diff --git a/.gitignore b/.gitignore
index 5ebb457..90fd273 100644
--- a/.gitignore
+++ b/.gitignore
@@ -24,3 +24,4 @@ example.sps
example
venv
foreign
+tmp
diff --git a/Dockerfile b/Dockerfile
deleted file mode 100644
index 0cbb998..0000000
--- a/Dockerfile
+++ /dev/null
@@ -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/
-
diff --git a/Dockerfile.jenkins b/Dockerfile.jenkins
index 1dbd00d..b1f118b 100644
--- a/Dockerfile.jenkins
+++ b/Dockerfile.jenkins
@@ -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
diff --git a/Jenkinsfile b/Jenkinsfile
index 06ddb9b..8ad1543 100644
--- a/Jenkinsfile
+++ b/Jenkinsfile
@@ -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()
+ }
}
}
diff --git a/Makefile b/Makefile
index 87d9b5e..52db121 100644
--- a/Makefile
+++ b/Makefile
@@ -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 "$$(cat retropikzel/${LIBRARY}/README.md)" > ${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
diff --git a/retropikzel/gi-repository.scm b/retropikzel/gi-repository.scm
index 3aed587..8564c46 100644
--- a/retropikzel/gi-repository.scm
+++ b/retropikzel/gi-repository.scm
@@ -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
+ (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)))))
diff --git a/retropikzel/gi-repository.sld b/retropikzel/gi-repository.sld
index ee99592..b57a10b 100644
--- a/retropikzel/gi-repository.sld
+++ b/retropikzel/gi-repository.sld
@@ -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"))
diff --git a/retropikzel/gi-repository/test.scm b/retropikzel/gi-repository/test.scm
index 0dceca1..2a69829 100644
--- a/retropikzel/gi-repository/test.scm
+++ b/retropikzel/gi-repository/test.scm
@@ -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")
diff --git a/retropikzel/requests/README.md b/retropikzel/requests/README.md
index 9acda97..323641d 100644
--- a/retropikzel/requests/README.md
+++ b/retropikzel/requests/README.md
@@ -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:
diff --git a/retropikzel/spite.scm b/retropikzel/spite.scm
index 6b2bcec..ae9eb93 100644
--- a/retropikzel/spite.scm
+++ b/retropikzel/spite.scm
@@ -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)))))
diff --git a/retropikzel/spite.sld b/retropikzel/spite.sld
index c3db5f0..d11f613 100644
--- a/retropikzel/spite.sld
+++ b/retropikzel/spite.sld
@@ -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