Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-09 05:57:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

[No code change] Formatted foreign.sld and removed unused commented code

Browse source
This commit is contained in:
Arthur Maciel 2021-01-30 17:19:58 -03:00
parent f5ad1ca6a2
commit b4febc8073
1 changed files with 258 additions and 291 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

57
libs/cyclone/foreign.sld
View file

@ -10,21 +10,15 @@
(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
;;
;;(eval `(define *foreign-types* (list)))
;; (c-define-type name type (pack (unpack))) ;; (c-define-type name type (pack (unpack)))
(define-syntax c-define-type (define-syntax c-define-type
(er-macro-transformer (er-macro-transformer
@ -37,8 +31,6 @@
;; handlers to check if variables are defined in that environment. ;; handlers to check if variables are defined in that environment.
;; ;;
(unless (eval '(with-handler (lambda X #f) *foreign-types*)) (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 `(define *foreign-types* (make-hash-table))))
(eval `(hash-table-set! *foreign-types* (quote ,name) (quote ,type))) (eval `(hash-table-set! *foreign-types* (quote ,name) (quote ,type)))
#f)))) #f))))
@ -50,28 +42,15 @@
(type-arg (caddr expr)) (type-arg (caddr expr))
(c-type (eval `(with-handler (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 (when c-type
;(write `(defined c type ,c-type) (current-error-port))
;(newline (current-error-port))
(set! type-arg (car c-type)) (set! type-arg (car c-type))
(if (= 3 (length c-type)) (if (= 3 (length c-type))
(set! c-ret-convert (caddr c-type)))) (set! c-ret-convert (caddr c-type))))
;(for-each
; (lambda (arg)
; (if (not (string? arg))
; (error "c-value" "Invalid argument: string expected, received " arg)))
; (cdr expr))
(if c-ret-convert (if c-ret-convert
`((lambda () (,c-ret-convert (Cyc-foreign-value ,code-arg ,(symbol->string type-arg))))) `((lambda () (,c-ret-convert (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))
`((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))) `((lambda () (Cyc-foreign-value ,code-arg ,(symbol->string type-arg)))))))))
)
))))
(define-syntax c-code (define-syntax c-code
(er-macro-transformer (er-macro-transformer
@ -151,8 +130,7 @@
(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
@ -173,16 +151,14 @@
(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) ((bytevector)
(let ((var (mangle (gensym 'var)))) (let ((var (mangle (gensym 'var))))
(cons (cons
(string-append (string-append
"make_empty_bytevector(" var ");" "make_empty_bytevector(" var ");"
var "->data = " ,code ";") var "->data = " ,code ";")
(string-append "&" var) (string-append "&" var))))
)))
((opaque) ((opaque)
(let ((var (mangle (gensym 'var)))) (let ((var (mangle (gensym 'var))))
(cons (cons
@ -247,9 +223,7 @@
(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 (cons
var var
(scm->c (scm->c
@ -260,9 +234,7 @@
(set! arg-cust-convert #t)) (set! arg-cust-convert #t))
(car arg-cust-type)) (car arg-cust-type))
(else (else
type))) type))))))
;(string-append "string_str(" var ")")
)))
arg-types)) arg-types))
(returns (returns
(c->scm (c->scm
@ -296,8 +268,7 @@
(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
@ -327,8 +298,4 @@
(,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)))))))))
))))
)
)