;;; them, the backquoted material will be recognizable to the
;;; pretty-printer.
(macrolet ((def (b-name name)
- (let ((args (gensym "ARGS")))
;; FIXME: This function should be INLINE so that the lists
;; aren't consed twice, but I ran into an optimizer bug the
;; first time I tried to make this work for BACKQ-LIST. See
;; whether there's still an optimizer bug, and fix it if so, and
;; then make these INLINE.
- `(defun ,b-name (&rest ,args)
- (declare (truly-dynamic-extent ,args))
- (apply #',name ,args)))))
+ `(defun ,b-name (&rest rest)
+ (declare (truly-dynamic-extent rest))
+ (apply #',name rest))))
(def backq-list list)
(def backq-list* list*)
(def backq-append append)
;;; function to call that fixes up the result returning any useful values, such
;;; as the result. This macro may evaluate its arguments more than once.
(sb!xc:defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun)
- (let ((borrow (gensym))
- (a-digit (gensym))
- (a-sign (gensym))
- (b-digit (gensym))
- (b-sign (gensym))
- (i (gensym))
- (v (gensym))
- (k (gensym)))
+ (with-unique-names (borrow a-digit a-sign b-digit b-sign i v k)
`(let* ((,borrow 1)
(,a-sign (%sign-digit ,a ,len-a))
(,b-sign (%sign-digit ,b ,len-b)))
from-end)
(sb!int:once-only ((n-dest dest)
(n-src src))
- (let ((n-start1 (gensym))
- (n-end1 (gensym))
- (n-start2 (gensym))
- (n-end2 (gensym))
- (i1 (gensym))
- (i2 (gensym))
- (end1 (or end1 `(%bignum-length ,n-dest)))
- (end2 (or end2 `(%bignum-length ,n-src))))
- (if from-end
- `(let ((,n-start1 ,start1)
- (,n-start2 ,start2))
- (do ((,i1 (1- ,end1) (1- ,i1))
- (,i2 (1- ,end2) (1- ,i2)))
- ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
- (declare (fixnum ,i1 ,i2))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i2))))
- (if (eql start1 start2)
- `(let ((,n-end1 (min ,end1 ,end2)))
- (do ((,i1 ,start1 (1+ ,i1)))
- ((>= ,i1 ,n-end1))
- (declare (type bignum-index ,i1))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i1))))
- `(let ((,n-end1 ,end1)
- (,n-end2 ,end2))
- (do ((,i1 ,start1 (1+ ,i1))
- (,i2 ,start2 (1+ ,i2)))
- ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
- (declare (type bignum-index ,i1 ,i2))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i2)))))))))
+ (with-unique-names (n-start1 n-end1 n-start2 n-end2 i1 i2)
+ (let ((end1 (or end1 `(%bignum-length ,n-dest)))
+ (end2 (or end2 `(%bignum-length ,n-src))))
+ (if from-end
+ `(let ((,n-start1 ,start1)
+ (,n-start2 ,start2))
+ (do ((,i1 (1- ,end1) (1- ,i1))
+ (,i2 (1- ,end2) (1- ,i2)))
+ ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
+ (declare (fixnum ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2))))
+ (if (eql start1 start2)
+ `(let ((,n-end1 (min ,end1 ,end2)))
+ (do ((,i1 ,start1 (1+ ,i1)))
+ ((>= ,i1 ,n-end1))
+ (declare (type bignum-index ,i1))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i1))))
+ `(let ((,n-end1 ,end1)
+ (,n-end2 ,end2))
+ (do ((,i1 ,start1 (1+ ,i1))
+ (,i2 ,start2 (1+ ,i2)))
+ ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
+ (declare (type bignum-index ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2))))))))))
(sb!xc:defmacro with-bignum-buffers (specs &body body)
#!+sb-doc
;;; This negates bignum-len digits of bignum, storing the resulting digits into
;;; result (possibly EQ to bignum) and returning whatever end-carry there is.
-(sb!xc:defmacro bignum-negate-loop (bignum
- bignum-len
- &optional (result nil resultp))
- (let ((carry (gensym))
- (end (gensym))
- (value (gensym))
- (last (gensym)))
+(sb!xc:defmacro bignum-negate-loop
+ (bignum bignum-len &optional (result nil resultp))
+ (with-unique-names (carry end value last)
`(let* (,@(if (not resultp) `(,last))
(,carry
(multiple-value-bind (,value ,carry)
(declare (type symbol symbol))
(sxhash symbol))
+(defvar sb!xc:*gensym-counter* 0)
+
+(defun sb!xc:gensym (&optional (thing "G"))
+ (declare (type string thing))
+ (let ((n sb!xc:*gensym-counter*))
+ (prog1
+ (make-symbol (concatenate 'string thing (write-to-string n :base 10 :radix nil :pretty nil)))
+ (incf sb!xc:*gensym-counter*))))
+
;;; These functions are needed for constant-folding.
(defun sb!kernel:simple-array-nil-p (object)
(when (typep object 'array)
(if (= (length vars) 1)
`(let ((,(car vars) ,value-form))
,@body)
- (let ((ignore (gensym)))
+ (let ((ignore (sb!xc:gensym)))
`(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
&rest ,ignore)
(declare (ignore ,ignore))
(k '() (list* (cadr l) (car l) k)))
((or (null l) (not (member (car l) keys)))
(values (nreverse k) l)))))
- (let ((block-tag (gensym))
+ (let ((block-tag (sb!xc:gensym "BLOCK"))
(temp-var (gensym))
(data
(macrolet (;; KLUDGE: This started as an old DEFMACRO
&rest forms)
(cddr clause))
(list (car clause) ;name=0
- (gensym) ;tag=1
+ (sb!xc:gensym "TAG") ;tag=1
(transform-keywords :report report ;keywords=2
:interactive interactive
:test test)
(and (consp x)
(eq 'lambda (car x))
(setf lambda-form x))))))
- (let ((name (gensym "LAMBDA")))
+ (let ((name (sb!xc:gensym "LAMBDA")))
(push `(,name ,@(cdr lambda-form)) local-funs)
(list type `(function ,name)))
binding))))
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause cases)))))))
(let* ((local-funs nil)
- (annotated-cases (mapcar (lambda (case)
- (let ((tag (gensym "TAG"))
- (fun (gensym "FUN")))
- (destructuring-bind (type ll &body body) case
- (push `(,fun ,ll ,@body) local-funs)
- (list tag type ll fun))))
- cases)))
+ (annotated-cases
+ (mapcar (lambda (case)
+ (with-unique-names (tag fun)
+ (destructuring-bind (type ll &body body) case
+ (push `(,fun ,ll ,@body) local-funs)
+ (list tag type ll fun))))
+ cases)))
(with-unique-names (block var form-fun)
`(dx-flet ((,form-fun ()
#!-x86 ,form
(declare (notinline find-classoid))
,@(let ((pf (dd-print-function defstruct))
(po (dd-print-object defstruct))
- (x (gensym))
- (s (gensym)))
+ (x (sb!xc:gensym "OBJECT"))
+ (s (sb!xc:gensym "STREAM")))
;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
;; leaves PO or PF equal to NIL. The user-level effect is
;; to generate a PRINT-OBJECT method specialized for the type,
(types)
(vals))
(dolist (slot (dd-slots defstruct))
- (let ((dum (gensym))
+ (let ((dum (sb!xc:gensym "DUM"))
(name (dsd-name slot)))
(arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
(types (dsd-type slot))
:dd-type dd-type))
(dd-slots (dd-slots dd))
(dd-length (1+ (length slot-names)))
- (object-gensym (gensym "OBJECT"))
- (new-value-gensym (gensym "NEW-VALUE-"))
+ (object-gensym (sb!xc:gensym "OBJECT"))
+ (new-value-gensym (sb!xc:gensym "NEW-VALUE-"))
(delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
(multiple-value-bind (raw-maker-form raw-reffer-operator)
(ecase dd-type
(in-package "SB!KERNEL")
;;; Common Lisp special variables which have SB-XC versions
-(proclaim '(special sb!xc:*macroexpand-hook*))
+(proclaim '(special sb!xc:*macroexpand-hook* sb!xc:*gensym-counter*))
;;; the Common Lisp defined type spec symbols
(defparameter *!standard-type-names*
;;; if the table is a synchronized table.
(defmacro dohash (((key-var value-var) table &key result locked) &body body)
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
- (let* ((gen (gensym))
- (n-more (gensym))
- (n-table (gensym))
- (iter-form `(with-hash-table-iterator (,gen ,n-table)
+ (with-unique-names (gen n-more n-table)
+ (let ((iter-form `(with-hash-table-iterator (,gen ,n-table)
(loop
(multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
,@decls
(unless ,n-more (return ,result))
,@forms)))))
- `(let ((,n-table ,table))
- ,(if locked
- `(with-locked-hash-table (,n-table)
- ,iter-form)
- iter-form)))))
+ `(let ((,n-table ,table))
+ ,(if locked
+ `(with-locked-hash-table (,n-table)
+ ,iter-form)
+ iter-form))))))
\f
;;;; hash cache utility
(default-values (if (and (consp default) (eq (car default) 'values))
(cdr default)
(list default)))
- (args-and-values (gensym))
+ (args-and-values (sb!xc:gensym "ARGS-AND-VALUES"))
(args-and-values-size (+ nargs values))
- (n-index (gensym))
- (n-cache (gensym)))
+ (n-index (sb!xc:gensym "INDEX"))
+ (n-cache (sb!xc:gensym "CACHE")))
(unless (= (length default-values) values)
(error "The number of default values ~S differs from :VALUES ~W."
(values-refs)
(values-names))
(dotimes (i values)
- (let ((name (gensym)))
+ (let ((name (sb!xc:gensym "VALUE")))
(values-names name)
(values-refs `(svref ,args-and-values (+ ,nargs ,i)))
(sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name))))
(let ((default-values (if (and (consp default) (eq (car default) 'values))
(cdr default)
(list default)))
- (arg-names (mapcar #'car args)))
- (collect ((values-names))
- (dotimes (i values)
- (values-names (gensym)))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- `(progn
- (define-hash-cache ,name ,args ,@options)
- (defun ,name ,arg-names
- ,@decls
- ,doc
- (cond #!+sb-show
- ((not (boundp '*hash-caches-initialized-p*))
- ;; This shouldn't happen, but it did happen to me
- ;; when revising the type system, and it's a lot
- ;; easier to figure out what what's going on with
- ;; that kind of problem if the system can be kept
- ;; alive until cold boot is complete. The recovery
- ;; mechanism should definitely be conditional on
- ;; some debugging feature (e.g. SB-SHOW) because
- ;; it's big, duplicating all the BODY code. -- WHN
- (/show0 ,name " too early in cold init, uncached")
- (/show0 ,(first arg-names) "=..")
- (/hexstr ,(first arg-names))
- ,@body)
- (t
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar (lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))))
+ (arg-names (mapcar #'car args))
+ (values-names (make-gensym-list values)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on some
+ ;; debugging feature (e.g. SB-SHOW) because it's big,
+ ;; duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,values-names
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ values-names default-values))
+ (multiple-value-bind ,values-names
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@values-names)
+ (values ,@values-names))
+ (values ,@values-names))))))))))
(defmacro define-cached-synonym
(name &optional (original (symbolicate "%" name)))
(let ((first? t)
maybe-print-space
(reversed-prints nil)
- (stream (gensym "STREAM")))
+ (stream (sb!xc:gensym "STREAM")))
(flet ((sref (slot-name)
`(,(symbolicate conc-name slot-name) structure)))
(dolist (slot-desc slot-descs)
(defmacro with-pretty-stream ((stream-var
&optional (stream-expression stream-var))
&body body)
- (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
+ (let ((flet-name (sb!xc:gensym "WITH-PRETTY-STREAM")))
`(flet ((,flet-name (,stream-var)
,@body))
(let ((stream ,stream-expression))
((t) *terminal-io*)
(t ,stream))))))
(let* ((object-var (if object (gensym) nil))
- (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
+ (block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-"))
(count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
- (pp-pop-name (gensym "PPRINT-POP-"))
+ (pp-pop-name (sb!xc:gensym "PPRINT-POP-"))
(body
;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
;; expand into a boatload of code, since DESCEND-INTO is a
;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too
;;; deep, then a #\# is printed to STREAM and BODY is ignored.
(defmacro descend-into ((stream) &body body)
- (let ((flet-name (gensym)))
+ (let ((flet-name (sb!xc:gensym "DESCEND")))
`(flet ((,flet-name ()
,@body))
(cond ((and (null *print-readably*)
t))))))
(defmacro with-circularity-detection ((object stream) &body body)
- (let ((marker (gensym "WITH-CIRCULARITY-DETECTION-"))
- (body-name (gensym "WITH-CIRCULARITY-DETECTION-BODY-")))
+ (with-unique-names (marker body-name)
`(labels ((,body-name ()
,@body))
(cond ((not *print-circle*)
(sb!xc:macroexpand-1 form environment)
(if expanded
(sb!xc:get-setf-expansion expansion environment)
- (let ((new-var (gensym "NEW")))
+ (let ((new-var (sb!xc:gensym "NEW")))
(values nil nil (list new-var)
`(setq ,form ,new-var) form)))))
;; Local functions inhibit global SETF methods.
environment))))
(defun get-setf-method-inverse (form inverse setf-fun environment)
- (let ((new-var (gensym "NEW"))
+ (let ((new-var (sb!xc:gensym "NEW"))
(vars nil)
(vals nil)
(args nil))
(destructuring-bind
(lambda-list (&rest store-variables) &body body)
rest
- (let ((whole-var (gensym "WHOLE-"))
- (access-form-var (gensym "ACCESS-FORM-"))
- (env-var (gensym "ENVIRONMENT-")))
+ (with-unique-names (whole access-form environment)
(multiple-value-bind (body local-decs doc)
(parse-defmacro `(,lambda-list ,@store-variables)
- whole-var body access-fn 'defsetf
- :environment env-var
+ whole body access-fn 'defsetf
+ :environment environment
:anonymousp t)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(assign-setf-macro
',access-fn
- (lambda (,access-form-var ,env-var)
+ (lambda (,access-form ,environment)
,@local-decs
- (%defsetf ,access-form-var ,(length store-variables)
- (lambda (,whole-var)
+ (%defsetf ,access-form ,(length store-variables)
+ (lambda (,whole)
,body)))
nil
',doc))))))
(sb!xc:defmacro deferr (name args &rest body)
(let* ((rest-pos (position '&rest args))
(required (if rest-pos (subseq args 0 rest-pos) args))
- (fp (gensym))
- (context (gensym))
- (sc-offsets (gensym))
(fn-name (symbolicate name "-HANDLER")))
- `(progn
- ;; FIXME: Having a separate full DEFUN for each error doesn't
- ;; seem to add much value, and it takes a lot of space. Perhaps
- ;; we could do this dispatch with a big CASE statement instead?
- (defun ,fn-name (name ,fp ,context ,sc-offsets)
- ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
- ;; tricks to hide this internal error-handling logic from the
- ;; poor high level user, so his debugger tells him about
- ;; where his error was detected instead of telling him where
- ;; he ended up inside the system error-handling logic.
- (declare (ignorable name ,fp ,context ,sc-offsets))
- (let (,@(let ((offset -1))
- (mapcar (lambda (var)
- `(,var (sb!di::sub-access-debug-var-slot
- ,fp
- (nth ,(incf offset)
- ,sc-offsets)
- ,context)))
- required))
- ,@(when rest-pos
- `((,(nth (1+ rest-pos) args)
- (mapcar (lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- ,fp
- sc-offset
- ,context))
- (nthcdr ,rest-pos ,sc-offsets))))))
- ,@body))
- (setf (svref *internal-errors* ,(error-number-or-lose name))
- #',fn-name))))
+ (with-unique-names (fp context sc-offsets)
+ `(progn
+ ;; FIXME: Having a separate full DEFUN for each error doesn't
+ ;; seem to add much value, and it takes a lot of space. Perhaps
+ ;; we could do this dispatch with a big CASE statement instead?
+ (defun ,fn-name (name ,fp ,context ,sc-offsets)
+ ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
+ ;; tricks to hide this internal error-handling logic from the
+ ;; poor high level user, so his debugger tells him about
+ ;; where his error was detected instead of telling him where
+ ;; he ended up inside the system error-handling logic.
+ (declare (ignorable name ,fp ,context ,sc-offsets))
+ (let (,@(let ((offset -1))
+ (mapcar (lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
+ ,fp
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
+ required))
+ ,@(when rest-pos
+ `((,(nth (1+ rest-pos) args)
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
+ (nthcdr ,rest-pos ,sc-offsets))))))
+ ,@body))
+ (setf (svref *internal-errors* ,(error-number-or-lose name))
+ #',fn-name)))))
) ; EVAL-WHEN
`(,*expander-next-arg-macro*
,*default-format-error-control-string*
,(or offset *default-format-error-offset*))
- (let ((symbol (gensym "FORMAT-ARG-")))
+ (let ((symbol (sb!xc:gensym "FORMAT-ARG")))
(push (cons symbol (or offset *default-format-error-offset*))
*simple-args*)
symbol)))
(once-only ((params params))
(if specs
(collect ((expander-bindings) (runtime-bindings))
- (dolist (spec specs)
- (destructuring-bind (var default) spec
- (let ((symbol (gensym)))
- (expander-bindings
- `(,var ',symbol))
- (runtime-bindings
- `(list ',symbol
- (let* ((param-and-offset (pop ,params))
- (offset (car param-and-offset))
- (param (cdr param-and-offset)))
- (case param
- (:arg `(or ,(expand-next-arg offset)
- ,,default))
- (:remaining
- (setf *only-simple-args* nil)
- '(length args))
- ((nil) ,default)
- (t param))))))))
- `(let ,(expander-bindings)
- `(let ,(list ,@(runtime-bindings))
- ,@(if ,params
- (error
- 'format-error
- :complaint
- "too many parameters, expected no more than ~W"
- :args (list ,(length specs))
- :offset (caar ,params)))
- ,,@body)))
+ (dolist (spec specs)
+ (destructuring-bind (var default) spec
+ (let ((symbol (sb!xc:gensym "FVAR")))
+ (expander-bindings
+ `(,var ',symbol))
+ (runtime-bindings
+ `(list ',symbol
+ (let* ((param-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg `(or ,(expand-next-arg offset) ,,default))
+ (:remaining
+ (setf *only-simple-args* nil)
+ '(length args))
+ ((nil) ,default)
+ (t param))))))))
+ `(let ,(expander-bindings)
+ `(let ,(list ,@(runtime-bindings))
+ ,@(if ,params
+ (error
+ 'format-error
+ :complaint "too many parameters, expected no more than ~W"
+ :args (list ,(length specs))
+ :offset (caar ,params)))
+ ,,@body)))
`(progn
(when ,params
(error 'format-error
(let ((defun-name (intern (format nil
"~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
char)))
- (directive (gensym))
- (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ (directive (sb!xc:gensym "DIRECTIVE"))
+ (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
`(progn
(defun ,defun-name (,directive ,directives)
,@(if lambda-list
;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
(defmacro def-format-directive (char lambda-list &body body)
- (let ((directives (gensym))
+ (let ((directives (sb!xc:gensym "DIRECTIVES"))
(declarations nil)
(body-without-decls body))
(loop
((base nil) (mincol 0) (padchar #\space) (commachar #\,)
(commainterval 3))
params
- (let ((n-arg (gensym)))
+ (let ((n-arg (sb!xc:gensym "ARG")))
`(let ((,n-arg ,(expand-next-arg)))
(if ,base
(format-print-integer stream ,n-arg ,colonp ,atsignp
(collect ((param-names) (bindings))
(dolist (param-and-offset params)
(let ((param (cdr param-and-offset)))
- (let ((param-name (gensym)))
+ (let ((param-name (sb!xc:gensym "PARAM")))
(param-names param-name)
(bindings `(,param-name
,(case param
;; optional dispatch mechanism for the M-V-B gets increasingly
;; hairy.
(if (integerp n)
- (let ((dummy-list nil)
- (keeper (gensym "KEEPER-")))
- ;; We build DUMMY-LIST, a list of variables to bind to useless
- ;; values, then we explicitly IGNORE those bindings and return
- ;; KEEPER, the only thing we're really interested in right now.
- (dotimes (i n)
- (push (gensym "IGNORE-") dummy-list))
+ (let ((dummy-list (make-gensym-list n))
+ (keeper (sb!xc:gensym "KEEPER")))
`(multiple-value-bind (,@dummy-list ,keeper) ,form
(declare (ignore ,@dummy-list))
,keeper))
PACKAGE with VAR bound to the current symbol."
(multiple-value-bind (body decls)
(parse-body body-decls :doc-string-allowed nil)
- (let ((flet-name (gensym "DO-SYMBOLS-")))
+ (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
,@decls
VAR bound to the current symbol."
(multiple-value-bind (body decls)
(parse-body body-decls :doc-string-allowed nil)
- (let ((flet-name (gensym "DO-SYMBOLS-")))
+ (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
,@decls
to the current symbol."
(multiple-value-bind (body decls)
(parse-body body-decls :doc-string-allowed nil)
- (let ((flet-name (gensym "DO-SYMBOLS-")))
+ (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
,@decls
such that successive invocations of (MNAME) will return the symbols, one by
one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
of :INHERITED :EXTERNAL :INTERNAL."
- (let* ((packages (gensym))
- (these-packages (gensym))
- (ordered-types (let ((res nil))
- (dolist (kind '(:inherited :external :internal)
- res)
- (when (member kind symbol-types)
- (push kind res))))) ; Order SYMBOL-TYPES.
- (counter (gensym))
- (kind (gensym))
- (hash-vector (gensym))
- (vector (gensym))
- (package-use-list (gensym))
- (init-macro (gensym))
- (end-test-macro (gensym))
- (real-symbol-p (gensym))
- (inherited-symbol-p (gensym))
- (BLOCK (gensym)))
- `(let* ((,these-packages ,package-list)
- (,packages `,(mapcar (lambda (package)
- (if (packagep package)
- package
- ;; Maybe FIND-PACKAGE-OR-DIE?
- (or (find-package package)
- (error 'simple-package-error
- ;; could be a character
- :package (string package)
- :format-control "~@<~S does not name a package ~:>"
- :format-arguments (list package)))))
- (if (consp ,these-packages)
- ,these-packages
- (list ,these-packages))))
- (,counter nil)
- (,kind (car ,packages))
- (,hash-vector nil)
- (,vector nil)
- (,package-use-list nil))
- ,(if (member :inherited ordered-types)
- `(setf ,package-use-list (package-%use-list (car ,packages)))
- `(declare (ignore ,package-use-list)))
- (macrolet ((,init-macro (next-kind)
- (declare (optimize (inhibit-warnings 3)))
- (let ((symbols (gensym)))
- `(progn
- (setf ,',kind ,next-kind)
- (setf ,',counter nil)
- ,(case next-kind
- (:internal
- `(let ((,symbols (package-internal-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))
- (:external
- `(let ((,symbols (package-external-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))
- (:inherited
- `(let ((,symbols (and ,',package-use-list
- (package-external-symbols
- (car ,',package-use-list)))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))))))
- (,end-test-macro (this-kind)
+ (with-unique-names (packages these-packages counter kind hash-vector vector
+ package-use-list init-macro end-test-macro real-symbol-p
+ inherited-symbol-p BLOCK)
+ (let ((ordered-types (let ((res nil))
+ (dolist (kind '(:inherited :external :internal) res)
+ (when (member kind symbol-types)
+ (push kind res)))))) ; Order SYMBOL-TYPES.
+ `(let* ((,these-packages ,package-list)
+ (,packages `,(mapcar (lambda (package)
+ (if (packagep package)
+ package
+ ;; Maybe FIND-PACKAGE-OR-DIE?
+ (or (find-package package)
+ (error 'simple-package-error
+ ;; could be a character
+ :package (string package)
+ :format-control "~@<~S does not name a package ~:>"
+ :format-arguments (list package)))))
+ (if (consp ,these-packages)
+ ,these-packages
+ (list ,these-packages))))
+ (,counter nil)
+ (,kind (car ,packages))
+ (,hash-vector nil)
+ (,vector nil)
+ (,package-use-list nil))
+ ,(if (member :inherited ordered-types)
+ `(setf ,package-use-list (package-%use-list (car ,packages)))
+ `(declare (ignore ,package-use-list)))
+ (macrolet ((,init-macro (next-kind)
+ (declare (optimize (inhibit-warnings 3)))
+ (let ((symbols (gensym)))
+ `(progn
+ (setf ,',kind ,next-kind)
+ (setf ,',counter nil)
+ ,(case next-kind
+ (:internal
+ `(let ((,symbols (package-internal-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:external
+ `(let ((,symbols (package-external-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:inherited
+ `(let ((,symbols (and ,',package-use-list
+ (package-external-symbols
+ (car ,',package-use-list)))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))))))
+ (,end-test-macro (this-kind)
`,(let ((next-kind (cadr (member this-kind
',ordered-types))))
- (if next-kind
- `(,',init-macro ,next-kind)
- `(if (endp (setf ,',packages (cdr ,',packages)))
+ (if next-kind
+ `(,',init-macro ,next-kind)
+ `(if (endp (setf ,',packages (cdr ,',packages)))
(return-from ,',BLOCK)
(,',init-macro ,(car ',ordered-types)))))))
- (when ,packages
- ,(when (null symbol-types)
- (error 'simple-program-error
- :format-control
- "At least one of :INTERNAL, :EXTERNAL, or ~
+ (when ,packages
+ ,(when (null symbol-types)
+ (error 'simple-program-error
+ :format-control
+ "At least one of :INTERNAL, :EXTERNAL, or ~
:INHERITED must be supplied."))
- ,(dolist (symbol symbol-types)
- (unless (member symbol '(:internal :external :inherited))
- (error 'simple-program-error
- :format-control
- "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
- :format-arguments (list symbol))))
- (,init-macro ,(car ordered-types))
- (flet ((,real-symbol-p (number)
- (> number 1)))
- (macrolet ((,mname ()
- (declare (optimize (inhibit-warnings 3)))
- `(block ,',BLOCK
- (loop
- (case ,',kind
- ,@(when (member :internal ',ordered-types)
- `((:internal
- (setf ,',counter
- (position-if #',',real-symbol-p
- (the hash-vector ,',hash-vector)
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :internal)))))
- ,@(when (member :external ',ordered-types)
- `((:external
- (setf ,',counter
- (position-if #',',real-symbol-p
- (the hash-vector ,',hash-vector)
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :external)))))
- ,@(when (member :inherited ',ordered-types)
- `((:inherited
- (flet ((,',inherited-symbol-p (number)
- (when (,',real-symbol-p number)
- (let* ((p (position
- number
- (the hash-vector
- ,',hash-vector)
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (s (svref ,',vector p)))
- (eql (nth-value
- 1 (find-symbol
- (symbol-name s)
- (car ,',packages)))
- :inherited)))))
- (setf ,',counter
- (when ,',hash-vector
- (position-if #',',inherited-symbol-p
- (the hash-vector
- ,',hash-vector)
- :start (if ,',counter
- (1+ ,',counter)
- 0)))))
- (cond (,',counter
- (return-from
- ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages))
- ))
- (t
- (setf ,',package-use-list
- (cdr ,',package-use-list))
- (cond ((endp ,',package-use-list)
- (setf ,',packages (cdr ,',packages))
- (when (endp ,',packages)
- (return-from ,',BLOCK))
- (setf ,',package-use-list
- (package-%use-list
- (car ,',packages)))
- (,',init-macro ,(car
- ',ordered-types)))
- (t (,',init-macro :inherited)
- (setf ,',counter nil)))))))))))))
- ,@body)))))))
+ ,(dolist (symbol symbol-types)
+ (unless (member symbol '(:internal :external :inherited))
+ (error 'simple-program-error
+ :format-control
+ "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
+ :format-arguments (list symbol))))
+ (,init-macro ,(car ordered-types))
+ (flet ((,real-symbol-p (number)
+ (> number 1)))
+ (macrolet ((,mname ()
+ (declare (optimize (inhibit-warnings 3)))
+ `(block ,',BLOCK
+ (loop
+ (case ,',kind
+ ,@(when (member :internal ',ordered-types)
+ `((:internal
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :internal)))))
+ ,@(when (member :external ',ordered-types)
+ `((:external
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :external)))))
+ ,@(when (member :inherited ',ordered-types)
+ `((:inherited
+ (flet ((,',inherited-symbol-p (number)
+ (when (,',real-symbol-p number)
+ (let* ((p (position
+ number
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (s (svref ,',vector p)))
+ (eql (nth-value
+ 1 (find-symbol
+ (symbol-name s)
+ (car ,',packages)))
+ :inherited)))))
+ (setf ,',counter
+ (when ,',hash-vector
+ (position-if #',',inherited-symbol-p
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))))
+ (cond (,',counter
+ (return-from
+ ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages))
+ ))
+ (t
+ (setf ,',package-use-list
+ (cdr ,',package-use-list))
+ (cond ((endp ,',package-use-list)
+ (setf ,',packages (cdr ,',packages))
+ (when (endp ,',packages)
+ (return-from ,',BLOCK))
+ (setf ,',package-use-list
+ (package-%use-list
+ (car ,',packages)))
+ (,',init-macro ,(car
+ ',ordered-types)))
+ (t (,',init-macro :inherited)
+ (setf ,',counter nil)))))))))))))
+ ,@body))))))))
:maximum ,explicit-maximum))))))
*arg-tests*))
(when key-seen
- (let ((problem (gensym "KEY-PROBLEM-"))
- (info (gensym "INFO-")))
+ (with-unique-names (problem info)
(push `(multiple-value-bind (,problem ,info)
(verify-keywords ,rest-name
',keys
(let ((block-name (when env
(car (find-if #'car (sb!c::lexenv-blocks env))))))
(if block-name
- (gensym (format nil "~A[~A]" name block-name))
- (gensym name))))
-
+ (sb!xc:gensym (format nil "~A[~A]" name block-name))
+ (sb!xc:gensym name))))
;;; Compile a version of BODY for all TYPES, and dispatch to the
;;; correct one based on the value of VAR. This was originally used
;;; only for strings, hence the name. Renaming it to something more
;;; generic might not be a bad idea.
(defmacro string-dispatch ((&rest types) var &body body)
- (let ((fun (gensym "STRING-DISPATCH-FUN-")))
+ (let ((fun (sb!xc:gensym "STRING-DISPATCH-FUN")))
`(flet ((,fun (,var)
,@body))
(declare (inline ,fun))
,@body))))
(:local
(/show0 ":LOCAL case")
- (let* ((var (gensym))
- (initval (if initial-value (gensym)))
+ (let* ((var (sb!xc:gensym "VAR"))
+ (initval (if initial-value (sb!xc:gensym "INITVAL")))
(info (make-local-alien-info :type alien-type))
(inner-body
`((note-local-alien-type ',info ,var)
(let ((stub (alien-fun-type-stub type)))
(unless stub
(setf stub
- (let ((fun (gensym))
+ (let ((fun (sb!xc:gensym "FUN"))
(parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
(intern (format nil
"~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
char)))
- (directive (gensym))
- (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ (directive (sb!xc:gensym "DIRECTIVE"))
+ (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
`(progn
(defun ,defun-name (stream ,directive ,directives orig-args args)
(declare (ignorable stream orig-args args))
(%set-format-directive-interpreter ,char #',defun-name))))
(sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
- (let ((directives (gensym)))
+ (let ((directives (sb!xc:gensym "DIRECTIVES")))
`(def-complex-format-interpreter ,char (,@lambda-list ,directives)
,@body
,directives)))
(multiple-value-bind (whole wholeless-arglist)
(if (eq '&whole (car arglist))
(values (cadr arglist) (cddr arglist))
- (values (gensym) arglist))
+ (values (sb!xc:gensym) arglist))
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
`(progn
;;; not checked for linux...
(defmacro fd-set (offset fd-set)
- (let ((word (gensym))
- (bit (gensym)))
+ (with-unique-names (word bit)
`(multiple-value-bind (,word ,bit) (floor ,offset
sb!vm:n-machine-word-bits)
(setf (deref (slot ,fd-set 'fds-bits) ,word)
;;; not checked for linux...
(defmacro fd-clr (offset fd-set)
- (let ((word (gensym))
- (bit (gensym)))
+ (with-unique-names (word bit)
`(multiple-value-bind (,word ,bit) (floor ,offset
sb!vm:n-machine-word-bits)
(setf (deref (slot ,fd-set 'fds-bits) ,word)
;;; not checked for linux...
(defmacro fd-isset (offset fd-set)
- (let ((word (gensym))
- (bit (gensym)))
+ (with-unique-names (word bit)
`(multiple-value-bind (,word ,bit) (floor ,offset
sb!vm:n-machine-word-bits)
(logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
"DEPOSIT-FIELD" "DPB"
"FBOUNDP" "FDEFINITION" "FMAKUNBOUND"
"FIND-CLASS"
+ "GENSYM" "*GENSYM-COUNTER*"
"GET-SETF-EXPANSION"
"LDB" "LDB-TEST"
"LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION"
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
- (segment-arg (gensym "SEGMENT-")))
+ (segment-arg (sb!xc:gensym "SEGMENT-")))
(dolist (byte-spec-expr byte-specs)
(let* ((byte-spec (eval byte-spec-expr))
(byte-size (byte-size byte-spec))
(byte-posn (byte-position byte-spec))
- (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
+ (arg (sb!xc:gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
(when (ldb-test (byte byte-size byte-posn) overall-mask)
(error "The byte spec ~S either overlaps another byte spec, or ~
extends past the end."
(defun grovel-lambda-list (lambda-list vop-var)
(let ((segment-name (car lambda-list))
- (vop-var (or vop-var (gensym "VOP-"))))
+ (vop-var (or vop-var (sb!xc:gensym "VOP"))))
(sb!int:collect ((new-lambda-list))
(new-lambda-list segment-name)
(new-lambda-list vop-var)
(values (first param)
(second param)
(or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
+ (sb!xc:gensym "SUPPLIED-P-")))
+ (values param nil (sb!xc:gensym "SUPPLIED-P-")))
(new-lambda-list (list name default supplied-p))
`(and ,supplied-p
(cons ,(if (consp name)
(values (first param)
(second param)
(or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
+ (sb!xc:gensym "SUPPLIED-P-")))
+ (values param nil (sb!xc:gensym "SUPPLIED-P-")))
(new-lambda-list (list name default supplied-p))
(multiple-value-bind (key var)
(if (consp name)
#-sb-xc-host ignore
#-sb-xc-host constraint-universe-end)
(let* ((constraint-universe #+sb-xc-host '*constraint-universe*
- #-sb-xc-host (gensym))
+ #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
(with-array-data
#+sb-xc-host '(progn)
#-sb-xc-host `(with-array-data
;; Constant CLASS and TYPE is an overwhelmingly common special case,
;; and we can implement it much more efficiently than the general case.
(if (and (keywordp class) (keywordp type))
- (let ((info (type-info-or-lose class type)))
+ (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type)))
(with-unique-names (value foundp)
`(multiple-value-bind (,value ,foundp)
(get-info-value ,name
(values ,value ,foundp))))
whole))
-(defun (setf info) (new-value
- class
- type
- name
- &optional (env-list nil env-list-p))
+(defun (setf info)
+ (new-value class type name &optional (env-list nil env-list-p))
(let* ((info (type-info-or-lose class type))
(tin (type-info-number info)))
(when (type-info-validate-function info)
;; does not accept them at all, and older SBCLs give a full warning.
;; So the easy thing is to hide this optimization from all xc hosts.
#-sb-xc-host
- (define-compiler-macro (setf info) (&whole whole
- new-value
- class
- type
- name
- &optional (env-list nil
- env-list-p))
+ (define-compiler-macro (setf info)
+ (&whole whole new-value class type name &optional (env-list nil env-list-p))
;; Constant CLASS and TYPE is an overwhelmingly common special case,
;; and we can resolve it much more efficiently than the general
;; case.
Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
style lambda-list used to parse the arguments. The Body should return a
list of subforms suitable for a \"~{~S ~}\" format string."
- (let ((n-whole (gensym)))
+ (with-unique-names (whole)
`(setf (gethash ',name *source-context-methods*)
- (lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+ (lambda (,whole)
+ (destructuring-bind ,lambda-list ,whole ,@body)))))
(define-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
(check-type ctran symbol)
(check-type lvar symbol)
(let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
- (post-binding-lexenv (or post-binding-lexenv (gensym))))
+ (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV"))))
`(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
,post-binding-lexenv-p
(lambda (,ctran ,lvar ,post-binding-lexenv)
;; KLUDGE: (NOT (< ...)) instead of >= avoids one round of
;; deftransforms and lambda-conversion.
`((,(if (zerop min) t `(not (< ,n-supplied ,max)))
- ,(let ((n-context (gensym))
- (n-count (gensym)))
+ ,(with-unique-names (n-context n-count)
`(multiple-value-bind (,n-context ,n-count)
(%more-arg-context ,n-supplied ,max)
(locally
(,get-setf-expansion-fun-name place env)
(when (cdr stores)
(error "multiple store variables for ~S" place))
- (let ((newval (gensym))
- (n-place (gensym))
+ (let ((newval (sb!xc:gensym))
+ (n-place (sb!xc:gensym))
(mask (compute-attribute-mask attributes ,translations-name)))
(values `(,@temps ,n-place)
`(,@values ,get)
(when (and eval-name defun-only)
(error "can't specify both DEFUN-ONLY and EVAL-NAME"))
(multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- (let ((n-args (gensym))
- (n-node (or node (gensym)))
- (n-decls (gensym))
- (n-lambda (gensym))
+ (let ((n-args (sb!xc:gensym))
+ (n-node (or node (sb!xc:gensym)))
+ (n-decls (sb!xc:gensym))
+ (n-lambda (sb!xc:gensym))
(decls-body `(,@decls ,@body)))
(multiple-value-bind (parsed-form vars)
(parse-deftransform lambda-list
;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
;;; methods are passed an additional POLICY argument, and IR2-CONVERT
;;; methods are passed an additional IR2-BLOCK argument.
-(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
+(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym))
&rest vars)
&body body)
(let ((name (if (symbolp what) what
;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
(*info-environment* *info-environment*)
(*compiler-sset-counter* 0)
- (*gensym-counter* 0))
+ (sb!xc:*gensym-counter* 0))
(handler-case
(handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
(with-compilation-values
;;; Call the emit function for TEMPLATE, linking the result in at the
;;; end of BLOCK.
(defmacro emit-template (node block template args results &optional info)
- (let ((n-first (gensym))
- (n-last (gensym)))
+ (with-unique-names (first last)
(once-only ((n-node node)
(n-block block)
(n-template template))
- `(multiple-value-bind (,n-first ,n-last)
+ `(multiple-value-bind (,first ,last)
(funcall (template-emit-function ,n-template)
,n-node ,n-block ,n-template ,args ,results
,@(when info `(,info)))
- (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
+ (insert-vop-sequence ,first ,last ,n-block nil)))))
;;; VOP Name Node Block Arg* Info* Result*
;;;
;;; represented by a local conflicts bit-vector and the IR2-BLOCK
;;; containing the location.
(defmacro do-live-tns ((tn-var live block &optional result) &body body)
- (let ((n-conf (gensym))
- (n-bod (gensym))
- (i (gensym))
- (ltns (gensym)))
+ (with-unique-names (conf bod i ltns)
(once-only ((n-live live)
(n-block block))
`(block nil
- (flet ((,n-bod (,tn-var) ,@body))
+ (flet ((,bod (,tn-var) ,@body))
;; Do component-live TNs.
(dolist (,tn-var (ir2-component-component-tns
(component-info
(block-component
(ir2-block-block ,n-block)))))
- (,n-bod ,tn-var))
+ (,bod ,tn-var))
(let ((,ltns (ir2-block-local-tns ,n-block)))
;; Do TNs always-live in this block and live :MORE TNs.
- (do ((,n-conf (ir2-block-global-tns ,n-block)
- (global-conflicts-next-blockwise ,n-conf)))
- ((null ,n-conf))
- (when (or (eq (global-conflicts-kind ,n-conf) :live)
- (let ((,i (global-conflicts-number ,n-conf)))
+ (do ((,conf (ir2-block-global-tns ,n-block)
+ (global-conflicts-next-blockwise ,conf)))
+ ((null ,conf))
+ (when (or (eq (global-conflicts-kind ,conf) :live)
+ (let ((,i (global-conflicts-number ,conf)))
(and (eq (svref ,ltns ,i) :more)
(not (zerop (sbit ,n-live ,i))))))
- (,n-bod (global-conflicts-tn ,n-conf))))
+ (,bod (global-conflicts-tn ,conf))))
;; Do TNs locally live in the designated live set.
(dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
(unless (zerop (sbit ,n-live ,i))
(let ((,tn-var (svref ,ltns ,i)))
(when (and ,tn-var (not (eq ,tn-var :more)))
- (,n-bod ,tn-var)))))))))))
+ (,bod ,tn-var)))))))))))
;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
(defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
(error "either too many args (~W) or too many results (~W); max = ~W"
num-args num-results register-arg-count))
(let ((num-temps (max num-args num-results))
- (node (gensym "NODE-")))
+ (node (sb!xc:gensym "NODE")))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
(let ((result-name (intern (format nil "RESULT-~D" i))))
;;; 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".)
-"1.0.27.31"
+"1.0.27.32"
projects / sbcl.git / commitdiff