Port to Chicken 6
This commit is contained in:
commit
ad7cfddc7d
GPG key ID:
B38976E82C9DAE42
46 changed files with 2703 additions and 0 deletions
2
.envrc
Normal file
2
.envrc
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
export NIXPKGS_ALLOW_BROKEN=1
|
||||
use nix
|
||||
3
README.org
Normal file
3
README.org
Normal 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
12
check-errors.basic.scm
Normal 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
150
check-errors.egg
Normal 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
4
check-errors.release-info
Normal 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
14
check-errors.scm
Normal 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
249
check-errors.sys.scm
Normal 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
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.
|
||||
'';
|
||||
};
|
||||
|
||||
})
|
||||
59
nix/sdl3.nix
Normal file
59
nix/sdl3.nix
Normal 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
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="$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
48
srfi-4-checks.scm
Normal 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
58
srfi-4-errors.scm
Normal 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
200
tests/check-errors-strict-test.scm
Normal 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
177
tests/check-errors-test.scm
Normal 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
4
tests/run.scm
Normal 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
94
tests/sys-checks-test.scm
Normal 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
33
type-checks-atoms.scm
Normal 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
145
type-checks-basic.scm
Normal 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
35
type-checks-numbers.bignum.scm
Normal 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
19
type-checks-numbers.cplxnum.scm
Normal 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
38
type-checks-numbers.fixnum.scm
Normal 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
37
type-checks-numbers.flonum.scm
Normal 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
37
type-checks-numbers.integer.scm
Normal 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
64
type-checks-numbers.interval.scm
Normal 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
37
type-checks-numbers.number.scm
Normal 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
35
type-checks-numbers.ratnum.scm
Normal 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
32
type-checks-numbers.scheme.scm
Normal 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
38
type-checks-numbers.scm
Normal 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
129
type-checks-structured.scm
Normal 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
14
type-checks.scm
Normal 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
31
type-errors-atoms.scm
Normal 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
158
type-errors-basic.scm
Normal 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
74
type-errors-en.incl.scm
Normal 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
29
type-errors-numbers.bignum.scm
Normal 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
18
type-errors-numbers.cplxnum.scm
Normal 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
31
type-errors-numbers.fixnum.scm
Normal 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
30
type-errors-numbers.flonum.scm
Normal 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
31
type-errors-numbers.integer.scm
Normal 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
44
type-errors-numbers.interval.scm
Normal 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
30
type-errors-numbers.number.scm
Normal 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
29
type-errors-numbers.ratnum.scm
Normal 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
30
type-errors-numbers.scheme.scm
Normal 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
39
type-errors-numbers.scm
Normal 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
61
type-errors-structured.scm
Normal 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
14
type-errors.scm
Normal 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
|
||||
Loading…
Reference in a new issue