Prepare Chicken 6 Port
This commit is contained in:
parent
a3a5daafd4
commit
9728c158bb
GPG key ID:
B38976E82C9DAE42
8 changed files with 483 additions and 207 deletions
4
.envrc
4
.envrc
|
|
@ -1,2 +1,2 @@
|
|||
use nix -p chicken chickenPackages_5.chickenEggs.r7rs chickenPackages_5.chickenEggs.rfc3339 chickenPackages_5.chickenEggs.coops chickenPackages_5.chickenEggs.test chickenPackages_5.chickenEggs.salmonella
|
||||
|
||||
export NIXPKGS_ALLOW_BROKEN=1
|
||||
use nix
|
||||
|
|
|
|||
126
nix/chicken.nix
Normal file
126
nix/chicken.nix
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
{
|
||||
pkgs,
|
||||
lib,
|
||||
stdenv,
|
||||
fetchgit,
|
||||
fetchurl,
|
||||
makeWrapper,
|
||||
darwin,
|
||||
tcc-mob,
|
||||
version ? "git",
|
||||
testers
|
||||
}:
|
||||
let
|
||||
platform = with stdenv;
|
||||
if isDarwin then "macosx"
|
||||
else if isCygwin then "cygwin"
|
||||
else if (isFreeBSD || isOpenBSD) then "bsd"
|
||||
else if isSunOS then "solaris"
|
||||
else "linux"; # Should be a sane default
|
||||
in
|
||||
stdenv.mkDerivation (finalAttrs: {
|
||||
pname = "chicken";
|
||||
inherit version;
|
||||
|
||||
binaryVersion = 12;
|
||||
|
||||
srcs = [
|
||||
(fetchgit {
|
||||
url = "git://code.call-cc.org/chicken-core";
|
||||
rev = "8b7b3124c47e018388f9f6b80bdb89813248ac76";
|
||||
sha256 = "sha256-BdZhxW6cgN5Lr1YFVZ+iejKMEvGYJ8sQlc+4DnO+Djw=";
|
||||
})
|
||||
(fetchurl {
|
||||
url = "https://code.call-cc.org/dev-snapshots/2024/07/01/chicken-6.0.0-bootstrap.tar.gz";
|
||||
sha256 = "sha256-qkcyWzsaN9+HbMBolmv7zeaPrtbaCTGa9HoF2g/3//o=";
|
||||
})
|
||||
];
|
||||
|
||||
unpackPhase = ''
|
||||
cp -r `echo $srcs | awk '{print $1}'`/* .
|
||||
cp -r `echo $srcs | awk '{print $1}'`/.* .
|
||||
chmod -R 777 .
|
||||
mkdir -p boot/snapshot
|
||||
cd boot
|
||||
tar xzf `echo $srcs | awk '{print $2}'`
|
||||
cd ..
|
||||
echo ${version} > buildid
|
||||
|
||||
cd boot/chicken-6.0.0
|
||||
case "${platform}" in
|
||||
bsd)
|
||||
mkcmd=gmake;;
|
||||
*)
|
||||
mkcmd=make;;
|
||||
esac
|
||||
export CC="${tcc-mob}/bin/tcc"
|
||||
$mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot
|
||||
$mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot install
|
||||
cd ../..
|
||||
./configure --chicken "$(pwd)"/boot/snapshot/bin/chicken --c-compiler "${tcc-mob}/bin/tcc"
|
||||
$mkcmd boot-chicken
|
||||
'';
|
||||
|
||||
# Disable two broken tests: "static link" and "linking tests"
|
||||
postPatch = ''
|
||||
sed -i tests/runtests.sh -e "/static link/,+4 { s/^/# / }"
|
||||
sed -i tests/runtests.sh -e "/linking tests/,+11 { s/^/# / }"
|
||||
'';
|
||||
|
||||
# -fno-strict-overflow is not a supported argument in clang
|
||||
hardeningDisable = lib.optionals stdenv.cc.isClang [ "strictoverflow" ];
|
||||
|
||||
makeFlags = [
|
||||
"PLATFORM=${platform}"
|
||||
"PREFIX=$(out)"
|
||||
"C_COMPILER=${tcc-mob}/bin/tcc"
|
||||
"CXX_COMPILER=$(CXX)"
|
||||
] ++ (lib.optionals stdenv.isDarwin [
|
||||
"XCODE_TOOL_PATH=${darwin.binutils.bintools}/bin"
|
||||
"LINKER_OPTIONS=-headerpad_max_install_names"
|
||||
"POSTINSTALL_PROGRAM=install_name_tool"
|
||||
]) ++ (lib.optionals (stdenv.hostPlatform != stdenv.buildPlatform) [
|
||||
"HOSTSYSTEM=${stdenv.hostPlatform.config}"
|
||||
"TARGET_C_COMPILER=${tcc-mob}/bin/${stdenv.cc.targetPrefix}tcc"
|
||||
"TARGET_CXX_COMPILER=${stdenv.cc}/bin/${stdenv.cc.targetPrefix}c++"
|
||||
]);
|
||||
|
||||
nativeBuildInputs = [
|
||||
makeWrapper
|
||||
pkgs.hostname
|
||||
tcc-mob
|
||||
] ++ lib.optionals (stdenv.isDarwin && stdenv.isAarch64) [
|
||||
darwin.autoSignDarwinBinariesHook
|
||||
];
|
||||
|
||||
configurePhase = ''
|
||||
./configure --chicken ./chicken-boot --prefix $PREFIX --platform=$PLATFORM --c-compiler "${tcc-mob}/bin/tcc"
|
||||
'';
|
||||
|
||||
doCheck = !stdenv.isDarwin;
|
||||
postCheck = ''
|
||||
./csi -R chicken.pathname -R chicken.platform \
|
||||
-p "(assert (equal? \"${toString finalAttrs.binaryVersion}\" (pathname-file (car (repository-path)))))"
|
||||
'';
|
||||
|
||||
passthru.tests.version = testers.testVersion {
|
||||
package = finalAttrs.finalPackage;
|
||||
command = "csi -version";
|
||||
};
|
||||
|
||||
meta = {
|
||||
homepage = "https://call-cc.org/";
|
||||
license = lib.licenses.bsd3;
|
||||
maintainers = with lib.maintainers; [ corngood nagy konst-aa ];
|
||||
platforms = lib.platforms.unix;
|
||||
description = "Portable compiler for the Scheme programming language";
|
||||
longDescription = ''
|
||||
CHICKEN is a compiler for the Scheme programming language.
|
||||
CHICKEN produces portable and efficient C, supports almost all
|
||||
of the R5RS Scheme language standard, and includes many
|
||||
enhancements and extensions. CHICKEN runs on Linux, macOS,
|
||||
Windows, and many Unix flavours.
|
||||
'';
|
||||
};
|
||||
|
||||
})
|
||||
129
nix/tinycc.nix
Normal file
129
nix/tinycc.nix
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
{ lib
|
||||
, copyPkgconfigItems
|
||||
, fetchFromRepoOrCz
|
||||
, makePkgconfigItem
|
||||
, perl
|
||||
, stdenv
|
||||
, texinfo
|
||||
, which
|
||||
}:
|
||||
|
||||
stdenv.mkDerivation (finalAttrs: {
|
||||
pname = "tcc-mob";
|
||||
version = "0.9.29-unstable-2024-09-16";
|
||||
|
||||
src = fetchFromRepoOrCz {
|
||||
repo = "tinycc";
|
||||
rev = "b8b6a5fd7b4e8cab8e5a5d01064cf5bf2b5eed95";
|
||||
hash = "sha256-jY0P2GErmo//YBaz6u4/jj/voOE3C2JaIDRmo0orXN8=";
|
||||
};
|
||||
|
||||
outputs = [ "out" "info" "man" ];
|
||||
|
||||
nativeBuildInputs = [
|
||||
copyPkgconfigItems
|
||||
perl
|
||||
texinfo
|
||||
which
|
||||
];
|
||||
|
||||
strictDeps = true;
|
||||
|
||||
pkgconfigItems = let
|
||||
libtcc-pcitem = {
|
||||
name = "libtcc";
|
||||
inherit (finalAttrs) version;
|
||||
cflags = [ "-I${libtcc-pcitem.variables.includedir}" ];
|
||||
libs = [
|
||||
"-L${libtcc-pcitem.variables.libdir}"
|
||||
"-Wl,--rpath ${libtcc-pcitem.variables.libdir}"
|
||||
"-ltcc"
|
||||
];
|
||||
variables = {
|
||||
prefix = "${placeholder "out"}";
|
||||
includedir = "${placeholder "dev"}/include";
|
||||
libdir = "${placeholder "lib"}/lib";
|
||||
};
|
||||
description = "Tiny C compiler backend";
|
||||
};
|
||||
in [
|
||||
(makePkgconfigItem libtcc-pcitem)
|
||||
];
|
||||
|
||||
postPatch = ''
|
||||
patchShebangs texi2pod.pl
|
||||
'';
|
||||
|
||||
configureFlags = [
|
||||
"--cc=$CC"
|
||||
"--ar=$AR"
|
||||
"--crtprefix=${lib.getLib stdenv.cc.libc}/lib"
|
||||
"--sysincludepaths=${lib.getDev stdenv.cc.libc}/include:{B}/include"
|
||||
"--libpaths=${lib.getLib stdenv.cc.libc}/lib"
|
||||
# build cross compilers
|
||||
"--enable-cross"
|
||||
] ++ lib.optionals stdenv.hostPlatform.isMusl [
|
||||
"--config-musl"
|
||||
];
|
||||
|
||||
preConfigure = let
|
||||
# To avoid "malformed 32-bit x.y.z" error on mac when using clang
|
||||
versionIsClean = version:
|
||||
builtins.match "^[0-9]\\.+[0-9]+\\.[0-9]+" version != null;
|
||||
in ''
|
||||
${
|
||||
if stdenv.isDarwin && ! versionIsClean finalAttrs.version
|
||||
then "echo 'not overwriting VERSION since it would upset ld'"
|
||||
else "echo ${finalAttrs.version} > VERSION"
|
||||
}
|
||||
configureFlagsArray+=("--elfinterp=$(< $NIX_CC/nix-support/dynamic-linker)")
|
||||
'';
|
||||
|
||||
env.NIX_CFLAGS_COMPILE = toString (lib.optionals stdenv.cc.isClang [
|
||||
"-Wno-error=implicit-int"
|
||||
"-Wno-error=int-conversion"
|
||||
]);
|
||||
|
||||
# Test segfault for static build
|
||||
doCheck = !stdenv.hostPlatform.isStatic;
|
||||
|
||||
checkTarget = "test";
|
||||
# https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10142.html
|
||||
preCheck = lib.optionalString (stdenv.isDarwin && stdenv.isx86_64) ''
|
||||
rm tests/tests2/{108,114}*
|
||||
'';
|
||||
|
||||
meta = {
|
||||
homepage = "https://repo.or.cz/tinycc.git";
|
||||
description = "Small, fast, and embeddable C compiler and interpreter";
|
||||
longDescription = ''
|
||||
TinyCC (aka TCC) is a small but hyper fast C compiler. Unlike other C
|
||||
compilers, it is meant to be self-sufficient: you do not need an external
|
||||
assembler or linker because TCC does that for you.
|
||||
|
||||
TCC compiles so fast that even for big projects Makefiles may not be
|
||||
necessary.
|
||||
|
||||
TCC not only supports ANSI C, but also most of the new ISO C99 standard
|
||||
and many GNU C extensions.
|
||||
|
||||
TCC can also be used to make C scripts, i.e. pieces of C source that you
|
||||
run as a Perl or Python script. Compilation is so fast that your script
|
||||
will be as fast as if it was an executable.
|
||||
|
||||
TCC can also automatically generate memory and bound checks while allowing
|
||||
all C pointers operations. TCC can do these checks even if non patched
|
||||
libraries are used.
|
||||
|
||||
With libtcc, you can use TCC as a backend for dynamic code generation.
|
||||
'';
|
||||
license = with lib.licenses; [ lgpl21Only ];
|
||||
mainProgram = "tcc";
|
||||
maintainers = with lib.maintainers; [ joachifm AndersonTorres ];
|
||||
platforms = lib.platforms.unix;
|
||||
# https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10199.html
|
||||
broken = stdenv.isDarwin && stdenv.isAarch64;
|
||||
};
|
||||
})
|
||||
# TODO: more multiple outputs
|
||||
# TODO: self-compilation
|
||||
34
shell.nix
Normal file
34
shell.nix
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
with import <nixpkgs> {
|
||||
overlays = [
|
||||
(final: prev: {
|
||||
tcc-mob = final.callPackage ./nix/tinycc.nix { stdenv = final.gcc13Stdenv; };
|
||||
chicken = final.callPackage ./nix/chicken.nix {
|
||||
stdenv = final.gcc13Stdenv;
|
||||
version = "6.0.0-8b7b312";
|
||||
};
|
||||
})
|
||||
];
|
||||
};
|
||||
mkShell {
|
||||
packages = with pkgs; [
|
||||
tcc-mob
|
||||
chicken
|
||||
]
|
||||
# ++ (with pkgs.chickenPackages_5.chickenEggs; [
|
||||
# apropos
|
||||
# chicken-doc
|
||||
# srfi-1
|
||||
# srfi-18
|
||||
# lsp-server
|
||||
# srfi-152
|
||||
# ])
|
||||
;
|
||||
shellHook = ''
|
||||
export CC="${pkgs.tcc-mob}/bin/tcc"
|
||||
export CHICKEN_INSTALL_PREFIX="$HOME/.chicken"
|
||||
export CHICKEN_INSTALL_REPOSITORY="$HOME/.chicken/eggs"
|
||||
export CHICKEN_REPOSITORY_PATH="${pkgs.chicken}/lib/chicken/12:$HOME/.chicken/eggs"
|
||||
export PATH="$PATH:$CHICKEN_PREFIX"
|
||||
export CHICKEN_INSTALL_PREFIX="${pkgs.chicken}"
|
||||
'';
|
||||
}
|
||||
|
|
@ -1,52 +1,51 @@
|
|||
(import (r7rs)
|
||||
(test)
|
||||
(import (test)
|
||||
(rfc3339)
|
||||
(toml))
|
||||
|
||||
(test-group "Basic"
|
||||
(let ((tdat (table-from-file "basic.toml")))
|
||||
(test "7 Key-Value-Pairs"
|
||||
7 (toml-count-key-vals tdat))
|
||||
7 (tdat 'count-key-vals))
|
||||
(test "Field name is TOML"
|
||||
"TOML" (toml-string tdat "name"))
|
||||
"TOML" (tdat 'string "name"))
|
||||
(test "Field language is Chicken Scheme"
|
||||
"Chicken Scheme" (toml-string tdat "language"))
|
||||
"Chicken Scheme" (tdat 'string "language"))
|
||||
(test "has-bool is #t"
|
||||
#t (toml-bool tdat "has-bool"))
|
||||
#t (tdat 'bool "has-bool"))
|
||||
(test "int is 5"
|
||||
5 (toml-int tdat "int"))
|
||||
5 (tdat 'int "int"))
|
||||
(test "double is 10.8"
|
||||
10.8 (toml-double tdat "double"))
|
||||
10.8 (tdat 'double "double"))
|
||||
(test "timestamp parsing"
|
||||
#(1979 05 27 07 32 00 0.0 0)
|
||||
(rfc3339->vector (toml-timestamp tdat "timestamp")))))
|
||||
(rfc3339->vector (tdat 'timestamp "timestamp")))))
|
||||
|
||||
(test-group "Table"
|
||||
(let ((tdat (table-from-file "table.toml")))
|
||||
(test "No top-level Key-Value-Pairs"
|
||||
0 (toml-count-key-vals tdat))
|
||||
0 (tdat 'count-key-vals))
|
||||
(test "One top-level table"
|
||||
1 (toml-count-tables tdat))
|
||||
(let ((servertbl (toml-table tdat "server")))
|
||||
1 (tdat 'count-tables))
|
||||
(let ((servertbl (tdat 'table "server")))
|
||||
(test "\"server\" table has 2 Key-Value-Pairs"
|
||||
2 (toml-count-key-vals servertbl))
|
||||
2 (servertbl 'count-key-vals))
|
||||
(test "host is www.example.com"
|
||||
"www.example.com" (toml-string servertbl "host"))
|
||||
"www.example.com" (servertbl 'string "host"))
|
||||
(test "timestamp parsing"
|
||||
#(2022 09 09 0 0 0 0.0 0)
|
||||
(rfc3339->vector (toml-timestamp servertbl "timestamp"))))))
|
||||
(rfc3339->vector (servertbl 'timestamp "timestamp"))))))
|
||||
|
||||
(test-group "Array"
|
||||
(let* ((tdat (table-from-file "table.toml"))
|
||||
(tserv (toml-table tdat "server"))
|
||||
(tarr (toml-array tserv "port")))
|
||||
(tserv (tdat 'table "server"))
|
||||
(tarr (tserv 'array "port")))
|
||||
(test "There is one array"
|
||||
1 (toml-count-arrays tserv))
|
||||
1 (tserv 'count-arrays))
|
||||
(test "The array has three entries"
|
||||
3 (toml-count-entries tarr))
|
||||
3 (tarr 'count-entries))
|
||||
(test "Element 0 is 8080"
|
||||
8080 (toml-int tarr 0))
|
||||
8080 (tarr 'int 0))
|
||||
(test "Element 2 is 8282"
|
||||
8282 (toml-int tarr 2))))
|
||||
8282 (tarr 'int 2))))
|
||||
|
||||
(test-exit)
|
||||
|
|
|
|||
333
toml-impl.scm
333
toml-impl.scm
|
|
@ -6,8 +6,7 @@
|
|||
(chicken gc)
|
||||
(chicken format)
|
||||
rfc3339
|
||||
coops
|
||||
coops-primitive-objects)
|
||||
prometheus)
|
||||
|
||||
(foreign-declare "#include <toml.h>")
|
||||
|
||||
|
|
@ -16,95 +15,106 @@
|
|||
(sprintf "0~S" n)
|
||||
(sprintf "~S" n)))
|
||||
|
||||
(define (set-toml-table-finalizer ttable)
|
||||
(define PointerObject (*the-root-object* 'clone))
|
||||
(PointerObject 'add-value-slot! 'ptr 'set-ptr! #f)
|
||||
|
||||
;;; TOML Array
|
||||
|
||||
(define (make-TomlArray pointer)
|
||||
(let ((obj (TomlArray 'clone)))
|
||||
(obj 'set-ptr! pointer)
|
||||
obj))
|
||||
|
||||
(define-object TomlArray (PointerObject)
|
||||
|
||||
((self-key self resend)
|
||||
((foreign-lambda* c-string ((c-pointer tarr))
|
||||
"C_return(toml_array_key(tarr));")
|
||||
(self 'ptr)))
|
||||
|
||||
((count-entries self resend)
|
||||
((foreign-lambda* int ((c-pointer tarr))
|
||||
"C_return(toml_array_nelem(tarr));")
|
||||
(self 'ptr)))
|
||||
|
||||
((string self resend index)
|
||||
((foreign-primitive ((c-pointer tarr)
|
||||
(int index))
|
||||
"toml_datum_t datum = toml_string_at(tarr, index);"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
|
||||
"C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
|
||||
"free(datum.u.s);"
|
||||
"C_values(3, data);")
|
||||
(self 'ptr) index))
|
||||
|
||||
((bool self resend index)
|
||||
((foreign-lambda* bool ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_bool_at(tarr, index).u.b);")
|
||||
(self 'ptr) index))
|
||||
|
||||
((int self resend index)
|
||||
((foreign-lambda* int ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_int_at(tarr, index).u.i);")
|
||||
(self 'ptr) index))
|
||||
|
||||
((double self resend index)
|
||||
((foreign-lambda* double ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_double_at(tarr, index).u.d);")
|
||||
(self 'ptr) index))
|
||||
|
||||
((timestamp self resend index)
|
||||
(let*-values (((Y M D h m s millis z)
|
||||
((foreign-primitive ((c-pointer tarr)
|
||||
(int index))
|
||||
"toml_datum_t datum = toml_timestamp_at(tarr, index);"
|
||||
"toml_timestamp_t* stamp = datum.u.ts;"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
||||
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
||||
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
||||
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
||||
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
||||
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
||||
"free(datum.u.ts);"
|
||||
"C_values(10, data);")
|
||||
(self 'ptr) index))
|
||||
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
||||
Y (zeropad M) (zeropad D)
|
||||
(zeropad h) (zeropad m) (zeropad s)
|
||||
millis z)))
|
||||
(string->rfc3339 rfcstr)))
|
||||
|
||||
((array self resend index)
|
||||
(make-TomlArray
|
||||
((foreign-lambda* c-pointer ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_array_at(tarr, index));")
|
||||
(self 'ptr) index)))
|
||||
|
||||
((table self resend index)
|
||||
(make-TomlTable
|
||||
((foreign-lambda* c-pointer ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_table_at(tarr, index));")
|
||||
(self 'ptr) index))))
|
||||
|
||||
;;; TOML Table
|
||||
|
||||
(define TomlTable (PointerObject 'clone))
|
||||
|
||||
(define (make-TomlTable pointer)
|
||||
(let ((obj (TomlTable 'clone)))
|
||||
(obj 'set-ptr! pointer)
|
||||
obj))
|
||||
|
||||
(define (set-table-finalizer ttable)
|
||||
(set-finalizer! ttable
|
||||
(lambda (obj)
|
||||
((foreign-lambda* void ((c-pointer ttp))
|
||||
"toml_free(ttp);")
|
||||
(ptr ttable)))))
|
||||
|
||||
(define-class <TomlArray> ()
|
||||
((ptr :accessor ptr :initform #f)))
|
||||
|
||||
(define-class <TomlTable> ()
|
||||
((ptr :accessor ptr :initform #f)))
|
||||
|
||||
|
||||
|
||||
(define-method (toml-self-key (tarr <TomlArray>))
|
||||
((foreign-lambda* c-string ((c-pointer tarr))
|
||||
"C_return(toml_array_key(tarr));")
|
||||
(ptr tarr)))
|
||||
|
||||
(define-method (toml-count-entries (tarr <TomlArray>))
|
||||
((foreign-lambda* int ((c-pointer tarr))
|
||||
"C_return(toml_array_nelem(tarr));")
|
||||
(ptr tarr)))
|
||||
|
||||
(define-method (toml-string (tarr <TomlArray>) (index <integer>))
|
||||
((foreign-primitive ((c-pointer tarr)
|
||||
(int index))
|
||||
"toml_datum_t datum = toml_string_at(tarr, index);"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
|
||||
"C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
|
||||
"free(datum.u.s);"
|
||||
"C_values(3, data);")
|
||||
(ptr tarr) index))
|
||||
|
||||
(define-method (toml-bool (tarr <TomlArray>) (index <integer>))
|
||||
((foreign-lambda* bool ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_bool_at(tarr, index).u.b);")
|
||||
(ptr tarr) index))
|
||||
|
||||
(define-method (toml-int (tarr <TomlArray>) (index <integer>))
|
||||
((foreign-lambda* int ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_int_at(tarr, index).u.i);")
|
||||
(ptr tarr) index))
|
||||
|
||||
(define-method (toml-double (tarr <TomlArray>) (index <integer>))
|
||||
((foreign-lambda* double ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_double_at(tarr, index).u.d);")
|
||||
(ptr tarr) index))
|
||||
|
||||
(define-method (toml-timestamp (tarr <TomlArray>) (index <integer>))
|
||||
(let*-values (((Y M D h m s millis z)
|
||||
((foreign-primitive ((c-pointer tarr)
|
||||
(int index))
|
||||
"toml_datum_t datum = toml_timestamp_at(tarr, index);"
|
||||
"toml_timestamp_t* stamp = datum.u.ts;"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
||||
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
||||
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
||||
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
||||
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
||||
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
||||
"free(datum.u.ts);"
|
||||
"C_values(10, data);")
|
||||
(ptr tarr) index))
|
||||
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
||||
Y (zeropad M) (zeropad D)
|
||||
(zeropad h) (zeropad m) (zeropad s)
|
||||
millis z)))
|
||||
(string->rfc3339 rfcstr)))
|
||||
|
||||
(define-method (toml-array (tarr <TomlArray>) (index <integer>))
|
||||
(make <TomlArray> 'ptr
|
||||
((foreign-lambda* c-pointer ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_array_at(tarr, index));")
|
||||
(ptr tarr) index)))
|
||||
|
||||
(define-method (toml-table (tarr <TomlArray>) (index <integer>))
|
||||
(make <TomlTable> 'ptr
|
||||
((foreign-lambda* c-pointer ((c-pointer tarr)
|
||||
(int index))
|
||||
"C_return(toml_table_at(tarr, index));")
|
||||
(ptr tarr) index)))
|
||||
|
||||
|
||||
(ttable 'ptr)))))
|
||||
|
||||
(define (table-from-file filename)
|
||||
(let ((ttp ((foreign-lambda* c-pointer ((c-string fname))
|
||||
|
|
@ -115,8 +125,8 @@
|
|||
"C_return(conf);")
|
||||
filename)))
|
||||
(when (not (eq? ttp 0))
|
||||
(let ((tomltable (make <TomlTable> 'ptr ttp)))
|
||||
(set-toml-table-finalizer tomltable)
|
||||
(let ((tomltable (make-TomlTable ttp)))
|
||||
(set-table-finalizer tomltable)
|
||||
tomltable))))
|
||||
|
||||
(define (table-from-string str)
|
||||
|
|
@ -126,109 +136,104 @@
|
|||
"C_return(conf);")
|
||||
str)))
|
||||
(when (not (eq? ttp 0))
|
||||
(let ((tomltable (make <TomlTable> 'ptr ttp)))
|
||||
(set-toml-table-finalizer tomltable)
|
||||
(let ((tomltable (make-TomlTable ttp)))
|
||||
(set-table-finalizer tomltable)
|
||||
tomltable))))
|
||||
|
||||
(define (set-toml-datum-string-finalizer tdatum)
|
||||
(set-finalizer! tdatum
|
||||
(lambda (obj)
|
||||
((foreign-lambda* void ((c-pointer tdat))
|
||||
"free(tdat);")
|
||||
(ptr tdatum)))))
|
||||
(define-object TomlTable (PointerObject)
|
||||
|
||||
(define-method (toml-self-key (ttbl <TomlTable>))
|
||||
((foreign-lambda* c-string ((c-pointer ttbl))
|
||||
"C_return(toml_table_key(ttbl));")
|
||||
(ptr ttbl)))
|
||||
((self-key self resend)
|
||||
((foreign-lambda* c-string ((c-pointer ttbl))
|
||||
"C_return(toml_table_key(ttbl));")
|
||||
(self 'ptr)))
|
||||
|
||||
(define-method (toml-key-exists? (ttbl <TomlTable>) (key <string>))
|
||||
(= 1
|
||||
((foreign-lambda* int ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_key_exists(ttbl, key));")
|
||||
(ptr ttbl) key)))
|
||||
((key-exists? self resend key)
|
||||
(= 1
|
||||
((foreign-lambda* int ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_key_exists(ttbl, key));")
|
||||
(self 'ptr) key)))
|
||||
|
||||
(define-method (toml-count-key-vals (ttbl <TomlTable>))
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_nkval(ttbl));")
|
||||
(ptr ttbl)))
|
||||
((count-key-vals self resend)
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_nkval(ttbl));")
|
||||
(self 'ptr)))
|
||||
|
||||
(define-method (toml-count-arrays (ttbl <TomlTable>))
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_narr(ttbl));")
|
||||
(ptr ttbl)))
|
||||
((count-arrays self resend)
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_narr(ttbl));")
|
||||
(self 'ptr)))
|
||||
|
||||
(define-method (toml-count-tables (ttbl <TomlTable>))
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_ntab(ttbl));")
|
||||
(ptr ttbl)))
|
||||
((count-tables self resend)
|
||||
((foreign-lambda* int ((c-pointer ttbl))
|
||||
"C_return(toml_table_ntab(ttbl));")
|
||||
(self 'ptr)))
|
||||
|
||||
(define-method (toml-key-at (ttbl <TomlTable>) (index <integer>))
|
||||
((foreign-lambda* c-string ((c-pointer ttbl)
|
||||
((key-at self resend index)
|
||||
((foreign-lambda* c-string ((c-pointer ttbl)
|
||||
(int index))
|
||||
"C_return(toml_key_in(ttbl, index));")
|
||||
(ptr ttbl) index))
|
||||
(self 'ptr) index))
|
||||
|
||||
(define-method (toml-string (ttbl <TomlTable>) (key <string>))
|
||||
((foreign-primitive ((c-pointer ttbl)
|
||||
((string self resend key)
|
||||
((foreign-primitive ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"toml_datum_t datum = toml_string_in(ttbl, key);"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
|
||||
"C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
|
||||
"free(datum.u.s);"
|
||||
"C_values(3, data);")
|
||||
(ptr ttbl) key))
|
||||
(self 'ptr) key))
|
||||
|
||||
(define-method (toml-bool (ttbl <TomlTable>) (key <string>))
|
||||
((foreign-lambda* bool ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
((bool self resend key)
|
||||
((foreign-lambda* bool ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_bool_in(ttbl, key).u.b);")
|
||||
(ptr ttbl) key))
|
||||
(self 'ptr) key))
|
||||
|
||||
(define-method (toml-int (ttbl <TomlTable>) (key <string>))
|
||||
((foreign-lambda* int ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
((int self resend key)
|
||||
((foreign-lambda* int ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_int_in(ttbl, key).u.i);")
|
||||
(ptr ttbl) key))
|
||||
(self 'ptr) key))
|
||||
|
||||
(define-method (toml-double (ttbl <TomlTable>) (key <string>))
|
||||
((foreign-lambda* double ((c-pointer ttbl)
|
||||
((double self resend key)
|
||||
((foreign-lambda* double ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_double_in(ttbl, key).u.d);")
|
||||
(ptr ttbl) key))
|
||||
(self 'ptr) key))
|
||||
|
||||
(define-method (toml-timestamp (ttbl <TomlTable>) (key <string>))
|
||||
(let*-values (((Y M D h m s millis z)
|
||||
((foreign-primitive ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"toml_datum_t datum = toml_timestamp_in(ttbl, key);"
|
||||
"toml_timestamp_t* stamp = datum.u.ts;"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
||||
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
||||
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
||||
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
||||
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
||||
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
||||
"free(datum.u.ts);"
|
||||
"C_values(10, data);")
|
||||
(ptr ttbl) key))
|
||||
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
||||
Y (zeropad M) (zeropad D)
|
||||
(zeropad h) (zeropad m) (zeropad s)
|
||||
millis z)))
|
||||
(string->rfc3339 rfcstr)))
|
||||
((timestamp self resend key)
|
||||
(let*-values (((Y M D h m s millis z)
|
||||
((foreign-primitive ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"toml_datum_t datum = toml_timestamp_in(ttbl, key);"
|
||||
"toml_timestamp_t* stamp = datum.u.ts;"
|
||||
"C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
|
||||
"C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
|
||||
"C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
|
||||
"C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
|
||||
"C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
|
||||
"C_string2(&s, stamp->z ?: \"Z\") } ;"
|
||||
"free(datum.u.ts);"
|
||||
"C_values(10, data);")
|
||||
(self 'ptr) key))
|
||||
((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
|
||||
Y (zeropad M) (zeropad D)
|
||||
(zeropad h) (zeropad m) (zeropad s)
|
||||
millis z)))
|
||||
(string->rfc3339 rfcstr)))
|
||||
|
||||
(define-method (toml-array (ttbl <TomlTable>) (key <string>))
|
||||
(make <TomlArray> 'ptr
|
||||
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
||||
((array self resend key)
|
||||
(make-TomlArray
|
||||
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_array_in(ttbl, key));")
|
||||
(ptr ttbl) key)))
|
||||
(self 'ptr) key)))
|
||||
|
||||
(define-method (toml-table (ttbl <TomlTable>) (key <string>))
|
||||
(make <TomlTable> 'ptr
|
||||
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
||||
((table self resend key)
|
||||
(make-TomlTable
|
||||
((foreign-lambda* c-pointer ((c-pointer ttbl)
|
||||
(c-string key))
|
||||
"C_return(toml_table_in(ttbl, key));")
|
||||
(ptr ttbl) key)))
|
||||
(self 'ptr) key))))
|
||||
|
|
|
|||
5
toml.egg
5
toml.egg
|
|
@ -4,7 +4,7 @@
|
|||
(category parsing)
|
||||
(license "MIT")
|
||||
(version "0.8")
|
||||
(dependencies r7rs rfc3339 coops)
|
||||
(dependencies rfc3339 prometheus)
|
||||
(test-dependencies test)
|
||||
|
||||
(components
|
||||
|
|
@ -12,5 +12,4 @@
|
|||
(source "tomlc99/toml.c"))
|
||||
(extension toml
|
||||
(objects tomlc99/toml)
|
||||
(csc-options "-X" "r7rs" "-R" "r7rs" "-K" "prefix" "-sJ"
|
||||
"-Itomlc99"))))
|
||||
(csc-options "-sJ" "-Itomlc99"))))
|
||||
|
|
|
|||
18
toml.scm
18
toml.scm
|
|
@ -1,21 +1,5 @@
|
|||
(import (r7rs))
|
||||
|
||||
(define-library (toml)
|
||||
(export table-from-file
|
||||
table-from-string
|
||||
toml-self-key
|
||||
toml-count-entries
|
||||
toml-count-key-vals
|
||||
toml-count-arrays
|
||||
toml-count-tables
|
||||
toml-string
|
||||
toml-bool
|
||||
toml-int
|
||||
toml-double
|
||||
toml-timestamp
|
||||
toml-array
|
||||
toml-table
|
||||
toml-key-exists?
|
||||
toml-key-at)
|
||||
table-from-string)
|
||||
(begin
|
||||
(include "toml-impl.scm")))
|
||||
|
|
|
|||
Loading…
Reference in a new issue