Switch to test-r7rs

.gitignore

@@ -25,5 +25,3 @@ example
 venv
 foreign
 tmp
-*.json
-test-program

Dockerfile.jenkins

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

Jenkinsfile

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

Makefile

@@ -1,69 +1,61 @@
-.SILENT:
 SCHEME=chibi
 DOCKER_TAG=latest
+IMAGE=${SCHEME}:${DOCKER_TAG}
 RNRS=r7rs
 LIBRARY=system
+EXAMPLE=editor
+EXAMPLE_FILE=retropikzel/${LIBRARY}/examples/${EXAMPLE}
 AUTHOR=Retropikzel
 
-VERSION != cat retropikzel/${LIBRARY}/VERSION
-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
-DESCRIPTION != head -n1 retropikzel/${LIBRARY}/README.md
+VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
+DESCRIPTION=$(shell head -n1 retropikzel/${LIBRARY}/README.md)
 README=retropikzel/${LIBRARY}/README.html
 TESTFILE=retropikzel/${LIBRARY}/test.scm
 
 PKG=retropikzel-${LIBRARY}-${VERSION}.tgz
 
-ifeq "${SCHEME}" "capyscheme"
-DOCKER_TAG=head
-endif
-ifeq "${SCHEME}" "chibi"
-DOCKER_TAG=head
-endif
-ifeq "${SCHEME}" "chicken"
-DOCKER_TAG=head
-endif
-ifeq "${SCHEME}" "gauche"
-DOCKER_TAG=head
+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
 
-all: package
+all: build
 
-package: retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md retropikzel/${LIBRARY}/LICENSE
+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=${README} \
 		--description="${DESCRIPTION}" \
 		${LIBRARY_FILE}
 
-${PKG}: package
-
 install:
 	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.64 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

retropikzel/download-file.scm

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

retropikzel/download-file.sld

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

retropikzel/download-file/APT_PACKAGES

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

retropikzel/download-file/CSC_OPTIONS

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

retropikzel/download-file/LICENSE

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

retropikzel/download-file/PACKAGE_ARGS

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

retropikzel/download-file/README.md

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

retropikzel/download-file/VERSION

@@ -1 +0,0 @@
-1.0.0

retropikzel/download-file/test.scm

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

retropikzel/file-append.scm

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

retropikzel/file-append.sld

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

retropikzel/file-append/LICENSE

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

retropikzel/file-append/README.md

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

retropikzel/file-append/VERSION

@@ -1 +0,0 @@
-0.3.1

retropikzel/file-append/test.scm

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

retropikzel/gi-repository.scm

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

retropikzel/gi-repository.sld

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

retropikzel/gi-repository/APT_PACKAGES

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

retropikzel/gi-repository/CSC_OPTIONS

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

retropikzel/gi-repository/test.scm

@@ -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 gobject (gi-repository "GObject" "2.0"))
-(define gobject-object (gi-object gtk "GObject" "Object"))
-(define gobject-closure (gi-struct gtk "GObject" "Closure"))
-
-(define gio (gi-repository "Gio" "2.0"))
-(define gio-application (gi-object gio "Gio" "Application"))
-
-(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-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")
-    (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"))
+(define repository (gi-repository-new))
+(display repository)
 (newline)
 
-(display (gi-object-invoke gio-application "run" 0 (c-bytevector-null)))
+(define err (make-c-null))
+
+(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 base-info
+  (gi-repository-find-by-name repository
+                              (string->c-utf8 "GLib")
+                              (string->c-utf8 "assertion_message")))
+
+(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)
+      )))
 
-
-;|#
-;(test-end "gi-repository")
+(test-end "gi-repository")

retropikzel/gtk-webview/README.md

@@ -1 +0,0 @@
-WIP

retropikzel/named-pipes.scm

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

retropikzel/named-pipes/VERSION

@@ -1 +1 @@
-1.0.4
+1.0.2

retropikzel/pstk.scm

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

retropikzel/pstk.sld

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

retropikzel/pstk/VERSION

@@ -1 +1 @@
-1.0.8
+1.0.7

retropikzel/scsh.sld

