Chicken/check-errors
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 17:33:04 +02:00
commit ad7cfddc7d
Signed by: zilti
GPG key ID: B38976E82C9DAE42
46 changed files with 2703 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

3
README.org Normal file
View file

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

12
check-errors.basic.scm Normal file
View file

@ -0,0 +1,12 @@
;;;; check-errors.basic.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '22
(module (check-errors basic) ()
(import scheme)
(import (chicken module))
(import type-checks-basic type-errors-basic)
(reexport type-checks-basic type-errors-basic)
) ;module (check-errors basic)

150
check-errors.egg Normal file
View file

@ -0,0 +1,150 @@
;;;; check-errors.egg -*- Scheme -*-
;;;; Kon Lovett, Jul '18
((synopsis "Argument checks & errors")
(version "3.8.3")
(category misc)
(license "BSD")
(author "Kon Lovett")
(test-dependencies test test-utils)
(component-options
(csc-options
;most before unsafe (want argc check)
"-O3"
;public api useful w/ apropos (arguably -d0 + ,doc is better)
"-d1"
;strong typing
"-strict-types"
;doesn't inject procedures. arguments are either predicated or given to
;generics.
;note that the callers environment determines the compilation of syntax
"-no-procedure-checks" "-no-bound-checks") )
(components
;;
(extension check-errors.sys
;NOTE implementation is syntax only ATM so irrelevent
(types-file)
;issues w/ unsafe compilation (check is seen as "unused" & only return value is produced)
#; ;not always built but always installed
(inline-file) )
;;
(extension check-errors
(types-file)
(component-dependencies type-checks srfi-4-checks) )
;;
(extension type-checks
(types-file)
(component-dependencies type-errors type-checks-basic type-checks-atoms type-checks-structured) )
(extension type-errors
(types-file)
(component-dependencies type-errors-basic type-errors-atoms type-errors-structured) ) ;;
;;
(extension check-errors.basic
(types-file)
(component-dependencies type-checks-basic type-errors-basic) )
(extension type-checks-basic
(types-file)
(component-dependencies type-errors-basic) )
(extension type-errors-basic
(types-file) )
;;
(extension type-checks-atoms
(types-file)
(component-dependencies type-checks-basic type-checks-numbers type-errors-atoms) )
(extension type-errors-atoms
(types-file)
(component-dependencies type-errors-basic type-errors-numbers) )
;;
(extension type-checks-numbers
(types-file)
(component-dependencies type-checks-basic
type-errors-numbers
type-checks-numbers.interval
type-checks-numbers.scheme
type-checks-numbers.number
type-checks-numbers.fixnum
type-checks-numbers.integer
type-checks-numbers.bignum
type-checks-numbers.ratnum
type-checks-numbers.flonum
type-checks-numbers.cplxnum) )
(extension type-errors-numbers
(types-file)
(component-dependencies type-errors-basic
type-errors-numbers.interval
type-errors-numbers.scheme
type-errors-numbers.number
type-errors-numbers.fixnum
type-errors-numbers.integer
type-errors-numbers.bignum
type-errors-numbers.ratnum
type-errors-numbers.flonum
type-errors-numbers.cplxnum) )
(extension type-checks-numbers.interval
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.interval) )
(extension type-errors-numbers.interval
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.scheme
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.scheme) )
(extension type-errors-numbers.scheme
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.number
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.number) )
(extension type-errors-numbers.number
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.fixnum
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.fixnum) )
(extension type-errors-numbers.fixnum
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.integer
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.integer) )
(extension type-errors-numbers.integer
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.bignum
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.bignum) )
(extension type-errors-numbers.bignum
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.ratnum
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.ratnum) )
(extension type-errors-numbers.ratnum
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.flonum
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.flonum) )
(extension type-errors-numbers.flonum
(types-file)
(component-dependencies type-errors-basic) )
(extension type-checks-numbers.cplxnum
(types-file)
(component-dependencies type-checks-basic type-errors-numbers.cplxnum) )
(extension type-errors-numbers.cplxnum
(types-file)
(component-dependencies type-errors-basic) )
;;
(extension type-checks-structured
(types-file)
(component-dependencies type-checks-basic type-errors-structured) )
(extension type-errors-structured
(types-file)
(component-dependencies type-errors-basic) )
;;
(extension srfi-4-checks
(types-file)
(component-dependencies type-checks-basic srfi-4-errors) )
(extension srfi-4-errors
(types-file)
(component-dependencies type-errors-basic) ) ) )

4
check-errors.release-info Normal file
View file

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

14
check-errors.scm Normal file
View file

@ -0,0 +1,14 @@
;;;; check-errors.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Dec '12
(module check-errors ()
(import scheme)
(import (chicken module))
(import type-checks type-errors srfi-4-checks srfi-4-errors)
(reexport type-checks type-errors srfi-4-checks srfi-4-errors)
) ;module check-errors

249
check-errors.sys.scm Normal file
View file

