Chicken/symbol-utils
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

Port to Chicken 6

Browse source
This commit is contained in:
Daniel Ziltener 2024-09-25 16:53:45 +02:00
commit 7cb9a1c8bb
Signed by: zilti
GPG key ID: B38976E82C9DAE42
14 changed files with 747 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.envrc Normal file
View file

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

4
README.org Normal file
View file

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

126
nix/chicken.nix Normal file
View 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 = "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.
'';
};
})

129
nix/tinycc.nix Normal file
View 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

32
shell.nix Normal file
View file

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

23
symbol-lolevel-utils.scm Normal file
View file

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

198
symbol-name-utils.scm Normal file
View file

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

29
symbol-utils.egg Normal file
View file

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

30
symbol-utils.gen.scm Normal file
View file

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

4
symbol-utils.release-info Normal file
View file

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

15
symbol-utils.scm Normal file
View file

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

59
symbol-value-utils.scm Normal file
View file

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

4
tests/run.scm Normal file
View file

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

92
tests/symbol-utils-test.scm Normal file
View file

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