From clisp, about 10 files still differ in xc fasls after these changes.
At least one remaining issue is obvious (floats, where our float constants
aren't representable on clisp) but there are other mysteries.
(let* ((name (first spec))
(exp-temp (gensym "ONCE-ONLY")))
`(let ((,exp-temp ,(second spec))
- (,name (gensym ,(symbol-name name))))
+ (,name (sb!xc:gensym ,(symbol-name name))))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
\f
(defmacro define-deprecated-function (state since name replacements lambda-list &body body)
(let* ((replacements (normalize-deprecation-replacements replacements))
- (doc (let ((*package* (find-package :keyword)))
- (apply #'format nil
- "~@<~S has been deprecated as of SBCL ~A.~
- ~#[~; Use ~S instead.~; ~
- Use ~S or ~S instead.~:; ~
- Use~@{~#[~; or~] ~S~^,~} instead.~]~@:>"
- name since replacements))))
+ (doc
+ (let ((*package* (find-package :keyword))
+ (*print-pretty* nil))
+ (apply #'format nil
+ "~S has been deprecated as of SBCL ~A.~
+ ~#[~;~2%Use ~S instead.~;~2%~
+ Use ~S or ~S instead.~:;~2%~
+ Use~@{~#[~; or~] ~S~^,~} instead.~]"
+ name since replacements))))
`(progn
,(ecase state
((:early :late)
- `(defun ,name ,lambda-list
- ,doc
- ,@body))
+ `(progn
+ (defun ,name ,lambda-list
+ ,doc
+ ,@body)))
((:final)
`(progn
(declaim (ftype (function * nil) ,name))
(stem (if (every #'alpha-char-p symbol-name)
symbol-name
(concatenate 'string symbol-name "-"))))
- `(,symbol (gensym ,stem))))
+ `(,symbol (sb!xc:gensym ,stem))))
symbols)
,@body))
(when (eq t name)
(break))
(if name
- (loop repeat n collect (gensym (string name)))
- (loop repeat n collect (gensym))))
+ (loop repeat n collect (sb!xc:gensym (string name)))
+ (loop repeat n collect (sb!xc:gensym))))
\f
;;;; miscellany
(string= name "-LOWTAG" :start1 (- len 7))
(zerop (logand (symbol-value sym) fixnum-tag-mask)))
(push sym fixtags))))
- `',fixtags)
+ `',(sort fixtags #'string< :key #'symbol-name))
#'equal)
;;; the heap types, stored in 8 bits of the header of an object on the
(dolist (default defaults)
(if (sb!xc:constantp default)
(default-vals default)
- (let ((var (gensym)))
+ (let ((var (sb!xc:gensym)))
(default-bindings `(,var ,default))
(default-vals var))))
(let ((bindings (default-bindings))
:type (leaf-type var)
:where-from (leaf-where-from var))))
- (let* ((n-context (gensym "N-CONTEXT-"))
+ (let* ((n-context (sb!xc:gensym "N-CONTEXT-"))
(context-temp (make-lambda-var :%source-name n-context))
- (n-count (gensym "N-COUNT-"))
+ (n-count (sb!xc:gensym "N-COUNT-"))
(count-temp (make-lambda-var :%source-name n-count
:type (specifier-type 'index))))
;; and take advantage of the base+index+displacement addressing
;; mode on x86oids.)
(when (optional-dispatch-keyp res)
- (let ((n-index (gensym "N-INDEX-"))
- (n-key (gensym "N-KEY-"))
- (n-value-temp (gensym "N-VALUE-TEMP-"))
- (n-allowp (gensym "N-ALLOWP-"))
- (n-lose (gensym "N-LOSE-"))
- (n-losep (gensym "N-LOSEP-"))
+ (let ((n-index (sb!xc:gensym "N-INDEX-"))
+ (n-key (sb!xc:gensym "N-KEY-"))
+ (n-value-temp (sb!xc:gensym "N-VALUE-TEMP-"))
+ (n-allowp (sb!xc:gensym "N-ALLOWP-"))
+ (n-lose (sb!xc:gensym "N-LOSE-"))
+ (n-losep (sb!xc:gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
(policy *lexenv* (zerop safety))))
(found-allow-p nil))
(default (arg-info-default info))
(keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
- (n-value (gensym "N-VALUE-"))
+ (n-value (sb!xc:gensym "N-VALUE-"))
(clause (cond (supplied-p
- (let ((n-supplied (gensym "N-SUPPLIED-")))
+ (let ((n-supplied (sb!xc:gensym "N-SUPPLIED-")))
(temps n-supplied)
(arg-vals n-value n-supplied)
`((eq ,n-key ',keyword)
;; Make up two extra variables, and squirrel them away in
;; ARG-INFO-DEFAULT for transforming (VALUES-LIST REST) into
;; (%MORE-ARG-VALUES CONTEXT 0 COUNT) when possible.
- (let* ((context-name (gensym "REST-CONTEXT"))
+ (let* ((context-name (sb!xc:gensym "REST-CONTEXT-"))
(context (make-lambda-var :%source-name context-name
:arg-info (make-arg-info :kind :more-context)))
- (count-name (gensym "REST-COUNT"))
+ (count-name (sb!xc:gensym "REST-COUNT-"))
(count (make-lambda-var :%source-name count-name
:arg-info (make-arg-info :kind :more-count)
:type (specifier-type 'index))))
(main-vars val-temp)
(bind-vars key)
(cond ((or hairy-default supplied-p)
- (let* ((n-supplied (gensym "N-SUPPLIED-"))
+ (let* ((n-supplied (sb!xc:gensym "N-SUPPLIED-"))
(supplied-temp (make-lambda-var
:%source-name n-supplied)))
(unless supplied-p
collection."
(if objects
(let ((pins (make-gensym-list (length objects)))
- (wpo (gensym "WITH-PINNED-OBJECTS-THUNK")))
+ (wpo (sb!xc:gensym "WITH-PINNED-OBJECTS-THUNK")))
;; BODY is stuffed in a function to preserve the lexical
;; environment.
`(flet ((,wpo () (progn ,@body)))
(dolist (flag flags)
(inst cmov flag res then))))))))
-(macrolet ((def-move-if (name type reg &optional stack)
- (when stack (setf stack (list stack)))
-
- `(define-vop (,name move-if)
- (:args (then :scs (immediate ,reg ,@stack) :to :eval
- :load-if (not (or (sc-is then immediate)
- (and (sc-is then ,@stack)
- (not (location= else res))))))
- (else :scs (immediate ,reg ,@stack) :target res
- :load-if (not (sc-is else immediate ,@stack))))
- (:arg-types ,type ,type)
- (:results (res :scs (,reg)
- :from (:argument 1)))
- (:result-types ,type))))
- (def-move-if move-if/t
- t descriptor-reg control-stack)
- (def-move-if move-if/fx
- tagged-num any-reg control-stack)
- (def-move-if move-if/unsigned
- unsigned-num unsigned-reg unsigned-stack)
- (def-move-if move-if/signed
- signed-num signed-reg signed-stack)
+(macrolet ((def-move-if (name type reg stack)
+ `(define-vop (,name move-if)
+ (:args (then :scs (immediate ,reg ,stack) :to :eval
+ :load-if (not (or (sc-is then immediate)
+ (and (sc-is then ,stack)
+ (not (location= else res))))))
+ (else :scs (immediate ,reg ,stack) :target res
+ :load-if (not (sc-is else immediate ,stack))))
+ (:arg-types ,type ,type)
+ (:results (res :scs (,reg)
+ :from (:argument 1)))
+ (:result-types ,type))))
+ (def-move-if move-if/t t descriptor-reg control-stack)
+ (def-move-if move-if/fx tagged-num any-reg control-stack)
+ (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
+ (def-move-if move-if/signed signed-num signed-reg signed-stack)
;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
#!+sb-unicode
- (def-move-if move-if/char
- character character-reg character-stack)
- (def-move-if move-if/sap
- system-area-pointer sap-reg sap-stack))
-
+ (def-move-if move-if/char character character-reg character-stack)
+ (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
\f
;;;; conditional VOPs
(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-"))
+ (new-rbp-ea
+ '(make-ea :qword
+ :disp (frame-byte-offset (+ sp->fp-offset -3 ocfp-save-offset))
+ :base rsp-tn)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
(let ((result-name (intern (format nil "RESULT-~D" i))))
;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
(cond ((policy ,node (>= speed space))
(inst sub rsp-tn (* 3 n-word-bytes))
- (inst mov (make-ea :qword :base rsp-tn
- :disp (frame-byte-offset
- (+ sp->fp-offset
- -3
- ocfp-save-offset)))
- rbp-tn)
- (inst lea rbp-tn (make-ea :qword :base rsp-tn
- :disp (frame-byte-offset
- (+ sp->fp-offset
- -3
- ocfp-save-offset)))))
+ (inst mov ,new-rbp-ea rbp-tn)
+ (inst lea rbp-tn ,new-rbp-ea))
(t
;; Dummy for return address.
(inst push rbp-tn)
,(if (zerop num-args)
'(inst xor ecx ecx)
- `(inst mov ecx (fixnumize ,num-args)))
+ `(inst mov ecx ,(fixnumize num-args)))
(note-this-location vop :call-site)
;; Old CMU CL comment: