init commit
This commit is contained in:
divorce committed
commit
6300e42bb2
28 files changed
+104005
No files matched your search
@@ -0,0 +1,798 @@
|
||||
(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 #f s7_make_complex s7_Complex)
|
||||
;; the typedef is around line 6116 in s7.c, but we also need s7_complex which requires the s7_Complex type
|
||||
;; xen.h uses (s7_real_part(a) + s7_imag_part(a) * _Complex_I) instead since c++ won't let use define s7_Complex in s7.h
|
||||
|
||||
'(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 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(sc))" (type->type-symbol return-type))
|
||||
(if (symbol? return-translator)
|
||||
(format pp ")")))
|
||||
(format pp (if (not (eq? return-translator #t))
|
||||
");~%"
|
||||
";~% return(s7_unspecified(sc));~%"))
|
||||
(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)
|
||||
|
||||
(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 " 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(sc)));~%"
|
||||
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(sc)));~%"
|
||||
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,~% s7_make_symbol(sc, ~S),~%" scheme-name)
|
||||
(format p " s7_make_typed_function(sc, ~S, ~A, ~D, ~D, false, ~S, ~A));~%"
|
||||
scheme-name
|
||||
base-name
|
||||
num-args
|
||||
opt-args
|
||||
helpf
|
||||
(if (pair? sig) (signatures sig) 'NULL))))
|
||||
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"
|
||||
*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)
|
||||
|#
|
||||
+137
@@ -0,0 +1,137 @@
|
||||
; enf.scm -- pure Scheme enfilade reference
|
||||
(define (make-enfilade) (vector 'enfilade '() '()))
|
||||
(define (enfilade-children e) (vector-ref e 1))
|
||||
(define (enfilade-values e) (vector-ref e 2))
|
||||
(define (set-enfilade-children! e x) (vector-set! e 1 x))
|
||||
(define (set-enfilade-values! e x) (vector-set! e 2 x))
|
||||
|
||||
(define (assoc-number k xs)
|
||||
(cond ((null? xs) #f)
|
||||
((= k (caar xs)) (car xs))
|
||||
(else (assoc-number k (cdr xs)))))
|
||||
|
||||
(define (alist-put xs k v)
|
||||
(let ((p (assoc-number k xs)))
|
||||
(if p (begin (set-cdr! p v) xs) (cons (cons k v) xs))))
|
||||
|
||||
(define (alist-remove xs k)
|
||||
(cond ((null? xs) '())
|
||||
((= k (caar xs)) (cdr xs))
|
||||
(else (cons (car xs) (alist-remove (cdr xs) k)))))
|
||||
|
||||
(define (insert-number n xs)
|
||||
(cond ((null? xs) (list n))
|
||||
((<= n (car xs)) (cons n xs))
|
||||
(else (cons (car xs) (insert-number n (cdr xs))))))
|
||||
|
||||
(define (sort-numbers xs)
|
||||
(if (null? xs) '()
|
||||
(insert-number (car xs) (sort-numbers (cdr xs)))))
|
||||
|
||||
(define (unique-numbers xs)
|
||||
(cond ((null? xs) '())
|
||||
((and (pair? (cdr xs)) (= (car xs) (cadr xs)))
|
||||
(unique-numbers (cdr xs)))
|
||||
(else (cons (car xs) (unique-numbers (cdr xs))))))
|
||||
|
||||
(define (tumbler-parse s)
|
||||
(if (= (string-length s) 0) '()
|
||||
(let loop ((i 0) (start 0) (out '()))
|
||||
(if (= i (string-length s))
|
||||
(reverse (cons (string->number (substring s start i)) out))
|
||||
(if (char=? (string-ref s i) #\.)
|
||||
(loop (+ i 1) (+ i 1)
|
||||
(cons (string->number (substring s start i)) out))
|
||||
(loop (+ i 1) start out))))))
|
||||
|
||||
(define (tumbler->list t)
|
||||
(cond ((string? t) (tumbler-parse t))
|
||||
((list? t) t)
|
||||
(else (error 'wrong-type-arg "tumbler must be a string or list"))))
|
||||
|
||||
(define (tumbler-compare a b)
|
||||
(let loop ((a (tumbler->list a)) (b (tumbler->list b)))
|
||||
(cond ((and (null? a) (null? b)) 0)
|
||||
((null? a) -1)
|
||||
((null? b) 1)
|
||||
((< (car a) (car b)) -1)
|
||||
((> (car a) (car b)) 1)
|
||||
(else (loop (cdr a) (cdr b))))))
|
||||
|
||||
(define (enfilade-get e key)
|
||||
(let ((v (assoc-number key (enfilade-values e)))
|
||||
(c (assoc-number key (enfilade-children e))))
|
||||
(append (if v (list (cdr v)) '())
|
||||
(if c (enfilade-get-range (cdr c)) '()))))
|
||||
|
||||
(define (enfilade-get-by-tumbler e t)
|
||||
(let loop ((node e) (parts (tumbler->list t)))
|
||||
(cond ((null? parts) (enfilade-get-range node))
|
||||
((null? (cdr parts)) (enfilade-get node (car parts)))
|
||||
(else
|
||||
(let ((c (assoc-number (car parts) (enfilade-children node))))
|
||||
(if c (loop (cdr c) (cdr parts)) '()))))))
|
||||
|
||||
(define (enfilade-put-data e t datum)
|
||||
(let ((parts (tumbler->list t)))
|
||||
(if (null? parts) (error 'out-of-range "empty tumbler"))
|
||||
(let loop ((node e) (parts parts))
|
||||
(if (null? (cdr parts))
|
||||
(set-enfilade-values!
|
||||
node (alist-put (enfilade-values node) (car parts) datum))
|
||||
(let* ((k (car parts))
|
||||
(p (assoc-number k (enfilade-children node)))
|
||||
(child (if p (cdr p) (make-enfilade))))
|
||||
(if (not p)
|
||||
(set-enfilade-children!
|
||||
node (alist-put (enfilade-children node) k child)))
|
||||
(loop child (cdr parts)))))
|
||||
datum))
|
||||
|
||||
(define (enfilade-empty? e)
|
||||
(and (null? (enfilade-children e)) (null? (enfilade-values e))))
|
||||
|
||||
(define (enfilade-remove e t)
|
||||
(let ((parts (tumbler->list t)))
|
||||
(if (null? parts) #f
|
||||
(let remove-at ((node e) (parts parts))
|
||||
(let ((k (car parts)))
|
||||
(if (null? (cdr parts))
|
||||
(if (assoc-number k (enfilade-values node))
|
||||
(begin
|
||||
(set-enfilade-values!
|
||||
node (alist-remove (enfilade-values node) k))
|
||||
#t)
|
||||
#f)
|
||||
(let ((p (assoc-number k (enfilade-children node))))
|
||||
(if (not p) #f
|
||||
(let* ((child (cdr p))
|
||||
(removed (remove-at child (cdr parts))))
|
||||
(if (and removed (enfilade-empty? child))
|
||||
(set-enfilade-children!
|
||||
node (alist-remove (enfilade-children node) k)))
|
||||
removed)))))))))
|
||||
|
||||
(define (enfilade-keys e)
|
||||
(unique-numbers
|
||||
(sort-numbers
|
||||
(append (map car (enfilade-values e))
|
||||
(map car (enfilade-children e))))))
|
||||
|
||||
(define (enfilade-get-range e . bounds)
|
||||
(let ((start (if (null? bounds) #f (car bounds)))
|
||||
(end (if (or (null? bounds) (null? (cdr bounds))) #f (cadr bounds))))
|
||||
(let loop ((ks (enfilade-keys e)) (out '()))
|
||||
(if (null? ks) out
|
||||
(let ((k (car ks)))
|
||||
(loop (cdr ks)
|
||||
(if (and (or (not start) (>= k start))
|
||||
(or (not end) (<= k end)))
|
||||
(append out (enfilade-get e k))
|
||||
out)))))))
|
||||
|
||||
; Example:
|
||||
; (define e (make-enfilade))
|
||||
; (enfilade-put-data e "1.2.3" 42)
|
||||
; (enfilade-put-data e "1.2.4" 43)
|
||||
; (enfilade-get-by-tumbler e "1.2") ; => (42 43)
|
||||
+1880
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,34 @@
|
||||
;;; libdl.scm
|
||||
;;;
|
||||
;;; tie the dynamic loader library into the *libdl* environment
|
||||
|
||||
(require cload.scm)
|
||||
(provide 'libdl.scm)
|
||||
|
||||
;; if loading from a different directory, pass that info to C
|
||||
(let ((directory (let ((current-file (port-filename)))
|
||||
(and (memv (current-file 0) '(#\/ #\~))
|
||||
(substring current-file 0 (- (length current-file) 9))))))
|
||||
(when (and directory (not (member directory *load-path*)))
|
||||
(set! *load-path* (cons directory *load-path*)))
|
||||
(with-let (rootlet)
|
||||
(require cload.scm))
|
||||
(when (and directory (not (string-position directory *cload-cflags*)))
|
||||
(set! *cload-cflags* (string-append "-I" directory " " *cload-cflags*))))
|
||||
|
||||
|
||||
(if (not (defined? '*libdl*))
|
||||
(define *libdl*
|
||||
(with-let (unlet)
|
||||
(set! *libraries* (cons (cons "libdl.scm" (curlet)) *libraries*))
|
||||
(set! *cload-library-name* "*libdl*")
|
||||
(c-define '((void* dlopen (char* int))
|
||||
(int dlclose (void*))
|
||||
(void* dlsym (void* char*))
|
||||
(char* dlerror (void))
|
||||
(C-macro (int (RTLD_LAZY RTLD_NOW RTLD_BINDING_MASK RTLD_NOLOAD RTLD_DEEPBIND RTLD_GLOBAL RTLD_LOCAL RTLD_NODELETE))))
|
||||
"" "dlfcn.h" "" "" "libdl_s7")
|
||||
(curlet))))
|
||||
|
||||
*libdl*
|
||||
;; the loader will return *libdl*
|
||||
Reference in new issue
Block a user