base.scm 29 KB
Newer Older
1 2 3
(define-module (logic guile-log prolog base)
  #:use-module (logic guile-log parsing operator-parser)
  #:use-module (logic guile-log guile-log-pre)
Stefan Israelsson Tampe committed
4
  #:use-module (ice-9 eval-string)
5 6
  #:use-module ((system base compile) #:select ((compile . scm-compile)))
  #:use-module (ice-9 time)
7
  #:use-module (logic guile-log guile-prolog closure)
8
  #:use-module (logic guile-log prolog order)
9 10 11
  #:use-module ((srfi srfi-1) #:select (lset-union 
                                        lset-intersection 
                                        lset-difference))
Stefan Israelsson Tampe committed
12
  #:use-module (logic guile-log functional-database)
13
  #:use-module (logic guile-log prolog pre)
14
  #:use-module (logic guile-log prolog run)
15
  #:use-module (logic guile-log prolog var)
16 17
  #:use-module (logic guile-log prolog goal)
  #:use-module (logic guile-log prolog directives)
18
  #:use-module (logic guile-log prolog parser)
19
  #:use-module (logic guile-log prolog symbols)
Stefan Israelsson Tampe committed
20
  #:use-module (logic guile-log prolog varstat)
21
  #:use-module (logic guile-log prolog modules)
22
  #:use-module (logic guile-log prolog dynamic)
Stefan Israelsson Tampe committed
23
  #:use-module ((logic guile-log prolog names)
24
                #:select (make-unbound-fkn end_of_file make-sym))
25
  #:use-module (logic guile-log umatch)
26
  #:use-module ((logic guile-log) #:renamer (lambda (x)
27
					      (if (eq? x '<_>)
28
						  'GL:_
29 30 31
						  (if (eq? x 'umatch)
						      'umatch-guile-log
						      x))))
32 33 34
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (logic guile-log parser)
35
  #:export (compile-prolog-string compile-prolog-file 
Stefan Israelsson Tampe committed
36
				  trace-level 
Stefan Israelsson Tampe committed
37
				  trace read-prolog-term save-operator-table
38 39
				  Trace Level trace-level
				  eval_when))
40

41

