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

(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-define-exported-bindings constant-list)
  (string-join
   (map
    (lambda (c)
      (format "s48_define_exported_binding(\"~a\", ~a);~%"
	      (constant-c-value-name c)
	      (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-define-exported-bindings-function c-fun-name constant-list)
  (wrap-in-c-function c-fun-name
		      (generate-c-define-exported-bindings 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))))))