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

Compare commits

base: Retropikzel:main
Branches Tags
Retropikzel:main
Retropikzel:fix-tests
..
compare: Retropikzel:fix-tests
Branches Tags
Retropikzel:main
Retropikzel:fix-tests

19 Commits
main ... fix-tests

Author SHA1 Message Date
retropikzel cf5c702387 Switch to test-r7rs 2026-03-26 09:07:33 +02:00
retropikzel 7570aeab0f Switch to test-r7rs 2026-03-26 09:06:28 +02:00
retropikzel b7d7015005 Switch to test-r7rs 2026-03-26 09:05:09 +02:00
retropikzel e34987ae8c Switch to test-r7rs 2026-03-26 09:04:43 +02:00
retropikzel be0bd6f609 Improve testing 2026-03-21 13:57:43 +02:00
retropikzel e8f0cd374b Improve testing 2026-03-21 13:47:47 +02:00
retropikzel 7bf3b69fd3 Improve testing 2026-03-21 13:19:12 +02:00
retropikzel 4501ccac4b Improve testing 2026-03-21 13:17:14 +02:00
retropikzel 8492575a65 Improve testing 2026-03-21 12:38:43 +02:00
retropikzel 619dfb8ad6 Fixing testing 2026-03-12 10:52:28 +02:00
retropikzel 975b851e9e Fixing testing 2026-03-12 10:45:01 +02:00
retropikzel 1c60967772 Fixing testing 2026-03-12 08:13:05 +02:00
retropikzel f020fc525f Fixing testing 2026-03-12 08:07:29 +02:00
retropikzel 376ad49ded Fixing testing 2026-03-12 08:00:42 +02:00
retropikzel 41191af6cc Fixing testing 2026-03-12 07:56:44 +02:00
retropikzel 9eebd513d9 Fixing testing 2026-03-12 07:56:11 +02:00
retropikzel 0a16717d1d Fixing testing 2026-03-12 07:52:18 +02:00
retropikzel da149e080b Fixing testing 2026-03-12 07:50:59 +02:00
retropikzel 1adaa618ca Fixing testing 2026-03-12 07:47:44 +02:00
54 changed files with 319 additions and 3500 deletions
Show Stats Expand all files Collapse all files

5
.gitignore vendored
View File

@ -25,8 +25,3 @@ example
venv
foreign
tmp
*.json
test-program
*.test
*.test1
!.snow-repo.scm

28
.snow-repo.scm
View File

@ -1,28 +0,0 @@
(repository
(package
(git
(hash "a417c9aec13dd81474373dc71cf50431c7dbbf4f")
(url "https://codeberg.org/retropikzel/foreign-c-libraries.git"))
(authors "Retropikzel")
(version "1.1.6")
(library
(name
(retropikzel system))
(path "retropikzel/system.sld")
(foreign-depends)
(depends
(scheme base)
(scheme write)
(scheme process-context)
(foreign c)))
(manual "retropikzel/system/README.md")
(description "Execute a shell command.")
(test "retropikzel/system/test.scm")
(test-depends
(scheme base)
(scheme write)
(scheme file)
(retropikzel system)
(retropikzel tap)
(srfi 64))
(updated "2026-08-29T16:47:57+00:00")))

9
Dockerfile.jenkins
View File

@ -1,4 +1,5 @@
FROM schemers/chibi:head
RUN apt-get update && apt-get install -y \
gcc ca-certificates libffi-dev docker.io make
RUN snow-chibi install --impls=chibi --always-yes retropikzel.test-r7rs
FROM alpine
RUN apk add make docker git
RUN git clone https://codeberg.org/retropikzel/test-r7rs.git --depth=1
RUN cd test-r7rs && ./configure && make && make install
COPY --from=schemers/chibi:alpine-head /usr/local /usr/local

46
Jenkinsfile vendored
View File

@ -3,46 +3,28 @@ pipeline {
dockerfile {
label 'docker-x86_64'
filename 'Dockerfile.jenkins'
args '-t --user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
reuseNode true
args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
}
}
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 ikarus ironscheme mosh racket sagittarius ypsilon'
R7RS_SCHEMES='capyscheme chibi chicken gauche kawa mosh racket sagittarius stklos ypsilon'
LIBRARIES='system named-pipes shell download-file file-append'
PWD="${WORKSPACE}"
parameters {
string(name: 'R7RS_SCHEMES', defaultValue: 'chibi chicken gauche guile kawa mosh racket sagittarius stklos ypsilon', description: '')
string(name: 'R6RS_SCHEMES', defaultValue: 'chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon', description: '')
string(name: 'LIBRARIES', defaultValue: 'system named-pipes shell requests', description: '')
}
stages {
stage('Parallel') {
parallel {
stage('Test R6RS Debian') {
steps {
script {
env.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
env.R6RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
params.LIBRARIES.split().each { LIBRARY ->
params.R6RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME} ${LIBRARY}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r6rs test-docker"
}
@ -52,14 +34,12 @@ pipeline {
}
}
}
}
stage('Test R7RS Debian') {
steps {
script {
env.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
env.R7RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME}") {
params.LIBRARIES.split().each { LIBRARY ->
params.R7RS_SCHEMESsplit().each { SCHEME ->
stage("${SCHEME} ${LIBRARY}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} RNRS=r7rs test-docker"
}
@ -70,12 +50,8 @@ pipeline {
}
}
}
}
}
}
post {
always {
sh "chown -R . jenkins"
cleanWs()
}
}

84
Makefile
View File

@ -1,55 +1,61 @@
.DEFAULT: all
.POSIX:
SCHEME=chibi
VERSION=$$(cat retropikzel/${LIBRARY}/VERSION)
PKG=retropikzel-${LIBRARY}-${VERSION}.tgz
LIBRARY=system
AUTHOR=Retropikzel
DOCKER_TAG=latest
IMAGE=${SCHEME}:${DOCKER_TAG}
RNRS=r7rs
LIBRARY=system
EXAMPLE=editor
EXAMPLE_FILE=retropikzel/${LIBRARY}/examples/${EXAMPLE}
AUTHOR=Retropikzel
PACKAGE_ARGS=$$(cat retropikzel/${LIBRARY}/PACKAGE_ARGS 2> /dev/null || echo "")
CSC_OPTIONS=$$(cat retropikzel/${LIBRARY}/CSC_OPTIONS 2> /dev/null || echo "")
APT_PACKAGES=$$(cat retropikzel/${LIBRARY}/APT_PACKAGES 2> /dev/null || echo "")
LIBRARY_FILE=retropikzel/${LIBRARY}.sld
VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
DESCRIPTION=$(shell head -n1 retropikzel/${LIBRARY}/README.md)
README=retropikzel/${LIBRARY}/README.html
TESTFILE=retropikzel/${LIBRARY}/test.scm
PKG=retropikzel-${LIBRARY}-${VERSION}.tgz
all: package
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
LIB_PATHS=-I .akku/lib
endif
package: retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md retropikzel/${LIBRARY}/LICENSE
all: build
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
snow-chibi package \
--always-yes \
${PACKAGE_ARGS} \
--version="${VERSION}" \
--authors="${AUTHOR}" \
--doc="retropikzel/${LIBRARY}/README.md" \
--test="retropikzel/${LIBRARY}/test.scm" \
--description="$$(head -n1 retropikzel/${LIBRARY}/README.md)" \
retropikzel/${LIBRARY}.sld
git-index: package
snow-chibi git-index ${PKG}
--version=${VERSION} \
--authors=${AUTHOR} \
--doc=${README} \
--description="${DESCRIPTION}" \
${LIBRARY_FILE}
install:
snow-chibi install --impls=${SCHEME} --skip-tests?=1 ${PKG}
snow-chibi install --impls=${SCHEME} --always-yes ${PKG}
test:
rm -rf test-program
COMPILE_R7RS=${SCHEME} \
CSC_OPTIONS="${CSC_OPTIONS}" \
compile-r7rs -o test-program ${TESTFILE}
./test-program
testfiles: build
rm -rf .tmp
mkdir -p .tmp
cp ${PKG} .tmp/
# R6RS testfiles
printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (retropikzel ${LIBRARY}))" > .tmp/test.sps
cat ${TESTFILE} >> .tmp/test.sps
# R7RS testfiles
echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > .tmp/test.scm
cat ${TESTFILE} >> .tmp/test.scm
test-docker:
DOCKER_TAG=${DOCKER_TAG} \
COMPILE_R7RS=${SCHEME} \
CSC_OPTIONS="${CSC_OPTIONS}" \
SNOW_PACKAGES="srfi.14 srfi.19 srfi.64 srfi.170 retropikzel.tap retropikzel.dot-locking retropikzel.debug foreign.c ${PKG}" \
AKKU_PACKAGES="akku-r7rs chez-srfi '(foreign c)' '(retropikzel ${LIBRARY})'" \
APT_PACKAGES="${APT_PACKAGES}" \
PASS_ENV_VARS="CSC_OPTIONS" \
test-r7rs -o test-program ${TESTFILE}
test: testfiles
cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
cd .tmp && ./test-program
test-docker: testfiles
cd .tmp && SNOW_PACKAGES="srfi.64 foreign.c" COMPILE_R7RS=${SCHEME} test-r7rs -o test-program test.${SFX} ${PKG}
clean:
git clean -X -f

61
retropikzel/download-file.scm
View File

