cload.scm

(provide 'cload.scm)

;;; --------------------------------------------------------------------------------
;;; automatically link a C function into s7 (there are a bunch of examples below)
;;;     (c-define '(double j0 (double)) "m" "math.h")
;;; means link the name m:j0 to the math library function j0 passing a double arg and getting a double result (reals in s7)
;;;
;;; (c-define c-info prefix headers cflags ldflags)
;;;    prefix is some arbitrary prefix (it can be "") that you want prepended to various names.
;;;    headers is a list of headers (as strings) that the c-info relies on, (("math.h") for example).
;;;    cflags are any special C compiler flags that are needed ("-I." in particular).
;;;    ldflags is the similar case for the loader.
;;;    c-info is a list that describes the C entities that you want to tie into s7.
;;;       it can be either one list describing one entity, or a list of such lists.
;;;       Each description has the form: (return-type entity-name-in-C (argument-type...))
;;;       where each entry is a symbol, and C names are used throughout.  So, in the j0
;;;       example above, (double j0 (double)) says we want access to j0, it returns
;;;       a C double, and takes one argument, also a C double.  s7 tries to figure out 
;;;       what the corresponding s7 type is, but in tricky cases, you should tell it
;;;       by replacing the bare type name with a list: (C-type underlying-C-type).  For example,
;;;       the Snd function set_graph_style takes an (enum) argument of type graph_style_t.
;;;       This is actually an int, so we use (graph_style_t int) as the type:
;;;         (void set_graph_style ((graph_style_t int)))
;;;       If the C entity is a constant, then the descriptor list has just two entries,
;;;       the C-type and the entity name: (int F_OK) for example. The entity name can also be a list 
;;;       (an enum listing for example).
;;;       If the C type has a space ("struct tm*" for example), use (symbol "struct tm*") 
;;;       to construct the corresponding symbol.
;;;    The entity is placed in the current s7 environment under the name (string-append prefix ":" name)
;;;    where the ":" is omitted if the prefix is null.  So in the j0 example, we get in s7 the function m:j0.
;;;
;;; some examples:
;;;
;;;  (c-define '((double j0 (double)) 
;;;              (double j1 (double)) 
;;;              (double erf (double)) 
;;;              (double erfc (double))
;;;              (double lgamma (double)))
;;;             "m" "math.h")
;;; 
;;;
;;; (c-define '(char* getenv (char*)))
;;; (c-define '(int setenv (char* char* int)))
;;; (define get-environment-variable (let () (c-define '(char* getenv (char*))) getenv))
;;;
;;; (define file-exists? (let () (c-define '((int F_OK) (int access (char* int))) "" "unistd.h") (lambda (arg) (= (access arg F_OK) 0))))
;;; (define delete-file (let () (c-define '(int unlink (char*)) "" "unistd.h") (lambda (file) (= (unlink file) 0)))) ; 0=success, -1=failure
;;;
;;;
;;; these pick up Snd stuff:
;;;   (c-define '(char* version_info ()) "" "snd.h" "-I.")
;;;   (c-define '(mus_float_t mus_degrees_to_radians (mus_float_t)) "" "snd.h" "-I.")
;;;
;;;   (c-define '(snd_info* any_selected_sound ()) "" "snd.h" "-I.")
;;;   (c-define '(void select_channel (snd_info* int)) "" "snd.h" "-I.")
;;;   (c-define '(((graph_style_t int) (GRAPH_LINES GRAPH_DOTS GRAPH_FILLED GRAPH_DOTS_AND_LINES GRAPH_LOLLIPOPS)) 
;;;               (void set_graph_style ((graph_style_t int)))) 
;;;             "" "snd.h" "-I.")
;;;   
;;;
;;;  (c-define '(char* getcwd (char* size_t)) "" "unistd.h")
;;;    :(let ((str (make-string 32))) (getcwd str 32) str)
;;;    "/home/bil/cl\x00                   "
;;;    so it works in a sense -- there is a memory leak here
;;; 
;;;
;;; (c-define (list '(time_t* calloc (size_t size_t))
;;;		    '(void free (time_t*))
;;;		    '(void time (time_t*))
;;;		    (list (symbol "struct tm*") 'localtime '(time_t*))
;;;                 (list 'size_t 'strftime (list 'char* 'size_t 'char* (symbol "struct tm*"))))
;;;          "" "time.h")
;;;   > (let ((p (calloc 1 8)) (str (make-string 32))) 
;;;       (time p) (let ((bytes (strftime str 32 "%a %d-%b-%Y %H:%M %Z" (localtime p)))) (free p) (substring str 0 bytes)))
;;;   "Sat 11-Aug-2012 08:55 PDT
;;;
;;;
;;; (c-define '((int closedir (DIR*))
;;; 	        (DIR* opendir (char*))
;;; 		(in-C "static char *read_dir(DIR *p) \
;;;                    {                             \
;;;                      struct dirent *dirp;         \
;;;                      dirp = readdir(p);           \
;;;                      if (!dirp) return(NULL);     \
;;;                      else return(dirp->d_name);   \
;;;                     }")
;;; 	        (char* read_dir (DIR*)))
;;;   "" '("sys/types.h" "dirent.h"))
;;; 
;;; (define (memory-usage)
;;;   (with-let *libc*
;;;     (let ((v (rusage.make))) 
;;;       (getrusage RUSAGE_SELF v)
;;;       (let ((mem (rusage.ru_maxrss v))) 
;;;         (free v) 
;;;         (* 1024 mem)))))
;;; --------------------------------------------------------------------------------

(define *cload-cflags* (if (provided? 'clang) "-fPIC" ""))
(define *cload-ldflags* "")
(unless (defined? '*cload-directory*)
  (define *cload-directory* ""))
(unless (defined? '*cload-library-name*)
  (define *cload-library-name* #f))

(define *cload-c-compiler* ;(if (provided? 'tcc)  ; how to get tcc to write a .so file?
			       ;"tcc"
			       (if (and (provided? 'gcc) 
					(not (provided? 'openbsd))) 
				   "gcc"
				   (if (provided? 'clang) 
				       "clang"
				       "cc")));)

(define-macro (defvar name value) 
  `(if (not (defined? ',name)) 
       (define ,name ,value)))

(defvar c-define-output-file-counter 0)   ; ugly, but I can't find a way around this (dlopen/dlsym stupidity)


;;; to place the new function in the caller's current environment, we need to pass the environment in explicitly:
(define-macro (c-define . args) 
  (cons 'c-define-1 (cons '(curlet) args)))


(define* (c-define-1 cur-env function-info (prefix "") (headers ()) (cflags "") (ldflags "") output-name)
  ;; write a C shared library module that links in the functions in function-info
  ;;    function info is either a list: (return-type c-name arg-type) or a list thereof
  ;;    the new functions are placed in cur-env

  (define handlers (list '(integer s7_is_integer s7_integer s7_make_integer s7_int)
			 '(boolean s7_is_boolean s7_boolean s7_make_boolean bool)
			 '(real s7_is_real s7_number_to_real_with_caller s7_make_real s7_double)

			 ;; '(complex s7_is_complex s7_to_c_complex?? s7_make_complex s7_complex)

			 '(string s7_is_string s7_string s7_make_string char*)
			 (list 'character 's7_is_character 's7_character 's7_make_character (symbol "unsigned char"))
			 '(c_pointer s7_is_c_pointer s7_c_pointer s7_make_c_pointer_with_type void*)
			 '(s7_pointer #f #f #f s7_pointer)
			 ))

  (define (C-type->s7-type type)

    (if (pair? type)                                  ; in case the type name does not make its C type obvious: (graph_style_t int)
	(C-type->s7-type (cadr type))
	(let ((type-name (symbol->string type)))
	  (cond ((string-position "**" type-name)     ; any complicated C pointer is uninterpreted
		 'c_pointer)

		((string=? "s7_pointer" type-name)
		 's7_pointer)
		
		((string-position "char*" type-name)  ; but not char** (caught above)
		 'string)

		((or (string-position "*" type-name)  ; float* etc
		     (string-position "pointer" type-name))
		 'c_pointer)

		((assoc type-name '(("char" . character) 
				    ("bool" . boolean)) string-position)
		 => cdr)
		
		;; ((string-position "complex" type-name)
		;;  'complex)                              ; double complex or complex double (mus_edot_product in clm.c uses the latter)

		((or (string-position "float" type-name) 
		     (string-position "double" type-name)) 
		 'real)

		((or (string-position "int" type-name) 
		     (string-position "long" type-name) ; assuming not "long double" here so we need to look for it first (above)
		     (string-position "short" type-name) 
		     (string-position "size" type-name)
		     (string-position "byte" type-name)) 
		 'integer)

		(#t #t)))))

  (define (find-handler type choice)
    (cond ((assq (C-type->s7-type type) handlers) => choice) (else #t)))

  (define (C->s7-cast type)
    (find-handler type (lambda (p) (list-ref p 4))))
    
  (define (C->s7 type)
    (find-handler type cadddr))
    
  (define (s7->C type)
    (find-handler type caddr))

  (define (checker type)
    (find-handler type cadr))

  (define (signature->pl type)
    (case type
      ((integer?)   #\i)
      ((boolean?)   #\b)
      ((real?)      #\r)
      ((float?)     #\d)
      ((char?)      #\c)
      ((string?)    #\s)
      ((c-pointer?) #\x)
      (else         #\t)))

  (set! c-define-output-file-counter (+ c-define-output-file-counter 1))

  (let ((file-name (string-append *cload-directory* 
				  (if (and (> (length *cload-directory*) 0)
					   (not (char=? (string-ref *cload-directory* (- (length *cload-directory*) 1)) #\/)))
				      "/" "")
				  (or output-name (format #f "temp-s7-output-~D" c-define-output-file-counter)))))
    (let ((c-file-name (string-append file-name ".c"))
	  (o-file-name (string-append file-name ".o"))
	  (so-file-name (string-append file-name ".so"))
	  (init-name (if (string? output-name)
			 (string-append output-name "_init")
			 (string-append "init_" (number->string c-define-output-file-counter))))
	  (functions ())
	  (constants ())
	  (macros ())     ; these are protected by #ifdef ... #endif
	  (inits ())      ; C code (a string in s7) inserted in the library initialization function
	  (type-symbols ())
	  (p #f)
	  (pp (open-output-string))
	  (int-funcs ())        ; functions guaranteed to return int
	  (double-funcs ())     ; functions returning double, all args double
	  (double-int-funcs ()) ; functions return double, args are (integer double)
	  (sig-symbols (list (cons 'integer? 0) (cons 'boolean? 0) (cons 'real?  0) (cons 'float? 0) 
			     (cons 'char? 0) (cons 'string? 0) (cons 'c-pointer? 0) (cons 't 0)))
	  (signatures (make-hash-table)))
      
      (define make-signature 
	(let ((cload->signature 
	       (lambda* (type rtn)
		 (case (C-type->s7-type type)
		   ((real)      (if rtn 'float? 'real?))
		   ((integer)   'integer?)
		   ((string)    'string?)
		   ((boolean)   'boolean?)
		   ((character) 'char?)
		   ((c_pointer) 'c-pointer?)
		   (else #t)))))
	  (lambda (rtn args)
	    (let ((sig (list (cload->signature rtn #t)))
		  (cyclic #f))
	      (for-each
	       (lambda (arg)
		 (set! sig (cons (cload->signature arg) sig)))
	       args)
	      (let ((len (length sig)))
		(set! sig (do ((sig sig (cdr sig)))
			      ((not (and (pair? sig) 
					 (pair? (cdr sig))
					 (eq? (car sig) (cadr sig))))
			       sig)))
		(set! cyclic (not (= len (length sig)))))
	      (set! sig (cons cyclic (reverse sig)))      ; need to include cyclic in key else trailing same-type args are dropped from the signature
	      (unless (signatures sig)                    ; it's not in our collection yet
		(let ((pl (make-string (+ (if cyclic 3 2) (length sig))))
		      (loc (if cyclic 4 3)))
		  (set! (pl 0) #\p) 
		  (if cyclic
		      (begin (set! (pl 1) #\c) (set! (pl 2) #\l) (set! (pl 3) #\_))
		      (begin (set! (pl 1) #\l) (set! (pl 2) #\_)))
		  (for-each 
		   (lambda (typer)
		     (set! (pl loc) (signature->pl typer))
		     (let ((count (or (assq typer sig-symbols)
				      (assq 't sig-symbols))))
		       (set-cdr! count (+ (cdr count) 1)))
		     (set! loc (+ loc 1)))
		   (cdr sig))
		  (set! (signatures sig) pl)))
	      sig))))
      
      (define (initialize-c-file)
	;; C header stuff
	(set! p (open-output-file c-file-name))
	(format p "#include <stdlib.h>~%")
	(format p "#include <stdio.h>~%")
	(format p "#include <string.h>~%")
	(if (string? headers)
	    (format p "#include <~A>~%" headers)
	    (for-each
	     (lambda (header)
	       (format p "#include <~A>~%" header))
	     headers))
	(format p "#include \"s7.h\"~%~%")
	(format p "static s7_pointer fsym, s7_F, s7_unspec, ffunc, c_pointer_string, string_string, character_string, boolean_string, real_string, complex_string, integer_string;~%"))
      
      (define collides?
	(let ((all-names (hash-table)))
	  (lambda (name)
	    (if (hash-table-ref all-names name) 
		(format *stderr* "~A twice?~%" name)
		(hash-table-set! all-names name #t))
	    name)))

      (define (hyphen->space type)
	(let* ((name (symbol->string type))
	       (pos (char-position #\- name)))
	  (when pos
	    (string-set! name pos #\space)
	    (set! pos (char-position #\- name (+ pos 1)))
	    (if pos
		(string-set! name pos #\space)))
	  name))
	    
      (define (type->type-symbol type)
	(cond ((assoc type type-symbols) => cdr)
	      (else 
	       (let ((name (symbol->string type)))
		 (do ((len (length name))
		      (i 0 (+ i 1)))
		     ((= i len))
		   (if (memv (name i) '(#\* #\- #\space)) ; "struct tm*" for example
		       (set! (name i) #\_)))
		 (set! name (symbol name "_symbol"))
		 (set! type-symbols (cons (cons type name) type-symbols))
		 name))))
      
      (define add-one-function 
	(let ()
	  (define (sig-every? f sequence)
	    (do ((arg sequence (cdr arg)))
		((not (and (pair? arg)
			   (f (car arg))))
		 (null? arg))))

	  (lambda* (return-type name arg-types doc)
	    ;; (format *stderr* "~A ~A ~A~%" return-type name arg-types): double j0 (double) for example
	    ;; C function -> scheme
	    (let ((func-name (symbol->string (collides? name))))
	      (let ((num-args (length arg-types))
		    (base-name (string-append (if (> (length prefix) 0) prefix "s7_") "_" func-name)) ; not "g" -- collides with glib
		    (scheme-name (string-append prefix (if (> (length prefix) 0) ":" "") func-name)))
		
		(if (and (= num-args 1) 
			 (eq? (car arg-types) 'void))
		    (set! num-args 0))
		(format pp "~%/* -------- ~A -------- */~%" func-name)
		(format pp "static s7_pointer ~A(s7_scheme *sc, s7_pointer args)~%" base-name)
		(format pp "{~%")
		
		;; get the Scheme args, check their types, assign to local C variables
		(when (positive? num-args)
		  (format pp "  s7_pointer p, arg;~%")
		  (do ((i 0 (+ i 1))
		       (type arg-types (cdr type)))
		      ((= i num-args))
		    (format pp "  ~A ~A_~D;~%" (hyphen->space ((if (pair? (car type)) caar car) type)) base-name i))
		  (format pp "  p = args;~%")
		  (do ((i 0 (+ i 1))
		       (type arg-types (cdr type)))
		      ((= i num-args))
		    (let* ((nominal-type ((if (pair? (car type)) caar car) type))  ; double in the example
			   (true-type    ((if (pair? (car type)) cadar car) type))
			   (s7-type      (C-type->s7-type true-type)))             ; real
		      (format pp "  arg = s7_car(p);~%")
		      (if (eq? true-type 's7_pointer)
			  (format pp "    ~A_~D = arg;~%" base-name i)
			  (if (eq? s7-type 'c_pointer)
			      (format pp "  ~A_~D = (~A)s7_c_pointer_with_type(sc, arg, ~S, __func__, ~S);~%" 
				      base-name i 
				      (hyphen->space nominal-type)
				      (type->type-symbol nominal-type)  ;(symbol->string nominal-type)
				      (if (= num-args 1) 0 (+ i 1)))

			      (let ((function-name (if *cload-library-name*
						       (string-append "(" *cload-library-name* " '" scheme-name ")")
						       (if (> (length prefix) 0)
							   scheme-name
							   (substring base-name 4)))))
				(format pp "  if (~A(arg))~%" (checker true-type))
				(format pp "    ~A_~D = (~A)~A(~Aarg~A);~%"
					base-name i
					(hyphen->space nominal-type)
					(s7->C true-type)                               ; s7_number_to_real which requires 
					(if (memq s7-type '(boolean real))              ;   the extra sc arg
					    "sc, " 
					    "")
					(if (memq s7-type '(boolean real))              ;   the extra trailing caller arg
					    ", __func__" 
					    ""))
				(format pp "  else return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, ~S, ~D), ~D, arg, ~A_string));~%"
					function-name
					(length function-name)
					(if (= num-args 1) 0 (+ i 1))
					s7-type))))

		      (if (< i (- num-args 1))
			  (format pp "  p = s7_cdr(p);~%")))))
		
		;; return C value to Scheme
		(if (pair? return-type) 
		    (set! return-type (cadr return-type)))
		(let ((return-translator (C->s7 return-type)))
		  (format pp "  ")
		  (if (not (eq? return-translator #t))
		      (format pp "return("))
		  (if (symbol? return-translator)
		      (format pp "~A(sc, (~A)" return-translator (C->s7-cast return-type)))
		  (format pp "~A(" func-name)
		  (do ((i 0 (+ i 1)))
		      ((>= i (- num-args 1)))
		    (format pp "~A_~D, " base-name i))
		  (if (positive? num-args)
		      (format pp "~A_~D" base-name (- num-args 1)))
		  (format pp ")")
		  
		  (if (eq? return-translator 's7_make_c_pointer_with_type)
		      (format pp ", ~S, s7_F)" (type->type-symbol return-type))
		      (if (symbol? return-translator)
			  (format pp ")")))
		  (format pp (if (not (eq? return-translator #t))
				 ");~%"
				 ";~%  return(s7_unspec);~%"))
		  (format pp "}~%"))
		
		;; add optimizer connection
		(when (and (eq? return-type 'double)
			   (< num-args 5)
			   (sig-every? (lambda (p) (eq? p 'double)) arg-types)
			   (not (defined? (symbol scheme-name) (rootlet)))) ; see below, double-funcs entry not used if already defined
		  (let ((local-name #f))
		    (case num-args
		      ((0)
		       (set! local-name "_d")
		       (format pp "static s7_double ~A~A(void) {return(~A());}~%"
			       func-name local-name func-name))
		      ((1)
		       (set! local-name "_d_d")
		       (format pp "static s7_double ~A~A(s7_double x) {return(~A(x));}~%"
			       func-name local-name func-name))
		      ((2)
		       (set! local-name "_d_dd")
		       (format pp "static s7_double ~A~A(s7_double x1, s7_double x2) {return(~A(x1, x2));}~%"
			       func-name local-name func-name))
		      ((3)
		       (set! local-name "_d_ddd")
		       (format pp "static s7_double ~A~A(s7_double x1, s7_double x2, s7_double x3) {return(~A(x1, x2, x3));}~%"
			       func-name local-name func-name))
		      ((4)
		       (set! local-name "_d_dddd")
		       (format pp "static s7_double ~A~A(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(~A(x1, x2, x3, x4));}~%"
			       func-name local-name func-name)))
		    (set! double-funcs (cons (list func-name scheme-name local-name) double-funcs))))

		(when (and (memq return-type '(int size_t))        ; int (f int|double|void)
			   (not (defined? (symbol scheme-name) (rootlet))) ; see below, int-funcs entry not used if already defined
			   (or ;(= num-args 0)
			    (and (= num-args 1)
				 (memq (car arg-types) '(int size_t double)))
			    (and (= num-args 2)
				 (memq (car arg-types) '(int size_t))
				 (memq (cadr arg-types) '(int size_t)))))
		  (let ((local-name #f))
		    (case (car arg-types)
		      ((void)
		       (set! local-name "_i")
		       (format pp "static s7_int ~A~A(void) {return(~A());}~%" func-name local-name func-name))
		      ((double)
		       (set! local-name "_i_7d")
		       (format pp "static s7_int ~A~A(s7_scheme *sc, s7_double x) {return(~A(x));}~%" func-name local-name func-name))
		      ((int size_t)
		       (if (= num-args 1)
			   (begin
			     (set! local-name "_i_i")
			     (format pp "static s7_int ~A~A(s7_int i1) {return(~A(i1));}~%" func-name local-name (if (string=? func-name "abs") "llabs" func-name)))
			   (begin
			     (set! local-name "_i_ii")
			     (format pp "static s7_int ~A~A(s7_int i1, s7_int i2) {return(~A(i1, i2));}~%" func-name local-name func-name)))))
		    (set! int-funcs (cons (list func-name scheme-name local-name) int-funcs))))
		
		(when (and (eq? return-type 'double)
			   (= num-args 2)
			   (memq (car arg-types) '(int size_t))
			   (eq? (cadr arg-types) 'double))
		  (format pp "static s7_double ~A~A(s7_int x1, s7_double x2) {return(~A(x1, x2));}~%" func-name "_d_id" func-name)
		  (set! double-int-funcs (cons (list func-name scheme-name "_d_id") double-int-funcs)))
		
		;; other possibilities: d_7pi|pii p=double* etc piid=checks in s7 (assumes float-vector)
		;;   d_pd [lots of d_pdd, d_p, p_i and i_p]
		;;   but how to recognize the "p" portions? (d_7pi with p="s7_pointer" gets no hits in libgsl)
		;; libgsl: d_i: 15, d_ii: 5, [handled: d_id: 32], d_iid: 7, d_ddi: 4, d_idd: 10, d_idi: 6, i_ddd i_iii: 1, i_dddd: 4
		
		(format pp "~%")
		(set! functions (cons (list scheme-name base-name 
					    (if (and (string? doc)
						     (> (length doc) 0))
						doc
						(format #f "~A ~A~A" return-type func-name arg-types))
					    num-args 0 
					    (make-signature return-type arg-types))
				      functions)))))))
      
      (define (end-c-file)
	(when (pair? type-symbols)
	  (format p "static s7_pointer ")
	  (let ((len (length type-symbols))
		(loc 1))
	    (for-each
	     (lambda (sym)
	       (format p "~A~A~A" (cdr sym) (if (< loc len) (values "," " ") (values ";" #\newline)))
	       (set! loc (+ loc 1)))
	     type-symbols)))
	(newline p)

	(display (get-output-string pp) p)
	(close-output-port pp)

	;; now the init function
	;;   the new scheme variables and functions are placed in the current environment
	
	(format p "void ~A(s7_scheme *sc);~%" init-name)
	(format p "void ~A(s7_scheme *sc)~%" init-name)
	(format p "{~%")
	(format p "  s7_pointer cur_env;~%")

	(when (> (hash-table-entries signatures) 0)   ; maybe just constants (no functions)
	  (format p "  s7_pointer ")
	  (let ((pls (hash-table-entries signatures))
		(loc 1))
	    (for-each
	     (lambda (s)
	       (format p "~A~A~A" (cdr s) (if (< loc pls) (values "," " ") (values ";" #\newline)))
	       (set! loc (+ loc 1)))
	     signatures))
	  
	  (let ((syms ())
		(names ()))
	    (for-each
	     (lambda (q)
	       (when (positive? (cdr q))
		 (set! syms (cons (car q) syms))
		 (set! names (cons (signature->pl (car q)) names))))
	     sig-symbols)
	    (when (pair? syms)
	      (format p "  {~%    s7_pointer ~{~C~^, ~};~%" names)
	      (for-each
	       (lambda (name sym)
		 (format p (if (eq? sym 't)
			       "    t = s7_t(sc);~%"
			       (values "    ~C = s7_make_symbol(sc, ~S);~%" name (symbol->string sym)))))
	       names syms)))
	  (format p "~%")
	  (for-each
	   (lambda (sig)
	     (let ((siglen (length (cdar sig)))
		   (cyclic (char=? ((cdr sig) 1) #\c)))
	       (format p (if cyclic 
			     (values "    ~A = s7_make_circular_signature(sc, ~D, ~D" (cdr sig) (- siglen 1) siglen)
			     (values "    ~A = s7_make_signature(sc, ~D" (cdr sig) siglen)))
	       (format p "~{~^, ~C~}" (substring (cdr sig) (if cyclic 4 3)))
	       (format p ");~%")))
	   signatures)
	  (format p "  }~%~%"))

	(format p "  s7_F = s7_f(sc);~%")
	(format p "  s7_unspec = s7_unspecified(sc);~%")
	(format p "  string_string = s7_make_semipermanent_string(sc, \"a string\");~%")
	(format p "  c_pointer_string = s7_make_semipermanent_string(sc, \"a c-pointer\");~%")
	(format p "  character_string = s7_make_semipermanent_string(sc, \"a character\");~%")
	(format p "  boolean_string = s7_make_semipermanent_string(sc, \"a boolean\");~%")
	(format p "  real_string = s7_make_semipermanent_string(sc, \"a real\");~%")
	(format p "  complex_string = s7_make_semipermanent_string(sc, \"a complex number\");~%")
	(format p "  integer_string = s7_make_semipermanent_string(sc, \"an integer\");~%")

	(format p "  cur_env = s7_curlet(sc);~%") ; changed from s7_outlet(s7_curlet) 20-Aug-17
	
	;; send out any special initialization code
	(for-each
	 (lambda (init-str)
	   (format p "  ~A~%" init-str))
	 (reverse inits))

	(when (pair? type-symbols)
	  (newline p)
	  (for-each
	   (lambda (sym)
	     (format p "  ~S = s7_make_symbol(sc, ~S);~%" (cdr sym) (symbol->string (car sym))))
	   type-symbols))
	
	;; constants
	(when (pair? constants)
	  (format p "~%")
	  (for-each
	   (lambda (c)
	     (let* ((type (c 0))
		    (c-name (c 1))
		    (scheme-name (string-append prefix (if (> (length prefix) 0) ":" "") c-name))
		    (trans (C->s7 type)))
	       (if (eq? trans 's7_make_c_pointer_with_type)
		   (format p "  s7_define(sc, cur_env, s7_make_symbol(sc, ~S), ~A(sc, (~A)~A, s7_make_symbol(sc, ~S), s7_F));~%" 
			   scheme-name
			   trans
			   (C->s7-cast type)
			   c-name
			   (if (eq? type 'c-pointer) "void*" (symbol->string type)))
		   (format p "  s7_define(sc, cur_env, s7_make_symbol(sc, ~S), ~A(sc, (~A)~A));~%" 
			   scheme-name
			   trans
			   (C->s7-cast type)
			   c-name))))
	   constants))
	
	;; C macros -- need #ifdef name #endif wrapper
	(when (pair? macros)
	  (format p "~%")
	  (for-each
	   (lambda (c)
	     (let* ((type (c 0))
		    (c-name (c 1))
		    (scheme-name (string-append prefix (if (> (length prefix) 0) ":" "") c-name))
		    (trans (C->s7 type)))
	       (format p "#ifdef ~A~%" c-name)
	       (if (eq? trans 's7_make_c_pointer_with_type)
		   (format p "  s7_define(sc, cur_env, s7_make_symbol(sc, ~S), s7_make_c_pointer_with_type(sc, (~A)~A, s7_make_symbol(sc, \"~S\"), s7_F));~%" 
			   scheme-name
			   (C->s7-cast type)
			   c-name
			   type)
		   (format p "  s7_define(sc, cur_env, s7_make_symbol(sc, ~S), ~A(sc, (~A)~A));~%" 
			   scheme-name
			   trans
			   (C->s7-cast type)
			   c-name))
	       (format p "#endif~%")))
	   macros))
	
	;; functions
	(for-each
	 (lambda (f) 
	   (let ((scheme-name (f 0))
		 (base-name   (f 1))
		 (helpf       (f 2))
		 (num-args    (f 3))
		 (opt-args    (if (> (length f) 4) (f 4) 0))
		 (sig         (and (> (length f) 5) (f 5))))
	     (format p "~%  s7_define(sc, cur_env,~%            fsym = s7_make_symbol(sc, ~S),~%" scheme-name)
	     (format p "            ffunc = s7_make_typed_function_with_environment(sc, ~S, ~A, ~D, ~D, false, ~S, ~A, cur_env));~%"
		     scheme-name
		     base-name
		     num-args
		     opt-args
		     helpf
		     (if (pair? sig) (signatures sig) 'NULL))
	     (format p "  s7_symbol_set_initial_value(sc, fsym, ffunc);~%"))) ; not sure this is a good idea, added 24-May-24
	 functions)
	
	;; optimizer connection
	(when (pair? double-funcs)
	  (format p "~%  /* double optimizer connections */~%")
	  (for-each
	   (lambda (f)
	     (unless (defined? (symbol (cadr f)) (rootlet))
	       (format p "  s7_set~A_function(sc, s7_name_to_value(sc, ~S), ~A~A);~%" (caddr f) (cadr f) (car f) (caddr f))))
	   double-funcs))
	
	(when (pair? int-funcs)
	  (format p "~%  /* int optimizer connections */~%")
	  (for-each
	   (lambda (f)
	     (unless (defined? (symbol (cadr f)) (rootlet))
	       (format p "  s7_set~A_function(sc, s7_name_to_value(sc, ~S), ~A~A);~%" (caddr f) (cadr f) (car f) (caddr f))))
	   int-funcs))

	(when (pair? double-int-funcs)
	  (format p "~%  /* double-int optimizer connections */~%")
	  (for-each
	   (lambda (f)
	     (unless (defined? (symbol (cadr f)) (rootlet))
	       (format p "  s7_set~A_function(sc, s7_name_to_value(sc, ~S), ~A~A);~%" (caddr f) (cadr f) (car f) (caddr f))))
	   double-int-funcs))
	
	(format p "}~%")
	(close-output-port p)

	(unless (or (file-exists? "s7.h")
		    (not (pair? *load-path*)))
	  (set! *cload-cflags* (append *cload-cflags* (format #f " -I~A" (car *load-path*)))))
	
	;; now we have the module .c file -- make it into a shared object
	
	(cond ((provided? 'osx)
	       ;; I assume the caller is also compiled with these flags?
	       (system (format #f "~A -c ~A -o ~A ~A ~A" 
			       *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
	       (system (format #f "~A ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"  
			       ;; -undefined suppress is deprecated, but still needed! (libgsl), and the suggested fix, -ld64, is also deprecated
			       *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
	      
	      ((provided? 'freebsd)
	       (system (format #f "cc -fPIC -c ~A -o ~A ~A ~A" 
			       c-file-name o-file-name *cload-cflags* cflags))
	       (system (format #f "cc ~A -shared -o ~A ~A ~A" 
			       o-file-name so-file-name *cload-ldflags* ldflags)))
	      
	      ((provided? 'openbsd)
	       (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A" 
			       *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
	       (system (format #f "~A ~A -shared -o ~A ~A ~A" 
			       *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
	      
	      ((provided? 'sunpro_c) ; just guessing here...
	       (system (format #f "cc -c ~A -o ~A ~A ~A" 
			       c-file-name o-file-name *cload-cflags* cflags))
	       (system (format #f "cc ~A -G -o ~A ~A ~A" 
			       o-file-name so-file-name *cload-ldflags* ldflags)))
	      
	      ((or (provided? 'mingw) (provided? 'msys2)) ; from chai xiaoxiang
	       ;; you'll need dlfcn which can be installed with pacman, and remember to build s7 with -DWITH_C_LOADER=1
	       ;; in msys2:  gcc s7.c -o s7 -DWITH_MAIN -DWITH_C_LOADER=1 -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
	       (system (format #f "gcc ~A s7.lib -shared -o ~A -I. ~A ~A"
			       c-file-name so-file-name cflags ldflags)))
	       
	      (else ; linux netbsd
	       (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A" 
			       *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
	       (system (format #f "~A ~A -shared -o ~A ~A ~A" 
			       *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))))
      
      (define handle-declaration 
	(let ()
	  (define (add-one-constant type name)
	    ;; C constant -> scheme
	    (let ((c-type (if (pair? type) (cadr type) type)))
	      (if (symbol? name)
		  (set! constants (cons (list c-type (symbol->string (collides? name))) constants))
		  (for-each 
		   (lambda (c)
		     (set! constants (cons (list c-type (symbol->string (collides? c))) constants)))
		   name))))
	  
	  (define (add-one-macro type name)
	    ;; C macro (with definition check) -> scheme
	    (let ((c-type (if (pair? type) (cadr type) type)))
	      (if (symbol? name)
		  (set! macros (cons (list c-type (symbol->string (collides? name))) macros))
		  (for-each 
		   (lambda (c)
		     (set! macros (cons (list c-type (symbol->string (collides? c))) macros)))
		   name))))
	  
	  (define (check-doc func-data)
	    (let ((doc (caddr func-data)))
	      (if (and (string? doc)
		       (> (length doc) 0))
		  func-data
		  (append (list (car func-data) (cadr func-data) (car func-data)) (cdddr func-data)))))
	  
	  (lambda (func)
	    ;; functions
	    (if (pair? func)
		(if (>= (length func) 3)
		    (apply add-one-function func)
		    (case (car func)
		      ((in-C)       (format pp "~A~%" (cadr func)))
		      ((C-init)     (set! inits (cons (cadr func) inits)))
		      ((C-macro)    (apply add-one-macro (cadr func)))
		      ((C-function) (collides? (caadr func)) (set! functions (cons (check-doc (cadr func)) functions)))
		      (else         (apply add-one-constant func))))
		(error 'wrong-type-arg "~S (func arg to handle-declaration in cload.scm) should be a pair" func)))))
      
      
      ;; c-define-1 (called in c-define macro above)
      (unless (and output-name
		   (file-exists? c-file-name)
		   (file-exists? so-file-name)
		   (provided? 'system-extras)
		   (>= (file-mtime so-file-name) (file-mtime c-file-name))
		   (not (and (file-exists? (port-filename))
			     (< (file-mtime so-file-name) (file-mtime (port-filename))))))
	(format *stderr* "writing ~A~%" c-file-name)
	;; write a new C file and compile it
	(initialize-c-file)
	
	(if (and (pair? (cdr function-info))
		 (symbol? (cadr function-info)))
	    (handle-declaration function-info)
	    (for-each handle-declaration function-info))
	
	(end-c-file)
	(delete-file o-file-name))
      
      ;; load the object file, clean up
      (varlet cur-env 'init_func (string->symbol init-name))
      (format *stderr* "loading ~A~%" so-file-name)
      (load so-file-name cur-env))))


#|
(let ((cd (symbol "complex double"))
      (cd* (symbol "complex double *")))
  (c-define (list cd 'mus_edot_product (list cd cd* 'int))))

;complex double mus_edot_product(complex double freq, complex double *data, mus_long_t size)
|#