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

Last change on this file since 16685 was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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