From c7b692e3325bda3ef48cf46e763eabf0423e670f Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 28 Apr 2020 16:35:12 -0400 Subject: [PATCH] Relocate macros --- libs/cyclone/foreign.sld | 155 +++++++++++++++++------ test-foreign.scm | 257 ++++++++++++++++++++------------------- 2 files changed, 244 insertions(+), 168 deletions(-) diff --git a/libs/cyclone/foreign.sld b/libs/cyclone/foreign.sld index 1c9dd52b..2d9b2b16 100644 --- a/libs/cyclone/foreign.sld +++ b/libs/cyclone/foreign.sld @@ -10,53 +10,18 @@ (import (scheme base) ;(scheme write) ;; TODO: debugging only! + ;(scheme cyclone pretty-print) + (scheme cyclone util) ) ;(include-c-header "") (export foreign-code foreign-value + define-foreign-lambda + c->scm + scm->c ) (begin - ;; TODO: internal to compiler? Anything to define in this library?? - ;; internal name could be different (Cyc-foreign-code) to facilitate - ;; library renaming, etc here - ;(foreign-code STRING ...) - - -;; TODO: foreign-lambda -;; -;; We are going to use the CHICKEN interface: -;; (foreign-lambda RETURNTYPE NAME ARGTYPE ...) -;; -;; And modify it a bit for our infrastructure: -;; -;; (define-foreign-lambda SCM-NAME RETURNTYPE C-NAME ARGTYPE ...) -;; -;; We need to develop a macro to accept this interface and generate a -;; define-c equivalent. Not nearly as flexible as CHICKEN but will work -;; with our existing infrastructure. This is good enough for version 1. - - - ;(define strlen - ; (foreign-lambda int "strlen" char-vector) ) - -; (define-syntax define-curl-const -; (er-macro-transformer -; (lambda (expr rename compare) -; (let* ((sym (cadr expr)) -; (str (symbol->string sym)) -; (lib_fnc_str (string-append "_" str)) -; (lib_fnc (string->symbol lib_fnc_str)) ;; Internal library function -; (args "(void *data, int argc, closure _, object k)") -; (body -; (string-append -; "return_closcall1(data, k, obj_int2obj(" str "));")) -; ) -; `(begin -; (define-c ,lib_fnc ,args ,body) -; (define ,sym (,lib_fnc)) -; ))))) - (define-syntax foreign-value (er-macro-transformer @@ -80,5 +45,115 @@ (error "foreign-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 ")")) + ((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) + ;; + ;; 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 ,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))))))) + + ;(pretty-print ( + (define-syntax define-foreign-lambda + (er-macro-transformer + (lambda (expr rename compare) + (let* ((scm-fnc (cadr expr)) + (c-fnc (cadddr expr)) + (rv-type (caddr expr)) + (arg-types (cddddr expr)) + (arg-syms/unbox + (map + (lambda (type) + (let ((var (mangle (gensym 'arg)))) + (cons + var + (scm->c var type) + ;(string-append "string_str(" var ")") + ))) + arg-types)) + (returns + (c->scm + (string-append + c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")") + 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 + ;; TODO: need to unbox all args, pass to C function, then box up the result + (string-append + return-alloc + "return_closcall1(data, k, " return-expr ");")) + ) + `(define-c ,scm-fnc ,args ,body) + )) + '(define-foreign-lambda scm-strlen int "strlen" string) + list + list)) + ) ) diff --git a/test-foreign.scm b/test-foreign.scm index b0531531..347385c5 100644 --- a/test-foreign.scm +++ b/test-foreign.scm @@ -2,137 +2,138 @@ (scheme base) (scheme write) (cyclone test) + (cyclone foreign) (scheme cyclone util) (scheme cyclone pretty-print)) -(define-syntax foreign-code - (er-macro-transformer - (lambda (expr rename compare) - (for-each - (lambda (arg) - (if (not (string? arg)) - (error "foreign-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 ")")) - ((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) -;; -;; 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 ,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))))))) - -;(pretty-print ( -(define-syntax define-foreign-lambda - (er-macro-transformer - (lambda (expr rename compare) - (let* ((scm-fnc (cadr expr)) - (c-fnc (cadddr expr)) - (rv-type (caddr expr)) - (arg-types (cddddr expr)) - (arg-syms/unbox - (map - (lambda (type) - (let ((var (mangle (gensym 'arg)))) - (cons - var - (scm->c var type) - ;(string-append "string_str(" var ")") - ))) - arg-types)) - (returns - (c->scm - (string-append - c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")") - 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 - ;; TODO: need to unbox all args, pass to C function, then box up the result - (string-append - return-alloc - "return_closcall1(data, k, " return-expr ");")) - ) - `(define-c ,scm-fnc ,args ,body) - )) - '(define-foreign-lambda scm-strlen int "strlen" string) - list - list -) -) - - -;(define-c foreign-value -; "(void *data, int argc, closure _, object k, object code, object type)" -; " // TODO: need to dispatch conversion based on type -; return_closcall1(data, k, obj_int2obj(code -; ") - +;(define-syntax foreign-code +; (er-macro-transformer +; (lambda (expr rename compare) +; (for-each +; (lambda (arg) +; (if (not (string? arg)) +; (error "foreign-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 ")")) +; ((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) +;;; +;;; 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 ,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))))))) +; +;;(pretty-print ( +;(define-syntax define-foreign-lambda +; (er-macro-transformer +; (lambda (expr rename compare) +; (let* ((scm-fnc (cadr expr)) +; (c-fnc (cadddr expr)) +; (rv-type (caddr expr)) +; (arg-types (cddddr expr)) +; (arg-syms/unbox +; (map +; (lambda (type) +; (let ((var (mangle (gensym 'arg)))) +; (cons +; var +; (scm->c var type) +; ;(string-append "string_str(" var ")") +; ))) +; arg-types)) +; (returns +; (c->scm +; (string-append +; c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")") +; 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 +; ;; TODO: need to unbox all args, pass to C function, then box up the result +; (string-append +; return-alloc +; "return_closcall1(data, k, " return-expr ");")) +; ) +; `(define-c ,scm-fnc ,args ,body) +; )) +; '(define-foreign-lambda scm-strlen int "strlen" string) +; list +; list +;) +;) +; +; +;;(define-c foreign-value +;; "(void *data, int argc, closure _, object k, object code, object type)" +;; " // TODO: need to dispatch conversion based on type +;; return_closcall1(data, k, obj_int2obj(code +;; ") +; ;(define-foreign-lambda scm-strlen int "strlen" string) ;(write (Cyc-foreign-value "errno" "3"))