turn off fastcall feature, add budy to unify.h
[gule-log:guile-log.git] / logic / guile-log / code-load.scm
1 (define-module (logic guile-log code-load)
2   #:use-module (system vm vm)
3   #:use-module (srfi srfi-11)
4   #:export  (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var! 
5                       gp->scm gp-print
6                       gp-c-system
7                       gp-budy gp-m-unify!
8                       gp-lookup
9                       gp-var? gp-cons! gp-set! 
10                       gp-var-number gp-print-stack
11                       gp-car gp-cdr gp-pair? gp-pair* gp-pair- gp-pair+
12                       gp-store-state gp-restore-state
13                       gp-make-fluid gp-fluid-set! gp-fluid-ref
14                       gp-dynwind
15                       gp-atomic? 
16                       gp-logical-var?
17                       gp-get-stack
18                       gp->scm
19                       gp-logical++ gp-logical-- gp-stack-set!
20                       gp-make-stack
21                       gp-pair!? gp-null!? gp-null?
22                       gp-jumpframe-start gp-jumpframe-end gp?
23                       gp-module-init
24                       gp-setup-set! gp-wind-set! gp-setup-ref gp-wind-ref
25                       -gp-member -gp-right-of -next-to -einstein))
26   
27
28
29 ;;need to add modded,   
30 (let ((file  (%search-load-path "logic/guile-log/src/libguile-unify.so")))
31   (if file
32       (load-extension file "gp_init")
33       (error "libguile-unify.so is not present, did you forget to make it?")))
34
35 (define-syntax-rule  (definek x val)
36   (module-define! (current-module) 'x val))
37
38 (define wrap #f)
39 (define-syntax-rule (define3 nm r)
40   (definek nm (let ((rr r))
41                 (if wrap
42                     (lambda (x y z) (rr x y z))
43                     rr))))
44
45 (define-syntax-rule (define2 nm r)
46   (definek nm (let ((rr r))
47                (if wrap
48                    (lambda (x y) (rr x y))
49                    rr))))
50
51 (define-syntax-rule (define1 nm r)
52   (definek nm (let ((rr r))
53                (if wrap                   
54                    (lambda (x) (rr x))
55                    r))))
56
57 (define (gp-pair+ x s)
58   (let ((s (gp-pair!? x s)))
59     (if s
60         (values (gp-car x s) 
61                 (gp-cdr x s)
62                 s)
63         (values #f #f #f))))
64
65 (define (gp-pair- x s)
66   (let ((s (gp-pair? x s)))
67     (if s
68         (values (gp-car x s) 
69                 (gp-cdr x s)
70                 s)
71         (values #f #f #f))))
72
73 (define (gp-pair* x s)
74   (if (pair? x)
75       (values (car x s) 
76               (cdr x s)
77               s)
78       (values #f #f #f)))
79
80 (if (and #f (module-defined? (current-module) 'the-c-closure-tag))
81     (begin
82       (definek gp-c-system #t)
83
84       (let ((tag (the-c-closure-tag)))
85         (set-car! tag 'c)
86         (set-cdr! tag 'tag)
87         (gp-set-closure-tag tag))
88
89
90       (definek api (gp-make-log-api))
91       (define3 gp-unify!      (cdr (assq 'gp-unify!     api)))
92       (define3 gp-unify-raw!  (cdr (assq 'gp-unify-raw! api)))
93       (define3 gp-m-unify     (cdr (assq 'gp-m-unify    api)))
94       (definek  -gp-member    (cdr (assq 'gp-member     api)))
95       (definek  -gp-right-of  (cdr (assq 'gp-right      api)))
96       (definek  -next-to      (cdr (assq 'gp-next-to    api)))
97       (define1 gp-jumpframe-start
98         (cdr (assq 'gp-jumpframe-start api)))
99       (define1 gp-jumpframe-end
100         (cdr (assq 'gp-jumpframe-end api)))
101       (define1 gp-unwind     (cdr (assq 'gp-unwind     api)))
102       (define1 gp-newframe   (cdr (assq 'gp-newframe   api)))
103       (define1 gp-var!       (cdr (assq 'gp-var!       api)))
104
105       (define2 gp-lookup     (cdr (assq 'gp-lookup     api)))
106       (define2 gp-pair!?     (cdr (assq 'gp-pair!?     api)))
107       (define2 gp-pair?      (cdr (assq 'gp-pair?      api)))
108       (define2 gp-null!?     (cdr (assq 'gp-null!?     api)))
109       (define2 gp-null?      (cdr (assq 'gp-null?      api)))
110       (define2 gp-car        (cdr (assq 'gp-car        api)))
111       (define2 gp-cdr        (cdr (assq 'gp-cdr        api)))
112       (define2 gp->scm       (cdr (assq 'gp->scm       api)))
113       (define2 gp-pair*      (cdr (assq 'gp-pair*      api)))
114       (define2 gp-pair-      (cdr (assq 'gp-pair-      api)))
115       (define2 gp-pair+      (cdr (assq 'gp-pair+      api))))
116     (begin
117       (definek gp-c-system #f)
118       (definek  -gp-member    #f)
119       (definek  -gp-right-of  #f)
120       (definek  -next-to      #f)))
121
122
123 #|
124 (define p+ gp-pair+)
125 (define (gp-pair+ x s)
126   (let-values (((x y s) (p+ x s)))
127     (pk `(pair ,s))
128     (values x y s)))
129
130 (define u! gp-unify!)
131 (define (gp-unify! x y s)
132   (let ((r (u! x y s)))
133     (pk `(unify ,r))
134     r))
135 |#
136
137 (define -einstein #f)