Port to Chicken 6

.envrc

@@ -0,0 +1,2 @@
+export NIXPKGS_ALLOW_BROKEN=1
+use nix

README.org

@@ -0,0 +1,4 @@
+* symbol-utils Egg for Chicken 6
+
+This is a port of =symbol-utils= to Chicken 6. It implements minimal changes to make the egg work.
+

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 = "dbffda19e57c3be092e5a9174f1829632f5fa5a7";
+      sha256 = "sha256-zWjf9JS4H1buBlkmUhIv+odCQzXaOPtI7VfIaQUhe6Q=";
+    })
+    (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,32 @@
+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; };
+    })
+  ];
+};
+mkShell {
+  packages = with pkgs; [
+    tcc-mob
+    chicken
+    rlwrap
+  ]
+  # ++ (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_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_PREFIX="${pkgs.chicken}"
+  '';
+}

symbol-lolevel-utils.scm

@@ -0,0 +1,23 @@
+;;;; symbol-lolevel-utils.scm  -*- Scheme -*-
+;;;; Kon Lovett, Mar '20
+;;;; Kon Lovett, Jul '18
+
+(declare
+  (bound-to-procedure ##sys#intern-symbol ##sys#check-symbol))
+
+(module symbol-lolevel-utils
+
+(;export
+  interned-symbol?)
+
+(import scheme)
+(import (chicken type))
+
+(: interned-symbol? (symbol --> boolean))
+
+(define (check-symbol loc obj) (##sys#check-symbol obj loc) obj)
+
+(define (interned-symbol? sym)
+  (##sys#interned-symbol? (check-symbol 'interned-symbol? sym)) )
+
+) ;module symbol-lolevel-utils

symbol-name-utils.scm

@@ -0,0 +1,198 @@
+;;;; symbol-name-utils.scm  -*- Scheme -*-
+;;;; Kon Lovett, Mar '20
+;;;; Kon Lovett, Jul '18
+
+(declare
+  (bound-to-procedure ##sys#check-symbol ##sys#check-keyword ##sys#check-list))
+
+(module symbol-name-utils
+
+(;export
+  ;
+  ->symbol
+  ->uninterned-symbol
+  keyword->symbol
+  keyword->uninterned-symbol
+  symbol->keyword
+  ;
+  symbol-printname-details
+  symbol-printname=? symbol-printname<?
+  symbol-printname-ci=? symbol-printname-ci<?
+  symbol-printname-length
+  max-symbol-printname-length
+  ;
+  module-printname module-printnames)
+
+(import scheme)
+(import (chicken base))
+(import (chicken type))
+(import (chicken keyword))
+(import (chicken fixnum))
+(import (chicken string))
+(import (srfi 13))
+
+(cond-expand
+  (chicken-5.0
+    (define-type keyword symbol))
+  (chicken-6.0
+    (define-type keyword symbol))
+  (else))
+
+(: exploded-qualified-symbol=? (string string string string #!optional boolean --> boolean))
+(: exploded-qualified-symbol<? (string string string string #!optional boolean --> boolean))
+
+(: *symbol-printname-details (symbol (or keyword symbol) --> string string))
+(
+: ->symbol (* --> symbol))
+(: ->uninterned-symbol (* -> symbol))
+
+(: keyword->symbol (keyword --> symbol))
+(: keyword->uninterned-symbol (keyword -> symbol))
+(: symbol->keyword ((or keyword symbol) --> keyword))
+
+(: symbol-printname-details ((or keyword symbol) --> string string))
+
+(: symbol-printname=? ((or keyword symbol) (or keyword symbol) --> boolean))
+(: symbol-printname<? ((or keyword symbol) (or keyword symbol) --> boolean))
+(: symbol-printname-ci=? ((or keyword symbol) (or keyword symbol) --> boolean))
+(: symbol-printname-ci<? ((or keyword symbol) (or keyword symbol) --> boolean))
+
+(: symbol-printname-length ((or keyword symbol) #!optional boolean --> fixnum))
+(: max-symbol-printname-length ((list-of (or keyword symbol)) #!optional boolean --> fixnum))
+
+(: module-printname (* -> (or false string)))
+(: module-printnames (* -> (or false (list-of string))))
+
+;;
+
+(define (check-keyword loc obj) (##sys#check-keyword obj loc) obj)
+(define (check-symbol loc obj) (##sys#check-symbol obj loc) obj)
+(define (check-list loc obj) (##sys#check-list obj loc) obj)
+
+;;
+
+(define (exploded-qualified-symbol=? px sx py sy #!optional ci)
+  (if ci
+      (and (string-ci= px py) (string-ci= sx sy))
+      (and (string=? px py) (string=? sx sy)) ) )
+
+(define (exploded-qualified-symbol<? px sx py sy #!optional ci)
+  (if ci
+      (or (and (string-ci= px py) (string-ci< sx sy))
+               (string-ci< px py))
+      (or (and (string=? px py) (string<? sx sy))
+          (string<? px py)) ) )
+
+;;
+
+(define (*symbol-printname-details loc sym)
+  (cond ((keyword? sym) (values (keyword->string sym) ":"))
+        (else (values (symbol->string (check-symbol loc sym)) ""))) )
+
+;;;
+
+;;
+
+(define (->symbol obj)
+  (cond ((symbol? obj) obj )
+        ((string? obj) (string->symbol obj) )
+        (else (string->symbol (->string obj)) ) ) )
+
+(define (->uninterned-symbol obj)
+  (string->uninterned-symbol (cond ((symbol? obj) (symbol->string obj))
+                                   ((string? obj) obj)
+                                   (else (->string obj)))) )
+
+;;
+
+(define (keyword->symbol kwd)
+  (string->symbol (keyword->string (check-keyword 'keyword->symbol kwd))) )
+
+(define (keyword->uninterned-symbol kwd)
+  (string->uninterned-symbol (keyword->string (check-keyword 'keyword->uninterned-symbol kwd))) )
+
+;;
+
+;symbol->string drops namespace qualification!
+;which means a keyword and a symbol of the same name have the same printname.
+
+(define (symbol->keyword sym)
+  (cond ((keyword? sym) (the keyword sym))
+        (else (string->keyword (symbol->string sym)) ) ) )
+
+(define (symbol-printname-details sym)
+  (receive (s p) (*symbol-printname-details 'symbol-printname-details sym)
+    ;do not expose the symbol's "raw" printname
+    (values (string-copy s) (string-copy p)) ) )
+
+;FIXME (forall (a ...) (a a --> boolean))
+
+(define (symbol-printname=? x y)
+  (let-values (((sx px) (*symbol-printname-details 'symbol-printname=? x))
+               ((sy py) (*symbol-printname-details 'symbol-printname=? y)) )
+    (exploded-qualified-symbol=? px sx py sy) ) )
+
+(define (symbol-printname<? x y)
+  (let-values (((sx px) (*symbol-printname-details 'symbol-printname<? x))
+               ((sy py) (*symbol-printname-details 'symbol-printname<? y)) )
+    (exploded-qualified-symbol<? px sx py sy) ) )
+
+(define (symbol-printname-ci=? x y)
+  (let-values (((sx px) (*symbol-printname-details 'symbol-printname=? x))
+               ((sy py) (*symbol-printname-details 'symbol-printname=? y)) )
+    (exploded-qualified-symbol=? px sx py sy #t) ) )
+
+(define (symbol-printname-ci<? x y)
+  (let-values (((sx px) (*symbol-printname-details 'symbol-printname<? x))
+               ((sy py) (*symbol-printname-details 'symbol-printname<? y)) )
+    (exploded-qualified-symbol<? px sx py sy #t) ) )
+
+;;
+
+(define (symbol-printname-length sym #!optional (sexp? #f))
+  (cond ((keyword? sym)
+          (let ((l (string-length (keyword->string sym))))
+            (fx+ l (if sexp? 2 1)) ) )
+        (else
+          (string-length (symbol->string (check-symbol 'symbol-printname-length sym))) ) ) )
+
+(define (max-symbol-printname-length syms #!optional (sexp? #f))
+  (foldl (lambda (mx sm) (fxmax mx (symbol-printname-length sm sexp?))) 0 (check-list 'max-symbol-printname-length syms)) )
+
+;;
+
+(define (module-printname obj)
+  ;
+  (define (norm-module-printname)
+    (cond ((string? obj) obj)
+          ((symbol? obj) (symbol->string obj))
+          ((list? obj)
+            (and-let* ((l (foldl
+                            (lambda (l s)
+                              (and (list? l) (symbol? s) (cons (symbol->string s) l)))
+                            '()
+                            obj))
+                       (l (reverse l)) )
+            (string-concatenate (intersperse l ".")) ) )
+          (else #f)) )
+  ;
+  (define (srfi-module-printname)
+    (and (list? obj) (= 2 (length obj))
+         (eq? 'srfi (car obj))
+         (and-let* ((n (cadr obj))
+                    ((and (integer? n) (not (negative? n)))) )
+           (string-append "srfi-" (number->string n)) ) ) )
+  ;
+  (or (srfi-module-printname) (norm-module-printname)) )
+
+(define (module-printnames obj)
+  (and (list? obj)
+       (and-let* ((l (foldl
+                       (lambda (l s)
+                         (and (list? l)
+                              (and-let* ((m (module-printname s))) (cons m l))) )
+                       '()
+                       obj)) )
+         (reverse l) ) ) )
+
+) ;module symbol-name-utils

symbol-utils.egg

@@ -0,0 +1,29 @@
+;;;; symbol-utils.meta  -*- Scheme -*-
+;;;; Kon Lovett, Mar '20
+;;;; Kon Lovett, Jul '18
+
+((synopsis "Symbol Utilities")
+ (version "2.6.1")
+ (category data)
+ (author "Kon Lovett")
+ (license "BSD")
+ (dependencies srfi-13)
+ (test-dependencies test test-utils)
+ (components
+  (extension symbol-utils.gen
+    (types-file)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension symbol-lolevel-utils
+    (types-file)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension symbol-name-utils
+    (types-file)
+    ;; FIXME: "-strict-types" here breaks *symbol-printname-details.
+    (csc-options "-O2" "-d1" "-no-procedure-checks" "-no-bound-checks") )
+  (extension symbol-value-utils
+    (types-file)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension symbol-utils
+    (types-file)
+    (component-dependencies symbol-utils.gen symbol-lolevel-utils symbol-name-utils symbol-value-utils)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) )

symbol-utils.gen.scm

@@ -0,0 +1,30 @@
+;;;; symbol-utils.gen.scm  -*- Scheme -*-
+;;;; Kon Lovett, Oct '22
+
+;"atomic"
+(declare (disable-interrupts))
+
+(module (symbol-utils gen)
+
+(;export
+  make-gensym)
+
+(import scheme (chicken base) (chicken type))
+
+(: make-gensym ((or symbol string) -> (#!optional (or symbol string) -> symbol)))
+
+(define (str-or-sym loc tag)
+  (cond ((not tag) "")
+        ((symbol? tag) (symbol->string tag))
+        ((string? tag) tag)
+        (else (error loc "bad argument - not a string or symbol" tag))) )
+
+(define (make-gensym bas)
+  (letrec ((+bas+ (str-or-sym 'make-gensym bas))
+           (+cnt+ 0)
+           (cnt++ (lambda () (let ((cnt +cnt+)) (set! +cnt+ (+ +cnt+ 1)) cnt))) )
+    (lambda (#!optional tag)
+      (string->uninterned-symbol
+       (string-append +bas+ (str-or-sym 'make-gensym tag) (number->string (cnt++)))) ) ) )
+
+) ;module (symbol-utils gen)

symbol-utils.release-info

@@ -0,0 +1,4 @@
+;; -*- Scheme -*-
+(repo git "https://gitea.lyrion.ch/Chicken/symbol-utils")
+(uri targz "https://gitea.lyrion.ch/Chicken/symbol-utils/archive/{egg-release}.tar.gz")
+(release "2.6.1") ;; Port to Chicken 6

symbol-utils.scm

@@ -0,0 +1,15 @@
+;;;; symbol-utils.scm  -*- Scheme -*-
+;;;; Kon Lovett, Mar '20
+;;;; Kon Lovett, Jul '18
+;;;; Kon Lovett, Aug '17
+;;;; Kon Lovett, Aug '10
+
+(module symbol-utils ()
+
+(import scheme)
+(import (chicken module))
+(import (symbol-utils gen) symbol-name-utils symbol-value-utils symbol-lolevel-utils)
+
+(reexport (symbol-utils gen) symbol-name-utils symbol-value-utils symbol-lolevel-utils)
+
+) ;module symbol-utils

symbol-value-utils.scm

@@ -0,0 +1,59 @@
+;;;; symbol-value-utils.scm  -*- Scheme -*-
+;;;; Kon Lovett, Mar '20
+;;;; Kon Lovett, Jul '18
+
+(declare
+  (bound-to-procedure ##sys#slot))
+
+(module symbol-value-utils
+
+(;export
+  ;Compiled Use Only
+  unbound-value? unbound?
+  symbol-value
+  ;
+  unspecified-value ;FIXME suspicious much?
+  unspecified-value? unspecified?)
+
+(import scheme)
+(import (chicken base))
+(import (chicken syntax))
+(import (chicken foreign))
+
+;; Unbound
+
+(define-syntax unbound-value?
+	(syntax-rules ()
+		((unbound-value? ?val)
+			(##core#inline "C_unboundvaluep" ?val) ) ) )
+
+(define-syntax unbound?
+	(syntax-rules ()
+		((unbound? ?sym)
+			(unbound-value? (##sys#slot ?sym 0)) ) ) )
+
+(define-syntax symbol-value
+	(syntax-rules ()
+    ;
+    ((symbol-value ?sym ?def)
+      (let ((val (##sys#slot ?sym 0)))
+        (if (unbound-value? val) ?def val) ) )
+    ;
+    ((symbol-value ?sym)
+      (symbol-value ?sym #f) ) ) )
+
+;; Undefined
+
+(define unspecified-value void)
+
+(define-syntax unspecified-value?
+	(syntax-rules ()
+		((unspecified-value? ?val)
+			(eq? (unspecified-value) ?val) ) ) )
+
+(define-syntax unspecified?
+	(syntax-rules ()
+		((unspecified? ?obj)
+			(unspecified-value? ?obj) ) ) )
+
+) ;module symbol-value-utils

tests/run.scm

@@ -0,0 +1,4 @@
+;;;; run.scm -*- Scheme -*-
+
+(import (test-utils run))
+(run-tests-for "symbol-utils")

tests/symbol-utils-test.scm

@@ -0,0 +1,92 @@
+;;;; symbol-utils-test.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+(import test)
+
+(test-begin "Symbol Utils")
+
+;;;
+
+(import symbol-utils)
+
+(test-group "value"
+  (cond-expand
+    (compiling
+      (test-assert (symbol-value symbol->keyword)) )
+    (else) )
+  (test-assert (unspecified? (unspecified-value)))
+)
+
+(test-group "keyword"
+  (test 'foo (keyword->symbol #:foo))
+  (test "foo" (symbol->string (keyword->uninterned-symbol #:foo)))
+  (test #:foo (symbol->keyword 'foo))
+)
+
+(test-group "printname"
+  (test-assert (symbol-printname=? 'foo 'foo))
+  (test-assert (not (symbol-printname=? 'foo 'bar)))
+  (test-assert (symbol-printname=? '##sys#list->string '##sys#list->string))
+  (test-assert (not (symbol-printname=? '##sys#list->string 'list->string)))
+
+  (test-assert (not (symbol-printname<? 'foo 'foo)))
+  (test-assert (symbol-printname<? 'bar 'foo))
+  (test-assert (not (symbol-printname<? '##sys#list->string '##sys#list->string)))
+  #;(test-assert (symbol-printname<? 'list->string '##sys#list->string))
+
+  (test-assert (symbol-printname-ci=? 'foo 'FOO))
+  (test-assert (not (symbol-printname-ci=? 'foo 'BAR)))
+  (test-assert (symbol-printname-ci=? '##sys#list->string '##sys#list->STRING))
+  (test-assert (not (symbol-printname-ci=? '##sys#list->string 'list->STRING)))
+
+  (test-assert (not (symbol-printname-ci<? 'foo 'FOO)))
+  (test-assert (symbol-printname-ci<? 'bar 'FOO))
+  (test-assert (not (symbol-printname-ci<? '##sys#list->string '##sys#list->STRING)))
+  #;(test-assert (symbol-printname-ci<? 'list->string '##sys#list->STRING))
+
+  (test 3 (symbol-printname-length 'foo))
+  (test 4 (symbol-printname-length #:foo))
+  (test 5 (symbol-printname-length #:foo #t))
+
+  (test 0 (max-symbol-printname-length '()))
+  (test 3 (max-symbol-printname-length '(a abc ab)))
+  (test 5 (max-symbol-printname-length '(a abc ab #:foo) #t))
+)
+
+(test-group "module printname"
+  (test-assert "must be list" (not (module-printnames "abc")))
+  (test-assert "not a #" (not (module-printnames '(a 23 "c"))))
+  (test-assert "xplody must be symbol" (not (module-printnames '(a (b "c") "d"))))
+  (test-assert "no negatives" (not (module-printnames '(a (srfi -8) "d"))))
+  (let ((mns (module-printnames '((foo bar baz) foo (srfi 0)))))
+    (test "xplody" "foo.bar.baz" (car mns))
+    (test "just a'" "foo" (cadr mns))
+    (test "special" "srfi-0" (caddr mns)) )
+)
+
+#;
+(test-group "qualified"
+  (test '##foo#bar (make-qualified-symbol "foo" 'bar))
+  (test-assert (qualified-symbol? '##sys#list->string))
+  (test-assert (not (qualified-symbol? 'sym)))
+  (test "##sys#list->string" (symbol->qualified-string '##sys#list->string))
+  (test "list->string" (symbol->qualified-string 'list->string))
+  (test-assert (not (interned-symbol? (make-qualified-uninterned-symbol "bar" 'foo))))
+)
+
+(test-group "interned"
+  (test-assert (interned-symbol? 'foo))
+  (test-assert (not (interned-symbol? (gensym))))
+)
+
+(test-group "gensym"
+  (let ((gen (make-gensym 'test)))
+    (test "gen 0" "test0" (symbol->string (gen)))
+    (test "gen 1" "testfoo1" (symbol->string (gen 'foo))) )
+)
+
+;;;
+
+(test-end "Symbol Utils")
+
+(test-exit)