@ -1,61 +0,0 @@
(define CURLOPT-URL 10002)
(define CURLOPT-WRITEDATA 10001)
(define-c-library libc '("stdio.h") #f '())
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
(define-c-procedure c-perror libc 'perror 'void '(pointer))
(define-c-library libcurl '("curl/curl.h") "curl" '((additional-versions ("4"))))
(define-c-procedure curl-easy-init libcurl 'curl_easy_init 'pointer '())
(define-c-procedure curl-easy-cleanup libcurl 'curl_easy_cleanup 'void '(pointer))
(define-c-procedure curl-easy-setopt-pointer libcurl 'curl_easy_setopt 'int '(pointer int pointer))
(define-c-procedure curl-easy-setopt-int libcurl 'curl_easy_setopt 'int '(pointer int int))
(define-c-procedure curl-easy-strerror libcurl 'curl_easy_strerror 'pointer '(int))
(define-c-procedure curl-easy-perform libcurl 'curl_easy_perform 'int '(pointer))
(define (get-right-char-until str chars)
(let ((result '())
(until? #f))
(for-each
(lambda (c)
(when (member c chars) (set! until? #t))
(when (not until?) (set! result (cons c result))))
(reverse (string->list str)))
(list->string result)))
(define (download-file url . download-path)
(when (and (not (null? download-path))
(not (string? (car download-path))))
(error "download-file error: download-path must be string"
(car download-path)))
(when (< (string-length url) 4)
(error "download-file error: url too short" url))
(when (and (not (string=? (string-copy url 0 4) "http"))
(not (string=? (string-copy url 0 5) "https")))
(error "download-file error: only http or https urls supported" url))
(when (not (string? url))
(error "download-file error: url must be string" url))
(let* ((handle (curl-easy-init))
(to-path (if (null? download-path)
(get-right-char-until url '(#\/ #\\))
(car download-path)))
(to-path-cbv (string->c-bytevector to-path))
(file-mode-cbv (string->c-bytevector "w"))
(to-file-cbv (c-fopen to-path-cbv file-mode-cbv))
(url-cbv (string->c-bytevector url)))
(when (c-bytevector-null? to-file-cbv)
(let* ((error-message "download-file error")
(error-pointer (string->c-bytevector error-message)))
(c-perror error-pointer)
(c-bytevector-free file-mode-cbv to-path-cbv to-file-cbv url-cbv error-pointer)
(error error-message)))
(curl-easy-setopt-pointer handle CURLOPT-WRITEDATA to-file-cbv)
(curl-easy-setopt-pointer handle CURLOPT-URL url-cbv)
(let ((result (curl-easy-perform handle)))
(when (not (= result 0))
(let* ((error-cbv (curl-easy-strerror result))
(error-string (c-bytevector->string error-cbv)))
(c-bytevector-free error-cbv)
(error error-string url)))
(curl-easy-cleanup handle))))

10
retropikzel/download-file.sld
View File

@ -1,10 +0,0 @@
(define-library
(retropikzel download-file)
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(foreign c))
(export download-file)
(include "download-file.scm"))

1
retropikzel/download-file/APT_PACKAGES
View File

@ -1 +0,0 @@
libcurl4-openssl-dev

1
retropikzel/download-file/CSC_OPTIONS
View File

@ -1 +0,0 @@
-L -lcurl

165
retropikzel/download-file/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/download-file/PACKAGE_ARGS
View File

@ -1 +0,0 @@
--foreign-depends curl

7
retropikzel/download-file/README.md
View File

@ -1,7 +0,0 @@
Download file using HTTP or HTTPS.
(**download-file** url [download-path])
URL must begin with http or https. If download path is not given file is
downloaded to the current direcotory with filename from url.

1
retropikzel/download-file/VERSION
View File

@ -1 +0,0 @@
1.0.0

13
retropikzel/download-file/test.scm
View File

@ -1,13 +0,0 @@
(test-begin "download-file")
(define tmpfile "/tmp/download-file-test-file.json")
(when (file-exists? tmpfile) (delete-file tmpfile))
(download-file "https://microsoftedge.github.io/Demos/json-dummy-data/64KB.json"
tmpfile)
(test-assert (file-exists? tmpfile))
(download-file "https://microsoftedge.github.io/Demos/json-dummy-data/64KB.json")
(test-assert (file-exists? "64KB.json"))
(test-end "download-file")

21
retropikzel/file-append.scm
View File

@ -1,21 +0,0 @@
(define-c-library libc '("stdio.h") #f ())
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
(define-c-procedure c-fwrite libc 'fwrite 'int '(pointer int int pointer))
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
(define mode-cbv (string->c-bytevector "a"))
(define (with-append-to-file path thunk)
(let* ((path-cbv (string->c-bytevector path))
(file-cbv (c-fopen path-cbv mode-cbv))
(output (parameterize ((current-output-port (open-output-string)))
(apply thunk '())
(get-output-string (current-output-port))))
(output-length (string-length output)))
(with-string->c-bytevector
output
(lambda (output-cbv)
(c-fwrite output-cbv 1 output-length file-cbv)))
(c-fclose file-cbv)
(c-bytevector-free path-cbv)))

7
retropikzel/file-append.sld
View File

@ -1,7 +0,0 @@
(define-library
(retropikzel file-append)
(import (scheme base)
(scheme write)
(foreign c))
(export with-append-to-file)
(include "file-append.scm"))

165
retropikzel/file-append/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.

7
retropikzel/file-append/README.md
View File

@ -1,7 +0,0 @@
Utilites for appending into files
(**with-append-to-file string thunk**)
Works similar to with-output-to-file except appends to the end of the file.
Note that currently the write happens after the thunk finishes!

1
retropikzel/file-append/VERSION
View File

@ -1 +0,0 @@
0.3.1

12
retropikzel/file-append/test.scm
View File

@ -1,12 +0,0 @@
(test-begin "file-append")
(define file-path "/tmp/file-append-test.txt")
(when (file-exists? file-path) (delete-file file-path))
(with-output-to-file file-path (lambda () (display "Hello")))
(test-equal "Hello" (with-input-from-file file-path (lambda () (read-line))))
(with-append-to-file file-path (lambda () (display " world")))
(test-equal "Hello world" (with-input-from-file file-path (lambda () (read-line))))
(test-end "file-append")

435
retropikzel/gi-repository.scm
View File

@ -1,437 +1,10 @@
(define-c-library libc '("stdlib.h") #f '())
(define-c-procedure c-perror libc 'perror 'void '(pointer))
(define-c-library c-gi
'("girepository/girepository.h")
"girepository-2.0"
'((additional-versions ("0"))))
(define-c-procedure c-gi-repository-new c-gi 'gi_repository_new 'pointer '())
(define-c-procedure c-gi-repository-require c-gi 'gi_repository_require 'pointer '(pointer pointer pointer int pointer))
(define-c-procedure c-gi-repository-find-by-name c-gi 'gi_repository_find_by_name 'pointer '(pointer pointer pointer))
(define-c-procedure c-gi-repository-c-prefix c-gi 'gi_repository_get_c_prefix 'pointer '(pointer pointer))
(define-c-procedure c-gi-repository-get-loaded-namespaces c-gi 'gi_repository_get_loaded_namespaces 'pointer '(pointer pointer))
(define-c-procedure c-gi-base-info-get-name c-gi 'gi_base_info_get_name 'pointer '(pointer))
(define-c-procedure c-gi-base-info-get-namespace c-gi 'gi_base_info_get_namespace 'pointer '(pointer))
(define-c-procedure c-gi-base-info-get-typelib c-gi 'gi_base_info_get_typelib 'pointer '(pointer))
(define-c-procedure c-gi-base-info-get-attribute c-gi 'gi_base_info_get_attribute 'pointer '(pointer pointer))
(define-c-procedure c-gi-base-info-get-namespace c-gi 'gi_base_info_get_namespace 'pointer '(pointer))
(define-c-procedure c-gi-function-info-invoke c-gi 'gi_function_info_invoke 'int '(pointer pointer int pointer int pointer pointer))
(define-c-procedure c-gi-callable-info-get-return-type c-gi 'gi_callable_info_get_return_type 'pointer '(pointer))
(define-c-procedure c-gi-callable-info-get-n-args c-gi 'gi_callable_info_get_n_args 'uint '(pointer))
(define-c-procedure c-gi-callable-info-get-arg c-gi 'gi_callable_info_get_arg 'pointer '(pointer uint))
(define-c-procedure c-gi-arg-info-get-type-info c-gi 'gi_arg_info_get_type_info 'pointer '(pointer))
(define-c-procedure c-gi-type-info-get-tag c-gi 'gi_type_info_get_tag 'uint '(pointer))
(define-c-procedure c-gi-type-info-get-interface c-gi 'gi_type_info_get_interface 'pointer '(pointer))
(define-c-procedure c-gi-struct-info-find-method c-gi 'gi_struct_info_find_method 'pointer '(pointer pointer))
(define-c-procedure c-gi-object-info-find-method c-gi 'gi_object_info_find_method 'pointer '(pointer pointer))
(define-c-procedure c-gi-object-info-find-signal c-gi 'gi_object_info_find_signal 'pointer '(pointer pointer))
(define-c-struct-type gerror '((domain u32) (code int) (message pointer)))
(define GI-TYPE-TAG-VOID 0)
(define GI-TYPE-TAG-BOOLEAN 1)
(define GI-TYPE-TAG-INT8 2)
(define GI-TYPE-TAG-UINT8 3)
(define GI-TYPE-TAG-INT16 4)
(define GI-TYPE-TAG-UINT16 5)
(define GI-TYPE-TAG-INT32 6)
(define GI-TYPE-TAG-UINT32 7)
(define GI-TYPE-TAG-INT64 8)
(define GI-TYPE-TAG-UINT64 9)
(define GI-TYPE-TAG-FLOAT 10)
(define GI-TYPE-TAG-DOUBLE 11)
(define GI-TYPE-TAG-GTYPE 12)
(define GI-TYPE-TAG-UTF8 13)
(define GI-TYPE-TAG-FILENAME 14)
(define GI-TYPE-TAG-ARRAY 15)
(define GI-TYPE-TAG-INTERFACE 16)
(define GI-TYPE-TAG-GLIST 17)
(define GI-TYPE-TAG-GSLIST 18)
(define GI-TYPE-TAG-GHASH 19)
(define GI-TYPE-TAG-ERROR 20)
(define GI-TYPE-TAG-UNICHAR 21)
(define (gi-type->foreign-c-type type-info)
(let* ((tag (c-gi-type-info-get-tag type-info))
(result (cond ((= tag GI-TYPE-TAG-VOID)
;; FIXME
'callback)
((= tag GI-TYPE-TAG-BOOLEAN) 'int)
((= tag GI-TYPE-TAG-INT8) 'i8)
((= tag GI-TYPE-TAG-UINT8) 'u8)
((= tag GI-TYPE-TAG-INT16) 'i16)
((= tag GI-TYPE-TAG-UINT16) 'u16)
((= tag GI-TYPE-TAG-INT32) 'i32)
((= tag GI-TYPE-TAG-UINT32) 'u32)
((= tag GI-TYPE-TAG-INT64) 'i64)
((= tag GI-TYPE-TAG-UINT64) 'u64)
((= tag GI-TYPE-TAG-FLOAT) 'float)
((= tag GI-TYPE-TAG-DOUBLE) 'double)
((= tag GI-TYPE-TAG-GTYPE) 'int)
((= tag GI-TYPE-TAG-UTF8) 'pointer)
((= tag GI-TYPE-TAG-FILENAME) 'pointer)
((= tag GI-TYPE-TAG-ARRAY) 'pointer)
((= tag GI-TYPE-TAG-INTERFACE)
;(display "HERE: interface name ")
;(write (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))))
;(newline)
;; FIXME Read type from type-info somehow
(cond ((or
(string=? (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))) "ApplicationFlags")
(string=? (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))) "WindowType"))
'int)
(else 'pointer)))
((= tag GI-TYPE-TAG-GLIST) 'pointer)
((= tag GI-TYPE-TAG-GSLIST) 'pointer)
((= tag GI-TYPE-TAG-GHASH) 'pointer)
((= tag GI-TYPE-TAG-ERROR) 'pointer)
((= tag GI-TYPE-TAG-UNICHAR) 'int)
(else (error "gi-type->foreign-c-type: Unknown gi-type"
(c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))))))))
result))
(define-record-type <gi-repository>
(make-gi-repository name cbv)
gi-repository?
(name gi-repository-name)
(cbv gi-repository-cbv))
(define (gi-repository name version)
(let ((repository (c-gi-repository-new))
(err (c-bytevector-null)))
(call-with-address-of
err
(lambda (err-address)
(c-gi-repository-require repository
(string->c-bytevector name)
(string->c-bytevector version)
0
err-address)))
(when (not (c-bytevector-null? err))
(let* ((error-list (c-bytevector->list err gerror))
(msg (c-bytevector->string (cdr (assoc 'message error-list)))))
(c-bytevector-free (cdr (assoc 'message error-list)))
(c-bytevector-free repository)
(error (string-append "load-gi-repository: " msg)
(car error-list)
(cadr error-list))))
(make-gi-repository name repository)))
(define (gi-repository-info repository)
(let*
((cbv (gi-repository-cbv repository))
(c-prefix (c-bytevector->string
(c-gi-repository-c-prefix cbv
(string->c-bytevector
(gi-repository-name repository)))))
(loaded-namespaces
(letrec* ((count-cbv (make-c-bytevector (c-type-size 'int)))
(namespaces (c-gi-repository-get-loaded-namespaces cbv count-cbv))
(count (c-bytevector-ref count-cbv 'int 0))
(looper
(lambda (index result)
(if (= index count)
result
(looper (+ index 1)
(append result
(list
(c-bytevector->string (c-bytevector-ref namespaces
'pointer
(* (c-type-size 'pointer) index))))))))))
(looper 0 '())
))
)
`((c-prefix . ,c-prefix)
(loaded-namespaces . ,loaded-namespaces)
)))
(define (gi-function-info repository function-name)
(let ((info (c-gi-repository-find-by-name
(gi-repository-cbv repository)
(string->c-bytevector (gi-repository-name repository))
(string->c-bytevector function-name))))
(if (c-bytevector-null? info)
#f
(letrec*
((return-info (c-gi-callable-info-get-return-type info))
(return-type (gi-type->foreign-c-type return-info))
(argument-count (c-gi-callable-info-get-n-args info))
(argument-types-loop
(lambda (index result)
(if (= index argument-count)
result
(argument-types-loop
(+ index 1)
(append
result
(list
(let* ((arg-info (c-gi-callable-info-get-arg info index))
(type-info (c-gi-arg-info-get-type-info arg-info))
(type (gi-type->foreign-c-type type-info)))
`((type . ,type)
(index . ,index)))))))))
(argument-types (argument-types-loop 0 '())))
`((namespace . ,(gi-repository-name repository))
(function-name . ,function-name)
(return-type . ,return-type)
(argument-count . ,argument-count)
(argument-types . ,argument-types)
(info-cbv . ,info))))))
(define (gi-invoke repository name . args)
(when (not (gi-repository? repository))
(error "gi-invoke: repository argument must be gi-repository" repository))
(when (not (string? name))
(error "gi-invoke: name argument must be string" name))
(letrec*
((function-info
(let ((function-info
(c-gi-repository-find-by-name
(gi-repository-cbv repository)
(string->c-bytevector (gi-repository-name repository))
(string->c-bytevector name))))
(when (c-bytevector-null? function-info)
(error "gi-invoke: Repository has not function"
(gi-repository-name repository)
name))
function-info))
(function-return-info (c-gi-callable-info-get-return-type function-info))
(return-type (gi-type->foreign-c-type function-return-info))
(n-args (let ((n-args (c-gi-callable-info-get-n-args function-info)))
(when (not (= n-args (length args)))
(error
(string-append "gi-invoke: Argument count mismatch, got "
(number->string (length args))
", wanted "
(number->string n-args))
;(gi-object-namespace object)
;(gi-object-name object)
name))
n-args))
(arg-info-looper
(lambda (index result)
(if (or (= index n-args)
(= index (length args)))
result
(arg-info-looper
(+ index 1)
(append
result
(list
(let* ((arg-info (c-gi-callable-info-get-arg function-info index))
(type-info (c-gi-arg-info-get-type-info arg-info))
(type (gi-type->foreign-c-type type-info)))
(cons type (list-ref args index)))))))))
(arg-info (arg-info-looper 0 '()))
(arg-cbv (make-c-bytevector 1024))
(arg-cbv-offset 0)
(invoke-error (c-bytevector-null))
(return-value (make-c-bytevector 1024)))
(for-each
(lambda (arg)
(c-bytevector-set! arg-cbv
(car arg)
arg-cbv-offset
(if (string? (cdr arg))
(string->c-bytevector (cdr arg))
(cdr arg)))
(set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (car arg)))))
arg-info)
(c-gi-function-info-invoke function-info
arg-cbv
n-args
(c-bytevector-null)
0
return-value
invoke-error)
(when (not (symbol=? return-type 'void))
(c-bytevector-ref return-value return-type 0))))
(define (gi-struct repository namespace name)
(let ((base-info
(c-gi-repository-find-by-name (gi-repository-cbv repository)
(string->c-bytevector namespace)
(string->c-bytevector name))))
(when (c-bytevector-null? base-info)
(c-perror (string->c-bytevector "(C perror) gi-object"))
(error "gi-object: ERROR" namespace name base-info))
base-info))
(define (gi-struct-method-info struct method-name)
(let ((info (c-gi-struct-info-find-method struct (string->c-bytevector method-name))))
(if (c-bytevector-null? info)
#f
(letrec*
((return-info (c-gi-callable-info-get-return-type info))
(return-type (gi-type->foreign-c-type return-info))
(argument-count (c-gi-callable-info-get-n-args info))
(argument-types-loop
(lambda (index result)
(if (= index argument-count)
result
(argument-types-loop
(+ index 1)
(append
result
(list
(let* ((arg-info (c-gi-callable-info-get-arg info index))
(type-info (c-gi-arg-info-get-type-info arg-info))
(type (gi-type->foreign-c-type type-info)))
`((type . ,type)
(index . ,index)))))))))
(argument-types (argument-types-loop 0 '())))
`((namespace . ,(gi-info-namespace struct))
(struct-name . ,(gi-info-name struct))
(method-name . ,method-name)
(return-type . ,return-type)
(argument-count . ,argument-count)
(argument-types . ,argument-types)
(info-cbv . ,info))))))
(define (gi-struct-invoke struct method-name . args)
(let ((method-info (gi-struct-method-info struct method-name)))
(when (not method-info)
(error "gi-struct-invoke: Struct has no method" struct method-name))
(when (not (= (cdr (assoc 'argument-count method-info)) (length args)))
(error
(string-append "gi-struct-invoke: Argument count mismatch, got "
(number->string (length args))
", wanted "
(number->string (cdr (assoc 'argument-count method-info))))
(gi-struct-namespace struct)
(gi-struct-name struct)
method-name))
(let
((info-cbv (cdr (assoc 'info-cbv method-info)))
(arg-cbv (make-c-bytevector 1024))
(arg-cbv-offset 0)
(invoke-error (c-bytevector-null))
(return-value (make-c-bytevector 1024)))
(for-each
(lambda (arg)
(let ((value (list-ref args (cdr (assoc 'index arg)))))
(c-bytevector-set! arg-cbv
(cdr (assoc 'type arg))
arg-cbv-offset
(if (string? value)
(string->c-bytevector value)
value))
(set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (cdr (assoc 'type arg)))))))
(cdr (assoc 'argument-types method-info)))
(c-gi-function-info-invoke info-cbv
arg-cbv
(cdr (assoc 'argument-count method-info))
(c-bytevector-null)
0
return-value
invoke-error)
(if (not (symbol=? (cdr (assoc 'return-type method-info)) 'void))
(c-bytevector-ref return-value
(cdr (assoc 'return-type method-info))
0)))))
(define (gi-object repository namespace name)
(let ((base-info
(c-gi-repository-find-by-name (gi-repository-cbv repository)
(string->c-bytevector namespace)
(string->c-bytevector name))))
(when (c-bytevector-null? base-info)
(c-perror (string->c-bytevector "(C perror) gi-object"))
(error "gi-object: ERROR" namespace name base-info))
base-info))
(define (gi-info-namespace info)
(c-bytevector->string (c-gi-base-info-get-namespace info)))
(define gi-object-namespace gi-info-namespace)
(define gi-struct-namespace gi-info-namespace)
(define (gi-info-name info)
(c-bytevector->string (c-gi-base-info-get-name info)))
(define gi-object-name gi-info-name)
(define gi-struct-name gi-info-name)
(define (gi-object-method-info object method-name)
(let ((info (c-gi-object-info-find-method object (string->c-bytevector method-name))))
(if (c-bytevector-null? info)
#f
(letrec*
((return-info (c-gi-callable-info-get-return-type info))
(return-type (gi-type->foreign-c-type return-info))
(argument-count (c-gi-callable-info-get-n-args info))
(argument-types-loop
(lambda (index result)
(if (= index argument-count)
result
(argument-types-loop
(+ index 1)
(append
result
(list
(let* ((arg-info (c-gi-callable-info-get-arg info index))
(type-info (c-gi-arg-info-get-type-info arg-info))
(type (gi-type->foreign-c-type type-info)))
`((type . ,type)
(index . ,index)))))))))
(argument-types (argument-types-loop 0 '())))
`((namespace . ,(gi-info-namespace object))
(object-name . ,(gi-info-name object))
(method-name . ,method-name)
(return-type . ,return-type)
(argument-count . ,argument-count)
(argument-types . ,argument-types)
(info-cbv . ,info))))))
(define (gi-object-invoke object method-name . args)
(let ((method-info (gi-object-method-info object method-name)))
(when (not method-info)
(error "gi-object-invoke: Object has no method" object method-name))
(when (not (= (cdr (assoc 'argument-count method-info)) (length args)))
(error
(string-append "gi-object-invoke: Argument count mismatch, got "
(number->string (length args))
", wanted "
(number->string (cdr (assoc 'argument-count method-info))))
(gi-object-namespace object)
(gi-object-name object)
method-name))
(let
((info-cbv (cdr (assoc 'info-cbv method-info)))
(arg-cbv (make-c-bytevector 1024))
(arg-cbv-offset 0)
(invoke-error (c-bytevector-null))
(return-value (make-c-bytevector 1024)))
(for-each
(lambda (arg)
(display "HERE: arg ")
(write arg)
(newline)
(let ((value (list-ref args (cdr (assoc 'index arg)))))
(c-bytevector-set! arg-cbv
(cdr (assoc 'type arg))
arg-cbv-offset
(if (string? value)
(string->c-bytevector value)
value))
(set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (cdr (assoc 'type arg)))))))
(cdr (assoc 'argument-types method-info)))
(c-gi-function-info-invoke info-cbv
arg-cbv
(cdr (assoc 'argument-count method-info))
(c-bytevector-null)
0
return-value
invoke-error)
(if (not (symbol=? (cdr (assoc 'return-type method-info)) 'void))
(c-bytevector-ref return-value
(cdr (assoc 'return-type method-info))
0)))))
(define-c-procedure gi-repository-new c-gi 'gi_repository_new 'pointer '())
(define-c-procedure gi-repository-require c-gi 'gi_repository_require 'pointer '(pointer pointer pointer int pointer))
(define-c-procedure gi-repository-find-by-name c-gi 'gi_repository_find_by_name 'pointer '(pointer pointer pointer))
(define-c-procedure gi-function-info-invoke c-gi 'gi_function_info_invoke 'int '(pointer pointer int pointer int pointer pointer))

24
retropikzel/gi-repository.sld
View File

@ -3,24 +3,8 @@
(import (scheme base)
(scheme write)
(foreign c))
(export gi-repository
gi-repository-info
gi-function-info
gi-invoke
gi-struct
gi-struct-method-info
gi-struct-namespace
gi-struct-name
gi-struct-invoke
gi-object
gi-object-info
gi-object-namespace
gi-object-name
gi-object-method-info
gi-object-invoke
gi-info-namespace
)
(export gi-repository-new
gi-repository-require
gi-repository-find-by-name
gi-function-info-invoke)
(include "gi-repository.scm"))

1
retropikzel/gi-repository/APT_PACKAGES
View File

@ -1 +0,0 @@
libgirepository-2.0-dev

1
retropikzel/gi-repository/CSC_OPTIONS
View File

@ -1 +0,0 @@
-L -lgirepository-2.0 -L -lgobject-2.0 -L -lglib-2.0

81
retropikzel/gi-repository/test.scm
View File

@ -1,44 +1,55 @@
;(test-begin "gi-repository")
(define-c-library libc '("stdlib.h" "stdio.h" "string.h" "stdio.h") #f ())
(define-c-procedure c-puts libc 'puts 'int '(pointer))
(test-begin "gi-repository")
(define gtk (gi-repository "Gtk" "4.0"))
(define gtk-application (gi-object gtk "Gtk" "Application"))
(define gtk-window (gi-object gtk "Gtk" "ApplicationWindow"))
(define repository (gi-repository-new))
(display repository)
(newline)
(define gobject (gi-repository "GObject" "2.0"))
(define gobject-object (gi-object gtk "GObject" "Object"))
(define gobject-closure (gi-struct gtk "GObject" "Closure"))
(define err (make-c-null))
(define gio (gi-repository "Gio" "2.0"))
(define gio-application (gi-object gio "Gio" "Application"))
(call-with-address-of
err
(lambda (err-address)
(gi-repository-require repository
(string->c-utf8 "GLib")
(string->c-utf8 "2.0")
0
err-address)
(when (not (c-null? err))
(error "gi-repository-require failed"))))
(define app (gi-object-invoke gtk-application "new" "org.hello.world" 0))
;(display "HERE: method-info ")
;(write (gi-object-method-info gtk-window "new"))
;(newline)
(define base-info
(gi-repository-find-by-name repository
(string->c-utf8 "GLib")
(string->c-utf8 "assertion_message")))
(define-c-callback
closure-process
'void
'(pointer pointer int pointer pointer pointer)
(lambda (closure return-value n-param-values param-values invocation-hint marshal-data)
;(c-puts (string->c-bytevector "HERE IN CLOSURE"))
(display "HERE: in closure")
(when (c-null? base-info) (error "base-info failed"))
(define args (make-c-bytevector (* (c-type-size 'pointer) 5)))
(c-bytevector-pointer-set! args 0 (string->c-utf8 "domain"))
(c-bytevector-pointer-set! args (c-type-size 'pointer) (string->c-utf8 "(retropikzel gi-repository)"))
(c-bytevector-u8-set! args (* (c-type-size 'pointer) 2) 42)
(c-bytevector-pointer-set! args (* (c-type-size 'pointer) 3) (string->c-utf8 "test.scm"))
(c-bytevector-pointer-set! args (* (c-type-size 'pointer) 4) (string->c-utf8 "foobar"))
(define return-value (make-c-bytevector (c-type-size 'int)))
(define invoke-err (make-c-null))
(call-with-address-of
invoke-err
(lambda (invoke-err-address)
(let ((return-code
(gi-function-info-invoke base-info
args
5
(make-c-null)
0
(make-c-null)
invoke-err-address)))
(display "HERE: ")
(write return-code)
(newline)
))
(define closure (gi-struct-invoke gobject-closure "new_simple" 128 closure-process))
)))
(gi-invoke gobject "signal_connect_closure" app "activate" closure 0)
(display "HERE: method-info ")
(write (gi-object-method-info gio-application "run"))
(newline)
(display (gi-object-invoke gio-application "run" 0 (c-bytevector-null)))
(newline)
;|#
;(test-end "gi-repository")
(test-end "gi-repository")

1
retropikzel/gtk-webview/README.md
View File

@ -1 +0,0 @@
WIP

3
retropikzel/named-pipes.scm
View File

@ -36,6 +36,9 @@
(lambda (msg return-code)
(when (and (number? return-code)
(< return-code 0))
(display "HERE: ")
(write return-code)
(newline)
(c-perror (string->c-bytevector msg))
(error msg return-code))
return-code))

2
retropikzel/named-pipes/VERSION
View File

@ -1 +1 @@
1.0.4
1.0.2

18
retropikzel/pstk.scm
View File

@ -1,7 +1,15 @@
(define (temp-name)
(let ((filename (create-temp-file "pstk.")))
(delete-file filename)
filename))
(random-source-randomize! default-random-source)
(let ((file (string-append "/tmp/pstk-"
(number->string (random-integer 1000))
"-"
(number->string (random-integer 1000))
"-"
(number->string (random-integer 1000)))))
(if (file-exists? file)
(temp-name)
file)))
(define wish-display pipe-write-string)
(define wish-read (lambda (pipe)
(let ((result (pipe-read pipe)))
@ -33,21 +41,17 @@
(define *use-keywords?*
(cond-expand
(chicken #t)
(kawa #t)
(stklos #t)
(else #f)))
(define (%keyword? x)
(cond-expand
(chicken (keyword? x))
(kawa (keyword? x))
(srfi-88 (keyword? x))
(else (error "Keywords not supported" x))))
(define (%keyword->string x)
(cond-expand
(chicken (keyword->string x))
(kawa (keyword->string x))
(stklos (keyword->string x))
(else (error "Keywords not supported" x))))

2
retropikzel/pstk.sld
View File

@ -108,7 +108,7 @@
(scheme process-context)
(retropikzel named-pipes)
(retropikzel system)
(srfi 170))
(srfi 27))
(export tk-eval
tk-id->widget
tk-var

2
retropikzel/pstk/VERSION
View File

@ -1 +1 @@
1.0.8
1.0.7

711
retropikzel/scsh.sld
View File

@ -1,711 +0,0 @@
(define-library
(retropikzel scsh)
(import (rename (scheme base)
(read-line r7rs-read-line))
(scheme read)
(scheme write)
(scheme file)
(scheme char)
(scheme process-context)
(retropikzel dot-locking)
(retropikzel debug)
(foreign c)
(chibi pathname)
(srfi 14)
(srfi 19)
(srfi 60)
(srfi 170))
(export
*temp-file-template*
->uid
->username
;%exec
;%exit
;%fork
;%fork/pipe
;%fork/pipe+
;%read-delimited!
;&
;&
;&&
reduce-port
absolute-file-name
add-after
add-before
alist->env
alist-compress
alist-delete
alist-update
arg
arg*
argv
arithmetic-shift
;ascii->char
autoreap-policy
;awk
become-session-leader
bitwise-and
bitwise-ior
bitwise-not
bitwise-xor
break-dot-lock
call-terminally
call-with-string-output-port
;call/fdes
;char->ascii
char-ascii?
char-blank?
char-digit?
char-graphic?
char-hex-digit?
char-iso-control?
char-letter+digit?
char-letter?
char-lower-case?
char-printing?
char-punctuation?
char-title-case?
char-upper-case?
char-whitespace?
;chdir ;; FIXME
;close
;close-after
;close-directory-stream
;close-syslog-channel
command-line
command-line-arguments
;control-tty-file-name
;copy-tty-info
;cpu-ticks/sec
create-directory
create-fifo
create-hard-link
create-symlink
create-temp-file
;crypt
;cwd ;; FIXME
delete-directory
delete-file
;delete-filesys-object ;; FIXME
directory-as-file-name
directory-files
;disable-tty-char
;drain-tty
;dup
;dup->fdes
;dup->inport
;dup->outport
;enabled-interrupts
env->alist
;errno-error
error-output-port
;exec
;exec-epf
;exec-epf
;exec-path
;exec-path-list
;exec-path-search
;exec-path/env
;exec/env
exit
;expand-file-name
;fdes->inport
;fdes->outport
;fdes-flags
;fdes-status
;field-reader
;field-splitter
;file-directory? ;; FIXME
;file-executable?
file-exists?
;file-fifo?
;file-group
file-info
file-info-directory?
;file-info-executable?
;file-info-fifo?
;file-info-not-executable?
;file-info-not-readable?
;file-info-not-writable?
;file-info-readable?
;file-info-regular?
;file-info-special?
;file-info-symlink?
;file-info-writable?
file-info:atime
file-info:ctime
file-info:device
file-info:gid
file-info:inode
file-info:mode
file-info:mtime
file-info:nlinks
file-info:size
;file-info:type
file-info:uid
;file-inode
file-last-access
file-last-mod
file-last-status-change
;file-match
file-mode
file-name-absolute?
file-name-as-directory
file-name-directory
file-name-directory?
file-name-extension
file-name-non-directory?
file-name-nondirectory
file-name-sans-extension
file-nlinks
;file-not-executable?
;file-not-exists?
;file-not-readable?
;file-not-writable?
file-owner
;file-readable?
;file-regular?
file-size
;file-special?
;file-symlink?
;file-type
;file-writable?
;fill-in-date!
;flush-all-ports
;flush-submatches
;flush-tty/both
;flush-tty/input
;flush-tty/output
;force-output
;fork
;fork-pty-session
;fork-thread
;fork/pipe
;fork/pipe+
;get-lock-region
getenv
glob
glob-quote
group-info
group-info:gid
;group-info:members
group-info:name
;handle-signal-default
;home-dir ;;FIXME
home-directory
;home-file ;; FIXME
host
;if-match
;if-sre-form
;ignore-signal
;infix-splitter
;interrupt-handler
;interrupt-set
;interrupt/alarm
;interrupt/alrm
;interrupt/chld
;interrupt/cont
;interrupt/hup
;interrupt/info
;interrupt/int
;interrupt/io
;interrupt/keyboard
;interrupt/memory-shortage
;interrupt/poll
;interrupt/prof
;interrupt/pwr
;interrupt/quit
;interrupt/term
;interrupt/tstp
;interrupt/urg
;interrupt/usr1
;interrupt/usr2
;interrupt/vtalrm
;interrupt/winch
;interrupt/xcpu
;interrupt/xfsz
;itimer
;let-match
;lock-owner-uid
;lock-region
;lock-region/no-block
;lock-region:end
;lock-region:exclusive?
;lock-region:len
;lock-region:proc
;lock-region:start
;lock-region:whence
;lock-region?
;lock?
;machine
make-char-port-filter
;make-lock
;make-lock-region
;make-md5-context ;; TODO (chibi md5)
;make-placeholder
;make-pty-generator
;make-re-char-set
;make-re-choice
;make-re-dsm
;make-re-repeat
;make-re-seq
;make-re-string
;make-re-submatch
;make-regexp ;; TODO (chibi irregex)
make-string-input-port
make-string-output-port
make-string-port-filter
;make-syslog-mask
;make-syslog-options
;make-tty-info
;match-cond
;match:end
;match:start
;match:substring
;maybe-obtain-lock
;; TODO (chibi md5) begin
;md5-context->md5-digest
;md5-context?
;md5-digest->number
;md5-digest-for-port
;md5-digest-for-string
;md5-digest?
;; TODO (chibi md5) end
;most-recent-sigevent
;move->fdes
;next-sigevent
;next-sigevent-set
;next-sigevent-set/no-wait
;next-sigevent/no-wait
nice
;number->md5-digest
obtain-dot-lock
;obtain-lock
;open-control-tty
;open-directory-stream ;; TODO C
;open-fdes
;open-input-file ;; TODO Different from R7RS
;open-output-file ;; TODO Different from R7RS
;open-pty
;open-syslog-channel
os
parent-pid
parse-file-name
;parse-sre
;parse-sres
path-list->file-name
pid
;pid->proc
;pipe
;placeholder-value
;placeholder?
;port->fdes
port->list
port->sexp-list
port->string
port->string-list
port-fold
;port-revealed
;posix-string->regexp
;priority
;proc
;proc:pid
;proc?
;process-group
process-sleep
;process-sleep-until
;process-times
;protocol-info
;pty-name->tty-name
;re-any
;re-any?
;re-bol
;re-bol?
;re-bos
;re-bos?
;re-char-set
;re-char-set:cset
;re-char-set?
;re-choice
;re-choice:elts
;re-choice:tsm
;re-choice?
;re-dsm
;re-dsm:body
;re-dsm:post-dsm
;re-dsm:pre-dsm
;re-dsm:tsm
;re-dsm?
;re-empty
;re-empty?
;re-eol
;re-eol?
;re-eos
;re-eos?
;re-nonl
;re-repeat:from
;re-repeat:to
;re-repeat:tsm
;re-repeat?
;re-seq
;re-seq:elts
;re-seq:tsm
;re-seq?
;re-string
;re-string:chars
;re-string?
;re-submatch:post-dsm
;re-submatch:pre-dsm
;re-submatch:tsm
;re-submatch?
;re-trivial
;re-trivial?
;re-tsm
read-delimited
;read-delimited!
;read-directory-stream
read-line
;read-paragraph ;; IN PROGRESS
;read-string
;read-string!
;read-string!/partial
;read-string/partial
read-symlink
;reap-zombies
;record-reader
;regexp->posix-string
;regexp->scheme
;regexp->sre
;regexp-fold
;regexp-fold-right
;regexp-for-each
;regexp-search
;regexp-search?
;regexp-substitute
;regexp-substitute/global
;regexp?, [2]
release-dot-lock
;release-lock
;release-port-handle
;relinquish-timeslice
rename-file
;replace-extension
;resolve-file-name
;run
;run
;run/collecting
;run/collecting*
;run/file
;run/file*
;run/port
;run/port*
;run/port+proc
;run/port+proc*
;run/sexp
;run/sexp*
;run/sexps
;run/sexps*
;run/string
;run/string*
;run/strings
;run/strings*
;rx
;seek
;select
;select-port-channels
;select-ports
;send-message
;send-message/partial
;send-tty-break
;service-info
;set-enabled-interrupts
;set-fdes-flags
;set-fdes-status
;set-file-group
set-file-mode
set-file-owner
set-file-times
;set-gid
;set-interrupt-handler
;set-port-buffering
;set-priority
;set-process-group
;set-socket-option
;set-tty-info/drain
;set-tty-info/flush
;set-tty-info/now
;set-tty-process-group
;set-uid
set-umask
;set-user-effective-gid
;set-user-effective-uid
setenv
;shutdown-socket
;sigevent?
;signal->interrupt
;signal-process
;signal-process-group
;signal/abrt
;signal/alrm
;signal/bus
;signal/chld
;signal/cont
;signal/emt
;signal/fpe
;signal/hup
;signal/ill
;signal/info
;signal/int
;signal/io
;signal/iot
;signal/kill
;signal/pipe
;signal/poll
;signal/prof
;signal/pwr
;signal/quit
;signal/segv
;signal/stop
;signal/sys
;signal/term
;signal/trap
;signal/tstp
;signal/ttin
;signal/ttou
;signal/urg
;signal/usr1
;signal/usr2
;signal/vtalrm
;signal/winch
;signal/xcpu
;signal/xfsz
simplify-file-name
;simplify-regexp
;skip-char-set
sleep
;sloppy-suffix-splitter
;socket-address->internet-address
;socket-address->unix-address
;socket-connect
;socket-local-address
;socket-option
;socket-remote-address
;spawn
;split-file-name
;spoon
;sre->regexp
;sre-form?
;start-tty-input
;start-tty-output
;static-regexp?
;status:exit-val
;status:stop-sig
;status:term-sig
;stdio->stdports
;stdports->stdio
;stop-tty-input
;stop-tty-output
;string-match
;string-output-port-output
;substitute-env-vars
;suffix-splitter
;suspend
;sync-file
;sync-file-system
;syslog, [2], [3]
;syslog-facility
;syslog-facility?
;syslog-level
;syslog-level?
;syslog-mask
;syslog-mask-all
;syslog-mask-upto
;syslog-mask?
;syslog-option
;syslog-option?
;syslog-options
;syslog-options?
;system-name
;tell
;temp-file-channel
;temp-file-iterate
;terminate-current-thread
;thread-name
;thread-uid
;thread?
;ticks/sec
;time
;time, [2]
;time+ticks
truncate-file
;tty-file-name
;tty-info
;tty-info record type
;tty-info:control-chars
;tty-info:control-flags
;tty-info:input-flags
;tty-info:input-speed
;tty-info:local-flags
;tty-info:min
;tty-info:output-flags
;tty-info:output-speed
;tty-info:time
;tty-info?
;tty-name->pty-name
;tty-process-group
;tty?
;ttyc/2-stop-bits
;ttyc/carrier-flow-ctl
;ttyc/char-size
;ttyc/char-size5
;ttyc/char-size6
;ttyc/char-size7
;ttyc/char-size8
;ttyc/CTS-output-flow-ctl
;ttyc/enable-parity
;ttyc/enable-read
;ttyc/hup-on-close
;ttyc/ignore-flags
;ttyc/no-modem-sync
;ttyc/odd-parity
;ttyc/RTS-input-flow-ctl
;ttychar/delayed-suspend
;ttychar/delete-char
;ttychar/delete-line
;ttychar/delete-word
;ttychar/discard
;ttychar/eof
;ttychar/eol
;ttychar/eol2
;ttychar/interrupt
;ttychar/literal-next
;ttychar/quit
;ttychar/reprint
;ttychar/start
;ttychar/status
;ttychar/stop
;ttychar/suspend
;ttyin/7bits
;ttyin/beep-on-overflow
;ttyin/check-parity
;ttyin/cr->nl
;ttyin/ignore-bad-parity-chars
;ttyin/ignore-break
;ttyin/ignore-cr
;ttyin/input-flow-ctl
;ttyin/interrupt-on-break
;ttyin/lowercase
;ttyin/mark-parity-errors
;ttyin/nl->cr
;ttyin/output-flow-ctl
;ttyin/xon-any
;ttyl/alt-delete-word
;ttyl/canonical
;ttyl/case-map
;ttyl/echo
;ttyl/echo-ctl
;ttyl/echo-delete-line
;ttyl/echo-nl
;ttyl/enable-signals
;ttyl/extended
;ttyl/flush-output
;ttyl/hardcopy-delete
;ttyl/no-flush-on-interrupt
;ttyl/no-kernel-status
;ttyl/reprint-unread-chars
;ttyl/ttou-signal
;ttyl/visual-delete
;ttyl/visual-delete-line
;ttyout/all-delay
;ttyout/bs-delay
;ttyout/bs-delay0
;ttyout/bs-delay1
;ttyout/cr->nl
;ttyout/cr-delay
;ttyout/cr-delay0
;ttyout/cr-delay1
;ttyout/cr-delay2
;ttyout/cr-delay3
;ttyout/delay-w/fill-char
;ttyout/discard-eot
;ttyout/enable
;ttyout/expand-tabs
;ttyout/ff-delay
;ttyout/ff-delay0
;ttyout/ff-delay1
;ttyout/fill-w/del
;ttyout/nl->crnl
;ttyout/nl-delay
;ttyout/nl-delay0
;ttyout/nl-delay1
;ttyout/nl-does-cr
;ttyout/no-col0-cr
;ttyout/tab-delay
;ttyout/tab-delay0
;ttyout/tab-delay1
;ttyout/tab-delay2
;ttyout/tab-delayx
;ttyout/uppercase
;ttyout/vtab-delay
;ttyout/vtab-delay0
;ttyout/vtab-delay1
umask
;uname
;uncase
;uncase-char-set
;uncase-string
;unix-address->socket-address
;unlock-region
user-effective-gid
user-effective-uid
user-gid
user-info
user-info:gid
user-info:home-dir
user-info:name
user-info:shell
user-info:uid
;user-login-name
;user-supplementary-gids
user-uid
;vendor
;wait
;wait-any
;wait-process-group
;with-current-input-port
;with-current-input-port*
;with-current-output-port
;with-current-output-port*
;with-cwd
;with-cwd*
with-dot-lock
with-dot-lock*
;with-enabled-interrupts
;with-enabled-interrupts*
;with-env
;with-env*
;with-errno-handler
;with-errno-handler*
;with-error-output-port
;with-error-output-port*
;with-region-lock
;with-region-lock*
;with-stdio-ports
;with-stdio-ports*
;with-syslog-destination
;with-total-env
;with-total-env*
;with-umask
;with-umask*
;with-user-effective-gid
;with-user-effective-gid*
;with-user-effective-uid
;with-user-effective-uid*
;write-string
;write-string/partial
)
(include "scsh/util.scm")
(include "scsh/portable.scm")
(cond-expand
(windows (begin (error "Windows not supported")))
(else (include "scsh/unix.scm"))))

26
retropikzel/scsh/LICENSE
View File

@ -1,26 +0,0 @@
Copyright 2026 Retropikzel
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

125
retropikzel/scsh/README.md
View File

@ -1,125 +0,0 @@
scsh - The Scheme Shell
This is an implementation of [scsh](https://scsh.net/) on top of
[(foreign c)](https://codeberg.org/foreign-c/foreign-c). It is not a port but
remake, trying to conform to the scsh as much as is possible but sane.
Not everything is implemented yet, see scsh.sld for commented out exports.
Currently only supports Linux.
## Documentation
See [https://scsh.net/docu/html/man-Z-H-13.html#node_index_start](https://scsh.net/docu/html/man-Z-H-13.html#node_index_start)
## Differences
Since the scsh proper is a program that you give source file to run to, and
this is a library. This version does not include everything. You should be able
to use other libraries to replace most things from scsh proper that this
library does not implement.
### alist->env, env->alist
For some reason the manual says that alist->env modifies the environment, yet
the scsh code does not. So this it returns a list of strings. Similarily
env->alist takes string as argument and returns alist instead of writing to env.
Check tests for examples.
### process-sleep
Same as sleep except instead of milliseconds uses seconds.
### No SRFI's by default
SRFI's that come with scsh proper are not included. See snow-fort or your
Scheme implementation for them.
### No scsh specifics
Not very usefull for library implementation or not possible to do.
- bin-dir
- prefix
- exec-prefix
- lib-dir
- include-dir
- man-dir
- cflags
- clean-up-cres
- compiler-flags
- cppflags
- default-lib-dirs
- define-record
- defs
- dump-scsh
- dump-scsh-program
- find-library-file
- ldflags
- lib-dirs
- lib-dirs-list
- libs
- linker-flags
- open-file
### No sockets
Since this implementation of scsh is library you can get them as library elsewhere.
- accept-connection
- bind-listen-accept-loop
- bind-prepare-listen-accept-loop
- bind-socket
- close-socket
- connect-socket
- connect-socket-no-wait
- connect-socket-successful?
- create-socket
- create-socket-pair
- file-info-socket?
- file-socket?
- host-info
- internet-address->socket-address
- listen-socket
- network-info
- port->socket
- receive-message
- receive-message!
- receive-message!/partial
- receive-message/partial
### No threads
Since this implementation of scsh is library you can get them as library elsewhere.
- current-thread
### No buffered io
- bufpol/block
- bufpol/line
- bufpol/none
### No date/time
Since this implementation of scsh is library you can get them as library elsewhere.
- date
- date->string
- format-date
- make-date
### No string utilities
Since this implementation of scsh is library you can get them as library elsewhere.
- join-strings

1
retropikzel/scsh/VERSION
View File

@ -1 +0,0 @@
0.1.0

533
retropikzel/scsh/portable.scm
View File

@ -1,533 +0,0 @@
(define (port-fold port reader op . seeds)
(letrec* ((looper (lambda new-seeds
(let ((read-value (reader port)))
(if (eof-object? read-value)
(apply values new-seeds)
(call-with-values (lambda ()
(apply op read-value new-seeds))
looper))))))
(apply looper seeds)))
(define reduce-port port-fold)
(define (simplify-file-name fname) ;; TODO
(cond
((not (string? fname))
(error "simplify-file-name error: fname must be string"))
(else fname)))
(define set-umask set-umask!)
(define (setenv var val)
(when (not (string? var)) (error "setenv error: var must be string"))
(when (not (string? val)) (error "setenv error: val must be string"))
(set-environment-variable! var val))
(define getenv get-environment-variable)
(define (glob-quote str)
(list->string
(apply
append
(map
(lambda (c)
(if (member c (list #\*))
(list #\\ c)
(list c)))
(string->list str)))))
(define (add-after elt after lst)
(apply
append
(map
(lambda (item)
(if (equal? item after)
(list item elt)
(list item)))
lst)))
(define (add-before elt after lst)
(apply
append
(map
(lambda (item)
(if (equal? item after)
(list elt item)
(list item)))
lst)))
(define (alist->env alist)
(map (lambda (item)
(cond
((not (pair? item))
(error "alist->env error: alist items must be pairs" item))
((not (string? (car item)))
(error "alist->env error: alist item car must be string" item))
((and (not (string? (cdr item)))
(not (list? (cdr item))))
(error (string-append "alist->env error: alist item cdr must be"
"string or list of strings")
item))
((string? (cdr item))
(string-append (car item) "=" (cdr item)))
((list? (cdr item))
(for-each
(lambda (cdr-list-item)
(when (not (string? cdr-list-item))
(error (string-append "alist->env errror: all cdr list"
" items must be strings"
item))))
(cdr item))
(string-append (car item) "=" (string-join (cdr item) ":")))
(else (error "alist->env error: unexpected error" alist))))
alist))
(define (alist-compress alist)
(let ((result '()))
(for-each
(lambda (item)
(when (not (member item result))
(set! result (cons item result))))
alist)
(reverse result)))
(define (alist-delete key alist)
(let ((result '()))
(for-each
(lambda (item)
(when (not (equal? key (car item)))
(set! result (cons item result))))
alist)
(reverse result)))
(define (alist-update key val alist)
(cons (cons key val) (alist-delete key alist)))
(define (arg arglist n . default)
(when (not (list? arglist)) (error "arg error: arglist must be list"))
(when (not (integer? n)) (error "arg error: n must be integer"))
(when (< n 1) (error "arg error: Index starts from 1"))
(if (and (< (length arglist) n)
(not (null? default)))
(car default)
(list-ref arglist (- n 1))))
(define (arg* arglist n . default-thunk)
(when (not (list? arglist)) (error "arg* error: arglist must be list"))
(when (not (integer? n)) (error "arg* error: n must be integer"))
(when (< n 1) (error "arg* error: Index starts from 1"))
(if (and (< (length arglist) n)
(not (null? default-thunk)))
(begin
(when (not (procedure? (car default-thunk)))
(error "arg* error: default-tunk must be procedure"))
(apply (car default-thunk) '()))
(list-ref arglist (- n 1))))
(define (argv n)
(when (not (integer? n)) (error "argv error: n must be integer"))
(arg (command-line) (+ n 1)))
(define current-autoreap-policy 'wait)
(define autoreap-policy
(lambda args
(cond
((null? args) current-autoreap-policy)
(else
(when (not (or (equal? (car args) 'early)
(equal? (car args) 'late)
(equal? (car args) #f)))
(error "autoreap-policy error: policy must be 'early, 'late or #f"
(car args)))
(set! current-autoreap-policy (car args))))))
(define (sleep time)
(when (not (integer? time)) (error "sleep error: time must be integer" time))
(letrec*
((end-time
(let ((end-time (current-time))
(seconds (quotient time 1000))
(nanoseconds (* (remainder time 1000) 1000000)))
(set-time-second! end-time (+ (time-second end-time) seconds))
(set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
end-time))
(looper (lambda () (when (time<? (current-time) end-time) (looper)))))
(looper)))
(define (process-sleep secs)
(when (not (integer? secs))
(error "process-sleep error: secs must be integer" secs))
(sleep (* secs 1000)))
(define (call-terminally thunk)
(when (not (procedure? thunk))
(error "call-terminally error: thunk must be procedure" thunk))
(thunk)
(exit 0))
(define (call-with-string-output-port procedure)
(when (not (procedure? procedure))
(error (string-append "call-with-string-output-port error: procedure"
" argument must be type of procedure")
procedure))
(let ((port (open-output-string)))
(procedure port)
(get-output-string port)))
(define (char-ascii? character)
(when (not (char? character))
(error "char-ascii? error: character argument must be of type character"
character))
(char-set-contains? char-set:ascii character))
(define (char-blank? character)
(when (not (char? character))
(error "char-blank? error: character argument must be of type character"
character))
(char-set-contains? char-set:blank character))
(define (char-digit? character)
(when (not (char? character))
(error "char-digit? error: character argument must be of type character"
character))
(char-set-contains? char-set:digit character))
(define (char-graphic? character)
(when (not (char? character))
(error "char-graphic? error: character argument must be of type character"
character))
(char-set-contains? char-set:graphic character))
(define (char-hex-digit? character)
(when (not (char? character))
(error "char-hex-digit? error: character argument must be of type character"
character))
(char-set-contains? char-set:hex-digit character))
(define (char-iso-control? character)
(when (not (char? character))
(error "char-iso-control? error: character argument must be of type character"
character))
(char-set-contains? char-set:iso-control character))
(define (char-letter+digit? character)
(when (not (char? character))
(error "char-letter+digit? error: character argument must be of type character"
character))
(char-set-contains? char-set:letter+digit character))
(define (char-letter? character)
(when (not (char? character))
(error "char-letter? error: character argument must be of type character"
character))
(char-set-contains? char-set:letter character))
(define (char-printing? character)
(when (not (char? character))
(error "char-printing? error: character argument must be of type character"
character))
(char-set-contains? char-set:printing character))
(define (char-punctuation? character)
(when (not (char? character))
(error "char-punctuation? error: character argument must be of type character"
character))
(char-set-contains? char-set:punctuation character))
(define (char-title-case? character)
(when (not (char? character))
(error "char-title-case? error: character argument must be of type character"
character))
(char-set-contains? char-set:title-case character))
(define (command-line-arguments)
(cdr (command-line)))
(define (directory-as-file-name fname)
(cond
((not (string? fname))
(error "directory-as-file-name error: fname must be string" fname))
((string=? fname "/")
"/")
((string=? fname "")
".")
(else
(let ((fname-length (string-length fname)))
(if (char=? (string-ref fname (- fname-length 1)) #\/)
(string-copy fname 0 (- fname-length 1))
fname)))))
(define (env->alist str)
(map (lambda (item)
(apply cons (string-split item #\=)))
(string-split str #\newline)))
(define (error-output-port) (current-error-port))
(define (file-last-access fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:atime fi)))
(define (file-last-mod fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:mtime fi)))
(define (file-last-status-change fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:ctime fi)))
(define (file-mode fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:mode fi)))
(define (file-name-absolute? fname)
(when (not (string? fname))
(error "file-name-absolute? error: fname must be string" fname))
(if (string=? fname "")
#t
(path-absolute? fname)))
(define (file-name-as-directory fname)
(when (not (string? fname))
(error "file-name-as-directory error: fname must be string" fname))
(cond ((string=? fname ".") "")
((string=? fname "/") "/")
((string=? fname "") "/")
((char=? (string-ref fname (- (string-length fname) 1)) #\/) fname)
(else (string-append fname "/"))))
(define (file-name-directory fname)
(when (not (string? fname))
(error "file-name-directory error: fname must be string" fname))
(cond ((string=? fname "/") "")
((string=? fname "") "")
((char=? (string-ref fname (- (string-length fname) 1)) #\/) fname)
(else
(let ((chibi-path (path-directory fname)))
(if (string=? chibi-path ".")
""
(string-append chibi-path "/"))))))
(define (file-name-directory? fname)
(when (not (string? fname))
(error "file-name-directory? error: fname must be string" fname))
(cond ((string=? fname "/") #t)
((string=? fname ".") #f)
((string=? fname "") #t)
(else (char=? (string-ref fname (- (string-length fname) 1)) #\/))))
(define (file-name-extension fname)
(when (not (string? fname))
(error "file-name-extension error: fname must be string" fname))
(let ((extension (path-extension fname)))
(if extension (string-append "." extension) "")))
(define (file-name-non-directory? fname)
(when (not (string? fname))
(error "file-name-non-directory? error: fname must be string" fname))
(if (string=? fname "") #t (not (file-name-directory? fname))))
(define (file-name-nondirectory fname)
(when (not (string? fname))
(error "file-name-nondirectory error: fname must be string" fname))
(cond ((string=? fname "/") "/")
(else (path-strip-directory fname))))
(define (file-name-sans-extension fname)
(when (not (string? fname))
(error "file-name-sans-extension error: fname must be string" fname))
(path-strip-extension fname))
(define (file-nlinks fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:nlinks fi)))
(define (file-owner fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:uid fi)))
(define (file-size fname/port follow?)
(let* ((fi (file-info fname/port follow?)))
(file-info:size fi)))
(define home-directory (get-environment-variable "HOME"))
(define home-file
(lambda args
(when (and (= (length args) 1) (not (string? (car args))))
(error "home-file error: fname must be string"))
(when (and (= (length args) 2) (not (string? (list-ref args 0))))j
(error "home-file error: user must be string"))
(when (and (= (length args) 2) (not (string? (list-ref args 1))))
(error "home-file error: user must be string"))
(let ((dir (if (= (length args) 2)
(home-dir (car args))
(home-dir)))
(fname (if (= (length args) 2)
(home-dir (list-ref args 1))
(home-dir))))
(string-append dir "/" fname))))
(define (make-char-port-filter filter)
(lambda ()
(letrec* ((looper (lambda (c)
(when (not (eof-object? c))
(write-char (filter c))
(looper (read-char))))))
(looper (read-char)))))
(define (make-string-input-port str) (open-input-string str))
(define (make-string-output-port str) (open-output-string str))
(define (make-string-port-filter filter . args)
(lambda ()
(letrec* ((buflen
(cond ((and (= (length args) 1)
(not (integer? (car args))))
(error (string-append "make-string-port-filter error:"
" buflen must be integer" )))
((and (= (length args) 1)) (car args))
(else 1024)))
(looper (lambda (str)
(when (not (eof-object? str))
(display (filter str))
(looper (read-string buflen))))))
(looper (read-string buflen)))))
(define (os)
(cond-expand
(linux 'linux)
(freebsd 'freesdb)
(netbsd 'netbsd)
(haiku 'haiku)
(else 'unix)))
(define (parse-file-name fname)
(when (not (string? fname))
(error "parse-file-name error: fname must be string" fname))
(let ((f (file-name-nondirectory fname)))
(list (file-name-directory fname)
(file-name-sans-extension f)
(file-name-extension f))))
(define (path-list->file-name path-list . args)
(let ((path (string-join path-list "/")))
(cond ((null? path-list) "")
((and (not (null? args))
(string=? (car args) ""))
(string-append "/" path))
((and (not (null? args))
(not (string? (car args))))
(error "path-list->file-name error: dir must be string"
(car args)))
((and (not (null? args))
(string? (car args)))
(string-append (file-name-as-directory (car args)) path))
(else path))))
(define (port->list reader port)
(reverse (port-fold port reader cons '())))
(define (port->sexp-list port) (port->list read port))
(define (port->string port)
(letrec* ((result "")
(looper (lambda (str)
(cond ((eof-object? str) result)
(else (set! result (string-append result str))
(looper (read-string 1024 port)))))))
(looper (read-string 1024 port))))
(define (port->string-list port) (reverse (port-fold port r7rs-read-line cons '())))
(define (read-delimited char-set . args)
(when (and (not (string? char-set))
(not (char-set? char-set)))
(error (string-append "read-delimited error: char-set must be either"
" string or char-set")))
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim peek concat split))))
(error (string-append "read-delimited error: handle-delim must be either"
" 'trim, 'peek, 'concat or 'split")
(list-ref args 1)))
(letrec* ((character-set (if (string? char-set)
(string->char-set char-set)
char-set))
(port (if (> (length args) 0) (car args) (current-input-port)))
(handle-delim (if (> (length args) 1) (list-ref args 1) 'trim))
(result '())
(in-char-set? (lambda (c) (char-set-contains? character-set c)))
(looper (lambda (c)
(cond ((in-char-set? c)
(cond ((equal? handle-delim 'trim)
(list->string (reverse result)))
((equal? handle-delim 'concat)
(list->string (reverse (cons c result))))
((equal? handle-delim 'split)
(values (list->string (reverse result)) c))))
((and (equal? handle-delim 'peek)
(in-char-set? (peek-char port)))
(list->string (reverse (cons c result))))
(else (set! result (cons c result))
(looper (read-char port)))))))
(looper (read-char port))))
(define read-line
(lambda args
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim peek concat split))))
(error (string-append "read-line error: handle-delim must be either"
" 'trim, 'peek, 'concat or 'split")
(list-ref args 1)))
(apply read-delimited (cons (string #\newline) args))))
;; IN PROGRESS
#|
(define read-paragraph
(lambda args
(when (and (> (length args) 0)
(not (port? (car args))))
(error (string-append "read-delimited error: port must of type port")))
(when (and (> (length args) 1)
(not (member (list-ref args 1) '(trim concat split))))
(error (string-append "read-paragraph error: handle-delim must be either"
" 'trim, 'concat or 'split (peek not supported)")
(list-ref args 1)))
(letrec*
((port (if (> (length args) 0) (car args) (current-input-port)))
(handle-delim (if (> (length args) 1) (list-ref args 1) 'trim))
(result '())
(skipped-blank-lines? #f)
(looper (lambda (line)
(cond ((and (eof-object? line) (null? result)) line)
((and (not skipped-blank-lines?) (string=? line ""))
(looper (read-line port handle-delim)))
((and (not (string=? line ""))
(equal handle-delim 'trim))
(set! result line result))
((and (not (string=? line ""))
(equal handle-delim 'concat))
(set! result (string-append line "\n") result))
))
|#

37
retropikzel/scsh/portable.sld
View File

@ -1,37 +0,0 @@
(define-library
(retropikzel scsh portable)
(import (scheme base)
(scheme read)
(scheme write)
(scheme file)
(scheme process-context)
(srfi 60)
(srfi 170))
(export reduce-port
port-fold
simplify-file-name
set-umask
setenv
getenv
glob-quote
add-after
add-before
alist->env
alist-compress
alist-delete
alist-update
arg
arg*
argv
current-autoreap-policy
bin-dir
prefix
exec-prefix
lib-dir
include-dir
man-dir
obtain-dot-lock
)
(begin (define set-umask set-umask!))
(include "scsh/portable.scm"))

536
retropikzel/scsh/test.scm
View File

@ -1,536 +0,0 @@
(import (scheme base)
(scheme write)
(scheme read)
(scheme char)
(scheme file)
(scheme process-context)
(retropikzel scsh)
(retropikzel tap)
(retropikzel debug)
(srfi 14)
(srfi 19)
(srfi 64))
(test-runner-current (tap-runner))
(test-begin "scsh")
(test-begin "setenv")
(setenv "SCSH_TEST1" "foobar")
(test-equal "foobar" (get-environment-variable "SCSH_TEST1"))
(test-end "setenv")
(test-begin "getenv")
(test-equal "foobar" (getenv "SCSH_TEST1"))
(test-end "getenv")
#| FIXME
(test-begin "glob")
(when (file-exists? "test.test") (delete-file "test.test"))
(with-output-to-file "test.test" (lambda () (display 1)))
(test-equal '("test.test") (glob "*.test"))
(test-equal "." (car (glob ".*")))
(test-end "glob")
|#
#| FIXME
(test-begin "glob-quote")
(test-equal "\\*.scm" (glob-quote "*.scm"))
(when (file-exists? "*.test1") (delete-file "*.test1"))
(with-output-to-file "*.test1" (lambda () (display 1)))
(test-equal '("*.test1") (glob (glob-quote "*.test1")))
(test-end "glob-quote")
|#
(test-begin "->uid")
(test-equal 0 (->uid 0))
(test-equal 0 (->uid "root"))
(test-end "->uid")
(test-begin "->username")
(test-equal "root" (->username "root"))
(test-equal "root" (->username 0))
(test-end "->username")
(test-begin "port-fold")
(let-values (((lst) (port-fold (open-input-string "1 2 3") read cons '())))
(test-equal '(3 2 1) lst))
(test-end "port-fold")
(test-begin "reduce-port")
(let-values (((lst) (reduce-port (open-input-string "1 2 3") read cons '())))
(test-equal '(3 2 1) lst))
(test-end "port-fold")
(test-begin "simplify-file-name") ;; TODO
(test-end "simplify-file-name")
(test-begin "absolute-file-name")
(test-equal "/tmp" (absolute-file-name "/tmp"))
(test-end "absolute-file-name")
(test-begin "add-after")
(test-equal '(foo baz bar) (add-after 'baz 'foo '(foo bar)))
(test-end "add-after")
(test-begin "add-before")
(test-equal '(baz foo bar) (add-before 'baz 'foo '(foo bar)))
(test-end "add-before")
(test-begin "alist->env")
(test-equal '("one=1" "two=2" "PATH=/tmp:/usr/local/bin")
(alist->env '(("one" . "1")
("two" . "2")
("PATH" "/tmp" "/usr/local/bin"))))
(test-end "alist->env")
(test-begin "alist-compress")
(test-equal '((one . 1) (two . 2) (three .3) (four . 4))
(alist-compress '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
(test-end "alist-compress")
(test-begin "alist-delete")
(test-equal '((one . 1) (three .3) (four . 4))
(alist-delete 'two '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
(test-end "alist-delete")
(test-begin "alist-update")
(test-equal '((two . 20) (one . 1) (three .3) (four . 4))
(alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4))))
(test-equal '((two . 20) (one . 1) (three .3) (four . 4))
(alist-update 'two 20 '((one . 1) (two . 2) (three .3) (four . 4) (two . 2))))
(test-end "alist-update")
(test-begin "arg")
(test-equal 2 (arg '(1 2 3) 2))
(test-equal 200 (arg '(1 2 3) 4 200))
(test-equal 3 (arg '(1 2 3) 3))
(test-equal 3 (arg '(1 2 3) 3 200))
(test-end "arg")
(test-begin "arg*")
(test-equal 2 (arg* '(1 2 3) 2))
(test-equal 2 (arg* '(1 2 3) 2 (lambda () 2)))
(test-equal 2 (arg* '(1 2 3) 20 (lambda () 2)))
(test-end "arg*")
(test-begin "argv")
(test-assert (string? (argv 0)))
(test-end "argv")
(test-begin "autoreap-policy")
(autoreap-policy 'early)
(test-equal 'early (autoreap-policy))
(autoreap-policy 'late)
(test-equal 'late (autoreap-policy))
(autoreap-policy #f)
(test-equal #f (autoreap-policy))
(test-end "autoreap-policy")
(test-begin "sleep")
(let ((start-time (current-time)))
(sleep 3000)
(display "Slept for seconds: ")
(write (time-second (time-difference (current-time) start-time)))
(newline))
(test-end "sleep")
(test-begin "call-with-string-output-port")
(let* ((procedure (lambda (port) (display "Hello world" port)))
(out-str (call-with-string-output-port procedure)))
(test-equal "Hello world" out-str))
(test-end "call-with-string-output-port")
(test-begin "char-ascii?")
(test-assert (char-ascii? #\a))
(test-end "char-ascii?")
(test-begin "char-blank?")
(test-assert (char-blank? #\space))
(test-assert (char-blank? #\tab))
(test-assert (not (char-blank? #\a)))
(test-end "char-blank?")
(test-begin "char-digit?")
(test-assert (char-digit? #\1))
(test-assert (char-digit? #\0))
(test-assert (not (char-digit? #\a)))
(test-end "char-digit?")
(test-begin "char-graphic?")
(test-assert (char-graphic? #\a))
(test-end "char-graphic?")
(test-begin "char-hex-digit?")
(test-assert (char-hex-digit? #\1))
(test-assert (char-hex-digit? #\a))
(test-assert (not (char-hex-digit? #\space)))
(test-end "char-hex-digit?")
(test-begin "char-iso-control?")
(test-assert (not (char-iso-control? #\space)))
(test-end "char-iso-control?")
(test-begin "char-letter+digit?")
(test-assert (char-letter+digit? #\1))
(test-assert (char-letter+digit? #\a))
(test-end "char-letter+digit?")
(test-begin "char-letter?")
(test-assert (not (char-letter? #\1)))
(test-assert (char-letter? #\a))
(test-end "char-letter?")
(test-begin "char-punctuation?")
(test-assert (not (char-punctuation? #\a)))
(test-assert (char-punctuation? #\!))
(test-end "char-punctuation?")
(test-begin "char-title-case?")
(test-assert (not (char-title-case? #\a)))
(test-end "char-title-case?")
#| FIXME
(test-begin "cwd")
(debug (cwd))
(test-assert (string? (cwd)))
(test-assert (char=? (string-ref (cwd) 0) #\/))
(test-end "cwd")
|#
#| FIXME
(test-begin "chdir")
(let ((test-dir (cwd)))
(debug 0)
(chdir "/tmp")
(debug (cwd))
(test-assert (string=? (cwd) "/tmp"))
(debug 1)
(chdir test-dir)
(debug 2)
(test-assert (string=? (cwd) test-dir))
(when (not (string=? (cwd) test-dir))
(error "Test did not change back to test directory")))
(test-end "chdir")
|#
(test-begin "command-line")
(test-assert (list? (command-line)))
(test-end "command-line")
(test-begin "command-line-arguments")
(test-assert (list? (command-line-arguments)))
(test-end "command-line-arguments")
#| FIXME
(test-begin "delete-filesys-object")
(let ((file "/tmp/scschtest1.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display 1)))
(test-assert (file-exists? file))
(delete-filesys-object file)
(test-assert (not (file-exists? file)))
(when (file-exists? file) (delete-file file)))
(test-end "delete-filesys-object")
|#
#| FIXME
(test-begin "file-directory?")
(test-assert (file-directory? "/tmp" #f))
(let ((file "/tmp/scsch-file-directory?.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display 1)))
(test-assert (not (file-directory? file #f)))
(when (file-exists? file) (delete-file file)))
(test-end "file-directory?")
|#
#| FIXME
(test-begin "home-dir")
(test-assert (string? (home-dir)))
(test-end "home-dir")
|#
(test-begin "directory-as-file-name")
(test-equal "/" (directory-as-file-name "/"))
(test-equal "." (directory-as-file-name ""))
(test-equal "/tmp" (directory-as-file-name "/tmp/"))
(test-end "directory-as-file-name")
(test-begin "env->alist")
(test-equal '(("one" . "1") ("two" . "2") ("PATH" . "/tmp:/tmp/bin"))
(env->alist "one=1\ntwo=2\nPATH=/tmp:/tmp/bin"))
(test-end "env->alist")
(test-begin "error-output-port")
(test-assert (port? (error-output-port)))
(test-end "error-output-port")
(test-begin "file-last-access")
(test-assert (time? (file-last-access "/tmp" #f)))
(test-end "file-last-access")
(test-begin "file-last-mod")
(test-assert (time? (file-last-mod "/tmp" #f)))
(test-end "file-last-mod")
(test-begin "file-last-status-change")
(test-assert (time? (file-last-status-change "/tmp" #f)))
(test-end "file-last-status-change")
(test-begin "file-mode")
(test-assert (integer? (file-mode "/tmp" #f)))
(test-end "file-mode")
(test-begin "file-name-as-directory")
(test-equal "" (file-name-as-directory "."))
(test-equal "/" (file-name-as-directory "/"))
(test-equal "/" (file-name-as-directory ""))
(test-equal "/tmp/" (file-name-as-directory "/tmp"))
(test-equal "/tmp/" (file-name-as-directory "/tmp/"))
(test-end "file-name-as-directory")
(test-begin "file-name-directory")
(test-equal "/tmp/" (file-name-directory "/tmp/hello.txt"))
(test-equal "" (file-name-directory "hello.txt"))
(test-equal "lol/" (file-name-directory "lol/hello.txt"))
(test-equal "" (file-name-directory ""))
(test-equal "/usr/" (file-name-directory "/usr/bdc"))
(test-equal "/usr/bdc/" (file-name-directory "/usr/bdc/"))
(test-equal "bdc/" (file-name-directory "bdc/.login"))
(test-equal "" (file-name-directory "main.c"))
(test-equal "" (file-name-directory "/"))
(test-equal "" (file-name-directory ""))
(test-end "file-name-directory")
(test-begin "file-name-directory?")
(test-assert (file-name-directory? "/"))
(test-assert (not (file-name-directory? ".")))
(test-assert (file-name-directory? ""))
(test-assert (file-name-directory? "/tmp/"))
(test-assert (not (file-name-directory? "/tmp")))
(test-end "file-name-directory?")
(test-begin "file-name-extension")
(test-equal ".bar" (file-name-extension "foo.bar"))
(test-equal "" (file-name-extension "foobar"))
(test-equal "" (file-name-extension ""))
(test-end "file-name-extension")
(test-begin "file-name-non-directory?")
(test-assert (not (file-name-non-directory? "/")))
(test-assert (file-name-non-directory? "."))
;(test-assert (not (file-name-non-directory? ""))) ;; FIXME
(test-assert (not (file-name-non-directory? "/tmp/")))
(test-assert (file-name-non-directory? "/tmp"))
(test-end "file-name-non-directory?")
(test-begin "file-name-nondirectory")
(test-equal "ian" (file-name-nondirectory "/usr/ian"))
(test-equal "" (file-name-nondirectory "/usr/ian/"))
(test-equal ".login" (file-name-nondirectory "ian/.login"))
(test-equal "main.c" (file-name-nondirectory "main.c"))
(test-equal "" (file-name-nondirectory ""))
(test-equal "/" (file-name-nondirectory "/"))
(test-end "file-name-nondirectory")
(test-begin "file-name-sans-extension")
(test-equal "foo" (file-name-sans-extension "foo.bar"))
(test-equal "foobar" (file-name-sans-extension "foobar"))
(test-end "file-name-sans-extension")
(test-begin "file-nlinks")
(test-assert (number? (file-nlinks "/tmp" #f)))
(test-end "file-nlinks")
(test-begin "file-owner")
(test-assert (number? (file-owner "/tmp" #f)))
(test-end "file-owner")
(test-begin "home-directory")
(test-equal home-directory (get-environment-variable "HOME"))
(test-end "home-directory")
#| FIXME
(test-begin "home-file")
(test-assert (string? (home-file "/foo.bar")))
(test-end "home-file")
|#
(test-begin "host")
(test-assert (string? (host)))
(test-end "host")
(test-begin "make-char-port-filter")
(test-assert (procedure? (make-char-port-filter char-downcase)))
(let ((file "/tmp/scsch-make-char-port-filter.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display "ABC")))
(let* ((file-content
(with-input-from-file
file
(lambda ()
(parameterize
((current-output-port (open-output-string)))
(apply (make-char-port-filter char-downcase) '())
(get-output-string (current-output-port)))))))
(test-equal "abc" file-content)
(when (file-exists? file) (delete-file file))))
(test-end "make-char-port-filter")
(test-begin "make-string-port-filter")
(test-assert (procedure? (make-string-port-filter string-downcase)))
(let ((file "/tmp/scsch-make-string-port-filter.txt"))
(when (file-exists? file) (delete-file file))
(with-output-to-file file (lambda () (display "ABC")))
(let* ((file-content
(with-input-from-file
file
(lambda ()
(parameterize
((current-output-port (open-output-string)))
(apply (make-string-port-filter string-downcase) '())
(get-output-string (current-output-port)))))))
(test-equal "abc" file-content)
(when (file-exists? file) (delete-file file))))
(test-end "make-string-port-filter")
(test-begin "parent-pid")
(test-assert (number? (parent-pid)))
(test-end "parent-pid")
(test-begin "parse-file-name")
(test-equal '("/tmp/" "foo" ".bar") (parse-file-name "/tmp/foo.bar"))
(test-end "parse-file-name")
(test-begin "path-list->file-name")
(test-equal "src/des/main.c" (path-list->file-name '("src" "des" "main.c")))
(test-equal "/src/des/main.c" (path-list->file-name '("" "src" "des" "main.c")))
(test-equal "/usr/shivers/src/des/main.c"
(path-list->file-name '("src" "des" "main.c") "/usr/shivers"))
(test-end "path-list->file-name")
(test-begin "port->list")
(test-equal '(foo bar baz) (port->list read (open-input-string "foo bar baz")))
(test-end "port->list")
(test-begin "port->sexp-list")
(test-equal '(foo bar baz (1 2 3))
(port->sexp-list (open-input-string "foo bar baz (1 2 3)")))
(test-end "port->sexp-list")
(test-begin "port->string")
(test-equal "1 2 3 (1 2 3)" (port->string (open-input-string "1 2 3 (1 2 3)")))
(test-end "port->string")
(test-begin "port->string-list")
(test-equal '("foo" "bar" "baz")
(port->string-list (open-input-string "foo\nbar\nbaz\n")))
(test-end "port->string-list")
(test-begin "read-delimited")
(test-equal "foo" (read-delimited "1"
(open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3")
'trim))
(let ((port (open-input-string "foo1bar2baz3")))
(test-equal "foo" (read-delimited char-set:digit port 'peek))
(test-equal #\1 (read-char port)))
(test-equal "foo1" (read-delimited char-set:digit
(open-input-string "foo1bar2baz3")
'concat))
(test-end "read-delimited")
(test-begin "read-line")
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line (open-input-string "foo\nbar\nbaz\n") 'trim))
(let ((port (open-input-string "foo\nbar\nbaz\n")))
(test-equal "foo" (read-line port 'peek))
(test-equal #\newline (read-char port)))
(test-equal "foo\n" (read-line (open-input-string "foo\nbar\nbaz\n") 'concat))
(test-end "read-line")
#| IN PROGRESS
(test-begin "read-paragraph")
(test-equal "foo" (read-line (open-input-string "foo\n\nbar\n\nbaz\n\n")))
(test-equal "foo" (read-line (open-input-string "foo\n\nbar\n\nbaz\n\n")))
(test-equal "foo" (read-line (open-input-string "foo\n\nbar\n\nbaz\n\n") 'trim))
(test-equal "foo\n" (read-line (open-input-string "foo\n\nbar\n\nbaz\n\n") 'concat))
(test-end "read-paragraph")
|#
(test-end "scsh")

193
retropikzel/scsh/unix.scm
View File

@ -1,193 +0,0 @@
(define-c-library libc
'("stdlib.h" "string.h" "stdio.h" "glob.h" "unistd.h")
#f
())
(define-c-procedure c-perror libc 'perror 'void '(pointer))
(define (perror procedure-name msg . objs)
(let ((procedure-name* (string->c-bytevector
(string-append procedure-name " error"))))
(c-perror procedure-name*)
(c-bytevector-free procedure-name*))
(apply error (cons (string-append procedure-name " error: ") objs)))
(define *temp-file-template*
(cond ((get-environment-variable "TMPDIR")
(string-append (get-environment-variable "TMPDIR")
"/"
(number->string (pid))
".~a"))
(else
(string-append "/var/tmp/" (number->string (pid)) ".~a"))))
(define (->uid uid/username)
(cond
((exact-integer? uid/username) uid/username)
((string? uid/username)
(letrec*
((username-length (string-length uid/username))
(looper (lambda (line)
(if (eof-object? line)
#f
(let ((line-length (string-length line)))
(if (and (>= line-length username-length)
(string=? uid/username
(string-copy line
0
username-length)))
(string->number (list-ref (string-split line #\:) 2))
(looper (r7rs-read-line))))))))
(with-input-from-file "/etc/passwd" (lambda () (looper (r7rs-read-line))))))
(else (error (string-append "->uid error: uid/username must be either"
" exact integer or string")))))
(define (->username uid/username)
(cond ((string? uid/username) uid/username)
((exact-integer? uid/username)
(letrec*
((looper (lambda (line)
(if (eof-object? line)
#f
(let* ((line-length (string-length line))
(line-list (string-split line #\:))
(line-list-length (length line-list)))
(if (and (>= line-list-length 3)
(= (string->number (list-ref line-list 2))
uid/username))
(car line-list)
(looper (r7rs-read-line))))))))
(with-input-from-file "/etc/passwd" (lambda () (looper (r7rs-read-line))))))
(else (error (string-append "->username error: uid/username must be either"
" exact integer or string")))))
(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer))
(define (absolute-file-name fname . dir)
(cond ((not (string? fname))
(error "abosolute-file-name error: fname must bes string"))
((= (string-length fname) 0) "/")
(else (let* ((fname* (string->c-bytevector fname))
(path* (c-realpath fname* (c-bytevector-null))))
(if (c-bytevector-null? path*)
(let ((error* (string->c-bytevector "absolute-file-name")))
(c-perror error*)
(c-bytevector-free fname* path* error*)
(error "" fname))
(let ((path (c-bytevector->string path*)))
(c-bytevector-free fname* path*)
path))))))
(define-c-procedure c-glob libc 'glob 'int '(pointer int pointer pointer))
(define-c-procedure c-globfree libc 'globfree 'int '(pointer))
(define-c-struct-type glob-struct '((gl_pathc int) (gl_pathv pointer) (gl_offs int)))
(define glob
(lambda paths
(let ((result '()))
(for-each
(lambda (path)
(let ((glob-struct* (make-c-bytevector (c-type-size glob-struct)))
(path* (string->c-bytevector path)))
(c-glob path* 0 (c-bytevector-null) glob-struct*)
(letrec
((path-count (c-bytevector-ref glob-struct* glob-struct 'gl_pathc))
(looper
(lambda (count)
(when (< count path-count)
(let* ((list-path*
(c-bytevector-ref
(c-bytevector-ref glob-struct* glob-struct 'gl_pathv)
'pointer
(* (c-type-size 'pointer) count)))
(list-path-string (c-bytevector->string list-path*)))
(set! result (append result (list list-path-string)))
(c-bytevector-free list-path*)
(looper (+ count 1)))))))
(looper 0)
(c-bytevector-free path* glob-struct*))))
paths)
result)))
(define-c-procedure c-setsid libc 'setsid 'int '())
(define (become-session-leader)
(let ((result (c-setsid)))
(when (< result 0)
(error "become-session-leader error: Most propably already session leader"
result))
result))
(define-c-procedure c-chdir libc 'chdir 'int '(pointer))
(define chdir
(lambda args
(let ((fname (if (null? args) home-directory (car args))))
(when (not (string? fname)) (error "chdir error: fname must be string"))
(let* ((fname* (string->c-bytevector fname))
(result (c-chdir fname*)))
(c-bytevector-free fname*)
(when (= result -1)
(perror "chdir" "could not change directory"))))))
(define-c-procedure c-getcwd libc 'getcwd 'pointer '(pointer int))
(define (cwd)
(letrec
((start-size 128)
(looper
(lambda (size)
(let* ((buffer* (make-c-bytevector size))
(cwd* (c-getcwd buffer* size)))
(if (c-bytevector-null? cwd*)
(looper (* size 2))
(let ((result (c-bytevector->string buffer*)))
(c-bytevector-free cwd* buffer*)
result))))))
(looper start-size)))
(define (delete-filesys-object fname)
(when (not (string? fname))
(error "delete-filesys-object error: fname must be string"))
(if (file-directory? fname #f)
(delete-directory fname)
(guard (condition (else #t))
(delete-file fname))))
(define (file-directory? fname/port . chase?)
(when (not (or (string? fname/port)
(port? fname/port)))
(error "file-directory? error: fname/port must be string or port"))
(when (and (not (null? chase?))
(not (equal? (car chase?) #t))
(not (equal? (car chase?) #f)))
(error "file-directory? error: chase? must be boolean"))
(let ((f-info (file-info fname/port (if (null? chase?) #t (car chase?)))))
(file-info-directory? f-info)))
(define home-dir
(lambda args
(let ((user (if (null? args)
(user-info:name (user-info (user-uid)))
(car args))))
(when (not (string? user))
(error "home-dir error: user must be string" user))
(letrec
((username-length (string-length user))
(looper (lambda (line)
(if (eof-object? line)
#f
(let ((line-length (string-length line)))
(if (and (>= line-length username-length)
(string=? user
(string-copy line
0
username-length)))
(list-ref (string-split line #\:) 5)
(looper (r7rs-read-line)))))))
(home-dir-path (with-input-from-file
"/etc/passwd"
(lambda () (looper (r7rs-read-line))))))
(when (not home-dir-path)
(error "home-dir error: home directory not found, user does not exist?"
user))
home-dir-path))))
(define (host) (with-input-from-file "/etc/hostname" (lambda () (r7rs-read-line))))
(define-c-procedure c-getppid libc 'getppid 'int '())
(define (parent-pid) (c-getppid))

19
retropikzel/scsh/util.scm
View File

@ -1,19 +0,0 @@
(define (string-split str split-by)
(read (open-input-string
(list->string
(append
(list #\( #\")
(apply
append
(map
(lambda (c)
(if (char=? c split-by)
(list #\" #\space #\")
(list c)))
(string->list str)))
(list #\" #\)))))))
(define (string-join lst join-by)
(apply string-append
(cdr (apply append (map (lambda (item) (list join-by item)) lst)))))

14
retropikzel/shell.scm
View File

@ -1,10 +1,16 @@
(define-c-library libc '("stdlib.h" "stdio.h" "unistd.h") #f '())
(define-c-procedure c-tempnam libc 'tempnam 'pointer '(pointer pointer))
(define previous-exit-code #f)
(define (shell cmd)
(when (not (string? cmd)) (error "shell: cmd must be string" cmd))
(call-with-temporary-filename
(lambda (input-path)
(let* ((shell-command (string-append cmd
(let* ((temp-prefix (string->c-bytevector "npcmd"))
(temp-name (lambda ()
(c-bytevector->string (c-tempnam (c-bytevector-null)
temp-prefix))))
(input-path (temp-name))
(shell-command (string-append cmd
" 1> "
input-path
" 2> "
@ -12,7 +18,7 @@
" & ")))
(create-pipe input-path 0777)
(set! previous-exit-code (system shell-command))
(pipe-read-string 64000 (open-input-pipe input-path #t))))))
(pipe-read-string 64000 (open-input-pipe input-path #t))))
(define (lines->list port result)
(let ((line (read-line port)))

1
retropikzel/shell.sld
View File

@ -4,7 +4,6 @@
(scheme write)
(scheme read)
(scheme file)
(srfi 170)
(foreign c)
(retropikzel system)
(retropikzel named-pipes))

2
retropikzel/shell/VERSION
View File

@ -1 +1 @@
1.0.2
1.0.1

259
retropikzel/spite.scm
View File

@ -10,30 +10,69 @@
(define draw-color-g 0)
(define draw-color-b 0)
(define draw-color-a 255)
(define-c-library sdl2*
'("SDL2/SDL.h")
"SDL2-2.0"
`((additional-paths ("retropikzel/spite"
"snow/retropikzel/spite"))
(additional-versions ("0"))))
(define-c-library sdl2-image*
'("SDL2/SDL_image.h")
"SDL2_image-2.0"
`((additional-paths ("retropikzel/spite"
"snow/retropikzel/spite"))
(additional-versions ("0"))))
(define-c-procedure sdl-init sdl2* 'SDL_Init 'int '(int))
(define-c-procedure sdl-get-window-flags sdl2* 'SDL_GetWindowFlags 'int '(pointer))
(define-c-procedure sdl-create-window sdl2* 'SDL_CreateWindow 'pointer '(pointer int int int int int))
(define-c-procedure sdl-create-renderer sdl2* 'SDL_CreateRenderer 'pointer '(pointer int int))
(define-c-procedure sdl-render-setlogial-size sdl2* 'SDL_RenderSetLogicalSize 'int '(pointer int int))
(define-c-procedure sdl-render-set-integer-scale sdl2* 'SDL_RenderSetIntegerScale 'int '(pointer int))
(define-c-procedure sdl-set-render-draw-color sdl2* 'SDL_SetRenderDrawColor 'int '(pointer int int int int))
(define-c-procedure sdl-render-clear sdl2* 'SDL_RenderClear 'int '(pointer))
(define-c-procedure sdl-render-present sdl2* 'SDL_RenderPresent 'void '(pointer))
(define-c-procedure sdl-get-key-from-scancode sdl2* 'SDL_GetKeyFromScancode 'int '(int))
(define-c-procedure sdl-get-key-name sdl2* 'SDL_GetKeyName 'pointer '(int))
(define-c-procedure sdl-poll-event sdl2* 'SDL_PollEvent 'int '(pointer))
(define-c-procedure sdl-img-load-texture sdl2-image* 'IMG_LoadTexture 'pointer '(pointer pointer))
(define-c-procedure sdl-render-copy sdl2* 'SDL_RenderCopy 'int '(pointer pointer pointer pointer))
(define-c-procedure sdl-render-draw-line sdl2* 'SDL_RenderDrawLine 'int '(pointer int int int int))
(define-c-procedure sdl-render-draw-rect sdl2* 'SDL_RenderDrawRect 'int '(pointer pointer))
(define-c-procedure sdl-render-fill-rect sdl2* 'SDL_RenderFillRect 'int '(pointer pointer))
(define-c-procedure sdl-render-set-scale sdl2* 'SDL_RenderSetScale 'int '(pointer float float))
(define-c-procedure sdl-create-texture-from-surface sdl2* 'SDL_CreateTextureFromSurface 'pointer '(pointer pointer))
(define-c-procedure sdl-set-window-resizable sdl2* 'SDL_SetWindowResizable 'void '(pointer int))
(define-c-procedure sdl-render-get-scale sdl2* 'SDL_RenderGetScale 'void '(pointer pointer pointer))
(define-c-procedure sdl-render-geometry sdl2* 'SDL_RenderGeometry 'void '(pointer pointer pointer int pointer int))
(define window* #f)
(define renderer* #f)
(define event* (make-c-bytevector 4000))
(define draw-rect* (make-c-bytevector (* (c-type-size 'int) 4)))
(define draw-slice-rect* (make-c-bytevector (* (c-type-size 'int) 4)))
(define fill-triangle-vertex-size 1024
;; FIXME
;(+ (* (c-type-size 'int) 6) (* (c-type-size 'float) 2))
)
(define fill-triangle-vertex-size (+ (* (c-type-size 'int) 6) (* (c-type-size 'float) 2)))
(define fill-triangle-vertex1* (make-c-bytevector fill-triangle-vertex-size 0))
(define fill-triangle-vertex2* (make-c-bytevector fill-triangle-vertex-size 0))
(define fill-triangle-vertex3* (make-c-bytevector fill-triangle-vertex-size 0))
(define fill-triangle-vertexes* (make-c-bytevector (* fill-triangle-vertex-size 3 0)))
(c-bytevector-set!
fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 0) fill-triangle-vertex1*)
(c-bytevector-set!
fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 1) fill-triangle-vertex2*)
(c-bytevector-set!
fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 2) fill-triangle-vertex3*)
(define main-loop-start-time 0)
(define delta-time 0)
(define (main-loop update-procedure draw-procedure)
(set! main-loop-start-time (SDL_GetTicks))
(set! main-loop-start-time (current-jiffy))
(sdl2-events-get)
(update-procedure main-loop-start-time delta-time (poll-events!))
(update-procedure delta-time (poll-events!))
(render-clear)
(draw-procedure)
(render-present)
(set! delta-time (- (SDL_GetTicks) main-loop-start-time))
(set! delta-time (/ (- (current-jiffy) main-loop-start-time) (jiffies-per-second)))
(unless exit? (main-loop update-procedure draw-procedure)))
(define sdl2-event->spite-event
@ -50,8 +89,8 @@
'int
(+ (* (c-type-size 'int) 3)
(* (c-type-size 'u8) 4))))
(keycode (SDL_GetKeyFromScancode scancode))
(key (c-bytevector->string (SDL_GetKeyName keycode)))
(keycode (sdl-get-key-from-scancode scancode))
(key (c-bytevector->string (sdl-get-key-name keycode)))
(repeat? (= (c-bytevector-ref
event
'u8
@ -103,7 +142,7 @@
(define sdl2-events-get
(lambda ()
(let ((poll-result (SDL_PollEvent event*)))
(let ((poll-result (sdl-poll-event event*)))
(cond
((= poll-result 1)
(let ((event (sdl2-event->spite-event event*)))
@ -114,12 +153,12 @@
(define render-clear
(lambda ()
(SDL_SetRenderDrawColor renderer* 255 255 255 255)
(SDL_RenderClear renderer*)))
(sdl-set-render-draw-color renderer* 255 255 255 255)
(sdl-render-clear renderer*)))
(define render-present
(lambda ()
(SDL_RenderPresent renderer*)))
(sdl-render-present renderer*)))
(define-record-type image
(make-image pointer path)
@ -130,32 +169,20 @@
(define load-image
(lambda (path)
(when (not spite-inited?) (error "Can not load images until spite is inited." path))
(when (not (string? path)) (error "load-image: path must be string" path))
(when (not (file-exists? path)) (error (string-append "load-image: no such file: " path)))
(make-image (IMG_LoadTexture renderer* (string->c-bytevector path)) path)))
(when (not (string? path)) (error "Load path must be string" path))
(when (not (file-exists? path)) (error (string-append "Could not load image, no such file: " path)))
(make-image (sdl-img-load-texture renderer* (string->c-bytevector path)) path)))
(define draw-image
(lambda (image x y width height)
(when (not (exact-integer? x)) (error "draw-image: x must be exact integer"))
(when (not (exact-integer? y)) (error "draw-image: y must be exact integer"))
(when (not (exact-integer? width)) (error "draw-image: width must be exact integer"))
(when (not (exact-integer? height)) (error "draw-image: width must be exact integer"))
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
(SDL_RenderCopy renderer* (image-pointer image) (c-bytevector-null) draw-rect*)))
(sdl-render-copy renderer* (image-pointer image) (c-bytevector-null) draw-rect*)))
(define draw-image-slice
(lambda (image x y width height slice-x slice-y slice-width slice-height)
(when (not (exact-integer? x)) (error "draw-image: x must be exact integer"))
(when (not (exact-integer? y)) (error "draw-image: y must be exact integer"))
(when (not (exact-integer? width)) (error "draw-image: width must be exact integer"))
(when (not (exact-integer? height)) (error "draw-image: width must be exact integer"))
(when (not (exact-integer? slice-x)) (error "draw-image: slice-x must be exact integer"))
(when (not (exact-integer? slice-y)) (error "draw-image: slice-y must be exact integer"))
(when (not (exact-integer? slice-width)) (error "draw-image: slice-width must be exact integer"))
(when (not (exact-integer? slice-height)) (error "draw-image: slice-width must be exact integer"))
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
@ -164,13 +191,9 @@
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 1) slice-y)
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 2) slice-width)
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 3) slice-height)
(SDL_RenderCopy renderer* (image-pointer image) draw-slice-rect* draw-rect*)))
(sdl-render-copy renderer* (image-pointer image) draw-slice-rect* draw-rect*)))
(define (set-draw-color r g b . a)
(when (not (exact-integer? r)) (error "set-draw-color: r must be exact integer"))
(when (not (exact-integer? g)) (error "set-draw-color: g must be exact integer"))
(when (not (exact-integer? b)) (error "set-draw-color: b must be exact integer"))
(when (and (not (null? a)) (not (exact-integer? (car a)))) (error "set-draw-color: a must be exact integer"))
(set! draw-color-r r)
(set! draw-color-g g)
(set! draw-color-b b)
@ -191,62 +214,41 @@
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 4) draw-color-b)
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 5) draw-color-b)
(SDL_SetRenderDrawColor renderer* r g b draw-color-a))
(sdl-set-render-draw-color renderer* r g b draw-color-a))
(define (set-line-size size)
(when (not (exact-integer? size)) (error "set-line-size: size must be exact integer"))
(set! current-line-size size)
(SDL_RenderSetScale renderer* (inexact (/ size 1)) (inexact (/ size 1))))
(sdl-render-set-scale renderer* (inexact (/ size 1)) (inexact (/ size 1))))
(define (draw-point x y)
(when (not (exact-integer? x)) (error "draw-point: x must be exact integer"))
(when (not (exact-integer? y)) (error "draw-point: y must be exact integer"))
(SDL_RenderDrawLine renderer*
(sdl-render-draw-line renderer*
(exact (round (/ x current-line-size)))
(exact (round (/ y current-line-size)))
(exact (round (/ x current-line-size)))
(exact (round (/ y current-line-size)))))
(define (draw-line x1 y1 x2 y2)
(when (not (exact-integer? x1)) (error "draw-line: x1 must be exact integer"))
(when (not (exact-integer? y1)) (error "draw-line: y1 must be exact integer"))
(when (not (exact-integer? x2)) (error "draw-line: x2 must be exact integer"))
(when (not (exact-integer? y2)) (error "draw-line: y2 must be exact integer"))
(SDL_RenderDrawLine renderer*
(sdl-render-draw-line renderer*
(exact (round (/ x1 current-line-size)))
(exact (round (/ y1 current-line-size)))
(exact (round (/ x2 current-line-size)))
(exact (round (/ y2 current-line-size)))))
(define (draw-rectangle x y width height)
(when (not (exact-integer? x)) (error "draw-rectangle: x must be exact integer"))
(when (not (exact-integer? y)) (error "draw-rectangle: y must be exact integer"))
(when (not (exact-integer? width)) (error "draw-rectangle: width must be exact integer"))
(when (not (exact-integer? height)) (error "draw-rectangle: width must be exact integer"))
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
(SDL_RenderDrawRect renderer* draw-rect*))
(sdl-render-draw-rect renderer* draw-rect*))
(define (fill-rectangle x y width height)
(when (not (exact-integer? x)) (error "fill-rectangle: x must be exact integer"))
(when (not (exact-integer? y)) (error "fill-rectangle: y must be exact integer"))
(when (not (exact-integer? width)) (error "fill-rectangle: width must be exact integer"))
(when (not (exact-integer? height)) (error "fill-rectangle: width must be exact integer"))
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
(SDL_RenderFillRect renderer* draw-rect*))
(sdl-render-fill-rect renderer* draw-rect*))
(define (draw-triangle x1 y1 x2 y2 x3 y3)
(when (not (exact-integer? x1)) (error "draw-triangle: x1 must be exact integer"))
(when (not (exact-integer? y1)) (error "draw-triangle: y1 must be exact integer"))
(when (not (exact-integer? x2)) (error "draw-triangle: x2 must be exact integer"))
(when (not (exact-integer? y2)) (error "draw-triangle: y2 must be exact integer"))
(when (not (exact-integer? x3)) (error "draw-triangle: x3 must be exact integer"))
(when (not (exact-integer? y3)) (error "draw-triangle: y3 must be exact integer"))
(draw-line x1 y1 x2 y2)
(draw-line x2 y2 x3 y3)
(draw-line x3 y3 x1 y1))
@ -262,23 +264,23 @@
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 0) x3)
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 1) y3)
(SDL_RenderGeometry renderer* (c-bytevector-null) fill-triangle-vertexes* 3 (c-bytevector-null) 0))
(sdl-render-geometry renderer* (c-bytevector-null) fill-triangle-vertexes* 3 (c-bytevector-null) 0))
(define (spite-option-set! name . value)
(cond
((equal? name 'allow-window-resizing)
(cond
((equal? value '(#t))
(SDL_SetWindowResizable window* 1))
(sdl-set-window-resizable window* 1))
((equal? value '(#f))
(SDL_SetWindowResizable window* 0))
(sdl-set-window-resizable window* 0))
(else (error "Wrong option value for 'allow-window-resizing, must be #t or #f"
value))))
((equal? name 'renderer-size)
(if (and (= (length value) 2)
(number? (car value))
(number? (cadr value)))
(SDL_RenderSetLogicalSize renderer* (car value) (cadr value))
(sdl-render-setlogial-size renderer* (car value) (cadr value))
(error "Wrong option value for renderer-size, must be two numbers")))
(else (error "No such option!" name))))
@ -287,17 +289,12 @@
(lambda ()
(let ((x (make-c-bytevector (c-type-size 'float)))
(y (make-c-bytevector (c-type-size 'float))))
(SDL_RenderGetScale renderer* x y)
(sdl-render-get-scale renderer* x y)
(list (cons 'x (c-bytevector-ref x 'float 0))
(cons 'y (c-bytevector-ref y 'float 0))))))
(define spite-start
(lambda (update-procedure draw-procedure)
(when (not (procedure? update-procedure)) (error "spite-start: update-procedure must be procedure"))
(when (not (procedure? draw-procedure)) (error "spite-start: draw-procedure must be procedure"))
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 0) fill-triangle-vertex1*)
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 1) fill-triangle-vertex2*)
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 2) fill-triangle-vertex3*)
(cond
((not started?)
(set! started? #t)
@ -305,15 +302,13 @@
(define spite-init
(lambda (title width height)
(when (not (exact-integer? width)) (error "spite-init: width must be exact integer"))
(when (not (exact-integer? height)) (error "spite-init: height must be exact integer"))
(cond
((not started?)
(SDL_Init 32)
(set! window* (SDL_CreateWindow (string->c-bytevector title) 0 0 width height 4))
(set! renderer* (SDL_CreateRenderer window* -1 2))
(SDL_RenderSetLogicalSize renderer* width height)
(SDL_RenderSetIntegerScale renderer* 1)
(sdl-init 32)
(set! window* (sdl-create-window (string->c-bytevector title) 0 0 width height 4))
(set! renderer* (sdl-create-renderer window* -1 2))
(sdl-render-setlogial-size renderer* width height)
(sdl-render-set-integer-scale renderer* 1)
(render-clear)
(render-present)
(set! spite-inited? #t)))))
@ -338,62 +333,76 @@
(lambda ()
(set! events (list))))
(define-record-type <bitmap-font>
(internal-make-bitmap-font image draw-width draw-height character-width character-height lookup-table)
(define-record-type bitmap-font
(internal-make-bitmap-font data)
bitmap-font?
(image bitmap-font-image)
(draw-width bitmap-font-draw-width)
(draw-height bitmap-font-draw-height)
(character-width bitmap-font-character-width)
(character-height bitmap-font-character-height)
(lookup-table bitmap-font-lookup-table))
(data bitmap-font-data))
(define (make-bitmap-font image character-width character-height draw-width draw-height character-lists)
(let* ((line-index -1)
(character-index -1)
(lookup-table (make-vector 0)))
(for-each
(lambda (line)
(set! line-index (+ line-index 1))
(set! character-index -1)
(for-each
(lambda (character)
(set! character-index (+ character-index 1))
(let ((c-int (char->integer character)))
(when (<= (vector-length lookup-table) c-int)
(set! lookup-table
(vector-append
lookup-table
(make-vector (+ (- c-int (vector-length lookup-table)) 1) #f))))
(vector-set! lookup-table
c-int
(vector character
(* character-index character-width)
(* line-index character-height)))))
line))
character-lists)
(internal-make-bitmap-font image draw-width draw-height character-width character-height lookup-table)))
(define (bitmap-font-get key bitmap)
(cdr (assoc key (bitmap-font-data bitmap))))
(define-record-type bitmap-char
(make-bitmap-char char x y)
bitmap-char?
(char bitmap-char-char)
(x bitmap-char-x)
(y bitmap-char-y))
(define (make-bitmap-font image character-width character-height draw-width draw-height character-lines)
(let* ((line-items-count (string-length (car character-lines)))
(characters (apply string-append character-lines))
(index -1)
(character-indexes (list))
(character-positions
(map (lambda (character)
(set! index (+ index 1))
(set! character-indexes (append character-indexes (list character index)))
(list character
(* (modulo index line-items-count)
character-width)
(* (floor (/ index line-items-count))
character-height)))
(string->list characters))))
(internal-make-bitmap-font
`((image . ,image)
(character-width . ,character-width)
(character-height . ,character-height)
(character-draw-width . ,draw-width)
(character-draw-height . ,draw-height)
(line-items-count . ,line-items-count)
(characters . ,characters)
(character-indexes . ,character-indexes)
(character-positions . ,character-positions)))))
(define (set-bitmap-font font)
(set! current-bitmap-font font))
(define (make-bitmap-text text font)
(map
(lambda (c)
(make-bitmap-char
c
(cadr (assq c (bitmap-font-get 'character-positions font)))
(cadr (cdr (assq c (bitmap-font-get 'character-positions font))))))
(string->list text)))
(define (set-bitmap-font font) (set! current-bitmap-font font))
(define draw-bitmap-text
(lambda (text x y)
(when (not current-bitmap-font)
(error "Current bitmap font not set, use make-bitmap-font and set-bitmap-font"))
(let ((offset-x x)
(lookup-table (bitmap-font-lookup-table current-bitmap-font)))
(let ((offset-x x))
(for-each
(lambda (character)
(let ((char-data (vector-ref lookup-table (char->integer character))))
(draw-image-slice (bitmap-font-image current-bitmap-font)
(lambda (bitmap-char)
(draw-image-slice (bitmap-font-get 'image current-bitmap-font)
offset-x
y
(bitmap-font-draw-width current-bitmap-font)
(bitmap-font-draw-height current-bitmap-font)
(vector-ref char-data 1)
(vector-ref char-data 2)
(bitmap-font-character-width current-bitmap-font)
(bitmap-font-character-height current-bitmap-font))
(set! offset-x (+ offset-x 14))))
(string->list text)))))
(bitmap-font-get 'character-draw-width current-bitmap-font)
(bitmap-font-get 'character-draw-height current-bitmap-font)
(bitmap-char-x bitmap-char)
(bitmap-char-y bitmap-char)
(bitmap-font-get 'character-width current-bitmap-font)
(bitmap-font-get 'character-height current-bitmap-font))
(set! offset-x (+ offset-x (bitmap-font-get 'character-draw-width current-bitmap-font))))
(make-bitmap-text text current-bitmap-font)))))

8
retropikzel/spite.sld
View File

@ -7,14 +7,6 @@
(scheme file)
(scheme load)
(scheme time)
(scheme char)
(c2foreign-c sdl2 init)
(c2foreign-c sdl2 video)
(c2foreign-c sdl2 render)
(c2foreign-c sdl2 events)
(c2foreign-c sdl2 keyboard)
(c2foreign-c sdl2 timer)
(c2foreign-c sdl2-image)
(foreign c))
(export spite-init
spite-start

1
retropikzel/spite/APT_PACKAGES
View File

@ -1 +0,0 @@
libsdl2-dev libsdl2-image-dev

1
retropikzel/spite/CSC_OPTIONS
View File

@ -1 +0,0 @@
-L -lSDL2_image -L -lSDL2

1
retropikzel/spite/PACKAGE_ARGS
View File

@ -1 +0,0 @@
--foreign-depends SDL2_image,sdl2

50
retropikzel/spite/README.md
View File

@ -1,54 +1,14 @@
Game library inspired by some other game library named after emotion
Game library inspired by some other game library named after emotion built on
top of [(foreign c)](https://sr.ht/~retropikzel/foreign-c/).
Please note that Spite is currently in **alpha** stage.
## Dependencies
SDL2 and SDL2 Image libraries.
[Issue tracker](https://todo.sr.ht/~retropikzel/Spite)
## Installation
[Mailing lists](https://sr.ht/~retropikzel/Spite/lists)
snow-chibi install --impls=$SCHEME retropikzel.spite
## Usage
Example:
(import (scheme base)
(scheme write)
(scheme read)
(scheme file)
(foreign c)
(retropikzel spite))
(spite-init "Hello world" 400 400)
(define black '(0 0 0))
(define player-x 64)
(define player-y 64)
(define update
(lambda (time-ms delta-time events)
(for-each
(lambda (event)
(when (symbol=? (cdr (assoc 'type event)) 'key-down)
(let ((key (cdr (assoc 'key event))))
(when (string=? key "W") (set! player-y (- player-y 8)))
(when (string=? key "A") (set! player-x (- player-x 8)))
(when (string=? key "S") (set! player-y (+ player-y 8)))
(when (string=? key "D") (set! player-x (+ player-x 8)))
)))
events)
#t))
(define draw
(lambda ()
(apply set-draw-color black)
(fill-rectangle player-x player-y 32 32)))
(spite-start update draw)
[Source](https://git.sr.ht/~retropikzel/spite)
## Documentation - Spite

2
retropikzel/spite/VERSION
View File

@ -1 +1 @@
0.3.0
0.1.0

20
retropikzel/spite/test.scm
View File

@ -5,7 +5,6 @@
(define player-y 100)
(define font-image (load-image "test-resources/charmap-cellphone_black.png"))
(define icons-image (load-image "test-resources/icons.png"))
(define black '(0 0 0))
(define blue '(0 0 255))
@ -14,23 +13,22 @@
(define character-height 9)
(define draw-width 14)
(define draw-height 18)
(define character-lists
`((#\space #\! #\" #\# #\$ #\% #\& #\/ #\( #\) #\* #\+ #\, #\- #\. #\0 #\1)
(#\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C)
(#\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U)
(#\V #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g)
(#\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y)
(#\z #\{ #\| #\} #\~ #\~)))
(define character-lines (list " !\"#¤%&/()*+,-./01"
"23456789:;<=>?@ABC"
"DEFGHIJKLMNOPQRSTU"
"VWXYZ[\\]^_´abcdefg"
"hijklmnopqrstuvwxy"
"z{|}~"))
(define font (make-bitmap-font font-image
character-width
character-height
draw-width
draw-height
character-lists))
character-lines))
(set-bitmap-font font)
(define update
(lambda (time-ms delta-time events)
(lambda (delta-time events)
(for-each
(lambda (event)
(when (symbol=? (cdr (assoc 'type event)) 'key-down)
@ -55,8 +53,6 @@
(fill-rectangle (+ player-x 32) (+ player-y 32) 16 16)
(draw-triangle 350 350 380 380 330 380)
;(fill-triangle 450 450 480 480 430 480)
(draw-image-slice icons-image 500 500 32 32 0 0 32 32)
(draw-image-slice icons-image 532 532 32 32 32 32 32 32)
))
(spite-start update draw)

6
retropikzel/system.scm
View File

@ -2,7 +2,7 @@
(define-c-procedure c-system libc 'system 'int '(pointer))
(define (system command)
(let* ((command-cbv (string->c-bytevector command))
(result (c-system command-cbv)))
(c-bytevector-free command-cbv)
(let* ((command-pointer (string->c-bytevector command))
(result (c-system command-pointer)))
(c-bytevector-free command-pointer)
result))

2
retropikzel/system/VERSION
View File

@ -1 +1 @@
1.1.6
1.1.5

8
retropikzel/system/test.scm
View File

@ -1,11 +1,3 @@
(import (scheme base)
(scheme write)
(scheme file)
(retropikzel system)
(retropikzel tap)
(srfi 64))
(test-runner-current (tap-runner))
(test-begin "foreign-c-system")