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

Last change on this file since 5632 was 5632, checked in by gb, 13 years ago

Just to be on the safe side (new pathname bugs, or old ?), append -BAK to
(NAMESTRING (TRUENAME path)), not just (NAMESTRING path) when renaming.
(MERGE-PATHNAMES call is producing a pathane with a non-null VERSION component,
as it arguably should have been all along.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 61.8 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 (truename 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.