fixes:-). But hopefully any remaining bugs will be simpler, less
fundamental, and more fixable then the bugs in the old IR1
interpreter code.
+* A bug in LOOP operations on hash tables has been fixed, thanks
+ to a bug report and patch from Alexey Dejneka.
* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry
and uses that copy, rather than the current dynamic value, when
it's trying to decide whether to truncate output . Thus e.g.
built into the system.
* lots of tidying up internally: renaming things so that names are
more systematic and consistent, converting C macros to inline
- functions, systematizing indentation
+ functions, systematizing indentation, making symbol packaging
+ more logical, and so forth
* The fasl file version number changed again, for any number of
good reasons.
"SUBTRACT-BIGNUM" "SXHASH-BIGNUM"))
#s(sb-cold:package-data
+ :name "SB!BYTECODE"
+ :doc "private: stuff related to the bytecode interpreter"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
+ :export ())
+
+ #s(sb-cold:package-data
:name "SB!C"
:doc "private: implementation of the compiler"
;; (It seems strange to have the compiler USE SB-ALIEN-INTERNALS,
#!+sb-dyncount "SB-DYNCOUNT" "SB!EXT" "SB!FASL" "SB!INT"
"SB!KERNEL" "SB!SYS")
:reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE")
- :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE"
+ :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND"
"%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES"
"%UNWIND-PROTECT-BREAKUP"
"MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN"
"MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET"
"MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK"
- "MAKE-VALUE-CELL" "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE"
+ "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE"
"META-PRIMITIVE-TYPE-OR-LOSE"
"META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE"
"MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL"
"TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE"
"TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE"
"UNSAFE" "UNWIND" "UWP-ENTRY"
- "VALUE-CELL-REF" "VALUE-CELL-SET"
"VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR"
"WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME"
"LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET"
"DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR"))
#s(sb-cold:package-data
- :name "SB!BYTECODE"
- :doc "private: stuff related to the bytecode interpreter"
- :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
- :export ())
-
- #s(sb-cold:package-data
:name "SB!EXT"
:doc "public: miscellaneous supported extensions to the ANSI Lisp spec"
;; FIXME: Why don't we just USE-PACKAGE %KERNEL here instead of importing?
"*ALL-MODIFIER-NAMES*"
"*BACKUP-EXTENSION*"
+ ;; lambda list keyword extensions
+ "&MORE"
+
;; INFO stuff doesn't belong in a user-visible package, we
;; should be able to change it without apology.
"*INFO-ENVIRONMENT*"
"MAXIMIZING" "MINIMIZING" "SUMMING"
"*ITERATE-WARNINGS*"))
+ ;; FIXME: This package is awfully huge. It'd probably be good to
+ ;; split it. There's at least one natural way to split it: the
+ ;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and
+ ;; SPECIFIER-TYPE) could move to a separate package SB!TYPE. (There's
+ ;; lots of stuff which currently uses the SB!KERNEL package which
+ ;; doesn't actually use the type system stuff.)
#s(sb-cold:package-data
:name "SB!KERNEL"
:doc
"MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"
"MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
"%MAKE-INSTANCE"
+ "MAKE-VALUE-CELL"
"MAKE-VALUES-TYPE"
"MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
"MEMBER-TYPE-P" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE"
"UNKNOWN-KEY-ARGUMENT-ERROR"
"UNKNOWN-TYPE" "UNKNOWN-TYPE-P"
"UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR"
- "UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE"
+ "UNSIGNED-BYTE-32-P"
+ "VALUE-CELL-REF" "VALUE-CELL-SET"
+ "VALUES-SPECIFIER-TYPE"
"VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
"VALUES-TYPE"
"VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP"
(aver (typep frame 'compiled-frame))
(let ((res (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p res)
- (sb!c:value-cell-ref res)
+ (value-cell-ref res)
res)))
;; (This function used to be more interesting, with more type
;; cases here, before the IR1 interpreter went away. It might
(aver (typep frame 'compiled-frame))
(let ((current-value (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p current-value)
- (sb!c:value-cell-set current-value value)
+ (value-cell-set current-value value)
(set-compiled-debug-var-slot debug-var frame value))))
;; (This function used to be more interesting, with more type
;; cases here, before the IR1 interpreter went away. It might
%name
;; its position in the implementation sequence
(index (required-argument) :type fixnum)
- ;; Name of accessor, or NIL if this accessor has the same name as an
- ;; inherited accessor (which we don't want to shadow.)
+ ;; the name of the accessor function
+ ;;
+ ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
+ ;; the same name as an inherited accessor (which we don't want to
+ ;; shadow)") but that behavior doesn't seem to be specified by (or
+ ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
(accessor nil)
default ; default value expression
(type t) ; declared type specifier
;;; Parse a slot description for DEFSTRUCT, add it to the description
;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
;;; modify to get the new slot. This is supplied when handling
-;;; included slots. If the new accessor name is already an accessor
-;;; for same slot in some included structure, then set the
-;;; DSD-ACCESSOR to NIL so that we don't clobber the more general
-;;; accessor.
+;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
(islot (make-defstruct-slot-description :%name ""
:index 0
(when (keywordp spec)
;; FIXME: should be style warning
(warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT -- ~S."
+ error in DEFSTRUCT: ~S."
spec))
spec))
:format-arguments (list name)))
(setf (dsd-%name islot) (string name))
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
-
- (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name))
- (existing (info :function :accessor-for accname)))
- (declare (notinline find)) ; to avoid bug 117 bogowarnings
- (if (and (structure-class-p existing)
- (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
- (string= (dsd-%name (find accname
- (dd-slots
- (layout-info
- (class-layout existing)))
- :key #'dsd-accessor))
- name))
- (setf (dsd-accessor islot) nil)
- (setf (dsd-accessor islot) accname)))
+ (setf (dsd-accessor islot)
+ (symbolicate (or (dd-conc-name defstruct) "") name))
(when default-p
(setf (dsd-default islot) default))
(when (or *loop-duplicate-code* (not rbefore))
(return-from loop-body (makebody)))
;; This outer loop iterates once for each not-first-time flag test
- ;; generated plus once more for the forms that don't need a flag test
+ ;; generated plus once more for the forms that don't need a flag test.
(do ((threshold (loop-code-duplication-threshold env))) (nil)
(declare (fixnum threshold))
- ;; Go backwards from the ends of before-loop and after-loop merging all
- ;; the equivalent forms into the body.
+ ;; Go backwards from the ends of before-loop and after-loop
+ ;; merging all the equivalent forms into the body.
(do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
(push (pop rbefore) main-body)
(pop rafter))
(unless rbefore (return (makebody)))
- ;; The first forms in RBEFORE & RAFTER (which are the chronologically
- ;; last forms in the list) differ, therefore they cannot be moved
- ;; into the main body. If everything that chronologically precedes
- ;; them either differs or is equal but is okay to duplicate, we can
- ;; just put all of rbefore in the prologue and all of rafter after
- ;; the body. Otherwise, there is something that is not okay to
- ;; duplicate, so it and everything chronologically after it in
- ;; rbefore and rafter must go into the body, with a flag test to
- ;; distinguish the first time around the loop from later times.
- ;; What chronologically precedes the non-duplicatable form will
- ;; be handled the next time around the outer loop.
+ ;; The first forms in RBEFORE & RAFTER (which are the
+ ;; chronologically last forms in the list) differ, therefore
+ ;; they cannot be moved into the main body. If everything that
+ ;; chronologically precedes them either differs or is equal but
+ ;; is okay to duplicate, we can just put all of rbefore in the
+ ;; prologue and all of rafter after the body. Otherwise, there
+ ;; is something that is not okay to duplicate, so it and
+ ;; everything chronologically after it in rbefore and rafter
+ ;; must go into the body, with a flag test to distinguish the
+ ;; first time around the loop from later times. What
+ ;; chronologically precedes the non-duplicatable form will be
+ ;; handled the next time around the outer loop.
(do ((bb rbefore (cdr bb))
(aa rafter (cdr aa))
(lastdiff nil)
(if (null expr) 0
(let ((ans (estimate-code-size expr env)))
(declare (fixnum ans))
- ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an
- ;; alist of optimize quantities back to help quantify how much code we
- ;; are willing to duplicate.
+ ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to
+ ;; get an alist of optimize quantities back to help quantify
+ ;; how much code we are willing to duplicate.
ans)))
(defvar *special-code-sizes*
(and *loop-source-code* ; Don't get confused by NILs..
(let ((z (car *loop-source-code*)))
(cond ((loop-tequal z 'of-type)
- ;; This is the syntactically unambigous form in that the form
- ;; of the type specifier does not matter. Also, it is assumed
- ;; that the type specifier is unambiguously, and without need
- ;; of translation, a common lisp type specifier or pattern
- ;; (matching the variable) thereof.
+ ;; This is the syntactically unambigous form in that
+ ;; the form of the type specifier does not matter.
+ ;; Also, it is assumed that the type specifier is
+ ;; unambiguously, and without need of translation, a
+ ;; common lisp type specifier or pattern (matching the
+ ;; variable) thereof.
(loop-pop-source)
(loop-pop-source))
((symbolp z)
- ;; This is the (sort of) "old" syntax, even though we didn't
- ;; used to support all of these type symbols.
+ ;; This is the (sort of) "old" syntax, even though we
+ ;; didn't used to support all of these type symbols.
(let ((type-spec (or (gethash z
(loop-universe-type-symbols
*loop-universe*))
(loop-pop-source)
type-spec)))
(t
- ;; This is our sort-of old syntax. But this is only valid for
- ;; when we are destructuring, so we will be compulsive (should
- ;; we really be?) and require that we in fact be doing variable
- ;; destructuring here. We must translate the old keyword
- ;; pattern typespec into a fully-specified pattern of real type
+ ;; This is our sort-of old syntax. But this is only
+ ;; valid for when we are destructuring, so we will be
+ ;; compulsive (should we really be?) and require that
+ ;; we in fact be doing variable destructuring here. We
+ ;; must translate the old keyword pattern typespec
+ ;; into a fully-specified pattern of real type
;; specifiers here.
(if (consp variable)
(unless (consp z)
\f
;;;; various FOR/AS subdispatches
-;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
-;;; is omitted (other than being more stringent in its placement), and like the
-;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first
-;;; initialization occurs in the loop body (first-step), not in the variable
-;;; binding phase.
+;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when
+;;; the THEN is omitted (other than being more stringent in its
+;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN
+;;; is present. I.e., the first initialization occurs in the loop body
+;;; (first-step), not in the variable binding phase.
(defun loop-ansi-for-equals (var val data-type)
(loop-make-iteration-variable var nil data-type)
(cond ((loop-tequal (car *loop-source-code*) :then)
;;;; list iteration
(defun loop-list-step (listvar)
- ;; We are not equipped to analyze whether 'FOO is the same as #'FOO here in
- ;; any sensible fashion, so let's give an obnoxious warning whenever 'FOO is
- ;; used as the stepping function.
+ ;; We are not equipped to analyze whether 'FOO is the same as #'FOO
+ ;; here in any sensible fashion, so let's give an obnoxious warning
+ ;; whenever 'FOO is used as the stepping function.
;;
;; While a Discerning Compiler may deal intelligently with
;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP
(apply fun var data-type preps user-data))))
(when *loop-named-variables*
(loop-error "Unused USING variables: ~S." *loop-named-variables*))
- ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the
- ;; system from the user and the user from himself.
+ ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).
+ ;; Protect the system from the user and the user from himself.
(unless (member (length stuff) '(6 10))
(loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
path))
(dummy-predicate-var nil)
(post-steps nil))
(multiple-value-bind (other-var other-p)
- (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
+ (named-variable (ecase which
+ (:hash-key 'hash-value)
+ (:hash-value 'hash-key)))
;; @@@@ NAMED-VARIABLE returns a second value of T if the name
;; was actually specified, so clever code can throw away the
;; GENSYM'ed-up variable if it isn't really needed. The
(bindings `((,variable nil ,data-type)
(,ht-var ,(cadar prep-phrases))
,@(and other-p other-var `((,other-var nil))))))
- (if (eq which 'hash-key)
- (setq key-var variable val-var (and other-p other-var))
- (setq key-var (and other-p other-var) val-var variable))
+ (ecase which
+ (:hash-key (setq key-var variable
+ val-var (and other-p other-var)))
+ (:hash-value (setq key-var (and other-p other-var)
+ val-var variable)))
(push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
(when (consp key-var)
(setq post-steps
,@(when doc (list doc))))
(defun %defconstant-eqx-value (symbol expr eqx)
(flet ((bummer (explanation)
- (error "~@<bad DEFCONSTANT-EQX ~S: ~2I~_~A~:>" symbol explanation)))
+ (error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
+ symbol
+ expr
+ explanation
+ (symbol-value symbol))))
(cond ((not (boundp symbol))
expr)
((not (constantp symbol))
(case type
(#.sb!vm:value-cell-header-type
(write-string "value cell " stream)
- (output-object (sb!c:value-cell-ref object) stream))
+ (output-object (value-cell-ref object) stream))
(t
(write-string "unknown pointer object, type=" stream)
(let ((*print-base* 16) (*print-radix* t))
(declare (type (or pcounter fixnum) count ticks consing profiles))
(values
;; ENCAPSULATION-FUN
- (lambda (sb-c:&more arg-context arg-count)
+ (lambda (&more arg-context arg-count)
(declare (optimize speed safety))
;; Make sure that we're not recursing infinitely.
(when (boundp '*computing-profiling-data-for*)
(values-specifier-type (third type)))))
(arglist (make-gensym-list (1+ (length args)))))
(cond
- ((null (intersection args lambda-list-keywords))
+ ((null (intersection args sb!xc:lambda-list-keywords))
`(defun (setf ,name) ,arglist
(declare ,@(mapcar #'(lambda (arg type)
`(type ,type ,arg))
"FBOUNDP" "FDEFINITION" "FMAKUNBOUND"
"FIND-CLASS"
"GET-SETF-EXPANSION"
- "LAMBDA-LIST-KEYWORDS"
"LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION"
"MACRO-FUNCTION"
"MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*"
(when lambda-list
(let ((param (car lambda-list)))
(cond
- ((member param lambda-list-keywords)
+ ((member param sb!xc:lambda-list-keywords)
(new-lambda-list param)
(grovel param (cdr lambda-list)))
(t
"The exclusive upper bound on the number of multiple VALUES that you can
return.")
-;;; FIXME: Shouldn't SB!C::&MORE be in this list?
(defconstant-eqx sb!xc:lambda-list-keywords
- '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
- #!+sb-doc
+ '(&allow-other-keys
+ &aux
+ &body
+ &environment
+ &key
+ &more
+ &optional
+ &rest
+ &whole)
#'equal
+ #!+sb-doc
"symbols which are magical in a lambda list")
\f
;;;; cross-compiler-only versions of CL special variables, so that we
(let ((cup (lexenv-cleanup lexenv)))
(when cup (return cup)))))
-;;; Convert the Form in a block inserted between Block1 and Block2 as an
-;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1
-;;; context when converting the form. Note that the block is not assigned a
-;;; number, and is linked into the DFO at the beginning. We indicate that we
-;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is
-;;; supplied, then convert with that cleanup.
+;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
+;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
+;;; for IR1 context when converting the form. Note that the block is
+;;; not assigned a number, and is linked into the DFO at the
+;;; beginning. We indicate that we have trashed the DFO by setting
+;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
+;;; that cleanup.
(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(:unused nil)
(:deleted nil)))
-;;; Update continuation use information so that Node is no longer a
-;;; use of its Cont. If the old continuation doesn't start its block,
-;;; then we don't update the Block-Start-Uses, since it will be
+;;; Update continuation use information so that NODE is no longer a
+;;; use of its CONT. If the old continuation doesn't start its block,
+;;; then we don't update the BLOCK-START-USES, since it will be
;;; deleted when we are done.
;;;
;;; Note: if you call this function, you may have to do a
(setf (node-cont node) nil))
(values))
-;;; Update continuation use information so that Node uses Cont. If
-;;; Cont is :Unused, then we set its block to Node's Node-Block (which
+;;; Update continuation use information so that NODE uses CONT. If
+;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which
;;; must be set.)
;;;
;;; Note: if you call this function, you may have to do a
(setf (node-cont node) cont)
(values))
-;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to
-;;; immediately after the evaluation of Node.
+;;; Return true if CONT is the NODE-CONT for NODE and CONT is
+;;; transferred to immediately after the evaluation of NODE.
(defun immediately-used-p (cont node)
(declare (type continuation cont) (type node node))
(and (eq (node-cont node) cont)
\f
;;;; continuation substitution
-;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL.
-;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
-;;; potential optimization opportunities.
+;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
+;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST
+;;; and to note potential optimization opportunities.
(defun substitute-continuation (new old)
(declare (type continuation old new))
(aver (not (continuation-dest new)))
print only the CAR.")
(declaim (type unsigned-byte *enclosing-source-cutoff*))
-;;; We separate the determination of compiler error contexts from the actual
-;;; signalling of those errors by objectifying the error context. This allows
-;;; postponement of the determination of how (and if) to signal the error.
+;;; We separate the determination of compiler error contexts from the
+;;; actual signalling of those errors by objectifying the error
+;;; context. This allows postponement of the determination of how (and
+;;; if) to signal the error.
;;;
-;;; We take care not to reference any of the IR1 so that pending potential
-;;; error messages won't prevent the IR1 from being GC'd. To this end, we
-;;; convert source forms to strings so that source forms that contain IR1
-;;; references (e.g. %DEFUN) don't hold onto the IR.
+;;; We take care not to reference any of the IR1 so that pending
+;;; potential error messages won't prevent the IR1 from being GC'd. To
+;;; this end, we convert source forms to strings so that source forms
+;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
(defstruct (compiler-error-context
#-no-ansi-print-object
(:print-object (lambda (x stream)
;;; no method is defined, then the first two subforms are returned.
;;; Note that this facility implicitly determines the string name
;;; associated with anonymous functions.
-;;; So even though SBCL itself only uses this macro within this file, it's a
-;;; reasonable thing to put in SB-EXT in case some dedicated user wants to do
-;;; some heavy tweaking to make SBCL give more informative output about his
-;;; code.
+;;; So even though SBCL itself only uses this macro within this file,
+;;; it's a reasonable thing to put in SB-EXT in case some dedicated
+;;; user wants to do some heavy tweaking to make SBCL give more
+;;; informative output about his code.
(defmacro def-source-context (name lambda-list &body body)
#!+sb-doc
"DEF-SOURCE-CONTEXT Name Lambda-List Form*
(t
form)))
-;;; Given a source path, return the original source form and a description
-;;; of the interesting aspects of the context in which it appeared. The
-;;; context is a list of lists, one sublist per context form. The sublist is a
-;;; list of some of the initial subforms of the context form.
+;;; Given a source path, return the original source form and a
+;;; description of the interesting aspects of the context in which it
+;;; appeared. The context is a list of lists, one sublist per context
+;;; form. The sublist is a list of some of the initial subforms of the
+;;; context form.
;;;
-;;; For now, we use the first two subforms of each interesting form. A form is
-;;; interesting if the first element is a symbol beginning with "DEF" and it is
-;;; not the source form. If there is no DEF-mumble, then we use the outermost
-;;; containing form. If the second subform is a list, then in some cases we
-;;; return the car of that form rather than the whole form (i.e. don't show
-;;; defstruct options, etc.)
+;;; For now, we use the first two subforms of each interesting form. A
+;;; form is interesting if the first element is a symbol beginning
+;;; with "DEF" and it is not the source form. If there is no
+;;; DEF-mumble, then we use the outermost containing form. If the
+;;; second subform is a list, then in some cases we return the CAR of
+;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
+;;; options, etc.)
(defun find-original-source (path)
(declare (list path))
(let* ((rpath (reverse (source-path-original-source path)))
(values))
;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
-;;; condition-signalling functions, but it just writes some output instead of
-;;; signalling. (In CMU CL, it did signal a condition, but this didn't seem to
-;;; work all that well; it was weird to have COMPILE-FILE return with
-;;; WARNINGS-P set when the only problem was that the compiler couldn't figure
-;;; out how to compile something as efficiently as it liked.)
+;;; condition-signalling functions, but it just writes some output
+;;; instead of signalling. (In CMU CL, it did signal a condition, but
+;;; this didn't seem to work all that well; it was weird to have
+;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
+;;; that the compiler couldn't figure out how to compile something as
+;;; efficiently as it liked.)
(defun compiler-note (format-string &rest format-args)
(unless (if *compiler-error-context*
(policy *compiler-error-context* (= inhibit-warnings 3))
(process-top-level-locally (rest form) path compile-time-too))
((progn)
(process-top-level-progn (rest form) path compile-time-too))
- #+sb-xc-host
- ;; Consider: What should we do when we hit e.g.
+ ;; When we're cross-compiling, consider: what should we
+ ;; do when we hit e.g.
;; (EVAL-WHEN (:COMPILE-TOPLEVEL)
;; (DEFUN FOO (X) (+ 7 X)))?
;; DEFUN has a macro definition in the cross-compiler,
;; cross-compilation time. So make sure we do the EVAL
;; here, before we macroexpand.
;;
+ ;; Then things get even dicier with something like
+ ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
+ ;; where we have to make sure that we don't uncross
+ ;; the SB!XC: prefix before we do EVAL, because otherwise
+ ;; we'd be trying to redefine the cross-compilation host's
+ ;; constants.
+ ;;
;; (Isn't it fun to cross-compile Common Lisp?:-)
+ #+sb-xc-host
(t
(when compile-time-too
(eval form)) ; letting xc host EVAL do its own macroexpansion
- (let* ((uncrossed (uncross form))
- ;; letting our cross-compiler do its macroexpansion too
- (expanded (preprocessor-macroexpand uncrossed)))
- (if (eq expanded uncrossed)
+ (let* (;; (We uncross the operator name because things
+ ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
+ ;; should be equivalent to their CL: counterparts
+ ;; when being compiled as target code. We leave
+ ;; the rest of the form uncrossed because macros
+ ;; might yet expand into EVAL-WHEN stuff, and
+ ;; things inside EVAL-WHEN can't be uncrossed
+ ;; until after we've EVALed them in the
+ ;; cross-compilation host.)
+ (slightly-uncrossed (cons (uncross (first form))
+ (rest form)))
+ (expanded (preprocessor-macroexpand slightly-uncrossed)))
+ (if (eq expanded slightly-uncrossed)
+ ;; (Now that we're no longer processing toplevel
+ ;; forms, and hence no longer need to worry about
+ ;; EVAL-WHEN, we can uncross everything.)
(convert-and-maybe-compile expanded path)
- ;; Note that we also have to demote
- ;; COMPILE-TIME-TOO to NIL, no matter what it was
- ;; before, since otherwise we'd tend to EVAL
- ;; subforms more than once.
+ ;; (We have to demote COMPILE-TIME-TOO to NIL
+ ;; here, no matter what it was before, since
+ ;; otherwise we'd tend to EVAL subforms more than
+ ;; once, because of WHEN COMPILE-TIME-TOO form
+ ;; above.)
(process-top-level-form expanded path nil))))
;; When we're not cross-compiling, we only need to
;; macroexpand once, so we can follow the 1-thru-6
(more-result (when more-results (car (last all-results))))
(conditional (vop-parse-conditional-p parse)))
- `(
- :type (specifier-type '(function () nil))
+ `(:type (specifier-type '(function () nil))
:arg-types (list ,@(mapcar #'make-operand-type args))
:more-args-type ,(when more-args (make-operand-type more-arg))
:result-types ,(if conditional
(defparameter *slot-inherit-alist*
'((:generator-function . vop-info-generator-function))))
-;;; Something to help with inheriting VOP-Info slots. We return a
-;;; keyword/value pair that can be passed to the constructor. SLOT is
-;;; the keyword name of the slot, Parse is a form that evaluates to
-;;; the VOP-Parse structure for the VOP inherited. If PARSE is NIL,
-;;; then we do nothing. If the TEST form evaluates to true, then we
-;;; return a form that selects the named slot from the VOP-Info
-;;; structure corresponding to PARSE. Otherwise, we return the FORM so
-;;; that the slot is recomputed.
+;;; This is something to help with inheriting VOP-Info slots. We
+;;; return a keyword/value pair that can be passed to the constructor.
+;;; SLOT is the keyword name of the slot, Parse is a form that
+;;; evaluates to the VOP-Parse structure for the VOP inherited. If
+;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
+;;; true, then we return a form that selects the named slot from the
+;;; VOP-Info structure corresponding to PARSE. Otherwise, we return
+;;; the FORM so that the slot is recomputed.
(defmacro inherit-vop-info (slot parse test form)
`(if (and ,parse ,test)
(list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
(make-generator-function parse)))
:variant (list ,@variant))))
\f
-;;; Define the symbol NAME to be a Virtual OPeration in the compiler. If
-;;; specified, INHERITS is the name of a VOP that we default unspecified
-;;; information from. Each SPEC is a list beginning with a keyword indicating
-;;; the interpretation of the other forms in the SPEC:
+;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
+;;; If specified, INHERITS is the name of a VOP that we default
+;;; unspecified information from. Each SPEC is a list beginning with a
+;;; keyword indicating the interpretation of the other forms in the
+;;; SPEC:
;;;
;;; :Args {(Name {Key Value}*)}*
;;; :Results {(Name {Key Value}*)}*
(unless (member state '(:required :optional))
(compiler-error "misplaced &REST in lambda list: ~S" list))
(setq state :rest))
- (sb!c:&more
+ (&more
(unless (member state '(:required :optional))
(compiler-error "misplaced &MORE in lambda list: ~S" list))
(setq morep t
--- /dev/null
+;;;; miscellaneous tests of LOOP-related stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03
+;;; is fixed now.
+(assert (equal (let ((hash (make-hash-table)))
+ (setf (gethash 'key1 hash) 'val1)
+ (setf (gethash 'key2 hash) 'val2)
+ (sort (loop for key being each hash-key in hash
+ collect key)
+ #'string<))
+ '(key1 key2)))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.32"
+"0.pre7.33"
projects / sbcl.git / commitdiff