[Gd-chatter] r10831 - in trunk/ltd: code test
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Wed Jul 26 00:27:46 CEST 2006
Author: turbo24prg
Date: Wed Jul 26 00:27:39 2006
New Revision: 10831
Modified:
trunk/ltd/code/load.lisp
trunk/ltd/code/ltd-table.lisp
trunk/ltd/code/options.lisp
trunk/ltd/code/read.lisp
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: minor
* patch from blitz
Modified: trunk/ltd/code/load.lisp
==============================================================================
--- trunk/ltd/code/load.lisp (original)
+++ trunk/ltd/code/load.lisp Wed Jul 26 00:27:39 2006
@@ -5,9 +5,10 @@
;;;; Common Lisp to Dylan Converter --- (Load-LTD) loads the system
(defun load-ltd (&key (compile nil))
- (mapc #'(lambda (file) (load (if compile (compile-file file) file)))
- '("misc.lisp" "options.lisp" "read.lisp" "dpp.lisp"
- "ltd.lisp" "ltd-table.lisp" "loop.lisp" "tables.lisp")))
+ (with-compilation-unit ()
+ (mapc #'(lambda (file) (load (if compile (compile-file file) file)))
+ '("misc.lisp" "options.lisp" "read.lisp" "dpp.lisp"
+ "ltd.lisp" "ltd-table.lisp" "loop.lisp" "tables.lisp"))))
(defun test-ltd ()
(defpackage comp)
Modified: trunk/ltd/code/ltd-table.lisp
==============================================================================
--- trunk/ltd/code/ltd-table.lisp (original)
+++ trunk/ltd/code/ltd-table.lisp Wed Jul 26 00:27:39 2006
@@ -748,7 +748,7 @@
(let* ((length (length control))
(i 0)
(unhandled nil)
- (result (make-array length :element-type 'string-char
+ (result (make-array length :element-type 'character
:adjustable t :fill-pointer 0)))
(flet ((emit (ch) (vector-push-extend ch result))
(consume () (if (< i length) (prog1 (aref control i) (incf i)))))
Modified: trunk/ltd/code/options.lisp
==============================================================================
--- trunk/ltd/code/options.lisp (original)
+++ trunk/ltd/code/options.lisp Wed Jul 26 00:27:39 2006
@@ -19,7 +19,7 @@
(defstruct (option (:type list))
name value type doc)
-(deftype boolean () '(member t nil))
+;(deftype boolean () '(member t nil))
(defparameter *default-options*
`(
Modified: trunk/ltd/code/read.lisp
==============================================================================
--- trunk/ltd/code/read.lisp (original)
+++ trunk/ltd/code/read.lisp Wed Jul 26 00:27:39 2006
@@ -9,16 +9,6 @@
(defvar *buffer*
(make-array 200 :element-type 'character :fill-pointer 0 :adjustable t))
-
-(defparameter *ltd-readtable*
- (let ((table (copy-readtable *readtable*)))
- (set-macro-character #\; 'collect-comments nil table)
- (set-macro-character #\( 'ltd-read-list nil table)
- (set-dispatch-macro-character #\# #\| 'collect-comments table)
- (set-dispatch-macro-character #\# #\A 'read-array table)
- (set-dispatch-macro-character #\# #\a 'read-array table)
- table))
-
(defstruct (com (:predicate comment?))
;; We spell it COM because LispWorks has a class called comment
(comment "") (code nil))
@@ -118,6 +108,14 @@
(otherwise (vector-push-extend char *buffer*))))))
(coerce *buffer* 'string))
+(defparameter *ltd-readtable*
+ (let ((table (copy-readtable *readtable*)))
+ (set-macro-character #\; 'collect-comments nil table)
+ (set-macro-character #\( 'ltd-read-list nil table)
+ (set-dispatch-macro-character #\# #\| 'collect-comments table)
+ (set-dispatch-macro-character #\# #\A 'read-array table)
+ (set-dispatch-macro-character #\# #\a 'read-array table)
+ table))
(defun ltd-read (&optional (stream *standard-input*))
"Read a Lisp expression, preserving comments and file positions."
Modified: trunk/ltd/test/aima-dtp.dylan
==============================================================================
--- trunk/ltd/test/aima-dtp.dylan (original)
+++ trunk/ltd/test/aima-dtp.dylan Wed Jul 26 00:27:39 2006
@@ -67,28 +67,11 @@
begin
define variable *dtp-version* =
- (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*);
+ (formatter-1("~D.~2,'0D [~A,~A]"))(#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 00:27:39 2006
@@ -395,10 +395,8 @@
define method union-env (e1, e2)
if (e1.env-count > e2.env-count)
- let g108128 = e2;
- let g108129 = e1;
- e1 := g108128;
- e2 := g108129;
+ let g15926 = e2;
+ begin e2 := e1; e1 := g15926; end;
#f;
end if;
block (return)
@@ -723,40 +721,7 @@
printer := atms-node-string(tms-node-atms(head(assumptions)));
end if;
for (a in assumptions) push!(printer(a), strings); end for;
- (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?));
+ (formatter-1("{~{~A~^,~}}"))(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 00:27:39 2006
@@ -153,10 +153,11 @@
define method seq-ref (seq, index)
// Return code that indexes into a sequence, using
// the pop-lists/aref-vectors strategy.
- list(#"if", list(#"listp", seq),
- list(#"prog1", list(#"first", seq),
- list(#"setq", seq, list(#"the", #"list", list(#"rest", seq)))),
- list(#"aref", seq, index));
+ 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));
end method seq-ref;
define method maybe-set-fill-pointer (array, new-length)
@@ -272,31 +273,18 @@
// 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:
-//
-nil(#f, nil(#f), "Concatenate symbols or strings to form an interned symbol",
- nil(nil(#f, "~{~a~}", #f)));
+#"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;
define method new-symbol (#rest args)
// Concatenate symbols or strings to form an uninterned symbol
- 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));
+ as(<symbol>, (formatter-1("~{~a~}"))(#f, args));
end method new-symbol;
define method last1 (list)
@@ -512,8 +500,8 @@
// Add the elements of LIST to the end of the queue.
head(q)
:= begin
- let s93739 = (tail(head(q)) := list);
- copy-sequence(s93739, start: size(s93739) - 1);
+ let s14663 = (tail(head(q)) := list);
+ copy-sequence(s14663, start: size(s14663) - 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 00:27:39 2006
@@ -1,11 +1,7 @@
// ----------------------------------------------------------------------------
-// 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
+// (SINGLE, BINARY OUTPUT)
+// "backprop.lisp"
// ----------------------------------------------------------------------------
// ----------------------------------------------------------------------------
// BACKPROPAGATION ALGORITHM
@@ -448,19 +444,9 @@
#f;
end for;
if (verbose)
- (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]));
+ (formatter-1("Result = ~14,7f ...~%"))(#t,
+ unit-activation(output-layer
+ .net-units[1]));
end if;
end method feed-forward;
@@ -506,27 +492,15 @@
= mult(eta, hi-unit.unit-delta, low-unit.unit-activation)
+ mult(temp-alpha, the-connection.connection-delta-weight);
if (verbose)
- (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);
+ (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);
end if;
the-connection.connection-weight
:= the-connection.connection-weight + newchange;
@@ -590,67 +564,27 @@
format(ifile, "EPOCH %d. Performance on training data:\n\n", epoch);
format(ifile, "Confidence: ");
for (i = 0 then 1+(i), until i = 8)
- (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);
+ (formatter-1("~6,2f "))(ifile, i * 0.05);
end for;
format(ifile, "\n");
format(ifile, "Guessed: ");
for (i = 0 then 1+(i), until i = 8)
- (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]));
+ (formatter-1("~6d "))(ifile, round(total-guessed[i]));
end for;
format(ifile, "\n");
format(ifile, "Correct: ");
for (i = 0 then 1+(i), until i = 8)
- (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]));
+ (formatter-1("~6d "))(ifile, round(total-right[i]));
end for;
format(ifile, "\n");
format(ifile, "Percent: ");
for (i = 0 then 1+(i), until i = 8)
- (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);
+ (formatter-1("~6,2f "))(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;
@@ -679,67 +613,27 @@
format(ifile, "EPOCH %d. Performance on testing data:\n\n", epoch);
format(ifile, "Confidence: ");
for (i = 0 then 1+(i), until i = 8)
- (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);
+ (formatter-1("~6,2f "))(ifile, i * 0.05);
end for;
format(ifile, "\n");
format(ifile, "Guessed: ");
for (i = 0 then 1+(i), until i = 8)
- (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]));
+ (formatter-1("~6d "))(ifile, round(total-guessed[i]));
end for;
format(ifile, "\n");
format(ifile, "Correct: ");
for (i = 0 then 1+(i), until i = 8)
- (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]));
+ (formatter-1("~6d "))(ifile, round(total-right[i]));
end for;
format(ifile, "\n");
format(ifile, "Percent: ");
for (i = 0 then 1+(i), until i = 8)
- (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);
+ (formatter-1("~6,2f "))(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;
@@ -757,8 +651,12 @@
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];
- format(ifile, "(~d ~d ~d ~14.7f)~%", k, u, u2,
- the-connection.connection-weight);
+ (formatter-1("(~d ~d ~d ~14.7f)~%"))(ifile,
+ 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 00:27:39 2006
@@ -29,21 +29,41 @@
if (conjunction.stack-pointer = conjunction.backtrack-pointer)
return-from-compute-nogoods(#f);
end if;
- let g151404 = active-conjunct(conjunction);
- begin
- if (g151404.nogoods == #"uninitialized") g151404.nogoods := #f; end if;
+ let g15949 = active-conjunct(conjunction);
+ g15949;
+ if (g15949.nogoods == #"uninitialized")
+ #f;
begin
- 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;
+ let g15950 = g15949;
+ let g15951 = #"nogoods";
+ let g15952 = #f;
+ .inv-slot-value(g15950, g15951, g15952);
end;
- 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 block;
end method compute-nogoods;
@@ -99,7 +119,8 @@
//
// ----------------------------------------------------------------------------
nil(#f, nil(), "Unless waiting for next subgoal answer, get the next answer",
- nil((nil(nil(#f)))(),
+ nil(nil(#f, #f)),
+ nil((nil(nil(#f)))(), nil(nil(nil(#f, #f), #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 00:27:39 2006
@@ -212,14 +212,15 @@
"%S",
variable)[0],
inc!(*name-counter*)),
- 0);
+ 0,
+ #f);
block (nil)
begin
// LTD: Function READ not yet implemented.
read(input);
end;
cleanup
- close(input);
+ deallocate-resource(#"string-input-simple-stream", 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 00:27:39 2006
@@ -53,138 +53,94 @@
// 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
- 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;
+ 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");
#"popf";
end;
Modified: trunk/ltd/test/caching.dylan
==============================================================================
--- trunk/ltd/test/caching.dylan (original)
+++ trunk/ltd/test/caching.dylan Wed Jul 26 00:27:39 2006
@@ -122,16 +122,27 @@
begin
subgoal := make(<dtp-subgoal>, literal: new-literal);
begin
- 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;
+ 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;
end;
subgoal;
end;
Modified: trunk/ltd/test/classes.dylan
==============================================================================
--- trunk/ltd/test/classes.dylan (original)
+++ trunk/ltd/test/classes.dylan Wed Jul 26 00:27:39 2006
@@ -56,41 +56,11 @@
else
format(stream, "?");
end if;
- (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));
+ (formatter-1(" with ~D answer~:P"))(stream, size(object.answers));
if (instance?(object.inferences, <list>))
if (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));
+ (formatter-1(" [~D task~:P pending]"))(stream,
+ size(object.inferences));
else
format(stream, " [complete]");
end if;
@@ -208,23 +178,7 @@
else
format(stream, "?");
end if;
- (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);
+ (formatter-1(" with ~D answer~:P>"))(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 00:27:39 2006
@@ -72,10 +72,9 @@
end for;
tail := reverse!(tail);
if (head) reverse := #t; end if;
- let g153318 = head;
- let g153317 = tail;
- head := g153317;
- tail := g153318;
+ let (g15971) = tail;
+ let (g15972) = head;
+ begin head := g15971; tail := g15972; end;
#f;
end if;
// Print the head
@@ -134,11 +133,11 @@
define method nclause-plug (clause, binding-list)
// Destructively modify CLAUSE by applying BINDING-LIST
- let list92543 = clause.clause-literals;
+ let list13156 = clause.clause-literals;
begin
do(method (old-lit) nliteral-plug(old-lit, binding-list); end method,
- list92543);
- list92543;
+ list13156);
+ list13156;
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 00:27:39 2006
@@ -79,9 +79,9 @@
define method make-clause (clause)
// Translate a message from define-class into a case clause.
- list(first(clause),
- list(#"function",
- apply(list, #"lambda", second(clause), rest2(clause))));
+ bq-list(first(clause),
+ bq-list(#"function",
+ bq-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 00:27:39 2006
@@ -376,7 +376,7 @@
1
=> base;
otherwise
- => list(#"^", base, exponent);
+ => bq-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 00:27:39 2006
@@ -116,21 +116,22 @@
define method standardize-operators (p)
select (car(p))
#"=>"
- => 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",
+ 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", second(p), list(#"not", pair(#"and", tail(tail(p)))));
+ => bq-list(#"or", second(p),
+ bq-list(#"not", bq-cons(#"and", tail(tail(p)))));
#"if"
- => list(#"or", third(p), list(#"not", second(p)));
+ => bq-list(#"or", third(p), bq-list(#"not", second(p)));
(#"<=>", #"iff")
- => list(#"or", list(#"and", second(p), third(p)),
- list(#"and", negate(second(p)), negate(third(p))));
+ => bq-list(#"or", bq-list(#"and", second(p), third(p)),
+ bq-list(#"and", negate(second(p)), negate(third(p))));
otherwise
=> p;
end select;
@@ -212,14 +213,16 @@
=> select (*if-translation*)
#"bc"
=> concatenate!(nf-backward(p),
- nf-backward(list(#"if",
- list(#"not", third(p)),
- list(#"not", second(p)))));
+ nf-backward(bq-list(#"if",
+ bq-list(#"not", third(p)),
+ bq-list(#"not",
+ second(p)))));
#"fc"
=> concatenate!(nf-forward(p),
- nf-forward(list(#"if",
- list(#"not", third(p)),
- list(#"not", second(p)))));
+ nf-forward(bq-list(#"if",
+ bq-list(#"not", third(p)),
+ bq-list(#"not",
+ second(p)))));
#"mix"
=> concatenate!(nf-backward(p), nf-forward(p));
otherwise
@@ -241,8 +244,9 @@
end select;
#"or"
=> if (tail(tail(p)))
- normal-form(list(#"<=", second(p),
- list(#"not", pair(#"and", tail(tail(p))))));
+ normal-form(bq-list(#"<=", second(p),
+ bq-list(#"not",
+ bq-cons(#"and", tail(tail(p))))));
else
normal-form(second(p));
end if;
@@ -262,11 +266,11 @@
define method nf-forward (p)
napcar(method (x)
if (tail(x))
- pair(#"=>",
- concatenate!(napcar(negate, copy-sequence(x, size(x) - 1)),
- list(head(copy-sequence(x,
- start: size(x)
- - 1)))));
+ bq-cons(#"=>",
+ bq-nconc(napcar(negate, copy-sequence(x, size(x) - 1)),
+ bq-list(head(copy-sequence(x,
+ start: size(x)
+ - 1)))));
else
head(x);
end if;
@@ -279,7 +283,7 @@
define method nf-backward (p)
napcar(method (x)
if (tail(x))
- apply(list, #"<=", head(x), napcar(negate, tail(x)));
+ bq-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 00:27:39 2006
@@ -127,15 +127,14 @@
// ==============================
def-scheme-macro(define, name(&rest, body),
if (not(instance?(name, <list>)))
- list(#"name!", apply(list, #"set!", name, body),
- list(#"quote", name));
+ bq-list(#"name!", bq-list*(#"set!", name, body),
+ bq-list(#"quote", name));
else
- scheme-macro-expand(list(#"define",
- first(name),
- apply(list,
- #"lambda",
- tail(name),
- body)));
+ scheme-macro-expand(bq-list(#"define",
+ first(name),
+ bq-list*(#"lambda",
+ tail(name),
+ body)));
end if);
define method name! (fn, name)
@@ -156,14 +155,7 @@
// If the argument is not a function, just princ it,
// but in a column at least 8 spaces wide.
if (~ fn-p(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);
+ (formatter-1("~8a"))(stream, fn);
else
write-element(*standard-output*, '\n');
inc!(depth, 8);
@@ -171,22 +163,7 @@
if (label-p(instr))
format(stream, "%S:", instr);
else
- (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);
+ (formatter-1("~VT"))(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 00:27:39 2006
@@ -76,14 +76,7 @@
// but in a column at least 8 spaces wide.
// This version handles code that has been assembled into a vector
if (~ fn-p(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);
+ (formatter-1("~8a"))(stream, fn);
else
write-element(*standard-output*, '\n');
for (i from 0 below size(fn.fn-code))
@@ -91,26 +84,7 @@
if (label-p(instr))
format(stream, "%S:", instr);
else
- (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);
+ (formatter-1("~VT~2d: "))(stream, indent, i);
for (arg in instr) show-fn(arg, stream, indent + 8); end for;
write-element(*standard-output*, '\n');
end if;
@@ -292,7 +266,7 @@
define method comp-go (exp)
// Compile and execute the expression.
- machine(compiler(list(#"exit", exp)));
+ machine(compiler(bq-list(#"exit", exp)));
end method comp-go;
// Peephole Optimizer
@@ -372,159 +346,3 @@
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 00:27:39 2006
@@ -24,22 +24,31 @@
conjunct.nogoods := #f;
end if;
begin
- let g154775 = conjunct.subgoal;
+ let g15973 = conjunct.subgoal;
+ g15973;
let answer = get-next-answer(conjunct.subgoal, conjunct);
if (answer)
- inc!(conjunct.(conjunct.answer-count));
+ begin
+ let g15974 = conjunct;
+ let g15975
+ = #(#"slot-value", #"conjunct", #(#"quote", #"answer-count"));
+ let g15976 = g15974.g15975 + 1;
+ .inv-slot-value(g15974, g15975, g15976);
+ end;
propagate(answer, conjunct.parent-conjunction);
elseif (exhausted-p(conjunct.subgoal))
propagate(not-an-answer: conjunct.parent-conjunction);
else
begin
- 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);
+ let g15977 = g15973;
+ let g15978 = #"conjuncts-to-propagate-to";
+ let g15979 = add!(conjunct, g15973.conjuncts-to-propagate-to);
+ .inv-slot-value(g15977, g15978, g15979);
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;
@@ -97,13 +106,22 @@
define method unattach (conjunct)
// Remove CONJUNCT from master subgoal propagate list
if (~ (conjunct.subgoal == #"uninitialized"))
- 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))
+ 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;
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 00:27:39 2006
@@ -31,52 +31,16 @@
// ----------------------------------------------------------------------------
define method theory-print-function (structure, stream, depth)
- (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));
+ (formatter-1("<Theory ~A with ~D node~:P>"))(stream,
+ structure.theory-name,
+ size(structure.theory-nodes));
end method theory-print-function;
define method node-index-print-function (structure, stream, depth)
- (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));
+ (formatter-1("<Index ~A with ~D node~:P>"))(stream,
+ structure.node-index-key,
+ size(structure
+ .node-index-nodes));
end method node-index-print-function;
// ----------------------------------------------------------------------------
@@ -219,8 +183,8 @@
if (theory)
id
:= kb-node-id(first(begin
- let s93739 = theory.theory-nodes;
- copy-sequence(s93739, start: size(s93739) - 1);
+ let s14663 = theory.theory-nodes;
+ copy-sequence(s14663, start: size(s14663) - 1);
end));
str := as(<string>, id);
str := copy-sequence(str, size(as(<string>, theory-name)) + 1);
@@ -254,78 +218,48 @@
end method,
cnf-label-pairs);
nodes
- := begin
+ := block (return)
+ let literal-list = #f;
+ let label = #f;
+ let g15984 :: <list> = literal-lists;
block (return)
- let literal-list = #f;
- let label = #f;
- let tail-156215 = literal-lists;
- let by-156216 = #"cdr$cons";
+ let count :: <real> = 1;
block (return)
- let count = 1;
- let to-156221 = #f;
- let by-156222 = 1;
+ let g15985 = list(#f);
+ let g15986 = g15985;
block (return)
- let accumulator-156213 :: <list> = list(#f);
+ let loop-not-first-time = #f;
block (return)
- 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;
+ 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();
end block;
end block;
end block;
end block;
- end;
+ end block;
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 00:27:39 2006
@@ -47,25 +47,7 @@
end method print-with-spaces;
define method print-with-spaces (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);
+ (formatter-1("~{~a ~}"))(#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 00:27:39 2006
@@ -104,9 +104,10 @@
// ----------------------------------------------------------------------------
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));
@@ -120,9 +121,11 @@
let subgoal = #f;
ac := active-conjunct(instance);
subgoal := ac.subgoal;
- 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);
+ let g15990 = ac;
+ let g15987 = subgoal;
+ let g15988 = #"conjuncts-to-propagate-to";
+ let g15989 = add!(g15990, g15987.g15988);
+ .inv-slot-value(g15987, g15988, g15989);
end method fork-specialize!;
// ----------------------------------------------------------------------------
Modified: trunk/ltd/test/frules.dylan
==============================================================================
--- trunk/ltd/test/frules.dylan (original)
+++ trunk/ltd/test/frules.dylan Wed Jul 26 00:27:39 2006
@@ -79,7 +79,7 @@
asn?);
// Returning this ensures that all procedure definitions
// are executed before any indexing occurs.
- pair(#"progn", concatenate(*rule-procedures*, list(index-form)));
+ bq-cons(#"progn", bq-append(*rule-procedures*, bq-list(index-form)));
end fluid-bind;
end fluid-bind;
end method do-rule;
@@ -91,8 +91,8 @@
if (empty?(triggers))
body;
else
- list(list(#"add-internal-rule", head(triggers),
- make-nested-rule(tail(triggers), body)));
+ bq-list(bq-list(#"add-internal-rule", head(triggers),
+ make-nested-rule(tail(triggers), body)));
end if;
end method make-nested-rule;
@@ -106,30 +106,28 @@
body-procedure := generate-body-procedure(pattern, var, body);
push!(match-procedure, *rule-procedures*);
push!(body-procedure, *rule-procedures*);
- 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?);
+ 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?);
end method build-rule;
define method parse-rule-trigger (trigger)
@@ -172,7 +170,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*));
- apply(list, #"defun", generate-rule-procedure-name(pattern), env, body);
+ bq-list*(#"defun", generate-rule-procedure-name(pattern), env, body);
end method generate-body-procedure;
define method generate-match-procedure (pattern, var, test)
@@ -181,17 +179,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);
- 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"))))))));
+ 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)));
end method generate-match-procedure;
define method scratchout (l1, l2)
@@ -297,14 +295,14 @@
define method show-rules (#key stream = *standard-output*)
counter := 0;
format(stream, "\n In global context:");
- let tab94009 = ftre-dbclass-table(*ftre*);
+ let tab15015 = 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(tab94009), tab94009);
+ key-sequence(tab15015), tab15015);
format(stream, "\n %D global rules.", counter);
if (ftre-depth(*ftre*) > 0)
format(stream, "\n In current context:");
@@ -324,13 +322,13 @@
define method get-rule (id, #key ftre = *ftre*)
block (return-from-get-rule)
- let tab94009 = ftre-dbclass-table(ftre);
+ let tab15015 = 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(tab94009), tab94009);
+ key-sequence(tab15015), tab15015);
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 00:27:39 2006
@@ -1,11 +1,6 @@
-// -----------------------------------------------------------------------------
-// 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
+// "graph-unify.lisp"
// ----------------------------------------------------------------------------
// ----------------------------------------------------------------------------
// GRAPH UNIFICATION
@@ -96,8 +91,8 @@
end method dispose-arc;
define method dispose-graph (node)
- let list92543 = nodes-in-graph(node);
- begin do(dispose-graph-node, list92543); list92543; end;
+ let list13156 = nodes-in-graph(node);
+ begin do(dispose-graph-node, list13156); list13156; end;
end method dispose-graph;
// COPIERS
@@ -191,11 +186,11 @@
define method mark-graph-1 (node, sym)
if (~ (node.graph-node-mark == sym))
node.graph-node-mark := sym;
- let list92543 = node.graph-node-arcs;
+ let list13156 = node.graph-node-arcs;
begin
do(method (a) mark-graph-1(a.arc-destination, sym); end method,
- list92543);
- list92543;
+ list13156);
+ list13156;
end;
end if;
end method mark-graph-1;
@@ -390,7 +385,7 @@
do(method (p)
p.graph-node-mfset := #f;
p.graph-node-class := second(p.graph-node-mark);
- let list92543 = third(p.graph-node-mark);
+ let list13156 = third(p.graph-node-mark);
begin
do(method (a)
add-arc-in-order(p,
@@ -402,8 +397,8 @@
.graph-node-mark);
end method)));
end method,
- list92543);
- list92543;
+ list13156);
+ list13156;
end;
end method,
n);
@@ -478,10 +473,10 @@
// UNION-FIND operations. Each node is essentially placed into a
// singleton equivalence class.
define method mf-init (x)
- let list92543 = nodes-in-graph(x);
+ let list13156 = nodes-in-graph(x);
begin
- do(method (n) n.graph-node-mfset := list(n); end method, list92543);
- list92543;
+ do(method (n) n.graph-node-mfset := list(n); end method, list13156);
+ list13156;
end;
end method mf-init;
@@ -494,13 +489,13 @@
define method create-result-graph (classes)
begin
do(method (n)
- let list92543 = n.graph-node-arcs;
+ let list13156 = n.graph-node-arcs;
begin
do(method (a)
a.arc-destination := mf-find(a.arc-destination);
end method,
- list92543);
- list92543;
+ list13156);
+ list13156;
end;
end method,
classes);
@@ -513,8 +508,8 @@
let nodes = nodes-in-graph(d);
let classes = remove(nodes, complement(mf-root-class?));
let res = create-result-graph(classes);
- let list92543 = set-difference(nodes, classes);
- begin do(dispose-graph-node, list92543); list92543; end;
+ let list13156 = set-difference(nodes, classes);
+ begin do(dispose-graph-node, list13156); list13156; end;
res;
end method create-result-graph-1;
@@ -527,8 +522,8 @@
end;
let classes = remove(nodes, complement(mf-root-class?));
let res = create-result-graph(classes);
- let list92543 = set-difference(nodes, classes);
- begin do(dispose-graph-node, list92543); list92543; end;
+ let list13156 = set-difference(nodes, classes);
+ begin do(dispose-graph-node, list13156); list13156; end;
res;
end method create-result-graph-2;
@@ -540,8 +535,8 @@
//
// Adds the arcs of n1 to n2.
define method carry-labels (n1, n2)
- let list92543 = n1.graph-node-arcs;
- begin do(method (l) add-arc(n2, l); end method, list92543); list92543; end;
+ let list13156 = n1.graph-node-arcs;
+ begin do(method (l) add-arc(n2, l); end method, list13156); list13156; end;
end method carry-labels;
// Functions for testing if a class is atomic or disjunctive, etc.
@@ -657,15 +652,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 list92543
+ let list13156
= 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,
- list92543);
- list92543;
+ list13156);
+ list13156;
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 00:27:39 2006
@@ -73,10 +73,10 @@
// ----------------------------------------------------------------------------
define method decludes (theory-name)
- let list92543 = includees(theory-name);
+ let list13156 = includees(theory-name);
begin
- do(method (x) unincludes(theory-name, x); end method, list92543);
- list92543;
+ do(method (x) unincludes(theory-name, x); end method, list13156);
+ list13156;
end;
end method decludes;
@@ -125,33 +125,8 @@
define method show-theory-dag-internal (name, depth, already-seen)
tab-to(depth);
- (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;
+ (formatter-1("~:(~A~)"))(#t, name);
+ if (name == *theory*) (formatter-1("~20T[Active]"))(#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 00:27:39 2006
@@ -98,17 +98,18 @@
if (empty?(*jsaint*.jsaint-solution))
format-out("\n Problem not solved yet.");
elseif (*jsaint*.jsaint-solution == #"failed-problem")
- explore-network(get-tms-node(list(#"failed", *jsaint*.jsaint-problem),
+ explore-network(get-tms-node(bq-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(list(#"failed", *jsaint*.jsaint-problem),
+ explore-network(get-tms-node(bq-list(#"failed", *jsaint*.jsaint-problem),
*jsaint*.jsaint-jtre));
else
format-out("\n Solved the problem:");
- explore-network(get-tms-node(list(#"solution-of", *jsaint*.jsaint-problem,
- *jsaint*.jsaint-solution),
+ explore-network(get-tms-node(bq-list(#"solution-of",
+ *jsaint*.jsaint-problem,
+ *jsaint*.jsaint-solution),
*jsaint*.jsaint-jtre));
end if;
end method explain-result;
@@ -127,13 +128,9 @@
*jsaint*) then fetch-solution(*jsaint*
.jsaint-problem,
*jsaint*),
- failure-signal = list(#"failed",
- list(#"integrate",
- *jsaint*
- .jsaint-problem)) then list(#"failed",
- list(#"integrate",
- *jsaint*
- .jsaint-problem)),
+ failure-signal = backquote(failed(integrate(bq-comma(*jsaint*
+ .jsaint-problem)))) then backquote(failed(integrate(bq-comma(*jsaint*
+ .jsaint-problem)))),
until done?)
if (solution)
*jsaint*.jsaint-solution := solution;
@@ -169,28 +166,27 @@
return-from-process-subproblem(#t);
end if;
if (any?(method (f) in?(f, jtre); end method, // Already expanded
- fetch(apply(list, #"and-subgoals", item, #(#"?subproblems")),
+ fetch(bq-list*(#"and-subgoals", item, #(#"?subproblems")),
jtre)))
debugging-jsaint(*jsaint*, "~% ..already expanded.");
return-from-process-subproblem(#t);
end if;
- for (suggestion in fetch(apply(list, #"suggest-for", item,
- #(#"?operator")),
+ for (suggestion in fetch(bq-list*(#"suggest-for", item, #(#"?operator")),
jtre))
if (in?(suggestion, jtre))
- queue-problem(list(#"try", third(suggestion)), item);
- push!(list(#"try", third(suggestion)), suggestions);
+ queue-problem(bq-list(#"try", third(suggestion)), item);
+ push!(bq-list(#"try", third(suggestion)), suggestions);
end if;
end for;
// Presume extra subgoals don't come along.
- assert!(list(#"or-subgoals", item, suggestions), or-subgoals: jtre);
+ assert!(bq-list(#"or-subgoals", item, suggestions), or-subgoals: jtre);
run-rules(jtre);
end block;
end method process-subproblem;
define method open-subproblem (item)
- assert!(list(#"expanded", item), expand-agenda-item: jtre);
- assume!(list(#"open", item), expand-agenda-item: jtre);
+ assert!(bq-list(#"expanded", item), expand-agenda-item: jtre);
+ assume!(bq-list(#"open", item), expand-agenda-item: jtre);
// Look for quick win, extra consequences.
run-rules(jtre);
end method open-subproblem;
@@ -233,8 +229,7 @@
// Auxiliary routines
define method fetch-solution (problem, #key *jsaint* = *jsaint*)
block (return-from-fetch-solution)
- for (solution in fetch(apply(list, #"solution-of", problem,
- #(#"?answer")),
+ for (solution in fetch(bq-list*(#"solution-of", problem, #(#"?answer")),
jtre))
if (in?(solution, jtre))
return-from-fetch-solution(third(solution));
@@ -279,9 +274,9 @@
alg-goal;
elseif (head(alg-goal) == #"integral")
// Simplify as needed
- list(#"integral",
- list(#"eval", list(#"simplify", quotize(second(alg-goal)))),
- third(alg-goal));
+ bq-list(#"integral",
+ bq-list(#"eval", bq-list(#"simplify", quotize(second(alg-goal)))),
+ third(alg-goal));
else
pair(simplifying-form-of(head(alg-goal)),
simplifying-form-of(tail(alg-goal)));
@@ -294,8 +289,9 @@
inc!(counter);
let rvar = as(<symbol>, format(#f, "?RESULT%D", counter));
push!(rvar, antes);
- list(#"in", list(#"solution-of", head(subpair), head(respair)),
- #"var", rvar);
+ bq-list(#"in",
+ bq-list(#"solution-of", head(subpair), head(respair)),
+ #"var", rvar);
end method,
sub-pairs, res-pairs);
values(triggers, reverse!(antes));
@@ -317,7 +313,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(apply(list, #"parent-of", pr, #(#"?x", #"?type"))),
+ stuff := fetch(bq-list*(#"parent-of", pr, #(#"?x", #"?type"))),
if (stuff)
format-out("\n Parent(s): ");
for (p in stuff)
@@ -330,13 +326,13 @@
else
format-out("\n No parents found.");
end if,
- if (fetch(list(#"expanded", pr)))
+ if (fetch(bq-list(#"expanded", pr)))
format-out("\n Expanded,");
else
format-out("\n Not expanded,");
end if,
- if (fetch(list(#"open", pr)))
- if (in?(list(#"open", pr)))
+ if (fetch(bq-list(#"open", pr)))
+ if (in?(bq-list(#"open", pr)))
format-out(" open,");
else
format-out(" closed,");
@@ -344,19 +340,20 @@
else
format-out(" not opened,");
end if,
- if (in?(list(#"relevant", pr)))
+ if (in?(bq-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(list(#"failed", pr)))) & in?(stuff))
+ elseif ((stuff := head(fetch(bq-list(#"failed", pr))))
+ & in?(stuff))
format-out("\n Failed.");
elseif (~ (head(pr) = #"try"))
format-out("\n Neither solved nor failed.");
end if,
- ands := fetch(apply(list, #"and-subgoals", pr, #(#"?ands"))),
+ ands := fetch(bq-list*(#"and-subgoals", pr, #(#"?ands"))),
if (ands)
format-out("\n And subgoals:");
for (subg in third(head(ands)))
@@ -364,7 +361,7 @@
end for;
format-out(".");
end if,
- ors := fetch(apply(list, #"or-subgoals", pr, #(#"?ors"))),
+ ors := fetch(bq-list*(#"or-subgoals", pr, #(#"?ors"))),
if (ors)
format-out("\n Or subgoals:");
for (subg in third(head(ors)))
@@ -407,7 +404,7 @@
end method update-ao-depth-table;
define method get-children (gp, #key *jsaint* = *jsaint*)
- for (maybe-kid in fetch(apply(list, #"parent-of", #"?x", gp, #(#"?type")),
+ for (maybe-kid in fetch(bq-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 00:27:39 2006
@@ -326,16 +326,20 @@
define method contradiction-check (jtms, flag, body)
let jtmsv = generate-symbol();
let old-value = generate-symbol();
- 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)));
+ 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)));
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 00:27:39 2006
@@ -140,76 +140,28 @@
let losing-branch = #f;
// Decide which branch has won and set variables accordingly:
if (right-delta2 < left-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++("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);
+ (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);
begin
threshold-delta2 := left-delta2;
winning-branch := tree.node-right-samples;
losing-branch := tree.node-left-samples;
end;
else
- (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);
+ (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);
begin
threshold-delta2 := right-delta2;
winning-branch := tree.node-left-samples;
@@ -249,56 +201,15 @@
else
// Indicate why there is more work to do:
if (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 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);
+ (formatter-1("~&~aTrying alternate branch because too few answers ~\n\t\t [~a <= ~a]."))(#t,
+ indent(level),
+ size(winning-answers),
+ count);
else
- (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);
+ (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);
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 00:27:39 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);
+ make-string-input-stream(as-uppercase!(title-string), 0, #f);
block (nil)
begin
for (i from 0 below 20)
@@ -466,7 +466,7 @@
end for;
end;
cleanup
- close(astream);
+ deallocate-resource(#"string-input-simple-stream", 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 00:27:39 2006
@@ -37,40 +37,9 @@
flip-negation = #f)
if (~ (node.literal-negated-p == flip-negation)) format(s, "(not "); end if;
format(s, "(");
- (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);
+ (formatter-1("~:(~A~)"))(s, node.literal-relation);
if (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);
+ (formatter-1("~{ ~S~}"))(s, node.literal-terms);
end if;
format(s, ")");
if (~ (node.literal-negated-p == flip-negation)) format(s, ")"); end if;
@@ -80,136 +49,53 @@
#key s = #t,
flip-negation = #f)
if (~ (node.literal-negated-p == flip-negation)) format(s, "~"); 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)(s, node.literal-relation);
+ (formatter-1("~:(~A~)"))(s, node.literal-relation);
if (node.literal-terms)
let term-strings = #f;
term-strings
:= map(method (term)
- 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);
+ 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);
+ _;
end method,
node.literal-terms);
- (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));
+ (formatter-1("(~A~{,~A~})"))(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))
- (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));
+ (formatter-1("~(~A~)"))(s, variable-to-string(term));
elseif (instance?(term, <pair>))
- (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));
+ (formatter-1("~:(~A~)"))(s, first(term));
if (tail(term)) format(s, "("); end if;
format(s, "%S",
begin
- 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);
+ 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);
+ _;
end);
if (tail(term)) format(s, ")"); end if;
elseif (instance?(term, <string>))
format(s, "%=", term);
else
- (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);
+ (formatter-1("~:(~A~)"))(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 00:27:39 2006
@@ -62,7 +62,8 @@
define method get-precons (ingred)
format-out("\n----------------");
format-out("\nGetting preconditions for %=", ingred);
- ingred & slots->mop(list(list(#"ingred", ingred)), #(#"m-precons"), #f);
+ ingred
+ & slots->mop(bq-list(bq-list(#"ingred", ingred)), #(#"m-precons"), #f);
end method get-precons;
define method make-mop (pattern, mop)
@@ -80,17 +81,17 @@
define method replace-slots (slots, mop)
for (slot(in: slots))
#"save";
- 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);
+ 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);
end for;
end method replace-slots;
@@ -257,8 +258,10 @@
let absts = mop-absts(solution);
for (slot(in: slots))
#"do";
- slots->mop(forms->slots(list(list(slot-role(slot), #"m-not",
- list(#"object", slot-filler(slot))))),
+ slots->mop(forms->slots(bq-list(bq-list(slot-role(slot),
+ #"m-not",
+ bq-list(#"object",
+ slot-filler(slot))))),
absts, #t);
end for;
slots->mop(slots, absts, #t);
@@ -289,22 +292,25 @@
end method generalize-mop;
define method chef-explain (mop)
- 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))),
+ 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))),
#(#"m-explanation"), #t);
end method chef-explain;
@@ -336,8 +342,8 @@
define method