scsh-ldap/ffi-tools/ffi-tools.scm

144 lines
4.3 KiB
Scheme

(define-record-type constant
(make-constant c-name scheme-name c-value-name type)
constant?
(c-name constant-c-name)
(scheme-name constant-scheme-name)
(c-value-name constant-c-value-name)
(type constant-type))
(define constant-type-int 'constant-type-int)
(define (constant-type-int? thing)
(equal? (constant-type thing) constant-type-int))
(define constant-type-char 'constant-type-char)
(define (constant-type-char? thing)
(equal? (constant-type thing) constant-type-char))
(define constant-type-string 'constant-type-string)
(define (constant-type-string? thing)
(equal? (constant-type thing) constant-type-string))
(define (constant-name->scheme-name constant-name)
(let ((replace-underscore
(lambda (c) (if (char=? c #\_) #\- c))))
(string-map replace-underscore (string-downcase constant-name))))
(define c-value-name-prefix "scheme_")
(define (constant-name->value-name constant-name)
(string-append c-value-name-prefix constant-name))
(define (make-integer-constant c-name scheme-name)
(make-constant c-name scheme-name
(constant-name->value-name c-name)
constant-type-int))
(define (make-string-constant c-name scheme-name)
(make-constant c-name scheme-name
(constant-name->value-name c-name)
constant-type-string))
(define (make-constant-from-c-name c-name type)
(let ((scheme-name (constant-name->scheme-name c-name)))
(make-constant c-name scheme-name
(constant-name->value-name c-name)
type)))
(define (make-constant-from-c-name-integer c-name)
(make-constant-from-c-name c-name constant-type-int))
(define (generate-c-declarations constant-list)
(string-join
(map
(lambda (c)
(format "static s48_value ~a = S48_FALSE;~%"
(constant-c-value-name c)))
constant-list)))
(define (generate-c-gc-protect-globals constant-list)
(string-join
(map
(lambda (c)
(format "S48_GC_PROTECT_GLOBAL(~a);~%"
(constant-c-value-name c)))
constant-list)))
(define (generate-c-enter-value c)
(cond
((constant-type-int? c)
(format "~a = s48_enter_integer(~a);~%"
(constant-c-value-name c) (constant-c-name c)))
((constant-type-string? c)
(format "~a = s48_enter_string(~a);~%"
(constant-c-value-name c) (constant-c-name c)))
(else
(error "Don't know how to handle this constant type: "
(constant-type c)))))
(define (generate-c-enter-values constant-list)
(string-join
(map generate-c-enter-value constant-list)))
(define (wrap-in-c-function fun-name body)
(format
(string-append
"void ~a(void) {~%"
"~a~%"
"}~%~%")
fun-name body))
(define (generate-c-enter-values-function c-fun-name constant-list)
(wrap-in-c-function c-fun-name
(generate-c-enter-values constant-list)))
(define (generate-c-gc-protect-globals-function c-fun-name constant-list)
(wrap-in-c-function c-fun-name
(generate-c-gc-protect-globals constant-list)))
;;; generating scheme code
(define (generate-binding constant)
(format "(define ~a (lookup-shared-value \"~a\"))~%"
(constant-scheme-name constant)
(constant-c-value-name constant)))
(define (generate-finite-type-definition ft-name name-converter constants)
(let ((predicate-name (string-append ft-name "-object?"))
(elements-name (string-append ft-name "-elements"))
(name-name (string-append ft-name "-name"))
(index-name (string-append ft-name "-index"))
(id-name (string-append ft-name "-id")))
(format
(string-append
"(define-finite-type ~a :~a~%"
" (id)~%"
" ~a~% ~a~% ~a~% ~a~%"
" (~a)~%"
" (~a))~%~%")
ft-name ft-name
predicate-name elements-name name-name index-name
(string-append "id " id-name)
(generate-finite-type-items name-converter constants))))
(define (generate-finite-type-items name-converter constants)
(string-join
(map (lambda (c) (generate-finite-type-item name-converter c))
constants)))
(define (generate-finite-type-item name-converter constant)
(format " (~a\t(lookup-shared-value \"~a\"))~%"
(name-converter constant)
(constant-c-value-name constant)))
(define (make-drop-common-prefix-name-converter prefix)
(let ((len (string-length prefix)))
(lambda (constant)
(let ((name (constant-c-name constant)))
(constant-name->scheme-name
(if (string-prefix? prefix name)
(string-drop name len)
name))))))