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

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

Handle casts from signed (negative) integer constants to unsigned
integer types, so (for instance) "(UNSIGNED_32_BIT_INT)-1" becomes
#xffffffff.

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