0.8alpha.0.9:

	defined WITH-UNIQUE-NAMES
	grepped for 'gensym "', and used WITH-UNIQUE-NAMES instead
		where it seemed more convenient
	tweaked miscellaneous text I noticed in my greppage
	added test case for just-fixed compiler bug
	bugfix: one last s/layout-class/layout-classoid/

diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp
index ebf484e..c48984c 100644 (file)
--- a/contrib/sb-aclrepl/inspect.lisp
+++ b/contrib/sb-aclrepl/inspect.lisp
@@ -56,7 +56,6 @@ The commands are:
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
 

-

 (defun inspector-fun (object input-stream output-stream)
   (declare (ignore input-stream))
   (let ((*current-inspect* nil)
 (defun inspector-fun (object input-stream output-stream)
   (declare (ignore input-stream))
   (let ((*current-inspect* nil)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index be590dc..84c86f8 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -860,7 +860,7 @@ retained, possibly temporariliy, because it might be used internally."
              "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package SB!UNIX
              "FEATUREP"
              "FLUSH-STANDARD-OUTPUT-STREAMS"
              "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package SB!UNIX
              "FEATUREP"
              "FLUSH-STANDARD-OUTPUT-STREAMS"

-             "MAKE-GENSYM-LIST"
+             "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" 

              "ABOUT-TO-MODIFY-SYMBOL-VALUE"
             "SYMBOL-SELF-EVALUATING-P"
              "PRINT-PRETTY-ON-STREAM-P"
              "ABOUT-TO-MODIFY-SYMBOL-VALUE"
             "SYMBOL-SELF-EVALUATING-P"
              "PRINT-PRETTY-ON-STREAM-P"

diff --git a/src/assembly/hppa/support.lisp b/src/assembly/hppa/support.lisp
index 1ed5d6a..18f8b8f 100644 (file)
--- a/src/assembly/hppa/support.lisp
+++ b/src/assembly/hppa/support.lisp
@@ -4,7 +4,7 @@
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
     (:raw
 (!def-vm-support-routine generate-call-sequence (name style vop)
   (ecase style
     (:raw

-     (let ((fixup (gensym "FIXUP-")))
+     (with-unique-names (fixup)

        (values
        `((let ((fixup (make-fixup ',name :assembly-routine)))
            (inst ldil fixup ,fixup)
        (values
        `((let ((fixup (make-fixup ',name :assembly-routine)))
            (inst ldil fixup ,fixup)

@@ -41,7 +41,7 @@
                      ,nfp-save)
          (:save-p :compute-only)))))
     (:none
                      ,nfp-save)
          (:save-p :compute-only)))))
     (:none

-     (let ((fixup (gensym "FIXUP-")))
+     (with-unique-names (fixup)

        (values
        `((let ((fixup (make-fixup ',name :assembly-routine)))
            (inst ldil fixup ,fixup)
        (values
        `((let ((fixup (make-fixup ',name :assembly-routine)))
            (inst ldil fixup ,fixup)

diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp
index fc0d0a0..739fa11 100644 (file)
--- a/src/code/cross-sap.lisp
+++ b/src/code/cross-sap.lisp
@@ -46,7 +46,7 @@
                   (defun ,name (sap offset)
                     (declare (ignore sap offset))
                     (sap-ref-stub ',name))
                   (defun ,name (sap offset)
                     (declare (ignore sap offset))
                     (sap-ref-stub ',name))

-                  ,@(let ((setter-stub (gensym "SAP-SETTER-STUB-")))
+                  ,@(let ((setter-stub (gensym "SETTER-STUB-")))

                       `((defun ,setter-stub (foo sap offset)
                           (declare (ignore foo sap offset))
                           (sap-ref-stub '(setf ,name)))
                       `((defun ,setter-stub (foo sap offset)
                           (declare (ignore foo sap offset))
                           (sap-ref-stub '(setf ,name)))

diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp
index ac2702f..c80dcba 100644 (file)
--- a/src/code/defmacro.lisp
+++ b/src/code/defmacro.lisp
@@ -23,8 +23,7 @@
     (when (special-operator-p name)
       (error "The special operator ~S can't be redefined as a macro."
              name))
     (when (special-operator-p name)
       (error "The special operator ~S can't be redefined as a macro."
              name))

-    (let ((whole (gensym "WHOLE-"))
-         (environment (gensym "ENV-")))
+    (with-unique-names (whole environment)

       (multiple-value-bind (new-body local-decs doc)
          (parse-defmacro lambda-list whole body name 'defmacro
                          :environment environment)
       (multiple-value-bind (new-body local-decs doc)
          (parse-defmacro lambda-list whole body name 'defmacro
                          :environment environment)

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 6822ef2..c020545 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -52,7 +52,7 @@
           (sb!c::compiler-note
            "implementation limitation: ~
              Non-toplevel DEFSTRUCT constructors are slow.")
           (sb!c::compiler-note
            "implementation limitation: ~
              Non-toplevel DEFSTRUCT constructors are slow.")

-          (let ((layout (gensym "LAYOUT")))
+          (with-unique-names (layout)

             `(let ((,layout (info :type :compiler-layout ',name)))
                (unless (typep (layout-info ,layout) 'defstruct-description)
                  (error "Class is not a structure class: ~S" ',name))
             `(let ((,layout (info :type :compiler-layout ',name)))
                (unless (typep (layout-info ,layout) 'defstruct-description)
                  (error "Class is not a structure class: ~S" ',name))

diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp
index 7e9b8e1..1a74b38 100644 (file)
--- a/src/code/destructuring-bind.lisp
+++ b/src/code/destructuring-bind.lisp
@@ -12,7 +12,7 @@
 (defmacro-mundanely destructuring-bind (lambda-list arg-list &rest body)
   #!+sb-doc
   "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
 (defmacro-mundanely destructuring-bind (lambda-list arg-list &rest body)
   #!+sb-doc
   "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."

-  (let* ((arg-list-name (gensym "ARG-LIST-")))
+  (let ((arg-list-name (gensym "ARG-LIST-")))

     (multiple-value-bind (body local-decls)
        (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
                        :anonymousp t
     (multiple-value-bind (body local-decls)
        (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
                        :anonymousp t

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index fe0f319..d279677 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -809,12 +809,6 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
         :format-string "~@<~S ~_is not a ~_~S~:>"
         :format-arguments (list value type)))
 \f
         :format-string "~@<~S ~_is not a ~_~S~:>"
         :format-arguments (list value type)))
 \f

-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
-  (loop repeat n collect (gensym)))
-

 ;;; Return a function like FUN, but expecting its (two) arguments in
 ;;; the opposite order that FUN does.
 (declaim (inline swapped-args-fun))
 ;;; Return a function like FUN, but expecting its (two) arguments in
 ;;; the opposite order that FUN does.
 (declaim (inline swapped-args-fun))

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index b09d1f0..76a8c43 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -414,8 +414,7 @@ GET-SETF-EXPANSION directly."
   (unless (symbolp access-fn)
     (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
           access-fn))
   (unless (symbolp access-fn)
     (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
           access-fn))

-  (let ((whole (gensym "WHOLE-"))
-       (environment (gensym "ENV-")))
+  (with-unique-names (whole environment)

     (multiple-value-bind (body local-decs doc)
        (parse-defmacro lambda-list whole body access-fn
                        'sb!xc:define-setf-expander
     (multiple-value-bind (body local-decs doc)
        (parse-defmacro lambda-list whole body access-fn
                        'sb!xc:define-setf-expander

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 3fa574f..766b241 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -245,20 +245,19 @@
 ;;;; alien type defining stuff
 
 (def!macro define-alien-type-translator (name lambda-list &body body)
 ;;;; alien type defining stuff
 
 (def!macro define-alien-type-translator (name lambda-list &body body)

-  (let ((whole (gensym "WHOLE"))
-       (env (gensym "ENV"))
-       (defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
-    (multiple-value-bind (body decls docs)
-       (sb!kernel:parse-defmacro lambda-list whole body name
-                                 'define-alien-type-translator
-                                 :environment env)
-      `(eval-when (:compile-toplevel :load-toplevel :execute)
-        (defun ,defun-name (,whole ,env)
-          (declare (ignorable ,env))
-          ,@decls
-          (block ,name
-            ,body))
-        (%define-alien-type-translator ',name #',defun-name ,docs)))))
+  (with-unique-names (whole env)
+    (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
+      (multiple-value-bind (body decls docs)
+         (sb!kernel:parse-defmacro lambda-list whole body name
+                                   'define-alien-type-translator
+                                   :environment env)
+       `(eval-when (:compile-toplevel :load-toplevel :execute)
+          (defun ,defun-name (,whole ,env)
+            (declare (ignorable ,env))
+            ,@decls
+            (block ,name
+              ,body))
+          (%define-alien-type-translator ',name #',defun-name ,docs))))))

 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun %define-alien-type-translator (name translator docs)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun %define-alien-type-translator (name translator docs)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 6f6e610..c74a081 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -97,8 +97,7 @@
 ;;;
 ;;; WHEN controls when the forms are executed.
 (defmacro !define-superclasses (type-class-name specs when)
 ;;;
 ;;; WHEN controls when the forms are executed.
 (defmacro !define-superclasses (type-class-name specs when)

-  (let ((type-class (gensym "TYPE-CLASS-"))
-       (info (gensym "INFO")))
+  (with-unique-names (type-class info)

     `(,when
        (let ((,type-class (type-class-or-lose ',type-class-name))
             (,info (mapcar (lambda (spec)
     `(,when
        (let ((,type-class (type-class-or-lose ',type-class-name))
             (,info (mapcar (lambda (spec)

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 51214a4..9f5a486 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -100,7 +100,6 @@
            :format-control "Symbol macro name already declared constant: ~S."
            :format-arguments (list name))))
   name)
            :format-control "Symbol macro name already declared constant: ~S."
            :format-arguments (list name))))
   name)

-

 \f
 ;;;; DEFINE-COMPILER-MACRO
 
 \f
 ;;;; DEFINE-COMPILER-MACRO
 

@@ -128,8 +127,7 @@
     (error 'simple-program-error
           :format-control "cannot define a compiler-macro for a special operator: ~S"
           :format-arguments (list name)))
     (error 'simple-program-error
           :format-control "cannot define a compiler-macro for a special operator: ~S"
           :format-arguments (list name)))

-  (let ((whole (gensym "WHOLE-"))
-       (environment (gensym "ENV-")))
+  (with-unique-names (whole environment)

     (multiple-value-bind (body local-decs doc)
        (parse-defmacro lambda-list whole body name 'define-compiler-macro
                        :environment environment)
     (multiple-value-bind (body local-decs doc)
        (parse-defmacro lambda-list whole body name 'define-compiler-macro
                        :environment environment)

@@ -139,7 +137,11 @@
                      ,body)))
            (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
                      ,body)))
            (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
        `(eval-when (:compile-toplevel :load-toplevel :execute)

-         (sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc ,debug-name))))))
+         (sb!c::%define-compiler-macro ',name
+                                       #',def
+                                       ',lambda-list
+                                       ,doc
+                                       ,debug-name))))))

 
 ;;; FIXME: This will look remarkably similar to those who have already
 ;;; seen the code for %DEFMACRO in src/code/defmacro.lisp.  Various
 
 ;;; FIXME: This will look remarkably similar to those who have already
 ;;; seen the code for %DEFMACRO in src/code/defmacro.lisp.  Various

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 83a3e49..9edc6d9 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -121,6 +121,33 @@
 (defmacro do-anonymous (varlist endlist &rest body)
   (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
 \f
 (defmacro do-anonymous (varlist endlist &rest body)
   (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
 \f

+;;;; GENSYM tricks
+
+;;; Automate an idiom often found in macros:
+;;;   (LET ((FOO (GENSYM "FOO"))
+;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;;     ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+  `(let ,(mapcar (lambda (symbol)
+                  (let* ((symbol-name (symbol-name symbol))
+                         (stem (if (every #'alpha-char-p symbol-name)
+                                   symbol-name
+                                   (concatenate 'string symbol-name "-"))))
+                    `(,symbol (gensym ,stem))))
+                symbols)
+     ,@body))
+
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+  (loop repeat n collect (gensym)))
+\f

 ;;;; miscellany
 
 ;;; Lots of code wants to get to the KEYWORD package or the
 ;;;; miscellany
 
 ;;; Lots of code wants to get to the KEYWORD package or the

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 9153a8f..946f95e 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -362,8 +362,7 @@
       (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)
       (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)

-  (let ((sap (gensym "SAP-"))
-       (size (gensym "SIZE-")))
+  (with-unique-names (sap size)

     `(multiple-value-bind
       (,sap ,var ,size)
       (string-list-to-c-strvec ,str-list)
     `(multiple-value-bind
       (,sap ,var ,size)
       (string-list-to-c-strvec ,str-list)

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 71c9c68..e9b5b60 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -535,7 +535,7 @@
         ,x
         ,(compiler-layout-or-lose class-name)))
       ((vector)
         ,x
         ,(compiler-layout-or-lose class-name)))
       ((vector)

-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)

         `(let ((,xx ,x))
            (declare (type vector ,xx))
            ,@(when (dd-named dd)
         `(let ((,xx ,x))
            (declare (type vector ,xx))
            ,@(when (dd-named dd)

@@ -550,7 +550,7 @@
                     :format-arguments (list ',class-name ,xx)))))
            (values))))
       ((list)
                     :format-arguments (list ',class-name ,xx)))))
            (values))))
       ((list)

-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)

         `(let ((,xx ,x))
            (declare (type list ,xx))
            ,@(when (dd-named dd)
         `(let ((,xx ,x))
            (declare (type list ,xx))
            ,@(when (dd-named dd)

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 18b278e..fd13e62 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -63,7 +63,7 @@
        (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
 
 (defmacro with-spinlock ((queue) &body body)
        (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
 
 (defmacro with-spinlock ((queue) &body body)

-  (let ((pid (gensym "PID")))
+  (with-unique-names (pid)

     `(unwind-protect
       (let ((,pid (current-thread-id)))
        (get-spinlock ,queue 2 ,pid)
     `(unwind-protect
       (let ((,pid (current-thread-id)))
        (get-spinlock ,queue 2 ,pid)

@@ -140,8 +140,7 @@
      (setf old-value t1))))
 
 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
      (setf old-value t1))))
 
 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)

-  (let ((block (gensym "NIL"))
-       (got (gensym "GOT")))
+  (with-unique-names (got)

     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
       (when ,got
        (unwind-protect
     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
       (when ,got
        (unwind-protect

diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 1984470..fcbdd94 100644 (file)
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -2,7 +2,7 @@
 
 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   #!+sb-thread
 
 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   #!+sb-thread

-  (let ((cfp (gensym "CFP")))
+  (with-unique-names (cfp)

     `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
       (unless (and (mutex-value ,mutex)
                   (SB!DI::control-stack-pointer-valid-p
     `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
       (unless (and (mutex-value ,mutex)
                   (SB!DI::control-stack-pointer-valid-p

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index d1df348..1fc56c9 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -46,7 +46,7 @@
 ;;; by QUIT) is caught and any final processing and return codes are
 ;;; handled appropriately.
 (defmacro handling-end-of-the-world (&body body)
 ;;; by QUIT) is caught and any final processing and return codes are
 ;;; handled appropriately.
 (defmacro handling-end-of-the-world (&body body)

-  (let ((caught (gensym "CAUGHT")))
+  (with-unique-names (caught)

     `(let ((,caught (catch '%end-of-the-world
                      (/show0 "inside CATCH '%END-OF-THE-WORLD")
                      ,@body)))
     `(let ((,caught (catch '%end-of-the-world
                      (/show0 "inside CATCH '%END-OF-THE-WORLD")
                      ,@body)))

diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp
index 92adc90..9f3bee9 100644 (file)
--- a/src/code/typecheckfuns.lisp
+++ b/src/code/typecheckfuns.lisp
@@ -122,7 +122,7 @@
 
 ;;; Memoize the FORM which returns a typecheckfun for TYPESPEC.
 (defmacro memoized-typecheckfun-form (form typespec)
 
 ;;; Memoize the FORM which returns a typecheckfun for TYPESPEC.
 (defmacro memoized-typecheckfun-form (form typespec)

-  (let ((n-typespec (gensym "TYPESPEC")))
+  (with-unique-names (n-typespec)

     `(let ((,n-typespec ,typespec))
        (or (gethash ,n-typespec *typecheckfuns*)
           (setf (gethash ,n-typespec *typecheckfuns*)
     `(let ((,n-typespec ,typespec))
        (or (gethash ,n-typespec *typecheckfuns*)
           (setf (gethash ,n-typespec *typecheckfuns*)

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 7f71780..1e973f3 100644 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -764,9 +764,7 @@
   "Execute the body, interrupting it with a SIGALRM after at least
 EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
 previous timer after the body has finished executing"
   "Execute the body, interrupting it with a SIGALRM after at least
 EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
 previous timer after the body has finished executing"

-  (let ((saved-seconds (gensym "SAVED-SECONDS"))
-       (saved-useconds (gensym "SAVED-USECONDS"))
-       (s (gensym "S")) (u (gensym "U")))
+  (with-unique-names (saved-seconds saved-useconds s u)

     `(let (- ,saved-seconds ,saved-useconds)
       (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
        (unix-getitimer :real))
     `(let (- ,saved-seconds ,saved-useconds)
       (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
        (unix-getitimer :real))

diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp
index 20b519a..86dcd58 100644 (file)
--- a/src/cold/shared.lisp
+++ b/src/cold/shared.lisp
@@ -311,7 +311,7 @@
 (defparameter *stems-and-flags* (read-from-file "build-order.lisp-expr"))
 
 (defmacro do-stems-and-flags ((stem flags) &body body)
 (defparameter *stems-and-flags* (read-from-file "build-order.lisp-expr"))
 
 (defmacro do-stems-and-flags ((stem flags) &body body)

-  (let ((stem-and-flags (gensym "STEM-AND-FLAGS-")))
+  (let ((stem-and-flags (gensym "STEM-AND-FLAGS")))

     `(dolist (,stem-and-flags *stems-and-flags*)
        (let ((,stem (first ,stem-and-flags))
             (,flags (rest ,stem-and-flags)))
     `(dolist (,stem-and-flags *stems-and-flags*)
        (let ((,stem (first ,stem-and-flags))
             (,flags (rest ,stem-and-flags)))

diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp
index d472eef..130b230 100644 (file)
--- a/src/compiler/alpha/macros.lisp
+++ b/src/compiler/alpha/macros.lisp
@@ -224,8 +224,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 5f1a28d..9b77313 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -626,10 +626,7 @@
                                   (element-type '*)
                                   unsafe?
                                   fail-inline?)
                                   (element-type '*)
                                   unsafe?
                                   fail-inline?)

-  (let ((size (gensym "SIZE-"))
-       (defaulted-end (gensym "DEFAULTED-END-"))
-       (data (gensym "DATA-"))
-       (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
+  (with-unique-names (size defaulted-end data cumulative-offset)

     `(let* ((,size (array-total-size ,array))
            (,defaulted-end
              (cond (,end
     `(let* ((,size (array-total-size ,array))
            (,defaulted-end
              (cond (,end

diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp
index e863633..778eb41 100644 (file)
--- a/src/compiler/assem.lisp
+++ b/src/compiler/assem.lisp
@@ -156,9 +156,7 @@
 ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
 (defmacro with-modified-segment-index-and-posn ((segment index posn)
                                                &body body)
 ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
 (defmacro with-modified-segment-index-and-posn ((segment index posn)
                                                &body body)

-  (let ((n-segment (gensym "SEGMENT"))
-       (old-index (gensym "OLD-INDEX-"))
-       (old-posn (gensym "OLD-POSN-")))
+  (with-unique-names (n-segment old-index old-posn)

     `(let* ((,n-segment ,segment)
            (,old-index (segment-current-index ,n-segment))
            (,old-posn (segment-current-posn ,n-segment)))
     `(let* ((,n-segment ,segment)
            (,old-index (segment-current-index ,n-segment))
            (,old-posn (segment-current-posn ,n-segment)))

@@ -1654,8 +1652,7 @@ p     ;; the branch has two dependents and one of them dpends on
                (append ,@(extract-nths 0 'list pdefs)))))))))
 
 (defmacro define-instruction-macro (name lambda-list &body body)
                (append ,@(extract-nths 0 'list pdefs)))))))))
 
 (defmacro define-instruction-macro (name lambda-list &body body)

-  (let ((whole (gensym "WHOLE-"))
-       (env (gensym "ENV-")))
+  (with-unique-names (whole env)

     (multiple-value-bind (body local-defs)
        (sb!kernel:parse-defmacro lambda-list
                                  whole
     (multiple-value-bind (body local-defs)
        (sb!kernel:parse-defmacro lambda-list
                                  whole

diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp
index e41c6fc..54cc932 100644 (file)
--- a/src/compiler/deftype.lisp
+++ b/src/compiler/deftype.lisp
@@ -14,7 +14,7 @@
   "Define a new type, with syntax like DEFMACRO."
   (unless (symbolp name)
     (error "type name not a symbol: ~S" name))
   "Define a new type, with syntax like DEFMACRO."
   (unless (symbolp name)
     (error "type name not a symbol: ~S" name))

-  (let ((whole (gensym "WHOLE-")))
+  (with-unique-names (whole)

     (multiple-value-bind (body local-decs doc)
        (parse-defmacro arglist whole body name 'deftype :default-default ''*)
       `(eval-when (:compile-toplevel :load-toplevel :execute)
     (multiple-value-bind (body local-decs doc)
        (parse-defmacro arglist whole body name 'deftype :default-default ''*)
       `(eval-when (:compile-toplevel :load-toplevel :execute)

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 7c4619f..991dc18 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -1259,7 +1259,7 @@
 (defun dump-layout (obj file)
   (when (layout-invalid obj)
     (compiler-error "attempt to dump reference to obsolete class: ~S"
 (defun dump-layout (obj file)
   (when (layout-invalid obj)
     (compiler-error "attempt to dump reference to obsolete class: ~S"

-                   (layout-class obj)))
+                   (layout-classoid obj)))

   (let ((name (classoid-name (layout-classoid obj))))
     (unless name
       (compiler-error "dumping anonymous layout: ~S" obj))
   (let ((name (classoid-name (layout-classoid obj))))
     (unless name
       (compiler-error "dumping anonymous layout: ~S" obj))

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 242445e..ee434de 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -819,15 +819,14 @@
   ;; Constant CLASS and TYPE is an overwhelmingly common special case,
   ;; and we can implement it much more efficiently than the general case.
   (if (and (constantp class) (constantp type))
   ;; Constant CLASS and TYPE is an overwhelmingly common special case,
   ;; and we can implement it much more efficiently than the general case.
   (if (and (constantp class) (constantp type))

-      (let ((info (type-info-or-lose class type))
-           (value (gensym "VALUE"))
-           (foundp (gensym "FOUNDP")))
-       `(multiple-value-bind (,value ,foundp)
-            (get-info-value ,name
-                            ,(type-info-number info)
-                            ,@(when env-list-p `(,env-list))) 
-          (declare (type ,(type-info-type info) ,value))
-          (values ,value ,foundp)))
+      (let ((info (type-info-or-lose class type)))
+       (with-unique-names (value foundp)
+         `(multiple-value-bind (,value ,foundp)
+              (get-info-value ,name
+                              ,(type-info-number info)
+                              ,@(when env-list-p `(,env-list))) 
+            (declare (type ,(type-info-type info) ,value))
+            (values ,value ,foundp))))

       whole))
 (defun (setf info) (new-value
                    class
       whole))
 (defun (setf info) (new-value
                    class

diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp
index 1cc39d6..73cc856 100644 (file)
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@ -750,8 +750,7 @@
           (sb!bignum:%multiply ,x ,y)
           (values ,carry))
         (values ,extra)))
           (sb!bignum:%multiply ,x ,y)
           (values ,carry))
         (values ,extra)))

-  (let ((hi (gensym "HI-"))
-       (lo (gensym "LO-")))
+  (with-unique-names (hi lo)

     (if (eql extra 0)
        `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
           (sb!bignum::%dual-word-add ,hi ,lo ,carry))
     (if (eql extra 0)
        `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
           (sb!bignum::%dual-word-add ,hi ,lo ,carry))

diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp
index 0995411..d0d8a15 100644 (file)
--- a/src/compiler/hppa/macros.lisp
+++ b/src/compiler/hppa/macros.lisp
@@ -184,8 +184,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

@@ -193,21 +192,18 @@
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))

-
-

 \f
 \f

-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
+;;;; PSEUDO-ATOMIC
+
+;;; handy macro for making sequences look atomic

 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
   (let ((n-extra (gensym)))
     `(let ((,n-extra ,extra))
        (inst addi 4 alloc-tn alloc-tn)
        ,@forms
        (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
   (let ((n-extra (gensym)))
     `(let ((,n-extra ,extra))
        (inst addi 4 alloc-tn alloc-tn)
        ,@forms
        (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))

-
-

 \f
 \f

-;;;; Indexed references:
+;;;; indexed references

 
 (deftype load/store-index (scale lowtag min-offset
                                 &optional (max-offset min-offset))
 
 (deftype load/store-index (scale lowtag min-offset
                                 &optional (max-offset min-offset))

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index ab89de1..73912b0 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -276,8 +276,7 @@
          ,(make-error-form "The local macro name ~S is not a symbol." 'name))
        (unless (listp arglist)
          ,(make-error-form "The local macro argument list ~S is not a list." 'arglist))
          ,(make-error-form "The local macro name ~S is not a symbol." 'name))
        (unless (listp arglist)
          ,(make-error-form "The local macro argument list ~S is not a list." 'arglist))

-       (let ((whole (gensym "WHOLE"))
-             (environment (gensym "ENVIRONMENT")))
+       (with-unique-names (whole environment)

          (multiple-value-bind (body local-decls)
              (parse-defmacro arglist whole body name 'macrolet
                              :environment environment)
          (multiple-value-bind (body local-decls)
              (parse-defmacro arglist whole body name 'macrolet
                              :environment environment)

@@ -878,45 +877,40 @@
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 

-;;; We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %WITHIN-CLEANUP.

 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*
 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*

-  Evaluates Tag and instantiates it as a catcher while the body forms are
-  evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+  Evaluate TAG and instantiate it as a catcher while the body forms are
+  evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic

   scope of the body, then control will be transferred to the end of the body
   and the thrown values will be returned."
   scope of the body, then control will be transferred to the end of the body
   and the thrown values will be returned."

+  ;; We represent the possibility of the control transfer by making an
+  ;; "escape function" that does a lexical exit, and instantiate the
+  ;; cleanup using %WITHIN-CLEANUP.

   (ir1-convert
    start cont
   (ir1-convert
    start cont

-   (let ((exit-block (gensym "EXIT-BLOCK-")))
+   (with-unique-names (exit-block)

      `(block ,exit-block
        (%within-cleanup
            :catch
            (%catch (%escape-fun ,exit-block) ,tag)
          ,@body)))))
 
      `(block ,exit-block
        (%within-cleanup
            :catch
            (%catch (%escape-fun ,exit-block) ,tag)
          ,@body)))))
 

-;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
-;;; cleanup forms into a local function so that they can be referenced
-;;; both in the case where we are unwound and in any local exits. We
-;;; use %CLEANUP-FUN on this to indicate that reference by
-;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
-;;; an XEP.

 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
   "Unwind-Protect Protected Cleanup*
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
   "Unwind-Protect Protected Cleanup*

-  Evaluate the form Protected, returning its values. The cleanup forms are
-  evaluated whenever the dynamic scope of the Protected form is exited (either
+  Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
+  evaluated whenever the dynamic scope of the PROTECTED form is exited (either

   due to normal completion or a non-local exit such as THROW)."
   due to normal completion or a non-local exit such as THROW)."

+  ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
+  ;; cleanup forms into a local function so that they can be referenced
+  ;; both in the case where we are unwound and in any local exits. We
+  ;; use %CLEANUP-FUN on this to indicate that reference by
+  ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
+  ;; an XEP.

   (ir1-convert
    start cont
   (ir1-convert
    start cont

-   (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
-        (drop-thru-tag (gensym "DROP-THRU-TAG-"))
-        (exit-tag (gensym "EXIT-TAG-"))
-        (next (gensym "NEXT"))
-        (start (gensym "START"))
-        (count (gensym "COUNT")))
+   (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)

      `(flet ((,cleanup-fun () ,@cleanup nil))
        ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
        ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
      `(flet ((,cleanup-fun () ,@cleanup nil))
        ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
        ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,

@@ -935,21 +929,22 @@
 \f
 ;;;; multiple-value stuff
 
 \f
 ;;;; multiple-value stuff
 

-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.

 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*
 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*

-  Call Function, passing all the values of each Values-Form as arguments,
-  values from the first Values-Form making up the first argument, etc."
+  Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
+  values from the first VALUES-FORM making up the first argument, etc."

   (let* ((fun-cont (make-continuation))
         (node (if args
   (let* ((fun-cont (make-continuation))
         (node (if args

+                  ;; If there are arguments, MULTIPLE-VALUE-CALL
+                  ;; turns into an MV-COMBINATION.

                   (make-mv-combination fun-cont)
                   (make-mv-combination fun-cont)

+                  ;; If there are no arguments, then we convert to a
+                  ;; normal combination, ensuring that a MV-COMBINATION
+                  ;; always has at least one argument. This can be
+                  ;; regarded as an optimization, but it is more
+                  ;; important for simplifying compilation of
+                  ;; MV-COMBINATIONS.

                   (make-combination fun-cont))))
     (ir1-convert start fun-cont
                 (if (and (consp fun) (eq (car fun) 'function))
                   (make-combination fun-cont))))
     (ir1-convert start fun-cont
                 (if (and (consp fun) (eq (car fun) 'function))

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index c5f7b41..c05b5d0 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -444,7 +444,7 @@
                                          :format-control "execution of a form compiled with errors:~% ~S"
                                          :format-arguments (list ',,form))))
                               &body body)
                                          :format-control "execution of a form compiled with errors:~% ~S"
                                          :format-arguments (list ',,form))))
                               &body body)

-                             (let ((skip (gensym "SKIP")))
+                             (with-unique-names (skip)

                                `(block ,skip
                                   (catch 'ir1-error-abort
                                     (let ((*compiler-error-bailout*
                                `(block ,skip
                                   (catch 'ir1-error-abort
                                     (let ((*compiler-error-bailout*

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 43b213d..c614cbc 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1335,8 +1335,7 @@
 (def-ir1-translator progv ((vars vals &body body) start cont)
   (ir1-convert
    start cont
 (def-ir1-translator progv ((vars vals &body body) start cont)
   (ir1-convert
    start cont

-   (let ((bind (gensym "BIND"))
-         (unbind (gensym "UNBIND")))
+   (with-unique-names (bind unbind)

      (once-only ((n-save-bs '(%primitive current-binding-pointer)))
                 `(unwind-protect
                       (progn
      (once-only ((n-save-bs '(%primitive current-binding-pointer)))
                 `(unwind-protect
                       (progn

@@ -1349,7 +1348,9 @@
                                    (declare (optimize (speed 2) (debug 0)))
                                    (cond ((null vars))
                                          ((null vals) (,unbind vars))
                                    (declare (optimize (speed 2) (debug 0)))
                                    (cond ((null vars))
                                          ((null vals) (,unbind vars))

-                                         (t (%primitive bind (car vals) (car vars))
+                                         (t (%primitive bind
+                                                       (car vals)
+                                                       (car vars))

                                             (,bind (cdr vars) (cdr vals))))))
                           (,bind ,vars ,vals))
                         nil
                                             (,bind (cdr vars) (cdr vals))))))
                           (,bind ,vars ,vals))
                         nil

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index f6e4fb0..d30e87a 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -689,7 +689,7 @@
      ,@body))
 
 (defmacro with-component-last-block ((component block) &body body)
      ,@body))
 
 (defmacro with-component-last-block ((component block) &body body)

-  (let ((old-last-block (gensym "OLD-LAST-BLOCK")))
+  (with-unique-names (old-last-block)

     (once-only ((component component)
                 (block block))
       `(let ((,old-last-block (component-last-block ,component)))
     (once-only ((component component)
                 (block block))
       `(let ((,old-last-block (component-last-block ,component)))

diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp
index a9bf98b..4a0efed 100644 (file)
--- a/src/compiler/mips/macros.lisp
+++ b/src/compiler/mips/macros.lisp
@@ -228,8 +228,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

@@ -237,9 +236,10 @@
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))

-

 \f
 \f

-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
+;;;; PSEUDO-ATOMIC
+
+;;; handy macro for making sequences look atomic

 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
   `(progn
      (aver (= (tn-offset ,flag-tn) nl4-offset))
 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
   `(progn
      (aver (= (tn-offset ,flag-tn) nl4-offset))

@@ -257,10 +257,8 @@
         (inst addu alloc-tn (1- ,extra))
         (inst break 16)
         (emit-label label)))))
         (inst addu alloc-tn (1- ,extra))
         (inst break 16)
         (emit-label label)))))

-
-

 \f
 \f

-;;;; Memory accessor vop generators
+;;;; memory accessor vop generators

 
 (deftype load/store-index (scale lowtag min-offset
                                 &optional (max-offset min-offset))
 
 (deftype load/store-index (scale lowtag min-offset
                                 &optional (max-offset min-offset))

diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index e8c5cdf..230bde1 100644 (file)
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -197,8 +197,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

@@ -206,18 +205,17 @@
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))

-
-

 \f
 \f

-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
+;;;; PSEUDO-ATOMIC
+
+;;; handy macro for making sequences look atomic

 ;;;
 ;;;

-;;; flag-tn must be wired to NL3. If a deferred interrupt happens
-;;; while we have the low bits of alloc-tn set, we add a "large"
-;;; constant to flag-tn.  On exit, we add flag-tn to alloc-tn
-;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
-;;; negative.  We then trap if alloc-tn's negative (handling the
-;;; deferred interrupt) and using flag-tn - minus the large constant -
-;;; to correct alloc-tn.
+;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
+;;; while we have the low bits of ALLOC-TN set, we add a "large"
+;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
+;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
+;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
+;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.

 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
   (let ((n-extra (gensym)))
     `(let ((,n-extra ,extra))
 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
   (let ((n-extra (gensym)))
     `(let ((,n-extra ,extra))

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index b640f51..647a862 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -130,7 +130,7 @@
   (declare (type list seqs seq-names)
            (type symbol into))
   (collect ((bindings)
   (declare (type list seqs seq-names)
            (type symbol into))
   (collect ((bindings)

-           (declarations)
+           (declarations)

             (vector-lengths)
             (tests)
             (places))
             (vector-lengths)
             (tests)
             (places))

@@ -145,7 +145,7 @@
            for seq-name in seq-names
            for type = (continuation-type seq)
            do (cond ((csubtypep type (specifier-type 'list))
            for seq-name in seq-names
            for type = (continuation-type seq)
            do (cond ((csubtypep type (specifier-type 'list))

-                     (let ((index (gensym "I")))
+                    (with-unique-names (index)

                        (bindings `(,index ,seq-name (cdr ,index)))
                        (declarations `(type list ,index))
                        (places `(car ,index))
                        (bindings `(,index ,seq-name (cdr ,index)))
                        (declarations `(type list ,index))
                        (places `(car ,index))

@@ -866,13 +866,7 @@
                                                            end-arg
                                                            element
                                                            done-p-expr)
                                                            end-arg
                                                            element
                                                            done-p-expr)

-  (let ((offset (gensym "OFFSET"))
-       (block (gensym "BLOCK"))
-       (index (gensym "INDEX"))
-       (n-sequence (gensym "N-SEQUENCE-"))
-       (sequence (gensym "SEQUENCE"))
-       (n-end (gensym "N-END-"))
-       (end (gensym "END-")))
+  (with-unique-names (offset block index n-sequence sequence n-end end)

     `(let ((,n-sequence ,sequence-arg)
           (,n-end ,end-arg))
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
     `(let ((,n-sequence ,sequence-arg)
           (,n-end ,end-arg))
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)

@@ -901,7 +895,7 @@
 
 (def!macro %find-position-vector-macro (item sequence
                                             from-end start end key test)
 
 (def!macro %find-position-vector-macro (item sequence
                                             from-end start end key test)

-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)

     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end

@@ -915,7 +909,7 @@
 
 (def!macro %find-position-if-vector-macro (predicate sequence
                                                     from-end start end key)
 
 (def!macro %find-position-if-vector-macro (predicate sequence
                                                     from-end start end key)

-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)

     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end

@@ -926,7 +920,7 @@
 
 (def!macro %find-position-if-not-vector-macro (predicate sequence
                                                         from-end start end key)
 
 (def!macro %find-position-if-not-vector-macro (predicate sequence
                                                         from-end start end key)

-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)

     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end

diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp
index 6ab3463..68bf325 100644 (file)
--- a/src/compiler/sparc/macros.lisp
+++ b/src/compiler/sparc/macros.lisp
@@ -198,8 +198,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

@@ -207,8 +206,6 @@
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))

-
-

 \f
 ;;; a handy macro for making sequences look atomic
 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 \f
 ;;; a handy macro for making sequences look atomic
 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)

@@ -227,4 +224,3 @@
        (inst andcc zero-tn alloc-tn 3)
        ;; The C code needs to process this correctly and fixup alloc-tn.
        (inst t :ne pseudo-atomic-trap)))))
        (inst andcc zero-tn alloc-tn 3)
        ;; The C code needs to process this correctly and fixup alloc-tn.
        (inst t :ne pseudo-atomic-trap)))))

-

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4679da2..648b31f 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -31,8 +31,7 @@
 
 ;;; Bind the value and make a closure that returns it.
 (define-source-transform constantly (value)
 
 ;;; Bind the value and make a closure that returns it.
 (define-source-transform constantly (value)

-  (let ((rest (gensym "CONSTANTLY-REST-"))
-       (n-value (gensym "CONSTANTLY-VALUE-")))
+  (with-unique-names (rest n-value)

     `(let ((,n-value ,value))
       (lambda (&rest ,rest)
        (declare (ignore ,rest))
     `(let ((,n-value ,value))
       (lambda (&rest ,rest)
        (declare (ignore ,rest))

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index bedd274..1af259d 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -307,7 +307,7 @@
 ;;; untagged memory lying around, but some documentation would be nice.
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
 ;;; untagged memory lying around, but some documentation would be nice.
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)

-  (let ((label (gensym "LABEL-")))
+  (with-unique-names (label)

     `(let ((,label (gen-label)))
       (inst fs-segment-prefix)
       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
     `(let ((,label (gen-label)))
       (inst fs-segment-prefix)
       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)

@@ -328,7 +328,7 @@
 
 #!-sb-thread
 (defmacro pseudo-atomic (&rest forms)
 
 #!-sb-thread
 (defmacro pseudo-atomic (&rest forms)

-  (let ((label (gensym "LABEL-")))
+  (with-unique-names (label)

     `(let ((,label (gen-label)))
       ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
       ;; something. (perhaps SVLB, for static variable low byte)
     `(let ((,label (gen-label)))
       ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
       ;; something. (perhaps SVLB, for static variable low byte)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7e0131d..e10af04 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1584,7 +1584,7 @@ bootstrapping.
 
 ;;; Keep pages clean by not setting if the value is already the same.
 (defmacro esetf (pos val)
 
 ;;; Keep pages clean by not setting if the value is already the same.
 (defmacro esetf (pos val)

-  (let ((valsym (gensym "value")))
+  (with-unique-names (valsym)

     `(let ((,valsym ,val))
        (unless (equal ,pos ,valsym)
         (setf ,pos ,valsym)))))
     `(let ((,valsym ,val))
        (unless (equal ,pos ,valsym)
         (setf ,pos ,valsym)))))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d904439..f36f860 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -778,6 +778,19 @@ BUG 48c, not yet fixed:
 (assert (raises-error? (test-type-of-special-2 3) type-error))
 (assert (equal (test-type-of-special-2 8) '(8 4 4)))
 
 (assert (raises-error? (test-type-of-special-2 3) type-error))
 (assert (equal (test-type-of-special-2 8) '(8 4 4)))
 

+;;; bug which existed in 0.8alpha.0.4 for several milliseconds before
+;;; APD fixed it in 0.8alpha.0.5
+(defun frob8alpha04 (x y)
+  (+ x y))
+(defun baz8alpha04 (this kids)
+  (flet ((n-i (&rest rest)
+          ;; Removing the #+NIL here makes the bug go away.
+          #+nil (format t "~&in N-I REST=~S~%" rest)
+          (apply #'frob8alpha04 this rest)))
+    (n-i kids)))
+;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
+(assert (= (baz8alpha04 12 13) 25))
+\f

 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
 

diff --git a/version.lisp-expr b/version.lisp-expr
index e89d624..5f00874 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.8alpha.0.8"
+"0.8alpha.0.9"