(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 (variable)
+(defun symbol-value (symbol)
#!+sb-doc
- "VARIABLE must evaluate to a symbol. This symbol's current special
- value is returned."
+ "Return SYMBOL's current bound value."
(declare (optimize (safety 1)))
- (symbol-value variable))
+ (symbol-value symbol))
-(defun boundp (variable)
+(defun boundp (symbol)
#!+sb-doc
- "VARIABLE must evaluate to a symbol. Return NIL if this symbol is
- unbound, T if it has a value."
- (boundp variable))
+ "Return non-NIL if SYMBOL is bound to a value."
+ (boundp symbol))
-(defun set (variable new-value)
+(defun set (symbol new-value)
#!+sb-doc
- "VARIABLE must evaluate to a symbol. This symbol's special value cell is
- set to the specified new value."
- (declare (type symbol variable))
- (about-to-modify variable)
- (%set-symbol-value variable new-value))
+ "Set SYMBOL's value cell to NEW-VALUE."
+ (declare (type symbol symbol))
+ (about-to-modify-symbol-value symbol)
+ (%set-symbol-value symbol new-value))
(defun %set-symbol-value (symbol new-value)
(%set-symbol-value symbol new-value))
-(defun makunbound (variable)
+(defun makunbound (symbol)
#!+sb-doc
- "VARIABLE must evaluate to a symbol. This symbol is made unbound,
- removing any value it may currently have."
- (set variable
- (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type))
- variable)
-
-#!+(or x86 mips) ;; only backends for which a symbol-hash vop exists
+ "Make SYMBOL unbound, removing any value it may currently have."
+ (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.
(defun symbol-hash (symbol)
- #!+sb-doc
- "Return the built-in hash value for symbol."
(symbol-hash symbol))
-#!-(or x86 mips)
-(defun symbol-hash (symbol)
- #!+sb-doc
- "Return the built-in hash value for symbol."
- (%sxhash-simple-string (symbol-name symbol)))
-
-
-(defun symbol-function (variable)
+(defun symbol-function (symbol)
#!+sb-doc
- "VARIABLE must evaluate to a symbol. This symbol's current definition
- is returned. Settable with SETF."
- (raw-definition variable))
+ "Return SYMBOL's current function definition. Settable with SETF."
+ (%coerce-name-to-fun symbol))
-(defun fset (symbol new-value)
+(defun (setf symbol-function) (new-value symbol)
(declare (type symbol symbol) (type function new-value))
- (setf (raw-definition 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 (variable)
+(defun symbol-plist (symbol)
#!+sb-doc
- "Return the property list of a symbol."
- (symbol-plist variable))
+ "Return SYMBOL's property list."
+ (symbol-plist symbol))
(defun %set-symbol-plist (symbol new-value)
(setf (symbol-plist symbol) new-value))
-(defun symbol-name (variable)
+(defun symbol-name (symbol)
#!+sb-doc
- "Return the print name of a symbol."
- (symbol-name variable))
+ "Return SYMBOL's name as a string."
+ (symbol-name symbol))
-(defun symbol-package (variable)
+(defun symbol-package (symbol)
#!+sb-doc
- "Return the package a symbol is interned in, or NIL if none."
- (symbol-package variable))
+ "Return the package SYMBOL was interned in, or NIL if none."
+ (symbol-package symbol))
(defun %set-symbol-package (symbol package)
(declare (type symbol symbol))
(defun make-symbol (string)
#!+sb-doc
"Make and return a new symbol with the STRING as its print name."
- #!-gengc (make-symbol string)
- #!+gengc (%make-symbol (random most-positive-fixnum) string))
+ (make-symbol string))
(defun get (symbol indicator &optional (default nil))
#!+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
(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))
- (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
(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
- "Searches the property list stored in Place for an indicator EQ to Indicator.
- If one is found, the corresponding value is returned, else the Default is
- returned."
+ "Search the property list stored in Place for an indicator EQ to INDICATOR.
+ If one is found, return the corresponding value, else return DEFAULT."
(do ((plist place (cddr plist)))
((null plist) default)
(cond ((atom (cdr plist))
- (error "~S is a malformed property list."
- place))
- ((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 get-properties (place indicator-list)
#!+sb-doc
- "Like GETF, except that Indicator-List is a list of indicators which will
- be looked for in the property list stored in Place. Three values are
+ "Like GETF, except that INDICATOR-LIST is a list of indicators which will
+ be looked for in the property list stored in PLACE. Three values are
returned, see manual for details."
(do ((plist place (cddr plist)))
((null plist) (values nil nil nil))
(cond ((atom (cdr plist))
- (error "~S is a malformed proprty list."
- place))
- ((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
(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)
- (copy-list (symbol-plist symbol)))
+ (copy-list (symbol-plist symbol)))
(when (fboundp symbol)
(setf (symbol-function new-symbol) (symbol-function symbol))))
new-symbol)
(defun keywordp (object)
#!+sb-doc
- "Returns true if Object is a symbol in the keyword package."
+ "Return true if Object is a symbol in the \"KEYWORD\" package."
(and (symbolp object)
(eq (symbol-package object) *keyword-package*)))
\f
(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)
- (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
- (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*))
(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)
- (declare (ignore symbol))
- (unless existsp (return (values (intern new-pname package))))))))
+ (declare (ignore symbol))
+ (unless existsp (return (values (intern new-pname package))))))))
projects / sbcl.git / blobdiff