diff --git a/.gitignore b/.gitignore
index bc59b0f..5ebb457 100644
--- a/.gitignore
+++ b/.gitignore
@@ -23,3 +23,4 @@ example.scm
example.sps
example
venv
+foreign
diff --git a/Makefile b/Makefile
index 403cf9e..98e0916 100644
--- a/Makefile
+++ b/Makefile
@@ -23,9 +23,9 @@ endif
all: build
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
- rm -rf *.tgz
- echo "
$$(cat retropikzel/${LIBRARY}/README.md)" > ${README}
- snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
+ @rm -rf *.tgz
+ @echo "$$(cat retropikzel/${LIBRARY}/README.md)" > ${README}
+ @snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
install:
snow-chibi install --impls=${SCHEME} ${SNOW_CHIBI_ARGS} ${PKG}
@@ -34,21 +34,26 @@ uninstall:
-snow-chibi remove --impls=${SCHEME} ${PKG}
init-venv: build
- rm -rf venv
- scheme-venv ${SCHEME} ${RNRS} venv
- echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > venv/test.scm
- echo "(import (rnrs) (srfi :64) (retropikzel ${LIBRARY}))" > venv/test.sps
- cat ${TESTFILE} >> venv/test.scm
- cat ${TESTFILE} >> venv/test.sps
- cp -r ../foreign-c/foreign venv/lib
- cp -r retropikzel venv/lib/
- if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
- if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
- if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
+ @rm -rf venv
+ @scheme-venv ${SCHEME} ${RNRS} venv
+ @echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > venv/test.scm
+ @printf "#!r6rs\n(import (rnrs) (srfi :64) (retropikzel ${LIBRARY}))" > venv/test.sps
+ @cat ${TESTFILE} >> venv/test.scm
+ @cat ${TESTFILE} >> venv/test.sps
+ @if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
+ @if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
+ @if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
+ @if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
+ @if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
+ @if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
+ @if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install; fi
+ @if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
+ @if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
+ @if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
run-test: init-venv
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi
- if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/scheme-compile venv/test.scm; fi
+ if [ "${RNRS}" = "r7rs" ]; then VENV_CSC_ARGS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
./venv/test
test-r7rs:
diff --git a/retropikzel/arena.scm b/retropikzel/arena.scm
deleted file mode 100644
index 1fa22f1..0000000
--- a/retropikzel/arena.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-(define-record-type
- (internal-make-arena pointer size fixed?)
- arena?
- (pointer arena-pointer)
- (size arena-size)
- (fixed? arena-fixed?))
-
-(define make-arena
- (lambda options
- #t
- ))
-
-(define (call-with-arena arena thunk)
- #t
- )
-
-(define (arena-allocate arena size)
- #t
- )
-
-(define (free-arena arena)
- #t
- )
diff --git a/retropikzel/arena.sld b/retropikzel/arena.sld
deleted file mode 100644
index d136a25..0000000
--- a/retropikzel/arena.sld
+++ /dev/null
@@ -1,12 +0,0 @@
-(define-library
- (retropikzel arena)
- (import (scheme base)
- (scheme write)
- (foreign c))
- (export make-arena
- arena?
- call-with-arena
- arena-allocate
- free-arena)
- (include "arena.scm"))
-
diff --git a/retropikzel/arena/README.md b/retropikzel/arena/README.md
deleted file mode 100644
index e69695c..0000000
--- a/retropikzel/arena/README.md
+++ /dev/null
@@ -1,39 +0,0 @@
-## Arenas
-
-Arena is static or growing size of memory which can be use to allocate
-c-bytevectors and then free them all at once. All memory allocated in arenas
-is zeroed by default.
-
-(**make-arena** [options])
-
-Creates and returns a new arena. Options is list of pairs.
-
-Options:
-
- - (size . N)
- - If the size argument is given, that much memory is allocated up front.
- - (fixed? . #t/#f)
- - #f means the arena grows automatically on allocation, #t means it does not
- and any allocation that would go over arena size will throw an error.
- - If #t and size is not given error will thrown
-
-(**arena?** obj)
-
-Returns #t if obj is arena, #f otherwise.
-
-(**call-with-arena** arena thunk)
-
-Call thunk with given arena as first argument. After the thunk returns arena
-is freed. If the thunk does not return, for example error occurs, the arena is
-not freed.
-
-
-(**arena-allocate** arena size)
-
-Allocate c-bytevector of given size from the given arena and return it. If
-allocation fails, error is signaled.
-
-
-(**free-arena** arena)
-
-Free the whole arena.
diff --git a/retropikzel/named-pipes.scm b/retropikzel/named-pipes.scm
index 9c04d54..e8ce705 100644
--- a/retropikzel/named-pipes.scm
+++ b/retropikzel/named-pipes.scm
@@ -39,6 +39,9 @@
(lambda (msg return-code)
(when (and (number? return-code)
(< return-code 0))
+ (display "HERE: ")
+ (write return-code)
+ (newline)
(c-perror (string->c-utf8 msg))
(error msg return-code))
return-code))
@@ -48,11 +51,13 @@
(let* ((path* (string->c-utf8 path))
(octal-mode (string->number (string-append "#o"
(number->string mode)))))
- (handle-c-errors (string-append "open-output-pipe mkfifo"
- " "
+ (handle-c-errors (string-append "open-output-pipe mkfifo: "
+ " path: "
path
- " "
- (number->string mode))
+ ", mode: "
+ (number->string mode)
+ ", octal-mode: "
+ (number->string octal-mode))
(c-mkfifo path* octal-mode)))))
(define open-input-pipe
diff --git a/retropikzel/named-pipes/test.scm b/retropikzel/named-pipes/test.scm
index 8703b47..f4d0aae 100644
--- a/retropikzel/named-pipes/test.scm
+++ b/retropikzel/named-pipes/test.scm
@@ -61,7 +61,7 @@
(newline)
(define should-be-eof (pipe-read-line input))
(when (not (eof-object? should-be-eof))
- (error "Reading line from empty buffer should eof"))
+ (error "Reading line from empty buffer should eof" should-be-eof))
(define line (string-append "Hello world" (string #\newline)))
(define expected-output-line "Hello world")
(pipe-write-string line output)
@@ -80,7 +80,7 @@
(newline)
(set! should-be-eof (pipe-read input))
(when (not (eof-object? should-be-eof))
- (error "Reading from empty buffer should eof"))
+ (error "Reading from empty buffer should eof" should-be-eof))
(define text1 (string-append "Hello world" (string #\newline)))
(pipe-write-string text1 output)
(define output-text1 (pipe-read input))
diff --git a/retropikzel/pstk.scm b/retropikzel/pstk.scm
index 8c66de2..5952be5 100644
--- a/retropikzel/pstk.scm
+++ b/retropikzel/pstk.scm
@@ -20,34 +20,41 @@
(define (shell-command program output-path input-path)
(string-append program " < " output-path " 1> " input-path " & "))
-(define wish-newline
- (lambda (pipe)
- (pipe-write-char #\newline pipe)))
+(define wish-newline (lambda (pipe) (pipe-write-char #\newline pipe)))
(define wish-flush (lambda () #t)) ; No need to do anything
(define wish-read-line pipe-read-line)
+(define input-pipe-path (temp-name))
+(define output-pipe-path (temp-name))
+(define input-pipe #f)
+(define output-pipe #f)
(define (run-program program)
- (let* ((input-path (temp-name))
- (output-path (temp-name)))
- (create-pipe input-path 0777)
- (create-pipe output-path 0777)
- (system (shell-command program output-path input-path))
- (list (open-input-pipe input-path)
- (open-output-pipe output-path))))
+ (create-pipe input-pipe-path 0777)
+ (create-pipe output-pipe-path 0777)
+ (system (shell-command program output-pipe-path input-pipe-path))
+ (set! input-pipe (open-input-pipe input-pipe-path))
+ (set! output-pipe (open-output-pipe output-pipe-path))
+ (list input-pipe output-pipe))
(define *wish-program* "tclsh")
(define *wish-debug-input* (if (get-environment-variable "PSTK_DEBUG") #t #f))
(define *wish-debug-output* (if (get-environment-variable "PSTK_DEBUG") #t #f))
-(define *use-keywords?* #t)
+(define *use-keywords?*
+ (cond-expand
+ (stklos #t)
+ (else #f)))
-(define (keyword? x)
+(define (%keyword? x)
(cond-expand
- (chicken (chicken-keyword? x))
- (else (error "Keywords not supported on this implementation"))))
-(define (keyword->string x)
+ (kawa (keyword? x))
+ (srfi-88 (keyword? x))
+ (else (error "Keywords not supported" x))))
+
+(define (%keyword->string x)
(cond-expand
- (chicken (chicken-keyword->string x))
- (else (error "Keywords not supported on this implementation"))))
+ (kawa (keyword->string x))
+ (stklos (keyword->string x))
+ (else (error "Keywords not supported" x))))
(define nl (string #\newline))
@@ -151,16 +158,11 @@
(lambda (x)
(newline)
(display x)
- (newline)
- ; (bottom x)
- ))
-
-
+ (newline)))
(define option?
(lambda (x)
- (or (and *use-keywords?*
- (keyword? x))
+ (or (and *use-keywords?* (%keyword? x))
(and (symbol? x)
(let* ((s (symbol->string x))
(n (string-length s)))
@@ -168,12 +170,11 @@
(define make-option-string
(lambda (x)
- (if (and *use-keywords?*
- (keyword? x))
- (string-append " -" (keyword->string x))
- (let ((s (symbol->string x)))
- (string-append " -"
- (substring s 0 (- (string-length s) 1)))))))
+ (if (and *use-keywords?* (%keyword? x))
+ (string-append " -" (%keyword->string x))
+ (let* ((s (symbol->string x))
+ (option (string-append " -" (substring s 0 (- (string-length s) 1)))))
+ option))))
(define improper-list->string
(lambda (a first)
@@ -198,7 +199,7 @@
(improper-list->string x #t))
")"))
((eof-object? x) "#")
- ((keyword? x) (keyword->string x))
+ ((and *use-keywords?* (%keyword? x)) (%keyword->string x))
(else "#"))))
(define string-translate
@@ -430,9 +431,7 @@
(define scheme-arglist->tk-argstring
(lambda (args)
- (apply string-append
- (map scheme-arg->tk-arg
- args))))
+ (apply string-append (map scheme-arg->tk-arg args))))
(define make-wish-func
(lambda (tkname)
@@ -558,7 +557,11 @@
(define tk-end
(lambda ()
(set! tk-is-running #f)
- (wish "after 200 exit")))
+ (wish "after 200 exit")
+ (close-pipe input-pipe)
+ (close-pipe output-pipe)
+ (delete-file input-pipe-path)
+ (delete-file output-pipe-path)))
(define tk-dispatch-event
(lambda ()
diff --git a/retropikzel/pstk.sld b/retropikzel/pstk.sld
index bacd299..abcbf0a 100644
--- a/retropikzel/pstk.sld
+++ b/retropikzel/pstk.sld
@@ -163,7 +163,8 @@
ttk/set-theme
ttk/style)
(cond-expand
- (chicken (import (prefix (chicken keyword) chicken-)))
+ (kawa (import (only (kawa base) keyword? keyword->string)))
+ (srfi-88 (import (srfi 88)))
(else))
(include "pstk.scm"))
diff --git a/retropikzel/requests.scm b/retropikzel/requests.scm
index f237a61..202834c 100644
--- a/retropikzel/requests.scm
+++ b/retropikzel/requests.scm
@@ -113,11 +113,7 @@
(let* ((pointer-size (c-type-size 'long))
(pointer (make-c-bytevector (c-type-size 'long))))
(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE pointer)
- (let ((code (c-bytevector-ref pointer
- 'sint
- 0
- (native-endianness)
- pointer-size)))
+ (let ((code (c-bytevector-ref pointer 'int 0)))
(c-free pointer)
code)))
diff --git a/retropikzel/requests/test.scm b/retropikzel/requests/test.scm
index 6facf11..aa7ab28 100644
--- a/retropikzel/requests/test.scm
+++ b/retropikzel/requests/test.scm
@@ -1,7 +1,3 @@
-(import (scheme base)
- (scheme write)
- (scheme process-context)
- (retropikzel requests))
(define response (request 'GET
"http://echo-http-requests.appspot.com/echo"
diff --git a/retropikzel/system.sld b/retropikzel/system.sld
index 5cb61a4..73d9c03 100644
--- a/retropikzel/system.sld
+++ b/retropikzel/system.sld
@@ -2,6 +2,7 @@
(retropikzel system)
(import (scheme base)
(scheme write)
+ (scheme process-context)
(foreign c))
(export system)
(include "system.scm"))