source: trunk/source/library/parse-ffi.lisp @ 11470

Last change on this file since 11470 was 11470, checked in by gb, 12 years ago

We really want definitions of functions that return structure types
to be explicit about that; at this level, we can't just translate
those functions into things that accepts a pointer argument and
returns NIL, since that loses information.

There was a variable - *FFI-EXPLICIT-STRUCT-RETURN* - that controlled
whether this happened or not; when it was true, the translator printed
infomation about functions that returned structures, and when it was
false, the return type was set to :VOID and an extra pointer arg was
added. Possibly to avoid printing that cryptic-looking info, the
variable was erroneously set false at some point in the past.

(At a higher level, functions that return structures do need to accept
a pointer to a structure as their fist argument, but how that pointer's
used depends on the ABI.)

In any case. botching this means that the interfaces that we've been
using for the last year or two (whenever this change was made) are
missing struct return info for foreign functions (though it's present
for ObjC methods), so we'll need new interfaces for most platforms.
(Darwin makes heaviest use of struct return.)

Here, don't think that making struct return explicit is optional.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 65.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(in-package "CCL")
18
19(defvar *parse-ffi-target-ftd* *target-ftd*)
20(defvar *ffi-lisp-readtable* (copy-readtable nil))
21(defvar *ffi-ordinal* -1)
22(defpackage "C" (:use))
23(defvar *lparen-symbol* (intern "(" (find-package "C")))
24(defvar *rparen-symbol* (intern ")" (find-package "C")))
25(defvar *leftbracket-symbol* (intern "[" (find-package "C")))
26(defvar *rightbracket-symbol* (intern "]" (find-package "C")))
27(defvar *sharp-symbol* (intern "#" (find-package "C")))
28(defvar *sharp-sharp-symbol* (intern "##" (find-package "C")))
29(defvar *comma-symbol* (intern "," (find-package "C")))
30
31
32(defstruct (ffi-macro (:include ffi-type))
33  args
34  expansion
35  disposition
36  tokens
37  expression )
38
39(defstruct (ffi-enum (:include ffi-type)))
40
41(defvar *ffi-typedefs*)
42(defvar *ffi-global-typedefs* nil)
43(defvar *ffi-unions*)
44(defvar *ffi-global-unions* nil)
45(defvar *ffi-transparent-unions* nil)
46(defvar *ffi-global-transparent-unions* nil)
47(defvar *ffi-structs*)
48(defvar *ffi-global-structs* nil)
49(defvar *ffi-functions*)
50(defvar *ffi-global-functions* nil)
51(defvar *ffi-global-constants* nil)
52(defvar *ffi-global-vars* nil)
53(defvar *ffi-objc-classes* nil)
54(defvar *ffi-global-objc-classes* nil)
55(defvar *ffi-global-objc-messages* nil)
56(defvar *ffi-macros*)
57(defvar *ffi-vars*)
58
59(defvar *ffi-void-reference* '(:primitive :void))
60
61
62
63(defun find-or-create-ffi-struct (string)
64  (or (gethash string *ffi-structs*)
65      (setf (gethash string *ffi-structs*)
66            (make-ffi-struct :string string
67                             :name (unless (digit-char-p (schar string 0))
68                                     (escape-foreign-name string))))))
69
70(defun find-or-create-ffi-union (string)
71  (or (gethash string *ffi-unions*)
72      (setf (gethash string *ffi-unions*)
73            (make-ffi-union :string string
74                            :name (unless (digit-char-p (schar string 0))
75                                    (escape-foreign-name string))))))
76
77(defun find-or-create-ffi-transparent-union (string)
78  (or (gethash string *ffi-transparent-unions*)
79      (setf (gethash string *ffi-transparent-unions*)
80            (make-ffi-transparent-union :string string
81                                        :name (unless (digit-char-p (schar string 0))
82                                                (escape-foreign-name string))))))
83
84(defun find-or-create-ffi-objc-class (string)
85  (or (gethash string *ffi-objc-classes*)
86      (setf (gethash string *ffi-objc-classes*)
87            (make-ffi-objc-class :string string
88                                 :name (escape-foreign-name string)))))
89
90(defun find-or-create-ffi-objc-message (string)
91  (or (gethash string *ffi-global-objc-messages*)
92      (setf (gethash string *ffi-global-objc-messages*)
93            (make-ffi-objc-message :string string))))
94
95(defun find-or-create-ffi-typedef (string)
96  (or (gethash string *ffi-typedefs*)
97      (setf (gethash string *ffi-typedefs*)
98            (make-ffi-typedef :string string
99                              :name (escape-foreign-name string)))))
100
101(defun eval-complex-c-expression (string constant-alist)
102  (declare (ignore string constant-alist)))
103
104(defun eval-c-float-string (string)
105  (setq string (nstring-upcase string))
106  ;; Make the c float string (which may contain trailing garbage)
107  ;; look enough like a lisp float string that READ-FROM-STRING will
108  ;; work.
109  ;; There can be some trailing garbage on the string, or it might
110  ;; end in a decimal point.
111  ;; The trailing garbage might be a size specifier : #\L or #\F,
112  ;; to denote a LONG-DOUBLE or a (single) FLOAT.
113  ;; MCL can't deal with LONG-DOUBLEs, and will assume that an
114  ;; unqualified float constant is a SINGLE-FLOAT (or whatever
115  ;; *READ-DEFAULT-FLOAT-FORMAT* says.  We may have to add or
116  ;; change an exponent marker.
117  (let* ((lastpos (1- (length string)))
118         (lastchar (schar string lastpos))
119         (size :double))
120    (case lastchar
121      (#\L (setq size :long-double) (setf (schar string lastpos) #\Space))
122      (#\F (setq size :single) (setf (schar string lastpos) #\Space))
123      (#\. (setq string (concatenate 'string string "0"))))
124    (unless (eq size :long-double)
125      (let* ((epos (position #\E string))
126             (dpos (position #\D string)))
127        (if (eq size :double)
128          (if epos
129            (setf (schar string epos) #\d)
130            (setq string (concatenate 'string string "d0")))
131          (if dpos
132            (setf (schar string dpos) #\e))))
133      (values (ignore-errors (let* ((*readtable* *ffi-lisp-readtable*))
134                               (read-from-string string)))))))
135
136(defun read-c-number (stream char)
137  (loop collect char into chars
138        with class = :integer
139        with hex = nil
140        with octal = (eql char #\0)
141        do (setq char (read-char stream nil nil))
142        while (or (find char "0123456789abcdefABCDEFxulXUL.")
143                  (and (find char "+-")
144                       (char-equal (car (last chars)) #\e)))   ;signed exponent
145        do (cond ((char-equal char #\x) 
146                  (setq hex t octal nil))
147                 ((and (not hex) (or (char-equal char #\.) (char-equal char #\e)))
148                  (setq class :float)))
149        finally
150        (when char (unread-char char stream))
151        (setq chars (coerce chars 'string))
152        (if (eq class :integer)
153          (return
154            (values
155             (ignore-errors
156               (parse-integer chars
157                              :start (if hex 2 0)
158                              :radix (if hex 16 (if octal 8 10))
159                              :junk-allowed t))))
160          (return (eval-c-float-string chars)))))
161
162(defun eval-c-number (string char)
163  (loop collect char into chars
164        with class = :integer
165        with hex = nil
166        with octal = (eql char #\0)
167        with len = (length string)
168        with i = 0
169        do (setq char (if (< (incf i) len) (schar string i)))
170        while (or (find char "0123456789abcdefABCDEFxulXUL.")
171                  (and (find char "+-")
172                       (char-equal (car (last chars)) #\e)))   ;signed exponent
173        do (cond ((char-equal char #\x) 
174                  (setq hex t octal nil))
175                 ((and (not hex) (or (char-equal char #\.) (char-equal char #\e)))
176                  (setq class :float)))
177        finally
178          (setq chars (coerce chars 'string))
179          (if (eq class :integer)
180            (return
181              (values
182               (ignore-errors
183                 (parse-integer chars
184                                :start (if hex 2 0)
185                                :radix (if hex 16 (if octal 8 10))
186                                :junk-allowed t))))
187            (return (eval-c-float-string chars)))))
188
189;;; For our purposes (evaluating constant expressions in C macros),
190;;; we don't have to get this exactly right (since the result is
191;;; only going to be used in a size-of or cast operation.)
192;;; All pointer types would therefore look identical.
193
194(defvar *the-ffi-pointer-type* (parse-foreign-type '(* t)))
195
196;;; If we don't get this right the first time, we never will;
197;;; if there's nothing better, just return the void type.
198
199(defvar *the-ffi-void-type* (parse-foreign-type :void))
200
201(defun parse-c-ffi-type (spec)
202  (flet ((parse-it-or-lose (spec)
203           (or (ignore-errors (parse-foreign-type spec))
204               *the-ffi-void-type*))
205         (make-type-name (name)
206           (escape-foreign-name (string name))))
207    (cond ((eq (car (last spec)) 'c::*) *the-ffi-pointer-type*)
208          ((member (car spec) '(c::|struct| c::|union|))
209           (parse-it-or-lose (mapcar #'make-type-name spec)))
210          ((null (cdr spec))
211           (parse-it-or-lose (make-type-name (car spec))))
212          (t
213           ;;; A qualified primitive type
214           (let* ((primitive (parse-it-or-lose (make-type-name (car (last spec))))))
215             (if (eq primitive *the-ffi-void-type*)
216               primitive
217               (let* ((long 0)
218                      (explicitly-signed nil))
219                 (declare (fixnum long))
220                 (if
221                   (dolist (token (butlast spec) t)
222                     (case token
223                       (c::|unsigned| (setq explicitly-signed :unsigned))
224                       (c::|signed| (setq explicitly-signed :signed))
225                       (c::|long| (incf long))
226                       (c::|short| (decf long))
227                       (t (return nil))))
228                   (cond ((typep primitive 'foreign-integer-type)
229                          (let* ((prim-bits (foreign-type-bits primitive))
230                                 (prim-signed (foreign-integer-type-signed primitive)))
231                            (if (> long 1)
232                              (make-foreign-integer-type :bits 64
233                                                         :signed (or (not explicitly-signed)
234                                                                     (eq explicitly-signed :signed)))
235                              (if (< long 0)
236                                (make-foreign-integer-type :bits 16
237                                                           :signed (or (not explicitly-signed)
238                                                                       (eq explicitly-signed :signed)))
239                                (if (= long 1)
240                                  (make-foreign-integer-type :bits 32
241                                                             :signed (or (not explicitly-signed)
242                                                                         (eq explicitly-signed :signed)))
243                                  (make-foreign-integer-type :bits prim-bits
244                                                             :signed
245                                                             (case explicitly-signed
246                                                               (:signed t)
247                                                               (:unsigned nil)
248                                                               (t prim-signed))))))))
249                         ((and (= long 1)
250                               (typep primitive 'foreign-double-float-type))
251                          (parse-it-or-lose :long-double))
252                         (t *the-ffi-void-type*))
253                   *the-ffi-void-type*))))))))
254                                                               
255(defun eval-parsed-c-expression (expression constant-alist)
256  (if (atom expression)
257    (if (identifierp expression)
258      (find-constant expression constant-alist)
259      (if (typep expression 'character)
260        (char-code expression)
261        expression))
262    (let* ((operator (car expression))
263           (operands (cdr expression))
264           (noperands (length operands)))
265      (case operator
266        (c::resolve-type (let* ((foreign-type  (ignore-errors (parse-c-ffi-type (car operands)))))
267                           (when foreign-type
268                             (setf (cdr expression) nil
269                                   (car expression) foreign-type)
270                             )))
271        (c::curly-bracketed-list ())
272        (t
273         (if (typep operator 'foreign-type)
274           operator
275         (when (do* ((tail (cdr expression) (cdr tail)))
276                    ((null tail) t)
277                 (let* ((expr (car tail))
278                        (value (eval-parsed-c-expression expr constant-alist)))
279                   (unless value (return))
280                   (unless (eq expr value)
281                     (rplaca tail value))))
282           (case noperands
283             (1
284              (let* ((operand (cadr expression)))
285                (case operator
286                  (c::! (if (zerop operand) 1 0))
287                  (c::- (- operand))
288                  (c::+ operand)
289                  (c::~ (lognot operand))
290                  (c::size-of
291                   (let* ((bits (ignore-errors (ensure-foreign-type-bits operand))))
292                     (when bits
293                       (ash (+ bits 7) -3))))
294                  (t
295                   ;(break "~s" expression)
296                   nil))))
297             (2
298              (let* ((a (car operands))
299                     (b (cadr operands)))
300                (case operator
301                  (c::<< (ash a b))
302                  (c::>> (ash a (- b)))
303                  (c::* (* a b))
304                  (c::/ (if (zerop b) 0 (values (floor a b)))) ; or maybe TRUNCATE ?
305                  (c::+ (+ a b))
306                  (c::- (- a b))
307                  (c::\| (logior a b))
308                  (c::\& (logand a b))
309                  (c::cast (if (foreign-typep (setq b (eval-parsed-c-expression b constant-alist)) a)
310                             b
311                             (if (and (typep a 'foreign-integer-type)
312                                      (not (foreign-integer-type-signed a))
313                                      (typep b 'integer)
314                                      (not (> (integer-length b)
315                                              (foreign-integer-type-bits a))))
316                               (logand b (1- (ash 1 (foreign-integer-type-bits a))))
317                               (if (and (typep a 'foreign-pointer-type)
318                                        (typep b 'integer)
319                                        (<= (integer-length b) 16))
320                                 (progn                                   
321                                   (%int-to-ptr (logand b #xffffffff)))))))
322                               
323                                           
324                  (t 
325                   ;(break "binary op = ~s ~s ~s" operator a b)
326                   nil))))
327             (t
328              ;(break "expression = ~s" expression)
329              nil)))))))))
330
331(defun eval-c-expression (macro constant-alist macro-table)
332  (let* ((string (ffi-macro-expansion macro))
333         (len (length string)))
334    (if (= len 0)
335      1
336      (progn
337        (unless (ffi-macro-tokens macro)
338          (let* ((transitive (gethash (ffi-macro-expansion macro) macro-table)))
339            (if transitive
340              (setf (ffi-macro-tokens macro) transitive
341                    (gethash (ffi-macro-name macro) macro-table) transitive)
342              (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string))
343                (if error
344                  (setf (ffi-macro-disposition macro) :bad-tokenize)
345                  (setf (ffi-macro-tokens macro) tokens))))))
346        (unless (ffi-macro-expression macro)
347          (let* ((tokens (ffi-macro-tokens macro)))
348            (when tokens
349              (multiple-value-bind (expression error)
350                  (ignore-errors (parse-c-expression tokens
351                                                     :constants constant-alist
352                                                     :expand-macros macro-table ))
353                (if (or error (null expression))
354                  (progn
355                    ;(format t "~& parse failed: ~s ~s" (ffi-macro-name macro)  string)
356                    ;(format t "~&  tokens = ~s, error = ~a" tokens error)
357                    (setf (ffi-macro-disposition macro) :bad-parse))
358                  (setf (ffi-macro-expression macro) expression))))))
359        (let* ((expression (ffi-macro-expression macro)))
360          (when expression (values (eval-parsed-c-expression expression constant-alist) t)))))))
361
362;;; Repeatedly iterate over the macros until nothing new's defined.
363(defun process-defined-macros (ffi-macros constant-alist parameterized-macros)
364  (let* ((new-def ()))
365    (loop
366        (setq new-def nil)
367        (dolist (macro ffi-macros)
368          (unless (ffi-macro-disposition macro)
369            (let* ((expansion (ffi-macro-expansion macro))
370                   (name (ffi-macro-name macro))
371                   (value nil))
372              (if (string= name expansion)
373                (setf (ffi-macro-disposition macro) t)
374                (when (setq value (eval-c-expression macro constant-alist parameterized-macros))
375                  (push (cons name value) constant-alist)
376                  (setf (ffi-macro-disposition macro) t)
377                  (setq new-def t))))))
378        (unless new-def
379          (return (values (reverse constant-alist) nil))))))
380
381(defun reference-ffi-type (spec)
382  (case (car spec)
383    (:typedef (list :typedef (find-or-create-ffi-typedef (cadr spec))))
384    (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec))))
385    (:union-ref (list :union (find-or-create-ffi-union (cadr spec))))
386    (:transparent-union-ref
387     (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec))))
388    (:enum-ref `(:primitive :signed))
389    (:function `(:primitive (* t)))
390    (:pointer (list :pointer (reference-ffi-type (cadr spec))))
391    (:array (list :array (cadr spec) (reference-ffi-type (caddr spec))))
392    (:void *ffi-void-reference*)
393    (t
394     (list :primitive
395           (ecase (car spec)
396             (:char (if (getf (ftd-attributes *parse-ffi-target-ftd*)
397                              :signed-char)
398                      '(:signed 8)
399                      '(:unsigned 8)))
400             (:signed-char  '(:signed 8))
401             (:unsigned-char '(:unsigned 8))
402             (:short '(:signed 16))
403             (:unsigned-short '(:unsigned 16))
404             ((:vec128 :unsigned-long-long-long) '(:unsigned 128))
405             (:signed-long-long-long '(:signed 128))
406             (:int '(:signed 32))
407             (:long (ecase (or
408                            (getf
409                             (ftd-attributes *parse-ffi-target-ftd*)
410                             :bits-per-long)
411                            (getf
412                             (ftd-attributes *parse-ffi-target-ftd*)
413                             :bits-per-word))
414                      (32 '(:signed 32))
415                      (64 '(:signed 64))))
416             (:unsigned  '(:unsigned 32))
417             (:unsigned-long (ecase (or
418                                     (getf
419                                      (ftd-attributes *parse-ffi-target-ftd*)
420                                      :bits-per-long)
421                                     (getf
422                                      (ftd-attributes *parse-ffi-target-ftd*)
423                                      :bits-per-word))
424                               (32 '(:unsigned 32))
425                               (64 '(:unsigned 64))))
426             (:long-long '(:signed 64))
427             ((:vec64 :unsigned-long-long) '(:unsigned 64))
428             (:float :float)
429             (:double :double)
430             (:long-double :long-float)
431             (:complex-int :complex-int)
432             (:complex-float :complex-float)
433             (:complex-double :complex-double)
434             (:complex-long-double :complex-long-float)
435             (:long-long-long :long-long-long)
436             #|(:void :void)|#)))))
437             
438             
439(defun process-ffi-fieldlist (fields)
440  (let* ((parsed-fields ()))
441    (dolist (field fields (nreverse parsed-fields))
442      (let* ((field-name (escape-foreign-name (car field)))
443             (field-descr (cadr field)))
444        (destructuring-bind (field-type offset width)
445            (cdr field-descr)
446          (push (cons field-name
447                      (ecase (car field-descr)
448                        (:field `(,(reference-ffi-type field-type) ,(ash offset 3) ,(ash width 3)))
449                        (:bitfield `((:primitive (:unsigned ,width)) ,offset ,width))))
450                parsed-fields))))))
451
452(defun process-ffi-union (form)
453  (destructuring-bind (source-info string fields &optional alignform)
454      (cdr form)
455    (declare (ignore source-info))
456    (let* ((union (find-or-create-ffi-union string)))
457      (setf (ffi-union-ordinal union) (incf *ffi-ordinal*))
458      (when alignform
459        (setf (ffi-union-alt-alignment-bits union) (cadr alignform)))
460      (unless (ffi-union-fields union)
461        (setf (ffi-union-fields union)
462              (process-ffi-fieldlist fields)))
463      union)))
464
465(defun process-ffi-transparent-union (form)
466  (destructuring-bind (source-info string fields &optional alignform)
467      (cdr form)
468    (declare (ignore source-info))
469    (let* ((union (find-or-create-ffi-transparent-union string)))
470      (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*))
471      (when alignform
472        (setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform)))
473      (unless (ffi-transparent-union-fields union)
474        (setf (ffi-transparent-union-fields union)
475              (process-ffi-fieldlist fields)))
476      union)))
477
478(defun process-ffi-struct (form)
479  (destructuring-bind (source-info string fields &optional alignform)
480      (cdr form)
481    (declare (ignore source-info))
482    (let* ((struct (find-or-create-ffi-struct string)))
483      (setf (ffi-struct-ordinal struct) (incf *ffi-ordinal*))
484      (when alignform
485        (setf (ffi-struct-alt-alignment-bits struct) (cadr alignform)))
486      (unless (ffi-struct-fields struct)
487        (setf (ffi-struct-fields struct)
488              (process-ffi-fieldlist fields)))
489      struct)))
490
491(defun process-ffi-objc-class (form)
492  (destructuring-bind (source-info class-name superclass-form protocols ivars) (cdr form)
493    (declare (ignore source-info))
494    (let* ((class (find-or-create-ffi-objc-class class-name)))
495      (setf (ffi-objc-class-ordinal class) (incf *ffi-ordinal*))
496      (unless (ffi-objc-class-super-foreign-name class)
497        (let* ((super-name (car superclass-form)))
498          (unless (eq super-name :void)
499            (setf (ffi-objc-class-super-foreign-name class)
500                  super-name))))
501      (unless (ffi-objc-class-protocol-names class)
502        (setf (ffi-objc-class-protocol-names class) protocols))
503      (unless (ffi-objc-class-own-ivars class)
504        (setf (ffi-objc-class-own-ivars class)
505              (process-ffi-fieldlist ivars)))
506      class)))
507
508(defun process-ffi-objc-method (form)
509  (destructuring-bind (method-type source-info class-name category-name message-name arglist result-type) form
510    (declare (ignore source-info category-name))
511    (let* ((flags ()))
512      (if (or (eq method-type :objc-class-method)
513              (eq method-type :objc-protocol-class-method))
514        (setf (getf flags :class) t))
515      (if (or (eq method-type :objc-protocol-class-method)
516              (eq method-type :objc-protocol-instance-method))
517        (setf (getf flags :protocol) t))
518      (let* ((message (find-or-create-ffi-objc-message message-name))
519             (class-method-p (getf flags :class))
520             (method
521              (make-ffi-objc-method :class-name class-name
522                                    :arglist (mapcar #'reference-ffi-type
523                                                     arglist)
524                                    :result-type (reference-ffi-type
525                                                  result-type)
526                                    :flags flags)))
527        (unless (dolist (m (ffi-objc-message-methods message))
528                  (when (and (equal (ffi-objc-method-class-name m)
529                                    class-name)
530                             (eq (getf (ffi-objc-method-flags m) :class)
531                                 class-method-p))
532                    (return t)))
533          (push method (ffi-objc-message-methods message)))))))
534     
535(defun process-ffi-typedef (form)
536  (let* ((string (caddr form))
537         (def (find-or-create-ffi-typedef string)))
538    (setf (ffi-typedef-ordinal def) (incf *ffi-ordinal*))
539    (unless (ffi-typedef-type def)
540      (setf (ffi-typedef-type def) (reference-ffi-type (cadddr form))))
541    def))
542
543
544(defun process-ffi-function (form)
545  (let* ((name (caddr form))
546         (ftype (cadddr form)))
547    (make-ffi-function :string name
548                       :arglist (mapcar #'reference-ffi-type (cadr ftype))
549                       :return-value (reference-ffi-type (caddr ftype)))))
550
551(defun process-ffi-macro (form)
552  (let* ((name-form (caddr form))
553         (expansion (cadddr form))
554         (name name-form)
555         (args nil)
556         (space-pos (position #\space name-form)))
557    (when space-pos
558      (setq name (subseq name-form 0 space-pos))
559      (let* ((open-pos (position #\( name-form))
560             (close-pos (position #\) name-form)))
561        (when (and open-pos close-pos (> close-pos open-pos))
562          (let* ((arg-string (subseq name-form open-pos close-pos))
563                 (arg-tokens (ignore-errors (string-to-tokens arg-string)))
564                 (arg-names (let* ((l ()))
565                              (dolist (arg-token arg-tokens (nreverse l))
566                                (unless (or (eq arg-token 'c::|,|)
567                                            (eq arg-token *lparen-symbol*))
568                                  (push arg-token l)))))
569                 (body-tokens (ignore-errors (string-to-tokens expansion))))
570            (when (and arg-names body-tokens)
571              (setq args (list arg-names body-tokens)
572                    expansion name))))))
573    (make-ffi-macro :name name :args args :expansion expansion)))
574
575(defun process-ffi-enum (form)
576  (declare (ignore form)))
577
578(defun process-ffi-var (form)
579  (let* ((name (caddr form))
580         (type (cadddr form)))
581    (cons name (reference-ffi-type type))))
582
583(defun process-ffi-enum-ident (form)
584  (cons (caddr form) (cadddr form)))
585
586(defun ensure-referenced-type-defined (spec)
587  (declare (ignorable spec))
588  (when nil
589  (ecase (car spec)
590    (:primitive)
591    (:typedef (define-typedef-from-ffi-info (cadr spec)))
592    (:struct (ensure-struct-defined (cadr spec)))
593    (:union (ensure-union-defined (cadr spec)))
594    (:transparent-union (ensure-transparent-union-defined (cadr spec)))
595    (:pointer (ensure-referenced-type-defined (cadr spec)))
596    (:array (ensure-referenced-type-defined (caddr spec)))
597    (:function (dolist (arg (ffi-function-arglist (cadr spec)))
598                 (ensure-referenced-type-defined arg))
599               (ensure-referenced-type-defined (ffi-function-return-value (cadr spec))))
600    )))
601
602 
603(defun ensure-fields-defined (fields)
604  (dolist (f fields)
605    (let* ((ftype (cadr f)))
606      (ensure-referenced-type-defined ftype))))
607
608(defun record-global-objc-class (c)
609  (when *ffi-global-objc-classes*
610    (setf (gethash (ffi-objc-class-string c) *ffi-global-objc-classes*) c)))
611
612(defun define-objc-class-from-ffi-info (c)
613  (unless (ffi-objc-class-defined c)
614    (setf (ffi-objc-class-defined c) t)
615    (record-global-objc-class c)
616    (ensure-fields-defined (ffi-objc-class-own-ivars c))))
617
618(defun record-global-union (u)
619  (when *ffi-global-unions*
620    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))
621
622(defun record-global-transparent-union (u)
623  (when *ffi-global-transparent-unions*
624    (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u)))
625
626(defun define-union-from-ffi-info (u)
627  (unless (ffi-union-defined u)
628    (setf (ffi-union-defined u) t)
629    (record-global-union u)
630    (when (ffi-union-name u)
631      (let* ((fields (ffi-union-fields u)))
632        (ensure-fields-defined fields)))))
633
634(defun define-transparent-union-from-ffi-info (u)
635  (unless (ffi-transparent-union-defined u)
636    (setf (ffi-transparent-union-defined u) t)
637    (record-global-transparent-union u)
638    (when (ffi-transparent-union-name u)
639      (let* ((fields (ffi-transparent-union-fields u)))
640        (ensure-fields-defined fields)))))
641
642(defun ensure-union-defined (u)
643  (let* ((name (ffi-union-name u)))
644    (if name
645      (define-union-from-ffi-info u)
646      (ensure-fields-defined (ffi-union-fields u)))))
647
648(defun ensure-transparent-union-defined (u)
649  (let* ((name (ffi-transparent-union-name u)))
650    (if name
651      (define-transparent-union-from-ffi-info u)
652      (ensure-fields-defined (ffi-transparent-union-fields u)))))
653
654(defun record-global-struct (s)
655  (when *ffi-global-structs*
656    (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s)))
657
658(defun define-struct-from-ffi-info (s)
659  (unless (ffi-struct-defined s)
660    (setf (ffi-struct-defined s) t)
661    (record-global-struct s)
662    (when (typep (ffi-struct-name s) 'keyword)
663      (let* ((fields (ffi-struct-fields s)))
664        (ensure-fields-defined fields)))))
665
666(defun ensure-struct-defined (s)
667  (let* ((name (ffi-struct-name s)))
668    (if (typep name 'keyword)
669      (define-struct-from-ffi-info s)
670      (ensure-fields-defined (ffi-struct-fields s)))))
671
672(defun record-global-typedef (def)
673  (when *ffi-global-typedefs*
674    (setf (gethash (ffi-typedef-string def) *ffi-global-typedefs*) def)))
675 
676(defun define-typedef-from-ffi-info (def)
677  (unless (ffi-typedef-defined def)
678    (setf (ffi-typedef-defined def) t)
679    (record-global-typedef def)
680    (let* ((target (ffi-typedef-type def)))
681      (unless (and (consp target)
682                   (member (car target) '(:struct :union :transparent-union :primitive)))
683        (ensure-referenced-type-defined target)))))
684
685(defun record-global-constant (name val)
686  (when *ffi-global-constants*
687    (setf (gethash name *ffi-global-constants*) val)))
688     
689(defun emit-ffi-constant (name val)
690  (record-global-constant name val))
691
692(defun record-global-var (name type)
693  (when *ffi-global-vars*
694    (setf (gethash name *ffi-global-vars*) type)))
695
696(defun emit-ffi-var (name type)
697  (record-global-var name type))
698
699
700(defun ffi-record-type-p (typeref)
701  (case (car typeref)
702    ((:struct :union :transparent-union) t)
703    (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref))))
704    (t nil)))
705
706(defun record-global-function (ffi-function)
707  (when *ffi-global-functions*
708    (setf (gethash (ffi-function-string ffi-function) *ffi-global-functions*)
709          ffi-function)))
710
711(defun emit-function-decl (ffi-function)
712  (let* ((args (ffi-function-arglist ffi-function))
713         (retval (ffi-function-return-value ffi-function)))
714    (if (eq (car (last args)) *ffi-void-reference*)
715      (setq args (butlast args)))
716    (dolist (arg args) (ensure-referenced-type-defined arg))
717    (ensure-referenced-type-defined retval)
718    (record-global-function ffi-function)))
719 
720(defun parse-ffi (inpath)
721  (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
722         (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
723         (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
724         (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
725         (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) 
726         (argument-macros (make-hash-table :test 'equal)))
727    (let* ((defined-types ())
728           (defined-constants ())
729           (defined-macros ())
730           (defined-functions ())
731           (defined-vars ()))
732      (with-open-file (in inpath)
733        (let* ((*ffi-ordinal* -1))
734          (let* ((*package* (find-package "KEYWORD")))
735            (do* ((form (read in nil :eof) (read in nil :eof)))
736                 ((eq form :eof))
737              (case (car form)
738                (:struct (push (process-ffi-struct form) defined-types))
739                (:objc-class (push (process-ffi-objc-class form) defined-types))
740                ((:objc-class-method
741                  :objc-instance-method
742                  :objc-protocol-class-method
743                  :objc-protocol-instance-method
744                  )
745                 (process-ffi-objc-method form))
746                (:function (push (process-ffi-function form) defined-functions))
747                (:macro (let* ((m (process-ffi-macro form))
748                               (args (ffi-macro-args m)))
749                          (if args
750                            (setf (gethash (string (ffi-macro-name m)) argument-macros) args)
751                            (push m defined-macros))))
752                (:type (push (process-ffi-typedef form) defined-types))
753                (:var (push (process-ffi-var form) defined-vars))
754                (:enum-ident (push (process-ffi-enum-ident form) defined-constants))
755                (:enum (process-ffi-enum form))
756                (:union (push (process-ffi-union form) defined-types))
757                (:transparent-union (push (process-ffi-transparent-union form) defined-types)))))
758          (multiple-value-bind (new-constants new-macros)
759              (process-defined-macros defined-macros (reverse defined-constants) argument-macros)
760            ;; If we're really lucky, we might be able to turn some C macros
761            ;; into lisp macros.  We can probably turn some C macros into
762            ;; lisp constants.
763            (declare (ignore new-macros))
764            (dolist (x (reverse new-constants))
765              (emit-ffi-constant (car x) (cdr x)))
766            (dolist (x defined-vars)
767              (emit-ffi-var (car x) (cdr x)))
768            (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal))
769              (typecase x
770                (ffi-struct (define-struct-from-ffi-info x))
771                (ffi-union (define-union-from-ffi-info x))
772                (ffi-transparent-union (define-transparent-union-from-ffi-info x))
773                (ffi-typedef (define-typedef-from-ffi-info x))
774                (ffi-objc-class (define-objc-class-from-ffi-info x))))
775            (dolist (f defined-functions) (emit-function-decl f))))))))
776
777(defun parse-standard-ffi-files (dirname &optional target)
778  (let* ((backend (if target (find-backend target) *target-backend*))
779         (ftd (backend-target-foreign-type-data backend))
780         (*parse-ffi-target-ftd* ftd)
781         (*target-ftd* ftd)
782         (*target-backend* backend)
783         (*ffi-struct-return-explicit* t)
784         (d (use-interface-dir dirname ftd))
785         (interface-dir (merge-pathnames
786                         (interface-dir-subdir d)
787                         (ftd-interface-db-directory ftd)))
788         (*prepend-underscores-to-ffi-function-names*
789          (getf (ftd-attributes ftd) :prepend-underscores))
790         (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
791         (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
792         (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
793         (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
794         (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
795         (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash)) 
796         (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash))
797         (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash))
798         (*ffi-global-vars* (make-hash-table :test 'string= :hash-function 'sxhash)))
799         
800    (dolist (f (directory (merge-pathnames ";C;**;*.ffi"
801                                           interface-dir)))
802      (format t "~&~s ..." f)
803      (parse-ffi f )
804      (format t "~&"))
805    (with-new-db-file (constants-cdbm (merge-pathnames
806                                       "new-constants.cdb"
807                                       interface-dir))
808      (maphash #'(lambda (name def)
809                   (db-define-constant constants-cdbm name def))
810               *ffi-global-constants*))
811    (with-new-db-file (types-cdbm (merge-pathnames
812                                       "new-types.cdb"
813                                       interface-dir))
814      (maphash #'(lambda (name def)
815                   (declare (ignore name))
816                   (save-ffi-typedef types-cdbm def))
817               *ffi-global-typedefs*))
818    (with-new-db-file (records-cdbm (merge-pathnames
819                                     "new-records.cdb"
820                                     interface-dir))
821      (maphash #'(lambda (name def)
822                   (declare (ignore name))
823                   (save-ffi-union records-cdbm def))
824               *ffi-global-unions*)
825      (maphash #'(lambda (name def)
826                   (declare (ignore name))
827                   (save-ffi-transparent-union records-cdbm def))
828               *ffi-global-transparent-unions*)
829                         
830      (maphash #'(lambda (name def)
831                   (declare (ignore name))
832                   (save-ffi-struct records-cdbm def))
833               *ffi-global-structs*))
834    (with-new-db-file (function-cdbm (merge-pathnames
835                                           "new-functions.cdb"
836                                           interface-dir))
837      (maphash #'(lambda (name def)
838                   (declare (ignore name))
839                   (save-ffi-function function-cdbm def))
840               *ffi-global-functions*))
841    (with-new-db-file (class-cdbm (merge-pathnames
842                                   "new-objc-classes.cdb"
843                                   interface-dir))
844      (maphash #'(lambda (name def)
845                   (declare (ignore name))
846                   (save-ffi-objc-class class-cdbm def))
847               *ffi-global-objc-classes*))
848    (with-new-db-file (vars-cdbm (merge-pathnames
849                             "new-vars.cdb"
850                             interface-dir))
851      (maphash #'(lambda (name type)
852                   (db-define-var vars-cdbm name type))
853               *ffi-global-vars*))
854    (with-new-db-file (methods-cdbm  (merge-pathnames
855                                      "new-objc-methods.cdb"
856                                      interface-dir))
857      (maphash #'(lambda (name message)
858                   (declare (ignore name))
859                   (save-ffi-objc-message methods-cdbm message))
860               *ffi-global-objc-messages*))
861    (install-new-db-files ftd d)))
862
863(defvar *c-readtable* (copy-readtable nil))
864(setf (readtable-case *c-readtable*) :preserve)
865
866
867;;; Each element of operators can be a symbol or a list of a symbol, a
868;;; function, and args All the symbols must start with the character
869;;; for which this is the macro-character fcn The entries must be in
870;;; the right order, e.g. dictionary order, so any two symbols with a
871;;; common prefix are adjacent in the list.  Furthermore each symbol
872;;; in the list must be preceded by every non-empty leading substring
873;;; of that symbol, since we only have one character of look-ahead in
874;;; the stream.
875(defun operator-macro (operators)
876  ;; The tree is an alist keyed by character (with a nil key at the end for the default)
877  ;; The cdr of each entry is either a symbol to produce, another decision tree,
878  ;; or a list of a function to call and additional arguments for the function
879  (let ((decision-tree (make-decision-tree operators)))
880    (labels ((read-c-operator (stream char)
881               (declare (ignore char))
882               (loop with decision-tree = decision-tree
883                     as char = (read-char stream nil nil)   ; eof => nil which works too
884                     as elem = (assoc char decision-tree)
885                     do (unless elem
886                          (unread-char char stream)
887                          (setq elem (assoc nil decision-tree)))
888                        (setq elem (cdr elem))
889                        (cond ((symbolp elem) 
890                               (return elem))
891                              ((symbolp (car elem)) 
892                               (return (apply (car elem) stream (cdr elem))))
893                              (t (setq decision-tree elem)))))
894             (read-c-singleton-operator (stream char)
895               (declare (ignore stream char))
896               (first operators))
897             (read-c-macro-character (stream char)
898               (declare (ignore char))
899               (apply (car decision-tree) stream (cdr decision-tree))))
900      (cond ((symbolp decision-tree) #'read-c-singleton-operator)
901            ((consp (car decision-tree)) #'read-c-operator)
902            (t #'read-c-macro-character)))))
903
904(defun make-decision-tree (operators)
905  (labels ((recurse (operators chars-so-far) ;returns new operators and decision tree element
906             (let ((next-char (aref (key (first operators))
907                                    (length chars-so-far)))
908                   (alist nil))
909               (setq chars-so-far (append chars-so-far (list next-char)))
910               (loop while operators
911                 as key = (key (first operators))
912                 while (every #'char= key chars-so-far)
913                 do (if (= (length key) (length chars-so-far))
914                      (push (cons nil (val (pop operators))) alist)
915                      (multiple-value-bind (remaining-operators elem)
916                          (recurse operators chars-so-far)
917                        (push elem alist)
918                        (setq operators remaining-operators))))
919               (values operators 
920                       (cons next-char (if (cdr alist) alist (cdar alist))))))
921           (key (operator)
922             (string (if (atom operator) operator (car operator))))
923           (val (operator)
924             (if (atom operator) operator (cdr operator))))
925    (multiple-value-bind (left-over elem) (recurse operators nil)
926      (when left-over
927        (error "Malformed operators list ~S:~S" (ldiff operators left-over) left-over))
928      (cdr elem))))
929
930;;; Doesn't support the L prefix for wide characters.  What a complete kludge!
931(defun c-read-string (stream single-quote)
932  (loop with delimiter = (if single-quote #\' #\")
933        as char = (read-char stream nil nil)
934        do (cond ((null char)
935                  (c-parse-error stream "Unmatched ~A" delimiter))
936                 ((char= char delimiter)
937
938                  (return (if single-quote
939                              (char-code (car chars))
940                              (coerce chars 'string))))
941                 ((char= char #\\)
942                  (setq char (read-char stream nil nil))
943                  (unless char (c-parse-error stream "EOF after backslash in string"))
944                  (let ((tem (assoc char '((#\n . #\newline)
945                                           (#\t . #\tab)
946                                           (#\v . #\^K)
947                                           (#\b . #\backspace)
948                                           (#\r . #\return)
949                                           (#\f . #\page)
950                                           (#\a . #\bell)
951                                           (#\\ . #\\)
952                                           (#\? . #\?)
953                                           (#\' . #\')
954                                           (#\" . #\")))))
955                    (cond (tem (setq char (cdr tem)))
956                          ((char<= #\0 char #\7)
957                           (setq char (loop while (char<= #\0 char #\7) for count from 1
958                                            with sum = 0
959                                            do (setq sum (+ (* sum 8) (digit-char-p char)))
960                                               (setq char (read-char stream nil nil))
961                                            until (= count 3)
962                                            finally 
963                                              (unread-char char stream)
964                                              (return (code-char sum)))))
965                          ((char= char #\x)
966                           (setq char (loop with sum = 0
967                                            as char = (read-char stream)
968                                            while (or (char<= #\0 char #\9)
969                                                      (char<= #\A char #\F)
970                                                      (char<= #\a char #\f))
971                                            do (setq sum (+ (* sum 16) (digit-char-p char 16)))
972                                            finally 
973                                              (unread-char char stream)
974                                              (return (code-char sum)))))))))
975        collect char into chars))
976
977(dolist (char '(#\_))
978  (set-syntax-from-char char #\A *c-readtable*))
979
980(dolist (op '( (c::! c::!=)
981               ((\" c-read-string nil))
982               (|#| |##|)            ; # and ## are pre-processor operators
983               (c::% c::%=)
984               (c::& c::&= c::&&)
985               ((\' c-read-string t))
986               (c::\()
987               (c::\))
988               (c::* c::*=)
989               (c::+ c::+= c::++)
990               (c::- c::-= c::-- c::->)
991               (c::\,)
992               (c::|.| c::|.*| c::|..| c::|...|)                 ; .01 will fail to parse as 0.01
993               (c::/ c::/= (// c-read-line-comment) (/* c-read-block-comment))
994               (c::\: c::\:\:)
995               (c::\;)
996               (c::< c::<= c::<< c::<<=)
997               (c::= c::==)
998               (c::> c::>= c::>> c::>>=)
999               (c::?)
1000               (c::[)
1001               (c::\\)
1002               (c::])
1003               (c::^ c::^=)
1004               (c::{)
1005               (c::\| c::\|= c::\|\|)
1006               (c::})
1007               (c::~)
1008               ;; C++ doesn't define any meaning for these, treat them as operators
1009               (c::\$)
1010               (c::\@)
1011               (c::\`)
1012               ))
1013  (set-macro-character (char (string (if (atom (car op)) (car op) (caar op))) 0)
1014                       (operator-macro op)
1015                       nil              ;token-terminating
1016                       *c-readtable*))
1017
1018(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
1019  (set-macro-character char 'read-c-number t *c-readtable*))
1020
1021
1022(defvar *backslash-symbol* 'c::|\\|)
1023
1024(defvar *pending-tokens* ())
1025
1026(defun unread-token (token)
1027  (push token *pending-tokens*)
1028  token)
1029
1030(defun next-token (stream)
1031  (if *pending-tokens*
1032    (pop *pending-tokens*)
1033    (do* ((tok (read-preserving-whitespace stream nil :eof)
1034                       (read-preserving-whitespace stream nil :eof)))
1035                 ((or (not (eq tok *backslash-symbol*))
1036                      (not (eq (peek-char nil stream nil nil) #\Newline)))
1037                  tok)     
1038             ;; Consume the #\newline that followed #\\.  Yecch.
1039             (read-char stream nil nil))))
1040             
1041(defun string-to-tokens (string)
1042  (with-input-from-string (stream string)
1043    (let* ((*package* (find-package "C"))
1044           (*readtable* *c-readtable*)
1045           (tokens ()))
1046      (loop
1047          (let* ((token (next-token stream)))
1048            (when (eq token :eof)
1049              (return (nreverse tokens)))
1050            (push token tokens))))))
1051
1052
1053(defun identifierp (token)
1054  (and (symbolp token)
1055       (let ((char (char (symbol-name token) 0)))
1056         (or (alpha-char-p char) (char= char #\_)))))
1057
1058
1059(defun evaluate-type-name (x)
1060  (let* ((name (car x)))
1061    (if (and (atom name) nil (null (cdr x)))
1062      name)))
1063     
1064
1065(defun find-constant (x constants)
1066  (when (symbolp x)
1067    (cdr (assoc (string x) constants :test #'string=))))
1068
1069(defun find-user-or-primitive-type (x)
1070  x
1071  nil)
1072
1073(defun macro-definition (id table)
1074  (gethash (string id) table))
1075
1076(defun expand-c-macro (name parameters arguments body stream macros-not-to-expand macro-table)
1077  (let ((expansion nil))
1078    (unless (= (length arguments) (length parameters))
1079      (c-parse-error stream "Expected ~D argument~:P to macro ~A but got ~D argument~:P."
1080                         (length parameters) name (length arguments)))
1081    (loop while body
1082      as token = (pop body)
1083      as next = (first body)
1084      as argno = (position token parameters) do
1085      (cond ((and argno (eq next *sharp-sharp-symbol*)) ; parameter ## token/parameter
1086             (pop body)
1087             (setq next (pop body))
1088             (let ((next-argno (position next parameters)))
1089               (push (intern (concatenate 'string (c-stringize-token-list (nth argno arguments))
1090                                          (if next-argno
1091                                            (c-stringize-token-list (nth next-argno arguments))
1092                                            (c-stringize-token next))))
1093                     expansion)))
1094            (argno                      ; normal parameter substitution
1095             (setq expansion (nreconc (expand-c-macros-in-token-list (nth argno arguments)
1096                                                                     stream macros-not-to-expand
1097                                                                     macro-table)
1098                                      expansion)))
1099            ((and (eq token *sharp-sharp-symbol*) ; token ## parameter
1100                  (setq argno (position next parameters)))
1101             (pop body)
1102             (push (intern (concatenate 'string (c-stringize-token (pop expansion))
1103                                        (c-stringize-token-list (nth argno arguments))))
1104                   expansion))
1105            ((and (eq token *sharp-symbol*)     ; # parameter
1106                  (setq argno (position next parameters)))
1107             (pop body)
1108             (push (c-stringize-token-list (nth argno arguments)) expansion))
1109            (t (push token expansion))))
1110    (expand-c-macros-in-token-list (nreverse expansion) stream
1111                                   (adjoin name macros-not-to-expand)
1112                                   macro-table)))
1113
1114(defun expand-c-macros-in-token-list (tokens stream macros-not-to-expand macro-table)
1115  (loop
1116      while tokens
1117    as token = (pop tokens)
1118    as macro = (and (symbolp token)
1119                    (not (member token macros-not-to-expand))
1120                    (macro-definition token macro-table))
1121    if macro
1122    nconc (if (eq (first macro) :none) 
1123            (expand-c-macros-in-token-list (second macro) stream 
1124                                           (adjoin token macros-not-to-expand) macro-table)
1125            (expand-c-macro token (first macro)
1126                            (let ((open (pop tokens)))
1127                              (unless (eq open *lparen-symbol*)
1128                                (c-parse-error
1129                                 stream
1130                                 "~A where open parenthesis expected after macro name ~A"
1131                                 open token))
1132                              (loop with done = nil
1133                                    collect
1134                                    (loop as token = (if tokens (pop tokens)
1135                                                       (c-parse-error stream
1136                                                                      "Unexpected impossible EOF"))
1137                                          with level = 0
1138                                          do (cond ((eq token *lparen-symbol*) (incf level))
1139                                                   ((eq token *rparen-symbol*)
1140                                                    (if (plusp level) (decf level) (setq done t))))
1141                                                  until (or done (and (zerop level)
1142                                                                      (eq token *comma-symbol*)))
1143                                                  collect token)
1144                                    until done))
1145                            (second macro) stream macros-not-to-expand macro-table))
1146    else collect token))
1147
1148(defun parse-c-expression (token-list &key  constants additional-constants 
1149                                          expand-macros)
1150  (labels ((next ()
1151             (unless token-list
1152               (fail "Unterminated expression or unbalanced parentheses"))
1153             (pop token-list))
1154           (peek ()
1155             (car token-list))
1156           (unread (token)
1157             (push token token-list))
1158           (collect-parenthesized ()
1159             (loop with level = 0
1160                   as token = (next)
1161                   until (and (eq token *rparen-symbol*) (= level 0))
1162                   collect token
1163                   do (case token
1164                        (#.*lparen-symbol* (incf level))
1165                        (#.*rparen-symbol* (decf level)))))
1166           (fail (format-string &rest format-arguments)
1167             (apply #'c-parse-error nil format-string format-arguments))
1168           (parse-expression ()
1169             (parse-assignment))
1170           (parse-assignment ()
1171             (let ((left (parse-conditional)))
1172               (if (eq (peek) 'c::|=|)
1173                 (let ((right (progn (next) (parse-assignment))))
1174                   (list 'setf left right))
1175                 left)))
1176           (parse-conditional ()
1177             (let ((left (parse-logical-or)))
1178               (if (eq (peek) 'c::|?|)
1179                 (let ((then (progn (next) (parse-expression)))
1180                       (else (if (eq (peek) '|:|)
1181                               (progn (next) (parse-conditional))
1182                               (fail "~A where : was expected" (peek)))))
1183                   (list 'if left then else))
1184                 left)))
1185           (parse-logical-or ()
1186             (let ((left (parse-logical-and)))
1187               (loop while (eq (peek) 'c::|\|\||)
1188                     do (setq left (list (next) left (parse-logical-and))))
1189               left))
1190           (parse-logical-and ()
1191             (let ((left (parse-bitwise-ior)))
1192               (loop while (eq (peek) 'c::|&&|)
1193                     do (setq left (list (next) left (parse-bitwise-ior))))
1194               left))
1195           (parse-bitwise-ior ()
1196             (let ((left (parse-bitwise-xor)))
1197               (loop while (eq (peek) 'c::|\||)
1198                     do (setq left (list (next) left (parse-bitwise-xor))))
1199               left))
1200           (parse-bitwise-xor ()
1201             (let ((left (parse-bitwise-and)))
1202               (loop while (eq (peek) 'c::|\^|)
1203                     do (setq left (list (next) left (parse-bitwise-and))))
1204               left))
1205           (parse-bitwise-and ()
1206             (let ((left (parse-equality)))
1207               (loop while (eq (peek) 'c::|&|)
1208                     do (setq left (list (next) left (parse-equality))))
1209               left))
1210           (parse-equality ()
1211             (let ((left (parse-relational)))
1212               (loop while (member (peek) '(c::|==| c::|!=|))
1213                     do (setq left (list (next) left (parse-relational))))
1214               left))
1215           (parse-relational ()
1216             (let ((left (parse-shift)))
1217               (loop while (member (peek) '(c::|<| c::|>| c::|<=| c::|>=|))
1218                     do (setq left (list (next) left (parse-shift))))
1219               left))
1220           (parse-shift ()
1221             (let ((left (parse-additive)))
1222               (loop while (member (peek) '(c::|<<| c::|>>|))
1223                     do (setq left (list (next) left (parse-additive))))
1224               left))
1225           (parse-additive ()
1226             (let ((left (parse-multiplicative)))
1227               (loop while (member (peek) '(c::|+| c::|-|))
1228                     do (setq left (list (next) left (parse-multiplicative))))
1229               left))
1230           (parse-multiplicative ()
1231             (let ((left (parse-pointer-to-member)))
1232               (loop while (member (peek) '(c::|*| c::|/| c::|%|))
1233                     do (setq left (list (next) left (parse-pointer-to-member))))
1234               left))
1235           (parse-pointer-to-member ()
1236             (let ((left (parse-unary)))
1237               (loop while (member (peek) '(c::|.*| c::|->*|))
1238                     do (setq left (list (next) left (parse-unary))))
1239               left))
1240           (parse-unary ()              ; subsumes parse-cast, thus accepting some invalid programs
1241             (let ((token (next)))      ; --- doesn't support new and delete yet
1242               (cond ((member token '(c::|+| c::|-| c::|!| c::|~| c::|++| c::|--|))
1243                      ;;--- doesn't yet have special support for calling destructors...
1244                      (list token (parse-unary)))
1245                     ((eq token 'c::|*|)
1246                      (list 'c::indirect (parse-unary)))
1247                     ((eq token 'c::|&|)
1248                      (list 'c::address-of (parse-unary)))
1249                     ((eq token 'c::|sizeof|)
1250                      (unless (eq (peek) *lparen-symbol*)          ; Require open paren, maybe it's really optional
1251                        (fail "~A where ( was expected after sizeof" (peek)))
1252                      (next)            ; Swallow open parenthesis
1253                      `(c::size-of (c::resolve-type ,(loop as token = (next)
1254                                                           until (eq token *rparen-symbol*)
1255                                                           collect token))))
1256                     (t (parse-postfix token)))))
1257           (parse-postfix (token)
1258             (loop with left = (parse-primary token)
1259                   as right =  (peek) do
1260                   (setq left
1261                         (cond ((eq right *leftbracket-symbol*)
1262                                (next)          ; swallow [
1263                                (let ((subscript (parse-expression))
1264                                      (delimiter (next)))
1265                                  (unless (eq delimiter *rightbracket-symbol*)
1266                                  (fail "~A where ] expected after subscript" delimiter))
1267                                  `(c::aref ,left ,subscript)))
1268                               ((eq right *lparen-symbol*)
1269                                (next)          ; swallow open parenthesis
1270                                (let ((macro (and expand-macros
1271                                                  (identifierp left)
1272                                                  (macro-definition left expand-macros))))
1273                                  (cond ((and macro (not (eq (first macro) ':none)))
1274                                         ;; Function-like macro - constant-like was alraedy handled
1275                                         (let ((more-tokens
1276                                                (expand-c-macro left (first macro)
1277                                                                (collect-macro-arguments)
1278                                                                (second macro) nil '()
1279                                                                expand-macros)))
1280                                           (setq token-list (append more-tokens token-list))
1281                                           (parse-expression)))
1282                                        ((valid-type-name? (list left))
1283                                         ;; This is an explicit type conversion
1284                                         `(c::cast ,(evaluate-type-name (list left))
1285                                           ,@(parse-argument-list)))
1286                                        (t `(c::call ,left ,@(parse-argument-list))))))
1287                               ((memq right '(c::|.| c::|->|))
1288                                (next)          ; swallow operator
1289                                `(,right ,left ,(parse-primary (next))))  ; parse-name, really
1290                               ((eq right 'c::|++|)
1291                                (next)          ; swallow operator
1292                                `(c::postfix++ ,left))
1293                               ((eq right 'c::|--|)
1294                                (next)          ; swallow operator
1295                                `(c::postfix-- ,left))
1296                               (t (return left))))))
1297           (parse-primary (token)
1298               (cond ((identifierp token)
1299                        ;; nonqualified name
1300                        (let ((value (find-constant token constants)))
1301                          (cond (value
1302                                 (setq value (list value) token-list `(,@value #.*rparen-symbol* ,@token-list))
1303                                 (parse-parenthesized))
1304                                ((setq value (assoc token additional-constants))
1305                                 (cdr value))
1306                                ((and expand-macros
1307                                      (setq value (macro-definition-of-token token))
1308                                      (eq (first value) ':none))
1309                                 (setq token-list (append (expand-c-macros-in-token-list
1310                                                           (second value) nil (list token) expand-macros)
1311                                                          token-list ))
1312                                 (parse-primary (next)))
1313                                (t token))))
1314                     ((eq token *lparen-symbol*)
1315                      (let* ((save-token-list token-list)
1316                            (type-name (collect-parenthesized))
1317                            (type (valid-type-name? type-name)))
1318                        (cond (type
1319                               ;; This is a cast
1320                               ;; Doing cast here is easier but accepts some invalid programs
1321                               (progn
1322                                 `(c::cast (,type) ,(parse-unary))))
1323                              (t
1324                               ;; These are ordinary grouping parentheses
1325                               (setq token-list save-token-list)
1326                               (parse-parenthesized)))))
1327                     ((eq token 'c::|{|)
1328                      (cons 'c::curly-bracketed-list
1329                            (loop as token = (next)
1330                                  until (eq token 'c::|}|)
1331                                  do (unread token)
1332                                  collect (parse-expression)
1333                                  do (let ((delimiter (peek)))
1334                                       (case delimiter
1335                                         (c::|,| (next))
1336                                         (c::|}| )
1337                                         (otherwise
1338                                          (fail "~A where , or } was expected" delimiter)))))))
1339                     ((numberp token) token)
1340                     ((stringp token) token)
1341                     ((eq token 'c::|::|)
1342                      (fail "Unary :: is not supported yet"))
1343                     (t (fail "~A is unrecognized syntax in an expression" token))))
1344           (parse-parenthesized ()
1345             (prog1 (parse-expression)
1346               (let ((close (next)))
1347                 (unless (eq close *rparen-symbol*)
1348                   (fail "~A where ) was expected" close)))))
1349           (parse-argument-list ()
1350             (if (eq (peek) *rparen-symbol*)
1351               (progn (next) '())
1352               (loop as arg = (parse-expression)
1353                     as delimiter = (next)
1354                     collect arg
1355                     do (unless (or (eq delimiter 'c::|,|) (eq delimiter *rparen-symbol*))
1356                          (fail "~A where , or ) expected in function arguments"
1357                                delimiter))
1358                     while (eq delimiter 'c::|,|))))
1359           (collect-macro-arguments ()
1360             (loop with done = nil with first = t
1361                   collect (loop as token = (next) with level = 0
1362                                 do (cond ((eq token *lparen-symbol*) (incf level))
1363                                          ((eq token *rparen-symbol*)
1364                                           (when first   ; () has to be treated as a special case
1365                                             (return-from collect-macro-arguments '()))
1366                                           (if (plusp level) (decf level) (setq done t))))
1367                                    (setq first nil)
1368                                 until (or done (and (zerop level) (eq token 'c::|,|)))
1369                                 collect token)
1370                   until done))
1371           
1372           ;;--- The following type-name routines don't support the full C++ syntax
1373           ;;--- Maybe we will add ::, arrays, functions, and God knows what later
1374           (valid-type-name? (token-list &optional tailp)
1375             (let* ((type (ignore-errors (parse-c-ffi-type token-list))))
1376               tailp
1377               (return-from valid-type-name?
1378                 (if (and type (not (eq type *the-ffi-void-type*)))
1379                   type)))
1380                                             
1381             ;; At least one type-specifier followed by an optional abstract-declarator
1382             ;; For now the type-specifier cannot contain :: and the only
1383             ;; abstract-declarators we accept are stars (not functions, arrays)
1384             (cond ((null token-list) tailp)
1385                   ((member (car token-list) '(c::|long| c::|short| c::|signed| c::|unsigned|))
1386                    (valid-type-name? (cdr token-list) t))
1387                   ((and (identifierp (car token-list))
1388                         (find-user-or-primitive-type (car token-list)))
1389                    (valid-type-name? (cdr token-list) t))
1390                   ;((eq (car token-list) '|::|) (valid-type-name? (cdr token-list)))
1391                   ((and tailp (eq (car token-list) 'c::|*|))
1392                    (valid-type-name? (cdr token-list) t))
1393                   (t nil))))
1394    (prog1 (parse-expression)
1395      (when token-list
1396        (fail "~{~A ~} left over after expression" token-list)))))
1397
1398(defun c-parse-error (stream format &rest args)
1399  (declare (ignore stream))
1400  (apply #'error format args))
1401
1402(defun macro-definition-of-token (x)
1403  (declare (ignore x)))
1404
1405(defun c-stringize-token-list (tokens)
1406  (apply #'concatenate 'string (mapcar #'c-stringize-token tokens)))
1407
1408(defun c-stringize-token (token)
1409  (etypecase token
1410    (symbol (string token))
1411    (string token)
1412    (number (princ-to-string token))))
1413
1414(defun install-new-db-files (ftd d)
1415  (let* ((dir (merge-pathnames (interface-dir-subdir d)
1416                               (ftd-interface-db-directory ftd))))
1417    (flet ((rename-and-reopen (was-open path newpath)
1418             (let* ((path (merge-pathnames path dir))
1419                    (newpath (merge-pathnames newpath dir)))
1420               (when was-open
1421                 (cdb-close was-open))
1422               (when (probe-file path)
1423                 (rename-file path
1424                              (concatenate 'string (namestring (truename path)) "-BAK")
1425                              :if-exists :supersede))
1426               (rename-file newpath path)
1427               (when was-open
1428                 (cdb-open path)))))
1429      (without-interrupts
1430       (setf (interface-dir-constants-interface-db-file d)
1431             (rename-and-reopen
1432              (interface-dir-constants-interface-db-file d)
1433              "constants.cdb"
1434              "new-constants.cdb"))
1435       (setf (interface-dir-functions-interface-db-file d)
1436             (rename-and-reopen
1437              (interface-dir-functions-interface-db-file d)
1438              "functions.cdb"
1439              "new-functions.cdb"))
1440       (setf (interface-dir-records-interface-db-file d)
1441             (rename-and-reopen
1442              (interface-dir-records-interface-db-file d)
1443              "records.cdb"
1444              "new-records.cdb"))
1445       (setf (interface-dir-types-interface-db-file d)
1446             (rename-and-reopen
1447              (interface-dir-types-interface-db-file d)
1448              "types.cdb"
1449              "new-types.cdb"))
1450       (setf (interface-dir-vars-interface-db-file d)
1451             (rename-and-reopen
1452              (interface-dir-vars-interface-db-file d)
1453              "vars.cdb"
1454              "new-vars.cdb"))
1455       (setf (interface-dir-objc-classes-interface-db-file d)
1456             (rename-and-reopen
1457              (interface-dir-objc-classes-interface-db-file d)
1458              "objc-classes.cdb"
1459              "new-objc-classes.cdb"))
1460       (setf (interface-dir-objc-methods-interface-db-file d)
1461             (rename-and-reopen
1462              (interface-dir-objc-methods-interface-db-file d)
1463              "objc-methods.cdb"
1464              "new-objc-methods.cdb")))))
1465  t)
1466
1467
Note: See TracBrowser for help on using the repository browser.