source: trunk/ccl/library/parse-ffi.lisp @ 3819

Last change on this file since 3819 was 3819, checked in by gb, 14 years ago

Treat VEC64/VEC128 like large integers, for now.

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