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

(require-library matchable)
(import matchable)

;; bind-foreign-lambda* and its cousins are functions that are similar to
;; foreign-lambda*, but where the C body is a lisp-like language instead of
;; C-code as flat strings.

;; introducing cexp: an sexp with C semantics. used in
;; bind-foreign-lambda* instead of flat strings. we are using this
;; intermediate representation of C-code so that we can manipulate it.
;; it is very basic, but allows us to do things like argument casting,
;; return-type conversion and similar things. try some of these:
;; (cexp->string '(= (deref "destination") ("vadd" v1 v2)))
;; (cexp->string '("return" (+ (deref x) u)))
;;
;; note the cexp is very limited, and covers only the small subset of C that
;; is needed by the foreign-code generated by bind.
(define (cexp->string cexp)
  (define (xpr->str cexp)
    (match cexp
      (('* args ...)  (conc (intersperse (map xpr->str args) "*")))
      (('+ args ...)  (conc (intersperse (map xpr->str args) "+")))
      (('-> structname x) (conc (xpr->str structname) "->" (xpr->str x)))
      (('= var x)     (conc (xpr->str var) " = " (xpr->str x)))
      (('deref x)     (conc "*" (xpr->str x)))
      (((? string? str) args ...) (conc str (intersperse (map xpr->str args) ",")))
      ((? string? a) a)
      ((? symbol? a) (symbol->string a))
      ((? number? a) (number->string a))
      (else (error "invalid c-exp" cexp))))
  (match cexp
    (('stmt statements ...) (apply conc (map (lambda (s) (conc s ";\n")) (map cexp->string statements))))
    (('return expr) (conc "return(" (xpr->str expr) ");"))
    (exp (xpr->str cexp))))

;; C expression or C statement?
(define (cexp-expression? cexp)
  (case (car cexp)
    ((stmt return) #f)
    (else #t)))

;; convert from foreign-lambda form to foreign-lambda* form which has a body.
;;
;; there is no performance overhead moving from foreign-lambda to
;; foreign-lambda* (says Felix). therefore, we don't need to convert
;; them back to bind-foreign-lambda even though they're unmodified.
;; This simplifies everything a lot, as we only have to deal with
;; foreign-lambda* in our translations/conversions.
;;
;; the first argument is either foreign-lambda or foreign-safe-lambda (not
;; renamed). for example:
;; (foreign-lambda->foreign-lambda* '(foreign-lambda float "foo" int int) identity)
(define foreign-lambda->foreign-lambda*
  (lambda (x rename)
    (let* ((foreign-lambda-type (car x)) ;; foreign-lambda or foreign-safe-lambda
           (rtype (cadr x))
           (fname (caddr x))
           (argtypes (cdddr x))
           ;; argument types with argument
           (args (map (lambda (type i) (list type (string->symbol (conc "a" i))))
                      argtypes
                      (iota (length argtypes)))))
      `(,(rename (string->symbol (conc foreign-lambda-type "*"))) ;; append *
        ,rtype
        ,args
        (,fname ,@(map cadr args))
        ))))

;; turn into a flat foreign-lambda* by converting cexp body into a flat
;; string of C-code.
(define bind-foreign-lambda*
  (lambda (x rename)
    (let ((foreign-lambda* (car x)) ;; foreign-lambda* / foreign-safe-lambda*
          (rtype (cadr x))
          (fname (caddr x))
          (body (cadddr x)))
      `(,foreign-lambda* ,rtype ,fname
        ,(let ([c-code (cexp->string body)])
           (if (cexp-expression? body)
               ;; add return(...) automatically
               (if (not (eq? rtype 'void))
                   (conc "return(" c-code ");")
                   (conc c-code ";"))
               c-code))))))