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
|
||||
(scheme base)
|
||||
;(scheme write) ;; TODO: debugging only!
|
||||
;(scheme cyclone pretty-print)
|
||||
(scheme cyclone util)
|
||||
)
|
||||
;(include-c-header "<ck_pr.h>")
|
||||
(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))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
257
test-foreign.scm
257
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"))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue