source: branches/working-0711/ccl/lib/db-io.lisp @ 8554

Last change on this file since 8554 was 8554, checked in by mb, 13 years ago

Merge in mb-coverage-merge branch. No other changes.

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