Only use c support if available

parent 0dfde24f
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var! #:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm gp-print gp->scm gp-print
gp-c-system
gp-budy gp-m-unify! gp-budy gp-m-unify!
gp-lookup gp-lookup
gp-var? gp-cons! gp-set! gp-var? gp-cons! gp-set!
...@@ -31,57 +32,94 @@ ...@@ -31,57 +32,94 @@
(load-extension file "gp_init") (load-extension file "gp_init")
(error "libguile-unify.so is not present, did you forget to make it?"))) (error "libguile-unify.so is not present, did you forget to make it?")))
(define-syntax-rule (definek x val)
(let ((tag (the-c-closure-tag))) (module-define! (current-module) 'x val))
(set-car! tag 'c)
(set-cdr! tag 'tag)
(gp-set-closure-tag tag))
(define wrap #f) (define wrap #f)
(define-syntax-rule (define3 nm r) (define-syntax-rule (define3 nm r)
(define nm (let ((rr r)) (definek nm (let ((rr r))
(if wrap (if wrap
(lambda (x y z) (rr x y z)) (lambda (x y z) (rr x y z))
rr)))) rr))))
(define-syntax-rule (define2 nm r) (define-syntax-rule (define2 nm r)
(define nm (let ((rr r)) (definek nm (let ((rr r))
(if wrap (if wrap
(lambda (x y) (rr x y)) (lambda (x y) (rr x y))
rr)))) rr))))
(define-syntax-rule (define1 nm r) (define-syntax-rule (define1 nm r)
(define nm (let ((rr r)) (definek nm (let ((rr r))
(if wrap (if wrap
(lambda (x) (rr x)) (lambda (x) (rr x))
r)))) r))))
(define api (gp-make-log-api)) (define (gp-pair+ x s)
(define3 gp-unify! (cdr (assq 'gp-unify! api))) (let ((s (gp-pair!? x s)))
(define3 gp-unify-raw! (cdr (assq 'gp-unify-raw! api))) (if s
(define3 gp-m-unify (cdr (assq 'gp-m-unify api))) (values (gp-car x s)
(define -gp-member (cdr (assq 'gp-member api))) (gp-cdr x s)
(define -gp-right-of (cdr (assq 'gp-right api))) s)
(define -next-to (cdr (assq 'gp-next-to api))) (values #f #f #f))))
(define1 gp-jumpframe-start
(cdr (assq 'gp-jumpframe-start api))) (define (gp-pair- x s)
(define1 gp-jumpframe-end (let ((s (gp-pair? x s)))
(cdr (assq 'gp-jumpframe-end api))) (if s
(define1 gp-unwind (cdr (assq 'gp-unwind api))) (values (gp-car x s)
(define1 gp-newframe (cdr (assq 'gp-newframe api))) (gp-cdr x s)
(define1 gp-var! (cdr (assq 'gp-var! api))) s)
(values #f #f #f))))
(define2 gp-lookup (cdr (assq 'gp-lookup api)))
(define2 gp-pair!? (cdr (assq 'gp-pair!? api))) (define (gp-pair* x s)
(define2 gp-pair? (cdr (assq 'gp-pair? api))) (if (pair? x)
(define2 gp-null!? (cdr (assq 'gp-null!? api))) (values (car x s)
(define2 gp-null? (cdr (assq 'gp-null? api))) (cdr x s)
(define2 gp-car (cdr (assq 'gp-car api))) s)
(define2 gp-cdr (cdr (assq 'gp-cdr api))) (values #f #f #f)))
(define2 gp->scm (cdr (assq 'gp->scm api)))
(define2 gp-pair* (cdr (assq 'gp-pair* api))) (if (module-defined? (current-module) 'the-c-closure-tag)
(define2 gp-pair- (cdr (assq 'gp-pair- api))) (begin
(define2 gp-pair+ (cdr (assq 'gp-pair+ api))) (format #t "Using the C system for c closures")
(definek gp-c-system #t)
(let ((tag (the-c-closure-tag)))
(set-car! tag 'c)
(set-cdr! tag 'tag)
(gp-set-closure-tag tag))
(definek api (gp-make-log-api))
(define3 gp-unify! (cdr (assq 'gp-unify! api)))
(define3 gp-unify-raw! (cdr (assq 'gp-unify-raw! api)))
(define3 gp-m-unify (cdr (assq 'gp-m-unify api)))
(definek -gp-member (cdr (assq 'gp-member api)))
(definek -gp-right-of (cdr (assq 'gp-right api)))
(definek -next-to (cdr (assq 'gp-next-to api)))
(define1 gp-jumpframe-start
(cdr (assq 'gp-jumpframe-start api)))
(define1 gp-jumpframe-end
(cdr (assq 'gp-jumpframe-end api)))
(define1 gp-unwind (cdr (assq 'gp-unwind api)))
(define1 gp-newframe (cdr (assq 'gp-newframe api)))
(define1 gp-var! (cdr (assq 'gp-var! api)))
(define2 gp-lookup (cdr (assq 'gp-lookup api)))
(define2 gp-pair!? (cdr (assq 'gp-pair!? api)))
(define2 gp-pair? (cdr (assq 'gp-pair? api)))
(define2 gp-null!? (cdr (assq 'gp-null!? api)))
(define2 gp-null? (cdr (assq 'gp-null? api)))
(define2 gp-car (cdr (assq 'gp-car api)))
(define2 gp-cdr (cdr (assq 'gp-cdr api)))
(define2 gp->scm (cdr (assq 'gp->scm api)))
(define2 gp-pair* (cdr (assq 'gp-pair* api)))
(define2 gp-pair- (cdr (assq 'gp-pair- api)))
(define2 gp-pair+ (cdr (assq 'gp-pair+ api))))
(begin
(definek gp-c-system #f)
(definek -gp-member #f)
(definek -gp-right-of #f)
(definek -next-to #f)))
#| #|
(define p+ gp-pair+) (define p+ gp-pair+)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment