Hi,
I'm searching for real-life examples of use of the extended loop macro
that combine several of its features such as a bunch of for-as-
clauses (possibly mixing arithmetic, lists, etc), some list- and
numeric-accumulations, a few conditionals in the middle, termination
tests, etc.
I don't mind seeing really ugly examples, as long as they do something
useful.
If you saw one of these beasts, I would be glad if you could share it
with me.
Thanks in advance,
Ant�nio Leit�o.
Antonio Menezes Leitao <··············@evaluator.pt> writes:
>
> Hi,
>
> I'm searching for real-life examples of use of the extended loop macro
> that combine several of its features such as a bunch of for-as-
> clauses (possibly mixing arithmetic, lists, etc), some list- and
> numeric-accumulations, a few conditionals in the middle, termination
> tests, etc.
Well, I don't have time for an exhaustive search, but here are some
examples from one of the source files of the Loom KR system. If you are
really curious, you could download the source files and search through
more of them yourself. ( http://www.isi.edu/isd/LOOM/ )
(loop for c in contextList
do (change-context c)
when (access-in-ctxt slotValue nil homeCtxt)
collect it)
(loop for item in rawList
as id = (unique-identifier item)
as seen = (gethash id ht)
when (and seen (not (eq seen item)))
do (pushnew id result)
else when id
do (setf (gethash id ht) item))
(loop for ctx in (generationForm)
as ns = (ns-cache-instances (namespace-cache ctx))
as obj = (when ns (gethash identifier ns))
when obj return obj)
(loop for parentName in parentContexts
as parent = (find-context parentName)
when parent
collect parent
and do (when (test-bit-flags (context-flag parent)
:context-flag :open-world)
(setq allParentsClosedP nil))
(within-context parent
(new-time-point))
else do (grumble "Can't inherit context ~S while defining context ~S~%~
because ~S is undefined. Abandoning definition of ~S."
parentName name parentName name)
(return-from define-context nil))
(loop for (nil . cxt) in *context-table*
when (and (theory-p cxt)
(loop for child in (child-contexts cxt)
never (theory-p child)))
collect cxt)
(loop for tail on *context-table*
as entry = (first tail)
when (eq (cdr entry) context)
do (setf (first tail) (first (rest tail)))
(setf (rest tail) (rest (rest tail))))
--
Thomas A. Russ, USC/Information Sciences Institute
Antonio Menezes Leitao wrote:
> Hi,
>
> I'm searching for real-life examples of use of the extended loop macro
> that combine several of its features such as a bunch of for-as-
> clauses (possibly mixing arithmetic, lists, etc), some list- and
> numeric-accumulations, a few conditionals in the middle, termination
> tests, etc.
Here is something from my AspectL library:
(defmacro dletf (bindings &body body &environment env)
"bind places to new values with dynamic scope in parallel,
and execute body in that new dynamic environment"
(loop for binding in bindings
do (setf binding (prepare-binding binding env))
collect (if (symbolp (car binding))
`',(car binding)
(car binding)) into symbol-forms
when (symbolp (car binding)) collect (car binding) into variables
collect (cadr binding) into value-forms
finally (return `(checked-progv
(with-symbol-access
(list ,@symbol-forms))
(list ,@value-forms)
(locally (declare (special ,@variables))
,@body)))))
I'd like to see the LinJ output. ;)
Pascal
--
Tyler: "How's that working out for you?"
Jack: "Great."
Tyler: "Keep it up, then."
Pascal Costanza <········@web.de> writes:
> Antonio Menezes Leitao wrote:
>
>> Hi, I'm searching for real-life examples of use of the extended loop
>> macro
>> that combine several of its features such as a bunch of for-as-
>> clauses (possibly mixing arithmetic, lists, etc), some list- and
>> numeric-accumulations, a few conditionals in the middle, termination
>> tests, etc.
>
> Here is something from my AspectL library:
>
> (defmacro dletf (bindings &body body &environment env)
> "bind places to new values with dynamic scope in parallel,
> and execute body in that new dynamic environment"
> (loop for binding in bindings
> do (setf binding (prepare-binding binding env))
> collect (if (symbolp (car binding))
> `',(car binding)
> (car binding)) into symbol-forms
> when (symbolp (car binding)) collect (car binding) into variables
> collect (cadr binding) into value-forms
> finally (return `(checked-progv
> (with-symbol-access
> (list ,@symbol-forms))
> (list ,@value-forms)
> (locally (declare (special ,@variables))
> ,@body)))))
>
>
> I'd like to see the LinJ output. ;)
Given the fact that it's a macro, Linj will not output anything.
(macro calls, in Linj, are expanded by the Common Lisp environment).
But if we change it to a function, writing instead:
(defun call-dletf (bindings body env)
"bind places to new values with dynamic scope in parallel,
and execute body in that new dynamic environment"
(loop for binding in bindings
do (setf binding (prepare-binding binding env))
collect (if (symbolp (car binding))
`',(car binding)
(car binding)) into symbol-forms
when (symbolp (car binding)) collect (car binding) into variables
collect (cadr binding) into value-forms
finally (return `(checked-progv
(with-symbol-access
(list ,@symbol-forms))
(list ,@value-forms)
(locally (declare (special ,@variables))
,@body)))))
then, Linj generates the following translation into Java:
// bind places to new values with dynamic scope in parallel,
// and execute body in that new dynamic environment
public static Cons callDletf(Object bindings, Object body, Object env) {
Cons valueForms = Cons.list();
Cons tail1 = Cons.list();
Cons variables = Cons.list();
Cons tail0 = Cons.list();
Cons symbolForms = Cons.list();
Cons tail = Cons.list();
Cons listBinding = (Cons)bindings;
for (; ! listBinding.endp(); listBinding = listBinding.rest()) {
Object binding = listBinding.first();
binding = prepareBinding(binding, env);
if (symbolForms.endp()) {
symbolForms = Cons.
list((((Cons)binding).car() instanceof Symbol) ?
Cons.list(Symbol.intern("quote"), ((Cons)binding).car()) :
((Cons)binding).car());
tail = (Cons)symbolForms.last(1);
} else {
tail.
nconc(Cons.
list((((Cons)binding).car() instanceof Symbol) ?
Cons.list(Symbol.intern("quote"), ((Cons)binding).car()) :
((Cons)binding).car()));
tail = (Cons)tail.last(1);
}
if (((Cons)binding).car() instanceof Symbol) {
if (variables.endp()) {
variables = Cons.list(((Cons)binding).car());
tail0 = (Cons)variables.last(1);
} else {
tail0.nconc(Cons.list(((Cons)binding).car()));
tail0 = (Cons)tail0.last(1);
}
}
if (valueForms.endp()) {
valueForms = Cons.list(((Cons)binding).cadr());
tail1 = (Cons)valueForms.last(1);
} else {
tail1.nconc(Cons.list(((Cons)binding).cadr()));
tail1 = (Cons)tail1.last(1);
}
}
return Cons.
list(Symbol.intern("checked-progv"),
Cons.list(Symbol.intern("with-symbol-access"), new Cons(Symbol.intern("list"), symbolForms)),
new Cons(Symbol.intern("list"), valueForms),
new Cons(Symbol.intern("locally"),
new Cons(Cons.
list(Symbol.intern("declare"), new Cons(Symbol.intern("special"), variables)),
body)));
}
It can be improved just a little bit by asserting that the parameters
are conses (adding a (declare (cons bindings body env)) or using the
shorthand notation (bindings/cons body/cons env/cons) in the parameter
list):
// bind places to new values with dynamic scope in parallel,
// and execute body in that new dynamic environment
public static Cons callDletf(Cons bindings, Cons body, Cons env) {
Cons valueForms = Cons.list();
Cons tail1 = Cons.list();
Cons variables = Cons.list();
Cons tail0 = Cons.list();
Cons symbolForms = Cons.list();
Cons tail = Cons.list();
Cons listBinding = bindings;
for (; ! listBinding.endp(); listBinding = listBinding.rest()) {
Object binding = listBinding.first();
binding = prepareBinding(binding, env);
if (symbolForms.endp()) {
symbolForms = Cons.
list((((Cons)binding).car() instanceof Symbol) ?
Cons.list(Symbol.intern("quote"), ((Cons)binding).car()) :
((Cons)binding).car());
tail = (Cons)symbolForms.last(1);
} else {
tail.
nconc(Cons.
list((((Cons)binding).car() instanceof Symbol) ?
Cons.list(Symbol.intern("quote"), ((Cons)binding).car()) :
((Cons)binding).car()));
tail = (Cons)tail.last(1);
}
if (((Cons)binding).car() instanceof Symbol) {
if (variables.endp()) {
variables = Cons.list(((Cons)binding).car());
tail0 = (Cons)variables.last(1);
} else {
tail0.nconc(Cons.list(((Cons)binding).car()));
tail0 = (Cons)tail0.last(1);
}
}
if (valueForms.endp()) {
valueForms = Cons.list(((Cons)binding).cadr());
tail1 = (Cons)valueForms.last(1);
} else {
tail1.nconc(Cons.list(((Cons)binding).cadr()));
tail1 = (Cons)tail1.last(1);
}
}
return Cons.
list(Symbol.intern("checked-progv"),
Cons.list(Symbol.intern("with-symbol-access"), new Cons(Symbol.intern("list"), symbolForms)),
new Cons(Symbol.intern("list"), valueForms),
new Cons(Symbol.intern("locally"),
new Cons(Cons.
list(Symbol.intern("declare"), new Cons(Symbol.intern("special"), variables)),
body)));
}
I didn't test it. I hope it's correct :-)
Thanks for the nice example.
Ant�nio Leit�o.
Antonio Menezes Leitao wrote:
> I didn't test it. I hope it's correct :-)
Yeah, this looks like the usual amount of code you need to express
simple things in Java. ;)
Pascal
--
Tyler: "How's that working out for you?"
Jack: "Great."
Tyler: "Keep it up, then."
"Pascal Costanza" <········@web.de> wrote in message
·················@newsreader2.netcologne.de...
>
>
> Antonio Menezes Leitao wrote:
>
> > I didn't test it. I hope it's correct :-)
>
> Yeah, this looks like the usual amount of code you need
You belong in the QA department for sure! ;-)
--
Coby Beck
(remove #\Space "coby 101 @ big pond . com")
On Fri, 03 Sep 2004 16:38:24 +0100, Antonio Menezes Leitao <··············@evaluator.pt> wrote:
> I'm searching for real-life examples of use of the extended loop
> macro that combine several of its features such as a bunch of
> for-as- clauses (possibly mixing arithmetic, lists, etc), some list-
> and numeric-accumulations, a few conditionals in the middle,
> termination tests, etc.
Here are some I found in my own code.
Cheers,
Edi.
(loop for element in (reverse (elements seq))
for loop-old-case-insensitive-p = old-case-insensitive-p
then (if skip
loop-old-case-insensitive-p
(case-insensitive-p element-end))
for element-end = (end-string-aux element
loop-old-case-insensitive-p)
for skip = (if element-end
(zerop (len element-end))
nil)
unless element-end
do (setq continuep nil)
while element-end
unless skip
do (cond (concatenated-string
(when concatenated-start
(setf concatenated-string
(make-array concatenated-length
:initial-contents (reverse (str concatenated-start))
:element-type 'character
:fill-pointer t
:adjustable t)
concatenated-start nil))
(let ((len (len element-end))
(str (str element-end)))
(declare (type fixnum len))
(incf concatenated-length len)
(loop for i of-type fixnum downfrom (1- len) to 0
do (vector-push-extend (char str i)
concatenated-string))))
(t
(setf concatenated-string
t
concatenated-start
element-end
concatenated-length
(len element-end)
case-insensitive-p
(case-insensitive-p element-end))))
while continuep)
(loop for (from to) on (append (list start) pos-list (list end))
for replace = nil then (and (not replace) to)
for reg-starts = (if replace (pop reg-list) nil)
for reg-ends = (if replace (pop reg-list) nil)
for curr-replacement = (if replace
(build-replacement replacement-template
target-string
start end
from to
reg-starts reg-ends
simple-calls)
nil)
while to
if replace
do (write-string (if preserve-case
(funcall (string-case-modifier target-string
from to
start end)
curr-replacement)
curr-replacement)
s)
else
do (write-string target-string s :start from :end to))
(loop named bmh-matcher
for k of-type fixnum = (+ start-pos m -1)
then (+ k (max 1 (aref skip (char-code (schar *string* k)))))
while (< k *end-pos*)
do (loop for j of-type fixnum downfrom (1- m)
for i of-type fixnum downfrom k
while (and (>= j 0)
(char-compare (schar *string* i)
(schar pattern j)))
finally (if (minusp j)
(return-from bmh-matcher (1+ i)))))
(loop for i = 0 then (cond (match (1+ i))
((cdr (assoc c (svref offsets i))))
(t 0))
for c = (peek-char)
for match = (char= c (char string i))
while (or (not match) (< (1+ i) length)) do
(cond (skip (read-char))
(t (vector-push-extend (read-char) collector)))
when write-through do
(write-char c)
finally (if write-through
(write-char (read-char))
(read-char))
(unless skip
(decf (fill-pointer collector) (1- length)))
(return (and (not skip) collector)))
(loop with scheme-char-seen-p = nil
for c across string
when (or (char-not-greaterp #\a c #\z)
(digit-char-p c)
(member c '(#\+ #\- #\.) :test #'char=))
do (setq scheme-char-seen-p t)
else return (and scheme-char-seen-p
(char= c #\:)))
--
"Lisp doesn't look any deader than usual to me."
(David Thornley, reply to a question older than most languages)
Real email: (replace (subseq ·········@agharta.de" 5) "edi")
Edi Weitz <········@agharta.de> writes:
> (loop with scheme-char-seen-p = nil
> for c across string
> when (or (char-not-greaterp #\a c #\z)
> (digit-char-p c)
> (member c '(#\+ #\- #\.) :test #'char=))
> do (setq scheme-char-seen-p t)
> else return (and scheme-char-seen-p
> (char= c #\:)))
>
Lot's of extremely nice examples! And the last one even ends with a
smile. I hope you can see it!
Thanks a lot,
Ant�nio Leit�o.