Add start of Larceny support
This commit is contained in:
parent
37eadb0f91
commit
3eb86782be
136
foreign/c.scm
136
foreign/c.scm
|
|
@ -65,69 +65,79 @@
|
|||
(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")))))
|
||||
(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))
|
||||
(cond-expand
|
||||
(i386
|
||||
(list
|
||||
"/lib/i386-linux-gnu"
|
||||
"/usr/lib/i386-linux-gnu"
|
||||
"/lib32"
|
||||
"/usr/lib32"))
|
||||
(else
|
||||
(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"
|
||||
; 32-bit
|
||||
)))))))
|
||||
(auto-load-versions (list ""))
|
||||
(paths (append auto-load-paths additional-paths))
|
||||
(versions (append additional-versions auto-load-versions))
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
(foreign c ikarus-primitives)))
|
||||
(kawa (import (foreign c kawa-primitives)))
|
||||
;(mit-scheme (import (foreign c mit-scheme-primitives)))
|
||||
;(larceny (import (foreign c larceny-primitives)))
|
||||
(larceny (import (foreign c larceny-primitives)))
|
||||
(mosh (import (only (mosh) include)
|
||||
(foreign c mosh-primitives)))
|
||||
(racket (import (foreign c racket-primitives)))
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@
|
|||
(or (equal? object #f) ; False can be null pointer
|
||||
(pointer? object))))
|
||||
|
||||
(define pffi-type->native-type
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
|
|
@ -137,7 +137,7 @@
|
|||
((equal? type 'pointer-address) '(maybe-null pointer void*))
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(maybe-null pointer void*))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
;; define-c-procedure
|
||||
|
||||
|
|
|
|||
|
|
@ -4,9 +4,31 @@
|
|||
(require 'foreign-cenums)
|
||||
(require 'foreign-stdlib)
|
||||
(require 'foreign-sugar)
|
||||
(require 'system-interface)
|
||||
;(require 'system-interface)
|
||||
|
||||
(define (type->native-type type)
|
||||
(cond ((equal? type 'int8) 'char)
|
||||
((equal? type 'uint8) 'uchar)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'ushort)
|
||||
((equal? type 'int32) 'int)
|
||||
((equal? type 'uint32) 'uint)
|
||||
((equal? type 'int64) 'long)
|
||||
((equal? type 'uint64) 'ulong)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'uchar)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'ushort)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'uint)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'ulong)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
(error "Unsupported type: " type)))
|
||||
|
||||
;; FIXME
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
|
|
@ -27,50 +49,54 @@
|
|||
((eq? type 'unsigned-long) 4)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) sizeof:pointer)
|
||||
((eq? type 'pointer) 8)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) sizeof:pointer)
|
||||
((eq? type 'callback) 8)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define align-of-type size-of-type)
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
;(void*? object)
|
||||
(number? object)))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (headers path . options)
|
||||
(lambda (path . options)
|
||||
(foreign-file path)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte)))
|
||||
;; FIXME
|
||||
#;(syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte)
|
||||
#t
|
||||
))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8))))
|
||||
;; FIXME
|
||||
#;(syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8))
|
||||
#t
|
||||
))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer)))
|
||||
;; FIXME
|
||||
#;(syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer)
|
||||
#t
|
||||
))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer))))
|
||||
;; FIXME
|
||||
#;(syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer))
|
||||
#t
|
||||
))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
0
|
||||
|
||||
#;(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
0
|
||||
#;(make-c-callback return-type argument-types procedure)))))
|
||||
(foreign-procedure (symbol->string c-name)
|
||||
(map type->native-type argument-types)
|
||||
(type->native-type return-type))))))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@
|
|||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
define-c-callback
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
|
|
|
|||
35
test.scm
35
test.scm
|
|
@ -39,23 +39,36 @@
|
|||
|
||||
(test-assert libc)
|
||||
|
||||
(define-c-library c-testlib
|
||||
'("libtest.h")
|
||||
"test"
|
||||
'((additional-paths ("." "./tests"))))
|
||||
|
||||
(define-c-procedure c-abs libc 'abs 'int '(int))
|
||||
(test-equal (c-abs -2) 2)
|
||||
|
||||
(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '())
|
||||
(c-takes-no-args)
|
||||
;; Skip these tests on 32 bit implementations
|
||||
(test-skip (cond-expand (i386 1) (else 0)))
|
||||
(cond-expand
|
||||
(i386 #t)
|
||||
(else
|
||||
(define-c-library c-testlib
|
||||
'("libtest.h")
|
||||
"test"
|
||||
'((additional-paths ("." "./tests"))))))
|
||||
|
||||
(define-c-procedure c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
|
||||
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
|
||||
(test-equal takes-no-args-returns-int-result 0)
|
||||
(cond-expand
|
||||
(i386 #t)
|
||||
(else
|
||||
(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '())
|
||||
(c-takes-no-args)))
|
||||
|
||||
|
||||
(cond-expand
|
||||
(i386 #t)
|
||||
(else
|
||||
(define-c-procedure c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
|
||||
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
|
||||
(test-equal takes-no-args-returns-int-result 0)))
|
||||
|
||||
(test-end "define-c-library")
|
||||
|
||||
|
||||
(test-begin "make-c-bytevector and c-bytevector?")
|
||||
(define bytes (make-c-bytevector 100))
|
||||
(test-assert (c-bytevector? bytes))
|
||||
|
|
@ -77,7 +90,7 @@
|
|||
(test-equal (c-bytevector-u8-ref u8-pointer 0) 42)
|
||||
|
||||
(test-end "c-bytevector-u8-set! and c-bytevector-u8-ref")
|
||||
|
||||
#|
|
||||
|
||||
(test-begin "c-bytevector-pointer-set! and c-bytevector-pointer-ref")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue