Commits

Moritz Heidkamp committed 20871b8

initial commit

Comments (0)

Files changed (4)

+((synopsis "Chibi Scheme in a Chicken egg")
+ (author "Moritz Heidkamp")
+ (test-depends test)
+ (foreign-depends chibi-scheme)
+ (category ffi)
+ (license "BSD"))
+(module chibi
+
+(make-context make-default-context load-standard-env load-standard-ports
+ eval sexp->chicken)
+
+(import chicken (except scheme eval car cdr cons) foreign)
+(import (prefix (only scheme car cdr cons) chicken-))
+(use posix ports lolevel)
+
+(foreign-declare "#include <chibi/eval.h>")
+
+(define-foreign-type sexp
+  (c-pointer (struct "sexp_struct")))
+
+(define-foreign-type sexp_uint_t
+  unsigned-integer)
+
+(define-foreign-type file
+  (c-pointer (struct "FILE")))
+
+(define destroy-context
+  (foreign-lambda void sexp_destroy_context sexp))
+
+(define (make-context)
+  (set-finalizer!
+   (tag-pointer
+    ((foreign-lambda sexp sexp_make_eval_context sexp sexp sexp sexp_uint_t sexp_uint_t)
+     #f #f #f 0 0)
+    'chibi-context)
+   destroy-context))
+
+(define (make-default-context)
+  (let ((ctx (make-context)))
+    (load-standard-env ctx)
+    (load-standard-ports ctx)
+    ctx))
+
+(define (load-standard-env ctx)
+  ((foreign-lambda sexp sexp_load_standard_env sexp sexp sexp)
+   ctx #f (foreign-value "SEXP_SEVEN" sexp)))
+
+(define (port->file port)
+  ((foreign-lambda file fdopen int c-string)
+   (port->fileno (current-input-port))
+   (if (input-port? port) "r" "a")))
+
+(define (load-standard-ports ctx)
+  ((foreign-lambda sexp sexp_load_standard_ports sexp sexp file file file bool)
+   ctx
+   #f
+   (port->file (current-input-port))
+   (port->file (current-output-port))
+   (port->file (current-error-port))
+   #t))
+
+(define (sexp->string ctx sexp)
+  (let* ((exp ((foreign-lambda sexp sexp_write_to_string sexp sexp) ctx sexp))
+         (len ((foreign-lambda int sexp_string_length sexp) exp))
+         (str (make-string len)))
+    ((foreign-lambda sexp sexp_write sexp sexp sexp) ctx exp
+     ((foreign-lambda sexp sexp_eval_string sexp c-string int sexp)
+      ctx "(current-output-port)" 21 #f))
+
+    (do ((i 0 (+ i 1)))
+        ((= i len) str)
+      
+      (string-set! str i ((foreign-lambda char sexp_unbox_character sexp)
+                          ((foreign-lambda sexp sexp_string_ref sexp int) exp i))))))
+
+(define-syntax sexp-type
+  (syntax-rules ()
+    ((_ sexp (fpred name) (fpred* name*) ...)
+     (if ((foreign-lambda bool fpred sexp) sexp)
+         'name
+         (sexp-type sexp (fpred* name*) ...)))
+    ((_ sexp)
+     (error 'sexp-type "unknown sexp type" sexp))))
+
+(define (tag-sexp sexp)
+  (tag-pointer
+   sexp
+   (sexp-type sexp
+     (sexp_booleanp chibi-boolean)
+     (sexp_fixnump chibi-fixnum)
+     (sexp_flonump chibi-flonum)
+     (sexp_bignump chibi-bignum)
+     (sexp_integerp chibi-integer)
+     (sexp_numberp chibi-number)
+     (sexp_charp chibi-char)
+     (sexp_stringp chibi-string)
+     (sexp_symbolp chibi-symbol)
+     (sexp_idp chibi-id)
+     (sexp_nullp chibi-null)
+     (sexp_pairp chibi-pair)
+     (sexp_vectorp chibi-vector)
+     (sexp_iportp chibi-iport)
+     (sexp_oportp chibi-oport)
+     (sexp_portp chibi-port)
+     (sexp_procedurep chibi-procedure)
+     (sexp_opcodep chibi-opcode)
+     (sexp_applicablep chibi-applicable)
+     (sexp_typep chibi-type)
+     (sexp_exceptionp chibi-exception)
+     (sexp_contextp chibi-context)
+     (sexp_envp chibi-env)
+     (sexp_corep chibi-core)
+     (sexp_macrop chibi-macro)
+     (sexp_synclop chibi-synclo)
+     (sexp_bytecodep chibi-bytecode)
+     (sexp_cpointerp chibi-cpointer))))
+
+(define (preserve-object ctx obj)
+  ((foreign-lambda void sexp_preserve_object sexp sexp) ctx obj)
+  (set-finalizer!
+   obj
+   (lambda (obj)
+     ((foreign-lambda void sexp_release_object sexp sexp) ctx obj))))
+
+(define-syntax sexp-lambda
+  (ir-macro-transformer
+   (lambda (x i c)
+     (let* ((fn (cadr x))
+            (arg-types (cddr x)))
+       `(lambda args
+          (for-each (lambda (type val)
+                      (unless (or (eq? type ',(i 'sexp))
+                                  (tagged-pointer? val type))
+                        (error ',fn "bad argument type" type (pointer-tag val))))
+                    ',arg-types args)
+          (tag-sexp (apply (foreign-lambda sexp ,fn . ,(map (lambda _ 'sexp) arg-types)) args)))))))
+
+(define car (sexp-lambda sexp_car chibi-pair))
+(define cdr (sexp-lambda sexp_cdr chibi-pair))
+(define current-context (make-parameter #f))
+
+(define (sexp->chicken sexp #!optional (ctx (current-context)))
+  (parameterize ((current-context (or ctx (current-context))))
+    (case (pointer-tag sexp)
+      ((chibi-procedure) sexp)
+      ((chibi-null)
+       '())    
+      ((chibi-pair)
+       (chicken-cons (sexp->chicken (car sexp))
+                     (sexp->chicken (cdr sexp))))
+      ((chibi-fixnum)
+       ((foreign-lambda int sexp_unbox_fixnum sexp) sexp))
+      ((chibi-flonum)
+       ((foreign-lambda double sexp_flonum_value sexp) sexp))
+      ((chibi-symbol)
+       ;; this segfaults for some unknown reason
+       ;; (string->symbol ((foreign-lambda c-string sexp_symbol_data sexp) sexp))
+       (string->symbol
+        (sexp->chicken
+         (tag-sexp
+          ((foreign-lambda sexp sexp_symbol_to_string_op sexp sexp int sexp)
+           (current-context) #f 1 sexp)))))
+      ((chibi-string)
+       ((foreign-lambda c-string sexp_string_data sexp) sexp))
+      ((chibi-boolean)
+       ((foreign-lambda bool sexp_unbox_boolean sexp) sexp))
+      ((chibi-exception)
+       (signal
+        (make-composite-condition
+         (make-property-condition 'chibi)
+         (make-property-condition 
+          (sexp->chicken ((sexp-lambda sexp_exception_kind sexp) sexp))
+          'message (sexp->chicken ((sexp-lambda sexp_exception_message sexp) sexp))
+          'irritants (sexp->chicken ((sexp-lambda sexp_exception_irritants sexp) sexp))
+          'procedure (sexp->chicken ((sexp-lambda sexp_exception_procedure sexp) sexp))
+          'source    (sexp->chicken ((sexp-lambda sexp_exception_source sexp) sexp))))))
+      (else
+       (error 'sexp->chicken "unknown chibi type" (pointer-tag sexp))))))
+
+(define (chicken->sexp ctx e)
+  (cond ((flonum? e)
+         ((foreign-lambda sexp sexp_make_flonum sexp double) ctx e))
+        ((fixnum? e)
+         ((foreign-lambda sexp sexp_make_integer sexp int) ctx e))
+        ((null? e)
+         (foreign-value "SEXP_NULL" sexp))
+        ((pair? e)
+         ((foreign-lambda sexp sexp_cons sexp sexp sexp)
+          ctx
+          (chicken->sexp ctx (chicken-car e))
+          (chicken->sexp ctx (chicken-cdr e))))
+        ((symbol? e)
+         (let ((s (symbol->string e)))
+           ((foreign-lambda sexp sexp_intern sexp c-string int) ctx s (string-length s))))
+        ((string? e)
+         ((foreign-lambda sexp sexp_c_string sexp c-string int) ctx e (string-length e)))
+        (else
+         (error 'chicken->sexp "don't know how to convert value to chibi value" e))))
+
+(define (eval exp ctx)
+  (tag-sexp
+   ((foreign-lambda sexp sexp_eval sexp sexp sexp)
+    ctx
+    (if (tagged-pointer? exp)
+        exp
+        (preserve-object ctx (chicken->sexp ctx exp)))
+    #f)))
+
+)
+(compile -s -L -lchibi-scheme chibi.scm -J)
+(compile -s chibi.import.scm)
+
+(install-extension 
+ 'chibi
+ '("chibi.so" "chibi.import.so")
+ '((version "0.0.1")))
+(use chibi test extras ports)
+
+(define-syntax test-eval
+  (syntax-rules ()
+    ((_ result exp)
+     (test (with-output-to-string (cut write exp))
+           result
+           (condition-case
+               (let ((ctx (make-default-context)))
+                 (sexp->chicken (eval exp ctx) ctx))
+             (exn (chibi)
+                  (with-output-to-port (current-error-port)
+                    (lambda ()
+                      (newline)
+                      (display "Error:")
+                      (newline)
+                      (pp (condition->list exn))))))))))
+
+(test-eval 1.0 1.0)
+(test-eval 123 123)
+(test-eval "foo" "foo")
+(test-eval '() ''())
+(test-eval 'foo ''foo)
+(test-eval '(1 foo) '(list 1 'foo))
+(test-eval 1 '(begin (newline) (display 'you-should-see-this) (newline) 1))
+
+(test "evaling a chibi sexp"
+      '(foo bar 1 2 3)
+      (let ((ctx (make-default-context)))
+        (sexp->chicken (eval (eval ''(list 'foo 'bar 1 2 3) ctx) ctx) ctx)))
+
+
+(let ((o #f))
+  (let ((ctx (make-default-context)))
+    (set! o (eval "hey" ctx)))
+  (gc #t)
+  (test "hey" (sexp->chicken o)))