Ignore:
Timestamp:
Apr 18, 2005, 6:47:05 AM (15 years ago)
Author:
gb
Message:

Support for ObjC class info, method info in interface files.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/library/parse-ffi.lisp

    r812 r1153  
    1515;;;   http://opensource.franz.com/preamble.html
    1616
     17
     18
    1719(in-package "CCL")
    1820
     
    3739  expression )
    3840
    39 
    40 
    4141(defstruct (ffi-enum (:include ffi-type)))
    4242
    43 
    44 
    45 
    46 
    47 
    48 (defvar *ffi-db-constants* nil)
    49 (defvar *ffi-db-types* nil)
    50 (defvar *ffi-db-records* nil)
    51 (defvar *ffi-db-functions* nil)
    52 (defvar *ffi-db-vars* nil)
    5343(defvar *ffi-typedefs*)
    5444(defvar *ffi-global-typedefs* nil)
     
    6151(defvar *ffi-global-constants* nil)
    6252(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)
    6356(defvar *ffi-macros*)
    6457(defvar *ffi-vars*)
    65 (defvar *ffi-out* t)
    66 (defvar *ffi-indent* 0)
    6758
    6859(defvar *ffi-void-reference* '(:primitive :void))
     60
     61
    6962
    7063(defun find-or-create-ffi-struct (string)
     
    7366            (make-ffi-struct :string string
    7467                             :name (unless (digit-char-p (schar string 0))
    75                                      (escape-foreign-name string))))))
     68                                     (escape-foreign-name string))))))
    7669
    7770(defun find-or-create-ffi-union (string)
     
    8073            (make-ffi-union :string string
    8174                            :name (unless (digit-char-p (schar string 0))
    82                                     (escape-foreign-name string)))))) 
     75                                    (escape-foreign-name string))))))
     76
     77(defun find-or-create-ffi-objc-class (string)
     78  (or (gethash string *ffi-objc-classes*)
     79      (setf (gethash string *ffi-objc-classes*)
     80            (make-ffi-objc-class :string string
     81                                 :name (escape-foreign-name string)))))
     82
     83(defun find-or-create-ffi-objc-message (string)
     84  (or (gethash string *ffi-global-objc-messages*)
     85      (setf (gethash string *ffi-global-objc-messages*)
     86            (make-ffi-objc-message :string string))))
    8387
    8488(defun find-or-create-ffi-typedef (string)
     
    423427      struct)))
    424428
     429(defun process-ffi-objc-class (form)
     430  (destructuring-bind (source-info class-name superclass-form template-form ivars) (cdr form)
     431    (declare (ignore source-info))
     432    (let* ((class (find-or-create-ffi-objc-class class-name)))
     433      (setf (ffi-objc-class-ordinal class) (incf *ffi-ordinal*))
     434      (unless (ffi-objc-class-super-foreign-name class)
     435        (let* ((super-name (cadr superclass-form)))
     436          (unless (eq super-name :void)
     437            (setf (ffi-objc-class-super-foreign-name class)
     438                  super-name))))
     439      (unless (ffi-objc-class-template-structure-name class)
     440        (setf (ffi-objc-class-template-structure-name class)
     441              (cadr (cadr template-form))))
     442      (unless (ffi-objc-class-own-ivars class)
     443        (setf (ffi-objc-class-own-ivars class)
     444              (process-ffi-fieldlist ivars)))
     445      class)))
     446
     447(defun process-ffi-objc-method (form)
     448  (destructuring-bind (method-type source-info class-name category-name message-name arglist result-type) form
     449    (declare (ignore source-info category-name))
     450    (let* ((message (find-or-create-ffi-objc-message message-name))
     451           (class-method-p (eq method-type :objc-class-method))
     452           (method
     453            (make-ffi-objc-method :class-name class-name
     454                                  :arglist (mapcar #'reference-ffi-type
     455                                                   arglist)
     456                                  :result-type (reference-ffi-type
     457                                                result-type)
     458                                  :class-method-p class-method-p)))
     459      (unless (dolist (m (ffi-objc-message-methods message))
     460                (when (and (equal (ffi-objc-method-class-name m)
     461                                  class-name)
     462                           (eq (ffi-objc-method-class-method-p m)
     463                               class-method-p))
     464                  (return t)))
     465        (push method (ffi-objc-message-methods message))))))
     466     
    425467(defun process-ffi-typedef (form)
    426468  (let* ((string (caddr form))
     
    479521  (ecase (car spec)
    480522    (:primitive)
    481     (:typedef (define-typedef (cadr spec)))
     523    (:typedef (define-typedef-from-ffi-info (cadr spec)))
    482524    (:struct (ensure-struct-defined (cadr spec)))
    483525    (:union (ensure-union-defined (cadr spec)))
     
    495537      (ensure-referenced-type-defined ftype))))
    496538
    497 (defun emit-fieldlist (fields)
    498   (when *ffi-out*
    499     (format *ffi-out* "~vt~&" *ffi-indent*)
    500     (let* ((*ffi-indent* (+ 2 *ffi-indent*)))
    501       (dolist (f fields)
    502         (format *ffi-out* "~&~vt(~s " *ffi-indent* (car f))
    503         (emit-type-reference (cadr f))
    504         (format *ffi-out* ")")))))
    505 
    506 (defun emit-union (u)
    507   (when *ffi-out*
    508     (format *ffi-out* "~&~vt(:union ~s " *ffi-indent* (ffi-union-name u))
    509     (emit-fieldlist (ffi-union-fields u))
    510     (format *ffi-out* ")")))
    511 
    512 (defun emit-global-union (u)
    513   (when *ffi-db-records*
    514     (save-ffi-union *ffi-db-records* u)))
     539(defun record-global-objc-class (c)
     540  (when *ffi-global-objc-classes*
     541    (setf (gethash (ffi-objc-class-string c) *ffi-global-objc-classes*) c)))
     542
     543(defun define-objc-class-from-ffi-info (c)
     544  (unless (ffi-objc-class-defined c)
     545    (setf (ffi-objc-class-defined c) t)
     546    (record-global-objc-class c)
     547    (ensure-fields-defined (ffi-objc-class-own-ivars c))))
    515548
    516549(defun record-global-union (u)
     
    518551    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))
    519552
    520 (defun define-union (u)
     553(defun define-union-from-ffi-info (u)
    521554  (unless (ffi-union-defined u)
    522555    (setf (ffi-union-defined u) t)
     
    524557    (when (ffi-union-name u)
    525558      (let* ((fields (ffi-union-fields u)))
    526         (ensure-fields-defined fields)
    527         (when *ffi-out*
    528           (format *ffi-out* "~&(ccl::def-foreign-type nil~&")
    529           (let* ((*ffi-indent* (+ *ffi-indent* 2)))
    530             (emit-union u))
    531           (format *ffi-out* ")~&"))))))
     559        (ensure-fields-defined fields)))))
    532560
    533561(defun ensure-union-defined (u)
    534562  (let* ((name (ffi-union-name u)))
    535563    (if name
    536       (define-union u)
     564      (define-union-from-ffi-info u)
    537565      (ensure-fields-defined (ffi-union-fields u)))))
    538 
    539 (defun emit-struct (s)
    540   (when *ffi-out*
    541     (format *ffi-out* "~&~vt(:struct ~s " *ffi-indent* (ffi-struct-name s))
    542     (emit-fieldlist (ffi-struct-fields s))
    543     (format *ffi-out* ")")))
    544 
    545 (defun emit-global-struct (s)
    546   (when *ffi-db-records*
    547     (save-ffi-struct *ffi-db-records* s)))
    548566
    549567(defun record-global-struct (s)
     
    551569    (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s)))
    552570
    553 (defun define-struct (s)
     571(defun define-struct-from-ffi-info (s)
    554572  (unless (ffi-struct-defined s)
    555573    (setf (ffi-struct-defined s) t)
     
    557575    (when (typep (ffi-struct-name s) 'keyword)
    558576      (let* ((fields (ffi-struct-fields s)))
    559         (ensure-fields-defined fields)
    560         (when *ffi-out*
    561           (format *ffi-out* "~&(ccl::def-foreign-type nil~&")
    562           (let* ((*ffi-indent* (+ *ffi-indent* 2)))
    563             (emit-struct s))
    564           (format *ffi-out* ")~&"))))))
     577        (ensure-fields-defined fields)))))
    565578
    566579(defun ensure-struct-defined (s)
    567580  (let* ((name (ffi-struct-name s)))
    568581    (if (typep name 'keyword)
    569       (define-struct s)
     582      (define-struct-from-ffi-info s)
    570583      (ensure-fields-defined (ffi-struct-fields s)))))
    571 
    572 (defun emit-global-typedef (def)
    573   (when *ffi-db-types*
    574     (save-ffi-typedef *ffi-db-types* def)))
    575584
    576585(defun record-global-typedef (def)
     
    578587    (setf (gethash (ffi-typedef-string def) *ffi-global-typedefs*) def)))
    579588 
    580 (defun define-typedef (def)
     589(defun define-typedef-from-ffi-info (def)
    581590  (unless (ffi-typedef-defined def)
    582591    (setf (ffi-typedef-defined def) t)
     
    585594      (unless (and (consp target)
    586595                   (member (car target) '(:struct :union :primitive)))
    587         (ensure-referenced-type-defined target))
    588       (when *ffi-out*
    589         (format *ffi-out* "~&(ccl::def-foreign-type ~s " (ffi-typedef-name def))
    590         (emit-type-reference target)
    591         (format *ffi-out* ")~&")))))
     596        (ensure-referenced-type-defined target)))))
    592597
    593598(defun record-global-constant (name val)
    594599  (when *ffi-global-constants*
    595600    (setf (gethash name *ffi-global-constants*) val)))
    596 
    597 (defun emit-global-constant (name val)
    598   (when *ffi-db-constants*
    599     (db-define-constant *ffi-db-constants* name val)))
    600601     
    601602(defun emit-ffi-constant (name val)
    602   (record-global-constant name val)
    603   (when *ffi-out*
    604     (format *ffi-out* "~&(cl:defconstant ~a " name)
    605     (format *ffi-out*
    606             (typecase val
    607               ((unsigned-byte 15) "~s)~&")
    608               (unsigned-byte "#x~x)~&")
    609               (t "~s)~&"))
    610             val)))
     603  (record-global-constant name val))
    611604
    612605(defun record-global-var (name type)
     
    614607    (setf (gethash name *ffi-global-vars*) type)))
    615608
    616 (defun emit-global-var (name type)
    617   (when *ffi-db-vars*
    618     (db-define-var *ffi-db-vars* name type)))
    619 
    620609(defun emit-ffi-var (name type)
    621610  (record-global-var name type))
    622 
    623 
    624 (defun emit-type-reference (ref)
    625   (when *ffi-out*
    626     (ecase (car ref)
    627       (:primitive (format *ffi-out* "~s" (cadr ref)))
    628       (:typedef (format *ffi-out* "~s" (ffi-type-name (cadr ref))))
    629       (:struct (let* ((s (cadr ref))
    630                       (name (ffi-struct-name s)))
    631                  (if (typep name 'keyword)
    632                    (format *ffi-out* "(:struct ~s)" name)
    633                    (emit-struct s))))
    634       (:union (let* ((u (cadr ref))
    635                      (name (ffi-union-name u)))
    636                 (if name
    637                   (format *ffi-out* "(:union ~s)" name)
    638                   (emit-union u))))
    639       (:pointer (let* ((target (cadr ref)))
    640                   (if (eq target *ffi-void-reference*)
    641                     (format *ffi-out* "(* t)")
    642                     (progn
    643                       (format *ffi-out* "(* ")
    644                       (emit-type-reference target)
    645                       (format *ffi-out* ")")))))
    646       (:array (format *ffi-out* "(:array ")
    647               (emit-type-reference (caddr ref))
    648               (format *ffi-out* " ~d)" (cadr ref))))
    649     (format *ffi-out* " ")))
    650  
    651 (defun emit-ffi-function-name (name-string)
    652   (when *ffi-out*
    653     (if (some #'upper-case-p name-string)
    654       (format *ffi-out* "(~a ~s)" (string-upcase name-string) name-string)
    655       (format *ffi-out* "~a" name-string))))
    656611
    657612
     
    667622          ffi-function)))
    668623
    669 (defun emit-global-function (ffi-function)
    670   (when *ffi-db-functions*
    671     (save-ffi-function *ffi-db-functions* ffi-function)))
    672    
    673624(defun emit-function-decl (ffi-function)
    674625  (let* ((args (ffi-function-arglist ffi-function))
     
    683634    (dolist (arg args) (ensure-referenced-type-defined arg))
    684635    (ensure-referenced-type-defined retval)
    685     (record-global-function ffi-function)
    686     (when *ffi-out*
    687       (format *ffi-out* "~&(ccl::define-external-function ")
    688       (emit-ffi-function-name (ffi-function-string ffi-function))
    689       (format *ffi-out* "~&  (")
    690       (dolist (arg args (format *ffi-out* ")~&  "))
    691         (emit-type-reference arg))
    692       (emit-type-reference retval)
    693       (format *ffi-out* ")~&"))))
     636    (record-global-function ffi-function)))
    694637 
    695 (defun parse-ffi (inpath outpath &key (package-name))
     638(defun parse-ffi (inpath)
    696639  (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
    697640         (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
    698641         (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
     642         (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
    699643         (argument-macros (make-hash-table :test 'equal)))
    700644    (let* ((defined-types ())
     
    704648           (defined-vars ()))
    705649      (with-open-file (in inpath)
    706         (let* ((*ffi-ordinal* -1)
    707                (*ffi-prefix* (namestring inpath)))
     650        (let* ((*ffi-ordinal* -1))
    708651          (let* ((*package* (find-package "KEYWORD")))
    709652            (do* ((form (read in nil :eof) (read in nil :eof)))
     
    711654              (case (car form)
    712655                (:struct (push (process-ffi-struct form) defined-types))
     656                (:objc-class (push (process-ffi-objc-class form) defined-types))
     657                ((:objc-class-method :objc-instance-method)
     658                 (process-ffi-objc-method form))
    713659                (:function (push (process-ffi-function form) defined-functions))
    714660                (:macro (let* ((m (process-ffi-macro form))
     
    728674            ;; lisp constants.
    729675            (declare (ignore new-macros))
    730             (let* ((*ffi-out* (when outpath
    731                                 (open outpath
    732                                       :direction :output
    733                                       :if-exists :supersede
    734                                       :if-does-not-exist :create))))
    735            
    736               (unwind-protect
    737                    (let* ((*print-case* :downcase))
    738                      (when *ffi-out*
    739                        (format *ffi-out* "~%~%(cl::in-package ~a)~%~%" package-name))
    740                      (dolist (x (reverse new-constants))
    741                        (emit-ffi-constant (car x) (cdr x)))
    742                      (dolist (x defined-vars)
    743                        (emit-ffi-var (car x) (cdr x)))
    744                      (when *ffi-out*
    745                        (terpri *ffi-out*)
    746                        (terpri *ffi-out*))
    747                      (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal))
    748                        (typecase x
    749                          (ffi-struct (define-struct x))
    750                          (ffi-union (define-union x))
    751                          (ffi-typedef (define-typedef x))))
    752                      (when *ffi-out*
    753                        (terpri *ffi-out*)
    754                        (terpri *ffi-out*))
    755                      (dolist (f defined-functions) (emit-function-decl f)))
    756                 (when *ffi-out* (close *ffi-out*))))
    757             outpath))))))
    758 
    759 (defun lisp-pathname-from-ffi-pathname (ffi-pathname)
    760   (let* ((inpath (pathname ffi-pathname))
    761          (indir (pathname-directory ffi-pathname))
    762          (outdir (remove "C" indir :test #'string=)))
    763     (make-pathname :host (pathname-host inpath)
    764                    :device (pathname-device inpath)
    765                    :directory outdir
    766                    :name (pathname-name inpath)
    767                    :type "lisp")))
    768 
     676            (dolist (x (reverse new-constants))
     677              (emit-ffi-constant (car x) (cdr x)))
     678            (dolist (x defined-vars)
     679              (emit-ffi-var (car x) (cdr x)))
     680            (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal))
     681              (typecase x
     682                (ffi-struct (define-struct-from-ffi-info x))
     683                (ffi-union (define-union-from-ffi-info x))
     684                (ffi-typedef (define-typedef-from-ffi-info x))
     685                (ffi-objc-class (define-objc-class-from-ffi-info x))))
     686            (dolist (f defined-functions) (emit-function-decl f))))))))
    769687
    770688(defun parse-standard-ffi-files (dirname &key
    771689                                         (ftd *target-ftd*)
    772                                          (write-lisp-file nil)
    773690                                         (prepend-underscores
    774691                                          #+(or darwinppc-target) t
     
    780697                         (ftd-interface-db-directory ftd)))
    781698         (*prepend-underscores-to-ffi-function-names* prepend-underscores)
    782          (package-name (ftd-interface-package-name ftd))
    783699         (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
    784700         (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
    785701         (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
     702         (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
     703         (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash))
    786704         (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash))
    787705         (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash))
     
    791709                                           interface-dir)))
    792710      (format t "~&~s ..." f)
    793       (format t " ~s" (parse-ffi f
    794                                  (if write-lisp-file
    795                                    (lisp-pathname-from-ffi-pathname f))
    796                                  :package-name package-name )))
    797     (with-new-db-file (*ffi-db-constants* (merge-pathnames
    798                                            "new-constants.cdb"
    799                                            interface-dir))
     711      (parse-ffi f )
     712      (format t "~&"))
     713    (with-new-db-file (constants-cdbm (merge-pathnames
     714                                       "new-constants.cdb"
     715                                       interface-dir))
    800716      (maphash #'(lambda (name def)
    801                    (emit-global-constant name def))
     717                   (db-define-constant constants-cdbm name def))
    802718               *ffi-global-constants*))
    803     (with-new-db-file (*ffi-db-types* (merge-pathnames
     719    (with-new-db-file (types-cdbm (merge-pathnames
    804720                                       "new-types.cdb"
    805721                                       interface-dir))
    806722      (maphash #'(lambda (name def)
    807723                   (declare (ignore name))
    808                    (emit-global-typedef def))
     724                   (save-ffi-typedef types-cdbm def))
    809725               *ffi-global-typedefs*))
    810     (with-new-db-file (*ffi-db-records* (merge-pathnames
    811                                         "new-records.cdb"
    812                                         interface-dir))
     726    (with-new-db-file (records-cdbm (merge-pathnames
     727                                    "new-records.cdb"
     728                                    interface-dir))
    813729      (maphash #'(lambda (name def)
    814730                   (declare (ignore name))
    815                    (emit-global-union def))
     731                   (save-ffi-union records-cdbm def))
    816732               *ffi-global-unions*)
    817733      (maphash #'(lambda (name def)
    818734                   (declare (ignore name))
    819                    (emit-global-struct def))
     735                   (save-ffi-struct records-cdbm def))
    820736               *ffi-global-structs*))
    821     (with-new-db-file (*ffi-db-functions* (merge-pathnames
     737    (with-new-db-file (function-cdbm (merge-pathnames
    822738                                           "new-functions.cdb"
    823739                                           interface-dir))
    824740      (maphash #'(lambda (name def)
    825741                   (declare (ignore name))
    826                    (emit-global-function def))
     742                   (save-ffi-function function-cdbm def))
    827743               *ffi-global-functions*))
    828     (with-new-db-file (*ffi-db-vars* (merge-pathnames
    829                                       "new-vars.cdb"
     744    (with-new-db-file (class-cdbm (merge-pathnames
     745                                   "new-objc-classes.cdb"
     746                                   interface-dir))
     747      (maphash #'(lambda (name def)
     748                   (declare (ignore name))
     749                   (save-ffi-objc-class class-cdbm def))
     750               *ffi-global-objc-classes*))
     751    (with-new-db-file (vars-cdbm (merge-pathnames
     752                             "new-vars.cdb"
     753                             interface-dir))
     754      (maphash #'(lambda (name type)
     755                   (db-define-var vars-cdbm name type))
     756               *ffi-global-vars*))
     757    (with-new-db-file (methods-cdbm  (merge-pathnames
     758                                      "new-objc-methods.cdb"
    830759                                      interface-dir))
    831       (maphash #'(lambda (name type)
    832                    (emit-global-var name type))
    833                *ffi-global-vars*))
     760      (maphash #'(lambda (name message)
     761                   (declare (ignore name))
     762                   (save-ffi-objc-message methods-cdbm message))
     763               *ffi-global-objc-messages*))
    834764    (install-new-db-files ftd d)))
    835765
     
    11171047    else collect token))
    11181048
    1119 ;;; We -could-
    11201049(defun parse-c-expression (token-list &key  constants additional-constants
    11211050                                          expand-macros)
     
    14201349              "types.cdb"
    14211350              "new-types.cdb"))
    1422               (setf (interface-dir-types-interface-db-file d)
     1351       (setf (interface-dir-vars-interface-db-file d)
    14231352             (rename-and-reopen
    1424               (interface-dir-types-interface-db-file d)
     1353              (interface-dir-vars-interface-db-file d)
    14251354              "vars.cdb"
    1426               "new-vars.cdb")))))
     1355              "new-vars.cdb"))
     1356       (setf (interface-dir-objc-classes-interface-db-file d)
     1357             (rename-and-reopen
     1358              (interface-dir-objc-classes-interface-db-file d)
     1359              "objc-classes.cdb"
     1360              "new-objc-classes.cdb"))
     1361       (setf (interface-dir-objc-methods-interface-db-file d)
     1362             (rename-and-reopen
     1363              (interface-dir-objc-methods-interface-db-file d)
     1364              "objc-methods.cdb"
     1365              "new-objc-methods.cdb")))))
    14271366  t)
    1428    
     1367
     1368
Note: See TracChangeset for help on using the changeset viewer.