Merge branch 'foreign-dev'

Makefile

@@ -78,6 +78,7 @@ install : libs install-libs install-includes install-bin
 	$(INSTALL) -m0644 scheme/cyclone/*.scm $(DESTDIR)$(DATADIR)/scheme/cyclone
 	$(INSTALL) -m0644 libs/cyclone/test.meta $(DESTDIR)$(DATADIR)/cyclone
 	$(INSTALL) -m0644 libs/cyclone/match.meta $(DESTDIR)$(DATADIR)/cyclone
+	$(INSTALL) -m0644 libs/cyclone/foreign.meta $(DESTDIR)$(DATADIR)/cyclone
 	$(INSTALL) -m0644 scheme/cyclone/*.o $(DESTDIR)$(DATADIR)/scheme/cyclone
 	$(INSTALL) -m0755 scheme/cyclone/*.so $(DESTDIR)$(DATADIR)/scheme/cyclone
 	$(INSTALL) -m0644 libs/cyclone/*.sld $(DESTDIR)$(DATADIR)/cyclone
@@ -271,6 +272,7 @@ bootstrap : icyc libs
 	cp scheme/cyclone/macros.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp libs/cyclone/match.c $(BOOTSTRAP_DIR)/cyclone
 	cp libs/cyclone/match.meta $(BOOTSTRAP_DIR)/cyclone
+	cp libs/cyclone/foreign.meta $(BOOTSTRAP_DIR)/cyclone
 	cp scheme/cyclone/pretty-print.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/primitives.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/transforms.c $(BOOTSTRAP_DIR)/scheme/cyclone

docs/API.md

@@ -57,6 +57,7 @@ Cyclone supports the following [Scheme Requests for Implementation (SRFI)](http:
 These libraries are provided as Cyclone-specific extensions:
 
 - [`cyclone concurrent`](api/cyclone/concurrent.md) - A helper library for writing concurrent code.
+- [`cyclone foreign`](api/cyclone/foreign.md) - Provides a convenient interface for integrating with C code.
 - [`cyclone match`](api/cyclone/match.md) - A hygienic pattern matcher based on Alex Shinn's portable `match.scm`.
 - [`cyclone test`](api/cyclone/test.md) - A unit testing framework ported from `(chibi test)`.
 - [`scheme cyclone array-list`](api/scheme/cyclone/array-list.md)

docs/api/cyclone/foreign.md

@@ -0,0 +1,72 @@
+# Foreign Library
+
+The `(cyclone foreign)` provides a convenient interface for integrating with C code. It is based in concept on the `(chicken foreign)` module from CHICKEN Scheme. Similarly to that module, this library manipulates the C code directly before it is compiled to a native binary. It is not possible to call these forms at runtime.
+
+# Overview
+
+- [`c-code`](#c-code)
+- [`c-value`](#c-value)
+- [`c-define`](#c-define)
+- [`c-define-type`](#c-define-type)
+
+## c-code
+
+*Syntax*
+
+    (c-code CODE ...)
+
+Insert C code directly into the compiled program. Each `CODE` parameter must be a string containing C code.
+
+## c-value
+
+*Syntax*
+
+    (c-value CODE TYPE)
+
+Generate code that takes the C code specified by the string `CODE` and converts it to a Scheme object of type `TYPE`.
+
+## c-define
+
+*Syntax*
+
+    (c-define SCM-FUNC RETURN-TYPE C-FUNC TYPE ...)
+
+Define a Scheme function `SCM-FUNC` returning an object of type `RETURN-TYPE`. The function will call C function specified by the string `C-FUNC` passed parameters of type specified by any `TYPE` arguments.
+
+For example, to define a function that calls `strlen`:
+
+    (c-define scm-strlen int "strlen" string)
+
+Note that these definitions are introduced at the top-level.
+
+## c-define-type
+
+*Syntax*
+
+    (c-define-type NAME TYPE (ARG-CONVERT (RET-CONVERT)))
+
+Define a custom type with symbol `NAME` that is an alias of type `TYPE`. It is also possible to specify conversion functions `ARG-CONVERT` and `RET-CONVERT` to convert to/from this custom type.
+
+EG, to define a type that consists of integers in Scheme and strings in C: 
+
+    (c-define-type string-as-integer string number->string string->number)
+
+
+# Type Specifiers
+
+The following built-in specifiers may be used as a `TYPE` for forms in this module. 
+
+Scheme | C
+------ | -
+`int` | `int`
+`integer` | `int`
+`bool` | `int`
+`char` | `int`
+`string` | `char *`
+`symbol` | `const char *`
+`bytevector` | `char *`
+`float` | `double`
+`double` | `double`
+`bignum` | `mp_int`
+`opaque` | `void *`
+

libs/cyclone/foreign.sld

@@ -0,0 +1,282 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2019, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This module makes it easier to interface directly with C code using the FFI.
+;;;;
+(define-library (cyclone foreign)
+ (import
+   (scheme base)
+   (scheme eval)
+   (scheme cyclone util)
+   ;(scheme write) ;; TODO: debugging only!
+ )
+ (export
+   c-code
+   c-value
+   c-define
+   c->scm
+   scm->c
+   c-define-type
+ )
+ (begin
+   ;; 
+   ;;(eval `(define *foreign-types* (list)))
+
+  ;; (c-define-type name type (pack (unpack)))
+  (define-syntax c-define-type
+    (er-macro-transformer
+      (lambda (expr rename compare)
+        (let ((name (cadr expr))
+              (type (cddr expr)))
+          ;;
+          ;; Custom foreign types are all stored within the global environment 
+          ;; used by `eval` at compile time. We play a few tricks using exception
+          ;; handlers to check if variables are defined in that environment.
+          ;;
+          (unless (eval '(with-handler (lambda X #f) *foreign-types*))
+            ;(write "no foreign type table" (current-error-port))
+            ;(newline (current-error-port))
+            (eval `(define *foreign-types* (make-hash-table))))
+          (eval `(hash-table-set! *foreign-types* (quote ,name) (quote ,type)))
+          #f))))
+
+  (define-syntax c-value
+    (er-macro-transformer
+      (lambda (expr rename compare)
+        (let* ((code-arg (cadr expr))
+               (type-arg (caddr expr))
+               (c-type (eval `(with-handler 
+                                (lambda X #f)
+                                (hash-table-ref *foreign-types* (quote ,type-arg))
+                                )))
+               (c-ret-convert #f)
+              )
+          (when c-type
+            ;(write `(defined c type ,c-type) (current-error-port))
+            ;(newline (current-error-port))
+            (set! type-arg (car c-type))
+            (if (= 3 (length c-type))
+                (set! c-ret-convert (caddr c-type))))
+
+          ;(for-each
+          ;  (lambda (arg)
+          ;    (if (not (string? arg))
+          ;        (error "c-value" "Invalid argument: string expected, received " arg)))
+          ;  (cdr expr))
+
+          (if c-ret-convert
+            `((lambda () (,c-ret-convert (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))
+            `((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg))))
+          )
+          ))))
+
+  (define-syntax c-code
+    (er-macro-transformer
+      (lambda (expr rename compare)
+        (for-each
+          (lambda (arg)
+            (if (not (string? arg))
+                (error "c-code" "Invalid argument: string expected, received " arg)))
+          (cdr expr))
+        `(Cyc-foreign-code ,@(cdr expr)))))
+
+  ;; 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)
+  (define-syntax scm->c
+    (er-macro-transformer
+      (lambda (expr rename compare)
+        (let ((code (cadr expr))
+              (type (caddr expr)))
+         `(case ,type
+            ((int integer)
+             (string-append "obj_obj2int(" ,code ")"))
+            ((double float)
+             (string-append "double_value(" ,code ")"))
+            ((bignum bigint)
+             (string-append "bignum_value(" ,code ")"))
+            ((bool)
+             (string-append "(" ,code " == boolean_f)"))
+            ((char)
+             (string-append "obj_obj2char(" ,code ")"))
+            ((string)
+             (string-append "string_str(" ,code ")"))
+            ((symbol)
+             (string-append "symbol_desc(" ,code ")"))
+            ((bytevector)
+             (string-append "(((bytevector_type *)" ,code ")->data)"))
+            ((opaque)
+             (string-append "opaque_ptr(" ,code ")"))
+            (else
+              (error "scm->c unable to convert scheme object of type " ,type)))))))
+  
+  ;; Box C object, basically the meat of (c-value)
+  ;;
+  ;; c->scm :: string -> symbol -> string
+  ;;
+  ;; Inputs:
+  ;;  - C expression
+  ;;  - Data type used to box the data
+  ;; Returns:
+  ;;  - Allocation code?
+  ;;  - C code
+  (define-syntax c->scm
+   (er-macro-transformer
+    (lambda (expr rename compare)
+      (let ((code (cadr expr))
+            (type (caddr expr)))
+       `(case (if (string? ,type)
+                  (string->symbol ,type)
+                  ,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)")))
+          ((char)
+           (cons
+             ""
+             (string-append "obj_char2obj(" ,code ")")))
+          ((string)
+           (let ((var (mangle (gensym 'var))))
+           (cons
+             (string-append 
+               "make_utf8_string(data," var ", " ,code ");")
+             (string-append "&" var)
+           )))
+          ((bytevector)
+           (let ((var (mangle (gensym 'var))))
+           (cons
+             (string-append 
+               "make_empty_bytevector(data," var ");"
+               var "->data = " ,code ";")
+             (string-append "&" var)
+           )))
+          ((opaque)
+           (let ((var (mangle (gensym 'var))))
+           (cons
+             (string-append 
+               "make_c_opaque(data," var ", " ,code ");")
+             (string-append "&" var)
+           )))
+          (else
+            (error "c->scm unable to convert C object of type " ,type)))))))
+  
+  (define-syntax c-define
+    (er-macro-transformer
+      (lambda (expr rename compare)
+        (let* ((scm-fnc (cadr expr))
+               (scm-fnc-wrapper (gensym 'scm-fnc))
+               (c-fnc (cadddr expr))
+               (rv-type (caddr expr))
+               ;; boolean - Are we returning a custom (user-defined) type?
+               (rv-cust-type (eval `(with-handler 
+                                (lambda X #f)
+                                (hash-table-ref *foreign-types* (quote ,rv-type))
+                                )))
+               ;; boolean - Does the custom return type have a conversion function?
+               (rv-cust-convert
+                 (if (and rv-cust-type (= 3 (length rv-cust-type)))
+                     (caddr rv-cust-type)
+                     #f))
+               (arg-types (cddddr expr))
+               (arg-cust-convert #f)
+               (arg-syms/unbox 
+                 (map 
+                   (lambda (type)
+                     (let ((var (mangle (gensym 'arg)))
+                           (arg-cust-type (eval `(with-handler 
+                                (lambda X #f)
+                                (hash-table-ref *foreign-types* (quote ,type))
+                                )))
+                           )
+                       (cons 
+                         var 
+                         (scm->c 
+                           var 
+                           (cond
+                            (arg-cust-type
+                             (if (> (length arg-cust-type) 1)
+                                 (set! arg-cust-convert #t))
+                             (car arg-cust-type))
+                            (else
+                              type)))
+                         ;(string-append "string_str(" var ")")
+                         )))
+                   arg-types))
+               (returns
+                 (c->scm 
+                   (string-append 
+                     c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
+                   (if rv-cust-type
+                       (car rv-cust-type)
+                       rv-type)))
+               (return-alloc (car returns))
+               (return-expr (cdr returns))
+               (args (string-append
+                       "(void *data, int argc, closure _, object k " 
+                       (apply string-append 
+                         (map
+                           (lambda (sym/unbox)
+                             (string-append ", object " (car sym/unbox)))
+                         arg-syms/unbox))
+                        ")"))
+               (body
+                 (string-append
+                   return-alloc
+                   "return_closcall1(data, k, " return-expr ");"))
+              )
+        (cond
+          ;; If there are any custom type conversion functions we need to create
+          ;; a wrapper function in Scheme to perform those conversions
+          ((or rv-cust-convert arg-cust-convert)
+           (if (not rv-cust-convert)
+               (set! rv-cust-convert 'begin))
+           (let ((arg-syms 
+                   (map 
+                     (lambda (type) 
+                       (let* ((sym (gensym 'arg))
+                              (arg-cust-type (eval `(with-handler 
+                                   (lambda X #f)
+                                   (hash-table-ref *foreign-types* (quote ,type)))))
+                              (pass-arg
+                                (if (and arg-cust-type
+                                         (> (length arg-cust-type) 1))
+                                   `(,(cadr arg-cust-type) ,sym)
+                                   sym)) )
+                         (cons 
+                           sym  ;; Arg 
+                           pass-arg)));; Passing arg to internal func
+                     arg-types)))
+             `(begin
+                (define-c ,scm-fnc-wrapper ,args ,body)
+                (define (,scm-fnc ,@(map car arg-syms))
+                  (,rv-cust-convert
+                    (,scm-fnc-wrapper ,@(map cdr arg-syms)))))))
+          ;; Simpler case, just define the function directly
+          (else
+           `(define-c ,scm-fnc ,args ,body)))
+          ))))
+
+ )
+)

libs/test-foreign.scm

@@ -0,0 +1,57 @@
+;; Unit tests for the (cyclone foreign) module.
+;;
+(import 
+  (scheme base) 
+  (scheme write)
+  (cyclone test)
+  (cyclone foreign)
+  (scheme cyclone util)
+  (scheme cyclone pretty-print)
+  )
+
+(define *my-global* #f)
+
+(c-define-type my-string string)
+(c-define-type my-integer integer)
+(c-define-type my-integer-as-string integer string->number number->string)
+(c-define-type string-as-integer string number->string string->number)
+
+(test-group "foreign value"
+  (test 3 (c-value "1 + 2" integer))
+  (test 4 (c-value "2 + 2" my-integer))
+  (test "4" (c-value "2 + 2" my-integer-as-string))
+  (test "test" (c-value "\"test\"" string))
+)
+
+(test-group "foreign code"
+  (test #f *my-global*)
+  (c-code 
+    "printf(\"test %d %d \\n\", 1, 2);"
+    "printf(\"test %d %d %d\\n\", 1, 2, 3);"
+    "__glo__85my_91global_85 = boolean_t;")
+  (test #t *my-global*)
+  (set! *my-global* 1)
+  (test 1 *my-global*)
+)
+
+;; Must be top-level
+
+;TODO: support custom types (arg and ret) for c-define.
+;      Also need to be able to support arg/ret convert optional type arguments
+;      Would need to generate scheme wrappers to handle these conversions
+
+(c-define scm-strlen my-integer "strlen" string)
+(c-define scm-strlen-str my-integer-as-string "strlen" string)
+;(c-define scm-strlen "int" "strlen" string)
+(c-define scm-strlend double "strlen" string)
+(c-define scm-strlen2 integer "strlen" my-string)
+(c-define scm-strlen3 integer "strlen" string-as-integer)
+
+(test-group "foreign lambda"
+  (test 15 (scm-strlen "testing 1, 2, 3"))
+  (test 15 (scm-strlen2 "testing 1, 2, 3"))
+  (test 15.0 (scm-strlend "testing 1, 2, 3"))
+  (test "15" (scm-strlen-str "testing 1, 2, 3"))
+  (test 3 (scm-strlen3 255))
+)
+(test-exit)

scheme/cyclone/cgen.sld

@@ -13,6 +13,7 @@
           (scheme eval)
           (scheme inexact)
           (scheme write)
+          (cyclone foreign)
           (scheme cyclone primitives)
           (scheme cyclone transforms)
           (scheme cyclone ast)
@@ -283,12 +284,12 @@
 ;;; Compilation routines.
 
 ;; Return generated code that also requests allocation of C variables on stack
-(define (c-code/vars str cvars)
+(define (c:code/vars str cvars)
   (list str
         cvars))
 
 ;; Return generated code with no C variables allocated on the stack
-(define (c-code str) (c-code/vars str (list)))
+(define (c:code str) (c:code/vars str (list)))
 
 ;; Append arg count to a C code pair
 (define (c:tuple/args cp num-args)
@@ -327,12 +328,12 @@
     c-allocs))
 
 (define (c:append cp1 cp2)
-  (c-code/vars 
+  (c:code/vars 
     (string-append (c:body cp1) (c:body cp2))
     (append (c:allocs cp1) (c:allocs cp2))))
 
 (define (c:append/prefix prefix cp1 cp2)
-  (c-code/vars 
+  (c:code/vars 
     (string-append prefix (c:body cp1) (c:body cp2))
     (append (c:allocs cp1) (c:allocs cp2))))
 
@@ -390,7 +391,7 @@
     ((const? exp)       (c-compile-const exp (alloca? ast-id trace) #f)) ;; TODO: OK to hardcode immutable to false here??
     ((prim?  exp)       
      ;; TODO: this needs to be more refined, probably w/a lookup table
-     (c-code (string-append "primitive_" (mangle exp))))
+     (c:code (string-append "primitive_" (mangle exp))))
     ((ref?   exp)       (c-compile-ref exp))
     ((quote? exp)       (c-compile-quote exp (alloca? ast-id trace)))
     ((if? exp)          (c-compile-if exp append-preamble cont ast-id trace cps?))
@@ -436,7 +437,7 @@
     (num-args 0)
     (create-cons
       (lambda (cvar a b)
-        (c-code/vars
+        (c:code/vars
          (string-append 
            c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");"
            (c-set-immutable-field cvar use-alloca immutable))
@@ -445,7 +446,7 @@
      (lambda (args)
        (cond
         ((null? args)
-           (c-code "NULL"))
+           (c:code "NULL"))
         ((not (pair? args))
          (c-compile-const args use-alloca immutable))
         (else
@@ -455,7 +456,7 @@
                           (c-compile-const (car args) use-alloca immutable) 
                           (_c-compile-scalars (cdr args)))))
              (set! num-args (+ 1 num-args))
-             (c-code/vars
+             (c:code/vars
                 (string-append addr-op cvar-name)
                 (append
                   (c:allocs cell)
@@ -484,7 +485,7 @@
                 (let ((idx-code (c-compile-const (vector-ref exp i) use-alloca immutable)))
                   (loop 
                     (+ i 1)
-                    (c-code/vars
+                    (c:code/vars
                      ;; The vector's C variable
                       (c:body code)
                       ;; Allocations
@@ -498,7 +499,7 @@
                             ";"))))))))))
     (cond
       ((zero? len)
-        (c-code/vars
+        (c:code/vars
             (string-append addr-op cvar-name) ; Code is just the variable name
             (list ; Allocate empty vector
               (string-append 
@@ -506,7 +507,7 @@
                 (c-set-immutable-field cvar-name use-alloca immutable)))))
       (else
         (let ((code
-                (c-code/vars
+                (c:code/vars
                   (string-append addr-op cvar-name) ; Code body is just var name
                   (list ; Allocate the vector
                     (string-append 
@@ -532,7 +533,7 @@
                 (let ((byte-val (number->string (bytevector-u8-ref exp i))))
                   (loop 
                     (+ i 1)
-                    (c-code/vars
+                    (c:code/vars
                      ;; The bytevector's C variable
                       (c:body code)
                       ;; Allocations
@@ -545,7 +546,7 @@
                             ";"))))))))))
     (cond
       ((zero? len)
-        (c-code/vars
+        (c:code/vars
             (string-append addr-op cvar-name) ; Code is just the variable name
             (list ; Allocate empty vector
               (string-append 
@@ -554,7 +555,7 @@
               ))))
       (else
         (let ((code
-                (c-code/vars
+                (c:code/vars
                   (string-append addr-op cvar-name) ; Code body is just var name
                   (list ; Allocate the vector
                     (string-append 
@@ -572,7 +573,7 @@
       (use-alloca
        (let ((tmp-name (mangle (gensym 'tmp)))
              (blen (number->string (string-byte-length exp))))
-        (c-code/vars
+        (c:code/vars
           (string-append "" cvar-name) ; Code is just the variable name
           (list     ; Allocate integer on the C stack
             (string-append 
@@ -595,7 +596,7 @@
                 use-alloca immutable)
             )))))
       (else
-        (c-code/vars
+        (c:code/vars
           (string-append "&" cvar-name) ; Code is just the variable name
           (list     ; Allocate integer on the C stack
             (string-append 
@@ -623,7 +624,7 @@
 (define (c-compile-const exp use-alloca immutable)
   (cond
     ((null? exp)
-     (c-code "NULL"))
+     (c:code "NULL"))
     ((pair? exp)
      (c-compile-scalars exp use-alloca immutable))
     ((vector? exp)
@@ -635,7 +636,7 @@
             (num2str (cond
                        (else
                          (number->string exp)))))
-        (c-code/vars
+        (c:code/vars
          (string-append "" cvar-name) ; Code is just the variable name
             (list     ; Allocate pointer on the C stack
               (string-append 
@@ -656,14 +657,14 @@
              (inum (num2str (imag-part exp)))
              (addr-op (if use-alloca "" "&"))
              (c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num")))
-        (c-code/vars
+        (c:code/vars
             (string-append addr-op cvar-name) ; Code is just the variable name
             (list     ; Allocate on the C stack
               (string-append 
                 c-make-macro "(" cvar-name ", " rnum ", " inum ");")))))
     ((and (integer? exp)
           (exact? exp))
-     (c-code (string-append "obj_int2obj(" 
+     (c:code (string-append "obj_int2obj(" 
                (number->string exp) ")")))
     ((real? exp)
       (let ((cvar-name (mangle (gensym 'c)))
@@ -676,22 +677,22 @@
                          (number->string exp))))
             (addr-op (if use-alloca "" "&"))
             (c-make-macro (if use-alloca "alloca_double" "make_double")))
-        (c-code/vars
+        (c:code/vars
          (string-append addr-op cvar-name) ; Code is just the variable name
             (list     ; Allocate on the C stack
               (string-append 
                 c-make-macro "(" cvar-name ", " num2str ");")))))
     ((boolean? exp) 
-      (c-code (string-append
+      (c:code (string-append
                 (if exp "boolean_t" "boolean_f"))))
     ((char? exp)
-     (c-code (string-append "obj_char2obj(" 
+     (c:code (string-append "obj_char2obj(" 
                (number->string (char->integer exp)) ")")))
     ((string? exp)
      (c-compile-string exp use-alloca immutable))
     ((symbol? exp)
      (allocate-symbol exp)
-     (c-code (string-append "quote_" (mangle exp))))
+     (c:code (string-append "quote_" (mangle exp))))
     (else
       (error "unknown constant: " exp))))
 
@@ -783,7 +784,7 @@
          (c-var-assign 
             (lambda (type)
               (let ((cv-name (mangle (gensym 'c))))
-                (c-code/vars 
+                (c:code/vars 
                   (string-append 
                     (if (or (prim:cont? p) 
                             (equal? (prim/c-var-assign p) "object")
@@ -830,7 +831,7 @@
       ;; the logic
       ;;
         (let ((cv-name (mangle (gensym 'c))))
-           (c-code/vars
+           (c:code/vars
             (if (or (prim:allocates-object? p use-alloca?)
                     (prim->c-func-uses-alloca? p use-alloca?))
                 cv-name ; Already a pointer
@@ -838,7 +839,7 @@
             (list
                 (string-append c-func "(" cv-name tdata-comma tdata)))))
      (else
-        (c-code/vars 
+        (c:code/vars 
           (string-append c-func "(" tdata tptr-comma tptr)
           (list tptr-decl))))))
 
@@ -869,7 +870,7 @@
 
 ;; c-compile-ref : ref-exp -> string
 (define (c-compile-ref exp)
-  (c-code 
+  (c:code 
     (if (member exp *global-syms*)
       (cgen:mangle-global exp)
       (mangle exp))))
@@ -882,7 +883,7 @@
           (lambda (args append-preamble prefix cont)
             (cond
              ((not (pair? args))
-              (c-code ""))
+              (c:code ""))
              (else
               ;; (trace:debug `(c-compile-args ,(car args)))
               (let ((cp (c-compile-exp (car args) 
@@ -929,7 +930,7 @@
                      cps?))
                 (num-cargs (c:num-args cgen)))
            (set-c-call-arity! num-cargs)
-           (c-code
+           (c:code
              (string-append
                (c:allocs->str (c:allocs cgen))
                "return_direct" (number->string num-cargs) 
@@ -978,7 +979,7 @@
                       parent-args
                       cgen-lis))))
            ;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
-           (c-code
+           (c:code
              (string-append
               cgen-allocs ; (c:allocs->str (c:allocs cgen))
                "\n"
@@ -986,6 +987,18 @@
                "\n"
                "continue;"))))
          
+        ((eq? 'Cyc-foreign-code fun)
+         (c:code/vars 
+           (string-append 
+             "")
+           args))
+
+        ((eq? 'Cyc-foreign-value fun)
+         (let ((kons (c->scm (car args) (cadr args))))
+           (c:code/vars
+             (cdr kons)
+             (list (car kons)))))
+
         ((prim? fun)
          (let* ((c-fun 
                  (c-compile-prim fun cont ast-id))
@@ -997,7 +1010,7 @@
                     (number->string num-args)
                     (if (> num-args 0) "," "")))
                 (c-args* (if (prim:arg-count? fun)
-                             (c:append (c-code num-args-str) c-args)
+                             (c:append (c:code num-args-str) c-args)
                              c-args)))
             ;; Emit symbol when mutating global variables, so we can look 
             ;; up the cvar
@@ -1016,7 +1029,7 @@
 
             (if (prim/cvar? fun)
               ;; Args need to go with alloc function
-              (c-code/vars
+              (c:code/vars
                 (c:body c-fun)
                 (append
                   (c:allocs c-args*) ; fun alloc depends upon arg allocs
@@ -1042,12 +1055,12 @@
                             (and (prim:udf? fun)
                                  (zero? num-args)))
                       c-fun
-                      (c:append c-fun (c-code ", "))))
+                      (c:append c-fun (c:code ", "))))
                   c-args*)
-                (c-code ")")))))
+                (c:code ")")))))
 
         ((equal? '%closure-ref fun)
-         (c-code (apply string-append (list
+         (c:code (apply string-append (list
             (c-compile-closure-element-ref 
               ast-id
               (car args)
@@ -1069,7 +1082,7 @@
                 (num-cargs (c:num-args cargs)))
            (cond
              ((not cps?)
-              (c-code 
+              (c:code 
                 (string-append
                   (c:allocs->str (c:allocs cfun) "\n")
                   (c:allocs->str (c:allocs cargs) "\n")
@@ -1125,7 +1138,7 @@
                                   (string-append " " p " = " tmp "; "))
                                 params tmp-params))))
                       ;; (trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
-                    (c-code/vars 
+                    (c:code/vars 
                       (string-append
                         (c:allocs->str (c:allocs cfun) "\n")
                         (c:allocs->str (c:allocs cargs) "\n")
@@ -1150,7 +1163,7 @@
                    (let* ((lid (ast:lambda-id wkf))
                           (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
                           (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
-                     (c-code
+                     (c:code
                        (string-append
                           (c:allocs->str (c:allocs cfun) "\n")
                           (c:allocs->str (c:allocs cargs) "\n")
@@ -1171,7 +1184,7 @@
                   ((and wkf fnc)
                    (let* ((lid (ast:lambda-id wkf))
                           (c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
-                     (c-code
+                     (c:code
                        (string-append
                           (c:allocs->str (c:allocs cfun) "\n")
                           (c:allocs->str (c:allocs cargs) "\n")
@@ -1184,7 +1197,7 @@
                           (c:body cargs)
                           ");"))))
                   (else
-                    (c-code 
+                    (c:code 
                       (string-append
                         (c:allocs->str (c:allocs cfun) "\n")
                         (c:allocs->str (c:allocs cargs) "\n")
@@ -1204,7 +1217,7 @@
                 (num-cargs (c:num-args cargs)))
            (cond
              ((not cps?)
-              (c-code
+              (c:code
                 (string-append
                    (c:allocs->str (c:allocs cfun) "\n")
                    (c:allocs->str (c:allocs cargs) "\n")
@@ -1224,7 +1237,7 @@
                    (let* ((lid (ast:lambda-id (closure->lam fun)))
                           (c-lambda-fnc-str (string-append "__lambda_" (number->string lid)))
                           (c-lambda-fnc-gc-ret-str (string-append "__lambda_gc_ret_" (number->string lid))))
-                     (c-code
+                     (c:code
                        (string-append
                           (c:allocs->str (c:allocs cfun) "\n")
                           (c:allocs->str (c:allocs cargs) "\n")
@@ -1241,7 +1254,7 @@
                   ((adbf:well-known fnc)
                    (let* ((lid (ast:lambda-id (closure->lam fun)))
                           (c-lambda-fnc-str (string-append "__lambda_" (number->string lid))))
-                     (c-code
+                     (c:code
                        (string-append
                           (c:allocs->str (c:allocs cfun) "\n")
                           (c:allocs->str (c:allocs cargs) "\n")
@@ -1254,7 +1267,7 @@
                           (c:body cargs)
                           ");"))))
                   (else
-                   (c-code
+                   (c:code
                      (string-append
                         (c:allocs->str (c:allocs cfun) "\n")
                         (c:allocs->str (c:allocs cargs) "\n")
@@ -1271,25 +1284,25 @@
                          ;; Join expressions; based on c:append
                          (let ((cp1 (if (ref? expr)
                                         ;; Ignore lone ref to avoid C warning
-                                        (c-code/vars "" '())
+                                        (c:code/vars "" '())
                                         (c-compile-exp expr append-preamble cont ast-id trace cps?)))
                                (cp2 acc))
-                           (c-code/vars 
+                           (c:code/vars 
                              (let ((cp1-body (c:body cp1)))
                                (if (zero? (string-length cp1-body))
                                    (c:body cp2) ; Ignore cp1 if necessary
                                    (string-append cp1-body ";" (c:body cp2))))
                              (append (c:allocs cp1) (c:allocs cp2)))))
-                       (c-code "")
+                       (c:code "")
                        args)))
           exps))
         ((equal? 'Cyc-local-set! fun)
          ;:(trace:error `(JAE DEBUG Cyc-local-set ,exp))
          (let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?)))
-           (c-code/vars
+           (c:code/vars
              (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";")
              (c:allocs val-exp)))
-         ;; (c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
+         ;; (c:code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
         )
         ((equal? 'let fun)
          (let* ((vars/vals (cadr exp))
@@ -1301,14 +1314,14 @@
                           (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
                                 (cp2 acc))
                             (set-use-alloca! #f) ; Revert flag
-                            (c-code/vars 
+                            (c:code/vars 
                               (let ((cp1-body (c:body cp1)))
                                 (string-append cp1-body ";" (c:body cp2)))
                               (append 
                                 (list (string-append "object " (mangle (car var/val)) ";"))
                                 (c:allocs cp1) 
                                 (c:allocs cp2)))))
-                        (c-code "")
+                        (c:code "")
                         vars/vals))
                (body-exp (c-compile-exp 
                            body append-preamble cont ast-id trace cps?)))
@@ -1324,7 +1337,7 @@
          (test (compile (if->condition exp)))
          (then (compile (if->then exp)))
          (els (compile (if->else exp))))
-  (c-code (string-append
+  (c:code (string-append
    (c:allocs->str (c:allocs test) "  ")
    "if( (boolean_f != "
    (c:body test)
@@ -1392,7 +1405,7 @@
           #f ; inline, so disable CPS on this pass
          )))
 
-   (c-code/vars "" (list ""))))
+   (c:code/vars "" (list ""))))
 
 (define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?)
    (let* ((precompiled-sym
@@ -1434,14 +1447,14 @@
        (define->var exp)
        #t ; (lambda? body) 
        (let ((cv-name (mangle (gensym 'c))))
-         (c-code/vars 
+         (c:code/vars 
            (string-append "&" cv-name)
            (list
              (string-append "mclosure0(" cv-name ", (function_type)__lambda_"
                (number->string lid) ");" cv-name ".num_args = "
                (number->string num-args)
                ";")))))
-     (c-code/vars "" (list ""))))
+     (c:code/vars "" (list ""))))
 
 ;; Symbol compilation
 
@@ -1642,7 +1655,7 @@
          (create-object (lambda ()
            ;; JAE - this is fine, now need to handle other side (actually reading the value without a closure obj
            ;; (trace:error `(create-object free-vars ,free-vars ,(car free-vars)))
-           (c-code/vars
+           (c:code/vars
              (car free-vars)
              (list))))
          (create-nclosure (lambda ()
@@ -1700,7 +1713,7 @@
     (use-obj-instead-of-closure?
       (create-object))
     (else
-      (c-code/vars
+      (c:code/vars
         (if (and use-alloca?
                  (> (length free-vars) 0))
             cv-name
@@ -1806,7 +1819,7 @@
                          "") ; No varargs, skip
                        (c:serialize
                          (c:append
-                           (c-code 
+                           (c:code 
                             ;; Only trace when entering initial defined function
                              (cond
                                (has-closure?

scheme/cyclone/primitives.sld

@@ -89,6 +89,8 @@
          Cyc-stderr
          Cyc-list
          Cyc-if
+         Cyc-foreign-code
+         Cyc-foreign-value
          Cyc-fast-plus
          Cyc-fast-sub
          Cyc-fast-mul
@@ -238,6 +240,8 @@
          (Cyc-stdin 0 0)
          (Cyc-stderr 0 0)
          (Cyc-if 3 3)
+         (Cyc-foreign-code 1 #f)
+         (Cyc-foreign-value 2 2)
          (Cyc-fast-plus 2 2)
          (Cyc-fast-sub 2 2)
          (Cyc-fast-mul 2 2)
@@ -529,6 +533,8 @@
          ((eq? p 'Cyc-stderr)            "Cyc_stderr")
          ((eq? p 'Cyc-list)              "Cyc_list")
          ((eq? p 'Cyc-if)                "Cyc_if")
+         ((eq? p 'Cyc-foreign-code)      "UNDEF")
+         ((eq? p 'Cyc-foreign-value)     "UNDEF")
          ((eq? p 'Cyc-fast-plus)         "Cyc_fast_sum")
          ((eq? p 'Cyc-fast-sub)          "Cyc_fast_sub")
          ((eq? p 'Cyc-fast-mul)          "Cyc_fast_mul")
@@ -701,6 +707,8 @@
      (or
       (memq p '(
         Cyc-list
+        Cyc-foreign-code
+        Cyc-foreign-value
         Cyc-fast-plus
         Cyc-fast-sub
         Cyc-fast-mul