Port to Chicken 6
This commit is contained in:
commit
e1cfffc17f
GPG key ID:
B38976E82C9DAE42
12 changed files with 1014 additions and 0 deletions
2
.envrc
Normal file
2
.envrc
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
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 = "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
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
|
||||
32
shell.nix
Normal file
32
shell.nix
Normal 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="$(pwd)/.chicken"
|
||||
export CHICKEN_INSTALL_REPOSITORY="$(pwd)/.chicken/eggs"
|
||||
export CHICKEN_REPOSITORY_PATH="${pkgs.chicken}/lib/chicken/12:$(pwd)/.chicken/eggs"
|
||||
export PATH="$PATH:$CHICKEN_PREFIX"
|
||||
export CHICKEN_PREFIX="${pkgs.chicken}"
|
||||
'';
|
||||
}
|
||||
29
test-utils.egg
Normal file
29
test-utils.egg
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
;; test-utils.egg -*- Scheme -*-
|
||||
|
||||
((synopsis "Test Utilities (for test egg)")
|
||||
(version "1.1.1")
|
||||
(license "BSD")
|
||||
(category testing)
|
||||
(author "Kon Lovett")
|
||||
(dependencies test)
|
||||
(test-dependencies test)
|
||||
(components
|
||||
(extension test-utils.run
|
||||
(types-file)
|
||||
(csc-options
|
||||
"-O3" "-d1" "-strict-types"
|
||||
"-no-procedure-checks-for-usual-bindings"
|
||||
"-no-procedure-checks-for-toplevel-bindings") )
|
||||
;FIXME Error: cannot load extension: test-utils.gloss.basic
|
||||
(extension test-utils.gloss
|
||||
(modules test-utils.gloss
|
||||
test-utils.gloss.support test-utils.gloss.basic test-utils.gloss.format)
|
||||
(types-file)
|
||||
(csc-options
|
||||
;#; ;single-thread; no threaded test-group(s)
|
||||
"-Duse-variable"
|
||||
#; ;when threaded test-group(s)
|
||||
"-Duse-parameter"
|
||||
"-O3" "-d1" "-strict-types"
|
||||
"-no-procedure-checks-for-usual-bindings"
|
||||
"-no-procedure-checks-for-toplevel-bindings") ) ) )
|
||||
280
test-utils.gloss.scm
Normal file
280
test-utils.gloss.scm
Normal file
|
|
@ -0,0 +1,280 @@
|
|||
;;; test "Gloss" API
|
||||
|
||||
(module (test-utils gloss support)
|
||||
|
||||
(;export
|
||||
;
|
||||
check-char
|
||||
check-string
|
||||
check-fixnum
|
||||
check-exact-unsigned-integer
|
||||
check-unsigned-fixnum
|
||||
define-checked-item
|
||||
;
|
||||
test-indent-width
|
||||
test-first-indentation
|
||||
test-max-indentation
|
||||
test-indentation-char
|
||||
;
|
||||
test-group-level
|
||||
test-group-indent-width
|
||||
test-group-indent-string)
|
||||
|
||||
(import scheme
|
||||
(scheme case-lambda)
|
||||
(chicken base)
|
||||
(chicken syntax)
|
||||
(only (chicken process-context) get-environment-variable))
|
||||
|
||||
;NOTE yes, order matters, i guess
|
||||
(cond-expand
|
||||
(use-parameter)
|
||||
(use-variable
|
||||
(import (chicken module))
|
||||
(export make-variable) ) )
|
||||
|
||||
(cond-expand
|
||||
((or use-parameter use-variable)
|
||||
;from (moremacros:)
|
||||
(import-for-syntax (only (chicken base) symbol-append))
|
||||
(define-syntax checked-guard
|
||||
(er-macro-transformer
|
||||
(lambda (frm rnm cmp)
|
||||
(##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
|
||||
(let ((_lambda (rnm 'lambda))
|
||||
(_let (rnm 'let))
|
||||
(_arg (rnm 'arg))
|
||||
(?locnam (cadr frm))
|
||||
(?typnam (caddr frm))
|
||||
(?body (cdddr frm)) )
|
||||
(let ((chknam (symbol-append 'check- (strip-syntax ?typnam)))) ;inject
|
||||
`(,_lambda (,_arg)
|
||||
(,chknam ',?locnam ,_arg)
|
||||
(,_let ((obj ,_arg))
|
||||
,@?body
|
||||
obj ) ) ) ) ) ) ) )
|
||||
(else) )
|
||||
|
||||
(cond-expand
|
||||
(use-parameter
|
||||
;from (moremacros:)
|
||||
(define-syntax define-parameter
|
||||
(syntax-rules ()
|
||||
((define-parameter name value guard)
|
||||
(define name (make-parameter value guard)))
|
||||
((define-parameter name value)
|
||||
(define name (make-parameter value)))
|
||||
((define-parameter name)
|
||||
(define name (make-parameter (void))))))
|
||||
(define-syntax define-checked-parameter
|
||||
(syntax-rules ()
|
||||
((define-checked-parameter ?name ?init ?typnam ?body0 ...)
|
||||
(define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
|
||||
(define-syntax define-checked-item
|
||||
(syntax-rules ()
|
||||
((define-checked-item ?name ?init ?typnam ?body0 ...)
|
||||
(define-checked-parameter ?name ?init ?typnam ?body0 ...) ) ) ) )
|
||||
(use-variable
|
||||
;from (moremacros: variable-item)
|
||||
(define (make-variable init #!optional (guard identity))
|
||||
(let ((value (guard init)))
|
||||
(define (setter obj) (set! value (guard obj)))
|
||||
(getter-with-setter
|
||||
;ugly but like parameter
|
||||
(lambda args
|
||||
(if (null? args) value
|
||||
(let ((new (car args)))
|
||||
(setter new)
|
||||
new ) ) )
|
||||
;emphasize not a paramter
|
||||
setter) ) )
|
||||
(define-syntax define-variable
|
||||
(syntax-rules ()
|
||||
((define-variable ?name ?init) (define ?name (make-variable ?init)) )
|
||||
((define-variable ?name ?init ?guard) (define ?name (make-variable ?init ?guard)) ) ) )
|
||||
(define-syntax define-checked-variable
|
||||
(syntax-rules ()
|
||||
((define-checked-variable ?name ?init ?typnam ?body0 ...)
|
||||
(define-variable ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
|
||||
(define-syntax define-checked-item
|
||||
(syntax-rules ()
|
||||
((define-checked-item ?name ?init ?typnam ?body0 ...)
|
||||
(define-checked-variable ?name ?init ?typnam ?body0 ...) ) ) ) ) )
|
||||
|
||||
;(check-errors sys)
|
||||
|
||||
(define (check-char loc obj) (##sys#check-char obj loc) obj)
|
||||
(define (check-string loc obj) (##sys#check-string obj loc) obj)
|
||||
(define (check-fixnum loc obj) (##sys#check-fixnum obj loc) obj)
|
||||
(define (check-exact-unsigned-integer loc obj) (##sys#check-exact-uinteger obj loc) obj)
|
||||
|
||||
(define (check-unsigned-fixnum loc obj) (check-exact-unsigned-integer loc (check-fixnum loc obj)) obj)
|
||||
|
||||
;from posix-utils (?)
|
||||
|
||||
(define get-environment-variable/default
|
||||
(case-lambda
|
||||
((nm)
|
||||
(get-environment-variable/default nm #f))
|
||||
((nm def)
|
||||
(cond ((get-environment-variable nm) => string->number)
|
||||
(else def))) ) )
|
||||
|
||||
;;
|
||||
|
||||
(define (check-indentation-amount loc obj) (check-unsigned-fixnum loc obj))
|
||||
|
||||
(define-checked-item test-indent-width
|
||||
(get-environment-variable/default "TEST_INDENT_WIDTH" 4)
|
||||
indentation-amount)
|
||||
|
||||
(define-checked-item test-first-indentation
|
||||
(get-environment-variable/default "TEST_FIRST_INDENTATION" 1)
|
||||
indentation-amount)
|
||||
|
||||
(define-checked-item test-max-indentation
|
||||
(get-environment-variable/default "TEST_MAX_INDENTATION" 5)
|
||||
indentation-amount)
|
||||
|
||||
(define-checked-item test-indentation-char
|
||||
(string-ref (get-environment-variable/default "TEST_INDENTATION_CHAR" " ") 0)
|
||||
char)
|
||||
|
||||
;;
|
||||
|
||||
;test?
|
||||
|
||||
(define (assq-ref ls key . args)
|
||||
(cond ((assq key ls) => cdr)
|
||||
((pair? args) (car args))
|
||||
(else #f)) )
|
||||
|
||||
(define (test-group-ref group field . args)
|
||||
(apply assq-ref (cdr group) field args) )
|
||||
|
||||
;;
|
||||
|
||||
(define (*test-group-level group)
|
||||
(add1 (- (test-group-ref group 'level 0) (test-first-indentation))) )
|
||||
|
||||
(define (test-group-level group)
|
||||
(min (test-max-indentation) (max 0 (*test-group-level group))) )
|
||||
|
||||
(define (test-group-indent-width group)
|
||||
(* (test-indent-width) (test-group-level group)) )
|
||||
|
||||
(define (test-group-indent-string group)
|
||||
(if (not group) ""
|
||||
(make-string (test-group-indent-width group) (test-indentation-char))) )
|
||||
|
||||
) ;module (test-utils gloss support)
|
||||
|
||||
;;
|
||||
|
||||
(module (test-utils gloss basic)
|
||||
|
||||
(;export
|
||||
;
|
||||
test-gloss-marker
|
||||
;
|
||||
glossln
|
||||
(glossn display-gloss-marker)
|
||||
gloss)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken syntax)
|
||||
test
|
||||
(test-utils gloss support))
|
||||
|
||||
;;
|
||||
|
||||
(define-constant TEST-GLOSS-MARKER "-->")
|
||||
|
||||
(define-checked-item test-gloss-marker TEST-GLOSS-MARKER string)
|
||||
|
||||
(define (display-gloss-marker)
|
||||
(display (test-group-indent-string (current-test-group)))
|
||||
(display (test-gloss-marker))
|
||||
(display #\space) )
|
||||
|
||||
;;
|
||||
|
||||
(define-syntax glossln
|
||||
(syntax-rules ()
|
||||
((glossln)
|
||||
(begin (newline) (flush-output) ) ) ) )
|
||||
|
||||
(define-syntax glossn
|
||||
(syntax-rules ()
|
||||
((glossn)
|
||||
(begin) )
|
||||
((glossn ?obj)
|
||||
(begin (display-gloss-marker) (display ?obj)))
|
||||
((glossn ?obj ...)
|
||||
(begin
|
||||
(display-gloss-marker)
|
||||
(for-each (lambda (x) (display x) (display #\space)) (list ?obj ...))) ) ) )
|
||||
|
||||
(define-syntax gloss
|
||||
(syntax-rules ()
|
||||
((gloss)
|
||||
(glossln) )
|
||||
((gloss ?obj ...)
|
||||
(begin (glossn ?obj ...) (glossln)) ) ) )
|
||||
|
||||
) ;module (test-utils gloss basic)
|
||||
|
||||
;; Formatted Gloss
|
||||
|
||||
;Needs a format, builtin or egg
|
||||
;(import (test gloss format) (only (chicken format) format))
|
||||
;(import (test gloss format) format)
|
||||
|
||||
(module (test-utils gloss format)
|
||||
|
||||
(;export
|
||||
glossnf
|
||||
glossf)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken syntax)
|
||||
test
|
||||
(test-utils gloss basic))
|
||||
|
||||
(define-syntax glossnf
|
||||
(syntax-rules ()
|
||||
((glossnf ?fmt ?arg0 ...)
|
||||
(glossn (format #f ?fmt ?arg0 ...)) ) ) )
|
||||
|
||||
(define-syntax glossf
|
||||
(syntax-rules ()
|
||||
((glossf ?fmt ?arg0 ...)
|
||||
(begin (glossnf ?fmt ?arg0 ...) (glossln) ) ) ) )
|
||||
|
||||
) ;module (test-utils gloss format)
|
||||
|
||||
(module (test-utils gloss) ()
|
||||
|
||||
(import scheme (chicken module))
|
||||
|
||||
(cond-expand
|
||||
(use-parameter
|
||||
(import (test-utils gloss support))
|
||||
(reexport
|
||||
(except (test-utils gloss support)
|
||||
check-char check-string check-fixnum check-exact-unsigned-integer
|
||||
check-unsigned-fixnum define-checked-item)) )
|
||||
(use-variable
|
||||
(import (except (test-utils gloss support) make-variable))
|
||||
(reexport
|
||||
(except (test-utils gloss support)
|
||||
make-variable
|
||||
check-char check-string check-fixnum check-exact-unsigned-integer
|
||||
check-unsigned-fixnum define-checked-item)) ) )
|
||||
|
||||
(import (test-utils gloss basic) (test-utils gloss format))
|
||||
(reexport (test-utils gloss basic) (test-utils gloss format))
|
||||
|
||||
) ;(test-utils gloss)
|
||||
4
test-utils.release-info
Normal file
4
test-utils.release-info
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
;; -*- Scheme -*-
|
||||
(repo git "https://gitea.lyrion.ch/Chicken/test-utils")
|
||||
(uri targz "https://gitea.lyrion.ch/Chicken/test-utils/archive/{egg-release}.tar.gz")
|
||||
(release "1.1.1") ;; Port to Chicken 6
|
||||
300
test-utils.run.scm
Normal file
300
test-utils.run.scm
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
;;;; test-utils.run.scm -*- Scheme -*-
|
||||
|
||||
;; Notes
|
||||
;;
|
||||
;; - chicken-install invokes "run.scm" as "<csi> -s run.scm <eggnam>"
|
||||
|
||||
(module (test-utils run)
|
||||
|
||||
(;export
|
||||
;
|
||||
make-test-filename
|
||||
make-test-pathname
|
||||
;
|
||||
test-list-order<
|
||||
;
|
||||
run-ident runid
|
||||
;
|
||||
run-test run-test-for
|
||||
test-files-rx
|
||||
test-lineup
|
||||
run-tests run-tests-for
|
||||
;
|
||||
csi-options csc-options
|
||||
run-test-evaluated run-test-compiled)
|
||||
|
||||
(import scheme
|
||||
(scheme case-lambda)
|
||||
(chicken base)
|
||||
(chicken type)
|
||||
(only (chicken pathname)
|
||||
make-pathname pathname-file pathname-replace-directory
|
||||
pathname-strip-extension pathname-directory
|
||||
pathname-strip-directory)
|
||||
(only (chicken process) system)
|
||||
(only (chicken process-context)
|
||||
command-line-arguments get-environment-variable executable-pathname)
|
||||
(only (chicken format) format)
|
||||
(only (chicken sort) sort)
|
||||
(only (chicken file) file-exists? find-files)
|
||||
(only (chicken irregex) irregex? irregex irregex-match?))
|
||||
|
||||
(define-type filename string)
|
||||
(define-type pathname string)
|
||||
(define-type irregex (struct regexp))
|
||||
|
||||
(define-type alist (list-of (pair symbol *)))
|
||||
|
||||
(define-type eggname string)
|
||||
(define-type testname (or eggname pathname))
|
||||
|
||||
(define-type options (list-of string))
|
||||
(define-type tests (list-of testname))
|
||||
|
||||
(define-type opt-options (or false (list-of string)))
|
||||
(define-type opt-tests (or false tests))
|
||||
|
||||
(: test-list-order< ((list-of testname) -> (testname testname -> boolean)))
|
||||
|
||||
(: run-ident (#!optional (or false alist) -> (or false alist)))
|
||||
(: runid (symbol #!optional * -> *))
|
||||
|
||||
(: make-test-filename (string -> filename))
|
||||
(: make-test-pathname (string -> pathname))
|
||||
|
||||
(: test-files-rx (#!optional (or false list irregex) -> (or false irregex)))
|
||||
|
||||
(: test-lineup (#!optional opt-tests -> opt-tests))
|
||||
|
||||
(: run-test (#!optional testname options options -> fixnum))
|
||||
(: run-test-for (eggname #!optional testname options options -> fixnum))
|
||||
|
||||
(: run-tests (#!optional tests options options -> void))
|
||||
(: run-tests-for (eggname #!optional tests options options -> void))
|
||||
|
||||
;not so "testy"
|
||||
|
||||
(: csi-options (#!optional opt-options -> opt-options))
|
||||
(: csc-options (#!optional opt-options -> opt-options))
|
||||
|
||||
(: run-test-evaluated (pathname options -> fixnum))
|
||||
(: run-test-compiled (pathname options -> fixnum))
|
||||
|
||||
;; Support
|
||||
|
||||
(define (system-must cmd)
|
||||
(let ((stat (system cmd)))
|
||||
(if (zero? stat) 0
|
||||
;failed, actual code irrelevant
|
||||
(exit 1) ) ) )
|
||||
|
||||
;(srfi 1)
|
||||
|
||||
;/1 good enough
|
||||
(define (list-index pd? ls)
|
||||
(let loop ((ls ls) (i 0))
|
||||
(cond ((null? ls) #f)
|
||||
((pd? (car ls)) i)
|
||||
(else (loop (cdr ls) (add1 i)))) ) )
|
||||
|
||||
(define (remove rmv? ls)
|
||||
(let loop ((ls ls) (os '()))
|
||||
(cond ((null? ls)
|
||||
(reverse os))
|
||||
((rmv? (car ls))
|
||||
(loop (cdr ls) os))
|
||||
(else
|
||||
(loop (cdr ls) (cons (car ls) os))) ) ) )
|
||||
|
||||
(define (remove/list os ls) (remove (cut member <> os) ls))
|
||||
|
||||
;; Globals
|
||||
|
||||
; Where to find CHICKEN binaries
|
||||
|
||||
(define *bin* (pathname-directory (executable-pathname)))
|
||||
|
||||
(define *csi* (or (get-environment-variable "CHICKEN_CSI") (make-pathname *bin* "csi")))
|
||||
(define *csc* (or (get-environment-variable "CHICKEN_CSC") (make-pathname *bin* "csc")))
|
||||
|
||||
; What options for the test run
|
||||
|
||||
(define *csi-init-options* '())
|
||||
|
||||
(define *csc-init-options* '(
|
||||
;Highly Problematic
|
||||
;"-disable-interrupts" "-unsafe"
|
||||
"-local"
|
||||
"-inline-global" "-inline"
|
||||
"-specialize" "-strict-types"
|
||||
"-optimize-leaf-routines" "-clustering" "-lfa2"
|
||||
"-no-trace" "-no-lambda-info"))
|
||||
|
||||
(define *egg-name*
|
||||
(let ((args (command-line-arguments)))
|
||||
(if (null? args) "" (car args)) ) )
|
||||
|
||||
(define *run-ident* `(
|
||||
(*test-directory* . ".")
|
||||
(*test-extension* . "scm")
|
||||
(*csi-options* . ())
|
||||
(*csi-excl-options* . ())
|
||||
(*csc-options* . ())
|
||||
(*csc-excl-options* . ())
|
||||
(*test-excl-names* . ())
|
||||
(*test-order* . ,string<?)
|
||||
(EGG-NAME . ,*egg-name*) ) )
|
||||
|
||||
;; Test Run Support
|
||||
|
||||
(define ((test-list-order< ordered) a b)
|
||||
(define (warn-test-order i tst)
|
||||
(unless i (warning 'test-list-order< "unknown test" tst))
|
||||
tst )
|
||||
;
|
||||
(let ((ai (list-index (cut string=? a <>) ordered))
|
||||
(bi (list-index (cut string=? b <>) ordered)) )
|
||||
(if (and ai bi) (< ai bi)
|
||||
(string<? (warn-test-order ai a) (warn-test-order bi b)) ) ) )
|
||||
|
||||
(define run-ident
|
||||
(let ((ids (the (or false alist) #f)))
|
||||
(case-lambda
|
||||
(()
|
||||
(or ids
|
||||
(run-ident *run-ident*)) )
|
||||
((x)
|
||||
;allow #f to reset
|
||||
(set! ids x) x) ) ) )
|
||||
|
||||
(define runid
|
||||
(case-lambda
|
||||
((id)
|
||||
(let ((cell (assq id (run-ident))))
|
||||
(if cell (cdr cell)
|
||||
(error 'runid "no such run ident" id) ) ) )
|
||||
((id v) (run-ident (cons (cons id v) (run-ident))) v) ) )
|
||||
|
||||
(define (make-test-filename name) (string-append name "-test"))
|
||||
|
||||
(define (make-test-pathname name)
|
||||
(make-pathname (runid '*test-directory*)
|
||||
(make-test-filename name) (runid '*test-extension*)) )
|
||||
|
||||
(define csi-options
|
||||
(let ((opts (the (or false options) #f)))
|
||||
(case-lambda
|
||||
(()
|
||||
(or opts
|
||||
(remove/list (runid '*csi-excl-options*)
|
||||
(append (runid '*csi-options*) *csi-init-options*))) )
|
||||
((x)
|
||||
;allow #f to reset
|
||||
(set! opts x) x) ) ) )
|
||||
|
||||
(define csc-options
|
||||
(let ((opts (the (or false options) #f)))
|
||||
(case-lambda
|
||||
(()
|
||||
(or opts
|
||||
(remove/list (runid '*csc-excl-options*)
|
||||
(append (runid '*csc-options*) *csc-init-options*))) )
|
||||
((x)
|
||||
;allow #f to reset
|
||||
(set! opts x) x) ) ) )
|
||||
|
||||
(define (extn-test-files-rx ext) `(: (+ graph) #\- "test" #\. ,ext))
|
||||
|
||||
(define test-files-rx
|
||||
(let ((rx (the (or false irregex) #f)))
|
||||
(case-lambda
|
||||
(()
|
||||
(or rx
|
||||
(test-files-rx (extn-test-files-rx (runid '*test-extension*)))) )
|
||||
((x)
|
||||
;allow #f to reset
|
||||
(set! rx (and x
|
||||
(if (irregex? x) x
|
||||
(irregex x 'utf8))))
|
||||
rx) ) ) )
|
||||
|
||||
;Internal
|
||||
|
||||
(define (egg-name) (runid 'EGG-NAME))
|
||||
|
||||
(define (test-file-name? x) (irregex-match? (test-files-rx) x))
|
||||
|
||||
(define (matching-test-file? x #!optional (remvs '()))
|
||||
(and (test-file-name? x) (not (member x remvs))) )
|
||||
|
||||
(define (test-files)
|
||||
(let ((remvs (map make-test-pathname (runid '*test-excl-names*))))
|
||||
(find-files (runid '*test-directory*)
|
||||
#:test (cut matching-test-file? <> remvs)
|
||||
#:limit 0) ) )
|
||||
|
||||
;FIXME very weak
|
||||
(define (ensure-test-pathname name)
|
||||
(if (test-file-name? name) name
|
||||
(make-test-pathname name)) )
|
||||
|
||||
(define (options->string opts)
|
||||
;FIXME map ->string over options & allow symbols, etc, not just strings
|
||||
(apply string-append (intersperse opts " ")) )
|
||||
|
||||
;; Run Tests
|
||||
|
||||
(define test-lineup
|
||||
(let ((fls #f))
|
||||
(case-lambda
|
||||
(()
|
||||
(or fls
|
||||
(let ((fls (test-files))
|
||||
(ord (runid '*test-order*)) )
|
||||
(define (stripped-ord a b)
|
||||
(ord (pathname-file a) (pathname-file b)) )
|
||||
(test-lineup (sort fls stripped-ord)))) )
|
||||
((x)
|
||||
;allow #f to reset
|
||||
(set! fls x) x) ) ) )
|
||||
|
||||
(define (run-test-evaluated source opts)
|
||||
(let ((optstr (options->string opts)))
|
||||
(format #t "*** ~A ~A ~A ***~%" *csi* (pathname-file source) optstr)
|
||||
(system-must (string-append *csi* " " optstr " -s " source)) ) )
|
||||
|
||||
(define (run-test-compiled source opts)
|
||||
(let ((optstr (options->string opts)))
|
||||
(format #t "*** ~A ~A ~A ***~%" *csc* (pathname-file source) optstr)
|
||||
;csc output is in current directory
|
||||
(system-must (string-append *csc* " " optstr " " source)) )
|
||||
(system-must
|
||||
(pathname-replace-directory (pathname-strip-extension source)
|
||||
(runid '*test-directory*))) )
|
||||
|
||||
(define (run-test #!optional
|
||||
(name (egg-name))
|
||||
(csc-options (csc-options))
|
||||
(csi-options (csi-options)))
|
||||
(let ((source (ensure-test-pathname name)))
|
||||
(unless (file-exists? source)
|
||||
(error 'run-test "no such file" source) )
|
||||
(run-test-evaluated source csi-options)
|
||||
(newline)
|
||||
(run-test-compiled source csc-options) ) )
|
||||
|
||||
(define (run-tests #!optional
|
||||
(tests (test-lineup))
|
||||
(csc-options (csc-options))
|
||||
(csi-options (csi-options)))
|
||||
(for-each (cut run-test <> csc-options csi-options) tests) )
|
||||
|
||||
(define (run-test-for eggnam . rest)
|
||||
(runid 'EGG-NAME eggnam)
|
||||
(apply run-test eggnam rest) )
|
||||
|
||||
(define (run-tests-for eggnam . rest)
|
||||
(runid 'EGG-NAME eggnam)
|
||||
(apply run-tests rest) )
|
||||
|
||||
) ;module (test-utils run)
|
||||
79
tests/run.scm
Normal file
79
tests/run.scm
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
;;;;
|
||||
|
||||
(import test)
|
||||
|
||||
#; ;FIXME
|
||||
(import (chicken format) (test-utils gloss format) (test-utils gloss basic))
|
||||
(import (chicken format) (test-utils gloss))
|
||||
|
||||
(import (test-utils run))
|
||||
|
||||
;Must set 1st thing
|
||||
(runid 'EGG-NAME "test-utils")
|
||||
|
||||
;NOTE order
|
||||
(define *tests* '("./test-utils-test.scm" "./three-test.scm" "./two-test.scm"))
|
||||
|
||||
(test-group "test-order<?"
|
||||
(define +tst+ (reverse *tests*))
|
||||
(define +len+ (length +tst+))
|
||||
(define +mid+ (floor (/ +len+ 2)))
|
||||
(define t<? (test-list-order< +tst+))
|
||||
|
||||
;same as (test-assert (<= 3 +len+))
|
||||
(test-assert (< 0 +mid+ (sub1 +len+)))
|
||||
|
||||
(test-assert (t<? (list-ref +tst+ 0) (list-ref +tst+ (sub1 +len+))))
|
||||
(test-assert (not (t<? (list-ref +tst+ (sub1 +len+)) (list-ref +tst+ 0))))
|
||||
(test-assert (t<? (list-ref +tst+ 0) (list-ref +tst+ +mid+)))
|
||||
(test-assert (not (t<? (list-ref +tst+ +mid+) (list-ref +tst+ 0))))
|
||||
(test-assert (t<? (list-ref +tst+ +mid+) (list-ref +tst+ (sub1 +len+))))
|
||||
(test-assert (not (t<? (list-ref +tst+ (sub1 +len+)) (list-ref +tst+ +mid+))))
|
||||
)
|
||||
|
||||
(test-group "runner"
|
||||
(test "test-utils" (runid 'EGG-NAME))
|
||||
(test "default dir" "." (runid '*test-directory*))
|
||||
(test "default ext" "scm" (runid '*test-extension*))
|
||||
(glossf "run-ident: ~S" (run-ident))
|
||||
(test-group "level 1"
|
||||
(define (empty-before id)
|
||||
(test (string-append "empty " (symbol->string id)) '() (runid id)))
|
||||
(gloss "level 1 (before 1st test)")
|
||||
(for-each empty-before
|
||||
'(*csi-options*
|
||||
*csi-excl-options*
|
||||
*csc-options*
|
||||
*csc-excl-options*
|
||||
*test-excl-names*))
|
||||
(gloss "level 1 (after 1st test)")
|
||||
(test "lexo test order" string<? (runid '*test-order*))
|
||||
(test-group "level 2"
|
||||
(gloss "level 2 (before 1st test)")
|
||||
(test "expected test-lineup" *tests* (test-lineup))
|
||||
(gloss "level 2 (after 1st test)")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(test-group "test order"
|
||||
(define (myord a b)
|
||||
(import (chicken pathname))
|
||||
(test-assert "expected order arguments"
|
||||
(and (not (pathname-directory a))
|
||||
(equal? (pathname-directory a) (pathname-directory b))
|
||||
(not (pathname-extension a))
|
||||
(equal? (pathname-extension a) (pathname-extension b))))
|
||||
(string<? a b) )
|
||||
(test-assert "successful reset" (not (test-lineup #f)))
|
||||
(test "change order" myord (runid '*test-order* myord))
|
||||
(test "changed order" myord (runid '*test-order*))
|
||||
(let ((res (test-lineup)))
|
||||
(test "expected test-lineup" *tests* res) )
|
||||
(test "reset order" string<? (runid '*test-order* string<?))
|
||||
)
|
||||
|
||||
;quit when not ahead
|
||||
(when (positive? (test-failure-count)) (test-exit))
|
||||
(gloss "Hello 1, 3 & 2")
|
||||
(run-tests)
|
||||
11
tests/test-utils-test.scm
Normal file
11
tests/test-utils-test.scm
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
;;;;
|
||||
|
||||
(import test)
|
||||
|
||||
#; ;FIXME
|
||||
(import (chicken format) (test-utils gloss format) (test-utils gloss basic))
|
||||
(import (chicken format) (test-utils gloss))
|
||||
|
||||
(gloss "Hello 1")
|
||||
|
||||
(test-exit)
|
||||
11
tests/three-test.scm
Normal file
11
tests/three-test.scm
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
;;;;
|
||||
|
||||
(import test)
|
||||
|
||||
#; ;FIXME
|
||||
(import (chicken format) (test-utils gloss format) (test-utils gloss basic))
|
||||
(import (chicken format) (test-utils gloss))
|
||||
|
||||
(gloss "Hello 3")
|
||||
|
||||
(test-exit)
|
||||
11
tests/two-test.scm
Normal file
11
tests/two-test.scm
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
;;;;
|
||||
|
||||
(import test)
|
||||
|
||||
#; ;FIXME
|
||||
(import (chicken format) (test-utils gloss format) (test-utils gloss basic))
|
||||
(import (chicken format) (test-utils gloss))
|
||||
|
||||
(gloss "Hello 2")
|
||||
|
||||
(test-exit)
|
||||
Loading…
Reference in a new issue