cyclone/test-foreign.scm

(import 
  (scheme base) 
  (scheme write)
  (cyclone test)
  (scheme cyclone util)
  (scheme cyclone pretty-print))

(define-syntax foreign-code
  (er-macro-transformer
    (lambda (expr rename compare)
      (for-each
        (lambda (arg)
          (if (not (string? arg))
              (error "foreign-code" "Invalid argument: string expected, received " arg)))
        (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 ")"))
          ((bool)
           (string-append "(" ,code " == boolean_f)"))
          ((string)
           (string-append "string_str(" ,code ")"))
          (else
            (error "scm->c unable to convert scheme object of type " ,type)))))))

;; Box C object, basically the meat of (foreign-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 ,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)
         )))
        ((bool)
         (cons
           ""
           (string-append "(" ,code " == 0 ? boolean_f : boolean_t)")))
    ;    ((string)
    ;    TODO: how to handle the allocation here?
    ;          may need to return a c-code pair???
    ;     (string-append "
    ;     ))
        (else
          (error "c->scm unable to convert C object of type " ,type)))))))

;(pretty-print (
(define-syntax define-foreign-lambda
  (er-macro-transformer
    (lambda (expr rename compare)
      (let* ((scm-fnc (cadr expr))
             (c-fnc (cadddr expr))
             (rv-type (caddr expr))
             (arg-types (cddddr expr))
             (arg-syms/unbox 
               (map 
                 (lambda (type)
                   (let ((var (mangle (gensym 'arg))))
                     (cons 
                       var 
                       (scm->c var type)
                       ;(string-append "string_str(" var ")")
                       )))
                 arg-types))
             (returns
               (c->scm 
                 (string-append 
                   c-fnc "(" (string-join (map cdr arg-syms/unbox) ",") ")")
                 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)
                           (string-append ", object " (car sym/unbox)))
                       arg-syms/unbox))
                      ")"))
             (body
             ;; TODO: need to unbox all args, pass to C function, then box up the result
               (string-append
                 return-alloc
                 "return_closcall1(data, k, " return-expr ");"))
            )
      `(define-c ,scm-fnc ,args ,body)
        ))
 '(define-foreign-lambda scm-strlen int "strlen" string)
 list
 list
)
)


;(define-c foreign-value
; "(void *data, int argc, closure _, object k, object code, object type)"
; " // TODO: need to dispatch conversion based on type
;   return_closcall1(data, k, obj_int2obj(code
; ")

;(define-foreign-lambda scm-strlen int "strlen" string)

;(write (Cyc-foreign-value "errno" "3"))
;(newline)
(test-group "foreign-value"
  (test 3 (Cyc-foreign-value "1 + 2" 'integer))
)

(test-group "foreign-code"
(write (foreign-code 
         "printf(\"test %d %d \\n\", 1, 2);"
         "printf(\"test %d %d %d\\n\", 1, 2, 3);")) (newline)
)

;; Must be top-level
(define-foreign-lambda scm-strlen int "strlen" string)
(define-foreign-lambda scm-strlend double "strlen" string)

(test-group "foreign lambda"
  (test 15 (scm-strlen "testing 1, 2, 3"))
  (test 15.0 (scm-strlend "testing 1, 2, 3"))
)
(test-exit)