;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
"If COND, evaluate BODY as a progn with `it' bound to the value of COND."
`(let ((it ,cond)) (when it ,@body)))
+(export 'aand)
+(defmacro aand (&rest forms)
+ "Like `and', but anaphoric.
+
+ Each FORM except the first is evaluated with `it' bound to the value of
+ the previous one. If there are no forms, then the result it `t'; if there
+ is exactly one, then wrapping it in `aand' is pointless."
+ (labels ((doit (first rest)
+ (if (null rest)
+ first
+ `(let ((it ,first))
+ (if it ,(doit (car rest) (cdr rest)) nil)))))
+ (if (null forms)
+ 't
+ (doit (car forms) (cdr forms)))))
+
(export 'acond)
(defmacro acond (&body clauses &environment env)
"Like COND, but with `it' bound to the value of the condition.
(:documentation
"Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
- (format stream "Merge inconsistency: failed to decide among ~A."
+ (format stream "Merge inconsistency: failed to decide between ~
+ ~{~#[~;~A~;~A and ~A~:;~
+ ~@{~A, ~#[~;and ~A~]~}~]~}"
(merge-error-candidates condition)))))
(export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
"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
(e.g., some list contains A followed by B, and another contains B followed
- by A) then an error of type `inconsistent-merge-error' is signalled.
+ by A) then an error of type `inconsistent-merge-error' is signalled. The
+ offending items are filtered for presentation through the PRESENT function
+ before being attached to the condition, so as to produce a more useful
+ diagnostic message.
Item equality is determined by TEST.
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,
;; 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))
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates candidates))
+ :candidates (mapcar present candidates)))
((null (cdr leasts))
(car leasts))
(pick
(,print))
(,print)))))
+(export 'print-ugly-stuff)
+(defun print-ugly-stuff (stream func)
+ "Print not-pretty things to the stream underlying STREAM.
+
+ The Lisp pretty-printing machinery, notably `pprint-logical-block', may
+ interpose additional streams between its body and the original target
+ stream. This makes it difficult to make use of the underlying stream's
+ special features, whatever they might be."
+
+ ;; This is unpleasant. Hacky hacky.
+ #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream)
+ (let ((target (sb-pretty::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ #+cmu '(if (typep stream 'pp:pretty-stream)
+ (let ((target (pp::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ '(funcall func stream)))
+
;;;--------------------------------------------------------------------------
;;; Iteration macros.
(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))))
+
+;;;--------------------------------------------------------------------------
;;; CLOS hacking.
(export 'default-slot)
(,classvar (,instance ,class) (,slotvar (eql ',slot)))
,@docs ,@decls
(declare (ignore ,classvar))
- (setf (slot-value ,instance ',slot) (progn ,@body))))))
+ (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff