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

Compare commits

base: Retropikzel:main
Branches Tags
Retropikzel:main
Retropikzel:http
Retropikzel:docstring
..
compare: Retropikzel:docstring
Branches Tags
Retropikzel:main
Retropikzel:http
Retropikzel:docstring

2 Commits
main ... docstring

Author SHA1 Message Date
retropikzel bf70aa7bab Backup 2026-04-12 15:47:23 +03:00
retropikzel f073d84eb4 Started docstring library that uses error mechanism 2026-04-06 20:21:50 +03:00
85 changed files with 341 additions and 5167 deletions
Show Stats Expand all files Collapse all files

5
.gitignore vendored
View File

@ -14,7 +14,6 @@ Akku.*
srfi
snow
*.wasm
*.wat
*.js
*.a
*.o
@ -23,6 +22,4 @@ snow
*.link
core.*
venv*
retropikzel/wasm/plus.sld
retropikzel/*.c
retropikzel/*.meta

13
Dockerfile.jenkins
View File

@ -1,8 +1,5 @@
FROM debian:trixie-slim
RUN apt-get update && apt-get install -y \
gcc ca-certificates libffi-dev docker.io make curl
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 \
&& cd chibi-scheme \
&& make \
&& make install
RUN snow-chibi install --use-curl --impls=chibi retropikzel.test-r7rs
FROM alpine
RUN apk add make git docker
RUN git clone https://codeberg.org/retropikzel/test-r7rs.git --depth=8 --branch=bugfixes
RUN cd test-r7rs && ./configure && make && make install
COPY --from=schemers/chibi:alpine-head /usr/local /usr/local

67
Jenkinsfile vendored
View File

@ -3,66 +3,49 @@ pipeline {
dockerfile {
label 'docker-x86_64'
filename 'Dockerfile.jenkins'
args '-t --user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
reuseNode true
}
}
triggers {
GenericTrigger(
genericVariables: [[key: 'ref', value: '$.ref']],
causeString: 'Triggered on $ref',
printContributedVariables: true,
printPostContent: true,
silentResponse: false,
shouldNotFlatten: false,
regexpFilterText: '$ref',
regexpFilterExpression: 'refs/heads/' + BRANCH_NAME
)
}
options {
disableConcurrentBuilds()
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
}
environment {
R6RS_SCHEMES='capyscheme chezscheme guile ikarus ironscheme loko mosh racket sagittarius ypsilon'
R7RS_SCHEMES='capyscheme chibi chicken cyclone foment gauche gambit kawa loko meevax mosh racket sagittarius skint stklos tr7 ypsilon'
LIBRARIES='tap junit debug lambda-utils ctrf mouth string url-encoding leb128 hardware-info'
parameters {
string(name: 'R6RS_SCHEMES', defaultValue: 'capyscheme chezscheme guile ikarus ironscheme loko mosh racket sagittarius ypsilon', description: '')
string(name: 'R7RS_SCHEMES', defaultValue: 'capyscheme chibi chicken cyclone foment gauche gambit guile kawa loko meevax mit-scheme mosh racket sagittarius skint stklos tr7 ypsilon', description: '')
string(name: 'LIBRARIES', defaultValue: 'ctrf mouth string url-encoding leb128', description: '')
}
stages {
stage('Parallel') {
parallel {
stage('R6RS tests') {
steps {
script {
env.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
env.R6RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 600 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r6rs test-docker"
}
}
stage('R6RS tests') {
steps {
script {
params.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
params.R6RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 6000 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r6rs test-docker"
}
}
}
}
}
}
stage('R7RS tests') {
steps {
script {
env.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
env.R7RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 600 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r7rs test-docker"
}
}
}
}
stage('R7RS tests') {
steps {
script {
params.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
params.R7RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 6000 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r7rs test-docker"
}
}
}

78
Makefile
View File

@ -1,81 +1,53 @@
.SILENT:
SCHEME=chibi
RNRS=r7rs
LIBRARY=ctrf
DOCKER_TAG=latest
VENV=venv-${SCHEME}-${RNRS}-${LIBRARY}
AUTHOR=retropikzel
PKG=${AUTHOR}-${LIBRARY}-${VERSION}.tgz
tmpdir=.tmp/${SCHEME}/${LIBRARY}
LIBRARY_FILE=retropikzel/${LIBRARY}.sld
TESTFILE=retropikzel/${LIBRARY}/test.scm
VERSION != cat retropikzel/${LIBRARY}/VERSION
DESCRIPTION != head -n1 retropikzel/${LIBRARY}/README.md
VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
DESCRIPTION=$(shell head -n1 retropikzel/${LIBRARY}/README.md)
README=retropikzel/${LIBRARY}/README.html
TESTFILE=retropikzel/${LIBRARY}/test.scm
AKKU_PACKAGES=""
SFX=scm
SNOW=snow-chibi --impls=${SCHEME} install --always-yes
LIB_PATHS=
ifeq "${RNRS}" "r6rs"
SNOW=snow-chibi --impls=${SCHEME} install --always-yes --install-source-dir=. --install-library-dir=.
SFX=sps
AKKU_PACKAGES="akku-r7rs"
LIB_PATHS=-I .akku/lib
endif
ifeq "${SCHEME}" "capyscheme"
DOCKER_TAG=head
endif
ifeq "${SCHEME}" "chibi"
DOCKER_TAG=head
endif
ifeq "${SCHEME}" "chicken"
DOCKER_TAG=head
endif
ifeq "${SCHEME}" "gauche"
DOCKER_TAG=head
endif
all: build
all: package
package: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
snow-chibi package \
--always-yes \
--version=${VERSION} \
--authors=${AUTHOR} \
--doc=${README} \
--description="${DESCRIPTION}" \
${LIBRARY_FILE}
${PKG}: package
snow-chibi package --always-yes --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
install:
snow-chibi install --impls=${SCHEME} ${PKG}
snow-chibi install --impls=${SCHEME} --always-yes ${PKG}
testfiles: ${PKG} ${TESTFILE}
rm -rf ${tmpdir}
mkdir -p ${tmpdir}
cp ${PKG} ${tmpdir}
cat test-headers.${SFX} | sed 's/LIBRARY/${LIBRARY}/' > ${tmpdir}/test.${SFX}
cat ${TESTFILE} >> ${tmpdir}/test.${SFX}
testfiles: build
rm -rf .tmp
mkdir -p .tmp
cp ${PKG} .tmp/
cp -r retropikzel .tmp/
cat test-headers.${SFX} ${TESTFILE} | sed 's/LIBRARY/${LIBRARY}/' > .tmp/test.${SFX}
test: testfiles
cd ${tmpdir} && COMPILE_R7RS=${SCHEME} CSC_OPIONS="-L -lcurl" compile-r7rs -o test-program test.${SFX}
cd ${tmpdir} && ./test-program
cd .tmp && COMPILE_R7RS=${SCHEME} CSC_OPIONS="-L -lcurl" compile-r7rs -o test-program -I . test.${SFX}
cd .tmp && ./test-program
test-docker: testfiles
SNOW_PACKAGES="srfi.19 srfi.64 srfi.180 ${PKG}" \
APT_PACKAGES="libcurl4-openssl-dev" \
AKKU_PACKAGES="${AKKU_PACKAGES}" \
DOCKER_TAG=${DOCKER_TAG} \
COMPILE_R7RS=${SCHEME} \
CSC_OPIONS="-L -lcurl" \
test-r7rs -o ${tmpdir}/test-program ${tmpdir}/test.${SFX}
cd .tmp && SNOW_PACKAGES="srfi.39 srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth" \
APT_PACKAGES="" \
COMPILE_R7RS=${SCHEME} \
test-r7rs test.${SFX} ${PKG}
retropikzel/wasm/plus.wat: retropikzel/wasm/plus.c
retropikzel/wasm/plus.wasm: retropikzel/wasm/plus.c
emcc -o retropikzel/wasm/plus.js retropikzel/wasm/plus.c
wasm-dis retropikzel/wasm/plus.wasm > retropikzel/wasm/plus.wat
clean:
git clean -X -f

18
retropikzel/concat.scm
View File

@ -1,18 +0,0 @@
(define (->string separator arg)
(cond ((string? arg) (string-append separator arg))
(else
(let* ((port (open-output-string))
(str (begin
(display separator port)
(display arg port)
(get-output-string port))))
(close-port port)
str))))
(define (concat separator . args)
(apply string-append
(cons
(string-copy
(->string separator (car args))
(string-length separator))
(map (lambda (arg) (->string separator arg)) (cdr args)))))

8
retropikzel/concat.sld
View File

@ -1,8 +0,0 @@
(define-library
(retropikzel concat)
(import (scheme base)
(scheme read)
(scheme write))
(export concat)
(include "concat.scm"))

7
retropikzel/concat/README.md
View File

@ -1,7 +0,0 @@
String concatenate anything
**concat** args
All arguments are concatenate together, if arg is not string it's display
presention is used.

14
retropikzel/concat/test.scm
View File

@ -1,14 +0,0 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel concat)
(srfi 64))
(test-begin "concat")
(test-equal "1 2 3 foo bar (1 2 3 4)"
(concat " " 1 2 3 "foo" 'bar '(1 2 3 4)))
(test-end "concat")

236
retropikzel/ctrf.scm
View File

@ -1,125 +1,123 @@
(define-syntax ctrf-runner
(syntax-rules ()
((_)
(let ((time-s (lambda () (current-second)))
(any->string
(lambda (any)
(let ((port (open-output-string)))
(display any port)
(newline port)
(get-output-string port))))
(runner (test-runner-null))
(tests (vector))
(failed-tests (vector))
(current-test-start-time 0)
(current-test-groups (vector))
(current-test-group-count 0)
(first-group-name #f))
(define ctrf-runner
(lambda ()
(let ((any->string
(lambda (any)
(let ((port (open-output-string)))
(display any port)
(newline port)
(get-output-string port))))
(runner (test-runner-null))
(tests (vector))
(failed-tests (vector))
(current-test-start-time 0)
(current-test-groups (vector))
(current-test-group-count 0)
(first-group-name #f))
(test-runner-on-group-begin!
runner
(lambda (runner suite-name count)
(set! current-test-group-count 0)
(when (not first-group-name) (set! first-group-name suite-name))
(set! current-test-groups
(vector-append current-test-groups (vector suite-name)))))
(test-runner-on-group-begin!
runner
(lambda (runner suite-name count)
(set! current-test-group-count 0)
(when (not first-group-name) (set! first-group-name suite-name))
(set! current-test-groups
(vector-append current-test-groups (vector suite-name)))))
(test-runner-on-group-end!
runner
(lambda (runner)
(set! current-test-groups
(list->vector
(reverse
(list-tail
(reverse (vector->list current-test-groups))
1))))))
(test-runner-on-group-end!
runner
(lambda (runner)
(set! current-test-groups
(list->vector
(reverse
(list-tail
(reverse (vector->list current-test-groups))
1))))))
(test-runner-on-test-begin!
runner
(lambda (runner)
(set! current-test-group-count (+ current-test-group-count 1))
(set! current-test-start-time (time-s))))
(test-runner-on-test-begin!
runner
(lambda (runner)
(set! current-test-group-count (+ current-test-group-count 1))
(set! current-test-start-time (time-s))))
(test-runner-on-test-end!
runner
(lambda (runner)
(let* ((name (test-runner-test-name runner))
(result (test-result-kind runner))
(status (cond ((equal? result 'pass) "passed")
((equal? result 'xpass) "passed")
((equal? result 'fail) "failed")
((equal? result 'xfail) "failed")
((equal? result 'skipped) "skipped")
(else "other")))
(duration (- (time-s) current-test-start-time))
(result-ref
(lambda (runner key)
(let ((value (test-result-ref runner key)))
(if value (any->string value) "")))))
(let* ((suite (car (reverse (vector->list current-test-groups))))
(test `((name . ,name)
(status . ,status)
(duration . ,duration)
(suite . ,suite)
(extra . ((source-file . ,(result-ref runner 'source-file))
(source-line . ,(result-ref runner 'source-line))
(source-form . ,(result-ref runner 'source-form))
(count . ,current-test-group-count)
(expected-value . ,(result-ref runner 'expected-value))
(actual-value . ,(result-ref runner 'actual-value))
(expected-error . ,(result-ref runner 'expected-error))
(actual-error . ,(result-ref runner 'actual-error)))))))
(test-runner-on-test-end!
runner
(lambda (runner)
(let* ((name (test-runner-test-name runner))
(result (test-result-kind runner))
(status (cond ((equal? result 'pass) "passed")
((equal? result 'xpass) "passed")
((equal? result 'fail) "failed")
((equal? result 'xfail) "failed")
((equal? result 'skipped) "skipped")
(else "other")))
(duration (- (time-s) current-test-start-time))
(result-ref
(lambda (runner key)
(let ((value (test-result-ref runner key)))
(if value (any->string value) "")))))
(let* ((suite (car (reverse (vector->list current-test-groups))))
(test `((name . ,name)
(status . ,status)
(duration . ,duration)
(suite . ,suite)
(extra . ((source-file . ,(result-ref runner 'source-file))
(source-line . ,(result-ref runner 'source-line))
(source-form . ,(result-ref runner 'source-form))
(count . ,current-test-group-count)
(expected-value . ,(result-ref runner 'expected-value))
(actual-value . ,(result-ref runner 'actual-value))
(expected-error . ,(result-ref runner 'expected-error))
(actual-error . ,(result-ref runner 'actual-error)))))))
(when (or (equal? result 'fail)
(equal? result 'xfail))
(let ((failed (cons `(suite . ,suite) test)))
(display "FAIL " (current-error-port))
(json-write failed (current-error-port))
(newline (current-error-port))
(set! failed-tests (vector-append failed-tests (vector failed)))))
(set! tests (vector-append tests (vector test)))))))
(when (or (equal? result 'fail)
(equal? result 'xfail))
(let ((failed (cons `(suite . ,suite) test)))
(display "FAIL " (current-error-port))
(json-write failed (current-error-port))
(newline (current-error-port))
(set! failed-tests (vector-append failed-tests (vector failed)))))
(set! tests (vector-append tests (vector test)))))))
(test-runner-on-final!
runner
(lambda (runner)
(let*
((pass (test-runner-pass-count runner))
(xpass (test-runner-xpass-count runner))
(fail (test-runner-fail-count runner))
(xfail (test-runner-xfail-count runner))
(skipped (test-runner-skip-count runner))
(tool `((name . "(retropikzel ctrf)")
(version . "1.0.0")))
(summary `((tests . ,(+ pass xpass fail xfail))
(passed . ,(+ pass xpass))
(failed . ,(+ fail xfail))
(pending . 0)
(skipped . ,skipped)
(other . 0)))
(results `((tool . ,tool)
(summary . ,summary)
(tests . ,tests)))
(env `((appName . ,implementation-name)
(osPlatform . ,operation-system)))
(output `((reportFormat . "CTRF")
(specVersion . "0.0.0")
(results . ,results)
(generatedBy . "(retropikzel ctrf)")
(environment . ,env)))
(output-file (string-append implementation-name
"-"
first-group-name
".ctrf.json"))
(short-output `((scheme . ,implementation-name)
(summary . ,summary)
(full . ,output-file))))
(when (file-exists? output-file) (delete-file output-file))
(with-output-to-file
output-file
(lambda ()
(json-write output (current-output-port))))
(json-write short-output (current-output-port))
(newline (current-output-port))
;(exit (+ fail xfail))
)))
runner))))
(test-runner-on-final!
runner
(lambda (runner)
(let*
((pass (test-runner-pass-count runner))
(xpass (test-runner-xpass-count runner))
(fail (test-runner-fail-count runner))
(xfail (test-runner-xfail-count runner))
(skipped (test-runner-skip-count runner))
(tool `((name . "(retropikzel ctrf)")
(version . "1.0.0")))
(summary `((tests . ,(+ pass xpass fail xfail))
(passed . ,(+ pass xpass))
(failed . ,(+ fail xfail))
(pending . 0)
(skipped . ,skipped)
(other . 0)))
(results `((tool . ,tool)
(summary . ,summary)
(tests . ,tests)))
(env `((appName . ,implementation-name)
(osPlatform . ,operation-system)))
(output `((reportFormat . "CTRF")
(specVersion . "0.0.0")
(results . ,results)
(generatedBy . "(retropikzel ctrf)")
(environment . ,env)))
(output-file (string-append implementation-name
"-"
first-group-name
".ctrf.json"))
(short-output `((scheme . ,implementation-name)
(summary . ,summary)
(full . ,output-file))))
(when (file-exists? output-file) (delete-file output-file))
(with-output-to-file
output-file
(lambda ()
(json-write output (current-output-port))))
(json-write short-output (current-output-port))
(newline (current-output-port))
;(exit (+ fail xfail))
)))
runner)))

6
retropikzel/ctrf.sld
View File

@ -36,9 +36,11 @@
(racket (begin (define implementation-name "racket")))
(sagittarius (begin (define implementation-name "sagittarius")))
(skint (begin (define implementation-name "skint")))
(stklos (begin (define implementation-name "stklos")))
(stklos (begin (define implementation-name "stklos"))
(export ctrf-runner))
(tr7 (begin (define implementation-name "tr7")))
(ypsilon (begin (define implementation-name "ypsilon")))
(else (begin (define implementation-name "unknown"))))
(begin (define (time-s) (current-second)))
(begin
(define (time-s) (current-second)))
(include "ctrf.scm"))

2
retropikzel/ctrf/VERSION
View File

@ -1 +1 @@
1.2.3
1.2.1

26
retropikzel/debug.scm
View File

@ -1,27 +1,9 @@
(define print
(lambda args
(map (lambda (item) (display item (current-error-port))) args)))
(define-syntax debug-display
(syntax-rules ()
((_ obj)
(begin
(print "[DEBUG] " 'obj ": " obj #\newline)
obj))))
(define-syntax debug
(syntax-rules ()
((_ obj)
(begin
(print "[DEBUG] " 'obj ": " obj #\newline)
(display 'obj)
(display ": ")
(write obj)
(newline)
obj))))
(define-syntax debug-proc
(syntax-rules ()
((_ proc arg ...)
(begin
(print "[DEBUG] Calling: " 'proc ", arguments: " '(arg ...))
(let ((result (apply proc (list arg ...))))
(print ", returned: " result #\newline)
result)))))

4
retropikzel/debug.sld
View File

@ -2,7 +2,5 @@
(retropikzel debug)
(import (scheme base)
(scheme write))
(export debug
debug-display
debug-proc)
(export debug)
(include "debug.scm"))

2
retropikzel/debug/VERSION
View File

@ -1 +1 @@
1.1.0
1.0.0

15
retropikzel/debug/test.scm
View File

@ -1,15 +0,0 @@
(test-begin "debug")
(debug 'lol)
(debug-display 'lol)
(define someval 123)
(debug someval)
(debug-display someval)
(define (plus a b) (+ a b))
(debug plus)
(debug-display plus)
(debug-proc plus 1 2)
(test-end "debug")

22
retropikzel/docstring.scm Normal file
View File

@ -0,0 +1,22 @@
(define return (make-parameter (lambda (x) x) (lambda (x) x)))
(define doc-string
(make-parameter
""
(lambda (x)
(apply (return) (list x)))))
(define (doc procedure)
(letrec*
((looper
(lambda (args cont)
(if (> (length args) 100)
#f
(with-exception-handler
(lambda (x)
(cont (looper (cons (lambda () (error "" '())) args) cont)))
(lambda ()
(return cont)
(apply procedure args)))))))
(call-with-current-continuation (lambda (cont) (looper '() cont)))))

10
retropikzel/docstring.sld Normal file
View File

@ -0,0 +1,10 @@
(define-library
(retropikzel docstring)
(import (scheme base)
(scheme write)
(srfi 39))
(export doc-string
doc
)
(include "docstring.scm"))

0
retropikzel/concat/LICENSE → retropikzel/docstring/LICENSE
View File

0
retropikzel/lambda-utils/README.md → retropikzel/docstring/README.md
View File

0
retropikzel/concat/VERSION → retropikzel/docstring/VERSION
View File

21
retropikzel/docstring/test.scm Normal file
View File

@ -0,0 +1,21 @@
;(test-begin "docstring")
(define (plus a b)
(doc-string "Add a to b")
(+ a b))
(define (minus a b)
(- a b))
(write (plus 1 1))
(newline)
(display (doc plus))
(newline)
(write (minus 1 1))
(newline)
(display (doc minus))
(newline)
;(test-end "docstring")

19
retropikzel/hardware-info.scm
View File

@ -1,19 +0,0 @@
(define (cpu-count)
(cond
((not (file-exists? "/proc/cpuinfo"))
(error "Could not get cpu count"))
(else
(let ((count 0))
(letrec*
((looper (lambda (line)
(cond
((eof-object? line) count)
(else
(when (and (> (string-length line) 8)
(string=? (string-copy line 0 9) "processor"))
(set! count (+ count 1)))
(looper (read-line)))))))
(with-input-from-file
"/proc/cpuinfo"
(lambda ()
(looper (read-line)))))))))

8
retropikzel/hardware-info.sld
View File

@ -1,8 +0,0 @@
(define-library
(retropikzel hardware-info)
(import (scheme base)
(scheme read)
(scheme write)
(scheme file))
(export cpu-count)
(include "hardware-info.scm"))

165
retropikzel/hardware-info/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

6
retropikzel/hardware-info/README.md
View File

@ -1,6 +0,0 @@
Get hardware information
(**cpu-count**)
Returns the amount of central processing units the system has.

1
retropikzel/hardware-info/VERSION
View File

@ -1 +0,0 @@
0.1.0

12
retropikzel/hardware-info/test.scm
View File

@ -1,12 +0,0 @@
(test-begin "hardware-info")
(define cpus (cpu-count))
(test-assert (number? cpus))
(write cpus)
(newline)
(test-end "hardware-info")

209
retropikzel/junit.scm
View File

@ -1,209 +0,0 @@
(define junit-runner-output-port (current-output-port))
(define (set-junit-runner-output-port! port)
(set! junit-runner-output-port port))
(define-syntax junit-runner
(syntax-rules ()
((_)
(letrec* ((hostname (if (file-exists? "/etc/hostname")
(with-input-from-file "/etc/hostname"
(lambda () (read-line)))
"localhost"))
(any->string
(lambda (any)
(let ((port (open-output-string)))
(display any port)
(get-output-string port))))
(indentation '())
(increase-indentation
(lambda ()
(set! indentation (append indentation '(#\space #\space)))))
(decrease-indentation
(lambda ()
(when (not (null? indentation))
(set! indentation (list-tail indentation 2)))))
(print
(lambda args
(map (lambda (item)
(display item junit-runner-output-port))
(append indentation args))))
(println
(lambda args
(map (lambda (item)
(display item junit-runner-output-port))
(append indentation args)) (newline junit-runner-output-port)))
(string-replace
(lambda (str replace with)
(list->string
(map (lambda (c)
(if (char=? c replace)
with
c))
(string->list str)))))
(runner (test-runner-null))
(group-tests '())
(started? #f)
(current-group-name #f)
(current-group-start-time #f)
(current-group-start-date #f)
(current-test-start-time #f)
(current-test-groups (vector))
(current-test-group-count 0)
(current-suite-name #f)
(total-pass 0)
(total-xpass 0)
(total-fail 0)
(total-xfail 0)
(total-skipped 0))
(test-runner-on-group-begin!
runner
(lambda (runner suite-name count)
(set! current-group-name suite-name)
(set! current-group-start-time (current-time time-utc))
(set! current-group-start-date (current-date))
(set! current-test-group-count 0)
(set! current-suite-name suite-name)
(set! current-test-groups
(vector-append current-test-groups (vector suite-name)))
(set! group-tests '())))
(test-runner-on-group-end!
runner
(lambda (runner)
(let* ((group-time
(time-second (time-difference (current-time time-utc)
current-group-start-time)))
(pass (- (test-runner-pass-count runner) total-pass))
(xpass (- (test-runner-xpass-count runner) total-xpass))
(fail (- (test-runner-fail-count runner) total-fail))
(xfail (- (test-runner-xfail-count runner) total-xfail))
(skipped (- (test-runner-skip-count runner) total-skipped))
(total-tests (+ pass xpass fail xfail skipped))
(timestamp
(date->string current-group-start-date "~1-T~3+0000"))
(testsuite-name-raw
(apply string-append
(map
(lambda (item)
(string-append item "."))
(test-runner-group-path runner))))
(testsuite-name
(string-replace
(string-copy testsuite-name-raw
0
(- (string-length testsuite-name-raw) 1))
#\space
#\-)))
(when (> total-tests 0)
(println "<testsuite"
" name=\"" testsuite-name "\""
" timestamp=\"" timestamp "\""
" hostname=\"" hostname "\""
" time=\"" group-time "\""
" tests=\"" total-tests "\""
" failures=\"" fail "\""
" skipped=\"" skipped "\""
">")
(increase-indentation)
(for-each
(lambda (test)
(println "<testcase"
" classname=\""
(string-append
testsuite-name
"."
(number->string (cdr (assoc 'count test))))
"\""
" name=\""
(if (string=? (cdr (assoc 'name test)) "")
(cdr (assoc 'count test))
(cdr (assoc 'name test)))
"\""
" time=\"" (cdr (assoc 'duration test)) "\""
">")
(when (string=? (cdr (assoc 'status test)) "failed")
(increase-indentation)
(println "<failure"
" type=\"" "fail" "\""
(if (and (not (string=? (cdr (assoc 'expected-value test)) ""))
(not (string=? (cdr (assoc 'actual-value test)) "")))
(string-append
" message=\"expected value: "
(cdr (assoc 'expected-value test))
" actual-value: "
(cdr (assoc 'actual-value test))
"\"")
"")
">")
(println "</failure>")
(decrease-indentation))
(println "</testcase>"))
(reverse group-tests))
(decrease-indentation)
(println "</testsuite>")
(set! current-test-groups
(list->vector
(reverse
(list-tail
(reverse (vector->list current-test-groups))
1))))
(set! total-pass (test-runner-pass-count runner))
(set! total-xpass (test-runner-xpass-count runner))
(set! total-fail (test-runner-fail-count runner))
(set! total-xfail (test-runner-xfail-count runner))
(set! total-skipped (test-runner-skip-count runner))))))
(test-runner-on-test-begin!
runner
(lambda (runner)
(when (not started?)
(println "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
(println "<testsuites>")
(increase-indentation)
(set! started? #t))
(set! current-test-group-count (+ current-test-group-count 1))
(set! current-test-start-time (current-time time-utc))))
(test-runner-on-test-end!
runner
(lambda (runner)
(let* ((end-time (current-time time-utc))
(duration
(time-second
(time-difference end-time current-test-start-time)))
(name (test-runner-test-name runner))
(result (test-result-kind runner))
(status (cond ((equal? result 'pass) "passed")
((equal? result 'xpass) "passed")
((equal? result 'fail) "failed")
((equal? result 'xfail) "failed")
((equal? result 'skipped) "skipped")
(else "other")))
(result-ref
(lambda (runner key)
(let ((value (test-result-ref runner key)))
(if value (any->string value) "")))))
(let* ((suite (car (reverse (vector->list current-test-groups))))
(test `((name . ,name)
(status . ,status)
(duration . ,duration)
(suite . ,suite)
(source-file . ,(result-ref runner 'source-file))
(source-line . ,(result-ref runner 'source-line))
(source-form . ,(result-ref runner 'source-form))
(count . ,current-test-group-count)
(expected-value . ,(result-ref runner 'expected-value))
(actual-value . ,(result-ref runner 'actual-value))
(expected-error . ,(result-ref runner 'expected-error))
(actual-error . ,(result-ref runner 'actual-error)))))
(set! group-tests (cons test group-tests))))))
(test-runner-on-final!
runner
(lambda (runner)
(decrease-indentation)
(println "</testsuites>")))
runner))))

10
retropikzel/junit.sld
View File

@ -1,10 +0,0 @@
(define-library
(retropikzel junit)
(import (scheme base)
(scheme write)
(scheme file)
(srfi 19)
(srfi 64))
(export junit-runner
set-junit-runner-output-port!)
(include "junit.scm"))

165
retropikzel/junit/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

30
retropikzel/junit/README.md
View File

@ -1,30 +0,0 @@
JUnit, output for SRFI-64
[JUnit](https://junit.org/)
## Usage
(import (scheme base)
(srfi 64)
(retropikzel junit))
(test-runner-current (junit-runner))
## Reference
(**junit-runner**)
Get the JUnit test runner.
(**set-junit-runner-output-port!** port)
Set the output port of the test runner. To output to file you can do:
(define junit-file "junit-result.xml")
(when (file-exists? junit-file) (delete-file junit-file))
(set-junit-runner-output-port! (open-output-file junit-file))

1
retropikzel/junit/VERSION
View File

@ -1 +0,0 @@
0.3.1

19
retropikzel/junit/test.scm
View File

@ -1,19 +0,0 @@
(test-runner-current (junit-runner))
(test-begin "junit")
(test-begin "junit 1")
(test-assert #t)
(test-assert #t)
(test-assert #f)
(test-equal '(1 2 3) '(4 5 6))
(test-end "junit 1")
(test-begin "junit 2")
(test-equal '(1 2 3) '(1 2 3))
(test-assert #t)
(test-assert "I have a name" #t)
(test-end "junit 2")
(test-end "junit")

29
retropikzel/lambda-utils.scm
View File

@ -1,29 +0,0 @@
(define-syntax default-lambda
(syntax-rules ()
((_ ((arg default) ...) body ...)
(lambda args
(let ((arg default) ...)
(for-each
(lambda (item)
(when (equal? (car item) 'arg) (set! arg (cadr item))) ...)
args)
body ...)))))
(define-syntax default-checked-lambda
(syntax-rules ()
((_ ((arg default check) ...) body ...)
(lambda args
(let ((arg default) ...)
(for-each
(lambda (item)
(when (equal? (car item) 'arg)
(set! arg (cadr item))
(when (not (check arg))
(error
(string-append "argument: "
(symbol->string 'arg)
", failed check: "
(symbol->string 'check)))))
...)
args)
body ...)))))

7
retropikzel/lambda-utils.sld
View File

@ -1,7 +0,0 @@
(define-library
(retropikzel lambda-utils)
(import (scheme base))
(export default-lambda
default-checked-lambda)
(include "lambda-utils.scm"))

165
retropikzel/lambda-utils/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

1
retropikzel/lambda-utils/VERSION
View File

@ -1 +0,0 @@
0.1.0

12
retropikzel/lambda-utils/test.scm
View File

@ -1,12 +0,0 @@
(test-begin "lambda-utils")
(define dl (default-lambda ((arg1 #f) (arg2 #f)) arg2))
(test-assert (not (dl)))
(test-equal 1 (dl '(arg2 1)))
(define dcl (default-checked-lambda ((arg1 #f string?) (arg2 #f string?)) arg2))
(test-assert (not (dcl)))
(test-equal "hello" (dcl '(arg2 "hello")))

53
retropikzel/leb128.scm
View File

@ -111,56 +111,3 @@
(not (exact-integer? (car start-index))))
(error "uleb128->integer: start-index must be exact integer" (car start-index)))
(car (uleb128->integer-and-length bytes (if (null? start-index) 0 (car start-index)))))
(define (read-leb128-and-length port)
(when (not (binary-port? port))
(error "read-leb128-and-length: port must be binary-port" port))
(letrec*
((result 0)
(shift 0)
(byte #f)
(looper
(lambda ()
(set! byte (read-u8 port))
(set! result (+ result (arithmetic-shift (bitwise-and byte #x7f) shift)))
(when (not (= (bitwise-and byte #x80) 0))
(set! shift (+ shift 7))
(set! index (+ index 1))
(looper)))))
(looper)
(cons
(if (not (= (bitwise-and byte #x40) 0))
(bitwise-ior result (* (arithmetic-shift 1 (+ shift 7)) -1))
result)
(+ index 1))))
(define (read-leb128 port)
(when (not (binary-port? port))
(error "read-leb128: port must be binary-port" port))
(car (read-leb128-and-length port)))
(define (read-uleb128-and-length port)
(when (not (binary-port? port))
(error "read-uleb128: port must be binary port" port))
(letrec*
((uleb-bytes-count 1)
(byte (read-u8 port))
(shift 0)
(result (arithmetic-shift (bitwise-and byte #x7f) shift))
(looper
(lambda ()
(cond
((= (bitwise-and byte #x80) 0) (cons result uleb-bytes-count))
(else
(set! uleb-bytes-count (+ uleb-bytes-count 1))
(set! byte (read-u8 port))
(set! result (bitwise-ior result (arithmetic-shift (bitwise-and byte #x7f) shift)))
(set! shift (+ shift 7))
(looper))))))
(set! shift (+ shift 7))
(looper)))
(define (read-uleb128 port)
(when (not (binary-port? port))
(error "read-uleb128: port must be binary-port" port))
(car (read-uleb128-and-length port)))

6
retropikzel/leb128.sld
View File

@ -8,9 +8,5 @@
leb128->integer-and-length
integer->uleb128
uleb128->integer
uleb128->integer-and-length
read-leb128
read-leb128-and-length
read-uleb128
read-uleb128-and-length)
uleb128->integer-and-length)
(include "leb128.scm"))

9
retropikzel/leb128/README.md
View File

@ -43,15 +43,6 @@ positive integer or 0 of uleb128 value.
Sams as uleb128->integer but returns a pair with integer as car and uleb128
bytevector length, as in how many bytes long the leb128 was, as cdr.
(**read-uleb12** port)
Read uleb128 from given port. *port* must be binary inpurt port. Returns exact
positive integer or 0 of uleb128 value.
(**read-leb12** port)
Read leb128 from given port. *port* must be binary inpurt port. Returns exact
integer of leb128 value.
Resources used:
https://en.wikipedia.org/wiki/LEB128

2
retropikzel/leb128/VERSION
View File

@ -1 +1 @@
1.1.1
1.0.0

15
retropikzel/mouth/snow-test.scm
View File

@ -1,15 +0,0 @@
(import (scheme base)
(retropikzel mouth)
(srfi 64))
(test-begin "mouth")
(spit "/tmp/mouthtestfile" "Hello world")
(test-assert (string=? (slurp "/tmp/mouthtestfile") "Hello world"))
(spit "/tmp/mouthtestfile" ", and append" #t)
(test-assert (string=? (slurp "/tmp/mouthtestfile") "Hello world, and append"))
(test-end "mouth")

19
retropikzel/parallel-srfi-18.scm
View File

@ -1,19 +0,0 @@
(define thread-proc (lambda (x) #t))
(define (new-thread)
(make-thread
(lambda ()
(thread-specific-set!
(current-thread)
(thread-proc (thread-specific (current-thread)))))))
(define threads (make-list thread-count (new-thread)))
(define-syntax parallel-map
(syntax-rules ()
((_ env (l args body ...) lst)
(let* ((lst-length (length lst))
(thread-proc (eval `(lambda args body ...)
(apply environment 'env))))
(map thread-proc lst)
))))

6
retropikzel/parallel.scm
View File

@ -1,6 +0,0 @@
(define-syntax parallel-map
(syntax-rules ()
((_ env (l args body ...) lst)
(let* ((lst-length (length lst))
(proc (eval `(lambda args body ...) (apply environment 'env))))
(map proc lst)))))

16
retropikzel/parallel.sld
View File

@ -1,16 +0,0 @@
(define-library
(retropikzel parallel)
(import (scheme base)
(scheme write)
(scheme eval)
(retropikzel hardware-info)
(retropikzel purer))
(include "parallel/shared.scm")
(cond-expand
((library (srfi 18))
(import (srfi 18))
(include "parallel-srfi-18.scm"))
(else
(import (scheme base))
(include "parallel.scm")))
(export parallel-map))

165
retropikzel/parallel/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

1
retropikzel/parallel/README.md
View File

@ -1 +0,0 @@
WIP

1
retropikzel/parallel/VERSION
View File

@ -1 +0,0 @@
0.1.0

1
retropikzel/parallel/shared.scm
View File

@ -1 +0,0 @@
(define thread-count (guard (condition (else 4)) (cpu-count)))

9
retropikzel/parallel/test.scm
View File

@ -1,9 +0,0 @@
(write (parallel-map
((scheme base))
(lambda (i)
(+ i 1))
'(1 2 3 4 5 6 7 8 9 10)))
(newline)

4
retropikzel/purer.scm
View File

@ -1,4 +0,0 @@
(define-syntax purer-lambda
(syntax-rules ()
((_ env args body ...)
(eval `(lambda args body ...) (apply environment 'env)))))

8
retropikzel/purer.sld
View File

@ -1,8 +0,0 @@
(define-library
(retropikzel purer)
(import (scheme base)
(scheme eval))
(export purer-lambda)
(include "purer.scm"))

165
retropikzel/purer/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

1
retropikzel/purer/README.md
View File

@ -1 +0,0 @@
WIP

1
retropikzel/purer/VERSION
View File

@ -1 +0,0 @@
0.1.0

10
retropikzel/purer/test.scm
View File

@ -1,10 +0,0 @@
(define x 5)
(define inc (purer-lambda
((scheme base))
(i)
(+ i 1)))
(display "HERE: ")
(write (inc 1))
(newline)

3
retropikzel/r7rs-tests.scm
View File

@ -1,3 +0,0 @@
(define (run-r7rs-tests)
(display "To run r7rs-tests run this packages test with snow-chibi")
(newline))

8
retropikzel/r7rs-tests.sld
View File

@ -1,8 +0,0 @@
(define-library
(retropikzel r7rs-tests)
(import (scheme base)
(scheme write)
(srfi 64)
(retropikzel ctrf))
(export run-r7rs-tests)
(include "r7rs-tests.scm"))

1
retropikzel/r7rs-tests/LICENSE
View File

@ -1 +0,0 @@
WIP

3
retropikzel/r7rs-tests/README.md
View File

@ -1,3 +0,0 @@
R7RS test suite. Covers all procedures and syntax in the small language except
`delete-file'. Currently assumes full-unicode support, the full numeric tower
and all standard libraries provided.

1
retropikzel/r7rs-tests/VERSION
View File

@ -1 +0,0 @@
1.0.0

2499
retropikzel/r7rs-tests/snow-test.scm
View File

File diff suppressed because it is too large Load Diff

99
retropikzel/tap.scm
View File

@ -1,99 +0,0 @@
(define tap-output-port (current-output-port))
(define (set-tap-runner-output-port! port) (set! tap-output-port port))
(define-syntax tap-runner
(syntax-rules ()
((_)
(letrec* ((any->string
(lambda (any)
(let ((port (open-output-string)))
(display any port)
(get-output-string port))))
(indentation '())
(increase-indentation
(lambda ()
(set! indentation (append indentation '(#\space #\space)))))
(decrease-indentation
(lambda ()
(when (not (null? indentation))
(set! indentation (list-tail indentation 2)))))
(print
(lambda args
(map (lambda (item)
(display item tap-output-port))
(append indentation args))))
(println
(lambda args
(map (lambda (item)
(display item tap-output-port))
(append indentation args))
(display "\n" tap-output-port)))
(runner (test-runner-null))
(started? #f)
(current-test-groups (vector))
(current-test-group-count 0)
(current-suite-name #f))
(test-runner-on-group-begin!
runner
(lambda (runner suite-name count)
(set! current-test-group-count 0)
(when current-suite-name
(println "# Subtest: " suite-name)
(increase-indentation))
(set! current-suite-name suite-name)
(set! current-test-groups (vector-append current-test-groups (vector suite-name)))))
(test-runner-on-group-end!
runner
(lambda (runner)
(when (> current-test-group-count 0)
(println "1.." current-test-group-count))
(decrease-indentation)
(set! current-test-groups
(list->vector
(reverse
(list-tail
(reverse (vector->list current-test-groups))
1))))))
(test-runner-on-test-begin!
runner
(lambda (runner)
(when (not started?)
(println "TAP version 14")
(set! started? #t))
(set! current-test-group-count (+ current-test-group-count 1))))
(test-runner-on-test-end!
runner
(lambda (runner)
(let* ((name (test-runner-test-name runner))
(result (test-result-kind runner))
(status (cond ((equal? result 'pass) "passed")
((equal? result 'xpass) "passed")
((equal? result 'fail) "failed")
((equal? result 'xfail) "failed")
((equal? result 'skipped) "skipped")
(else "other")))
(result-ref
(lambda (runner key)
(let ((value (test-result-ref runner key)))
(if value (any->string value) "")))))
(let* ((failed? (or (equal? result 'fail) (equal? result 'xfail))))
(when failed? (print "not "))
(print "ok " current-test-group-count)
(if (and (string? name) (not (string=? name "")))
(println " - " name)
(println ""))
(when failed?
(println " ---")
(println " severity: fail")
(println " data:")
(println " source: " (result-ref runner 'source-form))
(println " got: " (result-ref runner 'actual-value))
(println " expect: " (result-ref runner 'expected-value))
(println " at: ")
(println " file: " (result-ref runner 'source-file))
(println " line: " (result-ref runner 'source-line)))))))
runner))))

9
retropikzel/tap.sld
View File

@ -1,9 +0,0 @@
(define-library
(retropikzel tap)
(import (scheme base)
(scheme write)
(srfi 64))
(export tap-runner
set-tap-runner-output-port!)
(include "tap.scm"))

165
retropikzel/tap/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

29
retropikzel/tap/README.md
View File

@ -1,29 +0,0 @@
TAP output for SRFI-64
[Test Anything Protocol](https://testanything.org/)
## Usage
(import (scheme base)
(srfi 64)
(retropikzel tap))
(test-runner-current (tap-runner))
## Reference
(**tap-runner**)
Get the TAP test runner.
(**set-tap-runner-output-port!** port)
Set the output port of the test runner. To output to file you can do:
(define tap-file "tap-result.txt")
(when (file-exists? tap-file) (delete-file tap-file))
(set-tap-runner-output-port! (open-output-file tap-file))

1
retropikzel/tap/VERSION
View File

@ -1 +0,0 @@
0.2.1

24
retropikzel/tap/test.scm
View File

@ -1,24 +0,0 @@
(test-runner-current (tap-runner))
(test-begin "tap")
(test-assert #t)
(test-assert #t)
(test-begin "tap 1")
(test-assert #t)
(test-assert #t)
(test-assert #f)
(test-equal '(1 2 3) '(4 5 6))
(test-end "tap 1")
(test-begin "tap 2")
(test-equal '(1 2 3) '(1 2 3))
(test-assert #t)
(test-assert "I have a name" #t)
(test-end "tap 2")
(test-assert #t)
(test-equal '(4 5 6) '(7 8 9))
(test-end "tap")

11
retropikzel/tiled.scm
View File

@ -1,11 +0,0 @@
(define-record-type <map>
(make-map width height layers)
map?
(width map-width)
(height map-height)
(layers map-layers))
(define (read-map port)
(json-read port)
)

8
retropikzel/tiled.sld
View File

@ -1,8 +0,0 @@
(define-library
(retropikzel tiled)
(import (scheme base)
(scheme write)
(srfi 180))
(export read-map
map?)
(include "tiled.scm"))

165
retropikzel/tiled/LICENSE
View File

@ -1,165 +0,0 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

8
retropikzel/tiled/README.md
View File

@ -1,8 +0,0 @@
Library for parsing tiled map editor maps
[tiled](https://www.mapeditor.org/)
## Reference

1
retropikzel/tiled/VERSION
View File

@ -1 +0,0 @@
0.1.0

9
retropikzel/tiled/test.scm
View File

@ -1,9 +0,0 @@
(test-begin "tiled")
(define mapdata (read-map (open-input-file "retropikzel/tiled/testmap.json")))
(write mapdata)
(newline)
(test-end "tiled")

181
retropikzel/wasm.old.scm
View File

@ -1,181 +0,0 @@
(define (read-bytevector-until until . port)
(letrec*
((current-port (if (null? port) (current-input-port) (car port)))
(checklist (if (list? until) until (list until)))
(looper (lambda (bytes)
(display "HERE: ")
(write checklist)
(newline)
(write (member (peek-u8 current-port) checklist =))
(newline)
(if (or (eof-object? (peek-u8 current-port))
(member (peek-u8 current-port) checklist =))
bytes
(looper (bytevector-append bytes (bytevector (read-u8 current-port))))))))
(looper (bytevector))))
(define (list-slice l start end)
(vector->list (vector-copy (list->vector l) start end)))
(define (byte->type byte)
(cond ((= byte 0) 'void)
;; Number types
((= byte #x7C) 'f64)
((= byte #x7D) 'f32)
((= byte #x7E) 'i64)
((= byte #x7F) 'i32)
;; Vector type
((= byte #x7B) 'V128)
;; Heap types
((= byte #x69) 'exn)
((= byte #x6A) 'array)
((= byte #x6B) 'struct)
((= byte #x6C) 'i31)
((= byte #x6D) 'eq)
((= byte #x6E) 'any)
((= byte #x6F) 'extern)
((= byte #x70) 'func)
((= byte #x71) 'none)
((= byte #x72) 'noextern)
((= byte #x73) 'nofunc)
((= byte #x74) 'noexn)
(else
(display "byte->type warning: Unknown type ")
(display (bytevector byte))
(newline)
'unknown)))
(define (read-types type-count section-size port result)
(letrec*
((type-delimiter #x60)
(type-signature-byte->name
(lambda (byte)
(cond ((= byte #x5E) 'array)
((= byte #x5F) 'struct)
((= byte #x60) 'func)
(else 'unknown))))
(type-signature-byte?
(lambda (byte)
(not (symbol=? (type-signature-byte->name byte) 'unknown))))
(type-bytes->type
(lambda (bytes)
(let*
((argument-count (list-ref bytes 1))
(argument-types (map byte->type (list-slice bytes 2 (+ 2 argument-count))))
(return-type (byte->type (car (reverse bytes)))))
(append
`(,(type-signature-byte->name (list-ref bytes 0))
,(if (null? argument-types) '() `(param ,@argument-types))
,(if (symbol=? return-type 'void) '() `(result ,return-type)))))))
(read-type
(lambda (type-result)
(cond
((and (or (eof-object? (peek-u8 port))
(type-signature-byte? (peek-u8 port))
(= (+ (apply + (map length result))
(+ (length type-result) 1))
section-size))
(> (length type-result) 0))
(reverse type-result))
(else
(read-type (cons (read-u8 port) type-result)))))))
(cond
((= (length result) type-count)
(map type-bytes->type (reverse result)))
(else (read-types type-count section-size port (cons (read-type '()) result))))))
(define (read-import import-count section-size port result)
(if (= (length result) import-count)
result
(letrec*
((import-kind->type (lambda (type) (cond ((= type 0) 'func) (else 'unknown))))
(module-name-length (read-u8 port))
(module-name (utf8->string (read-bytevector module-name-length port)))
(field-name-length (read-u8 port))
(field-name (utf8->string (read-bytevector field-name-length port)))
(import-kind (read-u8 port))
(type-index (read-u8 port)))
(read-import import-count
section-size
port
(cons `(import (module ,module-name)
(field ,field-name)
(type ,type-index))
result)))))
(define (read-function function-count section-size port result)
(display "HERE: ")
(write result)
(newline)
(if (= (length result) function-count)
(reverse result)
(read-function function-count
section-size
port
(cons (read-bytevector-until 0 port) result))))
(define (read-tables type-count section-size port result)
`((bytes ,(read-bytevector (- section-size 1) port))))
(define (read-memory type-count section-size port result)
`((bytes ,(read-bytevector (- section-size 1) port))))
(define (read-global type-count section-size port result)
`((bytes ,(read-bytevector (- section-size 1) port))))
(define (read-section name size port)
(list name
(cond
((symbol=? name 'custom) (read-bytevector size port))
((symbol=? name 'type) (read-types (read-u8 port) size port '()))
((symbol=? name 'import) (read-import (read-u8 port) size port '()))
((symbol=? name 'function) (read-function (read-u8 port) size port '()))
((symbol=? name 'table) (read-tables (read-u8 port) size port '()))
((symbol=? name 'memory) (read-memory (read-u8 port) size port '()))
((symbol=? name 'global) (read-global (read-u8 port) size port '()))
((symbol=? name 'export) (read-bytevector size port))
((symbol=? name 'start) (read-bytevector size port))
((symbol=? name 'element) (read-bytevector size port))
((symbol=? name 'code) (read-bytevector size port))
((symbol=? name 'data) (read-bytevector size port)))))
(define (section-id->name id)
(cond ((= id 0) 'custom)
((= id 1) 'type)
((= id 2) 'import)
((= id 3) 'function)
((= id 4) 'table)
((= id 5) 'memory)
((= id 6) 'global)
((= id 7) 'export)
((= id 8) 'start)
((= id 9) 'element)
((= id 10) 'code)
((= id 11) 'data)
((= id 12) 'data-count)
((= id 13) 'tag)
(else (error "section-id->name: unrecognized section id" id))))
(define (wasm->sexp-loop port result)
(let* ((section-id (read-u8 port))
(section-name (section-id->name section-id))
(size (read-uleb128 port))
(section (read-section section-name size port)))
(display "Section name: ")
(display section-name)
(newline)
(display "Section size: ")
(write size)
(newline)
(if (eof-object? (peek-u8 port))
(reverse result)
(wasm->sexp-loop port (cons section result)))))
(define (wasm->sexp port)
(let ((magic-bytes (read-bytevector 4 port)))
(when (not (equal? magic-bytes #u8(#x00 #x61 #x73 #x6D)))
(error "Binary is not wasm (missing magic bytes)"))
(letrec*
((version (read-bytevector 4 port)))
(wasm->sexp-loop port '()))))

7
retropikzel/wasm.old.sld
View File

@ -1,7 +0,0 @@
(define-library
(retropikzel wasm)
(import (scheme base)
(scheme write)
(retropikzel leb128))
(export wasm->sexp)
(include "wasm.scm"))

219
retropikzel/wasm.scm
View File

@ -1,147 +1,84 @@
(define (get-data wat)
(car
(filter-map
(lambda (item)
(if (equal? (car item) 'data)
(let ((bytes
(filter-map
(lambda (c)
(display "HERE: c ")
(write c)
(newline)
(if (char=? c #\null)
#f
c))
(string->list (list-ref item 2)))))
(display "HERE: bytes")
(write bytes)
(newline)
(display "HERE: something ")
(write (map (lambda (c) (string->number (string c))) (string->list (list->string bytes))))
(newline)
(cons (cadr (list-ref item 1)) bytes))
#f))
(cdr wat))))
(define (wasm-bytevector? bytes)
(equal? (bytevector-copy bytes 0 4) (bytevector #x0 #x61 #x73 #x6D)))
(define (get-global-export-names wat)
(filter-map
(lambda (item)
(if (and (equal? (car item) 'export) (assq 'global item))
(cons (cadr (assq 'global item)) (string->symbol (cadr item)))
#f))
(cdr wat)))
(define (wasm-version bytes)
(bytevector-copy bytes 4 8))
(define (get-globals wat)
(filter-map
(lambda (item)
(cond
((equal? (car item) 'global)
`(define ,(list-ref item 1) ,(cadr (car (reverse item)))))
((and (equal? (car item) 'export) (assq 'global item))
`(define ,(string->symbol (cadr item)) ,(cadr (car (reverse item)))))
(else #f)))
(cdr wat)))
(define (section-id->name id)
(cond ((= id 0) 'custom)
((= id 1) 'type)
((= id 2) 'import)
((= id 3) 'function)
((= id 4) 'table)
((= id 5) 'memory)
((= id 6) 'global)
((= id 7) 'export)
((= id 8) 'start)
((= id 9) 'element)
((= id 10) 'code)
((= id 11) 'data)
((= id 12) 'data-count)
((= id 13) 'tag)
(else (error "section-id->name: unrecognized section id" id))))
#;(define (get-memory-export-names wat)
(filter-map
(lambda (item)
(if (and (equal? (car item) 'export) (assq 'memory item))
(string->symbol
(string-append "memory-"
(symbol->string (cadr (assq 'memory item)))))
#f))
(cdr wat)))
(define (bytes->type bytes)
(let ((first-byte (bytevector-u8-ref bytes 0)))
(display "HERE: ")
(display first-byte)
(newline)
(cond
((equal? first-byte #x7C) 'f64)
((equal? first-byte #x7D) 'f32)
((equal? first-byte #x7E) 'f64)
((equal? first-byte #x7F) 'f32)
(else 'unknown)
;(else (error "Unsupported type byte" first-byte))
)))
(define (get-memories wat)
(filter-map
(lambda (item)
(cond
((equal? (car item) 'memory)
(let* ((sizes (list-tail item 2))
(size (* (cond ((= (length sizes) 1)
(list-ref sizes 0))
(else (list-ref sizes 1)))
webassembly-page-size)))
`(vector-set! memory-index
,(string->number
(string-copy (symbol->string (list-ref item 1))
1))
(make-bytevector ,size 0))))
(else #f)))
(cdr wat)))
(define (bytes->types bytes)
(letrec*
((bytes-length (bytevector-length bytes))
(looper
(lambda (index types)
(if (>= index bytes-length)
types
(looper (+ index 1) (bytes->type (bytevector-copy bytes index)))))))
(looper 0 '())))
(define (get-function-names wat)
(filter-map
(lambda (item)
(if (and (equal? (car item) 'export) (assq 'func item))
(cons (cadr (assq 'func item)) (string->symbol (cadr item)))
#f))
(cdr wat)))
(define (section-bytes->sexp name bytes)
(cond
((equal? name 'type)
(let* ((number-of-types (leb128->integer-and-length bytes))
(types (bytes->types (bytevector-copy bytes (cdr number-of-types)))))
(display "TYPE: ")
(write bytes)
(newline)
`((number-of-types . ,(car number-of-types))
(types . ,types)
)))
(else '())))
(define (get-functions function-names wat)
(filter-map
(lambda (item)
(if (equal? (car item) 'func)
(let* ((name (if (assq (list-ref item 1) function-names)
(cdr (assq (list-ref item 1) function-names))
(list-ref item 1)))
(params (filter-map
(lambda (item)
(if (and (list? item) (equal? (car item) 'param))
(list-ref item 1)
#f))
(cdr item)))
(return (filter-map
(lambda (item)
(if (and (list? item)
(equal? (car item) 'return))
item
#f))
(cdr item)))
(body `(call-with-current-continuation
(lambda (return)
,@(cdr (filter-map
(lambda (item)
(if (and (list? item)
(equal? (car item) 'param))
#f
(body-item->sexp item)))
(cdr item))))))
(result `(define ,name
(lambda ,params
,body))))
(if (equal? body '(call-with-current-continuation (lambda (return))))
#f
result))
#f))
(cdr wat)))
(define (wat-module->r7rs-library library-name port)
(let* ((wat (read port))
(data (get-data wat))
(global-export-names (get-global-export-names wat))
(globals (get-globals wat))
;(memory-export-names (get-memory-export-names wat))
(memories (get-memories wat))
(function-names (get-function-names wat))
(exports (append (map cdr function-names)
(map cdr global-export-names)
;memory-export-names
))
(functions (get-functions function-names wat)))
`(define-library
,library-name
(import (scheme base)
(scheme write)
(only (r6rs bytevectors)
endianness
bytevector-s32-set!
bytevector-s32-ref)
(srfi 60))
(export ,@exports)
(begin
(define memory-index (make-vector 5243936 (make-bytevector 5243936 0)))
,@memories
(bytevector-copy! (vector-ref memory-index 0) ,(car data) ,(cdr data))
,@globals
,@functions))))
(define (wasm->sexp bytes)
(display bytes)
(newline)
(letrec*
((bytes-length (bytevector-length bytes))
(section-data '())
(index 8) ;; Jump over magic bytes and version
(looper (lambda ()
(when (< index bytes-length)
(let* ((id (bytevector-u8-ref bytes index))
(name (section-id->name id))
(len (uleb128->integer-and-length bytes (+ index 1) 0 0))
(data-bytes (bytevector-copy bytes index (+ index (car len)))))
(set! section-data
(append section-data
`((id . ,id)
(name . ,name)
(data . ,(section-bytes->sexp name data-bytes)))))
(set! index (+ index 1 (car len) (cdr len)))
(looper)
)))))
(looper)
section-data
))

7
retropikzel/wasm.sld
View File

@ -1,10 +1,7 @@
(define-library
(retropikzel wasm)
(import (scheme base)
(scheme read)
(scheme write)
(srfi 1)
(r6rs bytevectors))
(export wat-module->r7rs-library)
(include "wasm/util.scm")
(retropikzel leb128))
(export wasm->sexp)
(include "wasm.scm"))

1
retropikzel/wasm/README.md
View File

@ -1 +0,0 @@
WIP

23
retropikzel/wasm/plus.c
View File

@ -1,22 +1,3 @@
#include <stdio.h>
#include <emscripten/emscripten.h>
#include <stdint.h>
#ifdef __cplusplus
#define EXTERN extern "C"
#else
#define EXTERN
#endif
EXTERN EMSCRIPTEN_KEEPALIVE int x = 1;
EXTERN EMSCRIPTEN_KEEPALIVE int y = 50000;
EXTERN EMSCRIPTEN_KEEPALIVE int plus(int a, int b) {
return a + b + x;
int plus(int a, int b) {
return a + b;
}
/*
int plus_three(int a, int b, int c) {
return a + b + c;
}
*/

11
retropikzel/wasm/test.scm
View File

@ -1,9 +1,14 @@
(test-begin "wasm")
(define testdir "retropikzel/wasm")
(define testfile1 (string-append testdir "/" "plus.wat"))
(define lib (wat-module->r7rs-library '(wasmtestlibrary) (open-input-file testfile1)))
(define testfile1 (string-append testdir "/" "plus.wasm"))
(with-output-to-file "wasmtestlibrary.sld" (lambda () (show #t (pretty lib))))
(when (not (file-exists? testfile1))
(error (string-append testfile1 " does not exist")))
(define bytes (with-input-from-file testfile1 (lambda () (read-bytevector 10000))))
(write (wasm->sexp bytes))
(newline)
(test-end "wasm")

89
retropikzel/wasm/util.scm
View File

@ -1,89 +0,0 @@
(define (body-item->sexp item)
(cond ((not (list? item)) item)
((equal? (car item) 'local)
`(define ,(list-ref item 1) 0))
((equal? (car item) 'global.get)
(list-ref item 1))
((equal? (car item) 'global.set)
`(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2))))
((equal? (car item) 'global.tee)
`(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2))))
((equal? (car item) 'local.get)
(list-ref item 1))
((equal? (car item) 'local.set)
`(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2))))
((equal? (car item) 'local.tee)
`(set! ,(list-ref item 1) ,@(map body-item->sexp (list-tail item 2))))
((equal? (car item) 'result)
#f)
((equal? (car item) 'i32.const)
(list-ref item 1))
((equal? (car item) 'i32.and)
`(bitwise-and ,@(map body-item->sexp (cdr item))))
((equal? (car item) 'i32.add)
`(+ ,@(map body-item->sexp (cdr item))))
((equal? (car item) 'i32.sub)
`(- ,@(map body-item->sexp (cdr item))))
((equal? (car item) 'i32.store)
`(bytevector-s32-set! (vector-ref memory-index ,(body-item->sexp (list-ref item 2)))
,(offset=N->N (list-ref item 1))
,(body-item->sexp (list-ref item 3))
(endianness 'little)))
((equal? (car item) 'i32.load)
(if (> (length item) 2)
`(bytevector-s32-ref (vector-ref memory-index ,(body-item->sexp (list-ref item 2)))
,(offset=N->N (list-ref item 1))
(endianness 'little))
`(bytevector-s32-ref (vector-ref memory-idex 0)
,(body-item->sexp (list-ref item 1))
(endianness 'little))))
((equal? (car item) 'call)
`(,@(map body-item->sexp (cdr item))))
;((equal? (car item) 'block) (display "HERE: block ") (write (list-tail item 2)) (newline) `(call-with-current-continuation (lambda (,(list-ref item 1)) ,@(map body-item->sexp (list-tail item 2)))))
;((or (equal? (car item) 'i32.eqz)) `(= ,@(map body-item->sexp (cdr item))))
;((equal? (car item) 'br_if) `(when (= 1 ,@(map body-item->sexp (list-tail item 2))) (,(list-ref item 1))))
(else (map body-item->sexp item))))
(define webassembly-page-size 65536)
(define (symbol-append sym1 sym2)
(string->symbol (string-append (symbol->string sym1) (symbol->string sym2))))
(define (char-index str c)
(letrec*
((looper
(lambda (index)
(cond ((>= index (string-length str)) -1)
((char=? c (string-ref str index)) index)
(else (looper (+ index 1)))))))
(looper 0)))
(define (offset=N->N sym)
(string->number
(string-copy
(symbol->string sym)
(+ (char-index (symbol->string sym) #\=) 1))))
(define (symbol-starts-with? sym str)
(if (not (symbol? sym))
#f
(let ((sym-str (symbol->string sym)))
(and (>= (string-length sym-str) (string-length str))
(string=? (string-copy sym-str 0 (string-length str)) str)))))
(define string-split
(lambda (str mark)
(let* ((str-l (string->list str))
(res (list))
(last-index 0)
(index 0)
(splitter (lambda (c)
(cond ((char=? c mark)
(begin
(set! res (append res (list (string-copy str last-index index))))
(set! last-index (+ index 1))))
((equal? (length str-l) (+ index 1))
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
(set! index (+ index 1)))))
(for-each splitter str-l)
res)))

9
test-headers.scm
View File

@ -4,8 +4,9 @@
(scheme char)
(scheme file)
(scheme process-context)
(retropikzel tap)
(retropikzel LIBRARY)
(srfi 64))
(srfi 64)
;(retropikzel mouth)
;(retropikzel ctrf)
(retropikzel LIBRARY))
(test-runner-current (tap-runner))
;(test-runner-current (ctrf-runner))

12
test-headers.sps
View File

@ -1,7 +1,9 @@
(import (rnrs)
(retropikzel tap)
(retropikzel LIBRARY)
#!r6rs
(import (except (rnrs) delete-file)
(srfi :64)
(srfi :98))
(srfi :98)
;(retropikzel mouth)
;(retropikzel ctrf)
(retropikzel LIBRARY))
(test-runner-current (tap-runner))
;(test-runner-current (ctrf-runner))