Changeset 15580


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

(Largely) get rid of the SETF package: we only need to keep it around
until things are bootstrapped. Serialize creation of SETF function
names. Create those names as uninterned symbols (which we can externalize
via LOAD-TIME-VALUE.) Don't worry too much about generating unique pnames;
do worry that SETF names for different symbols will be unique (even if those
names had the same pnames/package/visibility when their SETF names were
created.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-aprims.lisp

    r15477 r15580  
    265265(defvar %setf-function-name-inverses% (make-hash-table :weak t :test 'eq))
    266266
     267(defvar *setf-names-lock* (make-lock))
    267268(defun setf-function-name (sym)
    268269  "Returns the symbol in the SETF package that holds the binding of (SETF sym)"
    269270   (or (gethash sym %setf-function-names%)
    270        (progn
    271          (let* ((setf-package-sym (construct-setf-function-name sym)))
    272            (setf (gethash setf-package-sym %setf-function-name-inverses%) sym
    273                  (gethash sym %setf-function-names%) setf-package-sym)))))
     271       (with-lock-grabbed (*setf-names-lock*)
     272         (or (gethash sym %setf-function-names%)
     273             (let* ((setf-package-sym (construct-setf-function-name sym)))
     274               (setf (gethash setf-package-sym %setf-function-name-inverses%) sym
     275                     (gethash sym %setf-function-names%) setf-package-sym))))))
    274276
    275277(defun existing-setf-function-name (sym)
     
    284286                     
    285287
    286 (defconstant *setf-package* (or (find-package "SETF") (make-package "SETF" :use nil :external-size 1)))
     288(defconstant *setf-package* (or (find-package "SETF")
     289                                (make-package
     290                                 "DEPRECATED SETF PACKAGE"
     291                                 :nicknames '("SETF") :use nil :external-size 1)))
    287292
    288293(defun construct-setf-function-name (sym)
    289   (let ((pkg (symbol-package sym)))
    290     (setq sym (symbol-name sym))
    291     (if (null pkg)
    292       (gentemp sym *setf-package*)
    293       (values
    294        (intern
    295         ;;I wonder, if we didn't check, would anybody report it as a bug?
    296         (if (not (%str-member #\: (setq pkg (package-name pkg))))
    297           (%str-cat pkg "::" sym)
    298           (%str-cat (prin1-to-string pkg) "::" (princ-to-string sym)))
    299         *setf-package*)))))
     294  (make-symbol (%str-cat "(setf " (symbol-name sym) ")")))
    300295
    301296(defun setf-function-name-p (name)
Note: See TracChangeset for help on using the changeset viewer.