added vm op codes

parent bf675b32
Prerequisits
This is a draft for guile-2.0.6 and later and works for linux.
You need to have guile-syntax-parse installed
http://gitorious.org/guile-syntax-parse/guile-syntax-parse
You need the sources to guile
We assume guile-2.0 is buildable and also installed. It is assumed that the
system is linux in order for the below to work out of the box. Also guile-syntax-parse must be installed.
First apply the guile.diff in the main directory patch using,
patch -p1 < path/to/guile.diff
In the guile directory and recompile.
Add this directory to guiles load-path
Install:
......
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index be430bf..ed654aa 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -420,7 +420,7 @@ DOT_DOC_FILES = \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
-DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i vm-i-subr.i
.c.i:
$(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@
@@ -455,7 +455,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
private-gc.h private-options.h
# vm instructions
-noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c vm-i-subr.c
libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES = @LIBLOBJS@
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ef4a9ce..d17df80 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -67,6 +67,7 @@ fetch_instruction_table ()
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
#undef VM_INSTRUCTION_TO_TABLE
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
{
diff --git a/libguile/instructions.h b/libguile/instructions.h
index a226322..63eb6e0 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -30,6 +30,7 @@ enum scm_opcode {
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
#undef VM_INSTRUCTION_TO_OPCODE
};
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c90458d..173ce76 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -34,6 +34,13 @@
#include "vm-engine.h"
+typedef SCM (*subr_type)() ;
+
+subr_type fast0[256];
+subr_type fast1[256];
+subr_type fast2[256];
+subr_type fast3[256];
+subr_type fast4[256];
static SCM
VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
@@ -79,6 +86,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
#undef jump_table
#undef VM_INSTRUCTION_TO_LABEL
}
@@ -127,6 +135,8 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#include "vm-i-system.c"
#include "vm-i-scheme.c"
#include "vm-i-loader.c"
+#include "vm-i-subr.c"
+
#ifndef HAVE_LABELS_AS_VALUES
default:
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 21fa5a1..c014dac 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -939,6 +939,7 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
}
}
+
VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
{
SCM smob, ret;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 41ce924..1e8bab9 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -390,6 +390,14 @@ If there is no handler at all, Guile prints an error and then exits."
(define bound-identifier=? #f)
(define free-identifier=? #f)
+(define fast-call-set! #f)
+(define fast-call-0 #f)
+(define fast-call-1 #f)
+(define fast-call-2 #f)
+(define fast-call-3 #f)
+(define fast-call-4 #f)
+(define gp-fpair!? #f)
+
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index a9f6df9..557c389 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -78,7 +78,14 @@
(define *primcall-ops* (make-hash-table))
(for-each
(lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
- '(((eq? . 2) . eq?)
+ '(((fast-call-0 . 1) . fast-call-0)
+ ((fast-call-1 . 2) . fast-call-1)
+ ((fast-call-2 . 3) . fast-call-2)
+ ((fast-call-3 . 4) . fast-call-3)
+ ((fast-call-4 . 5) . fast-call-4)
+ ((fast-call-set! . 3) . fast-call-set!)
+ ((gp-fpair!? . 2) . gp-fpair!?)
+ ((eq? . 2) . eq?)
((eqv? . 2) . eqv?)
((equal? . 2) . equal?)
((= . 2) . ee?)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 2039faa..492584a 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -32,7 +32,9 @@
singly-valued-primitive?))
(define *interesting-primitive-names*
- '(apply @apply
+ '(fast-call-0 fast-call-1 fast-call-2 fast-call-3 fast-call-4 fast-call-set!
+ gp-fpair!?
+ apply @apply
call-with-values @call-with-values
call-with-current-continuation @call-with-current-continuation
call/cc
@@ -161,7 +163,8 @@
;; Primitives that only return one value.
(define *singly-valued-primitives*
- '(eq? eqv? equal?
+ '(fast-call-0 fast-call-1 fast-call-2 fast-call-3 fast-call-4 fast-call-set!
+ eq? eqv? equal?
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
......@@ -151,8 +151,7 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v ()
g+s (sk ...) fk i)
(let* ((w (id v s))
(s (null? w s)))
(let* ((s (null? v s)))
(if s
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
......@@ -179,9 +178,9 @@
(if (pair? pp)
(let ((s (ppair? vv s)))
(if s
(let ((s (equal? (ccar vv) (car pp) s)))
(let ((s (equal? (ccar vv s) (car pp) s)))
(if s
(loop (id (ccdr vv) s) (cdr pp))
(loop (id (ccdr vv s) s) (cdr pp))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
rr)) fk)))
(insert-abs (abs ((ccar ccdr ppair? null? equal? id)
......@@ -225,7 +224,8 @@
((match-two abs ss v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (insert-abs abs (sk ... i))))
((match-two abs s v (? pred . p) g+s sk fk i)
(if (pred v) (match-one abs s v (and . p) g+s sk fk i) (insert-abs abs fk)))
(if (pred (id v s))
(match-one abs s v (and . p) g+s sk fk i) (insert-abs abs fk)))
;; stis, added $ support!
((match-two abs s v ($ n) g-s sk fk i)
......@@ -291,18 +291,16 @@
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
(let ((w (id v s)))
(let ((s (pair? w s)))
(if s
(let ((s (null? (id (cdr (id w s)) s) s)))
(if s
(let ((w (car (id w s))))
(match-one (abs ((car cdr pair? null? id) rr)) s w p
((car w)
(set-car! w)) sk fk i))
fk))
fk))))
(let ((s (pair? v s)))
(if s
(let ((s (null? (cdr v s) s)))
(if s
(let ((w (car v s)))
(match-one (abs ((car cdr pair? null? id) rr)) s w p
((car w)
(set-car! w)) sk fk i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
((match-two abs s v (p *** q) g+s sk fk i)
(match-extract-vars abs p (match-gen-search s v p q g+s sk fk i) i ()))
......@@ -312,17 +310,15 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q)
g+s sk fk i)
(let ((ww (id v s)))
(let ((s (pair? ww s)))
(if s
(let ((ww (id ww s)))
(let ((w (car ww)) (x (cdr ww)))
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
fk
i)))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))))
(let ((s (pair? v s)))
(if s
(let ((w (car v s)) (x (cdr v s)))
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
fk
i))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
((match-two abs s v #(p ...) g+s . x)
(match-vector abs s v 0 () (p ...) . x))
......
(define-module (logic guile-log code-load)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm gp-print
gp-budy gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set!
gp-var-number gp-print-stack
gp-car gp-cdr gp-pair?
gp-store-state gp-restore-state
gp-make-fluid gp-fluid-set! gp-fluid-ref
gp-dynwind
gp-atomic?
gp-logical-var?
gp-get-stack
gp->scm
gp-logical++ gp-logical-- gp-stack-set!
gp-make-stack
gp-pair!? gp-null!? gp-null?
gp-jumpframe-start gp-jumpframe-end gp?
gp-module-init))
;;need to add modded,
(let ((file (%search-load-path "logic/guile-log/src/libguile-unify.so")))
(if file
(load-extension file "gp_init")
(error "libguile-unify.so is not present, did you forget to make it?")))
;; fast call 3 args
(fast-call-set! gp-unify! 3 0)
(define -gp-unify! gp-unify!)
(define-inlinable (gp-unify! x y s)
(fast-call-3 0 x y s))
(fast-call-set! gp-unify-raw! 3 1)
(define -gp-unify-raw! gp-unify-raw!)
(define-inlinable (gp-unify-raw! x y s)
(fast-call-3 1 x y s))
(fast-call-set! gp-m-unify! 3 2)
(define -gp-m-unify! gp-m-unify!)
(define-inlinable (gp-m-unify! x y s)
(fast-call-3 2 x y s))
;; fast call 1 arg
(fast-call-set! gp-jumpframe-start 1 2)
(define-inlinable (gp-jumpframe-start s)
(fast-call-1 2 s))
(fast-call-set! gp-jumpframe-end 1 3)
(define-inlinable (gp-jumpframe-end s)
(fast-call-1 3 s))
(fast-call-set! gp-unwind 1 4)
(define-inlinable (gp-unwind s)
(fast-call-1 4 s))
(fast-call-set! gp-newframe 1 5)
(define-inlinable (gp-newframe s)
(fast-call-1 5 s))
;; fast call 2 arg
(fast-call-set! gp-lookup 2 0)
(define-inlinable (gp-lookup x s)
(fast-call-2 0 x s))
(fast-call-set! gp-pair!? 2 1)
(define-inlinable (gp-pair!? x s)
(fast-call-2 1 x s))
(fast-call-set! gp-pair? 2 2)
(define-inlinable (gp-pair? x s)
(fast-call-2 2 x s))
(fast-call-set! gp-null!? 2 3)
(define-inlinable (gp-null!? x s)
(fast-call-2 3 x s))
(fast-call-set! gp-null? 2 4)
(define-inlinable (gp-null? x s)
(fast-call-2 4 x s))
(fast-call-set! gp-car 2 5)
(define-inlinable (gp-car x s)
(fast-call-2 5 x s))
(fast-call-set! gp-cdr 2 6)
(define-inlinable (gp-cdr x s)
(fast-call-2 6 x s))
......@@ -8,17 +8,40 @@
(<define> (memb x l)
(<match> () (l)
((,x . _) <cc>)
((_ . l) (memb x l))
((,x . l) <cc>)
((_ . l) (<cut> (memb x l)))
(_ <fail>)))
#;
(<define> (on-right i j l)
(<match> () (l)
((,i ,j . _) <cc>)
((_) <fail>)
((_ . l) (on-right i j l))
((_ . l) (<cut> (on-right i j l)))
(() <fail>)
(_ <fail>)))
(define (on-right s p cc i j l)
(let ((f (gp-newframe s)))
(let loop ((l l))
(gp-unwind f)
(let ((s (gp-pair!? l f)))
(if s
(let ((ii (gp-car l s))
(ll (gp-cdr l s)))
(let ((s (gp-pair!? ll s)))
(if s
(let ((jj (gp-car ll s)))
(let ((s (gp-unify-raw! ii i s)))
(if s
(let ((s (gp-unify-raw! jj j s)))
(if s
(cc s (lambda () (loop ll)))
(loop ll)))
(loop ll))))
(p))))
(p))))))
(<define> (next-to item1 item2 rest)
(<or> (on-right item1 item2 rest)
......@@ -28,8 +51,8 @@
(define-syntax __
(lambda (x)
(syntax-case x ()
((x . l) #'((gp-var!) . l))
(_ #'(gp-var!)))))
((x . l) #'((gp-var! *current-stack*) . l))
(_ #'(gp-var! *current-stack*)))))
(<define> (einstein h)
(<and>
......
......@@ -296,8 +296,8 @@
(define-guile-log <with-fail>
(syntax-rules ()
((_ (cut s p cc) pp code ...)
(let ((p pp))
(parse<> (cut s p cc) (<and> code ...))))))
(let ((ppp pp))
(parse<> (cut s ppp cc) (<and> code ...))))))
(log-code-macro <with-fail>)
(define-guile-log <with-cut>
......
......@@ -354,7 +354,24 @@ SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
"unwinds the prolog stack till frame refered by the argument")
#define FUNC_NAME s_gp_gp_unwind
{
scm_fluid_set_x(gp_wind ,SCM_BOOL_T);
scm_fluid_set_x(gp_setup,SCM_BOOL_F);
gp_unwind(fr);
{
SCM l = scm_fluid_ref(gp_setup);
if(scm_is_false(l)) return SCM_UNSPECIFIED;
gp_jumpframe_start(fr);
while(SCM_CONSP(l))
{
scm_call_0(SCM_CAR(l));
l = SCM_CDR(l);
}
gp_jumpframe_end(fr);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......
......@@ -24,6 +24,9 @@ scm version 3 of the License, or (at your option) any later version.
scm_t_bits gp_type;
SCM gp_wind;
SCM gp_setup;
#define gp_format0(str) \
scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
......@@ -371,7 +374,7 @@ static inline SCM * gp_lookup(SCM *id, SCM s)
return id;
er:
scm_misc_error("gp_lookup","wrong format of s",SCM_EOL);
scm_misc_error("gp_lookup","wrong format of s = ~a",scm_list_1(s));
return id;
}
......@@ -1237,6 +1240,8 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
SCM * y;
gp_debus0("gp-pair!?>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
y = GP_GETREF(x);
if(GP_UNBOUND(y))
......@@ -1265,6 +1270,10 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
#define FUNC_NAME s_gp_pair
{
gp_debus0("gp-pair?>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
//printf("pair gp-addr %x, val %x\n",SCM_UNPACK(x),SCM_UNPACK(*GP_GETREF(x)));
......@@ -1284,6 +1293,9 @@ SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s),
{
gp_debus0("gp-null?>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
SCM *id = GP_GETREF(x);
if(GP_VAL(id))
......@@ -1302,6 +1314,10 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
{
SCM * y;
gp_debus0("gp-null!?>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
y = GP_GETREF(x);
......@@ -1355,12 +1371,15 @@ SCM_DEFINE(gp_m_unify, "gp-m-unify!", 3, 0, 0, (SCM x, SCM y, SCM s),
#undef FUNC_NAME
SCM_DEFINE(gp_car, "gp-car", 1, 0, 0, (SCM x),
SCM_DEFINE(gp_car, "gp-car", 2, 0, 0, (SCM x, SCM s),
"takes car a prolog pair or scheme pair")
#define FUNC_NAME s_gp_car
{
gp_debus0("gp-car?>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
return GP_UNREF(GP_CAR(GP_GETREF(x)));
}
......@@ -1372,11 +1391,15 @@ SCM_DEFINE(gp_car, "gp-car", 1, 0, 0, (SCM x),
#undef FUNC_NAME
SCM_DEFINE(gp_gp_cdr, "gp-cdr", 1, 0, 0, (SCM x),
SCM_DEFINE(gp_gp_cdr, "gp-cdr", 2, 0, 0, (SCM x, SCM s),
"takes cdr a prolog pair or scheme pair")
#define FUNC_NAME s_gp_gp_cdr
{
gp_debus0("gp-cdr>\n");
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
return GP_UNREF(GP_CDR(GP_GETREF(x)));
......@@ -1442,6 +1465,9 @@ SCM_DEFINE(gp_soft_init, "gp-module-init", 0, 0, 0, (),
this_module = scm_current_module ();
gp_wind = scm_variable_ref (scm_c_module_lookup (this_module, "*wind*"));
gp_setup = scm_variable_ref (scm_c_module_lookup (this_module, "*setup*"));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......
......@@ -54,8 +54,8 @@ SCM_API SCM gp_pair(SCM x, SCM s);
SCM_API SCM gp_null(SCM x, SCM s);
SCM_API SCM gp_null_bang(SCM x, SCM s);
SCM_API SCM gp_m_unify(SCM x, SCM y, SCM s);
SCM_API SCM gp_gp_cdr(SCM x);
SCM_API SCM gp_car(SCM x);
SCM_API SCM gp_gp_cdr(SCM x, SCM s);
SCM_API SCM gp_car(SCM x, SCM s);
SCM_API SCM gp_gp_unwind(SCM fr);
SCM_API SCM gp_gp_store_state(SCM s);
......
......@@ -19,57 +19,59 @@
;;; Code:
(define-module (logic guile-log umatch)
#:use-module (logic guile-log code-load)
#:use-module (ice-9 match-phd-lookup)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-9)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm gp-print
gp-budy gp-swap-to-a gp-swap-to-b gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set!
gp-printer gp-var-number gp-print-stack
gp-car gp-cdr gp-pair?
gp-store-state gp-restore-state gp-restore-wind
gp-make-fluid gp-fluid-set! gp-fluid-ref with-gp-fluids
gp-dynwind
gp-atomic?
umatch gp-logical-var?
gp-copy **um** gp-get-stack
push-setup que-setup
with-guarded-states with-guarded-globals gp->scm
gp-logical++ gp-logical-- gp-stack-set!
use-logical leave-logical gp-make-stack
*current-stack*))
(define gp-module-init #f)
(define gp? #f)
(define gp-pair? #f)
(define gp-car #f)
(define gp-cdr #f)
;;need to add modded,
(let ((file (%search-load-path "logic/guile-log/src/libguile-unify.so")))
(if file
(load-extension file "gp_init")
(error "libguile-unify.so is not present, did you forget to make it?")))
#:re-export (gp-clear gp-newframe gp-var!
gp-unify! gp-unify-raw! gp-m-unify! gp-car gp-cdr
gp->scm gp-print
gp-budy
gp-lookup
gp-var? gp-cons! gp-set!
gp-var-number gp-print-stack
gp-pair? gp-pair!? gp-null? gp-null!?
gp-store-state
gp-fluid-set!
gp-unwind
gp-atomic?
gp-logical++ gp-logical--
gp-get-stack
gp-module-init
gp-stack-set!
gp-make-stack)
#:export(gp-restore-wind with-gp-fluids gp-dynwind gp-restore-state
gp-logical-var? umatch **um** gp-make-fluid
push-setup gp-printer gp-fluid-ref
with-guarded-states with-guarded-globals
use-logical leave-logical *current-stack*
#;gp-unwind))
;; Compile function for fast path
;;fast call 1 args
(define *wind* (make-fluid #f))
(define *setup* (make-fluid #f))
(gp-module-init)
;; assq kind of base structure
(define mk-logical gp-var!)
(define logical? gp?)
(define *gp?* #t)
(define gpun gp-unwind)
#;
(define (gp-unwind x)
(set! *wind* #t)
(set! *setup* #f)
(gpun x)
(fluid-set! *wind* #t)
(fluid-set! *setup* #f)
((@@ (logic guile-log code-load) gp-unwind) x)
(gp-jumpframe-start x)
(do-setup)
(gp-jumpframe-end x))
......@@ -79,38 +81,33 @@
(define gp-logical-var? gp?)
(define-syntax **um** (syntax-rules () ((_ . l) (umatch . l))))
(define dyn gp-dynwind)
(define dyn (@@ (logic guile-log code-load) gp-dynwind))
(define *wind* #f)
(define *setup* #f)
(define (do-setup)
(if *setup*
(let ((setup (fluid-ref *setup*)))
(if setup
(dynamic-wind
(lambda x #f)
(lambda ()
(for-each (lambda (thunk) (thunk))
(car *setup*))
(for-each (lambda (thunk) (thunk))
(reverse (cdr *setup*))))
setup))
(lambda x
(set! *setup* #f)))))
(fluid-set! *setup* #f))))))
(define (push-setup x)
(if *setup*
(set-car! *setup* (cons x (car *setup*)))
(set! *setup* (cons (list x) '()))))
(let ((s (fluid-ref *setup*)))
(if s
(fluid-set! *setup* (cons x s))
(fluid-set! *setup* (list x)))))
(define (que-setup x)
(if *setup*
(set-cdr! *setup* (cons x (cdr *setup*)))
(set! *setup* (cons '() (list x)))))
(define *wind* #f)
(define *states* #t)
(define *current-stack* (gp-make-stack 0 0 100000 100000))
(define *store-id* (gp-make-fluid *current-stack*))
(define *store-id* ((@ (logic guile-log code-load) gp-make-fluid)
*current-stack*))
(gp-fluid-set! *store-id* 0 *current-stack*)
......@@ -134,7 +131,7 @@
((forward)
(if forward
(begin
(if (and *wind* (not done))
(if (and (fluid-ref *wind*) (not done))
(begin
(set! done #t)
(push-setup
......@@ -146,7 +143,7 @@
(begin (set! s ss) ...)))))))
(set! s ss) ...)
(begin
(if (and *wind* (not done<