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.
|
;;;; This module makes it easier to interface directly with C code using the FFI.
|
||||||
;;;;
|
;;;;
|
||||||
(define-library (cyclone foreign)
|
(define-library (cyclone foreign)
|
||||||
(import
|
(import
|
||||||
(scheme base)
|
(scheme base)
|
||||||
(scheme eval)
|
(scheme eval)
|
||||||
(scheme cyclone util)
|
(scheme cyclone util))
|
||||||
;(scheme write) ;; TODO: debugging only!
|
(export
|
||||||
)
|
|
||||||
(export
|
|
||||||
c-code
|
c-code
|
||||||
c-value
|
c-value
|
||||||
c-define
|
c-define
|
||||||
c->scm
|
c->scm
|
||||||
scm->c
|
scm->c
|
||||||
c-define-type
|
c-define-type)
|
||||||
)
|
(begin
|
||||||
(begin
|
;; (c-define-type name type (pack (unpack)))
|
||||||
;;
|
(define-syntax c-define-type
|
||||||
;;(eval `(define *foreign-types* (list)))
|
(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-value
|
||||||
(define-syntax c-define-type
|
(er-macro-transformer
|
||||||
(er-macro-transformer
|
(lambda (expr rename compare)
|
||||||
(lambda (expr rename compare)
|
(let* ((code-arg (cadr expr))
|
||||||
(let ((name (cadr expr))
|
(type-arg (caddr expr))
|
||||||
(type (cddr expr)))
|
(c-type (eval `(with-handler
|
||||||
;;
|
|
||||||
;; 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)
|
(lambda X #f)
|
||||||
(hash-table-ref *foreign-types* (quote ,type-arg))
|
(hash-table-ref *foreign-types* (quote ,type-arg)))))
|
||||||
)))
|
(c-ret-convert #f))
|
||||||
(c-ret-convert #f)
|
(when c-type
|
||||||
)
|
(set! type-arg (car c-type))
|
||||||
(when c-type
|
(if (= 3 (length c-type))
|
||||||
;(write `(defined c type ,c-type) (current-error-port))
|
(set! c-ret-convert (caddr c-type))))
|
||||||
;(newline (current-error-port))
|
(if c-ret-convert
|
||||||
(set! type-arg (car c-type))
|
`((lambda () (,c-ret-convert (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))
|
||||||
(if (= 3 (length c-type))
|
`((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))))))
|
||||||
(set! c-ret-convert (caddr c-type))))
|
|
||||||
|
|
||||||
;(for-each
|
(define-syntax c-code
|
||||||
; (lambda (arg)
|
(er-macro-transformer
|
||||||
; (if (not (string? arg))
|
(lambda (expr rename compare)
|
||||||
; (error "c-value" "Invalid argument: string expected, received " arg)))
|
(for-each
|
||||||
; (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)
|
(lambda (arg)
|
||||||
(if (not (string? arg))
|
(if (not (string? arg))
|
||||||
(error "c-code" "Invalid argument: string expected, received " arg)))
|
(error "c-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 ")"))
|
||||||
((double float)
|
((double float)
|
||||||
(string-append "double_value(" ,code ")"))
|
(string-append "double_value(" ,code ")"))
|
||||||
((bignum bigint)
|
((bignum bigint)
|
||||||
(string-append "bignum_value(" ,code ")"))
|
(string-append "bignum_value(" ,code ")"))
|
||||||
((bool)
|
((bool)
|
||||||
(string-append "(" ,code " == boolean_f)"))
|
(string-append "(" ,code " == boolean_f)"))
|
||||||
((char)
|
((char)
|
||||||
(string-append "obj_obj2char(" ,code ")"))
|
(string-append "obj_obj2char(" ,code ")"))
|
||||||
((string)
|
((string)
|
||||||
(string-append "string_str(" ,code ")"))
|
(string-append "string_str(" ,code ")"))
|
||||||
((symbol)
|
((symbol)
|
||||||
(string-append "symbol_desc(" ,code ")"))
|
(string-append "symbol_desc(" ,code ")"))
|
||||||
((bytevector)
|
((bytevector)
|
||||||
(string-append "(((bytevector_type *)" ,code ")->data)"))
|
(string-append "(((bytevector_type *)" ,code ")->data)"))
|
||||||
((opaque)
|
((opaque)
|
||||||
(string-append "opaque_ptr(" ,code ")"))
|
(string-append "opaque_ptr(" ,code ")"))
|
||||||
((c-void)
|
((c-void)
|
||||||
"Cyc_VOID")
|
"Cyc_VOID")
|
||||||
((thread-data)
|
((thread-data)
|
||||||
"data")
|
"data")
|
||||||
(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 (c-value)
|
;; Box C object, basically the meat of (c-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 (if (string? ,type)
|
`(case (if (string? ,type)
|
||||||
(string->symbol ,type)
|
(string->symbol ,type)
|
||||||
,type)
|
,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))))
|
||||||
)))
|
((bignum bigint)
|
||||||
((bignum bigint)
|
(let ((var (mangle (gensym 'var))))
|
||||||
(let ((var (mangle (gensym 'var))))
|
(cons
|
||||||
(cons
|
(string-append
|
||||||
(string-append
|
"alloc_bignum(data," var ");"
|
||||||
"alloc_bignum(data," var ");"
|
var "->bn = " ,code ";")
|
||||||
var "->bn = " ,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)")))
|
((char)
|
||||||
((char)
|
(cons
|
||||||
(cons
|
""
|
||||||
""
|
(string-append "obj_char2obj(" ,code ")")))
|
||||||
(string-append "obj_char2obj(" ,code ")")))
|
((string)
|
||||||
((string)
|
(let ((var (mangle (gensym 'var))))
|
||||||
(let ((var (mangle (gensym 'var))))
|
(cons
|
||||||
(cons
|
(string-append
|
||||||
(string-append
|
"make_utf8_string(data," var ", " ,code ");")
|
||||||
"make_utf8_string(data," var ", " ,code ");")
|
(string-append "&" var))))
|
||||||
(string-append "&" var)
|
((bytevector)
|
||||||
)))
|
(let ((var (mangle (gensym 'var))))
|
||||||
((bytevector)
|
(cons
|
||||||
(let ((var (mangle (gensym 'var))))
|
(string-append
|
||||||
(cons
|
"make_empty_bytevector(" var ");"
|
||||||
(string-append
|
var "->data = " ,code ";")
|
||||||
"make_empty_bytevector(" var ");"
|
(string-append "&" var))))
|
||||||
var "->data = " ,code ";")
|
((opaque)
|
||||||
(string-append "&" var)
|
(let ((var (mangle (gensym 'var))))
|
||||||
)))
|
(cons
|
||||||
((opaque)
|
(string-append
|
||||||
(let ((var (mangle (gensym 'var))))
|
"make_c_opaque(" var ", " ,code ");")
|
||||||
(cons
|
(string-append "&" var))))
|
||||||
(string-append
|
((c-void)
|
||||||
"make_c_opaque(" var ", " ,code ");")
|
(cons
|
||||||
(string-append "&" var))))
|
(string-append ,code ";")
|
||||||
((c-void)
|
"Cyc_VOID"))
|
||||||
(cons
|
(else
|
||||||
(string-append ,code ";")
|
(error "c->scm unable to convert C object of type " ,type)))))))
|
||||||
"Cyc_VOID"))
|
|
||||||
(else
|
(define-syntax c-define
|
||||||
(error "c->scm unable to convert C object of type " ,type)))))))
|
(er-macro-transformer
|
||||||
|
(lambda (expr rename compare)
|
||||||
(define-syntax c-define
|
(define (emit-type-check arg type)
|
||||||
(er-macro-transformer
|
(case type
|
||||||
(lambda (expr rename compare)
|
((int integer)
|
||||||
(define (emit-type-check arg type)
|
(string-append "Cyc_check_fixnum(data," arg ");"))
|
||||||
(case type
|
((double float)
|
||||||
((int integer)
|
(string-append "Cyc_check_double(data," arg ");"))
|
||||||
(string-append "Cyc_check_fixnum(data," arg ");"))
|
((bignum bigint)
|
||||||
((double float)
|
(string-append "Cyc_check_type(data,Cyc_is_bignum,bignum_tag," arg ");"))
|
||||||
(string-append "Cyc_check_double(data," arg ");"))
|
((bool)
|
||||||
((bignum bigint)
|
(string-append "Cyc_check_type(data,Cyc_is_boolean,boolean_tag," arg ");"))
|
||||||
(string-append "Cyc_check_type(data,Cyc_is_bignum,bignum_tag," arg ");"))
|
((char)
|
||||||
((bool)
|
(string-append
|
||||||
(string-append "Cyc_check_type(data,Cyc_is_boolean,boolean_tag," arg ");"))
|
|
||||||
((char)
|
|
||||||
(string-append
|
|
||||||
" if ((boolean_f == make_boolean(obj_is_char(" arg ")))) {"
|
" if ((boolean_f == make_boolean(obj_is_char(" arg ")))) {"
|
||||||
"Cyc_rt_raise2(data, \"Invalid type: expected char, found \", " arg "); } "))
|
"Cyc_rt_raise2(data, \"Invalid type: expected char, found \", " arg "); } "))
|
||||||
((string)
|
((string)
|
||||||
(string-append "Cyc_check_str(data," arg ");"))
|
(string-append "Cyc_check_str(data," arg ");"))
|
||||||
((symbol)
|
((symbol)
|
||||||
(string-append "Cyc_check_sym(data," arg ");"))
|
(string-append "Cyc_check_sym(data," arg ");"))
|
||||||
((bytevector)
|
((bytevector)
|
||||||
(string-append "Cyc_check_bvec(data," arg ");"))
|
(string-append "Cyc_check_bvec(data," arg ");"))
|
||||||
((opaque)
|
((opaque)
|
||||||
(string-append "Cyc_check_opaque(data," arg ");"))
|
(string-append "Cyc_check_opaque(data," arg ");"))
|
||||||
((c-void)
|
((c-void)
|
||||||
(string-append "Cyc_check_type(data,Cyc_is_void,void_tag," arg ");"))
|
(string-append "Cyc_check_type(data,Cyc_is_void,void_tag," arg ");"))
|
||||||
(else "")))
|
(else "")))
|
||||||
|
|
||||||
(let* ((scm-fnc (cadr expr))
|
(let* ((scm-fnc (cadr expr))
|
||||||
(scm-fnc-wrapper (gensym 'scm-fnc))
|
(scm-fnc-wrapper (gensym 'scm-fnc))
|
||||||
(c-fnc (cadddr expr))
|
(c-fnc (cadddr expr))
|
||||||
(rv-type (caddr expr))
|
(rv-type (caddr expr))
|
||||||
;; boolean - Are we returning a custom (user-defined) type?
|
;; boolean - Are we returning a custom (user-defined) type?
|
||||||
(rv-cust-type (eval `(with-handler
|
(rv-cust-type (eval `(with-handler
|
||||||
(lambda X #f)
|
(lambda X #f)
|
||||||
(hash-table-ref *foreign-types* (quote ,rv-type))
|
(hash-table-ref *foreign-types* (quote ,rv-type))
|
||||||
)))
|
)))
|
||||||
;; boolean - Does the custom return type have a conversion function?
|
;; boolean - Does the custom return type have a conversion function?
|
||||||
(rv-cust-convert
|
(rv-cust-convert
|
||||||
(if (and rv-cust-type (= 3 (length rv-cust-type)))
|
(if (and rv-cust-type (= 3 (length rv-cust-type)))
|
||||||
(caddr rv-cust-type)
|
(caddr rv-cust-type)
|
||||||
#f))
|
#f))
|
||||||
(arg-types (cddddr expr))
|
(arg-types (cddddr expr))
|
||||||
(arg-cust-convert #f)
|
(arg-cust-convert #f)
|
||||||
(arg-syms/unbox
|
(arg-syms/unbox
|
||||||
(map
|
(map
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(let ((var (mangle (gensym 'arg)))
|
(let ((var (mangle (gensym 'arg)))
|
||||||
(arg-cust-type (eval `(with-handler
|
(arg-cust-type (eval `(with-handler
|
||||||
(lambda X #f)
|
(lambda X #f)
|
||||||
(hash-table-ref *foreign-types* (quote ,type))
|
(hash-table-ref *foreign-types* (quote ,type))))))
|
||||||
)))
|
(cons
|
||||||
)
|
var
|
||||||
(cons
|
(scm->c
|
||||||
var
|
var
|
||||||
(scm->c
|
(cond
|
||||||
var
|
(arg-cust-type
|
||||||
(cond
|
(if (> (length arg-cust-type) 1)
|
||||||
(arg-cust-type
|
(set! arg-cust-convert #t))
|
||||||
(if (> (length arg-cust-type) 1)
|
(car arg-cust-type))
|
||||||
(set! arg-cust-convert #t))
|
(else
|
||||||
(car arg-cust-type))
|
type))))))
|
||||||
(else
|
arg-types))
|
||||||
type)))
|
(returns
|
||||||
;(string-append "string_str(" var ")")
|
|
||||||
)))
|
|
||||||
arg-types))
|
|
||||||
(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) ",") ")")
|
||||||
(if rv-cust-type
|
(if rv-cust-type
|
||||||
(car rv-cust-type)
|
(car rv-cust-type)
|
||||||
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 type)
|
(lambda (sym/unbox type)
|
||||||
(if (eq? type 'thread-data)
|
(if (eq? type 'thread-data)
|
||||||
""
|
""
|
||||||
(string-append ", object " (car sym/unbox))))
|
(string-append ", object " (car sym/unbox))))
|
||||||
arg-syms/unbox
|
arg-syms/unbox
|
||||||
arg-types))
|
arg-types))
|
||||||
")"))
|
")"))
|
||||||
(type-checks
|
(type-checks
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
(map
|
(map
|
||||||
(lambda (arg type)
|
(lambda (arg type)
|
||||||
(emit-type-check arg type))
|
(emit-type-check arg type))
|
||||||
(map car arg-syms/unbox)
|
(map car arg-syms/unbox)
|
||||||
arg-types) ))
|
arg-types) ))
|
||||||
(body
|
(body
|
||||||
(string-append
|
(string-append
|
||||||
type-checks
|
type-checks
|
||||||
return-alloc
|
return-alloc
|
||||||
"return_closcall1(data, k, " return-expr ");"))
|
"return_closcall1(data, k, " return-expr ");")))
|
||||||
)
|
(cond
|
||||||
(cond
|
;; If there are any custom type conversion functions we need to create
|
||||||
;; If there are any custom type conversion functions we need to create
|
;; a wrapper function in Scheme to perform those conversions
|
||||||
;; a wrapper function in Scheme to perform those conversions
|
((or rv-cust-convert arg-cust-convert)
|
||||||
((or rv-cust-convert arg-cust-convert)
|
(if (not rv-cust-convert)
|
||||||
(if (not rv-cust-convert)
|
(set! rv-cust-convert 'begin))
|
||||||
(set! rv-cust-convert 'begin))
|
(let ((arg-syms
|
||||||
(let ((arg-syms
|
(map
|
||||||
(map
|
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(let* ((sym (gensym 'arg))
|
(let* ((sym (gensym 'arg))
|
||||||
(arg-cust-type (eval `(with-handler
|
(arg-cust-type (eval `(with-handler
|
||||||
(lambda X #f)
|
(lambda X #f)
|
||||||
(hash-table-ref *foreign-types* (quote ,type)))))
|
(hash-table-ref *foreign-types* (quote ,type)))))
|
||||||
(pass-arg
|
(pass-arg
|
||||||
(if (and arg-cust-type
|
(if (and arg-cust-type
|
||||||
(> (length arg-cust-type) 1))
|
(> (length arg-cust-type) 1))
|
||||||
`(,(cadr arg-cust-type) ,sym)
|
`(,(cadr arg-cust-type) ,sym)
|
||||||
sym)) )
|
sym)) )
|
||||||
(cons
|
(cons
|
||||||
sym ;; Arg
|
sym ;; Arg
|
||||||
pass-arg)));; Passing arg to internal func
|
pass-arg)));; Passing arg to internal func
|
||||||
arg-types)))
|
arg-types)))
|
||||||
`(begin
|
`(begin
|
||||||
(define-c ,scm-fnc-wrapper ,args ,body)
|
(define-c ,scm-fnc-wrapper ,args ,body)
|
||||||
(define (,scm-fnc ,@(map car arg-syms))
|
(define (,scm-fnc ,@(map car arg-syms))
|
||||||
(,rv-cust-convert
|
(,rv-cust-convert
|
||||||
(,scm-fnc-wrapper ,@(map cdr arg-syms)))))))
|
(,scm-fnc-wrapper ,@(map cdr arg-syms)))))))
|
||||||
;; Simpler case, just define the function directly
|
;; Simpler case, just define the function directly
|
||||||
(else
|
(else
|
||||||
`(define-c ,scm-fnc ,args ,body)))
|
`(define-c ,scm-fnc ,args ,body)))))))))
|
||||||
))))
|
|
||||||
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue