| 1 | ;;;-*-Mode: LISP; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2001 Clozure Associates |
|---|
| 4 | ;;; This file is part of OpenMCL. |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
|---|
| 10 | ;;; conflict, the preamble takes precedence. |
|---|
| 11 | ;;; |
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
|---|
| 13 | ;;; |
|---|
| 14 | ;;; The LLGPL is also available online at |
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 16 | |
|---|
| 17 | (in-package "CCL") |
|---|
| 18 | |
|---|
| 19 | (defvar *parse-ffi-target-ftd* *target-ftd*) |
|---|
| 20 | (defvar *ffi-lisp-readtable* (copy-readtable nil)) |
|---|
| 21 | (defvar *ffi-ordinal* -1) |
|---|
| 22 | (defpackage "C" (:use)) |
|---|
| 23 | (defvar *lparen-symbol* (intern "(" (find-package "C"))) |
|---|
| 24 | (defvar *rparen-symbol* (intern ")" (find-package "C"))) |
|---|
| 25 | (defvar *leftbracket-symbol* (intern "[" (find-package "C"))) |
|---|
| 26 | (defvar *rightbracket-symbol* (intern "]" (find-package "C"))) |
|---|
| 27 | (defvar *sharp-symbol* (intern "#" (find-package "C"))) |
|---|
| 28 | (defvar *sharp-sharp-symbol* (intern "##" (find-package "C"))) |
|---|
| 29 | (defvar *comma-symbol* (intern "," (find-package "C"))) |
|---|
| 30 | |
|---|
| 31 | |
|---|
| 32 | (defstruct (ffi-macro (:include ffi-type)) |
|---|
| 33 | args |
|---|
| 34 | expansion |
|---|
| 35 | disposition |
|---|
| 36 | tokens |
|---|
| 37 | expression ) |
|---|
| 38 | |
|---|
| 39 | (defstruct (ffi-enum (:include ffi-type))) |
|---|
| 40 | |
|---|
| 41 | (defvar *ffi-typedefs*) |
|---|
| 42 | (defvar *ffi-global-typedefs* nil) |
|---|
| 43 | (defvar *ffi-unions*) |
|---|
| 44 | (defvar *ffi-global-unions* nil) |
|---|
| 45 | (defvar *ffi-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 *ffi-global-unions* |
|---|
| 622 | (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u))) |
|---|
| 623 | |
|---|
| 624 | (defun record-global-transparent-union (u) |
|---|
| 625 | (when *ffi-global-transparent-unions* |
|---|
| 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 *ffi-global-structs* |
|---|
| 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 | |
|---|
| 724 | (defun parse-ffi (inpath) |
|---|
| 725 | (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 726 | (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 727 | (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 728 | (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 729 | (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 730 | (argument-macros (make-hash-table :test 'equal))) |
|---|
| 731 | (let* ((defined-types ()) |
|---|
| 732 | (defined-constants ()) |
|---|
| 733 | (defined-macros ()) |
|---|
| 734 | (defined-functions ()) |
|---|
| 735 | (defined-vars ())) |
|---|
| 736 | (with-open-file (in inpath) |
|---|
| 737 | (let* ((*ffi-ordinal* -1)) |
|---|
| 738 | (let* ((*package* (find-package "KEYWORD"))) |
|---|
| 739 | (do* ((form (read in nil :eof) (read in nil :eof))) |
|---|
| 740 | ((eq form :eof)) |
|---|
| 741 | (case (car form) |
|---|
| 742 | (:struct (push (process-ffi-struct form) defined-types)) |
|---|
| 743 | (:objc-class (push (process-ffi-objc-class form) defined-types)) |
|---|
| 744 | ((:objc-class-method |
|---|
| 745 | :objc-instance-method |
|---|
| 746 | :objc-protocol-class-method |
|---|
| 747 | :objc-protocol-instance-method |
|---|
| 748 | ) |
|---|
| 749 | (process-ffi-objc-method form)) |
|---|
| 750 | (:function (push (process-ffi-function form) defined-functions)) |
|---|
| 751 | (:macro (let* ((m (process-ffi-macro form)) |
|---|
| 752 | (args (ffi-macro-args m))) |
|---|
| 753 | (if args |
|---|
| 754 | (setf (gethash (string (ffi-macro-name m)) argument-macros) args) |
|---|
| 755 | (push m defined-macros)))) |
|---|
| 756 | (:type (push (process-ffi-typedef form) defined-types)) |
|---|
| 757 | (:var (push (process-ffi-var form) defined-vars)) |
|---|
| 758 | (:enum-ident (push (process-ffi-enum-ident form) defined-constants)) |
|---|
| 759 | (:enum (process-ffi-enum form)) |
|---|
| 760 | (:union (push (process-ffi-union form) defined-types)) |
|---|
| 761 | (:transparent-union (push (process-ffi-transparent-union form) defined-types))))) |
|---|
| 762 | (dolist (override *ffi-macro-overrides*) |
|---|
| 763 | (let* ((m (process-ffi-macro override)) |
|---|
| 764 | (args (ffi-macro-args m))) |
|---|
| 765 | (if args |
|---|
| 766 | (setf (gethash (string (ffi-macro-name m)) argument-macros) args) |
|---|
| 767 | (push m defined-macros)))) |
|---|
| 768 | (multiple-value-bind (new-constants new-macros) |
|---|
| 769 | (process-defined-macros defined-macros (reverse defined-constants) argument-macros) |
|---|
| 770 | ;; If we're really lucky, we might be able to turn some C macros |
|---|
| 771 | ;; into lisp macros. We can probably turn some C macros into |
|---|
| 772 | ;; lisp constants. |
|---|
| 773 | (declare (ignore new-macros)) |
|---|
| 774 | (dolist (x (reverse new-constants)) |
|---|
| 775 | (emit-ffi-constant (car x) (cdr x))) |
|---|
| 776 | (dolist (x defined-vars) |
|---|
| 777 | (emit-ffi-var (car x) (cdr x))) |
|---|
| 778 | (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal)) |
|---|
| 779 | (typecase x |
|---|
| 780 | (ffi-struct (define-struct-from-ffi-info x)) |
|---|
| 781 | (ffi-union (define-union-from-ffi-info x)) |
|---|
| 782 | (ffi-transparent-union (define-transparent-union-from-ffi-info x)) |
|---|
| 783 | (ffi-typedef (define-typedef-from-ffi-info x)) |
|---|
| 784 | (ffi-objc-class (define-objc-class-from-ffi-info x)))) |
|---|
| 785 | (dolist (f defined-functions) (emit-function-decl f)))))))) |
|---|
| 786 | |
|---|
| 787 | (defun parse-standard-ffi-files (dirname &optional target) |
|---|
| 788 | (let* ((backend (if target (find-backend target) *target-backend*)) |
|---|
| 789 | (ftd (backend-target-foreign-type-data backend)) |
|---|
| 790 | (*parse-ffi-target-ftd* ftd) |
|---|
| 791 | (*target-ftd* ftd) |
|---|
| 792 | (*target-backend* backend) |
|---|
| 793 | (d (use-interface-dir dirname ftd)) |
|---|
| 794 | (interface-dir (merge-pathnames |
|---|
| 795 | (interface-dir-subdir d) |
|---|
| 796 | (ftd-interface-db-directory ftd))) |
|---|
| 797 | (*prepend-underscores-to-ffi-function-names* |
|---|
| 798 | (getf (ftd-attributes ftd) :prepend-underscores)) |
|---|
| 799 | (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 800 | (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 801 | (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 802 | (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 803 | (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 804 | (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 805 | (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 806 | (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash)) |
|---|
| 807 | (*ffi-global-vars* (make-hash-table :test 'string= :hash-function 'sxhash))) |
|---|
| 808 | |
|---|
| 809 | (dolist (f (directory (merge-pathnames ";C;**;*.ffi" |
|---|
| 810 | interface-dir))) |
|---|
| 811 | (format t "~&~s ..." f) |
|---|
| 812 | (parse-ffi f ) |
|---|
| 813 | (format t "~&")) |
|---|
| 814 | (with-new-db-file (constants-cdbm (merge-pathnames |
|---|
| 815 | "new-constants.cdb" |
|---|
| 816 | interface-dir)) |
|---|
| 817 | (maphash #'(lambda (name def) |
|---|
| 818 | (db-define-constant constants-cdbm name def)) |
|---|
| 819 | *ffi-global-constants*)) |
|---|
| 820 | (with-new-db-file (types-cdbm (merge-pathnames |
|---|
| 821 | "new-types.cdb" |
|---|
| 822 | interface-dir)) |
|---|
| 823 | (maphash #'(lambda (name def) |
|---|
| 824 | (declare (ignore name)) |
|---|
| 825 | (save-ffi-typedef types-cdbm def)) |
|---|
| 826 | *ffi-global-typedefs*)) |
|---|
| 827 | (with-new-db-file (records-cdbm (merge-pathnames |
|---|
| 828 | "new-records.cdb" |
|---|
| 829 | interface-dir)) |
|---|
| 830 | (maphash #'(lambda (name def) |
|---|
| 831 | (declare (ignore name)) |
|---|
| 832 | (save-ffi-union records-cdbm def)) |
|---|
| 833 | *ffi-global-unions*) |
|---|
| 834 | (maphash #'(lambda (name def) |
|---|
| 835 | (declare (ignore name)) |
|---|
| 836 | (save-ffi-transparent-union records-cdbm def)) |
|---|
| 837 | *ffi-global-transparent-unions*) |
|---|
| 838 | |
|---|
| 839 | (maphash #'(lambda (name def) |
|---|
| 840 | (declare (ignore name)) |
|---|
| 841 | (save-ffi-struct records-cdbm def)) |
|---|
| 842 | *ffi-global-structs*)) |
|---|
| 843 | (with-new-db-file (function-cdbm (merge-pathnames |
|---|
| 844 | "new-functions.cdb" |
|---|
| 845 | interface-dir)) |
|---|
| 846 | (maphash #'(lambda (name def) |
|---|
| 847 | (declare (ignore name)) |
|---|
| 848 | (save-ffi-function function-cdbm def)) |
|---|
| 849 | *ffi-global-functions*)) |
|---|
| 850 | (with-new-db-file (class-cdbm (merge-pathnames |
|---|
| 851 | "new-objc-classes.cdb" |
|---|
| 852 | interface-dir)) |
|---|
| 853 | (maphash #'(lambda (name def) |
|---|
| 854 | (declare (ignore name)) |
|---|
| 855 | (save-ffi-objc-class class-cdbm def)) |
|---|
| 856 | *ffi-global-objc-classes*)) |
|---|
| 857 | (with-new-db-file (vars-cdbm (merge-pathnames |
|---|
| 858 | "new-vars.cdb" |
|---|
| 859 | interface-dir)) |
|---|
| 860 | (maphash #'(lambda (name type) |
|---|
| 861 | (db-define-var vars-cdbm name type)) |
|---|
| 862 | *ffi-global-vars*)) |
|---|
| 863 | (with-new-db-file (methods-cdbm (merge-pathnames |
|---|
| 864 | "new-objc-methods.cdb" |
|---|
| 865 | interface-dir)) |
|---|
| 866 | (maphash #'(lambda (name message) |
|---|
| 867 | (declare (ignore name)) |
|---|
| 868 | (save-ffi-objc-message methods-cdbm message)) |
|---|
| 869 | *ffi-global-objc-messages*)) |
|---|
| 870 | (install-new-db-files ftd d))) |
|---|
| 871 | |
|---|
| 872 | (defvar *c-readtable* (copy-readtable nil)) |
|---|
| 873 | (setf (readtable-case *c-readtable*) :preserve) |
|---|
| 874 | |
|---|
| 875 | |
|---|
| 876 | ;;; Each element of operators can be a symbol or a list of a symbol, a |
|---|
| 877 | ;;; function, and args All the symbols must start with the character |
|---|
| 878 | ;;; for which this is the macro-character fcn The entries must be in |
|---|
| 879 | ;;; the right order, e.g. dictionary order, so any two symbols with a |
|---|
| 880 | ;;; common prefix are adjacent in the list. Furthermore each symbol |
|---|
| 881 | ;;; in the list must be preceded by every non-empty leading substring |
|---|
| 882 | ;;; of that symbol, since we only have one character of look-ahead in |
|---|
| 883 | ;;; the stream. |
|---|
| 884 | (defun operator-macro (operators) |
|---|
| 885 | ;; The tree is an alist keyed by character (with a nil key at the end for the default) |
|---|
| 886 | ;; The cdr of each entry is either a symbol to produce, another decision tree, |
|---|
| 887 | ;; or a list of a function to call and additional arguments for the function |
|---|
| 888 | (let ((decision-tree (make-decision-tree operators))) |
|---|
| 889 | (labels ((read-c-operator (stream char) |
|---|
| 890 | (declare (ignore char)) |
|---|
| 891 | (loop with decision-tree = decision-tree |
|---|
| 892 | as char = (read-char stream nil nil) ; eof => nil which works too |
|---|
| 893 | as elem = (assoc char decision-tree) |
|---|
| 894 | do (unless elem |
|---|
| 895 | (unread-char char stream) |
|---|
| 896 | (setq elem (assoc nil decision-tree))) |
|---|
| 897 | (setq elem (cdr elem)) |
|---|
| 898 | (cond ((symbolp elem) |
|---|
| 899 | (return elem)) |
|---|
| 900 | ((symbolp (car elem)) |
|---|
| 901 | (return (apply (car elem) stream (cdr elem)))) |
|---|
| 902 | (t (setq decision-tree elem))))) |
|---|
| 903 | (read-c-singleton-operator (stream char) |
|---|
| 904 | (declare (ignore stream char)) |
|---|
| 905 | (first operators)) |
|---|
| 906 | (read-c-macro-character (stream char) |
|---|
| 907 | (declare (ignore char)) |
|---|
| 908 | (apply (car decision-tree) stream (cdr decision-tree)))) |
|---|
| 909 | (cond ((symbolp decision-tree) #'read-c-singleton-operator) |
|---|
| 910 | ((consp (car decision-tree)) #'read-c-operator) |
|---|
| 911 | (t #'read-c-macro-character))))) |
|---|
| 912 | |
|---|
| 913 | (defun make-decision-tree (operators) |
|---|
| 914 | (labels ((recurse (operators chars-so-far) ;returns new operators and decision tree element |
|---|
| 915 | (let ((next-char (aref (key (first operators)) |
|---|
| 916 | (length chars-so-far))) |
|---|
| 917 | (alist nil)) |
|---|
| 918 | (setq chars-so-far (append chars-so-far (list next-char))) |
|---|
| 919 | (loop while operators |
|---|
| 920 | as key = (key (first operators)) |
|---|
| 921 | while (every #'char= key chars-so-far) |
|---|
| 922 | do (if (= (length key) (length chars-so-far)) |
|---|
| 923 | (push (cons nil (val (pop operators))) alist) |
|---|
| 924 | (multiple-value-bind (remaining-operators elem) |
|---|
| 925 | (recurse operators chars-so-far) |
|---|
| 926 | (push elem alist) |
|---|
| 927 | (setq operators remaining-operators)))) |
|---|
| 928 | (values operators |
|---|
| 929 | (cons next-char (if (cdr alist) alist (cdar alist)))))) |
|---|
| 930 | (key (operator) |
|---|
| 931 | (string (if (atom operator) operator (car operator)))) |
|---|
| 932 | (val (operator) |
|---|
| 933 | (if (atom operator) operator (cdr operator)))) |
|---|
| 934 | (multiple-value-bind (left-over elem) (recurse operators nil) |
|---|
| 935 | (when left-over |
|---|
| 936 | (error "Malformed operators list ~S:~S" (ldiff operators left-over) left-over)) |
|---|
| 937 | (cdr elem)))) |
|---|
| 938 | |
|---|
| 939 | ;;; Doesn't support the L prefix for wide characters. What a complete kludge! |
|---|
| 940 | (defun c-read-string (stream single-quote) |
|---|
| 941 | (loop with delimiter = (if single-quote #\' #\") |
|---|
| 942 | as char = (read-char stream nil nil) |
|---|
| 943 | do (cond ((null char) |
|---|
| 944 | (c-parse-error stream "Unmatched ~A" delimiter)) |
|---|
| 945 | ((char= char delimiter) |
|---|
| 946 | |
|---|
| 947 | (return (if single-quote |
|---|
| 948 | (char-code (car chars)) |
|---|
| 949 | (coerce chars 'string)))) |
|---|
| 950 | ((char= char #\\) |
|---|
| 951 | (setq char (read-char stream nil nil)) |
|---|
| 952 | (unless char (c-parse-error stream "EOF after backslash in string")) |
|---|
| 953 | (let ((tem (assoc char '((#\n . #\newline) |
|---|
| 954 | (#\t . #\tab) |
|---|
| 955 | (#\v . #\^K) |
|---|
| 956 | (#\b . #\backspace) |
|---|
| 957 | (#\r . #\return) |
|---|
| 958 | (#\f . #\page) |
|---|
| 959 | (#\a . #\bell) |
|---|
| 960 | (#\\ . #\\) |
|---|
| 961 | (#\? . #\?) |
|---|
| 962 | (#\' . #\') |
|---|
| 963 | (#\" . #\"))))) |
|---|
| 964 | (cond (tem (setq char (cdr tem))) |
|---|
| 965 | ((char<= #\0 char #\7) |
|---|
| 966 | (setq char (loop while (char<= #\0 char #\7) for count from 1 |
|---|
| 967 | with sum = 0 |
|---|
| 968 | do (setq sum (+ (* sum 8) (digit-char-p char))) |
|---|
| 969 | (setq char (read-char stream nil nil)) |
|---|
| 970 | until (= count 3) |
|---|
| 971 | finally |
|---|
| 972 | (unread-char char stream) |
|---|
| 973 | (return (code-char sum))))) |
|---|
| 974 | ((char= char #\x) |
|---|
| 975 | (setq char (loop with sum = 0 |
|---|
| 976 | as char = (read-char stream) |
|---|
| 977 | while (or (char<= #\0 char #\9) |
|---|
| 978 | (char<= #\A char #\F) |
|---|
| 979 | (char<= #\a char #\f)) |
|---|
| 980 | do (setq sum (+ (* sum 16) (digit-char-p char 16))) |
|---|
| 981 | finally |
|---|
| 982 | (unread-char char stream) |
|---|
| 983 | (return (code-char sum))))))))) |
|---|
| 984 | collect char into chars)) |
|---|
| 985 | |
|---|
| 986 | (dolist (char '(#\_)) |
|---|
| 987 | (set-syntax-from-char char #\A *c-readtable*)) |
|---|
| 988 | |
|---|
| 989 | (dolist (op '( (c::! c::!=) |
|---|
| 990 | ((\" c-read-string nil)) |
|---|
| 991 | (|#| |##|) ; # and ## are pre-processor operators |
|---|
| 992 | (c::% c::%=) |
|---|
| 993 | (c::& c::&= c::&&) |
|---|
| 994 | ((\' c-read-string t)) |
|---|
| 995 | (c::\() |
|---|
| 996 | (c::\)) |
|---|
| 997 | (c::* c::*=) |
|---|
| 998 | (c::+ c::+= c::++) |
|---|
| 999 | (c::- c::-= c::-- c::->) |
|---|
| 1000 | (c::\,) |
|---|
| 1001 | (c::|.| c::|.*| c::|..| c::|...|) ; .01 will fail to parse as 0.01 |
|---|
| 1002 | (c::/ c::/= (// c-read-line-comment) (/* c-read-block-comment)) |
|---|
| 1003 | (c::\: c::\:\:) |
|---|
| 1004 | (c::\;) |
|---|
| 1005 | (c::< c::<= c::<< c::<<=) |
|---|
| 1006 | (c::= c::==) |
|---|
| 1007 | (c::> c::>= c::>> c::>>=) |
|---|
| 1008 | (c::?) |
|---|
| 1009 | (c::[) |
|---|
| 1010 | (c::\\) |
|---|
| 1011 | (c::]) |
|---|
| 1012 | (c::^ c::^=) |
|---|
| 1013 | (c::{) |
|---|
| 1014 | (c::\| c::\|= c::\|\|) |
|---|
| 1015 | (c::}) |
|---|
| 1016 | (c::~) |
|---|
| 1017 | ;; C++ doesn't define any meaning for these, treat them as operators |
|---|
| 1018 | (c::\$) |
|---|
| 1019 | (c::\@) |
|---|
| 1020 | (c::\`) |
|---|
| 1021 | )) |
|---|
| 1022 | (set-macro-character (char (string (if (atom (car op)) (car op) (caar op))) 0) |
|---|
| 1023 | (operator-macro op) |
|---|
| 1024 | nil ;token-terminating |
|---|
| 1025 | *c-readtable*)) |
|---|
| 1026 | |
|---|
| 1027 | (dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) |
|---|
| 1028 | (set-macro-character char 'read-c-number t *c-readtable*)) |
|---|
| 1029 | |
|---|
| 1030 | |
|---|
| 1031 | (defvar *backslash-symbol* 'c::|\\|) |
|---|
| 1032 | |
|---|
| 1033 | (defvar *pending-tokens* ()) |
|---|
| 1034 | |
|---|
| 1035 | (defun unread-token (token) |
|---|
| 1036 | (push token *pending-tokens*) |
|---|
| 1037 | token) |
|---|
| 1038 | |
|---|
| 1039 | (defun next-token (stream) |
|---|
| 1040 | (if *pending-tokens* |
|---|
| 1041 | (pop *pending-tokens*) |
|---|
| 1042 | (do* ((tok (read-preserving-whitespace stream nil :eof) |
|---|
| 1043 | (read-preserving-whitespace stream nil :eof))) |
|---|
| 1044 | ((or (not (eq tok *backslash-symbol*)) |
|---|
| 1045 | (not (eq (peek-char nil stream nil nil) #\Newline))) |
|---|
| 1046 | tok) |
|---|
| 1047 | ;; Consume the #\newline that followed #\\. Yecch. |
|---|
| 1048 | (read-char stream nil nil)))) |
|---|
| 1049 | |
|---|
| 1050 | (defun string-to-tokens (string) |
|---|
| 1051 | (with-input-from-string (stream string) |
|---|
| 1052 | (let* ((*package* (find-package "C")) |
|---|
| 1053 | (*readtable* *c-readtable*) |
|---|
| 1054 | (tokens ())) |
|---|
| 1055 | (loop |
|---|
| 1056 | (let* ((token (next-token stream))) |
|---|
| 1057 | (when (eq token :eof) |
|---|
| 1058 | (return (nreverse tokens))) |
|---|
| 1059 | (push token tokens)))))) |
|---|
| 1060 | |
|---|
| 1061 | |
|---|
| 1062 | (defun identifierp (token) |
|---|
| 1063 | (and (symbolp token) |
|---|
| 1064 | (let ((char (char (symbol-name token) 0))) |
|---|
| 1065 | (or (alpha-char-p char) (char= char #\_))))) |
|---|
| 1066 | |
|---|
| 1067 | |
|---|
| 1068 | (defun evaluate-type-name (x) |
|---|
| 1069 | (let* ((name (car x))) |
|---|
| 1070 | (if (and (atom name) nil (null (cdr x))) |
|---|
| 1071 | name))) |
|---|
| 1072 | |
|---|
| 1073 | |
|---|
| 1074 | (defun find-constant (x constants) |
|---|
| 1075 | (when (symbolp x) |
|---|
| 1076 | (cdr (assoc (string x) constants :test #'string=)))) |
|---|
| 1077 | |
|---|
| 1078 | (defun find-user-or-primitive-type (x) |
|---|
| 1079 | x |
|---|
| 1080 | nil) |
|---|
| 1081 | |
|---|
| 1082 | (defun macro-definition (id table) |
|---|
| 1083 | (gethash (string id) table)) |
|---|
| 1084 | |
|---|
| 1085 | (defun expand-c-macro (name parameters arguments body stream macros-not-to-expand macro-table) |
|---|
| 1086 | (let ((expansion nil)) |
|---|
| 1087 | (unless (= (length arguments) (length parameters)) |
|---|
| 1088 | (c-parse-error stream "Expected ~D argument~:P to macro ~A but got ~D argument~:P." |
|---|
| 1089 | (length parameters) name (length arguments))) |
|---|
| 1090 | (loop while body |
|---|
| 1091 | as token = (pop body) |
|---|
| 1092 | as next = (first body) |
|---|
| 1093 | as argno = (position token parameters) do |
|---|
| 1094 | (cond ((and argno (eq next *sharp-sharp-symbol*)) ; parameter ## token/parameter |
|---|
| 1095 | (pop body) |
|---|
| 1096 | (setq next (pop body)) |
|---|
| 1097 | (let ((next-argno (position next parameters))) |
|---|
| 1098 | (push (intern (concatenate 'string (c-stringize-token-list (nth argno arguments)) |
|---|
| 1099 | (if next-argno |
|---|
| 1100 | (c-stringize-token-list (nth next-argno arguments)) |
|---|
| 1101 | (c-stringize-token next)))) |
|---|
| 1102 | expansion))) |
|---|
| 1103 | (argno ; normal parameter substitution |
|---|
| 1104 | (setq expansion (nreconc (expand-c-macros-in-token-list (nth argno arguments) |
|---|
| 1105 | stream macros-not-to-expand |
|---|
| 1106 | macro-table) |
|---|
| 1107 | expansion))) |
|---|
| 1108 | ((and (eq token *sharp-sharp-symbol*) ; token ## parameter |
|---|
| 1109 | (setq argno (position next parameters))) |
|---|
| 1110 | (pop body) |
|---|
| 1111 | (push (intern (concatenate 'string (c-stringize-token (pop expansion)) |
|---|
| 1112 | (c-stringize-token-list (nth argno arguments)))) |
|---|
| 1113 | expansion)) |
|---|
| 1114 | ((and (eq token *sharp-symbol*) ; # parameter |
|---|
| 1115 | (setq argno (position next parameters))) |
|---|
| 1116 | (pop body) |
|---|
| 1117 | (push (c-stringize-token-list (nth argno arguments)) expansion)) |
|---|
| 1118 | (t (push token expansion)))) |
|---|
| 1119 | (expand-c-macros-in-token-list (nreverse expansion) stream |
|---|
| 1120 | (adjoin name macros-not-to-expand) |
|---|
| 1121 | macro-table))) |
|---|
| 1122 | |
|---|
| 1123 | (defun expand-c-macros-in-token-list (tokens stream macros-not-to-expand macro-table) |
|---|
| 1124 | (loop |
|---|
| 1125 | while tokens |
|---|
| 1126 | as token = (pop tokens) |
|---|
| 1127 | as macro = (and (symbolp token) |
|---|
| 1128 | (not (member token macros-not-to-expand)) |
|---|
| 1129 | (macro-definition token macro-table)) |
|---|
| 1130 | if macro |
|---|
| 1131 | nconc (if (eq (first macro) :none) |
|---|
| 1132 | (expand-c-macros-in-token-list (second macro) stream |
|---|
| 1133 | (adjoin token macros-not-to-expand) macro-table) |
|---|
| 1134 | (expand-c-macro token (first macro) |
|---|
| 1135 | (let ((open (pop tokens))) |
|---|
| 1136 | (unless (eq open *lparen-symbol*) |
|---|
| 1137 | (c-parse-error |
|---|
| 1138 | stream |
|---|
| 1139 | "~A where open parenthesis expected after macro name ~A" |
|---|
| 1140 | open token)) |
|---|
| 1141 | (loop with done = nil |
|---|
| 1142 | collect |
|---|
| 1143 | (loop as token = (if tokens (pop tokens) |
|---|
| 1144 | (c-parse-error stream |
|---|
| 1145 | "Unexpected impossible EOF")) |
|---|
| 1146 | with level = 0 |
|---|
| 1147 | do (cond ((eq token *lparen-symbol*) (incf level)) |
|---|
| 1148 | ((eq token *rparen-symbol*) |
|---|
| 1149 | (if (plusp level) (decf level) (setq done t)))) |
|---|
| 1150 | until (or done (and (zerop level) |
|---|
| 1151 | (eq token *comma-symbol*))) |
|---|
| 1152 | collect token) |
|---|
| 1153 | until done)) |
|---|
| 1154 | (second macro) stream macros-not-to-expand macro-table)) |
|---|
| 1155 | else collect token)) |
|---|
| 1156 | |
|---|
| 1157 | (defun parse-c-expression (token-list &key constants additional-constants |
|---|
| 1158 | expand-macros) |
|---|
| 1159 | (labels ((next () |
|---|
| 1160 | (unless token-list |
|---|
| 1161 | (fail "Unterminated expression or unbalanced parentheses")) |
|---|
| 1162 | (pop token-list)) |
|---|
| 1163 | (peek () |
|---|
| 1164 | (car token-list)) |
|---|
| 1165 | (unread (token) |
|---|
| 1166 | (push token token-list)) |
|---|
| 1167 | (collect-parenthesized () |
|---|
| 1168 | (loop with level = 0 |
|---|
| 1169 | as token = (next) |
|---|
| 1170 | until (and (eq token *rparen-symbol*) (= level 0)) |
|---|
| 1171 | collect token |
|---|
| 1172 | do (case token |
|---|
| 1173 | (#.*lparen-symbol* (incf level)) |
|---|
| 1174 | (#.*rparen-symbol* (decf level))))) |
|---|
| 1175 | (fail (format-string &rest format-arguments) |
|---|
| 1176 | (apply #'c-parse-error nil format-string format-arguments)) |
|---|
| 1177 | (parse-expression () |
|---|
| 1178 | (parse-assignment)) |
|---|
| 1179 | (parse-assignment () |
|---|
| 1180 | (let ((left (parse-conditional))) |
|---|
| 1181 | (if (eq (peek) 'c::|=|) |
|---|
| 1182 | (let ((right (progn (next) (parse-assignment)))) |
|---|
| 1183 | (list 'setf left right)) |
|---|
| 1184 | left))) |
|---|
| 1185 | (parse-conditional () |
|---|
| 1186 | (let ((left (parse-logical-or))) |
|---|
| 1187 | (if (eq (peek) 'c::|?|) |
|---|
| 1188 | (let ((then (progn (next) (parse-expression))) |
|---|
| 1189 | (else (if (eq (peek) 'c::|:|) |
|---|
| 1190 | (progn (next) (parse-conditional)) |
|---|
| 1191 | (fail "~A where : was expected" (peek))))) |
|---|
| 1192 | (list 'if left then else)) |
|---|
| 1193 | left))) |
|---|
| 1194 | (parse-logical-or () |
|---|
| 1195 | (let ((left (parse-logical-and))) |
|---|
| 1196 | (loop while (eq (peek) 'c::|\|\||) |
|---|
| 1197 | do (setq left (list (next) left (parse-logical-and)))) |
|---|
| 1198 | left)) |
|---|
| 1199 | (parse-logical-and () |
|---|
| 1200 | (let ((left (parse-bitwise-ior))) |
|---|
| 1201 | (loop while (eq (peek) 'c::|&&|) |
|---|
| 1202 | do (setq left (list (next) left (parse-bitwise-ior)))) |
|---|
| 1203 | left)) |
|---|
| 1204 | (parse-bitwise-ior () |
|---|
| 1205 | (let ((left (parse-bitwise-xor))) |
|---|
| 1206 | (loop while (eq (peek) 'c::|\||) |
|---|
| 1207 | do (setq left (list (next) left (parse-bitwise-xor)))) |
|---|
| 1208 | left)) |
|---|
| 1209 | (parse-bitwise-xor () |
|---|
| 1210 | (let ((left (parse-bitwise-and))) |
|---|
| 1211 | (loop while (eq (peek) 'c::|\^|) |
|---|
| 1212 | do (setq left (list (next) left (parse-bitwise-and)))) |
|---|
| 1213 | left)) |
|---|
| 1214 | (parse-bitwise-and () |
|---|
| 1215 | (let ((left (parse-equality))) |
|---|
| 1216 | (loop while (eq (peek) 'c::|&|) |
|---|
| 1217 | do (setq left (list (next) left (parse-equality)))) |
|---|
| 1218 | left)) |
|---|
| 1219 | (parse-equality () |
|---|
| 1220 | (let ((left (parse-relational))) |
|---|
| 1221 | (loop while (member (peek) '(c::|==| c::|!=|)) |
|---|
| 1222 | do (setq left (list (next) left (parse-relational)))) |
|---|
| 1223 | left)) |
|---|
| 1224 | (parse-relational () |
|---|
| 1225 | (let ((left (parse-shift))) |
|---|
| 1226 | (loop while (member (peek) '(c::|<| c::|>| c::|<=| c::|>=|)) |
|---|
| 1227 | do (setq left (list (next) left (parse-shift)))) |
|---|
| 1228 | left)) |
|---|
| 1229 | (parse-shift () |
|---|
| 1230 | (let ((left (parse-additive))) |
|---|
| 1231 | (loop while (member (peek) '(c::|<<| c::|>>|)) |
|---|
| 1232 | do (setq left (list (next) left (parse-additive)))) |
|---|
| 1233 | left)) |
|---|
| 1234 | (parse-additive () |
|---|
| 1235 | (let ((left (parse-multiplicative))) |
|---|
| 1236 | (loop while (member (peek) '(c::|+| c::|-|)) |
|---|
| 1237 | do (setq left (list (next) left (parse-multiplicative)))) |
|---|
| 1238 | left)) |
|---|
| 1239 | (parse-multiplicative () |
|---|
| 1240 | (let ((left (parse-pointer-to-member))) |
|---|
| 1241 | (loop while (member (peek) '(c::|*| c::|/| c::|%|)) |
|---|
| 1242 | do (setq left (list (next) left (parse-pointer-to-member)))) |
|---|
| 1243 | left)) |
|---|
| 1244 | (parse-pointer-to-member () |
|---|
| 1245 | (let ((left (parse-unary))) |
|---|
| 1246 | (loop while (member (peek) '(c::|.*| c::|->*|)) |
|---|
| 1247 | do (setq left (list (next) left (parse-unary)))) |
|---|
| 1248 | left)) |
|---|
| 1249 | (parse-unary () ; subsumes parse-cast, thus accepting some invalid programs |
|---|
| 1250 | (let ((token (next))) ; --- doesn't support new and delete yet |
|---|
| 1251 | (cond ((member token '(c::|+| c::|-| c::|!| c::|~| c::|++| c::|--|)) |
|---|
| 1252 | ;;--- doesn't yet have special support for calling destructors... |
|---|
| 1253 | (list token (parse-unary))) |
|---|
| 1254 | ((eq token 'c::|*|) |
|---|
| 1255 | (list 'c::indirect (parse-unary))) |
|---|
| 1256 | ((eq token 'c::|&|) |
|---|
| 1257 | (list 'c::address-of (parse-unary))) |
|---|
| 1258 | ((eq token 'c::|sizeof|) |
|---|
| 1259 | (unless (eq (peek) *lparen-symbol*) ; Require open paren, maybe it's really optional |
|---|
| 1260 | (fail "~A where ( was expected after sizeof" (peek))) |
|---|
| 1261 | (next) ; Swallow open parenthesis |
|---|
| 1262 | `(c::size-of (c::resolve-type ,(loop as token = (next) |
|---|
| 1263 | until (eq token *rparen-symbol*) |
|---|
| 1264 | collect token)))) |
|---|
| 1265 | (t (parse-postfix token))))) |
|---|
| 1266 | (parse-postfix (token) |
|---|
| 1267 | (loop with left = (parse-primary token) |
|---|
| 1268 | as right = (peek) do |
|---|
| 1269 | (setq left |
|---|
| 1270 | (cond ((eq right *leftbracket-symbol*) |
|---|
| 1271 | (next) ; swallow [ |
|---|
| 1272 | (let ((subscript (parse-expression)) |
|---|
| 1273 | (delimiter (next))) |
|---|
| 1274 | (unless (eq delimiter *rightbracket-symbol*) |
|---|
| 1275 | (fail "~A where ] expected after subscript" delimiter)) |
|---|
| 1276 | `(c::aref ,left ,subscript))) |
|---|
| 1277 | ((eq right *lparen-symbol*) |
|---|
| 1278 | (next) ; swallow open parenthesis |
|---|
| 1279 | (let ((macro (and expand-macros |
|---|
| 1280 | (identifierp left) |
|---|
| 1281 | (macro-definition left expand-macros)))) |
|---|
| 1282 | (cond ((and macro (not (eq (first macro) ':none))) |
|---|
| 1283 | ;; Function-like macro - constant-like was alraedy handled |
|---|
| 1284 | (let ((more-tokens |
|---|
| 1285 | (expand-c-macro left (first macro) |
|---|
| 1286 | (collect-macro-arguments) |
|---|
| 1287 | (second macro) nil '() |
|---|
| 1288 | expand-macros))) |
|---|
| 1289 | (setq token-list (append more-tokens token-list)) |
|---|
| 1290 | (parse-expression))) |
|---|
| 1291 | ((valid-type-name? (list left)) |
|---|
| 1292 | ;; This is an explicit type conversion |
|---|
| 1293 | `(c::cast ,(evaluate-type-name (list left)) |
|---|
| 1294 | ,@(parse-argument-list))) |
|---|
| 1295 | (t `(c::call ,left ,@(parse-argument-list)))))) |
|---|
| 1296 | ((memq right '(c::|.| c::|->|)) |
|---|
| 1297 | (next) ; swallow operator |
|---|
| 1298 | `(,right ,left ,(parse-primary (next)))) ; parse-name, really |
|---|
| 1299 | ((eq right 'c::|++|) |
|---|
| 1300 | (next) ; swallow operator |
|---|
| 1301 | `(c::postfix++ ,left)) |
|---|
| 1302 | ((eq right 'c::|--|) |
|---|
| 1303 | (next) ; swallow operator |
|---|
| 1304 | `(c::postfix-- ,left)) |
|---|
| 1305 | (t (return left)))))) |
|---|
| 1306 | (parse-primary (token) |
|---|
| 1307 | (cond ((identifierp token) |
|---|
| 1308 | ;; nonqualified name |
|---|
| 1309 | (let ((value (find-constant token constants))) |
|---|
| 1310 | (cond (value |
|---|
| 1311 | (setq value (list value) token-list `(,@value #.*rparen-symbol* ,@token-list)) |
|---|
| 1312 | (parse-parenthesized)) |
|---|
| 1313 | ((setq value (assoc token additional-constants)) |
|---|
| 1314 | (cdr value)) |
|---|
| 1315 | ((and expand-macros |
|---|
| 1316 | (setq value (macro-definition-of-token token)) |
|---|
| 1317 | (eq (first value) ':none)) |
|---|
| 1318 | (setq token-list (append (expand-c-macros-in-token-list |
|---|
| 1319 | (second value) nil (list token) expand-macros) |
|---|
| 1320 | token-list )) |
|---|
| 1321 | (parse-primary (next))) |
|---|
| 1322 | (t token)))) |
|---|
| 1323 | ((eq token *lparen-symbol*) |
|---|
| 1324 | (let* ((save-token-list token-list) |
|---|
| 1325 | (type-name (collect-parenthesized)) |
|---|
| 1326 | (type (valid-type-name? type-name))) |
|---|
| 1327 | (cond (type |
|---|
| 1328 | ;; This is a cast |
|---|
| 1329 | ;; Doing cast here is easier but accepts some invalid programs |
|---|
| 1330 | (progn |
|---|
| 1331 | `(c::cast (,type) ,(parse-unary)))) |
|---|
| 1332 | (t |
|---|
| 1333 | ;; These are ordinary grouping parentheses |
|---|
| 1334 | (setq token-list save-token-list) |
|---|
| 1335 | (parse-parenthesized))))) |
|---|
| 1336 | ((eq token 'c::|{|) |
|---|
| 1337 | (cons 'c::curly-bracketed-list |
|---|
| 1338 | (loop as token = (next) |
|---|
| 1339 | until (eq token 'c::|}|) |
|---|
| 1340 | do (unread token) |
|---|
| 1341 | collect (parse-expression) |
|---|
| 1342 | do (let ((delimiter (peek))) |
|---|
| 1343 | (case delimiter |
|---|
| 1344 | (c::|,| (next)) |
|---|
| 1345 | (c::|}| ) |
|---|
| 1346 | (otherwise |
|---|
| 1347 | (fail "~A where , or } was expected" delimiter))))))) |
|---|
| 1348 | ((numberp token) token) |
|---|
| 1349 | ((stringp token) token) |
|---|
| 1350 | ((eq token 'c::|::|) |
|---|
| 1351 | (fail "Unary :: is not supported yet")) |
|---|
| 1352 | (t (fail "~A is unrecognized syntax in an expression" token)))) |
|---|
| 1353 | (parse-parenthesized () |
|---|
| 1354 | (prog1 (parse-expression) |
|---|
| 1355 | (let ((close (next))) |
|---|
| 1356 | (unless (eq close *rparen-symbol*) |
|---|
| 1357 | (fail "~A where ) was expected" close))))) |
|---|
| 1358 | (parse-argument-list () |
|---|
| 1359 | (if (eq (peek) *rparen-symbol*) |
|---|
| 1360 | (progn (next) '()) |
|---|
| 1361 | (loop as arg = (parse-expression) |
|---|
| 1362 | as delimiter = (next) |
|---|
| 1363 | collect arg |
|---|
| 1364 | do (unless (or (eq delimiter 'c::|,|) (eq delimiter *rparen-symbol*)) |
|---|
| 1365 | (fail "~A where , or ) expected in function arguments" |
|---|
| 1366 | delimiter)) |
|---|
| 1367 | while (eq delimiter 'c::|,|)))) |
|---|
| 1368 | (collect-macro-arguments () |
|---|
| 1369 | (loop with done = nil with first = t |
|---|
| 1370 | collect (loop as token = (next) with level = 0 |
|---|
| 1371 | do (cond ((eq token *lparen-symbol*) (incf level)) |
|---|
| 1372 | ((eq token *rparen-symbol*) |
|---|
| 1373 | (when first ; () has to be treated as a special case |
|---|
| 1374 | (return-from collect-macro-arguments '())) |
|---|
| 1375 | (if (plusp level) (decf level) (setq done t)))) |
|---|
| 1376 | (setq first nil) |
|---|
| 1377 | until (or done (and (zerop level) (eq token 'c::|,|))) |
|---|
| 1378 | collect token) |
|---|
| 1379 | until done)) |
|---|
| 1380 | |
|---|
| 1381 | ;;--- The following type-name routines don't support the full C++ syntax |
|---|
| 1382 | ;;--- Maybe we will add ::, arrays, functions, and God knows what later |
|---|
| 1383 | (valid-type-name? (token-list &optional tailp) |
|---|
| 1384 | (let* ((type (ignore-errors (parse-c-ffi-type token-list)))) |
|---|
| 1385 | tailp |
|---|
| 1386 | (return-from valid-type-name? |
|---|
| 1387 | (if (and type (not (eq type *the-ffi-void-type*))) |
|---|
| 1388 | type))) |
|---|
| 1389 | |
|---|
| 1390 | ;; At least one type-specifier followed by an optional abstract-declarator |
|---|
| 1391 | ;; For now the type-specifier cannot contain :: and the only |
|---|
| 1392 | ;; abstract-declarators we accept are stars (not functions, arrays) |
|---|
| 1393 | (cond ((null token-list) tailp) |
|---|
| 1394 | ((member (car token-list) '(c::|long| c::|short| c::|signed| c::|unsigned|)) |
|---|
| 1395 | (valid-type-name? (cdr token-list) t)) |
|---|
| 1396 | ((and (identifierp (car token-list)) |
|---|
| 1397 | (find-user-or-primitive-type (car token-list))) |
|---|
| 1398 | (valid-type-name? (cdr token-list) t)) |
|---|
| 1399 | ;((eq (car token-list) '|::|) (valid-type-name? (cdr token-list))) |
|---|
| 1400 | ((and tailp (eq (car token-list) 'c::|*|)) |
|---|
| 1401 | (valid-type-name? (cdr token-list) t)) |
|---|
| 1402 | (t nil)))) |
|---|
| 1403 | (prog1 (parse-expression) |
|---|
| 1404 | (when token-list |
|---|
| 1405 | (fail "~{~A ~} left over after expression" token-list))))) |
|---|
| 1406 | |
|---|
| 1407 | (defun c-parse-error (stream format &rest args) |
|---|
| 1408 | (declare (ignore stream)) |
|---|
| 1409 | (apply #'error format args)) |
|---|
| 1410 | |
|---|
| 1411 | (defun macro-definition-of-token (x) |
|---|
| 1412 | (declare (ignore x))) |
|---|
| 1413 | |
|---|
| 1414 | (defun c-stringize-token-list (tokens) |
|---|
| 1415 | (apply #'concatenate 'string (mapcar #'c-stringize-token tokens))) |
|---|
| 1416 | |
|---|
| 1417 | (defun c-stringize-token (token) |
|---|
| 1418 | (etypecase token |
|---|
| 1419 | (symbol (string token)) |
|---|
| 1420 | (string token) |
|---|
| 1421 | (number (princ-to-string token)))) |
|---|
| 1422 | |
|---|
| 1423 | (defun install-new-db-files (ftd d) |
|---|
| 1424 | (let* ((dir (merge-pathnames (interface-dir-subdir d) |
|---|
| 1425 | (ftd-interface-db-directory ftd)))) |
|---|
| 1426 | (flet ((rename-and-reopen (was-open path newpath) |
|---|
| 1427 | (let* ((path (merge-pathnames path dir)) |
|---|
| 1428 | (newpath (merge-pathnames newpath dir))) |
|---|
| 1429 | (when was-open |
|---|
| 1430 | (cdb-close was-open)) |
|---|
| 1431 | (when (probe-file path) |
|---|
| 1432 | (rename-file path |
|---|
| 1433 | (concatenate 'string (namestring (truename path)) "-BAK") |
|---|
| 1434 | :if-exists :supersede)) |
|---|
| 1435 | (rename-file newpath path) |
|---|
| 1436 | (when was-open |
|---|
| 1437 | (cdb-open path))))) |
|---|
| 1438 | (without-interrupts |
|---|
| 1439 | (setf (interface-dir-constants-interface-db-file d) |
|---|
| 1440 | (rename-and-reopen |
|---|
| 1441 | (interface-dir-constants-interface-db-file d) |
|---|
| 1442 | "constants.cdb" |
|---|
| 1443 | "new-constants.cdb")) |
|---|
| 1444 | (setf (interface-dir-functions-interface-db-file d) |
|---|
| 1445 | (rename-and-reopen |
|---|
| 1446 | (interface-dir-functions-interface-db-file d) |
|---|
| 1447 | "functions.cdb" |
|---|
| 1448 | "new-functions.cdb")) |
|---|
| 1449 | (setf (interface-dir-records-interface-db-file d) |
|---|
| 1450 | (rename-and-reopen |
|---|
| 1451 | (interface-dir-records-interface-db-file d) |
|---|
| 1452 | "records.cdb" |
|---|
| 1453 | "new-records.cdb")) |
|---|
| 1454 | (setf (interface-dir-types-interface-db-file d) |
|---|
| 1455 | (rename-and-reopen |
|---|
| 1456 | (interface-dir-types-interface-db-file d) |
|---|
| 1457 | "types.cdb" |
|---|
| 1458 | "new-types.cdb")) |
|---|
| 1459 | (setf (interface-dir-vars-interface-db-file d) |
|---|
| 1460 | (rename-and-reopen |
|---|
| 1461 | (interface-dir-vars-interface-db-file d) |
|---|
| 1462 | "vars.cdb" |
|---|
| 1463 | "new-vars.cdb")) |
|---|
| 1464 | (setf (interface-dir-objc-classes-interface-db-file d) |
|---|
| 1465 | (rename-and-reopen |
|---|
| 1466 | (interface-dir-objc-classes-interface-db-file d) |
|---|
| 1467 | "objc-classes.cdb" |
|---|
| 1468 | "new-objc-classes.cdb")) |
|---|
| 1469 | (setf (interface-dir-objc-methods-interface-db-file d) |
|---|
| 1470 | (rename-and-reopen |
|---|
| 1471 | (interface-dir-objc-methods-interface-db-file d) |
|---|
| 1472 | "objc-methods.cdb" |
|---|
| 1473 | "new-objc-methods.cdb"))))) |
|---|
| 1474 | t) |
|---|
| 1475 | |
|---|
| 1476 | |
|---|
