0.9.4.29:

[sbcl.git] / src / code / symbol.lisp

diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 76d7ab3..39f89a7 100644 (file)
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -15,7 +15,7 @@
 
 (in-package "SB!IMPL")
 
 
 (in-package "SB!IMPL")
 

-(declaim (maybe-inline get %put getf remprop %putf get-properties keywordp))
+(declaim (maybe-inline get get2 get3 %put getf remprop %putf get-properties keywordp))

 
 (defun symbol-value (symbol)
   #!+sb-doc
 
 (defun symbol-value (symbol)
   #!+sb-doc

@@ -35,37 +35,23 @@
   (about-to-modify-symbol-value symbol)
   (%set-symbol-value symbol new-value))
 
   (about-to-modify-symbol-value symbol)
   (%set-symbol-value symbol new-value))
 

-;;; can't do this yet, the appropriate vop only gets defined in
-;;; compiler/target/cell, 400 lines hence
-;;;(defun %set-symbol-value (symbol new-value)
-;;;  (%set-symbol-value symbol new-value))
+(defun %set-symbol-value (symbol new-value)
+  (%set-symbol-value symbol new-value))

 
 (defun makunbound (symbol)
   #!+sb-doc
   "Make SYMBOL unbound, removing any value it may currently have."
 
 (defun makunbound (symbol)
   #!+sb-doc
   "Make SYMBOL unbound, removing any value it may currently have."

-  (set symbol
-       (%primitive sb!c:make-other-immediate-type
-                  0
-                  sb!vm:unbound-marker-widetag))
-  symbol)
+  (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
+    (set symbol
+         (%primitive sb!c:make-other-immediate-type
+                     0
+                     sb!vm:unbound-marker-widetag))
+    symbol))

 
 ;;; Return the built-in hash value for SYMBOL.
 
 ;;; Return the built-in hash value for SYMBOL.

-
-;;; only backends for which a SYMBOL-HASH vop exists.  In the past,
-;;; when the MIPS backend supported (or nearly did) a generational
-;;; (non-conservative) garbage collector, this read (OR X86 MIPS).
-;;; Having excised the vestigial support for GENGC, this now only
-;;; applies for the x86 port, but if someone were to rework the GENGC
-;;; support, this might change again.  -- CSR, 2002-08-26
-#!+x86 

 (defun symbol-hash (symbol)
   (symbol-hash symbol))
 
 (defun symbol-hash (symbol)
   (symbol-hash symbol))
 

