Changeset 6419 for branches/x8664-call


Ignore:
Timestamp:
May 4, 2007, 2:21:29 PM (13 years ago)
Author:
gb
Message:

Treat #_?sym, #$?sym, and #&?sym as tests for the definedness of
the foreign function/constant/variable.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/x8664-call/ccl/lib/db-io.lisp

    r6221 r6419  
    776776            (cdb-open (interface-db-pathname "functions.cdb" dir)))))
    777777
    778 (defun load-os-constant (sym &optional reader-stream)
    779   (declare (ignore reader-stream))
    780   (let* ((val (or (do-interface-dirs (d)
     778(defun load-os-constant (sym &optional query)
     779  (let* ((val (do-interface-dirs (d)
    781780                    (let* ((v (db-lookup-constant (db-constants d) sym)))
    782                       (when v (return v))))
    783                   (error "Constant not found: ~s" sym))))
    784     (let* ((*record-source-file* nil))
    785       (%defconstant sym val)
    786       val)))
    787 
    788 (defun %load-var (name &optional (ftd *target-ftd*))
    789   (let* ((string (if (getf (ftd-attributes ftd)
     781                      (when v (return v))))))
     782    (if query
     783      (not (null val))
     784      (if val
     785        (let* ((*record-source-file* nil))
     786          (%defconstant sym val)
     787          val)
     788        (error "Constant not found: ~s" sym)))))
     789
     790(defun %load-var (name &optional query-only)
     791  (let* ((ftd *target-ftd*)
     792         (string (if (getf (ftd-attributes ftd)
    790793                           :prepend-underscores)
    791794                   (concatenate 'string "_" (string name))
     
    795798      (with-cstrs ((cstring string))
    796799        (let* ((type
    797               (do-interface-dirs (d)
    798                 (let* ((vars (db-vars d)))
    799                   (when vars
    800                     (rletZ ((value :cdb-datum)
    801                             (key :cdb-datum))
    802                       (setf (pref key :cdb-datum.data) cstring
    803                             (pref key :cdb-datum.size) (length string)
    804                             (pref value :cdb-datum.data) (%null-ptr)
    805                             (pref value :cdb-datum.size) 0)
    806                       (cdb-get vars key value)
    807                       (let* ((vartype (extract-db-type value ftd)))
    808                         (when vartype (return vartype)))))))))
    809         (unless type (error "Foreign variable ~s not found" string))
    810         (setq fv (%cons-foreign-variable string type))
    811         (resolve-foreign-variable fv nil)
    812         (setf (gethash string (fvs)) fv))))
    813     fv))
     800                (do-interface-dirs (d)
     801                  (let* ((vars (db-vars d)))
     802                    (when vars
     803                      (rletZ ((value :cdb-datum)
     804                              (key :cdb-datum))
     805                        (setf (pref key :cdb-datum.data) cstring
     806                              (pref key :cdb-datum.size) (length string)
     807                              (pref value :cdb-datum.data) (%null-ptr)
     808                              (pref value :cdb-datum.size) 0)
     809                        (cdb-get vars key value)
     810                        (let* ((vartype (extract-db-type value ftd)))
     811                          (when vartype (return vartype)))))))))
     812          (when type
     813            (setq fv (%cons-foreign-variable string type))
     814            (resolve-foreign-variable fv nil)
     815            (setf (gethash string (fvs)) fv)))))
     816    (if query-only
     817      (not (null fv))
     818      (or fv (error "Foreign variable ~s not found" string)))))
     819
    814820
    815821(set-dispatch-macro-character
     
    817823 (qlfun |#&-reader| (stream char arg)
    818824   (declare (ignore char arg))
    819    (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))
    820           (sym
    821            (%read-symbol-preserving-case
    822             stream
    823             package)))
    824      (unless *read-suppress*
    825        (let* ((fv (%load-var sym)))
    826          (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
    827                                        (fv.type fv)
    828                                        0
    829                                        nil))))))
     825   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
     826     (multiple-value-bind (sym query)
     827         (%read-symbol-preserving-case
     828          stream
     829          package)
     830       (unless *read-suppress*
     831         (let* ((fv (%load-var sym query)))
     832           (if query
     833             fv
     834             (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
     835                                   (fv.type fv)
     836                                   0
     837                                   nil))))))))
    830838
    831839
     
    942950      (when info (return info)))))
    943951
    944 (defun load-external-function (sym reader-stream)
    945   (declare (ignore reader-stream))
     952(defun load-external-function (sym query)
    946953  (let* ((def (or (do-interface-dirs (d)
    947954                    (let* ((f (db-lookup-function (db-functions d) sym)))
    948955                      (when f (return f))))
    949                   (error "Foreign function not found: ~s" sym))))
    950     (setf (gethash sym (ftd-external-function-definitions
    951                         *target-ftd*)) def)
    952     (setf (macro-function sym) #'%external-call-expander)
    953     sym))
     956                  (unless query
     957                    (error "Foreign function not found: ~s" sym)))))
     958    (if query
     959      (not (null def))
     960      (progn
     961        (setf (gethash sym (ftd-external-function-definitions
     962                            *target-ftd*)) def)
     963        (setf (macro-function sym) #'%external-call-expander)
     964        sym))))
    954965
    955966(defun %read-symbol-preserving-case (stream package)
    956967  (let* ((case (readtable-case *readtable*))
     968         (query nil)
    957969         (error nil)
    958970         (sym nil))
     
    961973           (progn
    962974             (setf (readtable-case *readtable*) :preserve)
     975             (when (eq #\? (peek-char t stream nil nil))
     976               (setq query t)
     977               (read-char stream))
    963978             (multiple-value-setq (sym error)
    964979               (handler-case (read stream nil nil)
    965980                 (error (condition) (values nil condition)))))
    966981        (setf (readtable-case *readtable*) case)))
    967     (if error
    968       (error error)
    969       sym)))
     982    (when error
     983      (error error))
     984    (values sym query)))
    970985
    971986(set-dispatch-macro-character
     
    973988 (qlfun |#$-reader| (stream char arg)
    974989   (declare (ignore char))
    975    (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))
    976           (sym
    977            (%read-symbol-preserving-case
     990   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
     991     (multiple-value-bind (sym query)
     992         (%read-symbol-preserving-case
    978993            stream
    979             package)))
    980      (unless *read-suppress*
    981        (etypecase sym
    982          (symbol
    983           (when (eq (symbol-package sym) package)
    984             (unless arg (setq arg 0))
    985             (ecase arg
    986               (0
    987                (unless (and (constant-symbol-p sym)
    988                             (not (eq (%sym-global-value sym)
    989                                      (%unbound-marker-8))))
    990                  (load-os-constant sym stream)))
    991               (1 (makunbound sym) (load-os-constant sym stream))))
    992           sym)
    993          (string
    994           (let* ((val 0)
    995                  (len (length sym)))
    996             (dotimes (i 4 val)
    997               (let* ((ch (if (< i len) (char sym i) #\space)))
    998                 (setq val (logior (ash val 8) (char-code ch))))))))))))
     994            package)
     995       (unless *read-suppress*
     996         (etypecase sym
     997           (symbol
     998            (if query
     999              (load-os-constant sym query)
     1000              (progn
     1001                (when (eq (symbol-package sym) package)
     1002                  (unless arg (setq arg 0))
     1003                  (ecase arg
     1004                    (0
     1005                     (unless (and (constant-symbol-p sym)
     1006                                  (not (eq (%sym-global-value sym)
     1007                                           (%unbound-marker-8))))
     1008                       (load-os-constant sym)))
     1009                    (1 (makunbound sym) (load-os-constant sym))))
     1010                sym)))
     1011           (string
     1012            (let* ((val 0)
     1013                   (len (length sym)))
     1014              (dotimes (i 4 val)
     1015                (let* ((ch (if (< i len) (char sym i) #\space)))
     1016                  (setq val (logior (ash val 8) (char-code ch)))))))))))))
    9991017
    10001018(set-dispatch-macro-character #\# #\_
     
    10021020    (declare (ignore char))
    10031021    (unless arg (setq arg 0))
    1004     (let* ((sym (%read-symbol-preserving-case
     1022    (multiple-value-bind (sym query)
     1023        (%read-symbol-preserving-case
    10051024                 stream
    1006                  (find-package (ftd-interface-package-name *target-ftd*)))))
     1025                 (find-package (ftd-interface-package-name *target-ftd*)))
    10071026      (unless *read-suppress*
    10081027        (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol))
    1009         (let* ((def (if (eql arg 0)
    1010                       (gethash sym (ftd-external-function-definitions
    1011                                     *target-ftd*)))))
    1012           (if (and def (eq (macro-function sym) #'%external-call-expander))
    1013             sym
    1014             (load-external-function sym stream)))))))
     1028        (if query
     1029          (load-external-function sym t)
     1030          (let* ((def (if (eql arg 0)
     1031                        (gethash sym (ftd-external-function-definitions
     1032                                      *target-ftd*)))))
     1033            (if (and def (eq (macro-function sym) #'%external-call-expander))
     1034              sym
     1035              (load-external-function sym nil))))))))
    10151036
    10161037
Note: See TracChangeset for help on using the changeset viewer.