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

gi-repository (#1) 

Just bringing all changes to main

Reviewed-on: https://codeberg.org/retropikzel/foreign-c-libraries/pulls/1
Co-authored-by: retropikzel <retropikzel@iki.fi>
Co-committed-by: retropikzel <retropikzel@iki.fi>
This commit is contained in:
retropikzel 2026-04-12 09:23:26 +02:00 committed by retropikzel
parent 5ce7aaf7de
commit 5db788c38d
11 changed files with 628 additions and 310 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -24,3 +24,4 @@ example.sps
example
venv
foreign
tmp

46
Dockerfile
View File

@ -1,46 +0,0 @@
ARG SCHEME=chibi
ARG IMAGE=${SCHEME}:head
FROM debian:trixie AS build
RUN apt-get update && apt-get install -y \
git ca-certificates make gcc libffi-dev libffi-dev wget xz-utils libcurl4
RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
WORKDIR /build
RUN wget https://gitlab.com/-/project/6808260/uploads/094ce726ce3c6cf8c14560f1e31aaea0/akku-1.1.0.amd64-linux.tar.xz \
&& tar -xf akku-1.1.0.amd64-linux.tar.xz \
&& mv akku-1.1.0.amd64-linux akku
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1
RUN git clone https://codeberg.org/retropikzel/compile-scheme.git --depth=1
WORKDIR /build/chibi-scheme
RUN make
RUN make install
WORKDIR /build/compile-scheme
RUN make build-gauche
WORKDIR /build
RUN git clone https://codeberg.org/foreign-c/foreign-c.git --depth=2
ARG SCHEME=chibi
ARG IMAGE=${SCHEME}:head
FROM schemers/${IMAGE}
RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche
RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
COPY --from=build /build /build
ARG SCHEME=chibi
WORKDIR /build/compile-scheme
RUN make install
WORKDIR /build/chibi-scheme
RUN make install
WORKDIR /build/chibi-scheme
RUN make install
WORKDIR /build/akku
RUN bash install.sh
ENV PATH=/root/.local/bin:${PATH}
RUN akku update
WORKDIR /build/foreign-c
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)" || true
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)" || true
RUN make SCHEME=${SCHEME} build install
WORKDIR /workdir
RUN cp -r /build/foreign-c/foreign .
COPY Makefile .
COPY retropikzel retropikzel/

13
Dockerfile.jenkins
View File

@ -1,8 +1,5 @@
FROM debian:trixie-slim
RUN apt-get update && apt-get install -y \
make ca-certificates git docker.io gauche time mit-scheme
WORKDIR /cache
RUN git clone https://codeberg.org/retropikzel/compile-scheme.git --depth=1
WORKDIR /cache/compile-scheme
RUN make build-gauche
RUN make install
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

67
Jenkinsfile vendored
View File

@ -15,46 +15,18 @@ pipeline {
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 shell', description: '')
string(name: 'LIBRARIES', defaultValue: 'system named-pipes shell requests', description: '')
}
stages {
stage('Tests') {
parallel {
stage('R6RS') {
steps {
script {
params.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
parallel params.R6RS_SCHEMES.split().collectEntries { SCHEME ->
[(SCHEME): {
def IMG="${SCHEME}:head"
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 600 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r6rs-docker"
}
}]
}
}
}
}
}
}
stage('R7RS') {
steps {
script {
params.LIBRARIES.split().each { LIBRARY ->
stage("${LIBRARY}") {
parallel params.R7RS_SCHEMES.split().collectEntries() { SCHEME ->
[(SCHEME): {
def IMG="${SCHEME}:head"
if("${SCHEME}" == "chicken") {
IMG="${SCHEME}:5"
}
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "timeout 600 make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r7rs-docker"
}
}]
}
stage('Test R6RS Debian') {
steps {
script {
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"
}
}
}
@ -62,6 +34,25 @@ pipeline {
}
}
}
stage('Test R7RS Debian') {
steps {
script {
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"
}
}
}
}
}
}
}
}
post {
always {
cleanWs()
}
}
}