@ -0,0 +1,249 @@
;;;; check-errors.builtins.scm -*- Scheme -*-
(module (check-errors sys)
(;export
;
check-list check-pair check-vector check-boolean check-char check-exact
check-inexact check-number check-integer check-real check-fixnum
check-string check-symbol check-keyword check-output-port check-input-port
check-locative check-closure check-procedure check-byte-vector check-blob
;
check-exact-integer check-exact-unsigned-integer
check-fixnum-in-range
;
check-structure)
(import scheme
(chicken base)
(chicken syntax))
(cond-expand
(unsafe
(define-syntax check-list
(syntax-rules ()
((check-list ?loc ?obj) ?obj) ) )
(define-syntax check-pair
(syntax-rules ()
((check-pair ?loc ?obj) ?obj) ) )
(define-syntax check-vector
(syntax-rules ()
((check-vector ?loc ?obj) ?obj) ) )
(define-syntax check-boolean
(syntax-rules ()
((check-boolean ?loc ?obj) ?obj) ) )
(define-syntax check-char
(syntax-rules ()
((check-char ?loc ?obj) ?obj) ) )
(define-syntax check-exact
(syntax-rules ()
((check-exact ?loc ?obj) ?obj) ) )
(define-syntax check-inexact
(syntax-rules ()
((check-inexact ?loc ?obj) ?obj) ) )
(define-syntax check-number
(syntax-rules ()
((check-number ?loc ?obj) ?obj) ) )
(define-syntax check-integer
(syntax-rules ()
((check-integer ?loc ?obj) ?obj) ) )
(define-syntax check-real
(syntax-rules ()
((check-real ?loc ?obj) ?obj) ) )
(define-syntax check-fixnum
(syntax-rules ()
((check-fixnum ?loc ?obj) ?obj) ) )
(define-syntax check-string
(syntax-rules ()
((check-string ?loc ?obj) ?obj) ) )
(define-syntax check-symbol
(syntax-rules ()
((check-symbol ?loc ?obj) ?obj) ) )
(define-syntax check-keyword
(syntax-rules ()
((check-keyword ?loc ?obj) ?obj) ) )
(define-syntax check-output-port
(syntax-rules ()
((check-output-port ?loc ?obj) ?obj) ) )
(define-syntax check-input-port
(syntax-rules ()
((check-input-port ?loc ?obj) ?obj) ) )
(define-syntax check-locative
(syntax-rules ()
((check-locative ?loc ?obj) ?obj) ) )
(define-syntax check-closure
(syntax-rules ()
((check-closure ?loc ?obj) ?obj) ) )
(define-syntax check-procedure
(syntax-rules ()
((check-procedure ?loc ?obj) ?obj) ) )
(define-syntax check-byte-vector
(syntax-rules ()
((check-byte-vector ?loc ?obj) ?obj) ) )
(define-syntax check-blob
(syntax-rules ()
((check-blob ?loc ?obj) ?obj) ) )
(define-syntax check-exact-integer
(syntax-rules ()
((check-exact-integer ?loc ?obj) ?obj) ) )
(define-syntax check-exact-unsigned-integer
(syntax-rules ()
((check-exact-unsigned-integer ?loc ?obj) ?obj) ) )
(define-syntax check-structure
(syntax-rules ()
((check-structure ?loc ?obj ?tag) ?obj) ) )
(define-syntax check-fixnum-in-range
(syntax-rules ()
((check-fixnum-in-range ?loc ?obj ?from ?to) ?obj)) ) )
(else
(define-syntax check-list
(syntax-rules ()
((check-list ?loc ?obj)
(begin (##sys#check-list ?obj ?loc) ?obj)) ) )
(define-syntax check-pair
(syntax-rules ()
((check-pair ?loc ?obj)
(begin (##sys#check-pair ?obj ?loc) ?obj)) ) )
(define-syntax check-vector
(syntax-rules ()
((check-vector ?loc ?obj)
(begin (##sys#check-vector ?obj ?loc) ?obj)) ) )
(define-syntax check-boolean
(syntax-rules ()
((check-boolean ?loc ?obj)
(begin (##sys#check-boolean ?obj ?loc) ?obj)) ) )
(define-syntax check-char
(syntax-rules ()
((check-char ?loc ?obj)
(begin (##sys#check-char ?obj ?loc) ?obj)) ) )
(define-syntax check-exact
(syntax-rules ()
((check-exact ?loc ?obj)
(begin (##sys#check-exact ?obj ?loc) ?obj)) ) )
(define-syntax check-inexact
(syntax-rules ()
((check-inexact ?loc ?obj)
(begin (##sys#check-inexact ?obj ?loc) ?obj)) ) )
(define-syntax check-number
(syntax-rules ()
((check-number ?loc ?obj)
(begin (##sys#check-number ?obj ?loc) ?obj)) ) )
(define-syntax check-integer
(syntax-rules ()
((check-integer ?loc ?obj)
(begin (##sys#check-integer ?obj ?loc) ?obj)) ) )
(define-syntax check-real
(syntax-rules ()
((check-real ?loc ?obj)
(begin (##sys#check-real ?obj ?loc) ?obj)) ) )
(define-syntax check-fixnum
(syntax-rules ()
((check-fixnum ?loc ?obj)
(begin (##sys#check-fixnum ?obj ?loc) ?obj)) ) )
(define-syntax check-string
(syntax-rules ()
((check-string ?loc ?obj)
(begin (##sys#check-string ?obj ?loc) ?obj)) ) )
(define-syntax check-symbol
(syntax-rules ()
((check-symbol ?loc ?obj)
(begin (##sys#check-symbol ?obj ?loc) ?obj)) ) )
(define-syntax check-keyword
(syntax-rules ()
((check-keyword ?loc ?obj)
(begin (##sys#check-keyword ?obj ?loc) ?obj)) ) )
(define-syntax check-output-port
(syntax-rules ()
((check-output-port ?loc ?obj)
(begin (##sys#check-output-port ?obj ?loc) ?obj)) ) )
(define-syntax check-input-port
(syntax-rules ()
((check-input-port ?loc ?obj)
(begin (##sys#check-input-port ?obj ?loc) ?obj)) ) )
(define-syntax check-locative
(syntax-rules ()
((check-locative ?loc ?obj)
(begin (##sys#check-locative ?obj ?loc) ?obj)) ) )
(define-syntax check-closure
(syntax-rules ()
((check-closure ?loc ?obj)
(begin (##sys#check-closure ?obj ?loc) ?obj)) ) )
(define-syntax check-procedure
(syntax-rules ()
((check-procedure ?loc ?obj)
(begin (##sys#check-closure ?obj ?loc) ?obj)) ) )
(define-syntax check-byte-vector
(syntax-rules ()
((check-byte-vector ?loc ?obj)
(begin (##sys#check-byte-vector ?obj ?loc) ?obj)) ) )
(define-syntax check-blob
(syntax-rules ()
((check-blob ?loc ?obj)
(begin (##sys#check-blob ?obj ?loc) ?obj)) ) )
(define-syntax check-exact-integer
(syntax-rules ()
((check-exact-integer ?loc ?obj)
(begin (##sys#check-exact-integer ?obj ?loc) ?obj)) ) )
(define-syntax check-exact-unsigned-integer
(syntax-rules ()
((check-exact-unsigned-integer ?loc ?obj)
(begin (##sys#check-exact-uinteger ?obj ?loc) ?obj)) ) )
;NOTE the module must export the tag as a binding, not all do!
(define-syntax check-structure
(syntax-rules ()
((check-structure ?loc ?obj ?tag)
(begin (##sys#check-structure ?obj ?tag ?loc) ?obj)) ) )
(define-syntax check-fixnum-in-range
(syntax-rules ()
((check-fixnum-in-range ?loc ?obj ?from ?to)
(begin (##sys#check-range ?obj ?from ?to ?loc) ?obj)) ) ) ) )
) ;module (check-errors sys)

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

59
nix/sdl3.nix Normal file
View file

@ -0,0 +1,59 @@
{
pkgs,
lib,
stdenv,
fetchgit,
fetchurl,
makeWrapper,
darwin,
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 = "SDL3";
inherit version;
src = fetchgit {
url = "https://github.com/libsdl-org/SDL";
rev = "3bc2bd790c04071aa65f09e71d41f7aa9ad9e639";
sha256 = "sha256-jaojRirdyhCrFRSy187xhyNVSbSGhqhsyCt92AG0Sd0=";
};
# -fno-strict-overflow is not a supported argument in clang
hardeningDisable = lib.optionals stdenv.cc.isClang [ "strictoverflow" ];
cmakeFlags = [
"-DCMAKE_BUILD_TYPE=Release"
];
nativeBuildInputs = [
makeWrapper
pkgs.hostname
pkgs.cmake
] ++ lib.optionals (stdenv.isDarwin && stdenv.isAarch64) [ darwin.autoSignDarwinBinariesHook ];
meta = {
homepage = "https://libsdl.org/";
license = lib.licenses.bsd3;
platforms = lib.platforms.unix;
description = "SDL3";
longDescription = ''
SDL3
'';
};
})

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

48
srfi-4-checks.scm Normal file
View file

@ -0,0 +1,48 @@
;;;; srfi-4-checks.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Dec '09
(module srfi-4-checks
(;export
check-s8vector
check-u8vector
check-s16vector
check-u16vector
check-s32vector
check-u32vector
check-s64vector
check-u64vector
check-f32vector
check-f64vector)
(import scheme)
(import (chicken base)) ; for `include'
(import (chicken type))
(import (srfi 4))
(import type-checks-basic)
(import srfi-4-errors)
(: check-s8vector (* s8vector #!optional * -> s8vector))
(: check-u8vector (* u8vector #!optional * -> u8vector))
(: check-s16vector (* s16vector #!optional * -> s16vector))
(: check-u16vector (* u16vector #!optional * -> u16vector))
(: check-s32vector (* s32vector #!optional * -> s32vector))
(: check-u32vector (* u32vector #!optional * -> u32vector))
(: check-s64vector (* s64vector #!optional * -> s64vector))
(: check-u64vector (* u64vector #!optional * -> u64vector))
(: check-f32vector (* f32vector #!optional * -> f32vector))
(: check-f64vector (* f64vector #!optional * -> f64vector))
(define-check-type s8vector)
(define-check-type u8vector)
(define-check-type s16vector)
(define-check-type u16vector)
(define-check-type s32vector)
(define-check-type u32vector)
(define-check-type s64vector)
(define-check-type u64vector)
(define-check-type f32vector)
(define-check-type f64vector)
) ;module srfi-4-checks

58
srfi-4-errors.scm Normal file
View file

@ -0,0 +1,58 @@
;;;; srfi-4-errors.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Dec '09
(module srfi-4-errors
(;export
error-s8vector
error-u8vector
error-s16vector
error-u16vector
error-s32vector
error-u32vector
error-s64vector
error-u64vector
error-f32vector
error-f64vector)
(import scheme)
(import (chicken base)) ; for `include'
(import (chicken type))
(import (srfi 4))
(import type-errors-basic)
(: error-s8vector (* * #!optional * -> noreturn))
(: error-u8vector (* * #!optional * -> noreturn))
(: error-s16vector (* * #!optional * -> noreturn))
(: error-u16vector (* * #!optional * -> noreturn))
(: error-s32vector (* * #!optional * -> noreturn))
(: error-u32vector (* * #!optional * -> noreturn))
(: error-s64vector (* * #!optional * -> noreturn))
(: error-u64vector (* * #!optional * -> noreturn))
(: error-f32vector (* * #!optional * -> noreturn))
(: error-f64vector (* * #!optional * -> noreturn))
(define-error-type s8vector)
(define-error-type u8vector)
(define-error-type s16vector)
(define-error-type u16vector)
(define-error-type s32vector)
(define-error-type u32vector)
(define-error-type s64vector)
(define-error-type u64vector)
(define-error-type f32vector)
(define-error-type f64vector)
(define-error-type s8vector)
(define-error-type u8vector)
(define-error-type s16vector)
(define-error-type u16vector)
(define-error-type s32vector)
(define-error-type u32vector)
(define-error-type s64vector)
(define-error-type u64vector)
(define-error-type f32vector)
(define-error-type f64vector)
) ;module srfi-4-errors

200
tests/check-errors-strict-test.scm Normal file
View file

@ -0,0 +1,200 @@
;;;; check-errors-test.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(import test)
(import (only (chicken format) format) (test-utils gloss))
(test-begin "Check Errors (strict-types)")
;;;
(import type-checks-basic)
(import type-checks-atoms)
(import type-checks-structured)
(import (type-checks-numbers bignum))
(import (type-checks-numbers cplxnum))
(import (type-checks-numbers fixnum))
(import (type-checks-numbers flonum))
(import (type-checks-numbers integer))
(import (type-checks-numbers interval))
(import (type-checks-numbers number))
(import (type-checks-numbers ratnum))
(import (type-checks-numbers scheme))
(import srfi-4-checks)
(import type-errors srfi-4-errors)
(import (only (chicken condition) condition-property-accessor))
(import srfi-4)
;;
(define-syntax test-check
(syntax-rules ()
((test-check ?check ?expt ?arg0 ...)
(test (symbol->string '?check)
?expt (?check 'test ?expt ?arg0 ...)) ) ) )
(define-syntax capture-error
(syntax-rules ()
((capture-error ?body ...)
(handle-exceptions exp
(map (lambda (p) ((condition-property-accessor 'exn p) exp))
'(location message arguments))
?body ... ) ) ) )
;; Basic
(cond-expand
(compiling
(gloss)
(gloss "!-------------------")
(gloss "! EXPECT TYPE ERRORS")
(gloss "! (runtime tests)")
(gloss "!-------------------") )
(else) )
(test-group "define-check+error-type"
(define (foo? obj) #t)
(define-check+error-type foo)
(test-assert error-foo)
(test-assert check-foo)
(define-check+error-type foo1 foo?)
(test-assert error-foo1)
(test-assert check-foo1)
(define-check+error-type foo2 foo? "foodie")
(test-assert error-foo2)
(test-assert check-foo2)
)
(define-syntax unbound-value
(syntax-rules ()
((unbound-value)
(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
(test-group "for failure"
(test-error (check-defined-value (void))) ;too few arguments
(test-error (check-bound-value (unbound-value))) ;too few arguments
(test-error (check-defined-value 'test (void))) ;cannot check type
(test-error (check-bound-value 'test (unbound-value))) ;cannot check type
(test-error (check-fixnum 'test 1.0))
(test-error (check-positive-fixnum 'test 0))
(test-error (check-negative-fixnum 'test 0))
(test-error (check-natural-fixnum 'test -1))
(test-error (check-non-positive-fixnum 'test 1))
(test-error (check-flonum 'test 1))
(test-error (check-integer 'test 0.1))
(test-error (check-positive-integer 'test 0.0))
(test-error (check-natural-integer 'test -1.0))
(test-error (check-number 'test 'x))
(test-error (check-positive-number 'test -0.1))
(test-error (check-natural-number 'test -0.1))
(test-error (check-procedure 'test 'x))
(test-error (check-input-port 'test 'x))
(test-error (check-output-port 'test 'x))
(test-error (check-list 'test 'x))
(test-error (check-pair 'test 'x))
(test-error (check-vector 'test 'x))
(test-error (check-structure 'test 'x))
(test-error (check-symbol 'test 1))
(test-error (check-keyword 'test 'x))
(test-error (check-string 'test 'x))
(test-error (check-char 'test 'x))
(test-error (check-boolean 'test 'x))
(test-error (check-alist 'test 'x))
(test-error (check-alist 'test '(23)))
(test-error (check-alist 'test '((a . 1) ())))
(test-error (check-minimum-argument-count 'test 0 1))
(test-error (check-argument-count 'test 1 0))
(test-error (check-open-interval 'test 1.1 1.1 1.2))
(test-error (check-open-interval 'test 1.2 1.1 1.2))
(test-error (check-closed-interval 'test 1.0 1.1 1.2))
(test-error (check-closed-interval 'test 1.3 1.1 1.2))
(test-error (check-half-open-interval 'test 1.1 1.1 1.2))
(test-error (check-half-open-interval 'test 1.3 1.1 1.2))
(test-error (check-half-closed-interval 'test 1.2 1.1 1.2))
(test-error (check-half-closed-interval 'test 1.3 1.1 1.2))
(test-error (check-range 'test 0 -1))
(test-error (check-u16vector 'test 23))
)
(test-group "for success"
(test-check check-defined-value 1)
(test-check check-bound-value 1)
(test-check check-fixnum 1)
(test-check check-positive-fixnum 1)
(test-check check-negative-fixnum -1)
(test-check check-natural-fixnum 0)
(test-check check-non-positive-fixnum 0)
(test-check check-flonum 1.0)
(test-check check-integer 1.0)
(test-check check-integer 1)
(test-check check-positive-integer 1.0)
(test-check check-positive-integer 1)
(test-check check-natural-integer 0.0)
(test-check check-natural-integer 0)
(test-check check-number 1.0)
(test-check check-number 1)
(test-check check-positive-number 1.0)
(test-check check-positive-number 1)
(test-check check-natural-number 0.0)
(test-check check-natural-number 0)
(test-check check-procedure check-procedure)
(test-check check-input-port (current-input-port))
(test-check check-output-port (current-output-port))
(test-check check-list '(x))
(test-check check-pair '(x . y))
(test-check check-vector '#(x))
(test-check check-structure (##sys#make-structure 'x) 'x)
(test-check check-symbol 'x)
(test-check check-keyword #:x)
(test-check check-string "x")
(test-check check-char #\x)
(test-check check-boolean #t)
(test-check check-alist '())
(test-check check-alist '((a . 1)))
(test-check check-alist '((a . 1) (b . 2)))
(test-check check-minimum-argument-count 1 1)
(test-check check-argument-count 1 1)
(test-check check-open-interval 1.11 1.1 1.2)
(test-check check-closed-interval 1.1 1.1 1.2)
(test-check check-half-open-interval 1.11 1.1 1.2)
(test-check check-half-closed-interval 1.11 1.1 1.2)
(test-check check-range 0 1)
(test-check check-s8vector (make-s8vector 2 0))
)
(test-group "error message"
(test '(test "bad argument type - not a fixnum" (#f))
(capture-error (check-fixnum 'test #f)))
(test '(test "bad `num' argument type - not a fixnum" (#f))
(capture-error (check-fixnum 'test #f 'num)))
(test '(test "bad argument must be in (1.1 1.2)" (1.1))
(capture-error (check-open-interval 'test 1.1 1.1 1.2)))
(test '(test "bad argument must be in [1.1 1.2]" (1.0))
(capture-error (check-closed-interval 'test 1.0 1.1 1.2)))
(test '(test "bad argument must be in (1.1 1.2]" (1.1))
(capture-error (check-half-open-interval 'test 1.1 1.1 1.2)))
(test '(test "bad argument must be in [1.1 1.2)" (1.2))
(capture-error (check-half-closed-interval 'test 1.2 1.1 1.2)))
(test '(test "bad argument" (0 -1))
(capture-error (check-range 'test 0 -1)))
(test '(test "bad argument count - received 3 but expected 2" ())
(capture-error (check-argument-count 'test 3 2)))
(test '(test "too few arguments - received 1 but expected 2" ())
(capture-error (check-minimum-argument-count 'test 1 2)))
)
(test-group "define-check-structure"
(define-record-type <foo-t> (make-foo-t x) foo-t? (x foo-t-x))
(define-check-structure <foo-t>)
(test-assert check-<foo-t>)
(test-error (check-<foo-t> 'test #f))
(test-assert (check-<foo-t> 'test (##sys#make-structure <foo-t>)))
)
;;;
(test-end "Check Errors (strict-types)")
(test-exit)

177
tests/check-errors-test.scm Normal file
View file

@ -0,0 +1,177 @@
;;;; check-errors-test.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(import test)
(import (only (chicken format) format) (test-utils gloss))
(test-begin "Check Errors")
;;;
(import check-errors)
(import (only (chicken condition) condition-property-accessor))
(import srfi-4)
;;
(define-syntax test-check
(syntax-rules ()
((test-check ?check ?expt ?arg0 ...)
(test (symbol->string '?check)
?expt (?check 'test ?expt ?arg0 ...)) ) ) )
(define-syntax capture-error
(syntax-rules ()
((capture-error ?body ...)
(handle-exceptions exp
(map (lambda (p) ((condition-property-accessor 'exn p) exp))
'(location message arguments))
?body ... ) ) ) )
;; Basic
(test-group "define-check+error-type"
(define (foo? obj) #t)
(define-check+error-type foo)
(test-assert error-foo)
(test-assert check-foo)
(define-check+error-type foo1 foo?)
(test-assert error-foo1)
(test-assert check-foo1)
(define-check+error-type foo2 foo? "foodie")
(test-assert error-foo2)
(test-assert check-foo2)
)
(define-syntax unbound-value
(syntax-rules ()
((unbound-value)
(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
(test-group "for failure"
(test-error (check-defined-value (void))) ;too few arguments
(test-error (check-bound-value (unbound-value))) ;too few arguments
(test-error (check-defined-value 'test (void))) ;cannot check type
(test-error (check-bound-value 'test (unbound-value))) ;cannot check type
(test-error (check-fixnum 'test 1.0))
(test-error (check-positive-fixnum 'test 0))
(test-error (check-negative-fixnum 'test 0))
(test-error (check-natural-fixnum 'test -1))
(test-error (check-non-positive-fixnum 'test 1))
(test-error (check-flonum 'test 1))
(test-error (check-integer 'test 0.1))
(test-error (check-positive-integer 'test 0.0))
(test-error (check-natural-integer 'test -1.0))
(test-error (check-number 'test 'x))
(test-error (check-positive-number 'test -0.1))
(test-error (check-natural-number 'test -0.1))
(test-error (check-procedure 'test 'x))
(test-error (check-input-port 'test 'x))
(test-error (check-output-port 'test 'x))
(test-error (check-list 'test 'x))
(test-error (check-pair 'test 'x))
(test-error (check-vector 'test 'x))
(test-error (check-structure 'test 'x))
(test-error (check-symbol 'test 1))
(test-error (check-keyword 'test 'x))
(test-error (check-string 'test 'x))
(test-error (check-char 'test 'x))
(test-error (check-boolean 'test 'x))
(test-error (check-alist 'test 'x))
(test-error (check-alist 'test '(23)))
(test-error (check-alist 'test '((a . 1) ())))
(test-error (check-minimum-argument-count 'test 0 1))
(test-error (check-argument-count 'test 1 0))
(test-error (check-open-interval 'test 1.1 1.1 1.2))
(test-error (check-open-interval 'test 1.2 1.1 1.2))
(test-error (check-closed-interval 'test 1.0 1.1 1.2))
(test-error (check-closed-interval 'test 1.3 1.1 1.2))
(test-error (check-half-open-interval 'test 1.1 1.1 1.2))
(test-error (check-half-open-interval 'test 1.3 1.1 1.2))
(test-error (check-half-closed-interval 'test 1.2 1.1 1.2))
(test-error (check-half-closed-interval 'test 1.3 1.1 1.2))
(test-error (check-range 'test 0 -1))
(test-error (check-u16vector 'test 23))
)
(test-group "for success"
(test-check check-defined-value 1)
(test-check check-bound-value 1)
(test-check check-fixnum 1)
(test-check check-positive-fixnum 1)
(test-check check-negative-fixnum -1)
(test-check check-natural-fixnum 0)
(test-check check-non-positive-fixnum 0)
(test-check check-flonum 1.0)
(test-check check-integer 1.0)
(test-check check-integer 1)
(test-check check-positive-integer 1.0)
(test-check check-positive-integer 1)
(test-check check-natural-integer 0.0)
(test-check check-natural-integer 0)
(test-check check-number 1.0)
(test-check check-number 1)
(test-check check-positive-number 1.0)
(test-check check-positive-number 1)
(test-check check-natural-number 0.0)
(test-check check-natural-number 0)
(test-check check-procedure check-procedure)
(test-check check-input-port (current-input-port))
(test-check check-output-port (current-output-port))
(test-check check-list '(x))
(test-check check-pair '(x . y))
(test-check check-vector '#(x))
(test-check check-structure (##sys#make-structure 'x) 'x)
(test-check check-symbol 'x)
(test-check check-keyword #:x)
(test-check check-string "x")
(test-check check-char #\x)
(test-check check-boolean #t)
(test-check check-alist '())
(test-check check-alist '((a . 1)))
(test-check check-alist '((a . 1) (b . 2)))
(test-check check-minimum-argument-count 1 1)
(test-check check-argument-count 1 1)
(test-check check-open-interval 1.11 1.1 1.2)
(test-check check-closed-interval 1.1 1.1 1.2)
(test-check check-half-open-interval 1.11 1.1 1.2)
(test-check check-half-closed-interval 1.11 1.1 1.2)
(test-check check-range 0 1)
(test-check check-s8vector (make-s8vector 2 0))
)
(test-group "error message"
(test '(test "bad argument type - not a fixnum" (#f))
(capture-error (check-fixnum 'test #f)))
(test '(test "bad `num' argument type - not a fixnum" (#f))
(capture-error (check-fixnum 'test #f 'num)))
(test '(test "bad argument must be in (1.1 1.2)" (1.1))
(capture-error (check-open-interval 'test 1.1 1.1 1.2)))
(test '(test "bad argument must be in [1.1 1.2]" (1.0))
(capture-error (check-closed-interval 'test 1.0 1.1 1.2)))
(test '(test "bad argument must be in (1.1 1.2]" (1.1))
(capture-error (check-half-open-interval 'test 1.1 1.1 1.2)))
(test '(test "bad argument must be in [1.1 1.2)" (1.2))
(capture-error (check-half-closed-interval 'test 1.2 1.1 1.2)))
(test '(test "bad argument" (0 -1))
(capture-error (check-range 'test 0 -1)))
(test '(test "bad argument count - received 3 but expected 2" ())
(capture-error (check-argument-count 'test 3 2)))
(test '(test "too few arguments - received 1 but expected 2" ())
(capture-error (check-minimum-argument-count 'test 1 2)))
)
(test-group "define-check-structure"
(define-record-type <foo-t> (make-foo-t x) foo-t? (x foo-t-x))
(define-check-structure <foo-t>)
(test-assert check-<foo-t>)
(test-error (check-<foo-t> 'test #f))
(test-assert (check-<foo-t> 'test (##sys#make-structure <foo-t>)))
)
;;;
(test-end "Check Errors")
(test-exit)

4
tests/run.scm Normal file
View file

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

94
tests/sys-checks-test.scm Normal file
View file

@ -0,0 +1,94 @@
;;;; buitins-test.scm -*- Scheme -*-
(import test)
(import (only (chicken format) format) (test-utils gloss))
(test-begin "Sys")
;;;
(import (check-errors sys))
(import (only (chicken condition) condition-property-accessor))
;;
(define-syntax test-check
(syntax-rules ()
((test-check ?check ?expt ?arg0 ...)
(test (symbol->string '?check)
?expt (?check 'test ?expt ?arg0 ...)) ) ) )
(define-syntax capture-error
(syntax-rules ()
((capture-error ?body ...)
(handle-exceptions exp
(map (lambda (p) ((condition-property-accessor 'exn p) exp))
'(location message arguments))
?body ... ) ) ) )
;; Basic
(cond-expand
(compiling
(gloss)
(gloss "!-------------------")
(gloss "! EXPECT TYPE ERRORS")
(gloss "! (runtime tests)")
(gloss "!-------------------") )
(else) )
(test-group "for failure"
(test-error (check-fixnum 'test 1.0))
(test-error (check-inexact 'test 1))
(test-error (check-integer 'test 0.1))
(test-error (check-number 'test 'x))
(test-error (check-procedure 'test 'x))
(test-error (check-input-port 'test 'x))
(test-error (check-output-port 'test 'x))
(test-error (check-list 'test 'x))
(test-error (check-pair 'test 'x))
(test-error (check-vector 'test 'x))
(test-error (check-structure 'test 3 'x))
(test-error (check-symbol 'test 1))
(test-error (check-keyword 'test 'x))
(test-error (check-string 'test 'x))
(test-error (check-char 'test 'x))
(test-error (check-boolean 'test 'x))
(test-error (check-fixnum-in-range 'test 1 0 1))
(test-error (check-fixnum-in-range 'test #f 0 1))
(test-error (check-fixnum-in-range 'test -1 0 4))
)
(test-group "for success"
(test-check check-fixnum 1)
(test-check check-inexact 1.0)
(test-check check-integer 1.0)
(test-check check-integer 1)
(test-check check-number 1.0)
(test-check check-number 1)
(test-check check-procedure current-input-port)
(test-check check-input-port (current-input-port))
(test-check check-output-port (current-output-port))
(test-check check-list '(x))
(test-check check-pair '(x . y))
(test-check check-vector '#(x))
(test-check check-structure (##sys#make-structure 'x) 'x)
(test-check check-symbol 'x)
(test-check check-keyword #:x)
(test-check check-string "x")
(test-check check-char #\x)
(test-check check-boolean #t)
(test-check check-fixnum-in-range 1 0 2)
(test-check check-fixnum-in-range 0 0 2)
)
(test-group "error message"
(test '(test "bad argument type - not a fixnum" (#f))
(capture-error (check-fixnum 'test #f)))
)
;;;
(test-end "Sys")
(test-exit)

33
type-checks-atoms.scm Normal file
View file

@ -0,0 +1,33 @@
;;;; type-checks-atoms.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module type-checks-atoms ()
(import (chicken module)) ; for `export' & `reexport'
(import type-checks-numbers)
(reexport type-checks-numbers)
(export
check-symbol
check-keyword
check-char
check-boolean)
(import scheme)
(import (chicken base)) ; for `include'
(import (chicken type))
(import (only (chicken keyword) keyword?))
(import type-errors-atoms type-checks-basic)
(: check-symbol (* symbol #!optional * -> symbol))
(: check-keyword (* keyword #!optional * -> keyword))
(: check-char (* char #!optional * -> char))
(: check-boolean (* boolean #!optional * -> boolean))
(define-check-type symbol)
(define-check-type keyword)
(define-check-type char)
(define-check-type boolean)
) ;module type-checks-atoms

145
type-checks-basic.scm Normal file
View file

@ -0,0 +1,145 @@
;;;; type-checks-basic.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module type-checks-basic
(;export
;
define-check-type
define-check+error-type
;
check-defined-value
check-bound-value
check-minimum-argument-count check-argument-count)
(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import type-errors-basic)
(: check-defined-value (* 'a #!optional * -> 'a))
(: check-bound-value (* 'a #!optional * -> 'a))
(: check-minimum-argument-count (* fixnum fixnum -> fixnum))
(: check-argument-count (* fixnum fixnum -> fixnum))
;;
#| ;UNUSED
(define-syntax unbound-value
(syntax-rules ()
((unbound-value)
(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
(define-syntax unbound-value?
(syntax-rules ()
((unbound-value? ?val)
(eq? (unbound-value) ?val) ) ) )
(define-syntax unbound?
(syntax-rules ()
((unbound? ?sym)
(unbound-value? (##sys#slot ?sym 0)) ) ) )
|#
;;
(cond-expand
(unsafe
(define-syntax define-check-type
(er-macro-transformer
(lambda (frm rnm cmp)
(let ((_define (rnm 'define)))
(let* ((*typ (strip-syntax (cadr frm)))
(chknam (symbol-append 'check- *typ)) )
`(,_define (,chknam loc obj . _) obj) ) ) ) ) )
(define defined-value? (lambda _ #t))
(define bound-value? (lambda _ #t))
(define (check-minimum-argument-count loc obj . _) obj)
(define (check-argument-count loc obj . _) obj) )
(else
(define-syntax define-check-type
(er-macro-transformer
(lambda (frm rnm cmp)
(let ((_define (rnm 'define))
(_unless (rnm 'unless))
(_the (rnm 'the))
(_import (rnm 'import))
(_chicken (rnm 'chicken))
(_type (rnm 'type))
(_loc (rnm 'loc))
(_obj (rnm 'obj))
(_args (rnm 'args))
(_optional (rnm 'optional)) )
(let* ((*typ (strip-syntax (cadr frm)))
(pred (if (null? (cddr frm)) (symbol-append *typ '?)
(caddr frm)))
(chknam (symbol-append 'check- *typ))
(errnam (symbol-append 'error- *typ)) )
#; ;NOTE requires a defined type so ?
`(,begin
(,_define ,chknam)
(,_let ()
(: (* ,*typ #!optional * -> ,*typ))
(,_set! ,chknam (,_lambda (,_loc ,_obj . ,_args)
(,_unless (,pred (,_the * ,_obj))
(,errnam ,_loc ,_obj (,_optional ,_args)) )
,_obj ) ) ) )
;caller must add type annotation
;(: (* ,*typ #!optional * -> ,*typ)) ;cannot be pure - must be called!
`(,_define (,chknam ,_loc ,_obj . ,_args)
(,_import (,_chicken ,_type))
;must override compiler ideas about the actual value type
;passed, otherwise it assumes all good, sometimes, not
;always.
(,_unless (,pred (,_the * ,_obj))
(,errnam ,_loc ,_obj (,_optional ,_args)))
,_obj ) ) ) ) ) )
;; Is the object non-void?
(define (defined-value? obj) (not (eq? (void) obj)))
;; Is the object bound to value?
;is obj the value from the de-ref of an unbound variable.
;could only occur in a rather unsafe calling environnment.
(define (bound-value? obj) (not (##core#inline "C_unboundvaluep" obj)))
;;
(define (check-minimum-argument-count loc argc minargc)
(unless (<= minargc argc) (error-minimum-argument-count loc argc minargc))
argc )
(define (check-argument-count loc argc maxargc)
(unless (<= argc maxargc) (error-argument-count loc argc maxargc))
argc ) ) )
;;
(define-check-type defined-value)
(define-check-type bound-value)
;;
;<type-symbol> [<type-predicate> [<message-string>]]
(define-syntax define-check+error-type
(er-macro-transformer
(lambda (frm rnm cmp)
(let ((_begin (rnm 'begin))
(_define-check-type (rnm 'define-check-type))
(_define-error-type (rnm 'define-error-type)) )
(let* ((typ (cadr frm))
(pred (and (not (null? (cddr frm))) (caddr frm)))
(mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
`(,_begin
(,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
(,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )
) ;module type-checks-basic

35
type-checks-numbers.bignum.scm Normal file
View file

@ -0,0 +1,35 @@
;;;; type-checks-numbers.bignum.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers bignum)
(;export
check-bignum
check-positive-bignum check-non-negative-bignum check-negative-bignum
check-non-positive-bignum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers bignum))
(: check-bignum (* bignum #!optional * -> bignum))
(: check-positive-bignum (* bignum #!optional * -> bignum))
(: check-non-negative-bignum (* bignum #!optional * -> bignum ))
(: check-negative-bignum (* bignum #!optional * -> bignum))
(: check-non-positive-bignum (* bignum #!optional * -> bignum))
(define (positive-bignum? x) (and (bignum? x) (positive? x)))
(define (non-negative-bignum? x) (and (bignum? x) (or (zero? x) (positive? x))))
(define (negative-bignum? x) (and (bignum? x) (negative? x)))
(define (non-positive-bignum? x) (and (bignum? x) (or (zero? x) (negative? x))))
(define-check-type bignum)
(define-check-type positive-bignum)
(define-check-type non-negative-bignum)
(define-check-type negative-bignum)
(define-check-type non-positive-bignum)
) ;module (type-checks-numbers bignum)

19
type-checks-numbers.cplxnum.scm Normal file
View file

@ -0,0 +1,19 @@
;;;; type-checks-numbers.cplxnum.scm -*- Scheme -*-
(module (type-checks-numbers cplxnum)
(;export
check-cplxnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers cplxnum))
(: check-cplxnum (* cplxnum #!optional * -> cplxnum))
(define-check-type cplxnum)
) ;module (type-checks-numbers cplxnum)

38
type-checks-numbers.fixnum.scm Normal file
View file

@ -0,0 +1,38 @@
;;;; type-checks-numbers.fixnum.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers fixnum)
(;export
check-fixnum
check-positive-fixnum check-non-negative-fixnum check-natural-fixnum
check-negative-fixnum check-non-positive-fixnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import (chicken fixnum))
(import type-checks-basic)
(import (type-errors-numbers fixnum))
(: check-fixnum (* fixnum #!optional * -> fixnum))
(: check-positive-fixnum (* fixnum #!optional * -> fixnum))
(: check-non-negative-fixnum (* fixnum #!optional * -> fixnum))
(: check-natural-fixnum (* fixnum #!optional * -> fixnum))
(: check-negative-fixnum (* fixnum #!optional * -> fixnum))
(: check-non-positive-fixnum (* fixnum #!optional * -> fixnum))
(define (positive-fixnum? x) (and (fixnum? x) (fx< 0 x)))
(define (non-negative-fixnum? x) (and (fixnum? x) (fx<= 0 x)))
(define (negative-fixnum? x) (and (fixnum? x) (fx> 0 x)))
(define (non-positive-fixnum? x) (and (fixnum? x) (fx>= 0 x)))
(define-check-type fixnum)
(define-check-type positive-fixnum)
(define-check-type non-negative-fixnum)
(define check-natural-fixnum check-non-negative-fixnum)
(define-check-type negative-fixnum)
(define-check-type non-positive-fixnum)
) ;module (type-checks-numbers fixnum)

37
type-checks-numbers.flonum.scm Normal file
View file

@ -0,0 +1,37 @@
;;;; type-checks-numbers.flonum.scm -*- Scheme -*-
(module (type-checks-numbers flonum)
(;export
check-flonum check-float
check-positive-flonum check-non-negative-flonum check-negative-flonum
check-non-positive-flonum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import (chicken flonum))
(import type-checks-basic)
(import (type-errors-numbers flonum))
(: check-float (* float #!optional * -> float))
(: check-flonum (* float #!optional * -> float))
(: check-positive-flonum (* float #!optional * -> float))
(: check-non-negative-flonum (* float #!optional * -> float))
(: check-negative-flonum (* float #!optional * -> float))
(: check-non-positive-flonum (* float #!optional * -> float))
(define (positive-flonum? x) (and (flonum? x) (fp< 0.0 x)))
(define (non-negative-flonum? x) (and (flonum? x) (fp<= 0.0 x)))
(define (negative-flonum? x) (and (flonum? x) (fp> 0.0 x)))
(define (non-positive-flonum? x) (and (flonum? x) (fp>= 0.0 x)))
(define-check-type flonum)
(define check-float check-flonum)
(define-check-type positive-flonum)
(define-check-type non-negative-flonum)
(define-check-type negative-flonum)
(define-check-type non-positive-flonum)
) ;module (type-checks-numbers flonum)

37
type-checks-numbers.integer.scm Normal file
View file

@ -0,0 +1,37 @@
;;;; type-checks-numbers.integer.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers integer)
(;export
check-integer
check-positive-integer check-non-negative-integer check-natural-integer
check-negative-integer check-non-positive-integer)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers integer))
(: check-integer (* integer #!optional * -> integer))
(: check-positive-integer (* integer #!optional * -> integer))
(: check-non-negative-integer (* integer #!optional * -> integer))
(: check-natural-integer (* integer #!optional * -> integer))
(: check-negative-integer (* integer #!optional * -> integer))
(: check-non-positive-integer (* integer #!optional * -> integer))
(define (positive-integer? x) (and (integer? x) (positive? x)))
(define (non-negative-integer? x) (and (integer? x) (or (zero? x) (positive? x))))
(define (negative-integer? x) (and (integer? x) (negative? x)))
(define (non-positive-integer? x) (and (integer? x) (or (zero? x) (negative? x))))
(define-check-type integer)
(define-check-type positive-integer)
(define-check-type non-negative-integer)
(define check-natural-integer check-non-negative-integer)
(define-check-type negative-integer)
(define-check-type non-positive-integer)
) ;module (type-checks-numbers integer)

64
type-checks-numbers.interval.scm Normal file
View file

@ -0,0 +1,64 @@
;;;; type-checks-numbers.interval.scm -*- Scheme -*-
(module (type-checks-numbers interval)
(;export
;
check-range
;
check-closed-interval check-open-interval
check-half-closed-interval check-half-open-interval)
(import scheme)
(import (chicken base))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers interval))
(: check-range (* number number #!optional * -> number number))
(: check-closed-interval (* number number number #!optional * -> number))
(: check-open-interval (* number number number #!optional * -> number))
(: check-half-closed-interval (* number number number #!optional * -> number))
(: check-half-open-interval (* number number number #!optional * -> number))
(cond-expand
(unsafe
(define (check-range loc obj . _) obj) )
(define (check-closed-interval loc obj . _) obj)
(define (check-open-interval loc obj . _) obj)
(define (check-half-closed-interval loc obj . _) obj)
(define (check-half-open-interval loc obj . _) obj)
(else
;check half-closed-interval itself
(define (check-range loc start end . args)
(unless (<= start end)
(error-range loc start end (optional args)) )
(values start end) )
(define (check-closed-interval loc num min max . args)
(unless (and (<= min num) (<= num max))
(error-closed-interval loc num min max (optional args)))
num )
(define (check-open-interval loc num min max . args)
(unless (and (< min num) (< num max))
(error-open-interval loc num min max (optional args)))
num )
(define (check-half-open-interval loc num min max . args)
(unless (and (< min num) (<= num max))
(error-half-open-interval loc num min max (optional args)))
num )
(define (check-half-closed-interval loc num min max . args)
(unless (and (<= min num) (< num max))
(error-half-closed-interval loc num min max (optional args)))
num) ) )
) ;module (type-checks-numbers interval)

37
type-checks-numbers.number.scm Normal file
View file

@ -0,0 +1,37 @@
;;;; type-checks-numbers.number.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers number)
(;export
check-number
check-positive-number check-non-negative-number check-natural-number
check-negative-number check-non-positive-number)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers number))
(: check-number (* number #!optional * -> number))
(: check-positive-number (* number #!optional * -> number))
(: check-non-negative-number (* number #!optional * -> number))
(: check-natural-number (* number #!optional * -> number))
(: check-negative-number (* number #!optional * -> number))
(: check-non-positive-number (* number #!optional * -> number))
(define (positive-number? x) (and (number? x) (positive? x)))
(define (non-negative-number? x) (and (number? x) (or (zero? x) (positive? x))))
(define (negative-number? x) (and (number? x) (negative? x)))
(define (non-positive-number? x) (and (number? x) (or (zero? x) (negative? x))))
(define-check-type number)
(define-check-type positive-number)
(define-check-type non-negative-number)
(define check-natural-number check-non-negative-number)
(define-check-type negative-number)
(define-check-type non-positive-number)
) ;module (type-checks-numbers number)

35
type-checks-numbers.ratnum.scm Normal file
View file

@ -0,0 +1,35 @@
;;;; type-checks-numbers.ratnum.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers ratnum)
(;export
check-ratnum
check-positive-ratnum check-non-negative-ratnum check-negative-ratnum
check-non-positive-ratnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers ratnum))
(: check-ratnum (* ratnum #!optional * -> ratnum))
(: check-positive-ratnum (* ratnum #!optional * -> ratnum))
(: check-non-negative-ratnum (* ratnum #!optional * -> ratnum ))
(: check-negative-ratnum (* ratnum #!optional * -> ratnum))
(: check-non-positive-ratnum (* ratnum #!optional * -> ratnum))
(define (positive-ratnum? x) (and (ratnum? x) (positive? x)))
(define (non-negative-ratnum? x) (and (ratnum? x) (or (zero? x) (positive? x))))
(define (negative-ratnum? x) (and (ratnum? x) (negative? x)))
(define (non-positive-ratnum? x) (and (ratnum? x) (or (zero? x) (negative? x))))
(define-check-type ratnum)
(define-check-type positive-ratnum)
(define-check-type non-negative-ratnum)
(define-check-type negative-ratnum)
(define-check-type non-positive-ratnum)
) ;module (type-checks-numbers ratnum)

32
type-checks-numbers.scheme.scm Normal file
View file

@ -0,0 +1,32 @@
;;;; type-checks-numbers.scheme.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module (type-checks-numbers scheme)
(;export
check-real
check-complex
check-rational
check-exact
check-inexact)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-checks-basic)
(import (type-errors-numbers scheme))
(: check-real (* number #!optional * -> number))
(: check-complex (* number #!optional * -> number))
(: check-rational (* number #!optional * -> number))
(: check-exact (* number #!optional * -> number))
(: check-inexact (* number #!optional * -> number))
(define-check-type real)
(define-check-type complex)
(define-check-type rational)
(define-check-type exact)
(define-check-type inexact)
) ;module (type-checks-numbers scheme)

38
type-checks-numbers.scm Normal file
View file

@ -0,0 +1,38 @@
;;;; type-checks-numbers.scm -*- Scheme -*-
;;;; Kon Lovett, Jun '18
(module type-checks-numbers ()
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import (type-checks-numbers interval))
(reexport (type-checks-numbers interval))
(import (type-checks-numbers scheme))
(reexport (type-checks-numbers scheme))
(import (type-checks-numbers number))
(reexport (type-checks-numbers number))
(import (type-checks-numbers fixnum))
(reexport (type-checks-numbers fixnum))
(import (type-checks-numbers integer))
(reexport (type-checks-numbers integer))
(import (type-checks-numbers bignum))
(reexport (type-checks-numbers bignum))
(import (type-checks-numbers ratnum))
(reexport (type-checks-numbers ratnum))
(import (type-checks-numbers flonum))
(reexport (type-checks-numbers flonum))
(import (type-checks-numbers cplxnum))
(reexport (type-checks-numbers cplxnum))
) ;module type-checks-numbers

129
type-checks-structured.scm Normal file
View file

@ -0,0 +1,129 @@
;;;; type-checks-structured.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(declare (bound-to-procedure ##sys#structure?))
(module type-checks-structured
(;export
check-procedure check-closure
check-input-port
check-output-port
check-list
check-alist
check-plist
check-pair
check-vector
check-structure
check-record
check-record-type
check-string
;
define-check-structure)
(import scheme)
(import (chicken base)) ; for `include'
(import (chicken type))
(import (chicken syntax))
(import type-errors-structured type-checks-basic)
;(import-for-syntax (only (chicken base) symbol-append))
;FIXME (struct 't) ?
(: check-structure (* 'a * #!optional * -> 'a))
(: check-record (* 'a * #!optional * -> 'a))
(: check-record-type (* 'a * #!optional * -> 'a))
(: check-string (* string #!optional * -> string))
(: check-procedure (* procedure #!optional * -> procedure))
(: check-closure (* procedure #!optional * -> procedure))
(: check-input-port (* input-port #!optional * -> input-port))
(: check-output-port (* output-port #!optional * -> output-port))
(: check-list (* list #!optional * -> list))
(: check-plist (* list #!optional * -> list)) ;? (alist-of p?) -> (* -> boolean : 'a)
(: check-alist (* list #!optional * -> list)) ;? (plist-of p?) -> (* -> boolean : 'a)
(: check-pair (* pair #!optional * -> pair))
(: check-vector (* vector #!optional * -> vector))
(cond-expand
(unsafe
(define alist? (lambda _ #t))
(define plist? (lambda _ #t))
(define (check-structure loc obj . _) obj)
(define (check-record loc obj . _) obj)
(define (check-record-type loc obj . _) obj) )
(else
;;These are weak predicates. Only check for structure.
(define-inline (list-every p? obj)
(and (list? obj)
(let every ((ls obj))
(or (null? ls)
(and (p? (car ls))
(every (cdr ls) ) ) ) ) ) )
(define (alist? obj)
(list-every pair? obj) )
(define (plist? obj)
(and (list? obj) (even? (length obj))) )
;;
;NOTE the module must export the tag as a binding, not all do! (allows generated tags)
(define (check-structure loc obj tag . args)
(unless (##sys#structure? obj tag)
(error-structure loc obj tag (optional args)))
obj )
(define (check-record loc obj tag . args)
(unless (##sys#structure? obj tag)
(error-record loc obj tag (optional args)))
obj )
(define (check-record-type loc obj tag . args)
(unless (##sys#structure? obj tag)
(error-record-type loc obj tag (optional args)))
obj ) ) )
;;
(define-check-type string)
(define-check-type procedure)
(define check-closure check-procedure)
(define-check-type input-port)
(define-check-type output-port)
(define-check-type list)
(define-check-type plist)
(define-check-type alist)
(define-check-type pair)
(define-check-type vector)
;NOTE the module really should export the tag as a binding, not all do!
;(allows named generated tags) but this allows a non-symbol tag value w/
;a symbol name
(define-syntax define-check-structure
(er-macro-transformer
(lambda (frm rnm cmp)
(let ((_define (rnm 'define))
(_apply (rnm 'apply))
(_loc (rnm 'loc))
(_obj (rnm 'obj))
(_args (rnm 'args))
(_check-structure (rnm 'check-structure)))
;FIXME strip-syntax tag ?
(let* ((tagnam (cadr frm))
(tag (if (null? (cddr frm)) tagnam (caddr frm)))
(nam (symbol-append 'check- (strip-syntax tagnam))) )
;FIXME apply for known, single, optional arg - #!optional needs rnm?
`(,_define (,nam ,_loc ,_obj . ,_args)
(,_apply ,_check-structure ,_loc ,_obj ,tag ,_args)) ) ) ) ) )
) ;module type-checks-structured

14
type-checks.scm Normal file
View file

@ -0,0 +1,14 @@
;;;; type-checks.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Apr '09
(module type-checks ()
(import scheme)
(import (chicken module))
(import type-checks-basic type-checks-atoms type-checks-structured)
(reexport type-checks-basic type-checks-atoms type-checks-structured)
) ;module type-checks

31
type-errors-atoms.scm Normal file
View file

@ -0,0 +1,31 @@
;;;; type-errors-atoms.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-atoms
(;export
error-symbol
error-keyword
error-char
error-boolean)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(import type-errors-numbers)
(reexport type-errors-numbers)
(: error-symbol (* * #!optional * -> noreturn))
(: error-keyword (* * #!optional * -> noreturn))
(: error-char (* * #!optional * -> noreturn))
(: error-boolean (* * #!optional * -> noreturn))
(define-error-type symbol)
(define-error-type keyword)
(define-error-type char)
(define-error-type boolean)
) ;module type-errors-atoms

158
type-errors-basic.scm Normal file
View file

@ -0,0 +1,158 @@
;;;; type-errors-basic.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;; Notes
;;
;; - The type error message is built so as to `look' like those of the
;; CHICKEN "core". Only with optional information.
;; Issues
;;
;; - Maybe "... not an integer" -> "... integer required" &
;; "... not a list" -> "... list required",
;; or "... not integer", ...
(module type-errors-basic
(;export
;
make-location-message
make-bad-argument-message
make-type-name-message
make-tagged-kind-message
make-error-type-message
make-error-interval-message
make-warning-type-message
make-arity-low-message
make-arity-message
;
signal-bounds-error signal-type-error signal-arity-error
;
error-argument-type
warning-argument-type
;
error-bound-value
error-defined-value
;
error-minimum-argument-count
error-argument-count
;
define-error-type)
(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken string) ->string) (only (chicken format) format))
(define (->boolean x) (and x #t))
;message api
(: make-location-message (* --> string))
(: make-bad-argument-message (#!optional * --> string))
(: make-type-name-message (* --> string))
(: make-tagged-kind-message (* * --> string))
(: make-error-type-message (* #!optional * --> string))
(: make-error-interval-message (* * * * #!optional * --> string))
(: make-warning-type-message (* * * #!optional * --> string))
(: make-arity-low-message (fixnum fixnum --> string))
(: make-arity-message (fixnum fixnum --> string))
(cond-expand
(else ;default `en'
(include-relative "type-errors-en.incl") ) )
;;
(define-syntax warning-argument-type
(syntax-rules ()
((warning-argument-type ?loc ?obj ?typnam)
(warning-argument-type ?loc ?obj ?typnam #f) )
((warning-argument-type ?loc ?obj ?typnam ?argnam)
(warning (make-warning-type-message ?loc ?obj ?typnam ?argnam)) ) ) )
;
(define-syntax signal-bounds-error
(syntax-rules ()
((signal-bounds-error ?loc ?objs ...)
(##sys#signal-hook #:bounds-error ?loc ?objs ...) ) ) )
(define-syntax signal-type-error
(syntax-rules ()
((signal-type-error ?loc ?objs ...)
(##sys#signal-hook #:type-error ?loc ?objs ...) ) ) )
(define-syntax signal-arity-error
(syntax-rules ()
((signal-arity-error ?loc ?objs ...)
(##sys#signal-hook #:arity-error ?loc ?objs ...) ) ) )
;
(define-syntax error-argument-type
(syntax-rules ()
((error-argument-type ?loc ?obj ?typnam)
(error-argument-type ?loc ?obj ?typnam #f) )
((error-argument-type ?loc ?obj ?typnam ?argnam)
(signal-type-error ?loc (make-error-type-message ?typnam ?argnam) ?obj) ) ) )
;
(define-syntax error-bound-value
(syntax-rules ()
((error-bound-value ?loc ?obj)
(error-bound-value ?loc ?obj #f) )
((error-bound-value ?loc ?obj ?argnam)
(error-argument-type ?loc "#<unbound>" "bound-value" ?argnam) ) ) )
(define-syntax error-defined-value
(syntax-rules ()
((error-defined-value ?loc ?obj)
(error-defined-value ?loc ?obj #f) )
((error-defined-value ?loc ?obj ?argnam)
(error-argument-type ?loc "#<unspecified>" "defined-value" ?argnam) ) ) )
;
;nothing to add to the error message, so builtin direct
(define-syntax error-argument-count
(syntax-rules ()
((error-argument-count ?loc ?argc ?maxargc)
(signal-arity-error ?loc (make-arity-message ?argc ?maxargc)) ) ) )
(define-syntax error-minimum-argument-count
(syntax-rules ()
((error-minimum-argument-count ?loc ?argc ?minargc)
(signal-arity-error ?loc (make-arity-low-message ?argc ?minargc)) ) ) )
;
; <symbol> : <typnam> is "<symbol>"
; <symbol> <string> : <typnam> is <string>
; (actually weaker preconditions than the above)
; ->
; (define (error-<symbol> loc obj #!optional argnam)
; (error-argument-type loc obj <typnam> argnam) )
(define-syntax define-error-type
(er-macro-transformer
(lambda (frm rnm cmp)
(let ((_define (rnm 'define))
#; ;FIXME apply for known, single, optional arg - #!optional needs rnm?
(_#!optional (rnm '#!optional))
(_loc (rnm 'loc))
(_obj (rnm 'obj))
(_argnam (rnm 'argnam))
(_error-argument-type (rnm 'error-argument-type)) )
(let* ((*typ (strip-syntax (cadr frm)))
(typnam (if (null? (cddr frm)) *typ (caddr frm)))
(nam (symbol-append 'error- *typ)) )
`(,_define (,nam ,_loc ,_obj #!optional ,_argnam)
(,_error-argument-type ,_loc ,_obj ',typnam ,_argnam) ) ) ) ) ) )
) ;module type-errors-basic

74
type-errors-en.incl.scm Normal file
View file

@ -0,0 +1,74 @@
;;;; type-errors-en.incl.scm -*- Scheme -*-
;; Notes
;;
;; - The type error message is built so as to `look' like those of the
;; CHICKEN "core". Only with optional information.
;; Issues
;;
;; - Maybe "... not an integer" -> "... integer required" &
;; "... not a list" -> "... list required",
;; or "... not integer", ...
;w/o SRFI 29 (xtd w/ source/binary) then cond-expand of includes
;in this case never #\y
(define (vowel? ch)
(->boolean (memq ch '(#\a #\e #\i #\o #\u))) )
(define (1st-letter s)
(and (not (zero? (string-length s)))
(string-ref s 0)) )
(define (indefinite-article s) (if (vowel? (1st-letter s)) "an" "a"))
(define (make-location-message loc)
(string-append "(" (->string loc) ")") )
(define (make-tagged-kind-message kndnam tag)
(string-append (->string kndnam) " " (->string tag)) )
(define (make-type-name-message typnam)
(let ((typstr (->string typnam)))
(string-append (indefinite-article typstr) " " typstr) ) )
(define (make-bad-argument-message #!optional argnam)
(if (not argnam)
"bad argument"
(string-append "bad `" (->string argnam) "' argument") ) )
(define (type-name-clause typnam)
(string-append "not " (make-type-name-message typnam)) )
(define (bad-argument-clause argnam)
(string-append (make-bad-argument-message argnam) " type") )
(define (make-error-type-message typnam #!optional argnam)
;a type-error-clause for the, optionally api-dependent, named type
(string-append (bad-argument-clause argnam) " - " (type-name-clause typnam)) )
(define (interval-name lft min max rgt)
(string-append (->string lft) (->string min) " " (->string max) (->string rgt)) )
(define (make-error-interval-message lft min max rgt #!optional argnam)
(string-append (make-bad-argument-message argnam)
" must be in "
(interval-name lft min max rgt)) )
(define (location-clause loc)
(if (not loc)
""
(string-append (make-location-message loc) " ")) )
(define (typed-object-error-clause obj typnam #!optional argnam)
(string-append (make-error-type-message typnam argnam) ": " (->string obj)) )
(define (make-warning-type-message loc obj typnam #!optional argnam)
(string-append (location-clause loc) (typed-object-error-clause obj typnam argnam)) )
(define (make-arity-low-message argc minargc)
(format #f "too few arguments - received ~A but expected ~A" argc minargc) )
(define (make-arity-message argc maxargc)
(format #f "bad argument count - received ~A but expected ~A" argc maxargc) )

29
type-errors-numbers.bignum.scm Normal file
View file

@ -0,0 +1,29 @@
;;;; type-errors-numbers.bignum.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers.bignum
(;export
error-bignum
error-positive-bignum error-non-negative-bignum error-negative-bignum
error-non-positive-bignum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-bignum (* * #!optional * -> noreturn))
(: error-positive-bignum (* * #!optional * -> noreturn))
(: error-non-negative-bignum (* * #!optional * -> noreturn))
(: error-negative-bignum (* * #!optional * -> noreturn))
(: error-non-positive-bignum (* * #!optional * -> noreturn))
(define-error-type bignum)
(define-error-type positive-bignum)
(define-error-type non-negative-bignum)
(define-error-type negative-bignum)
(define-error-type non-positive-bignum)
) ;module type-errors-numbers.bignum

18
type-errors-numbers.cplxnum.scm Normal file
View file

@ -0,0 +1,18 @@
;;;; type-errors-numbers.cplxnum.scm -*- Scheme -*-
(module type-errors-numbers.cplxnum
(;export
error-cplxnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-cplxnum (* * #!optional * -> noreturn))
(define-error-type cplxnum)
) ;module type-errors-numbers.cplxnum

31
type-errors-numbers.fixnum.scm Normal file
View file

@ -0,0 +1,31 @@
;;;; type-errors-numbers.fixnum.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers.fixnum
(;export
error-fixnum
error-positive-fixnum error-non-negative-fixnum error-natural-fixnum
error-negative-fixnum error-non-positive-fixnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-fixnum (* * #!optional * -> noreturn))
(: error-positive-fixnum (* * #!optional * -> noreturn))
(: error-non-negative-fixnum (* * #!optional * -> noreturn))
(: error-natural-fixnum (* * #!optional * -> noreturn))
(: error-negative-fixnum (* * #!optional * -> noreturn))
(: error-non-positive-fixnum (* * #!optional * -> noreturn))
(define-error-type fixnum)
(define-error-type positive-fixnum)
(define-error-type non-negative-fixnum)
(define error-natural-fixnum error-non-negative-fixnum)
(define-error-type negative-fixnum)
(define-error-type non-positive-fixnum)
) ;module type-errors-numbers.fixnum

30
type-errors-numbers.flonum.scm Normal file
View file

@ -0,0 +1,30 @@
;;;; type-errors-numbers.flonum.scm -*- Scheme -*-
(module type-errors-numbers.flonum
(;export
error-flonum error-float
error-positive-flonum error-non-negative-flonum error-negative-flonum
error-non-positive-flonum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-float (* * #!optional * -> noreturn))
(: error-flonum (* * #!optional * -> noreturn))
(: error-positive-flonum (* * #!optional * -> noreturn))
(: error-non-negative-flonum (* * #!optional * -> noreturn))
(: error-negative-flonum (* * #!optional * -> noreturn))
(: error-non-positive-flonum (* * #!optional * -> noreturn))
(define-error-type flonum)
(define error-float error-flonum)
(define-error-type positive-flonum)
(define-error-type non-negative-flonum)
(define-error-type negative-flonum)
(define-error-type non-positive-flonum)
) ;module type-errors-numbers.flonum

31
type-errors-numbers.integer.scm Normal file
View file

@ -0,0 +1,31 @@
;;;; type-errors-numbers.integer.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers.integer
(;export
error-integer
error-positive-integer error-non-negative-integer error-natural-integer
error-negative-integer error-non-positive-integer)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-integer (* * #!optional * -> noreturn))
(: error-positive-integer (* * #!optional * -> noreturn))
(: error-non-negative-integer (* * #!optional * -> noreturn))
(: error-natural-integer (* * #!optional * -> noreturn))
(: error-negative-integer (* * #!optional * -> noreturn))
(: error-non-positive-integer (* * #!optional * -> noreturn))
(define-error-type integer)
(define-error-type positive-integer)
(define-error-type non-negative-integer)
(define error-natural-integer error-non-negative-integer)
(define-error-type negative-integer)
(define-error-type non-positive-integer)
) ;module type-errors-numbers.integer

44
type-errors-numbers.interval.scm Normal file
View file

@ -0,0 +1,44 @@
;;;; type-errors-numbers.interval.scm -*- Scheme -*-
(module (type-errors-numbers interval)
(;export
;
error-range
;
error-interval
error-closed-interval error-open-interval
error-half-open-interval error-half-closed-interval)
(import scheme)
(import (chicken base))
(import (chicken type))
(import type-errors-basic)
(: error-range (* number number #!optional * -> noreturn))
(: error-interval (* * * number number * #!optional * -> noreturn))
(: error-closed-interval (* * number number #!optional * -> noreturn))
(: error-open-interval (* * number number #!optional * -> noreturn))
(: error-half-open-interval (* * number number #!optional * -> noreturn))
(: error-half-closed-interval (* * number number #!optional * -> noreturn))
(define (error-range loc start end #!optional argnam)
(signal-bounds-error loc (make-bad-argument-message argnam) start end) )
(define (error-interval loc num lft min max rgt #!optional argnam)
(signal-bounds-error loc (make-error-interval-message lft min max rgt argnam) num) )
(define (error-closed-interval loc num min max #!optional argnam)
(error-interval loc num #\[ min max #\] argnam) )
(define (error-open-interval loc num min max #!optional argnam)
(error-interval loc num #\( min max #\) argnam) )
(define (error-half-open-interval loc num min max #!optional argnam)
(error-interval loc num #\( min max #\] argnam) )
(define (error-half-closed-interval loc num min max #!optional argnam)
(error-interval loc num #\[ min max #\) argnam) )
) ;module (type-errors-numbers interval)

30
type-errors-numbers.number.scm Normal file
View file

@ -0,0 +1,30 @@
;;;; type-errors-numbers.number.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers.number
(;export
error-number error-positive-number error-non-negative-number
error-natural-number error-negative-number error-non-positive-number)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-number (* * #!optional * -> noreturn))
(: error-positive-number (* * #!optional * -> noreturn))
(: error-non-negative-number (* * #!optional * -> noreturn))
(: error-natural-number (* * #!optional * -> noreturn))
(: error-negative-number (* * #!optional * -> noreturn))
(: error-non-positive-number (* * #!optional * -> noreturn))
(define-error-type number)
(define-error-type positive-number)
(define-error-type non-negative-number)
(define error-natural-number error-non-negative-number)
(define-error-type negative-number)
(define-error-type non-positive-number)
) ;module type-errors-numbers.number

29
type-errors-numbers.ratnum.scm Normal file
View file

@ -0,0 +1,29 @@
;;;; type-errors-numbers.ratnum.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers.ratnum
(;export
error-ratnum
error-positive-ratnum error-non-negative-ratnum error-negative-ratnum
error-non-positive-ratnum)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-ratnum (* * #!optional * -> noreturn))
(: error-positive-ratnum (* * #!optional * -> noreturn))
(: error-non-negative-ratnum (* * #!optional * -> noreturn))
(: error-negative-ratnum (* * #!optional * -> noreturn))
(: error-non-positive-ratnum (* * #!optional * -> noreturn))
(define-error-type ratnum)
(define-error-type positive-ratnum)
(define-error-type non-negative-ratnum)
(define-error-type negative-ratnum)
(define-error-type non-positive-ratnum)
) ;module type-errors-numbers.ratnum

30
type-errors-numbers.scheme.scm Normal file
View file

@ -0,0 +1,30 @@
;;;; type-errors-numbers.scheme.scm -*- Scheme -*-
(module type-errors-numbers.scheme
(;export
error-real
error-complex
error-rational
error-exact
error-inexact)
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(: error-real (* * #!optional * -> noreturn))
(: error-complex (* * #!optional * -> noreturn))
(: error-rational (* * #!optional * -> noreturn))
(: error-exact (* * #!optional * -> noreturn))
(: error-inexact (* * #!optional * -> noreturn))
(define-error-type real)
(define-error-type complex)
(define-error-type rational)
(define-error-type exact)
(define-error-type inexact)
) ;module type-errors-numbers.scheme

39
type-errors-numbers.scm Normal file
View file

@ -0,0 +1,39 @@
;;;; type-errors-numbers.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-numbers ()
(import scheme)
(import (chicken base))
(import (chicken module))
(import (chicken type))
(import type-errors-basic)
(import (type-errors-numbers interval))
(reexport (type-errors-numbers interval))
(import (type-errors-numbers scheme))
(reexport (type-errors-numbers scheme))
(import (type-errors-numbers number))
(reexport (type-errors-numbers number))
(import (type-errors-numbers fixnum))
(reexport (type-errors-numbers fixnum))
(import (type-errors-numbers integer))
(reexport (type-errors-numbers integer))
(import (type-errors-numbers bignum))
(reexport (type-errors-numbers bignum))
(import (type-errors-numbers ratnum))
(reexport (type-errors-numbers ratnum))
(import (type-errors-numbers flonum))
(reexport (type-errors-numbers flonum))
(import (type-errors-numbers cplxnum))
(reexport (type-errors-numbers cplxnum))
) ;module type-errors-numbers

61
type-errors-structured.scm Normal file
View file

@ -0,0 +1,61 @@
;;;; type-errors-structured.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
(module type-errors-structured ()
(import (chicken module))
(export
error-procedure error-closure
error-input-port
error-output-port
error-list
error-plist
error-alist
error-pair
error-vector
error-structure
error-record
error-record-type
error-string)
(import scheme)
(import (chicken base)) ; for `include'
(import (chicken type))
(import type-errors-basic)
(: error-procedure (* * #!optional * -> noreturn))
(: error-closure (* * #!optional * -> noreturn))
(: error-input-port (* * #!optional * -> noreturn))
(: error-output-port (* * #!optional * -> noreturn))
(: error-list (* * #!optional * -> noreturn))
(: error-plist (* * #!optional * -> noreturn))
(: error-alist (* * #!optional * -> noreturn))
(: error-pair (* * #!optional * -> noreturn))
(: error-vector (* * #!optional * -> noreturn))
(: error-string (* * #!optional * -> noreturn))
(: error-structure (* * * #!optional * -> noreturn))
(: error-record (* * * #!optional * -> noreturn))
(: error-record-type (* * * #!optional * -> noreturn))
(define-error-type procedure)
(define error-closure error-procedure)
(define-error-type input-port)
(define-error-type output-port)
(define-error-type list)
(define-error-type plist "property-list")
(define-error-type alist "association-list")
(define-error-type pair)
(define-error-type vector)
(define-error-type string)
(define (error-structure loc obj tag #!optional argnam)
(error-argument-type loc obj (make-tagged-kind-message 'structure tag) argnam) )
(define (error-record loc obj tag #!optional argnam)
(error-argument-type loc obj (make-tagged-kind-message 'record tag) argnam) )
(define (error-record-type loc obj tag #!optional argnam)
(error-argument-type loc obj (make-tagged-kind-message 'record-type tag) argnam) )
) ;module type-errors-structured

14
type-errors.scm Normal file
View file

@ -0,0 +1,14 @@
;;;; type-errors.scm -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Apr '09
(module type-errors ()
(import scheme)
(import (chicken module))
(import type-errors-basic type-errors-atoms type-errors-structured)
(reexport type-errors-basic type-errors-atoms type-errors-structured)
) ;module type-errors