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

Last change on this file since 11805 was 11805, checked in by gz, 11 years ago

Make the compiler scan format strings for possible errors. ccl::*format-arg-functions* is the alist of functions that should be scanned (so setting this to nil is a way to disable the scanning). The code to actually do the scanning is in format.lisp. It doesn't seem to slow down the compiler in any noticable way. It finds some cases of insufficient args in format strings in ccl sources, I'll fix those in a separate checkin later.

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