;;; MDH interface for CHICKEN


(module mdh (^ ^next ^previous ^data ^count ^kill global? global-reference?
             global global-name global-free global-kill global-object
             global-count global-merge flush-globals global-reference-name
             global-ref global-set! global-next global-previous global-data
             close-globals global-name)
(import scheme)
(import (chicken base))
(import (chicken string))
(import (chicken foreign))
(import (chicken format))
(import (chicken platform))
(import (chicken memory representation))
(import-for-syntax (chicken string))

(foreign-declare #<<EOF
#include "libmpscpp.h"
static char buf[ STR_MAX + 1 ];
EOF
)

(define-syntax make-ref*
  (er-macro-transformer 
    (lambda (x r c)
      (let ((shape (cadr x))
            (args (cddr x))
            (%flambda (r 'foreign-lambda*)))
        `(,%flambda void (((c-pointer "global") p)
                         ,@(map (lambda (a) `(c-string ,a)) args))
          ,(string-append 
             "p->MakeGlobal(0, p->myname, \"" shape "\", "
             (string-intersperse (map ->string args) ", ")
             ");"))))))

(define closed #f)

(define (str x)
  (cond ((string? x) x)
        ((symbol? x) (symbol->string x))
        ((number? x) (number->string x))
        (else (error "expected string, symbol or numeric value" x))))

(define (make-ref g)
  (let* ((gr (->gref g))
         (p (check-ptr (global-reference-global gr)))
         (args (global-reference-indices gr)))
    (%make-ref p args)
    p))

(define (->gref g)
  (cond ((global-reference? g) g)
        (else (make-global-reference (global-object g) '()))))

(define (%make-ref p args)
  (let ((len (length args)))
    (case len
      ((0) ((foreign-lambda* void (((c-pointer "global") p))
              "p->MakeGlobal(0, p->myname, \"\", \"\");") p))
      ((1) ((lambda (a) ((make-ref* "a" a) p a)) (car args)))
      ((2) ((lambda (a b) ((make-ref* "a,b" a b) p a b)) 
            (car args) (cadr args)))
      ((3) ((lambda (a b c) ((make-ref* "a,b,c" a b c) p a b c)) 
            (car args) (cadr args) (caddr args)))
      ((4) ((lambda (a b c d) ((make-ref* "a,b,c,d" a b c d) p a b c d)) 
            (car args) (cadr args) (caddr args) (cadddr args)))
      ((5) ((lambda (a b c d e) ((make-ref* "a,b,c,d,e" a b c d e) 
              p a b c d e)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4)))
      ((6) ((lambda (a b c d e f) 
              ((make-ref* "a,b,c,d,e,f" a b c d e f) p a b c d e f)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4) (list-ref args 5)))
      ((7) ((lambda (a b c d e f g) 
              ((make-ref* "a,b,c,d,e,f,g" a b c d e f g) p a b c d e f g)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4) (list-ref args 5) (list-ref args 6)))
      ((8) ((lambda (a b c d e f g h) 
              ((make-ref* "a,b,c,d,e,f,g,h" a b c d e f g h) 
                p a b c d e f g h)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4) (list-ref args 5) (list-ref args 6)
            (list-ref args 7)))
      ((9) ((lambda (a b c d e f g h i) 
              ((make-ref* "a,b,c,d,e,f,g,h,i" a b c d e f g h i) 
                 p a b c d e f g h i)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4) (list-ref args 5) (list-ref args 6)
            (list-ref args 7) (list-ref args 8)))
      ((10) ((lambda (a b c d e f g h i j) 
              ((make-ref* "a,b,c,d,e,f,g,h,i,j" a b c d e f g h i j) 
                 p a b c d e f g h i j)) 
            (car args) (cadr args) (caddr args) (cadddr args) 
            (list-ref args 4) (list-ref args 5) (list-ref args 6)
            (list-ref args 7) (list-ref args 8) (list-ref args 9)))
      (else (error "too many indices" args)))))

(define (close-globals)
  (unless closed
    (set! closed #t)
    ((foreign-lambda* void () "GlobalClose;"))))

(define-record global name ptr)
(define-record global-reference global indices)

(define (global-reference-name gr)
  (global-name (global-reference-global gr)))

(define-record-printer (global g out)
  (fprintf out "<global ~s>" (global-name g)))

(define-record-printer (global-reference g out)
  (fprintf out "<global-reference ~s ~s>" 
    (global-reference-name g)
    (global-reference-indices g)))

(define STR_MAX (foreign-value "STR_MAX" int))

(define (->val x)
  (let ((y (str x)))
    (if (>= (string-length y) STR_MAX)
        (error "value or index exceeds maximum allowed length" x)
        y)))

(define (global-object x)
  (cond ((global? x) x)
        ((global-reference? x) (global-reference-global x))
        ((and (procedure? x) (procedure-data x))
          => (lambda (g) 
               (if (global? g)
                   g
                   (error 'global-object "not a global" x))))
        (else #f)))

(define (split-rest rest)
  (let* ((val "")
         (ix (let rec ((rest rest))
               (cond ((null? (cdr rest))
                        (set! val (car rest))
                        '())
                     (else (cons (car rest) (rec (cdr rest))))))))
    (cons ix val)))

(define (wrap g)
  (extend-procedure
    (lambda ix
      (make-global-reference g (map ->val ix)))
    g))

(define (global name)
  (wrap (make-global name (%make-global (->val name)))))

(define %make-global 
  (foreign-lambda* (pointer "global") ((c-string name))
    "return(new global(name));"))

(define (check-ptr g)
  (when closed (error "access to global after database has been closed" g))
  (or (global-ptr g)
      (error "global has already been released" g)))

(define (global-free g) 
  (let ((g (global-object g)))
    (and-let* ((ptr (global-ptr g)))
      (%free ptr)
      (global-ptr-set! g #f))))

(define %free 
  (foreign-lambda* void (((c-pointer "global") g))
    "delete g;"))

(define (global-count g)
  (%count (make-ref g)))

(define %count
  (foreign-lambda* int (((c-pointer "global") g))
    "return(g->Count());"))

(define (global-kill g) 
  (%kill (make-ref g)))

(define %kill
  (foreign-lambda* void (((c-pointer "global") g))
    "g->Kill();"))

(define (global-ref g)
  (%get (make-ref g)))

(define %get 
  (foreign-lambda* c-string (((c-pointer "global") g))
    "get_global(g->ref, buf);
     return(buf);"))

(define (global-set! g val)
  (%set (make-ref g) (->val val)))

(define %set 
  (foreign-lambda* void (((c-pointer "global") g) (c-string val))
    "set_global(g->ref, val);"))

(define (global-next g)
  (%order (make-ref g) 1))

(define (global-previous g)
  (%order (make-ref g) -1))

(define %order
  (foreign-lambda* c-string (((c-pointer "global") g) (int dir))
    "return(g->C_Order(dir));"))

(define (global-merge g1 g2)
  (let ((p1 (make-ref g1))
        (p2 (make-ref g2)))
    (%merge p1 p2)))

(define %merge
  (foreign-lambda* void (((c-pointer "global") g1) ((c-pointer "global") g2))
    "g1->Merge(*g2);"))

(define (global-data g)
  (data-name (%data (make-ref g))))

(define (data-name d)
  (case d
    ((0) #f)
    ((1) 'leaf)
    ((10) 'empty)
    ((11) 'branch)))

(define %data
  (foreign-lambda* int (((c-pointer "global") g))
    "return(g->Data());"))

(define (with-ref g loc ix proc)
  (cond ((or (string? g) (symbol? g))
          (let ((p (%make-global (->val g))))
            (%make-ref p (map ->val ix))
            (let ((result (proc p)))
              (%free p)
              result)))
        ((global? g)
          (proc (make-ref (make-global-reference g (map ->val ix)))))
        (else (error loc "not a global or valid global name" g))))

(define ^ 
  (getter-with-setter
    (lambda (name . ix)
      (with-ref name '^ ix %get))
    (lambda (name . rest)
      (let ((c (split-rest rest)))
        (with-ref name '^ (car c)
          (lambda (p) (%set p (->val (cdr c)))))))))

(define (^next name . ix)
  (with-ref name '^next ix (cut %order <> 1)))

(define (^previous name . ix)
  (with-ref name '^previous ix (cut %order <> -1)))

(define (^data name . ix)
  (with-ref name '^data ix
    (lambda (p) (data-name (%data p)))))

(define (^count name . ix)
  (with-ref name '^count ix %count))

(define (^kill name . ix)
  (with-ref name '^kill ix %kill))

(define flush-globals
  (foreign-lambda* void () "global::Flush();"))

(implicit-exit-handler close-globals)

(exit-handler 
  (lambda (#!optional (code 0)) 
    (close-globals)))

(when (or (not (feature? #:csi))
          (feature? #:chicken-script))
  (set! ##sys#error-handler
    (let ((old ##sys#error-handler))
      (lambda args
        (close-globals)
        (apply old args)))))

)