121
Makefile
View File

@ -1,4 +1,6 @@
SCHEME=chibi
DOCKER_TAG=latest
IMAGE=${SCHEME}:${DOCKER_TAG}
RNRS=r7rs
LIBRARY=system
EXAMPLE=editor
@ -13,84 +15,69 @@ TESTFILE=retropikzel/${LIBRARY}/test.scm
PKG=retropikzel-${LIBRARY}-${VERSION}.tgz
DOCKERIMG=${SCHEME}:head
ifeq "${SCHEME}" "chicken"
DOCKERIMG="chicken:5"
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
APT_PACKAGES=
CSC_OPTIONS=
ifeq "${LIBRARY}" "gi-repository"
APT_PACKAGES=libgirepository-2.0-dev
CSC_OPTIONS=-L -lgirepository-2.0 -L -lgobject-2.0 -L -lglib-2.0
endif
all: build
build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION
rm -rf *.tgz
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
snow-chibi package \
--always-yes \
--version=${VERSION} \
--authors=${AUTHOR} \
--doc=${README} \
--description="${DESCRIPTION}" \
${LIBRARY_FILE}
install:
snow-chibi install --impls=${SCHEME} ${SNOW_CHIBI_ARGS} ${PKG}
snow-chibi install --impls=${SCHEME} --always-yes ${PKG}
uninstall:
-snow-chibi remove --impls=${SCHEME} ${PKG}
testfiles: build
rm -rf .tmp
mkdir -p .tmp
cp -r test-resources .tmp/
cp -r retropikzel .tmp/
cp ${PKG} .tmp/
# R6RS testfiles
printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (foreign c) (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) (foreign c) (retropikzel ${LIBRARY}))" > .tmp/test.scm
cat ${TESTFILE} >> .tmp/test.scm
init-venv: build
rm -rf venv
scheme-venv ${SCHEME} ${RNRS} venv
echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > venv/test.scm
printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (retropikzel ${LIBRARY}))" > venv/test.sps
cat ${TESTFILE} >> venv/test.scm
cat ${TESTFILE} >> venv/test.sps
if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
#if [ "${SCHEME}" = "chezscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
#if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
#if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
#if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
test: testfiles
cd .tmp && \
COMPILE_R7RS=${SCHEME} \
CSC_OPTIONS="${CSC_OPTIONS}" \
compile-r7rs \
-o test-program \
test.${SFX}
cd .tmp && ./test-program
run-test: init-venv
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi
if [ "${RNRS}" = "r7rs" ]; then CSC_OPTIONS="-L -lcurl -L -lSDL2 -L -lSDL2_image" ./venv/bin/scheme-compile venv/test.scm; fi
./venv/test
test-r7rs:
echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (foreign c) (retropikzel ${LIBRARY}) (srfi 64))" > test-r7rs.scm
cat retropikzel/${LIBRARY}/test.scm >> test-r7rs.scm
COMPILE_R7RS=${SCHEME} timeout 60 compile-scheme -I . -o test-r7rs test-r7rs.scm
printf "\n" | timeout 60 ./test-r7rs
test-r7rs-docker:
echo "Building docker image..."
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet .
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs"
example.scm: ${EXAMPLE_FILE}.scm
cp ${EXAMPLE_FILE}.scm example.scm
example-r7rs: example.scm
COMPILE_R7RS=${SCHEME} compile-scheme -I . -o example example.scm
./example
test-r6rs:
echo "(import (except (rnrs) remove) (foreign c) (retropikzel ${LIBRARY}) (srfi :64))" > test-r6rs.sps
cat retropikzel/${LIBRARY}/test.scm >> test-r6rs.sps
akku install chez-srfi akku-r7rs
COMPILE_R7RS=${SCHEME} timeout 60 compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps
timeout 60 ./test-r6rs
test-r6rs-docker:
echo "Building docker image..."
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet .
docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r6rs"
example.sps: ${EXAMPLE_FILE}.sps
cp ${EXAMPLE_FILE}.scm example.sps
example-r6rs: example.sps
akku install akku-r7rs "(foreign c)"
COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o example example.sps
./example
test-docker: testfiles
cd .tmp && \
COMPILE_R7RS=${SCHEME} \
CSC_OPTIONS="${CSC_OPTIONS}" \
SNOW_PACKAGES="srfi.64 foreign.c" \
APT_PACKAGES="${APT_PACKAGES}" \
test-r7rs \
-o test-program \
test.${SFX} \
${PKG}
clean:
git clean -X -f

