From 0b7dacedbda699f017b775d1078e533afd70ae87 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 6 Feb 2026 14:54:02 +0200 Subject: [PATCH] Improvements to pstk --- .gitignore | 1 + Makefile | 35 ++++++++------- retropikzel/arena.scm | 23 ---------- retropikzel/arena.sld | 12 ------ retropikzel/arena/README.md | 39 ----------------- retropikzel/named-pipes.scm | 13 ++++-- retropikzel/named-pipes/test.scm | 4 +- retropikzel/pstk.scm | 73 +++++++++++++++++--------------- retropikzel/pstk.sld | 3 +- retropikzel/requests.scm | 6 +-- retropikzel/requests/test.scm | 4 -- retropikzel/system.sld | 1 + 12 files changed, 74 insertions(+), 140 deletions(-) delete mode 100644 retropikzel/arena.scm delete mode 100644 retropikzel/arena.sld delete mode 100644 retropikzel/arena/README.md 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"))