compile.scm 19.6 KB
Newer Older
1
(define-module (logic guile-log prolog compile)
2
  #:use-module (logic guile-log guile-prolog closure)
3
  #:use-module (logic guile-log guile-prolog copy-term)
4
  #:use-module (ice-9 pretty-print)
5
  #:use-module (ice-9 match)
6
  #:use-module (ice-9 time)
7 8
  #:use-module (logic guile-log)
  #:use-module (logic guile-log functional-database)
9
  #:use-module ((logic guile-log prolog names)
10 11
                #:select (! fail true false
			    prolog-and prolog-or prolog-not prolog=..))
12 13
  #:use-module (logic guile-log prolog goal-functors)
  #:use-module (system base compile)
14
  #:use-module (system base language)
15
  #:use-module ((logic guile-log umatch)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
16 17
                #:select (gp-attvar-raw? gp-att-data gp-att-raw-var
					 gp-make-var gp-var? gp-lookup))
18 19
  #:export (compile-prolog))

20 21
(define include-meta #t)

22 23
(define (default-extensions)
  (list prolog-and 'and prolog-or 'or prolog-not 'not prolog=.. '=..))
24

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
25 26 27
(define (simplify x)
  (datum->syntax #'simple-stx (syntax->datum x)))

28
(define do-print #f)
29 30 31 32 33 34 35 36 37 38
(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)))
39

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
40 41
(define ppp
  (case-lambda
42
  ((s x)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
43 44 45 46 47 48 49
    (when #t
      (pretty-print `(,s ,(syntax->datum x))))
    x)
   ((x)
    (when #t
      (pretty-print (syntax->datum x)))
    x)))
50

51 52 53 54 55 56 57 58 59
(define (make-vars n)
  (let lp ((i 0) (r '()))
    (if (< i n)
	(lp (+ i 1) 
	    (cons
	     ((@ (logic guile-log umatch) gp-make-var))
	     r))
	r)))

60 61
(define (ident? x)
  (or (char? x)
62
      (boolean? x)
63 64 65 66 67
      (string? x)
      (null?   x)
      (symbol? x)
      (number? x)))

68 69
(define-syntax-rule (G  x) '(@ (guile) x))
(define-syntax-rule (GL x) '(@ (logic guile-log) x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
70
(define-syntax-rule (UM x) '(@ (logic guile-log umatch) x))
71
(define-syntax-rule (FU x) '(@ (logic guile-log prolog goal-functor) x))
72 73 74 75 76 77 78 79
(define-syntax-rule (C  c) '(@@ (logic guile-log prolog compile) x))
(define-syntax-rule (lumelunda code)
  (let ((action (lambda () code))
	(f      #f))
    (lambda x
      (if (not f) (set! f (action)))
      (apply f x))))

80

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
81
(define is-compile-all (make-fluid #f))
82
(define (compile-prolog s a f source? extention?)
83 84 85 86 87 88 89 90 91
  (define meta-only? (and (pair? extention?)
			  (eq? (car extention?) #t)
			  (cadr extention?)))
  
  (define fast-compile?
    (and (pair? extention?)
	 (eq? (car extention?) #t)
	 (not (cadr extention?))))

92 93 94
  (define in-house (make-hash-table))
  (define ex-house (make-hash-table))
  (define fkns     (make-hash-table))
95
  
96 97 98
  (define (add-fkn x)
    (let ((r (hashq-ref fkns x #f)))
      (unless r
99 100 101
	(if (procedure? x)
	    (let ((n   (procedure-name x))
		  (mod (procedure-property x 'module)))
102
	      (if (or (not mod))
103 104
		  (hashq-set! fkns x (gensym "FKN"))))
	    (hashq-set! fkns x (gensym "FKN"))))))
105

106
  (define (get-fkn x)
107
    (let ((r (hashq-ref fkns x #f)))
108 109 110 111 112 113 114 115 116 117 118 119 120 121
      (if r 
	  r
	  (let ((n   (procedure-name x))
		(mod (let ((m (procedure-property x 'module)))
		       (if m
			   (if (pair? m)
			       m
			       (module-name m))
			   m))))
	    (if (and mod n)
		`(@@ ,mod ,n)
		(error (format #f
			       "BUG, prolog compile did not find fkn ~a"
			       x)))))))
122 123

  (define (get-var x)
124
    (let ((r (hashq-ref ex-house x #f)))
125 126
      (if r
          r
127
          (hashq-ref in-house x #f))))
128 129 130 131 132

  (define (add-var x)
    (let ((r1 (hashq-ref ex-house x #f))
          (r2 (hashq-ref in-house x #f)))     
      (unless (or r1 r2)
133
         (hashq-set! in-house x (gensym "VAR-")))))
134 135 136 137

  (define (add-exvar x)
    (let ((r1 (hashq-ref ex-house x #f)))
      (unless r1
138
        (hashq-set! ex-house x (gensym "MATCH-VAR-")))))
139 140

  (define (map* f l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
141
    (umatch (#:mode - #:status s #:name map*) (l)       
142 143
      ((x . l)
       (cons (f x) (map* f l)))
144 145
      (() '())
      (x  (f x))))
146 147

  (define (for-each* f l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
148
    (umatch (#:mode - #:status s #:name for-each*) (l)      
149 150 151 152
      ((x . l)
       (begin
         (f x) 
         (for-each* f l)))
153 154
      (() '())
      (x (f x))))
155

156
  (define match-map   #f)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
157 158 159
  (define match-map-o #f)
  (define match-map-i #f)
  (define-syntax-rule (recur-search x code)
160 161
    (let* ((x (gp-lookup x s))
	   (r (hashq-ref match-map x #f)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
162 163
      (if r
	  (if (eq? r #t)
164
	      (hashq-set! match-map x (gensym "REQ")))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
165 166 167 168
	  (begin
	    (hashq-set! match-map x #t)
	    code))))

169
  (define (scan-var add-var x)
170
    (umatch (#:mode - #:status s #:name scan-var) (x)       
171 172
     (#(#:brace x)
      (scan-var add-var x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
173
     (#((f . a))
174
      (begin 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
175 176 177 178 179 180 181
        (recur-search x
	 (cond
	  ((and (struct? f) (prolog-closure? f))
	   (add-fkn (prolog-closure-parent f))
	   (for-each* (lambda (x) (scan-var add-var x)) 
		      (prolog-closure-state f))
	   (for-each* (lambda (x) (scan-var add-var x)) a))         
182
	  ((procedure? f)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
183
	   (add-fkn f)
184 185 186
	   (for-each* (lambda (x) (scan-var add-var x)) a))
	  (else
	   (for-each* (lambda (x) (scan-var add-var x)) (cons f a)))))))
187

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
188 189 190 191 192
      ((a . l)
       (recur-search x
	 (begin
	   (scan-var add-var a)
	   (scan-var add-var l))))
193 194

      (x
195 196 197 198
       (let ((x (gp-lookup x s)))
         (cond 
          ((gp-var? x s)
           (add-var x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
199 200 201 202 203 204 205 206 207 208
	  ((gp-attvar-raw? x s)
	   (if (fluid-ref is-compile-all)
	       (recur-search x
	         (let ((v (gp-att-raw-var x s))
		       (d (gp-att-data x s)))
		   (scan-var add-var v)
		   (scan-var add-var d)))
	       (scan-var add-var (gp-att-raw-var x s))))

	  ((procedure? x)
209 210
           (add-fkn x))
          ((and (struct? x) (prolog-closure? x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
211 212 213 214 215 216 217 218 219 220
	   (recur-search x
	     (for-each
	      (lambda (x)
		(scan-var add-var x))
	      (prolog-closure-state x))))
	  
	   ((not (ident? x))
	    (add-fkn x))
	   (else
	    #t))))))
221 222
    
  (define (scan-goal x)
223
    (umatch (#:mode - #:status s #:name scan-goal) (x)       
224 225
      (#(#:brace a)
       (error "{ ... } as goal is not supprted"))
226
      (#((f . a))
227 228 229 230 231
       (cond
        ((and (struct? f) (prolog-closure? f))
         (add-fkn (prolog-closure-parent f))
         (for-each* scan-goal (prolog-closure-state f))
         (for-each* scan-goal a))         
232
        ((procedure? f)
233
         (add-fkn f)
234 235 236
         (for-each* scan-goal a))
	(else
	 (for-each* scan-goal (cons f a)))))
237

238
      ((u . v)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
239
       (scan-var add-var x))
240 241 242 243 244

      (x
       (cond 
        ((gp-var? x s)
         (add-var x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
245 246 247 248

	((gp-attvar-raw? x s)
	 (scan-var add-var x))

249 250
        ((procedure? x)
         (add-fkn x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
251

252 253 254
        ((and (struct? x) (prolog-closure? x))
         (add-fkn (prolog-closure-parent x))
         (for-each* scan-goal (prolog-closure-state x)))
255 256
        
	(else
257 258
         #t)))))

259
  (define (compile-a match-map-i x)
260 261 262 263 264 265 266 267 268 269 270 271
    (define-syntax-rule (do code)
      (let* ((x (gp-lookup x s))
	     (c (lambda () code))
	     (r1 (hashq-ref match-map-o x #f)))
	(if (and r1 (not (eq? r1 #t)))
	    (if (hashq-ref match-first x #f)
		r1
		(begin
		  (hashq-set! match-first x #t)
		  `(and ,r1 ,(c))))
	    (c))))

272
    (umatch (#:mode - #:status s #:name compile-a) (x)
273
       (#(#:brace x)
274 275 276 277
	(list 'unquote
	      (list (G vector) #:brace 
		    (list (G quasiquote)
			  (compile-a match-map-i x)))))
278

279
       (#((f . a))
280
	(do
281
	  (list 'unquote
282 283 284
	  (let ((f (gp-lookup f s)))
	    (cond
	     ((and (struct? f) (prolog-closure? f))
285 286 287 288 289 290 291 292 293 294 295
	      (list (G vector)
		    (list (G quasiquote)
			  (cons (list 'unquote
				      (cons 
				       (get-fkn (prolog-closure-parent f))
				       (map* (lambda (x) 
					       (compile-a match-map-i x))
					     (prolog-closure-state f))))
				(map* (lambda (x) 
					(compile-a match-map-i x))
				      a)))))
296
	     (else
297 298
	      (list (G vector)
		    (list (G quasiquote)
299 300 301 302 303
			  (cons (list 'unquote 
				      (if (procedure? f)
					  (get-fkn f)
					  (get-var a)))

304 305 306
				(map* (lambda (x) 
					(compile-a match-map-i x))
				      a))))))))))
307 308 309

       ((a . l)
        (do
310 311 312 313
	    (let* ((a  (list (G quasiquote) (compile-a match-map-i a)))
		   (b  (list (G quasiquote) (compile-a match-map-i l)))
		   (r0 (list (G cons) a b)))
	      (list 'unquote r0))))
314
       (a
315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
	(list 'unquote
	      (let ((a (gp-lookup a s)))
		(cond
		 ((gp-var? a s)
		  (get-var a))
		 ((gp-attvar-raw? a s)
		  ;; TODO This is not working
		  (if (fluid-ref is-compile-all)
		      (let ((raw (compile-a match-map-i (gp-att-raw-var a s)))
			    (l   (compile-a match-map-i (gp-att-data   a s))))
			(vector
			 `((@@ (logic guile-log) create)
			   ,raw ,l)))
		      (list (G quasiquote)
			    (compile-a match-map-i (gp-att-raw-var a s)))))
		 ((procedure? a)
		  (get-fkn a))
		 ((symbol? a)
		  (list (G quote) a))
334 335
		 ((null? a)
		 (list 'quote a))
336 337 338 339 340
		 ((and (struct? a) (prolog-closure? a))
		  (cons (get-fkn (prolog-closure-parent a))
			(map* (lambda (x) (compile-a match-map-i x))
			      (prolog-closure-state a))))
		 (else x)))))))
341 342 343 344 345 346 347 348 349

  (define (compile-s match-map-i x)
    (umatch (#:mode - #:status s #:name compile-s) (x)
       (#(#:brace x)
	(error "compile, {...} not supported in scheme tag"))
       (#((f . a))
	(let ((f (gp-lookup f s)))
	  (cond
	   ((procedure? f)	   
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371
	    (cond
	     ((eq? (object-property f 'prolog-functor-type) #:scm)
	      (cons* 
	       (get-fkn f)
	       (GL S)
	       (map* (lambda (x) 
		       (compile-s match-map-i x))
		     a)))
	     
	     ((eq? (object-property f 'prolog-functor-type) #:goal)
	      (cons*
	       (list '@ '(logic guile-log iso-prolog) (procedure-name f))
	       (map* (lambda (x) 
		       (compile-s match-map-i x))
		     a)))
	       
	     (else
	      (cons* 
	       (get-fkn f)
	       (map* (lambda (x) 
		       (compile-s match-map-i x))
		     a)))))
372 373
	   (else
	    (error "copmile-s fkn not a procedure")))))
374 375


376 377 378 379 380 381 382 383 384 385 386
       (a
	(let ((a (gp-lookup a s)))
	  (cond
	   ((gp-var? a s)
	    (list (GL <lookup>) (get-var a)))
	   ((procedure? a)
	    (get-fkn a))
	   ((symbol? a)
	    (list (G quote) a))
	   (else
	    a))))))
387
        
388 389 390

  (define (get-goal-types f)
    (object-property f 'goal-compile-types))
391
              
392 393 394 395
  (define (get-goal-stub f)
    (object-property f 'goal-compile-stub))

  (define (comp-map* l ll)
396
    (umatch (#:mode - #:status s #:name comp-map*) (l)       
397 398 399 400 401
      ((x . l)
       (match ll
         (('g . ll)
          (cons (compile-goal x) (comp-map* l ll)))
         (('v . ll)
402
          (cons (compile-a match-map-i x) (comp-map* l ll)))
403
         (('a . ll)
404 405
          (cons (list (G quasiquote) (compile-a match-map-i x))
		(comp-map* l ll)))
406
         (('s . ll)
407
          (cons (compile-s match-map-i x)
408
		(comp-map* l ll)))
409
         (('ff . ll)
410
	  ;; This is not used
411
          (cons (compile-match match-map-i x) (comp-map* l ll)))))
412 413
      (() '())))

414
  (define (compile-goal x)
415 416
    (pp 'compgoal x)
    (umatch (#:mode - #:status s #:name compile-goal) (x)
417 418 419
      (#(#:brace a)
       (error "{ ... } is not supported in goal"))

420 421 422 423 424
      (#((";" #(("->" x y)) z))
       (list (GL <if>) 
	     (compile-goal x) 
	     (compile-goal y) 
	     (compile-goal z)))
425
      (#((f . a))
426 427 428 429
       (let ((f (gp-lookup f s)))
         (cond
          ((and (struct? f) (prolog-closure? f))
           (cons (cons (get-fkn (prolog-closure-parent f))
430
                       (map* (lambda (x)
431 432
			       (list (G quasiquote) 
				     (compile-a match-map-i x)))
433
			     (prolog-closure-state f)))
434 435 436
                 (map* (lambda (x) 
			 (list (G quasiquote)
			       (compile-a match-map-i x)))
437
		       a)))
438 439

          ((goal-fkn? f)
440
	   (apply (get-goal-stub f ) (comp-map* a (get-goal-types f))))
441
          
442 443 444 445 446 447 448 449
          ((procedure? f)	   
           (cons 
	    (get-fkn f) 
	    (map* (lambda (x) 
		    (list (G quasiquote)
			  (compile-a match-map-i x)))
		  a)))

450
          (else
451 452 453 454 455
	   (cons* (list (GL <lookup>) (get-var x))
		  (map* (lambda (x) 
			  (list (G quasiquote)
				(compile-a match-map-i x)))
			a))))))
456

457 458 459 460 461 462 463
      ((u . v)
       (list (G quasiquote) (compile-a match-map-i x)))

      (x
       (let ((x (gp-lookup x s)))
	 (cond
	  ((gp-var? x s)
464
	   (list (list (GL <lookup>) (get-var x))))
465 466 467 468 469 470 471 472 473 474 475 476
	  ((eq? x true)
	   (GL <cc>))
	  ((or (eq? x fail) (eq? x false))
	   (GL <fail>))
	  ((eq? x !)
	   (GL <cut>))
	  ((procedure? x)
	   (compile-goal (vector (list x))))
	  ((and (struct? f) (prolog-closure? f))
	   (compile-goal (vector (list x))))
	  (else 
	   (error (format #f "Atom ~a is not allowed as a goal" x))))))))
477
  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
478
  (define match-first (make-hash-table))
479 480 481 482
  (define compile-match 
    (case-lambda 
     ((x) (compile-match match-map-o x))
     ((match-map-o x)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
483
    (define-syntax-rule (do code)
484 485 486 487 488 489 490 491 492 493 494
      (let* ((x (gp-lookup x s))
	     (c (lambda () code))
	     (r1 (hashq-ref match-map-o x #f)))
	(if (and r1 (not (eq? r1 #t)))
	    (if (hashq-ref match-first x #f)
		r1
		(begin
		  (hashq-set! match-first x #t)
		  `(and ,r1 ,(c))))
	    (c))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
495
    (pp 'match x)		  
496
    (umatch (#:mode - #:status s #:name compile-match) (x)
497 498 499
     (#(#:brace a)
      (vector #:brace (compile-match a)))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
500
     (#((f . a))
501 502 503 504 505 506 507 508 509 510 511
      (let lp ((first? #t))
	(if first?
	    (if extention? 		
		(let ((r (let ((r (member f extention?)))
			   (if r 
			       (member (cadr r) (default-extensions))
			       r))))
		  (if r
		      (cons (cadr r) (map compile-match a))
		      (let ((r (member f (default-extensions))))
			(if r
512
			    (cons (cadr r) (map* compile-match a))
513 514
			    (lp #f)))))
		(lp #f))	    
515 516 517 518
	    (if (procedure? f)
		(do (vector `((,'unquote ,(get-fkn f)) 
			      ,@(map* compile-match a))))
		(do (vector (map* compile-match (cons f a))))))))
519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549

     ((a . l)
      (do (cons (compile-match a) (compile-match l))))

     (a
      (let ((a (gp-lookup a s)))
	(cond
	 ((gp-var? a s)
	  (get-var a))
	 ((gp-attvar-raw? a s)
	  (do
	      (if (fluid-ref is-compile-all)
		  (let* ((v (gp-att-raw-var a s))
			 (d (gp-att-data a s))
			 (v (compile-match v))
			 (d (compile-match d))
			 (x (gensym "x")))
		    
		    `(and (= (lambda (,x) (,(UM gp-att-raw-var) ,x ,(GL S))) 
			     ,v)
			  (= (lambda (,x) (,(UM gp-att-data)    ,x ,(GL S)))
			     ,d)))		 
		  (compile-match (gp-att-raw-var x s)))))
	 ((procedure? a)
	  `(,(string->symbol "unquote") ,(get-fkn a)))
	 ((symbol? a)
	  `(quote ,a))        
	 ((not (ident? a))
	  `(,(string->symbol "unquote") ,(get-fkn a)))
	 (else
	  a))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
550 551
  
  (define var-first (make-hash-table))
552
  (define (compile-var match-map-i x)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
553
    (define-syntax-rule (do x code)
554 555 556 557 558 559 560 561
      (let* ((x  (gp-lookup x s))
	     (c  (lambda () code))
	     (r1 (hashq-ref match-map-i x #f)))
	(if (and r1 (not (eq? r1 #t)))
	    (if (hashq-ref var-first x #f)
		r1
		(begin
		  (hashq-set! var-first x #t)
562 563 564
		  `(,(G let) ((,r1 (,(G make-variable) #f)))
		    (,(G variable-set!) ,r1 ,(c))
		    ,r1)))
565 566 567
	    (c))))

    (define (map-cons match-map-i l)
568
      (umatch (#:mode - #:status s #:name compile-match) ((pp 'compile-var2 l))
569
       ((a . l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
570
	(do l
571 572 573
          (list (G cons) (compile-var match-map-i a) (map-cons match-map-i l))))
       (a (compile-var match-map-i a))))

574
    (umatch (#:mode - #:status s #:name compile-match) ((pp 'compil-var1 x))
575 576 577
      (#(#:brace a)
       (list (G vector) #:brace (compile-var match-map-i a)))

578
      (#((f . a))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
579 580
       (do x 
        (let ((f (gp-lookup f s)))
581 582 583 584
         (cond
          ((and (struct? f) (prolog-closure? f))
           `(,(G vector) (,(G list)
                          ,(cons (get-fkn (prolog-closure-parent f))
585
                                 (map* (lambda (x)
586
					 (compile-a match-map-i x))
587
                                       (prolog-closure-state f)))
588 589 590
                          ,@(map* (lambda (x) 
				    (compile-var match-map-i x))
				  a))))
591
          (else
592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
	   (let* ((l (map* (lambda (x)
			     (compile-var match-map-i x))
			   a))		  
		  (l (let lp ((l l) (r '()))
		       (if (pair? l)
			   (lp (cdr l) (cons (car l) r))
			   (if (null? l)
			       (reverse (cons (list (G quote) '()) r))
			       (reverse (cons l   r)))))))
			       
	     (list (G vector) (cons* (G cons*) 
				     (if (procedure? f)
					 (get-fkn f)
					 (get-var f))
				     l))))))))
       ((a . l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
608
       (do x
609 610
	   (list (G cons) (compile-var match-map-i a) 
		 (map-cons match-map-i l))))
611
      
612
      (a
613
       (let ((a (pp 'u (gp-lookup a s))))
614 615 616
         (cond
          ((gp-var? a s)
           (get-var a))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
617 618 619 620 621
	  ((gp-attvar-raw? a s)
           (do a
	     (if (fluid-ref is-compile-all)
		 (let* ((v (gp-att-raw-var a s))
			(d (gp-att-data a s))
622 623
			(v (compile-var match-map-i v))
			(d (compile-var match-map-i d)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
624
		   `(,(UM mak-attvar) ,v ,d))
625
		 (compile-var match-map-i (gp-att-raw-var a s)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
626

627
          ((procedure? a)
628
           (get-fkn a))
629 630
          ((symbol? a)
           (list 'quote a))
631
          ((and (struct? a) (prolog-closure? a))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
632 633
	   (do x
             (cons (get-fkn (prolog-closure-parent a))
634
		   (map* (lambda (x)
635
			   (list (G quaeiquote) (compile-a match-map-i x)))
636
			 (prolog-closure-state a)))))
637 638 639 640 641 642
          ((not (ident? a))
           (get-fkn a))
          ((null? a)
           ''())
          (else
           a))))))
643
                 
644
  (set! match-map   (make-hash-table))
645
  (scan-var add-exvar a)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
646 647 648 649

  (set! match-map-o match-map)
  (set! match-map   (make-hash-table))

650
  (scan-goal f)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
651 652

  (set! match-map-i match-map)
653
  (pp `(compile ,a ,f))
654 655 656 657 658 659 660 661 662 663
  (let* ((aa    (pp 'aa (compile-match a)))
	 (ff    (compile-goal f))
	 (aaa   (pp 'aaa (compile-var match-map-o a)))
	 (fff   (compile-var match-map-i f))
	 (vfkn  (hash-fold (lambda (k v r) (cons v r)) '() fkns))
	 (ffkn  (pp 'ffkn (hash-fold (lambda (k v r) (cons k r)) '() fkns)))
	 (vars  (hash-fold (lambda (k v r) (cons v r)) '() in-house))
	 (varq  (map (lambda v (gensym "VARIN-")) vars))
	 (ovars (hash-fold (lambda (k v r) (cons v r)) '() ex-house))
	 (ovarq (map (lambda v (gensym "MATCHVARIN-")) ovars)))
664 665 666
    (define src #f)
    (define lam
      (with-fluids ((*current-language* (lookup-language 'scheme))) 
667 668 669 670 671 672 673 674 675 676 677
	(set! src
	  (lambda (lam u)
	    (cond
	     (meta-only?
	      (pp 'comp
		  `(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
			  (,(G let) ,(map (lambda (w v) (list w v))
					  (append vars ovars)
					  (append varq ovarq))
			   ((@@ (logic guile-log functional-database) 
				<lambda-dyn-meta>) ,aa 
678 679 680
				,(if include-meta
				     (list (G cons) `,aaa `,fff)
				     (list (G cons) `(list) `(list))))))))
681 682 683 684 685 686 687
	       
	      (fast-compile?
	       (pp 'comp 
		   `(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
			   (,(G let) ,(map (lambda (w v) (list w v))
					   (append vars ovars)
					   (append varq ovarq))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
688 689
			    ((@ (logic guile-log) <lambda> ) (cut scut ,@aa)
			     ((@ (logic guile-log) <with-cut>) cut scut 
690 691 692 693
			      (,(GL <var>) ,vars ,ff)))))))

	       ((and (pair? extention?))
		(pp 'comp
694 695 696 697
		     `(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
			     (,(G let) ,(map (lambda (w v) (list w v))
					     (append vars ovars)
					     (append varq ovarq))
698 699 700 701 702 703 704 705 706 707
			      ((@@ (logic guile-log functional-database) 
				   <lambda-dyn-extended>) ,aa 
				   (,(GL <var>) ,vars ,ff)
				   ,(list (G cons) `,aaa `,fff))))))
	       (else
		(pp 'comp 
		    `(,@lam (,@u ,@vfkn ,@varq ,@ovarq)
			    (,(G let) ,(map (lambda (w v) (list w v))
					    (append vars ovars)
					    (append varq ovarq))
708 709 710
			      ((@@ (logic guile-log functional-database) 
				   <lambda-dyn>) ,aa 
				   (,(GL <var>) ,vars ,ff)
711
				   ,(list (G cons) `,aaa `,fff)))))))))
712 713 714 715 716 717
	(if (not source?)
	    (if meta-only?
		(eval (src (list (G lambda)) '())
		      (current-module))
		(compile (src (list (G lambda)) '())
			 #:env (current-module))))))
718

719 720 721
    (define (lamlam lam)
      (lambda (f)
	(lam f)))
722
    (if source?
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
723
	(simplify
724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
	#`(let ()
	    (define-syntax f
	      (syntax-rules ()
		#,(datum->syntax source? (src '() (list '_)))))
	    (f #,@(append (map (lamlam
				(lambda (f)
				  (datum->syntax
				   source?
				   (let ((mod (procedure-property f 'module)))
				     (if mod
					 (list '@@ mod
						   (procedure-name f))
					 (procedure-name f))))))
			       ffkn)
			  (map (lambda (x) #'((@ (logic guile-log umatch)
						 gp-make-var)))
740
			       (append vars ovars))))))      
741 742 743 744
	(apply lam
	       (append ffkn (map (lambda (x) (gp-make-var)) 
				 (append vars ovars)))))))

745
(set! (@@ (logic guile-log match) compile-prolog) compile-prolog)