440
retropikzel/gi-repository.scm
View File

@ -1,13 +1,437 @@
(define-c-library libc
'("stdlib.h")
libc-name
'((additional-versions ("6"))))
(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 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))
(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)))))

24
retropikzel/gi-repository.sld
View File

@ -3,8 +3,24 @@
(import (scheme base)
(scheme write)
(foreign c))
(export gi-repository-new
gi-repository-require
gi-repository-find-by-name
gi-function-info-invoke)
(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
)
(include "gi-repository.scm"))

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

@ -1,55 +1,44 @@
(test-begin "gi-repository")
;(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))
(define repository (gi-repository-new))
(display 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"))
(newline)
(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"))))
(display (gi-object-invoke gio-application "run" 0 (c-bytevector-null)))
(newline)
(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")

9
retropikzel/requests/README.md
View File

@ -1,7 +1,4 @@
# requests
Scheme library to make https requests. Built with
[foreign c](https://sr.ht/~retropikzel/foreign-c/) and libcurl.
Scheme library to make https requests. Built with (foreign c) and libcurl.
[Repository](https://git.sr.ht/~retropikzel/foreign-c-requests)
@ -9,15 +6,11 @@ Scheme library to make https requests. Built with
[Jenkins](https://jenkins.scheme.org/job/foreign_c/job/foreign-c-requests/)
## Caveats
- Not yet working on Mosh
- No cookie reading support yet
## Dependencies
Depends on libcurl, on Debian/Ubuntu:

125
retropikzel/spite.scm
View File

@ -3,19 +3,13 @@
(define exit? #f)
(define scale-x 1.0)
(define scale-y 1.0)
(define events (list))
(define events '())
(define current-bitmap-font #f)
(define current-line-size 1)
(define draw-color-r 0)
(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"
@ -23,67 +17,36 @@
"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 128) ;(+ (* (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 update-procedure #f)
(define draw-procedure #f)
(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
(lambda ()
(set! main-loop-start-time (current-jiffy))
(sdl2-events-get)
(update-procedure delta-time (poll-events!))
(render-clear)
(draw-procedure)
(render-present)
(set! delta-time (/ (- (current-jiffy) main-loop-start-time) (jiffies-per-second)))
(unless exit? (main-loop))))
(define (main-loop update-procedure draw-procedure)
(set! main-loop-start-time (current-jiffy))
(sdl2-events-get)
(update-procedure delta-time (poll-events!))
(render-clear)
(draw-procedure)
(render-present)
(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
(lambda (event)
@ -99,8 +62,8 @@
'int
(+ (* (c-type-size 'int) 3)
(* (c-type-size 'u8) 4))))
(keycode (sdl-get-key-from-scancode scancode))
(key (c-bytevector->string (sdl-get-key-name keycode)))
(keycode (SDL_GetKeyFromScancode scancode))
(key (c-bytevector->string (SDL_GetKeyName keycode)))
(repeat? (= (c-bytevector-ref
event
'u8
@ -152,7 +115,7 @@
(define sdl2-events-get
(lambda ()
(let ((poll-result (sdl-poll-event event*)))
(let ((poll-result (SDL_PollEvent event*)))
(cond
((= poll-result 1)
(let ((event (sdl2-event->spite-event event*)))
@ -163,12 +126,12 @@
(define render-clear
(lambda ()
(sdl-set-render-draw-color renderer* 255 255 255 255)
(sdl-render-clear renderer*)))
(SDL_SetRenderDrawColor renderer* 255 255 255 255)
(SDL_RenderClear renderer*)))
(define render-present
(lambda ()
(sdl-render-present renderer*)))
(SDL_RenderPresent renderer*)))
(define-record-type image
(make-image pointer path)
@ -189,7 +152,7 @@
(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-render-copy renderer* (image-pointer image) (c-bytevector-null) draw-rect*)))
(SDL_RenderCopy 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)
@ -201,7 +164,7 @@
(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-render-copy renderer* (image-pointer image) draw-slice-rect* draw-rect*)))
(SDL_RenderCopy renderer* (image-pointer image) draw-slice-rect* draw-rect*)))
(define (set-draw-color r g b . a)
(set! draw-color-r r)
@ -224,21 +187,21 @@
(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-set-render-draw-color renderer* r g b draw-color-a))
(SDL_SetRenderDrawColor renderer* r g b draw-color-a))
(define (set-line-size size)
(set! current-line-size size)
(sdl-render-set-scale renderer* (inexact (/ size 1)) (inexact (/ size 1))))
(SDL_RenderSetScale renderer* (inexact (/ size 1)) (inexact (/ size 1))))
(define (draw-point x y)
(sdl-render-draw-line renderer*
(SDL_RenderDrawLine 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)
(sdl-render-draw-line renderer*
(SDL_RenderDrawLine renderer*
(exact (round (/ x1 current-line-size)))
(exact (round (/ y1 current-line-size)))
(exact (round (/ x2 current-line-size)))
@ -249,14 +212,14 @@
(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-render-draw-rect renderer* draw-rect*))
(SDL_RenderDrawRect renderer* draw-rect*))
(define (fill-rectangle x y width height)
(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-render-fill-rect renderer* draw-rect*))
(SDL_RenderFillRect renderer* draw-rect*))
(define (draw-triangle x1 y1 x2 y2 x3 y3)
(draw-line x1 y1 x2 y2)
@ -274,23 +237,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-render-geometry renderer* (c-bytevector-null) fill-triangle-vertexes* 3 (c-bytevector-null) 0))
(SDL_RenderGeometry 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-set-window-resizable window* 1))
(SDL_SetWindowResizable window* 1))
((equal? value '(#f))
(sdl-set-window-resizable window* 0))
(SDL_SetWindowResizable 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-render-setlogial-size renderer* (car value) (cadr value))
(SDL_RenderSetLogicalSize renderer* (car value) (cadr value))
(error "Wrong option value for renderer-size, must be two numbers")))
(else (error "No such option!" name))))
@ -299,28 +262,26 @@
(lambda ()
(let ((x (make-c-bytevector (c-type-size 'float)))
(y (make-c-bytevector (c-type-size 'float))))
(sdl-render-get-scale renderer* x y)
(SDL_RenderGetScale renderer* x y)
(list (cons 'x (c-bytevector-ref x 'float 0))
(cons 'y (c-bytevector-ref y 'float 0))))))
(define spite-start
(lambda (new-update-procedure new-draw-procedure)
(set! update-procedure new-update-procedure)
(set! draw-procedure new-draw-procedure)
(lambda (update-procedure draw-procedure)
(cond
((not started?)
(set! started? #t)
(main-loop)))))
(main-loop update-procedure draw-procedure)))))
(define spite-init
(lambda (title width height)
(cond
((not started?)
(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)
(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)
(render-clear)
(render-present)
(set! spite-inited? #t)))))

5
retropikzel/spite.sld
View File

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