Prepare Chicken 6 Port

.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

nix/chicken.nix

@@ -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.
+    '';
+  }; 
+  
+})

nix/tinycc.nix

@@ -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

shell.nix

@@ -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}"
+  '';
+}

tests/run.scm

@@ -1,52 +1,51 @@
-(import (r7rs)
+(import (test)
-        (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))
+          1 (tdat 'count-tables))
-    (let ((servertbl (toml-table tdat "server")))
+    (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"))
+         (tserv (tdat 'table "server"))
-         (tarr (toml-array tserv "port")))
+         (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)

toml-impl.scm

@@ -6,8 +6,7 @@
         (chicken gc)
         (chicken format)
         rfc3339
-        coops
+        prometheus)
-        coops-primitive-objects)
 
 (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)))))
+                     (ttable 'ptr)))))
-
-(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)))
-
-
 
 (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)))
+      (let ((tomltable (make-TomlTable ttp)))
-        (set-toml-table-finalizer tomltable)
+        (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)))
+      (let ((tomltable (make-TomlTable ttp)))
-        (set-toml-table-finalizer tomltable)
+        (set-table-finalizer tomltable)
         tomltable))))
 
-(define (set-toml-datum-string-finalizer tdatum)
+(define-object TomlTable (PointerObject)
-  (set-finalizer! tdatum
-                  (lambda (obj)
-                    ((foreign-lambda* void ((c-pointer tdat))
-                       "free(tdat);")
-                     (ptr tdatum)))))
 
-(define-method (toml-self-key (ttbl <TomlTable>))
+  ((self-key self resend)
-  ((foreign-lambda* c-string ((c-pointer ttbl))
+   ((foreign-lambda* c-string ((c-pointer ttbl))
-     "C_return(toml_table_key(ttbl));")
+      "C_return(toml_table_key(ttbl));")
-   (ptr ttbl)))
+    (self 'ptr)))
 
-(define-method (toml-key-exists? (ttbl <TomlTable>) (key <string>))
+  ((key-exists? self resend key)
-  (= 1
+   (= 1
-     ((foreign-lambda* int ((c-pointer ttbl)
+      ((foreign-lambda* int ((c-pointer ttbl)
-                            (c-string key))
+                             (c-string key))
-        "C_return(toml_key_exists(ttbl, key));")
+         "C_return(toml_key_exists(ttbl, key));")
-      (ptr ttbl) key)))
+       (self 'ptr) key)))
 
-(define-method (toml-count-key-vals (ttbl <TomlTable>))
+  ((count-key-vals self resend)
-  ((foreign-lambda* int ((c-pointer ttbl))
+   ((foreign-lambda* int ((c-pointer ttbl))
-     "C_return(toml_table_nkval(ttbl));")
+      "C_return(toml_table_nkval(ttbl));")
-   (ptr ttbl)))
+    (self 'ptr)))
 
-(define-method (toml-count-arrays (ttbl <TomlTable>))
+  ((count-arrays self resend)
-  ((foreign-lambda* int ((c-pointer ttbl))
+   ((foreign-lambda* int ((c-pointer ttbl))
-     "C_return(toml_table_narr(ttbl));")
+      "C_return(toml_table_narr(ttbl));")
-   (ptr ttbl)))
+    (self 'ptr)))
 
-(define-method (toml-count-tables (ttbl <TomlTable>))
+  ((count-tables self resend)
-  ((foreign-lambda* int ((c-pointer ttbl))
+   ((foreign-lambda* int ((c-pointer ttbl))
-     "C_return(toml_table_ntab(ttbl));")
+      "C_return(toml_table_ntab(ttbl));")
-   (ptr ttbl)))
+    (self 'ptr)))
 
-(define-method (toml-key-at (ttbl <TomlTable>) (index <integer>))
+  ((key-at self resend index)
-  ((foreign-lambda* c-string ((c-pointer ttbl)
+   ((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>))
+  ((string self resend key)
-  ((foreign-primitive ((c-pointer ttbl)
+   ((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>))
+  ((bool self resend key)
-  ((foreign-lambda* bool ((c-pointer ttbl)
+   ((foreign-lambda* bool ((c-pointer ttbl)
-                          (c-string key))
+                           (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>))
+  ((int self resend key)
-  ((foreign-lambda* int ((c-pointer ttbl)
+   ((foreign-lambda* int ((c-pointer ttbl)
-                         (c-string key))
+                          (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>))
+  ((double self resend key)
-  ((foreign-lambda* double ((c-pointer ttbl)
+   ((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>))
+  ((timestamp self resend key)
-  (let*-values (((Y M D h m s millis z)
+   (let*-values (((Y M D h m s millis z)
-                 ((foreign-primitive ((c-pointer ttbl)
+                  ((foreign-primitive ((c-pointer ttbl)
-                                      (c-string key))
+                                       (c-string key))
-                      "toml_datum_t datum = toml_timestamp_in(ttbl, key);"
+                       "toml_datum_t datum = toml_timestamp_in(ttbl, key);"
-                    "toml_timestamp_t* stamp = datum.u.ts;"
+                     "toml_timestamp_t* stamp = datum.u.ts;"
-                    "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
+                     "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
-                    "C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
+                     "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->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->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_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
-                    "C_string2(&s, stamp->z ?: \"Z\") } ;"
+                     "C_string2(&s, stamp->z ?: \"Z\") } ;"
-                    "free(datum.u.ts);"
+                     "free(datum.u.ts);"
-                    "C_values(10, data);")
+                     "C_values(10, data);")
-                  (ptr ttbl) key))
+                   (self 'ptr) key))
-                ((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
+                 ((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
-                                   Y (zeropad M) (zeropad D)
+                                    Y (zeropad M) (zeropad D)
-                                   (zeropad h) (zeropad m) (zeropad s)
+                                    (zeropad h) (zeropad m) (zeropad s)
-                                   millis z)))
+                                    millis z)))
-    (string->rfc3339 rfcstr)))
+     (string->rfc3339 rfcstr)))
 
-(define-method (toml-array (ttbl <TomlTable>) (key <string>))
+  ((array self resend key)
-  (make <TomlArray> 'ptr
+   (make-TomlArray
-        ((foreign-lambda* c-pointer ((c-pointer ttbl)
+    ((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>))
+  ((table self resend key)
-  (make <TomlTable> 'ptr
+   (make-TomlTable
-        ((foreign-lambda* c-pointer ((c-pointer ttbl)
+    ((foreign-lambda* c-pointer ((c-pointer ttbl)
                                      (c-string key))
            "C_return(toml_table_in(ttbl, key));")
-         (ptr ttbl) key)))
+     (self 'ptr) key))))

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"
+             (csc-options "-sJ" "-Itomlc99"))))
-                          "-Itomlc99"))))

toml.scm

@@ -1,21 +1,5 @@
-(import (r7rs))
-
 (define-library (toml)
   (export table-from-file
-          table-from-string
+          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)
   (begin
     (include "toml-impl.scm")))