@@ -1,751 +0,0 @@
-(define-library
-  (retropikzel scsh)
-  (import (scheme base)
-          (scheme write)
-          (scheme file)
-          (scheme process-context)
-          (foreign c)
-          (srfi 170))
-  (export
-    ;*temp-file-template*
-    ;->uid
-    ;->username
-    ;%exec
-    ;%exit
-    ;%fork
-    ;%fork/pipe
-    ;%fork/pipe+
-    ;%read-delimited!
-    ;&
-    ;&
-    ;&&
-    ;reduce-port
-    ;absolute-file-name
-    ;accept-connection
-    ;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
-    ;bin-dir
-    ;bind-listen-accept-loop
-    ;bind-prepare-listen-accept-loop
-    ;bind-socket
-    ;bitwise-and
-    ;bitwise-ior
-    ;bitwise-not
-    ;bitwise-xor
-    ;break-dot-lock
-    ;bufpol/block
-    ;bufpol/line
-    ;bufpol/none
-    ;call-terminally
-    ;call-with-string-output-port
-    ;call/fdes
-    ;cflags
-    ;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
-    ;clean-up-cres
-    ;close
-    ;close-after
-    ;close-directory-stream
-    ;close-socket
-    ;close-syslog-channel
-    ;command-line
-    ;command-line-arguments
-    ;compiler-flags
-    ;connect-socket
-    ;connect-socket-no-wait
-    ;connect-socket-successful?
-    ;control-tty-file-name
-    ;copy-tty-info
-    ;cppflags
-    ;cpu-ticks/sec
-    create-directory
-    create-fifo
-    create-hard-link
-    ;create-socket
-    ;create-socket-pair
-    create-symlink
-    create-temp-file
-    ;crypt
-    ;current-thread
-    ;cwd
-    ;date, [2]
-    ;date, [2]
-    ;date->string
-    ;default-lib-dirs
-    ;define-record
-    ;defs
-    delete-directory
-    delete-file
-    ;delete-filesys-object
-    ;directory-as-file-name
-    directory-files
-    ;disable-tty-char
-    ;drain-tty
-    ;dump-scsh
-    ;dump-scsh-program
-    ;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-prefix
-    ;exec/env
-    exit
-    ;expand-file-name
-    ;fdes->inport
-    ;fdes->outport
-    ;fdes-flags
-    ;fdes-status
-    ;field-reader
-    ;field-splitter
-    ;file-directory?
-    ;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-socket?
-    ;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
-    ile-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-socket?
-    ;file-special?
-    ;file-symlink?
-    ;file-type
-    ;file-writable?
-    ;fill-in-date!
-    ;find-library-file
-    ;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+
-    ;format-date
-    ;get-lock-region
-    getenv
-    glob
-    ;glob-quote
-    group-info
-    group-info:gid
-    ;group-info:members
-    group-info:name
-    ;handle-signal-default
-    ;home-dir
-    ;home-directory
-    ;home-file
-    ;host
-    ;host-info
-    ;if-match
-    ;if-sre-form
-    ;ignore-signal
-    ;include-dir
-    ;infix-splitter
-    ;internet-address->socket-address
-    ;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
-    ;join-strings
-    ;ldflags
-    ;let-match
-    ;lib-dir
-    ;lib-dirs
-    ;lib-dirs-list
-    ;libs
-    ;linker-flags
-    ;listen-socket
-    ;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-date
-    ;make-lock
-    ;make-lock-region
-    ;make-md5-context
-    ;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
-    ;make-string-input-port
-    ;make-string-output-port
-    ;make-string-port-filter
-    ;make-syslog-mask
-    ;make-syslog-options
-    ;make-tty-info
-    ;man-dir
-    ;match-cond
-    ;match:end
-    ;match:start
-    ;match:substring
-    ;maybe-obtain-lock
-    ;md5-context->md5-digest
-    ;md5-context?
-    ;md5-digest->number
-    ;md5-digest-for-port
-    ;md5-digest-for-string
-    ;md5-digest?
-    ;most-recent-sigevent
-    ;move->fdes
-    ;network-info
-    ;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
-    ;open-fdes
-    ;open-file
-    ;open-input-file
-    ;open-output-file
-    ;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->socket
-    ;port->string
-    ;port->string-list
-    ;port-fold
-    ;port-revealed
-    ;posix-string->regexp
-    ;prefix
-    ;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
-    ;read-string
-    ;read-string!
-    ;read-string!/partial
-    ;read-string/partial
-    read-symlink
-    ;reap-zombies
-    ;receive-message
-    ;receive-message!
-    ;receive-message!/partial
-    ;receive-message/partial
-    ;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
-    )
-  (cond-expand
-    (windows (begin (error "Windows not supported")))
-    (else (include "scsh.unix.scm"))))

retropikzel/scsh.unix.scm

@@ -1,28 +0,0 @@
-(define-c-library libc '("stdlib.h" "string.h" "stdio.h" "glob.h") #f ())
-
-;(define-c-procedure c-setenv libc 'setenv 'int '(pointer pointer int))
-
-(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-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-cbv (make-c-bytevector (c-type-size glob-struct)))
-                (path-cbv (string->c-bytevector path)))
-            (c-glob path-cbv 0 glob-struct-cbv)
-            (display "HERE: path ")
-            (display path)
-            (newline)
-            (c-bytevector-free path-cbv)
-            ))
-        paths))))

retropikzel/scsh/LICENSE

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

retropikzel/scsh/README.md

@@ -1,14 +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).
-
-
-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)

retropikzel/scsh/VERSION

@@ -1 +0,0 @@
-0.1.0

retropikzel/scsh/test.scm

@@ -1,32 +0,0 @@
-(import (scheme base)
-        (scheme write)
-        (scheme read)
-        (scheme char)
-        (scheme file)
-        (scheme process-context)
-        (retropikzel scsh)
-        (srfi 64)
-        (retropikzel tap))
-
-(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")
-
-
-(test-begin "glob")
-(test-equal '("test.hehe") (glob "*.hehe"))
-(test-end "glob")
-
-
-
-(test-end "scsh")

retropikzel/shell.scm

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

retropikzel/shell.sld

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

retropikzel/shell/VERSION

@@ -1 +1 @@
-1.0.2
+1.0.1

retropikzel/spite.scm

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

retropikzel/spite.sld

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

retropikzel/spite/APT_PACKAGES

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

retropikzel/spite/CSC_OPTIONS

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

retropikzel/spite/PACKAGE_ARGS

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

retropikzel/spite/README.md

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

retropikzel/spite/VERSION

@@ -1 +1 @@
-0.3.0
+0.1.0

retropikzel/spite/test.scm

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

retropikzel/system.scm

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