(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)
"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"
(!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)
,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)
(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)))
(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)
(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))
(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
: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))
(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
;;;; 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)
;;;
;;; 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)
:format-control "Symbol macro name already declared constant: ~S."
:format-arguments (list name))))
name)
-
\f
;;;; DEFINE-COMPILER-MACRO
(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)
,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
(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
(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)
,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)
: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)
(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)
(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
(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
;;; 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)))
;;; 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*)
"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))
(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)))
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*)
(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
;;; 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)))
(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
"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)
(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))
;; 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
(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))
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*)
(emit-label ,error)
(cerror-call ,vop ,continue ,error-code ,@values)
,error)))))
-
-
\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))))
-
-
\f
-;;;; Indexed references:
+;;;; indexed references
(deftype load/store-index (scale lowtag min-offset
&optional (max-offset min-offset))
,(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)
(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,
\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*
- 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))
: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*
(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
(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
,@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)))
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*)
(emit-label ,error)
(cerror-call ,vop ,continue ,error-code ,@values)
,error)))))
-
\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))
(inst addu alloc-tn (1- ,extra))
(inst break 16)
(emit-label label)))))
-
-
\f
-;;;; Memory accessor vop generators
+;;;; memory accessor vop generators
(deftype load/store-index (scale lowtag min-offset
&optional (max-offset min-offset))
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*)
(emit-label ,error)
(cerror-call ,vop ,continue ,error-code ,@values)
,error)))))
-
-
\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))
(declare (type list seqs seq-names)
(type symbol into))
(collect ((bindings)
- (declarations)
+ (declarations)
(vector-lengths)
(tests)
(places))
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))
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)
(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
(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
(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
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*)
(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)
(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)))))
-
;;; 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))
;;; 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)
#!-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)
;;; 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)))))
(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
;;; 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"
projects / sbcl.git / commitdiff