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

Improvements to pstk

This commit is contained in:
retropikzel 2026-02-06 14:54:02 +02:00
parent 9dd9354e46
commit 0b7dacedbd
12 changed files with 74 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

35
Makefile
View File

@ -23,9 +23,9 @@ endif
all: build
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
rm -rf *.tgz
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
@rm -rf *.tgz
@echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${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:

23
retropikzel/arena.scm
View File

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

12
retropikzel/arena.sld
View File

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

39
retropikzel/arena/README.md
View File

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

13
retropikzel/named-pipes.scm
View File

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

4
retropikzel/named-pipes/test.scm
View File

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

73
retropikzel/pstk.scm
View File

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

3
retropikzel/pstk.sld
View File

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

6
retropikzel/requests.scm
View File

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

4
retropikzel/requests/test.scm
View File

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

1
retropikzel/system.sld
View File

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