Changeset 12402


Ignore:
Timestamp:
Jul 13, 2009, 2:51:06 AM (10 years ago)
Author:
gb
Message:

Make the #$ reader macro try to lookup foreign variables if it can't
find a constant definition.

When printing the address of a foreign variable on 64-bit platforms,
use a width of 16, (not 8, and not 168 ...).

Location:
trunk/source/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/db-io.lisp

    r11418 r12402  
    10531053 #\# #\$
    10541054 (qlfun |#$-reader| (stream char arg)
    1055    (declare (ignore char))
    1056    (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
    1057      (multiple-value-bind (sym query source)
    1058          (%read-symbol-preserving-case
    1059             stream
    1060             package)
    1061        (unless *read-suppress*
    1062          (etypecase sym
    1063            (symbol
    1064             (if query
    1065               (values (load-os-constant sym query) source)
    1066               (progn
    1067                 (when (eq (symbol-package sym) package)
    1068                   (unless arg (setq arg 0))
    1069                   (ecase arg
    1070                     (0
    1071                      (unless (and (constant-symbol-p sym)
    1072                                   (not (eq (%sym-global-value sym)
    1073                                            (%unbound-marker-8))))
    1074                        (load-os-constant sym)))
    1075                     (1 (makunbound sym) (load-os-constant sym))))
    1076                 (values sym source))))
    1077            (string
    1078             (let* ((val 0)
    1079                    (len (length sym)))
    1080               (dotimes (i 4 (values val source))
    1081                 (let* ((ch (if (< i len) (char sym i) #\space)))
    1082                   (setq val (logior (ash val 8) (char-code ch)))))))))))))
     1055        (declare (ignore char))
     1056        (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
     1057          (multiple-value-bind (sym query source)
     1058              (%read-symbol-preserving-case
     1059               stream
     1060               package)
     1061            (unless *read-suppress*
     1062              (etypecase sym
     1063                (symbol
     1064                 (let* ((const (load-os-constant sym t)))
     1065                   (if query
     1066                     (values const source)
     1067                     (progn
     1068                       (if const
     1069                         (progn
     1070                           (when (eq (symbol-package sym) package)
     1071                             (unless arg (setq arg 0))
     1072                             (ecase arg
     1073                               (0
     1074                                (unless (and (constant-symbol-p sym)
     1075                                             (not (eq (%sym-global-value sym)
     1076                                                      (%unbound-marker-8))))
     1077                                  (load-os-constant sym)))
     1078                               (1 (makunbound sym) (load-os-constant sym))))
     1079                           (values sym source))
     1080                         (let* ((fv (%load-var sym nil)))
     1081                           (values
     1082                            (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
     1083                                                  (fv.type fv)
     1084                                                  0
     1085                                                  nil)
     1086                            source)))))))
     1087                (string
     1088                 (let* ((val 0)
     1089                        (len (length sym)))
     1090                   (dotimes (i 4 (values val source))
     1091                     (let* ((ch (if (< i len) (char sym i) #\space)))
     1092                       (setq val (logior (ash val 8) (char-code ch)))))))))))))
    10831093
    10841094(set-dispatch-macro-character #\# #\_
  • trunk/source/lib/foreign-types.lisp

    r11323 r12402  
    14821482        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
    14831483        #+64-bit-target
    1484                 (format out " (#x~168,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
     1484                (format out " (#x~16,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
    14851485        (format out " {unresolved} "))
    14861486      (when (and container (or (not (typep container 'macptr))
Note: See TracChangeset for help on using the changeset viewer.