[Universal backend] Add ffi tests.

gsc/tests/40-univ/bijectiveproc.scm

@@ -0,0 +1,70 @@
+(declare (extended-bindings) (not safe))
+
+(##define-macro (case-target . clauses)
+  (let ((target (if (and (pair? ##compilation-options)
+                          (pair? (car ##compilation-options)))
+                    (let ((t (assq 'target ##compilation-options)))
+                      (if t (cadr t) 'c))
+                    'c)))
+    (let loop ((clauses clauses))
+      (if (pair? clauses)
+          (let* ((clause (car clauses))
+                  (cases (car clause)))
+            (if (or (eq? cases 'else)
+                    (memq target cases))
+                `(begin ,@(cdr clause))
+                (loop (cdr clauses))))
+          `(begin)))))
+
+(##define-macro (define-target name . clauses)
+  `(define ,name (case-target ,@clauses)))
+
+(define-target (bijective-fn x)
+ ((js)
+  (let ((tmp (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.scm_procedure2host : gambit_scm_procedure2host)(@1@)" x)))
+    (let ((res (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host_function2scm : gambit_host_function2scm)(@1@)" tmp)))
+      res)))
+ ((php ruby python)
+  (let ((tmp (##inline-host-expression "gambit_scm_procedure2host(@1@)" x)))
+    (let ((res (##inline-host-expression "gambit_host_function2scm(@1@)" tmp)))
+      res)))
+; ((module)
+;  (let ((tmp (##inline-host-expression "Gambit_RTS.scm_procedure2host(@1@)" x)))
+;    (let ((res (##inline-host-expression "Gambit_RTS.host_function2scm(@1@)" tmp)))
+;      res)))
+ (else (bijective x)))
+
+(define-target (bijective x)
+ ((js)
+  (let ((tmp (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.scm2host : gambit_scm2host)(@1@)" x)))
+    (let ((res (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host2scm : gambit_host2scm)(@1@)" tmp)))
+      res)))
+ ((php ruby python)
+  (let ((tmp (##inline-host-expression "gambit_scm2host(@1@)" x)))
+    (let ((res (##inline-host-expression "gambit_host2scm(@1@)" tmp)))
+      res)))
+;   ((module)
+;    (let ((tmp (##inline-host-expression "Gambit_RTS.host2scm(@1@)" x)))
+;     (let ((res (##inline-host-expression "Gambit_RTS.host2scm(@1@)" tmp)))
+;       res)))
+
+ (else x))
+
+;;----------------------------------------------------------------------------
+
+(define (id x) x)
+
+(define (rest a b . c) (##car c))
+
+(println ((bijective-fn id) "id"))
+(println ((bijective-fn rest) "a" "b" "c" "d" "e"))
+
+(case-target
+ ((php)
+  (begin
+   (println ((bijective-fn id) "id"))
+   (println ((bijective-fn rest) "a" "b" "c" "d" "e"))))
+ (else
+  (begin
+   (println ((bijective id) "id")))
+   (println ((bijective rest) "a" "b" "c" "d" "e"))))

gsc/tests/40-univ/bijectivetype.scm

@@ -0,0 +1,86 @@
+(declare (extended-bindings) (not safe))
+
+(##define-macro (case-target . clauses)
+  (let ((target (if (and (pair? ##compilation-options)
+                          (pair? (car ##compilation-options)))
+                    (let ((t (assq 'target ##compilation-options)))
+                      (if t (cadr t) 'c))
+                    'c)))
+    (let loop ((clauses clauses))
+      (if (pair? clauses)
+          (let* ((clause (car clauses))
+                  (cases (car clause)))
+            (if (or (eq? cases 'else)
+                    (memq target cases))
+                `(begin ,@(cdr clause))
+                (loop (cdr clauses))))
+          `(begin)))))
+
+(##define-macro (define-target name . clauses)
+  `(define ,name (case-target ,@clauses)))
+
+(define-target (bijective-fn x)
+ ((js)
+  (let ((tmp (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.scm_procedure2host : gambit_scm_procedure2host)(@1@)" x)))
+    (let ((res (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host_function2scm : gambit_host_function2scm)(@1@)" tmp)))
+      res)))
+ ((php ruby python)
+  (let ((tmp (##inline-host-expression "gambit_scm_procedure2host(@1@)" x)))
+    (let ((res (##inline-host-expression "gambit_host_function2scm(@1@)" tmp)))
+      res)))
+; ((module)
+;  (let ((tmp (##inline-host-expression "Gambit_RTS.scm_procedure2host(@1@)" x)))
+;    (let ((res (##inline-host-expression "Gambit_RTS.host_function2scm(@1@)" tmp)))
+;      res)))
+
+ (else (bijective x)))
+
+(define-target (bijective x)
+ ((js)
+  (let ((tmp (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.scm2host : gambit_scm2host)(@1@)" x)))
+    (let ((res (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host2scm : gambit_host2scm)(@1@)" tmp)))
+      res)))
+ ((php ruby python)
+  (let ((tmp (##inline-host-expression "gambit_scm2host(@1@)" x)))
+    (let ((res (##inline-host-expression "gambit_host2scm(@1@)" tmp)))
+      res)))
+; ((module)
+;  (let ((tmp (##inline-host-expression "Gambit_RTS.scm2host(@1@)" x)))
+;    (let ((res (##inline-host-expression "Gambit_RTS.host2scm(@1@)" tmp)))
+;       res)))
+
+ (else x))
+
+;;----------------------------------------------------------------------------
+
+;;
+(##define-macro (test type? x)
+  `(println (if (,type? ,x) "type check: OK" "type check: ERR")))
+
+(define (id x) x)
+
+;; null
+(test ##null? (bijective '()))
+
+;; void
+;(test ##void? (bijective #!void))
+
+;; boolean
+(test ##boolean? (bijective #t))
+(test ##boolean? (bijective #f))
+
+;; integer
+(test ##fixnum? (bijective 0))
+(test ##fixnum? (bijective 1))
+(test ##fixnum? (bijective -1))
+
+;; float
+(test ##flonum? (bijective 1.5))
+(test ##flonum? (bijective -1.5))
+
+;; string
+(test ##string? (bijective ""))
+(test ##string? (bijective "string"))
+
+;; procedure
+(test ##procedure? (bijective-fn id))

gsc/tests/40-univ/bijectiveval.scm

@@ -0,0 +1,63 @@
+(declare (extended-bindings) (not safe))
+
+(##define-macro (case-target . clauses)
+  (let ((target (if (and (pair? ##compilation-options)
+                          (pair? (car ##compilation-options)))
+                    (let ((t (assq 'target ##compilation-options)))
+                      (if t (cadr t) 'c))
+                    'c)))
+    (let loop ((clauses clauses))
+      (if (pair? clauses)
+          (let* ((clause (car clauses))
+                  (cases (car clause)))
+            (if (or (eq? cases 'else)
+                    (memq target cases))
+                `(begin ,@(cdr clause))
+                (loop (cdr clauses))))
+          `(begin)))))
+
+(##define-macro (define-target name . clauses)
+  `(define ,name (case-target ,@clauses)))
+
+(define-target (bijective x)
+ ((js)
+  (let ((tmp (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.scm2host : gambit_scm2host)(@1@)" x)))
+    (let ((res (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host2scm : gambit_host2scm)(@1@)" tmp)))
+      res)))
+ ((php ruby python)
+  (let ((tmp (##inline-host-expression "gambit_scm2host(@1@)" x)))
+    (let ((res (##inline-host-expression "gambit_host2scm(@1@)" tmp)))
+      res)))
+; ((module)
+;  (let ((tmp (##inline-host-expression "Gambit_RTS.scm2host(@1@)" x)))
+;    (let ((res (##inline-host-expression "Gambit_RTS.host2scm(@1@)" tmp)))
+;      res)))
+
+ (else x))
+
+;;----------------------------------------------------------------------------
+
+;; null
+(println (if (##null? (bijective '())) "'()" ""))
+
+;; void
+(println (bijective #!void))
+
+;; boolean
+(println (bijective #t))
+(println (bijective #f))
+
+;; integer
+(println (bijective 0))
+(println (bijective -1))
+
+;; float
+(println (bijective 1.5))
+(println (bijective -1.5))
+
+;; string
+(println (bijective ""))
+(println (bijective "string"))
+
+;; array
+;(println (bijective '(1 2 3 4)))

gsc/tests/40-univ/eval.scm

@@ -0,0 +1,76 @@
+(declare (extended-bindings) (not safe))
+
+(##define-macro (case-target . clauses)
+  (let ((target (if (and (pair? ##compilation-options)
+                          (pair? (car ##compilation-options)))
+                    (let ((t (assq 'target ##compilation-options)))
+                      (if t (cadr t) 'c))
+                    'c)))
+    (let loop ((clauses clauses))
+      (if (pair? clauses)
+          (let* ((clause (car clauses))
+                  (cases (car clause)))
+            (if (or (eq? cases 'else)
+                    (memq target cases))
+                `(begin ,@(cdr clause))
+                (loop (cdr clauses))))
+          `(begin)))))
+
+(##define-macro (define-target name . clauses)
+  `(define ,name (case-target ,@clauses)))
+
+(define-target num
+  ((js php python ruby) "1")
+  (else 1))
+
+(define-target str
+  ((js php python ruby) "\"a string\"")
+  (else "a string"))
+
+(define-target vd 
+  ((js) "undefined")
+  ((php) "NULL")
+  ((python) "None")
+  ((ruby) "nil")
+  (else #!void))
+
+(define-target flo
+  ((js php python ruby) "2.5")
+  (else 2.5))
+
+#;
+(define-target fn
+  ((js) "function(x) {return x}")
+  ((python) "lambda x : x")
+  ((ruby) "Proc.new {|x| x}")
+  (else (lambda (x) x)))
+
+(case-target
+ ((php)
+  (##inline-host-declaration
+"function ev($x) {
+  eval(\"\\$x=$x;\");
+  return $x;
+}"))
+ (else ""))
+
+(define-target host
+ ((js)
+  (##inline-host-expression "((typeof Gambit_RTS !== 'undefined') ? Gambit_RTS.host_function2scm : gambit_host_function2scm)(eval)"))
+ ((python)
+  (##inline-host-expression "gambit_host_function2scm(eval)")
+  #;(##inline-host-expression "Gambit_RTS.host_function2scm(eval)"))
+ ((ruby)
+  (##inline-host-expression "gambit_host_function2scm(Proc.new {|x| eval(x)})")
+  #;(##inline-host-expression "Gambit_RTS.host_function2scm(Proc.new {|x| eval(x)})"))
+ ((php)
+  (##inline-host-expression "gambit_host_function2scm(\"ev\")")
+  #;(##inline-host-expression "Gambit_RTS.host_function2scm(\"ev\")"))
+
+ (else (lambda (x) x)))
+
+(println (host num))
+(println (host flo))
+(println (host str))
+(println (host vd))
+

include/stamp.h

@@ -3,4 +3,4 @@
  */
 
 #define ___STAMP_YMD 20150728
-#define ___STAMP_HMS 124457
+#define ___STAMP_HMS 132818