doubled, to 4 million. (If your application spends a lot of time
GCing and you have a lot of RAM, you might want to experiment with
increasing it even more.)
-?? The system's handling of top-level forms and EVAL-WHEN is now
- more ANSI-compliant, fixing bugs
+* The EVAL and EVAL-WHEN code has been largely rewritten, and the
+ old CMU CL "IR1 interpreter" has gone away. The new interpreter
+ is probably slower and harder to debug than the old one, but
+ it's much simpler (several thousand lines of source code simpler)
+ and considerably more ANSI-compliant. Bugs
?? IR1-3 and
- ?? IR1-3a.
- It's also done by much newer code, so there might be some new bugs,
- but hopefully if so they'll be less fundamental and more fixable.
+ ?? IR1-3a
+ have been fixed. Since the code is newer, there might still be
+ some new bugs (though not as many as before Martin Atzmueller's
+ fixes:-). But hopefully any remaining bugs will be simpler, less
+ fundamental, and more fixable then the bugs in the old IR1
+ interpreter code.
* 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.
# *~, #*#, TAGS
# common names for editor temporary files
# *.htm, *.html
-# The system doc sources are SGML, any HTML is automatically
-# generated output.
+# The system doc sources are SGML, any HTML is
+# automatically-generated output.
# depend
# made by "make depend" (or "gmake depend" or some such thing)
# *.x86f, *.axpf, *.lbytef, *.fasl
"MULTIPLE-CALL-VARIABLE" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
"NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
"NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE"
+ "PARSE-EVAL-WHEN-SITUATIONS"
"POLICY" "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
"PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP"
"PRIMITIVE-TYPE-NAME" "PUSH-VALUES"
"PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
"PROPER-LIST-OF-LENGTH-P"
"LIST-OF-LENGTH-AT-LEAST-P"
+ "LIST-WITH-LENGTH-P"
"READ-SEQUENCE-OR-DIE"
"RENAME-KEY-ARGS"
"REQUIRED-ARGUMENT"
"ABOUT-TO-MODIFY"
"PRINT-PRETTY-ON-STREAM-P"
"LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P"
+ "POSITIVE-PRIMEP"
;; These could be moved back into SB!EXT if someone has
;; compelling reasons, but hopefully we can get by
"OBJECT-SET-OPERATION"
"OS-COLD-INIT-OR-REINIT" "OS-CONTEXT-T" "OUTPUT-RAW-BYTES"
"PARSE-BODY" "POINTER"
- "POINTER<" "POINTER>" "PORT" "POSITIVE-PRIMEP"
+ "POINTER<" "POINTER>" "PORT"
"READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE"
"REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER"
"REMOVE-PORT-OBJECT"
;;;; the byte code interpreter
+;;; FIXME: should really be in SB!BYTECODE
(in-package "SB!C")
;;;; This software is part of the SBCL system. See the README file for
--- /dev/null
+;;;; stuff originally from CMU CL's error.lisp which can or should
+;;;; come late (mostly related to the CONDITION class itself)
+;;;;
+;;;; FIXME: should perhaps be called condition.lisp, or moved into
+;;;; classes.lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+\f
+;;;; the CONDITION class
+
+(/show0 "late-target-error.lisp 20")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(def!struct (condition-class (:include slot-class)
+ (:constructor bare-make-condition-class))
+ ;; list of CONDITION-SLOT structures for the direct slots of this
+ ;; class
+ (slots nil :type list)
+ ;; list of CONDITION-SLOT structures for all of the effective class
+ ;; slots of this class
+ (class-slots nil :type list)
+ ;; report function or NIL
+ (report nil :type (or function null))
+ ;; list of alternating initargs and initforms
+ (default-initargs () :type list)
+ ;; class precedence list as a list of class objects, with all
+ ;; non-condition classes removed
+ (cpl () :type list)
+ ;; a list of all the effective instance allocation slots of this
+ ;; class that have a non-constant initform or default-initarg.
+ ;; Values for these slots must be computed in the dynamic
+ ;; environment of MAKE-CONDITION.
+ (hairy-slots nil :type list))
+
+(defun make-condition-class (&rest rest)
+ (apply #'bare-make-condition-class
+ (rename-key-args '((:name :%name)) rest)))
+
+) ; EVAL-WHEN
+
+(defstruct (condition
+ (:constructor make-condition-object (actual-initargs))
+ (:alternate-metaclass instance
+ condition-class
+ make-condition-class)
+ (:copier nil))
+ ;; actual initargs supplied to MAKE-CONDITION
+ (actual-initargs (required-argument) :type list)
+ ;; a plist mapping slot names to any values that were assigned or
+ ;; defaulted after creation
+ (assigned-slots () :type list))
+
+(defstruct (condition-slot (:copier nil))
+ (name (required-argument) :type symbol)
+ ;; list of all applicable initargs
+ (initargs (required-argument) :type list)
+ ;; names of reader and writer functions
+ (readers (required-argument) :type list)
+ (writers (required-argument) :type list)
+ ;; true if :INITFORM was specified
+ (initform-p (required-argument) :type (member t nil))
+ ;; If this is a function, call it with no args. Otherwise, it's the
+ ;; actual value.
+ (initform (required-argument) :type t)
+ ;; allocation of this slot, or NIL until defaulted
+ (allocation nil :type (member :instance :class nil))
+ ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
+ (cell nil :type (or cons null)))
+
+;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
+;;; in its CPL, while other classes derived from CONDITION-CLASS don't
+;;; have themselves listed in their CPLs. This behavior is inherited
+;;; from CMU CL, and didn't seem to be explained there, and I haven't
+;;; figured out whether it's right. -- WHN 19990612
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((condition-class (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
+ ;; constant class names which creates fast but
+ ;; non-cold-loadable, non-compact code. In this
+ ;; context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (sb!xc:find-class 'condition))))
+ (setf (condition-class-cpl condition-class)
+ (list condition-class))))
+
+(setf (condition-class-report (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
+ ;; for constant class names which creates fast
+ ;; but non-cold-loadable, non-compact code. In
+ ;; this context, we'd rather have compact,
+ ;; cold-loadable code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (find-class 'condition)))
+ #'(lambda (cond stream)
+ (format stream "Condition ~S was signalled." (type-of cond))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun find-condition-layout (name parent-types)
+ (let* ((cpl (remove-duplicates
+ (reverse
+ (reduce #'append
+ (mapcar #'(lambda (x)
+ (condition-class-cpl
+ (sb!xc:find-class x)))
+ parent-types)))))
+ (cond-layout (info :type :compiler-layout 'condition))
+ (olayout (info :type :compiler-layout name))
+ ;; FIXME: Does this do the right thing in case of multiple
+ ;; inheritance? A quick look at DEFINE-CONDITION didn't make
+ ;; it obvious what ANSI intends to be done in the case of
+ ;; multiple inheritance, so it's not actually clear what the
+ ;; right thing is..
+ (new-inherits
+ (order-layout-inherits (concatenate 'simple-vector
+ (layout-inherits cond-layout)
+ (mapcar #'class-layout cpl)))))
+ (if (and olayout
+ (not (mismatch (layout-inherits olayout) new-inherits)))
+ olayout
+ (make-layout :class (make-undefined-class name)
+ :inherits new-inherits
+ :depthoid -1
+ :length (layout-length cond-layout)))))
+
+) ; EVAL-WHEN
+
+;;; FIXME: ANSI's definition of DEFINE-CONDITION says
+;;; Condition reporting is mediated through the PRINT-OBJECT method
+;;; for the condition type in question, with *PRINT-ESCAPE* always
+;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
+;;; a condition type C is equivalent to:
+;;; (defmethod print-object ((x c) stream)
+;;; (if *print-escape* (call-next-method) (report-name x stream)))
+;;; The current code doesn't seem to quite match that.
+(def!method print-object ((x condition) stream)
+ (if *print-escape*
+ (print-unreadable-object (x stream :type t :identity t))
+ ;; KLUDGE: A comment from CMU CL here said
+ ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
+ ;; superclasses in define-condition call!
+ (dolist (class (condition-class-cpl (sb!xc:class-of x))
+ (error "no REPORT? shouldn't happen!"))
+ (let ((report (condition-class-report class)))
+ (when report
+ (return (funcall report x stream)))))))
+\f
+;;;; slots of CONDITION objects
+
+(defvar *empty-condition-slot* '(empty))
+
+(defun find-slot-default (class slot)
+ (let ((initargs (condition-slot-initargs slot))
+ (cpl (condition-class-cpl class)))
+ (dolist (class cpl)
+ (let ((default-initargs (condition-class-default-initargs class)))
+ (dolist (initarg initargs)
+ (let ((val (getf default-initargs initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
+ (return-from find-slot-default
+ (if (functionp val)
+ (funcall val)
+ val)))))))
+
+ (if (condition-slot-initform-p slot)
+ (let ((initform (condition-slot-initform slot)))
+ (if (functionp initform)
+ (funcall initform)
+ initform))
+ (error "unbound condition slot: ~S" (condition-slot-name slot)))))
+
+(defun find-condition-class-slot (condition-class slot-name)
+ (dolist (sclass
+ (condition-class-cpl condition-class)
+ (error "There is no slot named ~S in ~S."
+ slot-name condition-class))
+ (dolist (slot (condition-class-slots sclass))
+ (when (eq (condition-slot-name slot) slot-name)
+ (return-from find-condition-class-slot slot)))))
+
+(defun condition-writer-function (condition new-value name)
+ (dolist (cslot (condition-class-class-slots
+ (layout-class (%instance-layout condition)))
+ (setf (getf (condition-assigned-slots condition) name)
+ new-value))
+ (when (eq (condition-slot-name cslot) name)
+ (return (setf (car (condition-slot-cell cslot)) new-value)))))
+
+(defun condition-reader-function (condition name)
+ (let ((class (layout-class (%instance-layout condition))))
+ (dolist (cslot (condition-class-class-slots class))
+ (when (eq (condition-slot-name cslot) name)
+ (return-from condition-reader-function
+ (car (condition-slot-cell cslot)))))
+
+ (let ((val (getf (condition-assigned-slots condition) name
+ *empty-condition-slot*)))
+ (if (eq val *empty-condition-slot*)
+ (let ((actual-initargs (condition-actual-initargs condition))
+ (slot (find-condition-class-slot class name)))
+ (unless slot
+ (error "missing slot ~S of ~S" name condition))
+ (dolist (initarg (condition-slot-initargs slot))
+ (let ((val (getf actual-initargs
+ initarg
+ *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
+ (return-from condition-reader-function
+ (setf (getf (condition-assigned-slots condition)
+ name)
+ val)))))
+ (setf (getf (condition-assigned-slots condition) name)
+ (find-slot-default class slot)))
+ val))))
+\f
+;;;; MAKE-CONDITION
+
+(defun make-condition (thing &rest args)
+ #!+sb-doc
+ "Make an instance of a condition object using the specified initargs."
+ ;; Note: ANSI specifies no exceptional situations in this function.
+ ;; signalling simple-type-error would not be wrong.
+ (let* ((thing (if (symbolp thing)
+ (sb!xc:find-class thing)
+ thing))
+ (class (typecase thing
+ (condition-class thing)
+ (class
+ (error 'simple-type-error
+ :datum thing
+ :expected-type 'condition-class
+ :format-control "~S is not a condition class."
+ :format-arguments (list thing)))
+ (t
+ (error 'simple-type-error
+ :datum thing
+ :expected-type 'condition-class
+ :format-control "bad thing for class argument:~% ~S"
+ :format-arguments (list thing)))))
+ (res (make-condition-object args)))
+ (setf (%instance-layout res) (class-layout class))
+ ;; Set any class slots with initargs present in this call.
+ (dolist (cslot (condition-class-class-slots class))
+ (dolist (initarg (condition-slot-initargs cslot))
+ (let ((val (getf args initarg *empty-condition-slot*)))
+ (unless (eq val *empty-condition-slot*)
+ (setf (car (condition-slot-cell cslot)) val)))))
+ ;; Default any slots with non-constant defaults now.
+ (dolist (hslot (condition-class-hairy-slots class))
+ (when (dolist (initarg (condition-slot-initargs hslot) t)
+ (unless (eq (getf args initarg *empty-condition-slot*)
+ *empty-condition-slot*)
+ (return nil)))
+ (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
+ (find-slot-default class hslot))))
+
+ res))
+\f
+;;;; DEFINE-CONDITION
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun %compiler-define-condition (name direct-supers layout)
+ (multiple-value-bind (class old-layout)
+ (insured-find-class name #'condition-class-p #'make-condition-class)
+ (setf (layout-class layout) class)
+ (setf (class-direct-superclasses class)
+ (mapcar #'sb!xc:find-class direct-supers))
+ (cond ((not old-layout)
+ (register-layout layout))
+ ((not *type-system-initialized*)
+ (setf (layout-class old-layout) class)
+ (setq layout old-layout)
+ (unless (eq (class-layout class) layout)
+ (register-layout layout)))
+ ((redefine-layout-warning "current"
+ old-layout
+ "new"
+ (layout-length layout)
+ (layout-inherits layout)
+ (layout-depthoid layout))
+ (register-layout layout :invalidate t))
+ ((not (class-layout class))
+ (register-layout layout)))
+
+ (setf (layout-info layout)
+ (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
+ ;; names which creates fast but non-cold-loadable, non-compact
+ ;; code. In this context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (layout-info (class-layout (sb!xc:find-class 'condition)))))
+
+ (setf (sb!xc:find-class name) class)
+
+ ;; Initialize CPL slot.
+ (setf (condition-class-cpl class)
+ (remove-if-not #'condition-class-p
+ (std-compute-class-precedence-list class))))
+ (values))
+
+) ; EVAL-WHEN
+
+;;; Compute the effective slots of CLASS, copying inherited slots and
+;;; destructively modifying direct slots.
+;;;
+;;; FIXME: It'd be nice to explain why it's OK to destructively modify
+;;; direct slots. Presumably it follows from the semantics of
+;;; inheritance and redefinition of conditions, but finding the cite
+;;; and documenting it here would be good. (Or, if this is not in fact
+;;; ANSI-compliant, fixing it would also be good.:-)
+(defun compute-effective-slots (class)
+ (collect ((res (copy-list (condition-class-slots class))))
+ (dolist (sclass (condition-class-cpl class))
+ (dolist (sslot (condition-class-slots sclass))
+ (let ((found (find (condition-slot-name sslot) (res))))
+ (cond (found
+ (setf (condition-slot-initargs found)
+ (union (condition-slot-initargs found)
+ (condition-slot-initargs sslot)))
+ (unless (condition-slot-initform-p found)
+ (setf (condition-slot-initform-p found)
+ (condition-slot-initform-p sslot))
+ (setf (condition-slot-initform found)
+ (condition-slot-initform sslot)))
+ (unless (condition-slot-allocation found)
+ (setf (condition-slot-allocation found)
+ (condition-slot-allocation sslot))))
+ (t
+ (res (copy-structure sslot)))))))
+ (res)))
+
+(defun %define-condition (name slots documentation report default-initargs)
+ (let ((class (sb!xc:find-class name)))
+ (setf (condition-class-slots class) slots)
+ (setf (condition-class-report class) report)
+ (setf (condition-class-default-initargs class) default-initargs)
+ (setf (fdocumentation name 'type) documentation)
+
+ (dolist (slot slots)
+
+ ;; Set up reader and writer functions.
+ (let ((name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ (setf (fdefinition reader)
+ #'(lambda (condition)
+ (condition-reader-function condition name))))
+ (dolist (writer (condition-slot-writers slot))
+ (setf (fdefinition writer)
+ #'(lambda (new-value condition)
+ (condition-writer-function condition new-value name))))))
+
+ ;; Compute effective slots and set up the class and hairy slots
+ ;; (subsets of the effective slots.)
+ (let ((eslots (compute-effective-slots class))
+ (e-def-initargs
+ (reduce #'append
+ (mapcar #'condition-class-default-initargs
+ (condition-class-cpl class)))))
+ (dolist (slot eslots)
+ (ecase (condition-slot-allocation slot)
+ (:class
+ (unless (condition-slot-cell slot)
+ (setf (condition-slot-cell slot)
+ (list (if (condition-slot-initform-p slot)
+ (let ((initform (condition-slot-initform slot)))
+ (if (functionp initform)
+ (funcall initform)
+ initform))
+ *empty-condition-slot*))))
+ (push slot (condition-class-class-slots class)))
+ ((:instance nil)
+ (setf (condition-slot-allocation slot) :instance)
+ (when (or (functionp (condition-slot-initform slot))
+ (dolist (initarg (condition-slot-initargs slot) nil)
+ (when (functionp (getf e-def-initargs initarg))
+ (return t))))
+ (push slot (condition-class-hairy-slots class))))))))
+ name)
+
+(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
+ &body options)
+ #!+sb-doc
+ "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
+ Define NAME as a condition type. This new type inherits slots and its
+ report function from the specified PARENT-TYPEs. A slot spec is a list of:
+ (slot-name :reader <rname> :initarg <iname> {Option Value}*
+
+ The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
+ and :TYPE and the overall options :DEFAULT-INITARGS and
+ [type] :DOCUMENTATION are also allowed.
+
+ The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
+ a string or a two-argument lambda or function name. If a function, the
+ function is called with the condition and stream to report the condition.
+ If a string, the string is printed.
+
+ Condition types are classes, but (as allowed by ANSI and not as described in
+ CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
+ SLOT-VALUE may not be used on condition objects."
+ (let* ((parent-types (or parent-types '(condition)))
+ (layout (find-condition-layout name parent-types))
+ (documentation nil)
+ (report nil)
+ (default-initargs ()))
+ (collect ((slots)
+ (all-readers nil append)
+ (all-writers nil append))
+ (dolist (spec slot-specs)
+ (when (keywordp spec)
+ (warn "Keyword slot name indicates probable syntax error:~% ~S"
+ spec))
+ (let* ((spec (if (consp spec) spec (list spec)))
+ (slot-name (first spec))
+ (allocation :instance)
+ (initform-p nil)
+ initform)
+ (collect ((initargs)
+ (readers)
+ (writers))
+ (do ((options (rest spec) (cddr options)))
+ ((null options))
+ (unless (and (consp options) (consp (cdr options)))
+ (error "malformed condition slot spec:~% ~S." spec))
+ (let ((arg (second options)))
+ (case (first options)
+ (:reader (readers arg))
+ (:writer (writers arg))
+ (:accessor
+ (readers arg)
+ (writers `(setf ,arg)))
+ (:initform
+ (when initform-p
+ (error "more than one :INITFORM in ~S" spec))
+ (setq initform-p t)
+ (setq initform arg))
+ (:initarg (initargs arg))
+ (:allocation
+ (setq allocation arg))
+ (:type)
+ (t
+ (error "unknown slot option:~% ~S" (first options))))))
+
+ (all-readers (readers))
+ (all-writers (writers))
+ (slots `(make-condition-slot
+ :name ',slot-name
+ :initargs ',(initargs)
+ :readers ',(readers)
+ :writers ',(writers)
+ :initform-p ',initform-p
+ :initform
+ ,(if (constantp initform)
+ `',(eval initform)
+ `#'(lambda () ,initform)))))))
+
+ (dolist (option options)
+ (unless (consp option)
+ (error "bad option:~% ~S" option))
+ (case (first option)
+ (:documentation (setq documentation (second option)))
+ (:report
+ (let ((arg (second option)))
+ (setq report
+ (if (stringp arg)
+ `#'(lambda (condition stream)
+ (declare (ignore condition))
+ (write-string ,arg stream))
+ `#'(lambda (condition stream)
+ (funcall #',arg condition stream))))))
+ (:default-initargs
+ (do ((initargs (rest option) (cddr initargs)))
+ ((endp initargs))
+ (let ((val (second initargs)))
+ (setq default-initargs
+ (list* `',(first initargs)
+ (if (constantp val)
+ `',(eval val)
+ `#'(lambda () ,val))
+ default-initargs)))))
+ (t
+ (error "unknown option: ~S" (first option)))))
+
+ (when (all-writers)
+ (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
+ (all-writers)))
+
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-define-condition ',name ',parent-types ',layout))
+
+ (declaim (ftype (function (t) t) ,@(all-readers)))
+ (declaim (ftype (function (t t) t) ,@(all-writers)))
+
+ (%define-condition ',name
+ (list ,@(slots))
+ ,documentation
+ ,report
+ (list ,@default-initargs))))))
+\f
+;;;; DESCRIBE on CONDITIONs
+
+;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
+;;; eventually (once we get CLOS up and running so that we can define
+;;; methods)
+(defun describe-condition (condition stream)
+ (format stream
+ "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
+ condition
+ (type-of condition)
+ (concatenate 'list
+ (condition-actual-initargs condition)
+ (condition-assigned-slots condition))))
+\f
+;;;; various CONDITIONs specified by ANSI
+
+(define-condition serious-condition (condition) ())
+
+(define-condition error (serious-condition) ())
+
+(define-condition warning (condition) ())
+(define-condition style-warning (warning) ())
+
+(defun simple-condition-printer (condition stream)
+ (apply #'format
+ stream
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)))
+
+(define-condition simple-condition ()
+ ((format-control :reader simple-condition-format-control
+ :initarg :format-control)
+ (format-arguments :reader simple-condition-format-arguments
+ :initarg :format-arguments
+ :initform '()))
+ (:report simple-condition-printer))
+
+(define-condition simple-warning (simple-condition warning) ())
+
+(define-condition simple-error (simple-condition error) ())
+
+(define-condition storage-condition (serious-condition) ())
+
+(define-condition type-error (error)
+ ((datum :reader type-error-datum :initarg :datum)
+ (expected-type :reader type-error-expected-type :initarg :expected-type))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
+ (type-error-datum condition)
+ (type-error-expected-type condition)))))
+
+(define-condition simple-type-error (simple-condition type-error) ())
+
+(define-condition program-error (error) ())
+(define-condition parse-error (error) ())
+(define-condition control-error (error) ())
+(define-condition stream-error (error)
+ ((stream :reader stream-error-stream :initarg :stream)))
+
+(define-condition end-of-file (stream-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "end of file on ~S"
+ (stream-error-stream condition)))))
+
+(define-condition file-error (error)
+ ((pathname :reader file-error-pathname :initarg :pathname))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~@<error on file ~_~S: ~2I~:_~?~:>"
+ (file-error-pathname condition)
+ ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and
+ ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem
+ ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either.
+ ;; So how does this work?
+ (serious-condition-format-control condition)
+ (serious-condition-format-arguments condition)))))
+
+(define-condition package-error (error)
+ ((package :reader package-error-package :initarg :package)))
+
+(define-condition cell-error (error)
+ ((name :reader cell-error-name :initarg :name)))
+
+(define-condition unbound-variable (cell-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "The variable ~S is unbound."
+ (cell-error-name condition)))))
+
+(define-condition undefined-function (cell-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "The function ~S is undefined."
+ (cell-error-name condition)))))
+
+(define-condition arithmetic-error (error)
+ ((operation :reader arithmetic-error-operation
+ :initarg :operation
+ :initform nil)
+ (operands :reader arithmetic-error-operands
+ :initarg :operands))
+ (:report (lambda (condition stream)
+ (format stream
+ "arithmetic error ~S signalled"
+ (type-of condition))
+ (when (arithmetic-error-operation condition)
+ (format stream
+ "~%Operation was ~S, operands ~S."
+ (arithmetic-error-operation condition)
+ (arithmetic-error-operands condition))))))
+
+(define-condition division-by-zero (arithmetic-error) ())
+(define-condition floating-point-overflow (arithmetic-error) ())
+(define-condition floating-point-underflow (arithmetic-error) ())
+(define-condition floating-point-inexact (arithmetic-error) ())
+(define-condition floating-point-invalid-operation (arithmetic-error) ())
+
+(define-condition print-not-readable (error)
+ ((object :reader print-not-readable-object :initarg :object))
+ (:report
+ (lambda (condition stream)
+ (let ((obj (print-not-readable-object condition))
+ (*print-array* nil))
+ (format stream "~S cannot be printed readably." obj)))))
+
+(define-condition reader-error (parse-error stream-error)
+ ((format-control
+ :reader reader-error-format-control
+ :initarg :format-control)
+ (format-arguments
+ :reader reader-error-format-arguments
+ :initarg :format-arguments
+ :initform '()))
+ (:report
+ (lambda (condition stream)
+ (let ((error-stream (stream-error-stream condition)))
+ (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
+ (file-position error-stream) error-stream
+ (reader-error-format-control condition)
+ (reader-error-format-arguments condition))))))
+\f
+;;;; various other (not specified by ANSI) CONDITIONs
+;;;;
+;;;; These might logically belong in other files; they're here, after
+;;;; setup of CONDITION machinery, only because that makes it easier to
+;;;; get cold init to work.
+
+;;; KLUDGE: a condition for floating point errors when we can't or
+;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
+;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
+;;; know how but the old code was broken by the conversion to POSIX
+;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
+;;;
+;;; FIXME: Perhaps this should also be a base class for all
+;;; floating point exceptions?
+(define-condition floating-point-exception (arithmetic-error)
+ ((flags :initarg :traps
+ :initform nil
+ :reader floating-point-exception-traps))
+ (:report (lambda (condition stream)
+ (format stream
+ "An arithmetic error ~S was signalled.~%"
+ (type-of condition))
+ (let ((traps (floating-point-exception-traps condition)))
+ (if traps
+ (format stream
+ "Trapping conditions are: ~%~{ ~S~^~}~%"
+ traps)
+ (write-line
+ "No traps are enabled? How can this be?"
+ stream))))))
+
+(define-condition index-too-large-error (type-error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "The index ~S is too large."
+ (type-error-datum condition)))))
+
+(define-condition io-timeout (stream-error)
+ ((direction :reader io-timeout-direction :initarg :direction))
+ (:report
+ (lambda (condition stream)
+ (declare (type stream stream))
+ (format stream
+ "I/O timeout ~(~A~)ing ~S"
+ (io-timeout-direction condition)
+ (stream-error-stream condition)))))
+
+(define-condition namestring-parse-error (parse-error)
+ ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
+ (arguments :reader namestring-parse-error-arguments :initarg :arguments
+ :initform nil)
+ (namestring :reader namestring-parse-error-namestring :initarg :namestring)
+ (offset :reader namestring-parse-error-offset :initarg :offset))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "parse error in namestring: ~?~% ~A~% ~V@T^"
+ (namestring-parse-error-complaint condition)
+ (namestring-parse-error-arguments condition)
+ (namestring-parse-error-namestring condition)
+ (namestring-parse-error-offset condition)))))
+
+(define-condition simple-package-error (simple-condition package-error) ())
+
+(define-condition reader-package-error (reader-error) ())
+
+(define-condition reader-eof-error (end-of-file)
+ ((context :reader reader-eof-error-context :initarg :context))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "unexpected end of file on ~S ~A"
+ (stream-error-stream condition)
+ (reader-eof-error-context condition)))))
+\f
+;;;; restart definitions
+
+(define-condition abort-failure (control-error) ()
+ (:report
+ "An ABORT restart was found that failed to transfer control dynamically."))
+
+(defun abort (&optional condition)
+ #!+sb-doc
+ "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
+ none exists."
+ (invoke-restart (find-restart 'abort condition))
+ ;; ABORT signals an error in case there was a restart named ABORT
+ ;; that did not transfer control dynamically. This could happen with
+ ;; RESTART-BIND.
+ (error 'abort-failure))
+
+(defun muffle-warning (&optional condition)
+ #!+sb-doc
+ "Transfer control to a restart named MUFFLE-WARNING, signalling a
+ CONTROL-ERROR if none exists."
+ (invoke-restart (find-restart 'muffle-warning condition)))
+
+(macrolet ((define-nil-returning-restart (name args doc)
+ #!-sb-doc (declare (ignore doc))
+ `(defun ,name (,@args &optional condition)
+ #!+sb-doc ,doc
+ ;; FIXME: Perhaps this shared logic should be pulled out into
+ ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
+ (when (find-restart ',name condition)
+ (invoke-restart ',name ,@args)))))
+ (define-nil-returning-restart continue ()
+ "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
+ (define-nil-returning-restart store-value (value)
+ "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
+ none exists.")
+ (define-nil-returning-restart use-value (value)
+ "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
+ none exists."))
+
+(/show0 "late-target-error.lisp end of file")
+
--- /dev/null
+;;;; various extensions (including SB-INT "internal extensions")
+;;;; available both in the cross-compilation host Lisp and in the
+;;;; target SBCL
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+;;; something not EQ to anything we might legitimately READ
+(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
+
+;;; a type used for indexing into arrays, and for related quantities
+;;; like lengths of lists
+;;;
+;;; It's intentionally limited to one less than the
+;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
+;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
+;;; that lets the system know it can increment a value of this type
+;;; without having to worry about using a bignum to represent the
+;;; result.
+;;;
+;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
+;;; bound because ANSI specifies it as an exclusive bound.)
+(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
+
+;;; like INDEX, but augmented with -1 (useful when using the index
+;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
+;;; an implementation which terminates the loop by testing for the
+;;; index leaving the loop range)
+(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
+
+;;; the default value used for initializing character data. The ANSI
+;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
+;;; because it's not in the ANSI table of portable characters.
+(defconstant default-init-char #\space)
+
+;;; CHAR-CODE values for ASCII characters which we care about but
+;;; which aren't defined in section "2.1.3 Standard Characters" of the
+;;; ANSI specification for Lisp
+;;;
+;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
+;;; FOO-CHAR-CODE). I suspect that the current implementation is
+;;; expanding this idiom into a full call to CODE-CHAR, which is an
+;;; annoying overhead. I should check whether this is happening, and
+;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
+;;; (or just find a nicer way of expressing characters portably?) --
+;;; WHN 19990713
+(defconstant bell-char-code 7)
+(defconstant tab-char-code 9)
+(defconstant form-feed-char-code 12)
+(defconstant return-char-code 13)
+(defconstant escape-char-code 27)
+(defconstant rubout-char-code 127)
+\f
+;;;; type-ish predicates
+
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Return true if X is a proper list whose length is between MIN and
+ ;; MAX (inclusive).
+ (defun proper-list-of-length-p (x min &optional (max min))
+ ;; FIXME: This implementation will hang on circular list
+ ;; structure. Since this is an error-checking utility, i.e. its
+ ;; job is to deal with screwed-up input, it'd be good style to fix
+ ;; it so that it can deal with circular list structure.
+ (cond ((minusp max)
+ nil)
+ ((null x)
+ (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil))))
+
+;;; Is X a circular list?
+(defun circular-list-p (x)
+ (and (listp x)
+ (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
+ (do ((y x (safe-cddr y))
+ (started-p nil t)
+ (z x (cdr z)))
+ ((not (and (consp z) (consp y))) nil)
+ (when (and started-p (eq y z))
+ (return t))))))
+
+;;; Is X a (possibly-improper) list of at least N elements?
+(declaim (ftype (function (t index)) list-of-length-at-least-p))
+(defun list-of-length-at-least-p (x n)
+ (or (zerop n) ; since anything can be considered an improper list of length 0
+ (and (consp x)
+ (list-of-length-at-least-p (cdr x) (1- n)))))
+
+;;; Is X is a positive prime integer?
+(defun positive-primep (x)
+ ;; This happens to be called only from one place in sbcl-0.7.0, and
+ ;; only for fixnums, we can limit it to fixnums for efficiency. (And
+ ;; if we didn't limit it to fixnums, we should use a cleverer
+ ;; algorithm, since this one scales pretty badly for huge X.)
+ (declare (fixnum x))
+ (if (<= x 5)
+ (and (>= x 2) (/= x 4))
+ (and (not (evenp x))
+ (not (zerop (rem x 3)))
+ (do ((q 6)
+ (r 1)
+ (inc 2 (logxor inc 6)) ;; 2,4,2,4...
+ (d 5 (+ d inc)))
+ ((or (= r 0) (> d q)) (/= r 0))
+ (declare (fixnum inc))
+ (multiple-value-setq (q r) (truncate x d))))))
+\f
+;;;; the COLLECT macro
+;;;;
+;;;; comment from CMU CL: "the ultimate collection macro..."
+
+;;; helper functions for COLLECT, which become the expanders of the
+;;; MACROLET definitions created by COLLECT
+;;;
+;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
+;;;
+;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
+;;; is the pointer to the current tail of the list, or NIL if the list
+;;; is empty.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun collect-normal-expander (n-value fun forms)
+ `(progn
+ ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
+ ,n-value))
+ (defun collect-list-expander (n-value n-tail forms)
+ (let ((n-res (gensym)))
+ `(progn
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
+
+;;; Collect some values somehow. Each of the collections specifies a
+;;; bunch of things which collected during the evaluation of the body
+;;; of the form. The name of the collection is used to define a local
+;;; macro, a la MACROLET. Within the body, this macro will evaluate
+;;; each of its arguments and collect the result, returning the
+;;; current value after the collection is done. The body is evaluated
+;;; as a PROGN; to get the final values when you are done, just call
+;;; the collection macro with no arguments.
+;;;
+;;; INITIAL-VALUE is the value that the collection starts out with,
+;;; which defaults to NIL. FUNCTION is the function which does the
+;;; collection. It is a function which will accept two arguments: the
+;;; value to be collected and the current collection. The result of
+;;; the function is made the new value for the collection. As a
+;;; totally magical special-case, FUNCTION may be COLLECT, which tells
+;;; us to build a list in forward order; this is the default. If an
+;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; onto the end. Note that FUNCTION may be anything that can appear
+;;; in the functional position, including macros and lambdas.
+(defmacro collect (collections &body body)
+ (let ((macros ())
+ (binds ()))
+ (dolist (spec collections)
+ (unless (proper-list-of-length-p spec 1 3)
+ (error "malformed collection specifier: ~S." spec))
+ (let* ((name (first spec))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
+ `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+\f
+;;;; some old-fashioned functions. (They're not just for old-fashioned
+;;;; code, they're also used as optimized forms of the corresponding
+;;;; general functions when the compiler can prove that they're
+;;;; equivalent.)
+
+;;; like (MEMBER ITEM LIST :TEST #'EQ)
+(defun memq (item list)
+ #!+sb-doc
+ "Returns tail of LIST beginning with first element EQ to ITEM."
+ ;; KLUDGE: These could be and probably should be defined as
+ ;; (MEMBER ITEM LIST :TEST #'EQ)),
+ ;; but when I try to cross-compile that, I get an error from
+ ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
+ ;; comments for that error say it "is probably a botched interpreter stub".
+ ;; Rather than try to figure that out, I just rewrote this function from
+ ;; scratch. -- WHN 19990512
+ (do ((i list (cdr i)))
+ ((null i))
+ (when (eq (car i) item)
+ (return i))))
+
+;;; like (ASSOC ITEM ALIST :TEST #'EQ):
+;;; Return the first pair of ALIST where ITEM is EQ to the key of
+;;; the pair.
+(defun assq (item alist)
+ ;; KLUDGE: CMU CL defined this with
+ ;; (DECLARE (INLINE ASSOC))
+ ;; (ASSOC ITEM ALIST :TEST #'EQ))
+ ;; which is pretty, but which would have required adding awkward
+ ;; build order constraints on SBCL (or figuring out some way to make
+ ;; inline definitions installable at build-the-cross-compiler time,
+ ;; which was too ambitious for now). Rather than mess with that, we
+ ;; just define ASSQ explicitly in terms of more primitive
+ ;; operations:
+ (dolist (pair alist)
+ (when (eq (car pair) item)
+ (return pair))))
+
+;;; like (DELETE .. :TEST #'EQ):
+;;; Delete all LIST entries EQ to ITEM (destructively modifying
+;;; LIST), and return the modified LIST.
+(defun delq (item list)
+ (let ((list list))
+ (do ((x list (cdr x))
+ (splice '()))
+ ((endp x) list)
+ (cond ((eq item (car x))
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))) ; Move splice along to include element.
+
+
+;;; like (POSITION .. :TEST #'EQ):
+;;; Return the position of the first element EQ to ITEM.
+(defun posq (item list)
+ (do ((i list (cdr i))
+ (j 0 (1+ j)))
+ ((null i))
+ (when (eq (car i) item)
+ (return j))))
+
+(declaim (inline neq))
+(defun neq (x y)
+ (not (eq x y)))
+\f
+;;;; miscellaneous iteration extensions
+
+;;; "the ultimate iteration macro"
+;;;
+;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+(defmacro named-let (name binds &body body)
+ #!+sb-doc
+ (dolist (x binds)
+ (unless (proper-list-of-length-p x 2)
+ (error "malformed NAMED-LET variable spec: ~S" x)))
+ `(labels ((,name ,(mapcar #'first binds) ,@body))
+ (,name ,@(mapcar #'second binds))))
+
+;;; just like DOLIST, but with one-dimensional arrays
+(defmacro dovector ((elt vector &optional result) &rest forms)
+ (let ((index (gensym))
+ (length (gensym))
+ (vec (gensym)))
+ `(let ((,vec ,vector))
+ (declare (type vector ,vec))
+ (do ((,index 0 (1+ ,index))
+ (,length (length ,vec)))
+ ((>= ,index ,length) ,result)
+ (let ((,elt (aref ,vec ,index)))
+ ,@forms)))))
+
+;;; Iterate over the entries in a HASH-TABLE.
+(defmacro dohash ((key-var value-var table &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (let ((gen (gensym))
+ (n-more (gensym)))
+ `(with-hash-table-iterator (,gen ,table)
+ (loop
+ (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
+ ,@decls
+ (unless ,n-more (return ,result))
+ ,@forms))))))
+\f
+;;;; hash cache utility
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *profile-hash-cache* nil))
+
+;;; a flag for whether it's too early in cold init to use caches so
+;;; that we have a better chance of recovering so that we have a
+;;; better chance of getting the system running so that we have a
+;;; better chance of diagnosing the problem which caused us to use the
+;;; caches too early
+#!+sb-show
+(defvar *hash-caches-initialized-p*)
+
+;;; Define a hash cache that associates some number of argument values
+;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
+;;; is used to compare the value for that arg in a cache entry with a
+;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
+;;; its first arg, but need not return any particular value.
+;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
+;;;
+;;; NAME is used to define these functions:
+;;; <name>-CACHE-LOOKUP Arg*
+;;; See whether there is an entry for the specified ARGs in the
+;;; cache. If not present, the :DEFAULT keyword (default NIL)
+;;; determines the result(s).
+;;; <name>-CACHE-ENTER Arg* Value*
+;;; Encache the association of the specified args with VALUE.
+;;; <name>-CACHE-CLEAR
+;;; Reinitialize the cache, invalidating all entries and allowing
+;;; the arguments and result values to be GC'd.
+;;;
+;;; These other keywords are defined:
+;;; :HASH-BITS <n>
+;;; The size of the cache as a power of 2.
+;;; :HASH-FUNCTION function
+;;; Some thing that can be placed in CAR position which will compute
+;;; a value between 0 and (1- (expt 2 <hash-bits>)).
+;;; :VALUES <n>
+;;; the number of return values cached for each function call
+;;; :INIT-WRAPPER <name>
+;;; The code for initializing the cache is wrapped in a form with
+;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
+;;; in type system definitions so that caches will be created
+;;; before top-level forms run.)
+(defmacro define-hash-cache (name args &key hash-function hash-bits default
+ (init-wrapper 'progn)
+ (values 1))
+ (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+ (nargs (length args))
+ (entry-size (+ nargs values))
+ (size (ash 1 hash-bits))
+ (total-size (* entry-size size))
+ (default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (n-index (gensym))
+ (n-cache (gensym)))
+
+ (unless (= (length default-values) values)
+ (error "The number of default values ~S differs from :VALUES ~D."
+ default values))
+
+ (collect ((inlines)
+ (forms)
+ (inits)
+ (tests)
+ (sets)
+ (arg-vars)
+ (values-indices)
+ (values-names))
+ (dotimes (i values)
+ (values-indices `(+ ,n-index ,(+ nargs i)))
+ (values-names (gensym)))
+ (let ((n 0))
+ (dolist (arg args)
+ (unless (= (length arg) 2)
+ (error "bad argument spec: ~S" arg))
+ (let ((arg-name (first arg))
+ (test (second arg)))
+ (arg-vars arg-name)
+ (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
+ (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
+ (incf n)))
+
+ (when *profile-hash-cache*
+ (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
+ (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
+ (inits `(setq ,n-probe 0))
+ (inits `(setq ,n-miss 0))
+ (forms `(defvar ,n-probe))
+ (forms `(defvar ,n-miss))
+ (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name ,(arg-vars)
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ (cond ((and ,@(tests))
+ (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
+ (values-indices))))
+ (t
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
+ ,default))))))
+
+ (let ((fun-name (symbolicate name "-CACHE-ENTER")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name (,@(arg-vars) ,@(values-names))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ ,@(sets)
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ (values-names))
+ (values)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
+ (forms
+ `(defun ,fun-name ()
+ (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
+ (,n-cache ,var-name))
+ ((minusp ,n-index))
+ (declare (type fixnum ,n-index))
+ ,@(collect ((arg-sets))
+ (dotimes (i nargs)
+ (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
+ (arg-sets))
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ default-values))
+ (values)))
+ (forms `(,fun-name)))
+
+ (inits `(unless (boundp ',var-name)
+ (setq ,var-name (make-array ,total-size))))
+ #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
+
+ `(progn
+ (defvar ,var-name)
+ (declaim (type (simple-vector ,total-size) ,var-name))
+ #!-sb-fluid (declaim (inline ,@(inlines)))
+ (,init-wrapper ,@(inits))
+ ,@(forms)
+ ',name))))
+
+;;; some syntactic sugar for defining a function whose values are
+;;; cached by DEFINE-HASH-CACHE
+(defmacro defun-cached ((name &rest options &key (values 1) default
+ &allow-other-keys)
+ args &body body-decls-doc)
+ (let ((default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (arg-names (mapcar #'car args)))
+ (collect ((values-names))
+ (dotimes (i values)
+ (values-names (gensym)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on
+ ;; some debugging feature (e.g. SB-SHOW) because
+ ;; it's big, duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,(values-names)
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ (values-names) default-values))
+ (multiple-value-bind ,(values-names)
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@(values-names))
+ (values ,@(values-names)))
+ (values ,@(values-names))))))))))))
+\f
+;;;; package idioms
+
+;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
+;;; instead of this function. (The distinction only actually matters when
+;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
+;;; you generally do want to signal an error instead of proceeding.)
+(defun %find-package-or-lose (package-designator)
+ (or (find-package package-designator)
+ (error 'sb!kernel:simple-package-error
+ :package package-designator
+ :format-control "The name ~S does not designate any package."
+ :format-arguments (list package-designator))))
+
+;;; ANSI specifies (in the section for FIND-PACKAGE) that the
+;;; consequences of most operations on deleted packages are
+;;; unspecified. We try to signal errors in such cases.
+(defun find-undeleted-package-or-lose (package-designator)
+ (let ((maybe-result (%find-package-or-lose package-designator)))
+ (if (package-name maybe-result) ; if not deleted
+ maybe-result
+ (error 'sb!kernel:simple-package-error
+ :package maybe-result
+ :format-control "The package ~S has been deleted."
+ :format-arguments (list maybe-result)))))
+\f
+;;;; various operations on names
+
+;;; Is NAME a legal function name?
+(defun legal-function-name-p (name)
+ (or (symbolp name)
+ (and (consp name)
+ (eq (car name) 'setf)
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (null (cddr name)))))
+
+;;; Given a function name, return the name for the BLOCK which
+;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
+(defun function-name-block-name (function-name)
+ (cond ((symbolp function-name)
+ function-name)
+ ((and (consp function-name)
+ (= (length function-name) 2)
+ (eq (first function-name) 'setf))
+ (second function-name))
+ (t
+ (error "not legal as a function name: ~S" function-name))))
+
+(defun looks-like-name-of-special-var-p (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (> (length name) 2) ; to exclude '* and '**
+ (char= #\* (aref name 0))
+ (char= #\* (aref name (1- (length name))))))))
+
+;;; ANSI guarantees that some symbols are self-evaluating. This
+;;; function is to be called just before a change which would affect
+;;; that. (We don't absolutely have to call this function before such
+;;; changes, since such changes are given as undefined behavior. In
+;;; particular, we don't if the runtime cost would be annoying. But
+;;; otherwise it's nice to do so.)
+(defun about-to-modify (symbol)
+ (declare (type symbol symbol))
+ (cond ((eq symbol t)
+ (error "Veritas aeterna. (can't change T)"))
+ ((eq symbol nil)
+ (error "Nihil ex nihil. (can't change NIL)"))
+ ((keywordp symbol)
+ (error "Keyword values can't be changed."))
+ ;; (Just because a value is CONSTANTP is not a good enough
+ ;; reason to complain here, because we want DEFCONSTANT to
+ ;; be able to use this function, and it's legal to DEFCONSTANT
+ ;; a constant as long as the new value is EQL to the old
+ ;; value.)
+ ))
+\f
+;;;; ONCE-ONLY
+;;;;
+;;;; "The macro ONCE-ONLY has been around for a long time on various
+;;;; systems [..] if you can understand how to write and when to use
+;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
+;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
+;;;; in Common Lisp_, p. 853
+
+;;; ONCE-ONLY is a utility useful in writing source transforms and
+;;; macros. It provides a concise way to wrap a LET around some code
+;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.
+(defmacro once-only (specs &body body)
+ (named-let frob ((specs specs)
+ (body body))
+ (if (null specs)
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym (symbol-name name))))
+ `(let ((,exp-temp ,(second spec))
+ (,name (gensym "ONCE-ONLY-")))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
+\f
+;;;; various error-checking utilities
+
+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.
+(declaim (ftype (function () nil) required-argument))
+(defun required-argument ()
+ #!+sb-doc
+ (/show0 "entering REQUIRED-ARGUMENT")
+ (error "A required &KEY argument was not supplied."))
+
+;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
+;;; The CL:ASSERT restarts and whatnot expand into a significant
+;;; amount of code when you multiply them by 400, so replacing them
+;;; with this should reduce the size of the system by enough to be
+;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
+;;; worthwhile, and since I don't really like CERROR stuff deep in the
+;;; guts of complex systems anyway, I replaced it too.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(let ((*package* (find-package :keyword)))
+ (format nil "~S" expr)))))
+(defun %failed-aver (expr-as-string)
+ (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+(defmacro enforce-type (value type)
+ (once-only ((value value))
+ `(unless (typep ,value ',type)
+ (%failed-enforce-type ,value ',type))))
+(defun %failed-enforce-type (value type)
+ (error 'simple-type-error
+ :value value
+ :expected-type type
+ :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-arguments (list value type)))
+\f
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+ (loop repeat n collect (gensym)))
+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
+ (lambda (x y)
+ (funcall fun y x)))
+
+;;; Return the numeric value of a type bound, i.e. an interval bound
+;;; more or less in the format of bounds in ANSI's type specifiers,
+;;; where a bare numeric value is a closed bound and a list of a
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+ (if (consp x)
+ (destructuring-bind (result) x result)
+ x))
+
+;;; some commonly-occuring CONSTANTLY forms
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
+
+;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; handle arbitrary combinations of atoms using NOT, AND, OR.
+(defun featurep (x)
+ (if (consp x)
+ (case (car x)
+ ((:not not)
+ (if (cddr x)
+ (error "too many subexpressions in feature expression: ~S" x)
+ (not (featurep (cadr x)))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x)))
+ (not (null (memq x *features*)))))
+
+;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
+;;; &KEY-argument-list-style list of alternating keywords and
+;;; arbitrary values, return a new &KEY-argument-list-style list with
+;;; all substitutions applied to it.
+;;;
+;;; Note: If efficiency mattered, we could do less consing. (But if
+;;; efficiency mattered, why would we be using &KEY arguments at
+;;; all, much less renaming &KEY arguments?)
+;;;
+;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
+(defun rename-key-args (rename-list key-args)
+ (declare (type list rename-list key-args))
+ ;; Walk through RENAME-LIST modifying RESULT as per each element in
+ ;; RENAME-LIST.
+ (do ((result (copy-list key-args))) ; may be modified below
+ ((null rename-list) result)
+ (destructuring-bind (old new) (pop rename-list)
+ ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
+ (declare (type symbol old new))
+ ;; Walk through RESULT renaming any OLD key argument to NEW.
+ (do ((in-result result (cddr in-result)))
+ ((null in-result))
+ (declare (type list in-result))
+ (when (eq (car in-result) old)
+ (setf (car in-result) new))))))
+
+;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
+;;; other ANSI input functions, is defined to communicate end of file
+;;; status with its return value, not by signalling. That is not the
+;;; behavior that we usually want. This function is a wrapper which
+;;; restores the behavior that we usually want, causing READ-SEQUENCE
+;;; to communicate end-of-file status by signalling.
+(defun read-sequence-or-die (sequence stream &key start end)
+ ;; implementation using READ-SEQUENCE
+ #-no-ansi-read-sequence
+ (let ((read-end (read-sequence sequence
+ stream
+ :start start
+ :end end)))
+ (unless (= read-end end)
+ (error 'end-of-file :stream stream))
+ (values))
+ ;; workaround for broken READ-SEQUENCE
+ #+no-ansi-read-sequence
+ (progn
+ (aver (<= start end))
+ (let ((etype (stream-element-type stream)))
+ (cond ((equal etype '(unsigned-byte 8))
+ (do ((i start (1+ i)))
+ ((>= i end)
+ (values))
+ (setf (aref sequence i)
+ (read-byte stream))))
+ (t (error "unsupported element type ~S" etype))))))
+\f
+;;;; utilities for two-VALUES predicates
+
+;;; sort of like ANY and EVERY, except:
+;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
+;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
+;;; as SUBTYPEP does.)
+;;; * THING is just an atom, and we apply OP (an arity-2 function)
+;;; successively to THING and each element of LIST.
+(defun any/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (values nil certain?))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
+(defun every/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))
+\f
+;;;; DEFPRINTER
+
+;;; These functions are called by the expansion of the DEFPRINTER
+;;; macro to do the actual printing.
+(declaim (ftype (function (symbol t stream) (values))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream)
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream)
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+(defun defprinter-print-space (stream)
+ (write-char #\space stream))
+
+;;; Define some kind of reasonable PRINT-OBJECT method for a
+;;; STRUCTURE-OBJECT class.
+;;;
+;;; NAME is the name of the structure class, and CONC-NAME is the same
+;;; as in DEFSTRUCT.
+;;;
+;;; The SLOT-DESCS describe how each slot should be printed. Each
+;;; SLOT-DESC can be a slot name, indicating that the slot should
+;;; simply be printed. A SLOT-DESC may also be a list of a slot name
+;;; and other stuff. The other stuff is composed of keywords followed
+;;; by expressions. The expressions are evaluated with the variable
+;;; which is the slot name bound to the value of the slot. These
+;;; keywords are defined:
+;;;
+;;; :PRIN1 Print the value of the expression instead of the slot value.
+;;; :PRINC Like :PRIN1, only PRINC the value
+;;; :TEST Only print something if the test is true.
+;;;
+;;; If no printing thing is specified then the slot value is printed
+;;; as if by PRIN1.
+;;;
+;;; The structure being printed is bound to STRUCTURE and the stream
+;;; is bound to STREAM.
+(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-")))
+ &rest slot-descs)
+ (let ((first? t)
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (gensym "STREAM")))
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (dolist (slot-desc slot-descs)
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
+ `(def!method print-object ((structure ,name) ,stream)
+ ;; FIXME: should probably be byte-compiled
+ (pprint-logical-block (,stream nil)
+ (print-unreadable-object (structure ,stream :type t)
+ ,@(nreverse reversed-prints))))))
+\f
+;;;; etc.
+
+;;; Given a pathname, return a corresponding physical pathname.
+(defun physicalize-pathname (possibly-logical-pathname)
+ (if (typep possibly-logical-pathname 'logical-pathname)
+ (translate-logical-pathname possibly-logical-pathname)
+ possibly-logical-pathname))
+++ /dev/null
-;;;; that part of the condition system which can or should come early
-;;;; (mostly macro-related)
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!KERNEL")
-\f
-;;;; restarts
-
-;;; a list of lists of restarts
-(defvar *restart-clusters* '())
-
-;;; An ALIST (condition . restarts) which records the restarts currently
-;;; associated with Condition.
-(defvar *condition-restarts* ())
-
-(defun compute-restarts (&optional condition)
- #!+sb-doc
- "Return a list of all the currently active restarts ordered from most
- recently established to less recently established. If Condition is
- specified, then only restarts associated with Condition (or with no
- condition) will be returned."
- (let ((associated ())
- (other ()))
- (dolist (alist *condition-restarts*)
- (if (eq (car alist) condition)
- (setq associated (cdr alist))
- (setq other (append (cdr alist) other))))
- (collect ((res))
- (dolist (restart-cluster *restart-clusters*)
- (dolist (restart restart-cluster)
- (when (and (or (not condition)
- (member restart associated)
- (not (member restart other)))
- (funcall (restart-test-function restart) condition))
- (res restart))))
- (res))))
-
-(defstruct (restart (:copier nil))
- name
- function
- report-function
- interactive-function
- (test-function #'(lambda (cond) (declare (ignore cond)) t)))
-(def!method print-object ((restart restart) stream)
- (if *print-escape*
- (print-unreadable-object (restart stream :type t :identity t))
- (restart-report restart stream)))
-
-#!+sb-doc
-(setf (fdocumentation 'restart-name 'function)
- "Returns the name of the given restart object.")
-
-(defun restart-report (restart stream)
- (funcall (or (restart-report-function restart)
- (let ((name (restart-name restart)))
- #'(lambda (stream)
- (if name (format stream "~S" name)
- (format stream "~S" restart)))))
- stream))
-
-(defmacro with-condition-restarts (condition-form restarts-form &body body)
- #!+sb-doc
- "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
- Evaluates the Forms in a dynamic environment where the restarts in the list
- Restarts-Form are associated with the condition returned by Condition-Form.
- This allows FIND-RESTART, etc., to recognize restarts that are not related
- to the error currently being debugged. See also RESTART-CASE."
- (let ((n-cond (gensym)))
- `(let ((*condition-restarts*
- (cons (let ((,n-cond ,condition-form))
- (cons ,n-cond
- (append ,restarts-form
- (cdr (assoc ,n-cond *condition-restarts*)))))
- *condition-restarts*)))
- ,@body)))
-
-(defmacro restart-bind (bindings &body forms)
- #!+sb-doc
- "Executes forms in a dynamic context where the given restart bindings are
- in effect. Users probably want to use RESTART-CASE. When clauses contain
- the same restart name, FIND-RESTART will find the first such clause."
- `(let ((*restart-clusters*
- (cons (list
- ,@(mapcar #'(lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
- report function: ~S"
- binding))
- `(make-restart
- :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
- *restart-clusters*)))
- ,@forms))
-
-(defun find-restart (name &optional condition)
- #!+sb-doc
- "Returns the first restart named name. If name is a restart, it is returned
- if it is currently active. If no such restart is found, nil is returned.
- It is an error to supply nil as a name. If Condition is specified and not
- NIL, then only restarts associated with that condition (or with no
- condition) will be returned."
- (find-if #'(lambda (x)
- (or (eq x name)
- (eq (restart-name x) name)))
- (compute-restarts condition)))
-
-(defun invoke-restart (restart &rest values)
- #!+sb-doc
- "Calls the function associated with the given restart, passing any given
- arguments. If the argument restart is not a restart or a currently active
- non-nil restart name, then a control-error is signalled."
- (let ((real-restart (find-restart restart)))
- (unless real-restart
- (error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart)))
- (apply (restart-function real-restart) values)))
-
-(defun invoke-restart-interactively (restart)
- #!+sb-doc
- "Calls the function associated with the given restart, prompting for any
- necessary arguments. If the argument restart is not a restart or a
- currently active non-nil restart name, then a control-error is signalled."
- (let ((real-restart (find-restart restart)))
- (unless real-restart
- (error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart)))
- (apply (restart-function real-restart)
- (let ((interactive-function
- (restart-interactive-function real-restart)))
- (if interactive-function
- (funcall interactive-function)
- '())))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
-;;; appropriate. Gross, but it's what the book seems to say...
-(defun munge-restart-case-expression (expression data)
- (let ((exp (macroexpand expression)))
- (if (consp exp)
- (let* ((name (car exp))
- (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
- (if (member name '(signal error cerror warn))
- (once-only ((n-cond `(coerce-to-condition
- ,(first args)
- (list ,@(rest args))
- ',(case name
- (warn 'simple-warning)
- (signal 'simple-condition)
- (t 'simple-error))
- ',name)))
- `(with-condition-restarts
- ,n-cond
- (list ,@(mapcar (lambda (da)
- `(find-restart ',(nth 0 da)))
- data))
- ,(if (eq name 'cerror)
- `(cerror ,(second expression) ,n-cond)
- `(,name ,n-cond))))
- expression))
- expression)))
-) ; EVAL-WHEN
-
-;;; FIXME: I did a fair amount of rearrangement of this code in order to
-;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
-(defmacro restart-case (expression &body clauses)
- #!+sb-doc
- "(RESTART-CASE form
- {(case-name arg-list {keyword value}* body)}*)
- The form is evaluated in a dynamic context where the clauses have special
- meanings as points to which control may be transferred (see INVOKE-RESTART).
- When clauses contain the same case-name, FIND-RESTART will find the first
- such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
- macroexpands into such) then the signalled condition will be associated with
- the new restarts."
- (flet ((transform-keywords (&key report interactive test)
- (let ((result '()))
- (when report
- (setq result (list* (if (stringp report)
- `#'(lambda (stream)
- (write-string ,report stream))
- `#',report)
- :report-function
- result)))
- (when interactive
- (setq result (list* `#',interactive
- :interactive-function
- result)))
- (when test
- (setq result (list* `#',test
- :test-function
- result)))
- (nreverse result)))
- (parse-keyword-pairs (list keys)
- (do ((l list (cddr l))
- (k '() (list* (cadr l) (car l) k)))
- ((or (null l) (not (member (car l) keys)))
- (values (nreverse k) l)))))
- (let ((block-tag (gensym))
- (temp-var (gensym))
- (data
- (macrolet (;; KLUDGE: This started as an old DEFMACRO
- ;; WITH-KEYWORD-PAIRS general utility, which was used
- ;; only in this one place in the code. It was translated
- ;; literally into this MACROLET in order to avoid some
- ;; cross-compilation bootstrap problems. It would almost
- ;; certainly be clearer, and it would certainly be more
- ;; concise, to do a more idiomatic translation, merging
- ;; this with the TRANSFORM-KEYWORDS logic above.
- ;; -- WHN 19990925
- (with-keyword-pairs ((names expression) &body forms)
- (let ((temp (member '&rest names)))
- (unless (= (length temp) 2)
- (error "&REST keyword is ~:[missing~;misplaced~]."
- temp))
- (let* ((key-vars (ldiff names temp))
- (keywords (mapcar #'keywordicate key-vars))
- (key-var (gensym))
- (rest-var (cadr temp)))
- `(multiple-value-bind (,key-var ,rest-var)
- (parse-keyword-pairs ,expression ',keywords)
- (let ,(mapcar (lambda (var keyword)
- `(,var (getf ,key-var
- ,keyword)))
- key-vars keywords)
- ,@forms))))))
- (mapcar (lambda (clause)
- (with-keyword-pairs ((report interactive test
- &rest forms)
- (cddr clause))
- (list (car clause) ;name=0
- (gensym) ;tag=1
- (transform-keywords :report report ;keywords=2
- :interactive interactive
- :test test)
- (cadr clause) ;bvl=3
- forms))) ;body=4
- clauses))))
- `(block ,block-tag
- (let ((,temp-var nil))
- (tagbody
- (restart-bind
- ,(mapcar #'(lambda (datum)
- (let ((name (nth 0 datum))
- (tag (nth 1 datum))
- (keys (nth 2 datum)))
- `(,name #'(lambda (&rest temp)
- (setq ,temp-var temp)
- (go ,tag))
- ,@keys)))
- data)
- (return-from ,block-tag
- ,(munge-restart-case-expression expression data)))
- ,@(mapcan #'(lambda (datum)
- (let ((tag (nth 1 datum))
- (bvl (nth 3 datum))
- (body (nth 4 datum)))
- (list tag
- `(return-from ,block-tag
- (apply #'(lambda ,bvl ,@body)
- ,temp-var)))))
- data)))))))
-
-(defmacro with-simple-restart ((restart-name format-string
- &rest format-arguments)
- &body forms)
- #!+sb-doc
- "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
- body)
- If restart-name is not invoked, then all values returned by forms are
- returned. If control is transferred to this restart, it immediately
- returns the values nil and t."
- `(restart-case
- ;; If there's just one body form, then don't use PROGN. This allows
- ;; RESTART-CASE to "see" calls to ERROR, etc.
- ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
- (,restart-name ()
- :report (lambda (stream)
- (format stream ,format-string ,@format-arguments))
- (values nil t))))
-\f
-;;;; HANDLER-BIND
-
-(defvar *handler-clusters* nil)
-
-(defmacro handler-bind (bindings &body forms)
- #!+sb-doc
- "(HANDLER-BIND ( {(type handler)}* ) body)
- Executes body in a dynamic context where the given handler bindings are
- in effect. Each handler must take the condition being signalled as an
- argument. The bindings are searched first to last in the event of a
- signalled condition."
- (let ((member-if (member-if (lambda (x)
- (not (proper-list-of-length-p x 2)))
- bindings)))
- (when member-if
- (error "ill-formed handler binding: ~S" (first member-if))))
- `(let ((*handler-clusters*
- (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
- bindings))
- *handler-clusters*)))
- (multiple-value-prog1
- (progn
- ,@forms)
- ;; Wait for any float exceptions.
- #!+x86 (float-wait))))
-\f
-;;;; HANDLER-CASE and IGNORE-ERRORS
-
-(defmacro handler-case (form &rest cases)
- "(HANDLER-CASE form
- { (type ([var]) body) }* )
- Execute FORM in a context with handlers established for the condition
- types. A peculiar property allows type to be :no-error. If such a clause
- occurs, and form returns normally, all its values are passed to this clause
- as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
- var specification."
-
- ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH
- ;; operations, which seems like an ugly way to handle lexical
- ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch
- ;; (included below this form, but #+NIL'ed out) to switch over to
- ;; RETURN-FROM, which seems like basically a better idea.
- ;; Unfortunately when using his patch, this reasonable code
- ;; (DEFUN FOO1I ()
- ;; (IF (NOT (IGNORE-ERRORS
- ;; (MAKE-PATHNAME :HOST "FOO"
- ;; :DIRECTORY "!BLA"
- ;; :NAME "BAR")))
- ;; (PRINT "OK")
- ;; (ERROR "NOTUNLESSNOT")))
- ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK"
- ;; instead). I think this may not be a bug in MNA's patch, but
- ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM)
- ;; but whatever the reason. (I noticed this problem in
- ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
- ;; The problem also occurs at least in sbcl-0.6.12.59 and
- ;; sbcl-0.6.13.) -- WHN
- (let ((no-error-clause (assoc ':no-error cases)))
- (if no-error-clause
- (let ((normal-return (make-symbol "normal-return"))
- (error-return (make-symbol "error-return")))
- `(block ,error-return
- (multiple-value-call #'(lambda ,@(cdr no-error-clause))
- (block ,normal-return
- (return-from ,error-return
- (handler-case (return-from ,normal-return ,form)
- ,@(remove no-error-clause cases)))))))
- (let ((var (gensym))
- (outer-tag (gensym))
- (inner-tag (gensym))
- (tag-var (gensym))
- (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
- cases)))
- `(let ((,outer-tag (cons nil nil))
- (,inner-tag (cons nil nil))
- ,var ,tag-var)
- ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
- ,var ;ignoreable
- (catch ,outer-tag
- (catch ,inner-tag
- (throw ,outer-tag
- (handler-bind
- ,(mapcar #'(lambda (annotated-case)
- `(,(cadr annotated-case)
- #'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (setf ,tag-var
- ',(car annotated-case))
- (throw ,inner-tag nil))))
- annotated-cases)
- ,form)))
- (case ,tag-var
- ,@(mapcar #'(lambda (annotated-case)
- (let ((body (cdddr annotated-case))
- (varp (caddr annotated-case)))
- `(,(car annotated-case)
- ,@(if varp
- `((let ((,(car varp) ,var))
- ,@body))
- body))))
- annotated-cases)))))))
- #+nil ; MNA's patched version -- see FIXME above
- (let ((no-error-clause (assoc ':no-error cases)))
- (if no-error-clause
- (let ((normal-return (make-symbol "normal-return"))
- (error-return (make-symbol "error-return")))
- `(block ,error-return
- (multiple-value-call (lambda ,@(cdr no-error-clause))
- (block ,normal-return
- (return-from ,error-return
- (handler-case (return-from ,normal-return ,form)
- ,@(remove no-error-clause cases)))))))
- (let ((tag (gensym))
- (var (gensym))
- (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
- cases)))
- `(block ,tag
- (let ((,var nil))
- (declare (ignorable ,var))
- (tagbody
- (handler-bind
- ,(mapcar (lambda (annotated-case)
- (list (cadr annotated-case)
- `(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (go ,(car annotated-case)))))
- annotated-cases)
- (return-from ,tag
- #!-x86 ,form
- #!+x86 (multiple-value-prog1 ,form
- ;; Need to catch FP errors here!
- (float-wait))))
- ,@(mapcan
- (lambda (annotated-case)
- (list (car annotated-case)
- (let ((body (cdddr annotated-case)))
- `(return-from
- ,tag
- ,(cond ((caddr annotated-case)
- `(let ((,(caaddr annotated-case)
- ,var))
- ,@body))
- ((not (cdr body))
- (car body))
- (t
- `(progn ,@body)))))))
- annotated-cases))))))))
-
-(defmacro ignore-errors (&rest forms)
- #!+sb-doc
- "Execute FORMS handling ERROR conditions, returning the result of the last
- form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
- `(handler-case (progn ,@forms)
- (error (condition) (values nil condition))))
-\f
-;;;; helper functions for restartable error handling which couldn't be
-;;;; defined 'til now 'cause they use the RESTART-CASE macro
-
-(defun assert-error (assertion places datum &rest arguments)
- (let ((cond (if datum
- (coerce-to-condition datum
- arguments
- 'simple-error
- 'error)
- (make-condition 'simple-error
- :format-control "The assertion ~S failed."
- :format-arguments (list assertion)))))
- (restart-case
- (error cond)
- (continue ()
- :report (lambda (stream)
- (format stream "Retry assertion")
- (if places
- (format stream
- " with new value~P for ~{~S~^, ~}."
- (length places)
- places)
- (format stream ".")))
- nil))))
-
-;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
-;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
-;;; and by CHECK-TYPE.
-(defun read-evaluated-form ()
- (format *query-io* "~&Type a form to be evaluated:~%")
- (list (eval (read *query-io*))))
-
-(defun check-type-error (place place-value type type-string)
- (let ((cond (if type-string
- (make-condition 'simple-type-error
- :datum place
- :expected-type type
- :format-control
- "The value of ~S is ~S, which is not ~A."
- :format-arguments (list place
- place-value
- type-string))
- (make-condition 'simple-type-error
- :datum place
- :expected-type type
- :format-control
- "The value of ~S is ~S, which is not of type ~S."
- :format-arguments (list place
- place-value
- type)))))
- (restart-case (error cond)
- (store-value (value)
- :report (lambda (stream)
- (format stream "Supply a new value for ~S." place))
- :interactive read-evaluated-form
- value))))
-
-(defun case-body-error (name keyform keyform-value expected-type keys)
- (restart-case
- (error 'case-failure
- :name name
- :datum keyform-value
- :expected-type expected-type
- :possibilities keys)
- (store-value (value)
- :report (lambda (stream)
- (format stream "Supply a new value for ~S." keyform))
- :interactive read-evaluated-form
- value)))
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!BYTECODE")
-
-;;; Note: This is defined here, but it's visible in SB-KERNEL, since
-;;; various magical things need to happen to it, e.g. initialization
-;;; early in cold load, and save/restore in nonlocal exit logic.
-(defvar *eval-stack-top* 0)
+(in-package "SB!IMPL")
;;; general case of EVAL (except in that it can't handle toplevel
;;; EVAL-WHEN magic properly): Delegate to the byte compiler.
,expr))))
+;;; Handle PROGN and implicit PROGN.
+(defun eval-progn-body (progn-body)
+ (unless (list-with-length-p progn-body)
+ (let ((*print-circle* t))
+ (error 'simple-program-error
+ :format-control
+ "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
+ :format-arguments (list progn-body))))
+ ;; Note:
+ ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
+ ;; need to take care to return all the values of the final EVAL.
+ ;; * It's left as an exercise to the reader to verify that this
+ ;; gives the right result when PROGN-BODY is NIL, because
+ ;; (FIRST NIL) = (REST NIL) = NIL.
+ (do* ((i progn-body rest-i)
+ (rest-i (rest i) (rest i)))
+ (nil)
+ (if rest-i ; if not last element of list
+ (eval (first i))
+ (return (eval (first i))))))
+
;;; Pick off a few easy cases, and the various top-level EVAL-WHEN
;;; magical cases, and call %EVAL for the rest.
(defun eval (original-exp)
(%eval original-exp))))
(list
(let ((name (first exp))
- (args (1- (length exp))))
+ (n-args (1- (length exp))))
(case name
(function
- (unless (= args 1)
+ (unless (= n-args 1)
(error "wrong number of args to FUNCTION:~% ~S" exp))
(let ((name (second exp)))
(if (or (atom name)
(fdefinition name)
(%eval original-exp))))
(quote
- (unless (= args 1)
+ (unless (= n-args 1)
(error "wrong number of args to QUOTE:~% ~S" exp))
(second exp))
(setq
- (unless (evenp args)
+ (unless (evenp n-args)
(error "odd number of args to SETQ:~% ~S" exp))
- (unless (zerop args)
+ (unless (zerop n-args)
(do ((name (cdr exp) (cddr name)))
((null name)
(do ((args (cdr exp) (cddr args)))
(:special)
(t (return (%eval original-exp))))))))
((progn)
- (when (> args 0)
- (dolist (x (butlast (rest exp)) (eval (car (last exp))))
- (eval x))))
+ (eval-progn-body (rest exp)))
((eval-when)
- (if (and (> args 0)
- (or (member 'eval (second exp))
- (member :execute (second exp))))
- (when (> args 1)
- (dolist (x (butlast (cddr exp)) (eval (car (last exp))))
- (eval x)))
- (%eval original-exp)))
+ ;; FIXME: DESTRUCTURING-BIND returns
+ ;; DEFMACRO-LL-ARG-COUNT-ERROR instead of PROGRAM-ERROR
+ ;; when there's something wrong with the syntax here (e.g.
+ ;; missing SITUATIONS). This could be fixed by
+ ;; hand-crafting clauses to catch and report each
+ ;; possibility, but it would probably be cleaner to write
+ ;; a new macro DESTRUCTURING-BIND-PROGRAM-SYNTAX which
+ ;; does DESTRUCTURING-BIND and promotes any mismatch to
+ ;; PROGRAM-ERROR, then to use it here and in (probably
+ ;; dozens of) other places where the same problem arises.
+ (destructuring-bind (eval-when situations &rest body) exp
+ (declare (ignore eval-when))
+ (multiple-value-bind (ct lt e)
+ (sb!c:parse-eval-when-situations situations)
+ ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
+ ;; the situation :EXECUTE (or EVAL) controls whether
+ ;; evaluation occurs for other EVAL-WHEN forms; that
+ ;; is, those that are not top level forms, or those in
+ ;; code processed by EVAL or COMPILE. If the :EXECUTE
+ ;; situation is specified in such a form, then the
+ ;; body forms are processed as an implicit PROGN;
+ ;; otherwise, the EVAL-WHEN form returns NIL.
+ (declare (ignore ct lt))
+ (when e
+ (eval-progn-body body)))))
(t
(if (and (symbolp name)
(eq (info :function :kind name) :function))
+++ /dev/null
-;;;; various extensions (including SB-INT "internal extensions")
-;;;; available both in the cross-compilation host Lisp and in the
-;;;; target SBCL
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!IMPL")
-
-;;; Lots of code wants to get to the KEYWORD package or the
-;;; COMMON-LISP package without a lot of fuss, so we cache them in
-;;; variables. TO DO: How much does this actually buy us? It sounds
-;;; sensible, but I don't know for sure that it saves space or time..
-;;; -- WHN 19990521
-;;;
-;;; (The initialization forms here only matter on the cross-compilation
-;;; host; In the target SBCL, these variables are set in cold init.)
-(declaim (type package *cl-package* *keyword-package*))
-(defvar *cl-package* (find-package "COMMON-LISP"))
-(defvar *keyword-package* (find-package "KEYWORD"))
-
-;;; something not EQ to anything we might legitimately READ
-(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
-
-;;; a type used for indexing into arrays, and for related quantities
-;;; like lengths of lists
-;;;
-;;; It's intentionally limited to one less than the
-;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
-;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
-;;; that lets the system know it can increment a value of this type
-;;; without having to worry about using a bignum to represent the
-;;; result.
-;;;
-;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
-;;; bound because ANSI specifies it as an exclusive bound.)
-(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
-
-;;; like INDEX, but augmented with -1 (useful when using the index
-;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
-;;; an implementation which terminates the loop by testing for the
-;;; index leaving the loop range)
-(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
-
-;;; the default value used for initializing character data. The ANSI
-;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
-;;; because it's not in the ANSI table of portable characters.
-(defconstant default-init-char #\space)
-
-;;; CHAR-CODE values for ASCII characters which we care about but
-;;; which aren't defined in section "2.1.3 Standard Characters" of the
-;;; ANSI specification for Lisp
-;;;
-;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
-;;; FOO-CHAR-CODE). I suspect that the current implementation is
-;;; expanding this idiom into a full call to CODE-CHAR, which is an
-;;; annoying overhead. I should check whether this is happening, and
-;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
-;;; (or just find a nicer way of expressing characters portably?) --
-;;; WHN 19990713
-(defconstant bell-char-code 7)
-(defconstant tab-char-code 9)
-(defconstant form-feed-char-code 12)
-(defconstant return-char-code 13)
-(defconstant escape-char-code 27)
-(defconstant rubout-char-code 127)
-\f
-;;;; type-ish predicates
-
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-;;;
-;;; FIXME: This implementation will hang on circular list structure.
-;;; Since this is an error-checking utility, i.e. its job is to deal
-;;; with screwed-up input, it'd be good style to fix it so that it can
-;;; deal with circular list structure.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; Return true if X is a proper list whose length is between MIN and
- ;; MAX (inclusive).
- (defun proper-list-of-length-p (x min &optional (max min))
- (cond ((minusp max)
- nil)
- ((null x)
- (zerop min))
- ((consp x)
- (and (plusp max)
- (proper-list-of-length-p (cdr x)
- (if (plusp (1- min))
- (1- min)
- 0)
- (1- max))))
- (t nil))))
-
-;;; Is X a circular list?
-(defun circular-list-p (x)
- (and (listp x)
- (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
- (do ((y x (safe-cddr y))
- (started-p nil t)
- (z x (cdr z)))
- ((not (and (consp z) (consp y))) nil)
- (when (and started-p (eq y z))
- (return t))))))
-
-;;; Is X a (possibly-improper) list of at least N elements?
-(declaim (ftype (function (t index)) list-of-length-at-least-p))
-(defun list-of-length-at-least-p (x n)
- (or (zerop n) ; since anything can be considered an improper list of length 0
- (and (consp x)
- (list-of-length-at-least-p (cdr x) (1- n)))))
-\f
-;;;; the COLLECT macro
-;;;;
-;;;; comment from CMU CL: "the ultimate collection macro..."
-
-;;; helper functions for COLLECT, which become the expanders of the
-;;; MACROLET definitions created by COLLECT
-;;;
-;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
-;;;
-;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
-;;; is the pointer to the current tail of the list, or NIL if the list
-;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun collect-normal-expander (n-value fun forms)
- `(progn
- ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
- ,n-value))
- (defun collect-list-expander (n-value n-tail forms)
- (let ((n-res (gensym)))
- `(progn
- ,@(mapcar (lambda (form)
- `(let ((,n-res (cons ,form nil)))
- (cond (,n-tail
- (setf (cdr ,n-tail) ,n-res)
- (setq ,n-tail ,n-res))
- (t
- (setq ,n-tail ,n-res ,n-value ,n-res)))))
- forms)
- ,n-value))))
-
-;;; Collect some values somehow. Each of the collections specifies a
-;;; bunch of things which collected during the evaluation of the body
-;;; of the form. The name of the collection is used to define a local
-;;; macro, a la MACROLET. Within the body, this macro will evaluate
-;;; each of its arguments and collect the result, returning the
-;;; current value after the collection is done. The body is evaluated
-;;; as a PROGN; to get the final values when you are done, just call
-;;; the collection macro with no arguments.
-;;;
-;;; INITIAL-VALUE is the value that the collection starts out with,
-;;; which defaults to NIL. FUNCTION is the function which does the
-;;; collection. It is a function which will accept two arguments: the
-;;; value to be collected and the current collection. The result of
-;;; the function is made the new value for the collection. As a
-;;; totally magical special-case, FUNCTION may be COLLECT, which tells
-;;; us to build a list in forward order; this is the default. If an
-;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
-;;; onto the end. Note that FUNCTION may be anything that can appear
-;;; in the functional position, including macros and lambdas.
-(defmacro collect (collections &body body)
- (let ((macros ())
- (binds ()))
- (dolist (spec collections)
- (unless (proper-list-of-length-p spec 1 3)
- (error "malformed collection specifier: ~S." spec))
- (let* ((name (first spec))
- (default (second spec))
- (kind (or (third spec) 'collect))
- (n-value (gensym (concatenate 'string
- (symbol-name name)
- "-N-VALUE-"))))
- (push `(,n-value ,default) binds)
- (if (eq kind 'collect)
- (let ((n-tail (gensym (concatenate 'string
- (symbol-name name)
- "-N-TAIL-"))))
- (if default
- (push `(,n-tail (last ,n-value)) binds)
- (push n-tail binds))
- (push `(,name (&rest args)
- (collect-list-expander ',n-value ',n-tail args))
- macros))
- (push `(,name (&rest args)
- (collect-normal-expander ',n-value ',kind args))
- macros))))
- `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
-\f
-;;;; some old-fashioned functions. (They're not just for old-fashioned
-;;;; code, they're also used as optimized forms of the corresponding
-;;;; general functions when the compiler can prove that they're
-;;;; equivalent.)
-
-;;; like (MEMBER ITEM LIST :TEST #'EQ)
-(defun memq (item list)
- #!+sb-doc
- "Returns tail of LIST beginning with first element EQ to ITEM."
- ;; KLUDGE: These could be and probably should be defined as
- ;; (MEMBER ITEM LIST :TEST #'EQ)),
- ;; but when I try to cross-compile that, I get an error from
- ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
- ;; comments for that error say it "is probably a botched interpreter stub".
- ;; Rather than try to figure that out, I just rewrote this function from
- ;; scratch. -- WHN 19990512
- (do ((i list (cdr i)))
- ((null i))
- (when (eq (car i) item)
- (return i))))
-
-;;; like (ASSOC ITEM ALIST :TEST #'EQ):
-;;; Return the first pair of ALIST where ITEM is EQ to the key of
-;;; the pair.
-(defun assq (item alist)
- ;; KLUDGE: CMU CL defined this with
- ;; (DECLARE (INLINE ASSOC))
- ;; (ASSOC ITEM ALIST :TEST #'EQ))
- ;; which is pretty, but which would have required adding awkward
- ;; build order constraints on SBCL (or figuring out some way to make
- ;; inline definitions installable at build-the-cross-compiler time,
- ;; which was too ambitious for now). Rather than mess with that, we
- ;; just define ASSQ explicitly in terms of more primitive
- ;; operations:
- (dolist (pair alist)
- (when (eq (car pair) item)
- (return pair))))
-
-;;; like (DELETE .. :TEST #'EQ):
-;;; Delete all LIST entries EQ to ITEM (destructively modifying
-;;; LIST), and return the modified LIST.
-(defun delq (item list)
- (let ((list list))
- (do ((x list (cdr x))
- (splice '()))
- ((endp x) list)
- (cond ((eq item (car x))
- (if (null splice)
- (setq list (cdr x))
- (rplacd splice (cdr x))))
- (t (setq splice x)))))) ; Move splice along to include element.
-
-
-;;; like (POSITION .. :TEST #'EQ):
-;;; Return the position of the first element EQ to ITEM.
-(defun posq (item list)
- (do ((i list (cdr i))
- (j 0 (1+ j)))
- ((null i))
- (when (eq (car i) item)
- (return j))))
-
-(declaim (inline neq))
-(defun neq (x y)
- (not (eq x y)))
-\f
-;;;; miscellaneous iteration extensions
-
-;;; "the ultimate iteration macro"
-;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
-(defmacro named-let (name binds &body body)
- #!+sb-doc
- (dolist (x binds)
- (unless (proper-list-of-length-p x 2)
- (error "malformed NAMED-LET variable spec: ~S" x)))
- `(labels ((,name ,(mapcar #'first binds) ,@body))
- (,name ,@(mapcar #'second binds))))
-
-;;; just like DOLIST, but with one-dimensional arrays
-(defmacro dovector ((elt vector &optional result) &rest forms)
- (let ((index (gensym))
- (length (gensym))
- (vec (gensym)))
- `(let ((,vec ,vector))
- (declare (type vector ,vec))
- (do ((,index 0 (1+ ,index))
- (,length (length ,vec)))
- ((>= ,index ,length) ,result)
- (let ((,elt (aref ,vec ,index)))
- ,@forms)))))
-
-;;; Iterate over the entries in a HASH-TABLE.
-(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
- (let ((gen (gensym))
- (n-more (gensym)))
- `(with-hash-table-iterator (,gen ,table)
- (loop
- (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
- ,@decls
- (unless ,n-more (return ,result))
- ,@forms))))))
-\f
-;;;; hash cache utility
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *profile-hash-cache* nil))
-
-;;; a flag for whether it's too early in cold init to use caches so
-;;; that we have a better chance of recovering so that we have a
-;;; better chance of getting the system running so that we have a
-;;; better chance of diagnosing the problem which caused us to use the
-;;; caches too early
-#!+sb-show
-(defvar *hash-caches-initialized-p*)
-
-;;; Define a hash cache that associates some number of argument values
-;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
-;;; is used to compare the value for that arg in a cache entry with a
-;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
-;;; its first arg, but need not return any particular value.
-;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
-;;;
-;;; NAME is used to define these functions:
-;;; <name>-CACHE-LOOKUP Arg*
-;;; See whether there is an entry for the specified ARGs in the
-;;; cache. If not present, the :DEFAULT keyword (default NIL)
-;;; determines the result(s).
-;;; <name>-CACHE-ENTER Arg* Value*
-;;; Encache the association of the specified args with VALUE.
-;;; <name>-CACHE-CLEAR
-;;; Reinitialize the cache, invalidating all entries and allowing
-;;; the arguments and result values to be GC'd.
-;;;
-;;; These other keywords are defined:
-;;; :HASH-BITS <n>
-;;; The size of the cache as a power of 2.
-;;; :HASH-FUNCTION function
-;;; Some thing that can be placed in CAR position which will compute
-;;; a value between 0 and (1- (expt 2 <hash-bits>)).
-;;; :VALUES <n>
-;;; the number of return values cached for each function call
-;;; :INIT-WRAPPER <name>
-;;; The code for initializing the cache is wrapped in a form with
-;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
-;;; in type system definitions so that caches will be created
-;;; before top-level forms run.)
-(defmacro define-hash-cache (name args &key hash-function hash-bits default
- (init-wrapper 'progn)
- (values 1))
- (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
- (nargs (length args))
- (entry-size (+ nargs values))
- (size (ash 1 hash-bits))
- (total-size (* entry-size size))
- (default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (n-index (gensym))
- (n-cache (gensym)))
-
- (unless (= (length default-values) values)
- (error "The number of default values ~S differs from :VALUES ~D."
- default values))
-
- (collect ((inlines)
- (forms)
- (inits)
- (tests)
- (sets)
- (arg-vars)
- (values-indices)
- (values-names))
- (dotimes (i values)
- (values-indices `(+ ,n-index ,(+ nargs i)))
- (values-names (gensym)))
- (let ((n 0))
- (dolist (arg args)
- (unless (= (length arg) 2)
- (error "bad argument spec: ~S" arg))
- (let ((arg-name (first arg))
- (test (second arg)))
- (arg-vars arg-name)
- (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
- (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
- (incf n)))
-
- (when *profile-hash-cache*
- (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
- (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
- (inits `(setq ,n-probe 0))
- (inits `(setq ,n-miss 0))
- (forms `(defvar ,n-probe))
- (forms `(defvar ,n-miss))
- (forms `(declaim (fixnum ,n-miss ,n-probe)))))
-
- (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name ,(arg-vars)
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- (cond ((and ,@(tests))
- (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
- (values-indices))))
- (t
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
- ,default))))))
-
- (let ((fun-name (symbolicate name "-CACHE-ENTER")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name (,@(arg-vars) ,@(values-names))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- ,@(sets)
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- (values-names))
- (values)))))
-
- (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
- (forms
- `(defun ,fun-name ()
- (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
- (,n-cache ,var-name))
- ((minusp ,n-index))
- (declare (type fixnum ,n-index))
- ,@(collect ((arg-sets))
- (dotimes (i nargs)
- (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
- (arg-sets))
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- default-values))
- (values)))
- (forms `(,fun-name)))
-
- (inits `(unless (boundp ',var-name)
- (setq ,var-name (make-array ,total-size))))
- #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
-
- `(progn
- (defvar ,var-name)
- (declaim (type (simple-vector ,total-size) ,var-name))
- #!-sb-fluid (declaim (inline ,@(inlines)))
- (,init-wrapper ,@(inits))
- ,@(forms)
- ',name))))
-
-;;; some syntactic sugar for defining a function whose values are
-;;; cached by DEFINE-HASH-CACHE
-(defmacro defun-cached ((name &rest options &key (values 1) default
- &allow-other-keys)
- args &body body-decls-doc)
- (let ((default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (arg-names (mapcar #'car args)))
- (collect ((values-names))
- (dotimes (i values)
- (values-names (gensym)))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- `(progn
- (define-hash-cache ,name ,args ,@options)
- (defun ,name ,arg-names
- ,@decls
- ,doc
- (cond #!+sb-show
- ((not (boundp '*hash-caches-initialized-p*))
- ;; This shouldn't happen, but it did happen to me
- ;; when revising the type system, and it's a lot
- ;; easier to figure out what what's going on with
- ;; that kind of problem if the system can be kept
- ;; alive until cold boot is complete. The recovery
- ;; mechanism should definitely be conditional on
- ;; some debugging feature (e.g. SB-SHOW) because
- ;; it's big, duplicating all the BODY code. -- WHN
- (/show0 ,name " too early in cold init, uncached")
- (/show0 ,(first arg-names) "=..")
- (/hexstr ,(first arg-names))
- ,@body)
- (t
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar (lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))))
-\f
-;;;; package idioms
-
-;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
-;;; instead of this function. (The distinction only actually matters when
-;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
-;;; you generally do want to signal an error instead of proceeding.)
-(defun %find-package-or-lose (package-designator)
- (or (find-package package-designator)
- (error 'sb!kernel:simple-package-error
- :package package-designator
- :format-control "The name ~S does not designate any package."
- :format-arguments (list package-designator))))
-
-;;; ANSI specifies (in the section for FIND-PACKAGE) that the
-;;; consequences of most operations on deleted packages are
-;;; unspecified. We try to signal errors in such cases.
-(defun find-undeleted-package-or-lose (package-designator)
- (let ((maybe-result (%find-package-or-lose package-designator)))
- (if (package-name maybe-result) ; if not deleted
- maybe-result
- (error 'sb!kernel:simple-package-error
- :package maybe-result
- :format-control "The package ~S has been deleted."
- :format-arguments (list maybe-result)))))
-\f
-;;;; various operations on names
-
-;;; Is NAME a legal function name?
-(defun legal-function-name-p (name)
- (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
-
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
-(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
-(defun function-name-block-name (function-name)
- (cond ((symbolp function-name)
- function-name)
- ((and (consp function-name)
- (= (length function-name) 2)
- (eq (first function-name) 'setf))
- (second function-name))
- (t
- (error "not legal as a function name: ~S" function-name))))
-
-(defun looks-like-name-of-special-var-p (x)
- (and (symbolp x)
- (let ((name (symbol-name x)))
- (and (> (length name) 2) ; to exclude '* and '**
- (char= #\* (aref name 0))
- (char= #\* (aref name (1- (length name))))))))
-
-;;; ANSI guarantees that some symbols are self-evaluating. This
-;;; function is to be called just before a change which would affect
-;;; that. (We don't absolutely have to call this function before such
-;;; changes, since such changes are given as undefined behavior. In
-;;; particular, we don't if the runtime cost would be annoying. But
-;;; otherwise it's nice to do so.)
-(defun about-to-modify (symbol)
- (declare (type symbol symbol))
- (cond ((eq symbol t)
- (error "Veritas aeterna. (can't change T)"))
- ((eq symbol nil)
- (error "Nihil ex nihil. (can't change NIL)"))
- ((keywordp symbol)
- (error "Keyword values can't be changed."))
- ;; (Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to
- ;; be able to use this function, and it's legal to DEFCONSTANT
- ;; a constant as long as the new value is EQL to the old
- ;; value.)
- ))
-\f
-;;;; ONCE-ONLY
-;;;;
-;;;; "The macro ONCE-ONLY has been around for a long time on various
-;;;; systems [..] if you can understand how to write and when to use
-;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
-;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
-;;;; in Common Lisp_, p. 853
-
-;;; ONCE-ONLY is a utility useful in writing source transforms and
-;;; macros. It provides a concise way to wrap a LET around some code
-;;; to ensure that some forms are only evaluated once.
-;;;
-;;; Create a LET* which evaluates each value expression, binding a
-;;; temporary variable to the result, and wrapping the LET* around the
-;;; result of the evaluation of BODY. Within the body, each VAR is
-;;; bound to the corresponding temporary variable.
-(defmacro once-only (specs &body body)
- (named-let frob ((specs specs)
- (body body))
- (if (null specs)
- `(progn ,@body)
- (let ((spec (first specs)))
- ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
- (unless (proper-list-of-length-p spec 2)
- (error "malformed ONCE-ONLY binding spec: ~S" spec))
- (let* ((name (first spec))
- (exp-temp (gensym (symbol-name name))))
- `(let ((,exp-temp ,(second spec))
- (,name (gensym "ONCE-ONLY-")))
- `(let ((,,name ,,exp-temp))
- ,,(frob (rest specs) body))))))))
-\f
-;;;; various error-checking utilities
-
-;;; This function can be used as the default value for keyword
-;;; arguments that must be always be supplied. Since it is known by
-;;; the compiler to never return, it will avoid any compile-time type
-;;; warnings that would result from a default value inconsistent with
-;;; the declared type. When this function is called, it signals an
-;;; error indicating that a required &KEY argument was not supplied.
-;;; This function is also useful for DEFSTRUCT slot defaults
-;;; corresponding to required arguments.
-(declaim (ftype (function () nil) required-argument))
-(defun required-argument ()
- #!+sb-doc
- (/show0 "entering REQUIRED-ARGUMENT")
- (error "A required &KEY argument was not supplied."))
-
-;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
-;;;
-;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
-;;; The CL:ASSERT restarts and whatnot expand into a significant
-;;; amount of code when you multiply them by 400, so replacing them
-;;; with this should reduce the size of the system by enough to be
-;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
-;;; worthwhile, and since I don't really like CERROR stuff deep in the
-;;; guts of complex systems anyway, I replaced it too.)
-(defmacro aver (expr)
- `(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
-(defun %failed-aver (expr-as-string)
- (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
-(defmacro enforce-type (value type)
- (once-only ((value value))
- `(unless (typep ,value ',type)
- (%failed-enforce-type ,value ',type))))
-(defun %failed-enforce-type (value type)
- (error 'simple-type-error
- :value value
- :expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
- :format-arguments (list value type)))
-\f
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
-;;; Return a function like FUN, but expecting its (two) arguments in
-;;; the opposite order that FUN does.
-(declaim (inline swapped-args-fun))
-(defun swapped-args-fun (fun)
- (declare (type function fun))
- (lambda (x y)
- (funcall fun y x)))
-
-;;; Return the numeric value of a type bound, i.e. an interval bound
-;;; more or less in the format of bounds in ANSI's type specifiers,
-;;; where a bare numeric value is a closed bound and a list of a
-;;; single numeric value is an open bound.
-;;;
-;;; The "more or less" bit is that the no-bound-at-all case is
-;;; represented by NIL (not by * as in ANSI type specifiers); and in
-;;; this case we return NIL.
-(defun type-bound-number (x)
- (if (consp x)
- (destructuring-bind (result) x result)
- x))
-
-;;; some commonly-occuring CONSTANTLY forms
-(macrolet ((def-constantly-fun (name constant-expr)
- `(setf (symbol-function ',name)
- (constantly ,constant-expr))))
- (def-constantly-fun constantly-t t)
- (def-constantly-fun constantly-nil nil)
- (def-constantly-fun constantly-0 0))
-
-;;; If X is an atom, see whether it is present in *FEATURES*. Also
-;;; handle arbitrary combinations of atoms using NOT, AND, OR.
-(defun featurep (x)
- (if (consp x)
- (case (car x)
- ((:not not)
- (if (cddr x)
- (error "too many subexpressions in feature expression: ~S" x)
- (not (featurep (cadr x)))))
- ((:and and) (every #'featurep (cdr x)))
- ((:or or) (some #'featurep (cdr x)))
- (t
- (error "unknown operator in feature expression: ~S." x)))
- (not (null (memq x *features*)))))
-
-;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; &KEY-argument-list-style list of alternating keywords and
-;;; arbitrary values, return a new &KEY-argument-list-style list with
-;;; all substitutions applied to it.
-;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if
-;;; efficiency mattered, why would we be using &KEY arguments at
-;;; all, much less renaming &KEY arguments?)
-;;;
-;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-key-args (rename-list key-args)
- (declare (type list rename-list key-args))
- ;; Walk through RENAME-LIST modifying RESULT as per each element in
- ;; RENAME-LIST.
- (do ((result (copy-list key-args))) ; may be modified below
- ((null rename-list) result)
- (destructuring-bind (old new) (pop rename-list)
- ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
- (declare (type symbol old new))
- ;; Walk through RESULT renaming any OLD key argument to NEW.
- (do ((in-result result (cddr in-result)))
- ((null in-result))
- (declare (type list in-result))
- (when (eq (car in-result) old)
- (setf (car in-result) new))))))
-
-;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
-;;; other ANSI input functions, is defined to communicate end of file
-;;; status with its return value, not by signalling. That is not the
-;;; behavior that we usually want. This function is a wrapper which
-;;; restores the behavior that we usually want, causing READ-SEQUENCE
-;;; to communicate end-of-file status by signalling.
-(defun read-sequence-or-die (sequence stream &key start end)
- ;; implementation using READ-SEQUENCE
- #-no-ansi-read-sequence
- (let ((read-end (read-sequence sequence
- stream
- :start start
- :end end)))
- (unless (= read-end end)
- (error 'end-of-file :stream stream))
- (values))
- ;; workaround for broken READ-SEQUENCE
- #+no-ansi-read-sequence
- (progn
- (aver (<= start end))
- (let ((etype (stream-element-type stream)))
- (cond ((equal etype '(unsigned-byte 8))
- (do ((i start (1+ i)))
- ((>= i end)
- (values))
- (setf (aref sequence i)
- (read-byte stream))))
- (t (error "unsupported element type ~S" etype))))))
-\f
-;;;; utilities for two-VALUES predicates
-
-;;; sort of like ANY and EVERY, except:
-;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
-;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
-;;; as SUBTYPEP does.)
-;;; * THING is just an atom, and we apply OP (an arity-2 function)
-;;; successively to THING and each element of LIST.
-(defun any/type (op thing list)
- (declare (type function op))
- (let ((certain? t))
- (dolist (i list (values nil certain?))
- (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (when sub-value (return (values t t)))
- (setf certain? nil))))))
-(defun every/type (op thing list)
- (declare (type function op))
- (let ((certain? t))
- (dolist (i list (if certain? (values t t) (values nil nil)))
- (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (unless sub-value (return (values nil t)))
- (setf certain? nil))))))
-\f
-;;;; DEFPRINTER
-
-;;; These functions are called by the expansion of the DEFPRINTER
-;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream) (values))
- defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream)
- (defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream)
- (defprinter-prinx #'princ name value stream))
-(defun defprinter-prinx (prinx name value stream)
- (declare (type function prinx))
- (when *print-pretty*
- (pprint-newline :linear stream))
- (format stream ":~A " name)
- (funcall prinx value stream)
- (values))
-(defun defprinter-print-space (stream)
- (write-char #\space stream))
-
-;;; Define some kind of reasonable PRINT-OBJECT method for a
-;;; STRUCTURE-OBJECT class.
-;;;
-;;; NAME is the name of the structure class, and CONC-NAME is the same
-;;; as in DEFSTRUCT.
-;;;
-;;; The SLOT-DESCS describe how each slot should be printed. Each
-;;; SLOT-DESC can be a slot name, indicating that the slot should
-;;; simply be printed. A SLOT-DESC may also be a list of a slot name
-;;; and other stuff. The other stuff is composed of keywords followed
-;;; by expressions. The expressions are evaluated with the variable
-;;; which is the slot name bound to the value of the slot. These
-;;; keywords are defined:
-;;;
-;;; :PRIN1 Print the value of the expression instead of the slot value.
-;;; :PRINC Like :PRIN1, only PRINC the value
-;;; :TEST Only print something if the test is true.
-;;;
-;;; If no printing thing is specified then the slot value is printed
-;;; as if by PRIN1.
-;;;
-;;; The structure being printed is bound to STRUCTURE and the stream
-;;; is bound to STREAM.
-(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
- (symbol-name name)
- "-")))
- &rest slot-descs)
- (let ((first? t)
- maybe-print-space
- (reversed-prints nil)
- (stream (gensym "STREAM")))
- (flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
- (dolist (slot-desc slot-descs)
- (if first?
- (setf maybe-print-space nil
- first? nil)
- (setf maybe-print-space `(defprinter-print-space ,stream)))
- (cond ((atom slot-desc)
- (push maybe-print-space reversed-prints)
- (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
- reversed-prints))
- (t
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (push `(let ((,sname ,(sref sname)))
- (when ,test
- ,maybe-print-space
- ,@(or (stuff)
- `((defprinter-prin1
- ',sname ,sname ,stream)))))
- reversed-prints))
- (case (first option)
- (:prin1
- (stuff `(defprinter-prin1
- ',sname ,(second option) ,stream)))
- (:princ
- (stuff `(defprinter-princ
- ',sname ,(second option) ,stream)))
- (:test (setq test (second option)))
- (t
- (error "bad option: ~S" (first option)))))))))))
- `(def!method print-object ((structure ,name) ,stream)
- ;; FIXME: should probably be byte-compiled
- (pprint-logical-block (,stream nil)
- (print-unreadable-object (structure ,stream :type t)
- ,@(nreverse reversed-prints))))))
-\f
-;;;; etc.
-
-;;; Given a pathname, return a corresponding physical pathname.
-(defun physicalize-pathname (possibly-logical-pathname)
- (if (typep possibly-logical-pathname 'logical-pathname)
- (translate-logical-pathname possibly-logical-pathname)
- possibly-logical-pathname))
--- /dev/null
+;;;; various extensions (including SB-INT "internal extensions")
+;;;; available both in the cross-compilation host Lisp and in the
+;;;; target SBCL, but which can't be defined on the target until until
+;;;; some significant amount of machinery (e.g. error-handling) is
+;;;; defined
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
+;;; not improper and which is not circular?
+(defun list-with-length-p (x)
+ (values (ignore-errors (list-length x))))
+++ /dev/null
-;;;; stuff originally from CMU CL's error.lisp which can or should
-;;;; come late (mostly related to the CONDITION class itself)
-;;;;
-;;;; FIXME: should perhaps be called condition.lisp, or moved into
-;;;; classes.lisp
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!KERNEL")
-\f
-;;;; the CONDITION class
-
-(/show0 "late-target-error.lisp 20")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(def!struct (condition-class (:include slot-class)
- (:constructor bare-make-condition-class))
- ;; list of CONDITION-SLOT structures for the direct slots of this
- ;; class
- (slots nil :type list)
- ;; list of CONDITION-SLOT structures for all of the effective class
- ;; slots of this class
- (class-slots nil :type list)
- ;; report function or NIL
- (report nil :type (or function null))
- ;; list of alternating initargs and initforms
- (default-initargs () :type list)
- ;; class precedence list as a list of class objects, with all
- ;; non-condition classes removed
- (cpl () :type list)
- ;; a list of all the effective instance allocation slots of this
- ;; class that have a non-constant initform or default-initarg.
- ;; Values for these slots must be computed in the dynamic
- ;; environment of MAKE-CONDITION.
- (hairy-slots nil :type list))
-
-(defun make-condition-class (&rest rest)
- (apply #'bare-make-condition-class
- (rename-key-args '((:name :%name)) rest)))
-
-) ; EVAL-WHEN
-
-(defstruct (condition
- (:constructor make-condition-object (actual-initargs))
- (:alternate-metaclass instance
- condition-class
- make-condition-class)
- (:copier nil))
- ;; actual initargs supplied to MAKE-CONDITION
- (actual-initargs (required-argument) :type list)
- ;; a plist mapping slot names to any values that were assigned or
- ;; defaulted after creation
- (assigned-slots () :type list))
-
-(defstruct (condition-slot (:copier nil))
- (name (required-argument) :type symbol)
- ;; list of all applicable initargs
- (initargs (required-argument) :type list)
- ;; names of reader and writer functions
- (readers (required-argument) :type list)
- (writers (required-argument) :type list)
- ;; true if :INITFORM was specified
- (initform-p (required-argument) :type (member t nil))
- ;; If this is a function, call it with no args. Otherwise, it's the
- ;; actual value.
- (initform (required-argument) :type t)
- ;; allocation of this slot, or NIL until defaulted
- (allocation nil :type (member :instance :class nil))
- ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
- (cell nil :type (or cons null)))
-
-;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
-;;; in its CPL, while other classes derived from CONDITION-CLASS don't
-;;; have themselves listed in their CPLs. This behavior is inherited
-;;; from CMU CL, and didn't seem to be explained there, and I haven't
-;;; figured out whether it's right. -- WHN 19990612
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((condition-class (locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
- ;; constant class names which creates fast but
- ;; non-cold-loadable, non-compact code. In this
- ;; context, we'd rather have compact, cold-loadable
- ;; code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (sb!xc:find-class 'condition))))
- (setf (condition-class-cpl condition-class)
- (list condition-class))))
-
-(setf (condition-class-report (locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
- ;; for constant class names which creates fast
- ;; but non-cold-loadable, non-compact code. In
- ;; this context, we'd rather have compact,
- ;; cold-loadable code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (find-class 'condition)))
- #'(lambda (cond stream)
- (format stream "Condition ~S was signalled." (type-of cond))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defun find-condition-layout (name parent-types)
- (let* ((cpl (remove-duplicates
- (reverse
- (reduce #'append
- (mapcar #'(lambda (x)
- (condition-class-cpl
- (sb!xc:find-class x)))
- parent-types)))))
- (cond-layout (info :type :compiler-layout 'condition))
- (olayout (info :type :compiler-layout name))
- ;; FIXME: Does this do the right thing in case of multiple
- ;; inheritance? A quick look at DEFINE-CONDITION didn't make
- ;; it obvious what ANSI intends to be done in the case of
- ;; multiple inheritance, so it's not actually clear what the
- ;; right thing is..
- (new-inherits
- (order-layout-inherits (concatenate 'simple-vector
- (layout-inherits cond-layout)
- (mapcar #'class-layout cpl)))))
- (if (and olayout
- (not (mismatch (layout-inherits olayout) new-inherits)))
- olayout
- (make-layout :class (make-undefined-class name)
- :inherits new-inherits
- :depthoid -1
- :length (layout-length cond-layout)))))
-
-) ; EVAL-WHEN
-
-;;; FIXME: ANSI's definition of DEFINE-CONDITION says
-;;; Condition reporting is mediated through the PRINT-OBJECT method
-;;; for the condition type in question, with *PRINT-ESCAPE* always
-;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of
-;;; a condition type C is equivalent to:
-;;; (defmethod print-object ((x c) stream)
-;;; (if *print-escape* (call-next-method) (report-name x stream)))
-;;; The current code doesn't seem to quite match that.
-(def!method print-object ((x condition) stream)
- (if *print-escape*
- (print-unreadable-object (x stream :type t :identity t))
- ;; KLUDGE: A comment from CMU CL here said
- ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
- ;; superclasses in define-condition call!
- (dolist (class (condition-class-cpl (sb!xc:class-of x))
- (error "no REPORT? shouldn't happen!"))
- (let ((report (condition-class-report class)))
- (when report
- (return (funcall report x stream)))))))
-\f
-;;;; slots of CONDITION objects
-
-(defvar *empty-condition-slot* '(empty))
-
-(defun find-slot-default (class slot)
- (let ((initargs (condition-slot-initargs slot))
- (cpl (condition-class-cpl class)))
- (dolist (class cpl)
- (let ((default-initargs (condition-class-default-initargs class)))
- (dolist (initarg initargs)
- (let ((val (getf default-initargs initarg *empty-condition-slot*)))
- (unless (eq val *empty-condition-slot*)
- (return-from find-slot-default
- (if (functionp val)
- (funcall val)
- val)))))))
-
- (if (condition-slot-initform-p slot)
- (let ((initform (condition-slot-initform slot)))
- (if (functionp initform)
- (funcall initform)
- initform))
- (error "unbound condition slot: ~S" (condition-slot-name slot)))))
-
-(defun find-condition-class-slot (condition-class slot-name)
- (dolist (sclass
- (condition-class-cpl condition-class)
- (error "There is no slot named ~S in ~S."
- slot-name condition-class))
- (dolist (slot (condition-class-slots sclass))
- (when (eq (condition-slot-name slot) slot-name)
- (return-from find-condition-class-slot slot)))))
-
-(defun condition-writer-function (condition new-value name)
- (dolist (cslot (condition-class-class-slots
- (layout-class (%instance-layout condition)))
- (setf (getf (condition-assigned-slots condition) name)
- new-value))
- (when (eq (condition-slot-name cslot) name)
- (return (setf (car (condition-slot-cell cslot)) new-value)))))
-
-(defun condition-reader-function (condition name)
- (let ((class (layout-class (%instance-layout condition))))
- (dolist (cslot (condition-class-class-slots class))
- (when (eq (condition-slot-name cslot) name)
- (return-from condition-reader-function
- (car (condition-slot-cell cslot)))))
-
- (let ((val (getf (condition-assigned-slots condition) name
- *empty-condition-slot*)))
- (if (eq val *empty-condition-slot*)
- (let ((actual-initargs (condition-actual-initargs condition))
- (slot (find-condition-class-slot class name)))
- (unless slot
- (error "missing slot ~S of ~S" name condition))
- (dolist (initarg (condition-slot-initargs slot))
- (let ((val (getf actual-initargs
- initarg
- *empty-condition-slot*)))
- (unless (eq val *empty-condition-slot*)
- (return-from condition-reader-function
- (setf (getf (condition-assigned-slots condition)
- name)
- val)))))
- (setf (getf (condition-assigned-slots condition) name)
- (find-slot-default class slot)))
- val))))
-\f
-;;;; MAKE-CONDITION
-
-(defun make-condition (thing &rest args)
- #!+sb-doc
- "Make an instance of a condition object using the specified initargs."
- ;; Note: ANSI specifies no exceptional situations in this function.
- ;; signalling simple-type-error would not be wrong.
- (let* ((thing (if (symbolp thing)
- (sb!xc:find-class thing)
- thing))
- (class (typecase thing
- (condition-class thing)
- (class
- (error 'simple-type-error
- :datum thing
- :expected-type 'condition-class
- :format-control "~S is not a condition class."
- :format-arguments (list thing)))
- (t
- (error 'simple-type-error
- :datum thing
- :expected-type 'condition-class
- :format-control "bad thing for class argument:~% ~S"
- :format-arguments (list thing)))))
- (res (make-condition-object args)))
- (setf (%instance-layout res) (class-layout class))
- ;; Set any class slots with initargs present in this call.
- (dolist (cslot (condition-class-class-slots class))
- (dolist (initarg (condition-slot-initargs cslot))
- (let ((val (getf args initarg *empty-condition-slot*)))
- (unless (eq val *empty-condition-slot*)
- (setf (car (condition-slot-cell cslot)) val)))))
- ;; Default any slots with non-constant defaults now.
- (dolist (hslot (condition-class-hairy-slots class))
- (when (dolist (initarg (condition-slot-initargs hslot) t)
- (unless (eq (getf args initarg *empty-condition-slot*)
- *empty-condition-slot*)
- (return nil)))
- (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
- (find-slot-default class hslot))))
-
- res))
-\f
-;;;; DEFINE-CONDITION
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun %compiler-define-condition (name direct-supers layout)
- (multiple-value-bind (class old-layout)
- (insured-find-class name #'condition-class-p #'make-condition-class)
- (setf (layout-class layout) class)
- (setf (class-direct-superclasses class)
- (mapcar #'sb!xc:find-class direct-supers))
- (cond ((not old-layout)
- (register-layout layout))
- ((not *type-system-initialized*)
- (setf (layout-class old-layout) class)
- (setq layout old-layout)
- (unless (eq (class-layout class) layout)
- (register-layout layout)))
- ((redefine-layout-warning "current"
- old-layout
- "new"
- (layout-length layout)
- (layout-inherits layout)
- (layout-depthoid layout))
- (register-layout layout :invalidate t))
- ((not (class-layout class))
- (register-layout layout)))
-
- (setf (layout-info layout)
- (locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
- ;; names which creates fast but non-cold-loadable, non-compact
- ;; code. In this context, we'd rather have compact, cold-loadable
- ;; code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (layout-info (class-layout (sb!xc:find-class 'condition)))))
-
- (setf (sb!xc:find-class name) class)
-
- ;; Initialize CPL slot.
- (setf (condition-class-cpl class)
- (remove-if-not #'condition-class-p
- (std-compute-class-precedence-list class))))
- (values))
-
-) ; EVAL-WHEN
-
-;;; Compute the effective slots of CLASS, copying inherited slots and
-;;; destructively modifying direct slots.
-;;;
-;;; FIXME: It'd be nice to explain why it's OK to destructively modify
-;;; direct slots. Presumably it follows from the semantics of
-;;; inheritance and redefinition of conditions, but finding the cite
-;;; and documenting it here would be good. (Or, if this is not in fact
-;;; ANSI-compliant, fixing it would also be good.:-)
-(defun compute-effective-slots (class)
- (collect ((res (copy-list (condition-class-slots class))))
- (dolist (sclass (condition-class-cpl class))
- (dolist (sslot (condition-class-slots sclass))
- (let ((found (find (condition-slot-name sslot) (res))))
- (cond (found
- (setf (condition-slot-initargs found)
- (union (condition-slot-initargs found)
- (condition-slot-initargs sslot)))
- (unless (condition-slot-initform-p found)
- (setf (condition-slot-initform-p found)
- (condition-slot-initform-p sslot))
- (setf (condition-slot-initform found)
- (condition-slot-initform sslot)))
- (unless (condition-slot-allocation found)
- (setf (condition-slot-allocation found)
- (condition-slot-allocation sslot))))
- (t
- (res (copy-structure sslot)))))))
- (res)))
-
-(defun %define-condition (name slots documentation report default-initargs)
- (let ((class (sb!xc:find-class name)))
- (setf (condition-class-slots class) slots)
- (setf (condition-class-report class) report)
- (setf (condition-class-default-initargs class) default-initargs)
- (setf (fdocumentation name 'type) documentation)
-
- (dolist (slot slots)
-
- ;; Set up reader and writer functions.
- (let ((name (condition-slot-name slot)))
- (dolist (reader (condition-slot-readers slot))
- (setf (fdefinition reader)
- #'(lambda (condition)
- (condition-reader-function condition name))))
- (dolist (writer (condition-slot-writers slot))
- (setf (fdefinition writer)
- #'(lambda (new-value condition)
- (condition-writer-function condition new-value name))))))
-
- ;; Compute effective slots and set up the class and hairy slots
- ;; (subsets of the effective slots.)
- (let ((eslots (compute-effective-slots class))
- (e-def-initargs
- (reduce #'append
- (mapcar #'condition-class-default-initargs
- (condition-class-cpl class)))))
- (dolist (slot eslots)
- (ecase (condition-slot-allocation slot)
- (:class
- (unless (condition-slot-cell slot)
- (setf (condition-slot-cell slot)
- (list (if (condition-slot-initform-p slot)
- (let ((initform (condition-slot-initform slot)))
- (if (functionp initform)
- (funcall initform)
- initform))
- *empty-condition-slot*))))
- (push slot (condition-class-class-slots class)))
- ((:instance nil)
- (setf (condition-slot-allocation slot) :instance)
- (when (or (functionp (condition-slot-initform slot))
- (dolist (initarg (condition-slot-initargs slot) nil)
- (when (functionp (getf e-def-initargs initarg))
- (return t))))
- (push slot (condition-class-hairy-slots class))))))))
- name)
-
-(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
- &body options)
- #!+sb-doc
- "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
- Define NAME as a condition type. This new type inherits slots and its
- report function from the specified PARENT-TYPEs. A slot spec is a list of:
- (slot-name :reader <rname> :initarg <iname> {Option Value}*
-
- The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
- and :TYPE and the overall options :DEFAULT-INITARGS and
- [type] :DOCUMENTATION are also allowed.
-
- The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
- a string or a two-argument lambda or function name. If a function, the
- function is called with the condition and stream to report the condition.
- If a string, the string is printed.
-
- Condition types are classes, but (as allowed by ANSI and not as described in
- CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
- SLOT-VALUE may not be used on condition objects."
- (let* ((parent-types (or parent-types '(condition)))
- (layout (find-condition-layout name parent-types))
- (documentation nil)
- (report nil)
- (default-initargs ()))
- (collect ((slots)
- (all-readers nil append)
- (all-writers nil append))
- (dolist (spec slot-specs)
- (when (keywordp spec)
- (warn "Keyword slot name indicates probable syntax error:~% ~S"
- spec))
- (let* ((spec (if (consp spec) spec (list spec)))
- (slot-name (first spec))
- (allocation :instance)
- (initform-p nil)
- initform)
- (collect ((initargs)
- (readers)
- (writers))
- (do ((options (rest spec) (cddr options)))
- ((null options))
- (unless (and (consp options) (consp (cdr options)))
- (error "malformed condition slot spec:~% ~S." spec))
- (let ((arg (second options)))
- (case (first options)
- (:reader (readers arg))
- (:writer (writers arg))
- (:accessor
- (readers arg)
- (writers `(setf ,arg)))
- (:initform
- (when initform-p
- (error "more than one :INITFORM in ~S" spec))
- (setq initform-p t)
- (setq initform arg))
- (:initarg (initargs arg))
- (:allocation
- (setq allocation arg))
- (:type)
- (t
- (error "unknown slot option:~% ~S" (first options))))))
-
- (all-readers (readers))
- (all-writers (writers))
- (slots `(make-condition-slot
- :name ',slot-name
- :initargs ',(initargs)
- :readers ',(readers)
- :writers ',(writers)
- :initform-p ',initform-p
- :initform
- ,(if (constantp initform)
- `',(eval initform)
- `#'(lambda () ,initform)))))))
-
- (dolist (option options)
- (unless (consp option)
- (error "bad option:~% ~S" option))
- (case (first option)
- (:documentation (setq documentation (second option)))
- (:report
- (let ((arg (second option)))
- (setq report
- (if (stringp arg)
- `#'(lambda (condition stream)
- (declare (ignore condition))
- (write-string ,arg stream))
- `#'(lambda (condition stream)
- (funcall #',arg condition stream))))))
- (:default-initargs
- (do ((initargs (rest option) (cddr initargs)))
- ((endp initargs))
- (let ((val (second initargs)))
- (setq default-initargs
- (list* `',(first initargs)
- (if (constantp val)
- `',(eval val)
- `#'(lambda () ,val))
- default-initargs)))))
- (t
- (error "unknown option: ~S" (first option)))))
-
- (when (all-writers)
- (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
- (all-writers)))
-
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (%compiler-define-condition ',name ',parent-types ',layout))
-
- (declaim (ftype (function (t) t) ,@(all-readers)))
- (declaim (ftype (function (t t) t) ,@(all-writers)))
-
- (%define-condition ',name
- (list ,@(slots))
- ,documentation
- ,report
- (list ,@default-initargs))))))
-\f
-;;;; DESCRIBE on CONDITIONs
-
-;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T)
-;;; eventually (once we get CLOS up and running so that we can define
-;;; methods)
-(defun describe-condition (condition stream)
- (format stream
- "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>"
- condition
- (type-of condition)
- (concatenate 'list
- (condition-actual-initargs condition)
- (condition-assigned-slots condition))))
-\f
-;;;; various CONDITIONs specified by ANSI
-
-(define-condition serious-condition (condition) ())
-
-(define-condition error (serious-condition) ())
-
-(define-condition warning (condition) ())
-(define-condition style-warning (warning) ())
-
-(defun simple-condition-printer (condition stream)
- (apply #'format
- stream
- (simple-condition-format-control condition)
- (simple-condition-format-arguments condition)))
-
-(define-condition simple-condition ()
- ((format-control :reader simple-condition-format-control
- :initarg :format-control)
- (format-arguments :reader simple-condition-format-arguments
- :initarg :format-arguments
- :initform '()))
- (:report simple-condition-printer))
-
-(define-condition simple-warning (simple-condition warning) ())
-
-(define-condition simple-error (simple-condition error) ())
-
-(define-condition storage-condition (serious-condition) ())
-
-(define-condition type-error (error)
- ((datum :reader type-error-datum :initarg :datum)
- (expected-type :reader type-error-expected-type :initarg :expected-type))
- (:report
- (lambda (condition stream)
- (format stream
- "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
- (type-error-datum condition)
- (type-error-expected-type condition)))))
-
-(define-condition simple-type-error (simple-condition type-error) ())
-
-(define-condition program-error (error) ())
-(define-condition parse-error (error) ())
-(define-condition control-error (error) ())
-(define-condition stream-error (error)
- ((stream :reader stream-error-stream :initarg :stream)))
-
-(define-condition end-of-file (stream-error) ()
- (:report
- (lambda (condition stream)
- (format stream
- "end of file on ~S"
- (stream-error-stream condition)))))
-
-(define-condition file-error (error)
- ((pathname :reader file-error-pathname :initarg :pathname))
- (:report
- (lambda (condition stream)
- (format stream
- "~@<error on file ~_~S: ~2I~:_~?~:>"
- (file-error-pathname condition)
- ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and
- ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem
- ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either.
- ;; So how does this work?
- (serious-condition-format-control condition)
- (serious-condition-format-arguments condition)))))
-
-(define-condition package-error (error)
- ((package :reader package-error-package :initarg :package)))
-
-(define-condition cell-error (error)
- ((name :reader cell-error-name :initarg :name)))
-
-(define-condition unbound-variable (cell-error) ()
- (:report
- (lambda (condition stream)
- (format stream
- "The variable ~S is unbound."
- (cell-error-name condition)))))
-
-(define-condition undefined-function (cell-error) ()
- (:report
- (lambda (condition stream)
- (format stream
- "The function ~S is undefined."
- (cell-error-name condition)))))
-
-(define-condition arithmetic-error (error)
- ((operation :reader arithmetic-error-operation
- :initarg :operation
- :initform nil)
- (operands :reader arithmetic-error-operands
- :initarg :operands))
- (:report (lambda (condition stream)
- (format stream
- "arithmetic error ~S signalled"
- (type-of condition))
- (when (arithmetic-error-operation condition)
- (format stream
- "~%Operation was ~S, operands ~S."
- (arithmetic-error-operation condition)
- (arithmetic-error-operands condition))))))
-
-(define-condition division-by-zero (arithmetic-error) ())
-(define-condition floating-point-overflow (arithmetic-error) ())
-(define-condition floating-point-underflow (arithmetic-error) ())
-(define-condition floating-point-inexact (arithmetic-error) ())
-(define-condition floating-point-invalid-operation (arithmetic-error) ())
-
-(define-condition print-not-readable (error)
- ((object :reader print-not-readable-object :initarg :object))
- (:report
- (lambda (condition stream)
- (let ((obj (print-not-readable-object condition))
- (*print-array* nil))
- (format stream "~S cannot be printed readably." obj)))))
-
-(define-condition reader-error (parse-error stream-error)
- ((format-control
- :reader reader-error-format-control
- :initarg :format-control)
- (format-arguments
- :reader reader-error-format-arguments
- :initarg :format-arguments
- :initform '()))
- (:report
- (lambda (condition stream)
- (let ((error-stream (stream-error-stream condition)))
- (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
- (file-position error-stream) error-stream
- (reader-error-format-control condition)
- (reader-error-format-arguments condition))))))
-\f
-;;;; various other (not specified by ANSI) CONDITIONs
-;;;;
-;;;; These might logically belong in other files; they're here, after
-;;;; setup of CONDITION machinery, only because that makes it easier to
-;;;; get cold init to work.
-
-;;; KLUDGE: a condition for floating point errors when we can't or
-;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
-;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
-;;; know how but the old code was broken by the conversion to POSIX
-;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
-;;;
-;;; FIXME: Perhaps this should also be a base class for all
-;;; floating point exceptions?
-(define-condition floating-point-exception (arithmetic-error)
- ((flags :initarg :traps
- :initform nil
- :reader floating-point-exception-traps))
- (:report (lambda (condition stream)
- (format stream
- "An arithmetic error ~S was signalled.~%"
- (type-of condition))
- (let ((traps (floating-point-exception-traps condition)))
- (if traps
- (format stream
- "Trapping conditions are: ~%~{ ~S~^~}~%"
- traps)
- (write-line
- "No traps are enabled? How can this be?"
- stream))))))
-
-(define-condition index-too-large-error (type-error)
- ()
- (:report
- (lambda (condition stream)
- (format stream
- "The index ~S is too large."
- (type-error-datum condition)))))
-
-(define-condition io-timeout (stream-error)
- ((direction :reader io-timeout-direction :initarg :direction))
- (:report
- (lambda (condition stream)
- (declare (type stream stream))
- (format stream
- "I/O timeout ~(~A~)ing ~S"
- (io-timeout-direction condition)
- (stream-error-stream condition)))))
-
-(define-condition namestring-parse-error (parse-error)
- ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
- (arguments :reader namestring-parse-error-arguments :initarg :arguments
- :initform nil)
- (namestring :reader namestring-parse-error-namestring :initarg :namestring)
- (offset :reader namestring-parse-error-offset :initarg :offset))
- (:report
- (lambda (condition stream)
- (format stream
- "parse error in namestring: ~?~% ~A~% ~V@T^"
- (namestring-parse-error-complaint condition)
- (namestring-parse-error-arguments condition)
- (namestring-parse-error-namestring condition)
- (namestring-parse-error-offset condition)))))
-
-(define-condition simple-package-error (simple-condition package-error) ())
-
-(define-condition reader-package-error (reader-error) ())
-
-(define-condition reader-eof-error (end-of-file)
- ((context :reader reader-eof-error-context :initarg :context))
- (:report
- (lambda (condition stream)
- (format stream
- "unexpected end of file on ~S ~A"
- (stream-error-stream condition)
- (reader-eof-error-context condition)))))
-\f
-;;;; restart definitions
-
-(define-condition abort-failure (control-error) ()
- (:report
- "An ABORT restart was found that failed to transfer control dynamically."))
-
-(defun abort (&optional condition)
- #!+sb-doc
- "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
- none exists."
- (invoke-restart (find-restart 'abort condition))
- ;; ABORT signals an error in case there was a restart named ABORT
- ;; that did not transfer control dynamically. This could happen with
- ;; RESTART-BIND.
- (error 'abort-failure))
-
-(defun muffle-warning (&optional condition)
- #!+sb-doc
- "Transfer control to a restart named MUFFLE-WARNING, signalling a
- CONTROL-ERROR if none exists."
- (invoke-restart (find-restart 'muffle-warning condition)))
-
-(macrolet ((define-nil-returning-restart (name args doc)
- #!-sb-doc (declare (ignore doc))
- `(defun ,name (,@args &optional condition)
- #!+sb-doc ,doc
- ;; FIXME: Perhaps this shared logic should be pulled out into
- ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
- (when (find-restart ',name condition)
- (invoke-restart ',name ,@args)))))
- (define-nil-returning-restart continue ()
- "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
- (define-nil-returning-restart store-value (value)
- "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
- none exists.")
- (define-nil-returning-restart use-value (value)
- "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
- none exists."))
-
-(/show0 "late-target-error.lisp end of file")
-
(defmacro-mundanely nth-value (n form)
#!+sb-doc
- "Evaluates FORM and returns the Nth value (zero based). This involves no
+ "Evaluate FORM and return the Nth value (zero based). This involves no
consing when N is a trivial constant integer."
(if (integerp n)
(let ((dummy-list nil)
`(sb!xc:proclaim ',x))
specs))))
-(defmacro-mundanely print-unreadable-object ((object stream
- &key type identity)
+(defmacro-mundanely print-unreadable-object ((object stream &key type identity)
&body body)
+ "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
+ with object-type prefix and object-identity suffix, and executing the
+ code in BODY to provide possible further output."
`(%print-unreadable-object ,object ,stream ,type ,identity
,(if body
`#'(lambda () ,@body)
nil)))
+
+(defmacro-mundanely ignore-errors (&rest forms)
+ #!+sb-doc
+ "Execute FORMS handling ERROR conditions, returning the result of the last
+ form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
+ `(handler-case (progn ,@forms)
+ (error (condition) (values nil condition))))
+++ /dev/null
-;;;; numeric things needed within the cross-compiler
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!KERNEL")
-
-;;; FIXME: This probably belongs in SB-INT instead of SB-KERNEL.
-;;; And couldn't it be limited to FIXNUM arguments?
-(defun positive-primep (x)
- #!+sb-doc
- "Returns T iff X is a positive prime integer."
- (declare (integer x))
- (if (<= x 5)
- (and (>= x 2) (/= x 4))
- (and (not (evenp x))
- (not (zerop (rem x 3)))
- (do ((q 6)
- (r 1)
- (inc 2 (logxor inc 6)) ;; 2,4,2,4...
- (d 5 (+ d inc)))
- ((or (= r 0) (> d q)) (/= r 0))
- (declare (fixnum inc))
- (multiple-value-setq (q r) (truncate x d))))))
-;;;; error-handling machinery for PARSE-DEFMACRO, separated from PARSE-DEFMACRO
-;;;; code itself because the happy path can be handled earlier in the bootstrap
-;;;; sequence than DEFINE-CONDITION can be, and because some of the error
-;;;; handling depends on SBCL extensions, while PARSE-DEFMACRO needs to run in
-;;;; the cross-compiler on the host Common Lisp
+;;;; error-handling machinery for PARSE-DEFMACRO, separated from
+;;;; PARSE-DEFMACRO code itself because the happy path can be handled
+;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be,
+;;;; and because some of the error handling depends on SBCL
+;;;; extensions, while PARSE-DEFMACRO needs to run in the
+;;;; cross-compiler on the host Common Lisp
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
--- /dev/null
+;;;; that part of the condition system which can or should come early
+;;;; (mostly macro-related)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+\f
+;;;; restarts
+
+;;; a list of lists of restarts
+(defvar *restart-clusters* '())
+
+;;; An ALIST (condition . restarts) which records the restarts currently
+;;; associated with Condition.
+(defvar *condition-restarts* ())
+
+(defun compute-restarts (&optional condition)
+ #!+sb-doc
+ "Return a list of all the currently active restarts ordered from most
+ recently established to less recently established. If Condition is
+ specified, then only restarts associated with Condition (or with no
+ condition) will be returned."
+ (let ((associated ())
+ (other ()))
+ (dolist (alist *condition-restarts*)
+ (if (eq (car alist) condition)
+ (setq associated (cdr alist))
+ (setq other (append (cdr alist) other))))
+ (collect ((res))
+ (dolist (restart-cluster *restart-clusters*)
+ (dolist (restart restart-cluster)
+ (when (and (or (not condition)
+ (member restart associated)
+ (not (member restart other)))
+ (funcall (restart-test-function restart) condition))
+ (res restart))))
+ (res))))
+
+(defstruct (restart (:copier nil))
+ name
+ function
+ report-function
+ interactive-function
+ (test-function #'(lambda (cond) (declare (ignore cond)) t)))
+(def!method print-object ((restart restart) stream)
+ (if *print-escape*
+ (print-unreadable-object (restart stream :type t :identity t))
+ (restart-report restart stream)))
+
+#!+sb-doc
+(setf (fdocumentation 'restart-name 'function)
+ "Returns the name of the given restart object.")
+
+(defun restart-report (restart stream)
+ (funcall (or (restart-report-function restart)
+ (let ((name (restart-name restart)))
+ #'(lambda (stream)
+ (if name (format stream "~S" name)
+ (format stream "~S" restart)))))
+ stream))
+
+(defmacro with-condition-restarts (condition-form restarts-form &body body)
+ #!+sb-doc
+ "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
+ Evaluates the Forms in a dynamic environment where the restarts in the list
+ Restarts-Form are associated with the condition returned by Condition-Form.
+ This allows FIND-RESTART, etc., to recognize restarts that are not related
+ to the error currently being debugged. See also RESTART-CASE."
+ (let ((n-cond (gensym)))
+ `(let ((*condition-restarts*
+ (cons (let ((,n-cond ,condition-form))
+ (cons ,n-cond
+ (append ,restarts-form
+ (cdr (assoc ,n-cond *condition-restarts*)))))
+ *condition-restarts*)))
+ ,@body)))
+
+(defmacro restart-bind (bindings &body forms)
+ #!+sb-doc
+ "Executes forms in a dynamic context where the given restart bindings are
+ in effect. Users probably want to use RESTART-CASE. When clauses contain
+ the same restart name, FIND-RESTART will find the first such clause."
+ `(let ((*restart-clusters*
+ (cons (list
+ ,@(mapcar #'(lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
+ report function: ~S"
+ binding))
+ `(make-restart
+ :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
+ *restart-clusters*)))
+ ,@forms))
+
+(defun find-restart (name &optional condition)
+ #!+sb-doc
+ "Returns the first restart named name. If name is a restart, it is returned
+ if it is currently active. If no such restart is found, nil is returned.
+ It is an error to supply nil as a name. If Condition is specified and not
+ NIL, then only restarts associated with that condition (or with no
+ condition) will be returned."
+ (find-if #'(lambda (x)
+ (or (eq x name)
+ (eq (restart-name x) name)))
+ (compute-restarts condition)))
+
+(defun invoke-restart (restart &rest values)
+ #!+sb-doc
+ "Calls the function associated with the given restart, passing any given
+ arguments. If the argument restart is not a restart or a currently active
+ non-nil restart name, then a control-error is signalled."
+ (let ((real-restart (find-restart restart)))
+ (unless real-restart
+ (error 'simple-control-error
+ :format-control "Restart ~S is not active."
+ :format-arguments (list restart)))
+ (apply (restart-function real-restart) values)))
+
+(defun invoke-restart-interactively (restart)
+ #!+sb-doc
+ "Calls the function associated with the given restart, prompting for any
+ necessary arguments. If the argument restart is not a restart or a
+ currently active non-nil restart name, then a control-error is signalled."
+ (let ((real-restart (find-restart restart)))
+ (unless real-restart
+ (error 'simple-control-error
+ :format-control "Restart ~S is not active."
+ :format-arguments (list restart)))
+ (apply (restart-function real-restart)
+ (let ((interactive-function
+ (restart-interactive-function real-restart)))
+ (if interactive-function
+ (funcall interactive-function)
+ '())))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
+;;; appropriate. Gross, but it's what the book seems to say...
+(defun munge-restart-case-expression (expression data)
+ (let ((exp (macroexpand expression)))
+ (if (consp exp)
+ (let* ((name (car exp))
+ (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
+ (if (member name '(signal error cerror warn))
+ (once-only ((n-cond `(coerce-to-condition
+ ,(first args)
+ (list ,@(rest args))
+ ',(case name
+ (warn 'simple-warning)
+ (signal 'simple-condition)
+ (t 'simple-error))
+ ',name)))
+ `(with-condition-restarts
+ ,n-cond
+ (list ,@(mapcar (lambda (da)
+ `(find-restart ',(nth 0 da)))
+ data))
+ ,(if (eq name 'cerror)
+ `(cerror ,(second expression) ,n-cond)
+ `(,name ,n-cond))))
+ expression))
+ expression)))
+) ; EVAL-WHEN
+
+;;; FIXME: I did a fair amount of rearrangement of this code in order to
+;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
+(defmacro restart-case (expression &body clauses)
+ #!+sb-doc
+ "(RESTART-CASE form
+ {(case-name arg-list {keyword value}* body)}*)
+ The form is evaluated in a dynamic context where the clauses have special
+ meanings as points to which control may be transferred (see INVOKE-RESTART).
+ When clauses contain the same case-name, FIND-RESTART will find the first
+ such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
+ macroexpands into such) then the signalled condition will be associated with
+ the new restarts."
+ (flet ((transform-keywords (&key report interactive test)
+ (let ((result '()))
+ (when report
+ (setq result (list* (if (stringp report)
+ `#'(lambda (stream)
+ (write-string ,report stream))
+ `#',report)
+ :report-function
+ result)))
+ (when interactive
+ (setq result (list* `#',interactive
+ :interactive-function
+ result)))
+ (when test
+ (setq result (list* `#',test
+ :test-function
+ result)))
+ (nreverse result)))
+ (parse-keyword-pairs (list keys)
+ (do ((l list (cddr l))
+ (k '() (list* (cadr l) (car l) k)))
+ ((or (null l) (not (member (car l) keys)))
+ (values (nreverse k) l)))))
+ (let ((block-tag (gensym))
+ (temp-var (gensym))
+ (data
+ (macrolet (;; KLUDGE: This started as an old DEFMACRO
+ ;; WITH-KEYWORD-PAIRS general utility, which was used
+ ;; only in this one place in the code. It was translated
+ ;; literally into this MACROLET in order to avoid some
+ ;; cross-compilation bootstrap problems. It would almost
+ ;; certainly be clearer, and it would certainly be more
+ ;; concise, to do a more idiomatic translation, merging
+ ;; this with the TRANSFORM-KEYWORDS logic above.
+ ;; -- WHN 19990925
+ (with-keyword-pairs ((names expression) &body forms)
+ (let ((temp (member '&rest names)))
+ (unless (= (length temp) 2)
+ (error "&REST keyword is ~:[missing~;misplaced~]."
+ temp))
+ (let* ((key-vars (ldiff names temp))
+ (keywords (mapcar #'keywordicate key-vars))
+ (key-var (gensym))
+ (rest-var (cadr temp)))
+ `(multiple-value-bind (,key-var ,rest-var)
+ (parse-keyword-pairs ,expression ',keywords)
+ (let ,(mapcar (lambda (var keyword)
+ `(,var (getf ,key-var
+ ,keyword)))
+ key-vars keywords)
+ ,@forms))))))
+ (mapcar (lambda (clause)
+ (with-keyword-pairs ((report interactive test
+ &rest forms)
+ (cddr clause))
+ (list (car clause) ;name=0
+ (gensym) ;tag=1
+ (transform-keywords :report report ;keywords=2
+ :interactive interactive
+ :test test)
+ (cadr clause) ;bvl=3
+ forms))) ;body=4
+ clauses))))
+ `(block ,block-tag
+ (let ((,temp-var nil))
+ (tagbody
+ (restart-bind
+ ,(mapcar #'(lambda (datum)
+ (let ((name (nth 0 datum))
+ (tag (nth 1 datum))
+ (keys (nth 2 datum)))
+ `(,name #'(lambda (&rest temp)
+ (setq ,temp-var temp)
+ (go ,tag))
+ ,@keys)))
+ data)
+ (return-from ,block-tag
+ ,(munge-restart-case-expression expression data)))
+ ,@(mapcan #'(lambda (datum)
+ (let ((tag (nth 1 datum))
+ (bvl (nth 3 datum))
+ (body (nth 4 datum)))
+ (list tag
+ `(return-from ,block-tag
+ (apply #'(lambda ,bvl ,@body)
+ ,temp-var)))))
+ data)))))))
+
+(defmacro with-simple-restart ((restart-name format-string
+ &rest format-arguments)
+ &body forms)
+ #!+sb-doc
+ "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
+ body)
+ If restart-name is not invoked, then all values returned by forms are
+ returned. If control is transferred to this restart, it immediately
+ returns the values nil and t."
+ `(restart-case
+ ;; If there's just one body form, then don't use PROGN. This allows
+ ;; RESTART-CASE to "see" calls to ERROR, etc.
+ ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
+ (,restart-name ()
+ :report (lambda (stream)
+ (format stream ,format-string ,@format-arguments))
+ (values nil t))))
+\f
+;;;; HANDLER-BIND
+
+(defvar *handler-clusters* nil)
+
+(defmacro handler-bind (bindings &body forms)
+ #!+sb-doc
+ "(HANDLER-BIND ( {(type handler)}* ) body)
+ Executes body in a dynamic context where the given handler bindings are
+ in effect. Each handler must take the condition being signalled as an
+ argument. The bindings are searched first to last in the event of a
+ signalled condition."
+ (let ((member-if (member-if (lambda (x)
+ (not (proper-list-of-length-p x 2)))
+ bindings)))
+ (when member-if
+ (error "ill-formed handler binding: ~S" (first member-if))))
+ `(let ((*handler-clusters*
+ (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
+ bindings))
+ *handler-clusters*)))
+ (multiple-value-prog1
+ (progn
+ ,@forms)
+ ;; Wait for any float exceptions.
+ #!+x86 (float-wait))))
+\f
+;;;; HANDLER-CASE
+
+(defmacro handler-case (form &rest cases)
+ "(HANDLER-CASE form
+ { (type ([var]) body) }* )
+ Execute FORM in a context with handlers established for the condition
+ types. A peculiar property allows type to be :no-error. If such a clause
+ occurs, and form returns normally, all its values are passed to this clause
+ as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
+ var specification."
+
+ ;; FIXME: This old SBCL code uses multiple nested THROW/CATCH
+ ;; operations, which seems like an ugly way to handle lexical
+ ;; nonlocal exit. MNA sbcl-devel 2001-07-17 provided a patch
+ ;; (included below this form, but #+NIL'ed out) to switch over to
+ ;; RETURN-FROM, which seems like basically a better idea.
+ ;; Unfortunately when using his patch, this reasonable code
+ ;; (DEFUN FOO1I ()
+ ;; (IF (NOT (IGNORE-ERRORS
+ ;; (MAKE-PATHNAME :HOST "FOO"
+ ;; :DIRECTORY "!BLA"
+ ;; :NAME "BAR")))
+ ;; (PRINT "OK")
+ ;; (ERROR "NOTUNLESSNOT")))
+ ;; fails (doing ERROR "NOTUNLESSNOT" when it should PRINT "OK"
+ ;; instead). I think this may not be a bug in MNA's patch, but
+ ;; instead in the rest of the compiler (e.g. handling of RETURN-FROM)
+ ;; but whatever the reason. (I noticed this problem in
+ ;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
+ ;; The problem also occurs at least in sbcl-0.6.12.59 and
+ ;; sbcl-0.6.13.) -- WHN
+ (let ((no-error-clause (assoc ':no-error cases)))
+ (if no-error-clause
+ (let ((normal-return (make-symbol "normal-return"))
+ (error-return (make-symbol "error-return")))
+ `(block ,error-return
+ (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+ (block ,normal-return
+ (return-from ,error-return
+ (handler-case (return-from ,normal-return ,form)
+ ,@(remove no-error-clause cases)))))))
+ (let ((var (gensym))
+ (outer-tag (gensym))
+ (inner-tag (gensym))
+ (tag-var (gensym))
+ (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+ cases)))
+ `(let ((,outer-tag (cons nil nil))
+ (,inner-tag (cons nil nil))
+ ,var ,tag-var)
+ ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
+ ,var ;ignoreable
+ (catch ,outer-tag
+ (catch ,inner-tag
+ (throw ,outer-tag
+ (handler-bind
+ ,(mapcar #'(lambda (annotated-case)
+ `(,(cadr annotated-case)
+ #'(lambda (temp)
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (setf ,tag-var
+ ',(car annotated-case))
+ (throw ,inner-tag nil))))
+ annotated-cases)
+ ,form)))
+ (case ,tag-var
+ ,@(mapcar #'(lambda (annotated-case)
+ (let ((body (cdddr annotated-case))
+ (varp (caddr annotated-case)))
+ `(,(car annotated-case)
+ ,@(if varp
+ `((let ((,(car varp) ,var))
+ ,@body))
+ body))))
+ annotated-cases)))))))
+ #+nil ; MNA's patched version -- see FIXME above
+ (let ((no-error-clause (assoc ':no-error cases)))
+ (if no-error-clause
+ (let ((normal-return (make-symbol "normal-return"))
+ (error-return (make-symbol "error-return")))
+ `(block ,error-return
+ (multiple-value-call (lambda ,@(cdr no-error-clause))
+ (block ,normal-return
+ (return-from ,error-return
+ (handler-case (return-from ,normal-return ,form)
+ ,@(remove no-error-clause cases)))))))
+ (let ((tag (gensym))
+ (var (gensym))
+ (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
+ cases)))
+ `(block ,tag
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ (tagbody
+ (handler-bind
+ ,(mapcar (lambda (annotated-case)
+ (list (cadr annotated-case)
+ `(lambda (temp)
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (go ,(car annotated-case)))))
+ annotated-cases)
+ (return-from ,tag
+ #!-x86 ,form
+ #!+x86 (multiple-value-prog1 ,form
+ ;; Need to catch FP errors here!
+ (float-wait))))
+ ,@(mapcan
+ (lambda (annotated-case)
+ (list (car annotated-case)
+ (let ((body (cdddr annotated-case)))
+ `(return-from
+ ,tag
+ ,(cond ((caddr annotated-case)
+ `(let ((,(caaddr annotated-case)
+ ,var))
+ ,@body))
+ ((not (cdr body))
+ (car body))
+ (t
+ `(progn ,@body)))))))
+ annotated-cases))))))))
+\f
+;;;; helper functions for restartable error handling which couldn't be
+;;;; defined 'til now 'cause they use the RESTART-CASE macro
+
+(defun assert-error (assertion places datum &rest arguments)
+ (let ((cond (if datum
+ (coerce-to-condition datum
+ arguments
+ 'simple-error
+ 'error)
+ (make-condition 'simple-error
+ :format-control "The assertion ~S failed."
+ :format-arguments (list assertion)))))
+ (restart-case
+ (error cond)
+ (continue ()
+ :report (lambda (stream)
+ (format stream "Retry assertion")
+ (if places
+ (format stream
+ " with new value~P for ~{~S~^, ~}."
+ (length places)
+ places)
+ (format stream ".")))
+ nil))))
+
+;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
+;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
+;;; and by CHECK-TYPE.
+(defun read-evaluated-form ()
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (list (eval (read *query-io*))))
+
+(defun check-type-error (place place-value type type-string)
+ (let ((cond (if type-string
+ (make-condition 'simple-type-error
+ :datum place
+ :expected-type type
+ :format-control
+ "The value of ~S is ~S, which is not ~A."
+ :format-arguments (list place
+ place-value
+ type-string))
+ (make-condition 'simple-type-error
+ :datum place
+ :expected-type type
+ :format-control
+ "The value of ~S is ~S, which is not of type ~S."
+ :format-arguments (list place
+ place-value
+ type)))))
+ (restart-case (error cond)
+ (store-value (value)
+ :report (lambda (stream)
+ (format stream "Supply a new value for ~S." place))
+ :interactive read-evaluated-form
+ value))))
+
+(defun case-body-error (name keyform keyform-value expected-type keys)
+ (restart-case
+ (error 'case-failure
+ :name name
+ :datum keyform-value
+ :expected-type expected-type
+ :possibilities keys)
+ (store-value (value)
+ :report (lambda (stream)
+ (format stream "Supply a new value for ~S." keyform))
+ :interactive read-evaluated-form
+ value)))
(defun primify (x)
(declare (type unsigned-byte x))
(do ((n (logior x 1) (+ n 2)))
- ((sb!sys:positive-primep n)
- n)))
+ ((positive-primep n) n)))
\f
;;;; info classes, info types, and type numbers, part I: what's needed
;;;; not only at compile time but also at run time
;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
-;;; so they're never seen at this level.)
+;;; so that they're never seen at this level.)
;;;
;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
;;; of non-top-level EVAL-WHENs is very simple:
:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
- (when e
- (ir1-convert-progn-body start cont forms)))
+ (ir1-convert-progn-body start cont (and e forms)))
(values))
;;; common logic for MACROLET and SYMBOL-MACROLET
("src/compiler/target/parms")
("src/code/early-array") ; needs "early-vm" numbers
- ("src/code/parse-body") ; on host for PARSE-BODY
- ("src/code/parse-defmacro") ; on host for PARSE-DEFMACRO
- ("src/code/extensions") ; on host for COLLECT, SYMBOLICATE, etc.
- ("src/compiler/deftype") ; on host for SB!XC:DEFTYPE
- ("src/code/early-alieneval") ; for vars needed both at build and run time
+ ("src/code/parse-body") ; on host for PARSE-BODY
+ ("src/code/parse-defmacro") ; on host for PARSE-DEFMACRO
+ ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc.
+ ("src/compiler/deftype") ; on host for SB!XC:DEFTYPE
+ ("src/code/early-alieneval") ; for vars needed both at build and run time
("src/code/specializable-array")
;; "maybe should be :BYTE-COMPILE T". Once the system is stable,
;; look into them.
- ("src/code/early-target-error" :not-host) ; maybe should be :BYTE-COMPILE T
- ;; FIXME: maybe should be called "target-error", with "late-target-error"
- ;; called "condition"
+ ("src/code/target-error" :not-host) ; maybe should be :BYTE-COMPILE T
;; a comment from classic CMU CL:
;; "These guys can supposedly come in any order, but not really.
("src/compiler/early-c")
("src/compiler/policy")
- ("src/code/numbers")
-
("src/code/typedefs")
;; ("src/code/defbangmacro" was here until sbcl-0.6.7.3.)
;; The definitions for CONDITION and CONDITION-CLASS depend on
;; SLOT-CLASS, defined in classes.lisp.
- ("src/code/late-target-error" :not-host) ; FIXME: maybe should be :BYTE-COMPILE T
+ ("src/code/condition" :not-host) ; FIXME: maybe should be :BYTE-COMPILE T
("src/compiler/generic/primtype")
("src/code/macroexpand")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; files which are only needed in the target system, and/or which are
- ;; only possible in the target system, and which depend in some way
- ;; (directly or indirectly) on stuff compiled as part of the compiler
+ ;; files which depend in some way (directly or indirectly) on stuff
+ ;; compiled as part of the compiler
+ ("src/code/late-extensions") ; needs condition system
("src/compiler/generic/target-core" :not-host) ; uses stuff from
; "compiler/generic/core"
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.28"
+"0.pre7.29"
projects / sbcl.git / commitdiff