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

Last change on this file since 11129 was 11129, checked in by gz, 12 years ago

More changes in support of read-recording-source (which is still not used anywhere, but will be)

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