(,bodyfunc))))))))
(export 'parse-body)
-(defun parse-body (body)
+(defun parse-body (body &key (docp t) (declp t))
"Parse the BODY into a docstring, declarations and the body forms.
These are returned as three lists, so that they can be spliced into a
macro expansion easily. The declarations are consolidated into a single
- `declare' form."
+ `declare' form. If DOCP is nil then a docstring is not permitted; if
+ DECLP is nil, then declarations are not permitted."
(let ((decls nil)
(doc nil))
(loop
(cond ((null body) (return))
- ((and (consp (car body)) (eq (caar body) 'declare))
+ ((and declp (consp (car body)) (eq (caar body) 'declare))
(setf decls (append decls (cdr (pop body)))))
- ((and (stringp (car body)) (not doc) (cdr body))
+ ((and docp (stringp (car body)) (not doc) (cdr body))
(setf doc (pop body)))
(t (return))))
(values (and doc (list doc))
((candidates :initarg :candidates
:reader merge-error-candidates))
(:documentation
- "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
+ "Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
(format stream "Merge inconsistency: failed to decide among ~A."
(merge-error-candidates condition)))))
(defun merge-lists (lists &key pick (test #'eql))
"Return a merge of the given LISTS.
- The resulting LIST contains the items of the given lists, with duplicates
+ The resulting list contains the items of the given LISTS, with duplicates
removed. The order of the resulting list is consistent with the orders of
the input LISTS in the sense that if A precedes B in some input list then
A will also precede B in the output list. If the lists aren't consistent
If there is an ambiguity at any point -- i.e., a choice between two or
more possible next items to emit -- then PICK is called to arbitrate.
PICK is called with two arguments: the list of candidate next items, and
- the current output list. It should return one of the candidate items. If
- PICK is omitted then an arbitrary choice is made.
+ the current output list. It should return one of the candidate items.
+ The order of the candidates in the list given to the PICK function
+ reflects their order in the input LISTS: item A will precede item B in the
+ candidates list if and only if an occurrence of A appears in an earlier
+ input list than any occurrence of item B. (This completely determines the
+ order of the candidates: it is not possible that two candidates appear in
+ the same input list would resolve the ambiguity between them.) If PICK is
+ omitted then the item chosen is the one appearing in the earliest of the
+ input lists: i.e., effectively, the default PICK function is
+
+ (lambda (candidates output-so-far)
+ (declare (ignore output-so-far))
+ (car candidates))
The primary use of this function is in computing class precedence lists.
By building the input lists and selecting the PICK function appropriately,
a variety of different CPL algorithms can be implemented."
- (do* ((lb (make-list-builder)))
- ((null lists) (lbuild-list lb))
+ (do ((lb (make-list-builder)))
+ ((null lists) (lbuild-list lb))
;; The candidate items are the ones at the front of the input lists.
;; Gather them up, removing duplicates. If a candidate is somewhere in
;; one of the other lists other than at the front then we reject it. If
;; we've just rejected everything, then we can make no more progress and
;; the input lists were inconsistent.
- (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
+ (let* ((candidates (delete-duplicates (mapcar #'car lists)
+ :test test :from-end t))
(leasts (remove-if (lambda (item)
(some (lambda (list)
(member item (cdr list) :test test))
(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)))
+ (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 ,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)))
+ ,@decls
+ (tagbody ,@body)))
(etypecase ,seq
(vector
(let ((,endvar (or ,end (length ,seq))))
(list
(if ,end
,(loopguts t t end)
- ,(loopguts indexvar t nil))))))))))
+ ,(loopguts indexvar t nil)))))))))))
;;;--------------------------------------------------------------------------
;;; Structure accessor hacks.
Sets up the named SLOT of CLASS to establish its value as the implicit
progn BODY, by defining an appropriate method on `slot-unbound'."
- (with-gensyms (classvar slotvar)
- `(defmethod slot-unbound
- (,classvar (,instance ,class) (,slotvar (eql ',slot)))
- (declare (ignore ,classvar))
- (setf (slot-value ,instance ',slot) (progn ,@body)))))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ (with-gensyms (classvar slotvar)
+ `(defmethod slot-unbound
+ (,classvar (,instance ,class) (,slotvar (eql ',slot)))
+ ,@docs ,@decls
+ (declare (ignore ,classvar))
+ (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff