Backup
This commit is contained in:
parent
cf5c702387
commit
2f8166a779
29
Makefile
29
Makefile
|
|
@ -24,6 +24,13 @@ 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
|
||||
|
|
@ -42,20 +49,34 @@ install:
|
|||
testfiles: build
|
||||
rm -rf .tmp
|
||||
mkdir -p .tmp
|
||||
cp -r retropikzel .tmp/
|
||||
cp ${PKG} .tmp/
|
||||
# R6RS testfiles
|
||||
printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (retropikzel ${LIBRARY}))" > .tmp/test.sps
|
||||
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) (retropikzel ${LIBRARY}))" > .tmp/test.scm
|
||||
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
|
||||
|
||||
test: testfiles
|
||||
cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
|
||||
cd .tmp && \
|
||||
COMPILE_R7RS=${SCHEME} \
|
||||
CSC_OPTIONS="${CSC_OPTIONS}" \
|
||||
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}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,174 @@
|
|||
(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-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-object-info-find-method c-gi 'gi_object_info_find_method 'pointer '(pointer pointer))
|
||||
|
||||
(define-c-struct-type gerror '((domain u32) (code int) (message pointer)))
|
||||
|
||||
(define GI-TYPE-TAG-UTF8 13)
|
||||
(define GI-TYPE-TAG-INTERFACE 16)
|
||||
|
||||
(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 pointer gerror))
|
||||
(msg (c-bytevector->string (cdr (assoc 'message error-list)))))
|
||||
(c-bytevector-free (cdr (assoc 'message error-list)))
|
||||
(c-bytevector-free repository)
|
||||
;(c-bytevector-free err)
|
||||
(error (string-append "load-gi-repository: " msg)
|
||||
(car error-list)
|
||||
(cadr error-list))))
|
||||
repository))
|
||||
|
||||
(define (gi-object repository namespace name)
|
||||
(let ((base-info
|
||||
(c-gi-repository-find-by-name 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-info-name info)
|
||||
(c-bytevector->string (c-gi-base-info-get-name info)))
|
||||
(define gi-object-name gi-info-name)
|
||||
|
||||
(define (gi-type->foreign-c-type type-info)
|
||||
(let ((tag (c-gi-type-info-get-tag type-info)))
|
||||
(cond
|
||||
((= tag GI-TYPE-TAG-UTF8) 'pointer)
|
||||
((= tag GI-TYPE-TAG-INTERFACE)
|
||||
(display "HERE: ")
|
||||
(write (c-bytevector->string (c-gi-base-info-get-namespace (c-gi-type-info-get-interface type-info))))
|
||||
(newline)
|
||||
(write (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))))
|
||||
(newline)
|
||||
'int) ;; FIXME
|
||||
)))
|
||||
|
||||
|
||||
(define (gi-object-invoke object method-name . args)
|
||||
(letrec*
|
||||
((method-info (c-gi-object-info-find-method object method-name))
|
||||
(method-return-info (c-gi-callable-info-get-return-type method-info))
|
||||
(return-type (gi-type->foreign-c-type method-return-info))
|
||||
(n-args (let ((n-args (c-gi-callable-info-get-n-args method-info)))
|
||||
(when (not (= n-args (length args)))
|
||||
(error
|
||||
(string-append "gi-object-invoke: Argument count mismatch, got "
|
||||
(number->string (length args))
|
||||
", wanted "
|
||||
(number->string n-args))
|
||||
(gi-object-namespace object)
|
||||
(gi-object-name object)
|
||||
method-name))
|
||||
n-args))
|
||||
(arg-info-looper
|
||||
(lambda (index result)
|
||||
(if (= index n-args)
|
||||
result
|
||||
(arg-info-looper
|
||||
(+ index 1)
|
||||
(append
|
||||
result
|
||||
(list
|
||||
(let* ((arg-info (c-gi-callable-info-get-arg method-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 method-info
|
||||
arg-cbv
|
||||
n-args
|
||||
(c-bytevector-null)
|
||||
0
|
||||
return-value
|
||||
invoke-error)
|
||||
(display "HERE: return-type ")
|
||||
(write return-type)
|
||||
(newline)
|
||||
return-value))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define (gi-repository-find-by-name repository namespace name)
|
||||
(let ((base-info
|
||||
(c-gi-repository-find-by-name repository
|
||||
(string->c-bytevector namespace)
|
||||
(string->c-bytevector name))))
|
||||
(when (c-bytevector-null? base-info)
|
||||
(c-perror (string->c-bytevector "(C perror) find-gi-function"))
|
||||
(error "find-gi-function: ERROR" namespace name base-info))
|
||||
base-info))
|
||||
|
||||
(define (gi-invoke function-info argv argc return-type)
|
||||
(let ((return-value (make-c-bytevector 1024))
|
||||
(invoke-error (c-bytevector-null)))
|
||||
(c-gi-function-info-invoke function-info
|
||||
argv
|
||||
argc
|
||||
(c-bytevector-null)
|
||||
0
|
||||
return-value
|
||||
invoke-error)
|
||||
(c-bytevector-ref return-value return-type 0)))
|
||||
|
|
|
|||
|
|
@ -3,8 +3,11 @@
|
|||
(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-object
|
||||
gi-object-namespace
|
||||
gi-object-name
|
||||
gi-object-invoke
|
||||
|
||||
)
|
||||
(include "gi-repository.scm"))
|
||||
|
|
|
|||
|
|
@ -1,55 +1,71 @@
|
|||
|
||||
(test-begin "gi-repository")
|
||||
;(test-begin "gi-repository")
|
||||
|
||||
(define repository (gi-repository-new))
|
||||
(display repository)
|
||||
(newline)
|
||||
(define gtk (gi-repository "Gtk" "3.0"))
|
||||
(define gtk-application (gi-object gtk "Gtk" "Application"))
|
||||
(define app (gi-object-invoke gtk-application "new" "org.hello.world" 0))
|
||||
|
||||
(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)
|
||||
(write app)
|
||||
(newline)
|
||||
)))
|
||||
|
||||
(test-end "gi-repository")
|
||||
|
||||
#|
|
||||
(define gtk (load-gi-repository "Gtk" "3.0"))
|
||||
(define gtk-application (gi-repository-find-by-name gtk "Gtk" "Application"))
|
||||
(display "HERE: gtk-application ")
|
||||
(write (gi-info-namespace gtk-application))
|
||||
(newline)
|
||||
(write (gi-info-name gtk-application))
|
||||
(newline)
|
||||
|
||||
(define gtk-application-new (gi-object-info-find-method gtk-application "new"))
|
||||
(display "HERE: gtk-application-new ")
|
||||
(write (gi-info-namespace gtk-application-new))
|
||||
(newline)
|
||||
(write (gi-info-name gtk-application-new))
|
||||
(newline)
|
||||
|
||||
(define app
|
||||
(let ((args (make-c-bytevector 1024)))
|
||||
(c-bytevector-set! args 'pointer 0 (c-bytevector-null))
|
||||
(c-bytevector-set! args 'int (c-type-size 'pointer) 0)
|
||||
(gi-invoke gtk-application-new args 2 'pointer)))
|
||||
|
||||
(write app)
|
||||
(newline)
|
||||
|
||||
(define gtk-application-window (gi-repository-find-by-name gtk "Gtk" "ApplicationWindow"))
|
||||
;(define gtk-application-window-new (gi-object-info-find-method gtk-application-window "new"))
|
||||
(display "HERE: gtk-application-window ")
|
||||
(write (gi-info-namespace gtk-application-window))
|
||||
(newline)
|
||||
(write (gi-info-name gtk-application-window))
|
||||
(newline)
|
||||
|
||||
(define gtk-application-window-new (gi-object-info-find-method gtk-application-window "new"))
|
||||
(display "HERE: gtk-application-window-new ")
|
||||
(write (gi-info-namespace gtk-application-window-new))
|
||||
(newline)
|
||||
(write (gi-info-name gtk-application-window-new))
|
||||
(newline)
|
||||
|
||||
(define window
|
||||
(let ((args (make-c-bytevector 1024)))
|
||||
(c-bytevector-set! args 'pointer 0 app)
|
||||
(gi-invoke gtk-application-window-new args 1 'pointer)))
|
||||
|
||||
(write window)
|
||||
(newline)
|
||||
|
||||
#;(define return-code
|
||||
(c-gi-function-info-invoke gtk-application-new
|
||||
args
|
||||
2
|
||||
(c-bytevector-null)
|
||||
0
|
||||
app-return-value
|
||||
invoke-error))
|
||||
|
||||
;|#
|
||||
;(test-end "gi-repository")
|
||||
|
|
|
|||
Loading…
Reference in New Issue