run-program: proper handling of :if-input-does-not-exist NIL.

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

diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index ab82c19..f2f7f35 100644 (file)
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -15,7 +15,7 @@
 
 (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
@@ -32,20 +32,37 @@
   #!+sb-doc
   "Set SYMBOL's value cell to NEW-VALUE."
   (declare (type symbol symbol))
-  (about-to-modify-symbol-value symbol)
+  (about-to-modify-symbol-value symbol 'set new-value)
   (%set-symbol-value symbol new-value))
 
 (defun %set-symbol-value (symbol new-value)
   (%set-symbol-value symbol new-value))
 
+(defun symbol-global-value (symbol)
+  #!+sb-doc
+  "Return the SYMBOL's current global value. Identical to SYMBOL-VALUE,
+in single-threaded builds: in multithreaded builds bound values are
+distinct from the global value. Can also be SETF."
+  (declare (optimize (safety 1)))
+  (symbol-global-value symbol))
+
+(defun set-symbol-global-value (symbol new-value)
+  (about-to-modify-symbol-value symbol 'set new-value)
+  (sb!kernel:%set-symbol-global-value symbol new-value))
+
+(declaim (inline %makunbound))
+(defun %makunbound (symbol)
+  (%set-symbol-value symbol (%primitive sb!c:make-other-immediate-type
+                                        0 sb!vm:unbound-marker-widetag)))
+
 (defun makunbound (symbol)
   #!+sb-doc
   "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))
+    (when (and (info :variable :always-bound symbol))
+      (error "Can't make ~A variable unbound: ~S" 'always-bound symbol))
+    (about-to-modify-symbol-value symbol 'makunbound)
+    (%makunbound symbol)
     symbol))
 
 ;;; Return the built-in hash value for SYMBOL.
@@ -88,19 +105,41 @@
 (defun make-symbol (string)
   #!+sb-doc
   "Make and return a new symbol with the STRING as its print name."
-  (make-symbol string))
+  (declare (type string string))
+  (%make-symbol (if (simple-string-p string)
+                    string
+                    (subseq string 0))))
 
 (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
@@ -141,7 +180,7 @@
 
 (defun getf (place indicator &optional (default ()))
   #!+sb-doc
-  "Search the property list stored in Place for an indicator EQ to INDICATOR.
+  "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)
@@ -207,6 +246,11 @@
 \f
 ;;;; GENSYM and friends
 
+(defun %make-symbol-name (prefix counter)
+  (with-output-to-string (s)
+    (write-string prefix s)
+    (%output-integer-in-base counter 10 s)))
+
 (defvar *gensym-counter* 0
   #!+sb-doc
   "counter for generating unique GENSYM symbols")
@@ -225,7 +269,7 @@
       (let ((new (etypecase old
                    (index (1+ old))
                    (unsigned-byte (1+ old)))))
-        (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
+        (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
         (setq *gensym-counter* new)))
     (multiple-value-bind (prefix int)
         (etypecase thing
@@ -233,10 +277,7 @@
           (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)))))))
+      (make-symbol (%make-symbol-name prefix int)))))
 
 (defvar *gentemp-counter* 0)
 (declaim (type unsigned-byte *gentemp-counter*))
@@ -245,11 +286,6 @@
   #!+sb-doc
   "Creates a new symbol interned in package PACKAGE with the given PREFIX."
   (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*))))
-      (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
-        (declare (ignore symbol))
-        (unless existsp (return (values (intern new-pname package))))))))
+  (loop for name = (%make-symbol-name prefix (incf *gentemp-counter*))
+        while (nth-value 1 (find-symbol name package))
+        finally (return (values (intern name package)))))