42 43 44 45
(define-syntax-rule (stp x) 
  (syntax-parameterize ((S (lambda (z) #'(fluid-ref *current-stack*))))
    x))
						
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
(define do-print #f)
(define pp
  (case-lambda
   ((s x)
    (when do-print
      (pretty-print `(,s ,(syntax->datum x))))
    x)
   ((x)
    (when do-print
      (pretty-print (syntax->datum x)))
    x)))

(define ppp
  (case-lambda
   ((s x)
    (when #t
      (pretty-print `(,s ,(syntax->datum x))))
    x)
   ((x)
    (when #t
      (pretty-print (syntax->datum x)))
    x)))

69
(define-syntax-rule (G x) #'(@ (guile) x))
Stefan Israelsson Tampe committed
70 71 72 73 74 75 76
(define (mk-scheme stx s l unq?)
  (let* ((sym (eval-string (string-append "'" l) #:lang 'scheme))
         (lam (if unq? (lambda (x) #`(unquote #,x)) (lambda (x) x)))
         (w   (datum->syntax stx sym))
         (v   #`(lambda () #,w)))
    (case s
      ((do)
77 78 79 80
       (lam #`(#,(G vector) 
	       (#,(G list)
		(@@ (logic guile-log prolog var) do-eval-scheme)
		#,v))))
Stefan Israelsson Tampe committed
81
      ((when)
82 83 84 85
       (lam #`(#,(G vector)
	       (#,(G list)
		(@@ (logic guile-log prolog var) when-eval-scheme)
		#,v))))
Stefan Israelsson Tampe committed
86 87 88 89 90 91
      ((v var)
       (fluid-set! v-variables (cons sym (fluid-ref v-variables)))
       (lam w))
      ((s scm)
       (lam w)))))

92 93
(define (add x y z n m)
  (if z
94 95
      `((xfy _ "," _) ,x ((xfy _ "," _) ,y ,z ,n ,m) ,n ,m)
      ` ((xfy _ "," _) ,x ,y ,n ,m)))
96

Stefan Israelsson Tampe committed
97 98 99
(define (goal stx x)
  ((@ (logic guile-log prolog goal) goal) stx x))

100 101 102 103
(define (union        x y) (lset-union        eq? x y))
(define (intersection x y) (lset-intersection eq? x y))
(define (diff         x y) (lset-difference   eq? x y))

Stefan Israelsson Tampe committed
104
(define trace-level 0)
105
(define *trace* (make-fluid #f))
106 107 108 109 110 111
(define *eval-only* #f)

(define (maybe_add_call z)
  (if *eval-only*
      `(#:term (#:atom call  #f #f 0 0) ,z #f 0 0)
      z))
112

113
(<define> (trace-fkn b f lev . l)
114 115
  (if (<= lev trace-level )
      (<and>
116
       (<pp-dyn> `(,b enter ,f) `(,b leave ,f))
117
       ((@ (logic guile-log iso-prolog) write) (list b 'trace f l))
118 119
       ((@ (logic guile-log iso-prolog) nl)))
      <cc>))
Stefan Israelsson Tampe committed
120

121 122 123
(define-syntax-parameter Trace (lambda (x) #f))
(define-syntax-parameter Level (lambda (x)  0))
(define-syntax-parameter Fkn   (lambda (x) #''unbound-fkn))
Stefan Israelsson Tampe committed
124 125 126 127 128 129

(define-syntax trace
  (syntax-rules ()
    ((trace f level)
     (syntax-parameterize ((Trace (lambda (x) #'#t))
			   (Level (lambda (x) #'level)))
130
	(mktr Fkn f))) 		  
Stefan Israelsson Tampe committed
131 132
    ((trace f)
     (syntax-parameterize ((Trace (lambda (x) #'#t)))
133
        (mktr Fkn f)))))
134 135 136 137 138 139 140

(define (tr-meta f fnew)     
  (set-object-properties! fnew (object-properties f))
  (if (procedure? f)
      (set-procedure-properties! fnew (procedure-properties f)))
  fnew)

141
(define-syntax-rule (mktr f xx)
142
  (let ((ff f))
143 144 145 146
    (if Trace
      (tr-meta
       ff
       (<lambda> x                       
147
	  (<apply> trace-fkn 'in ff Level x)
148
	  (<apply> xx x)
149
	  (<apply> trace-fkn 'out ff Level x)))
150
      xx)))
151

152 153 154
(define (-define-or-set! xx fkn)
  (let* ((bd?    (module-locally-bound? (current-module) fkn))
	 (fold   (module-ref (current-module) fkn))
155 156 157 158 159
	 (xxf    (if (procedure? xx) (<lambda> z (<apply> xx z)) xx))
	 (sf     (case-lambda 
		   (()  xx)
		   ((f) (set! xx f)))))
    (set-procedure-property! xxf 'debug-fkn sf)
160
    (if bd?
161 162
	(module-set! (current-module) fkn xxf)
	(define! fkn xxf))
163

164
    (set-procedure-property! xxf 'module (module-name (current-module)))
165
    (set-procedure-property! xxf 'shallow #t)
166 167 168
    (set-procedure-property! xxf 'name fkn)))

(define-syntax-rule (define-or-set! x) (-define-or-set! x Fkn))
169 170

(define (define-or-set-fkn! f x)
171 172
  (letrec ((bd?  (module-locally-bound? (current-module) Fkn))
	   (fold (module-ref (current-module) Fkn))
173 174 175 176 177 178
	   (xx   x)
	   (xxf    (if (procedure? xx) (<lambda> z (<apply> xx z)) xx))
	   (sf     (case-lambda 
		     (()  xx)
		     ((f) (set! xx f)))))
    (set-procedure-property! xxf 'debug-fkn sf)
179
    (if bd?
180 181
        (module-set! (current-module) f xxf)
        (define! f xxf))
182

183
    (set-procedure-property! xxf 'module (module-name (current-module)))
184
    (set-procedure-property! xxf 'shallow #t)
185
    (set-procedure-property! xxf 'name f)))
186
        
187

188
(define lambdas (make-fluid '()))
189
(define functors '())
190 191 192
(define (add-lambda x)
  (fluid-set! lambdas (cons x (fluid-ref lambdas))))

193
(eval-when (compile)
194
  (define-syntax-rule (wrapu s1 code ...)
Stefan Israelsson Tampe committed
195 196 197
    (let* ((s1 (gp-newframe (fluid-ref *current-stack*)))
	   (s2 (gp-newframe s1)))
      (with-fluids ((*current-stack* s2))
198
	(let ((ret (begin code ...)))
199
	  (gp-unwind-tail s1)
Stefan Israelsson Tampe committed
200
	  ret)))))
201

202
(define* (compile stx l #:optional (name #f) (lam? #f) (closed? #f))
203 204
  (define (less x y)
    (match (pp 'less-x x)
205
      ((_ #:translated n x) 
206
       (match (pp 'less-y y)
207
         ((_ #:translated m y)
208 209
          (< n m))
         (_ #t)))
210

211
      ((_ #f #f _ _)
212
       #t)      
213

214
      ((_ f xa xb _)
215
       (match (pp 'less-y y)
216
	 ((_ #:translated _ _)
217 218
	  #f)

219
	 ((_ #f #f _ _)
220 221
	  #f)

222
	 ((_ g ya yb _)
223 224 225 226 227 228 229 230
	  (let ((fstr (symbol->string f))
		(gstr (symbol->string g)))
	    (if (string< fstr gstr)
		#t
		(if (string= fstr gstr)
		    (< (length xa) (length ya))
		    #f))))))))

Stefan Israelsson Tampe committed
231
  (define (flatten x)
232 233 234
    (match (pp 'flatt x)
      (((#:include i) . l)
       (append i (flatten l))) 
Stefan Israelsson Tampe committed
235 236
      ((x . l)
       (cons x (flatten l)))
237 238
      (() '())
      (x  (error "match error in flatten"))))
Stefan Israelsson Tampe committed
239
       
Stefan Israelsson Tampe committed
240 241
  (define simple-lam #f)

242 243 244
  (define (ext f)
    #f)

245 246 247 248
  (define (get-fu stx v l)
    (let ((l (get.. "," l)))
      (cons
       (pat-match stx v)
249 250 251
       (if (and (pair? l) (not (null? (car l))))
	   (map (lambda (x) (pat-match stx x)) l)
	   '()))))
252
  
253
  
254
  (define (assert-source x ext)
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285
    (let ((res (wrapu s
		 (assertz-source s		
		    (lambda () (error "failed to compile assertz"))
		    (lambda (s p x) x)
		    stx
		    (let lp ()
		      (catch #t
			(lambda ()
			  (term-init-variables)
			  (let ((code (pp (term stx x)))
				(vs   (map
				       (lambda (x)
					 (list (datum->syntax stx x)
					       #`((@ (logic guile-log umatch)
						     gp-make-var))))
				       (term-get-variables))))
			    (pp (eval
				 (pp `((@@ (logic guile-log prolog base) stp)
				       ((@ (guile) let-syntax)
					((f ((@ (guile) lambda) (z)
					     ,#`(let #,vs `#,code))))
					f)))
				 (current-module)))))
			(lambda x
			  (match x
			    (('unbound-variable _ _ (nm) _)
			     (make-sym (current-module) nm)
			     (lp))
			    (_
			     (error x))))))
		    ext))))
286 287 288
      (pp #`(let* ((fr1 (gp-newframe (fluid-ref *current-stack*)))
		   (fr2 (gp-newframe fr1)))
	      (with-fluids ((*current-stack* fr2))
289
		 ((<lambda> () #,res) fr2 (lambda () #f) (lambda x #t))
290
		 (gp-unwind-tail fr1))))))
291 292
		
  (define (top x i)    
293
    (match (pp 'top x)
294
      ((('fy _ "-" _) (and sym (#:atom v . _)) n m)
295 296 297 298
       (add-sym #f #f sym)
       (set! functors (cons (get-fu stx sym '()) functors))
       #f)

299
      ((('fy _ "-" _) (#:term (and sym (#:atom v . _))  w . _) n m)
300 301 302 303
       (add-sym #f #f sym)
       (set! functors (cons (get-fu stx sym w) functors))
       #f)

304 305 306 307
      ((('fx _ ":-" _) _ n m)
       (warn "COPMILE ERROR: now known :- directive at ~a" (get-refstr n m))
       #f)

Stefan Israelsson Tampe committed
308 309 310 311
      ((('xfy _ "|"  _) args rs n m)
        (set! simple-lam #t)
        (top `(((xfx _ ":-" _) 
                (#:term (#:atom simple-1276 #f #f ,n ,m) ,args #f ,n ,m) 
312
                ,rs ,n ,m)) i))
Stefan Israelsson Tampe committed
313

314
      ((('xfx _ "-->" _) (#:term (and sym (#:atom v . _)) y . l) z n m)
315
       (let ((In  (list #:variable (gensym "In")  n m))
316
	     (Out (list #:variable (gensym "Out") n m)))	 
317
	 (top
318
	  `((xfx _ ":-" _)
319 320
	    (#:term ,sym ,(add In Out y n m) ,@l)
	    ,(dcg In Out z) 
321
	    ,n ,m) i)))
322
       
323 324
      (((and opp ('xfx _ ":-" _)) ((_ _ (and op (not ":")) _) a b n2 m2) z n m)
       (top (list opp (list #:term (list #:atom (string->symbol op) #f #f n2 m2)
325
			    (add a b #f n2 m2) #f n2 m2) z n m) i))
326

Stefan Israelsson Tampe committed
327
      ((('xfx _ ":-" _) (#:term (and sym (#:atom v . _)) y . _) z n m)
328
       (add-sym #f #f sym)
329
       (if (is-dynamic? v)
330
	   (let ((f functors))
331
	     (set! functors '())
332
	     `(,i #:translated 1 ,(assert-source x (ext f))))
333
           (let ((fu (pp v functors)))
334 335 336
	     (set! functors '())
	     (match y
		    (()
337
		     (list i v '() (maybe_add_call z) fu))
338
		    (_
339
		     (list i v (get.. "," y) (maybe_add_call z) fu)))
340
	     )))
341

342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
      (((and op ('xfx _ ":-" _)) ((_ _ ":" _) (#:atom mod . _)
				 (and x
				      (#:term (and sym 
						   (#:atom v _ _ na ma))
					      y . l))
				 . _) z n m)
       (if (is-dynamic? mod v)
	   (let ((x (list op
			  (cons* #:term 
				 (list #:atom 
				       v '@@ 
				       (ref-module-name mod)
				       na ma)
				 y l)
			  z n m)))
				       
358
	     `(,i #:translated 
359 360 361 362 363 364
	       1 ,#`(prolog-run-* 
		     (namespace-switch (ref-module '#,(datum->syntax stx mod))
		        (<lambda> ()
			  #,(mk-rhs stx
				    `(#:term (#:atom assertz #f #f ,n ,m)
					     ,x #f ,n ,m)))))))
365 366
	   (error "Can't define a non multifile goal in different files"
		  mod sym)))
367

368
      ((('xfx _ "-->" _) (and sym (#:atom v . _)) z n m)
369
       (let ((In  (list #:variable (gensym "In")  n m))
370
	     (Out (list #:variable (gensym "Out") n m)))
371
	 (top
372 373 374
	  ` ((xfx _ ":-" _)
	     (#:term ,sym ,(add In Out #f n m) #f ,n ,m)
	     ,(dcg In Out z) 
375
	     ,n ,m) i)))
376

Stefan Israelsson Tampe committed
377
      ((('xfx _ ":-" _) (and sym (#:atom v . _)) z n m)
378
       (add-sym #f #f sym)
379
       (if (is-dynamic? v)
380
	   (let ((f functors))
381
	     (set! functors '())
382
	     `(,i #:translated 1 ,(assert-source x (ext f))))
383
	   (let ((fu (pp v functors)))
384
	     (set! functors '())
385
	     (list i v '() z fu))))
386
	   
Stefan Israelsson Tampe committed
387
      ((('xfx _ ":-" _) (((_ _ op _) a b _ _)) z _ _)
388 389
       (if (is-dynamic? (string->symbol op))
           (error "dynamic operator not supprted")
390 391
	   (let ((fu functors))
	     (set! functors '())
392
	     (list i (string->symbol op) (list a b) (maybe_add_call z) fu))))
393

394

Stefan Israelsson Tampe committed
395
      ((('xfx _ ":-" _) (((_ _ op _) a _ _)) z _ _)
396
       (if (is-dynamic? (string->symbol op))
397
           (error "dynamic operator not supported")
398 399
	   (let ((fu functors))
	     (set! functors '())
400
	     (list i (string->symbol op) (list a) z fu))))
401

Stefan Israelsson Tampe committed
402
      ((('fx _ ":-" _) z . _)
403 404
       (let ((fu functors))
	 (set! functors '())
405
	 (list i #f #f z fu)))
406

407 408
      ((#:translated n (#:init (x)))
       (list
409
	i
410 411
	#:translated n
	(list
412
	 i
413
	 #:init
414
	 #`(prolog-run-* #,(mk-rhs stx x)))))
415
      
416 417
      ((#:translated n (#:init x))
       (list
418
	i
419 420 421
	#:translated n
	(list
	 #:init
422
	 #`(prolog-run-* #,(mk-rhs stx x)))))
423 424 425

      ((#:translated n (#:include fn x))
       (set! functors '())
426
       (let ((res (list i #:include (map top x))))
427 428 429
	 (set! functors '())
	 res))

430
      ((#:translated _ _)
431 432
       (cons i x))
      
433 434
      ((and sym (#:atom v _ _ n m))
       (add-sym #f #f sym)
435
       (if (is-dynamic? v)
436
           `(,i #:translated  1 ,(assert-source x #f))
437
           (list i v '() '() '())))
438

439 440
      (((_ _ ":" _) (#:atom mod . _) (#:term (#:atom v _ _ na ma) y . l)
	n m)
441
       (if (is-dynamic? mod v)
442 443 444 445 446 447 448 449
	   (let ((x (cons* #:term 
			   (list #:atom
				 v
				 '@@
				 (ref-module-name mod)
				 na ma)
			   y  l)))
	     
450
	     `(,i #:translated 
451
	       1 ,#`(prolog-run-* 
452
		     (namespace-switch (ref-module #,(datum->syntax stx mod))
453 454 455 456
			(<lambda> ()
			      #,(mk-rhs stx
				    `(#:term (#:atom assertz #f #f ,n ,m)
					     ,x #f ,n ,m)))))))
457 458
	   (error "Can't define a non multifile goal in different files II"
		  mod v)))
459
          	  
460 461 462
      (((_ _ (and op (not ":")) _) x y n m)
       (top (list #:term 
		  (list #:atom (string->symbol op) #f #f n m)
463
		  (add x y #f n m) #f n m) i))
464

465 466
      ((#:term (and sym (#:atom v . _)) y _ n m)
       (add-sym #f #f sym)
467
       (if (is-dynamic? v)
468
           `(,i #:translated 1 ,(assert-source x #f))
469 470
	   (let ((fu functors))
	     (set! functors '())
471
	     (list i v (get.. "," y) '() fu))))
Stefan Israelsson Tampe committed
472
      
473
      ((_) (top (car x) i))
Stefan Israelsson Tampe committed
474
      #;((rs)
Stefan Israelsson Tampe committed
475 476 477 478 479
       (set! simple-lam #t)
       (top `(((xfx _ ":-" _) 
                (#:term (#:atom simple-1277 #f #f 0 0) () #f 0 0) 
                (,rs) 0 0))))

Stefan Israelsson Tampe committed
480
      #;(rs
Stefan Israelsson Tampe committed
481 482 483 484
       (set! simple-lam #t)
       (top `(((xfx _ ":-" _) 
                (#:term (#:atom simple-1277 #f #f 0 0) () #f 0 0) 
                (,rs) 0 0))))))
485 486 487 488 489 490 491
  
  (define (remfalse x)
    (let ((x x))
     (match x
      ((#f . l) (remfalse l))
      ((x  . l) (cons x (remfalse l)))
      (()       '()))))
492

493 494 495 496
  (define (order x)
    (map cdr (stable-sort x (lambda (x y) (< (car x) (car y))))))
     

497 498
  (define-syntax-rule (wi x) (if lam? x (with-fluids ((lambdas '())) x)))

499
  (define (mcar x) (if x x '()))
Stefan Israelsson Tampe committed
500
  (pp 'compile-1 l)
501
  (if l (begin
502 503 504
  (with-fluids ((v-variables '()))
  (wi 
   (let* ((l-r (pp 'l-r (stable-sort 
505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520
			 (remfalse 
			  (pp 'toped 
			      (flatten
			       (map top (pp 'compile-2 
					    (mcar l))
				    (iota (length (mcar l)))))))
			 less)))

	  (in.r (pp 'in.r
		    (let lp ((l-r l-r) (def '()) (r  '()) (mod '()))
		      (match (pp 'ini l-r)
			     (((_ #:translated _ (#:module x)) . l)
			      (lp l def r mod))

			     (((i #:translated _ (#:init x)) . l)
			      (lp l def (cons (cons i x) r) mod))
521
		     
522 523 524 525 526 527 528 529 530 531
			     (((i #:translated n x) . l)
			      (lp l (cons (cons i x) def) r mod))
			     (x 
			      (cons* def r x mod))))))

	  (ini  (reverse (car  in.r)))
	  (evl  (reverse (cadr in.r)))
	  (l-r  (caddr in.r))
	  (mod  (cdddr in.r))
	  (com (pp 'com 
532
		   (let lp ((f #f) (xx #f) (l l-r) (r '()) (rl '()) (res '()) 
533 534
		       (fuu '()))
		(define (next l x y fu)
535 536
		  (if (= (length x) (length xx))
		      (lp f x l (cons (cons x y) r) 
537
			  rl                    res (pp f (append fu fuu)))
538
		      (lp f x l (list (cons x y))   
539
			  (cons (reverse r) rl) res (pp f (append fu fuu)))))
540
		
541
		(match (pp 'com l)
542
		 (((i v x y fu) . l)
543
		  (if f
544
		      (if (eq? v (cdr f))
545
			  (next l x y fu)
546
			  (if (pair? r)
547
			      (lp (cons i v) x l (list (cons x y)) '()
548
				  (cons (cons* f fuu
549
					      (reverse (cons (reverse r) rl)))
550
					res) fu)
551
			      (lp (cons i v) x l (list (cons x y)) '()
552 553
				  (cons (cons* f fuu (reverse rl))
					res) fu)))
554 555
		      (lp (cons i v) x l (list (cons x y)) rl res
			  (append fu fuu))))
556 557 558
		 (()
		  (if f
		      (let* ((rl_ (if (null? r) 
559 560 561
				      (cons* f fuu (reverse rl))
				      (cons* f fuu (reverse 
						    (cons (reverse r) rl)))))
562 563 564 565 566
			     (res_ (if (null? rl_)
				       (reverse res)
				       (reverse (cons rl_ res)))))
			
			res_)
567
		      '())))))))	  
Stefan Israelsson Tampe committed
568 569 570 571 572 573 574 575 576 577 578 579 580 581 582

    (let* ((last-name #f)           
           (nm        (if name name
                          (gensym "closure-")))

           (l         (map (gen-fkn stx lam? (if simple-lam nm #f)
                                    (lambda (x) (set! last-name x)))
                           (pp 'com com)))

           (name      (if simple-lam
                          nm
                          (if name name
                              (if last-name last-name
                                  nm)))))
                          
583 584 585 586 587 588 589 590
      (if lam?     
          (let* ((nm   (datum->syntax stx name))
                 (vs   (fluid-ref v-variables))
                 (vstx (map (lambda (x) 
                              (datum->syntax stx x))
                            vs)))
            (add-lambda (list name
                              vs
Stefan Israelsson Tampe committed
591 592 593 594 595
                              (pp 'closure
                                   #`(letrec 
                                         ((parent
                                           (lambda #,vstx
                                             (let ()
596
					       #,@(order (append l evl))
Stefan Israelsson Tampe committed
597 598
                                               (make-prolog-closure
                                                #,nm parent 
599 600
                                                (#,(G list)
						 #,@vstx) #,closed?)))))
Stefan Israelsson Tampe committed
601
                                       parent))))
602
            (pp 'res #`(let () #,@ini (#,nm #,@vstx))))
603 604 605 606 607 608 609 610 611 612 613 614
          (with-syntax (((lam-def ...)
                         (let lp ((l (fluid-ref lambdas)))
                           (match l
                             (((nm vs lam) . l)
                              (if 
                               (pair? (pp vs))                               
                               (error "v[.] is refering to a global variable"))
                              (cons (mk-lam stx nm lam) (lp l)))
                             ((#(x) . l)
                              (cons x (lp l)))
                             (() '())))))

615 616
	     (let* ((syms (get-syms))
		    (syms (union syms syms)))
617
	       (pp 'res #`(begin
618
                            #,@mod
619
			    (eval-when (compile load eval)
620
				       (add-non-defined 
621
					(quote #,(datum->syntax stx syms))))
622
			    lam-def ... #,@(order (append l ini evl))))))))))))
623
      #''compile-error))
624

625 626 627 628 629
(define-syntax save-operator-table
  (lambda (x)
    (syntax-case x ()
      ((_)
       #`(assq->ops #,(ops->assq))))))
630

631
(define-syntax-rule (map2 f x ...)
632 633 634 635
  (let ((F f))
    (map (lambda (x ...) (map F x ...)) x ...)))


636
(define (mk-rhs stx rhs)
Stefan Israelsson Tampe committed
637 638 639 640 641 642
  (with-varstat
   (let* ((var       (get-variables (list rhs)))
	  (l.v.code  ((get-rhs stx) '() var rhs))
	  (loc       (list-ref l.v.code 0))
	  (var       (list-ref l.v.code 1))
	  (code      (list-ref l.v.code 2)))
643
     #`(<let> #,(map (lambda (v) #`(#,(datum->syntax stx v) #f))
644 645
		     '() #;loc)
	(<var> #,(map (lambda (x) (datum->syntax stx x)) (append var loc))
Stefan Israelsson Tampe committed
646
	   #,code)))))
647
    
648 649 650 651
(define (mk-lam stx nm lam)
  (with-syntax ((dir (datum->syntax stx (module-name (current-module))))
                (nm  (datum->syntax stx nm)))
    #`(begin
652 653
        (syntax-parameterize ((Fkn (lambda (x) #''nm)))
           (define-or-set! #,lam))
654 655
        (set-procedure-property! nm 'module dir)
        (set-procedure-property! nm 'shallow #t))))
656

657 658 659 660 661 662
(define-syntax apply-fu
  (syntax-rules (unquote)
    ((_ ((,fu ,a ...) . l) code)
     (fu (apply-fu l code) a ...))
    ((_ () code) 
     code)))
663

664 665 666 667 668 669 670 671
;; This is matched from the toplevel, got syntax issues e.g. eval-when does
;; Not match on symbols, but syntaxes
(define-syntax eval_when 
  (lambda (x)
    (syntax-case x ()
      ((eval_when f a ...)
       #'f))))

Stefan Israelsson Tampe committed
672
(define (gen-fkn stx lam? nm nm-store)
673
  (lambda (com)
674
   (match com
675
    (((i . f) fu . (((l . r) ...) ...))
676 677 678 679
     (define lams '())
     (define vs   '())
     (define ret
       (with-fluids ((lambdas '()))
680
         (let* ((f     (if nm nm f))
681
		(fu    (reverse fu))
Stefan Israelsson Tampe committed
682
                (v-l   (pp 'v-l   (map2 get-variables l)))
683
                (v-r   (pp 'v-r   (map2 (lambda (x)
684
                                          (get-variables (list x))) r)))
Stefan Israelsson Tampe committed
685
                (v-new (pp 'v-new (map2 difference v-r v-l)))
686 687
                (v-all (union v-l v-r))
                (lhs   (pp 'lhs   (map2 (get-lhs stx) l)))
Stefan Israelsson Tampe committed
688 689 690 691 692 693 694 695 696 697 698 699
                (loc.v.rhs (pp 'rhs   (map2 (get-rhs stx) v-l v-new r)))
		(loc   (map2 (lambda (x)
			       (map (lambda (x)
				      (datum->syntax stx x))
				    (list-ref x 0)))
			     loc.v.rhs))
		(v-new (map2 (lambda (x)
			       (map (lambda (x)
				      (datum->syntax stx x))
				    (list-ref x 1)))
			     loc.v.rhs))
		(rhs   (map2 (lambda (x) (list-ref x 2)) loc.v.rhs)))
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718
           
           (let lp ((ls (fluid-ref lambdas)))
             (match ls
               (((nm vs lam) . ls)
                (let* ((v-int (intersection vs v-all))
                       (v-out (diff         vs v-int)))
                  (set! vs (union v-out vs))
                  (set! lams (cons (vector (mk-lam stx nm lam)) lams))
                  (lp ls)))
                           
               ((x .lams)
                (set! lams (cons x lams)))

               (() #t)))

                            
           (count-variables (map (lambda (x) (cons x 0)) v-all) (cons l r))
           (with-syntax (((((lhs ...) ...) ...) lhs)
                         (((rhs  ...) ...)      rhs)
Stefan Israelsson Tampe committed
719
			 ((((loc ...) ...) ...) loc)
720
                         ((((v   ...) ...) ...) v-new)
Stefan Israelsson Tampe committed
721
                         (fstx                 (datum->syntax stx f)))
722 723 724 725 726

	     (when (member f (string->list ",;"))
	       (warn "redifing , or ;, mayby . => , is needed"))
		     
				 
727
             (if lam?
Stefan Israelsson Tampe committed
728 729 730
                 (begin
                   (nm-store f)
                   (pp 'fkn
731
                   #`(syntax-parameterize ((Fkn (lambda (x) #''fstx)))
732
		      (define fstx (apply-fu #,fu
733
                       (<<case-lambda-dyn-combined>> fstx
Stefan Israelsson Tampe committed
734 735 736 737
                        ((lhs ...       
			      (<let> ((loc #f) ...)
                                 (<var> (v ...) 
                                     rhs))) ...)
738
                        ...))))))
739
             
740
		   (let* ((fuu (syntax-case fu (eval_when unquote)
741 742 743 744 745 746 747
			       (((,eval_when . a) . f)
				#'f)
			       (x #'x)))
			(ret 
			 #`(syntax-parameterize ((Fkn (lambda (x) #''fstx)))
			     (define-or-set! 
                               (apply-fu #,fuu
748
				 (<<case-lambda-dyn-combined>> fstx
749 750 751 752 753 754 755
				   ((lhs ...
					 (<let> ((loc #f) ...)
					   (<var> (v ...) 
					     rhs))) ...)
				   ...))))))
      
		   (syntax-case fu (eval_when unquote)
756
		     (((,eval_when ,args ...) . l)
757 758 759 760 761 762 763 764
		      #`(eval-when #,(map (lambda (x)
					    (datum->syntax #'eval_when 
					      (syntax->datum x)))
					  #'(args ...))
			     #,ret))
		     (else
		      ret))))))))
			
765 766 767 768 769 770 771
     (fluid-set! lambdas (append lams (fluid-ref lambdas)))
     (when (pair? vs)
       (if 
        lam?
        (fluid-set! v-variables (union vs v-variables))
        (error 
   "v[.] used by first level function - not supported or use scm[.] in stead")))
772
     (cons i ret)))))
773 774 775 776 777




           
778 779 780 781 782 783 784 785

(define (union v1 v2)
  (define tab  (make-hash-table))
  (define (fold k v l) (cons k l))
  (for-each (lambda (x) (hashq-set! tab x #t)) v1)
  (for-each (lambda (x) (hashq-set! tab x #t)) v2)
  (hash-fold fold '() tab))
  
Stefan Israelsson Tampe committed
786
(define difference  
787 788 789 790
  (lambda (x y)
    (define x-tab (make-hash-table))
    (define (fold k v l)
      (if v
Stefan Israelsson Tampe committed
791
	  (cons k l)
792 793 794 795 796 797 798
	  l))
    (define (f x p)
      (for-each
       (lambda (x) (hash-set! x-tab x p))
       x))

    (f x #t)
Stefan Israelsson Tampe committed
799
    (f y #f)
800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815
    (hash-fold fold '() x-tab)))

(define (count-variables vs l)
  (define tab (make-hash-table))
  (define (coll x) (hashq-set! tab x 0))
  (for-each coll vs)
  (let lp ((l l))
    (match l
      ((#:variable x . _)
       (hashq-set! tab x (+ (hashq-ref tab x 0) 1)))
      ((x . l)
       (lp x) (lp l))
      (_ #t)))
  (let lp ((l l))
    (match l
      ((#:variable x n m)
816
       (when (and (not (eq? x '_)) (= (hashq-ref tab x 0) 1))
Stefan Israelsson Tampe committed
817 818
	 (warn (format #f "At ~a, Variable ~a only used one time"
		       (get-refstr n m) x))))
819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834
      ((x . l)
       (lp x) (lp l))
      (_ #t))))

(define (get-variables exp)
  (define vs (make-hash-table))
  (define (add v)
    (hash-set! vs v #t))
 
  (define (loop exp)
    (match (pp 'get-variables exp)
      (((_ . _) x y _ _)
       (loop x)
       (loop y))
      (((_ . _) x _ _)
       (loop x))
Stefan Israelsson Tampe committed
835
            
836 837 838
      ((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
       (loop l))
      
839 840 841
      ((#:group x)
       (loop x))

842
      ((#:variable x . _) 
Stefan Israelsson Tampe committed
843 844
       (if (not (eq? x '_))
	   (add x)))
845
      ((#:termvar v _ l . _)
846 847
       (add v)
       (loop l))
848

849 850 851
      ((#:termstring v l . _)
       (loop l))

852 853 854 855
      ((#:fknfkn a b)
       (loop a)
       (loop b))

856 857 858 859
      ((#:term v l . _)
       (loop l))
      ((#:list l . _)
       (loop l))
Stefan Israelsson Tampe committed
860 861
      ((x)
       (loop x))
862 863 864 865 866 867 868 869
      (_ #t)))

  (map loop exp)
 
  (hash-fold (lambda (k v l) (cons k l)) '() vs))

(define (get-lhs stx)
  (lambda (x)
870
    (map (lambda (x) (pat-match stx x)) x)))
871 872
      
(define (get-rhs stx)
Stefan Israelsson Tampe committed
873 874 875
  (lambda (vl vs x) 
    (with-varstat
     (init-first-variables)
876
     (for-each first-variable! vl)
Stefan Israelsson Tampe committed
877
     (register-variables x)
878
     (let ((code  (goal stx x))
Stefan Israelsson Tampe committed
879 880 881 882 883 884 885 886 887 888 889 890 891 892
	   (loc   (let lp ((var vs))
		   (if (pair? var)
		       (if (local-variable? (car var))
			   (cons (car var) (lp (cdr var)))
			   (lp (cdr var)))
		       '())))
	   (var   (let lp ((var vs))
		    (if (pair? var)
			(if (not (local-variable? (car var)))
			    (cons (car var) (lp (cdr var)))
			    (lp (cdr var)))
			'()))))
       (list loc var code)))))

893

894
(define-syntax compile-prolog-string
895 896 897
  (lambda (x)
    (syntax-case x ()
      ((n str)
Stefan Israelsson Tampe committed
898
       (wrapu s
899 900 901
	 (with-syms
	  (compile x
		   (prolog-parse x (syntax->datum #'str)))))))))
902

903
(define (re-compile stx str nm closed?)
904 905 906 907 908
  (let ((str (string-trim-right str)))
    (when (not (eq? (string-ref str (- (string-length str) 1)) #\.))
      (set! str (string-append str ".")))
    (compile stx
             (prolog-parse stx str)
909
             nm #t closed?)))
910 911

(set! (@@ (logic guile-log prolog var) compile-lambda) re-compile)
912
(define-syntax compile-prolog-file
913 914
  (lambda (x)
    (syntax-case x ()
915
      ((n str . l)
916 917
       (with-input-from-file (syntax->datum #'str)
	 (lambda ()
Stefan Israelsson Tampe committed
918
           (with-fluids ((*prolog-file* (syntax->datum #'str)))
Stefan Israelsson Tampe committed
919
	     (wrapu s
920 921 922
	       (with-syms
		(compile x
			 (prolog-parse x)))))))))))
Stefan Israelsson Tampe committed
923

924 925
(eval-when (compile eval load)
 (define lamman (make-fluid)))
926

Stefan Israelsson Tampe committed
927 928
(define mod (current-module))
        
929
(define burp (make-fluid #f))
Stefan Israelsson Tampe committed
930

931
(define (read-prolog-term state stream module)
932
  (let ((stx (vector 'syntax-object 'a '((top)) 
933
		     (cons* 'hygiene (module-name module)))))
934
    (with-fluids ((lambdas '()))
935
      (begin
936
	(term-init-variables)
937
        (with-syms
938
	 (let* ((r  (pp 'parse (prolog-parse-read stream stx))))
939
	   (if (and (pair? r) (pair? (car r)))
940
	       (let* ((r   (pp 'term (term stx (reverse (car r)))))
941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
		      (vl  (pp 'vl   (term-get-variables-list)))
		      (vs  (pp 'vs   (term-get-variables)))
		      (h   (make-hash-table))
		      (w   (map (lambda (x) 
				  (let ((r (gp-make-var))) 
				    (hash-set! h x r)
				    r))
				vs))
		      (s   (make-hash-table))
		      (wl  (let lp ((vl vl) (r '()))
			     (if (pair? vl)
				 (let ((x (car vl)))
				   (if (hash-ref s x)
				       (begin
					 (hash-set! s x 1)
					 (lp (cdr vl) r))
				       (begin
					 (hash-set! s x 0)
					 (lp (cdr vl) (cons x r)))))
				 (reverse! r))))
		      (ws  (let lp ((vs vs))                            
			     (if (pair? vs)
				 (let ((x (car vs)))
				   (if (hash-ref s x)
				       (cons (cons x  (hash-ref h x))
					     (lp (cdr vs)))
				       (cdr vs)))
				 '())))
		      (burp #f))
970
                
971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987
		 (add-non-defined (get-syms))

		 (pp 'lambdas (fluid-ref lambdas))
		 ;; Make sure to define closure parents in current module
		 (let lp ((lams (fluid-ref lambdas)))
		   (match lams
		     (((nm vs lam) . lams)
		      (let ((fkn 
			     (eval
			      `(let-syntax 
				   ((f 
				     (lambda (x) 
				       ,((@@ (logic guile-log prolog base) 
					     pp) 'lammit lam))))
				 f)
			      (current-module))))
			(define-or-set-fkn! nm fkn))
Stefan Israelsson Tampe committed
988
                     
989 990
		      (lp lams))
		     
991
                    (() #t)))
992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
		 (set! burp 
		   (pp 'burp
		       #`(lambda (s123 #,@(map 
					   (lambda (x)
					     (datum->syntax stx x))
					   vs))
			   `#,r)))

		 (values
		  (let ((r 
			 (apply
			  (eval 
			   `((lambda () (let-syntax ((fexpr (lambda (x) ,burp)))
					  fexpr)))
			   mod)
			  state w)))
		    r)
		  w wl ws))
	       end_of_file)))))))
1011

1012 1013 1014 1015 1016 1017
(define (add-non-defined l)
  (when #t (eq? (get-flag 'auto_sym) 'on)
    (let lp ((l l))
      (match l
        ((x . l)
         (let ((mod (current-module)))
1018
           (unless (module-defined? mod x)
1019
             (let ((f (make-unbound-fkn x)))
1020
               ;(format #t "Defined non defined variable ~a~%" x)
1021
               (module-define! mod x f)
1022
               (set-procedure-property! f 'module (module-name mod))
1023
               (set-procedure-property! f 'shallow #t)
1024
               (set-procedure-property! f 'name x))))
1025 1026
         (lp l))
        (() #t)))))
1027

1028 1029 1030 1031 1032 1033 1034 1035
#|
For read term we need to know how to translate in a goody daddy way,
especially symbol functors need to be handled, the translation of
functor names to functor objects. In the end we might need to add special
syntax for symbol + module knowledge, this means that e,g, code that is defined
in one module get's it's value in another one and name object mapping might go 
out of order and be buggy. To note is that we might use some kind of directive 
to tell the parser how to translate
Stefan Israelsson Tampe committed
1036
|#