diff --git a/Makefile b/Makefile index c1fe43d2..086b025a 100644 --- a/Makefile +++ b/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 diff --git a/docs/API.md b/docs/API.md index 18b3f6d8..f3dc2273 100644 --- a/docs/API.md +++ b/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) diff --git a/docs/api/cyclone/foreign.md b/docs/api/cyclone/foreign.md new file mode 100644 index 00000000..ffc7869b --- /dev/null +++ b/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 *` + diff --git a/libs/cyclone/foreign.sld b/libs/cyclone/foreign.sld new file mode 100644 index 00000000..6831bfc1 --- /dev/null +++ b/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))) + )))) + + ) +) diff --git a/libs/test-foreign.scm b/libs/test-foreign.scm new file mode 100644 index 00000000..4805c71b --- /dev/null +++ b/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) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 285771cd..1777dafa 100644 --- a/scheme/cyclone/cgen.sld +++ b/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? diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index 0d268a8d..5dd4ec34 100644 --- a/scheme/cyclone/primitives.sld +++ b/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