mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-11 23:07:36 +02:00
Relocate macros
This commit is contained in:
Justin Ethier
parent
c747e8c8e1
commit
c7b692e332
2 changed files with 244 additions and 168 deletions
|
|
@ -10,53 +10,18 @@
|
||||||
(import
|
(import
|
||||||
(scheme base)
|
(scheme base)
|
||||||
;(scheme write) ;; TODO: debugging only!
|
;(scheme write) ;; TODO: debugging only!
|
||||||
|
;(scheme cyclone pretty-print)
|
||||||
|
(scheme cyclone util)
|
||||||
)
|
)
|
||||||
;(include-c-header "<ck_pr.h>")
|
;(include-c-header "<ck_pr.h>")
|
||||||
(export
|
(export
|
||||||
foreign-code
|
foreign-code
|
||||||
foreign-value
|
foreign-value
|
||||||
|
define-foreign-lambda
|
||||||
|
c->scm
|
||||||
|
scm->c
|
||||||
)
|
)
|
||||||
(begin
|
(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
|
(define-syntax foreign-value
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
|
|
@ -80,5 +45,115 @@
|
||||||
(error "foreign-code" "Invalid argument: string expected, received " arg)))
|
(error "foreign-code" "Invalid argument: string expected, received " arg)))
|
||||||
(cdr expr))
|
(cdr expr))
|
||||||
`(Cyc-foreign-code ,@(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))
|
||||||
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
|
||||||
257
test-foreign.scm
257
test-foreign.scm
|
|
@ -2,137 +2,138 @@
|
||||||
(scheme base)
|
(scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(cyclone test)
|
(cyclone test)
|
||||||
|
(cyclone foreign)
|
||||||
(scheme cyclone util)
|
(scheme cyclone util)
|
||||||
(scheme cyclone pretty-print))
|
(scheme cyclone pretty-print))
|
||||||
|
|
||||||
(define-syntax foreign-code
|
;(define-syntax foreign-code
|
||||||
(er-macro-transformer
|
; (er-macro-transformer
|
||||||
(lambda (expr rename compare)
|
; (lambda (expr rename compare)
|
||||||
(for-each
|
; (for-each
|
||||||
(lambda (arg)
|
; (lambda (arg)
|
||||||
(if (not (string? arg))
|
; (if (not (string? arg))
|
||||||
(error "foreign-code" "Invalid argument: string expected, received " arg)))
|
; (error "foreign-code" "Invalid argument: string expected, received " arg)))
|
||||||
(cdr expr))
|
; (cdr expr))
|
||||||
`(Cyc-foreign-code ,@(cdr expr)))))
|
; `(Cyc-foreign-code ,@(cdr expr)))))
|
||||||
|
;
|
||||||
;; Unbox scheme object
|
;;; Unbox scheme object
|
||||||
;;
|
;;;
|
||||||
;; scm->c :: string -> symbol -> string
|
;;; scm->c :: string -> symbol -> string
|
||||||
;;
|
;;;
|
||||||
;; Inputs:
|
;;; Inputs:
|
||||||
;; - code - C variable used to reference the Scheme object
|
;;; - code - C variable used to reference the Scheme object
|
||||||
;; - type - Data type of the Scheme object
|
;;; - type - Data type of the Scheme object
|
||||||
;; Returns:
|
;;; Returns:
|
||||||
;; - C code used to unbox the data
|
;;; - C code used to unbox the data
|
||||||
;(define (scm->c code type)
|
;;(define (scm->c code type)
|
||||||
(define-syntax scm->c
|
;(define-syntax scm->c
|
||||||
(er-macro-transformer
|
; (er-macro-transformer
|
||||||
(lambda (expr rename compare)
|
; (lambda (expr rename compare)
|
||||||
(let ((code (cadr expr))
|
; (let ((code (cadr expr))
|
||||||
(type (caddr expr)))
|
; (type (caddr expr)))
|
||||||
`(case ,type
|
; `(case ,type
|
||||||
((int integer)
|
; ((int integer)
|
||||||
(string-append "obj_obj2int(" ,code ")"))
|
; (string-append "obj_obj2int(" ,code ")"))
|
||||||
((bool)
|
; ((bool)
|
||||||
(string-append "(" ,code " == boolean_f)"))
|
; (string-append "(" ,code " == boolean_f)"))
|
||||||
((string)
|
; ((string)
|
||||||
(string-append "string_str(" ,code ")"))
|
; (string-append "string_str(" ,code ")"))
|
||||||
(else
|
; (else
|
||||||
(error "scm->c unable to convert scheme object of type " ,type)))))))
|
; (error "scm->c unable to convert scheme object of type " ,type)))))))
|
||||||
|
;
|
||||||
;; Box C object, basically the meat of (foreign-value)
|
;;; Box C object, basically the meat of (foreign-value)
|
||||||
;;
|
;;;
|
||||||
;; c->scm :: string -> symbol -> string
|
;;; c->scm :: string -> symbol -> string
|
||||||
;;
|
;;;
|
||||||
;; Inputs:
|
;;; Inputs:
|
||||||
;; - C expression
|
;;; - C expression
|
||||||
;; - Data type used to box the data
|
;;; - Data type used to box the data
|
||||||
;; Returns:
|
;;; Returns:
|
||||||
;; - Allocation code?
|
;;; - Allocation code?
|
||||||
;; - C code
|
;;; - C code
|
||||||
(define-syntax c->scm
|
;(define-syntax c->scm
|
||||||
(er-macro-transformer
|
; (er-macro-transformer
|
||||||
(lambda (expr rename compare)
|
; (lambda (expr rename compare)
|
||||||
(let ((code (cadr expr))
|
; (let ((code (cadr expr))
|
||||||
(type (caddr expr)))
|
; (type (caddr expr)))
|
||||||
`(case ,type
|
; `(case ,type
|
||||||
((int integer)
|
; ((int integer)
|
||||||
(cons
|
; (cons
|
||||||
""
|
; ""
|
||||||
(string-append "obj_int2obj(" ,code ")")))
|
; (string-append "obj_int2obj(" ,code ")")))
|
||||||
((float double)
|
; ((float double)
|
||||||
(let ((var (mangle (gensym 'var))))
|
; (let ((var (mangle (gensym 'var))))
|
||||||
(cons
|
; (cons
|
||||||
(string-append
|
; (string-append
|
||||||
"make_double(" var ", " ,code ");")
|
; "make_double(" var ", " ,code ");")
|
||||||
(string-append "&" var)
|
; (string-append "&" var)
|
||||||
)))
|
; )))
|
||||||
((bool)
|
; ((bool)
|
||||||
(cons
|
; (cons
|
||||||
""
|
; ""
|
||||||
(string-append "(" ,code " == 0 ? boolean_f : boolean_t)")))
|
; (string-append "(" ,code " == 0 ? boolean_f : boolean_t)")))
|
||||||
; ((string)
|
; ; ((string)
|
||||||
; TODO: how to handle the allocation here?
|
; ; TODO: how to handle the allocation here?
|
||||||
; may need to return a c-code pair???
|
; ; may need to return a c-code pair???
|
||||||
; (string-append "
|
; ; (string-append "
|
||||||
; ))
|
; ; ))
|
||||||
(else
|
; (else
|
||||||
(error "c->scm unable to convert C object of type " ,type)))))))
|
; (error "c->scm unable to convert C object of type " ,type)))))))
|
||||||
|
;
|
||||||
;(pretty-print (
|
;;(pretty-print (
|
||||||
(define-syntax define-foreign-lambda
|
;(define-syntax define-foreign-lambda
|
||||||
(er-macro-transformer
|
; (er-macro-transformer
|
||||||
(lambda (expr rename compare)
|
; (lambda (expr rename compare)
|
||||||
(let* ((scm-fnc (cadr expr))
|
; (let* ((scm-fnc (cadr expr))
|
||||||
(c-fnc (cadddr expr))
|
; (c-fnc (cadddr expr))
|
||||||
(rv-type (caddr expr))
|
; (rv-type (caddr expr))
|
||||||
(arg-types (cddddr expr))
|
; (arg-types (cddddr expr))
|
||||||
(arg-syms/unbox
|
; (arg-syms/unbox
|
||||||
(map
|
; (map
|
||||||
(lambda (type)
|
; (lambda (type)
|
||||||
(let ((var (mangle (gensym 'arg))))
|
; (let ((var (mangle (gensym 'arg))))
|
||||||
(cons
|
; (cons
|
||||||
var
|
; var
|
||||||
(scm->c var type)
|
; (scm->c var type)
|
||||||
;(string-append "string_str(" var ")")
|
; ;(string-append "string_str(" var ")")
|
||||||
)))
|
; )))
|
||||||
arg-types))
|
; arg-types))
|
||||||
(returns
|
; (returns
|
||||||
(c->scm
|
; (c->scm
|
||||||
(string-append
|
; (string-append
|
||||||
c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
|
; c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
|
||||||
rv-type))
|
; rv-type))
|
||||||
(return-alloc (car returns))
|
; (return-alloc (car returns))
|
||||||
(return-expr (cdr returns))
|
; (return-expr (cdr returns))
|
||||||
(args (string-append
|
; (args (string-append
|
||||||
"(void *data, int argc, closure _, object k "
|
; "(void *data, int argc, closure _, object k "
|
||||||
(apply string-append
|
; (apply string-append
|
||||||
(map
|
; (map
|
||||||
(lambda (sym/unbox)
|
; (lambda (sym/unbox)
|
||||||
(string-append ", object " (car sym/unbox)))
|
; (string-append ", object " (car sym/unbox)))
|
||||||
arg-syms/unbox))
|
; arg-syms/unbox))
|
||||||
")"))
|
; ")"))
|
||||||
(body
|
; (body
|
||||||
;; TODO: need to unbox all args, pass to C function, then box up the result
|
; ;; TODO: need to unbox all args, pass to C function, then box up the result
|
||||||
(string-append
|
; (string-append
|
||||||
return-alloc
|
; return-alloc
|
||||||
"return_closcall1(data, k, " return-expr ");"))
|
; "return_closcall1(data, k, " return-expr ");"))
|
||||||
)
|
; )
|
||||||
`(define-c ,scm-fnc ,args ,body)
|
; `(define-c ,scm-fnc ,args ,body)
|
||||||
))
|
; ))
|
||||||
'(define-foreign-lambda scm-strlen int "strlen" string)
|
; '(define-foreign-lambda scm-strlen int "strlen" string)
|
||||||
list
|
; list
|
||||||
list
|
; list
|
||||||
)
|
;)
|
||||||
)
|
;)
|
||||||
|
;
|
||||||
|
;
|
||||||
;(define-c foreign-value
|
;;(define-c foreign-value
|
||||||
; "(void *data, int argc, closure _, object k, object code, object type)"
|
;; "(void *data, int argc, closure _, object k, object code, object type)"
|
||||||
; " // TODO: need to dispatch conversion based on type
|
;; " // TODO: need to dispatch conversion based on type
|
||||||
; return_closcall1(data, k, obj_int2obj(code
|
;; return_closcall1(data, k, obj_int2obj(code
|
||||||
; ")
|
;; ")
|
||||||
|
;
|
||||||
;(define-foreign-lambda scm-strlen int "strlen" string)
|
;(define-foreign-lambda scm-strlen int "strlen" string)
|
||||||
|
|
||||||
;(write (Cyc-foreign-value "errno" "3"))
|
;(write (Cyc-foreign-value "errno" "3"))
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue