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

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

Recognize "transparent unions" (unions with a specified attribute);
we treat them as a separate kind of foreign-record-type, but it'd
also work to treat them as unions with a bit set somewhere.

A transparent union is just like a union in all contexts except
the case where it's passed by value to a foreign function; in that
case, things behave as if the union's first field was passed. (For
this to work, all fields must be the same size and be of types
that're passed by the same calling conventions.)

Linux uses transparent unions for a few types in socket-related
functions (so we'll have to support them when we switch l1-sockets
to use foreign-function calls instead of syscalls.) Other platforms
don't seem to use them in their standard headers (but we should
probably support the concept, just in case.)

Getting information about transparent unions into the interface
database requires changes to the ffi translator; the changes
here (mostly) deal with encoding that info to and decoding it
from the .cdb files.

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