fix of cleaned file
[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 (ice-9 format)
4   #:use-module (srfi srfi-11)
5   #:use-module (srfi srfi-9)
6   #:use-module (srfi srfi-9 gnu)
7   #:export  (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind 
8                       gp->scm gp-print gp-var!  gp-heap-var! 
9                       gp-c-system
10                       gp-budy gp-m-unify!
11                       gp-lookup ;gp-lookup-clean
12                       gp-var? gp-cons! gp-set! 
13                       gp-var-number gp-print-stack
14                       gp-car gp-cdr gp-pair? gp-pair* gp-pair- gp-pair+
15                       gp-store-state gp-restore-state
16                       gp-make-var gp-var-set gp-var-set!
17                       gp-dynwind
18                       gp-atomic? 
19                       gp-logical-var?
20                       gp-get-stack
21                       gp-rguards-ref
22                       gp->scm
23                       gp-logical++ gp-logical-- 
24                       gp-make-stack
25                       gp-pair!? gp-null!? gp-null?
26                       gp-jumpframe-start gp-jumpframe-end gp?
27                       gp-module-init                      
28                       gp-thread-safe-set!
29                       -gp-member -gp-right-of -next-to -einstein
30                       
31                       gp-current-stack-ref
32                       gp-undo-safe-variable-guard
33                       gp-undo-safe-variable-rguard
34                       gp-undo-safe-variable-lguard
35                       gp-prompt gp-abort
36                       gp-fluid-set
37                       
38                       gp-handlers-ref
39                       gp-handlers-set!
40                       gp-cont-ids-ref
41                       gp-cont-ids-set!
42
43                       gp-guard-vars
44                       
45                       vlist? vlist-cons vlist-head vlist-tail vlist-null?
46                       vlist-null list->vlist vlist-ref vlist-set!
47                       vlist-fold vlist-fold-right 
48                       vlist-last-val vlist-cons* vlist-pair?
49                       test-vlist
50                       vlist-drop vlist-take
51                       vlist-length  vlist-map
52                      ;vlist-unfold vlist-unfold-right vlist-append
53                       vlist-reverse vlist-filter vlist-delete vlist->list
54                       vlist-for-each
55                       vlist-truncate! vhash-truncate!
56                       vlist-thread-inc vlist-new-thread
57                       vlist-refcount-- vlist-refcount++
58                       
59                       vhash-set! vhash-setq! vhash-setv!
60                       vhash? vhash-cons vhash-consq vhash-consv
61                       vhash-assoc vhash-assq vhash-assv
62                       vhash-delete vhash-delq vhash-delv
63                       vhash-fold vhash-fold-right
64                      ;vhash-fold* vhash-foldq* vhash-foldv*
65                      ;alist->vhash
66                       vhash->assoc
67                       vhashq->assoc
68                       vhashv->assoc
69                      block-growth-factor init-block-size
70                      
71                      get-index-set get-index-test
72                      ))
73
74 ;; Tos silence the compiler, those are fetched from the .so file
75 (define setup-vlist #f)
76
77
78 ;;need to add modded,   
79 (catch #t
80   (lambda ()
81     (load-extension "libguile-log" "gp_init"))
82   (lambda x      
83     (let ((file  
84            (%search-load-path "logic/guile-log/src/.libs/libguile-log.so")))
85       (if 
86        file
87        (catch #t
88          (lambda ()
89            (load-extension file "gp_init"))
90          (lambda x
91            (pk x)
92            (warn
93             "libguile-log is not loadable!")))
94        (warn 
95         "libguile-unify is not present, did you forget to make it?")))))
96
97 (define-syntax-rule  (definek x val)
98   (module-define! (current-module) 'x val))
99
100 (define wrap #f)
101 (define-syntax-rule (define3 nm r)
102   (definek nm (let ((rr r))
103                 (if wrap
104                     (lambda (x y z) (rr x y z))
105                     rr))))
106
107 (define-syntax-rule (define2 nm r)
108   (definek nm (let ((rr r))
109                (if wrap
110                    (lambda (x y) (rr x y))
111                    rr))))
112
113 (define-syntax-rule (define1 nm r)
114   (definek nm (let ((rr r))
115                (if wrap                   
116                    (lambda (x) (rr x))
117                    r))))
118
119 (define (gp-pair+ x s)
120   (let ((s (gp-pair!? x s)))
121     (if s
122         (values (gp-car x s) 
123                 (gp-cdr x s)
124                 s)
125         (values #f #f #f))))
126
127 (define (gp-pair- x s)
128   (let ((s (gp-pair? x s)))
129     (if s
130         (values (gp-car x s) 
131                 (gp-cdr x s)
132                 s)
133         (values #f #f #f))))
134
135 (define (gp-pair* x s)
136   (if (pair? x)
137       (values (car x) 
138               (cdr x)
139               s)
140       (values #f #f #f)))
141
142 (definek   gp-c-system #f)
143 (definek  -gp-member    #f)
144 (definek  -gp-right-of  #f)
145 (definek  -next-to      #f)
146
147 (define -einstein #f)
148
149 (define-record-type <vlist>
150   ;; A vlist is just a base+offset pair pointing to a block.
151
152   ;; XXX: Allocating a <vlist> record in addition to the block at each
153   ;; `vlist-cons' call is inefficient.  However, Bagwell's hack to avoid it
154   ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
155   ;; performance hit for everyone.
156   (make-vlist base offset)
157   vlist?
158   (base    vlist-base)
159   (offset  vlist-offset))
160
161 (set-record-type-printer! <vlist>
162                           (lambda (vl port)
163                             (cond ((vlist-null? vl)
164                                    (format port "#<vlist ()>"))
165                                   ((vhash? vl)
166                                    (format port "#<vhash ~x ~a pairs>"
167                                            (object-address vl)
168                                            (vlist-length vl)))
169                                   (else
170                                    (format port "#<vlist ~a>"
171                                            (vlist->list vl))))))
172
173 (define x                   (setup-vlist <vlist>))
174 (define vlist-null          (list-ref x 0))
175 (define block-growth-factor (list-ref x 1))
176 (define init-block-size     (list-ref x 2))
177 (define thread-seq          (list-ref x 3))
178 (define thread-nr           (list-ref x 4))
179 (define thread-inc          (list-ref x 5))
180 (define (vlist-pair? x) (and (vlist? x) (not (vlist-null? x))))
181
182 (define (vlist-thread-inc)
183   (fluid-set! thread-seq (+ thread-inc (fluid-ref thread-seq))))
184
185 (define (vlist-new-thread)
186   (fluid-set! thread-nr  (+ thread-inc (fluid-ref thread-nr)))
187   (fluid-set! thread-seq thread-inc))
188
189 (define (vlist-last-val x)
190   (if (vlist-pair? x)
191       (vlist-ref x (- (vlist-length x) 1))
192       #f))
193
194 (define (vlist-cons* . l)
195   (let ((r (vlist-last-val l)))
196     (if r
197         (let lp ((l l))
198           (if (eq? l r)
199               r
200               (vlist-cons (car l) (lp (cdr l)))))
201         r)))
202         
203