;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 2001-2009 Clozure Associates
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")

(defvar *parse-ffi-target-ftd* *target-ftd*)
(defvar *ffi-lisp-readtable* (copy-readtable nil))
(defvar *ffi-ordinal* -1)
(defpackage "C" (:use))
(defvar *lparen-symbol* (intern "(" (find-package "C")))
(defvar *rparen-symbol* (intern ")" (find-package "C")))
(defvar *leftbracket-symbol* (intern "[" (find-package "C")))
(defvar *rightbracket-symbol* (intern "]" (find-package "C")))
(defvar *sharp-symbol* (intern "#" (find-package "C")))
(defvar *sharp-sharp-symbol* (intern "##" (find-package "C")))
(defvar *comma-symbol* (intern "," (find-package "C")))


(defstruct (ffi-macro (:include ffi-type))
  args
  expansion
  disposition
  tokens
  expression )

(defstruct (ffi-enum (:include ffi-type)))

(defvar *ffi-typedefs*)
(defvar *ffi-global-typedefs* nil)
(defvar *ffi-unions*)
(defvar *ffi-global-unions* nil)
(defvar *ffi-transparent-unions* nil)
(defvar *ffi-global-transparent-unions* nil)
(defvar *ffi-structs*)
(defvar *ffi-global-structs* nil)
(defvar *ffi-functions*)
(defvar *ffi-global-functions* nil)
(defvar *ffi-global-constants* nil)
(defvar *ffi-global-vars* nil)
(defvar *ffi-objc-classes* nil)
(defvar *ffi-global-objc-classes* nil)
(defvar *ffi-global-objc-messages* nil)
;;; Some things are just too hard to parse, but are important.
;;; Override those things with simpler versions.
(defvar *ffi-macro-overrides*
  '((:macro ("{override}" 0) "_IOC_TYPECHECK ( t )" "sizeof(t)")))

(defvar *ffi-void-reference* '(:primitive :void))



(defun find-or-create-ffi-struct (string)
  (or (gethash string *ffi-structs*)
      (setf (gethash string *ffi-structs*)
            (make-ffi-struct :string string
                             :name (unless (digit-char-p (schar string 0))
                                     (escape-foreign-name string))))))

(defun find-or-create-ffi-union (string)
  (or (gethash string *ffi-unions*)
      (setf (gethash string *ffi-unions*)
            (make-ffi-union :string string
                            :name (unless (digit-char-p (schar string 0))
                                    (escape-foreign-name string))))))

(defun find-or-create-ffi-transparent-union (string)
  (or (gethash string *ffi-transparent-unions*)
      (setf (gethash string *ffi-transparent-unions*)
            (make-ffi-transparent-union :string string
                                        :name (unless (digit-char-p (schar string 0))
                                                (escape-foreign-name string))))))

(defun find-or-create-ffi-objc-class (string)
  (or (gethash string *ffi-objc-classes*)
      (setf (gethash string *ffi-objc-classes*)
            (make-ffi-objc-class :string string
                                 :name (escape-foreign-name string)))))

(defun find-or-create-ffi-objc-message (string)
  (or (gethash string *ffi-global-objc-messages*)
      (setf (gethash string *ffi-global-objc-messages*)
            (make-ffi-objc-message :string string))))

(defun find-or-create-ffi-typedef (string)
  (or (gethash string *ffi-typedefs*)
      (setf (gethash string *ffi-typedefs*)
            (make-ffi-typedef :string string
                              :name (escape-foreign-name string)))))

(defun eval-complex-c-expression (string constant-alist)
  (declare (ignore string constant-alist)))

(defun eval-c-float-string (string)
  (setq string (nstring-upcase string))
  ;; Make the c float string (which may contain trailing garbage)
  ;; look enough like a lisp float string that READ-FROM-STRING will
  ;; work.
  ;; There can be some trailing garbage on the string, or it might
  ;; end in a decimal point.
  ;; The trailing garbage might be a size specifier : #\L or #\F,
  ;; to denote a LONG-DOUBLE or a (single) FLOAT.
  ;; MCL can't deal with LONG-DOUBLEs, and will assume that an
  ;; unqualified float constant is a SINGLE-FLOAT (or whatever
  ;; *READ-DEFAULT-FLOAT-FORMAT* says.  We may have to add or
  ;; change an exponent marker.
  (let* ((lastpos (1- (length string)))
         (lastchar (schar string lastpos))
         (size :double))
    (case lastchar
      (#\L (setq size :long-double) (setf (schar string lastpos) #\Space))
      (#\F (setq size :single) (setf (schar string lastpos) #\Space))
      (#\. (setq string (concatenate 'string string "0"))))
    (unless (eq size :long-double)
      (let* ((epos (position #\E string))
             (dpos (position #\D string)))
        (if (eq size :double)
          (if epos
            (setf (schar string epos) #\d)
            (setq string (concatenate 'string string "d0")))
          (if dpos
            (setf (schar string dpos) #\e))))
      (values (ignore-errors (let* ((*readtable* *ffi-lisp-readtable*))
                               (read-from-string string)))))))

(defun read-c-number (stream char)
  (loop collect char into chars
        with class = :integer
        with hex = nil
        with octal = (eql char #\0)
        do (setq char (read-char stream nil nil))
        while (or (find char "0123456789abcdefABCDEFxulXUL.")
                  (and (find char "+-")
                       (char-equal (car (last chars)) #\e)))   ;signed exponent
        do (cond ((char-equal char #\x) 
                  (setq hex t octal nil))
                 ((and (not hex) (or (char-equal char #\.) (char-equal char #\e)))
                  (setq class :float)))
        finally
        (when char (unread-char char stream))
        (setq chars (coerce chars 'string))
        (if (eq class :integer)
          (return
            (values
             (ignore-errors
               (parse-integer chars
                              :start (if hex 2 0)
                              :radix (if hex 16 (if octal 8 10))
                              :junk-allowed t))))
          (return (eval-c-float-string chars)))))

(defun eval-c-number (string char)
  (loop collect char into chars
        with class = :integer
        with hex = nil
        with octal = (eql char #\0)
        with len = (length string)
        with i = 0
        do (setq char (if (< (incf i) len) (schar string i)))
        while (or (find char "0123456789abcdefABCDEFxulXUL.")
                  (and (find char "+-")
                       (char-equal (car (last chars)) #\e)))   ;signed exponent
        do (cond ((char-equal char #\x) 
                  (setq hex t octal nil))
                 ((and (not hex) (or (char-equal char #\.) (char-equal char #\e)))
                  (setq class :float)))
        finally
          (setq chars (coerce chars 'string))
          (if (eq class :integer)
            (return
              (values
               (ignore-errors
                 (parse-integer chars
                                :start (if hex 2 0)
                                :radix (if hex 16 (if octal 8 10))
                                :junk-allowed t))))
            (return (eval-c-float-string chars)))))

;;; For our purposes (evaluating constant expressions in C macros),
;;; we don't have to get this exactly right (since the result is
;;; only going to be used in a size-of or cast operation.)
;;; All pointer types would therefore look identical.

(defvar *the-ffi-pointer-type* (parse-foreign-type '(* t)))

;;; If we don't get this right the first time, we never will;
;;; if there's nothing better, just return the void type.

(defvar *the-ffi-void-type* (parse-foreign-type :void))

(defun parse-c-ffi-type (spec)
  (flet ((parse-it-or-lose (spec)
           (or (ignore-errors (parse-foreign-type spec))
               *the-ffi-void-type*))
         (make-type-name (name)
	   (escape-foreign-name (string name))))
    (cond ((eq (car (last spec)) 'c::*) *the-ffi-pointer-type*)
          ((member (car spec) '(c::|struct| c::|union|))
           (parse-it-or-lose (mapcar #'make-type-name spec)))
          ((null (cdr spec))
           (parse-it-or-lose (make-type-name (car spec))))
          (t
           ;;; A qualified primitive type
           (let* ((primitive (parse-it-or-lose (make-type-name (car (last spec))))))
             (if (eq primitive *the-ffi-void-type*)
               primitive
               (let* ((long 0)
                      (explicitly-signed nil))
                 (declare (fixnum long))
                 (if
                   (dolist (token (butlast spec) t)
                     (case token
                       (c::|unsigned| (setq explicitly-signed :unsigned))
                       (c::|signed| (setq explicitly-signed :signed))
                       (c::|long| (incf long))
                       (c::|short| (decf long))
                       (t (return nil))))
                   (cond ((typep primitive 'foreign-integer-type)
                          (let* ((prim-bits (foreign-type-bits primitive))
                                 (prim-signed (foreign-integer-type-signed primitive)))
                            (if (> long 1)
                              (make-foreign-integer-type :bits 64
                                                         :signed (or (not explicitly-signed)
                                                                     (eq explicitly-signed :signed)))
                              (if (< long 0)
                                (make-foreign-integer-type :bits 16
                                                           :signed (or (not explicitly-signed)
                                                                       (eq explicitly-signed :signed)))
                                (if (= long 1)
                                  (make-foreign-integer-type :bits 32
                                                             :signed (or (not explicitly-signed)
                                                                         (eq explicitly-signed :signed)))
                                  (make-foreign-integer-type :bits prim-bits
                                                             :signed
                                                             (case explicitly-signed
                                                               (:signed t)
                                                               (:unsigned nil)
                                                               (t prim-signed))))))))
                         ((and (= long 1)
                               (typep primitive 'foreign-double-float-type))
                          (parse-it-or-lose :long-double))
                         (t *the-ffi-void-type*))
                   *the-ffi-void-type*))))))))
                                                               
(defun eval-parsed-c-expression (expression constant-alist)
  (if (atom expression)
    (if (identifierp expression)
      (find-constant expression constant-alist)
      (if (typep expression 'character)
        (char-code expression)
        expression))
    (let* ((operator (car expression))
           (operands (cdr expression))
           (noperands (length operands)))
      (case operator
        (c::resolve-type (let* ((foreign-type  (ignore-errors (parse-c-ffi-type (car operands)))))
                           (when foreign-type
                             (setf (cdr expression) nil
                                   (car expression) foreign-type)
                             )))
        (c::curly-bracketed-list ())
        (t
         (if (typep operator 'foreign-type)
           operator
         (when (do* ((tail (cdr expression) (cdr tail)))
                    ((null tail) t)
                 (let* ((expr (car tail))
                        (value (eval-parsed-c-expression expr constant-alist)))
                   (unless value (return))
                   (unless (eq expr value)
                     (rplaca tail value))))
           (case noperands
             (1
              (let* ((operand (cadr expression)))
                (case operator
                  (c::! (if (zerop operand) 1 0))
                  (c::- (- operand))
		  (c::+ operand)
                  (c::~ (lognot operand))
                  (c::size-of
                   (let* ((bits (ignore-errors (ensure-foreign-type-bits operand))))
                     (when bits
                       (ash (+ bits 7) -3))))
                  (t
                   ;(break "~s" expression)
		   nil))))
             (2
              (let* ((a (car operands))
                     (b (cadr operands)))
                (case operator
                  (c::<< (ash a b))
                  (c::>> (ash a (- b)))
                  (c::* (* a b))
                  (c::/ (if (zerop b) 0 (values (floor a b)))) ; or maybe TRUNCATE ?
                  (c::+ (+ a b))
                  (c::- (- a b))
                  (c::\| (logior a b))
                  (c::\& (logand a b))
                  (c::cast (if (foreign-typep (setq b (eval-parsed-c-expression b constant-alist)) a)
                             b
                             (if (and (typep a 'foreign-integer-type)
                                      (not (foreign-integer-type-signed a))
                                      (typep b 'integer)
                                      (not (> (integer-length b)
                                              (foreign-integer-type-bits a))))
                               (logand b (1- (ash 1 (foreign-integer-type-bits a))))
                               (if (and (typep a 'foreign-pointer-type)
                                        (typep b 'integer)
                                        (<= (integer-length b) 16))
                                 (progn                                   
                                   (%int-to-ptr (logand b #xffffffff)))))))
                               
                                           
                  (t 
		   ;(break "binary op = ~s ~s ~s" operator a b)
		   nil))))
             (t
              ;(break "expression = ~s" expression)
	      nil)))))))))

(defun eval-c-expression (macro constant-alist macro-table)
  (let* ((string (ffi-macro-expansion macro))
         (len (length string)))
    (if (= len 0)
      1
      (progn
        (unless (ffi-macro-tokens macro)
          (let* ((transitive (gethash (ffi-macro-expansion macro) macro-table)))
            (if transitive
              (setf (ffi-macro-tokens macro) transitive
                    (gethash (ffi-macro-name macro) macro-table) transitive)
              (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string))
                (if error
                  (setf (ffi-macro-disposition macro) :bad-tokenize)
                  (setf (ffi-macro-tokens macro) tokens))))))
        (unless (ffi-macro-expression macro)
          (let* ((tokens (ffi-macro-tokens macro)))
            (when tokens
              (multiple-value-bind (expression error)
                  (ignore-errors (parse-c-expression tokens
                                                     :constants constant-alist
                                                     :expand-macros macro-table ))
                (if (or error (null expression))
                  (progn
                    ;(format t "~& parse failed: ~s ~s" (ffi-macro-name macro)  string)
                    ;(format t "~&  tokens = ~s, error = ~a" tokens error)
                    (setf (ffi-macro-disposition macro) :bad-parse))
                  (setf (ffi-macro-expression macro) expression))))))
        (let* ((expression (ffi-macro-expression macro)))
          (when expression (values (eval-parsed-c-expression expression constant-alist) t)))))))

;;; Repeatedly iterate over the macros until nothing new's defined.
(defun process-defined-macros (ffi-macros constant-alist parameterized-macros)
  (let* ((new-def ()))
    (loop
        (setq new-def nil)
        (dolist (macro ffi-macros)
          (unless (ffi-macro-disposition macro)
            (let* ((expansion (ffi-macro-expansion macro))
                   (name (ffi-macro-name macro))
                   (value nil))
              (if (string= name expansion)
                (setf (ffi-macro-disposition macro) t)
                (when (setq value (eval-c-expression macro constant-alist parameterized-macros))
                  (push (cons name value) constant-alist)
                  (setf (ffi-macro-disposition macro) t)
                  (setq new-def t))))))
        (unless new-def
          (return (values (reverse constant-alist) nil))))))

(defun reference-ffi-type (spec)
  (case (car spec)
    (:typedef (list :typedef (find-or-create-ffi-typedef (cadr spec))))
    (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec))))
    (:union-ref (list :union (find-or-create-ffi-union (cadr spec))))
    (:transparent-union-ref
     (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec))))
    (:enum-ref `(:primitive :signed))
    (:function `(:primitive (* t)))
    (:pointer (list :pointer (reference-ffi-type (cadr spec))))
    (:array (list :array (cadr spec) (reference-ffi-type (caddr spec))))
    (:void *ffi-void-reference*)
    (t
     (list :primitive
           (ecase (car spec)
	     (:char (if (getf (ftd-attributes *parse-ffi-target-ftd*)
                              :signed-char)
		      '(:signed 8)
		      '(:unsigned 8)))
             (:signed-char  '(:signed 8))
             (:unsigned-char '(:unsigned 8))
             (:short '(:signed 16))
             (:unsigned-short '(:unsigned 16))
             ((:vec128 :unsigned-long-long-long) '(:unsigned 128))
             (:signed-long-long-long '(:signed 128))
             (:int '(:signed 32))
             (:long (ecase (or
                            (getf
                             (ftd-attributes *parse-ffi-target-ftd*)
                             :bits-per-long)
                            (getf
                             (ftd-attributes *parse-ffi-target-ftd*)
                             :bits-per-word))
                      (32 '(:signed 32))
                      (64 '(:signed 64))))
             (:unsigned  '(:unsigned 32))
             (:unsigned-long (ecase (or
                                     (getf
                                      (ftd-attributes *parse-ffi-target-ftd*)
                                      :bits-per-long)
                                     (getf
                                      (ftd-attributes *parse-ffi-target-ftd*)
                                      :bits-per-word))
                               (32 '(:unsigned 32))
                               (64 '(:unsigned 64))))
             (:long-long '(:signed 64))
             ((:vec64 :unsigned-long-long) '(:unsigned 64))
             (:float :float)
             (:double :double)
             (:long-double :long-float)
             (:complex-int :complex-int)
             (:complex-float :complex-float)
             (:complex-double :complex-double)
             (:complex-long-double :complex-long-float)
             (:long-long-long :long-long-long)
             #|(:void :void)|#)))))
             
             
(defun process-ffi-fieldlist (fields)
  (let* ((parsed-fields ()))
    (dolist (field fields (nreverse parsed-fields))
      (let* ((field-name (escape-foreign-name (car field)))
             (field-descr (cadr field)))
        (destructuring-bind (field-type offset width)
            (cdr field-descr)
          (push (cons field-name
                      (ecase (car field-descr)
                        (:field `(,(reference-ffi-type field-type) ,(ash offset 3) ,(ash width 3)))
                        (:bitfield `((:primitive (:unsigned ,width)) ,offset ,width))))
                parsed-fields))))))

(defun process-ffi-union (form)
  (destructuring-bind (source-info string fields &optional alignform)
      (cdr form)
    (declare (ignore source-info))
    (let* ((union (find-or-create-ffi-union string)))
      (setf (ffi-union-ordinal union) (incf *ffi-ordinal*))
      (when alignform
	(setf (ffi-union-alt-alignment-bits union) (cadr alignform)))
      (unless (ffi-union-fields union)
	(setf (ffi-union-fields union)
	      (process-ffi-fieldlist fields)))
      union)))

(defun process-ffi-transparent-union (form)
  (destructuring-bind (source-info string fields &optional alignform)
      (cdr form)
    (declare (ignore source-info))
    (let* ((union (find-or-create-ffi-transparent-union string)))
      (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*))
      (when alignform
	(setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform)))
      (unless (ffi-transparent-union-fields union)
	(setf (ffi-transparent-union-fields union)
	      (process-ffi-fieldlist fields)))
      union)))

(defun process-ffi-struct (form)
  (destructuring-bind (source-info string fields &optional alignform)
      (cdr form)
    (declare (ignore source-info))
    (let* ((struct (find-or-create-ffi-struct string)))
      (setf (ffi-struct-ordinal struct) (incf *ffi-ordinal*))
      (when alignform
	(setf (ffi-struct-alt-alignment-bits struct) (cadr alignform)))
      (unless (ffi-struct-fields struct)
	(setf (ffi-struct-fields struct)
	      (process-ffi-fieldlist fields)))
      struct)))

(defun process-ffi-objc-class (form)
  (destructuring-bind (source-info class-name superclass-form protocols ivars) (cdr form)
    (declare (ignore source-info))
    (let* ((class (find-or-create-ffi-objc-class class-name)))
      (setf (ffi-objc-class-ordinal class) (incf *ffi-ordinal*))
      (unless (ffi-objc-class-super-foreign-name class)
        (let* ((super-name (car superclass-form)))
          (unless (eq super-name :void)
            (setf (ffi-objc-class-super-foreign-name class)
                  super-name))))
      (unless (ffi-objc-class-protocol-names class)
        (setf (ffi-objc-class-protocol-names class) protocols))
      (unless (ffi-objc-class-own-ivars class)
        (setf (ffi-objc-class-own-ivars class)
              (process-ffi-fieldlist ivars)))
      class)))

(defun process-ffi-objc-method (form)
  (destructuring-bind (method-type source-info class-name category-name message-name arglist result-type) form
    (declare (ignore source-info category-name))
    (let* ((flags ()))
      (if (or (eq method-type :objc-class-method)
              (eq method-type :objc-protocol-class-method))
        (setf (getf flags :class) t))
      (if (or (eq method-type :objc-protocol-class-method)
              (eq method-type :objc-protocol-instance-method))
        (setf (getf flags :protocol) t))
      (let* ((message (find-or-create-ffi-objc-message message-name))
             (class-method-p (getf flags :class))
             (method
              (make-ffi-objc-method :class-name class-name
                                    :arglist (mapcar #'reference-ffi-type
                                                     arglist)
                                    :result-type (reference-ffi-type
                                                  result-type)
                                    :flags flags)))
        (unless (dolist (m (ffi-objc-message-methods message))
                  (when (and (equal (ffi-objc-method-class-name m)
                                    class-name)
                             (eq (getf (ffi-objc-method-flags m) :class)
                                 class-method-p))
                    (return t)))
          (push method (ffi-objc-message-methods message)))))))
      
(defun process-ffi-typedef (form)
  (let* ((string (caddr form))
         (def (find-or-create-ffi-typedef string)))
    (setf (ffi-typedef-ordinal def) (incf *ffi-ordinal*))
    (unless (ffi-typedef-type def)
      (setf (ffi-typedef-type def) (reference-ffi-type (cadddr form))))
    def))


(defun process-ffi-function (form)
  (let* ((name (caddr form))
         (ftype (cadddr form)))
    (make-ffi-function :string name
                       :arglist (mapcar #'reference-ffi-type (cadr ftype))
                       :return-value (reference-ffi-type (caddr ftype)))))

(defun process-ffi-macro (form)
  (let* ((name-form (caddr form))
         (expansion (cadddr form))
         (name name-form)
         (args nil)
         (space-pos (position #\space name-form)))
    (when space-pos
      (setq name (subseq name-form 0 space-pos))
      (let* ((open-pos (position #\( name-form))
             (close-pos (position #\) name-form)))
        (when (and open-pos close-pos (> close-pos open-pos))
          (let* ((arg-string (subseq name-form open-pos close-pos))
                 (arg-tokens (ignore-errors (string-to-tokens arg-string)))
                 (arg-names (let* ((l ()))
                              (dolist (arg-token arg-tokens (nreverse l))
                                (unless (or (eq arg-token 'c::|,|)
                                            (eq arg-token *lparen-symbol*))
                                  (push arg-token l)))))
                 (body-tokens (ignore-errors (string-to-tokens expansion))))
            (when (and arg-names body-tokens)
              (setq args (list arg-names body-tokens)
                    expansion name))))))
    (make-ffi-macro :name name :args args :expansion expansion)))

(defun process-ffi-enum (form)
  (declare (ignore form)))

(defun process-ffi-var (form)
  (let* ((name (caddr form))
         (type (cadddr form)))
    (cons name (reference-ffi-type type))))

(defun process-ffi-enum-ident (form)
  (cons (caddr form) (cadddr form)))

(defun ensure-referenced-type-defined (spec)
  (declare (ignorable spec))
  (when nil
  (ecase (car spec)
    (:primitive)
    (:typedef (define-typedef-from-ffi-info (cadr spec)))
    (:struct (ensure-struct-defined (cadr spec)))
    (:union (ensure-union-defined (cadr spec)))
    (:transparent-union (ensure-transparent-union-defined (cadr spec)))
    (:pointer (ensure-referenced-type-defined (cadr spec)))
    (:array (ensure-referenced-type-defined (caddr spec)))
    (:function (dolist (arg (ffi-function-arglist (cadr spec)))
                 (ensure-referenced-type-defined arg))
               (ensure-referenced-type-defined (ffi-function-return-value (cadr spec))))
    )))

  
(defun ensure-fields-defined (fields)
  (dolist (f fields)
    (let* ((ftype (cadr f)))
      (ensure-referenced-type-defined ftype))))

(defun record-global-objc-class (c)
  (when *ffi-global-objc-classes*
    (setf (gethash (ffi-objc-class-string c) *ffi-global-objc-classes*) c)))

(defun define-objc-class-from-ffi-info (c)
  (unless (ffi-objc-class-defined c)
    (setf (ffi-objc-class-defined c) t)
    (record-global-objc-class c)
    (ensure-fields-defined (ffi-objc-class-own-ivars c))))

(defun record-global-union (u)
  (when (and *ffi-global-unions* (ffi-union-fields u))
    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))

(defun record-global-transparent-union (u)
  (when (and *ffi-global-transparent-unions* (ffi-transparent-union-fields u))
    (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u)))

(defun define-union-from-ffi-info (u)
  (unless (ffi-union-defined u)
    (setf (ffi-union-defined u) t)
    (record-global-union u)
    (when (ffi-union-name u)
      (let* ((fields (ffi-union-fields u)))
        (ensure-fields-defined fields)))))

(defun define-transparent-union-from-ffi-info (u)
  (unless (ffi-transparent-union-defined u)
    (setf (ffi-transparent-union-defined u) t)
    (record-global-transparent-union u)
    (when (ffi-transparent-union-name u)
      (let* ((fields (ffi-transparent-union-fields u)))
        (ensure-fields-defined fields)))))

(defun ensure-union-defined (u)
  (let* ((name (ffi-union-name u)))
    (if name
      (define-union-from-ffi-info u)
      (ensure-fields-defined (ffi-union-fields u)))))

(defun ensure-transparent-union-defined (u)
  (let* ((name (ffi-transparent-union-name u)))
    (if name
      (define-transparent-union-from-ffi-info u)
      (ensure-fields-defined (ffi-transparent-union-fields u)))))

(defun record-global-struct (s)
  (when (and *ffi-global-structs* (ffi-struct-fields s))
    (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s)))

(defun define-struct-from-ffi-info (s)
  (unless (ffi-struct-defined s)
    (setf (ffi-struct-defined s) t)
    (record-global-struct s)
    (when (typep (ffi-struct-name s) 'keyword)
      (let* ((fields (ffi-struct-fields s)))
        (ensure-fields-defined fields)))))

(defun ensure-struct-defined (s)
  (let* ((name (ffi-struct-name s)))
    (if (typep name 'keyword)
      (define-struct-from-ffi-info s)
      (ensure-fields-defined (ffi-struct-fields s)))))

(defun record-global-typedef (def)
  (when *ffi-global-typedefs*
    (setf (gethash (ffi-typedef-string def) *ffi-global-typedefs*) def)))
  
(defun define-typedef-from-ffi-info (def)
  (unless (ffi-typedef-defined def)
    (setf (ffi-typedef-defined def) t)
    (record-global-typedef def)
    (let* ((target (ffi-typedef-type def)))
      (unless (and (consp target)
		   (member (car target) '(:struct :union :transparent-union :primitive)))
	(ensure-referenced-type-defined target)))))

(defun record-global-constant (name val)
  (when *ffi-global-constants*
    (setf (gethash name *ffi-global-constants*) val)))
      
(defun emit-ffi-constant (name val)
  (record-global-constant name val))

(defun record-global-var (name type)
  (when *ffi-global-vars*
    (setf (gethash name *ffi-global-vars*) type)))

(defun emit-ffi-var (name type)
  (record-global-var name type))


(defun ffi-record-type-p (typeref)
  (case (car typeref)
    ((:struct :union :transparent-union) t)
    (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref))))
    (t nil)))

(defun record-global-function (ffi-function)
  (when *ffi-global-functions*
    (setf (gethash (ffi-function-string ffi-function) *ffi-global-functions*)
	  ffi-function)))

(defun emit-function-decl (ffi-function)
  (let* ((args (ffi-function-arglist ffi-function))
         (retval (ffi-function-return-value ffi-function)))
    (if (eq (car (last args)) *ffi-void-reference*)
      (setq args (butlast args)))
    (dolist (arg args) (ensure-referenced-type-defined arg))
    (ensure-referenced-type-defined retval)
    (record-global-function ffi-function)))


(defun read-ffi-toplevel-form (stream eof-value)
  (loop
    (let* ((ch (peek-char  nil stream nil eof-value)))
      (cond ((eq ch eof-value) (return eof-value))
            ((eql ch #\() (return (read stream nil eof-value)))
            (t (read-line stream))))))

(defun parse-ffi (inpath)
  (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) 
         (argument-macros (make-hash-table :test 'equal)))
    (let* ((defined-types ())
           (defined-constants ())
           (defined-macros ())
           (defined-functions ())
           (defined-vars ()))
      (with-open-file (in inpath)
        (let* ((*ffi-ordinal* -1))
          (let* ((*package* (find-package "KEYWORD")))
            (do* ((form (read-ffi-toplevel-form in :eof)
                        (read-ffi-toplevel-form in :eof)))
                 ((eq form :eof))
              (case (car form)
                (:struct (push (process-ffi-struct form) defined-types))
                (:objc-class (push (process-ffi-objc-class form) defined-types))
                ((:objc-class-method
                  :objc-instance-method
                  :objc-protocol-class-method
                  :objc-protocol-instance-method
                  )
                 (process-ffi-objc-method form))
                (:function (push (process-ffi-function form) defined-functions))
                (:macro (let* ((m (process-ffi-macro form))
                               (args (ffi-macro-args m)))
                          (if args
                            (setf (gethash (string (ffi-macro-name m)) argument-macros) args)
                            (push m defined-macros))))
                (:type (push (process-ffi-typedef form) defined-types))
                (:var (push (process-ffi-var form) defined-vars))
                (:enum-ident (push (process-ffi-enum-ident form) defined-constants))
                (:enum (process-ffi-enum form))
                (:union (push (process-ffi-union form) defined-types))
                (:transparent-union (push (process-ffi-transparent-union form) defined-types)))))
          (dolist (override *ffi-macro-overrides*)
            (let* ((m (process-ffi-macro override))
                   (args (ffi-macro-args m)))
              (if args
                (setf (gethash (string (ffi-macro-name m)) argument-macros) args)
                (push m defined-macros))))
          (multiple-value-bind (new-constants new-macros)
              (process-defined-macros defined-macros (reverse defined-constants) argument-macros)
	    ;; If we're really lucky, we might be able to turn some C macros
	    ;; into lisp macros.  We can probably turn some C macros into
	    ;; lisp constants.
            (declare (ignore new-macros))
            (dolist (x (reverse new-constants))
              (emit-ffi-constant (car x) (cdr x)))
            (dolist (x defined-vars)
              (emit-ffi-var (car x) (cdr x)))
            (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal))
              (typecase x
                (ffi-struct (define-struct-from-ffi-info x))
                (ffi-union (define-union-from-ffi-info x))
                (ffi-transparent-union (define-transparent-union-from-ffi-info x))
                (ffi-typedef (define-typedef-from-ffi-info x))
                (ffi-objc-class (define-objc-class-from-ffi-info x))))
            (dolist (f defined-functions) (emit-function-decl f))))))))

(defun parse-standard-ffi-files (dirname &optional target)
  (let* ((backend (if target (find-backend target) *target-backend*))
         (ftd (backend-target-foreign-type-data backend))
         (*parse-ffi-target-ftd* ftd)
         (*target-ftd* ftd)
         (*target-backend* backend)
	 (d (use-interface-dir dirname ftd))
	 (interface-dir (merge-pathnames
			 (interface-dir-subdir d)
			 (ftd-interface-db-directory ftd)))
	 (*prepend-underscores-to-ffi-function-names*
          (getf (ftd-attributes ftd) :prepend-underscores))
	 (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
	 (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
	 (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash)) 
	 (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash))
	 (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash))
         (*ffi-global-vars* (make-hash-table :test 'string= :hash-function 'sxhash)))
         
    (dolist (f (directory (merge-pathnames ";C;**;*.ffi"
					   interface-dir)))
      (format t "~&~s ..." f)
      (parse-ffi f )
      (format t "~&"))
    (with-new-db-file (constants-cdbm (merge-pathnames
                                       "new-constants.cdb"
                                       interface-dir))
      (maphash #'(lambda (name def)
                   (db-define-constant constants-cdbm name def))
	       *ffi-global-constants*))
    (with-new-db-file (types-cdbm (merge-pathnames
				       "new-types.cdb"
				       interface-dir))
      (maphash #'(lambda (name def)
		   (declare (ignore name))
		   (save-ffi-typedef types-cdbm def))
	       *ffi-global-typedefs*))
    (with-new-db-file (records-cdbm (merge-pathnames
                                     "new-records.cdb"
                                     interface-dir))
      (maphash #'(lambda (name def)
		   (declare (ignore name))
                   (save-ffi-union records-cdbm def))
	       *ffi-global-unions*)
      (maphash #'(lambda (name def)
                   (declare (ignore name))
                   (save-ffi-transparent-union records-cdbm def))
               *ffi-global-transparent-unions*)
                         
      (maphash #'(lambda (name def)
		   (declare (ignore name))
		   (save-ffi-struct records-cdbm def))
	       *ffi-global-structs*))
    (with-new-db-file (function-cdbm (merge-pathnames
					   "new-functions.cdb"
					   interface-dir))
      (maphash #'(lambda (name def)
		   (declare (ignore name))
		   (save-ffi-function function-cdbm def))
	       *ffi-global-functions*))
    (with-new-db-file (class-cdbm (merge-pathnames
                                   "new-objc-classes.cdb"
                                   interface-dir))
      (maphash #'(lambda (name def)
                   (declare (ignore name))
                   (save-ffi-objc-class class-cdbm def))
               *ffi-global-objc-classes*))
    (with-new-db-file (vars-cdbm (merge-pathnames
                             "new-vars.cdb"
                             interface-dir))
      (maphash #'(lambda (name type)
                   (db-define-var vars-cdbm name type))
               *ffi-global-vars*))
    (with-new-db-file (methods-cdbm  (merge-pathnames
                                      "new-objc-methods.cdb"
                                      interface-dir))
      (maphash #'(lambda (name message)
                   (declare (ignore name))
                   (save-ffi-objc-message methods-cdbm message))
               *ffi-global-objc-messages*))
    (install-new-db-files ftd d)))

(defvar *c-readtable* (copy-readtable nil))
(setf (readtable-case *c-readtable*) :preserve)


;;; Each element of operators can be a symbol or a list of a symbol, a
;;; function, and args All the symbols must start with the character
;;; for which this is the macro-character fcn The entries must be in
;;; the right order, e.g. dictionary order, so any two symbols with a
;;; common prefix are adjacent in the list.  Furthermore each symbol
;;; in the list must be preceded by every non-empty leading substring
;;; of that symbol, since we only have one character of look-ahead in
;;; the stream.
(defun operator-macro (operators)
  ;; The tree is an alist keyed by character (with a nil key at the end for the default)
  ;; The cdr of each entry is either a symbol to produce, another decision tree,
  ;; or a list of a function to call and additional arguments for the function
  (let ((decision-tree (make-decision-tree operators)))
    (labels ((read-c-operator (stream char)
               (declare (ignore char))
               (loop with decision-tree = decision-tree
                     as char = (read-char stream nil nil)   ; eof => nil which works too
                     as elem = (assoc char decision-tree)
                     do (unless elem
                          (unread-char char stream)
                          (setq elem (assoc nil decision-tree)))
                        (setq elem (cdr elem))
                        (cond ((symbolp elem) 
                               (return elem))
                              ((symbolp (car elem)) 
                               (return (apply (car elem) stream (cdr elem))))
                              (t (setq decision-tree elem)))))
             (read-c-singleton-operator (stream char)
               (declare (ignore stream char))
               (first operators))
             (read-c-macro-character (stream char)
               (declare (ignore char))
               (apply (car decision-tree) stream (cdr decision-tree))))
      (cond ((symbolp decision-tree) #'read-c-singleton-operator)
            ((consp (car decision-tree)) #'read-c-operator)
            (t #'read-c-macro-character)))))

(defun make-decision-tree (operators)
  (labels ((recurse (operators chars-so-far) ;returns new operators and decision tree element
             (let ((next-char (aref (key (first operators))
                                    (length chars-so-far)))
                   (alist nil))
               (setq chars-so-far (append chars-so-far (list next-char)))
               (loop while operators
                 as key = (key (first operators))
                 while (every #'char= key chars-so-far)
                 do (if (= (length key) (length chars-so-far))
                      (push (cons nil (val (pop operators))) alist)
                      (multiple-value-bind (remaining-operators elem)
                          (recurse operators chars-so-far)
                        (push elem alist)
                        (setq operators remaining-operators))))
               (values operators 
                       (cons next-char (if (cdr alist) alist (cdar alist))))))
           (key (operator)
             (string (if (atom operator) operator (car operator))))
           (val (operator)
             (if (atom operator) operator (cdr operator))))
    (multiple-value-bind (left-over elem) (recurse operators nil)
      (when left-over
        (error "Malformed operators list ~S:~S" (ldiff operators left-over) left-over))
      (cdr elem))))

;;; Doesn't support the L prefix for wide characters.  What a complete kludge!
(defun c-read-string (stream single-quote)
  (loop with delimiter = (if single-quote #\' #\")
        as char = (read-char stream nil nil)
        do (cond ((null char)
                  (c-parse-error stream "Unmatched ~A" delimiter))
                 ((char= char delimiter)

                  (return (if single-quote
                              (char-code (car chars))
                              (coerce chars 'string))))
                 ((char= char #\\)
                  (setq char (read-char stream nil nil))
                  (unless char (c-parse-error stream "EOF after backslash in string"))
                  (let ((tem (assoc char '((#\n . #\newline)
                                           (#\t . #\tab)
                                           (#\v . #\^K)
                                           (#\b . #\backspace)
                                           (#\r . #\return)
                                           (#\f . #\page)
                                           (#\a . #\bell)
                                           (#\\ . #\\)
                                           (#\? . #\?)
                                           (#\' . #\')
                                           (#\" . #\")))))
                    (cond (tem (setq char (cdr tem)))
                          ((char<= #\0 char #\7)
                           (setq char (loop while (char<= #\0 char #\7) for count from 1
                                            with sum = 0
                                            do (setq sum (+ (* sum 8) (digit-char-p char)))
                                               (setq char (read-char stream nil nil))
                                            until (= count 3)
                                            finally 
                                              (unread-char char stream)
                                              (return (code-char sum)))))
                          ((char= char #\x)
                           (setq char (loop with sum = 0
                                            as char = (read-char stream)
                                            while (or (char<= #\0 char #\9)
                                                      (char<= #\A char #\F)
                                                      (char<= #\a char #\f))
                                            do (setq sum (+ (* sum 16) (digit-char-p char 16)))
                                            finally 
                                              (unread-char char stream)
                                              (return (code-char sum)))))))))
        collect char into chars))

(dolist (char '(#\_))
  (set-syntax-from-char char #\A *c-readtable*))

(dolist (op '( (c::! c::!=)
               ((\" c-read-string nil))
               (|#| |##|)            ; # and ## are pre-processor operators
               (c::% c::%=)
               (c::& c::&= c::&&)
               ((\' c-read-string t))
               (c::\()
               (c::\))
               (c::* c::*=)
               (c::+ c::+= c::++)
               (c::- c::-= c::-- c::->)
               (c::\,)
               (c::|.| c::|.*| c::|..| c::|...|)                 ; .01 will fail to parse as 0.01
               (c::/ c::/= (// c-read-line-comment) (/* c-read-block-comment))
               (c::\: c::\:\:)
               (c::\;)
               (c::< c::<= c::<< c::<<=)
               (c::= c::==)
               (c::> c::>= c::>> c::>>=)
               (c::?)
               (c::[)
               (c::\\)
               (c::])
               (c::^ c::^=)
               (c::{)
               (c::\| c::\|= c::\|\|)
               (c::})
               (c::~)
               ;; C++ doesn't define any meaning for these, treat them as operators
               (c::\$)
               (c::\@)
               (c::\`)
               ))
  (set-macro-character (char (string (if (atom (car op)) (car op) (caar op))) 0)
                       (operator-macro op)
                       nil              ;token-terminating
                       *c-readtable*))

(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
  (set-macro-character char 'read-c-number t *c-readtable*))


(defvar *backslash-symbol* 'c::|\\|)

(defvar *pending-tokens* ())

(defun unread-token (token)
  (push token *pending-tokens*)
  token)

(defun next-token (stream)
  (if *pending-tokens*
    (pop *pending-tokens*)
    (do* ((tok (read-preserving-whitespace stream nil :eof)
                       (read-preserving-whitespace stream nil :eof)))
                 ((or (not (eq tok *backslash-symbol*))
                      (not (eq (peek-char nil stream nil nil) #\Newline)))
                  tok)     
	     ;; Consume the #\newline that followed #\\.  Yecch.
	     (read-char stream nil nil))))
              
(defun string-to-tokens (string)
  (with-input-from-string (stream string)
    (let* ((*package* (find-package "C"))
           (*readtable* *c-readtable*)
           (tokens ()))
      (loop
          (let* ((token (next-token stream)))
            (when (eq token :eof)
              (return (nreverse tokens)))
            (push token tokens))))))


(defun identifierp (token)
  (and (symbolp token)
       (let ((char (char (symbol-name token) 0)))
	 (or (alpha-char-p char) (char= char #\_)))))


(defun evaluate-type-name (x)
  (let* ((name (car x)))
    (if (and (atom name) nil (null (cdr x)))
      name)))
      

(defun find-constant (x constants)
  (when (symbolp x)
    (cdr (assoc (string x) constants :test #'string=))))

(defun find-user-or-primitive-type (x)
  x
  nil)

(defun macro-definition (id table)
  (gethash (string id) table))

(defun expand-c-macro (name parameters arguments body stream macros-not-to-expand macro-table)
  (let ((expansion nil))
    (unless (= (length arguments) (length parameters))
      (c-parse-error stream "Expected ~D argument~:P to macro ~A but got ~D argument~:P."
			 (length parameters) name (length arguments)))
    (loop while body
      as token = (pop body)
      as next = (first body)
      as argno = (position token parameters) do
      (cond ((and argno (eq next *sharp-sharp-symbol*)) ; parameter ## token/parameter
	     (pop body)
	     (setq next (pop body))
	     (let ((next-argno (position next parameters)))
	       (push (intern (concatenate 'string (c-stringize-token-list (nth argno arguments))
					  (if next-argno
					    (c-stringize-token-list (nth next-argno arguments))
					    (c-stringize-token next))))
		     expansion)))
	    (argno			; normal parameter substitution
	     (setq expansion (nreconc (expand-c-macros-in-token-list (nth argno arguments)
                                                                     stream macros-not-to-expand
                                                                     macro-table)
				      expansion)))
	    ((and (eq token *sharp-sharp-symbol*) ; token ## parameter
		  (setq argno (position next parameters)))
	     (pop body)
	     (push (intern (concatenate 'string (c-stringize-token (pop expansion))
					(c-stringize-token-list (nth argno arguments))))
		   expansion))
	    ((and (eq token *sharp-symbol*)	; # parameter
		  (setq argno (position next parameters)))
	     (pop body)
	     (push (c-stringize-token-list (nth argno arguments)) expansion))
	    (t (push token expansion))))
    (expand-c-macros-in-token-list (nreverse expansion) stream
                                   (adjoin name macros-not-to-expand)
                                   macro-table)))

(defun expand-c-macros-in-token-list (tokens stream macros-not-to-expand macro-table)
  (loop
      while tokens
    as token = (pop tokens)
    as macro = (and (symbolp token)
                    (not (member token macros-not-to-expand))
                    (macro-definition token macro-table))
    if macro
    nconc (if (eq (first macro) :none) 
            (expand-c-macros-in-token-list (second macro) stream 
                                           (adjoin token macros-not-to-expand) macro-table)
            (expand-c-macro token (first macro)
                            (let ((open (pop tokens)))
                              (unless (eq open *lparen-symbol*)
                                (c-parse-error
                                 stream
                                 "~A where open parenthesis expected after macro name ~A"
                                 open token))
                              (loop with done = nil
                                    collect
                                    (loop as token = (if tokens (pop tokens)
                                                       (c-parse-error stream
                                                                      "Unexpected impossible EOF"))
                                          with level = 0
                                          do (cond ((eq token *lparen-symbol*) (incf level))
                                                   ((eq token *rparen-symbol*)
                                                    (if (plusp level) (decf level) (setq done t))))
                                                  until (or done (and (zerop level)
                                                                      (eq token *comma-symbol*)))
                                                  collect token)
                                    until done))
                            (second macro) stream macros-not-to-expand macro-table))
    else collect token))

(defun parse-c-expression (token-list &key  constants additional-constants 
                                          expand-macros)
  (labels ((next ()
             (unless token-list
               (fail "Unterminated expression or unbalanced parentheses"))
             (pop token-list))
           (peek ()
             (car token-list))
           (unread (token)
             (push token token-list))
           (collect-parenthesized ()
             (loop with level = 0
                   as token = (next)
                   until (and (eq token *rparen-symbol*) (= level 0))
                   collect token
                   do (case token
                        (#.*lparen-symbol* (incf level))
                        (#.*rparen-symbol* (decf level)))))
           (fail (format-string &rest format-arguments)
             (apply #'c-parse-error nil format-string format-arguments))
           (parse-expression ()
             (parse-assignment))
           (parse-assignment ()
             (let ((left (parse-conditional)))
               (if (eq (peek) 'c::|=|)
                 (let ((right (progn (next) (parse-assignment))))
                   (list 'setf left right))
                 left)))
           (parse-conditional ()
             (let ((left (parse-logical-or)))
               (if (eq (peek) 'c::|?|)
                 (let ((then (progn (next) (parse-expression)))
                       (else (if (eq (peek) 'c::|:|)
                               (progn (next) (parse-conditional))
                               (fail "~A where : was expected" (peek)))))
                   (list 'if left then else))
                 left)))
           (parse-logical-or ()
             (let ((left (parse-logical-and)))
               (loop while (eq (peek) 'c::|\|\||)
                     do (setq left (list (next) left (parse-logical-and))))
               left))
           (parse-logical-and ()
             (let ((left (parse-bitwise-ior)))
               (loop while (eq (peek) 'c::|&&|)
                     do (setq left (list (next) left (parse-bitwise-ior))))
               left))
           (parse-bitwise-ior ()
             (let ((left (parse-bitwise-xor)))
               (loop while (eq (peek) 'c::|\||)
                     do (setq left (list (next) left (parse-bitwise-xor))))
               left))
           (parse-bitwise-xor ()
             (let ((left (parse-bitwise-and)))
               (loop while (eq (peek) 'c::|\^|)
                     do (setq left (list (next) left (parse-bitwise-and))))
               left))
           (parse-bitwise-and ()
             (let ((left (parse-equality)))
               (loop while (eq (peek) 'c::|&|)
                     do (setq left (list (next) left (parse-equality))))
               left))
           (parse-equality ()
             (let ((left (parse-relational)))
               (loop while (member (peek) '(c::|==| c::|!=|))
                     do (setq left (list (next) left (parse-relational))))
               left))
           (parse-relational ()
             (let ((left (parse-shift)))
               (loop while (member (peek) '(c::|<| c::|>| c::|<=| c::|>=|))
                     do (setq left (list (next) left (parse-shift))))
               left))
           (parse-shift ()
             (let ((left (parse-additive)))
               (loop while (member (peek) '(c::|<<| c::|>>|))
                     do (setq left (list (next) left (parse-additive))))
               left))
           (parse-additive ()
             (let ((left (parse-multiplicative)))
               (loop while (member (peek) '(c::|+| c::|-|))
                     do (setq left (list (next) left (parse-multiplicative))))
               left))
           (parse-multiplicative ()
             (let ((left (parse-pointer-to-member)))
               (loop while (member (peek) '(c::|*| c::|/| c::|%|))
                     do (setq left (list (next) left (parse-pointer-to-member))))
               left))
           (parse-pointer-to-member ()
             (let ((left (parse-unary)))
               (loop while (member (peek) '(c::|.*| c::|->*|))
                     do (setq left (list (next) left (parse-unary))))
               left))
           (parse-unary ()              ; subsumes parse-cast, thus accepting some invalid programs
             (let ((token (next)))      ; --- doesn't support new and delete yet
               (cond ((member token '(c::|+| c::|-| c::|!| c::|~| c::|++| c::|--|))
                      ;;--- doesn't yet have special support for calling destructors...
                      (list token (parse-unary)))
                     ((eq token 'c::|*|)
                      (list 'c::indirect (parse-unary)))
                     ((eq token 'c::|&|)
                      (list 'c::address-of (parse-unary)))
                     ((eq token 'c::|sizeof|)
                      (unless (eq (peek) *lparen-symbol*)          ; Require open paren, maybe it's really optional
                        (fail "~A where ( was expected after sizeof" (peek)))
                      (next)            ; Swallow open parenthesis
                      `(c::size-of (c::resolve-type ,(loop as token = (next)
                                                           until (eq token *rparen-symbol*)
                                                           collect token))))
                     (t (parse-postfix token)))))
           (parse-postfix (token)
             (loop with left = (parse-primary token)
                   as right =  (peek) do
                   (setq left
                         (cond ((eq right *leftbracket-symbol*)
                                (next)          ; swallow [
                                (let ((subscript (parse-expression))
                                      (delimiter (next)))
                                  (unless (eq delimiter *rightbracket-symbol*)
                                  (fail "~A where ] expected after subscript" delimiter))
                                  `(c::aref ,left ,subscript)))
                               ((eq right *lparen-symbol*)
                                (next)          ; swallow open parenthesis
                                (let ((macro (and expand-macros
                                                  (identifierp left)
                                                  (macro-definition left expand-macros))))
                                  (cond ((and macro (not (eq (first macro) ':none)))
                                         ;; Function-like macro - constant-like was alraedy handled
                                         (let ((more-tokens 
                                                (expand-c-macro left (first macro)
                                                                (collect-macro-arguments)
                                                                (second macro) nil '()
                                                                expand-macros)))
                                           (setq token-list (append more-tokens token-list))
                                           (parse-expression)))
                                        ((valid-type-name? (list left))
                                         ;; This is an explicit type conversion
                                         `(c::cast ,(evaluate-type-name (list left))
                                           ,@(parse-argument-list)))
                                        (t nil #|`(c::call ,left ,@(parse-argument-list))|#))))
                               ((memq right '(c::|.| c::|->|))
                                (next)          ; swallow operator
                                `(,right ,left ,(parse-primary (next))))  ; parse-name, really
                               ((eq right 'c::|++|)
                                (next)          ; swallow operator
                                `(c::postfix++ ,left))
                               ((eq right 'c::|--|)
                                (next)          ; swallow operator
                                `(c::postfix-- ,left))
                               (t (return left))))))
           (parse-primary (token)
               (cond ((identifierp token)
                        ;; nonqualified name
                        (let ((value (find-constant token constants)))
                          (cond (value 
                                 (setq value (list value) token-list `(,@value #.*rparen-symbol* ,@token-list))
                                 (parse-parenthesized))
                                ((setq value (assoc token additional-constants))
                                 (cdr value))
                                ((and expand-macros
                                      (setq value (macro-definition-of-token token))
                                      (eq (first value) ':none))
                                 (setq token-list (append (expand-c-macros-in-token-list 
                                                           (second value) nil (list token) expand-macros)
                                                          token-list ))
                                 (parse-primary (next)))
                                (t token))))
                     ((eq token *lparen-symbol*)
                      (let* ((save-token-list token-list)
                            (type-name (collect-parenthesized))
                            (type (valid-type-name? type-name)))
                        (cond (type
                               ;; This is a cast
                               ;; Doing cast here is easier but accepts some invalid programs
                               (progn
                                 `(c::cast (,type) ,(parse-unary))))
                              (t
                               ;; These are ordinary grouping parentheses
                               (setq token-list save-token-list)
                               (parse-parenthesized)))))
                     ((eq token 'c::|{|)
                      (cons 'c::curly-bracketed-list
                            (loop as token = (next)
                                  until (eq token 'c::|}|)
                                  do (unread token)
                                  collect (parse-expression)
                                  do (let ((delimiter (peek)))
                                       (case delimiter
                                         (c::|,| (next))
                                         (c::|}| )
                                         (otherwise 
                                          (fail "~A where , or } was expected" delimiter)))))))
                     ((numberp token) token)
                     ((stringp token) token)
                     ((eq token 'c::|::|)
                      (fail "Unary :: is not supported yet"))
                     (t (fail "~A is unrecognized syntax in an expression" token))))
           (parse-parenthesized ()
             (prog1 (parse-expression)
               (let ((close (next)))
                 (unless (eq close *rparen-symbol*)
                   (fail "~A where ) was expected" close)))))
           (parse-argument-list ()
             (if (eq (peek) *rparen-symbol*)
               (progn (next) '())
               (loop as arg = (parse-expression)
                     as delimiter = (next)
                     collect arg
                     do (unless (or (eq delimiter 'c::|,|) (eq delimiter *rparen-symbol*))
                          (fail "~A where , or ) expected in function arguments"
                                delimiter))
                     while (eq delimiter 'c::|,|))))
           (collect-macro-arguments ()
             (loop with done = nil with first = t
                   collect (loop as token = (next) with level = 0
                                 do (cond ((eq token *lparen-symbol*) (incf level))
                                          ((eq token *rparen-symbol*) 
                                           (when first   ; () has to be treated as a special case
                                             (return-from collect-macro-arguments '()))
                                           (if (plusp level) (decf level) (setq done t))))
                                    (setq first nil)
                                 until (or done (and (zerop level) (eq token 'c::|,|)))
                                 collect token)
                   until done))
           
           ;;--- The following type-name routines don't support the full C++ syntax
           ;;--- Maybe we will add ::, arrays, functions, and God knows what later
           (valid-type-name? (token-list &optional tailp)
             (let* ((type (ignore-errors (parse-c-ffi-type token-list))))
               tailp
               (return-from valid-type-name?
                 (if (and type (not (eq type *the-ffi-void-type*)))
                   type)))
                                              
             ;; At least one type-specifier followed by an optional abstract-declarator
             ;; For now the type-specifier cannot contain :: and the only
             ;; abstract-declarators we accept are stars (not functions, arrays)
             (cond ((null token-list) tailp)
                   ((member (car token-list) '(c::|long| c::|short| c::|signed| c::|unsigned|))
                    (valid-type-name? (cdr token-list) t))
                   ((and (identifierp (car token-list))
                         (find-user-or-primitive-type (car token-list)))
                    (valid-type-name? (cdr token-list) t))
                   ;((eq (car token-list) '|::|) (valid-type-name? (cdr token-list)))
                   ((and tailp (eq (car token-list) 'c::|*|))
                    (valid-type-name? (cdr token-list) t))
                   (t nil))))
    (prog1 (parse-expression)
      (when token-list
        (fail "~{~A ~} left over after expression" token-list)))))

(defun c-parse-error (stream format &rest args)
  (declare (ignore stream))
  (apply #'error format args))

(pushnew '(c-parse-error . 1) ccl::*format-arg-functions* :test #'equal)

(defun macro-definition-of-token (x)
  (declare (ignore x)))

(defun c-stringize-token-list (tokens)
  (apply #'concatenate 'string (mapcar #'c-stringize-token tokens)))

(defun c-stringize-token (token)
  (etypecase token
    (symbol (string token))
    (string token)
    (number (princ-to-string token))))

(defun install-new-db-files (ftd d)
  (let* ((dir (merge-pathnames (interface-dir-subdir d)
			       (ftd-interface-db-directory ftd))))
    (flet ((rename-and-reopen (was-open path newpath)
	     (let* ((path (merge-pathnames path dir))
		    (newpath (merge-pathnames newpath dir)))
	       (when was-open
		 (cdb-close was-open))
	       (when (probe-file path)
		 (rename-file path
			      (concatenate 'string (namestring (truename path)) "-BAK")
			      :if-exists :supersede))
	       (rename-file newpath path)
	       (when was-open
		 (cdb-open path)))))
      (without-interrupts
       (setf (interface-dir-constants-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-constants-interface-db-file d)
	      "constants.cdb"
	      "new-constants.cdb"))
       (setf (interface-dir-functions-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-functions-interface-db-file d)
	      "functions.cdb"
	      "new-functions.cdb"))
       (setf (interface-dir-records-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-records-interface-db-file d)
	      "records.cdb"
	      "new-records.cdb"))
       (setf (interface-dir-types-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-types-interface-db-file d)
	      "types.cdb"
	      "new-types.cdb"))
       (setf (interface-dir-vars-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-vars-interface-db-file d)
	      "vars.cdb"
	      "new-vars.cdb"))
       (setf (interface-dir-objc-classes-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-objc-classes-interface-db-file d)
	      "objc-classes.cdb"
	      "new-objc-classes.cdb"))
       (setf (interface-dir-objc-methods-interface-db-file d)
	     (rename-and-reopen
	      (interface-dir-objc-methods-interface-db-file d)
	      "objc-methods.cdb"
	      "new-objc-methods.cdb")))))
  t)


