(in-package "SB!C")
-(file-comment
- "$Header$")
-
(declaim (special *wild-type* *universal-type* *compiler-error-context*))
-;;; An INLINEP value describes how a function is called. The values have these
-;;; meanings:
-;;; NIL No declaration seen: do whatever you feel like, but don't dump
-;;; an inline expansion.
+;;; An INLINEP value describes how a function is called. The values
+;;; have these meanings:
+;;; NIL No declaration seen: do whatever you feel like, but don't
+;;; dump an inline expansion.
;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
-;;; :INLINE INLINE declaration seen: save expansion, expanding to it if
-;;; policy favors.
+;;; :INLINE INLINE declaration seen: save expansion, expanding to it
+;;; if policy favors.
;;; :MAYBE-INLINE
;;; Retain expansion, but only use it opportunistically.
(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
\f
-;;;; the POLICY macro
-
-(defparameter *policy-parameter-slots*
- '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety)
- (cspeed . cookie-cspeed) (brevity . cookie-brevity)
- (debug . cookie-debug)))
-
-;;; Find all the policy parameters which are actually mentioned in Stuff,
-;;; returning the names in a list. We assume everything is evaluated.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun find-used-parameters (stuff)
- (if (atom stuff)
- (if (assoc stuff *policy-parameter-slots*) (list stuff) ())
- (collect ((res () nunion))
- (dolist (arg (cdr stuff) (res))
- (res (find-used-parameters arg))))))
-) ; EVAL-WHEN
-
-;;; This macro provides some syntactic sugar for querying the settings of
-;;; the compiler policy parameters.
-(defmacro policy (node &rest conditions)
- #!+sb-doc
- "Policy Node Condition*
- Test whether some conditions apply to the current compiler policy for Node.
- Each condition is a predicate form which accesses the policy values by
- referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and
- DEBUG. The results of all the conditions are combined with AND and returned
- as the result.
-
- Node is a form which is evaluated to obtain the node which the policy is for.
- If Node is NIL, then we use the current policy as defined by *DEFAULT-COOKIE*
- and *CURRENT-COOKIE*. This option is only well defined during IR1
- conversion."
- (let* ((form `(and ,@conditions))
- (n-cookie (gensym))
- (binds (mapcar
- #'(lambda (name)
- (let ((slot (cdr (assoc name *policy-parameter-slots*))))
- `(,name (,slot ,n-cookie))))
- (find-used-parameters form))))
- `(let* ((,n-cookie (lexenv-cookie
- ,(if node
- `(node-lexenv ,node)
- '*lexenv*)))
- ,@binds)
- ,form)))
-\f
;;;; source-hacking defining forms
-;;; Passed to PARSE-DEFMACRO when we want compiler errors instead of real
-;;; errors.
+;;; to be passed to PARSE-DEFMACRO when we want compiler errors
+;;; instead of real errors
#!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
(defun convert-condition-into-compiler-error (datum &rest stuff)
(if (stringp datum)
(apply #'make-condition datum stuff)
datum))))
-;;; Parse DEFMACRO-style lambda-list, setting things up so that a
+;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
;;; compiler error happens if the syntax is invalid.
+;;;
+;;; Define a function that converts a special form or other magical
+;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda list.
+;;; START-VAR and CONT-VAR are bound to the start and result
+;;; continuations for the resulting IR1. KIND is the function kind to
+;;; associate with NAME.
(defmacro def-ir1-translator (name (lambda-list start-var cont-var
&key (kind :special-form))
&body body)
- #!+sb-doc
- "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)
- [Doc-String] Form*
- Define a function that converts a Special-Form or other magical thing into
- IR1. Lambda-List is a defmacro style lambda list. Start-Var and Cont-Var
- are bound to the start and result continuations for the resulting IR1.
- This keyword is defined:
- Kind
- The function kind to associate with Name (default :special-form)."
(let ((fn-name (symbolicate "IR1-CONVERT-" name))
(n-form (gensym))
(n-env (gensym)))
`((setf (symbol-function ',name)
(lambda (&rest rest)
(declare (ignore rest))
- (error "Can't FUNCALL the SYMBOL-FUNCTION of ~
- special forms.")))))))))
+ (error "can't FUNCALL the SYMBOL-FUNCTION of ~
+ special forms")))))))))
-;;; Similar to DEF-IR1-TRANSLATOR, except that we pass if the syntax is
-;;; invalid.
+;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
+;;; syntax is invalid.)
+;;;
+;;; Define a macro-like source-to-source transformation for the
+;;; function NAME. A source transform may "pass" by returning a
+;;; non-nil second value. If the transform passes, then the form is
+;;; converted as a normal function call. If the supplied arguments are
+;;; not compatible with the specified LAMBDA-LIST, then the transform
+;;; automatically passes.
+;;;
+;;; Source transforms may only be defined for functions. Source
+;;; transformation is not attempted if the function is declared
+;;; NOTINLINE. Source transforms should not examine their arguments.
+;;; If it matters how the function is used, then DEFTRANSFORM should
+;;; be used to define an IR1 transformation.
+;;;
+;;; If the desirability of the transformation depends on the current
+;;; OPTIMIZE parameters, then the POLICY macro should be used to
+;;; determine when to pass.
(defmacro def-source-transform (name lambda-list &body body)
- #!+sb-doc
- "Def-Source-Transform Name Lambda-List Form*
- Define a macro-like source-to-source transformation for the function Name.
- A source transform may \"pass\" by returning a non-nil second value. If the
- transform passes, then the form is converted as a normal function call. If
- the supplied arguments are not compatible with the specified lambda-list,
- then the transform automatically passes.
-
- Source-Transforms may only be defined for functions. Source transformation
- is not attempted if the function is declared Notinline. Source transforms
- should not examine their arguments. If it matters how the function is used,
- then Deftransform should be used to define an IR1 transformation.
-
- If the desirability of the transformation depends on the current Optimize
- parameters, then the Policy macro should be used to determine when to pass."
(let ((fn-name
(if (listp name)
(collect ((pieces))
,body))
(setf (info :function :source-transform ',name) #',fn-name)))))
+;;; Define a function that converts a use of (%PRIMITIVE NAME ..)
+;;; into Lisp code. LAMBDA-LIST is a DEFMACRO-style lambda list.
(defmacro def-primitive-translator (name lambda-list &body body)
- #!+sb-doc
- "DEF-PRIMITIVE-TRANSLATOR Name Lambda-List Form*
- Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
- code. Lambda-List is a DEFMACRO-style lambda list."
(let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
(n-form (gensym))
(n-env (gensym)))
(dolist (name names)
(let ((mask (cdr (assoc name alist))))
(unless mask
- (error "Unknown attribute name: ~S." name))
+ (error "unknown attribute name: ~S" name))
(res mask)))
(res)))
NAME-attributes attribute-name*
Return a set of the named attributes."
- (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
+ (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
(test-name (symbolicate name "-ATTRIBUTEP")))
(collect ((alist))
(do ((mask 1 (ash mask 1))
(alist (cons (car names) mask)))
`(progn
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant ,const-name ',(alist)))
+ (defparameter ,translations-name ',(alist)))
(defmacro ,test-name (attributes &rest attribute-names)
"Automagically generated boolean attribute test function. See
Def-Boolean-Attribute."
- `(logtest ,(compute-attribute-mask attribute-names ,const-name)
+ `(logtest ,(compute-attribute-mask attribute-names
+ ,translations-name)
(the attributes ,attributes)))
(define-setf-expander ,test-name (place &rest attributes
(error "multiple store variables for ~S" place))
(let ((newval (gensym))
(n-place (gensym))
- (mask (compute-attribute-mask attributes ,const-name)))
+ (mask (compute-attribute-mask attributes
+ ,translations-name)))
(values `(,@temps ,n-place)
`(,@values ,get)
`(,newval)
(defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
"Automagically generated boolean attribute creation function. See
Def-Boolean-Attribute."
- (compute-attribute-mask attribute-names ,const-name))))))
+ (compute-attribute-mask attribute-names ,translations-name))))))
;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
;;; And now for some gratuitous pseudo-abstraction...
;;; The second value is a list of all the arguments bound. We make the
;;; variables IGNORABLE so that we don't have to manually declare them
;;; Ignore if their only purpose is to make the syntax work.
-(declaim (ftype (function (list list symbol t) list) parse-deftransform))
(defun parse-deftransform (lambda-list body args error-form)
(multiple-value-bind (req opt restp rest keyp keys allowp)
(parse-lambda-list lambda-list)
(dolist (spec keys)
(if (or (atom spec) (atom (first spec)))
(let* ((var (if (atom spec) spec (first spec)))
- (key (intern (symbol-name var) "KEYWORD")))
+ (key (keywordicate var)))
(vars var)
(binds `(,var (find-keyword-continuation ,n-keys ,key)))
(keywords key))
`(<= ,min-args ,n-length))
,@(when keyp
(if allowp
- `((check-keywords-constant ,n-keys))
+ `((check-key-args-constant ,n-keys))
`((check-transform-keys ,n-keys ',(keywords))))))
,error-form)
(let ,(binds)
\f
;;;; DEFTRANSFORM
-;;; Parse the lambda-list and generate code to test the policy and
-;;; automatically create the result lambda.
+;;; Define an IR1 transformation for NAME. An IR1 transformation
+;;; computes a lambda that replaces the function variable reference
+;;; for the call. A transform may pass (decide not to transform the
+;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST
+;;; both determines how the current call is parsed and specifies the
+;;; LAMBDA-LIST for the resulting lambda.
+;;;
+;;; We parse the call and bind each of the lambda-list variables to
+;;; the continuation which represents the value of the argument. When
+;;; parsing the call, we ignore the defaults, and always bind the
+;;; variables for unsupplied arguments to NIL. If a required argument
+;;; is missing, an unknown keyword is supplied, or an argument keyword
+;;; is not a constant, then the transform automatically passes. The
+;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at
+;;; transformation time, rather than to the variables of the resulting
+;;; lambda. Bound-but-not-referenced warnings are suppressed for the
+;;; lambda-list variables. The DOC-STRING is used when printing
+;;; efficiency notes about the defined transform.
+;;;
+;;; Normally, the body evaluates to a form which becomes the body of
+;;; an automatically constructed lambda. We make LAMBDA-LIST the
+;;; lambda-list for the lambda, and automatically insert declarations
+;;; of the argument and result types. If the second value of the body
+;;; is non-null, then it is a list of declarations which are to be
+;;; inserted at the head of the lambda. Automatic lambda generation
+;;; may be inhibited by explicitly returning a lambda from the body.
+;;;
+;;; The ARG-TYPES and RESULT-TYPE are used to create a function type
+;;; which the call must satisfy before transformation is attempted.
+;;; The function type specifier is constructed by wrapping (FUNCTION
+;;; ...) around these values, so the lack of a restriction may be
+;;; specified by omitting the argument or supplying *. The argument
+;;; syntax specified in the ARG-TYPES need not be the same as that in
+;;; the LAMBDA-LIST, but the transform will never happen if the
+;;; syntaxes can't be satisfied simultaneously. If there is an
+;;; existing transform for the same function that has the same type,
+;;; then it is replaced with the new definition.
+;;;
+;;; These are the legal keyword options:
+;;; :RESULT - A variable which is bound to the result continuation.
+;;; :NODE - A variable which is bound to the combination node for the call.
+;;; :POLICY - A form which is supplied to the POLICY macro to determine
+;;; whether this transformation is appropriate. If the result
+;;; is false, then the transform automatically gives up.
+;;; :EVAL-NAME
+;;; - The name and argument/result types are actually forms to be
+;;; evaluated. Useful for getting closures that transform similar
+;;; functions.
+;;; :DEFUN-ONLY
+;;; - Don't actually instantiate a transform, instead just DEFUN
+;;; Name with the specified transform definition function. This
+;;; may be later instantiated with %DEFTRANSFORM.
+;;; :IMPORTANT
+;;; - If supplied and non-NIL, note this transform as ``important,''
+;;; which means efficiency notes will be generated when this
+;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
+;;; INHIBIT-WARNINGS>SPEED).
+;;; :WHEN {:NATIVE | :BYTE | :BOTH}
+;;; - Indicates whether this transform applies to native code,
+;;; byte-code or both (default :native.)
(defmacro deftransform (name (lambda-list &optional (arg-types '*)
(result-type '*)
&key result policy node defun-only
eval-name important (when :native))
&body body-decls-doc)
- #!+sb-doc
- "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
- Declaration* [Doc-String] Form*
- Define an IR1 transformation for NAME. An IR1 transformation computes a
- lambda that replaces the function variable reference for the call. A
- transform may pass (decide not to transform the call) by calling the
- GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST both determines how the
- current call is parsed and specifies the LAMBDA-LIST for the resulting
- lambda.
-
- We parse the call and bind each of the lambda-list variables to the
- continuation which represents the value of the argument. When parsing
- the call, we ignore the defaults, and always bind the variables for
- unsupplied arguments to NIL. If a required argument is missing, an
- unknown keyword is supplied, or an argument keyword is not a constant,
- then the transform automatically passes. The DECLARATIONS apply to the
- bindings made by DEFTRANSFORM at transformation time, rather than to
- the variables of the resulting lambda. Bound-but-not-referenced
- warnings are suppressed for the lambda-list variables. The DOC-STRING
- is used when printing efficiency notes about the defined transform.
-
- Normally, the body evaluates to a form which becomes the body of an
- automatically constructed lambda. We make LAMBDA-LIST the lambda-list
- for the lambda, and automatically insert declarations of the argument
- and result types. If the second value of the body is non-null, then it
- is a list of declarations which are to be inserted at the head of the
- lambda. Automatic lambda generation may be inhibited by explicitly
- returning a lambda from the body.
-
- The ARG-TYPES and RESULT-TYPE are used to create a function type
- which the call must satisfy before transformation is attempted. The
- function type specifier is constructed by wrapping (FUNCTION ...)
- around these values, so the lack of a restriction may be specified by
- omitting the argument or supplying *. The argument syntax specified in
- the ARG-TYPES need not be the same as that in the LAMBDA-LIST, but the
- transform will never happen if the syntaxes can't be satisfied
- simultaneously. If there is an existing transform for the same
- function that has the same type, then it is replaced with the new
- definition.
-
- These are the legal keyword options:
- :Result - A variable which is bound to the result continuation.
- :Node - A variable which is bound to the combination node for the call.
- :Policy - A form which is supplied to the POLICY macro to determine whether
- this transformation is appropriate. If the result is false, then
- the transform automatically passes.
- :Eval-Name
- - The name and argument/result types are actually forms to be
- evaluated. Useful for getting closures that transform similar
- functions.
- :Defun-Only
- - Don't actually instantiate a transform, instead just DEFUN
- Name with the specified transform definition function. This may
- be later instantiated with %DEFTRANSFORM.
- :Important
- - If supplied and non-NIL, note this transform as ``important,''
- which means efficiency notes will be generated when this
- transform fails even if brevity=speed (but not if brevity>speed)
- :When {:Native | :Byte | :Both}
- - Indicates whether this transform applies to native code,
- byte-code or both (default :native.)"
-
(when (and eval-name defun-only)
(error "can't specify both DEFUN-ONLY and EVAL-NAME"))
(multiple-value-bind (body decls doc) (parse-body body-decls-doc)
;;;
;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
;;; out some way to keep it from appearing in the target system.
+;;;
+;;; Declare the function NAME to be a known function. We construct a
+;;; type specifier for the function by wrapping (FUNCTION ...) around
+;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list
+;;; of boolean attributes of the function. These attributes are
+;;; meaningful here:
+;;;
+;;; CALL
+;;; May call functions that are passed as arguments. In order
+;;; to determine what other effects are present, we must find
+;;; the effects of all arguments that may be functions.
+;;;
+;;; UNSAFE
+;;; May incorporate arguments in the result or somehow pass
+;;; them upward.
+;;;
+;;; UNWIND
+;;; May fail to return during correct execution. Errors
+;;; are O.K.
+;;;
+;;; ANY
+;;; The (default) worst case. Includes all the other bad
+;;; things, plus any other possible bad thing.
+;;;
+;;; FOLDABLE
+;;; May be constant-folded. The function has no side effects,
+;;; but may be affected by side effects on the arguments. E.g.
+;;; SVREF, MAPC.
+;;;
+;;; FLUSHABLE
+;;; May be eliminated if value is unused. The function has
+;;; no side effects except possibly CONS. If a function is
+;;; defined to signal errors, then it is not flushable even
+;;; if it is movable or foldable.
+;;;
+;;; MOVABLE
+;;; May be moved with impunity. Has no side effects except
+;;; possibly CONS, and is affected only by its arguments.
+;;;
+;;; PREDICATE
+;;; A true predicate likely to be open-coded. This is a
+;;; hint to IR1 conversion that it should ensure calls always
+;;; appear as an IF test. Not usually specified to DEFKNOWN,
+;;; since this is implementation dependent, and is usually
+;;; automatically set by the DEFINE-VOP :CONDITIONAL option.
+;;;
+;;; NAME may also be a list of names, in which case the same
+;;; information is given to all the names. The keywords specify the
+;;; initial values for various optimizers that the function might
+;;; have.
(defmacro defknown (name arg-types result-type &optional (attributes '(any))
&rest keys)
- #!+sb-doc
- "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*
- Declare the function Name to be a known function. We construct a type
- specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
- and Result-Type. Attributes is an unevaluated list of boolean
- attributes of the function. These attributes are meaningful here:
- call
- May call functions that are passed as arguments. In order
- to determine what other effects are present, we must find
- the effects of all arguments that may be functions.
-
- unsafe
- May incorporate arguments in the result or somehow pass
- them upward.
-
- unwind
- May fail to return during correct execution. Errors
- are O.K.
-
- any
- The (default) worst case. Includes all the other bad
- things, plus any other possible bad thing.
-
- foldable
- May be constant-folded. The function has no side effects,
- but may be affected by side effects on the arguments. E.g.
- SVREF, MAPC.
-
- flushable
- May be eliminated if value is unused. The function has
- no side effects except possibly CONS. If a function is
- defined to signal errors, then it is not flushable even
- if it is movable or foldable.
-
- movable
- May be moved with impunity. Has no side effects except
- possibly CONS,and is affected only by its arguments.
-
- predicate
- A true predicate likely to be open-coded. This is a
- hint to IR1 conversion that it should ensure calls always
- appear as an IF test. Not usually specified to Defknown,
- since this is implementation dependent, and is usually
- automatically set by the Define-VOP :Conditional option.
-
- Name may also be a list of names, in which case the same information
- is given to all the names. The keywords specify the initial values
- for various optimizers that the function might have."
(when (and (intersection attributes '(any call unwind))
(intersection attributes '(movable)))
- (error "Function cannot have both good and bad attributes: ~S" attributes))
+ (error "function cannot have both good and bad attributes: ~S" attributes))
`(%defknown ',(if (and (consp name)
(not (eq (car name) 'setf)))
attributes))
,@keys))
-;;; Create a function which parses combination args according to
-;;; LAMBDA-LIST, optionally storing it in a FUNCTION-INFO slot.
+;;; Create a function which parses combination args according to WHAT
+;;; and LAMBDA-LIST, where WHAT is either a function name or a list
+;;; (FUNCTION-NAME KIND) and does some KIND of optimization.
+;;;
+;;; The FUNCTION-NAME must name a known function. LAMBDA-LIST is used
+;;; to parse the arguments to the combination as in DEFTRANSFORM. If
+;;; the argument syntax is invalid or there are non-constant keys,
+;;; then we simply return NIL.
+;;;
+;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible
+;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If
+;;; a symbol is specified instead of a (FUNCTION KIND) list, then we
+;;; just do a DEFUN with the symbol as its name, and don't do anything
+;;; with the definition. This is useful for creating optimizers to be
+;;; passed by name to DEFKNOWN.
+;;;
+;;; If supplied, NODE-VAR is bound to the combination node being
+;;; optimized. If additional VARS are supplied, then they are used as
+;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
+;;; methods are passed an additional POLICY argument, and IR2-CONVERT
+;;; methods are passed an additional IR2-BLOCK argument.
(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
&rest vars)
&body body)
- #!+sb-doc
- "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
- Declaration* Form*
- Define some Kind of optimizer for the named Function. Function must be a
- known function. Lambda-List is used to parse the arguments to the
- combination as in Deftransform. If the argument syntax is invalid or there
- are non-constant keys, then we simply return NIL.
-
- The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are
- DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is
- specified instead of a (Function Kind) list, then we just do a DEFUN with the
- symbol as its name, and don't do anything with the definition. This is
- useful for creating optimizers to be passed by name to DEFKNOWN.
-
- If supplied, Node-Var is bound to the combination node being optimized. If
- additional Vars are supplied, then they are used as the rest of the optimizer
- function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY
- argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK
- argument."
-
(let ((name (if (symbolp what) what
(symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
\f
;;;; IR groveling macros
+;;; Iterate over the blocks in a component, binding BLOCK-VAR to each
+;;; block in turn. The value of ENDS determines whether to iterate
+;;; over dummy head and tail blocks:
+;;; NIL -- Skip Head and Tail (the default)
+;;; :HEAD -- Do head but skip tail
+;;; :TAIL -- Do tail but skip head
+;;; :BOTH -- Do both head and tail
+;;;
+;;; If supplied, RESULT-FORM is the value to return.
(defmacro do-blocks ((block-var component &optional ends result) &body body)
#!+sb-doc
- "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
- Iterate over the blocks in a component, binding Block-Var to each block in
- turn. The value of Ends determines whether to iterate over dummy head and
- tail blocks:
- NIL -- Skip Head and Tail (the default)
- :Head -- Do head but skip tail
- :Tail -- Do tail but skip head
- :Both -- Do both head and tail
-
- If supplied, Result-Form is the value to return."
(unless (member ends '(nil :head :tail :both))
- (error "Losing Ends value: ~S." ends))
+ (error "losing ENDS value: ~S" ends))
(let ((n-component (gensym))
(n-tail (gensym)))
`(let* ((,n-component ,component)
"Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
Like Do-Blocks, only iterate over the blocks in reverse order."
(unless (member ends '(nil :head :tail :both))
- (error "Losing Ends value: ~S." ends))
+ (error "losing ENDS value: ~S" ends))
(let ((n-component (gensym))
(n-head (gensym)))
`(let* ((,n-component ,component)
,(if restart-p
`(cond
((eq (continuation-block ,cont-var) ,n-block)
- (assert (continuation-next ,cont-var))
+ (aver (continuation-next ,cont-var))
(continuation-next ,cont-var))
(t
(let ((start (block-start ,n-block)))
(values (cdr ,n-res) t)
(values nil nil))))
\f
-;;; These functions are called by the expansion of the DEFPRINTER
-;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream &optional t) (values))
- defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'princ name value stream))
-(defun defprinter-prinx (prinx name value stream)
- (declare (type function prinx))
- (write-char #\space stream)
- (when *print-pretty*
- (pprint-newline :linear stream))
- (format stream ":~A " name)
- (funcall prinx value stream)
- (values))
-
-;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT.
-;;
-;; 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 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)
- (flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
- (collect ((prints))
- (dolist (slot-desc slot-descs)
- (if (atom slot-desc)
- (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream))
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (prints
- `(let ((,sname ,(sref sname)))
- (when ,test
- ,@(or (stuff)
- `((defprinter-prin1 ',sname ,sname
- stream)))))))
- (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 DEFPRINTER option: ~S" (first option)))))))))
-
- `(def!method print-object ((structure ,name) stream)
- (print-unreadable-object (structure stream :type t)
- (pprint-logical-block (stream nil)
- ;;(pprint-indent :current 2 stream)
- ,@(prints)))))))
-\f
-;;;; the Event statistics/trace utility
+;;;; the EVENT statistics/trace utility
;;; FIXME: This seems to be useful for troubleshooting and
;;; experimentation, not for ordinary use, so it should probably
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defstruct event-info
+(defstruct (event-info (:copier nil))
;; The name of this event.
(name (required-argument) :type symbol)
;; The string rescribing this event.
Next. Key, Test and Test-Not are the same as for generic sequence
functions."
(when (and test-p not-p)
- (error "It's silly to supply both :Test and :Test-Not."))
+ (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
(if not-p
(do ((current list (funcall next current)))
((null current) nil)
linked by the accessor function Next. Key, Test and Test-Not are the same as
for generic sequence functions."
(when (and test-p not-p)
- (error "Silly to supply both :Test and :Test-Not."))
+ (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
(if not-p
(do ((current list (funcall next current))
(i 0 (1+ i)))
(defmacro position-or-lose (&rest args)
`(or (position ,@args)
- (error "Shouldn't happen?")))
+ (error "shouldn't happen?")))