ffi-tools initial import

c/ffi-tools.c

@@ -1,84 +0,0 @@
-#include "ffi-tools.h"
-
-/* convert null-terminated array of strings to a list of Scheme strings */
-s48_value ffit_enter_string_array(char **array)
-{
-  int i;
-  s48_value res = S48_NULL;
-  S48_DECLARE_GC_PROTECT(1);
-
-  S48_GC_PROTECT_1(res);
-  for (i = 0; array[i] != NULL; i++)
-    res = s48_cons(s48_enter_string(array[i]), res);
-  S48_GC_UNPROTECT();
-  return res;
-}
-
-int call_scheme_boolean_p(s48_value v)
-{
-  s48_value res;
-  S48_DECLARE_GC_PROTECT(2);
-  
-  S48_GC_PROTECT_2(v, res);
-  res = s48_call_scheme(S48_SHARED_BINDING_REF(scheme_boolean_p_function), 1, v);
-  S48_GC_UNPROTECT();
-  return S48_TRUE_P(res);
-}
-
-int call_scheme_integer_p(s48_value v)
-{
-  s48_value res;
-  S48_DECLARE_GC_PROTECT(2);
-  
-  S48_GC_PROTECT_2(v, res);
-  res = s48_call_scheme(S48_SHARED_BINDING_REF(scheme_integer_p_function), 1, v);
-  S48_GC_UNPROTECT();
-  return S48_TRUE_P(res);
-}
-
-/* convert a Scheme list of strings into an null-terminated array of strings */
-char** ffit_extract_list_of_strings(s48_value list)
-{
-  char **a;
-  int l, i;
-  s48_value e;
-  S48_DECLARE_GC_PROTECT(2);
-
-  S48_GC_PROTECT_2(list, e);
-  l = s48_length(list);
-
-  if ((a = (char **) calloc(l + 1, sizeof(char *))) == NULL)
-    s48_raise_out_of_memory_error();
-  a[l] = NULL;
-  
-  e = list;
-  i = 0;
-  while (e != S48_NULL) {
-    if (S48_PAIR_P(e)) 
-      if (S48_STRING_P(S48_CAR(e))) {
-	a[i] = s48_extract_string(S48_CAR(e));
-	e = S48_CDR(e);
-	i++;
-      }
-      else {
-	free(a);
-	s48_raise_argument_type_error(e);
-      }
-    else {
-      free(a);
-      s48_raise_argument_type_error(e);
-    }
-  }
-  S48_GC_UNPROTECT();
-  return a;
-}
-
-void ffit_init_hook(void)
-{
-  S48_GC_PROTECT_GLOBAL(scheme_integer_p_function);
-  S48_GC_PROTECT_GLOBAL(scheme_boolean_p_function);
-
-  scheme_integer_p_function = s48_get_imported_binding("integer?");
-  scheme_boolean_p_function = s48_get_imported_binding("boolean?"); 
-}
-

pkg-def.scm

@@ -1,19 +0,0 @@
-(define-package "ffi-tools" (0 1 0)
-  ((install-lib-version (1 0)))
-
-  (let ((scheme-dir (get-directory 'scheme #f))
-	(lib-dir (get-directory 'lib #f)))
-    (write-to-load-script
-     `((config)
-       (run '(define-structure ffi-tools-path 
-		 (export ffi-tools-lib-path)
-	       (open scheme)
-	       (begin
-		 (define (ffi-tools-lib-path) ,lib-dir))))
-       (load ,(string-append scheme-dir "/packages-run.scm"))
-       (load ,(string-append scheme-dir "/packages-gen.scm"))
-       (user))))
-  
-  (install-directory-contents "scheme" 'scheme)
-  (install-directory-contents "c" 'lib)
-)

scheme/generate.scm

@@ -1,156 +0,0 @@
-(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))))))
-
-
-	      

scheme/packages-gen.scm

@@ -1,34 +0,0 @@
-;;; packages for generating code
-
-(define-interface ffi-import-constants-interface
-  (export
-   make-constant
-   constant?
-   constant-type-int?
-   constant-type-char?
-   constant-type-string?
-   constant-c-name
-   constant-scheme-name
-   constant-c-value-name
-   constant-type
-
-   make-integer-constant
-   make-string-constant
-
-   make-constant-from-c-name
-   make-constant-from-c-name-integer
-
-   generate-c-declarations
-   generate-c-define-exported-bindings-function
-   generate-c-enter-values-function
-   generate-c-gc-protect-globals-function
-
-   generate-binding
-   generate-finite-type-definition
-   make-drop-common-prefix-name-converter))
-
-(define-structure ffi-import-constants ffi-import-constants-interface
-  (open
-   scheme signals
-   srfi-1 srfi-9 srfi-13 srfi-28)
-  (files generate))

scheme/packages-run.scm

@@ -1,10 +0,0 @@
-;;; packages readed at runtime
-
-(define-interface ffi-tools-rts-interface
-  (export
-   (lookup-shared-value :syntax)
-   make-finite-type-import-function))
-
-(define-structure ffi-tools-rts ffi-tools-rts-interface
-  (open scheme srfi-23 external-calls)
-  (files runtime))

scheme/runtime.scm

@@ -1,23 +0,0 @@
-(define-exported-binding "length" length)
-(define-exported-binding "boolean?" boolean?)
-(define-exported-binding "integer?" integer?)
-
-(define-syntax lookup-shared-value
-  (syntax-rules ()
-    ((lookup-shared-value %s)
-     (shared-binding-ref
-      (lookup-imported-binding %s)))))
-
-(define (make-finite-type-alist elements id-proc)
-  (map
-   (lambda (e) (cons (id-proc e) e))
-   (vector->list elements)))
-
-(define (make-finite-type-import-function finite-type-name elements id-proc)
-  (let ((alist (make-finite-type-alist elements id-proc)))
-    (lambda (id)
-      (cond 
-       ((assoc id alist) => cdr)
-       (else
-        (error "Could not map value to finite type "
-    	   finite-type-name id))))))