(:temp ebx unsigned-reg ebx-offset))
(inst mov ebx eax)
(inst shl ebx 1)
- (inst jmp :o bignum)
+ (inst jmp :o BIGNUM)
(inst shl ebx 1)
- (inst jmp :o bignum)
+ (inst jmp :o BIGNUM)
(inst shl ebx 1)
- (inst jmp :o bignum)
+ (inst jmp :o BIGNUM)
(inst ret)
BIGNUM
(move rax x) ; must use eax for 64-bit result
(inst sar rax 3) ; remove *4 fixnum bias
(inst imul y) ; result in edx:eax
- (inst jmp :no okay) ; still fixnum
+ (inst jmp :no OKAY) ; still fixnum
;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
;; pfw says that loses big -- edx is target for arg x and result res
(:temp edi unsigned-reg rdi-offset))
;; Pick off the cases where everything fits in register args.
- (inst jecxz zero-values)
+ (inst jecxz ZERO-VALUES)
(inst cmp ecx (fixnumize 1))
- (inst jmp :e one-value)
+ (inst jmp :e ONE-VALUE)
(inst cmp ecx (fixnumize 2))
- (inst jmp :e two-values)
+ (inst jmp :e TWO-VALUES)
(inst cmp ecx (fixnumize 3))
- (inst jmp :e three-values)
+ (inst jmp :e THREE-VALUES)
;; Save the count, because the loop is going to destroy it.
(inst mov edx ecx)
(inst jmp :z error))
(inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
- (inst jmp :e exit)
+ (inst jmp :e EXIT)
(loadw catch catch catch-block-previous-catch-slot)
- (inst jmp loop)
+ (inst jmp LOOP)
EXIT
(inst cmp uwp
(make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
;; If a match, return to context in arg block.
- (inst jmp :e do-exit)
+ (inst jmp :e DO-EXIT)
;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context.
;; Important! Must save (and return) the arg 'block' for later use!!
(if nil
`(assert ,@args)))
;; We'll be doing a lot of modular arithmetic.
- (sb!xc:defmacro M (form)
+ (sb!xc:defmacro modularly (form)
`(logand all-ones-digit ,form)))
;;; I'm not sure why I need this FTYPE declaration. Compiled by the
(dotimes (i digit-size)
(setf umask (logior umask imask))
(unless (zerop (logand ud umask))
- (setf ud (M (- ud vd)))
- (setf m (M (logior m imask))))
- (setf imask (M (ash imask 1)))
- (setf vd (M (ash vd 1))))
+ (setf ud (modularly (- ud vd)))
+ (setf m (modularly (logior m imask))))
+ (setf imask (modularly (ash imask 1)))
+ (setf vd (modularly (ash vd 1))))
m))
(defun dmod (u u-len v v-len tmp1)
(let* ((c (bmod x y))
(n1 c)
(d1 1)
- (n2 (M (1+ (M (lognot n1)))))
- (d2 (M -1)))
+ (n2 (modularly (1+ (modularly (lognot n1)))))
+ (d2 (modularly -1)))
(declare (type (unsigned-byte #.sb!vm:n-word-bits) n1 d1 n2 d2))
(loop while (> n2 (expt 2 (truncate digit-size 2))) do
(loop for i of-type (mod #.sb!vm:n-word-bits)
downfrom (- (integer-length n1) (integer-length n2))
while (>= n1 n2) do
- (when (>= n1 (M (ash n2 i)))
- (psetf n1 (M (- n1 (M (ash n2 i))))
- d1 (M (- d1 (M (ash d2 i)))))))
+ (when (>= n1 (modularly (ash n2 i)))
+ (psetf n1 (modularly (- n1 (modularly (ash n2 i))))
+ d1 (modularly (- d1 (modularly (ash d2 i)))))))
(psetf n1 n2
d1 d2
n2 n1
(- (copy-bignum tmp1 tmp1-len)
(copy-bignum tmp2 tmp2-len)))))
(bignum-abs-buffer u u-len)
- (gcd-assert (zerop (M u)))))
+ (gcd-assert (zerop (modularly u)))))
(setf u-len (make-gcd-bignum-odd u u-len))
(rotatef u v)
(rotatef u-len v-len))
(defmacro define-cached-synonym
(name &optional (original (symbolicate "%" name)))
- (let ((cached-name (symbolicate "%%" name "-cached")))
+ (let ((cached-name (symbolicate "%%" name "-CACHED")))
`(progn
(defun-cached (,cached-name :hash-bits 8
:hash-function (lambda (x)
(mapcar
(lambda (buffering)
(let ((function
- (intern (let ((*print-case* :upcase))
- (format nil name-fmt (car buffering))))))
+ (intern (format nil name-fmt (string (car buffering))))))
`(progn
(defun ,function (stream byte)
(output-wrapper/variable-width (stream ,size ,buffering ,restart)
(mapcar
(lambda (buffering)
(let ((function
- (intern (let ((*print-case* :upcase))
- (format nil name-fmt (car buffering))))))
+ (intern (format nil name-fmt (string (car buffering))))))
`(progn
(defun ,function (stream byte)
(output-wrapper (stream ,size ,buffering ,restart)
(defmacro define-external-format (external-format size output-restart
out-expr in-expr)
(let* ((name (first external-format))
- (out-function (intern (let ((*print-case* :upcase))
- (format nil "OUTPUT-BYTES/~A" name))))
- (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
- (in-function (intern (let ((*print-case* :upcase))
- (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
- name))))
- (in-char-function (intern (let ((*print-case* :upcase))
- (format nil "INPUT-CHAR/~A" name)))))
+ (out-function (symbolicate "OUTPUT-BYTES/" name))
+ (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
+ (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
+ (in-char-function (symbolicate "INPUT-CHAR/" name)))
`(progn
(defun ,out-function (stream string flush-p start end)
(let ((start (or start 0))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
- (intern (let ((*print-case* :upcase))
- (format nil format buffering))))
+ (intern (format nil format (string buffering))))
'(:none :line :full)))
*external-formats*)))))
(external-format output-restart out-size-expr
out-expr in-size-expr in-expr)
(let* ((name (first external-format))
- (out-function (intern (let ((*print-case* :upcase))
- (format nil "OUTPUT-BYTES/~A" name))))
- (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
- (in-function (intern (let ((*print-case* :upcase))
- (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
- name))))
- (in-char-function (intern (let ((*print-case* :upcase))
- (format nil "INPUT-CHAR/~A" name))))
- (resync-function (intern (let ((*print-case* :upcase))
- (format nil "RESYNC/~A" name)))))
+ (out-function (symbolicate "OUTPUT-BYTES/" name))
+ (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
+ (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
+ (in-char-function (symbolicate "INPUT-CHAR/" name))
+ (resync-function (symbolicate "RESYNC/" name)))
`(progn
(defun ,out-function (fd-stream string flush-p start end)
(let ((start (or start 0))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
- (intern (let ((*print-case* :upcase))
- (format nil format buffering))))
+ (intern (format nil format (string buffering))))
'(:none :line :full))
,resync-function)
*external-formats*)))))
(error 'floating-point-underflow))
((not (zerop (logand float-inexact-trap-bit traps)))
(error 'floating-point-inexact))
- #!+FreeBSD
+ #!+freebsd
((zerop (ldb float-exceptions-byte modes))
;; I can't tell what caused the exception!!
(error 'floating-point-exception
(cond ((satisfies-the-test old subtree) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (satisfies-the-test old subtree)
(setf (cdr last) new)))
(cond ((funcall test (apply-key key subtree)) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (funcall test (apply-key key subtree))
(setf (cdr last) new)))
(cond ((not (funcall test (apply-key key subtree))) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (not (funcall test (apply-key key subtree)))
(setf (cdr last) new)))
(declare (inline assoc))
(let (temp)
(labels ((s (subtree)
- (cond ((Setq temp (nsublis-macro))
+ (cond ((setq temp (nsublis-macro))
(cdr temp))
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (setq temp (nsublis-macro))
(setf (cdr last) (cdr temp))))
(if (setq temp (nsublis-macro))
- (return (setf (Cdr last) (Cdr temp)))
+ (return (setf (cdr last) (cdr temp)))
(setf (car subtree) (s (car subtree)))))
subtree))))
(s tree)))))
(do () ((endp list1))
(if (with-set-keys (member (apply-key key (car list1)) list2))
(steve-splice list1 res)
- (setq list1 (Cdr list1))))
+ (setq list1 (cdr list1))))
res)))
(defun set-difference (list1 list2
(cond ((eql t1 0) 0)
((eql g2 1)
(%make-ratio t1 (* t2 dy)))
- (T (let* ((nn (truncate t1 g2))
+ (t (let* ((nn (truncate t1 g2))
(t3 (truncate dy g2))
(nd (if (eql t2 1) t3 (* t2 t3))))
(if (eql nd 1) nn (%make-ratio nn nd))))))))))))
"Return T if all of its arguments are numerically equal, NIL otherwise."
(the number number)
(do ((nlist more-numbers (cdr nlist)))
- ((atom nlist) T)
+ ((atom nlist) t)
(declare (list nlist))
(if (not (= (car nlist) number)) (return nil))))
((atom nlist) t)
(declare (list nlist))
(unless (do* ((nl nlist (cdr nl)))
- ((atom nl) T)
+ ((atom nl) t)
(declare (list nl))
(if (= head (car nl)) (return nil)))
(return nil))))
"If true, all objects will printed readably. If readable printing is
impossible, an error will be signalled. This overrides the value of
*PRINT-ESCAPE*.")
-(defvar *print-escape* T
+(defvar *print-escape* t
#!+sb-doc
"Should we print in a reasonably machine-readable way? (possibly
overridden by *PRINT-READABLY*)")
(defun sharp-B (stream sub-char numarg)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 2))
+ (sharp-R stream sub-char 2))
(defun sharp-C (stream sub-char numarg)
(ignore-numarg sub-char numarg)
;; The next thing had better be a list of two numbers.
(let ((cnum (read stream t nil t)))
- (when *read-suppress* (return-from sharp-c nil))
+ (when *read-suppress* (return-from sharp-C nil))
(if (and (listp cnum) (= (length cnum) 2))
(complex (car cnum) (cadr cnum))
(%reader-error stream "illegal complex number format: #C~S" cnum))))
(defun sharp-O (stream sub-char numarg)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 8))
+ (sharp-R stream sub-char 8))
(defun sharp-R (stream sub-char radix)
(cond (*read-suppress*
(defun sharp-X (stream sub-char numarg)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 16))
+ (sharp-R stream sub-char 16))
\f
;;;; reading circular data: the #= and ## readmacros
(set-dispatch-macro-character #\# #\C #'sharp-C)
(set-dispatch-macro-character #\# #\c #'sharp-C)
(set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
- (set-dispatch-macro-character #\# #\p #'sharp-p)
- (set-dispatch-macro-character #\# #\P #'sharp-p)
+ (set-dispatch-macro-character #\# #\p #'sharp-P)
+ (set-dispatch-macro-character #\# #\P #'sharp-P)
(set-dispatch-macro-character #\# #\) #'sharp-illegal)
(set-dispatch-macro-character #\# #\< #'sharp-illegal)
(set-dispatch-macro-character #\# #\Space #'sharp-illegal)
`(let ((,svar ,stream))
(cond ((null ,svar) *standard-input*)
((eq ,svar t) *terminal-io*)
- (T ,@(when check-type `((enforce-type ,svar ,check-type)))
+ (t ,@(when check-type `((enforce-type ,svar ,check-type))) ;
#!+high-security
(unless (input-stream-p ,svar)
(error 'simple-type-error
`(let ((,svar ,stream))
(cond ((null ,svar) *standard-output*)
((eq ,svar t) *terminal-io*)
- (T ,@(when check-type `((check-type ,svar ,check-type)))
+ (t ,@(when check-type `((check-type ,svar ,check-type)))
#!+high-security
(unless (output-stream-p ,svar)
(error 'simple-type-error
;; We just simple-stringify the name and call INTERN*, where the real
;; logic is.
(let ((name (if (simple-string-p name)
- name
- (coerce name 'simple-string)))
+ name
+ (coerce name 'simple-string)))
(package (find-undeleted-package-or-lose package)))
(declare (simple-string name))
(intern* name
(enumerable nil :read-only t)
;; an arbitrary hash code used in EQ-style hashing of identity
;; (since EQ hashing can't be done portably)
- (hash-value (random #.(ash 1 20))
+ (hash-value (random #.(ash 1 15))
:type (and fixnum unsigned-byte)
:read-only t)
;; Can this object contain other types? A global property of our
;;; they are ready for reading and writing. See the UNIX Programmer's
;;; Manual for more information.
(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
- (declare (type (integer 0 #.FD-SETSIZE) nfds)
+ (declare (type (integer 0 #.fd-setsize) nfds)
(type unsigned-byte rdfds wrfds xpfds)
(type (or (unsigned-byte 31) null) to-secs)
(type (unsigned-byte 31) to-usecs)
(rem (struct timespec)))
(setf (slot req 'tv-sec) secs)
(setf (slot req 'tv-nsec) nsecs)
- (loop while (eql sb!unix:EINTR
+ (loop while (eql sb!unix:eintr
(nth-value 1
(int-syscall ("nanosleep" (* (struct timespec))
(* (struct timespec)))
(tz (struct timezone)))
(syscall* ("gettimeofday" (* (struct timeval))
(* (struct timezone)))
- (values T
+ (values t
(slot tv 'tv-sec)
(slot tv 'tv-usec)
(slot tz 'tz-minuteswest)
(it-interval (struct timeval)) ; timer interval
(it-value (struct timeval)))) ; current value
-(defconstant ITIMER-REAL 0)
-(defconstant ITIMER-VIRTUAL 1)
-(defconstant ITIMER-PROF 2)
+(defconstant itimer-real 0)
+(defconstant itimer-virtual 1)
+(defconstant itimer-prof 2)
-(defun unix-getitimer(which)
+(defun unix-getitimer (which)
"Unix-getitimer returns the INTERVAL and VALUE slots of one of
three system timers (:real :virtual or :profile). On success,
unix-getitimer returns 5 values,
(unsigned-byte 29) (mod 1000000)
(unsigned-byte 29) (mod 1000000)))
(let ((which (ecase which
- (:real ITIMER-REAL)
- (:virtual ITIMER-VIRTUAL)
- (:profile ITIMER-PROF))))
+ (:real itimer-real)
+ (:virtual itimer-virtual)
+ (:profile itimer-prof))))
(with-alien ((itv (struct itimerval)))
(syscall* ("getitimer" int (* (struct itimerval)))
- (values T
+ (values t
(slot (slot itv 'it-interval) 'tv-sec)
(slot (slot itv 'it-interval) 'tv-usec)
(slot (slot itv 'it-value) 'tv-sec)
(unsigned-byte 29) (mod 1000000)
(unsigned-byte 29) (mod 1000000)))
(let ((which (ecase which
- (:real ITIMER-REAL)
- (:virtual ITIMER-VIRTUAL)
- (:profile ITIMER-PROF))))
+ (:real itimer-real)
+ (:virtual itimer-virtual)
+ (:profile itimer-prof))))
(with-alien ((itvn (struct itimerval))
(itvo (struct itimerval)))
(setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
(slot (slot itvn 'it-value ) 'tv-sec ) val-secs
(slot (slot itvn 'it-value ) 'tv-usec) val-usec)
(syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
- (values T
+ (values t
(slot (slot itvo 'it-interval) 'tv-sec)
(slot (slot itvo 'it-interval) 'tv-usec)
(slot (slot itvo 'it-value) 'tv-sec)
(push (eval `(list (multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
name
- (format nil "~A[~A]" name args)
+ (format nil "~@:(~A[~A]~)" name args)
(cdr option-spec)))))
pdefs))
(:printer-list
`(multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
',name
- (format nil "~A[~A]" ',name printer)
+ (format nil "~@:(~A[~A]~)" ',name printer)
printer
nil)))
,(cadr option-spec)))))
(6 (dump-fop 'fop-list*-6 file))
(7 (dump-fop 'fop-list*-7 file))
(8 (dump-fop 'fop-list*-8 file))
- (T (do ((nn n (- nn 255)))
+ (t (do ((nn n (- nn 255)))
((< nn 256)
(dump-fop 'fop-list* file)
(dump-byte nn file))
(6 (dump-fop 'fop-list-6 file))
(7 (dump-fop 'fop-list-7 file))
(8 (dump-fop 'fop-list-8 file))
- (T (cond ((< n 256)
+ (t (cond ((< n 256)
(dump-fop 'fop-list file)
(dump-byte n file))
(t (dump-fop 'fop-list file)
(n-info-types '*info-types*))
`(dotimes (,n-index (length ,n-table))
(declare (type index ,n-index))
- (block ,PUNT
+ (block ,punt
(let ((,name-var (svref ,n-table ,n-index)))
(unless (eql ,name-var 0)
(do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
,@body
(unless (zerop (logand ,n-info
compact-info-entry-last))
- (return-from ,PUNT))))))))))))))
+ (return-from ,punt))))))))))))))
;;; Return code to iterate over a volatile info environment.
(defun do-volatile-info (name-var class-var type-var type-number-var value-var
(let* ((fenv (when env (sb!c::lexenv-funs env)))
(local-def (cdr (assoc symbol fenv))))
(cond (local-def
- (if (and (consp local-def) (eq (car local-def) 'MACRO))
+ (if (and (consp local-def) (eq (car local-def) 'macro))
(cdr local-def)
nil))
((eq (info :function :kind symbol) :macro)
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
kind name)))
;; A magical cons that MACROEXPAND-1 understands.
- `(,name . (MACRO . ,expansion))))))
+ `(,name . (macro . ,expansion))))))
(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
name)))
(setq-var start next result leaf (second things)))
(cons
- (aver (eq (car leaf) 'MACRO))
+ (aver (eq (car leaf) 'macro))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
(ir1-convert start next result
`(setf ,(cdr leaf) ,(second things))))
(:macro
(let ((expansion (info :variable :macro-expansion name))
(type (type-specifier (info :variable :type name))))
- `(MACRO . (the ,type ,expansion))))
+ `(macro . (the ,type ,expansion))))
(:constant
(let ((value (info :variable :constant-value name)))
(make-constant :value value
(warn "reading an ignored variable: ~S" name)))
(reference-leaf start next result var))
(cons
- (aver (eq (car var) 'MACRO))
+ (aver (eq (car var) 'macro))
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(ir1-convert start next result (cdr var)))
(heap-alien-info
(process-var it nil))))
(cons
;; FIXME: non-ANSI weirdness
- (aver (eq (car var) 'MACRO))
- (new-vars `(,var-name . (MACRO . (the ,(first decl)
+ (aver (eq (car var) 'macro))
+ (new-vars `(,var-name . (macro . (the ,(first decl)
,(cdr var))))))
(heap-alien-info
(compiler-error
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
- (aver (eq (car var) 'MACRO))
+ (aver (eq (car var) 'macro))
(compiler-error
"~S is a symbol-macro and thus can't be declared special."
name))
(if (null splice)
(setq list (cdr x))
(rplacd splice (cdr x))))
- (T (setq splice x)))))
+ (t (setq splice x)))))
(deftransform fill ((seq item &key (start 0) (end (length seq)))
(vector t &key (:start t) (:end index))
;; on INFERIORS to find all the blocks.
(blocks nil :type (or null cblock)))
-(defprinter (cloop :conc-name LOOP-)
+(defprinter (cloop :conc-name loop-)
kind
head
tail
(move result number)
(move ecx amount)
(inst or ecx ecx)
- (inst jmp :ns positive)
+ (inst jmp :ns POSITIVE)
(inst neg ecx)
(inst cmp ecx 63)
- (inst jmp :be okay)
+ (inst jmp :be OKAY)
(inst mov ecx 63)
OKAY
(inst sar result :cl)
- (inst jmp done)
+ (inst jmp DONE)
POSITIVE
;; The result-type ensures us that this shift will not overflow.
(move result number)
(move ecx amount)
(inst or ecx ecx)
- (inst jmp :ns positive)
+ (inst jmp :ns POSITIVE)
(inst neg ecx)
(inst cmp ecx 63)
- (inst jmp :be okay)
+ (inst jmp :be OKAY)
(inst xor result result)
- (inst jmp done)
+ (inst jmp DONE)
OKAY
(inst shr result :cl)
- (inst jmp done)
+ (inst jmp DONE)
POSITIVE
;; The result-type ensures us that this shift will not overflow.
(move result number)
(move ecx amount)
(inst or ecx ecx)
- (inst jmp :ns positive)
+ (inst jmp :ns POSITIVE)
(inst neg ecx)
(inst xor zero zero)
(inst shr result :cl)
(inst cmp ecx 63)
(inst cmov :nbe result zero)
- (inst jmp done)
+ (inst jmp DONE)
POSITIVE
;; The result-type ensures us that this shift will not overflow.
(inst not res)
POS
(inst bsr res res)
- (inst jmp :z zero)
+ (inst jmp :z ZERO)
(inst inc res)
- (inst jmp done)
+ (inst jmp DONE)
ZERO
(inst xor res res)
DONE))
(:result-types unsigned-num)
(:generator 26
(inst bsr res arg)
- (inst jmp :z zero)
+ (inst jmp :z ZERO)
(inst inc res)
- (inst jmp done)
+ (inst jmp DONE)
ZERO
(inst xor res res)
DONE))
((sap-stack)
#+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
(tn-offset ret-tn))
- (inst lea return-label (make-fixup nil :code-object return))
+ (inst lea return-label (make-fixup nil :code-object RETURN))
(storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
((sap-reg)
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
#+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
(tn-offset ret-tn))
;; Stack
- (inst lea return-label (make-fixup nil :code-object return))
+ (inst lea return-label (make-fixup nil :code-object RETURN))
(storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
((sap-reg)
;; Register
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
#+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
(tn-offset ret-tn))
;; Stack
- (inst lea return-label (make-fixup nil :code-object return))
+ (inst lea return-label (make-fixup nil :code-object RETURN))
(storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
((sap-reg)
;; Register
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
(:generator 20
;; Avoid the copy if there are no more args.
(cond ((zerop fixed)
- (inst jecxz just-alloc-frame))
+ (inst jecxz JUST-ALLOC-FRAME))
(t
(inst cmp rcx-tn (fixnumize fixed))
- (inst jmp :be just-alloc-frame)))
+ (inst jmp :be JUST-ALLOC-FRAME)))
;; Allocate the space on the stack.
;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
;; Number to copy = nargs-3
(inst sub rcx-tn (fixnumize register-arg-count))
;; Everything of interest in registers.
- (inst jmp :be do-regs))
+ (inst jmp :be DO-REGS))
(t
;; Number to copy = nargs-fixed
(inst sub rcx-tn (fixnumize fixed))))
(if (zerop i)
(inst test rcx-tn rcx-tn)
(inst cmp rcx-tn (fixnumize i)))
- (inst jmp :eq done)))
+ (inst jmp :eq DONE)))
- (inst jmp done)
+ (inst jmp DONE)
JUST-ALLOC-FRAME
(inst lea rsp-tn
:disp (- (* simple-fun-code-offset n-word-bytes)
fun-pointer-lowtag)))
(inst cmp type simple-fun-header-widetag)
- (inst jmp :e normal-fn)
+ (inst jmp :e NORMAL-FUN)
(inst lea raw (make-fixup "closure_tramp" :foreign))
- NORMAL-FN
+ NORMAL-FUN
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result function)))
(:generator 0
(load-tl-symbol-value bsp *binding-stack-pointer*)
(inst cmp where bsp)
- (inst jmp :e done)
+ (inst jmp :e DONE)
LOOP
(loadw symbol bsp (- binding-symbol-slot binding-size))
(inst or symbol symbol)
- (inst jmp :z skip)
+ (inst jmp :z SKIP)
(loadw value bsp (- binding-value-slot binding-size))
#!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
SKIP
(inst sub bsp (* binding-size n-word-bytes))
(inst cmp where bsp)
- (inst jmp :ne loop)
+ (inst jmp :ne LOOP)
;; we're done with value, so can use it as a temporary
(store-tl-symbol-value bsp *binding-stack-pointer* value)
(defun allocation (alloc-tn size &optional ignored)
(declare (ignore ignored))
- (let ((not-inline (gen-label))
- (done (gen-label))
+ (let ((NOT-INLINE (gen-label))
+ (DONE (gen-label))
;; Yuck.
(in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
(free-pointer
(:generator 4
(move eax x)
(inst test al-tn 7) ; a symbolic constant for this
- (inst jmp :z fixnum) ; would be nice
+ (inst jmp :z FIXNUM) ; would be nice
(loadw y eax bignum-digits-offset other-pointer-lowtag)
- (inst jmp done)
+ (inst jmp DONE)
FIXNUM
(inst sar eax (1- n-lowtag-bits))
(move y eax)
(move num rcx)
(inst shr rcx word-shift) ; word count for <rep movs>
;; If we got zero, we be done.
- (inst jecxz done)
+ (inst jecxz DONE)
;; Copy them down.
(inst std)
(inst rep)
(inst xor count count)
;; If we are starting with NIL, then it's really easy.
(inst cmp ptr nil-value)
- (inst jmp :e done)
+ (inst jmp :e DONE)
;; Note: we don't have to test to see whether the original argument is a
;; list, because this is a :fast-safe vop.
LOOP
(inst add count (fixnumize 1))
;; If we hit NIL, then we are done.
(inst cmp ptr nil-value)
- (inst jmp :e done)
+ (inst jmp :e DONE)
;; Otherwise, check to see whether we hit the end of a dotted list. If
;; not, loop back for more.
(move eax ptr)
(inst and al-tn lowtag-mask)
(inst cmp al-tn list-pointer-lowtag)
- (inst jmp :e loop)
+ (inst jmp :e LOOP)
;; It's dotted all right. Flame out.
(error-call vop object-not-list-error ptr)
;; We be done.
(inst xor count count)
;; If we are starting with NIL, we be done.
(inst cmp ptr nil-value)
- (inst jmp :e done)
+ (inst jmp :e DONE)
;; Indirect the next cons cell, and boost the count.
LOOP
(loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst add count (fixnumize 1))
;; If we aren't done, go back for more.
(inst cmp ptr nil-value)
- (inst jmp :ne loop)
+ (inst jmp :ne LOOP)
DONE))
(define-static-fun length (object) :translate length)
(inst mov rax object)
(inst and al-tn lowtag-mask)
(inst cmp al-tn other-pointer-lowtag)
- (inst jmp :e other-ptr)
+ (inst jmp :e OTHER-PTR)
(inst cmp al-tn fun-pointer-lowtag)
- (inst jmp :e function-ptr)
+ (inst jmp :e FUNCTION-PTR)
;; Pick off structures and list pointers.
(inst test al-tn 1)
- (inst jmp :ne done)
+ (inst jmp :ne DONE)
;; Pick off fixnums.
(inst and al-tn 7)
- (inst jmp :e done)
+ (inst jmp :e DONE)
;; must be an other immediate
(inst mov rax object)
- (inst jmp done)
+ (inst jmp DONE)
FUNCTION-PTR
(load-type al-tn object (- fun-pointer-lowtag))
- (inst jmp done)
+ (inst jmp DONE)
OTHER-PTR
(load-type al-tn object (- other-pointer-lowtag))
;; (and (fixnum) (or (no bits set >31) (all bits set >31))
(move rax-tn value)
(inst test rax-tn 7)
- (inst jmp :ne (if not-p target not-target))
+ (inst jmp :ne (if not-p target NOT-TARGET))
(inst sar rax-tn (+ 32 3 -1))
(if not-p
(progn
- (inst jmp :nz maybe)
- (inst jmp not-target))
+ (inst jmp :nz MAYBE)
+ (inst jmp NOT-TARGET))
(inst jmp :z target))
MAYBE
(inst cmp rax-tn -1)
(inst jmp :z ok)
(inst cmp rax-tn -1)
(inst jmp :ne nope)
- (emit-label OK)
+ (emit-label ok)
(move result value))))
;; (and (fixnum) (no bits set >31))
(move rax-tn value)
(inst test rax-tn 7)
- (inst jmp :ne (if not-p target not-target))
+ (inst jmp :ne (if not-p target NOT-TARGET))
(inst shr rax-tn (+ 32 sb!vm::n-fixnum-tag-bits))
(inst jmp (if not-p :nz :z) target)
NOT-TARGET))
(define-vop (symbolp type-predicate)
(:translate symbolp)
(:generator 12
- (let ((is-symbol-label (if not-p drop-thru target)))
+ (let ((is-symbol-label (if not-p DROP-THRU target)))
(inst cmp value nil-value)
(inst jmp :e is-symbol-label)
(test-type value target not-p (symbol-header-widetag)))
(:generator 12
(let ((error (generate-error-code vop object-not-symbol-error value)))
(inst cmp value nil-value)
- (inst jmp :e drop-thru)
+ (inst jmp :e DROP-THRU)
(test-type value error t (symbol-header-widetag)))
DROP-THRU
(move result value)))
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
- (let ((is-not-cons-label (if not-p target drop-thru)))
+ (let ((is-not-cons-label (if not-p target DROP-THRU)))
(inst cmp value nil-value)
(inst jmp :e is-not-cons-label)
(test-type value target not-p (list-pointer-lowtag)))
(inst sub rsi n-word-bytes)
(inst sub rdi n-word-bytes)
(inst cmp rsp-tn rsi)
- (inst jmp :a done)
+ (inst jmp :a DONE)
(inst std)
LOOP
(inst movs :qword)
(inst cmp rsp-tn rsi)
- (inst jmp :be loop)
+ (inst jmp :be LOOP)
DONE
(inst lea rsp-tn (make-ea :qword :base rdi :disp n-word-bytes))
(inst sub rdi rsi)
LOOP
(inst cmp list nil-temp)
- (inst jmp :e done)
+ (inst jmp :e DONE)
(pushw list cons-car-slot list-pointer-lowtag)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(inst mov rax list)
(inst and al-tn lowtag-mask)
(inst cmp al-tn list-pointer-lowtag)
- (inst jmp :e loop)
+ (inst jmp :e LOOP)
(error-call vop bogus-arg-to-values-list-error list)
DONE
(move temp1 count)
(inst mov start rsp-tn)
- (inst jecxz done) ; check for 0 count?
+ (inst jecxz DONE) ; check for 0 count?
(inst shr temp1 word-shift) ; convert the fixnum to a count.
LOOP
(inst lods temp)
(inst push temp)
- (inst loop loop)
+ (inst loop LOOP)
DONE))
lisp_name, unix_number, unix_number);
}
-#define DEFERRNO(name) defconstant(#name, name)
-#define DEFSIGNAL(name) defconstant(#name, name)
+void deferrno(char* lisp_name, long unix_number)
+{
+ defconstant(lisp_name, unix_number);
+}
+
+void defsignal(char* lisp_name, long unix_number)
+{
+ defconstant(lisp_name, unix_number);
+}
int
main(int argc, char *argv[])
printf("\n");
printf(";;; error numbers\n");
- DEFERRNO(ENOENT);
- DEFERRNO(EINTR);
- DEFERRNO(EIO);
- DEFERRNO(EEXIST);
- DEFERRNO(ESPIPE);
- DEFERRNO(EWOULDBLOCK);
+ deferrno("enoent", ENOENT);
+ deferrno("eintr", EINTR);
+ deferrno("eio", EIO);
+ deferrno("eexist", EEXIST);
+ deferrno("espipe", ESPIPE);
+ deferrno("ewouldblock", EWOULDBLOCK);
printf("\n");
printf(";;; for wait3(2) in run-program.lisp\n");
printf("\n");
printf(";;; signals\n");
- DEFSIGNAL(SIGALRM);
- DEFSIGNAL(SIGBUS);
- DEFSIGNAL(SIGCHLD);
- DEFSIGNAL(SIGCONT);
+ defsignal("sigalrm", SIGALRM);
+ defsignal("sigbus", SIGBUS);
+ defsignal("sigchld", SIGCHLD);
+ defsignal("sigcont", SIGCONT);
#ifdef SIGEMT
- DEFSIGNAL(SIGEMT);
+ defsignal("sigemt", SIGEMT);
#endif
- DEFSIGNAL(SIGFPE);
- DEFSIGNAL(SIGHUP);
- DEFSIGNAL(SIGILL);
- DEFSIGNAL(SIGINT);
- DEFSIGNAL(SIGIO);
- DEFSIGNAL(SIGIOT);
- DEFSIGNAL(SIGKILL);
- DEFSIGNAL(SIGPIPE);
- DEFSIGNAL(SIGPROF);
- DEFSIGNAL(SIGQUIT);
- DEFSIGNAL(SIGSEGV);
+ defsignal("sigfpe", SIGFPE);
+ defsignal("sighup", SIGHUP);
+ defsignal("sigill", SIGILL);
+ defsignal("sigint", SIGINT);
+ defsignal("sigio", SIGIO);
+ defsignal("sigiot", SIGIOT);
+ defsignal("sigkill", SIGKILL);
+ defsignal("sigpipe", SIGPIPE);
+ defsignal("sigprof", SIGPROF);
+ defsignal("sigquit", SIGQUIT);
+ defsignal("sigsegv", SIGSEGV);
#if ((defined LISP_FEATURE_LINUX) && (defined LISP_FEATURE_X86))
- DEFSIGNAL(SIGSTKFLT);
+ defsignal("sigstkflt", SIGSTKFLT);
#endif
- DEFSIGNAL(SIGSTOP);
+ defsignal("sigstop", SIGSTOP);
#if (!((defined LISP_FEATURE_LINUX) && (defined LISP_FEATURE_X86)))
- DEFSIGNAL(SIGSYS);
+ defsignal("sigsys", SIGSYS);
#endif
- DEFSIGNAL(SIGTERM);
- DEFSIGNAL(SIGTRAP);
- DEFSIGNAL(SIGTSTP);
- DEFSIGNAL(SIGTTIN);
- DEFSIGNAL(SIGTTOU);
- DEFSIGNAL(SIGURG);
- DEFSIGNAL(SIGUSR1);
- DEFSIGNAL(SIGUSR2);
- DEFSIGNAL(SIGVTALRM);
+ defsignal("sigterm", SIGTERM);
+ defsignal("sigtrap", SIGTRAP);
+ defsignal("sigtstp", SIGTSTP);
+ defsignal("sigttin", SIGTTIN);
+ defsignal("sigttou", SIGTTOU);
+ defsignal("sigurg", SIGURG);
+ defsignal("sigusr1", SIGUSR1);
+ defsignal("sigusr2", SIGUSR2);
+ defsignal("sigvtalrm", SIGVTALRM);
#ifdef LISP_FEATURE_SUNOS
- DEFSIGNAL(SIGWAITING);
+ defsignal("sigwaiting", SIGWAITING);
#endif
- DEFSIGNAL(SIGWINCH);
+ defsignal("sigwinch", SIGWINCH);
#ifndef LISP_FEATURE_HPUX
- DEFSIGNAL(SIGXCPU);
- DEFSIGNAL(SIGXFSZ);
+ defsignal("sigxcpu", SIGXCPU);
+ defsignal("sigxfsz", SIGXFSZ);
#endif
return 0;
}
;;; 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.9.0.5"
+"0.9.0.6"
projects / sbcl.git / commitdiff