From: William Harold Newman Date: Sat, 3 May 2003 18:19:43 +0000 (+0000) Subject: 0.8alpha.0.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git 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 --- 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-"))) - (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 --- 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" - "MAKE-GENSYM-LIST" + "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" "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 --- 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 - (let ((fixup (gensym "FIXUP-"))) + (with-unique-names (fixup) (values `((let ((fixup (make-fixup ',name :assembly-routine))) (inst ldil fixup ,fixup) @@ -41,7 +41,7 @@ ,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) diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp index fc0d0a0..739fa11 100644 --- 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)) - ,@(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))) diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index ac2702f..c80dcba 100644 --- 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)) - (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) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6822ef2..c020545 100644 --- 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.") - (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)) diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp index 7e9b8e1..1a74b38 100644 --- 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." - (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 diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index fe0f319..d279677 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -809,12 +809,6 @@ which can be found at .~:@>" :format-string "~@<~S ~_is not a ~_~S~:>" :format-arguments (list value type))) -;;; 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)) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index b09d1f0..76a8c43 100644 --- 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)) - (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 diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 3fa574f..766b241 100644 --- 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) - (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) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 6f6e610..c74a081 100644 --- 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) - (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) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 51214a4..9f5a486 100644 --- 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) - ;;;; 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))) - (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) @@ -139,7 +137,11 @@ ,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 diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 83a3e49..9edc6d9 100644 --- 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))) +;;;; 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))) + ;;;; 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 --- 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) - (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) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 71c9c68..e9b5b60 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -535,7 +535,7 @@ ,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) @@ -550,7 +550,7 @@ :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) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 18b278e..fd13e62 100644 --- 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) - (let ((pid (gensym "PID"))) + (with-unique-names (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) - (let ((block (gensym "NIL")) - (got (gensym "GOT"))) + (with-unique-names (got) `(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 --- 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 - (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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d1df348..1fc56c9 100644 --- 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) - (let ((caught (gensym "CAUGHT"))) + (with-unique-names (caught) `(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 --- 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) - (let ((n-typespec (gensym "TYPESPEC"))) + (with-unique-names (n-typespec) `(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 --- 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" - (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)) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 20b519a..86dcd58 100644 --- 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) - (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))) diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index d472eef..130b230 100644 --- 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." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(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 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -626,10 +626,7 @@ (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 diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index e863633..778eb41 100644 --- 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) - (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))) @@ -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) - (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 diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp index e41c6fc..54cc932 100644 --- 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)) - (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) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 7c4619f..991dc18 100644 --- 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" - (layout-class obj))) + (layout-classoid 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 --- 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)) - (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 diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp index 1cc39d6..73cc856 100644 --- 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))) - (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)) diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp index 0995411..d0d8a15 100644 --- 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." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -193,21 +192,18 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - - -;;; 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)))) - - -;;;; Indexed references: +;;;; indexed references (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 --- 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)) - (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) @@ -878,45 +877,40 @@ (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* - 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." + ;; 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 - (let ((exit-block (gensym "EXIT-BLOCK-"))) + (with-unique-names (exit-block) `(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* - 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)." + ;; 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 - (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, @@ -935,21 +929,22 @@ ;;;; 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* - 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 + ;; If there are arguments, MULTIPLE-VALUE-CALL + ;; turns into an MV-COMBINATION. (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)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c5f7b41..c05b5d0 100644 --- 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) - (let ((skip (gensym "SKIP"))) + (with-unique-names (skip) `(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 --- 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 - (let ((bind (gensym "BIND")) - (unbind (gensym "UNBIND"))) + (with-unique-names (bind unbind) (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)) - (t (%primitive bind (car vals) (car vars)) + (t (%primitive bind + (car vals) + (car vars)) (,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 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -689,7 +689,7 @@ ,@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))) diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp index a9bf98b..4a0efed 100644 --- 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." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -237,9 +236,10 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - -;;; 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)) @@ -257,10 +257,8 @@ (inst addu alloc-tn (1- ,extra)) (inst break 16) (emit-label label))))) - - -;;;; Memory accessor vop generators +;;;; memory accessor vop generators (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 --- 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." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -206,18 +205,17 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - - -;;; 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)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index b640f51..647a862 100644 --- 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) - (declarations) + (declarations) (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)) - (let ((index (gensym "I"))) + (with-unique-names (index) (bindings `(,index ,seq-name (cdr ,index))) (declarations `(type list ,index)) (places `(car ,index)) @@ -866,13 +866,7 @@ 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) @@ -901,7 +895,7 @@ (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 @@ -915,7 +909,7 @@ (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 @@ -926,7 +920,7 @@ (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 diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp index 6ab3463..68bf325 100644 --- 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." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -207,8 +206,6 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - - ;;; 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))))) - diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 4679da2..648b31f 100644 --- 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) - (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)) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index bedd274..1af259d 100644 --- 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) - (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) @@ -328,7 +328,7 @@ #!-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) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 7e0131d..e10af04 100644 --- 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) - (let ((valsym (gensym "value"))) + (with-unique-names (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 --- 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))) +;;; 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)) + ;;;; 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 --- 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".) -"0.8alpha.0.8" +"0.8alpha.0.9"