From 08307967c71c580058a503d46aa087cfefcf8c69 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 15 Jan 2002 23:53:50 +0000 Subject: [PATCH] 0.pre7.135: 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 --- doc/compiler.sgml | 2 +- package-data-list.lisp-expr | 2 +- src/assembly/assemfile.lisp | 6 +-- src/code/ansi-stream.lisp | 2 +- src/code/bignum.lisp | 73 ++++++++++++++++++++--------------- src/code/bit-bash.lisp | 42 ++++++++++---------- src/code/cold-init.lisp | 8 ++-- src/code/defboot.lisp | 10 ++--- src/code/defstruct.lisp | 4 +- src/code/fd-stream.lisp | 28 +++++++------- src/code/load.lisp | 9 ++--- src/code/primordial-extensions.lisp | 4 +- src/code/signal.lisp | 8 ++-- src/code/stream.lisp | 2 +- src/code/target-load.lisp | 2 +- src/code/target-signal.lisp | 4 +- src/code/x86-vm.lisp | 14 +++---- src/compiler/alpha/system.lisp | 6 +-- src/compiler/checkgen.lisp | 4 +- src/compiler/ir1-translators.lisp | 4 +- src/compiler/ir1tran.lisp | 10 +++-- src/compiler/ir2tran.lisp | 9 ++++- src/compiler/life.lisp | 10 ++--- src/compiler/represent.lisp | 6 +-- src/compiler/target-disassem.lisp | 10 ++--- src/compiler/x86/system.lisp | 6 +-- src/pcl/defcombin.lisp | 4 +- src/pcl/time.lisp | 2 +- tests/debug.impure.lisp | 3 ++ version.lisp-expr | 2 +- 30 files changed, 158 insertions(+), 138 deletions(-) diff --git a/doc/compiler.sgml b/doc/compiler.sgml index a72bc1a..39468a6 100644 --- a/doc/compiler.sgml +++ b/doc/compiler.sgml @@ -276,7 +276,7 @@ gives this error: (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) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c2b2403..6f88fc2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1474,7 +1474,7 @@ SB-KERNEL) have been undone, but probably more remain." "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" diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index 10fe4d8..dd2cabf 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -13,7 +13,7 @@ (in-package "SB!C") ;;; 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) @@ -31,7 +31,7 @@ (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)) @@ -191,6 +191,6 @@ (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))))) diff --git a/src/code/ansi-stream.lisp b/src/code/ansi-stream.lisp index 819cd89..dc728e0 100644 --- a/src/code/ansi-stream.lisp +++ b/src/code/ansi-stream.lisp @@ -113,7 +113,7 @@ (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))) diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index 4dc565f..9fd5085 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -1702,12 +1702,13 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (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))) @@ -1730,8 +1731,10 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (*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))) @@ -1760,13 +1763,15 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! 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)) @@ -1783,14 +1788,18 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (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. @@ -1807,7 +1816,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (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) @@ -1819,15 +1828,17 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (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)) diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 1933baf..68865a9 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -128,12 +128,12 @@ (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (setf (sap-ref-32 sap (the index (ash offset 2))) value)) -;;;; 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) @@ -181,11 +181,11 @@ mask))))))))) (values)) -;;;; 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 @@ -448,24 +448,24 @@ (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)) @@ -475,25 +475,25 @@ (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 ;;; diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 2390630..e6d99a1 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -178,10 +178,10 @@ (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*"))))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index b11c1d2..a816b28 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -283,11 +283,11 @@ ;;;; 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* @@ -298,7 +298,7 @@ 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* @@ -309,7 +309,7 @@ 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 diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index d3fc916..d06c839 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -515,7 +515,7 @@ (when offset (incf (dd-length dd) offset))))) (when (dd-include dd) - (do-dd-inclusion-stuff dd)) + (frob-dd-inclusion-stuff dd)) dd))) @@ -676,7 +676,7 @@ ;;; 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 diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 105ee6f..2e461b7 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -117,7 +117,7 @@ ;;; 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)) @@ -156,7 +156,7 @@ :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))))) @@ -168,7 +168,7 @@ ;;; 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)) @@ -194,7 +194,7 @@ (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 @@ -350,7 +350,7 @@ (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 @@ -381,7 +381,7 @@ (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)) @@ -391,7 +391,7 @@ ((: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 @@ -414,7 +414,7 @@ ;;; 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)) @@ -475,7 +475,7 @@ #!+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) @@ -485,7 +485,7 @@ (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))) @@ -496,7 +496,7 @@ (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) @@ -833,7 +833,7 @@ 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 @@ -1030,7 +1030,7 @@ ;;; 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 "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) @@ -1157,7 +1157,7 @@ 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 diff --git a/src/code/load.lisp b/src/code/load.lisp index 75cfec5..cea8927 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -30,10 +30,9 @@ (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) @@ -327,7 +326,7 @@ (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*)) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index db95431..b496278 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -68,7 +68,7 @@ ;;;; 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)) @@ -129,7 +129,7 @@ ;;; 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))) ;;;; miscellany diff --git a/src/code/signal.lisp b/src/code/signal.lisp index 14a8cf0..4205bf1 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -23,8 +23,8 @@ ;;; 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 @@ -55,7 +55,7 @@ ;; 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) @@ -68,7 +68,7 @@ (,name) (let ((*interrupts-enabled* t)) (when *interrupt-pending* - (do-pending-interrupt)) + (receive-pending-interrupt)) (,name)))))) ;;;; utilities for dealing with signal names and numbers diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 19cde5e..cba489e 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -58,7 +58,7 @@ (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))) ;;; stream manipulation functions diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 0c8e9b6..88196b3 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -29,7 +29,7 @@ ;;; 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*) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 15f14be..1ae74ff 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -142,8 +142,8 @@ ;;; 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)) ;;; stale code which I'm insufficiently motivated to test -- WHN 19990714 #| diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index d0e88ad..affa75b 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -119,16 +119,16 @@ (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 @@ -160,11 +160,11 @@ (: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))))))) ;;;; low-level signal context access functions ;;;; diff --git a/src/compiler/alpha/system.lisp b/src/compiler/alpha/system.lisp index f6d3305..eb9aa9a 100644 --- a/src/compiler/alpha/system.lisp +++ b/src/compiler/alpha/system.lisp @@ -215,10 +215,10 @@ ;;;; 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))) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index fa280ab..237906a 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -404,7 +404,7 @@ ;;; 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)) @@ -491,7 +491,7 @@ (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)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 971550f..f1fc71b 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -720,7 +720,7 @@ ;;; 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) @@ -749,7 +749,7 @@ ;;; 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 diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 241e8a0..c6d14e7 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1062,10 +1062,12 @@ (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 diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a323fb1..906c0c8 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -46,9 +46,14 @@ ;;; 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)) ;;;; leaf reference diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 154fdb6..31e881a 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -655,10 +655,10 @@ (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))) @@ -749,7 +749,7 @@ (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))))) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 99df597..7f4a169 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -346,7 +346,7 @@ ;;; 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)) @@ -453,7 +453,7 @@ (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 @@ -599,7 +599,7 @@ (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 diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 0a6fa38..b004f45 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -506,7 +506,7 @@ (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))) @@ -527,7 +527,7 @@ (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) @@ -568,10 +568,10 @@ (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 @@ -581,7 +581,7 @@ (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))) diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index 8644e1e..2bbfa62 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -266,10 +266,10 @@ ;;;; 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))) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index a0bebde..0ca1521 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -92,7 +92,7 @@ (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))) @@ -100,7 +100,7 @@ (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))) diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index e0d70c1..d147a59 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -139,7 +139,7 @@ (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)) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index defd346..4c5bdfd 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -57,3 +57,6 @@ (assert (symbolp control-sym)) (assert (eql &rest-sym '&rest)) (assert (symbolp format-args-sym))) + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 17d6b06..eb28f6d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4