source: project/release/4/bind/trunk/bind-foreign-transformer.scm @ 29019

Last change on this file since 29019 was 29019, checked in by felix winkelmann, 8 years ago

bind 1.5: applied fix and test-enhancements by KLM

File size: 3.5 KB
Line 
1(require-library matchable)
2(import matchable)
3
4;; bind-foreign-lambda* and its cousins are functions that are similar to
5;; foreign-lambda*, but where the C body is a lisp-like language instead of
6;; C-code as flat strings.
7
8;; introducing cexp: an sexp with C semantics. used in
9;; bind-foreign-lambda* instead of flat strings. we are using this
10;; intermediate representation of C-code so that we can manipulate it.
11;; it is very basic, but allows us to do things like argument casting,
12;; return-type conversion and similar things. try some of these:
13;; (cexp->string '(= (deref "destination") ("vadd" v1 v2)))
14;; (cexp->string '("return" (+ (deref x) u)))
15;;
16;; note the cexp is very limited, and covers only the small subset of C that
17;; is needed by the foreign-code generated by bind.
18(define (cexp->string cexp)
19  (define (xpr->str cexp)
20    (match cexp
21      (('* args ...)  (conc (intersperse (map xpr->str args) "*")))
22      (('+ args ...)  (conc (intersperse (map xpr->str args) "+")))
23      (('-> struct x) (conc (xpr->str struct) "->" (xpr->str x)))
24      (('= var x)     (conc (xpr->str var) " = " (xpr->str x)))
25      (('deref x)     (conc "*" (xpr->str x)))
26      (((? string? str) args ...) (conc str (intersperse (map xpr->str args) ",")))
27      ((? string? a) a)
28      ((? symbol? a) (symbol->string a))
29      ((? number? a) (number->string a))
30      (else (error "invalid c-exp" cexp))))
31  (match cexp
32    (('stmt statements ...) (apply conc (map (lambda (s) (conc s ";\n")) (map cexp->string statements))))
33    (('return expr) (conc "return(" (xpr->str expr) ");"))
34    (exp (xpr->str cexp))))
35
36;; C expression or C statement?
37(define (cexp-expression? cexp)
38  (case (car cexp)
39    ((stmt return) #f)
40    (else #t)))
41
42;; convert from foreign-lambda form to foreign-lambda* form which has a body.
43;;
44;; there is no performance overhead moving from foreign-lambda to
45;; foreign-lambda* (says Felix). therefore, we don't need to convert
46;; them back to bind-foreign-lambda even though they're unmodified.
47;; This simplifies everything a lot, as we only have to deal with
48;; foreign-lambda* in our translations/conversions.
49;;
50;; the first argument is either foreign-lambda or foreign-safe-lambda (not
51;; renamed). for example:
52;; (foreign-lambda->foreign-lambda* '(foreign-lambda float "foo" int int) identity)
53(define foreign-lambda->foreign-lambda*
54  (lambda (x rename)
55    (let* ((foreign-lambda-type (car x)) ;; foreign-lambda or foreign-safe-lambda
56           (rtype (cadr x))
57           (fname (caddr x))
58           (argtypes (cdddr x))
59           ;; argument types with argument
60           (args (map (lambda (type i) (list type (string->symbol (conc "a" i))))
61                      argtypes
62                      (iota (length argtypes)))))
63      `(,(rename (string->symbol (conc foreign-lambda-type "*"))) ;; append *
64        ,rtype
65        ,args
66        (,fname ,@(map cadr args))
67        ))))
68
69;; turn into a flat foreign-lambda* by converting cexp body into a flat
70;; string of C-code.
71(define bind-foreign-lambda*
72  (lambda (x rename)
73    (let ((foreign-lambda* (car x)) ;; foreign-lambda* / foreign-safe-lambda*
74          (rtype (cadr x))
75          (fname (caddr x))
76          (body (cadddr x)))
77      `(,foreign-lambda* ,rtype ,fname
78        ,(let ([c-code (cexp->string body)])
79           (if (cexp-expression? body)
80               ;; add return(...) automatically
81               (if (not (eq? rtype 'void))
82                   (conc "return(" c-code ");")
83                   (conc c-code ";"))
84               c-code))))))
Note: See TracBrowser for help on using the repository browser.