-;;; Compute the hash value for SYMBOL.
-#!-x86
-(defun symbol-hash (symbol)
-  (%sxhash-simple-string (symbol-name symbol)))
-

 (defun symbol-function (symbol)
   #!+sb-doc
   "Return SYMBOL's current function definition. Settable with SETF."
 (defun symbol-function (symbol)
   #!+sb-doc
   "Return SYMBOL's current function definition. Settable with SETF."

@@ -73,7 +59,9 @@
 
 (defun (setf symbol-function) (new-value symbol)
   (declare (type symbol symbol) (type function new-value))
 
 (defun (setf symbol-function) (new-value symbol)
   (declare (type symbol symbol) (type function new-value))

-  (setf (%coerce-name-to-fun symbol) new-value))
+  (with-single-package-locked-error
+      (:symbol symbol "setting the symbol-function of ~A")
+    (setf (%coerce-name-to-fun symbol) new-value)))

 
 (defun symbol-plist (symbol)
   #!+sb-doc
 
 (defun symbol-plist (symbol)
   #!+sb-doc

@@ -106,13 +94,32 @@
   #!+sb-doc
   "Look on the property list of SYMBOL for the specified INDICATOR. If this
   is found, return the associated value, else return DEFAULT."
   #!+sb-doc
   "Look on the property list of SYMBOL for the specified INDICATOR. If this
   is found, return the associated value, else return DEFAULT."

-  (do ((pl (symbol-plist symbol) (cddr pl)))
-      ((atom pl) default)
-    (cond ((atom (cdr pl))
-          (error "~S has an odd number of items in its property list."
-                  symbol))
-         ((eq (car pl) indicator)
-          (return (cadr pl))))))
+  (get3 symbol indicator default))
+
+(defun get2 (symbol indicator)
+  (get3 symbol indicator nil))
+#|
+  (let (cdr-pl)
+    (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
+        ((atom pl) nil)
+      (setf cdr-pl (cdr pl))
+      (cond ((atom cdr-pl)
+             (error "~S has an odd number of items in its property list."
+                    symbol))
+            ((eq (car pl) indicator)
+             (return (car cdr-pl)))))))
+|#
+
+(defun get3 (symbol indicator default)
+  (let (cdr-pl)
+    (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
+        ((atom pl) default)
+      (setq cdr-pl (cdr pl))
+      (cond ((atom cdr-pl)
+             (error "~S has an odd number of items in its property list."
+                    symbol))
+            ((eq (car pl) indicator)
+             (return (car cdr-pl)))))))

 
 (defun %put (symbol indicator value)
   #!+sb-doc
 
 (defun %put (symbol indicator value)
   #!+sb-doc

@@ -121,14 +128,14 @@
   (do ((pl (symbol-plist symbol) (cddr pl)))
       ((endp pl)
        (setf (symbol-plist symbol)
   (do ((pl (symbol-plist symbol) (cddr pl)))
       ((endp pl)
        (setf (symbol-plist symbol)

-            (list* indicator value (symbol-plist symbol)))
+             (list* indicator value (symbol-plist symbol)))

        value)
     (cond ((endp (cdr pl))
        value)
     (cond ((endp (cdr pl))

-          (error "~S has an odd number of items in its property list."
-                 symbol))
-         ((eq (car pl) indicator)
-          (rplaca (cdr pl) value)
-          (return value)))))
+           (error "~S has an odd number of items in its property list."
+                  symbol))
+          ((eq (car pl) indicator)
+           (rplaca (cdr pl) value)
+           (return value)))))

 
 (defun remprop (symbol indicator)
   #!+sb-doc
 
 (defun remprop (symbol indicator)
   #!+sb-doc

@@ -143,13 +150,13 @@
        (prev nil pl))
       ((atom pl) nil)
     (cond ((atom (cdr pl))
        (prev nil pl))
       ((atom pl) nil)
     (cond ((atom (cdr pl))

-          (error "~S has an odd number of items in its property list."
-                 symbol))
-         ((eq (car pl) indicator)
-          (cond (prev (rplacd (cdr prev) (cddr pl)))
-                (t
-                 (setf (symbol-plist symbol) (cddr pl))))
-          (return pl)))))
+           (error "~S has an odd number of items in its property list."
+                  symbol))
+          ((eq (car pl) indicator)
+           (cond (prev (rplacd (cdr prev) (cddr pl)))
+                 (t
+                  (setf (symbol-plist symbol) (cddr pl))))
+           (return pl)))))

 
 (defun getf (place indicator &optional (default ()))
   #!+sb-doc
 
 (defun getf (place indicator &optional (default ()))
   #!+sb-doc

@@ -158,13 +165,13 @@
   (do ((plist place (cddr plist)))
       ((null plist) default)
     (cond ((atom (cdr plist))
   (do ((plist place (cddr plist)))
       ((null plist) default)
     (cond ((atom (cdr plist))

-          (error 'simple-type-error
-                 :format-control "malformed property list: ~S."
-                 :format-arguments (list place)
-                 :datum (cdr plist)
-                 :expected-type 'cons))
-         ((eq (car plist) indicator)
-          (return (cadr plist))))))
+           (error 'simple-type-error
+                  :format-control "malformed property list: ~S."
+                  :format-arguments (list place)
+                  :datum (cdr plist)
+                  :expected-type 'cons))
+          ((eq (car plist) indicator)
+           (return (cadr plist))))))

 
 (defun %putf (place property new-value)
   (declare (type list place))
 
 (defun %putf (place property new-value)
   (declare (type list place))

@@ -183,13 +190,13 @@
   (do ((plist place (cddr plist)))
       ((null plist) (values nil nil nil))
     (cond ((atom (cdr plist))
   (do ((plist place (cddr plist)))
       ((null plist) (values nil nil nil))
     (cond ((atom (cdr plist))

-          (error 'simple-type-error
-                 :format-control "malformed property list: ~S."
-                 :format-arguments (list place)
-                 :datum (cdr plist)
-                 :expected-type 'cons))
-         ((memq (car plist) indicator-list)
-          (return (values (car plist) (cadr plist) plist))))))
+           (error 'simple-type-error
+                  :format-control "malformed property list: ~S."
+                  :format-arguments (list place)
+                  :datum (cdr plist)
+                  :expected-type 'cons))
+          ((memq (car plist) indicator-list)
+           (return (values (car plist) (cadr plist) plist))))))

 
 (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
   #!+sb-doc
 
 (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
   #!+sb-doc

@@ -201,9 +208,9 @@
   (setq new-symbol (make-symbol (symbol-name symbol)))
   (when copy-props
     (%set-symbol-value new-symbol
   (setq new-symbol (make-symbol (symbol-name symbol)))
   (when copy-props
     (%set-symbol-value new-symbol

-                      (%primitive sb!c:fast-symbol-value symbol))
+                       (%primitive sb!c:fast-symbol-value symbol))

     (setf (symbol-plist new-symbol)
     (setf (symbol-plist new-symbol)

-         (copy-list (symbol-plist symbol)))
+          (copy-list (symbol-plist symbol)))

     (when (fboundp symbol)
       (setf (symbol-function new-symbol) (symbol-function symbol))))
   new-symbol)
     (when (fboundp symbol)
       (setf (symbol-function new-symbol) (symbol-function symbol))))
   new-symbol)

@@ -235,20 +242,20 @@
   (let ((old *gensym-counter*))
     (unless (numberp thing)
       (let ((new (etypecase old
   (let ((old *gensym-counter*))
     (unless (numberp thing)
       (let ((new (etypecase old

-                  (index (1+ old))
-                  (unsigned-byte (1+ old)))))
-       (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
-       (setq *gensym-counter* new)))
+                   (index (1+ old))
+                   (unsigned-byte (1+ old)))))
+        (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
+        (setq *gensym-counter* new)))

     (multiple-value-bind (prefix int)
     (multiple-value-bind (prefix int)

-       (etypecase thing
-         (simple-string (values thing old))
-         (fixnum (values "G" thing))
-         (string (values (coerce thing 'simple-string) old)))
+        (etypecase thing
+          (simple-string (values thing old))
+          (fixnum (values "G" thing))
+          (string (values (coerce thing 'simple-string) old)))

       (declare (simple-string prefix))
       (make-symbol
        (concatenate 'simple-string prefix
       (declare (simple-string prefix))
       (make-symbol
        (concatenate 'simple-string prefix

-                   (the simple-string
-                        (quick-integer-to-string int)))))))
+                    (the simple-string
+                         (quick-integer-to-string int)))))))

 
 (defvar *gentemp-counter* 0)
 (declaim (type unsigned-byte *gentemp-counter*))
 
 (defvar *gentemp-counter* 0)
 (declaim (type unsigned-byte *gentemp-counter*))

@@ -259,9 +266,9 @@
   (declare (type string prefix))
   (loop
     (let ((*print-base* 10)
   (declare (type string prefix))
   (loop
     (let ((*print-base* 10)

-         (*print-radix* nil)
-         (*print-pretty* nil)
-         (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))
+          (*print-radix* nil)
+          (*print-pretty* nil)
+          (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))

       (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
       (multiple-value-bind (symbol existsp) (find-symbol new-pname package)

-       (declare (ignore symbol))
-       (unless existsp (return (values (intern new-pname package))))))))
+        (declare (ignore symbol))
+        (unless existsp (return (values (intern new-pname package))))))))