367 lines
15 KiB
Scheme
367 lines
15 KiB
Scheme
(define c-type-signed?
|
|
(lambda (type)
|
|
(if (member type '(int8 int16 int32 int64 char short int long float double))
|
|
#t
|
|
#f)))
|
|
|
|
(define c-type-unsigned?
|
|
(lambda (type)
|
|
(if (member type '(uint8 uint16 uint32 uint64 unsigned-char unsigned-short unsigned-int unsigned-long))
|
|
#t
|
|
#f)))
|
|
|
|
(define c-type-size
|
|
(lambda (type)
|
|
(size-of-type type)))
|
|
|
|
(define c-type-align
|
|
(lambda (type)
|
|
(align-of-type type)))
|
|
|
|
(define foreign-c:string-split
|
|
(lambda (str mark)
|
|
(let* ((str-l (string->list str))
|
|
(res (list))
|
|
(last-index 0)
|
|
(index 0)
|
|
(splitter (lambda (c)
|
|
(cond ((char=? c mark)
|
|
(begin
|
|
(set! res (append res (list (string-copy str last-index index))))
|
|
(set! last-index (+ index 1))))
|
|
((equal? (length str-l) (+ index 1))
|
|
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
|
(set! index (+ index 1)))))
|
|
(for-each splitter str-l)
|
|
res)))
|
|
|
|
(cond-expand
|
|
(gambit #t) ; Defined in gambit.scm
|
|
(chicken
|
|
(define-syntax define-c-library
|
|
(syntax-rules ()
|
|
((_ scheme-name headers object-name options)
|
|
(begin
|
|
(define scheme-name #t)
|
|
(shared-object-load headers))))))
|
|
(cyclone #t) ; Defined in cyclone.scm
|
|
(else
|
|
(define-syntax define-c-library
|
|
(syntax-rules ()
|
|
((_ scheme-name headers object-name options)
|
|
(define scheme-name
|
|
(let* ((internal-options (if (null? 'options)
|
|
(list)
|
|
(cadr 'options)))
|
|
(additional-paths (if (assoc 'additional-paths internal-options)
|
|
(cadr (assoc 'additional-paths internal-options))
|
|
(list)))
|
|
(additional-versions (if (assoc 'additional-versions internal-options)
|
|
(map (lambda (version)
|
|
(if (number? version)
|
|
(number->string version)
|
|
version))
|
|
(cadr (assoc 'additional-versions internal-options)))
|
|
(list)))
|
|
(slash (cond-expand (windows (string #\\)) (else "/")))
|
|
(auto-load-paths
|
|
(cond-expand
|
|
(windows
|
|
(append
|
|
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
|
|
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
|
|
(list))
|
|
(if (get-environment-variable "SYSTEM")
|
|
(list (get-environment-variable "SYSTEM"))
|
|
(list))
|
|
(if (get-environment-variable "WINDIR")
|
|
(list (get-environment-variable "WINDIR"))
|
|
(list))
|
|
(if (get-environment-variable "WINEDLLDIR0")
|
|
(list (get-environment-variable "WINEDLLDIR0"))
|
|
(list))
|
|
(if (get-environment-variable "SystemRoot")
|
|
(list (string-append
|
|
(get-environment-variable "SystemRoot")
|
|
slash
|
|
"system32"))
|
|
(list))
|
|
(list ".")
|
|
(if (get-environment-variable "PATH")
|
|
(foreign-c:string-split (get-environment-variable "PATH") #\;)
|
|
(list))
|
|
(if (get-environment-variable "PWD")
|
|
(list (get-environment-variable "PWD"))
|
|
(list))))
|
|
(else
|
|
(append
|
|
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
|
|
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
|
|
(list))
|
|
; Guix
|
|
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
|
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
|
|
"")
|
|
"/run/current-system/profile/lib")
|
|
; Debian
|
|
(if (get-environment-variable "LD_LIBRARY_PATH")
|
|
(foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
|
|
(list))
|
|
(list
|
|
;;; x86-64
|
|
; Debian
|
|
"/lib/x86_64-linux-gnu"
|
|
"/usr/lib/x86_64-linux-gnu"
|
|
"/usr/local/lib"
|
|
; Fedora/Alpine
|
|
"/usr/lib"
|
|
"/usr/lib64"
|
|
;;; aarch64
|
|
; Debian
|
|
"/lib/aarch64-linux-gnu"
|
|
"/usr/lib/aarch64-linux-gnu"
|
|
"/usr/local/lib"
|
|
; Fedora/Alpine
|
|
"/usr/lib"
|
|
"/usr/lib64"
|
|
; NetBSD
|
|
"/usr/pkg/lib"
|
|
; Haiku
|
|
"/boot/system/lib")))))
|
|
(auto-load-versions (list ""))
|
|
(paths (append auto-load-paths additional-paths))
|
|
(versions (append additional-versions auto-load-versions))
|
|
(platform-lib-prefix (cond-expand (windows "") (else "lib")))
|
|
(platform-file-extension (cond-expand (windows ".dll") (else ".so")))
|
|
(shared-object #f)
|
|
(searched-paths (list)))
|
|
(for-each
|
|
(lambda (path)
|
|
(for-each
|
|
(lambda (version)
|
|
(let ((library-path
|
|
(string-append path
|
|
slash
|
|
platform-lib-prefix
|
|
object-name
|
|
(cond-expand
|
|
(windows "")
|
|
(else platform-file-extension))
|
|
(if (string=? version "")
|
|
""
|
|
(string-append
|
|
(cond-expand (windows "-")
|
|
(else "."))
|
|
version))
|
|
(cond-expand
|
|
(windows platform-file-extension)
|
|
(else ""))))
|
|
(library-path-without-suffixes (string-append path
|
|
slash
|
|
platform-lib-prefix
|
|
object-name)))
|
|
(set! searched-paths (append searched-paths (list library-path)))
|
|
(when (and (not shared-object)
|
|
(file-exists? library-path))
|
|
(set! shared-object
|
|
(cond-expand (racket library-path-without-suffixes)
|
|
(else library-path))))))
|
|
versions))
|
|
paths)
|
|
(if (not shared-object)
|
|
(begin
|
|
(display "Could not load shared object: ")
|
|
(write (list (cons 'object object-name)
|
|
(cons 'paths paths)
|
|
(cons 'platform-file-extension platform-file-extension)
|
|
(cons 'versions versions)))
|
|
(newline)
|
|
(display "Searched paths: ")
|
|
(write searched-paths)
|
|
(newline)
|
|
(exit 1))
|
|
(cond-expand
|
|
(stklos shared-object)
|
|
(else (shared-object-load shared-object
|
|
`((additional-versions ,additional-versions)))))))))))))
|
|
|
|
(cond-expand
|
|
(windows
|
|
(define libc-name "ucrtbase"))
|
|
(else
|
|
(define libc-name
|
|
(cond ;((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
|
|
(else "c")))))
|
|
|
|
|
|
(define-c-library libc
|
|
'("stdlib.h" "stdio.h" "string.h")
|
|
libc-name
|
|
'((additional-versions ("0" "6"))))
|
|
|
|
;(define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
|
|
(cond-expand
|
|
(gambit
|
|
(define c-memset-address->pointer
|
|
(c-lambda (unsigned-int64 unsigned-int8 int)
|
|
(pointer void)
|
|
"___return(memset((void*)___arg1, ___arg2, ___arg3));")))
|
|
(chicken
|
|
(define c-memset-address->pointer
|
|
(lambda (address value offset)
|
|
(address->pointer address))))
|
|
(else
|
|
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))))
|
|
|
|
(cond-expand
|
|
(gambit
|
|
(define c-memset-pointer->address
|
|
(c-lambda ((pointer void) unsigned-int8 int)
|
|
unsigned-int64
|
|
"___return((uint64_t)memset(___arg1, ___arg2, ___arg3));")))
|
|
(chicken (define c-memset-pointer->address
|
|
(lambda (pointer value offset)
|
|
(pointer->address pointer))))
|
|
(else (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))))
|
|
;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
|
|
;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
|
|
(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
|
|
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
|
|
|
|
(define make-c-bytevector
|
|
(lambda (k . byte)
|
|
(if (null? byte)
|
|
(c-malloc k)
|
|
(bytevector->c-bytevector (make-bytevector k (car byte))))))
|
|
|
|
(define c-bytevector
|
|
(lambda bytes
|
|
(bytevector->c-bytevector (apply bytevector bytes))))
|
|
|
|
(cond-expand
|
|
(else (define-c-procedure c-free libc 'free 'void '(pointer))))
|
|
|
|
(define bytevector->c-bytevector
|
|
(lambda (bytes)
|
|
(letrec* ((bytes-length (bytevector-length bytes))
|
|
(pointer (make-c-bytevector bytes-length))
|
|
(looper (lambda (index)
|
|
(when (< index bytes-length)
|
|
(c-bytevector-u8-set! pointer
|
|
index
|
|
(bytevector-u8-ref bytes index))
|
|
(looper (+ index 1))))))
|
|
(looper 0)
|
|
pointer)))
|
|
|
|
(define c-bytevector->bytevector
|
|
(lambda (pointer size)
|
|
(letrec* ((bytes (make-bytevector size))
|
|
(looper (lambda (index)
|
|
(let ((byte (c-bytevector-u8-ref pointer index)))
|
|
(if (= index size)
|
|
bytes
|
|
(begin
|
|
(bytevector-u8-set! bytes index byte)
|
|
(looper (+ index 1))))))))
|
|
(looper 0))))
|
|
|
|
(define c-string-length
|
|
(lambda (bytevector-var)
|
|
(c-strlen bytevector-var)))
|
|
|
|
(define c-utf8->string
|
|
(lambda (c-bytevector)
|
|
(when (c-null? c-bytevector)
|
|
(error "Can not turn null pointer into string" c-bytevector))
|
|
(let ((size (c-strlen c-bytevector)))
|
|
(utf8->string (c-bytevector->bytevector c-bytevector size)))))
|
|
|
|
(define string->c-utf8
|
|
(lambda (string-var)
|
|
(bytevector->c-bytevector
|
|
(string->utf8 (string-append string-var (string #\null))))))
|
|
|
|
(cond-expand
|
|
;; FIXME
|
|
(chicken
|
|
(define make-c-null
|
|
(lambda ()
|
|
(address->pointer 0))))
|
|
;; FIXME
|
|
(kawa
|
|
(define make-c-null
|
|
(lambda ()
|
|
(static-field java.lang.foreign.MemorySegment 'NULL))))
|
|
;(chibi #t)
|
|
(else (define make-c-null
|
|
(lambda ()
|
|
(cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
|
|
(free-bytes pointer)
|
|
pointer))
|
|
(else (c-memset-address->pointer 0 0 0)))))))
|
|
|
|
(cond-expand
|
|
;; FIXME
|
|
(chicken
|
|
(define c-null?
|
|
(lambda (pointer)
|
|
(if (and (not (pointer? pointer))
|
|
pointer)
|
|
#f
|
|
(or (not pointer) ; #f counts as null pointer on Chicken
|
|
(= (pointer->address pointer) 0))))))
|
|
;; FIXME
|
|
(kawa
|
|
(define c-null?
|
|
(lambda (pointer)
|
|
(invoke pointer 'equals (make-c-null)))))
|
|
;; FIXME
|
|
(chibi #t) ;; In chibi-primitives.stub
|
|
(gauche (define c-null? pointer-null?))
|
|
(stklos (define c-null?
|
|
(lambda (pointer)
|
|
(cond ((void? pointer) #t)
|
|
((= (c-memset-pointer->address pointer 0 0) 0) #t)
|
|
(else #f)))))
|
|
(else (define c-null?
|
|
(lambda (pointer)
|
|
(if (c-bytevector? pointer)
|
|
(= (c-memset-pointer->address pointer 0 0) 0)
|
|
#f)))))
|
|
|
|
(define c-bytevector->address
|
|
(lambda (c-bytevector)
|
|
(c-memset-pointer->address c-bytevector 0 0)))
|
|
|
|
(define address->c-bytevector
|
|
(lambda (address)
|
|
(c-memset-address->pointer address 0 0)))
|
|
|
|
#;(define c-bytevector-pointer-set!
|
|
(lambda (c-bytevector k pointer)
|
|
(c-bytevector-uint-set! c-bytevector
|
|
0
|
|
(c-bytevector->address pointer)
|
|
(native-endianness)
|
|
(c-type-size 'pointer))))
|
|
|
|
#;(define c-bytevector-pointer-ref
|
|
(lambda (c-bytevector k)
|
|
(address->c-bytevector (c-bytevector-uint-ref c-bytevector
|
|
0
|
|
(native-endianness)
|
|
(c-type-size 'pointer)))))
|
|
|
|
(cond-expand
|
|
;(kawa #t) ; Defined in kawa.scm
|
|
(else (define-syntax call-with-address-of
|
|
(syntax-rules ()
|
|
((_ input-pointer thunk)
|
|
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
|
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
|
|
(let ((result (apply thunk (list address-pointer))))
|
|
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
|
|
(c-free address-pointer)
|
|
result)))))))
|