From: Tobias C. Rittweiler
Subject: Request for comments: WITH-DETACHED-BINDINGS
Date:
Message-ID: <87k6digl40.fsf@GNUlot.localnet>
In my experience, one reason for not writing very descriptive error
messages is that those tend to be rather long, and strings spanning
several lines are distracting from the actual flow of function when
they're sprinkled within the code directly. Naturally, they make a
function rather long, too. (Note: I'm not saying that it's /the/ reason,
just one. The main reason is probably that it's usually so frigging
boring. :-))
I thought about a possible construct that would alleviate at least the
disturbance factor, and I came up with WITH-DETACHED-BINDINGS:
WITH-DETACHED-BINDINGS (identifier*)
form*
(identifier lambda-list local-form*)*
It's essentially an FLET where the body and the binding definitions are
transposed, i.e. FORM is evaluated in a context where each IDENTIFIER is
assigned to a function as constituted by LAMBDA-LIST and LOCAL-FORM.
The purpose is that the flow of function (the FORMs) is seperated from
the actual error invocations that sit in the LOCAL-FORMs wherein it's
now possible to write very long messages without messing up the actual
code.
A stupid example follows:
(defun really-dingdong (a b)
(with-detached-bindings (error-since-bigger error-since-smaller)
(cond ((> a b) (error-since-bigger a b))
((< a b) (error-since-smaller a b))
(t 'EQUAL))
(error-since-bigger (bigger smaller)
(error "FAILED -- ~A is bigger than ~A." bigger smaller))
(error-since-smaller (smaller bigger)
(error "FAILED -- ~A is smaller than ~A." smaller bigger))))
Of course, that doesn't show very much because on one hand the messages
aren't any long and on the other hand, the function itself is short as
well. Anyway, REALLY-DINGDONG gets expanded into the following:
(FLET ((ERROR-SINCE-BIGGER (BIGGER SMALLER)
(ERROR "FAILED -- ~A is bigger than ~A." BIGGER SMALLER))
(ERROR-SINCE-SMALLER (SMALLER BIGGER)
(ERROR "FAILED -- ~A is smaller than ~A." SMALLER BIGGER)))
(DECLARE (INLINE ERROR-SINCE-BIGGER ERROR-SINCE-SMALLER))
(COND ((> A B) (ERROR-SINCE-BIGGER A B))
((< A B) (ERROR-SINCE-SMALLER A B))
(T 'EQUAL)))
A slightly not-as-contrived example will follow below, but first, here's
how I implemented it: (as you will see, it requires ITERATE and
ONCE-ONLY. It's also recommended to resize your reader's window to be
able to display lines with up to 100 characters.)
(defmacro with-detached-bindings ((&rest detached-identifiers) &body body)
(multiple-value-bind (bindings real-body-forms)
(%split-w/d/b-body detached-identifiers body)
(if bindings
`(flet ,bindings
(declare (inline ,@(mapcar #'identifier bindings)))
,@real-body-forms)
`(progn ,@real-body-forms))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun identifier (binding) (car binding))
(defun binding-p (sexp) (and (consp sexp) (symbolp (identifier sexp))))
(defun detached-binding-p (sexp detached-identifiers)
(and (binding-p sexp)
(member (identifier sexp) detached-identifiers)))
(defun %split-w/d/b-body (identifiers body)
(macrolet ((collect-binding (binding)
(once-only (binding)
`(progn (collect ,binding into bindings)
(collect (identifier ,binding) into seen-identifiers)
;; note: this will implicitely remove duplicates for us.
(setf remaining-identifiers
(remove (identifier ,binding) remaining-identifiers))))))
(iter (with remaining-identifiers = identifiers)
(with reached-bindings-p = nil)
(for sexp in body)
(if (not reached-bindings-p)
(if (not (detached-binding-p sexp remaining-identifiers))
(collect sexp into forms)
(progn (setf reached-bindings-p t) (collect-binding sexp)))
(cond ((not (binding-p sexp))
(error "Not a proper detached binding: ~A" sexp))
((member (identifier sexp) seen-identifiers)
(error "Found more than one binding for: ~A" (identifier sexp)))
((not (member (identifier sexp) remaining-identifiers))
(error "Binding was not previously defined: ~A" sexp))
(t (collect-binding sexp))))
(finally (when (not (null remaining-identifiers))
(error "Found no bindings for: ~A" remaining-identifiers))
(return (values bindings forms)))))))
Now, let's see how %SPLIT-W/D/B-BODY could be metacircularly implemented
by means of WITH-DETACHED-BINDINGS itself:
(defun %split-w/d/b-body-2 (identifiers body)
(with-detached-bindings (err-no-proper-binding err-seen-twice err-not-defined err-no-bindings)
(macrolet ((collect-binding (binding)
(once-only (binding)
`(progn (collect ,binding into bindings)
(collect (identifier ,binding) into seen-identifiers)
;; note: this will implicitely remove duplicates for us.
(setf remaining-identifiers
(remove (identifier ,binding) remaining-identifiers))))))
(iter (with remaining-identifiers = identifiers)
(with reached-bindings-p = nil)
(for sexp in body)
(if (not reached-bindings-p)
(if (not (detached-binding-p sexp remaining-identifiers))
(collect sexp into forms)
(progn (setf reached-bindings-p t) (collect-binding sexp)))
(with-detached-bindings (seen-twice-p previously-defined-p)
(cond ((not (binding-p sexp)) (err-no-proper-binding sexp))
((seen-twice-p (identifier sexp)) (err-seen-twice (identifier sexp)))
((not (previously-defined-p (identifier sexp))) (err-not-defined sexp))
(t (collect-binding sexp)))
(seen-twice-p (identifier) (member identifier seen-identifiers))
(previously-defined-p (identifier) (member identifier remaining-identifiers))))
(finally (when (not (null remaining-identifiers))
(err-no-bindings remaining-identifiers))
(return (values bindings forms)))))
(err-no-proper-binding (binding) (error "Not a proper detached condition binding: ~A" binding))
(err-seen-twice (name) (error "Found more than one binding for: ~A" name))
(err-not-defined (binding) (error "Not previously defined: ~A" binding))
(err-no-bindings (names) (error "Found no bindings for: ~A" names))))
I'm not necessarily convinced about the usefulness of the second
(nested) WITH-DETACHED-BINDINGS. While it gives names to forms (to
clarify what they're doing, hopefully), I'm not so sure how much that
messes up with reading flow, and being overly abstract isn't always a
good thing. What was your impression while reading the code?
Well, that's it. Comments about the code, the idea and possible
alternatives are very much welcome.
-*- tcr