Improving testing
This commit is contained in:
parent
1f0f9f4a67
commit
3aaa9e95a0
|
|
@ -1,8 +0,0 @@
|
|||
(define-c-library libc '("stdlib.h") libc-name '((additional-versions ("6"))))
|
||||
(define-c-procedure c-system libc 'system 'int '(pointer))
|
||||
|
||||
(define (system command)
|
||||
(let* ((command-pointer (string->c-utf8 command))
|
||||
(result (c-system command-pointer)))
|
||||
(c-free command-pointer)
|
||||
result))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(define-library
|
||||
(retropikzel system)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(foreign c))
|
||||
(export system)
|
||||
(include "system.scm"))
|
||||
|
|
@ -1,165 +0,0 @@
|
|||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
|
||||
This version of the GNU Lesser General Public License incorporates
|
||||
the terms and conditions of version 3 of the GNU General Public
|
||||
License, supplemented by the additional permissions listed below.
|
||||
|
||||
0. Additional Definitions.
|
||||
|
||||
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||
General Public License.
|
||||
|
||||
"The Library" refers to a covered work governed by this License,
|
||||
other than an Application or a Combined Work as defined below.
|
||||
|
||||
An "Application" is any work that makes use of an interface provided
|
||||
by the Library, but which is not otherwise based on the Library.
|
||||
Defining a subclass of a class defined by the Library is deemed a mode
|
||||
of using an interface provided by the Library.
|
||||
|
||||
A "Combined Work" is a work produced by combining or linking an
|
||||
Application with the Library. The particular version of the Library
|
||||
with which the Combined Work was made is also called the "Linked
|
||||
Version".
|
||||
|
||||
The "Minimal Corresponding Source" for a Combined Work means the
|
||||
Corresponding Source for the Combined Work, excluding any source code
|
||||
for portions of the Combined Work that, considered in isolation, are
|
||||
based on the Application, and not on the Linked Version.
|
||||
|
||||
The "Corresponding Application Code" for a Combined Work means the
|
||||
object code and/or source code for the Application, including any data
|
||||
and utility programs needed for reproducing the Combined Work from the
|
||||
Application, but excluding the System Libraries of the Combined Work.
|
||||
|
||||
1. Exception to Section 3 of the GNU GPL.
|
||||
|
||||
You may convey a covered work under sections 3 and 4 of this License
|
||||
without being bound by section 3 of the GNU GPL.
|
||||
|
||||
2. Conveying Modified Versions.
|
||||
|
||||
If you modify a copy of the Library, and, in your modifications, a
|
||||
facility refers to a function or data to be supplied by an Application
|
||||
that uses the facility (other than as an argument passed when the
|
||||
facility is invoked), then you may convey a copy of the modified
|
||||
version:
|
||||
|
||||
a) under this License, provided that you make a good faith effort to
|
||||
ensure that, in the event an Application does not supply the
|
||||
function or data, the facility still operates, and performs
|
||||
whatever part of its purpose remains meaningful, or
|
||||
|
||||
b) under the GNU GPL, with none of the additional permissions of
|
||||
this License applicable to that copy.
|
||||
|
||||
3. Object Code Incorporating Material from Library Header Files.
|
||||
|
||||
The object code form of an Application may incorporate material from
|
||||
a header file that is part of the Library. You may convey such object
|
||||
code under terms of your choice, provided that, if the incorporated
|
||||
material is not limited to numerical parameters, data structure
|
||||
layouts and accessors, or small macros, inline functions and templates
|
||||
(ten or fewer lines in length), you do both of the following:
|
||||
|
||||
a) Give prominent notice with each copy of the object code that the
|
||||
Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
4. Combined Works.
|
||||
|
||||
You may convey a Combined Work under terms of your choice that,
|
||||
taken together, effectively do not restrict modification of the
|
||||
portions of the Library contained in the Combined Work and reverse
|
||||
engineering for debugging such modifications, if you also do each of
|
||||
the following:
|
||||
|
||||
a) Give prominent notice with each copy of the Combined Work that
|
||||
the Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
c) For a Combined Work that displays copyright notices during
|
||||
execution, include the copyright notice for the Library among
|
||||
these notices, as well as a reference directing the user to the
|
||||
copies of the GNU GPL and this license document.
|
||||
|
||||
d) Do one of the following:
|
||||
|
||||
0) Convey the Minimal Corresponding Source under the terms of this
|
||||
License, and the Corresponding Application Code in a form
|
||||
suitable for, and under terms that permit, the user to
|
||||
recombine or relink the Application with a modified version of
|
||||
the Linked Version to produce a modified Combined Work, in the
|
||||
manner specified by section 6 of the GNU GPL for conveying
|
||||
Corresponding Source.
|
||||
|
||||
1) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (a) uses at run time
|
||||
a copy of the Library already present on the user's computer
|
||||
system, and (b) will operate properly with a modified version
|
||||
of the Library that is interface-compatible with the Linked
|
||||
Version.
|
||||
|
||||
e) Provide Installation Information, but only if you would otherwise
|
||||
be required to provide such information under section 6 of the
|
||||
GNU GPL, and only to the extent that such information is
|
||||
necessary to install and execute a modified version of the
|
||||
Combined Work produced by recombining or relinking the
|
||||
Application with a modified version of the Linked Version. (If
|
||||
you use option 4d0, the Installation Information must accompany
|
||||
the Minimal Corresponding Source and Corresponding Application
|
||||
Code. If you use option 4d1, you must provide the Installation
|
||||
Information in the manner specified by section 6 of the GNU GPL
|
||||
for conveying Corresponding Source.)
|
||||
|
||||
5. Combined Libraries.
|
||||
|
||||
You may place library facilities that are a work based on the
|
||||
Library side by side in a single library together with other library
|
||||
facilities that are not Applications and are not covered by this
|
||||
License, and convey such a combined library under terms of your
|
||||
choice, if you do both of the following:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work based
|
||||
on the Library, uncombined with any other library facilities,
|
||||
conveyed under the terms of this License.
|
||||
|
||||
b) Give prominent notice with the combined library that part of it
|
||||
is a work based on the Library, and explaining where to find the
|
||||
accompanying uncombined form of the same work.
|
||||
|
||||
6. Revised Versions of the GNU Lesser General Public License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions
|
||||
of the GNU Lesser General Public License from time to time. Such new
|
||||
versions will be similar in spirit to the present version, but may
|
||||
differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Library as you received it specifies that a certain numbered version
|
||||
of the GNU Lesser General Public License "or any later version"
|
||||
applies to it, you have the option of following the terms and
|
||||
conditions either of that published version or of any later version
|
||||
published by the Free Software Foundation. If the Library as you
|
||||
received it does not specify a version number of the GNU Lesser
|
||||
General Public License, you may choose any version of the GNU Lesser
|
||||
General Public License ever published by the Free Software Foundation.
|
||||
|
||||
If the Library as you received it specifies that a proxy can decide
|
||||
whether future versions of the GNU Lesser General Public License shall
|
||||
apply, that proxy's public statement of acceptance of any version is
|
||||
permanent authorization for you to choose that version for the
|
||||
Library.
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
<pre>Execute a shell command.
|
||||
|
||||
Built upon [(foreign c)](https://sr.ht/~retropikzel/foreign-c/).
|
||||
|
||||
[Repository](https://git.sr.ht/~retropikzel/foreign-c-system)
|
||||
|
||||
[Issue tracker](https://sr.ht/~retropikzel/foreign-c/trackers)
|
||||
|
||||
[Maling lists](https://sr.ht/~retropikzel/foreign-c/lists)
|
||||
|
||||
[Jenkins](https://jenkins.scheme.org/job/retropikzel/job/foreign-c-system/)
|
||||
|
||||
|
||||
(**system** _command_)
|
||||
|
||||
_command_ is a string containing the command you want to run.
|
||||
|
||||
Returns the exit code of the command.
|
||||
|
||||
Example:
|
||||
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(retropikzel system))
|
||||
|
||||
(define testfile "test.txt")
|
||||
(system (apply string-append `("echo \"Hello\" > " ,testfile)))
|
||||
|
||||
(define text (with-input-from-file testfile (lambda () (read-line))))
|
||||
(display text)
|
||||
(newline)</pre>
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
Execute a shell command.
|
||||
|
||||
Built upon [(foreign c)](https://sr.ht/~retropikzel/foreign-c/).
|
||||
|
||||
[Repository](https://git.sr.ht/~retropikzel/foreign-c-system)
|
||||
|
||||
[Issue tracker](https://sr.ht/~retropikzel/foreign-c/trackers)
|
||||
|
||||
[Maling lists](https://sr.ht/~retropikzel/foreign-c/lists)
|
||||
|
||||
[Jenkins](https://jenkins.scheme.org/job/retropikzel/job/foreign-c-system/)
|
||||
|
||||
|
||||
(**system** _command_)
|
||||
|
||||
_command_ is a string containing the command you want to run.
|
||||
|
||||
Returns the exit code of the command.
|
||||
|
||||
Example:
|
||||
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(retropikzel system))
|
||||
|
||||
(define testfile "test.txt")
|
||||
(system (apply string-append `("echo \"Hello\" > " ,testfile)))
|
||||
|
||||
(define text (with-input-from-file testfile (lambda () (read-line))))
|
||||
(display text)
|
||||
(newline)
|
||||
|
||||
|
|
@ -1 +0,0 @@
|
|||
1.1.2
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
|
||||
(test-begin "foreign-c-system")
|
||||
|
||||
(define testfile "/tmp/foreign-c-system-test.txt")
|
||||
|
||||
(define exit-code1 (system (apply string-append `("echo \"Hello\" > " ,testfile))))
|
||||
|
||||
(test-assert (= exit-code1 0))
|
||||
|
||||
(define (read-all result)
|
||||
(let ((c (read-char)))
|
||||
(if (eof-object? c)
|
||||
result
|
||||
(read-all (string-append result (string c))))))
|
||||
|
||||
(define text (with-input-from-file testfile (lambda () (read-all ""))))
|
||||
|
||||
(test-assert (string=? text "Hello"))
|
||||
|
||||
(define exit-code2 (system "no-such-command 2> /dev/null"))
|
||||
|
||||
(test-assert (> exit-code2 0))
|
||||
|
||||
(test-end "foreign-c-system")
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
(import (scheme base) (scheme write) (scheme file) (scheme process-context) (retropikzel system) (srfi 64))
|
||||
|
||||
(test-begin "foreign-c-system")
|
||||
|
||||
(define testfile "/tmp/foreign-c-system-test.txt")
|
||||
|
||||
(define exit-code1 (system (apply string-append `("echo \"Hello\" > " ,testfile))))
|
||||
|
||||
(test-assert (= exit-code1 0))
|
||||
|
||||
(define (read-all result)
|
||||
(let ((c (read-char)))
|
||||
(if (eof-object? c)
|
||||
result
|
||||
(read-all (string-append result (string c))))))
|
||||
|
||||
(define text (with-input-from-file testfile (lambda () (read-all ""))))
|
||||
|
||||
(test-assert (string=? text "Hello"))
|
||||
|
||||
(define exit-code2 (system "no-such-command 2> /dev/null"))
|
||||
|
||||
(test-assert (> exit-code2 0))
|
||||
|
||||
(test-end "foreign-c-system")
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
|
||||
(test-begin "foreign-c-system")
|
||||
|
||||
(define testfile "/tmp/foreign-c-system-test.txt")
|
||||
|
||||
(define exit-code1 (system (apply string-append `("echo \"Hello\" > " ,testfile))))
|
||||
|
||||
(test-assert (= exit-code1 0))
|
||||
|
||||
(define (read-all result)
|
||||
(let ((c (read-char)))
|
||||
(if (eof-object? c)
|
||||
result
|
||||
(read-all (string-append result (string c))))))
|
||||
|
||||
(define text (with-input-from-file testfile (lambda () (read-all ""))))
|
||||
|
||||
(test-assert (string=? text "Hello"))
|
||||
|
||||
(define exit-code2 (system "no-such-command 2> /dev/null"))
|
||||
|
||||
(test-assert (> exit-code2 0))
|
||||
|
||||
(test-end "foreign-c-system")
|
||||
|
|
@ -1 +0,0 @@
|
|||
src
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
AKKU_CHEZ_PATH="$R6RS_PATH";
|
||||
AKKU_R6RS_PATH="$R6RS_PATH";
|
||||
AKKU_R7RS_PATH="$R7RS_PATH";
|
||||
AKKU_CHEZ_PATH=$PWD/.akku/lib::$PWD/.akku/libobj${AKKU_CHEZ_PATH:+:}$AKKU_CHEZ_PATH;
|
||||
AKKU_R6RS_PATH=$PWD/.akku/lib${AKKU_R6RS_PATH:+:}$AKKU_R6RS_PATH;
|
||||
AKKU_R7RS_PATH=$PWD/.akku/lib${AKKU_R7RS_PATH:+:}$AKKU_R7RS_PATH;
|
||||
export CHEZSCHEMELIBDIRS="$AKKU_CHEZ_PATH";
|
||||
unset CHEZSCHEMELIBEXTS;
|
||||
export GUILE_LOAD_PATH="$AKKU_R6RS_PATH";
|
||||
export GUILE_LOAD_COMPILED_PATH="$PWD/.akku/libobj";
|
||||
export IKARUS_LIBRARY_PATH="$AKKU_R6RS_PATH";
|
||||
export MOSH_LOADPATH="$AKKU_R6RS_PATH";
|
||||
export PLTCOLLECTS=":$AKKU_R6RS_PATH";
|
||||
export SAGITTARIUS_LOADPATH="$AKKU_R6RS_PATH";
|
||||
export VICARE_SOURCE_PATH="$AKKU_R6RS_PATH";
|
||||
export YPSILON_SITELIB="$AKKU_R6RS_PATH";
|
||||
export LARCENY_LIBPATH="$AKKU_R6RS_PATH";
|
||||
export IRONSCHEME_LIBRARY_PATH="$AKKU_R6RS_PATH";
|
||||
export LOKO_LIBRARY_PATH="$AKKU_R6RS_PATH";
|
||||
export DIGAMMA_SITELIB="$AKKU_R6RS_PATH";
|
||||
export CHIBI_MODULE_PATH="$AKKU_R7RS_PATH";
|
||||
export GAUCHE_LOAD_PATH="$AKKU_R7RS_PATH";
|
||||
export PATH=$PWD/.akku/bin${PATH:+:}$PATH;
|
||||
export LD_LIBRARY_PATH=$PWD/.akku/ffi${LD_LIBRARY_PATH:+:}$LD_LIBRARY_PATH;
|
||||
export DYLD_LIBRARY_PATH=$PWD/.akku/ffi${DYLD_LIBRARY_PATH:+:}$DYLD_LIBRARY_PATH;
|
||||
unset AKKU_CHEZ_PATH;
|
||||
unset AKKU_R6RS_PATH;
|
||||
unset AKKU_R7RS_PATH;
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
set AKKU_CHEZ_PATH "$R6RS_PATH"
|
||||
set AKKU_R6RS_PATH "$R6RS_PATH"
|
||||
set AKKU_R7RS_PATH "$R7RS_PATH"
|
||||
set --prepend AKKU_CHEZ_PATH $PWD/.akku/lib::$PWD/.akku/libobj
|
||||
set --prepend AKKU_R6RS_PATH $PWD/.akku/lib
|
||||
set --prepend AKKU_R7RS_PATH $PWD/.akku/lib
|
||||
set --export CHEZSCHEMELIBDIRS "$AKKU_CHEZ_PATH"
|
||||
set --erase CHEZSCHEMELIBEXTS
|
||||
set --export GUILE_LOAD_PATH "$AKKU_R6RS_PATH"
|
||||
set --export GUILE_LOAD_COMPILED_PATH "$PWD/.akku/libobj"
|
||||
set --export IKARUS_LIBRARY_PATH "$AKKU_R6RS_PATH"
|
||||
set --export MOSH_LOADPATH "$AKKU_R6RS_PATH"
|
||||
set --export PLTCOLLECTS ":$AKKU_R6RS_PATH"
|
||||
set --export SAGITTARIUS_LOADPATH "$AKKU_R6RS_PATH"
|
||||
set --export VICARE_SOURCE_PATH "$AKKU_R6RS_PATH"
|
||||
set --export YPSILON_SITELIB "$AKKU_R6RS_PATH"
|
||||
set --export LARCENY_LIBPATH "$AKKU_R6RS_PATH"
|
||||
set --export IRONSCHEME_LIBRARY_PATH "$AKKU_R6RS_PATH"
|
||||
set --export LOKO_LIBRARY_PATH "$AKKU_R6RS_PATH"
|
||||
set --export DIGAMMA_SITELIB "$AKKU_R6RS_PATH"
|
||||
set --export CHIBI_MODULE_PATH "$AKKU_R7RS_PATH"
|
||||
set --export GAUCHE_LOAD_PATH "$AKKU_R7RS_PATH"
|
||||
set --export --prepend PATH $PWD/.akku/bin
|
||||
set --export --prepend LD_LIBRARY_PATH $PWD/.akku/ffi
|
||||
set --export --prepend DYLD_LIBRARY_PATH $PWD/.akku/ffi
|
||||
set --erase AKKU_CHEZ_PATH
|
||||
set --erase AKKU_R6RS_PATH
|
||||
set --erase AKKU_R7RS_PATH
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#!/bin/sh
|
||||
# Run this from anywhere to get a shell in the project environment -*-sh-*-
|
||||
# To load in the current shell with bash: eval $(.akku/env -s)
|
||||
# For fish, use: .akku/env -f | source
|
||||
export AKKU_ENV=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd)
|
||||
dir=$(pwd)
|
||||
if [ ! -d "$AKKU_ENV" ] || [ ! -e "$AKKU_ENV/.akku/bin/activate" ]; then
|
||||
echo The .akku/env script should be run, not sourced
|
||||
else
|
||||
cd "$AKKU_ENV" || exit 1
|
||||
. "$AKKU_ENV/.akku/bin/activate"
|
||||
|
||||
if [ "$1" = "-s" ]; then
|
||||
echo "AKKU_ENV=\"$AKKU_ENV\";"
|
||||
sed -e "s/\$PWD/\$AKKU_ENV/g" "$AKKU_ENV/.akku/bin/activate"
|
||||
cd "$dir" || exit 1
|
||||
elif [ "$1" = "-f" ]; then
|
||||
echo "set AKKU_ENV \"$AKKU_ENV\""
|
||||
sed -e "s/\$PWD/\$AKKU_ENV/g" "$AKKU_ENV/.akku/bin/activate.fish"
|
||||
cd "$dir" || exit 1
|
||||
else
|
||||
cd "$dir" || exit 1
|
||||
SHELL=${SHELL:-/bin/sh}
|
||||
exec "${@:-$SHELL}"
|
||||
fi
|
||||
fi
|
||||
|
|
@ -1,586 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs base)
|
||||
(export
|
||||
* + - / < <= = > >= abs and append apply assoc assq
|
||||
assv begin binary-port? boolean=? boolean? bytevector
|
||||
bytevector-append bytevector-copy bytevector-copy!
|
||||
bytevector-length bytevector-u8-ref bytevector-u8-set!
|
||||
bytevector? caar cadr call-with-current-continuation
|
||||
call-with-port call-with-values call/cc car case cdar cddr
|
||||
cdr ceiling char->integer char-ready? char<=? char<? char=?
|
||||
char>=? char>? char? close-input-port close-output-port
|
||||
close-port complex? cond cond-expand cons current-error-port
|
||||
current-input-port current-output-port define
|
||||
define-record-type define-syntax define-values denominator
|
||||
do dynamic-wind eof-object eof-object? eq? equal? eqv?
|
||||
error error-object-irritants error-object-message
|
||||
error-object? even? exact exact-integer-sqrt exact-integer?
|
||||
exact? expt features file-error? floor floor-quotient
|
||||
floor-remainder floor/ flush-output-port for-each gcd
|
||||
get-output-bytevector get-output-string guard if include
|
||||
include-ci inexact inexact? input-port-open? input-port?
|
||||
integer->char integer? lambda lcm length let let*
|
||||
let*-values let-syntax let-values letrec letrec*
|
||||
letrec-syntax list list->string list->vector list-copy
|
||||
list-ref list-set! list-tail list? make-bytevector make-list
|
||||
make-parameter make-string make-vector map max member memq
|
||||
memv min modulo negative? newline not null? number->string
|
||||
number? numerator odd? open-input-bytevector
|
||||
open-input-string open-output-bytevector open-output-string
|
||||
or output-port-open? output-port? pair? parameterize
|
||||
peek-char peek-u8 port? positive? procedure? quasiquote
|
||||
quote quotient raise raise-continuable rational? rationalize
|
||||
read-bytevector read-bytevector! read-char read-error?
|
||||
read-line read-string read-u8 real? remainder reverse round
|
||||
set! set-car! set-cdr! square string string->list
|
||||
string->number string->symbol string->utf8 string->vector
|
||||
string-append string-copy string-copy! string-fill!
|
||||
string-for-each string-length string-map string-ref
|
||||
string-set! string<=? string<? string=? string>=? string>?
|
||||
string? substring symbol->string symbol=? symbol?
|
||||
syntax-error syntax-rules textual-port? truncate
|
||||
truncate-quotient truncate-remainder truncate/ u8-ready?
|
||||
unless unquote unquote-splicing utf8->string values vector
|
||||
vector->list vector->string vector-append vector-copy
|
||||
vector-copy! vector-fill! vector-for-each vector-length
|
||||
vector-map vector-ref vector-set! vector? when
|
||||
with-exception-handler write-bytevector write-char
|
||||
write-string write-u8 zero?)
|
||||
(import
|
||||
(except (rnrs) case syntax-rules error define-record-type
|
||||
string->list string-copy string->utf8 vector->list
|
||||
vector-fill! bytevector-copy! bytevector-copy
|
||||
utf8->string
|
||||
map for-each member assoc
|
||||
vector-map read
|
||||
let-syntax
|
||||
expt flush-output-port
|
||||
string-for-each
|
||||
vector-for-each)
|
||||
(prefix (rnrs) r6:)
|
||||
(only (rnrs bytevectors) u8-list->bytevector)
|
||||
(only (rnrs control) case-lambda)
|
||||
(rnrs conditions)
|
||||
(except (rnrs io ports)
|
||||
flush-output-port)
|
||||
(rnrs mutable-pairs)
|
||||
(prefix (rnrs mutable-strings) r6:)
|
||||
(only (rnrs mutable-strings) string-set!)
|
||||
(rnrs syntax-case)
|
||||
(rnrs r5rs)
|
||||
(only (srfi :1 lists) map for-each member assoc make-list list-copy)
|
||||
(srfi :6 basic-string-ports)
|
||||
(srfi :9 records)
|
||||
(only (srfi :13 strings) string-copy!)
|
||||
(srfi :39 parameters)
|
||||
(only (srfi :43 vectors) vector-copy!)
|
||||
(for (prefix (akku metadata) akku:) expand)
|
||||
(for (akku-r7rs compat) run expand)
|
||||
(for (akku-r7rs include) expand))
|
||||
|
||||
(define (error message . irritants)
|
||||
(if (and (symbol? message) (pair? irritants) (string? (car irritants)))
|
||||
(apply r6:error message irritants)
|
||||
(apply r6:error #f message irritants)))
|
||||
|
||||
;; Based on the definition in R7RS.
|
||||
(define-syntax cond-expand
|
||||
(lambda (x)
|
||||
(syntax-case x (and or not else library)
|
||||
((_)
|
||||
(syntax-violation 'cond-expand "Unfulfilled cond-expand" x))
|
||||
((_ (else body ...))
|
||||
#'(begin body ...))
|
||||
((_ ((and) body ...) more-clauses ...)
|
||||
#'(begin body ...))
|
||||
((_ ((and req1 req2 ...) body ...)
|
||||
more-clauses ...)
|
||||
#'(cond-expand
|
||||
(req1
|
||||
(cond-expand
|
||||
((and req2 ...) body ...)
|
||||
more-clauses ...))
|
||||
more-clauses ...))
|
||||
((_ ((or) body ...) more-clauses ...)
|
||||
#'(cond-expand more-clauses ...))
|
||||
((_ ((or req1 req2 ...) body ...)
|
||||
more-clauses ...)
|
||||
#'(cond-expand
|
||||
(req1
|
||||
(begin body ...))
|
||||
(else
|
||||
(cond-expand
|
||||
((or req2 ...) body ...)
|
||||
more-clauses ...))))
|
||||
((_ ((not req) body ...)
|
||||
more-clauses ...)
|
||||
#'(cond-expand
|
||||
(req
|
||||
(cond-expand more-clauses ...))
|
||||
(else body ...)))
|
||||
((cond-expand (id body ...)
|
||||
more-clauses ...)
|
||||
(memq (syntax->datum #'id) (features))
|
||||
#'(begin body ...))
|
||||
((_ ((library lib-name)
|
||||
body ...)
|
||||
more-clauses ...)
|
||||
(r6:member (syntax->datum #'lib-name) akku:installed-libraries)
|
||||
#'(begin body ...))
|
||||
;; Fallthrough
|
||||
((_ (feature-id body ...)
|
||||
more-clauses ...)
|
||||
#'(cond-expand more-clauses ...))
|
||||
((_ ((library (name ...))
|
||||
body ...)
|
||||
more-clauses ...)
|
||||
#'(cond-expand more-clauses ...)))))
|
||||
|
||||
(define-syntax include
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((k fn* ...)
|
||||
(include-helper 'include #'k #f (syntax->datum #'(fn* ...)))))))
|
||||
|
||||
(define-syntax include-ci
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((k fn* ...)
|
||||
(include-helper 'include-ci #'k #f (syntax->datum #'(fn* ...)))))))
|
||||
|
||||
(define-syntax syntax-error
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ message args ...)
|
||||
(syntax-violation 'syntax-error #'message '#'(args ...))))))
|
||||
|
||||
;; let-syntax from Kato2014.
|
||||
(define-syntax let-syntax
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ ((vars trans) ...) . expr)
|
||||
#'(r6:let-syntax ((vars trans) ...)
|
||||
(let () . expr))))))
|
||||
|
||||
;;; SRFI-46 style syntax-rules
|
||||
|
||||
;; FIXME: We should use with-syntax like:
|
||||
;; http://srfi.schemers.org/srfi-93/mail-archive/msg00024.html
|
||||
(define-syntax syntax-rules
|
||||
(lambda (x)
|
||||
;; filt and emap handle ellipsis in the patterns
|
||||
(define (filt elip x)
|
||||
(if (identifier? x)
|
||||
(cond ((free-identifier=? elip x) #'(... ...))
|
||||
((free-identifier=? #'(... ...) x) #'bogus)
|
||||
(else x))
|
||||
x))
|
||||
(define (emap elip in)
|
||||
(syntax-case in ()
|
||||
((x . y) (cons (emap elip #'x)
|
||||
(emap elip #'y)))
|
||||
(#(x ...) (list->vector (emap elip #'(x ...))))
|
||||
(x (filt elip #'x))))
|
||||
;; This translates _ into temporaries and guards -weinholt
|
||||
(define (get-underscores stx)
|
||||
(syntax-case stx ()
|
||||
[(x . y)
|
||||
(let-values (((t0 p0) (get-underscores #'x))
|
||||
((t1 p1) (get-underscores #'y)))
|
||||
(values (append t0 t1) (cons p0 p1)))]
|
||||
[#(x* ...)
|
||||
(let lp ((x* #'(x* ...))
|
||||
(t* '())
|
||||
(p* '()))
|
||||
(if (null? x*)
|
||||
(values (apply append (reverse t*))
|
||||
(list->vector (reverse p*)))
|
||||
(let-values (((t p) (get-underscores (car x*))))
|
||||
(lp (cdr x*) (cons t t*) (cons p p*)))))]
|
||||
[x
|
||||
(and (identifier? #'x) (free-identifier=? #'x #'_))
|
||||
(let ((t* (generate-temporaries #'(_))))
|
||||
(values t* (car t*)))]
|
||||
[x
|
||||
(values '() #'x)]))
|
||||
(syntax-case x ()
|
||||
((_ (lit ...) (pat tmpl) ...) ;compatible with r6rs
|
||||
(not (memq '_ (syntax->datum #'(lit ...))))
|
||||
#'(r6:syntax-rules (lit ...) (pat tmpl) ...))
|
||||
|
||||
((_ (lit ...) (pat tmpl) ...) ;_ in the literals list
|
||||
#'(syntax-rules (... ...) (lit ...) (pat tmpl) ...))
|
||||
|
||||
((_ elip (lit ...) (pat tmpl) ...) ;custom ellipsis
|
||||
(and (identifier? #'elip)
|
||||
(not (memq '_ (syntax->datum #'(lit ...)))))
|
||||
(with-syntax (((clause ...) (emap #'elip #'((pat tmpl) ...))))
|
||||
#'(r6:syntax-rules (lit ...) clause ...)))
|
||||
|
||||
((_ elip (lit ...) (pat tmpl) ...)
|
||||
;; Both custom ellipsis and _ in the literals list.
|
||||
(identifier? #'elip)
|
||||
(with-syntax (((clause ...) (emap #'elip #'((pat tmpl) ...)))
|
||||
((lit^ ...) (filter (lambda (x)
|
||||
(not (free-identifier=? #'_ x)))
|
||||
#'(lit ...))))
|
||||
(with-syntax (((clause^ ...)
|
||||
(map (lambda (cls)
|
||||
(syntax-case cls ()
|
||||
[((_unused . pattern) template)
|
||||
(let-values (((t p) (get-underscores #'pattern)))
|
||||
(if (null? t)
|
||||
#'((_unused . pattern)
|
||||
#'template)
|
||||
(with-syntax ((pattern^ p) ((t ...) t))
|
||||
#'((_unused . pattern^)
|
||||
(and (underscore? #'t) ...)
|
||||
#'template))))]))
|
||||
#'(clause ...))))
|
||||
#'(lambda (y)
|
||||
(define (underscore? x)
|
||||
(and (identifier? x) (free-identifier=? x #'_)))
|
||||
(syntax-case y (lit^ ...)
|
||||
clause^ ...))))))))
|
||||
|
||||
;;; Case
|
||||
|
||||
(define-syntax %r7case-clause
|
||||
(syntax-rules (else =>)
|
||||
((_ obj (translated ...) ())
|
||||
(r6:case obj translated ...))
|
||||
((_ obj (translated ...) (((e0 e1 ...) => f) rest ...))
|
||||
(%r7case-clause obj (translated ... ((e0 e1 ...) (f obj))) (rest ...)))
|
||||
((_ obj (translated ...) ((else => f) rest ...))
|
||||
(%r7case-clause obj (translated ... (else (f obj))) (rest ...)))
|
||||
((_ obj (translated ...) (otherwise rest ...))
|
||||
(%r7case-clause obj (translated ... otherwise) (rest ...)))))
|
||||
|
||||
(define-syntax case
|
||||
(syntax-rules (else =>)
|
||||
((_ key clause ...)
|
||||
(let ((obj key))
|
||||
(%r7case-clause obj () (clause ...))))))
|
||||
|
||||
;;;
|
||||
|
||||
;; R7RS error object will be mapped to R6RS condition object
|
||||
(define error-object? condition?)
|
||||
(define file-error? i/o-error?)
|
||||
(define read-error? lexical-violation?)
|
||||
|
||||
(define (error-object-irritants obj)
|
||||
(and (irritants-condition? obj)
|
||||
(condition-irritants obj)))
|
||||
|
||||
(define (error-object-message obj)
|
||||
(and (message-condition? obj)
|
||||
(condition-message obj)))
|
||||
|
||||
;;; Ports
|
||||
|
||||
(define (open-input-bytevector bv) (open-bytevector-input-port bv))
|
||||
|
||||
(define (open-output-bytevector)
|
||||
(let-values (((p extract) (open-bytevector-output-port)))
|
||||
(define pos 0)
|
||||
(define buf #vu8())
|
||||
(define (read! target target-start count)
|
||||
(when (zero? (- (bytevector-length buf) pos))
|
||||
(set! buf (bytevector-append buf (extract)))) ;resets p
|
||||
(let ((count (min count (- (bytevector-length buf) pos))))
|
||||
(r6:bytevector-copy! buf pos
|
||||
target target-start count)
|
||||
(set! pos (+ pos count))
|
||||
count))
|
||||
(define (write! bv start count)
|
||||
(put-bytevector p bv start count)
|
||||
(set! pos (+ pos count))
|
||||
count)
|
||||
(define (get-position)
|
||||
pos)
|
||||
(define (set-position! new-pos)
|
||||
(set! pos new-pos))
|
||||
(define (close)
|
||||
(close-port p))
|
||||
;; It's actually an input/output port, but only
|
||||
;; get-output-bytevector should ever read from it. If it was just
|
||||
;; an output port then there would be no good way for
|
||||
;; get-output-bytevector to read the data. -weinholt
|
||||
(make-custom-binary-input/output-port
|
||||
"bytevector" read! write! get-position set-position! close)))
|
||||
|
||||
(define (get-output-bytevector port)
|
||||
;; R7RS says "It is an error if port was not created with
|
||||
;; open-output-bytevector.", so we can safely assume that the port
|
||||
;; was created by open-output-bytevector. -weinholt
|
||||
(set-port-position! port 0)
|
||||
(let ((bv (get-bytevector-all port)))
|
||||
(if (eof-object? bv)
|
||||
#vu8()
|
||||
bv)))
|
||||
|
||||
(define (exact-integer? i) (and (integer? i) (exact? i)))
|
||||
|
||||
(define peek-u8
|
||||
(case-lambda
|
||||
(() (peek-u8 (current-input-port)))
|
||||
((port)
|
||||
(lookahead-u8 port))))
|
||||
|
||||
(define read-bytevector
|
||||
(case-lambda
|
||||
((len) (read-bytevector len (current-input-port)))
|
||||
((len port) (get-bytevector-n port len))))
|
||||
|
||||
(define read-string
|
||||
(case-lambda
|
||||
((len) (read-string len (current-input-port)))
|
||||
((len port) (get-string-n port len))))
|
||||
|
||||
(define read-bytevector!
|
||||
(case-lambda
|
||||
((bv)
|
||||
(read-bytevector! bv (current-input-port)))
|
||||
((bv port)
|
||||
(read-bytevector! bv port 0))
|
||||
((bv port start)
|
||||
(read-bytevector! bv port start (bytevector-length bv)))
|
||||
((bv port start end)
|
||||
(get-bytevector-n! port bv start (- end start)))))
|
||||
|
||||
(define read-line
|
||||
(case-lambda
|
||||
(() (read-line (current-input-port)))
|
||||
((port) (get-line port))))
|
||||
|
||||
(define write-u8
|
||||
(case-lambda
|
||||
((obj) (write-u8 obj (current-output-port)))
|
||||
((obj port) (put-u8 port obj))))
|
||||
|
||||
(define read-u8
|
||||
(case-lambda
|
||||
(() (read-u8 (current-input-port)))
|
||||
((port) (get-u8 port))))
|
||||
|
||||
(define write-bytevector
|
||||
(case-lambda
|
||||
((bv) (write-bytevector bv (current-output-port)))
|
||||
((bv port) (put-bytevector port bv))
|
||||
((bv port start) (write-bytevector (%subbytevector1 bv start) port))
|
||||
((bv port start end)
|
||||
(write-bytevector (%subbytevector bv start end) port))))
|
||||
|
||||
(define write-string
|
||||
(case-lambda
|
||||
((str) (write-string str (current-output-port)))
|
||||
((str port) (put-string port str))
|
||||
((str port start) (write-string str port start (string-length str)))
|
||||
((str port start end)
|
||||
(write-string (substring str start end) port))))
|
||||
|
||||
(define flush-output-port
|
||||
(case-lambda
|
||||
(()
|
||||
(flush-output-port (current-output-port)))
|
||||
((port)
|
||||
(r6:flush-output-port port))))
|
||||
|
||||
;;; List additions
|
||||
|
||||
(define (list-set! l k obj)
|
||||
(define (itr cur count)
|
||||
(if (= count k)
|
||||
(set-car! cur obj)
|
||||
(itr (cdr cur) (+ count 1))))
|
||||
(itr l 0))
|
||||
|
||||
;;; Vector and string additions
|
||||
|
||||
;; FIXME: Optimize them
|
||||
(define (string-map proc . strs)
|
||||
(list->string (apply map proc (map r6:string->list strs))))
|
||||
|
||||
(define (vector-map proc . args)
|
||||
(list->vector (apply map proc (map r6:vector->list args))))
|
||||
|
||||
(define (bytevector . lis)
|
||||
(u8-list->bytevector lis))
|
||||
|
||||
(define (bytevector-append . bvs)
|
||||
(call-with-bytevector-output-port
|
||||
(lambda (p)
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bvs))))
|
||||
|
||||
(define (vector-append . lis)
|
||||
(list->vector (apply append (map r6:vector->list lis))))
|
||||
|
||||
;;; Substring functionalities added
|
||||
|
||||
;; string
|
||||
(define (%substring1 str start) (substring str start (string-length str)))
|
||||
|
||||
(define string->list
|
||||
(case-lambda
|
||||
((str) (r6:string->list str))
|
||||
((str start) (r6:string->list (%substring1 str start)))
|
||||
((str start end) (r6:string->list (substring str start end)))))
|
||||
|
||||
(define string->vector
|
||||
(case-lambda
|
||||
((str) (list->vector (string->list str)))
|
||||
((str start) (string->vector (%substring1 str start)))
|
||||
((str start end) (string->vector (substring str start end)))))
|
||||
|
||||
(define string-copy
|
||||
(case-lambda
|
||||
((str) (r6:string-copy str))
|
||||
((str start) (%substring1 str start))
|
||||
((str start end) (substring str start end))))
|
||||
|
||||
(define string->utf8
|
||||
(case-lambda
|
||||
((str) (r6:string->utf8 str))
|
||||
((str start) (r6:string->utf8 (%substring1 str start)))
|
||||
((str start end) (r6:string->utf8 (substring str start end)))))
|
||||
|
||||
(define string-fill!
|
||||
(case-lambda
|
||||
((str fill) (r6:string-fill! str fill))
|
||||
((str fill start) (string-fill! str fill start (string-length str)))
|
||||
((str fill start end)
|
||||
(define (itr r)
|
||||
(unless (= r end)
|
||||
(string-set! str r fill)
|
||||
(itr (+ r 1))))
|
||||
(itr start))))
|
||||
|
||||
(define (string-for-each proc str . str*)
|
||||
(do ((len (fold-left min (string-length str) (map string-length str*)))
|
||||
(i 0 (+ i 1)))
|
||||
((= i len))
|
||||
(apply proc (string-ref str i) (map (lambda (s) (string-ref s i)) str*))))
|
||||
|
||||
;;; vector
|
||||
|
||||
(define (%subvector v start end)
|
||||
(define mlen (- end start))
|
||||
(define out (make-vector (- end start)))
|
||||
(define (itr r)
|
||||
(if (= r mlen)
|
||||
out
|
||||
(begin
|
||||
(vector-set! out r (vector-ref v (+ start r)))
|
||||
(itr (+ r 1)))))
|
||||
(itr 0))
|
||||
|
||||
(define (%subvector1 v start) (%subvector v start (vector-length v)))
|
||||
|
||||
(define vector-copy
|
||||
(case-lambda
|
||||
((v) (%subvector1 v 0))
|
||||
((v start) (%subvector1 v start))
|
||||
((v start end) (%subvector v start end))))
|
||||
|
||||
(define vector->list
|
||||
(case-lambda
|
||||
((v) (r6:vector->list v))
|
||||
((v start) (r6:vector->list (%subvector1 v start)))
|
||||
((v start end) (r6:vector->list (%subvector v start end)))))
|
||||
|
||||
(define vector->string
|
||||
(case-lambda
|
||||
((v) (list->string (vector->list v)))
|
||||
((v start) (vector->string (%subvector1 v start)))
|
||||
((v start end) (vector->string (%subvector v start end)))))
|
||||
|
||||
(define vector-fill!
|
||||
(case-lambda
|
||||
((vec fill) (r6:vector-fill! vec fill))
|
||||
((vec fill start) (vector-fill! vec fill start (vector-length vec)))
|
||||
((vec fill start end)
|
||||
(define (itr r)
|
||||
(unless (= r end)
|
||||
(vector-set! vec r fill)
|
||||
(itr (+ r 1))))
|
||||
(itr start))))
|
||||
|
||||
(define (vector-for-each proc vec . vec*)
|
||||
(do ((len (fold-left min (vector-length vec) (map vector-length vec*)))
|
||||
(i 0 (+ i 1)))
|
||||
((= i len))
|
||||
(apply proc (vector-ref vec i) (map (lambda (s) (vector-ref s i)) vec*))))
|
||||
|
||||
(define (%subbytevector bv start end)
|
||||
(define mlen (- end start))
|
||||
(define out (make-bytevector mlen))
|
||||
(r6:bytevector-copy! bv start out 0 mlen)
|
||||
out)
|
||||
|
||||
(define (%subbytevector1 bv start)
|
||||
(%subbytevector bv start (bytevector-length bv)))
|
||||
|
||||
(define bytevector-copy!
|
||||
(case-lambda
|
||||
((to at from) (bytevector-copy! to at from 0))
|
||||
((to at from start)
|
||||
(let ((flen (bytevector-length from))
|
||||
(tlen (bytevector-length to)))
|
||||
(let ((fmaxcopysize (- flen start))
|
||||
(tmaxcopysize (- tlen at)))
|
||||
(bytevector-copy! to at from start (+ start
|
||||
(min fmaxcopysize
|
||||
tmaxcopysize))))))
|
||||
((to at from start end)
|
||||
(r6:bytevector-copy! from start to at (- end start)))))
|
||||
|
||||
(define bytevector-copy
|
||||
(case-lambda
|
||||
((bv) (r6:bytevector-copy bv))
|
||||
((bv start) (%subbytevector1 bv start))
|
||||
((bv start end) (%subbytevector bv start end))))
|
||||
|
||||
(define utf8->string
|
||||
(case-lambda
|
||||
((bv) (r6:utf8->string bv))
|
||||
((bv start) (r6:utf8->string (%subbytevector1 bv start)))
|
||||
((bv start end) (r6:utf8->string (%subbytevector bv start end)))))
|
||||
|
||||
;;; From division library
|
||||
|
||||
(define-syntax %define-division
|
||||
(syntax-rules ()
|
||||
((_ fix quo rem q+r)
|
||||
(begin
|
||||
(define (quo x y)
|
||||
(exact (fix (/ x y))))
|
||||
(define (rem x y)
|
||||
(- x (* (quo x y) y)))
|
||||
(define (q+r x y)
|
||||
(let ((q (quo x y)))
|
||||
(values q
|
||||
(- x (* q y)))))))))
|
||||
|
||||
(%define-division
|
||||
floor
|
||||
floor-quotient
|
||||
floor-remainder0 ;; Most implementation has native modulo
|
||||
floor/)
|
||||
(define floor-remainder modulo)
|
||||
|
||||
(define truncate-quotient quotient)
|
||||
(define truncate-remainder remainder)
|
||||
(define (truncate/ x y)
|
||||
(values (truncate-quotient x y)
|
||||
(truncate-remainder x y)))
|
||||
|
||||
(define (square x) (* x x))
|
||||
|
||||
(define (expt x y)
|
||||
(if (eqv? x 0.0)
|
||||
(inexact (r6:expt x y))
|
||||
(r6:expt x y))))
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs compat)
|
||||
(export
|
||||
features
|
||||
input-port-open?
|
||||
output-port-open?
|
||||
char-ready?
|
||||
(rename (input-port-ready? u8-ready?))
|
||||
interaction-environment
|
||||
eval ;allows define
|
||||
native-emergency-exit
|
||||
define-values)
|
||||
(import
|
||||
(chezscheme))
|
||||
|
||||
(define (features)
|
||||
(let ((mt (symbol->string (machine-type))))
|
||||
(append
|
||||
(if (char=? (string-ref mt 0) #\t)
|
||||
'(threads)
|
||||
'())
|
||||
(case (machine-type)
|
||||
((ti3le i3le) '(i386 posix gnu-linux))
|
||||
((ti3nt i3nt) '(i386 windows))
|
||||
((ti3fb i3fb) '(i386 posix bsd freebsd))
|
||||
((ti3ob i3ob) '(i386 posix bsd openbsd))
|
||||
((ti3osx i3osx) '(i386 posix bsd darwin))
|
||||
((ti3s2 i3s2) '(i386 posix unix solaris))
|
||||
((ti3nb i3nb) '(i386 posix bsd netbsd))
|
||||
((ti3qnx i3qnx) '(i386 posix qnx))
|
||||
((ta6le a6le) '(x86-64 posix gnu-linux))
|
||||
((ta6osx a6osx) '(x86-64 posix bsd darwin))
|
||||
((ta6ob a6ob) '(x86-64 posix bsd openbsd))
|
||||
((ta6s2 a6s2) '(x86-64 posix bsd solaris))
|
||||
((ta6fb a6fb) '(x86-64 posix bsd freebsd))
|
||||
((ta6nb a6nb) '(x86-64 posix bsd netbsd))
|
||||
((ta6nt a6nt) '(x86-64 windows))
|
||||
((tarm32le arm32le) '(arm posix gnu-linux))
|
||||
((tppc32le ppc32le) '(ppc posix gnu-linux))
|
||||
(else '()))
|
||||
(case (native-endianness)
|
||||
((big) '(big-endian))
|
||||
((little) '(little-endian))
|
||||
(else '()))
|
||||
'(chezscheme
|
||||
syntax-case r6rs
|
||||
r7rs exact-closed exact-complex ieee-float full-unicode ratios))))
|
||||
|
||||
(define (input-port-open? port)
|
||||
(and (not (port-closed? port)) (input-port? port)))
|
||||
|
||||
(define (output-port-open? port)
|
||||
(and (not (port-closed? port)) (output-port? port)))
|
||||
|
||||
(define native-emergency-exit
|
||||
(let ((c-exit (foreign-procedure "(cs)c_exit" (integer-32) void)))
|
||||
(case-lambda
|
||||
(()
|
||||
(c-exit 0))
|
||||
((status)
|
||||
(c-exit status))))))
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs compat)
|
||||
(export
|
||||
features
|
||||
input-port-open?
|
||||
output-port-open?
|
||||
char-ready?
|
||||
(rename (char-ready? u8-ready?))
|
||||
interaction-environment
|
||||
eval ;allows define
|
||||
(rename (primitive-_exit native-emergency-exit))
|
||||
define-values)
|
||||
(import
|
||||
(guile)
|
||||
(only (rnrs) native-endianness))
|
||||
|
||||
(define (features)
|
||||
(append
|
||||
%cond-expand-features
|
||||
(case (native-endianness)
|
||||
((big) '(big-endian))
|
||||
((little) '(little-endian))
|
||||
(else '()))
|
||||
'(r6rs
|
||||
syntax-case
|
||||
r7rs exact-closed ieee-float full-unicode ratios)))
|
||||
|
||||
(define (input-port-open? port)
|
||||
(and (not (port-closed? port)) (input-port? port)))
|
||||
|
||||
(define (output-port-open? port)
|
||||
(and (not (port-closed? port)) (output-port? port))))
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs compat)
|
||||
(export
|
||||
features
|
||||
input-port-open?
|
||||
output-port-open?
|
||||
char-ready?
|
||||
u8-ready?
|
||||
interaction-environment
|
||||
eval ;allows define
|
||||
native-emergency-exit
|
||||
define-values)
|
||||
(import
|
||||
(ikarus)
|
||||
(srfi private define-values))
|
||||
|
||||
(define (features)
|
||||
(append
|
||||
(cond ((equal? (host-info) "x86_64-unknown-linux-gnu")
|
||||
'(x86-64 posix gnu-linux))
|
||||
((equal? (host-info) "i386-unknown-linux-gnu")
|
||||
'(i386 posix gnu-linux))
|
||||
(else '()))
|
||||
(case (native-endianness)
|
||||
((big) '(big-endian))
|
||||
((little) '(little-endian))
|
||||
(else '()))
|
||||
'(ikarus
|
||||
syntax-case r6rs
|
||||
r7rs exact-closed exact-complex ieee-float full-unicode ratios)))
|
||||
|
||||
(define (char-ready? port)
|
||||
(error 'char-ready? "Not implemented in akku-r7rs" port))
|
||||
|
||||
(define (u8-ready? port)
|
||||
(error 'u8-ready? "Not implemented in akku-r7rs" port))
|
||||
|
||||
(define (input-port-open? port)
|
||||
(and (not (port-closed? port)) (input-port? port)))
|
||||
|
||||
(define (output-port-open? port)
|
||||
(and (not (port-closed? port)) (output-port? port)))
|
||||
|
||||
(define native-emergency-exit
|
||||
(case-lambda
|
||||
(()
|
||||
(foreign-call "ikrt_exit" 0))
|
||||
((status)
|
||||
(foreign-call "ikrt_exit" status)))))
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs compat)
|
||||
(export
|
||||
features
|
||||
input-port-open?
|
||||
output-port-open?
|
||||
char-ready?
|
||||
u8-ready?
|
||||
interaction-environment
|
||||
eval
|
||||
native-emergency-exit
|
||||
define-values)
|
||||
(import
|
||||
(rnrs)
|
||||
(rnrs eval) ;does not allow define
|
||||
(srfi private define-values))
|
||||
|
||||
(define (features)
|
||||
(append
|
||||
(case (native-endianness)
|
||||
((big) '(big-endian))
|
||||
((little) '(little-endian))
|
||||
(else '()))
|
||||
'(syntax-case r6rs
|
||||
r7rs exact-closed exact-complex ieee-float full-unicode ratios)))
|
||||
|
||||
(define (todo who)
|
||||
(error who "(akku-r7rs compat) is not implemented for this Scheme"))
|
||||
|
||||
(define (char-ready? port) (todo 'char-ready?))
|
||||
|
||||
(define (u8-ready? port) (todo 'u8-ready?))
|
||||
|
||||
(define (interaction-environment) (todo 'interaction-environment))
|
||||
|
||||
(define (input-port-open? port) (todo 'input-port-open?))
|
||||
|
||||
(define (output-port-open? port) (todo 'output-port-open?))
|
||||
|
||||
(define native-emergency-exit exit))
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
;; -*- mode: scheme; coding: utf-8 -*-
|
||||
;; SPDX-License-Identifier: CC0-1.0
|
||||
#!r6rs
|
||||
|
||||
(library (akku-r7rs include)
|
||||
(export
|
||||
include-helper)
|
||||
(import
|
||||
(rnrs)
|
||||
(srfi private include compat)
|
||||
(akku metadata)
|
||||
(laesare reader))
|
||||
|
||||
;; Include, with inspiration from chez-srfi and chez.
|
||||
|
||||
(define (include-helper who ctxt foldcase? fn*)
|
||||
(define (read-file filename)
|
||||
(call-with-input-file filename
|
||||
(lambda (p)
|
||||
(let ((reader (make-reader p filename)))
|
||||
(reader-fold-case?-set! reader foldcase?)
|
||||
(let lp ()
|
||||
(let ((x (read-datum reader)))
|
||||
(if (eof-object? x)
|
||||
'()
|
||||
(cons (datum->syntax ctxt x) (lp)))))))))
|
||||
(define (read-include filename)
|
||||
(let lp ((dir* (search-paths)))
|
||||
(if (null? dir*)
|
||||
(error 'include "File not found" filename (search-paths))
|
||||
(let ((fn (string-append (car dir*) "/" filename)))
|
||||
(if (file-exists? fn)
|
||||
(read-file fn)
|
||||
(lp (cdr dir*)))))))
|
||||
(cond ((assoc (cons who fn*) installed-assets)
|
||||
=> (lambda (asset) ;(original-include filenames . _)
|
||||
(let ((filenames (cadr asset)))
|
||||
#`(begin #,@(apply append (map read-include filenames))))))
|
||||
(else
|
||||
(syntax-violation who "The include is missing from (akku metadata)"
|
||||
fn*)))))
|
||||
|
|
@ -1,619 +0,0 @@
|
|||
#!r6rs
|
||||
;; This file was written by Akku.scm
|
||||
;; This file is automatically generated and is not a copyrightable work.
|
||||
(library
|
||||
(akku metadata)
|
||||
(export
|
||||
main-package-name
|
||||
main-package-version
|
||||
installed-libraries
|
||||
installed-assets)
|
||||
(import (only (rnrs) define quote))
|
||||
(define main-package-name '"chezscheme")
|
||||
(define main-package-version '"0.0.0-alpha.0")
|
||||
(define installed-libraries
|
||||
'((akku-r7rs base)
|
||||
(akku-r7rs compat)
|
||||
(akku-r7rs include)
|
||||
(foreign c)
|
||||
(foreign c array)
|
||||
(foreign c chez-primitives)
|
||||
(foreign c chibi-primitives)
|
||||
(foreign c chicken-primitives)
|
||||
(foreign c gambit-primitives)
|
||||
(foreign c gauche-primitives)
|
||||
(foreign c guile-primitives)
|
||||
(foreign c ikarus-primitives)
|
||||
(foreign c ironscheme-primitives)
|
||||
(foreign c kawa-primitives)
|
||||
(foreign c larceny-primitives)
|
||||
(foreign c mit-scheme-primitives)
|
||||
(foreign c mosh-primitives)
|
||||
(foreign c primitives-cyclone)
|
||||
(foreign c racket-primitives)
|
||||
(foreign c sagittarius-primitives)
|
||||
(foreign c stklos-primitives)
|
||||
(foreign c struct)
|
||||
(foreign c ypsilon-primitives)
|
||||
(foreign c-bytevectors)
|
||||
(laesare reader)
|
||||
(laesare writer)
|
||||
(private install sipp)
|
||||
(retropikzel system)
|
||||
(scheme base)
|
||||
(scheme case-lambda)
|
||||
(scheme char)
|
||||
(scheme complex)
|
||||
(scheme cxr)
|
||||
(scheme eval)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme lazy)
|
||||
(scheme load)
|
||||
(scheme process-context)
|
||||
(scheme r5rs)
|
||||
(scheme read)
|
||||
(scheme repl)
|
||||
(scheme time)
|
||||
(scheme write)
|
||||
(srfi :0)
|
||||
(srfi :0 cond-expand)
|
||||
(srfi :1)
|
||||
(srfi :1 lists)
|
||||
(srfi :11)
|
||||
(srfi :11 let-values)
|
||||
(srfi :111)
|
||||
(srfi :111 boxes)
|
||||
(srfi :113)
|
||||
(srfi :113 sets-and-bags)
|
||||
(srfi :115)
|
||||
(srfi :115 regexp)
|
||||
(srfi :115 regexp boundary)
|
||||
(srfi :116)
|
||||
(srfi :116 ilists)
|
||||
(srfi :117)
|
||||
(srfi :117 list-queues)
|
||||
(srfi :125)
|
||||
(srfi :125 hashtables)
|
||||
(srfi :126)
|
||||
(srfi :126 helpers helpers)
|
||||
(srfi :126 r6rs-hashtables)
|
||||
(srfi :127)
|
||||
(srfi :127 lazy-sequences)
|
||||
(srfi :128)
|
||||
(srfi :128 comparators)
|
||||
(srfi :129)
|
||||
(srfi :129 titlecase)
|
||||
(srfi :13)
|
||||
(srfi :13 strings)
|
||||
(srfi :130)
|
||||
(srfi :130 string-cursors)
|
||||
(srfi :131)
|
||||
(srfi :131 records)
|
||||
(srfi :132)
|
||||
(srfi :132 sorting)
|
||||
(srfi :133)
|
||||
(srfi :133 vectors)
|
||||
(srfi :134)
|
||||
(srfi :134 ideques)
|
||||
(srfi :139)
|
||||
(srfi :139 impl)
|
||||
(srfi :14)
|
||||
(srfi :14 char-sets)
|
||||
(srfi :14 char-sets inversion-list)
|
||||
(srfi :141)
|
||||
(srfi :141 integer-division)
|
||||
(srfi :143)
|
||||
(srfi :143 fixnums)
|
||||
(srfi :143 helpers)
|
||||
(srfi :145)
|
||||
(srfi :145 assumptions)
|
||||
(srfi :146)
|
||||
(srfi :146 gleckler hamt)
|
||||
(srfi :146 gleckler hamt-map)
|
||||
(srfi :146 gleckler hamt-misc)
|
||||
(srfi :146 gleckler vector-edit)
|
||||
(srfi :146 hash)
|
||||
(srfi :146 mappings)
|
||||
(srfi :146 nieper rbtree)
|
||||
(srfi :15 fluid-let)
|
||||
(srfi :151)
|
||||
(srfi :151 bitwise-operations)
|
||||
(srfi :152)
|
||||
(srfi :152 strings)
|
||||
(srfi :156)
|
||||
(srfi :156 predicate-combiners)
|
||||
(srfi :158)
|
||||
(srfi :158 generators-and-accumulators)
|
||||
(srfi :16)
|
||||
(srfi :16 case-lambda)
|
||||
(srfi :165)
|
||||
(srfi :166)
|
||||
(srfi :166 base)
|
||||
(srfi :166 color)
|
||||
(srfi :166 columnar)
|
||||
(srfi :166 pretty)
|
||||
(srfi :166 show-shared)
|
||||
(srfi :166 unicode)
|
||||
(srfi :17)
|
||||
(srfi :17 generalized-set!)
|
||||
(srfi :17 helpers)
|
||||
(srfi :171)
|
||||
(srfi :171 meta)
|
||||
(srfi :171 transducers)
|
||||
(srfi :175)
|
||||
(srfi :19)
|
||||
(srfi :19 time)
|
||||
(srfi :19 time compat)
|
||||
(srfi :19 time not-implemented)
|
||||
(srfi :197)
|
||||
(srfi :197 pipeline-operators)
|
||||
(srfi :2)
|
||||
(srfi :2 and-let*)
|
||||
(srfi :213)
|
||||
(srfi :213 impl)
|
||||
(srfi :214)
|
||||
(srfi :214 impl)
|
||||
(srfi :214 parameters)
|
||||
(srfi :219)
|
||||
(srfi :224)
|
||||
(srfi :23)
|
||||
(srfi :23 error)
|
||||
(srfi :23 error tricks)
|
||||
(srfi :244)
|
||||
(srfi :244 define-values)
|
||||
(srfi :25)
|
||||
(srfi :25 multi-dimensional-arrays)
|
||||
(srfi :25 multi-dimensional-arrays all)
|
||||
(srfi :25 multi-dimensional-arrays arlib)
|
||||
(srfi :26)
|
||||
(srfi :26 cut)
|
||||
(srfi :27)
|
||||
(srfi :27 random-bits)
|
||||
(srfi :28)
|
||||
(srfi :28 basic-format-strings)
|
||||
(srfi :29)
|
||||
(srfi :29 localization)
|
||||
(srfi :31)
|
||||
(srfi :31 rec)
|
||||
(srfi :34)
|
||||
(srfi :34 exception-handling)
|
||||
(srfi :35)
|
||||
(srfi :35 conditions)
|
||||
(srfi :37)
|
||||
(srfi :37 args-fold)
|
||||
(srfi :38)
|
||||
(srfi :38 with-shared-structure)
|
||||
(srfi :39)
|
||||
(srfi :39 parameters)
|
||||
(srfi :4)
|
||||
(srfi :4 numeric-vectors)
|
||||
(srfi :41)
|
||||
(srfi :41 streams)
|
||||
(srfi :41 streams derived)
|
||||
(srfi :41 streams primitive)
|
||||
(srfi :42)
|
||||
(srfi :42 eager-comprehensions)
|
||||
(srfi :43)
|
||||
(srfi :43 vectors)
|
||||
(srfi :45)
|
||||
(srfi :45 lazy)
|
||||
(srfi :48)
|
||||
(srfi :48 intermediate-format-strings)
|
||||
(srfi :48 intermediate-format-strings compat)
|
||||
(srfi :5)
|
||||
(srfi :5 let)
|
||||
(srfi :51)
|
||||
(srfi :51 rest-values)
|
||||
(srfi :54)
|
||||
(srfi :54 cat)
|
||||
(srfi :6)
|
||||
(srfi :6 basic-string-ports)
|
||||
(srfi :6 basic-string-ports compat)
|
||||
(srfi :60)
|
||||
(srfi :60 integer-bits)
|
||||
(srfi :61)
|
||||
(srfi :61 cond)
|
||||
(srfi :64)
|
||||
(srfi :64 testing)
|
||||
(srfi :67)
|
||||
(srfi :67 compare-procedures)
|
||||
(srfi :69)
|
||||
(srfi :69 basic-hash-tables)
|
||||
(srfi :78)
|
||||
(srfi :78 lightweight-testing)
|
||||
(srfi :78 lightweight-testing compat)
|
||||
(srfi :8)
|
||||
(srfi :8 receive)
|
||||
(srfi :9)
|
||||
(srfi :9 records)
|
||||
(srfi :98)
|
||||
(srfi :98 os-environment-variables)
|
||||
(srfi :99)
|
||||
(srfi :99 records)
|
||||
(srfi :99 records helper)
|
||||
(srfi :99 records inspection)
|
||||
(srfi :99 records procedural)
|
||||
(srfi :99 records syntactic)
|
||||
(srfi private OS-id-features)
|
||||
(srfi private check-arg)
|
||||
(srfi private define-values)
|
||||
(srfi private feature-cond)
|
||||
(srfi private helpers)
|
||||
(srfi private include)
|
||||
(srfi private include compat)
|
||||
(srfi private include read)
|
||||
(srfi private let-opt)
|
||||
(srfi private platform-features)
|
||||
(srfi private registry)
|
||||
(srfi private registry-names)
|
||||
(srfi private vanish)
|
||||
(srfi srfi-0)
|
||||
(srfi srfi-48 compat)
|
||||
(srfi srfi-78 compat)))
|
||||
(define installed-assets
|
||||
'(((include "./c/primitives/guile.scm")
|
||||
("foreign/c/primitives/guile.scm")
|
||||
(foreign c))
|
||||
((include "array.scm") ("foreign/c/array.scm") (foreign c array))
|
||||
((include "c.scm") ("foreign/c.scm") (foreign c))
|
||||
((include "c/array.scm") ("foreign/c/array.scm") (foreign c))
|
||||
((include "c/c-bytevectors.scm")
|
||||
("foreign/c/c-bytevectors.scm")
|
||||
(foreign c))
|
||||
((include "c/c-types.scm") ("foreign/c/c-types.scm") (foreign c))
|
||||
((include "c/define-c-library.scm")
|
||||
("foreign/c/define-c-library.scm")
|
||||
(foreign c))
|
||||
((include "c/internal.scm") ("foreign/c/internal.scm") (foreign c))
|
||||
((include "c/libc.scm") ("foreign/c/libc.scm") (foreign c))
|
||||
((include "c/main.scm") ("foreign/c/main.scm") (foreign c))
|
||||
((include "c/pointer.scm") ("foreign/c/pointer.scm") (foreign c))
|
||||
((include "c/primitives/chibi.scm")
|
||||
("foreign/c/primitives/chibi.scm")
|
||||
(foreign c))
|
||||
((include "c/primitives/mosh.scm")
|
||||
("foreign/c/primitives/mosh.scm")
|
||||
(foreign c))
|
||||
((include "c/primitives/sagittarius.scm")
|
||||
("foreign/c/primitives/sagittarius.scm")
|
||||
(foreign c))
|
||||
((include "c/primitives/ypsilon.scm")
|
||||
("foreign/c/primitives/ypsilon.scm")
|
||||
(foreign c))
|
||||
((include "c/struct.scm") ("foreign/c/struct.scm") (foreign c))
|
||||
((include "chez-primitives.scm")
|
||||
("foreign/c/chez-primitives.scm")
|
||||
(foreign c chez-primitives))
|
||||
((include "chibi-primitives.scm")
|
||||
("foreign/c/chibi-primitives.scm")
|
||||
(foreign c chibi-primitives))
|
||||
((include "chicken-primitives.scm")
|
||||
("foreign/c/chicken-primitives.scm")
|
||||
(foreign c chicken-primitives))
|
||||
((include "gambit-primitives.scm")
|
||||
("foreign/c/gambit-primitives.scm")
|
||||
(foreign c gambit-primitives))
|
||||
((include "gauche-primitives.scm")
|
||||
("foreign/c/gauche-primitives.scm")
|
||||
(foreign c gauche-primitives))
|
||||
((include "guile-primitives.scm")
|
||||
("foreign/c/guile-primitives.scm")
|
||||
(foreign c guile-primitives))
|
||||
((include "kawa-primitives.scm")
|
||||
("foreign/c/kawa-primitives.scm")
|
||||
(foreign c kawa-primitives))
|
||||
((include "larceny-primitives.scm")
|
||||
("foreign/c/larceny-primitives.scm")
|
||||
(foreign c larceny-primitives))
|
||||
((include "mosh-primitives.scm")
|
||||
("foreign/c/mosh-primitives.scm")
|
||||
(foreign c mosh-primitives))
|
||||
((include "racket-primitives.scm")
|
||||
("foreign/c/racket-primitives.scm")
|
||||
(foreign c racket-primitives))
|
||||
((include "sagittarius-primitives.scm")
|
||||
("foreign/c/sagittarius-primitives.scm")
|
||||
(foreign c sagittarius-primitives))
|
||||
((include "stklos-primitives.scm")
|
||||
("foreign/c/stklos-primitives.scm")
|
||||
(foreign c stklos-primitives))
|
||||
((include "struct.scm") ("foreign/c/struct.scm") (foreign c struct))
|
||||
((include "system.scm") ("retropikzel/system.scm") (retropikzel system))
|
||||
((include "ypsilon-primitives.scm")
|
||||
("foreign/c/ypsilon-primitives.scm")
|
||||
(foreign c ypsilon-primitives))
|
||||
((include/resolve ("srfi" "%3a1") "srfi-1-reference.scm")
|
||||
("srfi/%3a1/srfi-1-reference.scm")
|
||||
(srfi :1 lists))
|
||||
((include/resolve ("srfi" "%3a115") "regexp-impl.scm")
|
||||
("srfi/%3a115/regexp-impl.scm")
|
||||
(srfi :115 regexp))
|
||||
((include/resolve ("srfi" "%3a115") "regexp-impl.scm")
|
||||
("srfi/%3a115/regexp-impl.scm")
|
||||
(srfi srfi-115))
|
||||
((include/resolve ("srfi" "%3a115" "regexp") "boundary-impl.scm")
|
||||
("srfi/%3a115/regexp/boundary-impl.scm")
|
||||
(srfi :115 regexp boundary))
|
||||
((include/resolve ("srfi" "%3a115" "regexp") "boundary-impl.scm")
|
||||
("srfi/%3a115/regexp/boundary-impl.scm")
|
||||
(srfi srfi-115 boundary))
|
||||
((include/resolve ("srfi" "%3a117") "list-queues-impl.scm")
|
||||
("srfi/%3a117/list-queues-impl.scm")
|
||||
(srfi :117 list-queues))
|
||||
((include/resolve ("srfi" "%3a117") "list-queues-impl.scm")
|
||||
("srfi/%3a117/list-queues-impl.scm")
|
||||
(srfi srfi-117))
|
||||
((include/resolve ("srfi" "%3a125") "125.body.scm")
|
||||
("srfi/%3a125/125.body.scm")
|
||||
(srfi :125 hashtables))
|
||||
((include/resolve ("srfi" "%3a125") "125.body.scm")
|
||||
("srfi/%3a125/125.body.scm")
|
||||
(srfi srfi-125))
|
||||
((include/resolve ("srfi" "%3a126") "126.body.scm")
|
||||
("srfi/%3a126/126.body.scm")
|
||||
(srfi :126 r6rs-hashtables))
|
||||
((include/resolve ("srfi" "%3a126") "126.body.scm")
|
||||
("srfi/%3a126/126.body.scm")
|
||||
(srfi srfi-126))
|
||||
((include/resolve ("srfi" "%3a127") "lseqs-impl.scm")
|
||||
("srfi/%3a127/lseqs-impl.scm")
|
||||
(srfi :127 lazy-sequences))
|
||||
((include/resolve ("srfi" "%3a127") "lseqs-impl.scm")
|
||||
("srfi/%3a127/lseqs-impl.scm")
|
||||
(srfi srfi-127))
|
||||
((include/resolve ("srfi" "%3a128") "128.body1.scm")
|
||||
("srfi/%3a128/128.body1.scm")
|
||||
(srfi :128 comparators))
|
||||
((include/resolve ("srfi" "%3a128") "128.body1.scm")
|
||||
("srfi/%3a128/128.body1.scm")
|
||||
(srfi srfi-128))
|
||||
((include/resolve ("srfi" "%3a128") "128.body2.scm")
|
||||
("srfi/%3a128/128.body2.scm")
|
||||
(srfi :128 comparators))
|
||||
((include/resolve ("srfi" "%3a128") "128.body2.scm")
|
||||
("srfi/%3a128/128.body2.scm")
|
||||
(srfi srfi-128))
|
||||
((include/resolve ("srfi" "%3a129") "titlecase-impl.scm")
|
||||
("srfi/%3a129/titlecase-impl.scm")
|
||||
(srfi :129 titlecase))
|
||||
((include/resolve ("srfi" "%3a129") "titlecase-impl.scm")
|
||||
("srfi/%3a129/titlecase-impl.scm")
|
||||
(srfi srfi-129))
|
||||
((include/resolve ("srfi" "%3a129") "titlemaps.scm")
|
||||
("srfi/%3a129/titlemaps.scm")
|
||||
(srfi :129 titlecase))
|
||||
((include/resolve ("srfi" "%3a129") "titlemaps.scm")
|
||||
("srfi/%3a129/titlemaps.scm")
|
||||
(srfi srfi-129))
|
||||
((include/resolve ("srfi" "%3a13") "srfi-13.scm")
|
||||
("srfi/%3a13/srfi-13.scm")
|
||||
(srfi :13 strings))
|
||||
((include/resolve ("srfi" "%3a130") "130.body.scm")
|
||||
("srfi/%3a130/130.body.scm")
|
||||
(srfi :130 string-cursors))
|
||||
((include/resolve ("srfi" "%3a130") "130.body.scm")
|
||||
("srfi/%3a130/130.body.scm")
|
||||
(srfi srfi-130))
|
||||
((include/resolve ("srfi" "%3a132") "delndups.scm")
|
||||
("srfi/%3a132/delndups.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "delndups.scm")
|
||||
("srfi/%3a132/delndups.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "lmsort.scm")
|
||||
("srfi/%3a132/lmsort.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "lmsort.scm")
|
||||
("srfi/%3a132/lmsort.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "median.scm")
|
||||
("srfi/%3a132/median.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "median.scm")
|
||||
("srfi/%3a132/median.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "sort.scm")
|
||||
("srfi/%3a132/sort.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "sort.scm")
|
||||
("srfi/%3a132/sort.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "sortp.scm")
|
||||
("srfi/%3a132/sortp.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "sortp.scm")
|
||||
("srfi/%3a132/sortp.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "vector-util.scm")
|
||||
("srfi/%3a132/vector-util.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "vector-util.scm")
|
||||
("srfi/%3a132/vector-util.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "vhsort.scm")
|
||||
("srfi/%3a132/vhsort.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "vhsort.scm")
|
||||
("srfi/%3a132/vhsort.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "visort.scm")
|
||||
("srfi/%3a132/visort.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "visort.scm")
|
||||
("srfi/%3a132/visort.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "vmsort.scm")
|
||||
("srfi/%3a132/vmsort.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "vmsort.scm")
|
||||
("srfi/%3a132/vmsort.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a132") "vqsort2.scm")
|
||||
("srfi/%3a132/vqsort2.scm")
|
||||
(srfi :132 sorting))
|
||||
((include/resolve ("srfi" "%3a132") "vqsort2.scm")
|
||||
("srfi/%3a132/vqsort2.scm")
|
||||
(srfi srfi-132))
|
||||
((include/resolve ("srfi" "%3a133") "vectors-impl.scm")
|
||||
("srfi/%3a133/vectors-impl.scm")
|
||||
(srfi :133 vectors))
|
||||
((include/resolve ("srfi" "%3a133") "vectors-impl.scm")
|
||||
("srfi/%3a133/vectors-impl.scm")
|
||||
(srfi srfi-133))
|
||||
((include/resolve ("srfi" "%3a14") "srfi-14-base-char-sets.scm")
|
||||
("srfi/%3a14/srfi-14-base-char-sets.scm")
|
||||
(srfi :14 char-sets))
|
||||
((include/resolve ("srfi" "%3a14") "srfi-14-char-sets.scm")
|
||||
("srfi/%3a14/srfi-14-char-sets.scm")
|
||||
(srfi :14 char-sets))
|
||||
((include/resolve ("srfi" "%3a14") "srfi-14.scm")
|
||||
("srfi/%3a14/srfi-14.scm")
|
||||
(srfi :14 char-sets))
|
||||
((include/resolve ("srfi" "%3a14" "char-sets") "inversion-list-impl.scm")
|
||||
("srfi/%3a14/char-sets/inversion-list-impl.scm")
|
||||
(srfi :14 char-sets inversion-list))
|
||||
((include/resolve ("srfi" "%3a141") "srfi-141-impl.scm")
|
||||
("srfi/%3a141/srfi-141-impl.scm")
|
||||
(srfi :141 integer-division))
|
||||
((include/resolve ("srfi" "%3a141") "srfi-141-impl.scm")
|
||||
("srfi/%3a141/srfi-141-impl.scm")
|
||||
(srfi srfi-141))
|
||||
((include/resolve ("srfi" "%3a152") "extend-comparisons.scm")
|
||||
("srfi/%3a152/extend-comparisons.scm")
|
||||
(srfi :152 strings))
|
||||
((include/resolve ("srfi" "%3a152") "extend-comparisons.scm")
|
||||
("srfi/%3a152/extend-comparisons.scm")
|
||||
(srfi srfi-152))
|
||||
((include/resolve ("srfi" "%3a152") "macros.scm")
|
||||
("srfi/%3a152/macros.scm")
|
||||
(srfi :152 strings))
|
||||
((include/resolve ("srfi" "%3a152") "macros.scm")
|
||||
("srfi/%3a152/macros.scm")
|
||||
(srfi srfi-152))
|
||||
((include/resolve ("srfi" "%3a152") "portable.scm")
|
||||
("srfi/%3a152/portable.scm")
|
||||
(srfi :152 strings))
|
||||
((include/resolve ("srfi" "%3a152") "portable.scm")
|
||||
("srfi/%3a152/portable.scm")
|
||||
(srfi srfi-152))
|
||||
((include/resolve ("srfi" "%3a152") "r7rs-shim.scm")
|
||||
("srfi/%3a152/r7rs-shim.scm")
|
||||
(srfi :152 strings))
|
||||
((include/resolve ("srfi" "%3a152") "r7rs-shim.scm")
|
||||
("srfi/%3a152/r7rs-shim.scm")
|
||||
(srfi srfi-152))
|
||||
((include/resolve ("srfi" "%3a156") "srfi-156-impl.scm")
|
||||
("srfi/%3a156/srfi-156-impl.scm")
|
||||
(srfi :156 predicate-combiners))
|
||||
((include/resolve ("srfi" "%3a156") "srfi-156-impl.scm")
|
||||
("srfi/%3a156/srfi-156-impl.scm")
|
||||
(srfi srfi-156))
|
||||
((include/resolve ("srfi" "%3a158") "srfi-158-impl.scm")
|
||||
("srfi/%3a158/srfi-158-impl.scm")
|
||||
(srfi :158 generators-and-accumulators))
|
||||
((include/resolve ("srfi" "%3a165") "implementation.scm")
|
||||
("srfi/%3a165/implementation.scm")
|
||||
(srfi :165))
|
||||
((include/resolve ("srfi" "%3a166") "base.scm")
|
||||
("srfi/%3a166/base.scm")
|
||||
(srfi :166 base))
|
||||
((include/resolve ("srfi" "%3a166") "color.scm")
|
||||
("srfi/%3a166/color.scm")
|
||||
(srfi :166 color))
|
||||
((include/resolve ("srfi" "%3a166") "column.scm")
|
||||
("srfi/%3a166/column.scm")
|
||||
(srfi :166 columnar))
|
||||
((include/resolve ("srfi" "%3a166") "pretty.scm")
|
||||
("srfi/%3a166/pretty.scm")
|
||||
(srfi :166 pretty))
|
||||
((include/resolve ("srfi" "%3a166") "show.scm")
|
||||
("srfi/%3a166/show.scm")
|
||||
(srfi :166 base))
|
||||
((include/resolve ("srfi" "%3a166") "unicode.scm")
|
||||
("srfi/%3a166/unicode.scm")
|
||||
(srfi :166 unicode))
|
||||
((include/resolve ("srfi" "%3a166") "width.scm")
|
||||
("srfi/%3a166/width.scm")
|
||||
(srfi :166 unicode))
|
||||
((include/resolve ("srfi" "%3a166") "write.scm")
|
||||
("srfi/%3a166/write.scm")
|
||||
(srfi :166 base))
|
||||
((include/resolve ("srfi" "%3a19") "srfi-19.scm")
|
||||
("srfi/%3a19/srfi-19.scm")
|
||||
(srfi :19 time))
|
||||
((include/resolve ("srfi" "%3a224") "224.scm")
|
||||
("srfi/%3a224/224.scm")
|
||||
(srfi :224))
|
||||
((include/resolve ("srfi" "%3a224") "matchers.scm")
|
||||
("srfi/%3a224/matchers.scm")
|
||||
(srfi :224))
|
||||
((include/resolve ("srfi" "%3a224") "trie.scm")
|
||||
("srfi/%3a224/trie.scm")
|
||||
(srfi :224))
|
||||
((include/resolve ("srfi" "%3a25") "arlib.scm")
|
||||
("srfi/%3a25/arlib.scm")
|
||||
(srfi :25 multi-dimensional-arrays arlib))
|
||||
((include/resolve ("srfi" "%3a25") "arlib.scm")
|
||||
("srfi/%3a25/arlib.scm")
|
||||
(srfi srfi-25 arlib))
|
||||
((include/resolve ("srfi" "%3a25") "array.scm")
|
||||
("srfi/%3a25/array.scm")
|
||||
(srfi :25 multi-dimensional-arrays all))
|
||||
((include/resolve ("srfi" "%3a25") "array.scm")
|
||||
("srfi/%3a25/array.scm")
|
||||
(srfi srfi-25 all))
|
||||
((include/resolve ("srfi" "%3a25") "ix-ctor.scm")
|
||||
("srfi/%3a25/ix-ctor.scm")
|
||||
(srfi :25 multi-dimensional-arrays all))
|
||||
((include/resolve ("srfi" "%3a25") "ix-ctor.scm")
|
||||
("srfi/%3a25/ix-ctor.scm")
|
||||
(srfi srfi-25 all))
|
||||
((include/resolve ("srfi" "%3a25") "op-ctor.scm")
|
||||
("srfi/%3a25/op-ctor.scm")
|
||||
(srfi :25 multi-dimensional-arrays all))
|
||||
((include/resolve ("srfi" "%3a25") "op-ctor.scm")
|
||||
("srfi/%3a25/op-ctor.scm")
|
||||
(srfi srfi-25 all))
|
||||
((include/resolve ("srfi" "%3a26") "cut-impl.scm")
|
||||
("srfi/%3a26/cut-impl.scm")
|
||||
(srfi :26 cut))
|
||||
((include/resolve ("srfi" "%3a27") "mrg32k3a-a.scm")
|
||||
("srfi/%3a27/mrg32k3a-a.scm")
|
||||
(srfi :27 random-bits))
|
||||
((include/resolve ("srfi" "%3a27") "mrg32k3a.scm")
|
||||
("srfi/%3a27/mrg32k3a.scm")
|
||||
(srfi :27 random-bits))
|
||||
((include/resolve ("srfi" "%3a37") "srfi-37-reference.scm")
|
||||
("srfi/%3a37/srfi-37-reference.scm")
|
||||
(srfi :37 args-fold))
|
||||
((include/resolve ("srfi" "%3a42") "ec.scm")
|
||||
("srfi/%3a42/ec.scm")
|
||||
(srfi :42 eager-comprehensions))
|
||||
((include/resolve ("srfi" "%3a43") "vector-lib.scm")
|
||||
("srfi/%3a43/vector-lib.scm")
|
||||
(srfi :43 vectors))
|
||||
((include/resolve ("srfi" "%3a51") "srfi-51-impl.scm")
|
||||
("srfi/%3a51/srfi-51-impl.scm")
|
||||
(srfi :51 rest-values))
|
||||
((include/resolve ("srfi" "%3a51") "srfi-51-impl.scm")
|
||||
("srfi/%3a51/srfi-51-impl.scm")
|
||||
(srfi srfi-51))
|
||||
((include/resolve ("srfi" "%3a54") "srfi-54-impl.scm")
|
||||
("srfi/%3a54/srfi-54-impl.scm")
|
||||
(srfi :54 cat))
|
||||
((include/resolve ("srfi" "%3a54") "srfi-54-impl.scm")
|
||||
("srfi/%3a54/srfi-54-impl.scm")
|
||||
(srfi srfi-54))
|
||||
((include/resolve ("srfi" "%3a64") "testing-impl.scm")
|
||||
("srfi/%3a64/testing-impl.scm")
|
||||
(srfi :64 testing))
|
||||
((include/resolve ("srfi" "%3a67") "compare.scm")
|
||||
("srfi/%3a67/compare.scm")
|
||||
(srfi :67 compare-procedures))
|
||||
((include/resolve ("srfi" "%3a78") "check.scm")
|
||||
("srfi/%3a78/check.scm")
|
||||
(srfi :78 lightweight-testing))
|
||||
((include/resolve ("srfi" "%3a78") "check.scm")
|
||||
("srfi/%3a78/check.scm")
|
||||
(srfi srfi-78)))))
|
||||
|
|
@ -1,635 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c-bytevectors.sld"
|
||||
;;; Copyright 2025 Retropikzel
|
||||
;;;
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
;;; is granted subject to the restriction that all copies made of this
|
||||
;;; software must include this copyright and permission notice in full.
|
||||
;;;
|
||||
;;; This is R6RS c-Bytevectors library, modified to work with C pointers.
|
||||
;;; Mostly just by adding c- prefix to each word "bytevector".
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Copyright 2015 William D Clinger.
|
||||
;;;
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
;;; is granted subject to the restriction that all copies made of this
|
||||
;;; software must include this copyright and permission notice in full.
|
||||
;;;
|
||||
;;; I also request that you send me a copy of any improvements that you
|
||||
;;; make to this software so that they may be incorporated within it to
|
||||
;;; the benefit of the Scheme community.
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; This R7RS-portable implementation of (rnrs bytevectors) is
|
||||
;;; mostly derived from Larceny's src/Lib/Common/bytevector.sch.
|
||||
;;;
|
||||
;;; The R6RS requires implementations to select a native endianness.
|
||||
;;; That choice is arbitrary, intended to affect performance but not
|
||||
;;; behavior. In this implementation, the native endianness is
|
||||
;;; obtained via cond-expand, which should coincide with the
|
||||
;;; endianness obtained by calling the features procedure. Of the
|
||||
;;; R7RS systems I've tested, only one omits endianness from its
|
||||
;;; (features), and it's a slow interpreter for which the native
|
||||
;;; endianness probably won't affect performance.
|
||||
;;;
|
||||
;;; This implementation defines a 53-bit exact integer constant,
|
||||
;;; and the procedures that work with byte fields of arbitrary
|
||||
;;; width may create even larger exact integers.
|
||||
;;;
|
||||
;;; FIXME: It should be possible to delay creation of that 53-bit
|
||||
;;; constant until it's needed, which might be better for systems
|
||||
;;; that don't support exact 53-bit integers. It looks as though
|
||||
;;; most systems R7RS systems either support exact 53-bit integers
|
||||
;;; or overflow into inexact 53-bit integers; if the constant turns
|
||||
;;; out to be inexact, then the procedure that needs it will fail
|
||||
;;; when it is called, which is what would happen if creation of
|
||||
;;; that constant were delayed.
|
||||
|
||||
(library
|
||||
(foreign c-bytevectors)
|
||||
(export
|
||||
c-bytevectors-init
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-native-ref
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-set!)
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs control)
|
||||
(only (rnrs r5rs) remainder quotient)
|
||||
(only (rnrs bytevectors) native-endianness))
|
||||
(define make-c-bytevector #f)
|
||||
(define c-bytevector-u8-set! #f)
|
||||
(define c-bytevector-u8-ref #f)
|
||||
(define (c-bytevectors-init make u8-set! u8-ref)
|
||||
(set! make-c-bytevector make)
|
||||
(set! c-bytevector-u8-set! u8-set!)
|
||||
(set! c-bytevector-u8-ref u8-ref))
|
||||
(define (complain who . irritants)
|
||||
(apply error
|
||||
(string-append "illegal arguments passed to " (symbol->string who))
|
||||
irritants))
|
||||
(define-syntax unspecified (syntax-rules () ((_) (if #f #f))))
|
||||
(define-syntax c-bytevector:div (syntax-rules () ((_ x y) (quotient x y))))
|
||||
(define-syntax c-bytevector:mod (syntax-rules () ((_ x y) (remainder x y))))
|
||||
(define-syntax u8->s8
|
||||
(syntax-rules ()
|
||||
((_ octet0) (let ((octet octet0)) (if (> octet 127) (- octet 256) octet)))))
|
||||
(define-syntax s8->u8
|
||||
(syntax-rules ()
|
||||
((_ val0) (let ((val val0)) (if (negative? val) (+ val 256) val)))))
|
||||
(define (make-uint-ref size)
|
||||
(lambda (c-bytevector k endianness)
|
||||
(c-bytevector-uint-ref c-bytevector k endianness size)))
|
||||
(define (make-sint-ref size)
|
||||
(lambda (c-bytevector k endianness)
|
||||
(c-bytevector-sint-ref c-bytevector k endianness size)))
|
||||
(define (make-uint-set! size)
|
||||
(lambda (c-bytevector k n endianness)
|
||||
(c-bytevector-uint-set! c-bytevector k n endianness size)))
|
||||
(define (make-sint-set! size)
|
||||
(lambda (c-bytevector k n endianness)
|
||||
(c-bytevector-sint-set! c-bytevector k n endianness size)))
|
||||
(define (make-ref/native base base-ref)
|
||||
(lambda (c-bytevector index)
|
||||
(ensure-aligned index base)
|
||||
(base-ref c-bytevector index (native-endianness))))
|
||||
(define (make-set!/native base base-set!)
|
||||
(lambda (c-bytevector index val)
|
||||
(ensure-aligned index base)
|
||||
(base-set! c-bytevector index val (native-endianness))))
|
||||
(define (ensure-aligned index base)
|
||||
(if (not (zero? (c-bytevector:mod index base)))
|
||||
(error "non-aligned c-bytevector access" index base)))
|
||||
(define (make-int-list->c-bytevector c-bytevector-set!)
|
||||
(lambda (l endness size)
|
||||
(let* ((c-bytevector (make-c-bytevector (* size (length l))))
|
||||
(setter!
|
||||
(lambda (i n) (c-bytevector-set! c-bytevector i n endness size))))
|
||||
(let loop ((i 0) (l l))
|
||||
(if (null? l)
|
||||
c-bytevector
|
||||
(begin (setter! i (car l)) (loop (+ i size) (cdr l))))))))
|
||||
(define c-bytevector:single-maxexponent 255)
|
||||
(define c-bytevector:single-bias
|
||||
(c-bytevector:div c-bytevector:single-maxexponent 2))
|
||||
(define c-bytevector:single-hidden-bit (expt 2 23))
|
||||
(define c-bytevector:double-maxexponent 2047)
|
||||
(define c-bytevector:double-bias
|
||||
(c-bytevector:div c-bytevector:double-maxexponent 2))
|
||||
(define c-bytevector:double-hidden-bit (expt 2 52))
|
||||
(define two^48 (expt 2 48))
|
||||
(define two^40 (expt 2 40))
|
||||
(define two^32 (expt 2 32))
|
||||
(define two^24 (expt 2 24))
|
||||
(define two^16 (expt 2 16))
|
||||
(define two^8 (expt 2 8))
|
||||
(define (c-bytevector:normalized-ieee-parts p q)
|
||||
(cond
|
||||
((< p q) (do ((p p (+ p p)) (e 0 (- e 1))) ((>= p q) (values e p q))))
|
||||
((<= (+ q q) p)
|
||||
(do ((q q (+ q q)) (e 0 (+ e 1))) ((< p (+ q q)) (values e p q))))
|
||||
(else (values 0 p q))))
|
||||
(define (c-bytevector:ieee-parts x bias q)
|
||||
(cond
|
||||
((nan? x) (values 0 (+ bias bias 1) (- q 1)))
|
||||
((infinite? x) (values (if (positive? x) 0 1) (+ bias bias 1) 0))
|
||||
((zero? x) (values (if (eqv? x -0.0) 1 0) 0 0))
|
||||
(else (let* ((sign (if (negative? x) 1 0))
|
||||
(y (exact (abs x)))
|
||||
(num (numerator y))
|
||||
(den (denominator y)))
|
||||
(call-with-values
|
||||
(lambda () (c-bytevector:normalized-ieee-parts num den))
|
||||
(lambda (exponent num den)
|
||||
(let ((biased-exponent (+ exponent bias)))
|
||||
(cond
|
||||
((< 0 biased-exponent (+ bias bias 1))
|
||||
(if (<= den q)
|
||||
(let* ((factor (/ q den)) (num*factor (* num factor)))
|
||||
(if (integer? factor)
|
||||
(values sign biased-exponent num*factor)
|
||||
(error 'c-bytevector:ieee-parts
|
||||
"this shouldn't happen: "
|
||||
x
|
||||
bias
|
||||
q)))
|
||||
(let* ((factor (/ den q)) (num*factor (/ num factor)))
|
||||
(values sign biased-exponent (round num*factor)))))
|
||||
((>= biased-exponent (+ bias bias 1))
|
||||
(values (if (positive? x) 0 1) (+ bias bias 1) 0))
|
||||
(else (do ((biased biased-exponent (+ biased 1))
|
||||
(num (round (/ (* q num) den))
|
||||
(round (c-bytevector:div num 2)))) ((and (< num
|
||||
q)
|
||||
(= biased
|
||||
1))
|
||||
(values
|
||||
sign
|
||||
biased
|
||||
num))))))))))))
|
||||
(define (c-bytevector-ieee-double-big-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte4 (c-bytevector-u8-ref c-bytevector (+ k 4)))
|
||||
(byte5 (c-bytevector-u8-ref c-bytevector (+ k 5)))
|
||||
(byte6 (c-bytevector-u8-ref c-bytevector (+ k 6)))
|
||||
(byte7 (c-bytevector-u8-ref c-bytevector (+ k 7)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 16 (remainder byte0 128)) (quotient byte1 16)))
|
||||
(hibits (+ (* 65536 (remainder byte1 16)) (* 256 byte2) byte3))
|
||||
(midbits (+ (* 256 byte4) byte5))
|
||||
(lobits (+ (* 256 byte6) byte7)))
|
||||
(make-ieee-double sign biased-exponent hibits midbits lobits)))
|
||||
(define (c-bytevector-ieee-double-little-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 7)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 6)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 5)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 4)))
|
||||
(byte4 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte5 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte6 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte7 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 16 (remainder byte0 128)) (quotient byte1 16)))
|
||||
(hibits (+ (* 65536 (remainder byte1 16)) (* 256 byte2) byte3))
|
||||
(midbits (+ (* 256 byte4) byte5))
|
||||
(lobits (+ (* 256 byte6) byte7)))
|
||||
(make-ieee-double sign biased-exponent hibits midbits lobits)))
|
||||
(define (c-bytevector-ieee-single-big-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 2 (remainder byte0 128)) (quotient byte1 128)))
|
||||
(bits (+ (* 65536 (remainder byte1 128)) (* 256 byte2) byte3)))
|
||||
(make-ieee-single sign biased-exponent bits)))
|
||||
(define (c-bytevector-ieee-single-little-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 2 (remainder byte0 128)) (quotient byte1 128)))
|
||||
(bits (+ (* 65536 (remainder byte1 128)) (* 256 byte2) byte3)))
|
||||
(make-ieee-single sign biased-exponent bits)))
|
||||
(define (make-ieee-double sign biased-exponent hibits midbits lobits)
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:double-maxexponent)
|
||||
(if (zero? (+ hibits midbits lobits))
|
||||
(if (= 0 sign) +inf.0 -inf.0)
|
||||
(if (= 0 sign) +nan.0 +nan.0)))
|
||||
((= 0 biased-exponent)
|
||||
(if (and (= 0 hibits) (= 0 midbits) (= 0 lobits))
|
||||
(if (= 0 sign) 0.0 -0.0)
|
||||
(let* ((x (inexact hibits))
|
||||
(x (+ (* 65536.0 x) (inexact midbits)))
|
||||
(x (+ (* 65536.0 x) (inexact lobits)))
|
||||
(two^51 2251799813685248.0)
|
||||
(x (/ x two^51))
|
||||
(x (* x (expt 2.0 (- c-bytevector:double-bias)))))
|
||||
(if (= 0 sign) x (- x)))))
|
||||
(else (let* ((hibits (+ 1048576 hibits))
|
||||
(x (inexact hibits))
|
||||
(x (+ (* 65536.0 x) (inexact midbits)))
|
||||
(x (+ (* 65536.0 x) (inexact lobits)))
|
||||
(two^52 4503599627370496.0)
|
||||
(x (/ x two^52))
|
||||
(x (* x
|
||||
(expt 2.0 (- biased-exponent c-bytevector:double-bias)))))
|
||||
(if (= 0 sign) x (- x))))))
|
||||
(define (make-ieee-single sign biased-exponent bits)
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:single-maxexponent)
|
||||
(if (zero? bits)
|
||||
(if (= 0 sign) +inf.0 -inf.0)
|
||||
(if (= 0 sign) +nan.0 +nan.0)))
|
||||
((= 0 biased-exponent)
|
||||
(if (= 0 bits)
|
||||
(if (= 0 sign) 0.0 -0.0)
|
||||
(let* ((x (inexact bits))
|
||||
(two^22 4194304.0)
|
||||
(x (/ x two^22))
|
||||
(x (* x (expt 2.0 (- c-bytevector:single-bias)))))
|
||||
(if (= 0 sign) x (- x)))))
|
||||
(else (let* ((bits (+ 8388608 bits))
|
||||
(x (inexact bits))
|
||||
(two^23 8388608.0)
|
||||
(x (/ x two^23))
|
||||
(x (* x
|
||||
(expt 2.0 (- biased-exponent c-bytevector:single-bias)))))
|
||||
(if (= 0 sign) x (- x))))))
|
||||
(define-syntax endianness
|
||||
(syntax-rules () ((_ big) 'big) ((_ little) 'little)))
|
||||
(define (r6rs:c-bytevector-copy!
|
||||
source
|
||||
source-start
|
||||
target
|
||||
target-start
|
||||
count)
|
||||
(if (>= source-start target-start)
|
||||
(do ((i 0 (+ i 1))) ((>= i count))
|
||||
(c-bytevector-u8-set!
|
||||
target
|
||||
(+ target-start i)
|
||||
(c-bytevector-u8-ref source (+ source-start i))))
|
||||
(do ((i (- count 1) (- i 1))) ((< i 0))
|
||||
(c-bytevector-u8-set!
|
||||
target
|
||||
(+ target-start i)
|
||||
(c-bytevector-u8-ref source (+ source-start i))))))
|
||||
(define (c-bytevector-s8-ref b k) (u8->s8 (c-bytevector-u8-ref b k)))
|
||||
(define (c-bytevector-s8-set! b k val)
|
||||
(c-bytevector-u8-set! b k (s8->u8 val)))
|
||||
(define (u8-list->c-bytevector vals)
|
||||
(let* ((n (length vals)) (b (make-c-bytevector n)))
|
||||
(do ((vals vals (cdr vals)) (i 0 (+ i 1))) ((null? vals))
|
||||
(c-bytevector-u8-set! b i (car vals)))
|
||||
b))
|
||||
(define (c-bytevector-uchar-ref c-bytevector index)
|
||||
(integer->char (c-bytevector-u8-ref c-bytevector index)))
|
||||
(define (c-bytevector-uchar-set! c-bytevector index char)
|
||||
(c-bytevector-u8-set! c-bytevector index (char->integer char)))
|
||||
(define (c-bytevector-char-ref c-bytevector index)
|
||||
(integer->char (c-bytevector-s8-ref c-bytevector index)))
|
||||
(define (c-bytevector-char-set! c-bytevector index char)
|
||||
(c-bytevector-s8-set! c-bytevector index (char->integer char)))
|
||||
(define (c-bytevector-uint-ref c-bytevector index endness size)
|
||||
(cond
|
||||
((equal? endness 'big)
|
||||
(do ((i 0 (+ i 1))
|
||||
(result
|
||||
0
|
||||
(+ (* 256 result) (c-bytevector-u8-ref c-bytevector (+ index i))))) ((>= i
|
||||
size)
|
||||
result)))
|
||||
((equal? endness 'little)
|
||||
(do ((i (- size 1) (- i 1))
|
||||
(result
|
||||
0
|
||||
(+ (* 256 result) (c-bytevector-u8-ref c-bytevector (+ index i))))) ((< i
|
||||
0)
|
||||
result)))
|
||||
(else (c-bytevector-uint-ref c-bytevector index (native-endianness) size))))
|
||||
(define (c-bytevector-sint-ref c-bytevector index endness size)
|
||||
(let* ((high-byte
|
||||
(c-bytevector-u8-ref
|
||||
c-bytevector
|
||||
(if (eq? endness 'big) index (+ index size -1))))
|
||||
(uresult (c-bytevector-uint-ref c-bytevector index endness size)))
|
||||
(if (> high-byte 127) (- uresult (expt 256 size)) uresult)))
|
||||
(define (c-bytevector-uint-set! c-bytevector index val endness size)
|
||||
(case endness
|
||||
((little)
|
||||
(do ((i 0 (+ i 1)) (val val (c-bytevector:div val 256))) ((>= i size)
|
||||
(unspecified))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ index i)
|
||||
(c-bytevector:mod val 256))))
|
||||
((big)
|
||||
(do ((i (- size 1) (- i 1)) (val val (c-bytevector:div val 256))) ((< i
|
||||
0)
|
||||
(unspecified))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ index i)
|
||||
(c-bytevector:mod val 256))))
|
||||
(else (c-bytevector-uint-set!
|
||||
c-bytevector
|
||||
index
|
||||
val
|
||||
(native-endianness)
|
||||
size))))
|
||||
(define (c-bytevector-sint-set! c-bytevector index val endness size)
|
||||
(let ((uval (if (< val 0) (+ val (expt 256 size)) val)))
|
||||
(c-bytevector-uint-set! c-bytevector index uval endness size)))
|
||||
(define c-bytevector-u16-ref (make-uint-ref 2))
|
||||
(define c-bytevector-s16-ref (make-sint-ref 2))
|
||||
(define c-bytevector-u16-set! (make-uint-set! 2))
|
||||
(define c-bytevector-s16-set! (make-sint-set! 2))
|
||||
(define c-bytevector-u16-native-ref (make-ref/native 2 c-bytevector-u16-ref))
|
||||
(define c-bytevector-s16-native-ref (make-ref/native 2 c-bytevector-s16-ref))
|
||||
(define c-bytevector-u16-native-set!
|
||||
(make-set!/native 2 c-bytevector-u16-set!))
|
||||
(define c-bytevector-s16-native-set!
|
||||
(make-set!/native 2 c-bytevector-s16-set!))
|
||||
(define c-bytevector-u32-ref (make-uint-ref 4))
|
||||
(define c-bytevector-s32-ref (make-sint-ref 4))
|
||||
(define c-bytevector-u32-set! (make-uint-set! 4))
|
||||
(define c-bytevector-s32-set! (make-sint-set! 4))
|
||||
(define c-bytevector-u32-native-ref (make-ref/native 4 c-bytevector-u32-ref))
|
||||
(define c-bytevector-s32-native-ref (make-ref/native 4 c-bytevector-s32-ref))
|
||||
(define c-bytevector-u32-native-set!
|
||||
(make-set!/native 4 c-bytevector-u32-set!))
|
||||
(define c-bytevector-s32-native-set!
|
||||
(make-set!/native 4 c-bytevector-s32-set!))
|
||||
(define c-bytevector-u64-ref (make-uint-ref 8))
|
||||
(define c-bytevector-s64-ref (make-sint-ref 8))
|
||||
(define c-bytevector-u64-set! (make-uint-set! 8))
|
||||
(define c-bytevector-s64-set! (make-sint-set! 8))
|
||||
(define c-bytevector-u64-native-ref (make-ref/native 8 c-bytevector-u64-ref))
|
||||
(define c-bytevector-s64-native-ref (make-ref/native 8 c-bytevector-s64-ref))
|
||||
(define c-bytevector-u64-native-set!
|
||||
(make-set!/native 8 c-bytevector-u64-set!))
|
||||
(define c-bytevector-s64-native-set!
|
||||
(make-set!/native 8 c-bytevector-s64-set!))
|
||||
(define (c-bytevector-ieee-single-native-ref c-bytevector k)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-single-little-endian-ref c-bytevector k))
|
||||
(else (if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-single-big-endian-ref c-bytevector k))))
|
||||
(define (c-bytevector-ieee-double-native-ref c-bytevector k)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-double-little-endian-ref c-bytevector k))
|
||||
(else (if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-double-big-endian-ref c-bytevector k))))
|
||||
(define (c-bytevector-ieee-single-native-set! c-bytevector k x)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-set! c-bytevector k x))
|
||||
(c-bytevector-ieee-single-set! c-bytevector k x 'little))
|
||||
(else (if (not (= 0 (remainder k 4)))
|
||||
(complain
|
||||
'c-bytevector-ieee-single-native-set!
|
||||
c-bytevector
|
||||
k
|
||||
x))
|
||||
(c-bytevector-ieee-single-set! c-bytevector k x 'big))))
|
||||
(define (c-bytevector-ieee-double-native-set! c-bytevector k x)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-set! c-bytevector k x))
|
||||
(c-bytevector-ieee-double-set! c-bytevector k x 'little)))
|
||||
(else (if (not (= 0 (remainder k 8)))
|
||||
(complain
|
||||
'c-bytevector-ieee-double-native-set!
|
||||
c-bytevector
|
||||
k
|
||||
x))
|
||||
(c-bytevector-ieee-double-set! c-bytevector k x 'big))))
|
||||
(define (c-bytevector-ieee-single-ref c-bytevector k endianness)
|
||||
(case endianness
|
||||
((big) (c-bytevector-ieee-single-big-endian-ref c-bytevector k))
|
||||
((little) (c-bytevector-ieee-single-little-endian-ref c-bytevector k))
|
||||
(else (complain 'c-bytevector-ieee-single-ref c-bytevector k endianness))))
|
||||
(define (c-bytevector-ieee-double-ref c-bytevector k endianness)
|
||||
(case endianness
|
||||
((big) (c-bytevector-ieee-double-big-endian-ref c-bytevector k))
|
||||
((little) (c-bytevector-ieee-double-little-endian-ref c-bytevector k))
|
||||
(else (complain 'c-bytevector-ieee-double-ref c-bytevector k endianness))))
|
||||
(define (c-bytevector-ieee-single-set! c-bytevector k x endianness)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(c-bytevector:ieee-parts
|
||||
x
|
||||
c-bytevector:single-bias
|
||||
c-bytevector:single-hidden-bit))
|
||||
(lambda (sign biased-exponent frac)
|
||||
(define (store! sign biased-exponent frac)
|
||||
(if (eq? 'big endianness)
|
||||
(begin
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
k
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 2)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(+ (* 128 (c-bytevector:mod biased-exponent 2))
|
||||
(c-bytevector:div frac (* 256 256))))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(c-bytevector:div (c-bytevector:mod frac (* 256 256)) 256))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(c-bytevector:mod frac 256)))
|
||||
(begin
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 2)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(+ (* 128 (c-bytevector:mod biased-exponent 2))
|
||||
(c-bytevector:div frac (* 256 256))))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(c-bytevector:div (c-bytevector:mod frac (* 256 256)) 256))
|
||||
(c-bytevector-u8-set! c-bytevector k (c-bytevector:mod frac 256))))
|
||||
(unspecified))
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:single-maxexponent)
|
||||
(store! sign biased-exponent frac))
|
||||
((< frac c-bytevector:single-hidden-bit) (store! sign 0 frac))
|
||||
(else (store!
|
||||
sign
|
||||
biased-exponent
|
||||
(- frac c-bytevector:single-hidden-bit)))))))
|
||||
(define (c-bytevector-ieee-double-set! c-bytevector k x endianness)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(c-bytevector:ieee-parts
|
||||
x
|
||||
c-bytevector:double-bias
|
||||
c-bytevector:double-hidden-bit))
|
||||
(lambda (sign biased-exponent frac)
|
||||
(define (store! sign biased-exponent frac)
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 7)
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 16)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 6)
|
||||
(+ (* 16 (c-bytevector:mod biased-exponent 16))
|
||||
(c-bytevector:div frac two^48)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 5)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^48) two^40))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 4)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^40) two^32))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^32) two^24))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^24) two^16))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^16) 256))
|
||||
(c-bytevector-u8-set! c-bytevector k (c-bytevector:mod frac 256))
|
||||
(if (not (eq? endianness 'little))
|
||||
(begin
|
||||
(swap! (+ k 0) (+ k 7))
|
||||
(swap! (+ k 1) (+ k 6))
|
||||
(swap! (+ k 2) (+ k 5))
|
||||
(swap! (+ k 3) (+ k 4))))
|
||||
(unspecified))
|
||||
(define (swap! i j)
|
||||
(let ((bi (c-bytevector-u8-ref c-bytevector i))
|
||||
(bj (c-bytevector-u8-ref c-bytevector j)))
|
||||
(c-bytevector-u8-set! c-bytevector i bj)
|
||||
(c-bytevector-u8-set! c-bytevector j bi)))
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:double-maxexponent)
|
||||
(store! sign biased-exponent frac))
|
||||
((< frac c-bytevector:double-hidden-bit) (store! sign 0 frac))
|
||||
(else (store!
|
||||
sign
|
||||
biased-exponent
|
||||
(- frac c-bytevector:double-hidden-bit)))))))
|
||||
(define (string->utf16 string . rest)
|
||||
(let* ((endianness
|
||||
(cond
|
||||
((null? rest) 'big)
|
||||
((not (null? (cdr rest)))
|
||||
(apply complain 'string->utf16 string rest))
|
||||
((eq? (car rest) 'big) 'big)
|
||||
((eq? (car rest) 'little) 'little)
|
||||
(else (apply complain 'string->utf16 string rest))))
|
||||
(hi (if (eq? 'big endianness) 0 1))
|
||||
(lo (- 1 hi))
|
||||
(n (string-length string)))
|
||||
(define (result-length)
|
||||
(do ((i 0 (+ i 1))
|
||||
(k 0
|
||||
(let ((sv (char->integer (string-ref string i))))
|
||||
(if (< sv 65536) (+ k 2) (+ k 4))))) ((= i n) k)))
|
||||
(let ((bv (make-c-bytevector (result-length))))
|
||||
(define (loop i k)
|
||||
(if (< i n)
|
||||
(let ((sv (char->integer (string-ref string i))))
|
||||
(if (< sv 65536)
|
||||
(let ((hibits (quotient sv 256))
|
||||
(lobits (remainder sv 256)))
|
||||
(c-bytevector-u8-set! bv (+ k hi) hibits)
|
||||
(c-bytevector-u8-set! bv (+ k lo) lobits)
|
||||
(loop (+ i 1) (+ k 2)))
|
||||
(let* ((x (- sv 65536))
|
||||
(hibits (quotient x 1024))
|
||||
(lobits (remainder x 1024))
|
||||
(hi16 (+ 55296 hibits))
|
||||
(lo16 (+ 56320 lobits))
|
||||
(hi1 (quotient hi16 256))
|
||||
(lo1 (remainder hi16 256))
|
||||
(hi2 (quotient lo16 256))
|
||||
(lo2 (remainder lo16 256)))
|
||||
(c-bytevector-u8-set! bv (+ k hi) hi1)
|
||||
(c-bytevector-u8-set! bv (+ k lo) lo1)
|
||||
(c-bytevector-u8-set! bv (+ k hi 2) hi2)
|
||||
(c-bytevector-u8-set! bv (+ k lo 2) lo2)
|
||||
(loop (+ i 1) (+ k 4)))))))
|
||||
(loop 0 0)
|
||||
bv))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../foreign/c-bytevectors.sld
|
||||
|
|
@ -1,635 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c-bytevectors.sld"
|
||||
;;; Copyright 2025 Retropikzel
|
||||
;;;
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
;;; is granted subject to the restriction that all copies made of this
|
||||
;;; software must include this copyright and permission notice in full.
|
||||
;;;
|
||||
;;; This is R6RS c-Bytevectors library, modified to work with C pointers.
|
||||
;;; Mostly just by adding c- prefix to each word "bytevector".
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Copyright 2015 William D Clinger.
|
||||
;;;
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
;;; is granted subject to the restriction that all copies made of this
|
||||
;;; software must include this copyright and permission notice in full.
|
||||
;;;
|
||||
;;; I also request that you send me a copy of any improvements that you
|
||||
;;; make to this software so that they may be incorporated within it to
|
||||
;;; the benefit of the Scheme community.
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; This R7RS-portable implementation of (rnrs bytevectors) is
|
||||
;;; mostly derived from Larceny's src/Lib/Common/bytevector.sch.
|
||||
;;;
|
||||
;;; The R6RS requires implementations to select a native endianness.
|
||||
;;; That choice is arbitrary, intended to affect performance but not
|
||||
;;; behavior. In this implementation, the native endianness is
|
||||
;;; obtained via cond-expand, which should coincide with the
|
||||
;;; endianness obtained by calling the features procedure. Of the
|
||||
;;; R7RS systems I've tested, only one omits endianness from its
|
||||
;;; (features), and it's a slow interpreter for which the native
|
||||
;;; endianness probably won't affect performance.
|
||||
;;;
|
||||
;;; This implementation defines a 53-bit exact integer constant,
|
||||
;;; and the procedures that work with byte fields of arbitrary
|
||||
;;; width may create even larger exact integers.
|
||||
;;;
|
||||
;;; FIXME: It should be possible to delay creation of that 53-bit
|
||||
;;; constant until it's needed, which might be better for systems
|
||||
;;; that don't support exact 53-bit integers. It looks as though
|
||||
;;; most systems R7RS systems either support exact 53-bit integers
|
||||
;;; or overflow into inexact 53-bit integers; if the constant turns
|
||||
;;; out to be inexact, then the procedure that needs it will fail
|
||||
;;; when it is called, which is what would happen if creation of
|
||||
;;; that constant were delayed.
|
||||
|
||||
(library
|
||||
(foreign c-bytevectors)
|
||||
(export
|
||||
c-bytevectors-init
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-native-ref
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-set!)
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs control)
|
||||
(only (rnrs r5rs) remainder quotient)
|
||||
(only (rnrs bytevectors) native-endianness))
|
||||
(define make-c-bytevector #f)
|
||||
(define c-bytevector-u8-set! #f)
|
||||
(define c-bytevector-u8-ref #f)
|
||||
(define (c-bytevectors-init make u8-set! u8-ref)
|
||||
(set! make-c-bytevector make)
|
||||
(set! c-bytevector-u8-set! u8-set!)
|
||||
(set! c-bytevector-u8-ref u8-ref))
|
||||
(define (complain who . irritants)
|
||||
(apply error
|
||||
(string-append "illegal arguments passed to " (symbol->string who))
|
||||
irritants))
|
||||
(define-syntax unspecified (syntax-rules () ((_) (if #f #f))))
|
||||
(define-syntax c-bytevector:div (syntax-rules () ((_ x y) (quotient x y))))
|
||||
(define-syntax c-bytevector:mod (syntax-rules () ((_ x y) (remainder x y))))
|
||||
(define-syntax u8->s8
|
||||
(syntax-rules ()
|
||||
((_ octet0) (let ((octet octet0)) (if (> octet 127) (- octet 256) octet)))))
|
||||
(define-syntax s8->u8
|
||||
(syntax-rules ()
|
||||
((_ val0) (let ((val val0)) (if (negative? val) (+ val 256) val)))))
|
||||
(define (make-uint-ref size)
|
||||
(lambda (c-bytevector k endianness)
|
||||
(c-bytevector-uint-ref c-bytevector k endianness size)))
|
||||
(define (make-sint-ref size)
|
||||
(lambda (c-bytevector k endianness)
|
||||
(c-bytevector-sint-ref c-bytevector k endianness size)))
|
||||
(define (make-uint-set! size)
|
||||
(lambda (c-bytevector k n endianness)
|
||||
(c-bytevector-uint-set! c-bytevector k n endianness size)))
|
||||
(define (make-sint-set! size)
|
||||
(lambda (c-bytevector k n endianness)
|
||||
(c-bytevector-sint-set! c-bytevector k n endianness size)))
|
||||
(define (make-ref/native base base-ref)
|
||||
(lambda (c-bytevector index)
|
||||
(ensure-aligned index base)
|
||||
(base-ref c-bytevector index (native-endianness))))
|
||||
(define (make-set!/native base base-set!)
|
||||
(lambda (c-bytevector index val)
|
||||
(ensure-aligned index base)
|
||||
(base-set! c-bytevector index val (native-endianness))))
|
||||
(define (ensure-aligned index base)
|
||||
(if (not (zero? (c-bytevector:mod index base)))
|
||||
(error "non-aligned c-bytevector access" index base)))
|
||||
(define (make-int-list->c-bytevector c-bytevector-set!)
|
||||
(lambda (l endness size)
|
||||
(let* ((c-bytevector (make-c-bytevector (* size (length l))))
|
||||
(setter!
|
||||
(lambda (i n) (c-bytevector-set! c-bytevector i n endness size))))
|
||||
(let loop ((i 0) (l l))
|
||||
(if (null? l)
|
||||
c-bytevector
|
||||
(begin (setter! i (car l)) (loop (+ i size) (cdr l))))))))
|
||||
(define c-bytevector:single-maxexponent 255)
|
||||
(define c-bytevector:single-bias
|
||||
(c-bytevector:div c-bytevector:single-maxexponent 2))
|
||||
(define c-bytevector:single-hidden-bit (expt 2 23))
|
||||
(define c-bytevector:double-maxexponent 2047)
|
||||
(define c-bytevector:double-bias
|
||||
(c-bytevector:div c-bytevector:double-maxexponent 2))
|
||||
(define c-bytevector:double-hidden-bit (expt 2 52))
|
||||
(define two^48 (expt 2 48))
|
||||
(define two^40 (expt 2 40))
|
||||
(define two^32 (expt 2 32))
|
||||
(define two^24 (expt 2 24))
|
||||
(define two^16 (expt 2 16))
|
||||
(define two^8 (expt 2 8))
|
||||
(define (c-bytevector:normalized-ieee-parts p q)
|
||||
(cond
|
||||
((< p q) (do ((p p (+ p p)) (e 0 (- e 1))) ((>= p q) (values e p q))))
|
||||
((<= (+ q q) p)
|
||||
(do ((q q (+ q q)) (e 0 (+ e 1))) ((< p (+ q q)) (values e p q))))
|
||||
(else (values 0 p q))))
|
||||
(define (c-bytevector:ieee-parts x bias q)
|
||||
(cond
|
||||
((nan? x) (values 0 (+ bias bias 1) (- q 1)))
|
||||
((infinite? x) (values (if (positive? x) 0 1) (+ bias bias 1) 0))
|
||||
((zero? x) (values (if (eqv? x -0.0) 1 0) 0 0))
|
||||
(else (let* ((sign (if (negative? x) 1 0))
|
||||
(y (exact (abs x)))
|
||||
(num (numerator y))
|
||||
(den (denominator y)))
|
||||
(call-with-values
|
||||
(lambda () (c-bytevector:normalized-ieee-parts num den))
|
||||
(lambda (exponent num den)
|
||||
(let ((biased-exponent (+ exponent bias)))
|
||||
(cond
|
||||
((< 0 biased-exponent (+ bias bias 1))
|
||||
(if (<= den q)
|
||||
(let* ((factor (/ q den)) (num*factor (* num factor)))
|
||||
(if (integer? factor)
|
||||
(values sign biased-exponent num*factor)
|
||||
(error 'c-bytevector:ieee-parts
|
||||
"this shouldn't happen: "
|
||||
x
|
||||
bias
|
||||
q)))
|
||||
(let* ((factor (/ den q)) (num*factor (/ num factor)))
|
||||
(values sign biased-exponent (round num*factor)))))
|
||||
((>= biased-exponent (+ bias bias 1))
|
||||
(values (if (positive? x) 0 1) (+ bias bias 1) 0))
|
||||
(else (do ((biased biased-exponent (+ biased 1))
|
||||
(num (round (/ (* q num) den))
|
||||
(round (c-bytevector:div num 2)))) ((and (< num
|
||||
q)
|
||||
(= biased
|
||||
1))
|
||||
(values
|
||||
sign
|
||||
biased
|
||||
num))))))))))))
|
||||
(define (c-bytevector-ieee-double-big-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte4 (c-bytevector-u8-ref c-bytevector (+ k 4)))
|
||||
(byte5 (c-bytevector-u8-ref c-bytevector (+ k 5)))
|
||||
(byte6 (c-bytevector-u8-ref c-bytevector (+ k 6)))
|
||||
(byte7 (c-bytevector-u8-ref c-bytevector (+ k 7)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 16 (remainder byte0 128)) (quotient byte1 16)))
|
||||
(hibits (+ (* 65536 (remainder byte1 16)) (* 256 byte2) byte3))
|
||||
(midbits (+ (* 256 byte4) byte5))
|
||||
(lobits (+ (* 256 byte6) byte7)))
|
||||
(make-ieee-double sign biased-exponent hibits midbits lobits)))
|
||||
(define (c-bytevector-ieee-double-little-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 7)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 6)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 5)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 4)))
|
||||
(byte4 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte5 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte6 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte7 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 16 (remainder byte0 128)) (quotient byte1 16)))
|
||||
(hibits (+ (* 65536 (remainder byte1 16)) (* 256 byte2) byte3))
|
||||
(midbits (+ (* 256 byte4) byte5))
|
||||
(lobits (+ (* 256 byte6) byte7)))
|
||||
(make-ieee-double sign biased-exponent hibits midbits lobits)))
|
||||
(define (c-bytevector-ieee-single-big-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 2 (remainder byte0 128)) (quotient byte1 128)))
|
||||
(bits (+ (* 65536 (remainder byte1 128)) (* 256 byte2) byte3)))
|
||||
(make-ieee-single sign biased-exponent bits)))
|
||||
(define (c-bytevector-ieee-single-little-endian-ref c-bytevector k)
|
||||
(let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 3)))
|
||||
(byte1 (c-bytevector-u8-ref c-bytevector (+ k 2)))
|
||||
(byte2 (c-bytevector-u8-ref c-bytevector (+ k 1)))
|
||||
(byte3 (c-bytevector-u8-ref c-bytevector (+ k 0)))
|
||||
(sign (quotient byte0 128))
|
||||
(biased-exponent
|
||||
(+ (* 2 (remainder byte0 128)) (quotient byte1 128)))
|
||||
(bits (+ (* 65536 (remainder byte1 128)) (* 256 byte2) byte3)))
|
||||
(make-ieee-single sign biased-exponent bits)))
|
||||
(define (make-ieee-double sign biased-exponent hibits midbits lobits)
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:double-maxexponent)
|
||||
(if (zero? (+ hibits midbits lobits))
|
||||
(if (= 0 sign) +inf.0 -inf.0)
|
||||
(if (= 0 sign) +nan.0 +nan.0)))
|
||||
((= 0 biased-exponent)
|
||||
(if (and (= 0 hibits) (= 0 midbits) (= 0 lobits))
|
||||
(if (= 0 sign) 0.0 -0.0)
|
||||
(let* ((x (inexact hibits))
|
||||
(x (+ (* 65536.0 x) (inexact midbits)))
|
||||
(x (+ (* 65536.0 x) (inexact lobits)))
|
||||
(two^51 2251799813685248.0)
|
||||
(x (/ x two^51))
|
||||
(x (* x (expt 2.0 (- c-bytevector:double-bias)))))
|
||||
(if (= 0 sign) x (- x)))))
|
||||
(else (let* ((hibits (+ 1048576 hibits))
|
||||
(x (inexact hibits))
|
||||
(x (+ (* 65536.0 x) (inexact midbits)))
|
||||
(x (+ (* 65536.0 x) (inexact lobits)))
|
||||
(two^52 4503599627370496.0)
|
||||
(x (/ x two^52))
|
||||
(x (* x
|
||||
(expt 2.0 (- biased-exponent c-bytevector:double-bias)))))
|
||||
(if (= 0 sign) x (- x))))))
|
||||
(define (make-ieee-single sign biased-exponent bits)
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:single-maxexponent)
|
||||
(if (zero? bits)
|
||||
(if (= 0 sign) +inf.0 -inf.0)
|
||||
(if (= 0 sign) +nan.0 +nan.0)))
|
||||
((= 0 biased-exponent)
|
||||
(if (= 0 bits)
|
||||
(if (= 0 sign) 0.0 -0.0)
|
||||
(let* ((x (inexact bits))
|
||||
(two^22 4194304.0)
|
||||
(x (/ x two^22))
|
||||
(x (* x (expt 2.0 (- c-bytevector:single-bias)))))
|
||||
(if (= 0 sign) x (- x)))))
|
||||
(else (let* ((bits (+ 8388608 bits))
|
||||
(x (inexact bits))
|
||||
(two^23 8388608.0)
|
||||
(x (/ x two^23))
|
||||
(x (* x
|
||||
(expt 2.0 (- biased-exponent c-bytevector:single-bias)))))
|
||||
(if (= 0 sign) x (- x))))))
|
||||
(define-syntax endianness
|
||||
(syntax-rules () ((_ big) 'big) ((_ little) 'little)))
|
||||
(define (r6rs:c-bytevector-copy!
|
||||
source
|
||||
source-start
|
||||
target
|
||||
target-start
|
||||
count)
|
||||
(if (>= source-start target-start)
|
||||
(do ((i 0 (+ i 1))) ((>= i count))
|
||||
(c-bytevector-u8-set!
|
||||
target
|
||||
(+ target-start i)
|
||||
(c-bytevector-u8-ref source (+ source-start i))))
|
||||
(do ((i (- count 1) (- i 1))) ((< i 0))
|
||||
(c-bytevector-u8-set!
|
||||
target
|
||||
(+ target-start i)
|
||||
(c-bytevector-u8-ref source (+ source-start i))))))
|
||||
(define (c-bytevector-s8-ref b k) (u8->s8 (c-bytevector-u8-ref b k)))
|
||||
(define (c-bytevector-s8-set! b k val)
|
||||
(c-bytevector-u8-set! b k (s8->u8 val)))
|
||||
(define (u8-list->c-bytevector vals)
|
||||
(let* ((n (length vals)) (b (make-c-bytevector n)))
|
||||
(do ((vals vals (cdr vals)) (i 0 (+ i 1))) ((null? vals))
|
||||
(c-bytevector-u8-set! b i (car vals)))
|
||||
b))
|
||||
(define (c-bytevector-uchar-ref c-bytevector index)
|
||||
(integer->char (c-bytevector-u8-ref c-bytevector index)))
|
||||
(define (c-bytevector-uchar-set! c-bytevector index char)
|
||||
(c-bytevector-u8-set! c-bytevector index (char->integer char)))
|
||||
(define (c-bytevector-char-ref c-bytevector index)
|
||||
(integer->char (c-bytevector-s8-ref c-bytevector index)))
|
||||
(define (c-bytevector-char-set! c-bytevector index char)
|
||||
(c-bytevector-s8-set! c-bytevector index (char->integer char)))
|
||||
(define (c-bytevector-uint-ref c-bytevector index endness size)
|
||||
(cond
|
||||
((equal? endness 'big)
|
||||
(do ((i 0 (+ i 1))
|
||||
(result
|
||||
0
|
||||
(+ (* 256 result) (c-bytevector-u8-ref c-bytevector (+ index i))))) ((>= i
|
||||
size)
|
||||
result)))
|
||||
((equal? endness 'little)
|
||||
(do ((i (- size 1) (- i 1))
|
||||
(result
|
||||
0
|
||||
(+ (* 256 result) (c-bytevector-u8-ref c-bytevector (+ index i))))) ((< i
|
||||
0)
|
||||
result)))
|
||||
(else (c-bytevector-uint-ref c-bytevector index (native-endianness) size))))
|
||||
(define (c-bytevector-sint-ref c-bytevector index endness size)
|
||||
(let* ((high-byte
|
||||
(c-bytevector-u8-ref
|
||||
c-bytevector
|
||||
(if (eq? endness 'big) index (+ index size -1))))
|
||||
(uresult (c-bytevector-uint-ref c-bytevector index endness size)))
|
||||
(if (> high-byte 127) (- uresult (expt 256 size)) uresult)))
|
||||
(define (c-bytevector-uint-set! c-bytevector index val endness size)
|
||||
(case endness
|
||||
((little)
|
||||
(do ((i 0 (+ i 1)) (val val (c-bytevector:div val 256))) ((>= i size)
|
||||
(unspecified))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ index i)
|
||||
(c-bytevector:mod val 256))))
|
||||
((big)
|
||||
(do ((i (- size 1) (- i 1)) (val val (c-bytevector:div val 256))) ((< i
|
||||
0)
|
||||
(unspecified))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ index i)
|
||||
(c-bytevector:mod val 256))))
|
||||
(else (c-bytevector-uint-set!
|
||||
c-bytevector
|
||||
index
|
||||
val
|
||||
(native-endianness)
|
||||
size))))
|
||||
(define (c-bytevector-sint-set! c-bytevector index val endness size)
|
||||
(let ((uval (if (< val 0) (+ val (expt 256 size)) val)))
|
||||
(c-bytevector-uint-set! c-bytevector index uval endness size)))
|
||||
(define c-bytevector-u16-ref (make-uint-ref 2))
|
||||
(define c-bytevector-s16-ref (make-sint-ref 2))
|
||||
(define c-bytevector-u16-set! (make-uint-set! 2))
|
||||
(define c-bytevector-s16-set! (make-sint-set! 2))
|
||||
(define c-bytevector-u16-native-ref (make-ref/native 2 c-bytevector-u16-ref))
|
||||
(define c-bytevector-s16-native-ref (make-ref/native 2 c-bytevector-s16-ref))
|
||||
(define c-bytevector-u16-native-set!
|
||||
(make-set!/native 2 c-bytevector-u16-set!))
|
||||
(define c-bytevector-s16-native-set!
|
||||
(make-set!/native 2 c-bytevector-s16-set!))
|
||||
(define c-bytevector-u32-ref (make-uint-ref 4))
|
||||
(define c-bytevector-s32-ref (make-sint-ref 4))
|
||||
(define c-bytevector-u32-set! (make-uint-set! 4))
|
||||
(define c-bytevector-s32-set! (make-sint-set! 4))
|
||||
(define c-bytevector-u32-native-ref (make-ref/native 4 c-bytevector-u32-ref))
|
||||
(define c-bytevector-s32-native-ref (make-ref/native 4 c-bytevector-s32-ref))
|
||||
(define c-bytevector-u32-native-set!
|
||||
(make-set!/native 4 c-bytevector-u32-set!))
|
||||
(define c-bytevector-s32-native-set!
|
||||
(make-set!/native 4 c-bytevector-s32-set!))
|
||||
(define c-bytevector-u64-ref (make-uint-ref 8))
|
||||
(define c-bytevector-s64-ref (make-sint-ref 8))
|
||||
(define c-bytevector-u64-set! (make-uint-set! 8))
|
||||
(define c-bytevector-s64-set! (make-sint-set! 8))
|
||||
(define c-bytevector-u64-native-ref (make-ref/native 8 c-bytevector-u64-ref))
|
||||
(define c-bytevector-s64-native-ref (make-ref/native 8 c-bytevector-s64-ref))
|
||||
(define c-bytevector-u64-native-set!
|
||||
(make-set!/native 8 c-bytevector-u64-set!))
|
||||
(define c-bytevector-s64-native-set!
|
||||
(make-set!/native 8 c-bytevector-s64-set!))
|
||||
(define (c-bytevector-ieee-single-native-ref c-bytevector k)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-single-little-endian-ref c-bytevector k))
|
||||
(else (if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-single-big-endian-ref c-bytevector k))))
|
||||
(define (c-bytevector-ieee-double-native-ref c-bytevector k)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-double-little-endian-ref c-bytevector k))
|
||||
(else (if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
|
||||
(c-bytevector-ieee-double-big-endian-ref c-bytevector k))))
|
||||
(define (c-bytevector-ieee-single-native-set! c-bytevector k x)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(complain 'c-bytevector-ieee-single-native-set! c-bytevector k x))
|
||||
(c-bytevector-ieee-single-set! c-bytevector k x 'little))
|
||||
(else (if (not (= 0 (remainder k 4)))
|
||||
(complain
|
||||
'c-bytevector-ieee-single-native-set!
|
||||
c-bytevector
|
||||
k
|
||||
x))
|
||||
(c-bytevector-ieee-single-set! c-bytevector k x 'big))))
|
||||
(define (c-bytevector-ieee-double-native-set! c-bytevector k x)
|
||||
(cond
|
||||
((equal? (native-endianness) 'little)
|
||||
(if (not (= 0 (remainder k 4)))
|
||||
(if (not (= 0 (remainder k 8)))
|
||||
(complain 'c-bytevector-ieee-double-native-set! c-bytevector k x))
|
||||
(c-bytevector-ieee-double-set! c-bytevector k x 'little)))
|
||||
(else (if (not (= 0 (remainder k 8)))
|
||||
(complain
|
||||
'c-bytevector-ieee-double-native-set!
|
||||
c-bytevector
|
||||
k
|
||||
x))
|
||||
(c-bytevector-ieee-double-set! c-bytevector k x 'big))))
|
||||
(define (c-bytevector-ieee-single-ref c-bytevector k endianness)
|
||||
(case endianness
|
||||
((big) (c-bytevector-ieee-single-big-endian-ref c-bytevector k))
|
||||
((little) (c-bytevector-ieee-single-little-endian-ref c-bytevector k))
|
||||
(else (complain 'c-bytevector-ieee-single-ref c-bytevector k endianness))))
|
||||
(define (c-bytevector-ieee-double-ref c-bytevector k endianness)
|
||||
(case endianness
|
||||
((big) (c-bytevector-ieee-double-big-endian-ref c-bytevector k))
|
||||
((little) (c-bytevector-ieee-double-little-endian-ref c-bytevector k))
|
||||
(else (complain 'c-bytevector-ieee-double-ref c-bytevector k endianness))))
|
||||
(define (c-bytevector-ieee-single-set! c-bytevector k x endianness)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(c-bytevector:ieee-parts
|
||||
x
|
||||
c-bytevector:single-bias
|
||||
c-bytevector:single-hidden-bit))
|
||||
(lambda (sign biased-exponent frac)
|
||||
(define (store! sign biased-exponent frac)
|
||||
(if (eq? 'big endianness)
|
||||
(begin
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
k
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 2)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(+ (* 128 (c-bytevector:mod biased-exponent 2))
|
||||
(c-bytevector:div frac (* 256 256))))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(c-bytevector:div (c-bytevector:mod frac (* 256 256)) 256))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(c-bytevector:mod frac 256)))
|
||||
(begin
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 2)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(+ (* 128 (c-bytevector:mod biased-exponent 2))
|
||||
(c-bytevector:div frac (* 256 256))))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(c-bytevector:div (c-bytevector:mod frac (* 256 256)) 256))
|
||||
(c-bytevector-u8-set! c-bytevector k (c-bytevector:mod frac 256))))
|
||||
(unspecified))
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:single-maxexponent)
|
||||
(store! sign biased-exponent frac))
|
||||
((< frac c-bytevector:single-hidden-bit) (store! sign 0 frac))
|
||||
(else (store!
|
||||
sign
|
||||
biased-exponent
|
||||
(- frac c-bytevector:single-hidden-bit)))))))
|
||||
(define (c-bytevector-ieee-double-set! c-bytevector k x endianness)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(c-bytevector:ieee-parts
|
||||
x
|
||||
c-bytevector:double-bias
|
||||
c-bytevector:double-hidden-bit))
|
||||
(lambda (sign biased-exponent frac)
|
||||
(define (store! sign biased-exponent frac)
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 7)
|
||||
(+ (* 128 sign) (c-bytevector:div biased-exponent 16)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 6)
|
||||
(+ (* 16 (c-bytevector:mod biased-exponent 16))
|
||||
(c-bytevector:div frac two^48)))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 5)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^48) two^40))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 4)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^40) two^32))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 3)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^32) two^24))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 2)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^24) two^16))
|
||||
(c-bytevector-u8-set!
|
||||
c-bytevector
|
||||
(+ k 1)
|
||||
(c-bytevector:div (c-bytevector:mod frac two^16) 256))
|
||||
(c-bytevector-u8-set! c-bytevector k (c-bytevector:mod frac 256))
|
||||
(if (not (eq? endianness 'little))
|
||||
(begin
|
||||
(swap! (+ k 0) (+ k 7))
|
||||
(swap! (+ k 1) (+ k 6))
|
||||
(swap! (+ k 2) (+ k 5))
|
||||
(swap! (+ k 3) (+ k 4))))
|
||||
(unspecified))
|
||||
(define (swap! i j)
|
||||
(let ((bi (c-bytevector-u8-ref c-bytevector i))
|
||||
(bj (c-bytevector-u8-ref c-bytevector j)))
|
||||
(c-bytevector-u8-set! c-bytevector i bj)
|
||||
(c-bytevector-u8-set! c-bytevector j bi)))
|
||||
(cond
|
||||
((= biased-exponent c-bytevector:double-maxexponent)
|
||||
(store! sign biased-exponent frac))
|
||||
((< frac c-bytevector:double-hidden-bit) (store! sign 0 frac))
|
||||
(else (store!
|
||||
sign
|
||||
biased-exponent
|
||||
(- frac c-bytevector:double-hidden-bit)))))))
|
||||
(define (string->utf16 string . rest)
|
||||
(let* ((endianness
|
||||
(cond
|
||||
((null? rest) 'big)
|
||||
((not (null? (cdr rest)))
|
||||
(apply complain 'string->utf16 string rest))
|
||||
((eq? (car rest) 'big) 'big)
|
||||
((eq? (car rest) 'little) 'little)
|
||||
(else (apply complain 'string->utf16 string rest))))
|
||||
(hi (if (eq? 'big endianness) 0 1))
|
||||
(lo (- 1 hi))
|
||||
(n (string-length string)))
|
||||
(define (result-length)
|
||||
(do ((i 0 (+ i 1))
|
||||
(k 0
|
||||
(let ((sv (char->integer (string-ref string i))))
|
||||
(if (< sv 65536) (+ k 2) (+ k 4))))) ((= i n) k)))
|
||||
(let ((bv (make-c-bytevector (result-length))))
|
||||
(define (loop i k)
|
||||
(if (< i n)
|
||||
(let ((sv (char->integer (string-ref string i))))
|
||||
(if (< sv 65536)
|
||||
(let ((hibits (quotient sv 256))
|
||||
(lobits (remainder sv 256)))
|
||||
(c-bytevector-u8-set! bv (+ k hi) hibits)
|
||||
(c-bytevector-u8-set! bv (+ k lo) lobits)
|
||||
(loop (+ i 1) (+ k 2)))
|
||||
(let* ((x (- sv 65536))
|
||||
(hibits (quotient x 1024))
|
||||
(lobits (remainder x 1024))
|
||||
(hi16 (+ 55296 hibits))
|
||||
(lo16 (+ 56320 lobits))
|
||||
(hi1 (quotient hi16 256))
|
||||
(lo1 (remainder hi16 256))
|
||||
(hi2 (quotient lo16 256))
|
||||
(lo2 (remainder lo16 256)))
|
||||
(c-bytevector-u8-set! bv (+ k hi) hi1)
|
||||
(c-bytevector-u8-set! bv (+ k lo) lo1)
|
||||
(c-bytevector-u8-set! bv (+ k hi 2) hi2)
|
||||
(c-bytevector-u8-set! bv (+ k lo 2) lo2)
|
||||
(loop (+ i 1) (+ k 4)))))))
|
||||
(loop 0 0)
|
||||
bv))))
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
foreign-procedure
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c chez-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c guile-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c ikarus-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c ironscheme-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../foreign/c.sld
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c mosh-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../foreign/c.sld
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../foreign/c.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../foreign/c.sld
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c.sld"
|
||||
(library
|
||||
(foreign c)
|
||||
(export
|
||||
c-function
|
||||
bytevector-c-int8-set!
|
||||
bytevector-c-uint8-ref
|
||||
c-type-size
|
||||
c-type-align
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
make-c-bytevector
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
string->c-utf8
|
||||
c-utf8->string
|
||||
libc-name
|
||||
native-endianness
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-uchar-set!
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-native-set!
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-native-set!
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
c-bytevector-ieee-double-set!
|
||||
c-bytevector-ieee-double-ref
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-native-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(scheme inexact)
|
||||
(foreign c-bytevectors)
|
||||
(foreign c ypsilon-primitives))
|
||||
(include "c/define-c-library.scm")
|
||||
(include "c/libc.scm")
|
||||
(include "c.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/array.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/array.sld
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/array.sld"
|
||||
(library
|
||||
(foreign c array)
|
||||
(export make-c-array c-array-ref c-array-set! list->c-array c-array->list)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context))
|
||||
(include "array.scm"))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,11 +0,0 @@
|
|||
(define c-type-signed?
|
||||
(lambda (type)
|
||||
(if (member type '(int8 int16 int32 int64 char short int long float double))
|
||||
#t
|
||||
#f)))
|
||||
|
||||
(define c-type-unsigned?
|
||||
(lambda (type)
|
||||
(if (member type '(uint8 uint16 uint32 uint64 unsigned-char unsigned-short unsigned-int unsigned-long))
|
||||
#t
|
||||
#f)))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chez-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chez-primitives.sld
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/chez-primitives.sld"
|
||||
(library
|
||||
(foreign c chez-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!
|
||||
foreign-procedure
|
||||
type->native-type)
|
||||
(import (chezscheme))
|
||||
(include "chez-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chibi-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chibi-primitives.sld
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chicken-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/chicken-primitives.sld
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/chicken-primitives.sld"
|
||||
(library
|
||||
(foreign c chicken-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!
|
||||
foreign-declare
|
||||
foreign-safe-lambda
|
||||
void
|
||||
pointer?
|
||||
foreign-declare
|
||||
address->pointer
|
||||
pointer->address)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(chicken base)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random))
|
||||
(include "chicken-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/define-c-library.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/gambit-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/gambit-primitives.sld
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/gambit-primitives.sld"
|
||||
(library
|
||||
(foreign c gambit-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
define-c-callback
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (gambit) c-declare c-lambda c-define define-macro))
|
||||
(include "gambit-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/gauche-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/gauche-primitives.sld
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/gauche-primitives.sld"
|
||||
(library
|
||||
(foreign c gauche-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(gauche ffi))
|
||||
(include "gauche-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/guile-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/guile-primitives.sld
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/guile-primitives.sld"
|
||||
(library
|
||||
(foreign c guile-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!
|
||||
implementation
|
||||
os
|
||||
arch
|
||||
libc-name)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(system foreign)
|
||||
(system foreign-library)
|
||||
(foreign c-bytevectors))
|
||||
(include "guile-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/ikarus-primitives.sld
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/ikarus-primitives.sld"
|
||||
(library
|
||||
(foreign c ikarus-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs files)
|
||||
(rnrs io simple)
|
||||
(rnrs programs)
|
||||
(only (rnrs bytevectors)
|
||||
make-bytevector
|
||||
bytevector-length
|
||||
utf8->string
|
||||
string->utf8
|
||||
bytevector-u8-ref
|
||||
bytevector-u8-set!)
|
||||
(only (rnrs r5rs) remainder quotient)
|
||||
(ikarus include)
|
||||
(ikarus foreign))
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) 2)
|
||||
((eq? type 'unsigned-short) 2)
|
||||
((eq? type 'int) 4)
|
||||
((eq? type 'unsigned-int) 4)
|
||||
((eq? type 'long) 8)
|
||||
((eq? type 'unsigned-long) 8)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) 8)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
(define align-of-type size-of-type)
|
||||
(define (type->native-type type)
|
||||
(cond
|
||||
((equal? type 'int8) 'signed-char)
|
||||
((equal? type 'uint8) 'unsigned-char)
|
||||
((equal? type 'int16) 'signed-short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'signed-int)
|
||||
((equal? type 'uint32) 'unsigned-int)
|
||||
((equal? type 'int64) 'signed-long)
|
||||
((equal? type 'uint64) 'unsigned-long)
|
||||
((equal? type 'char) 'signed-char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'signed-short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'signed-int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'signed-long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'pointer)
|
||||
((equal? type 'void) 'void)
|
||||
(error "Unsupported type: " type)))
|
||||
(define c-bytevector? (lambda (object) (pointer? object)))
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
((make-c-callout
|
||||
(type->native-type return-type)
|
||||
(map type->native-type argument-types))
|
||||
(dlsym shared-object (symbol->string c-name)))))))
|
||||
(define shared-object-load (lambda (path options) (dlopen path)))
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte) (pointer-set-c-char! c-bytevector k byte)))
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k) (pointer-ref-c-unsigned-char c-bytevector k)))
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(pointer-set-c-pointer! c-bytevector k pointer)))
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k) (pointer-ref-c-pointer c-bytevector k))))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
(define type->libffi-type-number
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 2)
|
||||
((equal? type 'int16) 3)
|
||||
((equal? type 'uint16) 4)
|
||||
((equal? type 'int32) 5)
|
||||
((equal? type 'uint32) 6)
|
||||
((equal? type 'int64) 7)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 9)
|
||||
((equal? type 'unsigned-char) 10)
|
||||
((equal? type 'short) 11)
|
||||
((equal? type 'unsigned-short) 12)
|
||||
((equal? type 'int) 13)
|
||||
((equal? type 'unsigned-int) 14)
|
||||
((equal? type 'long) 15)
|
||||
((equal? type 'unsigned-long) 16)
|
||||
((equal? type 'float) 17)
|
||||
((equal? type 'double) 18)
|
||||
((equal? type 'void) 19)
|
||||
((equal? type 'pointer) 20)
|
||||
((equal? type 'pointer-address) 21)
|
||||
((equal? type 'callback) 22)
|
||||
(else (error "Undefined type" type)))))
|
||||
|
||||
(define c-bytevector-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
|
||||
((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
|
||||
((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
|
||||
((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
|
||||
((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
|
||||
((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
|
||||
((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
|
||||
((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
|
||||
((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
|
||||
((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
|
||||
((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
|
||||
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
|
||||
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
|
||||
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
|
||||
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
|
||||
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
|
||||
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
|
||||
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
|
||||
((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
|
||||
((not (equal? type 'void)) (error "No such foreign type" type))
|
||||
;; Return unspecified on purpose if type is void
|
||||
)))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/ironscheme-primitives.sld
|
||||
|
|
@ -1,118 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/ironscheme-primitives.sld"
|
||||
(library
|
||||
(foreign c ironscheme-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs files)
|
||||
(rnrs io simple)
|
||||
(rnrs programs)
|
||||
(only (rnrs bytevectors)
|
||||
make-bytevector
|
||||
bytevector-length
|
||||
utf8->string
|
||||
string->utf8
|
||||
bytevector-u8-ref
|
||||
bytevector-u8-set!)
|
||||
(only (rnrs r5rs) remainder quotient)
|
||||
(ironscheme)
|
||||
(ironscheme clr)
|
||||
(ironscheme clr internal)
|
||||
(ironscheme ffi)
|
||||
(srfi :0))
|
||||
(clr-using System.Runtime.InteropServices)
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) 2)
|
||||
((eq? type 'unsigned-short) 2)
|
||||
((eq? type 'int) 4)
|
||||
((eq? type 'unsigned-int) 4)
|
||||
((eq? type 'long) 8)
|
||||
((eq? type 'unsigned-long) 8)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) 8)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
(define align-of-type size-of-type)
|
||||
(define (type->native-type type)
|
||||
(cond
|
||||
((equal? type 'int8) 'int8)
|
||||
((equal? type 'uint8) 'uint8)
|
||||
((equal? type 'int16) 'int16)
|
||||
((equal? type 'uint16) 'uint16)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'uint32)
|
||||
((equal? type 'int64) 'in64)
|
||||
((equal? type 'uint64) 'uint64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'uchar)
|
||||
((equal? type 'short) 'int16)
|
||||
((equal? type 'unsigned-short) 'uint16)
|
||||
((equal? type 'int) 'int32)
|
||||
((equal? type 'unsigned-int) 'uint32)
|
||||
((equal? type 'long) 'int64)
|
||||
((equal? type 'unsigned-long) 'uint64)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'pointer) 'void*)
|
||||
(error "Unsupported type: " type)))
|
||||
(define c-bytevector? (lambda (object) (pointer? object)))
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
((make-ffi-callout
|
||||
(type->native-type return-type)
|
||||
(map type->native-type argument-types))
|
||||
(cond-expand
|
||||
(windows (dlsym shared-object (symbol->string c-name)))
|
||||
(else (apply (pinvoke-call libc dlsym void* (void* string))
|
||||
(list shared-object (symbol->string c-name))))))))))
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(cond-expand
|
||||
(windows (dlopen path))
|
||||
(else (apply (pinvoke-call libc dlopen void* (string int)) (list path 0))))))
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(clr-static-call
|
||||
Marshal
|
||||
(WriteByte IntPtr Int32 Byte)
|
||||
c-bytevector
|
||||
k
|
||||
(clr-static-call Convert (ToByte Int32) byte))))
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(clr-static-call
|
||||
Convert
|
||||
(ToInt32 Byte)
|
||||
(clr-static-call Marshal (ReadByte IntPtr Int32) c-bytevector k))))
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer) (write-intptr! c-bytevector k pointer)))
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k) (read-intptr c-bytevector k))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/kawa-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/kawa-primitives.sld
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/kawa-primitives.sld"
|
||||
(library
|
||||
(foreign c kawa-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context))
|
||||
(include "kawa-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/larceny-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/larceny-primitives.sld
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/larceny-primitives.sld"
|
||||
(library
|
||||
(foreign c larceny-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(rnrs base)
|
||||
(rnrs lists)
|
||||
(rnrs control)
|
||||
(rnrs files)
|
||||
(rnrs io simple)
|
||||
(rnrs programs)
|
||||
(only (rnrs bytevectors)
|
||||
make-bytevector
|
||||
bytevector-length
|
||||
utf8->string
|
||||
string->utf8
|
||||
bytevector-u8-ref
|
||||
bytevector-u8-set!)
|
||||
(only (rnrs r5rs) remainder quotient)
|
||||
(rename (primitives r5rs:require) (r5rs:require require))
|
||||
(primitives std-ffi)
|
||||
(primitives foreign-procedure)
|
||||
(primitives foreign-file)
|
||||
(primitives foreign-stdlib)
|
||||
(primitives system-interface))
|
||||
(include "larceny-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/libc.scm
|
||||
|
|
@ -1,168 +0,0 @@
|
|||
(define c-type-size
|
||||
(lambda (type)
|
||||
(size-of-type type)))
|
||||
|
||||
(define c-type-align
|
||||
(lambda (type)
|
||||
(align-of-type type)))
|
||||
|
||||
(define foreign-c:string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(cond-expand
|
||||
(gambit #t) ; Defined in gambit.scm
|
||||
(chicken #t) ; Defined in chicken.scm
|
||||
(cyclone #t) ; Defined in cyclone.scm
|
||||
(else
|
||||
(define-syntax define-c-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(define scheme-name
|
||||
(let* ((internal-options (if (null? 'options)
|
||||
(list)
|
||||
(cadr 'options)))
|
||||
(additional-paths (if (assoc 'additional-paths internal-options)
|
||||
(cadr (assoc 'additional-paths internal-options))
|
||||
(list)))
|
||||
(additional-versions (if (assoc 'additional-versions internal-options)
|
||||
(map (lambda (version)
|
||||
(if (number? version)
|
||||
(number->string version)
|
||||
version))
|
||||
(cadr (assoc 'additional-versions internal-options)))
|
||||
(list)))
|
||||
(slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
(auto-load-paths
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
|
||||
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
|
||||
(list))
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(foreign-c:string-split (get-environment-variable "PATH") #\;)
|
||||
(list))
|
||||
(if (get-environment-variable "PWD")
|
||||
(list (get-environment-variable "PWD"))
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
|
||||
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
|
||||
(list))
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
|
||||
(list))
|
||||
(list
|
||||
;;; x86-64
|
||||
; Debian
|
||||
"/lib/x86_64-linux-gnu"
|
||||
"/usr/lib/x86_64-linux-gnu"
|
||||
"/usr/local/lib"
|
||||
; Fedora/Alpine
|
||||
"/usr/lib"
|
||||
"/usr/lib64"
|
||||
;;; aarch64
|
||||
; Debian
|
||||
"/lib/aarch64-linux-gnu"
|
||||
"/usr/lib/aarch64-linux-gnu"
|
||||
"/usr/local/lib"
|
||||
; Fedora/Alpine
|
||||
"/usr/lib"
|
||||
"/usr/lib64"
|
||||
; NetBSD
|
||||
"/usr/pkg/lib"
|
||||
; Haiku
|
||||
"/boot/system/lib")))))
|
||||
(auto-load-versions (list ""))
|
||||
(paths (append auto-load-paths additional-paths))
|
||||
(versions (append additional-versions auto-load-versions))
|
||||
(platform-lib-prefix (cond-expand (windows "") (else "lib")))
|
||||
(platform-file-extension (cond-expand (windows ".dll") (else ".so")))
|
||||
(shared-object #f)
|
||||
(searched-paths (list)))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path
|
||||
(string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
(cond-expand
|
||||
(windows "")
|
||||
(else platform-file-extension))
|
||||
(if (string=? version "")
|
||||
""
|
||||
(string-append
|
||||
(cond-expand (windows "-")
|
||||
(else "."))
|
||||
version))
|
||||
(cond-expand
|
||||
(windows platform-file-extension)
|
||||
(else ""))))
|
||||
(library-path-without-suffixes (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name)))
|
||||
(set! searched-paths (append searched-paths (list library-path)))
|
||||
(when (and (not shared-object)
|
||||
(file-exists? library-path))
|
||||
(set! shared-object
|
||||
(cond-expand (racket library-path-without-suffixes)
|
||||
(else library-path))))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(begin
|
||||
(display "Could not load shared object: ")
|
||||
(write (list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(newline)
|
||||
(display "Searched paths: ")
|
||||
(write searched-paths)
|
||||
(newline)
|
||||
(exit 1))
|
||||
(cond-expand
|
||||
(stklos shared-object)
|
||||
(else (shared-object-load shared-object
|
||||
`((additional-versions ,additional-versions)))))))))))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/mit-scheme-primitives.sld
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/mit-scheme-primitives.sld"
|
||||
(library
|
||||
(foreign c mit-scheme-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
define-c-callback
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context))
|
||||
(declare (usual-integrations))
|
||||
(load-option 'ffi)
|
||||
(C-include "mit-scheme-foreign-c")
|
||||
(define (hello) (puts "Hello from puts") (newline)))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/mosh-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/mosh-primitives.sld
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/mosh-primitives.sld"
|
||||
(library
|
||||
(foreign c mosh-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(mosh ffi))
|
||||
(include "mosh-primitives.scm"))
|
||||
|
|
@ -1,149 +0,0 @@
|
|||
(define-c-library libc
|
||||
'("stdlib.h" "stdio.h" "string.h")
|
||||
libc-name
|
||||
'((additional-versions ("0" "6"))))
|
||||
|
||||
(define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
|
||||
(cond-expand
|
||||
(gambit
|
||||
(define c-memset-address->pointer
|
||||
(c-lambda (unsigned-int64 unsigned-int8 int)
|
||||
(pointer void)
|
||||
"___return(memset((void*)___arg1, ___arg2, ___arg3));")))
|
||||
(chicken
|
||||
(define c-memset-address->pointer
|
||||
(lambda (address value offset)
|
||||
(address->pointer address))))
|
||||
(else
|
||||
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))))
|
||||
|
||||
(cond-expand
|
||||
(gambit
|
||||
(define c-memset-pointer->address
|
||||
(c-lambda ((pointer void) unsigned-int8 int)
|
||||
unsigned-int64
|
||||
"___return((uint64_t)memset(___arg1, ___arg2, ___arg3));")))
|
||||
(chicken (define c-memset-pointer->address
|
||||
(lambda (pointer value offset)
|
||||
(pointer->address pointer))))
|
||||
(else (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))))
|
||||
;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
|
||||
;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
|
||||
(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
|
||||
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
|
||||
|
||||
(define make-c-bytevector
|
||||
(lambda (k . byte)
|
||||
(if (null? byte)
|
||||
(c-malloc k)
|
||||
(bytevector->c-bytevector (make-bytevector k (car byte))))))
|
||||
|
||||
(define c-bytevector
|
||||
(lambda bytes
|
||||
(bytevector->c-bytevector (apply bytevector bytes))))
|
||||
|
||||
(cond-expand
|
||||
(else (define-c-procedure c-free libc 'free 'void '(pointer))))
|
||||
|
||||
(define bytevector->c-bytevector
|
||||
(lambda (bytes)
|
||||
(letrec* ((bytes-length (bytevector-length bytes))
|
||||
(pointer (make-c-bytevector bytes-length))
|
||||
(looper (lambda (index)
|
||||
(when (< index bytes-length)
|
||||
(c-bytevector-u8-set! pointer
|
||||
index
|
||||
(bytevector-u8-ref bytes index))
|
||||
(looper (+ index 1))))))
|
||||
(looper 0)
|
||||
pointer)))
|
||||
|
||||
(define c-bytevector->bytevector
|
||||
(lambda (pointer size)
|
||||
(letrec* ((bytes (make-bytevector size))
|
||||
(looper (lambda (index)
|
||||
(let ((byte (c-bytevector-u8-ref pointer index)))
|
||||
(if (= index size)
|
||||
bytes
|
||||
(begin
|
||||
(bytevector-u8-set! bytes index byte)
|
||||
(looper (+ index 1))))))))
|
||||
(looper 0))))
|
||||
|
||||
(define c-string-length
|
||||
(lambda (bytevector-var)
|
||||
(c-strlen bytevector-var)))
|
||||
|
||||
(define c-utf8->string
|
||||
(lambda (c-bytevector)
|
||||
(when (c-null? c-bytevector)
|
||||
(error "Can not turn null pointer into string" c-bytevector))
|
||||
(let ((size (c-strlen c-bytevector)))
|
||||
(utf8->string (c-bytevector->bytevector c-bytevector size)))))
|
||||
|
||||
(define string->c-utf8
|
||||
(lambda (string-var)
|
||||
(bytevector->c-bytevector
|
||||
(string->utf8 (string-append string-var (string #\null))))))
|
||||
|
||||
(cond-expand
|
||||
(chicken #t) ; FIXME
|
||||
(kawa #t) ; FIXME
|
||||
;(chibi #t)
|
||||
(else (define make-c-null
|
||||
(lambda ()
|
||||
(cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
|
||||
(free-bytes pointer)
|
||||
pointer))
|
||||
(else (c-memset-address->pointer 0 0 0)))))))
|
||||
|
||||
(cond-expand
|
||||
(chicken #t) ; FIXME
|
||||
(kawa #t) ; FIXME
|
||||
(chibi #t)
|
||||
(gauche (define c-null? pointer-null?))
|
||||
(stklos (define c-null?
|
||||
(lambda (pointer)
|
||||
(cond ((void? pointer) #t)
|
||||
((= (c-memset-pointer->address pointer 0 0) 0) #t)
|
||||
(else #f)))))
|
||||
(else (define c-null?
|
||||
(lambda (pointer)
|
||||
(if (c-bytevector? pointer)
|
||||
(= (c-memset-pointer->address pointer 0 0) 0)
|
||||
#f)))))
|
||||
|
||||
(define c-bytevector->address
|
||||
(lambda (c-bytevector)
|
||||
(c-memset-pointer->address c-bytevector 0 0)))
|
||||
|
||||
#;(define address->c-bytevector
|
||||
(lambda (address)
|
||||
(c-memset-address->pointer address 0 0)))
|
||||
|
||||
#;(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(c-bytevector-uint-set! c-bytevector
|
||||
0
|
||||
(c-bytevector->address pointer)
|
||||
(native-endianness)
|
||||
(c-type-size 'pointer))))
|
||||
|
||||
#;(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(address->c-bytevector (c-bytevector-uint-ref c-bytevector
|
||||
0
|
||||
(native-endianness)
|
||||
(c-type-size 'pointer)))))
|
||||
|
||||
(cond-expand
|
||||
;(kawa #t) ; Defined in kawa.scm
|
||||
(else (define-syntax call-with-address-of
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
||||
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
|
||||
(let ((result (apply thunk (list address-pointer))))
|
||||
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
|
||||
(c-free address-pointer)
|
||||
result)))))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/cyclone-primitives.sld
|
||||
|
|
@ -1,281 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/cyclone-primitives.sld"
|
||||
(library
|
||||
(foreign c primitives-cyclone)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
define-c-callback
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives))
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) int)
|
||||
((equal? type 'uint8) int)
|
||||
((equal? type 'int16) int)
|
||||
((equal? type 'uint16) int)
|
||||
((equal? type 'int32) int)
|
||||
((equal? type 'uint32) int)
|
||||
((equal? type 'int64) int)
|
||||
((equal? type 'uint64) int)
|
||||
((equal? type 'char) char)
|
||||
((equal? type 'unsigned-char) char)
|
||||
((equal? type 'short) int)
|
||||
((equal? type 'unsigned-short) int)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) int)
|
||||
((equal? type 'long) int)
|
||||
((equal? type 'unsigned-long) int)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) opaque)
|
||||
((equal? type 'void) c-void)
|
||||
((equal? type 'callback) opaque)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
(define c-bytevector? (lambda (object) (opaque? object)))
|
||||
(define-syntax define-c-procedure
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) 'int)
|
||||
((equal? type 'uint8) 'int)
|
||||
((equal? type 'int16) 'int)
|
||||
((equal? type 'uint16) 'int)
|
||||
((equal? type 'int32) 'int)
|
||||
((equal? type 'uint32) 'int)
|
||||
((equal? type 'int64) 'int)
|
||||
((equal? type 'uint64) 'int)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'opaque)
|
||||
((equal? type 'void) 'c-void)
|
||||
((equal? type 'callback) 'opaque)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
(scheme-name (cadr expr))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type
|
||||
(type->native-type
|
||||
(car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types) '() (map type->native-type types)))))
|
||||
(if (null? argument-types)
|
||||
`(c-define ,scheme-name ,return-type ,c-name)
|
||||
`(c-define ,scheme-name ,return-type ,c-name ,@argument-types))))))
|
||||
(define define-c-callback
|
||||
(lambda (scheme-name return-type argument-types procedure)
|
||||
(error "define-callback not yet implemented on Cyclone")))
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (c-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (c-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (c-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (c-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (c-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (c-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (c-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (c-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (c-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (c-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (c-value "sizeof(float)" int))
|
||||
((equal? type 'double) (c-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
|
||||
(define align-of-type size-of-type)
|
||||
(define-c
|
||||
pointer-address
|
||||
"(void *data, int argc, closure _, object k, object pointer)"
|
||||
"make_c_opaque(opq, &(void*)opaque_ptr(pointer));\n return_closcall1(data, k, &opq);")
|
||||
(define pointer-null (lambda () (make-opaque)))
|
||||
(define-syntax define-c-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(begin (define scheme-name #t) (shared-object-load headers)))))
|
||||
(define-syntax shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cadr (cadr expr)))
|
||||
(includes
|
||||
(map (lambda (header)
|
||||
`(include-c-header ,(string-append "<" header ">")))
|
||||
headers)))
|
||||
`(,@includes)))))
|
||||
(define pointer-null?
|
||||
(lambda (pointer) (and (opaque? pointer) (opaque-null? pointer))))
|
||||
(define-c
|
||||
pointer-int8-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-uint8-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-int16-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-uint16-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-int32-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-uint32-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-int64-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-uint64-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-char-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"char* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2char(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-short-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"short* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-unsigned-short-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-int-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-unsigned-int-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-long-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"long* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-unsigned-long-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = obj_obj2int(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-float-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"float* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = double_value(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-double-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"double* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = double_value(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
c-bytevector-pointer-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset); *p = (uintptr_t)&opaque_ptr(value); return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
(define-c
|
||||
pointer-int8-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-uint8-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-int16-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-uint16-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-int32-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-uint32-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-int64-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-uint64-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-char-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"char* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_char2obj(*p));")
|
||||
(define-c
|
||||
pointer-short-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"short* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-unsigned-short-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-int-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-unsigned-int-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-long-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"long* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-unsigned-long-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); return_closcall1(data, k, obj_int2obj(*p));")
|
||||
(define-c
|
||||
pointer-float-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"float* p = opaque_ptr(pointer) + obj_obj2int(offset); alloca_double(d, *p); return_closcall1(data, k, d);")
|
||||
(define-c
|
||||
pointer-double-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"double* p = opaque_ptr(pointer) + obj_obj2int(offset); alloca_double(d, *p); return_closcall1(data, k, d);")
|
||||
(define-c
|
||||
c-bytevector-pointer-ref
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset)); return_closcall1(data, k, &opq);")
|
||||
(define c-bytevector-u8-set! pointer-uint8-set!)
|
||||
(define c-bytevector-u8-ref pointer-uint8-get))
|
||||
|
|
@ -1,124 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (size-of-int8_t))
|
||||
((eq? type 'uint8) (size-of-uint8_t))
|
||||
((eq? type 'int16) (size-of-int16_t))
|
||||
((eq? type 'uint16) (size-of-uint16_t))
|
||||
((eq? type 'int32) (size-of-int32_t))
|
||||
((eq? type 'uint32) (size-of-uint32_t))
|
||||
((eq? type 'int64) (size-of-int64_t))
|
||||
((eq? type 'uint64) (size-of-uint64_t))
|
||||
((eq? type 'char) (size-of-char))
|
||||
((eq? type 'unsigned-char) (size-of-char))
|
||||
((eq? type 'short) (size-of-short))
|
||||
((eq? type 'unsigned-short) (size-of-unsigned-short))
|
||||
((eq? type 'int) (size-of-int))
|
||||
((eq? type 'unsigned-int) (size-of-unsigned-int))
|
||||
((eq? type 'long) (size-of-long))
|
||||
((eq? type 'unsigned-long) (size-of-unsigned-long))
|
||||
((eq? type 'float) (size-of-float))
|
||||
((eq? type 'double) (size-of-double))
|
||||
((eq? type 'pointer) (size-of-pointer))
|
||||
((eq? type 'pointer-address) (size-of-pointer))
|
||||
((eq? type 'callback) (size-of-pointer))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (align-of-int8_t))
|
||||
((eq? type 'uint8) (align-of-uint8_t))
|
||||
((eq? type 'int16) (align-of-int16_t))
|
||||
((eq? type 'uint16) (align-of-uint16_t))
|
||||
((eq? type 'int32) (align-of-int32_t))
|
||||
((eq? type 'uint32) (align-of-uint32_t))
|
||||
((eq? type 'int64) (align-of-int64_t))
|
||||
((eq? type 'uint64) (align-of-uint64_t))
|
||||
((eq? type 'char) (align-of-char))
|
||||
((eq? type 'unsigned-char) (align-of-char))
|
||||
((eq? type 'short) (align-of-short))
|
||||
((eq? type 'unsigned-short) (align-of-unsigned-short))
|
||||
((eq? type 'int) (align-of-int))
|
||||
((eq? type 'unsigned-int) (align-of-unsigned-int))
|
||||
((eq? type 'long) (align-of-long))
|
||||
((eq? type 'unsigned-long) (align-of-unsigned-long))
|
||||
((eq? type 'float) (align-of-float))
|
||||
((eq? type 'double) (align-of-double))
|
||||
((eq? type 'pointer) (align-of-pointer))
|
||||
((eq? type 'pointer-address) (align-of-pointer))
|
||||
((eq? type 'callback) (align-of-pointer))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(let ((shared-object (dlopen path RTLD-NOW))
|
||||
(maybe-error (dlerror)))
|
||||
shared-object)))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(or (equal? object #f) ; False can be null pointer
|
||||
(pointer? object))))
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) '(maybe-null pointer void*))
|
||||
((equal? type 'pointer-address) '(maybe-null pointer void*))
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(maybe-null pointer void*))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
;; define-c-procedure
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(lambda arguments
|
||||
(let* ((return-pointer
|
||||
(internal-ffi-call (length argument-types)
|
||||
(type->libffi-type-number return-type)
|
||||
(map type->libffi-type-number argument-types)
|
||||
c-function
|
||||
(c-type-size return-type)
|
||||
arguments)))
|
||||
(c-bytevector-get return-pointer return-type 0))))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define make-c-callback
|
||||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback return-type 'argument-types procedure)))))
|
||||
|
|
@ -1,206 +0,0 @@
|
|||
|
||||
(define type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(c-name (symbol->string (cadr (list-ref expr 3))))
|
||||
(return-type (type->native-type (cadr (list-ref expr 4))))
|
||||
(argument-types (if (null? (cdr (list-ref expr 5)))
|
||||
(list)
|
||||
(map type->native-type
|
||||
(cadr (list-ref expr 5))))))
|
||||
(if (null? argument-types)
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name))
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(return-type (type->native-type (cadr (list-ref expr 2))))
|
||||
(argument-types (map type->native-type (cadr (list-ref expr 3))))
|
||||
(argument-names (cadr (list-ref expr 4)))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
`(,name ,type))
|
||||
argument-types argument-names))
|
||||
(procedure-body (cdr (cdr (list-ref expr 4)))))
|
||||
`(begin (define-external ,(cons 'external_123456789 arguments)
|
||||
,return-type
|
||||
(begin ,@ procedure-body))
|
||||
(define ,scheme-name (location external_123456789)))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (foreign-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (foreign-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (foreign-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (foreign-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (foreign-value "sizeof(float)" int))
|
||||
((equal? type 'double) (foreign-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
|
||||
((equal? type 'string) (foreign-value "sizeof(void*)" int))
|
||||
((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (foreign-value "_Alignof(int8_t)" int))
|
||||
((equal? type 'uint8) (foreign-value "_Alignof(uint8_t)" int))
|
||||
((equal? type 'int16) (foreign-value "_Alignof(int16_t)" int))
|
||||
((equal? type 'uint16) (foreign-value "_Alignof(uint16_t)" int))
|
||||
((equal? type 'int32) (foreign-value "_Alignof(int32_t)" int))
|
||||
((equal? type 'uint32) (foreign-value "_Alignof(uint32_t)" int))
|
||||
((equal? type 'int64) (foreign-value "_Alignof(int64_t)" int))
|
||||
((equal? type 'uint64) (foreign-value "_Alignof(uint64_t)" int))
|
||||
((equal? type 'char) (foreign-value "_Alignof(char)" int))
|
||||
((equal? type 'unsigned-char) (foreign-value "_Alignof(unsigned char)" int))
|
||||
((equal? type 'short) (foreign-value "_Alignof(short)" int))
|
||||
((equal? type 'unsigned-short) (foreign-value "_Alignof(unsigned short)" int))
|
||||
((equal? type 'int) (foreign-value "_Alignof(int)" int))
|
||||
((equal? type 'unsigned-int) (foreign-value "_Alignof(unsigned int)" int))
|
||||
((equal? type 'long) (foreign-value "_Alignof(long)" int))
|
||||
((equal? type 'unsigned-long) (foreign-value "_Alignof(unsigned long)" int))
|
||||
((equal? type 'float) (foreign-value "_Alignof(float)" int))
|
||||
((equal? type 'double) (foreign-value "_Alignof(double)" int))
|
||||
((equal? type 'pointer) (foreign-value "_Alignof(void*)" int))
|
||||
((equal? type 'string) (foreign-value "_Alignof(void*)" int))
|
||||
((equal? type 'callback) (foreign-value "_Alignof(void*)" int)))))
|
||||
|
||||
(define make-c-null
|
||||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
(define-syntax define-c-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(begin
|
||||
(define scheme-name #t)
|
||||
(shared-object-load headers)))))
|
||||
|
||||
(define-syntax shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cadr (car (cdr expr)))))
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(foreign-declare ,(string-append "#include <" header ">")))
|
||||
headers))))))
|
||||
|
||||
(define c-null?
|
||||
(lambda (pointer)
|
||||
(if (and (not (pointer? pointer))
|
||||
pointer)
|
||||
#f
|
||||
(or (not pointer) ; #f counts as null pointer on Chicken
|
||||
(= (pointer->address pointer) 0)))))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(pointer-u8-ref (pointer+ c-bytevector k))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(pointer-u8-set! (pointer+ c-bytevector k) byte)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(address->pointer (pointer-u64-ref (pointer+ c-bytevector k)))))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer))))
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
;;;; This file is dependent on content of other files added trough (include...)
|
||||
;;;; And that's why it is separated
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(lambda arguments
|
||||
(let ((return-pointer (internal-ffi-call (length argument-types)
|
||||
(type->libffi-type-number return-type)
|
||||
(map type->libffi-type-number argument-types)
|
||||
c-function
|
||||
(size-of-type return-type)
|
||||
arguments)))
|
||||
(c-bytevector-get return-pointer return-type 0))))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
|
@ -1,132 +0,0 @@
|
|||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) uint8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) uint16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) uint32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) uint64)
|
||||
((equal? type 'char) int8)
|
||||
((equal? type 'unsigned-char) uint8)
|
||||
((equal? type 'short) short)
|
||||
((equal? type 'unsigned-short) unsigned-short)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) unsigned-int)
|
||||
((equal? type 'long) long)
|
||||
((equal? type 'unsigned-long) unsigned-long)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'callback) '*)
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(foreign-library-function shared-object
|
||||
(symbol->string c-name)
|
||||
#:return-type (type->native-type return-type)
|
||||
#:arg-types (map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(procedure->pointer (type->native-type return-type)
|
||||
procedure
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (type->native-type type)))
|
||||
(cond ((equal? native-type void) 0)
|
||||
(native-type (sizeof native-type))
|
||||
(else #f)))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (type->native-type type)))
|
||||
(cond ((equal? native-type void) 0)
|
||||
(native-type (alignof native-type))
|
||||
(else #f)))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
|
||||
(bytevector-u8-set! p k byte))))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
|
||||
(bytevector-u8-ref p k))))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(c-bytevector-uint-set! c-bytevector
|
||||
k
|
||||
(pointer-address pointer)
|
||||
(native-endianness)
|
||||
(size-of-type 'pointer))))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(make-pointer (c-bytevector-uint-ref c-bytevector
|
||||
k
|
||||
(native-endianness)
|
||||
(size-of-type 'pointer)))))
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'uint8) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
|
||||
((equal? type 'short) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
|
||||
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
|
||||
|
||||
#;(define pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
|
||||
((equal? type 'uint8) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
|
||||
((equal? type 'short) (bytevector-s8-ref p offset))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
||||
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))
|
||||
|
|
@ -1,217 +0,0 @@
|
|||
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
||||
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
|
||||
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
(define INTEGER-MAX-VALUE (static-field java.lang.Integer 'MAX_VALUE))
|
||||
|
||||
(define value->object
|
||||
(lambda (value type)
|
||||
(cond ((equal? type 'byte)
|
||||
(java.lang.Byte value))
|
||||
((equal? type 'int8)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'uint8)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'unsigned-short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'unsigned-int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'unsigned-long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'float)
|
||||
(java.lang.Float value))
|
||||
((equal? type 'double)
|
||||
(java.lang.Double value))
|
||||
((equal? type 'char)
|
||||
(java.lang.Char value))
|
||||
(else value))))
|
||||
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1))
|
||||
((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2))
|
||||
((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2))
|
||||
((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8))
|
||||
((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8))
|
||||
((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1))
|
||||
((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1))
|
||||
((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2))
|
||||
((equal? type 'unsigned-short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2))
|
||||
((equal? type 'int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'unsigned-int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8))
|
||||
((equal? type 'unsigned-long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8))
|
||||
((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4))
|
||||
((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8))
|
||||
((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1))
|
||||
((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(string=? (invoke (invoke object 'getClass) 'getName)
|
||||
"jdk.internal.foreign.NativeMemorySegmentImpl")))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(lambda vals
|
||||
(invoke (invoke (cdr (assoc 'linker shared-object))
|
||||
'downcallHandle
|
||||
(invoke (invoke (cdr (assoc 'lookup shared-object))
|
||||
'find
|
||||
(symbol->string c-name))
|
||||
'orElseThrow)
|
||||
(if (equal? return-type 'void)
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
|
||||
(map type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(type->native-type return-type)
|
||||
(map type->native-type argument-types))))
|
||||
'invokeWithArguments
|
||||
(map value->object vals argument-types)))))))
|
||||
|
||||
(define range
|
||||
(lambda (from to)
|
||||
(letrec*
|
||||
((looper
|
||||
(lambda (count result)
|
||||
(if (= count to)
|
||||
(append result (list count))
|
||||
(looper (+ count 1) (append result (list count)))))))
|
||||
(looper from (list)))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(let* ((callback-procedure
|
||||
(lambda (arg1 . args)
|
||||
(try-catch (begin (apply procedure (append (list arg1) args)))
|
||||
(ex <java.lang.Throwable> #f))))
|
||||
(function-descriptor
|
||||
(let ((function-descriptor
|
||||
(if (equal? return-type 'void)
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
|
||||
(map type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(type->native-type return-type)
|
||||
(map type->native-type argument-types)))))
|
||||
(write function-descriptor)
|
||||
(newline)
|
||||
(write (invoke function-descriptor 'getClass))
|
||||
(newline)
|
||||
(write function-descriptor)
|
||||
(newline)
|
||||
function-descriptor))
|
||||
;(method-type (invoke function-descriptor 'toMethodType))
|
||||
(method-type (field callback-procedure 'applyMethodType))
|
||||
(method-handle
|
||||
(let* ((method-handle (field callback-procedure 'applyToConsumerDefault)))
|
||||
(write method-handle)
|
||||
(newline)
|
||||
method-handle)))
|
||||
(invoke native-linker 'upcallStub method-handle function-descriptor arena))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (type->native-type type)))
|
||||
(if native-type
|
||||
(invoke native-type 'byteAlignment)
|
||||
#f))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (type->native-type type)))
|
||||
(if native-type
|
||||
(invoke native-type 'byteAlignment)
|
||||
#f))))
|
||||
|
||||
(define make-c-null
|
||||
(lambda ()
|
||||
(static-field java.lang.foreign.MemorySegment 'NULL)))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(let* ((library-file (make java.io.File path))
|
||||
(file-name (invoke library-file 'getName))
|
||||
(library-parent-folder (make java.io.File (invoke library-file 'getParent)))
|
||||
(absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath)
|
||||
"/"
|
||||
file-name))
|
||||
(linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
(lookup (invoke-static java.lang.foreign.SymbolLookup
|
||||
'libraryLookup
|
||||
absolute-path
|
||||
arena)))
|
||||
(list (cons 'linker linker)
|
||||
(cons 'lookup lookup)))))
|
||||
|
||||
(define null-pointer (make-c-null))
|
||||
(define c-null?
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'equals null-pointer)))
|
||||
|
||||
(define u8-value-layout
|
||||
(invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE)
|
||||
'withByteAlignment
|
||||
1))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE)
|
||||
'set
|
||||
u8-value-layout
|
||||
k
|
||||
byte)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(invoke (java.lang.Byte 1)
|
||||
'toUnsignedInt
|
||||
(invoke
|
||||
(invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE)
|
||||
'get
|
||||
u8-value-layout
|
||||
k))))
|
||||
|
||||
(define pointer-value-layout
|
||||
(invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS)
|
||||
'withByteAlignment
|
||||
8))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE)
|
||||
'set
|
||||
pointer-value-layout
|
||||
k
|
||||
pointer)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE)
|
||||
'get
|
||||
pointer-value-layout
|
||||
k)))
|
||||
|
||||
#;(define-syntax call-with-address-of-c-bytevector
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
||||
(pointer-set! address-pointer 'pointer 0 input-pointer)
|
||||
(apply thunk (list address-pointer))
|
||||
(set! input-pointer (pointer-get address-pointer 'pointer 0))
|
||||
(c-free address-pointer)))))
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) size-of-short)
|
||||
((eq? type 'unsigned-short) size-of-unsigned-short)
|
||||
((eq? type 'int) size-of-int)
|
||||
((eq? type 'unsigned-int) size-of-unsigned-int)
|
||||
((eq? type 'long) size-of-long)
|
||||
((eq? type 'unsigned-long) size-of-unsigned-long)
|
||||
((eq? type 'float) size-of-float)
|
||||
((eq? type 'double) size-of-double)
|
||||
((eq? type 'pointer) size-of-pointer)
|
||||
((eq? type 'callback) size-of-pointer)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) align-of-short)
|
||||
((eq? type 'unsigned-short) align-of-short)
|
||||
((eq? type 'int) align-of-int)
|
||||
((eq? type 'unsigned-int) align-of-int)
|
||||
((eq? type 'long) align-of-long)
|
||||
((eq? type 'unsigned-long) align-of-unsigned-long)
|
||||
((eq? type 'float) align-of-float)
|
||||
((eq? type 'double) align-of-double)
|
||||
((eq? type 'pointer) align-of-void*)
|
||||
((eq? type 'callback) align-of-void*)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8)
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (pointer offset value)
|
||||
(pointer-set-c-pointer! pointer offset value)))
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (pointer offset)
|
||||
(pointer-ref-c-pointer pointer offset)))
|
||||
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(type->native-type return-type)
|
||||
c-name
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (type->native-type return-type)
|
||||
(map type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
|
@ -1,149 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) size-of-int8_t)
|
||||
((eq? type 'uint8) size-of-uint8_t)
|
||||
((eq? type 'int16) size-of-int16_t)
|
||||
((eq? type 'uint16) size-of-uint16_t)
|
||||
((eq? type 'int32) size-of-int32_t)
|
||||
((eq? type 'uint32) size-of-uint32_t)
|
||||
((eq? type 'int64) size-of-int64_t)
|
||||
((eq? type 'uint64) size-of-uint64_t)
|
||||
((eq? type 'char) size-of-char)
|
||||
((eq? type 'unsigned-char) size-of-char)
|
||||
((eq? type 'short) size-of-short)
|
||||
((eq? type 'unsigned-short) size-of-unsigned-short)
|
||||
((eq? type 'int) size-of-int)
|
||||
((eq? type 'unsigned-int) size-of-unsigned-int)
|
||||
((eq? type 'long) size-of-long)
|
||||
((eq? type 'unsigned-long) size-of-unsigned-long)
|
||||
((eq? type 'float) size-of-float)
|
||||
((eq? type 'double) size-of-double)
|
||||
((eq? type 'pointer) size-of-void*)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) size-of-void*)
|
||||
(else #f))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) align-of-int8_t)
|
||||
((eq? type 'uint8) align-of-uint8_t)
|
||||
((eq? type 'int16) align-of-int16_t)
|
||||
((eq? type 'uint16) align-of-uint16_t)
|
||||
((eq? type 'int32) align-of-int32_t)
|
||||
((eq? type 'uint32) align-of-uint32_t)
|
||||
((eq? type 'int64) align-of-int64_t)
|
||||
((eq? type 'uint64) align-of-uint64_t)
|
||||
((eq? type 'char) align-of-char)
|
||||
((eq? type 'unsigned-char) align-of-char)
|
||||
((eq? type 'short) align-of-short)
|
||||
((eq? type 'unsigned-short) align-of-unsigned-short)
|
||||
((eq? type 'int) align-of-int)
|
||||
((eq? type 'unsigned-int) align-of-unsigned-int)
|
||||
((eq? type 'long) align-of-long)
|
||||
((eq? type 'unsigned-long) align-of-unsigned-long)
|
||||
((eq? type 'float) align-of-float)
|
||||
((eq? type 'double) align-of-double)
|
||||
((eq? type 'pointer) align-of-void*)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) align-of-void*)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
(else #f))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(type->native-type return-type)
|
||||
c-name
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (type->native-type return-type)
|
||||
(map type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
|
||||
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
|
||||
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
#;(define pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
|
|
@ -1,149 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (c-sizeof int8_t))
|
||||
((eq? type 'uint8) (c-sizeof uint8_t))
|
||||
((eq? type 'int16) (c-sizeof int16_t))
|
||||
((eq? type 'uint16) (c-sizeof uint16_t))
|
||||
((eq? type 'int32) (c-sizeof int32_t))
|
||||
((eq? type 'uint32) (c-sizeof uint32_t))
|
||||
((eq? type 'int64) (c-sizeof int64_t))
|
||||
((eq? type 'uint64) (c-sizeof uint64_t))
|
||||
((eq? type 'char) (c-sizeof char))
|
||||
((eq? type 'unsigned-char) (c-sizeof char))
|
||||
((eq? type 'short) (c-sizeof short))
|
||||
((eq? type 'unsigned-short) (c-sizeof unsigned-short))
|
||||
((eq? type 'int) (c-sizeof int))
|
||||
((eq? type 'unsigned-int) (c-sizeof unsigned-int))
|
||||
((eq? type 'long) (c-sizeof long))
|
||||
((eq? type 'unsigned-long) (c-sizeof unsigned-long))
|
||||
((eq? type 'float) (c-sizeof float))
|
||||
((eq? type 'double) (c-sizeof double))
|
||||
((eq? type 'pointer) (c-sizeof void*))
|
||||
((eq? type 'callback) (c-sizeof void*))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define align-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (alignof:int8_t))
|
||||
((eq? type 'uint8) (alignof:int8_t))
|
||||
((eq? type 'int16) (alignof:int16_t))
|
||||
((eq? type 'uint16) (alignof:int16_t))
|
||||
((eq? type 'int32) (alignof:int32_t))
|
||||
((eq? type 'uint32) (alignof:int32_t))
|
||||
((eq? type 'int64) (alignof:int64_t))
|
||||
((eq? type 'uint64) (alignof:int64_t))
|
||||
((eq? type 'char) (alignof:int8_t))
|
||||
((eq? type 'unsigned-char) (alignof:int8_t))
|
||||
((eq? type 'short) (alignof:short))
|
||||
((eq? type 'unsigned-short) (alignof:short))
|
||||
((eq? type 'int) (alignof:int))
|
||||
((eq? type 'unsigned-int) (alignof:int))
|
||||
((eq? type 'long) (alignof:long))
|
||||
((eq? type 'unsigned-long) (alignof:long))
|
||||
((eq? type 'float) (alignof:float))
|
||||
((eq? type 'double) (alignof:double))
|
||||
((eq? type 'pointer) (alignof:void*))
|
||||
((eq? type 'callback) (alignof:void*))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(number? object)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
;; Ypsilon for some reason does not have bytevector-c-uint8-set!
|
||||
;; or other bytevector-c-u*-set! procedures so we use
|
||||
;; bytevector-c-int8-set!
|
||||
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'uint8))
|
||||
0
|
||||
byte)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(bytevector-c-uint8-ref (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'uint8))
|
||||
0)))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(bytevector-c-void*-set! (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'pointer))
|
||||
0
|
||||
pointer)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(bytevector-c-void*-ref (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'pointer))
|
||||
0)))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(load-shared-object path)))
|
||||
|
||||
(define-macro
|
||||
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(let ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type))))))
|
||||
`(define ,scheme-name
|
||||
(c-function ,(type->native-type (cadr return-type))
|
||||
,(cadr c-name)
|
||||
,(map type->native-type (cadr argument-types)))))))
|
||||
|
||||
(define-macro
|
||||
(define-c-callback scheme-name return-type argument-types procedure)
|
||||
(let* ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
(native-return-type (type->native-type (cadr return-type)))
|
||||
(native-argument-types (map type->native-type (cadr argument-types))))
|
||||
`(define ,scheme-name
|
||||
(c-callback ,native-return-type ,native-argument-types ,procedure))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/racket-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/racket-primitives.sld
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/racket-primitives.sld"
|
||||
(library
|
||||
(foreign c racket-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type system-big-endian?)
|
||||
(ffi winapi)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)
|
||||
(ffi vector))
|
||||
(include "racket-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/sagittarius-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/sagittarius-primitives.sld
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/sagittarius-primitives.sld"
|
||||
(library
|
||||
(foreign c sagittarius-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(except (sagittarius ffi) c-free c-malloc define-c-struct)
|
||||
(sagittarius))
|
||||
(include "sagittarius-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/stklos-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/stklos-primitives.sld
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/stklos-primitives.sld"
|
||||
(library
|
||||
(foreign c stklos-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!
|
||||
get-environment-variable
|
||||
file-exists?
|
||||
make-external-function
|
||||
void?
|
||||
free-bytes)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (stklos)
|
||||
%make-callback
|
||||
make-external-function
|
||||
allocate-bytes
|
||||
free-bytes
|
||||
cpointer?
|
||||
cpointer-null?
|
||||
cpointer-data
|
||||
cpointer-data-set!
|
||||
cpointer-set-abs!
|
||||
cpointer-ref-abs
|
||||
c-size-of
|
||||
void?)
|
||||
(foreign c-bytevectors))
|
||||
(include "stklos-primitives.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/struct.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/struct.sld
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/struct.sld"
|
||||
(library
|
||||
(foreign c struct)
|
||||
(export define-c-struct c-struct->alist)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context))
|
||||
(include "struct.scm"))
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/ypsilon-primitives.scm
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../../../foreign/c/ypsilon-primitives.sld
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#!r6rs
|
||||
;; Akku.scm wrote this file based on "foreign/c/ypsilon-primitives.sld"
|
||||
(library
|
||||
(foreign c ypsilon-primitives)
|
||||
(export
|
||||
size-of-type
|
||||
align-of-type
|
||||
shared-object-load
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-pointer-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-function
|
||||
bytevector-c-int8-set!
|
||||
bytevector-c-uint8-ref)
|
||||
(import
|
||||
(scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(ypsilon c-ffi)
|
||||
(ypsilon c-types)
|
||||
(only (core)
|
||||
define-macro
|
||||
syntax-case
|
||||
bytevector-c-int8-set!
|
||||
bytevector-c-uint8-ref))
|
||||
(include "ypsilon-primitives.scm"))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue