Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues 4 Pull Requests Releases Activity

Add Racket R7RS support.

This commit is contained in:
retropikzel 2025-04-19 09:37:17 +03:00
parent 9bee11a3c8
commit 477266d6e1
11 changed files with 207 additions and 2256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
Makefile
View File

@ -1,16 +1,15 @@
.PHONY: snow
PREFIX=/usr/local
build:
printf "#!/bin/sh\nsash --disable-cache -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs
snow:
rm -rf snow
mkdir -p snow
cp -r ../r7rs-pffi/retropikzel snow/
cp -r ../pffi-srfi-170/srfi snow/
install:
# Does uninstall because without that the changes do not seem to update
install: uninstall
mkdir -p ${PREFIX}/lib/compile-r7rs/snow
cp -r snow/* ${PREFIX}/lib/compile-r7rs/snow
cp -r libs ${PREFIX}/lib/compile-r7rs/snow/libs
@ -63,6 +62,12 @@ test-r7rs-docker:
docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=compile-r7rs-test-${COMPILE_R7RS} .
docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${COMPILE_R7RS} sh -c "make && make install && make clean-test COMPILE_R7RS=${COMPILE_R7RS} test-r7rs"
clean-snow:
rm -rf snow
clean-test:
rm -rf test
clean:
find . -name "*.so" -delete
find . -name "*.o*" -delete
@ -74,5 +79,4 @@ clean:
rm -rf dist
rm -rf test
clean-test:
rm -rf test

20
README.md
View File

@ -98,6 +98,11 @@ as compiler.
- interpreter
- R6RS
- R7RS
- racket
- interpreter
- Has compiling capabilities but I havent got them to work yet
- r6rs
- r7rs
- sagittarius
- interpreter
- R6RS
@ -132,12 +137,6 @@ as compiler.
https://github.com/yamacir-kit/meevax/issues/494, might not be
implemented yet
- r7rs
- racket
- Wants the library paths to be full paths so I need to implement
realpath into [pffi-srfi-170](https://git.sr.ht/~retropikzel/pffi-srfi-170)
to get them
- r6rs
- r7rs
- picrin
- Might not be possible, seems to not have (include...) that works like
others
@ -435,12 +434,3 @@ libs/util.sld.
If the transformer has to go trough hoops, that is is little or much unusual
then it is a good idea to explain how it works in this readmes how it works
section.
### Misc notes
<a name="#development-misc-notes"></a>
When developing and testing, run:
make && sudo make uninstall install
without the uninstall the changes to libraries dont seem to update.

56
libs/data.sld
View File

@ -391,13 +391,26 @@
" "
,input-file)))))
(racket
(type . compiler)
(type . interpreter)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(let ((library-rkt-file (change-file-suffix library-file ".rkt")))
(apply string-append
`("printf"
" "
"'#lang r7rs\\n(import (scheme base))\\n(include \""
,(path->filename library-file)
"\")\\n"
"'"
" "
">"
" "
,library-rkt-file)))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(let ((rkt-input-file (if (string=? input-file "")
""
(change-file-suffix input-file ".rkt"))))
(when (not (string=? rkt-input-file ""))
(if (file-exists? rkt-input-file)
(when (file-exists? rkt-input-file)
(delete-file rkt-input-file))
(with-output-to-file
rkt-input-file
@ -410,38 +423,23 @@
(display (path->filename input-file))
(display "\")")
(newline))))
(for-each
(lambda (file)
(let ((library-rkt-file (change-file-suffix file ".rkt")))
(if (file-exists? library-rkt-file)
(delete-file library-rkt-file))
(with-output-to-file
library-rkt-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (scheme base))")
(newline)
(display "(include \"")
(display (path->filename file))
(display "\")")
(newline)))))
library-files)
(apply string-append
;; TODO run realpath to each directory
;; as Racket expects static paths
`("PLTCOLLECTS="
,(string-join prepend-directories ":")
,(string-join append-directories ":")
" "
"raco exe"
`("racket"
" "
,(util-getenv "COMPILE_R7RS_RACKET")
" "
"--orig-exe ++lang r7rs -o "
,output-file
"-I"
" "
,rkt-input-file))))))
,(if r6rs? "r6rs" "r7rs")
" "
,@(map (lambda (item)
(string-append "-S " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-S " item " "))
append-directories)
" "
,(if r6rs? input-file rkt-input-file)))))))
(sagittarius
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)

52
snow/retropikzel/pffi/Makefile
View File

@ -1,13 +1,55 @@
CC=gcc
chibi-pffi.so: chibi/pffi.stub
chibi-ffi chibi/pffi.stub
${CC} -g3 -o chibi-pffi.so chibi/pffi.c -fPIC -lffi -shared
chibi: chibi-src/pffi.stub
chibi-ffi chibi-src/pffi.stub
${CC} -g3 -o chibi-pffi.so chibi-src/pffi.c -fPIC -lffi -shared
gauche-pffi.so:
chicken:
@echo "Nothing to build for Chicken"
cyclone:
@echo "Nothing to build for Cyclone"
gambit:
@echo "Nothing to build for Gambit"
gauche: gauche-src/gauche-pffi.c gauche-src/gauchelib.scm
gauche-package compile \
--srcdir=gauche \
--srcdir=gauche-src \
--cc=${CC} \
--cflags="-I./include" \
--libs=-lffi \
gauche-pffi gauche-pffi.c gauchelib.scm
gerbil:
@echo "Nothing to build for Gerbil"
guile:
@echo "Nothing to build for Guile"
kawa:
@echo "Nothing to build for Kawa"
larceny:
@echo "Nothing to build for Larceny"
mosh:
@echo "Nothing to build for Mosh"
racket:
@echo "Nothing to build for Racket"
sagittarius:
@echo "Nothing to build for Sagittarius"
skint:
@echo "Nothing to build for Skint"
stklos:
@echo "Nothing to build for Stklos"
tr7:
@echo "Nothing to build for tr7"
ypsilon:
@echo "Nothing to build for Ypsilon"

0
snow/retropikzel/pffi/chibi/pffi.stub → snow/retropikzel/pffi/chibi-src/pffi.stub
View File

1421
snow/retropikzel/pffi/chibi/pffi.c
View File

File diff suppressed because it is too large Load Diff

0
snow/retropikzel/pffi/gauche/gauchelib.scm → snow/retropikzel/pffi/gauche-src/gauchelib.scm
View File

692
snow/retropikzel/pffi/gauche/gauche-pffi.c
View File

@ -1,692 +0,0 @@
#include <math.h>
#include <stdint.h>
#include <gauche.h>
#include <gauche/extend.h>
#include <gauche/module.h>
#include <gauche/load.h>
#include <gauche/number.h>
#include <gauche/string.h>
#include <gauche-pffi.h>
#include <ffi.h>
#include <dlfcn.h>
void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
void* p = SCM_FOREIGN_POINTER_REF(void*, obj);
if(p == NULL) {
Scm_Printf(sink, "<pffi-pointer: (null)>\n");
} else {
Scm_Printf(sink, "<pffi-pointer: %i>\n", &p);
}
}
void dprint_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
void* p = SCM_FOREIGN_POINTER_REF(void*, obj);
if(p == NULL) {
Scm_Printf(sink, "<DEBUG pffi-pointer: (null)>\n");
} else {
Scm_Printf(sink, "<DEBUG pffi-pointer: %i>\n", &p);
}
}
ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); }
ScmObj size_of_uint8() { return Scm_MakeInteger(sizeof(uint8_t)); }
ScmObj size_of_int16() { return Scm_MakeInteger(sizeof(int16_t)); }
ScmObj size_of_uint16() { return Scm_MakeInteger(sizeof(uint16_t)); }
ScmObj size_of_int32() { return Scm_MakeInteger(sizeof(int32_t)); }
ScmObj size_of_uint32() { return Scm_MakeInteger(sizeof(uint32_t)); }
ScmObj size_of_int64() { return Scm_MakeInteger(sizeof(int64_t)); }
ScmObj size_of_uint64() { return Scm_MakeInteger(sizeof(uint64_t)); }
ScmObj size_of_char() { return Scm_MakeInteger(sizeof(char)); }
ScmObj size_of_unsigned_char() { return Scm_MakeInteger(sizeof(unsigned char)); }
ScmObj size_of_short() { return Scm_MakeInteger(sizeof(short)); }
ScmObj size_of_unsigned_short() { return Scm_MakeInteger(sizeof(unsigned short)); }
ScmObj size_of_int() { return Scm_MakeInteger(sizeof(int)); }
ScmObj size_of_unsigned_int() { return Scm_MakeInteger(sizeof(unsigned int)); }
ScmObj size_of_long() { return Scm_MakeInteger(sizeof(long)); }
ScmObj size_of_unsigned_long() { return Scm_MakeInteger(sizeof(unsigned long)); }
ScmObj size_of_float() { return Scm_MakeInteger(sizeof(float)); }
ScmObj size_of_double() { return Scm_MakeInteger(sizeof(double)); }
ScmObj size_of_string() { return Scm_MakeInteger(sizeof(char*)); }
ScmObj size_of_pointer() { return Scm_MakeInteger(sizeof(void*)); }
ScmObj size_of_void() { return Scm_MakeInteger(sizeof(void)); }
ScmModule* module = NULL;
ScmObj shared_object_load(ScmString* path) {
const ScmStringBody* body = SCM_STRING_BODY(path);
const char* c_path = SCM_STRING_BODY_START(body);
void* shared_object = dlopen(c_path, RTLD_NOW);
ScmClass* shared_object_class = Scm_MakeForeignPointerClass(module, "pffi-shared-object", print_pointer, NULL, 0);
ScmObj scm_shared_object = Scm_MakeForeignPointer(shared_object_class, shared_object);
return scm_shared_object;
}
ScmObj pointer_null() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
ScmObj pointer = Scm_MakeForeignPointer(pointer_class, NULL);
return pointer;
}
ScmObj is_pointer_null(ScmObj pointer) {
if(!Scm_TypeP(pointer, SCM_CLASS_FOREIGN_POINTER)) {
return SCM_FALSE;
}
if(SCM_FOREIGN_POINTER_REF(void*, pointer) == NULL) {
return SCM_TRUE;
} else {
return SCM_FALSE;
}
}
ScmObj pointer_allocate(int size) {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
void* p = malloc(size);
ScmObj pointer = Scm_MakeForeignPointer(pointer_class, p);
return pointer;
}
ScmObj pointer_address(ScmObj object) {
if(!Scm_TypeP(object, SCM_CLASS_FOREIGN_POINTER)) {
Scm_Error("Can only get pointer address of a pointer");
return SCM_UNDEFINED;
}
void* p = SCM_FOREIGN_POINTER_REF(void*, object);
return SCM_MAKE_INT(&p);
}
ScmObj is_pointer(ScmObj pointer) {
if(Scm_TypeP(pointer, SCM_CLASS_FOREIGN_POINTER)) {
return SCM_TRUE;
} else {
return SCM_FALSE;
}
}
ScmObj pointer_free(ScmObj pointer) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
free(SCM_FOREIGN_POINTER_REF(void*, pointer));
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(int8_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(uint8_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(int16_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(uint16_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(int32_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(uint32_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(int64_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(uint64_t*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_char(ScmObj pointer, int offset, char value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(char*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(unsigned char*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_short(ScmObj pointer, int offset, short value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(short*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(unsigned short*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_int(ScmObj pointer, int offset, int value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(int*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(unsigned int*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_long(ScmObj pointer, int offset, long value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(long*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(unsigned long*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_float(ScmObj pointer, int offset, float value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(float*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_double(ScmObj pointer, int offset, double value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
*(double*)((char*)p + offset) = value;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* v = SCM_FOREIGN_POINTER_REF(void*, value);
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
char* p1 = (char*)p + offset;
*(char**)p1 = v;
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_int8(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(int8_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_uint8(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(uint8_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_int16(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(int16_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_uint16(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(uint16_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_int32(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(int32_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_uint32(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(uint32_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_int64(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(int64_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_uint64(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(uint64_t*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_char(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(char*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_unsigned_char(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(unsigned char*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_short(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(short*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_unsigned_short(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(unsigned short*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_int(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(int*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_unsigned_int(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(unsigned int*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_long(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(long*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return SCM_MAKE_INT(*(unsigned long*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_float(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return Scm_MakeFlonum(*(float*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_double(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
return Scm_MakeFlonum(*(double*)((char*)p + offset));
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pointer_get_pointer(ScmObj pointer, int offset) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
char* p1 = (char*)p + offset;
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", dprint_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, (void*)*(char**)p1);
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj string_to_pointer(ScmObj string) {
if(SCM_STRINGP(string)) {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, Scm_GetString(SCM_STRING(string)));
} else {
Scm_Error("Not a string: %S", string);
}
return SCM_UNDEFINED;
}
ScmObj pointer_to_string(ScmObj pointer) {
if(SCM_FOREIGN_POINTER_P(pointer)) {
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
void* string = (char*)p;
return Scm_MakeString(string, -1, -1, 0);
} else {
Scm_Error("Not a pointer: %S", pointer);
}
return SCM_UNDEFINED;
}
ScmObj pffi_dlerror() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
void* msg = dlerror();
if(msg == NULL) {
return Scm_MakeForeignPointer(pointer_class, NULL);
} else {
return Scm_MakeForeignPointer(pointer_class, msg);
}
}
ScmObj pffi_dlsym(ScmObj shared_object, ScmObj c_name) {
if(!SCM_FOREIGN_POINTER_P(shared_object)) {
Scm_Error("Not a shared object: %S", shared_object);
return SCM_UNDEFINED;
}
if(!SCM_STRINGP(c_name)) {
Scm_Error("Not a string: %S", c_name);
return SCM_UNDEFINED;
}
void* handle = SCM_FOREIGN_POINTER_REF(void*, shared_object);
const ScmStringBody* body = SCM_STRING_BODY(c_name);
const char* name = SCM_STRING_BODY_START(body);
void* symbol = dlsym(handle, name);
if(symbol == NULL) {
Scm_Error("Could not find function %S", c_name);
return SCM_UNDEFINED;
}
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, symbol);
}
ScmObj get_ffi_type_int8() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint8);
}
ScmObj get_ffi_type_uint8() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint8);
}
ScmObj get_ffi_type_int16() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint16);
}
ScmObj get_ffi_type_uint16() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint16);
}
ScmObj get_ffi_type_int32() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint32);
}
ScmObj get_ffi_type_uint32() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint32);
}
ScmObj get_ffi_type_int64() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint64);
}
ScmObj get_ffi_type_uint64() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint64);
}
ScmObj get_ffi_type_char() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_schar);
}
ScmObj get_ffi_type_unsigned_char() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uchar);
}
ScmObj get_ffi_type_short() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sshort);
}
ScmObj get_ffi_type_unsigned_short() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_ushort);
}
ScmObj get_ffi_type_int() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint);
}
ScmObj get_ffi_type_unsigned_int() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint);
}
ScmObj get_ffi_type_long() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_slong);
}
ScmObj get_ffi_type_unsigned_long() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_ulong);
}
ScmObj get_ffi_type_float() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_float);
}
ScmObj get_ffi_type_double() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_double);
}
ScmObj get_ffi_type_void() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_void);
}
ScmObj get_ffi_type_pointer() {
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
return Scm_MakeForeignPointer(pointer_class, &ffi_type_pointer);
}
ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues) {
ffi_cif cif;
unsigned int c_nargs = SCM_INT_VALUE(nargs);
ffi_type* c_rtype = SCM_FOREIGN_POINTER_REF(ffi_type*, rtype);
int atypes_length = (int)Scm_Length(atypes);
ffi_type* c_atypes[atypes_length];
for(int i = 0; i < atypes_length; i++) {
c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED));
}
int prep_status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, c_nargs, c_rtype, c_atypes);
void* c_fn = SCM_FOREIGN_POINTER_REF(void*, fn);
void* c_rvalue = SCM_FOREIGN_POINTER_REF(void*, rvalue);
int avalues_length = (int)Scm_Length(avalues);
void* c_avalues[avalues_length];
for(int i = 0; i < avalues_length; i++) {
ScmObj item = Scm_ListRef(avalues, i, SCM_UNDEFINED);
void* pp = SCM_FOREIGN_POINTER_REF(void*, item);
char* list_p = (char*)c_avalues + (sizeof(void) * i);
c_avalues[i] = pp;
}
ffi_call(&cif, FFI_FN(c_fn), c_rvalue, c_avalues);
return SCM_UNDEFINED;
}
/*
ScmObj procedure_to_pointer(ScmObj procedure) {
return SCM_UNDEFINED;
}*/
void Scm_Init_gauche_pffi(void)
{
SCM_INIT_EXTENSION(retropikzel.pffi.gauche);
module = SCM_MODULE(SCM_FIND_MODULE("retropikzel.pffi.gauche", TRUE));
Scm_Init_gauchelib();
}

7
snow/retropikzel/pffi/shared/struct.scm
View File

@ -30,9 +30,6 @@
(let* ((member-type (cadr struct-member))
(member-name (car struct-member))
(member-size (pffi-size-of member-type)))
(display "HERE: ")
(write member-size)
(newline)
(pffi-pointer-set! pointer
member-type
offset
@ -114,10 +111,6 @@
(error "Struct has no such member" (list struct member-name)))
(let ((type (car (cdr (assoc member-name (pffi-struct-members struct)))))
(offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))))
(map display (list "type: " type
", offset: " offset
", value: " (pffi-pointer-get (pffi-struct-pointer struct) type offset)
#\newline))
(pffi-pointer-get (pffi-struct-pointer struct) type offset)))
(define (pffi-struct-set! struct member-name value)

195
snow/srfi/170.scm
View File

@ -36,14 +36,55 @@
(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
(pffi-define uv-fs-scandir-next libuv 'uv_fs_scandir_next 'int '(pointer pointer))
(pffi-define uv-fs-get-ptr libuv 'uv_fs_get_ptr 'pointer '(pointer))
(pffi-define uv-fs-realpath libuv 'uv_fs_realpath 'int '(pointer pointer pointer pointer))
(pffi-define uv-fs-cleanup libuv 'uv_fs_req_cleanup 'void '(pointer))
;(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
;(pffi-define c-printf libc 'printf 'int '(string))
;(pffi-define c-cos libc 'cos 'double '(double))
(define UV-FS 6)
(define uv-fs-t-make
(pffi-define-struct uv-fs-t-make
'uv_fs_t
'((pointer . data)
(int . type)
(pointer . reserved1)
(pointer . reserved2)
(pointer . reserved3)
(pointer . reserved4)
(pointer . reserved5)
(pointer . reserved6)
(pointer . fs_type)
(pointer . loop)
(pointer . cb)
(int . result)
(pointer . ptr)
(pointer . path)
(int . statbuf)
(pointer . new_path)
(int . file)
(int . flags)
(int . mode)
(pointer . bufs)
(int . off)
(int . uid)
(int . gid)
(double . atime)
(double . mtime)
(pointer . work_req)
(pointer . bufsml1)
(pointer . bufsml2)
(pointer . bufsml3)
(pointer . bufsml4)))
(define req-type (uv-fs-t-make))
;(pffi-struct-set! struct 'fs_type UV-FS)
#;(define uv-fs-t-make
(lambda ()
(let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer) ; .loop
(let ((struct (uv-fs-t)))
(pffi-struct-set! struct 'fs_type UV-FS)
struct
#;(let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer) ; .loop
(pffi-size-of 'int) ; .uv_fs_type
(pffi-size-of 'pointer) ; .path
(pffi-size-of 'int) ; .result
@ -52,7 +93,11 @@
512 ; Temporary fix
))))
(pffi-pointer-set! p 'int (pffi-size-of 'pointer) UV-FS)
p)))
p))))
(pffi-define-struct uv-dirent-make
'uv_dirent_t
'((pointer . name) (int . uv_dirent_type)))
(define handle-errors
(lambda (return-code . irritants)
@ -85,115 +130,105 @@
; FIX make the "follow?" argument work
(define file-info
(lambda (fname/port follow?)
(let* ((req-type (uv-fs-t-make)))
(handle-errors (uv-fs-stat (uv-default-loop)
req-type
(pffi-string->pointer fname/port)
(pffi-pointer-null)))
(let ((stat-pointer (uv-fs-get-ptr req-type)))
(file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12))
fname/port
follow?)))))
(handle-errors (uv-fs-stat (uv-default-loop)
(pffi-struct-pointer req-type)
(pffi-string->pointer fname/port)
(pffi-pointer-null)))
(let* ((stat-pointer (uv-fs-get-ptr (pffi-struct-pointer req-type)))
(result (file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11))
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12))
fname/port
follow?)))
(uv-fs-cleanup (pffi-struct-pointer req-type))
result)))
(define file-info-directory?
(lambda (file-info)
; Try to open the file-info path as directory, if it fails say it's not a directory
(let ((req-type (uv-fs-t-make)))
(let* ((file-path (file-info:fname/port file-info))
(result (uv-fs-opendir (uv-default-loop)
req-type
(pffi-string->pointer file-path)
(pffi-pointer-null))))
(cond ((not (file-exists? file-path)) #f)
((not (= result -20)) #t)
; If it is a dir then it's open and needs to be closed
(else (uv-fs-closedir (uv-default-loop)
req-type
(uv-fs-get-ptr req-type)
(pffi-pointer-null))
#f))))))
(let* ((file-path (file-info:fname/port file-info))
(uv-result (uv-fs-opendir (uv-default-loop)
(pffi-struct-pointer req-type)
(pffi-string->pointer file-path)
(pffi-pointer-null))))
(cond ((not (file-exists? file-path))
(uv-fs-cleanup (pffi-struct-pointer req-type))
#f)
((not (= uv-result -20))
(uv-fs-cleanup (pffi-struct-pointer req-type))
#t)
; If it is a dir then it's open and needs to be closed
(else (uv-fs-closedir (uv-default-loop)
(pffi-struct-pointer req-type)
(uv-fs-get-ptr (pffi-struct-pointer req-type))
(pffi-pointer-null))
(uv-fs-cleanup (pffi-struct-pointer req-type))
#f)))))
(define create-directory
(lambda (fname . permission-bits)
(let ((req-type (uv-fs-t-make))
(mode (if (null? permission-bits) #o775 (car permission-bits))))
(let ((mode (if (null? permission-bits) #o775 (car permission-bits))))
(handle-errors (uv-fs-mkdir (uv-default-loop)
req-type
(pffi-struct-pointer req-type)
(pffi-string->pointer fname)
mode
(pffi-pointer-null))
(uv-fs-cleanup (pffi-struct-pointer req-type))
fname))))
(define delete-directory
(lambda (fname)
(let ((req-type (uv-fs-t-make)))
(handle-errors
(uv-fs-rmdir (uv-default-loop)
req-type
(pffi-string->pointer fname)
(pffi-pointer-null))
fname))))
(handle-errors
(uv-fs-rmdir (uv-default-loop)
(pffi-struct-pointer req-type)
(pffi-string->pointer fname)
(pffi-pointer-null))
(uv-fs-cleanup (pffi-struct-pointer req-type))
fname)))
(define directory-files
(lambda (dir . args)
(letrec* ((dotfiles? (if (null? args) #f (car args)))
(req-type (uv-fs-t-make))
(result (handle-errors (uv-fs-scandir (uv-default-loop)
req-type
(pffi-struct-pointer req-type)
(pffi-string->pointer dir)
0
(pffi-pointer-null))
dir))
(uv-dirent-t (pffi-pointer-allocate (+ (pffi-size-of 'pointer)
(pffi-size-of 'int)
512)))
(uv-dirent-t (uv-dirent-make))
(files (list))
(looper
(lambda ()
(let ((next-file (uv-fs-scandir-next req-type uv-dirent-t)))
(let ((next-file (uv-fs-scandir-next (pffi-struct-pointer req-type)
(pffi-struct-pointer uv-dirent-t))))
(when (= next-file 0) ; End of file
(let ((file-name (string-copy (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0)))))
(let ((file-name (pffi-pointer->string (pffi-struct-get uv-dirent-t 'name))))
(if (and (> (string-length file-name) 0)
(char=? (string-ref file-name 0) #\.))
(if dotfiles? (set! files (append files (list file-name))))
(set! files (append files (list file-name)))
)
(set! files (append files (list file-name))))
(looper)))))))
(looper)
files
;(write result)
;(newline)
;(write (uv-fs-scandir-next req-type uv-dirent-t))
;(newline)
;(write (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0)))
;(newline)
(uv-fs-cleanup (pffi-struct-pointer req-type))
files)))
(define real-path
(lambda (path)
(let* ((result (uv-fs-realpath (uv-default-loop)
(pffi-struct-pointer req-type)
(pffi-string->pointer path)
(pffi-pointer-null)))
(realpath (pffi-pointer->string (uv-fs-get-ptr (pffi-struct-pointer req-type)))))
(uv-fs-cleanup (pffi-struct-pointer req-type))
realpath)))
;(write (uv-default-loop))
;(newline)
;(write (uv-fs-scandir (uv-default-loop) (pffi-string->pointer ".") 0 (pffi-pointer-null)))
;(newline)
;(write (c-opendir (pffi-string->pointer ".")))
;(newline)
;(c-puts (pffi-string->pointer "Hello world"))
;(c-printf (pffi-string->pointer "Hello world\n"))
;(newline)
;(c-cos 5.5)
;#t
)))

6
snow/srfi/170.sld
View File

@ -3,7 +3,9 @@
(import (scheme base)
(scheme write)
(scheme file)
(retropikzel pffi))
(retropikzel pffi)
(scheme process-context)
)
(export ;posix-error?
;posix-error-name
;posix-error-message
@ -46,7 +48,7 @@
;open-directory
;read-directory
;close-directory
;real-path
real-path
;file-space
;temp-file-prefix
;create-temp-file