Skip to content
Projects
Groups
Snippets
Help
This project
Loading...
Sign in / Register
Toggle navigation
G
Guile Log
Overview
Overview
Details
Activity
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Commits
Issue Boards
Open sidebar
gule-log
Guile Log
Commits
b227dfa2
Commit
b227dfa2
authored
Sep 19, 2016
by
Stefan Israelsson Tampe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
engines work
parent
8fccf112
Hide whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
222 additions
and
101 deletions
+222
-101
Makefile.am
Makefile.am
+13
-13
dynamic-features.scm
logic/guile-log/dynamic-features.scm
+1
-1
dynamic-features.scm
logic/guile-log/guile-prolog/dynamic-features.scm
+4
-4
engine.scm
logic/guile-log/guile-prolog/engine.scm
+82
-19
interpreter.scm
logic/guile-log/guile-prolog/interpreter.scm
+24
-5
macros.scm
logic/guile-log/macros.scm
+1
-0
parser.scm
logic/guile-log/parser.scm
+20
-12
parser.scm
logic/guile-log/prolog/parser.scm
+8
-5
run.scm
logic/guile-log/run.scm
+24
-16
Makefile
logic/guile-log/src/Makefile
+1
-1
dynstack.c
logic/guile-log/src/dynstack.c
+38
-20
state.c
logic/guile-log/src/state.c
+3
-4
unify-undo-redo.c
logic/guile-log/src/unify-undo-redo.c
+1
-1
unify.c
logic/guile-log/src/unify.c
+1
-0
umatch.scm
logic/guile-log/umatch.scm
+1
-0
No files found.
Makefile.am
View file @
b227dfa2
...
...
@@ -100,7 +100,6 @@ PSSOURCES = \
logic/guile-log/iso-prolog.scm
\
logic/guile-log/prolog/goal-expand.scm
\
logic/guile-log/guile-prolog/set.scm
\
logic/guile-log/guile-prolog/engine.scm
\
logic/guile-log/guile-prolog/delay.scm
\
logic/guile-log/guile-prolog/foldarg.scm
\
logic/guile-log/guile-prolog/ops.scm
\
...
...
@@ -115,6 +114,7 @@ PSSOURCES = \
logic/guile-log/guile-prolog/canon.scm
\
logic/guile-log/guile-prolog/project.scm
\
logic/guile-log/guile-prolog/interpreter.scm
\
logic/guile-log/guile-prolog/engine.scm
\
logic/guile-log/guile-prolog/state.scm
\
logic/guile-log/guile-prolog/postpone.scm
\
logic/guile-log/guile-prolog/gc-call.scm
\
...
...
@@ -132,26 +132,26 @@ PSSOURCES = \
logic/guile-log/guile-prolog/vm/vm-unify.scm
\
logic/guile-log/guile-prolog/vm/vm-goal.scm
\
logic/guile-log/guile-prolog/vm-compiler.scm
\
logic/guile-log/guile-prolog/vm/vm-var2.scm
\
logic/guile-log/guile-prolog/vm/vm-scm2.scm
\
logic/guile-log/guile-prolog/vm/vm-args2.scm
\
logic/guile-log/guile-prolog/vm/vm-handle2.scm
\
logic/guile-log/guile-prolog/vm/vm-disj2.scm
\
logic/guile-log/guile-prolog/vm/vm-conj2.scm
\
logic/guile-log/guile-prolog/vm/vm-imprint2.scm
\
logic/guile-log/guile-prolog/vm/vm-unify2.scm
\
logic/guile-log/guile-prolog/vm/vm-goal2.scm
\
logic/guile-log/guile-prolog/vm-compiler2.scm
\
logic/guile-log/examples/kanren/type-inference.scm
\
logic/guile-log/imatch.scm
\
prolog-user.scm
\
language/prolog/install.scm
\
language/prolog/spec.scm
\
language/prolog/modules/user.scm
\
language/prolog/modules/sandbox.pl
\
language/prolog/modules/boot/expand.pl
\
language/prolog/modules/boot/dcg.pl
\
language/prolog/modules/boot/if.pl
language/prolog/modules/boot/if.pl
\
prolog-user.scm
# logic/guile-log/guile-prolog/vm/vm-var2.scm \
# logic/guile-log/guile-prolog/vm/vm-scm2.scm \
# logic/guile-log/guile-prolog/vm/vm-args2.scm \
# logic/guile-log/guile-prolog/vm/vm-handle2.scm \
# logic/guile-log/guile-prolog/vm/vm-disj2.scm \
# logic/guile-log/guile-prolog/vm/vm-conj2.scm \
# logic/guile-log/guile-prolog/vm/vm-imprint2.scm \
# logic/guile-log/guile-prolog/vm/vm-unify2.scm \
# logic/guile-log/guile-prolog/vm/vm-goal2.scm \
# logic/guile-log/guile-prolog/vm-compiler2.scm \
# language/prolog/modules/swi/term_macro.pl \
# language/prolog/modules/library/error.pl \
# language/prolog/modules/library/vhash.scm \
...
...
logic/guile-log/dynamic-features.scm
View file @
b227dfa2
...
...
@@ -405,7 +405,7 @@ before. This works very much like a fluid
(
rd
(
mk
api
e
h
ref
(
dotr
))))
(
let
((
wind
(
gp-windlevel-ref
s
)))
(
gp-undo-safe-variable-lguard
(
gp-undo-safe-variable-lguard
rd
(
gp-rebased-level-ref
wind
)
s
)
...
...
logic/guile-log/guile-prolog/dynamic-features.scm
View file @
b227dfa2
...
...
@@ -40,7 +40,7 @@
(
<recur>
lp
((
l
l
))
(
if
(
pair?
l
)
(
<and>
(
add-dynamic-function-dynamics
(
car
l
))
(
add-dynamic-function-dynamics
(
<lookup>
(
car
l
)
))
(
lp
(
cdr
l
)))
<cc>
)))
...
...
@@ -51,7 +51,7 @@
(
<recur>
lp
((
h
h
))
(
if
(
pair?
h
)
(
<and>
(
backtrack-dynamic-object
(
car
h
)
fail-
)
(
backtrack-dynamic-object
(
<lookup>
(
car
h
)
)
fail-
)
(
lp
(
cdr
h
)))
<cc>
))))
...
...
@@ -66,9 +66,9 @@
(
define
a_b
(
<case-lambda>
((
h
code
)
(
a-b
h
(
<lambda>
()
(
goal-eval
code
))
fail-
))
(
a-b
(
<lookup>
h
)
(
<lambda>
()
(
goal-eval
code
))
fail-
))
((
h
.
l
)
(
a-b
h
(
<lambda>
()
(
<apply>
a_b
l
))
fail-
)))))
(
a-b
(
<lookup>
h
)
(
<lambda>
()
(
<apply>
a_b
l
))
fail-
)))))
(
mk-with
with_fluid_guard_dynamic_object
with-fluid-guard-dynamic-object
)
...
...
logic/guile-log/guile-prolog/engine.scm
View file @
b227dfa2
(
define-module
(
logic
guile-log
guile-prolog
engine
)
#
:use-module
(
ice-9
match
)
#
:use-module
(
logic
guile-log
run
)
#
:use-module
(
logic
guile-log
)
#
:use-module
(
logic
guile-log
guile-prolog
dynamic-features
)
#
:use-module
(
logic
guile-log
guile-prolog
interpreter
)
#
:use-module
(
logic
guile-log
dynamic-features
)
#
:use-module
(
logic
guile-log
umatch
)
#
:use-module
(
logic
guile-log
code-load
)
...
...
@@ -43,8 +45,27 @@
((
#
:throw
e
)
(
set!
engine
#f
)
state
)
(
_
state
))))
(
x
(
if
(
eq?
x
'stalled
)
(
begin
(
set!
state
(
list
#
:stalled
(
let
((
e
engine
)
(
g
guards
)
(
p
path
))
(
lambda
()
(
set!
engine
e
)
(
set!
guards
g
)
(
set!
path
p
)))
(
cons
(
@@
(
logic
guile-log
guile-prolog
interpreter
)
lold
)
(
get-continuation
))))
state
)
state
)))))
(
start-f
(
lambda
(
s
)
...
...
@@ -53,7 +74,7 @@
(
set!
start-f
next
)
(
let
((
s2
#f
)
(
pth
#f
)
(
g
(
gp-store-engine-guards
)
))
(
g
#f
))
(
dynamic-wind
(
lambda
()
(
set!
g
(
gp-store-engine-guards
))
...
...
@@ -104,14 +125,22 @@
((
#
:throw
e
)
state
)
((
#
:stalled
thunk
cc
)
(
thunk
)
(
<state-set!>
(
car
cc
))
(
set!
state
(
continue
(
cdr
cc
)))
(
on-result
))
((
#
:yield
s0
p0
cc
x
)
(
set!
state
(
cc
s0
p0
))
state
)
(
on-result
)
)
((
#
:finish
_
p
x
)
(
set!
state
(
p
))
state
))
(
on-result
))
(
x
x
))
#
:exit
))
(
lambda
()
...
...
@@ -125,6 +154,10 @@
(
#
:post
(
apply
variable-set!
postbox
term
))
(
#
:finish
(
set!
engine
#f
))
(
#
:set-state
(
set!
state
s
))
(
#
:set-engine
(
set!
engine
(
cadr
state
)))
(
#
:exist
(
and
engine
(
match
state
...
...
@@ -143,25 +176,40 @@
(
<define>
(
engine_next
engine
term
)
(
let*
((
engine
(
<lookup>
engine
))
(
res
(
engine
#
:run
S
)))
(
<<match>>
(
#
:mode
-
)
(
res
)
(
#
:exit
<fail>
)
(
<recur>
lp
((
res
res
))
(
<<match>>
(
#
:mode
-
#
:name
engine_next
)
(
res
)
(
#
:exit
<fail>
)
((
#
:throw
e
)
(
<var>
(
ee
)
(
copy_term
e
ee
)
(
throw
ee
)))
((
#
:throw
e
)
(
<var>
(
ee
)
(
copy_term
e
ee
)
(
throw
ee
)))
((
#
:finish
s
p
x
)
(
<=>
x
term
))
((
#
:finish
s
p
x
)
(
<=>
x
term
))
((
#
:yield
s
p
cc
x
)
(
<=>
x
term
)))))
((
#
:yield
s
p
cc
x
)
(
<=>
x
term
))
((
#
:stalled
_
_
)
(
<and>
(
write
"stalled engine > "
)
(
write
engine
)
(
nl
)
(
let
((
state
res
))
(
stall
)
(
<code>
(
engine
#
:set-state
state
))
(
lp
(
engine
#
:run
S
)))))
(
x
(
<ret>
x
))))))
(
<define>
(
engine_next_reified
engine
term
)
(
let*
((
engine
(
<lookup>
engine
))
(
res
(
engine
#
:run
S
)))
(
<<match>>
(
#
:mode
-
)
(
res
)
(
<recur>
lp
((
res
res
))
(
<<match>>
(
#
:mode
-
#
:name
engine_next_reified
)
(
res
)
(
#
:exit
(
<=>
"no"
term
))
...
...
@@ -173,7 +221,20 @@
(
<=>
,
(
vector
(
list
"the"
x
))
term
))
((
#
:yield
s
p
cc
x
)
(
<=>
,
(
vector
(
list
"the"
x
))
term
)))))
(
<=>
,
(
vector
(
list
"the"
x
))
term
))
((
#
:stalled
_
_
)
(
<and>
(
write
"stalled engine > "
)
(
write
engine
)
(
nl
)
(
let
((
state
res
))
(
stall
)
(
<code>
(
engine
#
:set-state
state
))
(
lp
(
engine
#
:run
S
)))))
(
x
(
<ret>
x
))))))
(
define
engine_post
(
<case-lambda>
...
...
@@ -231,6 +292,8 @@
parse_ops(L,Ops,Defaults).
defaults([\"alias\"(noname),\"global\"(100),\"local\"(100),\"trail\"(100)]).
engine_create(Template, Goal, Engine) :-
engine_create(Template, Goal, Engine, []).
engine_create(Template, Goal, Engine, Ops) :-
defaults(Defaults),
parse_ops(Ops, [\"alias\"(Name),\"local\"(Size)], Defaults),
...
...
logic/guile-log/guile-prolog/interpreter.scm
View file @
b227dfa2
...
...
@@ -37,6 +37,8 @@
stall
thin_stall
))
(
define-named-object
-all-
(
make-fluid
false
))
(
define
*cc*
(
@@
(
logic
guile-log
run
)
*cc*
))
(
<wrap>
add-fluid-dynamics
*cc*
)
(
<wrap>
add-fluid-dynamics
-all-
)
(
define-named-object
*once*
(
gp-make-var
#f
))
(
define-named-object
-nsol-
(
make-fluid
#f
))
...
...
@@ -445,11 +447,28 @@ conversation_ :-
conversation1(X,All) :-
backtrack_dynamic_object(scm[*globals-map*]),
fluid_guard_dynamic_object(scm[*var-attributator*],scm[-n-],scm[env],
scm[-nsol-], scm[-all-], scm[-mute?-],scm[*globals-map*]),
state_guard_dynamic_object(scm[*var-attributator*],
scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-],scm[env],
scm[*user-data*],scm[*globals-map*]),
fluid_guard_dynamic_object(
scm[-n-],
scm[-nsol-],
scm[-all-],
scm[*globals-map*],
scm[*var-attributator*],
scm[env],
scm[*cc*],
scm[*user-data*],
scm[-mute?-]),
state_guard_dynamic_object(
scm[-n-],
scm[-nsol-],
scm[-all-],
scm[*globals-map*],
scm[*var-attributator*],
scm[env],
scm[*cc*],
scm[*user-data*],
scm[-mute?-]),
wrap_frame,
'new-machine',
conversation2(X,All).
...
...
logic/guile-log/macros.scm
View file @
b227dfa2
...
...
@@ -1164,6 +1164,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
#
;(log-code-macro '<dynwind>)
;; This is code that allow to store a state
(
define
(
pkk
x
)
(
pk
(
vector-ref
(
car
(
cdr
x
))
3
))
x
)
(
define
(
<state-ref>
)
(
gp-store-state
(
fluid-ref
*current-stack*
)))
...
...
logic/guile-log/parser.scm
View file @
b227dfa2
(
define-module
(
logic
guile-log
parser
)
#
:use-module
(
logic
guile-log
parsing
scanner
)
#
:use-module
(
logic
guile-log
)
#
:use-module
(
logic
guile-log
vlist
)
#
:use-module
(
logic
guile-log
fstream
)
#
:use-module
(
logic
guile-log
umatch
)
#
:use-module
((
ice-9
match
)
#
:renamer
(
symbol-prefix-proc
'ice:
))
...
...
@@ -63,14 +64,13 @@
(
define
*freeze-map*
#f
)
(
define
head
#f
)
(
define
clear-tokens
(
let
((
fl
(
make-fluid
#f
)))
(
let
((
fl
(
make-fluid
vlist-null
)))
(
set!
*freeze-map*
fl
)
(
lambda
()
(
let
((
ht
(
make-hash-table
)))
(
set!
head
ht
)
(
let
((
ht
vlist-null
))
(
fluid-set!
fl
ht
)))))
(
clear-tokens
)
(
define
make-file-reader
...
...
@@ -440,8 +440,9 @@
(
define
(
p-freeze
tok
f
mk
)
(
<p-lambda>
(
c
)
(
<and!>
(
<let>
((
val
(
hash-ref
(
fluid-ref
*freeze-map*
)
(
cons*
N
M
tok
)
#f
))
(
<let>
((
val
(
vhash-ref
(
fluid-ref
*freeze-map*
)
(
cons*
N
M
tok
)
#f
))
(
op
P
)
(
os
S
)
(
fr
(
<newframe>
)))
...
...
@@ -455,14 +456,21 @@
(
<unwind-tail>
fr
))
(
<with-fail>
op
(
<with-s>
os
(
<code>
(
hash-set!
(
fluid-ref
*freeze-map*
)
(
cons*
n
m
tok
)
(
list
X
XL
N
M
XX
...
val2
)))
(
<p-cc>
val2
)))))
(
<code>
(
fluid-set!
*freeze-map*
(
vhash-cons
(
cons*
n
m
tok
)
(
list
X
XL
N
M
XX
...
val2
)
(
fluid-ref
*freeze-map*
))))
(
<p-cc>
val2
)))))
(
<let>
((
val2
'fail
))
(
<code>
(
hash-set!
(
fluid-ref
*freeze-map*
)
(
cons*
n
m
tok
)
val2
))
(
fluid-set!
*freeze-map*
(
vhash-cons
(
cons*
n
m
tok
)
val2
(
fluid-ref
*freeze-map*
))))
<fail>
)))
(
if
(
pair?
val
)
(
<and>
...
...
logic/guile-log/prolog/parser.scm
View file @
b227dfa2
...
...
@@ -710,23 +710,26 @@
(
..
(
a
)
(
l
c2
))
(
<p-cc>
#t
))
(
<p-cc>
#f
)))
(
<pp>
`
(
c2
,
c2
))
(
xx
(
c3
)
(
<or>
(
<and>
(
<and>
(
..
(
u
)
((
f-or
expr
(
f-and
ws
(
f-out
#f
)))
cl
))
(
if
(
match
u
(((
_
_
"|"
_
)
.
l
)
#f
)
(
else
#t
))
(
<p-cc>
u
)
(
..
((
e
c1
)
cl
))))
(
..
((
e
c1
)
cl
))))
(
..
((
e
c1
)
cl
))
(
<p-cc>
(
pk
c2
))))
(
<pp>
`
(
c3
,
c3
))
(
..
(
c4
)
(
r
c3
))
(
xx
(
c5
)
(
if
cl
(
..
(
r
c4
))
(
<p-cc>
#f
)))
(
..
(
u
)
(
@tag
c5
))
(
<p-cc>
(
wrap@
u
(
if
(
eq?
c2
c3
)
(
wrap@
u
(
pk
(
if
(
eq?
c2
c3
)
`
(
#
:lam-term
,
c1
()
,
cl
,
n
,
m
)
`
(
#
:lam-term
,
c1
,
(
<scm>
c3
)
,
cl
,
n
,
m
))))))
`
(
#
:lam-term
,
c1
,
(
<scm>
c3
)
,
cl
,
n
,
m
))))))
)
mk-id
)))
(
define
set-tok
...
...
@@ -747,7 +750,7 @@
(
..
(
c0
)
(
ws
c
))
(
<let>
((
n
N
)
(
m
M
))
(
..
(
c2
)
(
l
c0
))
(
..
(
c3
)
(
expr
c2
))
(
xx
(
c3
)
(
<or>
(
..
(
expr
c2
))
(
<p-cc>
'
())
))
(
..
(
c4
)
(
r
c3
))
(
<p-cc>
`
(
#
:lam-term
#f
,
(
<scm>
c3
)
#f
,
n
,
m
))))
...
...
logic/guile-log/run.scm
View file @
b227dfa2
...
...
@@ -8,6 +8,7 @@
#
:export
(
<stall>
<continue>
<take>
<run>
<eval>
<ask>
<cont-ref>
<cont-set!>
*gp-var-tr*
*kanren-assq*
get-continuation
continue
*init-tr*
))
(
define
put_attr
#f
)
(
define
*init-tr*
(
make-fluid
(
lambda
()
#f
)))
...
...
@@ -36,29 +37,38 @@
(
define
bar
build_attribut_representation
)
(
define-named-object
*cc*
(
gp-make-var
#f
))
(
define-named-object
*cc*
(
make-fluid
#f
))
(
define
(
<stall>
s
p
cc
.
l
)
(
gp-var-set
*cc*
(
cons
s
(
cons
(
cons
p
l
)
cc
))
s
)
(
fluid-set!
*cc*
(
cons
s
(
cons
(
cons
p
l
)
cc
))
)
(
fluid-set!
*current-stack*
s
)
'stalled
)
(
define
(
<cont-ref>
)
(
gp-var
-ref
*cc*
))
(
fluid
-ref
*cc*
))
(
define
(
<cont-set!>
cc
)
(
let
((
s
(
car
cc
)))
(
gp-var-set
*cc*
cc
s
)
(
fluid-set!
*cc*
cc
)
(
fluid-set!
*current-stack*
s
)))
(
define
(
get-continuation
)
(
fluid-ref
*cc*
))
(
define
(
continue
*cc*
)
(
if
(
and
*cc*
(
car
*cc*
))
(
apply
(
cddr
*cc*
)
(
car
*cc*
)
(
cadr
*cc*
))
'cannot-continue
))
(
define
(
<take>
n
)
(
<continue>
n
))
(
define
<continue>
(
case-lambda
(()
(
let
((
*cc*
(
gp-var
-ref
*cc*
)))
(()
(
let
((
*cc*
(
fluid
-ref
*cc*
)))
(
if
(
and
*cc*
(
car
*cc*
))
(
apply
(
cddr
*cc*
)
(
car
*cc*
)
(
cadr
*cc*
))
'cannot-continue
)))
((
n
)
(
let
((
*cc*
(
gp-var
-ref
*cc*
)))
((
n
)
(
let
((
*cc*
(
fluid
-ref
*cc*
)))
(
if
(
and
*cc*
(
integer?
n
)
(
not
(
car
*cc*
)))
((
cdr
*cc*
)
n
)
'cannot-continue-and-take-n
)))))
...
...
@@ -210,20 +220,20 @@
(
lambda
(
s
p
)
(
if
(
=
n
0
)
(
let
((
r
(
reverse
ret
)))
(
gp-var-set
*cc*
(
cons
#f
(
lambda
(
mm
)
(
fluid-set!
*cc*
(
cons
#f
(
lambda
(
mm
)
(
set!
n
mm
)
(
set!
ret
'
())
(
p
)))
s
)
(
p
))))
r
)
(
begin
(
set!
n
(
-
n
1
))
(
set!
ret
(
cons
(
tr
(
gp->scm
v
s
)
s
#t
)
ret
))
(
if
(
=
n
0
)
(
let
((
r
(
reverse
ret
)))
(
gp-var-set
*cc*
(
cons
#f
(
lambda
(
mm
)
(
fluid-set!
*cc*
(
cons
#f
(
lambda
(
mm
)
(
set!
n
mm
)
(
set!
ret
'
())
(
p
)))
s
)
(
p
))))
r
)
(
p
)))))))))))
...
...
@@ -247,22 +257,20 @@
(
lambda
(
s
p
)
(
if
(
=
n
0
)
(
let
((
r
(
reverse
ret
)))
(
gp-var-set
*cc*
(
cons
#f
(
lambda
(
mm
)
(
fluid-set!
*cc*
(
cons
#f
(
lambda
(
mm
)
(
set!
n
mm
)
(
set!
ret
'
())
(
p
)))
s
)
(
p
))))
r
)
(
begin
(
set!
n
(
-
n
1
))
(
set!
ret
(
cons
(
tr
(
list
(
gp->scm
v
s
)
...
)
s
#f
)
ret
))
(
if
(
=
n
0
)
(
let
((
r
(
reverse
ret
)))
(
gp-var-set
*cc*
(
cons
#f
(
lambda
(
mm
)
(
fluid-set!
*cc*
(
cons
#f
(
lambda
(
mm
)
(
set!
n
mm
)
(
set!
ret
'
())
(
p
)))
s
)
(
p
))))
r
)
(
p
)))))))))))))
...
...
logic/guile-log/src/Makefile
View file @
b227dfa2
...
...
@@ -204,7 +204,7 @@ AUTOHEADER = ${SHELL} /home/stis/src/guile-log/build-aux/missing autoheader
AUTOMAKE
=
${
SHELL
}
/home/stis/src/guile-log/build-aux/missing automake-1.14
AWK
=
gawk
CC
=
gcc
CCDEPMODE
=
depmode
=
gcc3
CCDEPMODE
=
depmode
=
gcc3
CFLAGS
=
-g
-O2
CPP
=
gcc
-E
CPPFLAGS
=
...
...
logic/guile-log/src/dynstack.c
View file @
b227dfa2
...
...
@@ -9,6 +9,7 @@ In a future version we might deside to put in a link between the functional
structure and this tree and unwind/rewind them in a logically more correct way.
*/
//#define DB(X) X
//ID structure
#define D_VARIABLE_GUARD 2
#define D_FLUID 6
...
...
@@ -32,14 +33,26 @@ structure and this tree and unwind/rewind them in a logically more correct way.
//LGUARD
#define D_LGUARD_VAR 1
#define D_LGUARD_K 2
#define D_NLGUARD 3
#define D_OLD_K 3
#define D_NLGUARD 4
//FLUID
#define D_FLUID_VAR 1
#define D_FLUID_VAL 2
//
#define D_OLD_K 3
#define D_OLD_K 3
#define D_NFLUID 4
inline
SCM
make_rguard
(
SCM
var
,
SCM
val
,
SCM
k
)
{
SCM
vnew_
=
scm_c_make_vector
(
D_NGUARD
-
1
,
SCM_BOOL_F
);
SCM
*
vnew
=
SCM_I_VECTOR_WELTS
(
vnew_
);
vnew
[
D_GUARD_K
-
1
]
=
k
;
vnew
[
D_GUARD_VAR
-
1
]
=
var
;
vnew
[
D_GUARD_VAL
-
1
]
=
val
;
return
vnew_
;
}
#define GET_ENV(h) SCM_I_VECTOR_WELTS(SCM_VARIABLE_REF(h));
#define OLD(h) h[4];
#define NEXT(h) h[3];
...
...
@@ -64,7 +77,7 @@ SCM_DEFINE(gp_get_rguards, "gp-rguards-ref", 0, 0, 0,(),"")
SCM_DEFINE
(
undo_safe_variable_guard
,
"gp-undo-safe-variable-guard"
,
3
,
0
,
0
,
(
SCM
var
,
SCM
kind
,
SCM
s
),
""
)
#define FUNC_NAME s_safe_variable_guard
#define FUNC_NAME s_
undo_
safe_variable_guard
{
SCM
ggp
;
struct
gp_stack
*
gp
;
...
...
@@ -120,7 +133,7 @@ SCM get_l_k_part(SCM k, SCM guards)
SCM_DEFINE
(
undo_safe_variable_rguard
,
"gp-undo-safe-variable-rguard"
,
3
,
0
,
0
,
(
SCM
var
,
SCM
kind
,
SCM
s
),
""
)
#define FUNC_NAME s_safe_variable_rguard
#define FUNC_NAME s_
undo_
safe_variable_rguard
{
SCM
ggp
;
struct
gp_stack
*
gp
;
...
...
@@ -184,12 +197,11 @@ SCM get_oldkind(SCM k, SCM guards)
SCM_DEFINE
(
undo_safe_variable_lguard
,
"gp-undo-safe-variable-lguard"
,
3
,
0
,
0
,
(
SCM
var
,
SCM
kind
,
SCM
s
),
""
)
#define FUNC_NAME s_safe_variable_lguard
#define FUNC_NAME s_
undo_
safe_variable_lguard
{
return
SCM_BOOL_F
;
SCM
ggp
;
struct
gp_stack
*
gp
;
//format2("lguard ~a -> ~a~%",var, SCM_FLUID_P(var)?scm_fluid_ref(var):SCM_BOOL_F);
UNPACK_ALL00
(
ggp
,
gp
,
s
,
"failed to unpack s in undo_safe_variable_rguard"
);
if
(
SCM_VARIABLEP
(
var
)
||
SCM_FLUID_P
(
var
)
||
SCM_CONSP
(
var
)
...
...
@@ -197,6 +209,7 @@ SCM_DEFINE(undo_safe_variable_lguard, "gp-undo-safe-variable-lguard", 3, 0, 0,
{
SCM
vnew_
=
scm_c_make_vector
(
D_NLGUARD
,
SCM_BOOL_F
);
SCM
*
vnew
=
SCM_I_VECTOR_WELTS
(
vnew_
);
vnew
[
D_ID
]
=
SCM_PACK
(
D_LGUARD
);
vnew
[
D_LGUARD_K
]
=
kind
;
vnew
[
D_LGUARD_VAR
]
=
var
;
...
...
@@ -214,8 +227,8 @@ SCM_DEFINE(undo_safe_variable_lguard, "gp-undo-safe-variable-lguard", 3, 0, 0,
gp
->
dynstack
=
scm_cons
(
vnew_
,
gp
->
dynstack
);
gp
->
dynstack_length
+=
4
;
gp
->
rguards
=
scm_cons
(
scm_cons
(
v
new
[
D_LGUARD_VAR
],
vnew
[
D_LGUARD_K
]
),
gp
->
rguards
=
scm_cons
(
scm_cons
(
v
ar
,
kind
),
gp
->
rguards
);
return
SCM_UNSPECIFIED
;
...
...
@@ -240,6 +253,8 @@ SCM_DEFINE(gp_with_fluid, "gp-fluid-set", 2, 0, 0,
gp
=
(
struct
gp_stack
*
)
SCM_SMOB_DATA
(
a
);
//format3("var ~a -> ~a | n = ~a~%",var,SCM_FLUID_P(var)?scm_fluid_ref(var):SCM_BOOL_F,SCM_PACK(gp->dynstack_length));
if
(
SCM_VARIABLEP
(
var
)
||
SCM_FLUID_P
(
var
)
||
scm_is_true
(
scm_procedure_p
(
var
)))
{
...
...
@@ -424,12 +439,13 @@ void eval_rguard(SCM guard, SCM K)
{
SCM
*
v
=
SCM_I_VECTOR_WELTS
(
guard
);
SCM
k
=
v
[
D_GUARD_K
-
1
];
gp_debug0
(
"A guard
\n
"
);
if
(
dynwind_check
(
k
,
K
))
{
SCM
var
=
v
[
D_GUARD_VAR
-
1
];
SCM
val
=
v
[
D_GUARD_VAL
-
1
];
gp_format2
(
"var = val, ~a = ~a~%"
,
var
,
val
);
if
(
SCM_CONSP
(
var
))
SCM_SETCDR
(
var
,
val
);
else
if
(
SCM_VARIABLEP
(
var
))
...
...
@@ -597,6 +613,7 @@ SCM wind_dynstack(SCM pt, SCM dynstack, SCM K, SCM *rguard)
SCM
unwind_dynstack_it
(
SCM
pp
,
SCM
*
rguard
)
{
gp_debug0
(
"unwind it
\n
"
);
SCM
*
v
=
SCM_I_VECTOR_WELTS
(
pp
);
scm_t_bits
id
=
SCM_UNPACK
(
v
[
D_ID
]);
...
...
@@ -806,6 +823,7 @@ void reinstate_dynstack(struct gp_stack *gp,
//#define DB(X)
SCM
make_rguards
(
SCM
rguards
)
{
gp_debug0
(
"make_rguards
\n
"
);
...
...
@@ -813,22 +831,21 @@ SCM make_rguards(SCM rguards)
while
(
SCM_CONSP
(
rguards
))
{
SCM
guard
=
SCM_CAR
(
rguards
);
SCM
vnew_
=
scm_c_make_vector
(
D_NGUARD
-
1
,
SCM_BOOL_F
);
SCM
*
vnew
=
SCM_I_VECTOR_WELTS
(
vnew_
);
vnew
[
D_GUARD_K
-
1
]
=
SCM_CDR
(
guard
);
SCM
k
=
SCM_CDR
(
guard
);
SCM
var
=
SCM_CAR
(
guard
);
vnew
[
D_GUARD_VAR
-
1
]
=
var
;
SCM
val
;
if
(
SCM_CONSP
(
var
))
v
new
[
D_GUARD_VAL
-
1
]
=
SCM_CDR
(
var
);
v
al
=
SCM_CDR
(
var
);
else
if
(
SCM_VARIABLEP
(
var
))
vnew
[
D_GUARD_VAL
-
1
]
=
SCM_VARIABLE_REF
(
var
);
val
=
SCM_VARIABLE_REF
(
var
);
else
if
(
SCM_FLUID_P
(
var
))
v
new
[
D_GUARD_VAL
-
1
]
=
scm_fluid_ref
(
var
);
v
al
=
scm_fluid_ref
(
var
);
else
vnew
[
D_GUARD_VAL
-
1
]
=
scm_call_0
(
var
);
val
=
scm_call_0
(
var
);
out
=
scm_cons
(
make_rguard
(
var
,
val
,
k
),
out
);
out
=
scm_cons
(
vnew_
,
out
);
rguards
=
SCM_CDR
(
rguards
);
}
...
...
@@ -886,3 +903,4 @@ void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n)
SCM_EOL););
*/
}
//#define DB(X)
logic/guile-log/src/state.c
View file @
b227dfa2
...
...
@@ -333,7 +333,7 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i
gp
->
dynstack
=
SCM_EOL
;
gp
->
dynstack_length
=
2
;
gp
->
dynstack_length
=
2
;
//2 = SCM_UNPACK(scm_from_int(0));
gp
->
rguards
=
SCM_EOL
;
gp
->
handlers
=
SCM_EOL
;
...
...
@@ -1632,16 +1632,15 @@ SCM_DEFINE(gp_new_engine, "gp-new-engine", 1, 0, 0, (SCM e),
scm_fluid_set_x
(
gp_current_stack
,
e
);
{
struct
gp_stack
*
gp
=
get_gp
();
gp_clear
(
SCM_BOOL_F
);
SCM
ss
=
scm_fluid_ref
(
current_stack
);
//Sooo confusing TODO: FIXME
SCM
carss
=
gp_car
(
ss
,
ss
);
SCM
cdr
=
scm_cons
(
SCM_EOL
,
SCM_EOL
);
SCM
cdr
=
scm_cons
(
SCM_EOL
,
gp_engine_path
);
ss
=
scm_cons
(
carss
,
scm_cons
(
SCM_EOL
,
gp_engine_path
)
);
ss
=
scm_cons
(
carss
,
cdr
);