- (once-only (:environment env seq start end)
- (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
-
- (flet ((loopguts (indexp listp endvar)
- ;; Build a DO-loop to do what we want.
- (let* ((do-vars nil)
- (end-condition (if endvar
- `(>= ,ivar ,endvar)
- `(endp ,seq)))
- (item (if listp
- `(car ,seq)
- `(aref ,seq ,ivar)))
- (body-call `(,bodyfunc ,item)))
- (when listp
- (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
- do-vars))
- (when indexp
- (push `(,ivar ,start (1+ ,ivar)) do-vars))
- (when indexvar
- (setf body-call (append body-call (list ivar))))
- `(do ,do-vars (,end-condition) ,body-call))))
-
- `(block nil
- (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
- (tagbody ,@body)))
- (etypecase ,seq
- (vector
- (let ((,endvar (or ,end (length ,seq))))
- ,(loopguts t nil endvar)))
- (list
- (if ,end
- ,(loopguts t t end)
- ,(loopguts indexvar t nil))))))))))
+ (once-only (:environment env start end)
+ (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-")
+ (endvar "END-") (bodyfunc "BODY-"))
+ (multiple-value-bind (docs decls body) (parse-body body :docp nil)
+ (declare (ignore docs))
+
+ (flet ((loopguts (indexp listp endvar)
+ ;; Build a DO-loop to do what we want.
+ (let* ((do-vars nil)
+ (end-condition (if endvar
+ `(>= ,ivar ,endvar)
+ `(endp ,seqvar)))
+ (item (if listp
+ `(car ,seqvar)
+ `(aref ,seqvar ,ivar)))
+ (body-call `(,bodyfunc ,item)))
+ (when listp
+ (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar))
+ do-vars))
+ (when indexp
+ (push `(,ivar ,start (1+ ,ivar)) do-vars))
+ (when indexvar
+ (setf body-call (append body-call (list ivar))))
+ `(do ,do-vars (,end-condition) ,body-call))))
+
+ `(block nil
+ (let ((,seqvar ,seq))
+ (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+ ,@decls
+ (tagbody ,@body)))
+ (etypecase ,seqvar
+ (vector
+ (let ((,endvar (or ,end (length ,seqvar))))
+ ,(loopguts t nil endvar)))
+ (list
+ (if ,end
+ ,(loopguts t t end)
+ ,(loopguts indexvar t nil))))))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Structure accessor hacks.
+
+(export 'define-access-wrapper)
+(defmacro define-access-wrapper (from to &key read-only)
+ "Make (FROM THING) work like (TO THING).
+
+ If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like
+ (setf (TO THING) VALUE).
+
+ This is mostly useful for structure slot accessors where the slot has to
+ be given an unpleasant name to avoid it being an external symbol."
+ `(progn
+ (declaim (inline ,from ,@(and (not read-only) `((setf ,from)))))
+ (defun ,from (object)
+ (,to object))
+ ,@(and (not read-only)
+ `((defun (setf ,from) (value object)
+ (setf (,to object) value))))))
+
+;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+ &key allow-pointless-arguments)
+ "Return the condition designated by DATUM and ARGUMENTS.
+
+ DATUM and ARGUMENTS together are a `condition designator' of (some
+ supertype of) DEFAULT-TYPE; return the condition so designated."
+ (typecase datum
+ (condition
+ (unless (or allow-pointless-arguments (null arguments))
+ (error "Argument list provided with specific condition"))
+ datum)
+ (symbol
+ (apply #'make-condition datum arguments))
+ ((or string function)
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error "Unexpected condition designator datum ~S" datum))))
+
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+ ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+ "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+ Find an active restart designated by RESTART; if CONDITION is not nil,
+ then restrict the search to restarts associated with CONDITION, and
+ restarts not associated with any condition. If no such restart is found
+ then signal an error of type `control-error'; otherwise invoke the restart
+ with the given ARGUMENTS."
+ (apply #'invoke-restart
+ (or (find-restart restart condition)
+ (error 'simple-control-error
+ :format-control "~:[Restart ~S is not active~;~
+ No active `~(~A~)' restart~]~
+ ~@[ for condition ~S~]"
+ :format-arguments (list (symbolp restart)
+ restart
+ condition)))
+ arguments))
+
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+ ((%enclosed-condition :initarg :condition :type condition
+ :reader enclosed-condition))
+ (:documentation
+ "A condition which encloses another condition
+
+ This is useful if one wants to attach additional information to an
+ existing condition. The enclosed condition can be obtained using the
+ `enclosed-condition' function.")
+ (:report (lambda (condition stream)
+ (princ (enclosed-condition condition) stream))))
+
+(export 'information)
+(define-condition information (condition)
+ ())
+
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+ ())
+
+(export 'info)
+(defun info (datum &rest arguments)
+ "Report some useful diagnostic information.
+
+ Establish a simple restart named `noted', and signal the condition of type
+ `information' designated by DATUM and ARGUMENTS. Return non-nil if the
+ restart was invoked, otherwise nil."
+ (restart-case
+ (signal (designated-condition 'simple-information datum arguments))
+ (noted () :report "Noted." t)))
+
+(export 'noted)
+(defun noted (&optional condition)
+ "Invoke the `noted' restart, possibly associated with the given CONDITION."
+ (invoke-associated-restart 'noted condition))
+
+(export 'promiscuous-cerror)
+(defun promiscuous-cerror (continue-string datum &rest arguments)
+ "Like standard `cerror', but robust against sneaky changes of conditions.
+
+ It seems that `cerror' (well, at least the version in SBCL) is careful
+ to limit its restart to the specific condition it signalled. But that's
+ annoying, because `sod-parser:with-default-error-location' substitutes
+ different conditions carrying the error-location information."
+ (restart-case (apply #'error datum arguments)
+ (continue ()
+ :report (lambda (stream)
+ (apply #'format stream continue-string datum arguments))
+ nil)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+ (apply #'promiscuous-cerror "Continue" datum arguments))