Changeset 15579


Ignore:
Timestamp:
Jan 13, 2013, 12:05:19 PM (6 years ago)
Author:
gb
Message:

When scanning/dumping symbols, check to see if the symbol is a
(proxy) SETF function symbol for some name X; if so, dump the
symbol as (LOAD-TIME-VALUE (SETF-FUNCTION-NAME X)).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/nfcomp.lisp

    r15536 r15579  
    9898(defparameter *fasl-package-qualified-symbols* '(*loading-file-source-file* set-package %define-package)
    9999  "These symbols are always fasdumped with full package qualification.")
     100
     101(defvar *fasl-setf-name-alias-alist* ())
    100102
    101103(defun setup-target-features (backend features)
     
    233235                                      :inferred
    234236                                      external-format))
     237           (*fasl-setf-name-alias-alist* ())
    235238           (forms nil))
    236239      (let ((current *outstanding-deferred-warnings*) last)
     
    14531456          (fasl-scan-form compiled-initform))))))
    14541457
     1458(defun fasl-setf-name-inverse-p (sym &optional create)
     1459  (or (cdr (assoc sym *fasl-setf-name-alias-alist*))
     1460      (and create
     1461           (let* (#+notyet (pname (symbol-name sym))
     1462                  #+notyet (namelen (length pname))
     1463                  (setf-for
     1464                   (and #+notyet (> namelen 2)
     1465                        #+notyet (eql (schar pname 0) #\()
     1466                        #+notyet (eql (schar pname (1- namelen)) #\))
     1467                        (gethash sym %setf-function-name-inverses%))))
     1468           (when setf-for
     1469             (let* ((list `(,cfasl-load-time-eval-sym (setf-function-name ',setf-for))))
     1470               (fasl-scan-list list)
     1471               (push (cons sym list) *fasl-setf-name-alias-alist*)
     1472               list))))))
     1473 
    14551474(defun fasl-scan-symbol (form)
    1456   (fasl-scan-ref form)
    1457   (fasl-scan-form (symbol-package form)))
     1475  (unless (fasl-setf-name-inverse-p form t)
     1476    (fasl-scan-ref form)
     1477    (fasl-scan-form (symbol-package form))))
    14581478 
    14591479
     
    19371957
    19381958(defun fasl-dump-symbol (sym)
    1939   (let* ((pkg (symbol-package sym))
    1940          (name (symbol-name sym))
    1941          (nextra (utf-8-extra-bytes name))
    1942          (ascii (eql nextra 0))
    1943          (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
    1944                 (declare (fixnum i))
    1945                 (unless (zerop i) i))))
    1946     (cond ((null pkg)
    1947            (progn
    1948              (fasl-out-opcode (if idx
    1949                                 (if ascii $fasl-nvmksym-special $fasl-vmksym-special)
    1950                                 (if ascii $fasl-nvmksym $fasl-vmksym))
    1951                               sym)
    1952              (if ascii
    1953                (fasl-out-nvstring name)
    1954                (fasl-out-vstring name nextra))))
    1955           (*fasdump-epush*
    1956            (progn
    1957              (fasl-out-byte (fasl-epush-op (if idx
    1958                                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
    1959                                              (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern))))
    1960              (fasl-dump-form pkg)
    1961              (fasl-dump-epush sym)
    1962              (if ascii
    1963                (fasl-out-nvstring name)
    1964                (fasl-out-vstring name nextra))))
    1965           (t
    1966            (progn
    1967              (fasl-out-byte (if idx
    1968                               (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
    1969                               (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern)))
    1970              (fasl-dump-form pkg)
    1971              (if ascii
    1972                (fasl-out-nvstring name)
    1973                (fasl-out-vstring name nextra)))))))
     1959  (let* ((inverse (fasl-setf-name-inverse-p sym)))
     1960    (if inverse
     1961      (fasl-dump-form inverse)
     1962      (let* ((pkg (symbol-package sym))
     1963             (name (symbol-name sym))
     1964             (nextra (utf-8-extra-bytes name))
     1965             (ascii (eql nextra 0))
     1966             (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
     1967                    (declare (fixnum i))
     1968                    (unless (zerop i) i))))
     1969        (cond ((null pkg)
     1970               (progn
     1971                 (fasl-out-opcode (if idx
     1972                                    (if ascii $fasl-nvmksym-special $fasl-vmksym-special)
     1973                                    (if ascii $fasl-nvmksym $fasl-vmksym))
     1974                                  sym)
     1975                 (if ascii
     1976                   (fasl-out-nvstring name)
     1977                   (fasl-out-vstring name nextra))))
     1978              (*fasdump-epush*
     1979               (progn
     1980                 (fasl-out-byte (fasl-epush-op (if idx
     1981                                                 (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
     1982                                                 (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern))))
     1983                 (fasl-dump-form pkg)
     1984                 (fasl-dump-epush sym)
     1985                 (if ascii
     1986                   (fasl-out-nvstring name)
     1987                   (fasl-out-vstring name nextra))))
     1988              (t
     1989               (progn
     1990                 (fasl-out-byte (if idx
     1991                                  (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
     1992                                  (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern)))
     1993                 (fasl-dump-form pkg)
     1994                 (if ascii
     1995                   (fasl-out-nvstring name)
     1996                   (fasl-out-vstring name nextra)))))))))
    19741997
    19751998
Note: See TracChangeset for help on using the changeset viewer.