Only use c support if available

parent 0dfde24f
......@@ -3,6 +3,7 @@
#:use-module (srfi srfi-11)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm gp-print
gp-c-system
gp-budy gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set!
......@@ -31,57 +32,94 @@
(load-extension file "gp_init")
(error "libguile-unify.so is not present, did you forget to make it?")))
(let ((tag (the-c-closure-tag)))
(set-car! tag 'c)
(set-cdr! tag 'tag)
(gp-set-closure-tag tag))
(define-syntax-rule (definek x val)
(module-define! (current-module) 'x val))
(define wrap #f)
(define-syntax-rule (define3 nm r)
(define nm (let ((rr r))
(if wrap
(lambda (x y z) (rr x y z))
rr))))
(definek nm (let ((rr r))
(if wrap
(lambda (x y z) (rr x y z))
rr))))
(define-syntax-rule (define2 nm r)
(define nm (let ((rr r))
(definek nm (let ((rr r))
(if wrap
(lambda (x y) (rr x y))
rr))))
(define-syntax-rule (define1 nm r)
(define nm (let ((rr r))
(definek nm (let ((rr r))
(if wrap
(lambda (x) (rr x))
r))))
(define 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)))
(define -gp-member (cdr (assq 'gp-member api)))
(define -gp-right-of (cdr (assq 'gp-right api)))
(define -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)))
(define (gp-pair+ x s)
(let ((s (gp-pair!? x s)))
(if s
(values (gp-car x s)
(gp-cdr x s)
s)
(values #f #f #f))))
(define (gp-pair- x s)
(let ((s (gp-pair? x s)))
(if s
(values (gp-car x s)
(gp-cdr x s)
s)
(values #f #f #f))))
(define (gp-pair* x s)
(if (pair? x)
(values (car x s)
(cdr x s)
s)
(values #f #f #f)))
(if (module-defined? (current-module) 'the-c-closure-tag)
(begin
(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+)
......
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