[Gd-chatter] r10833 - trunk/ltd/test
housel at gwydiondylan.org
housel at gwydiondylan.org
Wed Jul 26 05:46:04 CEST 2006
Author: housel
Date: Wed Jul 26 05:45:57 2006
New Revision: 10833
Modified:
trunk/ltd/test/aima-dtp.dylan
trunk/ltd/test/atms.dylan
trunk/ltd/test/auxfns.dylan
trunk/ltd/test/backprop.dylan
trunk/ltd/test/backtrack.dylan
trunk/ltd/test/backward.dylan
trunk/ltd/test/bindings.dylan
trunk/ltd/test/caching.dylan
trunk/ltd/test/classes.dylan
trunk/ltd/test/clauses.dylan
trunk/ltd/test/clos.dylan
trunk/ltd/test/cmacsyma.dylan
trunk/ltd/test/cnf.dylan
trunk/ltd/test/compile1.dylan
trunk/ltd/test/compile3.dylan
trunk/ltd/test/conjunct.dylan
trunk/ltd/test/database.dylan
trunk/ltd/test/eliza.dylan
trunk/ltd/test/fork.dylan
trunk/ltd/test/frules.dylan
trunk/ltd/test/graph-unify.dylan
trunk/ltd/test/hierarchy.dylan
trunk/ltd/test/jsaint.dylan
trunk/ltd/test/jtms.dylan
trunk/ltd/test/kd.dylan
trunk/ltd/test/library.dylan
trunk/ltd/test/literals.dylan
trunk/ltd/test/mcchef.dylan
trunk/ltd/test/mcmops.dylan
trunk/ltd/test/micro-tale-spin.dylan
trunk/ltd/test/mycin.dylan
trunk/ltd/test/n-puzzle.dylan
trunk/ltd/test/onlisp.dylan
trunk/ltd/test/othello.dylan
trunk/ltd/test/othello2.dylan
trunk/ltd/test/output.dylan
trunk/ltd/test/overview.dylan
trunk/ltd/test/pf.dylan
trunk/ltd/test/search.dylan
trunk/ltd/test/student.dylan
trunk/ltd/test/unifgram.dylan
trunk/ltd/test/waltz.dylan
trunk/ltd/test/winston-clos.dylan
Log:
Bug: 7322
Revert unnecessary changes (from r10831) to the reference test output files.
Modified: trunk/ltd/test/aima-dtp.dylan
==============================================================================
--- trunk/ltd/test/aima-dtp.dylan (original)
+++ trunk/ltd/test/aima-dtp.dylan Wed Jul 26 05:45:57 2006
@@ -67,11 +67,28 @@
begin
define variable *dtp-version* =
- (formatter-1("~D.~2,'0D [~A,~A]"))(#f,
- *dtp-major-version*,
- *dtp-minor-version*,
- *dtp-tracing-status*,
- *dtp-typing-status*);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~D", pop!(args));
+ write-char++('.', xp);
+ using-format(xp, "~2,'0D", pop!(args));
+ write-string++(" [", xp, 0, 2);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-char++(',', xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-char++(']', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#f, *dtp-major-version*, *dtp-minor-version*,
+ *dtp-tracing-status*, *dtp-typing-status*);
define module dtp export *dtp-version*; end module dtp;
end;
Modified: trunk/ltd/test/atms.dylan
==============================================================================
--- trunk/ltd/test/atms.dylan (original)
+++ trunk/ltd/test/atms.dylan Wed Jul 26 05:45:57 2006
@@ -395,8 +395,10 @@
define method union-env (e1, e2)
if (e1.env-count > e2.env-count)
- let g15926 = e2;
- begin e2 := e1; e1 := g15926; end;
+ let g108128 = e2;
+ let g108129 = e1;
+ e1 := g108128;
+ e2 := g108129;
#f;
end if;
block (return)
@@ -721,7 +723,40 @@
printer := atms-node-string(tms-node-atms(head(assumptions)));
end if;
for (a in assumptions) push!(printer(a), strings); end for;
- (formatter-1("{~{~A~^,~}}"))(stream, sort!(strings, test: string-less?));
+ (method (s, #rest args)
+ block (return)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ block (return)
+ block (return)
+ write-char++('{', xp);
+ let args = pop!(args);
+ block (return)
+ block (return)
+ block (return)
+ local method go-l ()
+ if (empty?(args)) return(#f); end if;
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ if (empty?(args))
+ return-from-nil(#f);
+ end if;
+ write-char++(',', xp);
+ go-l();
+ end method go-l;
+ go-l();
+ end block;
+ end block;
+ end block;
+ write-char++('}', xp);
+ end block;
+ if (args) copy-sequence(args); end if;
+ end block;
+ end method,
+ s, args);
+ end block;
+ end method)(stream, sort!(strings, test: string-less?));
end method env-string;
// Printing global data
Modified: trunk/ltd/test/auxfns.dylan
==============================================================================
--- trunk/ltd/test/auxfns.dylan (original)
+++ trunk/ltd/test/auxfns.dylan Wed Jul 26 05:45:57 2006
@@ -153,11 +153,10 @@
define method seq-ref (seq, index)
// Return code that indexes into a sequence, using
// the pop-lists/aref-vectors strategy.
- bq-list(#"if", bq-list(#"listp", seq),
- bq-list(#"prog1", bq-list(#"first", seq),
- bq-list(#"setq", seq,
- bq-list(#"the", #"list", bq-list(#"rest", seq)))),
- bq-list(#"aref", seq, index));
+ list(#"if", list(#"listp", seq),
+ list(#"prog1", list(#"first", seq),
+ list(#"setq", seq, list(#"the", #"list", list(#"rest", seq)))),
+ list(#"aref", seq, index));
end method seq-ref;
define method maybe-set-fill-pointer (array, new-length)
@@ -273,18 +272,31 @@
// This has not been done (for compatibility with the book). The only near-ANSI
// Lisp tested was Franz's Allegro EXCL, for which we allow the definition by
// unlocking the excl and common-lisp packages with the following form:
-#"dolist"(#"pkg"(#(#"excl", #"common-lisp")),
- #"setf"(#"package-lock-fdefinitions"(#"find-package"(#"pkg")),
- #"nil"));
-
-define method symbol (#rest args)
- // Concatenate symbols or strings to form an interned symbol
- as(<symbol>, (formatter-1("~{~a~}"))(#f, args));
-end method symbol;
+//
+nil(#f, nil(#f), "Concatenate symbols or strings to form an interned symbol",
+ nil(nil(#f, "~{~a~}", #f)));
define method new-symbol (#rest args)
// Concatenate symbols or strings to form an uninterned symbol
- as(<symbol>, (formatter-1("~{~a~}"))(#f, args));
+ as(<symbol>,
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let args = pop!(args);
+ block (return)
+ local method go-l ()
+ if (empty?(args)) return(#f); end if;
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ go-l();
+ end method go-l;
+ go-l();
+ end block;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#f, args));
end method new-symbol;
define method last1 (list)
@@ -500,8 +512,8 @@
// Add the elements of LIST to the end of the queue.
head(q)
:= begin
- let s14663 = (tail(head(q)) := list);
- copy-sequence(s14663, start: size(s14663) - 1);
+ let s93739 = (tail(head(q)) := list);
+ copy-sequence(s93739, start: size(s93739) - 1);
end;
end method queue-nconc;
Modified: trunk/ltd/test/backprop.dylan
==============================================================================
--- trunk/ltd/test/backprop.dylan (original)
+++ trunk/ltd/test/backprop.dylan Wed Jul 26 05:45:57 2006
@@ -1,7 +1,11 @@
// ----------------------------------------------------------------------------
-// BACKPROPAGATION ALGORITHM
-// (SINGLE, BINARY OUTPUT)
-// "backprop.lisp"
+// Artificial Intelligence, Second Edition
+// Elaine Rich and Kevin Knight
+// McGraw Hill, 1991
+//
+// This code may be freely copied and used for educational or research purposes.
+// All software written by Kevin Knight.
+// Comments, bugs, improvements to knight at cs.cmu.edu
// ----------------------------------------------------------------------------
// ----------------------------------------------------------------------------
// BACKPROPAGATION ALGORITHM
@@ -444,9 +448,19 @@
#f;
end for;
if (verbose)
- (formatter-1("Result = ~14,7f ...~%"))(#t,
- unit-activation(output-layer
- .net-units[1]));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ write-string++("Result = ", xp, 0, 9);
+ using-format(xp, "~14,7f", pop!(args));
+ write-string++(" ...", xp, 0, 4);
+ pprint-newline+(unconditional: xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, unit-activation(output-layer.net-units[1]));
end if;
end method feed-forward;
@@ -492,15 +506,27 @@
= mult(eta, hi-unit.unit-delta, low-unit.unit-activation)
+ mult(temp-alpha, the-connection.connection-delta-weight);
if (verbose)
- (formatter-1("Changing weight (~d ~d ~d) from ~14,7f to ~14,7f~%"))(#t,
- l,
- u,
- u2,
- the-connection
- .connection-weight,
- the-connection
- .connection-weight
- + newchange);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ write-string++("Changing weight (", xp, 0, 17);
+ using-format(xp, "~d", pop!(args));
+ write-char++(' ', xp);
+ using-format(xp, "~d", pop!(args));
+ write-char++(' ', xp);
+ using-format(xp, "~d", pop!(args));
+ write-string++(") from ", xp, 0, 7);
+ using-format(xp, "~14,7f", pop!(args));
+ write-string++(" to ", xp, 0, 4);
+ using-format(xp, "~14,7f", pop!(args));
+ pprint-newline+(unconditional: xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, l, u, u2, the-connection.connection-weight,
+ the-connection.connection-weight + newchange);
end if;
the-connection.connection-weight
:= the-connection.connection-weight + newchange;
@@ -564,27 +590,67 @@
format(ifile, "EPOCH %d. Performance on training data:\n\n", epoch);
format(ifile, "Confidence: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6,2f "))(ifile, i * 0.05);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6,2f", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, i * 0.05);
end for;
format(ifile, "\n");
format(ifile, "Guessed: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6d "))(ifile, round(total-guessed[i]));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6d", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, round(total-guessed[i]));
end for;
format(ifile, "\n");
format(ifile, "Correct: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6d "))(ifile, round(total-right[i]));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6d", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, round(total-right[i]));
end for;
format(ifile, "\n");
format(ifile, "Percent: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6,2f "))(ifile,
- if (total-guessed[i] > 0.5)
- 100.0 * total-right[i] / total-guessed[i];
- else
- 0.0;
- end if);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6,2f", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile,
+ if (total-guessed[i] > 0.5)
+ 100.0 * total-right[i] / total-guessed[i];
+ else
+ 0.0;
+ end if);
end for;
format(ifile, "\n\n");
end with-open-file;
@@ -613,27 +679,67 @@
format(ifile, "EPOCH %d. Performance on testing data:\n\n", epoch);
format(ifile, "Confidence: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6,2f "))(ifile, i * 0.05);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6,2f", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, i * 0.05);
end for;
format(ifile, "\n");
format(ifile, "Guessed: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6d "))(ifile, round(total-guessed[i]));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6d", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, round(total-guessed[i]));
end for;
format(ifile, "\n");
format(ifile, "Correct: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6d "))(ifile, round(total-right[i]));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6d", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile, round(total-right[i]));
end for;
format(ifile, "\n");
format(ifile, "Percent: ");
for (i = 0 then 1+(i), until i = 8)
- (formatter-1("~6,2f "))(ifile,
- if (total-guessed[i] > 0.5)
- 100.0 * total-right[i] / total-guessed[i];
- else
- 0.0;
- end if);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ using-format(xp, "~6,2f", pop!(args));
+ write-char++(' ', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(ifile,
+ if (total-guessed[i] > 0.5)
+ 100.0 * total-right[i] / total-guessed[i];
+ else
+ 0.0;
+ end if);
end for;
format(ifile, "\n\n");
end with-open-file;
@@ -651,12 +757,8 @@
for (u = 0 then 1+(u), until u > layer.net-size)
for (u2 = 1 then 1+(u2), until u2 > layer.net-next-layer.net-size)
let the-connection = layer.net-connections[u, u2];
- (formatter-1("(~d ~d ~d ~14.7f)~%"))(ifile,
- k,
- u,
- u2,
- the-connection
- .connection-weight);
+ format(ifile, "(~d ~d ~d ~14.7f)~%", k, u, u2,
+ the-connection.connection-weight);
finally
#f;
end for;
Modified: trunk/ltd/test/backtrack.dylan
==============================================================================
--- trunk/ltd/test/backtrack.dylan (original)
+++ trunk/ltd/test/backtrack.dylan Wed Jul 26 05:45:57 2006
@@ -29,41 +29,21 @@
if (conjunction.stack-pointer = conjunction.backtrack-pointer)
return-from-compute-nogoods(#f);
end if;
- let g15949 = active-conjunct(conjunction);
- g15949;
- if (g15949.nogoods == #"uninitialized")
- #f;
+ let g151404 = active-conjunct(conjunction);
+ begin
+ if (g151404.nogoods == #"uninitialized") g151404.nogoods := #f; end if;
begin
- let g15950 = g15949;
- let g15951 = #"nogoods";
- let g15952 = #f;
- .inv-slot-value(g15950, g15951, g15952);
+ let failed-vars = literal-vars-in(g151404.literal);
+ for (conjunct-index from 0, answer in reverse(conjunction.stack))
+ if (any?(method (var) answer-binds-var-p(answer, var); end method,
+ failed-vars))
+ let new-value-151406 = conjunct-index;
+ let g151405 = add!(new-value-151406, g151404.nogoods, test: \=);
+ set-slot-value(g151404, #"nogoods", g151405);
+ end if;
+ end for;
end;
- elseif (nil);
- end if;
- let failed-vars = literal-vars-in(g15949.literal);
- let conjunct-index :: <real> = 0;
- let answer = #f;
- let g15953 :: <list> = reverse(conjunction.stack);
- local method go-end-loop () #f; end method go-end-loop,
- method go-next-loop ()
- if (not(pair?(g15953))) #f; go-end-loop(); elseif (nil); end if;
- answer := head(g15953);
- g15953 := tail(g15953);
- if (any?(method (var) answer-binds-var-p(answer, var); end method,
- failed-vars))
- let g15954 = g15949;
- let g15955 = #"nogoods";
- let g15956 = add!(conjunct-index, g15949.nogoods, test: \=);
- .inv-slot-value(g15954, g15955, g15956);
- else
- #f;
- end if;
- conjunct-index := conjunct-index + 1;
- go-next-loop();
- go-end-loop();
- end method go-next-loop;
- go-next-loop();
+ end;
end block;
end method compute-nogoods;
@@ -119,8 +99,7 @@
//
// ----------------------------------------------------------------------------
nil(#f, nil(), "Unless waiting for next subgoal answer, get the next answer",
- nil(nil(#f, #f)),
- nil((nil(nil(#f)))(), nil(nil(nil(#f, #f), #f)),
+ nil((nil(nil(#f)))(),
nil(#f,
nil(nil(), #f,
nil(nil(nil(#f, #()), nil(#f, nil(#f, #()))), nil(#f))))));
Modified: trunk/ltd/test/backward.dylan
==============================================================================
--- trunk/ltd/test/backward.dylan (original)
+++ trunk/ltd/test/backward.dylan Wed Jul 26 05:45:57 2006
@@ -212,15 +212,14 @@
"%S",
variable)[0],
inc!(*name-counter*)),
- 0,
- #f);
+ 0);
block (nil)
begin
// LTD: Function READ not yet implemented.
read(input);
end;
cleanup
- deallocate-resource(#"string-input-simple-stream", input);
+ close(input);
end block;
end method,
variables);
Modified: trunk/ltd/test/bindings.dylan
==============================================================================
--- trunk/ltd/test/bindings.dylan (original)
+++ trunk/ltd/test/bindings.dylan Wed Jul 26 05:45:57 2006
@@ -53,94 +53,138 @@
// delete-bdg (x bdg-list) remove binding for x in bdg-list
// get-bdg (x bdg-list) find binding for x in bdg-list
begin
- check-lock-definitions-compile-time(#"popf", #"function", #"defmacro",
- // LTD: Function FBOUNDP not yet implemented.
- fboundp(#"popf"));
- // LTD: Function MACRO-FUNCTION not yet implemented.
- macro-function(#"popf")
- := method (**macroarg**, ..environment..)
- dt-macro-argument-check(2, #f, **macroarg**, #"macro");
- let env = ..environment..;
- let g15957 = tail(**macroarg**);
- let %reference = car-fussy(g15957, #"%reference");
- let item = car-fussy(tail(g15957), #"item");
- let keywords = tail(tail(g15957));
- #f;
- let (dummies, vals, newvals, setter, getter)
- = get-setf-expansion(%reference, env);
- for (d = dummies then cdr(d), v = vals then cdr(v),
- let-list = nil then cons(list(car(d), car(v)), let-list),
- until empty?(d))
- #f;
- finally
- bq-list(#"let*",
- setf-binding-list(newvals, let-list,
- if (instance?(getter, <pair>)
- & #"the" == head(getter))
- list(#"the",
- second(getter),
- apply(list,
- #"pop-fn",
- getter,
- item,
- keywords));
- else
- apply(list,
- #"pop-fn",
- getter,
- item,
- keywords);
- end if),
- setter);
- end for;
- end method;
- set-func_name(// LTD: Function MACRO-FUNCTION not yet implemented.
- macro-function(#"popf"),
- #"popf");
- .inv-func_formals(// LTD: Function FBOUNDP not yet implemented.
- fboundp(#"popf"),
- #(#"%reference", #"item", #"&rest", #"keywords"));
- ce-putprop(#"popf",
- method (**macroarg**, ..environment..)
- dt-macro-argument-check(2, #f, **macroarg**, #"macro");
- let env = ..environment..;
- let g15957 = tail(**macroarg**);
- let %reference = car-fussy(g15957, #"%reference");
- let item = car-fussy(tail(g15957), #"item");
- let keywords = tail(tail(g15957));
- #f;
- let (dummies, vals, newvals, setter, getter)
- = get-setf-expansion(%reference, env);
- for (d = dummies then cdr(d), v = vals then cdr(v),
- let-list = nil then cons(list(car(d), car(v)), let-list),
- until empty?(d))
- #f;
- finally
- bq-list(#"let*",
- setf-binding-list(newvals,
- let-list,
- if (instance?(getter, <pair>)
- & #"the" == head(getter))
- list(#"the",
- second(getter),
- apply(list,
- #"pop-fn",
- getter,
- item,
- keywords));
- else
- apply(list,
- #"pop-fn",
- getter,
- item,
- keywords);
- end if),
- setter);
- end for;
- end method,
- #".compile-file-macro.");
- symbol-remove-property(#"popf", #"%fun-documentation");
- record-source-file(#"popf");
+ fluid-bind (*function-name*
+ = generate-subform-name(#"popf", *function-name*))
+ fluid-bind (*function-parent* = tlf-function-parent(#(#"quote", #"popf")))
+ record-sf-eval(compiler-eval(*function-name*),
+ compiler-eval(*function-parent*));
+ record-sf-compile(*function-name*, *function-parent*);
+ set-macro-function(#"popf",
+ method (%%macroarg%%, environment)
+ let &whole151751 = %%macroarg%%;
+ let (%reference ...)151752 = tail(&whole151751);
+ let check-lambda-list-top-level151755
+ = check-lambda-list-top-level(#(#"%reference",
+ #"item",
+ #"&rest",
+ #"keywords"),
+ &whole151751,
+ (%reference ...)151752,
+ 2,
+ 2,
+ #"t",
+ #"macro");
+ let %reference = head((%reference ...)151752);
+ let (item ...)151753
+ = tail((%reference ...)151752);
+ let item = head((item ...)151753);
+ let keywords151754 = tail((item ...)151753);
+ let keywords = keywords151754;
+ begin
+ #f;
+ let (dummies, vals, newval, setter, getter)
+ = // LTD: Function GET-SETF-METHOD not yet implemented.
+ get-setf-method(%reference, environment);
+ for (d = dummies then cdr(d),
+ v = vals then cdr(v),
+ let-list = nil then cons(list(car(d),
+ car(v)),
+ let-list),
+ until empty?(d))
+ #f;
+ finally
+ values(push!(list(head(newval),
+ apply(list,
+ #"pop-fn",
+ getter,
+ item,
+ keywords)),
+ let-list),
+ list(#"let*",
+ reverse!(let-list),
+ setter));
+ end for;
+ end;
+ end method);
+ broadcast-redefined(#"popf",
+ macro: #(#(#"let*",
+ #(#(#"&whole151751", #"%%macroarg%%"),
+ #(#"(%reference ...)151752",
+ #(#"cdr", #"&whole151751")),
+ #(#"check-lambda-list-top-level151755",
+ #(#"check-lambda-list-top-level",
+ #(#"quote",
+ #(#"%reference",
+ #"item",
+ #"&rest",
+ #"keywords")),
+ #"&whole151751",
+ #"(%reference ...)151752",
+ 2,
+ 2,
+ #(#"quote", #"t"),
+ #"macro")),
+ #(#"%reference",
+ #(#"car",
+ #(#"the-cons",
+ #"(%reference ...)151752"))),
+ #(#"(item ...)151753",
+ #(#"cdr",
+ #(#"the-cons",
+ #"(%reference ...)151752"))),
+ #(#"item",
+ #(#"car",
+ #(#"the-cons",
+ #"(item ...)151753"))),
+ #(#"keywords151754",
+ #(#"cdr",
+ #(#"the-cons",
+ #"(item ...)151753"))),
+ #(#"keywords", #"keywords151754")),
+ #(#"block",
+ #"popf",
+ #(),
+ #(#"multiple-value-bind",
+ #(#"dummies",
+ #"vals",
+ #"newval",
+ #"setter",
+ #"getter"),
+ #(#"get-setf-method",
+ #"%reference",
+ #"environment"),
+ #(#"do",
+ #(#(#"d",
+ #"dummies",
+ #(#"cdr", #"d")),
+ #(#"v",
+ #"vals",
+ #(#"cdr", #"v")),
+ #(#"let-list",
+ #(),
+ #(#"cons",
+ #(#"list",
+ #(#"car", #"d"),
+ #(#"car", #"v")),
+ #"let-list"))),
+ #(#(#"null", #"d"),
+ #(#"push",
+ #(#"list",
+ #(#"car", #"newval"),
+ #(#"list*",
+ #(#"quote", #"pop-fn"),
+ #"getter",
+ #"item",
+ #"keywords")),
+ #"let-list"),
+ #(#"list",
+ #(#"quote", #"let*"),
+ #(#"nreverse", #"let-list"),
+ #"setter"))))))));
+ symbol-remove-property(#"popf", #"%fun-documentation");
+ flag-symbol-macro$symbol(#"popf");
+ end fluid-bind;
+ end fluid-bind;
#"popf";
end;
Modified: trunk/ltd/test/caching.dylan
==============================================================================
--- trunk/ltd/test/caching.dylan (original)
+++ trunk/ltd/test/caching.dylan Wed Jul 26 05:45:57 2006
@@ -122,27 +122,16 @@
begin
subgoal := make(<dtp-subgoal>, literal: new-literal);
begin
- let g15958 = conjunct.parent-conjunction;
- g15958;
- let g15959 = subgoal;
- let g15960 = #"parent-subgoal";
- let g15961 = g15958.parent-subgoal;
- .inv-slot-value(g15959, g15960, g15961);
- let g15962 = subgoal;
- let g15963 = #"parent-conjunct";
- let g15964 = conjunct;
- .inv-slot-value(g15962, g15963, g15964);
- if (g15958.parent-subgoal)
- let g15965 = subgoal;
- let g15966 = #"depth";
- let g15967 = g15958.parent-subgoal.depth + 1;
- .inv-slot-value(g15965, g15966, g15967);
- else
- let g15968 = subgoal;
- let g15969 = #"depth";
- let g15970 = 0;
- .inv-slot-value(g15968, g15969, g15970);
- end if;
+ let g152260 = conjunct.parent-conjunction;
+ begin
+ subgoal.(g152260.parent-subgoal) := g152260.parent-subgoal;
+ subgoal.parent-conjunct := conjunct;
+ if (g152260.parent-subgoal)
+ subgoal.depth := g152260.parent-subgoal.depth + 1;
+ else
+ subgoal.depth := 0;
+ end if;
+ end;
end;
subgoal;
end;
Modified: trunk/ltd/test/classes.dylan
==============================================================================
--- trunk/ltd/test/classes.dylan (original)
+++ trunk/ltd/test/classes.dylan Wed Jul 26 05:45:57 2006
@@ -56,11 +56,41 @@
else
format(stream, "?");
end if;
- (formatter-1(" with ~D answer~:P"))(stream, size(object.answers));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let init = args;
+ begin
+ write-string++(" with ", xp, 0, 6);
+ using-format(xp, "~D", pop!(args));
+ write-string++(" answer", xp, 0, 7);
+ if (~ (head(backup-in-list(1, init, args)) == 1))
+ write-char++('s', xp);
+ end if;
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, size(object.answers));
if (instance?(object.inferences, <list>))
if (object.inferences)
- (formatter-1(" [~D task~:P pending]"))(stream,
- size(object.inferences));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let init = args;
+ begin
+ write-string++(" [", xp, 0, 2);
+ using-format(xp, "~D", pop!(args));
+ write-string++(" task", xp, 0, 5);
+ if (~ (head(backup-in-list(1, init, args)) == 1))
+ write-char++('s', xp);
+ end if;
+ write-string++(" pending]", xp, 0, 9);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, size(object.inferences));
else
format(stream, " [complete]");
end if;
@@ -178,7 +208,23 @@
else
format(stream, "?");
end if;
- (formatter-1(" with ~D answer~:P>"))(stream, object.answer-count);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let init = args;
+ begin
+ write-string++(" with ", xp, 0, 6);
+ using-format(xp, "~D", pop!(args));
+ write-string++(" answer", xp, 0, 7);
+ if (~ (head(backup-in-list(1, init, args)) == 1))
+ write-char++('s', xp);
+ end if;
+ write-char++('>', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, object.answer-count);
end;
end method print-object;
Modified: trunk/ltd/test/clauses.dylan
==============================================================================
--- trunk/ltd/test/clauses.dylan (original)
+++ trunk/ltd/test/clauses.dylan Wed Jul 26 05:45:57 2006
@@ -72,9 +72,10 @@
end for;
tail := reverse!(tail);
if (head) reverse := #t; end if;
- let (g15971) = tail;
- let (g15972) = head;
- begin head := g15971; tail := g15972; end;
+ let g153318 = head;
+ let g153317 = tail;
+ head := g153317;
+ tail := g153318;
#f;
end if;
// Print the head
@@ -133,11 +134,11 @@
define method nclause-plug (clause, binding-list)
// Destructively modify CLAUSE by applying BINDING-LIST
- let list13156 = clause.clause-literals;
+ let list92543 = clause.clause-literals;
begin
do(method (old-lit) nliteral-plug(old-lit, binding-list); end method,
- list13156);
- list13156;
+ list92543);
+ list92543;
end;
clause.clause-literals
:= cl-remove-duplicates(clause.clause-literals, from-end: #t,
Modified: trunk/ltd/test/clos.dylan
==============================================================================
--- trunk/ltd/test/clos.dylan (original)
+++ trunk/ltd/test/clos.dylan Wed Jul 26 05:45:57 2006
@@ -79,9 +79,9 @@
define method make-clause (clause)
// Translate a message from define-class into a case clause.
- bq-list(first(clause),
- bq-list(#"function",
- bq-list*(#"lambda", second(clause), rest2(clause))));
+ list(first(clause),
+ list(#"function",
+ apply(list, #"lambda", second(clause), rest2(clause))));
end method make-clause;
define method ensure-generic-fn (message)
Modified: trunk/ltd/test/cmacsyma.dylan
==============================================================================
--- trunk/ltd/test/cmacsyma.dylan (original)
+++ trunk/ltd/test/cmacsyma.dylan Wed Jul 26 05:45:57 2006
@@ -376,7 +376,7 @@
1
=> base;
otherwise
- => bq-list(#"^", base, exponent);
+ => list(#"^", base, exponent);
end select;
end method exponent->prefix;
Modified: trunk/ltd/test/cnf.dylan
==============================================================================
--- trunk/ltd/test/cnf.dylan (original)
+++ trunk/ltd/test/cnf.dylan Wed Jul 26 05:45:57 2006
@@ -116,22 +116,21 @@
define method standardize-operators (p)
select (car(p))
#"=>"
- => bq-list(#"or",
- bq-list(#"not",
- bq-cons(#"and",
- begin
- let l14762 = tail(p);
- copy-sequence(l14762, size(l14762) - 1);
- end)),
- head(copy-sequence(p, start: size(p) - 1)));
+ => list(#"or",
+ list(#"not",
+ pair(#"and",
+ begin
+ let l93820 = tail(p);
+ copy-sequence(l93820, size(l93820) - 1);
+ end)),
+ head(copy-sequence(p, start: size(p) - 1)));
#"<="
- => bq-list(#"or", second(p),
- bq-list(#"not", bq-cons(#"and", tail(tail(p)))));
+ => list(#"or", second(p), list(#"not", pair(#"and", tail(tail(p)))));
#"if"
- => bq-list(#"or", third(p), bq-list(#"not", second(p)));
+ => list(#"or", third(p), list(#"not", second(p)));
(#"<=>", #"iff")
- => bq-list(#"or", bq-list(#"and", second(p), third(p)),
- bq-list(#"and", negate(second(p)), negate(third(p))));
+ => list(#"or", list(#"and", second(p), third(p)),
+ list(#"and", negate(second(p)), negate(third(p))));
otherwise
=> p;
end select;
@@ -213,16 +212,14 @@
=> select (*if-translation*)
#"bc"
=> concatenate!(nf-backward(p),
- nf-backward(bq-list(#"if",
- bq-list(#"not", third(p)),
- bq-list(#"not",
- second(p)))));
+ nf-backward(list(#"if",
+ list(#"not", third(p)),
+ list(#"not", second(p)))));
#"fc"
=> concatenate!(nf-forward(p),
- nf-forward(bq-list(#"if",
- bq-list(#"not", third(p)),
- bq-list(#"not",
- second(p)))));
+ nf-forward(list(#"if",
+ list(#"not", third(p)),
+ list(#"not", second(p)))));
#"mix"
=> concatenate!(nf-backward(p), nf-forward(p));
otherwise
@@ -244,9 +241,8 @@
end select;
#"or"
=> if (tail(tail(p)))
- normal-form(bq-list(#"<=", second(p),
- bq-list(#"not",
- bq-cons(#"and", tail(tail(p))))));
+ normal-form(list(#"<=", second(p),
+ list(#"not", pair(#"and", tail(tail(p))))));
else
normal-form(second(p));
end if;
@@ -266,11 +262,11 @@
define method nf-forward (p)
napcar(method (x)
if (tail(x))
- bq-cons(#"=>",
- bq-nconc(napcar(negate, copy-sequence(x, size(x) - 1)),
- bq-list(head(copy-sequence(x,
- start: size(x)
- - 1)))));
+ pair(#"=>",
+ concatenate!(napcar(negate, copy-sequence(x, size(x) - 1)),
+ list(head(copy-sequence(x,
+ start: size(x)
+ - 1)))));
else
head(x);
end if;
@@ -283,7 +279,7 @@
define method nf-backward (p)
napcar(method (x)
if (tail(x))
- bq-list*(#"<=", head(x), napcar(negate, tail(x)));
+ apply(list, #"<=", head(x), napcar(negate, tail(x)));
else
head(x);
end if;
Modified: trunk/ltd/test/compile1.dylan
==============================================================================
--- trunk/ltd/test/compile1.dylan (original)
+++ trunk/ltd/test/compile1.dylan Wed Jul 26 05:45:57 2006
@@ -127,14 +127,15 @@
// ==============================
def-scheme-macro(define, name(&rest, body),
if (not(instance?(name, <list>)))
- bq-list(#"name!", bq-list*(#"set!", name, body),
- bq-list(#"quote", name));
+ list(#"name!", apply(list, #"set!", name, body),
+ list(#"quote", name));
else
- scheme-macro-expand(bq-list(#"define",
- first(name),
- bq-list*(#"lambda",
- tail(name),
- body)));
+ scheme-macro-expand(list(#"define",
+ first(name),
+ apply(list,
+ #"lambda",
+ tail(name),
+ body)));
end if);
define method name! (fn, name)
@@ -155,7 +156,14 @@
// If the argument is not a function, just princ it,
// but in a column at least 8 spaces wide.
if (~ fn-p(fn))
- (formatter-1("~8a"))(stream, fn);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ using-format(xp, "~8a", pop!(args));
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, fn);
else
write-element(*standard-output*, '\n');
inc!(depth, 8);
@@ -163,7 +171,22 @@
if (label-p(instr))
format(stream, "%S:", instr);
else
- (formatter-1("~VT"))(stream, depth);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ pprint-tab+(line: begin
+ let _that = #f;
+ if (_that := pop!(args))
+ _that;
+ else
+ 1;
+ end if;
+ end,
+ 1, xp);
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, depth);
for (arg in instr) show-fn(arg, stream, depth); end for;
write-element(*standard-output*, '\n');
end if;
Modified: trunk/ltd/test/compile3.dylan
==============================================================================
--- trunk/ltd/test/compile3.dylan (original)
+++ trunk/ltd/test/compile3.dylan Wed Jul 26 05:45:57 2006
@@ -76,7 +76,14 @@
// but in a column at least 8 spaces wide.
// This version handles code that has been assembled into a vector
if (~ fn-p(fn))
- (formatter-1("~8a"))(stream, fn);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ using-format(xp, "~8a", pop!(args));
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, fn);
else
write-element(*standard-output*, '\n');
for (i from 0 below size(fn.fn-code))
@@ -84,7 +91,26 @@
if (label-p(instr))
format(stream, "%S:", instr);
else
- (formatter-1("~VT~2d: "))(stream, indent, i);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-tab+(line: begin
+ let _that = #f;
+ if (_that := pop!(args))
+ _that;
+ else
+ 1;
+ end if;
+ end,
+ 1, xp);
+ using-format(xp, "~2d", pop!(args));
+ write-string++(": ", xp, 0, 2);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, indent, i);
for (arg in instr) show-fn(arg, stream, indent + 8); end for;
write-element(*standard-output*, '\n');
end if;
@@ -266,7 +292,7 @@
define method comp-go (exp)
// Compile and execute the expression.
- machine(compiler(bq-list(#"exit", exp)));
+ machine(compiler(list(#"exit", exp)));
end method comp-go;
// Peephole Optimizer
@@ -346,3 +372,159 @@
set-dispatch-macro-character('#', 'f', method (#rest ignore) #f; end method,
*scheme-readtable*);
+set-dispatch-macro-character('#', 'd',
+ // In both Common Lisp and Scheme,
+ // #x, #o and #b are hexidecimal, octal, and binary,
+ // e.g. #xff = #o377 = #b11111111 = 255
+ // In Scheme only, #d255 is decimal 255.
+ method (stream, #rest ignore)
+ fluid-bind (*read-base* = 10)
+ scheme-read(stream);
+ end fluid-bind;
+ end method,
+ *scheme-readtable*);
+
+// LTD: Function SET-MACRO-CHARACTER not yet implemented.
+set-macro-character('`',
+ method (s, ignore)
+ list(#"quasiquote", scheme-read(s));
+ end method,
+ #f, *scheme-readtable*);
+
+// LTD: Function SET-MACRO-CHARACTER not yet implemented.
+set-macro-character(',',
+ method (stream, ignore)
+ let ch = read-element(stream, nil);
+ if (ch = '@')
+ list(#"unquote-splicing",
+ // LTD: Function READ not yet implemented.
+ read(stream));
+ else
+ unread-element(stream, ch);
+ list(#"unquote",
+ // LTD: Function READ not yet implemented.
+ read(stream));
+ end if;
+ end method,
+ #f, *scheme-readtable*);
+
+// ==============================
+define variable *primitive-fns* =
+ #(#(#"+", 2, #"+", #"true"), #(#"-", 2, #"-", #"true"),
+ #(#"*", 2, #"*", #"true"), #(#"/", 2, #"/", #"true"), #(#"<", 2, #"<"),
+ #(#">", 2, #">"), #(#"<=", 2, #"<="), #(#">=", 2, #">="),
+ #(#"/=", 2, #"/="), #(#"=", 2, #"="), #(#"eq?", 2, #"eq"),
+ #(#"equal?", 2, #"equal"), #(#"eqv?", 2, #"eql"), #(#"not", 1, #"not"),
+ #(#"null?", 1, #"not"), #(#"car", 1, #"car"), #(#"cdr", 1, #"cdr"),
+ #(#"cadr", 1, #"cadr"), #(#"cons", 2, #"cons", #"true"),
+ #(#"list", 1, #"list1", #"true"), #(#"list", 2, #"list2", #"true"),
+ #(#"list", 3, #"list3", #"true"),
+ #(#"read", 0, #"scheme-read", #(), #"t"),
+ #(#"eof-object?", 1, #"eof-object?"), // ***
+ #(#"write", 1, #"write", #(), #"t"),
+ #(#"display", 1, #"display", #(), #"t"),
+ #(#"newline", 0, #"newline", #(), #"t"),
+ #(#"compiler", 1, #"compiler", #"t"),
+ #(#"name!", 2, #"name!", #"true", #"t"),
+ #(#"random", 1, #"random", #"true", #()));
+
+// ==============================
+// (setf (scheme-macro 'quasiquote) 'quasi-q)
+define method quasi-q (x)
+ // Expand a quasiquote form into append, list, and cons calls.
+ if (instance?(x, <vector>))
+ list(#"apply", #"vector", quasi-q(as(<list>, x)));
+ elseif (not(instance?(x, <list>)))
+ if (constant?(x)) x; else list(#"quote", x); end if;
+ elseif (starts-with(x, #"unquote"))
+ assert(tail(x) & empty?(rest2(x)));
+ second(x);
+ elseif (starts-with(x, #"quasiquote"))
+ assert(tail(x) & empty?(rest2(x)));
+ quasi-q(quasi-q(second(x)));
+ elseif (starts-with(first(x), #"unquote-splicing"))
+ if (empty?(tail(x)))
+ second(first(x));
+ else
+ list(#"append", second(first(x)), quasi-q(tail(x)));
+ end if;
+ else
+ combine-quasiquote(quasi-q(head(x)), quasi-q(tail(x)), x);
+ end if;
+end method quasi-q;
+
+define method combine-quasiquote (left, right, x)
+ // Combine left and right (car and cdr), possibly re-using x.
+ if (constant?(left) & constant?(right))
+ if (// LTD: Function EVAL not yet implemented.
+ eval(left)
+ == first(x)
+ & // LTD: Function EVAL not yet implemented.
+ eval(right)
+ == tail(x))
+ list(#"quote", x);
+ else
+ list(#"quote",
+ pair(// LTD: Function EVAL not yet implemented.
+ eval(left),
+ // LTD: Function EVAL not yet implemented.
+ eval(right)));
+ end if;
+ elseif (empty?(right))
+ list(#"list", left);
+ elseif (starts-with(right, #"list"))
+ apply(list, #"list", left, tail(right));
+ else
+ list(#"cons", left, right);
+ end if;
+end method combine-quasiquote;
+
+// ==============================
+define method scheme-read (#key stream = *standard-input*)
+ fluid-bind (*readtable* = *scheme-readtable*)
+ convert-numbers(// LTD: Function READ not yet implemented.
+ read(stream, #f, eof));
+ end fluid-bind;
+end method scheme-read;
+
+define method convert-numbers (x)
+ // Replace symbols that look like Scheme numbers with their values.
+ // Don't copy structure, make changes in place.
+ select (x by instance?)
+ cons
+ => head(x) := convert-numbers(head(x));
+ tail(x) := convert-numbers(tail(x));
+ x;
+ // *** Bug fix, gat, 11/9/92
+ symbol
+ => convert-number(x) | x;
+ vector
+ => for (i from 0 below size(x)) x[i] := convert-numbers(x[i]); end for;
+ x;
+ // *** Bug fix, gat, 11/9/92
+ #t
+ => x;
+ end select;
+end method convert-numbers;
+
+define method convert-number (symbol)
+ // If str looks like a complex number, return the number.
+ let str = as(<string>, symbol);
+ let pos = find-key(str, sign-p);
+ let end = size(str) - 1;
+ if (pos & char-equal?(str[end], 'i'))
+ let re
+ = // LTD: Function READ-FROM-STRING not yet implemented.
+ read-from-string(str, #f, #f, start: 0, end: pos);
+ let im
+ = // LTD: Function READ-FROM-STRING not yet implemented.
+ read-from-string(str, #f, #f, start: pos, end: end);
+ if (instance?(re, <number>) & instance?(im, <number>))
+ // LTD: Function COMPLEX not yet implemented.
+ complex(re, im);
+ end if;
+ end if;
+end method convert-number;
+
+define method sign-p (char) cl-find(char, "+-"); end method sign-p;
+
Modified: trunk/ltd/test/conjunct.dylan
==============================================================================
--- trunk/ltd/test/conjunct.dylan (original)
+++ trunk/ltd/test/conjunct.dylan Wed Jul 26 05:45:57 2006
@@ -24,31 +24,22 @@
conjunct.nogoods := #f;
end if;
begin
- let g15973 = conjunct.subgoal;
- g15973;
+ let g154775 = conjunct.subgoal;
let answer = get-next-answer(conjunct.subgoal, conjunct);
if (answer)
- begin
- let g15974 = conjunct;
- let g15975
- = #(#"slot-value", #"conjunct", #(#"quote", #"answer-count"));
- let g15976 = g15974.g15975 + 1;
- .inv-slot-value(g15974, g15975, g15976);
- end;
+ inc!(conjunct.(conjunct.answer-count));
propagate(answer, conjunct.parent-conjunction);
elseif (exhausted-p(conjunct.subgoal))
propagate(not-an-answer: conjunct.parent-conjunction);
else
begin
- let g15977 = g15973;
- let g15978 = #"conjuncts-to-propagate-to";
- let g15979 = add!(conjunct, g15973.conjuncts-to-propagate-to);
- .inv-slot-value(g15977, g15978, g15979);
+ let new-value-154777 = conjunct;
+ let g154776
+ = add!(new-value-154777, g154775.conjuncts-to-propagate-to);
+ set-slot-value(g154775, #"conjuncts-to-propagate-to", g154776);
end;
if (~ cl-find(conjunct.subgoal, proof-subgoal-agenda(*proof*)))
- #f;
agenda-add(conjunct.subgoal);
- elseif (nil);
end if;
propagate(blocked: conjunct.parent-conjunction);
end if;
@@ -106,22 +97,13 @@
define method unattach (conjunct)
// Remove CONJUNCT from master subgoal propagate list
if (~ (conjunct.subgoal == #"uninitialized"))
- let g15980 = conjunct.subgoal;
- g15980;
- if (cl-find(conjunct, g15980.conjuncts-to-propagate-to))
- #f;
- begin
- let g15981 = g15980;
- let g15982 = #"conjuncts-to-propagate-to";
- let g15983 = remove(g15980.conjuncts-to-propagate-to, conjunct);
- .inv-slot-value(g15981, g15982, g15983);
- end;
- if (empty?(g15980.conjuncts-to-propagate-to))
- #f;
+ let g154970 = conjunct.subgoal;
+ if (cl-find(conjunct, g154970.conjuncts-to-propagate-to))
+ g154970.conjuncts-to-propagate-to
+ := remove(g154970.conjuncts-to-propagate-to, conjunct);
+ if (empty?(g154970.conjuncts-to-propagate-to))
agenda-remove(conjunct.subgoal);
- elseif (nil);
end if;
- elseif (nil);
end if;
end if;
end method unattach;
Modified: trunk/ltd/test/database.dylan
==============================================================================
--- trunk/ltd/test/database.dylan (original)
+++ trunk/ltd/test/database.dylan Wed Jul 26 05:45:57 2006
@@ -31,16 +31,52 @@
// ----------------------------------------------------------------------------
define method theory-print-function (structure, stream, depth)
- (formatter-1("<Theory ~A with ~D node~:P>"))(stream,
- structure.theory-name,
- size(structure.theory-nodes));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let init = args;
+ begin
+ write-string++("<Theory ", xp, 0, 8);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" with ", xp, 0, 6);
+ using-format(xp, "~D", pop!(args));
+ write-string++(" node", xp, 0, 5);
+ if (~ (head(backup-in-list(1, init, args)) == 1))
+ write-char++('s', xp);
+ end if;
+ write-char++('>', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, structure.theory-name, size(structure.theory-nodes));
end method theory-print-function;
define method node-index-print-function (structure, stream, depth)
- (formatter-1("<Index ~A with ~D node~:P>"))(stream,
- structure.node-index-key,
- size(structure
- .node-index-nodes));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let init = args;
+ begin
+ write-string++("<Index ", xp, 0, 7);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" with ", xp, 0, 6);
+ using-format(xp, "~D", pop!(args));
+ write-string++(" node", xp, 0, 5);
+ if (~ (head(backup-in-list(1, init, args)) == 1))
+ write-char++('s', xp);
+ end if;
+ write-char++('>', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(stream, structure.node-index-key,
+ size(structure.node-index-nodes));
end method node-index-print-function;
// ----------------------------------------------------------------------------
@@ -183,8 +219,8 @@
if (theory)
id
:= kb-node-id(first(begin
- let s14663 = theory.theory-nodes;
- copy-sequence(s14663, start: size(s14663) - 1);
+ let s93739 = theory.theory-nodes;
+ copy-sequence(s93739, start: size(s93739) - 1);
end));
str := as(<string>, id);
str := copy-sequence(str, size(as(<string>, theory-name)) + 1);
@@ -218,48 +254,78 @@
end method,
cnf-label-pairs);
nodes
- := block (return)
- let literal-list = #f;
- let label = #f;
- let g15984 :: <list> = literal-lists;
+ := begin
block (return)
- let count :: <real> = 1;
+ let literal-list = #f;
+ let label = #f;
+ let tail-156215 = literal-lists;
+ let by-156216 = #"cdr$cons";
block (return)
- let g15985 = list(#f);
- let g15986 = g15985;
+ let count = 1;
+ let to-156221 = #f;
+ let by-156222 = 1;
block (return)
- let loop-not-first-time = #f;
+ let accumulator-156213 :: <list> = list(#f);
block (return)
- local method go-end-loop ()
- return-from-nil(tail(g15985));
- end method go-end-loop,
- method go-next-loop ()
- if (not(pair?(g15984))) go-end-loop(); end if;
- let loop-desetq-temp = head(g15984);
- (literal-list := head(loop-desetq-temp));
- (loop-desetq-temp := tail(loop-desetq-temp));
- (label := head(loop-desetq-temp));
- (g15984 := tail(g15984));
- if (loop-not-first-time)
- (count := count + 1);
- else
- (loop-not-first-time := #t);
- end if;
- (tail(g15986)
- := (g15986
- := list(make-kb-node(id: make-new-id(theory-name,
- count),
- clause: make-clause-node(literals: literal-list,
- label: label)))));
- go-next-loop();
- go-end-loop();
- end method go-next-loop;
- go-next-loop();
+ let aux-var-156224 = accumulator-156213;
+ block (return)
+ block (return)
+ local method go-end-loop-156212 ()
+ return-from-nil(tail(accumulator-156213));
+ end method go-end-loop-156212,
+ method go-begin-loop-156211 ()
+ (aux-var-156224
+ := begin
+ let s93739
+ = (tail(aux-var-156224)
+ := list(make-kb-node(id: make-new-id(theory-name,
+ count),
+ clause: make-clause-node(literals: literal-list,
+ label: label))));
+ copy-sequence(s93739,
+ start: size(s93739) - 1);
+ end);
+ begin
+ if (not(pair?(tail-156215)))
+ go-end-loop-156212();
+ end if;
+ let temp-156218 = by-156216(tail-156215);
+ let temp-156217 = car$cons(tail-156215);
+ let destructor-156219 = temp-156217;
+ (literal-list := head(destructor-156219));
+ let destructor-156220
+ = tail(destructor-156219);
+ (label := head(destructor-156220));
+ #f;
+ (tail-156215 := temp-156218);
+ end;
+ let temp-156223 = count + by-156222;
+ (count := temp-156223);
+ go-begin-loop-156211();
+ go-end-loop-156212();
+ end method go-begin-loop-156211;
+ begin
+ if (not(pair?(tail-156215)))
+ go-end-loop-156212();
+ end if;
+ let temp-156218 = by-156216(tail-156215);
+ let temp-156217 = car$cons(tail-156215);
+ let destructor-156219 = temp-156217;
+ (literal-list := head(destructor-156219));
+ let destructor-156220 = tail(destructor-156219);
+ (label := head(destructor-156220));
+ #f;
+ (tail-156215 := temp-156218);
+ end;
+ #f;
+ go-begin-loop-156211();
+ end block;
+ end block;
end block;
end block;
end block;
end block;
- end block;
+ end;
make-theory-from-nodes(nodes, theory-name);
theory-name;
end block;
Modified: trunk/ltd/test/eliza.dylan
==============================================================================
--- trunk/ltd/test/eliza.dylan (original)
+++ trunk/ltd/test/eliza.dylan Wed Jul 26 05:45:57 2006
@@ -47,7 +47,25 @@
end method print-with-spaces;
define method print-with-spaces (list)
- (formatter-1("~{~a ~}"))(#t, list);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let args = pop!(args);
+ block (return)
+ local method go-l ()
+ if (empty?(args)) return(#f); end if;
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-char++(' ', xp);
+ go-l();
+ end method go-l;
+ go-l();
+ end block;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, list);
end method print-with-spaces;
// ==============================
Modified: trunk/ltd/test/fork.dylan
==============================================================================
--- trunk/ltd/test/fork.dylan (original)
+++ trunk/ltd/test/fork.dylan Wed Jul 26 05:45:57 2006
@@ -104,10 +104,9 @@
// ----------------------------------------------------------------------------
nil(#f, nil(),
"Return a copy of the conjunction (with some slot values copied)",
- nil(nil(#f, #f)),
nil(nil(), nil(#f, nil(#())), nil(nil(#f, #()), nil(nil, nil(#f, #()))),
nil(nil(#f, #()), nil(nil(#f, #()))),
- nil(nil(#(#(), #(), #(), #(), #(), #(), #(), #())),
+ nil(nil(#(#(), #(), #(), #(), #(), #(), #())),
nil(nil(#f, #f), nil(#f, #f))),
#f));
@@ -121,11 +120,9 @@
let subgoal = #f;
ac := active-conjunct(instance);
subgoal := ac.subgoal;
- let g15990 = ac;
- let g15987 = subgoal;
- let g15988 = #"conjuncts-to-propagate-to";
- let g15989 = add!(g15990, g15987.g15988);
- .inv-slot-value(g15987, g15988, g15989);
+ let new-value-157314 = ac;
+ let g157313 = add!(new-value-157314, subgoal.conjuncts-to-propagate-to);
+ set-slot-value(subgoal, #"conjuncts-to-propagate-to", g157313);
end method fork-specialize!;
// ----------------------------------------------------------------------------
Modified: trunk/ltd/test/frules.dylan
==============================================================================
--- trunk/ltd/test/frules.dylan (original)
+++ trunk/ltd/test/frules.dylan Wed Jul 26 05:45:57 2006
@@ -79,7 +79,7 @@
asn?);
// Returning this ensures that all procedure definitions
// are executed before any indexing occurs.
- bq-cons(#"progn", bq-append(*rule-procedures*, bq-list(index-form)));
+ pair(#"progn", concatenate(*rule-procedures*, list(index-form)));
end fluid-bind;
end fluid-bind;
end method do-rule;
@@ -91,8 +91,8 @@
if (empty?(triggers))
body;
else
- bq-list(bq-list(#"add-internal-rule", head(triggers),
- make-nested-rule(tail(triggers), body)));
+ list(list(#"add-internal-rule", head(triggers),
+ make-nested-rule(tail(triggers), body)));
end if;
end method make-nested-rule;
@@ -106,28 +106,30 @@
body-procedure := generate-body-procedure(pattern, var, body);
push!(match-procedure, *rule-procedures*);
push!(body-procedure, *rule-procedures*);
- bq-list(#"insert-rule",
- bq-list*(#"get-dbclass", get-trigger-dbclass(pattern),
- #(#"*ftre*")),
- bq-list(#"function",
- if (*bound-vars*)
- bq-list(#"lambda", #(#"p"),
- bq-list*(second(match-procedure), #"p",
- *bound-vars*));
- else
- second(match-procedure);
- end if),
- bq-list(#"function",
- if (*bound-vars*)
- let tv = reverse!(pattern-free-variables(trigger));
- bq-list(#"lambda", tv,
- bq-cons(second(body-procedure),
- bq-append(tv,
- scratchout(tv, *bound-vars*))));
- else
- second(body-procedure);
- end if),
- asn?);
+ list(#"insert-rule",
+ apply(list, #"get-dbclass", get-trigger-dbclass(pattern),
+ #(#"*ftre*")),
+ // return form to index rule
+ #(#"function", // the match procedure for rule
+ #(#(#","), #"if", #"*bound-vars*",
+ #(#"list", #(#"quote", #"lambda"), #(#"quote", #(#"p")),
+ #(#"list*", #(#"cadr", #"match-procedure"), #(#"quote", #"p"),
+ #"*bound-vars*")),
+ #(#"cadr", #"match-procedure"))),
+ #(#"function", // the body procedure
+ #(#(#","), #"if", #"*bound-vars*",
+ #(#"let",
+ #(#(#"tv",
+ #(#"nreverse", #(#"pattern-free-variables", #"trigger")))),
+ #(#"list", #(#"quote", #"lambda"), #"tv",
+ #(#"cons", #(#"cadr", #"body-procedure"),
+ #(#"append", #"tv",
+ #(#"quote",
+ #(// (fn-name parameters)
+ #(#(#",@"), #"scratchout", #"tv",
+ #"*bound-vars*"))))))),
+ #(#"cadr", #"body-procedure"))),
+ asn?);
end method build-rule;
define method parse-rule-trigger (trigger)
@@ -170,7 +172,7 @@
if (var) push!(var, newly-bound); end if;
body := with-pushed-variable-bindings(newly-bound, fully-expand-body(body));
env := concatenate(newly-bound, scratchout(newly-bound, *bound-vars*));
- bq-list*(#"defun", generate-rule-procedure-name(pattern), env, body);
+ apply(list, #"defun", generate-rule-procedure-name(pattern), env, body);
end method generate-body-procedure;
define method generate-match-procedure (pattern, var, test)
@@ -179,17 +181,17 @@
// That procedure will return NIL if no match,
// (values T <binding-spec>) if match is successful.
generate-match-body(pattern, pattern-free-variables(pattern), test);
- bq-list(#"defun", generate-rule-procedure-name(pattern),
- bq-cons(#"p", *bound-vars*),
- bq-list(#"if", bq-cons(#"and", tests),
- bq-list(#"values", #"t",
- if (empty?(var) & empty?(binding-specs))
- #f;
- else
- bq-cons(#"list",
- bq-append(if (var) #(#"p"); end if,
- reverse(binding-specs)));
- end if)));
+ apply(list, #"defun", generate-rule-procedure-name(pattern),
+ pair(#"p", *bound-vars*),
+ #(// first arg, P, is the pattern
+ #(#"if", #(#"and", #(#(#",@") . #"tests")),
+ #(#"values", #"t",
+ #(#(#","), #"if",
+ #(#"and", #(#"null", #"var"), #(#"null", #"binding-specs")),
+ #(),
+ #(#"cons", #(#"quote", #"list"),
+ #(#"append", #(#"if", #"var", #(#"quote", #(#"p"))),
+ #(#"reverse", #"binding-specs"))))))));
end method generate-match-procedure;
define method scratchout (l1, l2)
@@ -295,14 +297,14 @@
define method show-rules (#key stream = *standard-output*)
counter := 0;
format(stream, "\n In global context:");
- let tab15015 = ftre-dbclass-table(*ftre*);
+ let tab94009 = ftre-dbclass-table(*ftre*);
do(method (key, dbclass)
for (rule in dbclass-rules(dbclass))
inc!(counter);
print-rule(rule, stream);
end for;
end method,
- key-sequence(tab15015), tab15015);
+ key-sequence(tab94009), tab94009);
format(stream, "\n %D global rules.", counter);
if (ftre-depth(*ftre*) > 0)
format(stream, "\n In current context:");
@@ -322,13 +324,13 @@
define method get-rule (id, #key ftre = *ftre*)
block (return-from-get-rule)
- let tab15015 = ftre-dbclass-table(ftre);
+ let tab94009 = ftre-dbclass-table(ftre);
do(method (key, dbclass)
for (rule in dbclass-rules(dbclass))
if (rule.rule-id = id) return-from-get-rule(rule); end if;
end for;
end method,
- key-sequence(tab15015), tab15015);
+ key-sequence(tab94009), tab94009);
end block;
end method get-rule;
Modified: trunk/ltd/test/graph-unify.dylan
==============================================================================
--- trunk/ltd/test/graph-unify.dylan (original)
+++ trunk/ltd/test/graph-unify.dylan Wed Jul 26 05:45:57 2006
@@ -1,6 +1,11 @@
-// ----------------------------------------------------------------------------
-// GRAPH UNIFICATION
-// "graph-unify.lisp"
+// -----------------------------------------------------------------------------
+// Artificial Intelligence, Second Edition
+// Elaine Rich and Kevin Knight
+// McGraw Hill, 1991
+//
+// This code may be freely copied and used for educational or research purposes.
+// All software written by Kevin Knight.
+// Comments, bugs, improvements to knight at cs.cmu.edu
// ----------------------------------------------------------------------------
// ----------------------------------------------------------------------------
// GRAPH UNIFICATION
@@ -91,8 +96,8 @@
end method dispose-arc;
define method dispose-graph (node)
- let list13156 = nodes-in-graph(node);
- begin do(dispose-graph-node, list13156); list13156; end;
+ let list92543 = nodes-in-graph(node);
+ begin do(dispose-graph-node, list92543); list92543; end;
end method dispose-graph;
// COPIERS
@@ -186,11 +191,11 @@
define method mark-graph-1 (node, sym)
if (~ (node.graph-node-mark == sym))
node.graph-node-mark := sym;
- let list13156 = node.graph-node-arcs;
+ let list92543 = node.graph-node-arcs;
begin
do(method (a) mark-graph-1(a.arc-destination, sym); end method,
- list13156);
- list13156;
+ list92543);
+ list92543;
end;
end if;
end method mark-graph-1;
@@ -385,7 +390,7 @@
do(method (p)
p.graph-node-mfset := #f;
p.graph-node-class := second(p.graph-node-mark);
- let list13156 = third(p.graph-node-mark);
+ let list92543 = third(p.graph-node-mark);
begin
do(method (a)
add-arc-in-order(p,
@@ -397,8 +402,8 @@
.graph-node-mark);
end method)));
end method,
- list13156);
- list13156;
+ list92543);
+ list92543;
end;
end method,
n);
@@ -473,10 +478,10 @@
// UNION-FIND operations. Each node is essentially placed into a
// singleton equivalence class.
define method mf-init (x)
- let list13156 = nodes-in-graph(x);
+ let list92543 = nodes-in-graph(x);
begin
- do(method (n) n.graph-node-mfset := list(n); end method, list13156);
- list13156;
+ do(method (n) n.graph-node-mfset := list(n); end method, list92543);
+ list92543;
end;
end method mf-init;
@@ -489,13 +494,13 @@
define method create-result-graph (classes)
begin
do(method (n)
- let list13156 = n.graph-node-arcs;
+ let list92543 = n.graph-node-arcs;
begin
do(method (a)
a.arc-destination := mf-find(a.arc-destination);
end method,
- list13156);
- list13156;
+ list92543);
+ list92543;
end;
end method,
classes);
@@ -508,8 +513,8 @@
let nodes = nodes-in-graph(d);
let classes = remove(nodes, complement(mf-root-class?));
let res = create-result-graph(classes);
- let list13156 = set-difference(nodes, classes);
- begin do(dispose-graph-node, list13156); list13156; end;
+ let list92543 = set-difference(nodes, classes);
+ begin do(dispose-graph-node, list92543); list92543; end;
res;
end method create-result-graph-1;
@@ -522,8 +527,8 @@
end;
let classes = remove(nodes, complement(mf-root-class?));
let res = create-result-graph(classes);
- let list13156 = set-difference(nodes, classes);
- begin do(dispose-graph-node, list13156); list13156; end;
+ let list92543 = set-difference(nodes, classes);
+ begin do(dispose-graph-node, list92543); list92543; end;
res;
end method create-result-graph-2;
@@ -535,8 +540,8 @@
//
// Adds the arcs of n1 to n2.
define method carry-labels (n1, n2)
- let list13156 = n1.graph-node-arcs;
- begin do(method (l) add-arc(n2, l); end method, list13156); list13156; end;
+ let list92543 = n1.graph-node-arcs;
+ begin do(method (l) add-arc(n2, l); end method, list92543); list92543; end;
end method carry-labels;
// Functions for testing if a class is atomic or disjunctive, etc.
@@ -652,15 +657,15 @@
w := mf-union(u, v);
w.graph-node-class := newclass;
if (w == v) carry-labels(u, v); else carry-labels(v, u); end if;
- let list13156
+ let list92543
= intersection(graph-node-arc-labels(u), graph-node-arc-labels(v));
begin
do(method (l)
push!(pair(graph-node-subnode(u, l), graph-node-subnode(v, l)),
pairs);
end method,
- list13156);
- list13156;
+ list92543);
+ list92543;
end;
finally
create-result-graph-2(e1, e2);
Modified: trunk/ltd/test/hierarchy.dylan
==============================================================================
--- trunk/ltd/test/hierarchy.dylan (original)
+++ trunk/ltd/test/hierarchy.dylan Wed Jul 26 05:45:57 2006
@@ -73,10 +73,10 @@
// ----------------------------------------------------------------------------
define method decludes (theory-name)
- let list13156 = includees(theory-name);
+ let list92543 = includees(theory-name);
begin
- do(method (x) unincludes(theory-name, x); end method, list13156);
- list13156;
+ do(method (x) unincludes(theory-name, x); end method, list92543);
+ list92543;
end;
end method decludes;
@@ -125,8 +125,33 @@
define method show-theory-dag-internal (name, depth, already-seen)
tab-to(depth);
- (formatter-1("~:(~A~)"))(#t, name);
- if (name == *theory*) (formatter-1("~20T[Active]"))(#t); end if;
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"cap1");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, name);
+ if (name == *theory*)
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-tab+(line: 20, 1, xp);
+ write-string++("[Active]", xp, 0, 8);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t);
+ end if;
format-out("\n");
let children = includees(name);
let new-seen = union(children, already-seen);
Modified: trunk/ltd/test/jsaint.dylan
==============================================================================
--- trunk/ltd/test/jsaint.dylan (original)
+++ trunk/ltd/test/jsaint.dylan Wed Jul 26 05:45:57 2006
@@ -98,18 +98,17 @@
if (empty?(*jsaint*.jsaint-solution))
format-out("\n Problem not solved yet.");
elseif (*jsaint*.jsaint-solution == #"failed-problem")
- explore-network(get-tms-node(bq-list(#"failed", *jsaint*.jsaint-problem),
+ explore-network(get-tms-node(list(#"failed", *jsaint*.jsaint-problem),
*jsaint*.jsaint-jtre));
format-out("\n Failed to find a solution.");
elseif (*jsaint*.jsaint-solution == #"failed-empty")
format-out("\n Ran out of things to do.");
- explore-network(get-tms-node(bq-list(#"failed", *jsaint*.jsaint-problem),
+ explore-network(get-tms-node(list(#"failed", *jsaint*.jsaint-problem),
*jsaint*.jsaint-jtre));
else
format-out("\n Solved the problem:");
- explore-network(get-tms-node(bq-list(#"solution-of",
- *jsaint*.jsaint-problem,
- *jsaint*.jsaint-solution),
+ explore-network(get-tms-node(list(#"solution-of", *jsaint*.jsaint-problem,
+ *jsaint*.jsaint-solution),
*jsaint*.jsaint-jtre));
end if;
end method explain-result;
@@ -128,9 +127,13 @@
*jsaint*) then fetch-solution(*jsaint*
.jsaint-problem,
*jsaint*),
- failure-signal = backquote(failed(integrate(bq-comma(*jsaint*
- .jsaint-problem)))) then backquote(failed(integrate(bq-comma(*jsaint*
- .jsaint-problem)))),
+ failure-signal = list(#"failed",
+ list(#"integrate",
+ *jsaint*
+ .jsaint-problem)) then list(#"failed",
+ list(#"integrate",
+ *jsaint*
+ .jsaint-problem)),
until done?)
if (solution)
*jsaint*.jsaint-solution := solution;
@@ -166,27 +169,28 @@
return-from-process-subproblem(#t);
end if;
if (any?(method (f) in?(f, jtre); end method, // Already expanded
- fetch(bq-list*(#"and-subgoals", item, #(#"?subproblems")),
+ fetch(apply(list, #"and-subgoals", item, #(#"?subproblems")),
jtre)))
debugging-jsaint(*jsaint*, "~% ..already expanded.");
return-from-process-subproblem(#t);
end if;
- for (suggestion in fetch(bq-list*(#"suggest-for", item, #(#"?operator")),
+ for (suggestion in fetch(apply(list, #"suggest-for", item,
+ #(#"?operator")),
jtre))
if (in?(suggestion, jtre))
- queue-problem(bq-list(#"try", third(suggestion)), item);
- push!(bq-list(#"try", third(suggestion)), suggestions);
+ queue-problem(list(#"try", third(suggestion)), item);
+ push!(list(#"try", third(suggestion)), suggestions);
end if;
end for;
// Presume extra subgoals don't come along.
- assert!(bq-list(#"or-subgoals", item, suggestions), or-subgoals: jtre);
+ assert!(list(#"or-subgoals", item, suggestions), or-subgoals: jtre);
run-rules(jtre);
end block;
end method process-subproblem;
define method open-subproblem (item)
- assert!(bq-list(#"expanded", item), expand-agenda-item: jtre);
- assume!(bq-list(#"open", item), expand-agenda-item: jtre);
+ assert!(list(#"expanded", item), expand-agenda-item: jtre);
+ assume!(list(#"open", item), expand-agenda-item: jtre);
// Look for quick win, extra consequences.
run-rules(jtre);
end method open-subproblem;
@@ -229,7 +233,8 @@
// Auxiliary routines
define method fetch-solution (problem, #key *jsaint* = *jsaint*)
block (return-from-fetch-solution)
- for (solution in fetch(bq-list*(#"solution-of", problem, #(#"?answer")),
+ for (solution in fetch(apply(list, #"solution-of", problem,
+ #(#"?answer")),
jtre))
if (in?(solution, jtre))
return-from-fetch-solution(third(solution));
@@ -274,9 +279,9 @@
alg-goal;
elseif (head(alg-goal) == #"integral")
// Simplify as needed
- bq-list(#"integral",
- bq-list(#"eval", bq-list(#"simplify", quotize(second(alg-goal)))),
- third(alg-goal));
+ list(#"integral",
+ list(#"eval", list(#"simplify", quotize(second(alg-goal)))),
+ third(alg-goal));
else
pair(simplifying-form-of(head(alg-goal)),
simplifying-form-of(tail(alg-goal)));
@@ -289,9 +294,8 @@
inc!(counter);
let rvar = as(<symbol>, format(#f, "?RESULT%D", counter));
push!(rvar, antes);
- bq-list(#"in",
- bq-list(#"solution-of", head(subpair), head(respair)),
- #"var", rvar);
+ list(#"in", list(#"solution-of", head(subpair), head(respair)),
+ #"var", rvar);
end method,
sub-pairs, res-pairs);
values(triggers, reverse!(antes));
@@ -313,7 +317,7 @@
define method show-problem (pr, #key *jsaint* = *jsaint*)
format-out("\n%S:: (%D)", pr, estimate-difficulty(pr));
with-jtre(*jsaint*.jsaint-jtre,
- stuff := fetch(bq-list*(#"parent-of", pr, #(#"?x", #"?type"))),
+ stuff := fetch(apply(list, #"parent-of", pr, #(#"?x", #"?type"))),
if (stuff)
format-out("\n Parent(s): ");
for (p in stuff)
@@ -326,13 +330,13 @@
else
format-out("\n No parents found.");
end if,
- if (fetch(bq-list(#"expanded", pr)))
+ if (fetch(list(#"expanded", pr)))
format-out("\n Expanded,");
else
format-out("\n Not expanded,");
end if,
- if (fetch(bq-list(#"open", pr)))
- if (in?(bq-list(#"open", pr)))
+ if (fetch(list(#"open", pr)))
+ if (in?(list(#"open", pr)))
format-out(" open,");
else
format-out(" closed,");
@@ -340,20 +344,19 @@
else
format-out(" not opened,");
end if,
- if (in?(bq-list(#"relevant", pr)))
+ if (in?(list(#"relevant", pr)))
format-out(" relevant.");
else
format-out(" not relevant.");
end if,
if (stuff := fetch-solution(pr))
format-out("\n Solved, solution = %S", stuff);
- elseif ((stuff := head(fetch(bq-list(#"failed", pr))))
- & in?(stuff))
+ elseif ((stuff := head(fetch(list(#"failed", pr)))) & in?(stuff))
format-out("\n Failed.");
elseif (~ (head(pr) = #"try"))
format-out("\n Neither solved nor failed.");
end if,
- ands := fetch(bq-list*(#"and-subgoals", pr, #(#"?ands"))),
+ ands := fetch(apply(list, #"and-subgoals", pr, #(#"?ands"))),
if (ands)
format-out("\n And subgoals:");
for (subg in third(head(ands)))
@@ -361,7 +364,7 @@
end for;
format-out(".");
end if,
- ors := fetch(bq-list*(#"or-subgoals", pr, #(#"?ors"))),
+ ors := fetch(apply(list, #"or-subgoals", pr, #(#"?ors"))),
if (ors)
format-out("\n Or subgoals:");
for (subg in third(head(ors)))
@@ -404,7 +407,7 @@
end method update-ao-depth-table;
define method get-children (gp, #key *jsaint* = *jsaint*)
- for (maybe-kid in fetch(bq-list*(#"parent-of", #"?x", gp, #(#"?type")),
+ for (maybe-kid in fetch(apply(list, #"parent-of", #"?x", gp, #(#"?type")),
*jsaint*.jsaint-jtre))
if (in?(maybe-kid, *jsaint*.jsaint-jtre))
push!(second(maybe-kid), children);
Modified: trunk/ltd/test/jtms.dylan
==============================================================================
--- trunk/ltd/test/jtms.dylan (original)
+++ trunk/ltd/test/jtms.dylan Wed Jul 26 05:45:57 2006
@@ -326,20 +326,16 @@
define method contradiction-check (jtms, flag, body)
let jtmsv = generate-symbol();
let old-value = generate-symbol();
- bq-list(#"let*",
- bq-list(bq-list(jtmsv, jtms),
- bq-list(old-value,
- bq-list(#"jtms-checking-contradictions", jtmsv))),
- bq-list(#"unwind-protect",
- bq-list*(#"progn",
- bq-list(#"setf",
- bq-list(#"jtms-checking-contradictions",
- jtmsv),
- flag),
- body),
- bq-list(#"setf",
- bq-list(#"jtms-checking-contradictions", jtmsv),
- old-value)));
+ list(#"let*",
+ list(list(jtmsv, jtms),
+ list(old-value, list(#"jtms-checking-contradictions", jtmsv))),
+ list(#"unwind-protect",
+ apply(list, #"progn",
+ list(#"setf", list(#"jtms-checking-contradictions", jtmsv),
+ flag),
+ body),
+ list(#"setf", list(#"jtms-checking-contradictions", jtmsv),
+ old-value)));
end method contradiction-check;
// LTD: No macros.
Modified: trunk/ltd/test/kd.dylan
==============================================================================
--- trunk/ltd/test/kd.dylan (original)
+++ trunk/ltd/test/kd.dylan Wed Jul 26 05:45:57 2006
@@ -140,28 +140,76 @@
let losing-branch = #f;
// Decide which branch has won and set variables accordingly:
if (right-delta2 < left-delta2)
- (formatter-1("~&~aTurn toward large numbers in dimension ~a: ~\n\t\t ~a is closer to ~a than to ~a."))(#t,
- indent(level),
- dimension,
- projection,
- tree
- .node-right-min,
- tree
- .node-left-max);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-newline+(fresh: xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("Turn toward large numbers in dimension ", xp,
+ 0, 39);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(": ", xp, 0, 2);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" is closer to ", xp, 0, 14);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" than to ", xp, 0, 9);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-char++('.', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, indent(level), dimension, projection,
+ tree.node-right-min, tree.node-left-max);
begin
threshold-delta2 := left-delta2;
winning-branch := tree.node-right-samples;
losing-branch := tree.node-left-samples;
end;
else
- (formatter-1("~&~aTurn toward small numbers in dimension ~a: ~\n\t\t ~a is closer to ~a than to ~a."))(#t,
- indent(level),
- dimension,
- projection,
- tree
- .node-left-max,
- tree
- .node-right-min);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-newline+(fresh: xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("Turn toward small numbers in dimension ", xp,
+ 0, 39);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(": ", xp, 0, 2);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" is closer to ", xp, 0, 14);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" than to ", xp, 0, 9);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-char++('.', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, indent(level), dimension, projection, tree.node-left-max,
+ tree.node-right-min);
begin
threshold-delta2 := right-delta2;
winning-branch := tree.node-left-samples;
@@ -201,15 +249,56 @@
else
// Indicate why there is more work to do:
if (nearest-winning-distance2 <= threshold-delta2)
- (formatter-1("~&~aTrying alternate branch because too few answers ~\n\t\t [~a <= ~a]."))(#t,
- indent(level),
- size(winning-answers),
- count);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-newline+(fresh: xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("Trying alternate branch because too few answers ",
+ xp, 0, 48);
+ write-char++('[', xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" <= ", xp, 0, 4);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("].", xp, 0, 2);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, indent(level), size(winning-answers), count);
else
- (formatter-1("~&~aTrying other branch because worst answer ~\n\t\t is not good enough [~a > ~a]."))(#t,
- indent(level),
- nearest-winning-distance2,
- threshold-delta2);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ pprint-newline+(fresh: xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("Trying other branch because worst answer ",
+ xp, 0, 41);
+ write-string++("is not good enough [", xp, 0, 20);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++(" > ", xp, 0, 3);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ write-string++("].", xp, 0, 2);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(#t, indent(level), nearest-winning-distance2,
+ threshold-delta2);
end if;
// Establish best answers on the losing branch of the tree:
losing-answers
Modified: trunk/ltd/test/library.dylan
==============================================================================
--- trunk/ltd/test/library.dylan (original)
+++ trunk/ltd/test/library.dylan Wed Jul 26 05:45:57 2006
@@ -451,7 +451,7 @@
let retlist = #f;
let astream
= // LTD: Function MAKE-STRING-INPUT-STREAM not yet implemented.
- make-string-input-stream(as-uppercase!(title-string), 0, #f);
+ make-string-input-stream(as-uppercase!(title-string), 0);
block (nil)
begin
for (i from 0 below 20)
@@ -466,7 +466,7 @@
end for;
end;
cleanup
- deallocate-resource(#"string-input-simple-stream", astream);
+ close(astream);
end block;
pair(#"book:", reverse(retlist));
end method shrink-title;
Modified: trunk/ltd/test/literals.dylan
==============================================================================
--- trunk/ltd/test/literals.dylan (original)
+++ trunk/ltd/test/literals.dylan Wed Jul 26 05:45:57 2006
@@ -37,9 +37,40 @@
flip-negation = #f)
if (~ (node.literal-negated-p == flip-negation)) format(s, "(not "); end if;
format(s, "(");
- (formatter-1("~:(~A~)"))(s, node.literal-relation);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"cap1");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, node.literal-relation);
if (node.literal-terms)
- (formatter-1("~{ ~S~}"))(s, node.literal-terms);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ let args = pop!(args);
+ block (return)
+ local method go-l ()
+ if (empty?(args)) return(#f); end if;
+ write-char++(' ', xp);
+ fluid-bind (*print-escape* = #t)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ go-l();
+ end method go-l;
+ go-l();
+ end block;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, node.literal-terms);
end if;
format(s, ")");
if (~ (node.literal-negated-p == flip-negation)) format(s, ")"); end if;
@@ -49,53 +80,136 @@
#key s = #t,
flip-negation = #f)
if (~ (node.literal-negated-p == flip-negation)) format(s, "~"); end if;
- (formatter-1("~:(~A~)"))(s, node.literal-relation);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"cap1");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, node.literal-relation);
if (node.literal-terms)
let term-strings = #f;
term-strings
:= map(method (term)
- let s = allocate-resource(#"string-output-simple-stream");
- #"character";
- term-to-string(term, s);
- let _
- = // LTD: Function GET-OUTPUT-STREAM-STRING not yet implemented.
- get-output-stream-string(s);
- deallocate-resource(#"string-output-simple-stream", s);
- _;
+ let s
+ = // LTD: Function MAKE-STRING-OUTPUT-STREAM not yet implemented.
+ make-string-output-stream(element-type: #f);
+ block (nil)
+ begin term-to-string(term, s); end;
+ cleanup
+ close(s);
+ end block;
+ // LTD: Function GET-OUTPUT-STREAM-STRING not yet implemented.
+ get-output-stream-string(s);
end method,
node.literal-terms);
- (formatter-1("(~A~{,~A~})"))(s, head(term-strings), tail(term-strings));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ write-char++('(', xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ let args = pop!(args);
+ block (return)
+ local method go-l ()
+ if (empty?(args)) return(#f); end if;
+ write-char++(',', xp);
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ go-l();
+ end method go-l;
+ go-l();
+ end block;
+ write-char++(')', xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, head(term-strings), tail(term-strings));
end if;
end method print-literal-node-as-logic;
define method term-to-string (term, #key s = #t)
// Variable terms -> lowercase string, Constant terms -> capitalized string
if (varp(term))
- (formatter-1("~(~A~)"))(s, variable-to-string(term));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"down");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, variable-to-string(term));
elseif (instance?(term, <pair>))
- (formatter-1("~:(~A~)"))(s, first(term));
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"cap1");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, first(term));
if (tail(term)) format(s, "("); end if;
format(s, "%S",
begin
- let str = allocate-resource(#"string-output-simple-stream");
- #"character";
- for (remaining-terms = tail(term) then tail(remaining-terms),
- until empty?(remaining-terms),
- subterm = first(remaining-terms) then first(remaining-terms))
- term-to-string(subterm, str);
- if (tail(remaining-terms)) format(str, ","); end if;
- end for;
- let _
- = // LTD: Function GET-OUTPUT-STREAM-STRING not yet implemented.
- get-output-stream-string(str);
- deallocate-resource(#"string-output-simple-stream", str);
- _;
+ let str
+ = // LTD: Function MAKE-STRING-OUTPUT-STREAM not yet implemented.
+ make-string-output-stream(element-type: #f);
+ block (nil)
+ begin
+ for (remaining-terms = tail(term) then tail(remaining-terms),
+ until empty?(remaining-terms),
+ subterm = first(remaining-terms) then first(remaining-terms))
+ term-to-string(subterm, str);
+ if (tail(remaining-terms)) format(str, ","); end if;
+ end for;
+ end;
+ cleanup
+ close(str);
+ end block;
+ // LTD: Function GET-OUTPUT-STREAM-STRING not yet implemented.
+ get-output-stream-string(str);
end);
if (tail(term)) format(s, ")"); end if;
elseif (instance?(term, <string>))
format(s, "%=", term);
else
- (formatter-1("~:(~A~)"))(s, term);
+ (method (s, #rest args)
+ apply(maybe-initiate-xp-printing,
+ method (xp, #rest args)
+ begin
+ push-char-mode(xp, #"cap1");
+ fluid-bind (*print-escape* = #f)
+ write+(pop!(args), xp);
+ end fluid-bind;
+ pop-char-mode(xp);
+ end;
+ if (args) copy-sequence(args); end if;
+ end method,
+ s, args);
+ end method)(s, term);
end if;
end method term-to-string;
Modified: trunk/ltd/test/mcchef.dylan
==============================================================================
--- trunk/ltd/test/mcchef.dylan (original)
+++ trunk/ltd/test/mcchef.dylan Wed Jul 26 05:45:57 2006
@@ -62,8 +62,7 @@
define method get-precons (ingred)
format-out("\n----------------");
format-out("\nGetting preconditions for %=", ingred);
- ingred
- & slots->mop(bq-list(bq-list(#"ingred", ingred)), #(#"m-precons"), #f);
+ ingred & slots->mop(list(list(#"ingred", ingred)), #(#"m-precons"), #f);
end method get-precons;
define method make-mop (pattern, mop)
@@ -81,17 +80,17 @@
define method replace-slots (slots, mop)
for (slot(in: slots))
#"save";
- bq-list(slot-role(slot),
- begin
- let filler = slot-filler(slot);
- if (abstp(#"m-role", filler))
- role-filler(filler, mop);
- elseif (abstp(#"m-path", filler))
- path-filler(group->list(filler), mop);
- else
- filler;
- end if;
- end);
+ list(slot-role(slot),
+ begin
+ let filler = slot-filler(slot);
+ if (abstp(#"m-role", filler))
+ role-filler(filler, mop);
+ elseif (abstp(#"m-path", filler))
+ path-filler(group->list(filler), mop);
+ else
+ filler;
+ end if;
+ end);
end for;
end method replace-slots;
@@ -258,10 +257,8 @@
let absts = mop-absts(solution);
for (slot(in: slots))
#"do";
- slots->mop(forms->slots(bq-list(bq-list(slot-role(slot),
- #"m-not",
- bq-list(#"object",
- slot-filler(slot))))),
+ slots->mop(forms->slots(list(list(slot-role(slot), #"m-not",
+ list(#"object", slot-filler(slot))))),
absts, #t);
end for;
slots->mop(slots, absts, #t);
@@ -292,25 +289,22 @@
end method generalize-mop;
define method chef-explain (mop)
- slots->mop(bq-list(#"instance", bq-list(#"failure", mop),
- bq-list(#"cause", *bad-step*), #(#"rule", #"m-rule"),
- bq-list(#"mapping",
- slots->mop(forms->slots(#(#(1,
- #"m-map",
- #"instance",
- #(#"abst",
- #"m-meat"),
- #(#"spec",
- #"i-m-beef")),
- #(2,
- #"m-map",
- #"instance",
- #(#"abst",
- #"m-crisp-vegetable"),
- #(#"spec",
- #"i-m-broccoli")))),
- #(#"m-map-group"),
- #t))),
+ slots->mop(list(#"instance", list(#"failure", mop),
+ list(#"cause", *bad-step*), #(#"rule", #"m-rule"),
+ list(#"mapping",
+ slots->mop(forms->slots(#(#(1,
+ #"m-map",
+ #"instance",
+ #(#"abst", #"m-meat"),
+ #(#"spec", #"i-m-beef")),
+ #(2,
+ #"m-map",
+ #"instance",
+ #(#"abst",
+ #"m-crisp-vegetable"),
+ #(#"spec",
+ #"i-m-broccoli")))),
+ #(#"m-map-group"), #t))),
#(#"m-explanation"), #t);
end method chef-explain;
@@ -342,8 +336,8 @@
define method chef3 ()
*recipe-repair*
- := chef-repair(bq-list(bq-list(#"solution", *bad-recipe*),
- bq-list(#"explanation", *bad-recipe-explanation*)));
+ := chef-repair(list(list(#"solution", *bad-recipe*),
+ list(#"explanation", *bad-recipe-explanation*)));
*good-recipe* := role-filler(#"repaired-solution", *recipe-repair*);
end method chef3;
Modified: trunk/ltd/test/mcmops.dylan
==============================================================================
--- trunk/ltd/test/mcmops.dylan (original)
+++ trunk/ltd/test/mcmops.dylan Wed Jul 26 05:45:57 2006
@@ -15,10 +15,9 @@
define method make-insist-forms (fnname, exps)
~ empty?(exps)
- & pair(bq-list(#"or", head(exps),
- bq-list(#"error", "~S failed in ~S",
- bq-list(#"quote", head(exps)),
- bq-list(#"quote", fnname))),
+ & pair(list(#"or", head(exps),
+ list(#"error", "~S failed in ~S", list(#"quote", head(exps)),
+ list(#"quote", fnname))),
make-insist-forms(fnname, tail(exps)));
end method make-insist-forms;
@@ -57,11 +56,10 @@
var-forms);
let mapfn-body
= (for-key(head(body-forms)))(when-form,
- bq-cons(#"progn", tail(body-forms)));
- bq-list*(head(mapfn-body),
- bq-list(#"function",
- bq-list(#"lambda", vars, head(tail(mapfn-body)))),
- lists);
+ pair(#"progn", tail(body-forms)));
+ apply(list, head(mapfn-body),
+ list(#"function", list(#"lambda", vars, head(tail(mapfn-body)))),
+ lists);
end method for-expander;
// LTD: No macros.
@@ -69,39 +67,35 @@
define-for-key(always: test(body), #"every",
if (test)
- bq-list(#"or", bq-list(#"not", test), body);
+ list(#"or", list(#"not", test), body);
else
body;
end if);
define-for-key(do: test(body), #"mapc",
- if (test) bq-list(#"and", test, body); else body; end if);
+ if (test) list(#"and", test, body); else body; end if);
define-for-key(filter: test(body), #"mapcan",
begin
let fbody
- = bq-list*(#"let", bq-list(bq-list(#"x", body)),
- #(#(#"and", #"x", #(#"list", #"x"))));
- if (test) bq-list(#"and", test, fbody); else fbody; end if;
+ = apply(list, #"let", list(list(#"x", body)),
+ #(#(#"and", #"x", #(#"list", #"x"))));
+ if (test) list(#"and", test, fbody); else fbody; end if;
end);
define-for-key(first: test(body), #"some",
- if (test) bq-list(#"and", test, body); else body; end if);
+ if (test) list(#"and", test, body); else body; end if);
define-for-key(save: test(body), if (test) #"mapcan"; else #"mapcar"; end if,
if (test)
- bq-list(#"and", test, bq-list(#"list", body));
+ list(#"and", test, list(#&qu