DO-FOO should be used for iteration names, not other things...
...s/do-assembly/emit-assembly-code-not-vops-p/
...s/do-truncate/return-quotient-leaving-remainder/
...s/do-constant-bit-bash/constant-bit-bash/
...s/do-unary-bit-bash/unary-bit-bash/
...s/do-do-body/frob-do-body/
...s/do-dd-inclusion-stuff/frob-dd-inclusion-stuff/
...s/do-output/frob-output/
...s/do-input/frob-input/
...s/do-old-rename/rename-the-old-one/
...s/do-load-verbose/maybe-announce-load/
...s/do-nothing/no-op-placeholder/
...s/do-pending-interrupt/receive-pending-interrupt/
...s/do-load-time-code-fixup/envector-load-time-code-fixup/
...s/do-type-warning/emit-type-warning/
...s/do-the-stuff/ir1ize-the-or-values/
...I'm not sure enough about behavior of VOP names to mess with
DO-MAKE-VALUE-CELL immediately, but at least I can
rename the MAKE-VALUE-CELL event to MAKE-VALUE-CELL-EVENT
to start to untangle the names here.
...s/do-save-p-stuff/conflictize-save-p-vop/
...s/do-coerce-efficiency-note/maybe-emit-coerce-efficiency-note/
...s/do-offs-hooks/call-offs-hooks/
...s/do-fun-hooks/call-fun-hooks/
...s/do-short-method-combination/short-combine-methods/
...s/do-tests/run-tests/
fixed dumb oversight in debug.impure.lisp
(DO ((CURRENT L #) (# NIL)) (WHEN (EQ # E) (RETURN CURRENT)) )
caught ERROR: (during macroexpansion)
-error in function LISP::DO-DO-BODY:
+error in function LISP::FROB-DO-BODY:
DO step variable is not a symbol: (ATOM CURRENT)</screen>
</para>
"DEALLOCATE-SYSTEM-MEMORY"
"DEFAULT-INTERRUPT"
"DEPORT-BOOLEAN" "DEPORT-INTEGER"
- "DO-DO-BODY" "DOUBLE-FLOAT-RADIX"
+ "FROB-DO-BODY" "DOUBLE-FLOAT-RADIX"
"ENABLE-INTERRUPT" "ENUMERATION"
"FD-STREAM" "FD-STREAM-FD"
"FD-STREAM-P"
(in-package "SB!C")
\f
;;; If non-NIL, emit assembly code. If NIL, emit VOP templates.
-(defvar *do-assembly* nil)
+(defvar *emit-assembly-code-not-vops-p* nil)
;;; a list of (NAME . LABEL) for every entry point
(defvar *entry-points* nil)
(output-file (make-pathname :defaults name
:type "assem")))
;; FIXME: Consider nuking the filename defaulting logic here.
- (let* ((*do-assembly* t)
+ (let* ((*emit-assembly-code-not-vops-p* t)
(name (pathname name))
;; the fasl file currently being output to
(lap-fasl-output (open-fasl-output (pathname output-file) name))
(values (car name&options)
(cdr name&options)))
(let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars)))
- (if *do-assembly*
+ (if *emit-assembly-code-not-vops-p*
(emit-assemble name options regs code)
(emit-vop name options regs)))))
(sout #'ill-out :type function) ; string output function
;; other, less-used methods
- (misc #'do-nothing :type function))
+ (misc #'no-op-placeholder :type function))
(def!method print-object ((x ansi-stream) stream)
(print-unreadable-object (x stream :type t :identity t)))
(defvar *truncate-x*)
(defvar *truncate-y*)
-;;; This divides x by y returning the quotient and remainder. In the general
-;;; case, we shift y to setup for the algorithm, and we use two buffers to save
-;;; consing intermediate values. X gets destructively modified to become the
-;;; remainder, and we have to shift it to account for the initial Y shift.
-;;; After we multiple bind q and r, we first fix up the signs and then return
-;;; the normalized results.
+;;; Divide X by Y returning the quotient and remainder. In the
+;;; general case, we shift Y to set up for the algorithm, and we use
+;;; two buffers to save consing intermediate values. X gets
+;;; destructively modified to become the remainder, and we have to
+;;; shift it to account for the initial Y shift. After we multiple
+;;; bind q and r, we first fix up the signs and then return the
+;;; normalized results.
(defun bignum-truncate (x y)
(declare (type bignum-type x y))
(let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x)))
(*truncate-y* (1+ len-y)))
(let ((y-shift (shift-y-for-truncate y)))
(shift-and-store-truncate-buffers x len-x y len-y y-shift)
- (values (do-truncate len-x+1 len-y)
- ;; DO-TRUNCATE must execute first.
+ (values (return-quotient-leaving-remainder len-x+1 len-y)
+ ;; Now that RETURN-QUOTIENT-LEAVING-REMAINDER
+ ;; has executed, we just tidy up the remainder
+ ;; (in *TRUNCATE-X*) and return it.
(cond
((zerop y-shift)
(let ((res (%allocate-bignum len-y)))
rem
(%normalize-bignum rem (%bignum-length rem))))))))
-;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes
-;;; up the quotient and remainder with respect to sign and normalization.
+;;; Divide X by Y when Y is a single bignum digit. BIGNUM-TRUNCATE
+;;; fixes up the quotient and remainder with respect to sign and
+;;; normalization.
;;;
-;;; We don't have to worry about shifting y to make its most significant digit
-;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit
-;;; and r-digit. If y is a single digit bignum, it is already large enough
-;;; for %FLOOR. That is, it has some bits on pretty high in the digit.
+;;; We don't have to worry about shifting Y to make its most
+;;; significant digit sufficiently large for %FLOOR to return 32-bit
+;;; quantities for the q-digit and r-digit. If Y is a single digit
+;;; bignum, it is already large enough for %FLOOR. That is, it has
+;;; some bits on pretty high in the digit.
(defun bignum-truncate-single-digit (x len-x y)
(declare (type bignum-index len-x))
(let ((q (%allocate-bignum len-x))
(setf (%bignum-ref rem 0) r)
(values q rem))))
-;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how
-;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies
-;;; *truncate-x* on each interation, and this buffer becomes our remainder.
+;;; a helper function for BIGNUM-TRUNCATE
;;;
-;;; *truncate-x* definitely has at least three digits, and it has one more than
-;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to
-;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS.
-(defun do-truncate (len-x len-y)
+;;; Divide *TRUNCATE-X* by *TRUNCATE-Y*, returning the quotient
+;;; and destructively modifying *TRUNCATE-X* so that it holds
+;;; the remainder.
+;;;
+;;; LEN-X and LEN-Y tell us how much of the buffers we care about.
+;;;
+;;; *TRUNCATE-X* definitely has at least three digits, and it has one
+;;; more than *TRUNCATE-Y*. This keeps i, i-1, i-2, and low-x-digit
+;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS.
+(defun return-quotient-leaving-remainder (len-x len-y)
(declare (type bignum-index len-x len-y))
(let* ((len-q (- len-x len-y))
;; Add one for extra sign digit in case high bit is on.
(loop
(setf (%bignum-ref q k)
(try-bignum-truncate-guess
- ;; This modifies *truncate-x*. Must access elements each pass.
+ ;; This modifies *TRUNCATE-X*. Must access elements each pass.
(bignum-truncate-guess y1 y2
(%bignum-ref *truncate-x* i)
(%bignum-ref *truncate-x* i-1)
(shiftf i i-1 i-2 (1- i-2)))))
q))
-;;; This takes a digit guess, multiplies it by *truncate-y* for a result one
-;;; greater in length than len-y, and subtracts this result from *truncate-x*.
-;;; Low-x-digit is the first digit of x to start the subtraction, and we know x
-;;; is long enough to subtract a len-y plus one length bignum from it. Next we
-;;; check the result of the subtraction, and if the high digit in x became
-;;; negative, then our guess was one too big. In this case, return one less
-;;; than guess passed in, and add one value of y back into x to account for
-;;; subtracting one too many. Knuth shows that the guess is wrong on the order
-;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely.
+;;; This takes a digit guess, multiplies it by *TRUNCATE-Y* for a
+;;; result one greater in length than LEN-Y, and subtracts this result
+;;; from *TRUNCATE-X*. LOW-X-DIGIT is the first digit of X to start
+;;; the subtraction, and we know X is long enough to subtract a LEN-Y
+;;; plus one length bignum from it. Next we check the result of the
+;;; subtraction, and if the high digit in X became negative, then our
+;;; guess was one too big. In this case, return one less than GUESS
+;;; passed in, and add one value of Y back into X to account for
+;;; subtracting one too many. Knuth shows that the guess is wrong on
+;;; the order of 3/b, where b is the base (2 to the digit-size power)
+;;; -- pretty rarely.
(defun try-bignum-truncate-guess (guess len-y low-x-digit)
(declare (type bignum-index low-x-digit len-y)
(type bignum-element-type guess))
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setf (sap-ref-32 sap (the index (ash offset 2))) value))
\f
-;;;; DO-CONSTANT-BIT-BASH
+;;;; CONSTANT-BIT-BASH
;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
;;; LENGTH bits.
-#!-sb-fluid (declaim (inline do-constant-bit-bash))
-(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
+#!-sb-fluid (declaim (inline constant-bit-bash))
+(defun constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
(declare (type offset dst-offset) (type unit value)
(type function dst-ref-fn dst-set-fn))
(multiple-value-bind (dst-word-offset dst-bit-offset)
mask)))))))))
(values))
\f
-;;;; DO-UNARY-BIT-BASH
+;;;; UNARY-BIT-BASH
-#!-sb-fluid (declaim (inline do-unary-bit-bash))
-(defun do-unary-bit-bash (src src-offset dst dst-offset length
- dst-ref-fn dst-set-fn src-ref-fn)
+#!-sb-fluid (declaim (inline unary-bit-bash))
+(defun unary-bit-bash (src src-offset dst dst-offset length
+ dst-ref-fn dst-set-fn src-ref-fn)
;; FIXME: Declaring these bit indices to be of type OFFSET, then
;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not
;; a good thing. At the very least, we should make sure that the
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
- (do-constant-bit-bash dst dst-offset length value
- #'%raw-bits #'%set-raw-bits)))
+ (constant-bit-bash dst dst-offset length value
+ #'%raw-bits #'%set-raw-bits)))
(defun system-area-fill (value dst dst-offset length)
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
- (do-constant-bit-bash dst dst-offset length value
- #'word-sap-ref #'%set-word-sap-ref))))
+ (constant-bit-bash dst dst-offset length value
+ #'word-sap-ref #'%set-word-sap-ref))))
(defun bit-bash-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0))
- (inline do-unary-bit-bash))
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'%raw-bits #'%set-raw-bits #'%raw-bits)))
+ (inline unary-bit-bash))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'%raw-bits)))
(defun system-area-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(declare (type system-area-pointer src))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
(declare (type system-area-pointer dst))
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'word-sap-ref #'%set-word-sap-ref
- #'word-sap-ref)))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref
+ #'word-sap-ref)))))
(defun copy-to-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
(defun copy-from-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
;;; a common idiom for calling COPY-TO-SYSTEM-AREA
;;;
(svref *!load-time-values* (third toplevel-thing)))))
#!+(and x86 gencgc)
(:load-time-code-fixup
- (sb!vm::!do-load-time-code-fixup (second toplevel-thing)
- (third toplevel-thing)
- (fourth toplevel-thing)
- (fifth toplevel-thing)))
+ (sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
+ (third toplevel-thing)
+ (fourth toplevel-thing)
+ (fifth toplevel-thing)))
(t
(!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
(t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
\f
;;;; iteration constructs
-;;; (These macros are defined in terms of a function DO-DO-BODY which
+;;; (These macros are defined in terms of a function FROB-DO-BODY which
;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not
;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS
-;;; and DO-DO-BODY should be, these macros can't conveniently be in
-;;; the same file as DO-DO-BODY.)
+;;; and FROB-DO-BODY should be, these macros can't conveniently be in
+;;; the same file as FROB-DO-BODY.)
(defmacro-mundanely do (varlist endlist &body body)
#!+sb-doc
"DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
are evaluated as a PROGN, with the result being the value of the DO. A block
named NIL is established around the entire expansion, allowing RETURN to be
used as an alternate exit mechanism."
- (do-do-body varlist endlist body 'let 'psetq 'do nil))
+ (frob-do-body varlist endlist body 'let 'psetq 'do nil))
(defmacro-mundanely do* (varlist endlist &body body)
#!+sb-doc
"DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
the Exit-Forms are evaluated as a PROGN, with the result being the value
of the DO. A block named NIL is established around the entire expansion,
allowing RETURN to be used as an laternate exit mechanism."
- (do-do-body varlist endlist body 'let* 'setq 'do* nil))
+ (frob-do-body varlist endlist body 'let* 'setq 'do* nil))
;;; DOTIMES and DOLIST could be defined more concisely using
;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then
(when offset (incf (dd-length dd) offset)))))
(when (dd-include dd)
- (do-dd-inclusion-stuff dd))
+ (frob-dd-inclusion-stuff dd))
dd)))
;;; Process any included slots pretty much like they were specified.
;;; Also inherit various other attributes.
-(defun do-dd-inclusion-stuff (dd)
+(defun frob-dd-inclusion-stuff (dd)
(destructuring-bind (included-name &rest modified-slots) (dd-include dd)
(let* ((type (dd-type dd))
(included-structure
;;; descriptor. Attempt to write the data again. If it worked, remove
;;; the data from the OUTPUT-LATER list. If it didn't work, something
;;; is wrong.
-(defun do-output-later (stream)
+(defun frob-output-later (stream)
(let* ((stuff (pop (fd-stream-output-later stream)))
(base (car stuff))
(start (cadr stuff))
:output
(lambda (fd)
(declare (ignore fd))
- (do-output-later stream)))))
+ (frob-output-later stream)))))
(t
(nconc (fd-stream-output-later stream)
(list (list base start end reuse-sap)))))
;;; Output the given noise. Check to see whether there are any pending
;;; writes. If so, just queue this one. Otherwise, try to write it. If
;;; this would block, queue it.
-(defun do-output (stream base start end reuse-sap)
+(defun frob-output (stream base start end reuse-sap)
(declare (type fd-stream stream)
(type (or system-area-pointer (simple-array * (*))) base)
(type index start end))
(defun flush-output-buffer (stream)
(let ((length (fd-stream-obuf-tail stream)))
(unless (= length 0)
- (do-output stream (fd-stream-obuf-sap stream) 0 length t)
+ (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
(setf (fd-stream-obuf-tail stream) 0))))
;;; Define output routines that output numbers SIZE bytes long for the
(setf (fd-stream-obuf-tail fd-stream) bytes))
(t
(flush-output-buffer fd-stream)
- (do-output fd-stream thing start end nil))))))
+ (frob-output fd-stream thing start end nil))))))
;;; the routine to use to output a string. If the stream is
;;; unbuffered, slam the string down the file descriptor, otherwise
(when last-newline
(flush-output-buffer stream)))
(:none
- (do-output stream thing start end nil)))
+ (frob-output stream thing start end nil)))
(if last-newline
(setf (fd-stream-char-pos stream)
(- end last-newline 1))
((:line :full)
(output-raw-bytes stream thing start end))
(:none
- (do-output stream thing start end nil))))))
+ (frob-output stream thing start end nil))))))
;;; Find an output routine to use given the type and buffering. Return
;;; as multiple values the routine, the real type transfered, and the
;;; Fill the input buffer, and return the first character. Throw to
;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
;;; if necessary.
-(defun do-input (stream)
+(defun frob-input (stream)
(let ((fd (fd-stream-fd stream))
(ibuf-sap (fd-stream-ibuf-sap stream))
(buflen (fd-stream-ibuf-length stream))
#!+mp (sb!mp:process-wait-until-fd-usable
fd :input (fd-stream-timeout stream))
(error 'io-timeout :stream stream :direction :read))
- (do-input stream))
+ (frob-input stream))
(simple-stream-perror "couldn't read from ~S" stream errno)))
((zerop count)
(setf (fd-stream-listen stream) :eof)
(incf (fd-stream-ibuf-tail stream) count))))))
;;; Make sure there are at least BYTES number of bytes in the input
-;;; buffer. Keep calling DO-INPUT until that condition is met.
+;;; buffer. Keep calling FROB-INPUT until that condition is met.
(defmacro input-at-least (stream bytes)
(let ((stream-var (gensym))
(bytes-var (gensym)))
(fd-stream-ibuf-head ,stream-var))
,bytes-var)
(return))
- (do-input ,stream-var)))))
+ (frob-input ,stream-var)))))
;;; a macro to wrap around all input routines to handle EOF-ERROR noise
(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
0
0))))
(cond ((eql count 1)
- (do-input fd-stream)
+ (frob-input fd-stream)
(setf (fd-stream-ibuf-head fd-stream) 0)
(setf (fd-stream-ibuf-tail fd-stream) 0))
(t
;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
;;; access, since we don't want to trash unwritable files even if we
;;; technically can. We return true if we succeed in renaming.
-(defun do-old-rename (namestring original)
+(defun rename-the-old-one (namestring original)
(unless (sb!unix:unix-access namestring sb!unix:w_ok)
(error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
(multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
namestring
err/dev)))))))
(unless (and exists
- (do-old-rename namestring original))
+ (rename-the-old-one namestring original))
(setf original nil)
(setf delete-original nil)
;; In order to use :SUPERSEDE instead, we have to make
(write-string semicolons))
(write-char #\space)))
-;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how we're
-;;; loading from STREAM-WE-ARE-LOADING-FROM.
-;;; FIXME: non-mnemonic name
-(defun do-load-verbose (stream-we-are-loading-from verbose)
+;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how
+;;; we're loading from STREAM-WE-ARE-LOADING-FROM.
+(defun maybe-announce-load (stream-we-are-loading-from verbose)
(when verbose
(load-fresh-line)
(let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
(declare (ignore print))
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
- (do-load-verbose stream verbose)
+ (maybe-announce-load stream verbose)
(let* ((*fasl-input-stream* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
(*current-fop-table-size* (length *current-fop-table*))
;;;; DO-related stuff which needs to be visible on the cross-compilation host
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun do-do-body (varlist endlist decls-and-code bind step name block)
+ (defun frob-do-body (varlist endlist decls-and-code bind step name block)
(let* ((r-inits nil) ; accumulator for reversed list
(r-steps nil) ; accumulator for reversed list
(label-1 (gensym))
;;; EXIT-FORMS are evaluated as a PROGN, with the result being the
;;; value of the DO.
(defmacro do-anonymous (varlist endlist &rest body)
- (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
+ (frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
\f
;;;; miscellany
;;; sets *interrupt-pending* and returns without handling the signal.
;;;
;;; When we drop out the without interrupts, we check to see whether
-;;; *interrupt-pending* has been set. If so, we call
-;;; do-pending-interrupt, which generates a SIGTRAP. The C code
+;;; *INTERRUPT-PENDING* has been set. If so, we call
+;;; RECEIVE-PENDING-INTERRUPT, which generates a SIGTRAP. The C code
;;; invokes the handler for the saved signal instead of the SIGTRAP
;;; after replacing the signal mask in the signal context with the
;;; saved value. When that hander returns, the original signal mask is
;; whether interrupts are pending before executing themselves
;; immediately?
(when *interrupt-pending*
- (do-pending-interrupt)))
+ (receive-pending-interrupt)))
(,name)))))
(sb!xc:defmacro with-interrupts (&body body)
(,name)
(let ((*interrupts-enabled* t))
(when *interrupt-pending*
- (do-pending-interrupt))
+ (receive-pending-interrupt))
(,name))))))
\f
;;;; utilities for dealing with signal names and numbers
(defun closed-flame (stream &rest ignore)
(declare (ignore ignore))
(error "~S is closed." stream))
-(defun do-nothing (&rest ignore)
+(defun no-op-placeholder (&rest ignore)
(declare (ignore ignore)))
\f
;;; stream manipulation functions
;;; Load a text file.
(defun load-as-source (stream verbose print)
- (do-load-verbose stream verbose)
+ (maybe-announce-load stream verbose)
(do ((sexpr (read stream nil *eof-object*)
(read stream nil *eof-object*)))
((eq sexpr *eof-object*)
;;; CMU CL comment:
;;; Magically converted by the compiler into a break instruction.
-(defun do-pending-interrupt ()
- (do-pending-interrupt))
+(defun receive-pending-interrupt ()
+ (receive-pending-interrupt))
\f
;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
#|
(setf (signed-sap-ref-32 sap offset) rel-val))))))
nil))
-;;; Add a code fixup to a code object generated by GENESIS. The fixup has
-;;; already been applied, it's just a matter of placing the fixup in the code's
-;;; fixup vector if necessary.
+;;; Add a code fixup to a code object generated by GENESIS. The fixup
+;;; has already been applied, it's just a matter of placing the fixup
+;;; in the code's fixup vector if necessary.
;;;
;;; KLUDGE: I'd like a good explanation of why this has to be done at
;;; load time instead of in GENESIS. It's probably simple, I just haven't
;;; figured it out, or found it written down anywhere. -- WHN 19990908
#!+gencgc
-(defun !do-load-time-code-fixup (code offset fixup kind)
- (flet ((add-load-time-code-fixup (code offset)
+(defun !envector-load-time-code-fixup (code offset fixup kind)
+ (flet ((frob (code offset)
(let ((fixups (code-header-ref code code-constants-offset)))
(cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
(let ((new-fixups
(:absolute
;; Record absolute fixups that point within the code object.
(when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
- (add-load-time-code-fixup code offset)))
+ (frob code offset)))
(:relative
;; Record relative fixups that point outside the code object.
(when (or (< fixup obj-start-addr) (> fixup code-end-addr))
- (add-load-time-code-fixup code offset)))))))
+ (frob code offset)))))))
\f
;;;; low-level signal context access functions
;;;;
\f
;;;; other random VOPs.
-(defknown sb!unix::do-pending-interrupt () (values))
-(define-vop (sb!unix::do-pending-interrupt)
+(defknown sb!unix::receive-pending-interrupt () (values))
+(define-vop (sb!unix::receive-pending-interrupt)
(:policy :fast-safe)
- (:translate sb!unix::do-pending-interrupt)
+ (:translate sb!unix::receive-pending-interrupt)
(:generator 1
(inst gentrap pending-interrupt-trap)))
;;; context. If the value is a constant, we print it specially. We
;;; ignore nodes whose type is NIL, since they are supposed to never
;;; return.
-(defun do-type-warning (node)
+(defun emit-type-warning (node)
(declare (type node node))
(let* ((*compiler-error-context* node)
(cont (node-cont node))
(node-derived-type use) atype)
(mark-error-continuation cont)
(unless (policy node (= inhibit-warnings 3))
- (do-type-warning use))))))
+ (emit-type-warning use))))))
(when (eq type-check t)
(cond ((probable-type-check-p cont)
(conts cont))
;;; We make this work by getting USE-CONTINUATION to do the unioning
;;; across COND branches. We can't do it here, since we don't know how
;;; many branches there are going to be.
-(defun do-the-stuff (type cont lexenv name)
+(defun ir1ize-the-or-values (type cont lexenv name)
(declare (type continuation cont) (type lexenv lexenv))
(let* ((ctype (values-specifier-type type))
(old-type (or (lexenv-find cont type-restrictions)
;;; this didn't seem to expand into an assertion, at least for ALIEN
;;; values. Check that SBCL doesn't have this problem.
(def-ir1-translator the ((type value) start cont)
- (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
+ (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the)))
(ir1-convert start cont value)))
;;; This is like the THE special form, except that it believes
(if *suppress-values-declaration*
res
(let ((types (cdr spec)))
- (do-the-stuff (if (eql (length types) 1)
- (car types)
- `(values ,@types))
- cont res 'values))))
+ (ir1ize-the-or-values (if (eql (length types) 1)
+ (car types)
+ `(values ,@types))
+ cont
+ res
+ 'values))))
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
(compiler-note
;;; Allocate an indirect value cell. Maybe do some clever stack
;;; allocation someday.
-(defevent make-value-cell "Allocate heap value cell for lexical var.")
+;;;
+;;; FIXME: DO-MAKE-VALUE-CELL is a bad name, since it doesn't make
+;;; clear what's the distinction between it and the MAKE-VALUE-CELL
+;;; VOP, and since the DO- further connotes iteration, which has
+;;; nothing to do with this. Clearer, more systematic names, anyone?
+(defevent make-value-cell-event "Allocate heap value cell for lexical var.")
(defun do-make-value-cell (node block value res)
- (event make-value-cell node)
+ (event make-value-cell-event node)
(vop make-value-cell node block value res))
\f
;;;; leaf reference
(make-debug-environment-tns-live block live-bits live-list)))
-;;; A function called in Conflict-Analyze-1-Block when we have a VOP with
-;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all
-;;; the live TNs to be stack environment TNs.
-(defun do-save-p-stuff (vop block live-bits)
+;;; A function called in CONFLICT-ANALYZE-1-BLOCK when we have a VOP
+;;; with SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK,
+;;; force all the live TNs to be stack environment TNs.
+(defun conflictize-save-p-vop (vop block live-bits)
(declare (type vop vop) (type ir2-block block)
(type local-tn-bit-vector live-bits))
(let ((ss (compute-save-set vop live-bits)))
(vop-prev vop)))
((null vop))
(when (vop-info-save-p (vop-info vop))
- (do-save-p-stuff vop block live-bits))
+ (conflictize-save-p-vop vop block live-bits))
(ensure-results-live)
(scan-vop-refs)))))
;;; If policy indicates, give an efficiency note for doing the
;;; coercion VOP, where OP is the operand we are coercing for and
;;; DEST-TN is the distinct destination in a move.
-(defun do-coerce-efficiency-note (vop op dest-tn)
+(defun maybe-emit-coerce-efficiency-note (vop op dest-tn)
(declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
(let* ((note (or (template-note vop) (template-name vop)))
(cost (template-cost vop))
(when res
(when (>= (vop-info-cost res)
*efficiency-note-cost-threshold*)
- (do-coerce-efficiency-note res op dest-tn))
+ (maybe-emit-coerce-efficiency-note res op dest-tn))
(let ((temp (make-representation-tn ptype scn)))
(change-tn-ref-tn op temp)
(cond
(res
(when (>= (vop-info-cost res)
*efficiency-note-cost-threshold*)
- (do-coerce-efficiency-note res args y))
+ (maybe-emit-coerce-efficiency-note res args y))
(emit-move-template node block res x y vop)
(delete-vop vop))
(t
(setf (dstate-cur-offs dstate) 0)
(setf (dstate-cur-labels dstate) (dstate-labels dstate)))
-(defun do-offs-hooks (before-address stream dstate)
+(defun call-offs-hooks (before-address stream dstate)
(declare (type (or null stream) stream)
(type disassem-state dstate))
(let ((cur-offs (dstate-cur-offs dstate)))
(unless (= (dstate-next-offs dstate) cur-offs)
(return)))))))
-(defun do-fun-hooks (chunk stream dstate)
+(defun call-fun-hooks (chunk stream dstate)
(let ((hooks (dstate-fun-hooks dstate))
(cur-offs (dstate-cur-offs dstate)))
(setf (dstate-next-offs dstate) cur-offs)
(setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
- (do-offs-hooks t stream dstate)
+ (call-offs-hooks t stream dstate)
(unless (or prefix-p (null stream))
(print-current-address stream dstate))
- (do-offs-hooks nil stream dstate)
+ (call-offs-hooks nil stream dstate)
(unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
(sb!sys:without-gcing
(sap-ref-dchunk (dstate-segment-sap dstate)
(dstate-cur-offs dstate)
(dstate-byte-order dstate))))
- (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
+ (let ((fun-prefix-p (call-fun-hooks chunk stream dstate)))
(if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
(setf prefix-p fun-prefix-p)
(let ((inst (find-inst chunk ispace)))
\f
;;;; other miscellaneous VOPs
-(defknown sb!unix::do-pending-interrupt () (values))
-(define-vop (sb!unix::do-pending-interrupt)
+(defknown sb!unix::receive-pending-interrupt () (values))
+(define-vop (sb!unix::receive-pending-interrupt)
(:policy :fast-safe)
- (:translate sb!unix::do-pending-interrupt)
+ (:translate sb!unix::receive-pending-interrupt)
(:generator 1
(inst break pending-interrupt-trap)))
(apply
(lambda (gf type options)
(declare (ignore gf))
- (do-short-method-combination
+ (short-combine-methods
type options operator ioa new-method doc))
args))
:definition-source `((define-method-combination ,type) ,truename)))
(remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)))
-(defun do-short-method-combination (type options operator ioa method doc)
+(defun short-combine-methods (type options operator ioa method doc)
(cond ((null options) (setq options '(:most-specific-first)))
((equal options '(:most-specific-first)))
((equal options '(:most-specific-last)))
(lambda () (slot-value object 'function)))
||#
-(defun do-tests ()
+(defun run-tests ()
(dolist (doc+form (reverse *tests*))
(format t "~&~%~A~%" (car doc+form))
(pprint (cdr doc+form))
(assert (symbolp control-sym))
(assert (eql &rest-sym '&rest))
(assert (symbolp format-args-sym)))
+
+;;; success
+(quit :unix-status 104)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.133"
+"0.pre7.135"
projects / sbcl.git / commitdiff