WIP

test-foreign.scm

@@ -22,6 +22,17 @@
     (lambda (expr rename compare)
 
 ;; Temporary definition, this does not stay here!
+;; TODO: extract these out, probably into cgen!
+
+;; Unbox scheme object
+;;
+;; scm->c :: string -> symbol -> string
+;;
+;; Inputs:
+;;  - code - C variable used to reference the Scheme object
+;;  - type - Data type of the Scheme object
+;; Returns:
+;;  - C code used to unbox the data
 (define (scm->c code type)
   (case type
     ((int integer)
@@ -33,6 +44,42 @@
     (else
       (error "scm->c unable to convert scheme object of type " type))))
 
+;; Box C object, basically the meat of (foreign-value)
+;;
+;; c->scm :: string -> symbol -> string
+;;
+;; Inputs:
+;;  - C expression
+;;  - Data type used to box the data
+;; Returns:
+;;  - Allocation code?
+;;  - C code
+(define (c->scm code type)
+  (case type
+    ((int integer)
+     (cons
+       ""
+       (string-append "obj_int2obj(" code ")")))
+    ((float double)
+     (let ((var (mangle (gensym 'var))))
+     (cons
+       (string-append 
+         "make_double(" var ", " code ");")
+       (string-append "&" var)
+     )))
+    ((bool)
+     (cons
+       ""
+       (string-append "(" code " == 0 ? boolean_f : boolean_t)")))
+;    ((string)
+;    TODO: how to handle the allocation here?
+;          may need to return a c-code pair???
+;     (string-append "
+;     ))
+    (else
+      (error "c->scm unable to convert C object of type " type))))
+
+
       (let* ((scm-fnc (cadr expr))
              (c-fnc (cadddr expr))
              (rv-type (caddr expr))
@@ -47,17 +94,13 @@
                        ;(string-append "string_str(" var ")")
                        )))
                  arg-types))
-             ;(arg-strings 
+             (returns
-             ;  (map
+               (c->scm 
-             ;    (lambda (sym)
+                 (string-append 
-             ;      (string-append " object " sym) 
+                   c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
-             ;    )
+                 rv-type))
-             ;    arg-syms))
+             (return-alloc (car returns))
-
+             (return-expr (cdr returns))
-           ; TODO: append mangled args to other args
-           ;  cyclone> (string-join '("a" "b" "c") ",")
-           ;  "a,b,c"
-
              (args (string-append
                      "(void *data, int argc, closure _, object k " 
                      (apply string-append 
@@ -69,7 +112,8 @@
              (body
              ;; TODO: need to unbox all args, pass to C function, then box up the result
                (string-append
-                 "return_closcall1(data, k, obj_int2obj(" c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")));"))
+                 return-alloc
+                 "return_closcall1(data, k, " return-expr ");"))
             )
       `(define-c ,scm-fnc ,args ,body)
         ))
@@ -79,33 +123,6 @@
 )
 )
 
-;; Unbox scheme object
-(define (scm->c code type)
-  (case type
-    ((int integer)
-     (string-append "obj_obj2int(" code ")"))
-    ((bool)
-     (string-append "(" code " == boolean_f)"))
-    ((string)
-     (string-append "string_str(" code ")"))
-    (else
-      (error "scm->c unable to convert scheme object of type " type))))
-
-;; Box C object, basically the meat of (foreign-value)
-(define (c->scm code type)
-  (case type
-    ((int integer)
-     (string-append "obj_int2obj(" code ")"))
-    ((bool)
-     (string-append "(" code " == 0 ? boolean_f : boolean_t)"))
-;    ((string)
-;    TODO: how to handle the allocation here?
-;          may need to return a c-code pair???
-;     (string-append "
-;     ))
-    (else
-      (error "c->scm unable to convert C object of type " type))))
-
 
 ;(define-c foreign-value
 ; "(void *data, int argc, closure _, object k, object code, object type)"
@@ -125,8 +142,10 @@
 
 ;; Must be top-level
 (define-foreign-lambda scm-strlen int "strlen" string)
+(define-foreign-lambda scm-strlend double "strlen" string)
 
 (test-group "foreign lambda"
   (test 15 (scm-strlen "testing 1, 2, 3"))
+  (test 15.0 (scm-strlend "testing 1, 2, 3"))
 )
 (test-exit)