Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added init script for chicken-install stuff for guix

This commit is contained in:
retropikzel 2024-05-17 17:34:02 +03:00
parent 5c327c8095
commit 75213ab432
12 changed files with 151 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -13,6 +13,8 @@ import
test/import
pffi-define
test/pffi-define
size-of
test/size-of
retropikzel/pffi/*/*.c
retropikzel/pffi/*/*.o*
retropikzel/pffi/*/*.so

16
Makefile
View File

@ -1,4 +1,4 @@
.PHONY: test/import.scm test/import.scm test/pffi-define.scm
.PHONY: test/import.scm test/import.scm test/pffi-define.scm test/size-of.scm
VERSION=v0-1-0
SASH=sash -c -r7 -L .
@ -32,8 +32,8 @@ build-main-chicken:
${CHICKEN} -sJ retropikzel.pffi.${VERSION}.main.scm
build-main-gambit:
#${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm
#${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld
${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm
${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld
#cp retropikzel/pffi/${VERSION}/*.o* test/
build-main-gerbil:
@ -60,24 +60,26 @@ test/import.scm: clean build
#${RACKET} $@
${STKLOS} $@
${KAWA} $@
#${CYCLONE} $@ && test/import
${CYCLONE} $@ && test/import
#${GAMBIT} -exe $@ && ./test/import
${CHICKEN} $@ && ./test/import
#${GERBIL} $@
test/import.scm: clean build
${GAMBIT} -exe $@ && ./test/import
test/pffi-define.scm: clean build
${SASH} $@
${GUILE} $@
${KAWA} $@
${CHICKEN} -L -lcurl $@ && ./test/pffi-define
test/pffi-define.scm: clean build
${CHICKEN} $@ && ./test/pffi-define
${CYCLONE} -CLNK -lcurl $@ && test/pffi-define
test/size-of.scm:
${SASH} $@
${GUILE} $@
#${RACKET} $@
#${STKLOS} $@
${KAWA} $@
test/pointer-set-get.scm:

7
guix-chicken-init.sh Normal file
View File

@ -0,0 +1,7 @@
#!/usr/bin/env bash
export CHICKEN_INSTALL_REPOSITORY=${HOME}/eggs/lib/chicken/5
export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/eggs/lib/chicken/5
chicken-install -init ${HOME}/eggs/lib/chicken/5
chicken-install r7rs

81
retropikzel/pffi/v0-1-0/chicken.scm
View File

@ -3,7 +3,9 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context))
(scheme process-context)
(chicken foreign)
(chicken syntax))
(export pffi-shared-object-load
pffi-define
pffi-size-of
@ -22,16 +24,73 @@
(define pffi-type->native-type
(lambda (type)
(error "Not defined")))
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types)))))))
(if (null? argument-types)
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name))
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
(define pffi-size-of
(lambda (type)
@ -57,9 +116,15 @@
(lambda (pointer size)
(error "Not defined")))
(define pffi-shared-object-load
(lambda (header path)
(error "Not defined")))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
(let* ((headers (cdr (car (cdr expr)))))
`(begin
,@ (map
(lambda (header)
`(foreign-declare ,(string-append "#include <" header ">")))
headers))))))
(define pffi-pointer-free
(lambda (pointer)

61
retropikzel/pffi/v0-1-0/cyclone.sld
View File

@ -55,15 +55,44 @@
(define-syntax pffi-define
(syntax-rules ()
((pffi-define msg)
;(define-c t "(void *data, int argc, closure _, object k, object h)" "puts(string_str(h));")
;(c-define puts int "puts" string)
(c-code "char* buffer[1000]; fgets(buffer, 1000, stdin); puts(buffer);")
#t
)
)
)
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types)))))))
(if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name
,return-type ,c-name ,@ argument-types))))))
(define pffi-size-of
@ -90,12 +119,14 @@
(lambda (pointer size)
(error "Not defined")))
(define-syntax pffi-shared-object-load
(syntax-rules ()
((when headers shared-object additional-paths)
)))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
`(begin
,@ (map
(lambda (header)
`(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr))))))))
(define pffi-pointer-free
(lambda (pointer)

1
retropikzel/pffi/v0-1-0/main.rkt
View File

@ -201,6 +201,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))

1
retropikzel/pffi/v0-1-0/main.scm
View File

@ -200,6 +200,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))

1
retropikzel/pffi/v0-1-0/main.sld
View File

@ -200,6 +200,7 @@
((pffi-shared-object-auto-load headers object-name additional-paths)
(cond-expand
(cyclone (pffi-shared-object-load headers object-path))
(chicken (pffi-shared-object-load headers object-path))
(else
(let* ((paths (append auto-load-paths additional-paths))
(shared-object #f))

2
retropikzel/pffi/v0-1-0/sagittarius.scm
View File

@ -32,8 +32,6 @@
((equal? type 'uint32) 'uint32_t)
((equal? type 'int64) 'int64_t)
((equal? type 'uint64) 'uint64_t)
((equal? type 'intptr) 'intptr_t)
((equal? type 'uintptr) 'uintptr_t)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'char)
((equal? type 'short) 'short)

16
test.scm
View File

@ -6,10 +6,12 @@
(cyclone foreign))
(define-syntax while
(syntax-rules ()
((while condition . body)
(let loop ()
(cond (condition
(begin . body)
(loop)))))))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
(let* ((headers (cdr (car (cdr expr)))))
`(begin
,@ (map
(lambda (header)
`(include-c-header ,(string-append "<" header ">")))
headers))))))

2
test/pffi-define.scm
View File

@ -9,7 +9,7 @@
(display libcurl)
(newline)
(pffi-define curl-version libcurl 'curl_version 'string (list))
(pffi-define 'curl-version libcurl 'curl_version 'string (list))
(display "=================")
(newline)

2
test/size-of.scm
View File

@ -1,6 +1,6 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(retropikzel pffi v0-1-0 main))
(display 'int8)
(display " ")