source: trunk/source/lib/db-io.lisp @ 13067

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 69.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 2001 Clozure Associates
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; The "CDB" files used here are similar (but not identical) to those
19;;; used in the Unix CDB package <http://cr.yp.to/cdb.html>.  The primary
20;;; known & intentional differences are:
21;;;
22;;; a) key values, record positions, and other 32-bit metadata in the
23;;;    files are stored in native (vice little-endian) order.
24;;; b) hash values are always non-negative fixnums.
25;;;
26;;; I haven't thought of a compelling reason to attempt full compatibility.
27;;;
28;;; The basic idea is that the database files are created in a batch
29;;; process and are henceforth read-only (e.g., lookup is optimized by
30;;; making insertion & deletion impractical or impossible.)  That's
31;;; just about exactly what we want here.
32;;;
33;;; Those of you keeping score may notice that this is the third or forth
34;;; database format that Clozure CL has used for its interface database.
35;;; As always, this will hopefully be the last format change; the fact
36;;; that this code is self-contained (doesn't depend on any Unix database
37;;; library) should make it easier to port to other platforms.
38
39(in-package "CCL")
40
41(defparameter *interface-abi-version* 2)
42(defparameter *min-interface-abi-version* 1)
43
44(defconstant cdb-hash-mask (1- (ash 1 29)))
45
46(defun cdb-hash (buf len)
47  (declare (fixnum len))
48  (let* ((h 5381))
49    (declare (fixnum h))
50    (dotimes (i len (logand h cdb-hash-mask))
51      (setq h (+ h (the fixnum (logand cdb-hash-mask (ash h 5)))))
52      (setq h (logxor (the (unsigned-byte 8) (%get-unsigned-byte buf i)) h)))))
53
54(defconstant cdbm-hplist 1000)
55
56(defmacro hp-h (v n)
57  `(aref ,v (* ,n 2)))
58
59(defmacro hp-p (v n)
60  `(aref ,v (1+ (* ,n 2))))
61
62(defstruct cdbm-hplist
63  (hp (make-array (* 2 cdbm-hplist)
64                  :element-type '(unsigned-byte 32)
65                  :initial-element 0))
66  (next nil)
67  (num 0))
68
69
70
71
72
73#+openmcl
74(progn
75  ;;; Given a (possibly logical) PATHNAME, return a corresponding namestring
76  ;;; suitable for passing to an OS file-open call.
77  (defun cdb-native-namestring (pathname)
78    (native-translated-namestring pathname))
79 
80  ;;; Open the file specified by PATHNAME for output and return a
81  ;;; small integer "file id" (fid).
82  (defun fid-open-output (pathname)
83    (let ((dir (make-pathname :type nil :name nil :defaults pathname)))
84      (unless (probe-file dir)
85        (error "The directory ~S does not exist, cannot open/create ~S"
86               dir pathname)))
87    (let* ((id (fd-open (cdb-native-namestring pathname)
88                        (logior #$O_WRONLY #$O_CREAT #$O_TRUNC))))
89      (if (< id 0)
90        (%errno-disp id pathname)
91        id)))
92
93  ;;; Open the file specified by PATHNAME for input and return a
94  ;;; file id.
95  #-windows-target
96  (defun fid-open-input (pathname)
97    (let* ((id (fd-open (cdb-native-namestring pathname) #$O_RDONLY)))
98      (if (< id 0)
99        (%errno-disp id pathname)
100        id)))
101  ;; On Windows, open() can't open the same file twice, which breaks
102  ;; bootstrapping.  Use CreateFile instead, and tell it to share.
103  #+windows-target
104  (defun fid-open-input (pathname)
105    (with-filename-cstrs ((name (cdb-native-namestring pathname)))
106      (let* ((handle (#_CreateFileW
107                                   name
108                                   #$GENERIC_READ
109                                   #$FILE_SHARE_READ
110                                   (%null-ptr)
111                                   #$OPEN_EXISTING
112                                   #$FILE_ATTRIBUTE_NORMAL
113                                   (%null-ptr))))
114        (if (eql handle *windows-invalid-handle*)
115          (error "Error opening CDB database ~S" pathname)
116          (%ptr-to-int handle)))))
117
118  ;;; Read N octets from FID into BUF.  Return #of octets read or error.
119  (defun fid-read (fid buf n)
120    (let* ((count (fd-read fid buf n)))
121      (if (< count 0)
122        (%errno-disp count "reading from file")
123        count)))
124
125  ;;; Write N octets to FID from BUF.  Return #of octets written or error.
126  (defun fid-write (fid buf n)
127    (let* ((count (fd-write fid buf n)))
128      (if (< count 0)
129        (%errno-disp count "writing to file")
130        count)))
131
132  ;;; Return the absolute (octet) position of FID.
133  (defun fid-pos (fid)
134    (fd-tell fid))
135
136  ;;; Return the current size of the file referenced by FID, in
137  ;;; octets.
138  (defun fid-size (fid)
139    (fd-size fid))
140 
141  ;;; Seek to specified position (relative to file start.)
142  (defun fid-seek (fid pos)
143    (fd-lseek fid pos #$SEEK_SET))
144
145  ;;; Guess what this does ?
146  (defun fid-close (fid)
147    (fd-close fid))
148
149  ;;; Allocate a block of size N bytes (via malloc, #_NewPtr, etc.)
150  (defun cdb-alloc (n)
151    (malloc n))
152
153  ;;; Free a block allocated by cdb-alloc.
154  (defun cdb-free (block)
155    (free block))
156  )
157
158;;; I suppose that if we wanted to store these things in little-endian
159;;; order this'd be the place to swap bytes ...
160(defun fid-write-u32 (fid val)
161  (%stack-block ((valptr 4))
162    (setf (%get-unsigned-long valptr) val)
163    (fid-write fid valptr 4)
164    val))
165
166(defun fid-read-u32 (fid)
167  (%stack-block ((valptr 4))
168    (fid-read fid valptr 4)
169    (%get-unsigned-long valptr)))
170
171
172
173;;; Write N elements of a vector of type (UNSIGNED-BYTE 32) to file-id
174;;; FID, starting at element START.  The vector should be a simple
175;;; (non-displaced) array.
176(defun fid-write-u32-vector (fid v n start)
177  (let* ((remaining-octets (* n 4))
178         (start-octet (* start 4))
179         (bufsize 2048))
180    (%stack-block ((buf bufsize))
181      (do* ()
182           ((zerop remaining-octets))
183        (let* ((chunksize (min remaining-octets bufsize)))
184          (%copy-ivector-to-ptr v start-octet buf 0 chunksize)
185          (fid-write fid buf chunksize)
186          (incf start-octet chunksize)
187          (decf remaining-octets chunksize))))))
188
189(defstruct cdbx
190  fid                                   ;a small integer denoting a file
191  pathname)                             ;that file's pathname
192
193;;; A CDBM is used to create a database.
194(defstruct (cdbm (:include cdbx))
195  (final (make-array (* 256 2)
196                     :element-type '(unsigned-byte 32)
197                     :initial-element 0))
198  (count (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0))
199  (start (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0))
200  (head nil)
201  (split nil)
202  (hash nil)
203  (numentries 0)
204  )
205
206(defun cdbm-open (pathname)
207  (let* ((fid (fid-open-output pathname))
208         (cdbm (make-cdbm :fid fid :pathname pathname))
209         (final (cdbm-final cdbm)))
210    ;;; Write the (empty) final table to the start of the file.  Twice.
211    (fid-write-u32-vector fid final (length final) 0)
212    (fid-write-u32-vector fid final (length final) 0)
213    cdbm))
214
215;;; Note a newly-added <key,value> pair's file position and hash code.
216(defun %cdbm-add-hash-pos (cdbm hash pos)
217  (let* ((head (cdbm-head cdbm)))
218    (when (or (null head)
219              (>= (cdbm-hplist-num head) cdbm-hplist))
220      (setq head (make-cdbm-hplist))
221      (setf (cdbm-hplist-next head) (cdbm-head cdbm)
222            (cdbm-head cdbm) head))
223    (let* ((num (cdbm-hplist-num head))
224           (hp (cdbm-hplist-hp head)))
225      (setf (hp-h hp num) hash
226            (hp-p hp num) pos))
227    (incf (cdbm-hplist-num head))
228    (incf (cdbm-numentries cdbm))))
229
230(defun cdbm-put (cdbm key data)
231  (let* ((fid (cdbm-fid cdbm))
232         (pos (fid-pos fid))
233         (keylen (pref key :cdb-datum.size))
234         (keyptr (pref key :cdb-datum.data))
235         (datalen (pref data :cdb-datum.size))
236         (hash (cdb-hash keyptr keylen)))
237    (fid-write-u32 fid keylen)
238    (fid-write-u32 fid datalen)
239    (fid-write fid keyptr keylen)
240    (fid-write fid (pref data :cdb-datum.data) datalen)
241    (%cdbm-add-hash-pos cdbm hash pos)))
242
243(defun %cdbm-split (cdbm)
244  (let* ((count (cdbm-count cdbm))
245         (start (cdbm-start cdbm))
246         (numentries (cdbm-numentries cdbm)))
247    (dotimes (i 256) (setf (aref count i) 0))
248    (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x)))
249         ((null x))
250      (do* ((i (cdbm-hplist-num x))
251            (hp (cdbm-hplist-hp x)))
252           ((zerop i))
253        (decf i)
254        (incf (aref count (logand 255 (hp-h hp i))))))
255    (let* ((memsize 1))
256      (dotimes (i 256)
257        (let* ((u (* 2 (aref count i))))
258          (if (> u memsize)
259            (setq memsize u))))
260      (incf memsize numentries)
261      (let* ((split (make-array (the fixnum (* 2 memsize))
262                                :element-type '(unsigned-byte 32))))
263        (setf (cdbm-split cdbm) split)
264        (setf (cdbm-hash cdbm)
265              (make-array (- (* 2 memsize)
266                             (* 2 numentries))
267                          :element-type '(unsigned-byte 32)
268                          :displaced-to split
269                          :displaced-index-offset (* 2 numentries)))
270        (let* ((u 0))
271          (dotimes (i 256)
272            (incf u (aref count i))
273            (setf (aref start i) u)))
274
275        (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x)))
276             ((null x))
277          (do* ((i (cdbm-hplist-num x))
278                (hp (cdbm-hplist-hp x)))
279               ((zerop i))
280            (decf i)
281            (let* ((idx (decf (aref start (logand 255 (hp-h hp i))))))
282              (setf (hp-h split idx) (hp-h hp i)
283                    (hp-p split idx) (hp-p hp i)))))))))
284
285(defun %cdbm-throw (cdbm pos b)
286  (let* ((count (aref (cdbm-count cdbm) b))
287         (len (* 2 count))
288         (hash (cdbm-hash cdbm))
289         (split (cdbm-split cdbm)))
290    (let* ((final (cdbm-final cdbm)))
291      (setf (aref final (* 2 b)) pos
292            (aref final (1+ (* 2 b))) len))
293    (unless (zerop len)
294      (dotimes (j len)
295        (setf (hp-h hash j) 0
296              (hp-p hash j) 0))
297      (let* ((hpi (aref (cdbm-start cdbm) b)))
298        (dotimes (j count)
299          (let* ((where (mod (ash (hp-h split hpi) -8) len)))
300            (do* ()
301                 ((zerop (hp-p hash where)))
302              (incf where)
303              (if (= where len)
304                (setq where 0)))
305            (setf (hp-p hash where) (hp-p split hpi)
306                  (hp-h hash where) (hp-h split hpi)
307                  hpi (1+ hpi))))))
308    len))
309
310;;; Write data structures to the file, then close the file.
311(defun cdbm-close (cdbm)
312  (when (cdbm-fid cdbm)
313    (%cdbm-split cdbm)
314    (let* ((hash (cdbm-hash cdbm))
315           (fid (cdbm-fid cdbm))
316           (pos (fid-pos fid)))
317      (dotimes (i 256)
318        (let* ((len (%cdbm-throw cdbm pos i)))
319          (dotimes (u len)
320            (fid-write-u32 fid (hp-h hash u))
321            (fid-write-u32 fid (hp-p hash u))
322            (incf pos 8))))
323      (write-cdbm-trailer cdbm)
324      (fid-seek fid (* 256 2 4)) ; skip the empty "final" table, write the new one
325      (let* ((final (cdbm-final cdbm)))
326        (fid-write-u32-vector fid final (length final) 0))
327      (fid-close fid)
328      (setf (cdbm-fid cdbm) nil))))
329
330(defun write-cdbm-trailer (cdbm)
331  (let* ((string (format nil "~s ~s ~d " "OpenMCL Interface File" (backend-name *target-backend*) *interface-abi-version*)))
332    (%stack-block ((buf 512))
333      (%cstr-pointer string buf)
334      (fid-write (cdbm-fid cdbm) buf 512))))
335
336     
337;;; A CDB is used to access a database.
338(defstruct (cdb (:include cdbx))
339  (lock (make-lock)))
340
341     
342;;; Do the bytes on disk match KEY ?
343(defun %cdb-match (fid key keylen)
344  (%stack-block ((buf keylen))
345    (fid-read fid buf keylen)
346    (dotimes (i keylen t)
347      (unless (= (the fixnum (%get-unsigned-byte key i))
348                 (the fixnum (%get-unsigned-byte buf i)))
349        (return)))))
350
351;;; Seek to file position of data associated with key.  Return length
352;;; of data (or NIL if no matching key.)
353(defun %cdb-seek (fid key keylen)
354  (let* ((hash (cdb-hash key keylen)))
355    (fid-seek fid (+ (* 256 2 4) (* 8 (logand hash 255))))
356    (let* ((pos (fid-read-u32 fid))
357           (lenhash (fid-read-u32 fid)))
358      (unless (zerop lenhash)
359        (let* ((h2 (mod (ash hash -8) lenhash)))
360          (dotimes (i lenhash)
361            (fid-seek fid (+ pos (* 8 h2)))
362            (let* ((hashed-key (fid-read-u32 fid))
363                   (poskd (fid-read-u32 fid)))
364              (when (zerop poskd)
365                (return-from %cdb-seek nil))
366              (when (= hashed-key hash)
367                (fid-seek fid poskd)
368                (let* ((hashed-key-len (fid-read-u32 fid))
369                       (data-len (fid-read-u32 fid)))
370                  (when (= hashed-key-len keylen)
371                    (if (%cdb-match fid key keylen)
372                      (return-from %cdb-seek data-len)))))
373              (if (= (incf h2) lenhash)
374                (setq h2 0)))))))))
375
376;;; This should only be called with the cdb-lock of the containing cdb
377;;; held.
378(defun %cdb-get (fid key value)
379  (setf (pref value :cdb-datum.size) 0
380        (pref value :cdb-datum.data) (%null-ptr))
381  (when fid
382    (let* ((datalen (%cdb-seek fid
383                               (pref key :cdb-datum.data)
384                               (pref key :cdb-datum.size))))
385      (when datalen
386        (let* ((buf (cdb-alloc datalen)))
387          (fid-read fid buf datalen)
388          (setf (pref value :cdb-datum.size) datalen
389                (pref value :cdb-datum.data) buf)))
390      value)))
391
392(defun cdb-get (cdb key value)
393  (with-lock-grabbed ((cdb-lock cdb))
394    (%cdb-get (cdb-fid cdb) key value)))
395
396(defun cdb-subdirectory-path (&optional (ftd *target-ftd*))
397  (let* ((ftd-name (ftd-interface-db-directory ftd))
398         (ftd-dir (pathname-directory ftd-name)))
399    (assert (equalp (pathname-host ftd-name) "ccl"))
400    (assert (eq (car ftd-dir) :absolute))
401    (cdr ftd-dir)))
402
403(defvar *interfaces-root* "ccl:")
404
405(defun open-interface-db-pathname (name d)
406  (let* ((db-path (make-pathname :host (pathname-host *interfaces-root*)
407                                 :directory (append
408                                             (or (pathname-directory *interfaces-root*)
409                                                 '(:absolute))
410                                             (cdb-subdirectory-path *target-ftd*))))
411         (path (merge-pathnames name
412                                (merge-pathnames (interface-dir-subdir d) db-path))))
413    (cdb-open path)))
414
415(defun cdb-open (pathname)
416  (if (probe-file pathname)
417    (let* ((cdb (make-cdb :fid (fid-open-input (cdb-native-namestring pathname))
418                          :pathname (namestring pathname))))
419      (cdb-check-trailer cdb))
420    (progn
421      (if (probe-file (make-pathname :name nil :type nil :defaults pathname))
422        (warn "Interface file ~s does not exist." pathname)
423        (warn "Interface file ~s does not exist, and the containing directory does not exist.~%This may mean that that the \"ccl:\" logical-pathname host has not been properly initialized. " (translate-logical-pathname pathname)))
424      (make-cdb :fid nil :pathname (namestring pathname)))))
425
426(defun cdb-check-trailer (cdb)
427  (flet ((error-with-cdb (string &rest args)
428           (error "Error in interface file at ~s: ~a"
429                  (cdb-pathname cdb) (apply #'format nil string args))))
430    (let* ((fid (cdb-fid cdb)))
431      (fid-seek fid (- (fid-size fid) 512))
432      (%stack-block ((buf 512))
433        (fid-read fid buf 512)
434        (let* ((string (make-string 512)))
435          (dotimes (i 512)
436            (setf (%scharcode string i) (%get-unsigned-byte buf i)))
437          (with-input-from-string (s string)
438            (let* ((sig (ignore-errors (read s)))
439                   (target (ignore-errors (read s)))
440                   (version (ignore-errors (read s))))
441              (if (equal sig "OpenMCL Interface File")
442                (if (eq target (backend-name *target-backend*))
443                  (if (and version
444                           (>= version *min-interface-abi-version*)
445                           (<=  version *interface-abi-version*))
446                    cdb
447                    (error-with-cdb "Wrong interface ABI version. Expected ~d, got ~d" *interface-abi-version* version))
448                  cdb #+nil(error-with-cdb "Wrong target."))
449                (error-with-cdb "Missing interface file signature.  Obsolete version?")))))))))
450
451                 
452   
453(defun cdb-close (cdb)
454  (let* ((fid (cdb-fid cdb)))
455    (setf (cdb-fid cdb) nil)
456    (when fid
457      (fid-close fid))
458    t))
459
460(defmethod print-object ((cdb cdbx) stream)
461  (print-unreadable-object (cdb stream :type t :identity t)
462    (let* ((fid (cdb-fid cdb)))
463      (format stream "~s [~a]" (cdb-pathname cdb) (or fid "closed")))))
464
465
466(defun cdb-enumerate-keys (cdb &optional (predicate #'true))
467  "Returns a list of all keys (strings) in the open .cdb file CDB which
468satisfy the optional predicate PREDICATE."
469  (with-lock-grabbed ((cdb-lock cdb))
470    (let* ((keys ())
471           (fid (cdb-fid cdb)))
472      (dotimes (i 256 keys)
473        (fid-seek fid (+ (* 256 2 4) (* 8 i)))
474        (let* ((pos (fid-read-u32 fid))
475               (n (fid-read-u32 fid)))
476          (dotimes (j n)
477            (fid-seek fid (+ pos (* 8 j) 4))
478            (let* ((posk (fid-read-u32 fid)))
479              (unless (zerop posk)
480                (fid-seek fid posk)
481                (let* ((hashed-key-len (fid-read-u32 fid)))
482                  ;; Skip hashed data length
483                  (fid-read-u32 fid)
484                  (let* ((string (make-string hashed-key-len)))
485                    (%stack-block ((buf hashed-key-len))
486                      (fid-read fid buf hashed-key-len)
487                      (dotimes (k hashed-key-len)
488                        (setf (schar string k)
489                              (code-char (%get-unsigned-byte buf k)))))
490                    (when (funcall predicate string)
491                      (push (copy-seq string) keys))))))))))))
492                                        ;
493                 
494
495
496(defstruct ffi-type
497  (ordinal nil)
498  (defined nil)
499  (string)
500  (name)                                ; a keyword, uppercased or NIL
501)
502
503(defmethod print-object ((x ffi-type) out)
504  (print-unreadable-object (x out :type t :identity t)
505    (format out "~a" (ffi-type-string x))))
506
507(defvar *ffi-prefix* "")
508
509(defstruct (ffi-mem-block (:include ffi-type))
510  fields
511  (anon-global-id )
512  (alt-alignment-bits nil))
513
514(defstruct (ffi-union (:include ffi-mem-block)
515                      (:constructor
516                       make-ffi-union (&key
517                                       string name
518                                       &aux
519                                       (anon-global-id
520                                        (unless name
521                                          (concatenate 'string
522                                                       *ffi-prefix*
523                                                       "-" string)))))))
524
525
526(defstruct (ffi-transparent-union (:include ffi-mem-block)
527                                  (:constructor
528                                   make-ffi-transparent-union (&key
529                                                               string name
530                                                               &aux
531                                                               (anon-global-id
532                                                                (unless name
533                                                                  (concatenate 'string
534                                                                               *ffi-prefix*
535                                                                               "-" string)))))))
536(defstruct (ffi-struct (:include ffi-mem-block)
537                       (:constructor
538                       make-ffi-struct (&key
539                                       string name
540                                       &aux
541                                       (anon-global-id
542                                        (unless name
543                                          (concatenate 'string
544                                                       *ffi-prefix*
545                                                       "-" string)))))))
546
547(defstruct (ffi-typedef (:include ffi-type))
548  (type))
549
550(defstruct (ffi-objc-class (:include ffi-type))
551  super-foreign-name
552  protocol-names
553  own-ivars
554  )
555
556(defstruct (ffi-objc-method)
557  class-name
558  arglist
559  result-type
560  flags)
561
562(defstruct (ffi-objc-message (:include ffi-type))
563  methods)
564                           
565
566(defun ffi-struct-reference (s)
567  (or (ffi-struct-name s) (ffi-struct-anon-global-id s)))
568
569(defun ffi-union-reference (u)
570  (or (ffi-union-name u) (ffi-union-anon-global-id u)))
571
572(defun ffi-transparent-union-reference (u)
573  (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u)))
574
575(defstruct (ffi-function (:include ffi-type))
576  arglist
577  return-value)
578   
579
580(eval-when (:compile-toplevel :load-toplevel :execute)
581(defconstant db-string-constant 0)
582(defconstant db-read-string-constant 1)
583(defconstant db-s32-constant 2)
584(defconstant db-u32-constant 3)
585(defconstant db-float-constant 4)
586(defconstant db-double-constant 5)
587(defconstant db-char-constant 6)
588(defconstant db-pointer-constant 7)
589)
590
591(defparameter *arg-spec-encoding*
592  '((#\Space . :void)
593    (#\a . :address)
594    (#\F . :signed-fullword)
595    (#\f . :unsigned-fullword)
596    (#\H . :signed-halfword)
597    (#\h . :unsigned-halfword)
598    (#\B . :signed-byte)
599    (#\b . :unsigned-byte)
600    (#\s . :single-float)
601    (#\d . :double-float)
602    (#\L . :signed-doubleword)
603    (#\l . :unsigned-doubleword)
604    (#\r . :record)))
605
606
607
608(defun decode-arguments (string)
609  (let* ((result nil))
610    (collect ((args))
611      (do* ((i 0 (1+ i)))
612           ((= i (length string)) (values (args) result))
613        (declare (fixnum i))
614        (let* ((ch (schar string i))
615               (val (if (or (eql ch #\r) (eql ch #\u) (eql ch #\t))
616                      (let* ((namelen (char-code (schar string (incf i))))
617                             (name (make-string namelen)))
618                        (dotimes (k namelen)
619                          (setf (schar name k)
620                                (schar string (incf i))))
621                        (setq name (escape-foreign-name name))
622                        (if (eql ch #\r)
623                          `(:struct ,name)
624                          (if (eql ch #\u)
625                            `(:union ,name)
626                            (if (eql ch #\U)
627                              `(:transparent-union ,name)
628                              name))))
629                      (cdr (assoc ch *arg-spec-encoding*)))))
630          (if result
631            (args val)
632            (setq result val)))))))
633
634
635;;; encoded external function looks like:
636;;; byte min-args
637;;; byte name-length
638;;; name-length bytes of name
639;;; result+arg specs
640
641(defun extract-db-function (datum)
642  (let* ((val nil)
643         (dsize (pref datum :cdb-datum.size)))
644    (with-macptrs ((dptr))
645      (%setf-macptr dptr (pref datum :cdb-datum.data))
646      (unless (%null-ptr-p dptr)
647        (let* ((min-args (%get-byte dptr))
648               (name-len (%get-byte dptr 1))
649               (external-name (%str-from-ptr (%inc-ptr dptr 2) name-len))
650               (encoding-len (- dsize (+ 2 name-len)))
651               (encoding (make-string encoding-len)))
652          (declare (dynamic-extent encoding))
653          (%str-from-ptr (%inc-ptr dptr (+ 2 name-len)) encoding-len encoding)
654          (cdb-free (pref datum :cdb-datum.data))
655          (multiple-value-bind (args result)
656              (decode-arguments encoding)
657            (setq val (make-external-function-definition
658                       :entry-name external-name
659                       :arg-specs args
660                       :result-spec result
661                       :min-args min-args))))))
662    val))
663
664(defun db-lookup-function (cdb name)
665  (when cdb
666    (rletZ ((value :cdb-datum)
667            (key :cdb-datum))
668      (with-cstrs ((keyname (string name)))
669        (setf (pref key :cdb-datum.data) keyname
670              (pref key :cdb-datum.size) (length (string name))
671              (pref value :cdb-datum.data) (%null-ptr)
672              (pref value :cdb-datum.size) 0)
673        (cdb-get cdb key value)
674        (extract-db-function value)))))
675
676
677
678
679       
680(defun extract-db-constant-value (datum)
681  (let* ((val nil)
682         (dsize (pref datum :cdb-datum.size)))
683    (with-macptrs ((dptr))
684      (%setf-macptr dptr (pref datum :cdb-datum.data))
685      (unless (%null-ptr-p dptr)
686        (let* ((class (pref dptr :dbm-constant.class)))
687          (setq val
688                (ecase class
689                  ((#.db-string-constant #.db-read-string-constant)
690                   (let* ((str (%str-from-ptr (%inc-ptr dptr 4) (- dsize 4))))
691                     (if (eql class db-read-string-constant)
692                       (read-from-string str)
693                       str)))
694                  (#.db-s32-constant (pref dptr :dbm-constant.value.s32))
695                  (#.db-u32-constant (pref dptr :dbm-constant.value.u32))
696                  (#.db-float-constant (pref dptr :dbm-constant.value.single-float))
697                  (#.db-double-constant (pref dptr :dbm-constant.value.double-float))
698                  (#.db-char-constant (code-char (pref dptr :dbm-constant.value.u32)))
699                  (#.db-pointer-constant
700                   (let* ((val (pref dptr :dbm-constant.value.u32)))
701                     #+64-bit-target
702                     (if (logbitp 31 val)
703                       (setq val (logior val (ash #xffffffff 32))))
704                     (%int-to-ptr val )))))
705          (cdb-free (pref datum :cdb-datum.data)))))
706    val))
707
708
709
710(defun db-lookup-constant (cdb name)
711  (when cdb
712    (rletZ ((value :cdb-datum)
713            (key :cdb-datum))
714      (with-cstrs ((keyname (string name)))
715        (setf (pref key :cdb-datum.data) keyname
716              (pref key :cdb-datum.size) (length (string name))
717              (pref value :cdb-datum.data) (%null-ptr)
718              (pref value :cdb-datum.size) 0)
719        (cdb-get cdb key value)
720        (extract-db-constant-value value)))))
721   
722
723
724(defun db-define-string-constant (cdbm name val &optional (class db-string-constant))
725  (let* ((dsize (+ 4 (length val))))
726    (%stack-block ((valbuf dsize))
727      (dotimes (i (length val))
728        (setf (%get-unsigned-byte valbuf (the fixnum (+ 4 i)))
729              (%scharcode val i)))
730      (setf (%get-long valbuf) class)
731      (rletZ ((content :cdb-datum)
732              (key :cdb-datum))
733        (setf (pref content :cdb-datum.size) dsize
734              (pref content :cdb-datum.data) valbuf)
735        (with-cstrs ((keyname (string name)))
736          (setf (pref key :cdb-datum.size) (length (string name))
737                (pref key :cdb-datum.data) keyname)
738          (cdbm-put cdbm key content))))))
739     
740(defun db-define-constant (cdbm name val)
741  (typecase val
742    (string (db-define-string-constant cdbm name val))
743    ((or (unsigned-byte 32)
744         (signed-byte 32)
745         short-float
746         double-float
747         character
748         macptr)
749     (rletZ ((constant :dbm-constant)
750             (content :cdb-datum)
751             (key :cdb-datum))
752       (etypecase val
753         ((signed-byte 32)
754          (setf (pref constant :dbm-constant.value.s32) val)
755          (setf (pref constant :dbm-constant.class) db-s32-constant))
756         ((unsigned-byte 32)
757          (setf (pref constant :dbm-constant.value.u32) val)
758          (setf (pref constant :dbm-constant.class) db-u32-constant))
759         (short-float
760          (setf (pref constant :dbm-constant.value.single-float) val)
761          (setf (pref constant :dbm-constant.class) db-float-constant))
762         (double-float
763          (setf (pref constant :dbm-constant.value.double-float) val)
764          (setf (pref constant :dbm-constant.class) db-double-constant))
765         (character
766          (setf (pref constant :dbm-constant.value.u32) (char-code val))
767          (setf (pref constant :dbm-constant.class) db-char-constant))
768         (macptr
769          (setf (pref constant :dbm-constant.value.u32) (logand #xffffffff (%ptr-to-int val)))
770          (setf (pref constant :dbm-constant.class) db-pointer-constant))
771         )
772       (setf (pref content :cdb-datum.data) constant
773             (pref content :cdb-datum.size) (record-length :dbm-constant))
774       (with-cstrs ((keyname (string name)))
775         (setf (pref key :cdb-datum.data) keyname
776               (pref key :cdb-datum.size) (length (string name)))
777         (cdbm-put cdbm key content))))
778    (t (db-define-string-constant cdbm name (format nil "~a" val) db-read-string-constant))))
779
780
781 
782
783(defmacro with-new-db-file ((var pathname) &body body)
784  (let* ((db (gensym)))
785    `(let* (,db)
786      (unwind-protect
787           (let* ((,var (setq ,db (cdbm-open ,pathname))))
788             ,@body)
789        (when ,db (cdbm-close ,db))))))
790
791
792
793(defun interface-db-pathname (name d &optional (ftd *target-ftd*))
794  (merge-pathnames name
795                   (merge-pathnames (interface-dir-subdir d)
796                                    (ftd-interface-db-directory ftd))))
797
798(def-ccl-pointers reset-db-files ()
799  (do-interface-dirs (d)
800    (setf (interface-dir-constants-interface-db-file d) nil
801          (interface-dir-functions-interface-db-file d) nil
802          (interface-dir-records-interface-db-file d) nil
803          (interface-dir-types-interface-db-file d) nil
804          (interface-dir-vars-interface-db-file d) nil
805          (interface-dir-objc-classes-interface-db-file d) nil
806          (interface-dir-objc-methods-interface-db-file d) nil)))
807
808(defun db-constants (dir)
809  (or (interface-dir-constants-interface-db-file dir)
810      (setf (interface-dir-constants-interface-db-file dir)
811            (open-interface-db-pathname "constants.cdb" dir))))
812
813(defun db-objc-classes (dir)
814  (or (interface-dir-objc-classes-interface-db-file dir)
815      (setf (interface-dir-objc-classes-interface-db-file dir)
816            (open-interface-db-pathname "objc-classes.cdb" dir))))
817
818(defun db-objc-methods (dir)
819  (or (interface-dir-objc-methods-interface-db-file dir)
820      (setf (interface-dir-objc-methods-interface-db-file dir)
821            (open-interface-db-pathname "objc-methods.cdb" dir))))
822
823(defun db-vars (dir)
824  (or (interface-dir-vars-interface-db-file dir)
825      (setf (interface-dir-vars-interface-db-file dir)
826            (open-interface-db-pathname "vars.cdb" dir))))
827
828(defun db-types (dir)
829  (or (interface-dir-types-interface-db-file dir)
830      (setf (interface-dir-types-interface-db-file dir)
831            (open-interface-db-pathname "types.cdb" dir))))
832
833(defun db-records (dir)
834  (or (interface-dir-records-interface-db-file dir)
835      (setf (interface-dir-records-interface-db-file dir)
836            (open-interface-db-pathname "records.cdb" dir))))
837
838(defun db-functions (dir)
839  (or (interface-dir-functions-interface-db-file dir)
840      (setf (interface-dir-functions-interface-db-file dir)
841            (open-interface-db-pathname "functions.cdb" dir))))
842
843(defun load-os-constant (sym &optional query)
844  (let* ((val (do-interface-dirs (d)
845                    (let* ((v (db-lookup-constant (db-constants d) sym)))
846                      (when v (return v))))))
847    (if query
848      (not (null val))
849      (if val
850        (let* ((*record-source-file* nil))
851          (%defconstant sym val)
852          val)
853        (error "Constant not found: ~s" sym)))))
854
855(defun %load-var (name &optional query-only)
856  (let* ((ftd *target-ftd*)
857         (string (if (getf (ftd-attributes ftd)
858                           :prepend-underscores)
859                   (concatenate 'string "_" (string name))
860                   (string name)))
861         (fv (gethash string (fvs))))
862    (unless fv
863      (with-cstrs ((cstring string))
864        (let* ((type
865                (do-interface-dirs (d)
866                  (let* ((vars (db-vars d)))
867                    (when vars
868                      (rletZ ((value :cdb-datum)
869                              (key :cdb-datum))
870                        (setf (pref key :cdb-datum.data) cstring
871                              (pref key :cdb-datum.size) (length string)
872                              (pref value :cdb-datum.data) (%null-ptr)
873                              (pref value :cdb-datum.size) 0)
874                        (cdb-get vars key value)
875                        (let* ((vartype (extract-db-type value ftd)))
876                          (when vartype (return vartype)))))))))
877          (when type
878            (setq fv (%cons-foreign-variable string type))
879            (resolve-foreign-variable fv nil)
880            (setf (gethash string (fvs)) fv)))))
881    (if query-only
882      (not (null fv))
883      (or fv (error "Foreign variable ~s not found" string)))))
884
885
886(set-dispatch-macro-character 
887 #\# #\&
888 (qlfun |#&-reader| (stream char arg)
889   (declare (ignore char arg))
890   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
891     (multiple-value-bind (sym query source)
892         (%read-symbol-preserving-case
893          stream
894          package)
895       (unless *read-suppress*
896         (let* ((fv (%load-var sym query)))
897           (values (if query
898                     fv
899                     (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
900                                           (fv.type fv)
901                                           0
902                                           nil))
903                   source)))))))
904
905
906             
907
908(defstruct objc-message-info
909  message-name
910  methods                               ; all methods
911  ambiguous-methods                     ; partitioned by signature
912  req-args
913  flags
914  protocol-methods
915  lisp-name
916  selector)
917
918
919
920   
921(defstruct objc-method-info
922  message-info
923  class-name
924  class-pointer                         ;canonical, in some sense
925  arglist
926  result-type
927  flags
928  signature
929  signature-info
930  )
931
932
933
934(defmethod print-object ((m objc-method-info) stream)
935  (print-unreadable-object (m stream :type t :identity t)
936    (format stream "~c[~a ~a]"
937            (if (getf (objc-method-info-flags m) :class)
938              #\+
939              #\-)
940            (let* ((name (objc-method-info-class-name m)))
941              (if (getf (objc-method-info-flags m) :protocol)
942                (format nil "<~a>" name)
943                name))
944            (objc-message-info-message-name
945                          (objc-method-info-message-info m)))))
946
947(defun extract-db-objc-message-info (datum message-name info &optional
948                                           (ftd *target-ftd*))
949  (with-macptrs ((buf))
950    (%setf-macptr buf (pref datum :cdb-datum.data))
951    (unless (%null-ptr-p buf)
952      (unless info
953        (setq info
954              (make-objc-message-info
955               :message-name (string message-name))))
956      (let* ((p 0)
957             (nmethods 0)
958             (nargs 0))
959        (multiple-value-setq (nmethods p) (%decode-uint buf p))
960        (multiple-value-setq (nargs p) (%decode-uint buf p))
961        (dotimes (i nmethods)
962          (let* ((flag-byte (prog1 (%get-unsigned-byte buf p)
963                              (incf p)))
964                 (is-class-method (logbitp 0 flag-byte))
965                 (is-protocol-method (logbitp 1 flag-byte))
966                 (class-name ())
967                 (result-type ())
968                 (arg-types ())
969                 (arg-type ()))
970            (multiple-value-setq (class-name p) (%decode-name buf p t))
971            (multiple-value-setq (result-type p) (%decode-type buf p ftd t))
972            (dotimes (i nargs)
973              (multiple-value-setq (arg-type p) (%decode-type buf p ftd t))
974              (push arg-type arg-types))
975            (unless (dolist (m (objc-message-info-methods info))
976                      (when (and (eq (getf (objc-method-info-flags m) :class)  is-class-method)
977                                 (string= (objc-method-info-class-name m)
978                                          class-name))
979                        (return t)))
980              (let* ((flags ()))
981                (if is-class-method
982                  (setf (getf flags :class) t))
983                (if is-protocol-method
984                  (setf (getf flags :protocol) t))
985                (push (make-objc-method-info
986                                     :message-info info
987                                     :class-name class-name
988                                     :arglist (nreverse arg-types)
989                                     :result-type result-type
990                                     :flags flags)
991                 (objc-message-info-methods info))))))
992        (cdb-free (pref datum :cdb-datum.data))))
993    info))
994
995(defun db-note-objc-method-info (cdb message-name message-info)
996  (when cdb
997    (rletZ ((value :cdb-datum)
998            (key :cdb-datum))
999      (with-cstrs ((keyname (string message-name)))
1000        (setf (pref key :cdb-datum.data) keyname
1001              (pref key :cdb-datum.size) (length (string message-name))
1002              (pref value :cdb-datum.data) (%null-ptr)
1003              (pref value :cdb-datum.size) 0)
1004        (cdb-get cdb key value)
1005        (extract-db-objc-message-info value message-name message-info)))))
1006
1007(defun lookup-objc-message-info (message-name &optional message-info)
1008  (do-interface-dirs (d)
1009    (setq message-info
1010          (db-note-objc-method-info (db-objc-methods d) message-name message-info)))
1011  message-info)
1012
1013(defun %find-objc-class-info (name)
1014  (do-interface-dirs (d)
1015    (let* ((info (db-lookup-objc-class (db-objc-classes d) name)))
1016      (when info (return info)))))
1017
1018(defun load-external-function (sym query)
1019  (let* ((def (or (do-interface-dirs (d)
1020                    (let* ((f (db-lookup-function (db-functions d) sym)))
1021                      (when f (return f))))
1022                  (unless query
1023                    (error "Foreign function not found: ~s" sym)))))
1024    (if query
1025      (not (null def))
1026      (progn
1027        (setf (gethash sym (ftd-external-function-definitions
1028                            *target-ftd*)) def)
1029        (setf (macro-function sym) #'%external-call-expander)
1030        sym))))
1031
1032(defun %read-symbol-preserving-case (stream package)
1033  (let* ((case (readtable-case *readtable*))
1034         (query nil)
1035         (error nil)
1036         (sym nil)
1037         (source nil))
1038    (let* ((*package* package))
1039      (unwind-protect
1040           (progn
1041             (setf (readtable-case *readtable*) :preserve)
1042             (when (eq #\? (peek-char t stream nil nil))
1043               (setq query t)
1044               (read-char stream))
1045             (multiple-value-setq (sym source error)
1046               (handler-case (read-internal stream nil nil nil)
1047                 (error (condition) (values nil nil condition)))))
1048        (setf (readtable-case *readtable*) case)))
1049    (when error
1050      (error error))
1051    (values sym query source)))
1052
1053(set-dispatch-macro-character 
1054 #\# #\$
1055 (qlfun |#$-reader| (stream char arg)
1056        (declare (ignore char))
1057        (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
1058          (multiple-value-bind (sym query source)
1059              (%read-symbol-preserving-case
1060               stream
1061               package)
1062            (unless *read-suppress*
1063              (etypecase sym
1064                (symbol
1065                 (let* ((const (load-os-constant sym t)))
1066                   (if query
1067                     (values const source)
1068                     (progn
1069                       (if const
1070                         (progn
1071                           (when (eq (symbol-package sym) package)
1072                             (unless arg (setq arg 0))
1073                             (ecase arg
1074                               (0
1075                                (unless (and (constant-symbol-p sym)
1076                                             (not (eq (%sym-global-value sym)
1077                                                      (%unbound-marker-8))))
1078                                  (load-os-constant sym)))
1079                               (1 (makunbound sym) (load-os-constant sym))))
1080                           (values sym source))
1081                         (let* ((fv (%load-var sym nil)))
1082                           (values
1083                            (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
1084                                                  (fv.type fv)
1085                                                  0
1086                                                  nil)
1087                            source)))))))
1088                (string
1089                 (let* ((val 0)
1090                        (len (length sym)))
1091                   (dotimes (i 4 (values val source))
1092                     (let* ((ch (if (< i len) (char sym i) #\space)))
1093                       (setq val (logior (ash val 8) (char-code ch)))))))))))))
1094
1095(set-dispatch-macro-character #\# #\_
1096  (qlfun |#_-reader| (stream char arg)
1097    (declare (ignore char))
1098    (unless arg (setq arg 0))
1099    (multiple-value-bind (sym query source)
1100        (%read-symbol-preserving-case
1101                 stream
1102                 (find-package (ftd-interface-package-name *target-ftd*)))
1103      (unless *read-suppress*
1104        (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol))
1105        (if query
1106          (values (load-external-function sym t) source)
1107          (let* ((def (if (eql arg 0)
1108                        (gethash sym (ftd-external-function-definitions
1109                                      *target-ftd*)))))
1110            (values (if (and def (eq (macro-function sym) #'%external-call-expander))
1111                      sym
1112                      (load-external-function sym nil))
1113                    source)))))))
1114
1115(set-dispatch-macro-character
1116 #\# #\>
1117 (qlfun |#>-reader| (stream char arg)
1118    (declare (ignore char arg))
1119    (if *read-suppress*
1120      (progn
1121        (%read-list-expression stream nil)
1122        nil)
1123      (let* ((readtable *readtable*)
1124             (case (readtable-case readtable))
1125             (string nil)
1126             (error nil))
1127        (unwind-protect
1128             (progn
1129               (setf (readtable-case readtable) :preserve)
1130               (multiple-value-setq (string error)
1131                 (handler-case (read-symbol-token stream)
1132                   (error (condition) (values nil condition)))))
1133          (setf (readtable-case *readtable*) case))
1134        (when error
1135          (error error))
1136        (escape-foreign-name string)))))
1137             
1138
1139
1140
1141(eval-when (:compile-toplevel :execute)
1142  (defconstant encoded-type-void 0)
1143  (defconstant encoded-type-signed-32 1)
1144  (defconstant encoded-type-unsigned-32 2)
1145  (defconstant encoded-type-signed-8 3)
1146  (defconstant encoded-type-unsigned-8 4)
1147  (defconstant encoded-type-signed-16 5)
1148  (defconstant encoded-type-unsigned-16 6)
1149  (defconstant encoded-type-signed-n 7) ;N
1150  (defconstant encoded-type-unsigned-n 8) ;N
1151  (defconstant encoded-type-single-float 9)
1152  (defconstant encoded-type-double-float 10)
1153  (defconstant encoded-type-pointer 11) ; <type>
1154  (defconstant encoded-type-array 12) ; <size> <type>
1155  (defconstant encoded-type-named-struct-ref 13); <tag>
1156  (defconstant encoded-type-named-union-ref 14) ;<tag>
1157  (defconstant encoded-type-named-type-ref 15) ; <name>
1158  (defconstant encoded-type-anon-struct-ref 16) ; <tag>
1159  (defconstant encoded-type-anon-union-ref 17) ; <tag>
1160  (defconstant encoded-type-bitfield-marker 18) ; <nbits>
1161  (defconstant encoded-type-named-transparent-union-ref 19) ; <name>
1162  (defconstant encoded-type-anon-transparent-union-ref 20)  ;<tag>
1163  )
1164
1165
1166(defconstant encoded-type-type-byte (byte 5 0))
1167(defconstant encoded-type-align-byte (byte 3 5)
1168  "alignment in octets, if other than \"natural\" alignment,")
1169
1170;;; Constants & function names get saved verbatim.
1171;;; Record, type, and field names get escaped.
1172
1173(defun encode-name (name &optional verbatim)
1174  (if (null name)
1175    (list 0)
1176    (let* ((string
1177            (if (and (typep name 'keyword)
1178                     (not verbatim))
1179              (unescape-foreign-name name)
1180              (string name)))
1181           (length (length string)))
1182      (cons length (map 'list #'char-code string)))))
1183
1184(defun encode-ffi-field (field)
1185  (destructuring-bind (name type offset width) field
1186  `(,@(encode-name name)
1187    ,@(encode-ffi-type type)
1188    ,@(encode-uint offset)
1189    ,@(encode-uint width))))
1190
1191(defun encode-ffi-field-list (fields)
1192  (let* ((len (length fields)))
1193    (labels ((encode-fields (fields)
1194               (if fields
1195                 `(,@(encode-ffi-field (car fields)) ,@(encode-fields (cdr fields))))))
1196      `(,@(encode-uint len) ,@(encode-fields fields)))))
1197
1198(defun encode-ffi-union (u)
1199  (let* ((name (ffi-union-name u))
1200         (alt-align-in-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
1201                                      0)
1202                                  (- 5 3))))
1203    (if name
1204      `(,(logior encoded-type-named-union-ref alt-align-in-bytes-mask)
1205        ,@(encode-name name)
1206        ,@(encode-ffi-field-list (ffi-union-fields u)))
1207      `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask)
1208        ,@(encode-ffi-field-list (ffi-union-fields u))))))
1209
1210(defun encode-ffi-transparent-union (u)
1211  (let* ((name (ffi-transparent-union-name u))
1212         (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u)
1213                                           0)
1214                                       (- 5 3))))
1215    (if name
1216      `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask)
1217        ,@(encode-name name)
1218        ,@(encode-ffi-field-list (ffi-union-fields u)))
1219      `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask)
1220        ,@(encode-ffi-field-list (ffi-union-fields u))))))
1221
1222(defun encode-ffi-struct (s)
1223  (let* ((name (ffi-struct-name s))
1224         (alt-align-in-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s)
1225                                           0)
1226                                       (- 5 3))))
1227    (if name
1228      `(,(logior encoded-type-named-struct-ref alt-align-in-bytes-mask)
1229        ,@(encode-name (ffi-struct-name s))
1230        ,@(encode-ffi-field-list (ffi-struct-fields s)))
1231      `(,(logior encoded-type-anon-struct-ref alt-align-in-bytes-mask)
1232        ,@(encode-ffi-field-list (ffi-struct-fields s))))))
1233
1234(defun encode-ffi-objc-class (c)
1235  (let* ((protocols (ffi-objc-class-protocol-names c)))
1236    (labels ((encode-name-list (names)
1237               (if names
1238                 `(,@(encode-name (car names) t)
1239                   ,@(encode-name-list (cdr names))))))
1240      `(,@(encode-name (ffi-objc-class-string c))
1241        ,@(encode-name (ffi-objc-class-super-foreign-name c))
1242        ,@(encode-uint (length protocols))
1243        ,@(encode-name-list protocols)
1244        ,@(encode-ffi-field-list (ffi-objc-class-own-ivars c))))))
1245
1246
1247(defstruct db-objc-class-info
1248  class-name
1249  superclass-name
1250  protocols
1251  ivars
1252  instance-methods
1253  class-methods
1254  )
1255
1256(defun extract-db-objc-class (datum &optional (ftd *target-ftd*))
1257  (let* ((val nil))
1258    (with-macptrs ((buf))
1259      (%setf-macptr buf (pref datum :cdb-datum.data))
1260      (unless (%null-ptr-p buf)
1261        (let* ((p 0)
1262               (protocol-count 0)
1263               (class-name ())
1264               (superclass-name ())
1265               (protocol-name ())
1266               (ivars ()))
1267          (collect ((protocols))
1268            (multiple-value-setq (class-name p) (%decode-name buf p t))
1269            (multiple-value-setq (superclass-name p) (%decode-name buf p t))
1270            (multiple-value-setq (protocol-count p) (%decode-uint buf p))
1271            (dotimes (i protocol-count)
1272              (multiple-value-setq (protocol-name p) (%decode-name buf p t))
1273              (protocols protocol-name))
1274            (setq ivars (%decode-field-list buf p ftd))
1275            (cdb-free (pref datum :cdb-datum.data))
1276            (setq val (make-db-objc-class-info
1277                       :class-name class-name
1278                       :superclass-name superclass-name
1279                       :ivars ivars
1280                       :protocols (protocols)
1281                     ))))))
1282    val))
1283
1284(defun db-lookup-objc-class (cdb name)
1285  (when cdb
1286    (rletZ ((value :cdb-datum)
1287            (key :cdb-datum))
1288      (with-cstrs ((keyname (string name)))
1289        (setf (pref key :cdb-datum.data) keyname
1290              (pref key :cdb-datum.size) (length (string name))
1291              (pref value :cdb-datum.data) (%null-ptr)
1292              (pref value :cdb-datum.size) 0)
1293        (cdb-get cdb key value)
1294        (extract-db-objc-class value)))))
1295
1296(defun encode-u32 (val)
1297  `(,(ldb (byte 8 24) val)
1298    ,(ldb (byte 8 16) val)
1299    ,(ldb (byte 8 8) val)
1300    ,(ldb (byte 8 0) val)))
1301
1302(defun encode-uint (val)
1303  (collect ((bytes))
1304    (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val))
1305          (done nil))
1306         (done (bytes))
1307      (when (zerop (setq val (ash val -7)))
1308        (setq b (logior #x80 b) done t))
1309      (bytes b))))
1310
1311   
1312
1313(defun encode-ffi-type (spec)
1314  (case (car spec)
1315    (:primitive
1316     (let ((primtype (cadr spec)))
1317       (if (atom primtype)
1318         (case primtype
1319           (:float `(,encoded-type-single-float))
1320           (:double `(,encoded-type-double-float))
1321           (:void `(,encoded-type-void))
1322           (:signed `(,encoded-type-signed-32))
1323           (:unsigned `(,encoded-type-unsigned-32))
1324           ((:long-double :complex-int
1325                        :complex-float :complex-double :complex-long-double)
1326            (encode-ffi-type `(:struct ,primtype))))
1327         (ecase (car primtype)
1328           (* `(,encoded-type-pointer ,@(encode-ffi-type
1329                                           (if (eq (cadr primtype) t)
1330                                             `(:primitive :void)
1331                                             (cadr primtype)))))
1332           (:signed
1333            (case (cadr primtype)
1334              (32 `(,encoded-type-signed-32))
1335              (16 `(,encoded-type-signed-16))
1336              (8 `(,encoded-type-signed-8))
1337              (t `(,encoded-type-signed-n ,(cadr primtype)))))
1338           (:unsigned
1339            (case (cadr primtype)
1340              (32 `(,encoded-type-unsigned-32))
1341              (16 `(,encoded-type-unsigned-16))
1342              (8 `(,encoded-type-unsigned-8))
1343              (t `(,encoded-type-unsigned-n ,(cadr primtype)))))))))
1344     (:struct
1345      (let* ((s (cadr spec))
1346             (name (ffi-struct-name s))
1347             (alt-align-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s)
1348                                            0)
1349                                        (- 5 3))))
1350      `(,(if name
1351             (logior encoded-type-named-struct-ref alt-align-bytes-mask)
1352             (logior encoded-type-anon-struct-ref alt-align-bytes-mask))
1353        ,@(encode-name (ffi-struct-reference s)))))
1354     (:union
1355      (let* ((u (cadr spec))
1356             (name (ffi-union-name u))
1357             (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
1358                                            0)
1359                                        (- 5 3)))            )
1360      `(,(if name
1361             (logior encoded-type-named-union-ref alt-align-bytes-mask)
1362             (logior encoded-type-anon-union-ref alt-align-bytes-mask))
1363        ,@(encode-name (ffi-union-reference u)))))
1364     (:transparent-union
1365      (let* ((u (cadr spec))
1366             (name (ffi-transparent-union-name u))
1367             (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
1368                                            0)
1369                                        (- 5 3)))            )
1370      `(,(if name
1371             (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask)
1372             (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask))
1373        ,@(encode-name (ffi-transparent-union-reference u)))))
1374     (:typedef
1375      `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec)))))
1376     (:pointer
1377      `(,encoded-type-pointer ,@(encode-ffi-type
1378                                   (if (eq (cadr spec) t)
1379                                     '(:primitive :void)
1380                                     (cadr spec)))))
1381     (:array
1382      `(,encoded-type-array ,@(encode-uint (cadr spec)) ,@(encode-ffi-type (caddr spec))))
1383     (t
1384      (break "Type spec = ~s" spec))))
1385
1386(defun encode-ffi-arg-type (spec)
1387  (case (car spec)
1388    (:primitive
1389     (let ((primtype (cadr spec)))
1390       (if (atom primtype)
1391         (case primtype
1392           (:float `(#\s))
1393           (:double `(#\d))
1394           (:void `(#\Space))
1395           (:signed `(#\F))
1396           (:unsigned `(f))
1397           ((:long-double :complex-int
1398                          :complex-float :complex-double :complex-long-double)           
1399            #|(encode-ffi-arg-type `(:struct ,primtype))|#
1400            `(#\?)))
1401         (ecase (car primtype)
1402           (* `(#\a))
1403           (:signed
1404            (let* ((nbits (cadr primtype)))
1405              (if (<= nbits 8)
1406                '(#\B)
1407                (if (<= nbits 16)
1408                  '(#\H)
1409                  (if (<= nbits 32)
1410                    '(#\F)
1411                    (if (<= nbits 64)
1412                      `(#\L)
1413                      '(#\?)))))))
1414           (:unsigned
1415            (let* ((nbits (cadr primtype)))
1416              (if (<= nbits 8)
1417                '(#\b)
1418                (if (<= nbits 16)
1419                  '(#\h)
1420                  (if (<= nbits 32)
1421                    '(#\f)
1422                    (if (<= nbits 64)
1423                      `(#\l)
1424                      '(#\?)))))))))))
1425    ((:struct :union :transparent-union)
1426     `(,(ecase (car spec)
1427          (:struct #\r)
1428          (:union #\u)
1429          (:transparent-union #\U))
1430           ,@(encode-name (ffi-struct-reference (cadr spec)))))
1431    (:typedef
1432     `(#\t ,@(encode-name (ffi-typedef-name (cadr spec)))))
1433    (:pointer
1434      `(#\a))
1435    (:array
1436      `(#\?))))
1437
1438(defun encode-ffi-arg-list (args)
1439  (if args
1440    `(,@(encode-ffi-arg-type (car args)) ,@(encode-ffi-arg-list (cdr args)))))
1441
1442(defvar *prepend-underscores-to-ffi-function-names* nil)
1443
1444(defun encode-ffi-function (f)
1445  (let* ((args (ffi-function-arglist f))
1446         (string (ffi-function-string f))
1447         (name (if *prepend-underscores-to-ffi-function-names*
1448                 (concatenate 'string "_" string)
1449                 string))
1450         (min-args (length args))
1451         (result (ffi-function-return-value f)))
1452    `(,min-args
1453      ,@(encode-name name t)            ; verbatim
1454      ,@(encode-ffi-arg-type result)
1455      ,@(encode-ffi-arg-list args))))
1456
1457(defun encode-ffi-objc-method (m)
1458  (let* ((flag-byte (logior (if (getf (ffi-objc-method-flags m) :class) 1 0)
1459                            (if (getf (ffi-objc-method-flags m) :protocol) 2 0))))
1460  `(,flag-byte
1461    ,@(encode-name (ffi-objc-method-class-name m) t)
1462    ,@(encode-ffi-type (ffi-objc-method-result-type m))
1463    ,@(apply #'append (mapcar #'encode-ffi-type (ffi-objc-method-arglist m))))))
1464
1465(defun save-ffi-objc-message (cdbm message)
1466  (let* ((methods (ffi-objc-message-methods message))
1467         (nmethods (length methods))
1468         (nargs (length (ffi-objc-method-arglist (car methods)))))
1469    (labels ((encode-objc-method-list (ml)
1470               (when ml
1471                 `(,@(encode-ffi-objc-method (car ml))
1472                   ,@(encode-objc-method-list (cdr ml))))))
1473      (db-write-byte-list cdbm
1474                          (ffi-objc-message-string message)
1475                          `(,@(encode-uint nmethods)
1476                            ,@(encode-uint nargs)
1477                            ,@(encode-objc-method-list methods))
1478                          t))))
1479 
1480   
1481(defun save-byte-list (ptr l)
1482  (do* ((l l (cdr l))
1483        (i 0 (1+ i)))
1484       ((null l))
1485    (let* ((b (car l)))
1486      (if (typep b 'character)
1487        (setq b (char-code b)))
1488      (setf (%get-unsigned-byte ptr i) b))))
1489
1490(defun db-write-byte-list (cdbm keyname bytes &optional verbatim)
1491  (let* ((len (length bytes)))
1492    (%stack-block ((p len))
1493      (save-byte-list p bytes)
1494      (rletZ ((contents :cdb-datum)
1495              (key :cdb-datum))
1496        (let* ((foreign-name
1497                (if verbatim
1498                  keyname
1499                  (unescape-foreign-name keyname))))
1500          (with-cstrs ((keystring foreign-name))
1501            (setf (pref contents :cdb-datum.data) p
1502                  (pref contents :cdb-datum.size) len
1503                  (pref key :cdb-datum.data) keystring
1504                  (pref key :cdb-datum.size) (length foreign-name))
1505            (cdbm-put cdbm key contents)))))))
1506
1507(defun save-ffi-function (cdbm fun)
1508  (let* ((encoding (encode-ffi-function fun)))
1509    (db-write-byte-list cdbm
1510                        (ffi-function-string fun)
1511                        encoding
1512                        t)))
1513
1514(defun save-ffi-typedef (cdbm def)
1515  (db-write-byte-list cdbm
1516                       (ffi-typedef-string def)
1517                       (encode-ffi-type (ffi-typedef-type def))
1518                       t))
1519
1520(defun save-ffi-struct (cdbm s)
1521  (db-write-byte-list cdbm (ffi-struct-reference s) (encode-ffi-struct s)))
1522
1523(defun save-ffi-union (cdbm u)
1524  (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u)))
1525
1526(defun save-ffi-transparent-union (cdbm u)
1527  (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u)))
1528
1529
1530(defun db-define-var (cdbm name type)
1531  (db-write-byte-list cdbm
1532                      (if *prepend-underscores-to-ffi-function-names*
1533                        (concatenate 'string "_" name)
1534                        name)
1535  (encode-ffi-type type) t))
1536
1537(defun save-ffi-objc-class (cdbm c)
1538  (db-write-byte-list cdbm (ffi-objc-class-name c) (encode-ffi-objc-class c)))
1539
1540
1541;;; An "uppercase-sequence" is a maximal substring of a string that
1542;;; starts with an uppercase character and doesn't contain any
1543;;; lowercase characters.
1544(defun count-uppercase-sequences (string)
1545  (let* ((state :lower)
1546         (nupper 0))
1547    (declare (fixnum nupper))
1548    (dotimes (i (length string) nupper)
1549      (let* ((ch (char string i)))
1550        (case state
1551          (:lower 
1552           (when (upper-case-p ch)
1553             (incf nupper)
1554             (setq state :upper)))
1555          (:upper
1556           (unless (upper-case-p ch)
1557             (setq state :lower))))))))
1558
1559(defun escape-foreign-name (in &optional
1560                               (count (count-uppercase-sequences in)))
1561  (intern
1562   (if (zerop count)
1563     (string-upcase in)
1564     (let* ((len (length in))
1565            (j 0)
1566            (out (make-string (+ len (* 2 count))))
1567            (state :lower))
1568       (flet ((outch (ch)
1569                (setf (schar out j) ch)
1570                (incf j)
1571                ch))
1572         (dotimes (i len (progn (if (eq state :upper) (outch #\>)) out))
1573           (let* ((ch (char in i)))
1574             (cond ((and (upper-case-p ch) (eq state :lower))
1575                    (outch #\<)
1576                    (setq state :upper))
1577                   ((and (not (upper-case-p ch)) (eq state :upper))
1578                    (outch #\>)
1579                    (setq state :lower)))
1580             (outch (char-upcase ch)))))))
1581   *keyword-package*))
1582
1583(defun unescape-foreign-name (key)
1584  (let* ((string (if (typep key 'symbol)
1585                   (string-downcase key)
1586                   (string key)))
1587         (nleftbrackets (count #\< string))
1588         (nrightbrackets (count #\> string))
1589         (nbrackets (+ nleftbrackets nrightbrackets)))
1590    (declare (fixnum nleftbrackets nrightbrackets nbrackets))
1591    (if (zerop nbrackets)
1592      string
1593      (if (/= nleftbrackets nrightbrackets)
1594        (error "Mismatched brackets in ~s." key)
1595        (let* ((len (length string))
1596               (out (make-string (- len nbrackets)))
1597               (j 0)
1598               (state :lower))
1599          (dotimes (i len out)
1600            (let* ((ch (schar string i)))
1601              (if (or (and (eq ch #\<)
1602                           (eq state :upper))
1603                      (and (eq ch #\>)
1604                           (eq state :lower)))
1605                (error "Mismatched brackets in ~s." key))
1606              (case ch
1607                (#\< (setq state :upper))
1608                (#\> (setq state :lower))
1609                (t (setf (schar out j) (if (eq state :upper)
1610                                         (char-upcase ch)
1611                                         (char-downcase ch))
1612                         j (1+ j)))))))))))
1613
1614       
1615       
1616(defun %decode-name (buf p &optional verbatim)
1617  (declare (type macptr buf) (fixnum p))
1618  (let* ((n (%get-unsigned-byte buf p)))
1619    (declare (fixnum n))
1620    (if (zerop n)
1621      (values nil (1+ p))
1622      (let* ((pname (%str-from-ptr (%inc-ptr buf (1+ p)) n)))
1623        (values (if verbatim pname (escape-foreign-name pname))
1624                (+ p (1+ n)))))))
1625
1626(defun %decode-u32 (buf p)
1627  (declare (fixnum p) (type macptr buf))
1628  (values (dpb
1629           (%get-unsigned-byte buf p)
1630           (byte 8 24)
1631           (dpb
1632            (%get-unsigned-byte buf (+ p 1))
1633            (byte 8 16)
1634            (dpb
1635             (%get-unsigned-byte buf (+ p 2))
1636             (byte 8 8)
1637             (%get-unsigned-byte buf (+ p 3)))))
1638          (+ p 4)))
1639
1640(defun %decode-uint (buf p)
1641  (do* ((val 0)
1642        (p p (1+ p))
1643        (shift 0 (+ shift 7))
1644        (done nil))
1645       (done (values val p))
1646    (let* ((b (%get-unsigned-byte buf p)))
1647      (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift))))))
1648       
1649 
1650;; Should return a FOREIGN-TYPE structure (except if suppress-typedef-expansion is true, may
1651;; return a symbol for encoded-type-named-type-ref)
1652(defun %decode-type (buf p ftd &optional suppress-typedef-expansion)
1653  (declare (type macptr buf) (fixnum p))
1654  (let* ((q (1+ p)))
1655    (ecase (ldb encoded-type-type-byte (%get-unsigned-byte buf p))
1656      (#.encoded-type-void (values (parse-foreign-type :void) q))
1657      (#.encoded-type-signed-32 (values (svref *signed-integer-types* 32) q))
1658      (#.encoded-type-unsigned-32 (values (svref *unsigned-integer-types* 32) q))
1659      (#.encoded-type-signed-8 (values (svref *signed-integer-types* 8) q))
1660      (#.encoded-type-unsigned-8 (values (svref *unsigned-integer-types* 8) q))
1661      (#.encoded-type-signed-16 (values (svref *signed-integer-types* 16) q))
1662      (#.encoded-type-unsigned-16 (values (svref *unsigned-integer-types* 16) q))
1663      (#.encoded-type-signed-n (values (let* ((bits (%get-unsigned-byte buf q)))
1664                                         (if (<= bits 32)
1665                                           (svref *signed-integer-types* bits)
1666                                           (make-foreign-integer-type
1667                                            :signed t
1668                                            :bits bits)))
1669                                         (1+ q)))
1670      (#.encoded-type-unsigned-n (values (let* ((bits (%get-unsigned-byte buf q)))
1671                                         (if (<= bits 32)
1672                                           (svref *unsigned-integer-types* bits)
1673                                           (make-foreign-integer-type
1674                                            :signed nil
1675                                            :bits bits)))
1676                                           (1+ q)))
1677      (#.encoded-type-single-float (values (parse-foreign-type :float) q))
1678      (#.encoded-type-double-float (values (parse-foreign-type :double) q))
1679      (#.encoded-type-pointer (multiple-value-bind (target qq)
1680                                  (%decode-type buf q ftd suppress-typedef-expansion)
1681                                (values (make-foreign-pointer-type
1682                                         :to target
1683                                         :bits (getf (ftd-attributes ftd)
1684                                                     :bits-per-word)
1685                                         )
1686                                          qq)))
1687      (#.encoded-type-array
1688       (multiple-value-bind (size qq) (%decode-uint buf q)
1689         (multiple-value-bind (target qqq) (%decode-type buf qq ftd)
1690           (let* ((type-alignment (foreign-type-alignment target))
1691                  (type-bits (foreign-type-bits target)))
1692             (values (make-foreign-array-type
1693                      :element-type target
1694                      :dimensions (list size)
1695                      :alignment type-alignment
1696                      :bits (if type-bits
1697                              (* (align-offset type-bits type-alignment) size)))
1698                     qqq)))))
1699      (#.encoded-type-named-type-ref
1700       (multiple-value-bind (name qq) (%decode-name buf q)         
1701         (values (if suppress-typedef-expansion
1702                   name
1703                   (%parse-foreign-type name))
1704                 qq)))
1705      (#.encoded-type-named-struct-ref
1706       (multiple-value-bind (name qq) (%decode-name buf q)
1707         (values (or (info-foreign-type-struct name)
1708                     (setf (info-foreign-type-struct name)
1709                           (make-foreign-record-type :kind :struct
1710                                                     :name name)))
1711                 qq)))
1712      (#.encoded-type-named-union-ref
1713       (multiple-value-bind (name qq) (%decode-name buf q)
1714         (values (or (info-foreign-type-union name)
1715                     (setf (info-foreign-type-union name)
1716                           (make-foreign-record-type :kind :union
1717                                                     :name name)))
1718                 qq)))
1719      (#.encoded-type-named-transparent-union-ref
1720       (multiple-value-bind (name qq) (%decode-name buf q)
1721         (let* ((already (info-foreign-type-union name)))
1722           (when already
1723             (setf (foreign-record-type-kind already) :transparent-union))
1724           (values (or already
1725                     (setf (info-foreign-type-union name)
1726                           (make-foreign-record-type :kind :transparent-union
1727                                                     :name name)))
1728                 qq))))
1729      ((#.encoded-type-anon-struct-ref
1730        #.encoded-type-anon-union-ref
1731        #.encoded-type-anon-transparent-union-ref)
1732       (multiple-value-bind (tag qq) (%decode-name buf q t)
1733         (values (load-record tag) qq))))))
1734
1735(defun extract-db-type (datum ftd)
1736  (let* ((data (pref datum :cdb-datum.data)))
1737    (unless (%null-ptr-p data)
1738      (prog1
1739          (%decode-type data 0 ftd)
1740        (cdb-free data)))))
1741
1742(defun %load-foreign-type (cdb name ftd)
1743  (when cdb
1744    (with-cstrs ((string (string name)))
1745      (rletZ ((contents :cdb-datum)
1746              (key :cdb-datum))
1747        (setf (pref key :cdb-datum.size) (length (string name))
1748            (pref key :cdb-datum.data) string
1749            (pref contents :cdb-datum.data) (%null-ptr)
1750            (pref contents :cdb-datum.size) 0)
1751      (cdb-get cdb key contents)
1752      (let* ((type (extract-db-type contents ftd)))
1753        (if type
1754          (%def-foreign-type (escape-foreign-name name) type ftd)))))))
1755
1756(defun load-foreign-type (name &optional (ftd *target-ftd*))
1757  (let* ((name (unescape-foreign-name name)))
1758    (do-interface-dirs (d ftd)
1759      (let* ((type (%load-foreign-type (db-types d) name ftd)))
1760        (when type (return type))))))
1761
1762(defun %decode-field (buf p ftd)
1763  (declare (type macptr buf) (fixnum p))
1764  (multiple-value-bind (name p) (%decode-name buf p)
1765    (multiple-value-bind (type p) (%decode-type buf p ftd)
1766      (multiple-value-bind (offset p) (%decode-uint buf p)
1767        (multiple-value-bind (width p) (%decode-uint buf p)
1768          (values (make-foreign-record-field :type type
1769                                             :name name
1770                                             :bits width
1771                                             :offset offset)
1772                  p))))))
1773
1774(defun %decode-field-list (buf p ftd)
1775  (declare (type macptr buf) (fixnum p))
1776  (let* ((n nil)
1777         (fields nil))
1778    (multiple-value-setq (n p) (%decode-uint buf p))
1779    (dotimes (i n (values (nreverse fields) p))
1780      (multiple-value-bind (field q) (%decode-field buf p ftd)
1781        (push field fields)
1782        (setq p q)))))
1783
1784(defun %determine-record-attributes (rtype parsed-fields &optional alt-align)
1785  (let* ((total-bits 0)
1786         (overall-alignment 1)
1787         #+(and darwinppc-target ppc32-target)
1788         (first-field-p t)
1789         (kind (foreign-record-type-kind rtype)))
1790    (dolist (field parsed-fields)
1791      (let* ((field-type (foreign-record-field-type field))
1792             (bits (ensure-foreign-type-bits field-type))
1793             (natural-alignment (foreign-type-alignment field-type))
1794             (alignment (if alt-align
1795                          (min natural-alignment alt-align)
1796                          #+(and darwinppc-target ppc32-target)
1797                          (if first-field-p
1798                            (progn
1799                              (setq first-field-p nil)
1800                              natural-alignment)
1801                            (min 32 natural-alignment))
1802                          #-(and darwinppc-target ppc32-target)
1803                          natural-alignment)))
1804        (unless bits
1805          (error "Unknown size: ~S"
1806                 (unparse-foreign-type field-type)))
1807        (unless alignment
1808          (error "Unknown alignment: ~S"
1809                 (unparse-foreign-type field-type)))
1810        (setq overall-alignment (max overall-alignment (if (= alignment 1) 32 alignment)))
1811        (ecase kind
1812          (:struct (let* ((imported-offset (foreign-record-field-offset field))
1813                          (offset (or imported-offset (align-offset total-bits alignment))))
1814                     (unless imported-offset
1815                       (setf (foreign-record-field-offset field) offset))
1816                     (setq total-bits (+ offset bits))))
1817          ((:union :transparent-union) (setq total-bits (max total-bits bits))))))
1818    (setf (foreign-record-type-fields rtype) parsed-fields
1819          (foreign-record-type-alignment rtype) (or
1820                                                 alt-align
1821                                                 overall-alignment)
1822          (foreign-record-type-bits rtype) (align-offset
1823                                            total-bits
1824                                            (or alt-align overall-alignment))
1825          (foreign-record-type-alt-align rtype) alt-align)
1826    rtype))
1827
1828(defun %decode-record-type (buf p ftd already)
1829  (declare (type macptr buf) (fixnum p))
1830  (let* ((rbyte (%get-unsigned-byte buf p))
1831         (rcode (ldb encoded-type-type-byte rbyte))
1832         (ralign-in-bytes (ldb encoded-type-align-byte rbyte))
1833         (alt-align (unless (zerop ralign-in-bytes)
1834                      (the fixnum (ash ralign-in-bytes 3)))))
1835    (declare (fixnum rbyte rcode ralign-in-bytes))
1836    (multiple-value-bind (name q)
1837        (case rcode
1838          ((#.encoded-type-anon-struct-ref
1839            #.encoded-type-anon-union-ref
1840            #.encoded-type-anon-transparent-union-ref)
1841           (values nil (1+ p)))
1842          (t
1843           (%decode-name buf (1+ p))))
1844      (%determine-record-attributes
1845       (or already
1846           (if name
1847             (if (eql rcode encoded-type-named-struct-ref)
1848               (or (info-foreign-type-struct name)
1849                   (setf (info-foreign-type-struct name)
1850                         (make-foreign-record-type :kind :struct :name name)))
1851               (or (info-foreign-type-union name)
1852                   (setf (info-foreign-type-union name)
1853                         (make-foreign-record-type :kind
1854                                                   (if (eql rcode encoded-type-named-union-ref)
1855                                                     :union
1856                                                     :transparent-union)
1857                                                   :name name))))
1858             (make-foreign-record-type
1859              :kind (if (eql rcode encoded-type-anon-struct-ref)
1860                      :struct
1861                      (if (eql rcode encoded-type-anon-union-ref)
1862                        :union
1863                        :transparent-union))
1864              :name name)))
1865       (%decode-field-list buf q ftd)
1866       alt-align))))
1867
1868(defun extract-db-record (datum ftd already)
1869  (let* ((data (pref datum :cdb-datum.data)))
1870    (unless (%null-ptr-p data)
1871      (prog1
1872          (%decode-record-type data 0 ftd already)
1873        (cdb-free data)))))
1874
1875
1876(defun %load-foreign-record (cdb name ftd already)
1877  (when cdb
1878    (with-cstrs ((string (string name)))
1879      (rlet ((contents :cdb-datum)
1880             (key :cdb-datum))
1881        (setf (pref key :cdb-datum.size) (length (string name))
1882              (pref key :cdb-datum.data) string
1883              (pref contents :cdb-datum.data) (%null-ptr)
1884              (pref contents :cdb-datum.size) 0)
1885        (cdb-get cdb key contents)
1886        (extract-db-record contents ftd already)))))
1887
1888(defun load-record (name &optional (ftd *target-ftd*))
1889  ;; Try to destructively modify any info we already have.  Use the
1890  ;; "escaped" name (keyword) for the lookup here.
1891  (let* ((already (or (info-foreign-type-struct name ftd)
1892                      (info-foreign-type-union name ftd)))
1893         (name (unescape-foreign-name name)))
1894    (do-interface-dirs (d ftd)
1895      (let* ((r (%load-foreign-record (db-records d) name ftd already)))
1896        (when r (return r))))))
1897
1898
Note: See TracBrowser for help on using the repository browser.