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

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

I'm fairly sure that the primitive foreign type :long-long-long is a
128-bit integer maintained in an xmm register; I think that it only
shows up in the .ffi files because it's a gcc intrinsic type, but
really hope that it's not actually used for anything ...

:long and :unsigned-long should look first at the ftd's :bits-per-long
attribute. On our good friend win64, :long is smaller than a word.

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