Improvements to pstk

.gitignore

@@ -23,3 +23,4 @@ example.scm
 example.sps
 example
 venv
+foreign

Makefile

@@ -23,9 +23,9 @@ endif
 all: build
 
 build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
-	rm -rf *.tgz
+	@rm -rf *.tgz
-	echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
+	@echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
-	snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
+	@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
+	@rm -rf venv
-	scheme-venv ${SCHEME} ${RNRS} 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 (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
+	@printf "#!r6rs\n(import (rnrs) (srfi :64) (retropikzel ${LIBRARY}))" > venv/test.sps
-	cat ${TESTFILE} >> venv/test.scm
+	@cat ${TESTFILE} >> venv/test.scm
-	cat ${TESTFILE} >> venv/test.sps
+	@cat ${TESTFILE} >> venv/test.sps
-	cp -r ../foreign-c/foreign venv/lib
+	@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
-	cp -r retropikzel venv/lib/
+	@if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
-	if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
+	@if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
-	if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
+	@if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
-	if [ "${RNRS}" = "r6rs" ]; 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:

retropikzel/arena.scm

@@ -1,23 +0,0 @@
-(define-record-type <arena>
-  (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
-  )

retropikzel/arena.sld

@@ -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"))
-

retropikzel/arena/README.md

@@ -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.

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
-                                      " "
+                                      ", mode: "
-                                      (number->string mode))
+                                      (number->string mode)
+                                      ", octal-mode: "
+                                      (number->string octal-mode))
                        (c-mkfifo path* octal-mode)))))
 
 (define open-input-pipe

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))

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
+(define wish-newline (lambda (pipe) (pipe-write-char #\newline pipe)))
-  (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))
+    (create-pipe input-pipe-path 0777)
-         (output-path (temp-name)))
+    (create-pipe output-pipe-path 0777)
-    (create-pipe input-path 0777)
+    (system (shell-command program output-pipe-path input-pipe-path))
-    (create-pipe output-path 0777)
+    (set! input-pipe (open-input-pipe input-pipe-path))
-    (system (shell-command program output-path input-path))
+    (set! output-pipe (open-output-pipe output-pipe-path))
-    (list (open-input-pipe input-path)
+    (list input-pipe output-pipe))
-          (open-output-pipe output-path))))
 
 (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))
+    (kawa (keyword? x))
-    (else (error "Keywords not supported on this implementation"))))
+    (srfi-88 (keyword? x))
-(define (keyword->string x)
+    (else (error "Keywords not supported" x))))
+
+(define (%keyword->string x)
   (cond-expand
-    (chicken (chicken-keyword->string x))
+    (kawa (keyword->string x))
-    (else (error "Keywords not supported on this implementation"))))
+    (stklos (keyword->string x))
+    (else (error "Keywords not supported" x))))
 
 (define nl (string #\newline))
 
@@ -151,16 +158,11 @@
   (lambda (x)
     (newline)
     (display x)
-    (newline)
+    (newline)))
-    ; (bottom x)
-    ))
-
-
 
 (define option?
   (lambda (x)
-    (or (and *use-keywords?*
+    (or (and *use-keywords?* (%keyword? x))
-             (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?*
+    (if (and *use-keywords?* (%keyword? x))
-             (keyword? x))
+      (string-append " -" (%keyword->string x))
-      (string-append " -" (keyword->string x))
+      (let* ((s (symbol->string x))
-      (let ((s (symbol->string x)))
+             (option (string-append " -" (substring s 0 (- (string-length s) 1)))))
-        (string-append " -"
+        option))))
-                       (substring s 0 (- (string-length s) 1)))))))
 
 (define improper-list->string
   (lambda (a first)
@@ -198,7 +199,7 @@
                                  (improper-list->string x #t))
                           ")"))
           ((eof-object? x) "#<eof>")
-          ((keyword? x) (keyword->string x))
+          ((and *use-keywords?* (%keyword? x)) (%keyword->string x))
           (else "#<unspecified>"))))
 
 (define string-translate
@@ -430,9 +431,7 @@
 
 (define scheme-arglist->tk-argstring
   (lambda (args)
-    (apply string-append
+    (apply string-append (map scheme-arg->tk-arg args))))
-           (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 ()

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"))
 

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
+    (let ((code (c-bytevector-ref pointer 'int 0)))
-                                  'sint
-                                  0
-                                  (native-endianness)
-                                  pointer-size)))
       (c-free pointer)
       code)))
 

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"

retropikzel/system.sld

@@ -2,6 +2,7 @@
   (retropikzel system)
   (import (scheme base)
           (scheme write)
+          (scheme process-context)
           (foreign c))
   (export system)
   (include "system.scm"))