mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-21 22:59:16 +02:00
[No code change] Formatted foreign.sld and removed unused commented code
This commit is contained in:
Arthur Maciel
parent
f5ad1ca6a2
commit
b4febc8073
1 changed files with 258 additions and 291 deletions
|
|
@ -7,328 +7,295 @@
|
|||
;;;; This module makes it easier to interface directly with C code using the FFI.
|
||||
;;;;
|
||||
(define-library (cyclone foreign)
|
||||
(import
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme eval)
|
||||
(scheme cyclone util)
|
||||
;(scheme write) ;; TODO: debugging only!
|
||||
)
|
||||
(export
|
||||
(scheme cyclone util))
|
||||
(export
|
||||
c-code
|
||||
c-value
|
||||
c-define
|
||||
c->scm
|
||||
scm->c
|
||||
c-define-type
|
||||
)
|
||||
(begin
|
||||
;;
|
||||
;;(eval `(define *foreign-types* (list)))
|
||||
c-define-type)
|
||||
(begin
|
||||
;; (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*))
|
||||
(eval `(define *foreign-types* (make-hash-table))))
|
||||
(eval `(hash-table-set! *foreign-types* (quote ,name) (quote ,type)))
|
||||
#f))))
|
||||
|
||||
;; (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
|
||||
(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))))
|
||||
(hash-table-ref *foreign-types* (quote ,type-arg)))))
|
||||
(c-ret-convert #f))
|
||||
(when c-type
|
||||
(set! type-arg (car c-type))
|
||||
(if (= 3 (length c-type))
|
||||
(set! c-ret-convert (caddr c-type))))
|
||||
(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)))))))))
|
||||
|
||||
;(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
|
||||
(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)))))
|
||||
`(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 ")"))
|
||||
((c-void)
|
||||
"Cyc_VOID")
|
||||
((thread-data)
|
||||
"data")
|
||||
(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)
|
||||
)))
|
||||
((bignum bigint)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"alloc_bignum(data," var ");"
|
||||
var "->bn = " ,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(" var ");"
|
||||
var "->data = " ,code ";")
|
||||
(string-append "&" var)
|
||||
)))
|
||||
((opaque)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_c_opaque(" var ", " ,code ");")
|
||||
(string-append "&" var))))
|
||||
((c-void)
|
||||
(cons
|
||||
(string-append ,code ";")
|
||||
"Cyc_VOID"))
|
||||
(else
|
||||
(error "c->scm unable to convert C object of type " ,type)))))))
|
||||
|
||||
(define-syntax c-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(define (emit-type-check arg type)
|
||||
(case type
|
||||
((int integer)
|
||||
(string-append "Cyc_check_fixnum(data," arg ");"))
|
||||
((double float)
|
||||
(string-append "Cyc_check_double(data," arg ");"))
|
||||
((bignum bigint)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_bignum,bignum_tag," arg ");"))
|
||||
((bool)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_boolean,boolean_tag," arg ");"))
|
||||
((char)
|
||||
(string-append
|
||||
;; 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 ")"))
|
||||
((c-void)
|
||||
"Cyc_VOID")
|
||||
((thread-data)
|
||||
"data")
|
||||
(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))))
|
||||
((bignum bigint)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"alloc_bignum(data," var ");"
|
||||
var "->bn = " ,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(" var ");"
|
||||
var "->data = " ,code ";")
|
||||
(string-append "&" var))))
|
||||
((opaque)
|
||||
(let ((var (mangle (gensym 'var))))
|
||||
(cons
|
||||
(string-append
|
||||
"make_c_opaque(" var ", " ,code ");")
|
||||
(string-append "&" var))))
|
||||
((c-void)
|
||||
(cons
|
||||
(string-append ,code ";")
|
||||
"Cyc_VOID"))
|
||||
(else
|
||||
(error "c->scm unable to convert C object of type " ,type)))))))
|
||||
|
||||
(define-syntax c-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(define (emit-type-check arg type)
|
||||
(case type
|
||||
((int integer)
|
||||
(string-append "Cyc_check_fixnum(data," arg ");"))
|
||||
((double float)
|
||||
(string-append "Cyc_check_double(data," arg ");"))
|
||||
((bignum bigint)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_bignum,bignum_tag," arg ");"))
|
||||
((bool)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_boolean,boolean_tag," arg ");"))
|
||||
((char)
|
||||
(string-append
|
||||
" if ((boolean_f == make_boolean(obj_is_char(" arg ")))) {"
|
||||
"Cyc_rt_raise2(data, \"Invalid type: expected char, found \", " arg "); } "))
|
||||
((string)
|
||||
(string-append "Cyc_check_str(data," arg ");"))
|
||||
((symbol)
|
||||
(string-append "Cyc_check_sym(data," arg ");"))
|
||||
((bytevector)
|
||||
(string-append "Cyc_check_bvec(data," arg ");"))
|
||||
((opaque)
|
||||
(string-append "Cyc_check_opaque(data," arg ");"))
|
||||
((c-void)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_void,void_tag," arg ");"))
|
||||
(else "")))
|
||||
"Cyc_rt_raise2(data, \"Invalid type: expected char, found \", " arg "); } "))
|
||||
((string)
|
||||
(string-append "Cyc_check_str(data," arg ");"))
|
||||
((symbol)
|
||||
(string-append "Cyc_check_sym(data," arg ");"))
|
||||
((bytevector)
|
||||
(string-append "Cyc_check_bvec(data," arg ");"))
|
||||
((opaque)
|
||||
(string-append "Cyc_check_opaque(data," arg ");"))
|
||||
((c-void)
|
||||
(string-append "Cyc_check_type(data,Cyc_is_void,void_tag," arg ");"))
|
||||
(else "")))
|
||||
|
||||
(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
|
||||
(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
|
||||
(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
|
||||
(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))))))
|
||||
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
|
||||
(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 type)
|
||||
(if (eq? type 'thread-data)
|
||||
""
|
||||
(string-append ", object " (car sym/unbox))))
|
||||
arg-syms/unbox
|
||||
arg-types))
|
||||
")"))
|
||||
(type-checks
|
||||
(map
|
||||
(lambda (sym/unbox type)
|
||||
(if (eq? type 'thread-data)
|
||||
""
|
||||
(string-append ", object " (car sym/unbox))))
|
||||
arg-syms/unbox
|
||||
arg-types))
|
||||
")"))
|
||||
(type-checks
|
||||
(apply
|
||||
string-append
|
||||
(map
|
||||
(lambda (arg type)
|
||||
(emit-type-check arg type))
|
||||
(map car arg-syms/unbox)
|
||||
arg-types) ))
|
||||
(body
|
||||
string-append
|
||||
(map
|
||||
(lambda (arg type)
|
||||
(emit-type-check arg type))
|
||||
(map car arg-syms/unbox)
|
||||
arg-types) ))
|
||||
(body
|
||||
(string-append
|
||||
type-checks
|
||||
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
|
||||
type-checks
|
||||
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)))))
|
||||
(lambda X #f)
|
||||
(hash-table-ref *foreign-types* (quote ,type)))))
|
||||
(pass-arg
|
||||
(if (and arg-cust-type
|
||||
(> (length arg-cust-type) 1))
|
||||
(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
|
||||
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)))
|
||||
))))
|
||||
|
||||
)
|
||||
)
|
||||
`(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)))))))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue