uim-1.8.8/0000755000175000017500000000000013275405531007330 500000000000000uim-1.8.8/config.sub0000755000175000017500000010645013275405273011244 00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2018 Free Software Foundation, Inc. timestamp='2018-02-22' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # Please send patches to . # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS Canonicalize a configuration name. Options: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright 1992-2018 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo "$1" exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ kopensolaris*-gnu* | cloudabi*-eabi* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; android-linux) os=-linux-android basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown ;; *) basic_machine=`echo "$1" | sed 's/-[^-]*$//'` if [ "$basic_machine" != "$1" ] then os=`echo "$1" | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze*) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -lynx*178) os=-lynxos178 ;; -lynx*5) os=-lynxos5 ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-sequent/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | aarch64 | aarch64_be \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arceb \ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ | avr | avr32 \ | ba \ | be32 | be64 \ | bfin \ | c4x | c8051 | clipper \ | d10v | d30v | dlx | dsp16xx \ | e2k | epiphany \ | fido | fr30 | frv | ft32 \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ | i370 | i860 | i960 | ia16 | ia64 \ | ip2k | iq2000 \ | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \ | open8 | or1k | or1knd | or32 \ | pdp10 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pru \ | pyramid \ | riscv32 | riscv64 \ | rl78 | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | visium \ | wasm32 \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; leon|leon[3-9]) basic_machine=sparc-$basic_machine ;; m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xgate) basic_machine=$basic_machine-unknown os=-none ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`"$1"\': machine \`"$basic_machine"\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | aarch64-* | aarch64_be-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | ba-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | c8051-* | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | e2k-* | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ | ip2k-* | iq2000-* \ | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ | microblaze-* | microblazeel-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pru-* \ | pyramid-* \ | riscv32-* | riscv64-* \ | rl78-* | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | visium-* \ | wasm32-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-pc os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; asmjs) basic_machine=asmjs-unknown ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2*) basic_machine=m68k-bull os=-sysv3 ;; e500v[12]) basic_machine=powerpc-unknown os=$os"spe" ;; e500v[12]-*) basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=$os"spe" ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; i*86v32) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; leon-*|leon[3-9]-*) basic_machine=sparc-`echo "$basic_machine" | sed 's/-.*//'` ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze*) basic_machine=microblaze-xilinx ;; mingw64) basic_machine=x86_64-pc os=-mingw64 ;; mingw32) basic_machine=i686-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; moxiebox) basic_machine=moxie-unknown os=-moxiebox ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo "$basic_machine" | sed -e 's/ms1-/mt-/'` ;; msys) basic_machine=i686-pc os=-msys ;; mvs) basic_machine=i370-ibm os=-mvs ;; nacl) basic_machine=le32-unknown os=-nacl ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; nsv-tandem) basic_machine=nsv-tandem ;; nsx-tandem) basic_machine=nsx-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos | rdos64) basic_machine=x86_64-pc os=-rdos ;; rdos32) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh5el) basic_machine=sh5le-unknown ;; simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; x64) basic_machine=x86_64-pc ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo "$basic_machine" | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`"$1"\': machine \`"$basic_machine"\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo "$basic_machine" | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo "$basic_machine" | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases that might get confused # with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # es1800 is here to avoid being matched by es* (a different OS) -es1800*) os=-ose ;; # Now accept the basic system types. # The portable systems comes first. # Each alternative MUST end in a * to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* | -plan9* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* | -cloudabi* | -sortix* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -knetbsd* | -mirbsd* | -netbsd* \ | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* | -glidix* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \ | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox* | -bme* \ | -midnightbsd*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -xray | -os68k* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo "$os" | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo "$os" | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo "$os" | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4*) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -pikeos*) # Until real need of OS specific support for # particular features comes up, bare metal # configurations are quite functional. case $basic_machine in arm*) os=-eabi ;; *) os=-elf ;; esac ;; -nacl*) ;; -ios) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`"$1"\': system \`"$os"\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; c8051-*) os=-elf ;; hexagon-*) os=-elf ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; pru-*) os=-elf ;; *-be) os=-beos ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo "$basic_machine" | sed "s/unknown/$vendor/"` ;; esac echo "$basic_machine$os" exit # Local variables: # eval: (add-hook 'write-file-functions 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: uim-1.8.8/Makefile.am0000644000175000017500000000222413274751167011314 00000000000000ACLOCAL_AMFLAGS = -I m4.generated -I m4 SUBDIRS = m4 doc replace sigscheme uim scm test test2 \ gtk2 gtk3 qt3 qt4 qt5 notify SUBDIRS += xim fep emacs po pixmaps examples tables byeoru-data EXTRA_DIST = RELNOTE autogen.sh make-dist.sh \ uim.pc.in uim.desktop \ intltool-extract.in intltool-merge.in intltool-update.in pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = uim.pc desktopdir = $(datadir)/applications desktop_in_files = uim.desktop.in desktop_DATA = $(desktop_in_files:.desktop.in=.desktop) @INTLTOOL_DESKTOP_RULE@ DIST_NAME = $(PACKAGE)-$(VERSION) #RELEASE_TAG = master RELEASE_TAG = $(DIST_NAME) DIST_SUM_LIST = $(DIST_NAME).sum DISTCLEANFILES = uim.pc uim.desktop \ intltool-extract intltool-merge intltool-update \ $(DIST_SUM_LIST) MAINTAINERCLEANFILES = \ aclocal.m4 ltmain.sh depcomp missing install-sh \ intltool-extract.in intltool-merge.in intltool-update.in .PHONY: FORCE sum FORCE: sum: $(MD5) $(DIST_ARCHIVES) | $(SED) 's/^/MD5: /' >$(DIST_SUM_LIST) $(SHA1) $(DIST_ARCHIVES) | $(SED) 's/^/SHA1: /' >>$(DIST_SUM_LIST) tag: git tag -a -m "$(VERSION) has been released!!!" $(VERSION) git push --tags uim-1.8.8/compile0000755000175000017500000001624513275405273010641 00000000000000#! /bin/sh # Wrapper for compilers which do not understand '-c -o'. scriptversion=2012-10-14.11; # UTC # Copyright (C) 1999-2014 Free Software Foundation, Inc. # Written by Tom Tromey . # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to or send patches to # . nl=' ' # We need space, tab and new line, in precisely that order. Quoting is # there to prevent tools from complaining about whitespace usage. IFS=" "" $nl" file_conv= # func_file_conv build_file lazy # Convert a $build file to $host form and store it in $file # Currently only supports Windows hosts. If the determined conversion # type is listed in (the comma separated) LAZY, no conversion will # take place. func_file_conv () { file=$1 case $file in / | /[!/]*) # absolute file, and not a UNC file if test -z "$file_conv"; then # lazily determine how to convert abs files case `uname -s` in MINGW*) file_conv=mingw ;; CYGWIN*) file_conv=cygwin ;; *) file_conv=wine ;; esac fi case $file_conv/,$2, in *,$file_conv,*) ;; mingw/*) file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` ;; cygwin/*) file=`cygpath -m "$file" || echo "$file"` ;; wine/*) file=`winepath -w "$file" || echo "$file"` ;; esac ;; esac } # func_cl_dashL linkdir # Make cl look for libraries in LINKDIR func_cl_dashL () { func_file_conv "$1" if test -z "$lib_path"; then lib_path=$file else lib_path="$lib_path;$file" fi linker_opts="$linker_opts -LIBPATH:$file" } # func_cl_dashl library # Do a library search-path lookup for cl func_cl_dashl () { lib=$1 found=no save_IFS=$IFS IFS=';' for dir in $lib_path $LIB do IFS=$save_IFS if $shared && test -f "$dir/$lib.dll.lib"; then found=yes lib=$dir/$lib.dll.lib break fi if test -f "$dir/$lib.lib"; then found=yes lib=$dir/$lib.lib break fi if test -f "$dir/lib$lib.a"; then found=yes lib=$dir/lib$lib.a break fi done IFS=$save_IFS if test "$found" != yes; then lib=$lib.lib fi } # func_cl_wrapper cl arg... # Adjust compile command to suit cl func_cl_wrapper () { # Assume a capable shell lib_path= shared=: linker_opts= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. eat=1 case $2 in *.o | *.[oO][bB][jJ]) func_file_conv "$2" set x "$@" -Fo"$file" shift ;; *) func_file_conv "$2" set x "$@" -Fe"$file" shift ;; esac ;; -I) eat=1 func_file_conv "$2" mingw set x "$@" -I"$file" shift ;; -I*) func_file_conv "${1#-I}" mingw set x "$@" -I"$file" shift ;; -l) eat=1 func_cl_dashl "$2" set x "$@" "$lib" shift ;; -l*) func_cl_dashl "${1#-l}" set x "$@" "$lib" shift ;; -L) eat=1 func_cl_dashL "$2" ;; -L*) func_cl_dashL "${1#-L}" ;; -static) shared=false ;; -Wl,*) arg=${1#-Wl,} save_ifs="$IFS"; IFS=',' for flag in $arg; do IFS="$save_ifs" linker_opts="$linker_opts $flag" done IFS="$save_ifs" ;; -Xlinker) eat=1 linker_opts="$linker_opts $2" ;; -*) set x "$@" "$1" shift ;; *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) func_file_conv "$1" set x "$@" -Tp"$file" shift ;; *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) func_file_conv "$1" mingw set x "$@" "$file" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -n "$linker_opts"; then linker_opts="-link$linker_opts" fi exec "$@" $linker_opts exit 1 } eat= case $1 in '') echo "$0: No command. Try '$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: compile [--help] [--version] PROGRAM [ARGS] Wrapper for compilers which do not understand '-c -o'. Remove '-o dest.o' from ARGS, run PROGRAM with the remaining arguments, and rename the output as expected. If you are trying to build a whole package this is not the right script to run: please start by reading the file 'INSTALL'. Report bugs to . EOF exit $? ;; -v | --v*) echo "compile $scriptversion" exit $? ;; cl | *[/\\]cl | cl.exe | *[/\\]cl.exe ) func_cl_wrapper "$@" # Doesn't return... ;; esac ofile= cfile= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. # So we strip '-o arg' only if arg is an object. eat=1 case $2 in *.o | *.obj) ofile=$2 ;; *) set x "$@" -o "$2" shift ;; esac ;; *.c) cfile=$1 set x "$@" "$1" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -z "$ofile" || test -z "$cfile"; then # If no '-o' option was seen then we might have been invoked from a # pattern rule where we don't need one. That is ok -- this is a # normal compilation that the losing compiler can handle. If no # '.c' file was seen then we are probably linking. That is also # ok. exec "$@" fi # Name of file we expect compiler to create. cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'` # Create the lock directory. # Note: use '[/\\:.-]' here to ensure that we don't use the same name # that we are using for the .o file. Also, base the name on the expected # object file name, since that is what matters with a parallel build. lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d while true; do if mkdir "$lockdir" >/dev/null 2>&1; then break fi sleep 1 done # FIXME: race condition here if user kills between mkdir and trap. trap "rmdir '$lockdir'; exit 1" 1 2 15 # Run the compile. "$@" ret=$? if test -f "$cofile"; then test "$cofile" = "$ofile" || mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: uim-1.8.8/replace/0000755000175000017500000000000013275405524010745 500000000000000uim-1.8.8/replace/bsd-snprintf.c0000644000175000017500000004627512503502431013444 00000000000000/* * Copyright Patrick Powell 1995 * This code is based on code written by Patrick Powell (papowell@astart.com) * It may be used for any purpose as long as this notice remains intact * on all source code distributions */ /************************************************************** * Original: * Patrick Powell Tue Apr 11 09:48:21 PDT 1995 * A bombproof version of doprnt (dopr) included. * Sigh. This sort of thing is always nasty do deal with. Note that * the version here does not include floating point... * * snprintf() is used instead of sprintf() as it does limit checks * for string length. This covers a nasty loophole. * * The other functions are there to prevent NULL pointers from * causing nast effects. * * More Recently: * Brandon Long 9/15/96 for mutt 0.43 * This was ugly. It is still ugly. I opted out of floating point * numbers, but the formatter understands just about everything * from the normal C string format, at least as far as I can tell from * the Solaris 2.5 printf(3S) man page. * * Brandon Long 10/22/97 for mutt 0.87.1 * Ok, added some minimal floating point support, which means this * probably requires libm on most operating systems. Don't yet * support the exponent (e,E) and sigfig (g,G). Also, fmtint() * was pretty badly broken, it just wasn't being exercised in ways * which showed it, so that's been fixed. Also, formated the code * to mutt conventions, and removed dead code left over from the * original. Also, there is now a builtin-test, just compile with: * gcc -DTEST_SNPRINTF -o snprintf snprintf.c -lm * and run snprintf for results. * * Thomas Roessler 01/27/98 for mutt 0.89i * The PGP code was using unsigned hexadecimal formats. * Unfortunately, unsigned formats simply didn't work. * * Michael Elkins 03/05/98 for mutt 0.90.8 * The original code assumed that both snprintf() and vsnprintf() were * missing. Some systems only have snprintf() but not vsnprintf(), so * the code is now broken down under HAVE_SNPRINTF and HAVE_VSNPRINTF. * * Andrew Tridgell (tridge@samba.org) Oct 1998 * fixed handling of %.0f * added test for HAVE_LONG_DOUBLE * * tridge@samba.org, idra@samba.org, April 2001 * got rid of fcvt code (twas buggy and made testing harder) * added C99 semantics * * date: 2002/12/19 19:56:31; author: herb; state: Exp; lines: +2 -0 * actually print args for %g and %e * * date: 2002/06/03 13:37:52; author: jmcd; state: Exp; lines: +8 -0 * Since includes.h isn't included here, VA_COPY has to be defined here. I don't * see any include file that is guaranteed to be here, so I'm defining it * locally. Fixes AIX and Solaris builds. * * date: 2002/06/03 03:07:24; author: tridge; state: Exp; lines: +5 -13 * put the ifdef for HAVE_VA_COPY in one place rather than in lots of * functions * * date: 2002/05/17 14:51:22; author: jmcd; state: Exp; lines: +21 -4 * Fix usage of va_list passed as an arg. Use __va_copy before using it * when it exists. * * date: 2002/04/16 22:38:04; author: idra; state: Exp; lines: +20 -14 * Fix incorrect zpadlen handling in fmtfp. * Thanks to Ollie Oldham for spotting it. * few mods to make it easier to compile the tests. * addedd the "Ollie" test to the floating point ones. * * Martin Pool (mbp@samba.org) April 2003 * Remove NO_CONFIG_H so that the test case can be built within a source * tree with less trouble. * Remove unnecessary SAFE_FREE() definition. * * Martin Pool (mbp@samba.org) May 2003 * Put in a prototype for dummy_snprintf() to quiet compiler warnings. * * Move #endif to make sure VA_COPY, LDOUBLE, etc are defined even * if the C library has some snprintf functions already. **************************************************************/ #include #if defined(BROKEN_SNPRINTF) /* For those with broken snprintf() */ # undef HAVE_SNPRINTF # undef HAVE_VSNPRINTF #endif #ifndef VA_COPY # ifdef HAVE_VA_COPY # define VA_COPY(dest, src) va_copy(dest, src) # else # ifdef HAVE___VA_COPY # define VA_COPY(dest, src) __va_copy(dest, src) # else # define VA_COPY(dest, src) (dest) = (src) # endif # endif #endif #if !defined(HAVE_SNPRINTF) || !defined(HAVE_VSNPRINTF) #include #include #include #include #ifdef HAVE_LONG_DOUBLE # define LDOUBLE long double #else # define LDOUBLE double #endif #ifdef HAVE_LONG_LONG # define LLONG long long #else # define LLONG long #endif /* * dopr(): poor man's version of doprintf */ /* format read states */ #define DP_S_DEFAULT 0 #define DP_S_FLAGS 1 #define DP_S_MIN 2 #define DP_S_DOT 3 #define DP_S_MAX 4 #define DP_S_MOD 5 #define DP_S_CONV 6 #define DP_S_DONE 7 /* format flags - Bits */ #define DP_F_MINUS (1 << 0) #define DP_F_PLUS (1 << 1) #define DP_F_SPACE (1 << 2) #define DP_F_NUM (1 << 3) #define DP_F_ZERO (1 << 4) #define DP_F_UP (1 << 5) #define DP_F_UNSIGNED (1 << 6) /* Conversion Flags */ #define DP_C_SHORT 1 #define DP_C_LONG 2 #define DP_C_LDOUBLE 3 #define DP_C_LLONG 4 #define char_to_int(p) ((p)- '0') #ifndef MAX # define MAX(p,q) (((p) >= (q)) ? (p) : (q)) #endif static size_t dopr(char *buffer, size_t maxlen, const char *format, va_list args_in); static void fmtstr(char *buffer, size_t *currlen, size_t maxlen, char *value, int flags, int min, int max); static void fmtint(char *buffer, size_t *currlen, size_t maxlen, LLONG value, int base, int min, int max, int flags); static void fmtfp(char *buffer, size_t *currlen, size_t maxlen, LDOUBLE fvalue, int min, int max, int flags); static void dopr_outch(char *buffer, size_t *currlen, size_t maxlen, char c); static size_t dopr(char *buffer, size_t maxlen, const char *format, va_list args_in) { char ch; LLONG value; LDOUBLE fvalue; char *strvalue; int min; int max; int state; int flags; int cflags; size_t currlen; va_list args; VA_COPY(args, args_in); state = DP_S_DEFAULT; currlen = flags = cflags = min = 0; max = -1; ch = *format++; while (state != DP_S_DONE) { if (ch == '\0') state = DP_S_DONE; switch(state) { case DP_S_DEFAULT: if (ch == '%') state = DP_S_FLAGS; else dopr_outch (buffer, &currlen, maxlen, ch); ch = *format++; break; case DP_S_FLAGS: switch (ch) { case '-': flags |= DP_F_MINUS; ch = *format++; break; case '+': flags |= DP_F_PLUS; ch = *format++; break; case ' ': flags |= DP_F_SPACE; ch = *format++; break; case '#': flags |= DP_F_NUM; ch = *format++; break; case '0': flags |= DP_F_ZERO; ch = *format++; break; default: state = DP_S_MIN; break; } break; case DP_S_MIN: if (isdigit((unsigned char)ch)) { min = 10*min + char_to_int (ch); ch = *format++; } else if (ch == '*') { min = va_arg (args, int); ch = *format++; state = DP_S_DOT; } else { state = DP_S_DOT; } break; case DP_S_DOT: if (ch == '.') { state = DP_S_MAX; ch = *format++; } else { state = DP_S_MOD; } break; case DP_S_MAX: if (isdigit((unsigned char)ch)) { if (max < 0) max = 0; max = 10*max + char_to_int (ch); ch = *format++; } else if (ch == '*') { max = va_arg (args, int); ch = *format++; state = DP_S_MOD; } else { state = DP_S_MOD; } break; case DP_S_MOD: switch (ch) { case 'h': cflags = DP_C_SHORT; ch = *format++; break; case 'l': cflags = DP_C_LONG; ch = *format++; if (ch == 'l') { /* It's a long long */ cflags = DP_C_LLONG; ch = *format++; } break; case 'L': cflags = DP_C_LDOUBLE; ch = *format++; break; default: break; } state = DP_S_CONV; break; case DP_S_CONV: switch (ch) { case 'd': case 'i': if (cflags == DP_C_SHORT) value = va_arg (args, int); else if (cflags == DP_C_LONG) value = va_arg (args, long int); else if (cflags == DP_C_LLONG) value = va_arg (args, LLONG); else value = va_arg (args, int); fmtint (buffer, &currlen, maxlen, value, 10, min, max, flags); break; case 'o': flags |= DP_F_UNSIGNED; if (cflags == DP_C_SHORT) value = va_arg (args, unsigned int); else if (cflags == DP_C_LONG) value = (long)va_arg (args, unsigned long int); else if (cflags == DP_C_LLONG) value = (long)va_arg (args, unsigned LLONG); else value = (long)va_arg (args, unsigned int); fmtint (buffer, &currlen, maxlen, value, 8, min, max, flags); break; case 'u': flags |= DP_F_UNSIGNED; if (cflags == DP_C_SHORT) value = va_arg (args, unsigned int); else if (cflags == DP_C_LONG) value = (long)va_arg (args, unsigned long int); else if (cflags == DP_C_LLONG) value = (LLONG)va_arg (args, unsigned LLONG); else value = (long)va_arg (args, unsigned int); fmtint (buffer, &currlen, maxlen, value, 10, min, max, flags); break; case 'X': flags |= DP_F_UP; case 'x': flags |= DP_F_UNSIGNED; if (cflags == DP_C_SHORT) value = va_arg (args, unsigned int); else if (cflags == DP_C_LONG) value = (long)va_arg (args, unsigned long int); else if (cflags == DP_C_LLONG) value = (LLONG)va_arg (args, unsigned LLONG); else value = (long)va_arg (args, unsigned int); fmtint (buffer, &currlen, maxlen, value, 16, min, max, flags); break; case 'f': if (cflags == DP_C_LDOUBLE) fvalue = va_arg (args, LDOUBLE); else fvalue = va_arg (args, double); /* um, floating point? */ fmtfp (buffer, &currlen, maxlen, fvalue, min, max, flags); break; case 'E': flags |= DP_F_UP; case 'e': if (cflags == DP_C_LDOUBLE) fvalue = va_arg (args, LDOUBLE); else fvalue = va_arg (args, double); fmtfp (buffer, &currlen, maxlen, fvalue, min, max, flags); break; case 'G': flags |= DP_F_UP; case 'g': if (cflags == DP_C_LDOUBLE) fvalue = va_arg (args, LDOUBLE); else fvalue = va_arg (args, double); fmtfp (buffer, &currlen, maxlen, fvalue, min, max, flags); break; case 'c': dopr_outch (buffer, &currlen, maxlen, va_arg (args, int)); break; case 's': strvalue = va_arg (args, char *); if (!strvalue) strvalue = "(NULL)"; if (max == -1) { max = strlen(strvalue); } if (min > 0 && max >= 0 && min > max) max = min; fmtstr (buffer, &currlen, maxlen, strvalue, flags, min, max); break; case 'p': strvalue = va_arg (args, void *); fmtint (buffer, &currlen, maxlen, (long) strvalue, 16, min, max, flags); break; case 'n': if (cflags == DP_C_SHORT) { short int *num; num = va_arg (args, short int *); *num = currlen; } else if (cflags == DP_C_LONG) { long int *num; num = va_arg (args, long int *); *num = (long int)currlen; } else if (cflags == DP_C_LLONG) { LLONG *num; num = va_arg (args, LLONG *); *num = (LLONG)currlen; } else { int *num; num = va_arg (args, int *); *num = currlen; } break; case '%': dopr_outch (buffer, &currlen, maxlen, ch); break; case 'w': /* not supported yet, treat as next char */ ch = *format++; break; default: /* Unknown, skip */ break; } ch = *format++; state = DP_S_DEFAULT; flags = cflags = min = 0; max = -1; break; case DP_S_DONE: break; default: /* hmm? */ break; /* some picky compilers need this */ } } if (maxlen != 0) { if (currlen < maxlen - 1) buffer[currlen] = '\0'; else if (maxlen > 0) buffer[maxlen - 1] = '\0'; } return currlen; } static void fmtstr(char *buffer, size_t *currlen, size_t maxlen, char *value, int flags, int min, int max) { int padlen, strln; /* amount to pad */ int cnt = 0; #ifdef DEBUG_SNPRINTF printf("fmtstr min=%d max=%d s=[%s]\n", min, max, value); #endif if (value == 0) { value = ""; } for (strln = 0; strln < max && value[strln]; ++strln); /* strlen */ padlen = min - strln; if (padlen < 0) padlen = 0; if (flags & DP_F_MINUS) padlen = -padlen; /* Left Justify */ while ((padlen > 0) && (cnt < max)) { dopr_outch (buffer, currlen, maxlen, ' '); --padlen; ++cnt; } while (*value && (cnt < max)) { dopr_outch (buffer, currlen, maxlen, *value++); ++cnt; } while ((padlen < 0) && (cnt < max)) { dopr_outch (buffer, currlen, maxlen, ' '); ++padlen; ++cnt; } } /* Have to handle DP_F_NUM (ie 0x and 0 alternates) */ static void fmtint(char *buffer, size_t *currlen, size_t maxlen, LLONG value, int base, int min, int max, int flags) { int signvalue = 0; unsigned LLONG uvalue; char convert[20]; int place = 0; int spadlen = 0; /* amount to space pad */ int zpadlen = 0; /* amount to zero pad */ int caps = 0; if (max < 0) max = 0; uvalue = value; if(!(flags & DP_F_UNSIGNED)) { if( value < 0 ) { signvalue = '-'; uvalue = -value; } else { if (flags & DP_F_PLUS) /* Do a sign (+/i) */ signvalue = '+'; else if (flags & DP_F_SPACE) signvalue = ' '; } } if (flags & DP_F_UP) caps = 1; /* Should characters be upper case? */ do { convert[place++] = (caps? "0123456789ABCDEF":"0123456789abcdef") [uvalue % (unsigned)base ]; uvalue = (uvalue / (unsigned)base ); } while(uvalue && (place < 20)); if (place == 20) place--; convert[place] = 0; zpadlen = max - place; spadlen = min - MAX (max, place) - (signvalue ? 1 : 0); if (zpadlen < 0) zpadlen = 0; if (spadlen < 0) spadlen = 0; if (flags & DP_F_ZERO) { zpadlen = MAX(zpadlen, spadlen); spadlen = 0; } if (flags & DP_F_MINUS) spadlen = -spadlen; /* Left Justifty */ #ifdef DEBUG_SNPRINTF printf("zpad: %d, spad: %d, min: %d, max: %d, place: %d\n", zpadlen, spadlen, min, max, place); #endif /* Spaces */ while (spadlen > 0) { dopr_outch (buffer, currlen, maxlen, ' '); --spadlen; } /* Sign */ if (signvalue) dopr_outch (buffer, currlen, maxlen, signvalue); /* Zeros */ if (zpadlen > 0) { while (zpadlen > 0) { dopr_outch (buffer, currlen, maxlen, '0'); --zpadlen; } } /* Digits */ while (place > 0) dopr_outch (buffer, currlen, maxlen, convert[--place]); /* Left Justified spaces */ while (spadlen < 0) { dopr_outch (buffer, currlen, maxlen, ' '); ++spadlen; } } static LDOUBLE abs_val(LDOUBLE value) { LDOUBLE result = value; if (value < 0) result = -value; return result; } static LDOUBLE POW10(int exp) { LDOUBLE result = 1; while (exp) { result *= 10; exp--; } return result; } static LLONG ROUND(LDOUBLE value) { LLONG intpart; intpart = (LLONG)value; value = value - intpart; if (value >= 0.5) intpart++; return intpart; } /* a replacement for modf that doesn't need the math library. Should be portable, but slow */ static double my_modf(double x0, double *iptr) { int i; long l; double x = x0; double f = 1.0; for (i=0;i<100;i++) { l = (long)x; if (l <= (x+1) && l >= (x-1)) break; x *= 0.1; f *= 10.0; } if (i == 100) { /* yikes! the number is beyond what we can handle. What do we do? */ (*iptr) = 0; return 0; } if (i != 0) { double i2; double ret; ret = my_modf(x0-l*f, &i2); (*iptr) = l*f + i2; return ret; } (*iptr) = l; return x - (*iptr); } static void fmtfp (char *buffer, size_t *currlen, size_t maxlen, LDOUBLE fvalue, int min, int max, int flags) { int signvalue = 0; double ufvalue; char iconvert[311]; char fconvert[311]; int iplace = 0; int fplace = 0; int padlen = 0; /* amount to pad */ int zpadlen = 0; int caps = 0; int idx; double intpart; double fracpart; double temp; /* * AIX manpage says the default is 0, but Solaris says the default * is 6, and sprintf on AIX defaults to 6 */ if (max < 0) max = 6; ufvalue = abs_val (fvalue); if (fvalue < 0) { signvalue = '-'; } else { if (flags & DP_F_PLUS) { /* Do a sign (+/i) */ signvalue = '+'; } else { if (flags & DP_F_SPACE) signvalue = ' '; } } #if 0 if (flags & DP_F_UP) caps = 1; /* Should characters be upper case? */ #endif #if 0 if (max == 0) ufvalue += 0.5; /* if max = 0 we must round */ #endif /* * Sorry, we only support 16 digits past the decimal because of our * conversion method */ if (max > 16) max = 16; /* We "cheat" by converting the fractional part to integer by * multiplying by a factor of 10 */ temp = ufvalue; my_modf(temp, &intpart); fracpart = ROUND((POW10(max)) * (ufvalue - intpart)); if (fracpart >= POW10(max)) { intpart++; fracpart -= POW10(max); } /* Convert integer part */ do { temp = intpart*0.1; my_modf(temp, &intpart); idx = (int) ((temp -intpart +0.05)* 10.0); /* idx = (int) (((double)(temp*0.1) -intpart +0.05) *10.0); */ /* printf ("%llf, %f, %x\n", temp, intpart, idx); */ iconvert[iplace++] = (caps? "0123456789ABCDEF":"0123456789abcdef")[idx]; } while (intpart && (iplace < 311)); if (iplace == 311) iplace--; iconvert[iplace] = 0; /* Convert fractional part */ if (fracpart) { do { temp = fracpart*0.1; my_modf(temp, &fracpart); idx = (int) ((temp -fracpart +0.05)* 10.0); /* idx = (int) ((((temp/10) -fracpart) +0.05) *10); */ /* printf ("%lf, %lf, %ld\n", temp, fracpart, idx ); */ fconvert[fplace++] = (caps? "0123456789ABCDEF":"0123456789abcdef")[idx]; } while(fracpart && (fplace < 311)); if (fplace == 311) fplace--; } fconvert[fplace] = 0; /* -1 for decimal point, another -1 if we are printing a sign */ padlen = min - iplace - max - 1 - ((signvalue) ? 1 : 0); zpadlen = max - fplace; if (zpadlen < 0) zpadlen = 0; if (padlen < 0) padlen = 0; if (flags & DP_F_MINUS) padlen = -padlen; /* Left Justifty */ if ((flags & DP_F_ZERO) && (padlen > 0)) { if (signvalue) { dopr_outch (buffer, currlen, maxlen, signvalue); --padlen; signvalue = 0; } while (padlen > 0) { dopr_outch (buffer, currlen, maxlen, '0'); --padlen; } } while (padlen > 0) { dopr_outch (buffer, currlen, maxlen, ' '); --padlen; } if (signvalue) dopr_outch (buffer, currlen, maxlen, signvalue); while (iplace > 0) dopr_outch (buffer, currlen, maxlen, iconvert[--iplace]); #ifdef DEBUG_SNPRINTF printf("fmtfp: fplace=%d zpadlen=%d\n", fplace, zpadlen); #endif /* * Decimal point. This should probably use locale to find the correct * char to print out. */ if (max > 0) { dopr_outch (buffer, currlen, maxlen, '.'); while (zpadlen > 0) { dopr_outch (buffer, currlen, maxlen, '0'); --zpadlen; } while (fplace > 0) dopr_outch (buffer, currlen, maxlen, fconvert[--fplace]); } while (padlen < 0) { dopr_outch (buffer, currlen, maxlen, ' '); ++padlen; } } static void dopr_outch(char *buffer, size_t *currlen, size_t maxlen, char c) { if (*currlen < maxlen) { buffer[(*currlen)] = c; } (*currlen)++; } #endif /* !defined(HAVE_SNPRINTF) || !defined(HAVE_VSNPRINTF) */ #if !defined(HAVE_VSNPRINTF) int vsnprintf (char *str, size_t count, const char *fmt, va_list args) { return dopr(str, count, fmt, args); } #endif #if !defined(HAVE_SNPRINTF) int snprintf(char *str, size_t count, SNPRINTF_CONST char *fmt, ...) { size_t ret; va_list ap; va_start(ap, fmt); ret = vsnprintf(str, count, fmt, ap); va_end(ap); return ret; } #endif uim-1.8.8/replace/strtonum.c0000644000175000017500000000354412503502431012716 00000000000000/* $OpenBSD: strtonum.c,v 1.6 2004/08/03 19:38:01 millert Exp $ */ /* * Copyright (c) 2004 Ted Unangst and Todd Miller * All rights reserved. * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ /* OPENBSD ORIGINAL: lib/libc/stdlib/strtonum.c */ #include #ifndef HAVE_STRTONUM #include #include #include #define INVALID 1 #define TOOSMALL 2 #define TOOLARGE 3 long long strtonum(const char *numstr, long long minval, long long maxval, const char **errstrp) { long long ll = 0; char *ep; int error = 0; struct errval { const char *errstr; int err; } ev[4] = { { NULL, 0 }, { "invalid", EINVAL }, { "too small", ERANGE }, { "too large", ERANGE }, }; ev[0].err = errno; errno = 0; if (minval > maxval) error = INVALID; else { ll = strtoll(numstr, &ep, 10); if (numstr == ep || *ep != '\0') error = INVALID; else if ((ll == LLONG_MIN && errno == ERANGE) || ll < minval) error = TOOSMALL; else if ((ll == LLONG_MAX && errno == ERANGE) || ll > maxval) error = TOOLARGE; } if (errstrp != NULL) *errstrp = ev[error].errstr; errno = ev[error].err; if (error) ll = 0; return (ll); } #endif /* HAVE_STRTONUM */ uim-1.8.8/replace/bsd-misc.c0000644000175000017500000001162312503502431012521 00000000000000 /* * Copyright (c) 1999-2004 Damien Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #if 0 #include #ifdef HAVE_SYS_SELECT_H # include #endif #ifdef HAVE_SYS_TIME_H # include #endif #endif #include #if 0 #include #include #include #include "xmalloc.h" #ifndef HAVE___PROGNAME char *__progname; #endif /* * NB. duplicate __progname in case it is an alias for argv[0] * Otherwise it may get clobbered by setproctitle() */ char *ssh_get_progname(char *argv0) { #ifdef HAVE___PROGNAME extern char *__progname; return xstrdup(__progname); #else char *p; if (argv0 == NULL) return ("unknown"); /* XXX */ p = strrchr(argv0, '/'); if (p == NULL) p = argv0; else p++; return (xstrdup(p)); #endif } #ifndef HAVE_SETLOGIN int setlogin(const char *name) { return (0); } #endif /* !HAVE_SETLOGIN */ #ifndef HAVE_INNETGR int innetgr(const char *netgroup, const char *host, const char *user, const char *domain) { return (0); } #endif /* HAVE_INNETGR */ #if !defined(HAVE_SETEUID) && defined(HAVE_SETREUID) int seteuid(uid_t euid) { return (setreuid(-1, euid)); } #endif /* !defined(HAVE_SETEUID) && defined(HAVE_SETREUID) */ #if !defined(HAVE_SETEGID) && defined(HAVE_SETRESGID) int setegid(uid_t egid) { return(setresgid(-1, egid, -1)); } #endif /* !defined(HAVE_SETEGID) && defined(HAVE_SETRESGID) */ #if !defined(HAVE_STRERROR) && defined(HAVE_SYS_ERRLIST) && defined(HAVE_SYS_NERR) const char *strerror(int e) { extern int sys_nerr; extern char *sys_errlist[]; if ((e >= 0) && (e < sys_nerr)) return (sys_errlist[e]); return ("unlisted error"); } #endif #ifndef HAVE_UTIMES int utimes(char *filename, struct timeval *tvp) { struct utimbuf ub; ub.actime = tvp[0].tv_sec; ub.modtime = tvp[1].tv_sec; return (utime(filename, &ub)); } #endif #ifndef HAVE_TRUNCATE int truncate(const char *path, off_t length) { int fd, ret, saverrno; fd = open(path, O_WRONLY); if (fd < 0) return (-1); ret = ftruncate(fd, length); saverrno = errno; close(fd); if (ret == -1) errno = saverrno; return(ret); } #endif /* HAVE_TRUNCATE */ #if !defined(HAVE_NANOSLEEP) && !defined(HAVE_NSLEEP) int nanosleep(const struct timespec *req, struct timespec *rem) { int rc, saverrno; extern int errno; struct timeval tstart, tstop, tremain, time2wait; TIMESPEC_TO_TIMEVAL(&time2wait, req) (void) gettimeofday(&tstart, NULL); rc = select(0, NULL, NULL, NULL, &time2wait); if (rc == -1) { saverrno = errno; (void) gettimeofday (&tstop, NULL); errno = saverrno; tremain.tv_sec = time2wait.tv_sec - (tstop.tv_sec - tstart.tv_sec); tremain.tv_usec = time2wait.tv_usec - (tstop.tv_usec - tstart.tv_usec); tremain.tv_sec += tremain.tv_usec / 1000000L; tremain.tv_usec %= 1000000L; } else { tremain.tv_sec = 0; tremain.tv_usec = 0; } if (rem != NULL) TIMEVAL_TO_TIMESPEC(&tremain, rem) return(rc); } #endif #ifndef HAVE_TCGETPGRP pid_t tcgetpgrp(int fd) { int ctty_pgrp; if (ioctl(fd, TIOCGPGRP, &ctty_pgrp) == -1) return(-1); else return(ctty_pgrp); } #endif /* HAVE_TCGETPGRP */ #ifndef HAVE_TCSENDBREAK int tcsendbreak(int fd, int duration) { # if defined(TIOCSBRK) && defined(TIOCCBRK) struct timeval sleepytime; sleepytime.tv_sec = 0; sleepytime.tv_usec = 400000; if (ioctl(fd, TIOCSBRK, 0) == -1) return (-1); (void)select(0, 0, 0, 0, &sleepytime); if (ioctl(fd, TIOCCBRK, 0) == -1) return (-1); return (0); # else return -1; # endif } #endif /* HAVE_TCSENDBREAK */ mysig_t mysignal(int sig, mysig_t act) { #ifdef HAVE_SIGACTION struct sigaction sa, osa; if (sigaction(sig, NULL, &osa) == -1) return (mysig_t) -1; if (osa.sa_handler != act) { memset(&sa, 0, sizeof(sa)); sigemptyset(&sa.sa_mask); sa.sa_flags = 0; #ifdef SA_INTERRUPT if (sig == SIGALRM) sa.sa_flags |= SA_INTERRUPT; #endif sa.sa_handler = act; if (sigaction(sig, &sa, NULL) == -1) return (mysig_t) -1; } return (osa.sa_handler); #else #undef signal return (signal(sig, act)); #endif } #endif /* 0 */ #ifndef HAVE_STRDUP char * strdup(const char *str) { size_t len; char *cp; len = strlen(str) + 1; cp = malloc(len); if (cp != NULL) return(memcpy(cp, str, len)); return NULL; } #endif uim-1.8.8/replace/bsd-poll.h0000644000175000017500000000410112503502431012532 00000000000000/* $OpenBSD: poll.h,v 1.11 2003/12/10 23:10:08 millert Exp $ */ /* * Copyright (c) 1996 Theo de Raadt * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* OPENBSD ORIGINAL: sys/sys/poll.h */ #if !defined(HAVE_POLL) && !defined(HAVE_POLL_H) #ifndef _COMPAT_POLL_H_ #define _COMPAT_POLL_H_ typedef struct pollfd { int fd; short events; short revents; } pollfd_t; typedef unsigned int nfds_t; #define POLLIN 0x0001 #define POLLOUT 0x0004 #define POLLERR 0x0008 #if 0 /* the following are currently not implemented */ #define POLLPRI 0x0002 #define POLLHUP 0x0010 #define POLLNVAL 0x0020 #define POLLRDNORM 0x0040 #define POLLNORM POLLRDNORM #define POLLWRNORM POLLOUT #define POLLRDBAND 0x0080 #define POLLWRBAND 0x0100 #endif #define INFTIM (-1) /* not standard */ int poll(struct pollfd *, nfds_t, int); #endif /* !_COMPAT_POLL_H_ */ #endif /* !HAVE_POLL_H */ uim-1.8.8/replace/Makefile.am0000644000175000017500000000054412503502431012710 00000000000000noinst_LTLIBRARIES = libreplace.la libreplace_la_SOURCES = \ bsd-asprintf.c \ bsd-misc.c \ bsd-poll.c \ bsd-poll.h \ bsd-snprintf.c \ bsd-waitpid.c \ bsd-waitpid.h \ daemon.c \ fake-rfc2553.c \ fake-rfc2553.h \ getpeereid.c \ os_dep.h \ setenv.c \ strlcat.c \ strlcpy.c \ strsep.c \ strtoll.c \ strtonum.c strtonum.lo: CFLAGS+=-std=c99 uim-1.8.8/replace/bsd-waitpid.h0000644000175000017500000000413112503502431013230 00000000000000/* $Id: bsd-waitpid.h,v 1.5 2003/08/29 16:59:52 mouring Exp $ */ /* * Copyright (c) 2000 Ben Lindstrom. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ #ifndef _BSD_WAITPID_H #define _BSD_WAITPID_H #ifndef HAVE_WAITPID /* Clean out any potental issues */ #undef WIFEXITED #undef WIFSTOPPED #undef WIFSIGNALED /* Define required functions to mimic a POSIX look and feel */ #define _W_INT(w) (*(int*)&(w)) /* convert union wait to int */ #define WIFEXITED(w) (!((_W_INT(w)) & 0377)) #define WIFSTOPPED(w) ((_W_INT(w)) & 0100) #define WIFSIGNALED(w) (!WIFEXITED(w) && !WIFSTOPPED(w)) #define WEXITSTATUS(w) (int)(WIFEXITED(w) ? ((_W_INT(w) >> 8) & 0377) : -1) #define WTERMSIG(w) (int)(WIFSIGNALED(w) ? (_W_INT(w) & 0177) : -1) #define WCOREFLAG 0x80 #define WCOREDUMP(w) ((_W_INT(w)) & WCOREFLAG) /* Prototype */ pid_t waitpid(int, int *, int); #endif /* !HAVE_WAITPID */ #endif /* _BSD_WAITPID_H */ uim-1.8.8/replace/daemon.c0000644000175000017500000000520012503502431012255 00000000000000/* $OpenBSD: daemon.c,v 1.6 2005/08/08 08:05:33 espie Exp $ */ /*- * Copyright (c) 1990, 1993 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* OPENBSD ORIGINAL: lib/libc/gen/daemon.c */ #include #ifndef HAVE_DAEMON #include #ifdef HAVE_SYS_STAT_H # include #endif #ifdef HAVE_FCNTL_H # include #endif #ifdef HAVE_UNISTD_H # include #endif #ifndef _PATH_DEVNULL #define _PATH_DEVNULL "/dev/null" #endif /* XXX */ #undef HAVE_CYGWIN int daemon(int nochdir, int noclose) { int fd; switch (fork()) { case -1: return (-1); case 0: #ifdef HAVE_CYGWIN register_9x_service(); #endif break; default: #ifdef HAVE_CYGWIN /* * This sleep avoids a race condition which kills the * child process if parent is started by a NT/W2K service. */ sleep(1); #endif _exit(0); } if (setsid() == -1) return (-1); if (!nochdir) (void)chdir("/"); if (!noclose && (fd = open(_PATH_DEVNULL, O_RDWR, 0)) != -1) { (void)dup2(fd, STDIN_FILENO); (void)dup2(fd, STDOUT_FILENO); (void)dup2(fd, STDERR_FILENO); if (fd > 2) (void)close (fd); } return (0); } #endif /* !HAVE_DAEMON */ uim-1.8.8/replace/Makefile.in0000644000175000017500000006017513275405323012740 00000000000000# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = replace ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ac_cxx_have_stl.m4 \ $(top_srcdir)/m4/ac_cxx_namespace.m4 \ $(top_srcdir)/m4/ax_cflags_gcc_option.m4 \ $(top_srcdir)/m4/ax_func_sigsetjmp.m4 \ $(top_srcdir)/m4/ax_lib_glibc.m4 \ $(top_srcdir)/m4/ax_path_qmake4.m4 \ $(top_srcdir)/m4/ax_path_qmake5.m4 $(top_srcdir)/m4/eb4.m4 \ $(top_srcdir)/m4/expat.m4 $(top_srcdir)/m4/openssl.m4 \ $(top_srcdir)/m4/wnn.m4 $(top_srcdir)/m4/xft.m4 \ $(top_srcdir)/m4/xkb.m4 $(top_srcdir)/m4.generated/codeset.m4 \ $(top_srcdir)/m4.generated/gettext.m4 \ $(top_srcdir)/m4.generated/iconv.m4 \ $(top_srcdir)/m4.generated/intlmacosx.m4 \ $(top_srcdir)/m4.generated/intltool.m4 \ $(top_srcdir)/m4.generated/lib-ld.m4 \ $(top_srcdir)/m4.generated/lib-link.m4 \ $(top_srcdir)/m4.generated/lib-prefix.m4 \ $(top_srcdir)/m4.generated/libtool.m4 \ $(top_srcdir)/m4.generated/longlong.m4 \ $(top_srcdir)/m4.generated/ltoptions.m4 \ $(top_srcdir)/m4.generated/ltsugar.m4 \ $(top_srcdir)/m4.generated/ltversion.m4 \ $(top_srcdir)/m4.generated/lt~obsolete.m4 \ $(top_srcdir)/m4.generated/nls.m4 \ $(top_srcdir)/m4.generated/po.m4 \ $(top_srcdir)/m4.generated/progtest.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/uim/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LTLIBRARIES = $(noinst_LTLIBRARIES) libreplace_la_LIBADD = am_libreplace_la_OBJECTS = bsd-asprintf.lo bsd-misc.lo bsd-poll.lo \ bsd-snprintf.lo bsd-waitpid.lo daemon.lo fake-rfc2553.lo \ getpeereid.lo setenv.lo strlcat.lo strlcpy.lo strsep.lo \ strtoll.lo strtonum.lo libreplace_la_OBJECTS = $(am_libreplace_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/uim depcomp = $(SHELL) $(top_srcdir)/depcomp am__depfiles_maybe = depfiles am__mv = mv -f COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(libreplace_la_SOURCES) DIST_SOURCES = $(libreplace_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/depcomp DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ ALLOCA = @ALLOCA@ ALL_LINGUAS = @ALL_LINGUAS@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ ANTHY_CFLAGS = @ANTHY_CFLAGS@ ANTHY_LIBS = @ANTHY_LIBS@ ANTHY_UTF8_CFLAGS = @ANTHY_UTF8_CFLAGS@ ANTHY_UTF8_LIBS = @ANTHY_UTF8_LIBS@ APPLET_2_14_CFLAGS = @APPLET_2_14_CFLAGS@ APPLET_2_14_LIBS = @APPLET_2_14_LIBS@ AR = @AR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CMAKE = @CMAKE@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CSI = @CSI@ CURL_CFLAGS = @CURL_CFLAGS@ CURL_LIBS = @CURL_LIBS@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXDEPMODE = @CXXDEPMODE@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DESTDIR = @DESTDIR@ DICT_CFLAGS = @DICT_CFLAGS@ DICT_LIBS = @DICT_LIBS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ EBCONF_EBINCS = @EBCONF_EBINCS@ EBCONF_EBLIBS = @EBCONF_EBLIBS@ EBCONF_INTLINCS = @EBCONF_INTLINCS@ EBCONF_INTLLIBS = @EBCONF_INTLLIBS@ EBCONF_PTHREAD_CFLAGS = @EBCONF_PTHREAD_CFLAGS@ EBCONF_PTHREAD_CPPFLAGS = @EBCONF_PTHREAD_CPPFLAGS@ EBCONF_PTHREAD_LDFLAGS = @EBCONF_PTHREAD_LDFLAGS@ EBCONF_ZLIBINCS = @EBCONF_ZLIBINCS@ EBCONF_ZLIBLIBS = @EBCONF_ZLIBLIBS@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EMACS = @EMACS@ EMACSLOADPATH = @EMACSLOADPATH@ EXEEXT = @EXEEXT@ EXPAT_CFLAGS = @EXPAT_CFLAGS@ EXPAT_LIBS = @EXPAT_LIBS@ FEP_LIBADD = @FEP_LIBADD@ FFI_CFLAGS = @FFI_CFLAGS@ FFI_LIBS = @FFI_LIBS@ FGREP = @FGREP@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ GCROOTS_CFLAGS = @GCROOTS_CFLAGS@ GCROOTS_LIBS = @GCROOTS_LIBS@ GETTEXT_MACRO_VERSION = @GETTEXT_MACRO_VERSION@ GETTEXT_PACKAGE = @GETTEXT_PACKAGE@ GMSGFMT = @GMSGFMT@ GMSGFMT_015 = @GMSGFMT_015@ GNOME3_APPLET_CFLAGS = @GNOME3_APPLET_CFLAGS@ GNOME3_APPLET_LIBS = @GNOME3_APPLET_LIBS@ GNOME_APPLET_CFLAGS = @GNOME_APPLET_CFLAGS@ GNOME_APPLET_LIBS = @GNOME_APPLET_LIBS@ GOSH = @GOSH@ GREP = @GREP@ GTK2_4_CFLAGS = @GTK2_4_CFLAGS@ GTK2_4_LIBS = @GTK2_4_LIBS@ GTK2_CFLAGS = @GTK2_CFLAGS@ GTK2_LIBS = @GTK2_LIBS@ GTK3_BINARY_VERSION = @GTK3_BINARY_VERSION@ GTK3_CFLAGS = @GTK3_CFLAGS@ GTK3_LIBDIR = @GTK3_LIBDIR@ GTK3_LIBS = @GTK3_LIBS@ GTK_BINARY_VERSION = @GTK_BINARY_VERSION@ GTK_LIBDIR = @GTK_LIBDIR@ HOST_MOC = @HOST_MOC@ HOST_UIC = @HOST_UIC@ INCLUDES = @INCLUDES@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ INTLLIBS = @INTLLIBS@ INTLTOOL_EXTRACT = @INTLTOOL_EXTRACT@ INTLTOOL_MERGE = @INTLTOOL_MERGE@ INTLTOOL_PERL = @INTLTOOL_PERL@ INTLTOOL_UPDATE = @INTLTOOL_UPDATE@ INTLTOOL_V_MERGE = @INTLTOOL_V_MERGE@ INTLTOOL_V_MERGE_OPTIONS = @INTLTOOL_V_MERGE_OPTIONS@ INTLTOOL__v_MERGE_ = @INTLTOOL__v_MERGE_@ INTLTOOL__v_MERGE_0 = @INTLTOOL__v_MERGE_0@ INTL_MACOSX_LIBS = @INTL_MACOSX_LIBS@ KDE4_CONFIG = @KDE4_CONFIG@ KDE_CONFIG = @KDE_CONFIG@ KDE_DATA_DIR = @KDE_DATA_DIR@ KDE_INCLUDE_DIR = @KDE_INCLUDE_DIR@ KDE_LIB_DIR = @KDE_LIB_DIR@ KDE_PREFIX = @KDE_PREFIX@ KNOTIFY3_DATA_DIR = @KNOTIFY3_DATA_DIR@ KNOTIFY3_INCLUDE_DIR = @KNOTIFY3_INCLUDE_DIR@ KNOTIFY3_LIB_DIR = @KNOTIFY3_LIB_DIR@ KNOTIFY3_PREFIX = @KNOTIFY3_PREFIX@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBEDIT_LIBS = @LIBEDIT_LIBS@ LIBICONV = @LIBICONV@ LIBINTL = @LIBINTL@ LIBNOTIFY_CFLAGS = @LIBNOTIFY_CFLAGS@ LIBNOTIFY_LIBS = @LIBNOTIFY_LIBS@ LIBOBJS = @LIBOBJS@ LIBPANEL_APPLET_DIR = @LIBPANEL_APPLET_DIR@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBICONV = @LTLIBICONV@ LTLIBINTL = @LTLIBINTL@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ M17NDB = @M17NDB@ M17NLIB_CFLAGS = @M17NLIB_CFLAGS@ M17NLIB_LIBS = @M17NLIB_LIBS@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANA = @MANA@ MANIFEST_TOOL = @MANIFEST_TOOL@ MD5 = @MD5@ MKDIR_P = @MKDIR_P@ MOC = @MOC@ MSGFMT = @MSGFMT@ MSGFMT_015 = @MSGFMT_015@ MSGMERGE = @MSGMERGE@ NETLIBS = @NETLIBS@ NM = @NM@ NMEDIT = @NMEDIT@ OBJC = @OBJC@ OBJCDEPMODE = @OBJCDEPMODE@ OBJCFLAGS = @OBJCFLAGS@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OPENSSL_CPPFLAGS = @OPENSSL_CPPFLAGS@ OPENSSL_LIBS = @OPENSSL_LIBS@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ POSUB = @POSUB@ PRIME_CFLAGS = @PRIME_CFLAGS@ PRIME_LIBS = @PRIME_LIBS@ QMAKE4 = @QMAKE4@ QMAKE5 = @QMAKE5@ QT_CONFIG_OPTS = @QT_CONFIG_OPTS@ QT_PLUGINSDIR = @QT_PLUGINSDIR@ RANLIB = @RANLIB@ RSVG = @RSVG@ SED = @SED@ SET_MAKE = @SET_MAKE@ SH = @SH@ SHA1 = @SHA1@ SHELL = @SHELL@ SQLITE3_CFLAGS = @SQLITE3_CFLAGS@ SQLITE3_LIBS = @SQLITE3_LIBS@ SRCDIR = @SRCDIR@ STRIP = @STRIP@ UIC = @UIC@ UIMEL_LISP_DIR = @UIMEL_LISP_DIR@ UIM_LIBEXECDIR = @UIM_LIBEXECDIR@ UIM_QT_CXXFLAGS = @UIM_QT_CXXFLAGS@ UIM_QT_LDFLAGS = @UIM_QT_LDFLAGS@ UIM_SCM_CFLAGS = @UIM_SCM_CFLAGS@ UIM_VERSION_MAJOR = @UIM_VERSION_MAJOR@ UIM_VERSION_MINOR = @UIM_VERSION_MINOR@ UIM_VERSION_PATCHLEVEL = @UIM_VERSION_PATCHLEVEL@ UI_XML_ANTHY_END = @UI_XML_ANTHY_END@ UI_XML_ANTHY_START = @UI_XML_ANTHY_START@ UI_XML_CANNA_END = @UI_XML_CANNA_END@ UI_XML_CANNA_START = @UI_XML_CANNA_START@ USE_NLS = @USE_NLS@ VERSION = @VERSION@ WNN_CPPFLAGS = @WNN_CPPFLAGS@ WNN_LIBADD = @WNN_LIBADD@ WNN_LIBS = @WNN_LIBS@ X11_CFLAGS = @X11_CFLAGS@ X11_LIBS = @X11_LIBS@ XFT_CFLAGS = @XFT_CFLAGS@ XFT_CONFIG = @XFT_CONFIG@ XFT_LIBS = @XFT_LIBS@ XGETTEXT = @XGETTEXT@ XGETTEXT_015 = @XGETTEXT_015@ XGETTEXT_EXTRA_OPTIONS = @XGETTEXT_EXTRA_OPTIONS@ XIM_CFLAGS = @XIM_CFLAGS@ XIM_LIBS = @XIM_LIBS@ XMKMF = @XMKMF@ X_CFLAGS = @X_CFLAGS@ X_EXTRA_LIBS = @X_EXTRA_LIBS@ X_LIBS = @X_LIBS@ X_PRE_LIBS = @X_PRE_LIBS@ _QMAKE = @_QMAKE@ _QMAKE4 = @_QMAKE4@ _QMAKE5 = @_QMAKE5@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ ac_ct_OBJC = @ac_ct_OBJC@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ intltool__v_merge_options_ = @intltool__v_merge_options_@ intltool__v_merge_options_0 = @intltool__v_merge_options_0@ libdir = @libdir@ libexecdir = @libexecdir@ lispdir = @lispdir@ localedir = @localedir@ localstatedir = @localstatedir@ m17n_db_dir = @m17n_db_dir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ uim_pixmapsdir = @uim_pixmapsdir@ noinst_LTLIBRARIES = libreplace.la libreplace_la_SOURCES = \ bsd-asprintf.c \ bsd-misc.c \ bsd-poll.c \ bsd-poll.h \ bsd-snprintf.c \ bsd-waitpid.c \ bsd-waitpid.h \ daemon.c \ fake-rfc2553.c \ fake-rfc2553.h \ getpeereid.c \ os_dep.h \ setenv.c \ strlcat.c \ strlcpy.c \ strsep.c \ strtoll.c \ strtonum.c all: all-am .SUFFIXES: .SUFFIXES: .c .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign replace/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign replace/Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): clean-noinstLTLIBRARIES: -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) @list='$(noinst_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } libreplace.la: $(libreplace_la_OBJECTS) $(libreplace_la_DEPENDENCIES) $(EXTRA_libreplace_la_DEPENDENCIES) $(AM_V_CCLD)$(LINK) $(libreplace_la_OBJECTS) $(libreplace_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bsd-asprintf.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bsd-misc.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bsd-poll.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bsd-snprintf.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bsd-waitpid.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/daemon.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fake-rfc2553.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/getpeereid.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/setenv.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/strlcat.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/strlcpy.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/strsep.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/strtoll.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/strtonum.Plo@am__quote@ .c.o: @am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< .c.obj: @am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: @am__fastdepCC_TRUE@ $(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(LTLIBRARIES) installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \ mostlyclean-am distclean: distclean-am -rm -rf ./$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -rf ./$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool clean-noinstLTLIBRARIES cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am .PRECIOUS: Makefile strtonum.lo: CFLAGS+=-std=c99 # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: uim-1.8.8/replace/fake-rfc2553.h0000644000175000017500000001214012503502431013015 00000000000000/* $Id: fake-rfc2553.h,v 1.13 2006/07/24 03:51:52 djm Exp $ */ /* * Copyright (C) 2000-2003 Damien Miller. All rights reserved. * Copyright (C) 1999 WIDE Project. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the project nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. */ #ifndef _FAKE_RFC2553_H #define _FAKE_RFC2553_H #include #if defined(HAVE_NETDB_H) # include #endif /* * First, socket and INET6 related definitions */ #ifndef HAVE_STRUCT_SOCKADDR_STORAGE # define _SS_MAXSIZE 128 /* Implementation specific max size */ # define _SS_PADSIZE (_SS_MAXSIZE - sizeof (struct sockaddr)) struct sockaddr_storage { struct sockaddr ss_sa; char __ss_pad2[_SS_PADSIZE]; }; # define ss_family ss_sa.sa_family #endif /* !HAVE_STRUCT_SOCKADDR_STORAGE */ #ifndef IN6_IS_ADDR_LOOPBACK # define IN6_IS_ADDR_LOOPBACK(a) \ (((u_int32_t *)(a))[0] == 0 && ((u_int32_t *)(a))[1] == 0 && \ ((u_int32_t *)(a))[2] == 0 && ((u_int32_t *)(a))[3] == htonl(1)) #endif /* !IN6_IS_ADDR_LOOPBACK */ #ifndef HAVE_STRUCT_IN6_ADDR struct in6_addr { u_int8_t s6_addr[16]; }; #endif /* !HAVE_STRUCT_IN6_ADDR */ #ifndef HAVE_STRUCT_SOCKADDR_IN6 struct sockaddr_in6 { unsigned short sin6_family; u_int16_t sin6_port; u_int32_t sin6_flowinfo; struct in6_addr sin6_addr; }; #endif /* !HAVE_STRUCT_SOCKADDR_IN6 */ #ifndef AF_INET6 /* Define it to something that should never appear */ #define AF_INET6 AF_MAX #endif /* * Next, RFC2553 name / address resolution API */ #ifndef NI_NUMERICHOST # define NI_NUMERICHOST (1) #endif #ifndef NI_NAMEREQD # define NI_NAMEREQD (1<<1) #endif #ifndef NI_NUMERICSERV # define NI_NUMERICSERV (1<<2) #endif #ifndef AI_PASSIVE # define AI_PASSIVE (1) #endif #ifndef AI_CANONNAME # define AI_CANONNAME (1<<1) #endif #ifndef AI_NUMERICHOST # define AI_NUMERICHOST (1<<2) #endif #ifndef NI_MAXSERV # define NI_MAXSERV 32 #endif /* !NI_MAXSERV */ #ifndef NI_MAXHOST # define NI_MAXHOST 1025 #endif /* !NI_MAXHOST */ #ifndef EAI_NODATA # define EAI_NODATA (INT_MAX - 1) #endif #ifndef EAI_MEMORY # define EAI_MEMORY (INT_MAX - 2) #endif #ifndef EAI_NONAME # define EAI_NONAME (INT_MAX - 3) #endif #ifndef EAI_SYSTEM # define EAI_SYSTEM (INT_MAX - 4) #endif #ifndef HAVE_STRUCT_ADDRINFO struct addrinfo { int ai_flags; /* AI_PASSIVE, AI_CANONNAME */ int ai_family; /* PF_xxx */ int ai_socktype; /* SOCK_xxx */ int ai_protocol; /* 0 or IPPROTO_xxx for IPv4 and IPv6 */ size_t ai_addrlen; /* length of ai_addr */ char *ai_canonname; /* canonical name for hostname */ struct sockaddr *ai_addr; /* binary address */ struct addrinfo *ai_next; /* next structure in linked list */ }; #endif /* !HAVE_STRUCT_ADDRINFO */ #ifndef HAVE_GETADDRINFO #ifdef getaddrinfo # undef getaddrinfo #endif #define getaddrinfo(a,b,c,d) (uim_getaddrinfo(a,b,c,d)) int getaddrinfo(const char *, const char *, const struct addrinfo *, struct addrinfo **); #endif /* !HAVE_GETADDRINFO */ #if !defined(HAVE_GAI_STRERROR) && !defined(HAVE_CONST_GAI_STRERROR_PROTO) #define gai_strerror(a) (uim_gai_strerror(a)) char *gai_strerror(int); #endif /* !HAVE_GAI_STRERROR */ #ifndef HAVE_FREEADDRINFO #define freeaddrinfo(a) (uim_freeaddrinfo(a)) void freeaddrinfo(struct addrinfo *); #endif /* !HAVE_FREEADDRINFO */ #ifndef HAVE_GETNAMEINFO #define getnameinfo(a,b,c,d,e,f,g) (uim_getnameinfo(a,b,c,d,e,f,g)) int getnameinfo(const struct sockaddr *, size_t, char *, size_t, char *, size_t, int); #endif /* !HAVE_GETNAMEINFO */ #endif /* !_FAKE_RFC2553_H */ uim-1.8.8/replace/bsd-waitpid.c0000644000175000017500000000352612503502431013232 00000000000000/* * Copyright (c) 2000 Ben Lindstrom. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include #ifndef HAVE_WAITPID #include #include #include "bsd-waitpid.h" pid_t waitpid(int pid, int *stat_loc, int options) { union wait statusp; pid_t wait_pid; if (pid <= 0) { if (pid != -1) { errno = EINVAL; return (-1); } /* wait4() wants pid=0 for indiscriminate wait. */ pid = 0; } wait_pid = wait4(pid, &statusp, options, NULL); if (stat_loc) *stat_loc = (int) statusp.w_status; return (wait_pid); } #endif /* !HAVE_WAITPID */ uim-1.8.8/replace/os_dep.h0000644000175000017500000001066513144164677012325 00000000000000/* Copyright (c) 2003-2013 uim Project https://github.com/uim/uim All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #ifndef UIM_REPLACE_OS_DEP_H #define UIM_REPLACE_OS_DEP_H /* stdint.h compatible type definitions */ #if HAVE_STDINT_H #include #endif #if HAVE_INTTYPES_H #include #endif #if HAVE_SYS_INTTYPES_H #include #endif #if HAVE_SYS_TYPES_H #include #endif #if HAVE_STDARG_H #include #endif #include #include #ifndef MAXPATHLEN # ifdef PATH_MAX # define MAXPATHLEN PATH_MAX # else /* PATH_MAX */ # define MAXPATHLEN 1024 /* 64 in openssh-portable */ # endif /* PATH_MAX */ #endif /* MAXPATHLEN */ #ifndef PATH_MAX # define PATH_MAX 1024 /* _POSIX_PATH_MAX in openssh-portable */ #endif #ifdef __cplusplus extern "C" { #endif #ifndef HAVE_GETPEEREID #include #define getpeereid uim_internal_getpeereid int getpeereid(int , uid_t *, gid_t *); #endif #ifndef HAVE_SETENV #define setenv uim_internal_setenv int setenv(const char *, const char *, int); #endif #ifndef HAVE_UNSETENV #define unsetenv uim_internal_unsetenv void unsetenv(const char *); #endif #ifndef HAVE_STRSEP #define strsep uim_internal_strsep char *strsep(char **stringp, const char *delim); #endif #ifndef HAVE_STRLCPY #define strlcpy uim_internal_strlcpy size_t strlcpy(char *dst, const char *src, size_t siz); #endif #ifndef HAVE_STRLCAT #define strlcat uim_internal_strlcat size_t strlcat(char *dst, const char *src, size_t siz); #endif #ifndef HAVE_STRDUP #define strdup uim_internal_strdup char *strdup(const char *); #endif #include "fake-rfc2553.h" #ifndef HAVE_VASPRINTF #define vasprintf uim_internal_vasprintf int vasprintf(char **ret, const char *format, va_list ap); #endif #ifndef HAVE_ASPRINTF #define asprintf uim_internal_asprintf int asprintf(char **ret, const char *format, ...); #endif #if !defined(HAVE_VSNPRINTF) || defined(BROKEN_SNPRINTF) #define vsnprintf uim_internal_vsnprintf int vsnprintf(char *str, size_t size, const char *format, va_list ap); #endif #if !defined(HAVE_SNPRINTF) || defined(BROKEN_SNPRINTF) #define snprintf uim_internal_snprintf int snprintf(char *str, size_t size, const char *format, ...); #endif #ifndef HAVE_STRTOLL #define strtoll uim_internal_strtoll long long strtoll(const char *, char **, int); #endif #ifndef HAVE_STRTONUM #define strtonum uim_internal_strtonum long long strtonum(const char *numstr, long long minval, long long maxval, const char **errstrp); #endif #ifdef HAVE_POLL_H #include #elif defined(HAVE_SYS_POLL_H) #include #else #include "bsd-poll.h" #endif #ifndef HAVE_POLL #define poll uim_internal_poll int poll(struct pollfd *, nfds_t, int); #endif #ifdef HAVE_WAITPID #include #else #include "bsd-waitpid.h" #endif #ifndef HAVE_WAITPID #define waitpid uim_internal_waitpid pid_t waitpid(pid_t, int *, int); #endif #ifndef HAVE_DAEMON #define daemon uim_internal_daemon int daemon(int, int); #endif #ifdef __cplusplus } #endif #endif /* UIM_REPLACE_OS_DEP_H */ uim-1.8.8/replace/strlcat.c0000644000175000017500000000355412503502431012500 00000000000000/* $NetBSD: strlcat.c,v 1.16 2003/10/27 00:12:42 lukem Exp $ */ /* $OpenBSD: strlcat.c,v 1.10 2003/04/12 21:56:39 millert Exp $ */ /* * Copyright (c) 1998 Todd C. Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND TODD C. MILLER DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL TODD C. MILLER BE LIABLE * FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION * OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #include #include #include #if !HAVE_STRLCAT /* * Appends src to string dst of size siz (unlike strncat, siz is the * full size of dst, not space left). At most siz-1 characters * will be copied. Always NUL terminates (unless siz <= strlen(dst)). * Returns strlen(src) + MIN(siz, strlen(initial dst)). * If retval >= siz, truncation occurred. */ size_t strlcat(dst, src, siz) char *dst; const char *src; size_t siz; { char *d = dst; const char *s = src; size_t n = siz; size_t dlen; if (dst == NULL) return 0; if (src == NULL) return 0; /* Find the end of dst and adjust bytes left but don't go past end */ while (n-- != 0 && *d != '\0') d++; dlen = d - dst; n = siz - dlen; if (n == 0) return(dlen + strlen(s)); while (*s != '\0') { if (n != 1) { *d++ = *s; n--; } s++; } *d = '\0'; return(dlen + (s - src)); /* count does not include NUL */ } #endif uim-1.8.8/replace/strlcpy.c0000644000175000017500000000337412503502431012524 00000000000000/* $NetBSD: strlcpy.c,v 1.14 2003/10/27 00:12:42 lukem Exp $ */ /* $OpenBSD: strlcpy.c,v 1.7 2003/04/12 21:56:39 millert Exp $ */ /* * Copyright (c) 1998 Todd C. Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND TODD C. MILLER DISCLAIMS ALL * WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL TODD C. MILLER BE LIABLE * FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION * OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #include #include #include #if !HAVE_STRLCPY /* * Copy src to string dst of size siz. At most siz-1 characters * will be copied. Always NUL terminates (unless siz == 0). * Returns strlen(src); if retval >= siz, truncation occurred. */ size_t strlcpy(dst, src, siz) char *dst; const char *src; size_t siz; { char *d = dst; const char *s = src; size_t n = siz; if (dst == NULL) return 0; if (src == NULL) return 0; /* Copy as many bytes as will fit */ if (n != 0 && --n != 0) { do { if ((*d++ = *s++) == 0) break; } while (--n != 0); } /* Not enough room in dst, add NUL and traverse rest of src */ if (n == 0) { if (siz != 0) *d = '\0'; /* NUL-terminate dst */ while (*s++) ; } return(s - src - 1); /* count does not include NUL */ } #endif uim-1.8.8/replace/fake-rfc2553.c0000644000175000017500000001370612503502431013021 00000000000000/* * Copyright (C) 2000-2003 Damien Miller. All rights reserved. * Copyright (C) 1999 WIDE Project. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the project nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. */ #include #include #include #include #include #ifndef HAVE_GETNAMEINFO int getnameinfo(const struct sockaddr *sa, size_t salen, char *host, size_t hostlen, char *serv, size_t servlen, int flags) { struct sockaddr_in *sin = (struct sockaddr_in *)sa; struct hostent *hp; char tmpserv[16]; if (serv != NULL) { snprintf(tmpserv, sizeof(tmpserv), "%d", ntohs(sin->sin_port)); if (strlcpy(serv, tmpserv, servlen) >= servlen) return (EAI_MEMORY); } if (host != NULL) { if (flags & NI_NUMERICHOST) { if (strlcpy(host, inet_ntoa(sin->sin_addr), hostlen) >= hostlen) return (EAI_MEMORY); else return (0); } else { hp = gethostbyaddr((char *)&sin->sin_addr, sizeof(struct in_addr), AF_INET); if (hp == NULL) return (EAI_NODATA); if (strlcpy(host, hp->h_name, hostlen) >= hostlen) return (EAI_MEMORY); else return (0); } } return (0); } #endif /* !HAVE_GETNAMEINFO */ #ifndef HAVE_GAI_STRERROR #ifdef HAVE_CONST_GAI_STRERROR_PROTO const char * #else char * #endif gai_strerror(int err) { switch (err) { case EAI_NODATA: return ("no address associated with name"); case EAI_MEMORY: return ("memory allocation failure."); case EAI_NONAME: return ("nodename nor servname provided, or not known"); default: return ("unknown/invalid error."); } } #endif /* !HAVE_GAI_STRERROR */ #ifndef HAVE_FREEADDRINFO void freeaddrinfo(struct addrinfo *ai) { struct addrinfo *next; for(; ai != NULL;) { next = ai->ai_next; free(ai); ai = next; } } #endif /* !HAVE_FREEADDRINFO */ #ifndef HAVE_GETADDRINFO static struct addrinfo *malloc_ai(int port, u_long addr, const struct addrinfo *hints) { struct addrinfo *ai; ai = malloc(sizeof(*ai) + sizeof(struct sockaddr_in)); if (ai == NULL) return (NULL); memset(ai, '\0', sizeof(*ai) + sizeof(struct sockaddr_in)); ai->ai_addr = (struct sockaddr *)(ai + 1); /* XXX -- ssh doesn't use sa_len */ ai->ai_addrlen = sizeof(struct sockaddr_in); ai->ai_addr->sa_family = ai->ai_family = AF_INET; ((struct sockaddr_in *)(ai)->ai_addr)->sin_port = port; ((struct sockaddr_in *)(ai)->ai_addr)->sin_addr.s_addr = addr; /* XXX: the following is not generally correct, but does what we want */ if (hints->ai_socktype) ai->ai_socktype = hints->ai_socktype; else ai->ai_socktype = SOCK_STREAM; if (hints->ai_protocol) ai->ai_protocol = hints->ai_protocol; return (ai); } int getaddrinfo(const char *hostname, const char *servname, const struct addrinfo *hints, struct addrinfo **res) { struct hostent *hp; struct servent *sp; struct in_addr in; int i; long int port; u_long addr; port = 0; if (servname != NULL) { char *cp; port = strtol(servname, &cp, 10); if (port > 0 && port <= 65535 && *cp == '\0') port = htons(port); else if ((sp = getservbyname(servname, NULL)) != NULL) port = sp->s_port; else port = 0; } if (hints && hints->ai_flags & AI_PASSIVE) { addr = htonl(0x00000000); if (hostname && inet_aton(hostname, &in) != 0) addr = in.s_addr; *res = malloc_ai(port, addr, hints); if (*res == NULL) return (EAI_MEMORY); return (0); } if (!hostname) { *res = malloc_ai(port, htonl(0x7f000001), hints); if (*res == NULL) return (EAI_MEMORY); return (0); } if (inet_aton(hostname, &in)) { *res = malloc_ai(port, in.s_addr, hints); if (*res == NULL) return (EAI_MEMORY); return (0); } /* Don't try DNS if AI_NUMERICHOST is set */ if (hints && hints->ai_flags & AI_NUMERICHOST) return (EAI_NONAME); hp = gethostbyname(hostname); if (hp && hp->h_name && hp->h_name[0] && hp->h_addr_list[0]) { struct addrinfo *cur, *prev; cur = prev = *res = NULL; for (i = 0; hp->h_addr_list[i]; i++) { struct in_addr *in = (struct in_addr *)hp->h_addr_list[i]; cur = malloc_ai(port, in->s_addr, hints); if (cur == NULL) { if (*res != NULL) freeaddrinfo(*res); return (EAI_MEMORY); } if (prev) prev->ai_next = cur; else *res = cur; prev = cur; } return (0); } return (EAI_NODATA); } #endif /* !HAVE_GETADDRINFO */ uim-1.8.8/replace/getpeereid.c0000644000175000017500000000601212503502431013131 00000000000000/* * Copyright (c) 2002,2004 Damien Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #include #include #include #include #include #include #if !defined(HAVE_GETPEEREID) #if defined(SO_PEERCRED) int getpeereid(int s, uid_t *euid, gid_t *gid) { struct ucred cred; socklen_t len = sizeof(cred); if (getsockopt(s, SOL_SOCKET, SO_PEERCRED, &cred, &len) < 0) return (-1); *euid = cred.uid; *gid = cred.gid; return (0); } #elif defined(LOCAL_CREDS) /* NetBSD */ int getpeereid(int s, uid_t *euid, gid_t *gid) { /* Credentials structure */ #ifdef __NetBSD__ /* XXX: should use autoconf */ #define HAVE_STRUCT_SOCKCRED #endif #if defined(HAVE_STRUCT_CMSGCRED) typedef struct cmsgcred Cred; #define cruid cmcred_euid #define crgid cmcred_groups[0] #elif defined(HAVE_STRUCT_FCRED) typedef struct fcred Cred; #define cruid fc_uid #define crgid fc_gid #elif defined(HAVE_STRUCT_SOCKCRED) typedef struct sockcred Cred; #define cruid sc_euid #define crgid sc_egid #endif Cred *cred; /* Compute size without padding */ char cmsgmem[CMSG_SPACE(sizeof(Cred))]; /* for NetBSD */ /* Point to start of first structure */ struct cmsghdr *cmsg = (struct cmsghdr *)cmsgmem; struct iovec iov; char buf; struct msghdr msg; memset(&msg, 0, sizeof(msg)); msg.msg_iov = &iov; msg.msg_iovlen = 1; msg.msg_control = (char *)cmsg; msg.msg_controllen = sizeof(cmsgmem); memset(cmsg, 0, sizeof(cmsgmem)); /* * The one character which is received here is not meaningful; its * purposes is only to make sure that recvmsg() blocks long enough for * the other side to send its credentials. */ iov.iov_base = &buf; iov.iov_len = 1; if (recvmsg(s, &msg, 0) < 0 || cmsg->cmsg_len < sizeof(cmsgmem) || cmsg->cmsg_type != SCM_CREDS) { return -1; } cred = (Cred *)CMSG_DATA(cmsg); *euid = cred->cruid; *gid = cred->crgid; return 0; } #else int getpeereid(int s, uid_t *euid, gid_t *gid) { *euid = geteuid(); *gid = getgid(); return (0); } #endif /* defined(SO_PEERCRED) */ #endif /* !defined(HAVE_GETPEEREID) */ uim-1.8.8/replace/bsd-poll.c0000644000175000017500000000562112503502431012535 00000000000000/* $Id: bsd-poll.c,v 1.3 2008/04/04 05:16:36 djm Exp $ */ /* * Copyright (c) 2004, 2005, 2007 Darren Tucker (dtucker at zip com au). * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #if !defined(HAVE_POLL) #ifdef HAVE_SYS_SELECT_H # include #endif #include #include #include "bsd-poll.h" /* * A minimal implementation of poll(2), built on top of select(2). * * Only supports POLLIN and POLLOUT flags in pfd.events, and POLLIN, POLLOUT * and POLLERR flags in revents. * * Supports pfd.fd = -1 meaning "unused" although it's not standard. */ int poll(struct pollfd *fds, nfds_t nfds, int timeout) { nfds_t i; int saved_errno, ret, fd, maxfd = 0; fd_set *readfds = NULL, *writefds = NULL, *exceptfds = NULL; size_t nmemb; struct timeval tv, *tvp = NULL; for (i = 0; i < nfds; i++) { if (fd >= FD_SETSIZE) { errno = EINVAL; return -1; } maxfd = MAX(maxfd, fds[i].fd); } nmemb = howmany(maxfd + 1 , NFDBITS); if ((readfds = calloc(nmemb, sizeof(fd_mask))) == NULL || (writefds = calloc(nmemb, sizeof(fd_mask))) == NULL || (exceptfds = calloc(nmemb, sizeof(fd_mask))) == NULL) { saved_errno = ENOMEM; ret = -1; goto out; } /* populate event bit vectors for the events we're interested in */ for (i = 0; i < nfds; i++) { fd = fds[i].fd; if (fd == -1) continue; if (fds[i].events & POLLIN) { FD_SET(fd, readfds); FD_SET(fd, exceptfds); } if (fds[i].events & POLLOUT) { FD_SET(fd, writefds); FD_SET(fd, exceptfds); } } /* poll timeout is msec, select is timeval (sec + usec) */ if (timeout >= 0) { tv.tv_sec = timeout / 1000; tv.tv_usec = (timeout % 1000) * 1000; tvp = &tv; } ret = select(maxfd + 1, readfds, writefds, exceptfds, tvp); saved_errno = errno; /* scan through select results and set poll() flags */ for (i = 0; i < nfds; i++) { fd = fds[i].fd; fds[i].revents = 0; if (fd == -1) continue; if (FD_ISSET(fd, readfds)) { fds[i].revents |= POLLIN; } if (FD_ISSET(fd, writefds)) { fds[i].revents |= POLLOUT; } if (FD_ISSET(fd, exceptfds)) { fds[i].revents |= POLLERR; } } out: free(readfds); free(writefds); free(exceptfds); if (ret == -1) errno = saved_errno; return ret; } #endif uim-1.8.8/replace/strsep.c0000644000175000017500000000474712503502431012351 00000000000000/*- * Copyright (c) 1990, 1993 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #include #include #include #if !defined(HAVE_STRSEP) /* * Get next token from string *stringp, where tokens are possibly-empty * strings separated by characters from delim. * * Writes NULs into the string at *stringp to end tokens. * delim need not remain constant from call to call. * On return, *stringp points past the last NUL written (if there might * be further tokens), or is NULL (if there are definitely no more tokens). * * If *stringp is NULL, strsep returns NULL. */ char * strsep(char **stringp, const char *delim) { char *s; const char *spanp; int c, sc; char *tok; if ((s = *stringp) == NULL) return (NULL); for (tok = s;;) { c = *s++; spanp = delim; do { if ((sc = *spanp++) == c) { if (c == 0) s = NULL; else s[-1] = 0; *stringp = s; return (tok); } } while (sc != 0); } /* NOTREACHED */ } #endif /* !defined(HAVE_STRSEP) */ uim-1.8.8/replace/strtoll.c0000644000175000017500000001044412503502431012523 00000000000000/* $OpenBSD: strtoll.c,v 1.6 2005/11/10 10:00:17 espie Exp $ */ /*- * Copyright (c) 1992 The Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* OPENBSD ORIGINAL: lib/libc/stdlib/strtoll.c */ #include #ifndef HAVE_STRTOLL #include #include #include #include #include /* * Convert a string to a long long. * * Ignores `locale' stuff. Assumes that the upper and lower case * alphabets and digits are each contiguous. */ long long strtoll(const char *nptr, char **endptr, int base) { const char *s; long long acc, cutoff; int c; int neg, any, cutlim; /* * Skip white space and pick up leading +/- sign if any. * If base is 0, allow 0x for hex and 0 for octal, else * assume decimal; if base is already 16, allow 0x. */ s = nptr; do { c = (unsigned char) *s++; } while (isspace(c)); if (c == '-') { neg = 1; c = *s++; } else { neg = 0; if (c == '+') c = *s++; } if ((base == 0 || base == 16) && c == '0' && (*s == 'x' || *s == 'X')) { c = s[1]; s += 2; base = 16; } if (base == 0) base = c == '0' ? 8 : 10; /* * Compute the cutoff value between legal numbers and illegal * numbers. That is the largest legal value, divided by the * base. An input number that is greater than this value, if * followed by a legal input character, is too big. One that * is equal to this value may be valid or not; the limit * between valid and invalid numbers is then based on the last * digit. For instance, if the range for long longs is * [-9223372036854775808..9223372036854775807] and the input base * is 10, cutoff will be set to 922337203685477580 and cutlim to * either 7 (neg==0) or 8 (neg==1), meaning that if we have * accumulated a value > 922337203685477580, or equal but the * next digit is > 7 (or 8), the number is too big, and we will * return a range error. * * Set any if any `digits' consumed; make it negative to indicate * overflow. */ cutoff = neg ? LLONG_MIN : LLONG_MAX; cutlim = cutoff % base; cutoff /= base; if (neg) { if (cutlim > 0) { cutlim -= base; cutoff += 1; } cutlim = -cutlim; } for (acc = 0, any = 0;; c = (unsigned char) *s++) { if (isdigit(c)) c -= '0'; else if (isalpha(c)) c -= isupper(c) ? 'A' - 10 : 'a' - 10; else break; if (c >= base) break; if (any < 0) continue; if (neg) { if (acc < cutoff || (acc == cutoff && c > cutlim)) { any = -1; acc = LLONG_MIN; errno = ERANGE; } else { any = 1; acc *= base; acc -= c; } } else { if (acc > cutoff || (acc == cutoff && c > cutlim)) { any = -1; acc = LLONG_MAX; errno = ERANGE; } else { any = 1; acc *= base; acc += c; } } } if (endptr != 0) *endptr = (char *) (any ? s - 1 : nptr); return (acc); } #endif /* HAVE_STRTOLL */ uim-1.8.8/replace/setenv.c0000644000175000017500000001074512503502431012330 00000000000000/* * Copyright (c) 1987 Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #include #include #include #if !defined(HAVE_SETENV) || !defined(HAVE_UNSETENV) static char *__findenv(const char *name, int *offset); extern char **environ; /* * __findenv -- * Returns pointer to value associated with name, if any, else NULL. * Sets offset to be the offset of the name/value combination in the * environmental array, for use by setenv(3) and unsetenv(3). * Explicitly removes '=' in argument name. * * This routine *should* be a static; don't use it. */ static char * __findenv(name, offset) register const char *name; int *offset; { register int len, i; register const char *np; register char **p, *cp; if (name == NULL || environ == NULL) return (NULL); for (np = name; *np && *np != '='; ++np) ; len = np - name; for (p = environ; (cp = *p) != NULL; ++p) { for (np = name, i = len; i && *cp; i--) if (*cp++ != *np++) break; if (i == 0 && *cp++ == '=') { *offset = p - environ; return (cp); } } return (NULL); } #ifndef HAVE_SETENV /* * setenv -- * Set the value of the environmental variable "name" to be * "value". If rewrite is set, replace any current value. */ int setenv(name, value, rewrite) register const char *name; register const char *value; int rewrite; { static int alloced; /* if allocated space before */ register char *C; int offset; size_t l_value; if (*value == '=') /* no `=' in value */ ++value; l_value = strlen(value); if ((C = __findenv(name, &offset))) { /* find if already exists */ if (!rewrite) return (0); if (strlen(C) >= l_value) { /* old larger; copy over */ while ((*C++ = *value++)) ; return (0); } } else { /* create new slot */ register int cnt; register char **P; for (P = environ, cnt = 0; *P; ++P, ++cnt); if (alloced) { /* just increase size */ P = (char **)realloc((void *)environ, (size_t)(sizeof(char *) * (cnt + 2))); if (!P) return (-1); environ = P; } else { /* get new space */ alloced = 1; /* copy old entries into it */ P = (char **)malloc((size_t)(sizeof(char *) * (cnt + 2))); if (!P) return (-1); memmove(P, environ, cnt * sizeof(char *)); environ = P; } environ[cnt + 1] = NULL; offset = cnt; } for (C = (char *)name; *C && *C != '='; ++C); /* no `=' in name */ if (!(environ[offset] = /* name + `=' + value */ malloc((size_t)((int)(C - name) + l_value + 2)))) return (-1); for (C = environ[offset]; (*C = *name++) && *C != '='; ++C) ; for (*C++ = '='; (*C++ = *value++); ) ; return (0); } #endif /* HAVE_SETENV */ #ifndef HAVE_UNSETENV /* * unsetenv(name) -- * Delete environmental variable "name". */ void unsetenv(name) const char *name; { register char **P; int offset; while (__findenv(name, &offset)) /* if set multiple times */ for (P = &environ[offset];; ++P) if (!(*P = *(P + 1))) break; } #endif /* HAVE_UNSETENV */ #endif /* !defined(HAVE_SETENV) || !defined(HAVE_UNSETENV) */ uim-1.8.8/replace/bsd-asprintf.c0000644000175000017500000000451212503502431013413 00000000000000/* * Copyright (c) 2004 Darren Tucker. * * Based originally on asprintf.c from OpenBSD: * Copyright (c) 1997 Todd C. Miller * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ #include #ifndef HAVE_VASPRINTF #include #include #include #ifndef VA_COPY # ifdef HAVE_VA_COPY # define VA_COPY(dest, src) va_copy(dest, src) # else # ifdef HAVE___VA_COPY # define VA_COPY(dest, src) __va_copy(dest, src) # else # define VA_COPY(dest, src) (dest) = (src) # endif # endif #endif #define INIT_SZ 128 int vasprintf(char **str, const char *fmt, va_list ap) { int ret = -1; va_list ap2; char *string, *newstr; size_t len; VA_COPY(ap2, ap); if ((string = malloc(INIT_SZ)) == NULL) goto fail; ret = vsnprintf(string, INIT_SZ, fmt, ap2); if (ret >= 0 && ret < INIT_SZ) { /* succeeded with initial alloc */ *str = string; } else if (ret == INT_MAX) { /* shouldn't happen */ goto fail; } else { /* bigger than initial, realloc allowing for nul */ len = (size_t)ret + 1; if ((newstr = realloc(string, len)) == NULL) { free(string); goto fail; } else { va_end(ap2); VA_COPY(ap2, ap); ret = vsnprintf(newstr, len, fmt, ap2); if (ret >= 0 && (size_t)ret < len) { *str = newstr; } else { /* failed with realloc'ed string, give up */ free(newstr); goto fail; } } } va_end(ap2); return (ret); fail: *str = NULL; errno = ENOMEM; va_end(ap2); return (-1); } #endif #ifndef HAVE_ASPRINTF int asprintf(char **str, const char *fmt, ...) { va_list ap; int ret; *str = NULL; va_start(ap, fmt); ret = vasprintf(str, fmt, ap); va_end(ap); return ret; } #endif uim-1.8.8/sigscheme/0000755000175000017500000000000013275405526011303 500000000000000uim-1.8.8/sigscheme/config.sub0000755000175000017500000010645013275405265013214 00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2018 Free Software Foundation, Inc. timestamp='2018-02-22' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # Please send patches to . # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS Canonicalize a configuration name. Options: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright 1992-2018 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo "$1" exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ kopensolaris*-gnu* | cloudabi*-eabi* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; android-linux) os=-linux-android basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown ;; *) basic_machine=`echo "$1" | sed 's/-[^-]*$//'` if [ "$basic_machine" != "$1" ] then os=`echo "$1" | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze*) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-pc/'` ;; -lynx*178) os=-lynxos178 ;; -lynx*5) os=-lynxos5 ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-sequent/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | aarch64 | aarch64_be \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arceb \ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ | avr | avr32 \ | ba \ | be32 | be64 \ | bfin \ | c4x | c8051 | clipper \ | d10v | d30v | dlx | dsp16xx \ | e2k | epiphany \ | fido | fr30 | frv | ft32 \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ | i370 | i860 | i960 | ia16 | ia64 \ | ip2k | iq2000 \ | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \ | open8 | or1k | or1knd | or32 \ | pdp10 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pru \ | pyramid \ | riscv32 | riscv64 \ | rl78 | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | visium \ | wasm32 \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; leon|leon[3-9]) basic_machine=sparc-$basic_machine ;; m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xgate) basic_machine=$basic_machine-unknown os=-none ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`"$1"\': machine \`"$basic_machine"\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | aarch64-* | aarch64_be-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | ba-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | c8051-* | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | e2k-* | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ | ip2k-* | iq2000-* \ | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ | microblaze-* | microblazeel-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pru-* \ | pyramid-* \ | riscv32-* | riscv64-* \ | rl78-* | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | visium-* \ | wasm32-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-pc os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; asmjs) basic_machine=asmjs-unknown ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2*) basic_machine=m68k-bull os=-sysv3 ;; e500v[12]) basic_machine=powerpc-unknown os=$os"spe" ;; e500v[12]-*) basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=$os"spe" ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; i*86v32) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; leon-*|leon[3-9]-*) basic_machine=sparc-`echo "$basic_machine" | sed 's/-.*//'` ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze*) basic_machine=microblaze-xilinx ;; mingw64) basic_machine=x86_64-pc os=-mingw64 ;; mingw32) basic_machine=i686-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; moxiebox) basic_machine=moxie-unknown os=-moxiebox ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo "$basic_machine" | sed -e 's/ms1-/mt-/'` ;; msys) basic_machine=i686-pc os=-msys ;; mvs) basic_machine=i370-ibm os=-mvs ;; nacl) basic_machine=le32-unknown os=-nacl ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; nsv-tandem) basic_machine=nsv-tandem ;; nsx-tandem) basic_machine=nsx-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos | rdos64) basic_machine=x86_64-pc os=-rdos ;; rdos32) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh5el) basic_machine=sh5le-unknown ;; simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo "$basic_machine" | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; x64) basic_machine=x86_64-pc ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo "$basic_machine" | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`"$1"\': machine \`"$basic_machine"\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo "$basic_machine" | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo "$basic_machine" | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases that might get confused # with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # es1800 is here to avoid being matched by es* (a different OS) -es1800*) os=-ose ;; # Now accept the basic system types. # The portable systems comes first. # Each alternative MUST end in a * to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* | -plan9* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* | -cloudabi* | -sortix* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -knetbsd* | -mirbsd* | -netbsd* \ | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* | -glidix* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \ | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox* | -bme* \ | -midnightbsd*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -xray | -os68k* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo "$os" | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo "$os" | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo "$os" | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4*) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -pikeos*) # Until real need of OS specific support for # particular features comes up, bare metal # configurations are quite functional. case $basic_machine in arm*) os=-eabi ;; *) os=-elf ;; esac ;; -nacl*) ;; -ios) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`"$1"\': system \`"$os"\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; c8051-*) os=-elf ;; hexagon-*) os=-elf ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; pru-*) os=-elf ;; *-be) os=-beos ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo "$basic_machine" | sed "s/unknown/$vendor/"` ;; esac echo "$basic_machine$os" exit # Local variables: # eval: (add-hook 'write-file-functions 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: uim-1.8.8/sigscheme/Makefile.am0000644000175000017500000000212013274722224013246 00000000000000ACLOCAL_AMFLAGS = -I m4 SUBDIRS = doc m4 tools if USE_LIBGCROOTS_BUNDLED SUBDIRS += libgcroots endif SUBDIRS += include src lib test test-c bench # To make 'make distclean' workable on --with-libgcroots=tiny-subdir, # libgcroots must be eliminated from $DIST_SUBDIRS. DIST_SUBDIRS = $(SUBDIRS) # $(distdir) does work as a part of $(RELEASE_URL) when configured as a # subpackage. DIST_NAME = $(PACKAGE)-$(VERSION) #RELEASE_TAG = master RELEASE_TAG = $(DIST_NAME) DIST_SUM_LIST = $(DIST_NAME).sum EXTRA_DIST = \ sigscheme.pc.in libgcroots.mk.in sigscheme.mk.in autogen.sh \ RELNOTE TODO QALog \ compare-scm.sh runbench.sh runtest.sh runtest-tail-rec.sh \ make-report.sh make-dist.sh if USE_LIBSSCM pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = sigscheme.pc endif $(pkgconfig_DATA): config.status DISTCLEANFILES = sigscheme.pc $(DIST_SUM_LIST) .PHONY: FORCE sum FORCE: sum: FORCE $(MD5) $(DIST_ARCHIVES) >$(DIST_SUM_LIST) $(SHA1) $(DIST_ARCHIVES) >>$(DIST_SUM_LIST) tag: git tag -a -m "$(VERSION) has been released!!!" $(VERSION) git push --tags uim-1.8.8/sigscheme/compile0000755000175000017500000001624513275405265012611 00000000000000#! /bin/sh # Wrapper for compilers which do not understand '-c -o'. scriptversion=2012-10-14.11; # UTC # Copyright (C) 1999-2014 Free Software Foundation, Inc. # Written by Tom Tromey . # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to or send patches to # . nl=' ' # We need space, tab and new line, in precisely that order. Quoting is # there to prevent tools from complaining about whitespace usage. IFS=" "" $nl" file_conv= # func_file_conv build_file lazy # Convert a $build file to $host form and store it in $file # Currently only supports Windows hosts. If the determined conversion # type is listed in (the comma separated) LAZY, no conversion will # take place. func_file_conv () { file=$1 case $file in / | /[!/]*) # absolute file, and not a UNC file if test -z "$file_conv"; then # lazily determine how to convert abs files case `uname -s` in MINGW*) file_conv=mingw ;; CYGWIN*) file_conv=cygwin ;; *) file_conv=wine ;; esac fi case $file_conv/,$2, in *,$file_conv,*) ;; mingw/*) file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` ;; cygwin/*) file=`cygpath -m "$file" || echo "$file"` ;; wine/*) file=`winepath -w "$file" || echo "$file"` ;; esac ;; esac } # func_cl_dashL linkdir # Make cl look for libraries in LINKDIR func_cl_dashL () { func_file_conv "$1" if test -z "$lib_path"; then lib_path=$file else lib_path="$lib_path;$file" fi linker_opts="$linker_opts -LIBPATH:$file" } # func_cl_dashl library # Do a library search-path lookup for cl func_cl_dashl () { lib=$1 found=no save_IFS=$IFS IFS=';' for dir in $lib_path $LIB do IFS=$save_IFS if $shared && test -f "$dir/$lib.dll.lib"; then found=yes lib=$dir/$lib.dll.lib break fi if test -f "$dir/$lib.lib"; then found=yes lib=$dir/$lib.lib break fi if test -f "$dir/lib$lib.a"; then found=yes lib=$dir/lib$lib.a break fi done IFS=$save_IFS if test "$found" != yes; then lib=$lib.lib fi } # func_cl_wrapper cl arg... # Adjust compile command to suit cl func_cl_wrapper () { # Assume a capable shell lib_path= shared=: linker_opts= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. eat=1 case $2 in *.o | *.[oO][bB][jJ]) func_file_conv "$2" set x "$@" -Fo"$file" shift ;; *) func_file_conv "$2" set x "$@" -Fe"$file" shift ;; esac ;; -I) eat=1 func_file_conv "$2" mingw set x "$@" -I"$file" shift ;; -I*) func_file_conv "${1#-I}" mingw set x "$@" -I"$file" shift ;; -l) eat=1 func_cl_dashl "$2" set x "$@" "$lib" shift ;; -l*) func_cl_dashl "${1#-l}" set x "$@" "$lib" shift ;; -L) eat=1 func_cl_dashL "$2" ;; -L*) func_cl_dashL "${1#-L}" ;; -static) shared=false ;; -Wl,*) arg=${1#-Wl,} save_ifs="$IFS"; IFS=',' for flag in $arg; do IFS="$save_ifs" linker_opts="$linker_opts $flag" done IFS="$save_ifs" ;; -Xlinker) eat=1 linker_opts="$linker_opts $2" ;; -*) set x "$@" "$1" shift ;; *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) func_file_conv "$1" set x "$@" -Tp"$file" shift ;; *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) func_file_conv "$1" mingw set x "$@" "$file" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -n "$linker_opts"; then linker_opts="-link$linker_opts" fi exec "$@" $linker_opts exit 1 } eat= case $1 in '') echo "$0: No command. Try '$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: compile [--help] [--version] PROGRAM [ARGS] Wrapper for compilers which do not understand '-c -o'. Remove '-o dest.o' from ARGS, run PROGRAM with the remaining arguments, and rename the output as expected. If you are trying to build a whole package this is not the right script to run: please start by reading the file 'INSTALL'. Report bugs to . EOF exit $? ;; -v | --v*) echo "compile $scriptversion" exit $? ;; cl | *[/\\]cl | cl.exe | *[/\\]cl.exe ) func_cl_wrapper "$@" # Doesn't return... ;; esac ofile= cfile= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as 'compile cc -o foo foo.c'. # So we strip '-o arg' only if arg is an object. eat=1 case $2 in *.o | *.obj) ofile=$2 ;; *) set x "$@" -o "$2" shift ;; esac ;; *.c) cfile=$1 set x "$@" "$1" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -z "$ofile" || test -z "$cfile"; then # If no '-o' option was seen then we might have been invoked from a # pattern rule where we don't need one. That is ok -- this is a # normal compilation that the losing compiler can handle. If no # '.c' file was seen then we are probably linking. That is also # ok. exec "$@" fi # Name of file we expect compiler to create. cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'` # Create the lock directory. # Note: use '[/\\:.-]' here to ensure that we don't use the same name # that we are using for the .o file. Also, base the name on the expected # object file name, since that is what matters with a parallel build. lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d while true; do if mkdir "$lockdir" >/dev/null 2>&1; then break fi sleep 1 done # FIXME: race condition here if user kills between mkdir and trap. trap "rmdir '$lockdir'; exit 1" 1 2 15 # Run the compile. "$@" ret=$? if test -f "$cofile"; then test "$cofile" = "$ofile" || mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: uim-1.8.8/sigscheme/COPYING0000644000175000017500000003060512532333147012254 00000000000000------------------------------------------------------------------------------ Copyright (C) 2005,2006 Kazuki Ohta 2005,2006 Jun Inoue 2005,2006 YAMAMOTO Kengo 2007-2008 SigScheme Project All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ------------------------------------------------------------------------------ Supplementary explanation (only for help and not legal): You may use, reuse, modify, distribute and/or sell material contained in this package, except for those files or directories that contain a notice that a different license applies. Such exceptional material must be distributed under the terms of the license specified therein. Each file indicates its copyright holder in its header. libgcroots is covered by: ----------------------------------------------------------------------------- Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. Copyright (c) 1999-2001 by Hewlett-Packard. All rights reserved. Copyright (c) 2006-2007 YAMAMOTO Kengo All rights reserved. THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. Permission is hereby granted to use or copy this program for any purpose, provided the above notices are retained on all copies. Permission to modify the code and to distribute modified code is granted, provided the above notices are retained, and a notice that the code was modified is included with the above copyright notice. ----------------------------------------------------------------------------- lib/srfi-1.scm is covered by: ----------------------------------------------------------------------------- ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with ;;; this code as long as you do not remove this copyright notice or ;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;;; -Olin ;;; Copyright (c) 2007-2008 SigScheme Project ----------------------------------------------------------------------------- lib/srfi-9.scm is covered by: ----------------------------------------------------------------------------- Copyright (C) Richard Kelsey (1999). All Rights Reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ----------------------------------------------------------------------------- lib/srfi-43.scm is covered by: ----------------------------------------------------------------------------- ;;; Taylor Campbell wrote this code; he places it in the public domain. ----------------------------------------------------------------------------- lib/srfi-69.scm is covered by: ----------------------------------------------------------------------------- Copyright (C) Panu Kalliokoski (2005). All Rights Reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ----------------------------------------------------------------------------- lib/srfi-95.scm is covered by: ----------------------------------------------------------------------------- ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) ;;; ;;; This code is in the public domain. ----------------------------------------------------------------------------- test/gauche-*.scm and some part of src/read.c and src/list.c are covered by: ----------------------------------------------------------------------------- Copyright (c) 2000-2004 Shiro Kawai, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- test/bigloo-*.scm are licensed under GPL2: --------------------------------------------------------------------- A practical implementation for the Scheme programming language ,--^, _ ___/ /|/ ,;'( )__, ) ' ;; // L__. ' \\ / ' ^ ^ Copyright (c) 1992-2004 Manuel Serrano Bug descriptions, use reports, comments or suggestions are welcome. Send them to bigloo@sophia.inria.fr http://www.inria.fr/mimosa/fp/Bigloo This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. More precisely, - The compiler and the tools are distributed under the terms of the GNU General Public License. - The Bigloo run-time system and the libraries are distributed under the terms of the GNU Library General Public License. The source code of the Bigloo runtime system is located in the ./runtime directory. The source code of the FairThreads library is located in the ./fthread directory. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --------------------------------------------------------------------- test/scm-r4rstest.scm is licensed under GPL2: ----------------------------------------------------------------------------- ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by the ;; Free Software Foundation; either version 2, or (at your option) any ;; later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; To receive a copy of the GNU General Public License, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA; or view ;; http://swiss.csail.mit.edu/~jaffer/GPL.html ----------------------------------------------------------------------------- test/oleg-srfi2.scm is covered by: ----------------------------------------------------------------------------- ;; License terms: ;; ;; http://pobox.com/~oleg/ftp/ ;; ;; "Unless specified otherwise, all the code and the documentation on this site ;; is in public domain." ----------------------------------------------------------------------------- uim-1.8.8/sigscheme/missing0000755000175000017500000001533013275405265012624 00000000000000#! /bin/sh # Common wrapper for a few potentially missing GNU programs. scriptversion=2013-10-28.13; # UTC # Copyright (C) 1996-2014 Free Software Foundation, Inc. # Originally written by Fran,cois Pinard , 1996. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. if test $# -eq 0; then echo 1>&2 "Try '$0 --help' for more information" exit 1 fi case $1 in --is-lightweight) # Used by our autoconf macros to check whether the available missing # script is modern enough. exit 0 ;; --run) # Back-compat with the calling convention used by older automake. shift ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due to PROGRAM being missing or too old. Options: -h, --help display this help and exit -v, --version output version information and exit Supported PROGRAM values: aclocal autoconf autoheader autom4te automake makeinfo bison yacc flex lex help2man Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and 'g' are ignored when checking the name. Send bug reports to ." exit $? ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing $scriptversion (GNU Automake)" exit $? ;; -*) echo 1>&2 "$0: unknown '$1' option" echo 1>&2 "Try '$0 --help' for more information" exit 1 ;; esac # Run the given program, remember its exit status. "$@"; st=$? # If it succeeded, we are done. test $st -eq 0 && exit 0 # Also exit now if we it failed (or wasn't found), and '--version' was # passed; such an option is passed most likely to detect whether the # program is present and works. case $2 in --version|--help) exit $st;; esac # Exit code 63 means version mismatch. This often happens when the user # tries to use an ancient version of a tool on a file that requires a # minimum version. if test $st -eq 63; then msg="probably too old" elif test $st -eq 127; then # Program was missing. msg="missing on your system" else # Program was found and executed, but failed. Give up. exit $st fi perl_URL=http://www.perl.org/ flex_URL=http://flex.sourceforge.net/ gnu_software_URL=http://www.gnu.org/software program_details () { case $1 in aclocal|automake) echo "The '$1' program is part of the GNU Automake package:" echo "<$gnu_software_URL/automake>" echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/autoconf>" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; autoconf|autom4te|autoheader) echo "The '$1' program is part of the GNU Autoconf package:" echo "<$gnu_software_URL/autoconf/>" echo "It also requires GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; esac } give_advice () { # Normalize program name to check for. normalized_program=`echo "$1" | sed ' s/^gnu-//; t s/^gnu//; t s/^g//; t'` printf '%s\n' "'$1' is $msg." configure_deps="'configure.ac' or m4 files included by 'configure.ac'" case $normalized_program in autoconf*) echo "You should only need it if you modified 'configure.ac'," echo "or m4 files included by it." program_details 'autoconf' ;; autoheader*) echo "You should only need it if you modified 'acconfig.h' or" echo "$configure_deps." program_details 'autoheader' ;; automake*) echo "You should only need it if you modified 'Makefile.am' or" echo "$configure_deps." program_details 'automake' ;; aclocal*) echo "You should only need it if you modified 'acinclude.m4' or" echo "$configure_deps." program_details 'aclocal' ;; autom4te*) echo "You might have modified some maintainer files that require" echo "the 'autom4te' program to be rebuilt." program_details 'autom4te' ;; bison*|yacc*) echo "You should only need it if you modified a '.y' file." echo "You may want to install the GNU Bison package:" echo "<$gnu_software_URL/bison/>" ;; lex*|flex*) echo "You should only need it if you modified a '.l' file." echo "You may want to install the Fast Lexical Analyzer package:" echo "<$flex_URL>" ;; help2man*) echo "You should only need it if you modified a dependency" \ "of a man page." echo "You may want to install the GNU Help2man package:" echo "<$gnu_software_URL/help2man/>" ;; makeinfo*) echo "You should only need it if you modified a '.texi' file, or" echo "any other file indirectly affecting the aspect of the manual." echo "You might want to install the Texinfo package:" echo "<$gnu_software_URL/texinfo/>" echo "The spurious makeinfo call might also be the consequence of" echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might" echo "want to install GNU make:" echo "<$gnu_software_URL/make/>" ;; *) echo "You might have modified some files without having the proper" echo "tools for further handling them. Check the 'README' file, it" echo "often tells you about the needed prerequisites for installing" echo "this package. You may also peek at any GNU archive site, in" echo "case some other package contains this missing '$1' program." ;; esac } give_advice "$1" | sed -e '1s/^/WARNING: /' \ -e '2,$s/^/ /' >&2 # Propagate the correct exit status (expected to be 127 for a program # not found, 63 for a program that failed due to version mismatch). exit $st # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: uim-1.8.8/sigscheme/bench/0000755000175000017500000000000013275405526012362 500000000000000uim-1.8.8/sigscheme/bench/bench-cpstak.scm0000644000175000017500000000202112532333147015335 00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; File: cpstak.sch ; Description: continuation-passing version of TAK ; Author: Will Clinger ; Created: 20-Aug-87 ; Language: Scheme ; Status: Public Domain ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CPSTAK -- A continuation-passing version of the TAK benchmark. ;;; A good test of first class procedures and tail recursion. (define (cpstak x y z) (define (tak x y z k) (if (not (< y x)) (k z) (tak (- x 1) y z (lambda (v1) (tak (- y 1) z x (lambda (v2) (tak (- z 1) x y (lambda (v3) (tak v1 v2 v3 k))))))))) (tak x y z (lambda (a) a))) (cpstak 18 12 6) ;;; (run-benchmark "CPSTAK" (lambda () (cpstak 18 12 6))) uim-1.8.8/sigscheme/bench/Makefile.am0000644000175000017500000000044612532333147014334 00000000000000EXTRA_DIST = \ bench-arithint.scm \ bench-case.scm \ bench-cpstak.scm \ bench-fib.scm \ bench-let-loop.scm \ bench-loop.scm \ bench-mem.scm \ bench-rec.scm \ bench-tak.scm \ bench-takl.scm \ bench-takr.scm uim-1.8.8/sigscheme/bench/bench-takr.scm0000644000175000017500000004076112532333147015026 00000000000000(define (tak0 x y z) (cond ((not (< y x)) z) (else (tak1 (tak37 (- x 1) y z) (tak11 (- y 1) z x) (tak17 (- z 1) x y))))) (define (tak1 x y z) (cond ((not (< y x)) z) (else (tak2 (tak74 (- x 1) y z) (tak22 (- y 1) z x) (tak34 (- z 1) x y))))) (define (tak2 x y z) (cond ((not (< y x)) z) (else (tak3 (tak11 (- x 1) y z) (tak33 (- y 1) z x) (tak51 (- z 1) x y))))) (define (tak3 x y z) (cond ((not (< y x)) z) (else (tak4 (tak48 (- x 1) y z) (tak44 (- y 1) z x) (tak68 (- z 1) x y))))) (define (tak4 x y z) (cond ((not (< y x)) z) (else (tak5 (tak85 (- x 1) y z) (tak55 (- y 1) z x) (tak85 (- z 1) x y))))) (define (tak5 x y z) (cond ((not (< y x)) z) (else (tak6 (tak22 (- x 1) y z) (tak66 (- y 1) z x) (tak2 (- z 1) x y))))) (define (tak6 x y z) (cond ((not (< y x)) z) (else (tak7 (tak59 (- x 1) y z) (tak77 (- y 1) z x) (tak19 (- z 1) x y))))) (define (tak7 x y z) (cond ((not (< y x)) z) (else (tak8 (tak96 (- x 1) y z) (tak88 (- y 1) z x) (tak36 (- z 1) x y))))) (define (tak8 x y z) (cond ((not (< y x)) z) (else (tak9 (tak33 (- x 1) y z) (tak99 (- y 1) z x) (tak53 (- z 1) x y))))) (define (tak9 x y z) (cond ((not (< y x)) z) (else (tak10 (tak70 (- x 1) y z) (tak10 (- y 1) z x) (tak70 (- z 1) x y))))) (define (tak10 x y z) (cond ((not (< y x)) z) (else (tak11 (tak7 (- x 1) y z) (tak21 (- y 1) z x) (tak87 (- z 1) x y))))) (define (tak11 x y z) (cond ((not (< y x)) z) (else (tak12 (tak44 (- x 1) y z) (tak32 (- y 1) z x) (tak4 (- z 1) x y))))) (define (tak12 x y z) (cond ((not (< y x)) z) (else (tak13 (tak81 (- x 1) y z) (tak43 (- y 1) z x) (tak21 (- z 1) x y))))) (define (tak13 x y z) (cond ((not (< y x)) z) (else (tak14 (tak18 (- x 1) y z) (tak54 (- y 1) z x) (tak38 (- z 1) x y))))) (define (tak14 x y z) (cond ((not (< y x)) z) (else (tak15 (tak55 (- x 1) y z) (tak65 (- y 1) z x) (tak55 (- z 1) x y))))) (define (tak15 x y z) (cond ((not (< y x)) z) (else (tak16 (tak92 (- x 1) y z) (tak76 (- y 1) z x) (tak72 (- z 1) x y))))) (define (tak16 x y z) (cond ((not (< y x)) z) (else (tak17 (tak29 (- x 1) y z) (tak87 (- y 1) z x) (tak89 (- z 1) x y))))) (define (tak17 x y z) (cond ((not (< y x)) z) (else (tak18 (tak66 (- x 1) y z) (tak98 (- y 1) z x) (tak6 (- z 1) x y))))) (define (tak18 x y z) (cond ((not (< y x)) z) (else (tak19 (tak3 (- x 1) y z) (tak9 (- y 1) z x) (tak23 (- z 1) x y))))) (define (tak19 x y z) (cond ((not (< y x)) z) (else (tak20 (tak40 (- x 1) y z) (tak20 (- y 1) z x) (tak40 (- z 1) x y))))) (define (tak20 x y z) (cond ((not (< y x)) z) (else (tak21 (tak77 (- x 1) y z) (tak31 (- y 1) z x) (tak57 (- z 1) x y))))) (define (tak21 x y z) (cond ((not (< y x)) z) (else (tak22 (tak14 (- x 1) y z) (tak42 (- y 1) z x) (tak74 (- z 1) x y))))) (define (tak22 x y z) (cond ((not (< y x)) z) (else (tak23 (tak51 (- x 1) y z) (tak53 (- y 1) z x) (tak91 (- z 1) x y))))) (define (tak23 x y z) (cond ((not (< y x)) z) (else (tak24 (tak88 (- x 1) y z) (tak64 (- y 1) z x) (tak8 (- z 1) x y))))) (define (tak24 x y z) (cond ((not (< y x)) z) (else (tak25 (tak25 (- x 1) y z) (tak75 (- y 1) z x) (tak25 (- z 1) x y))))) (define (tak25 x y z) (cond ((not (< y x)) z) (else (tak26 (tak62 (- x 1) y z) (tak86 (- y 1) z x) (tak42 (- z 1) x y))))) (define (tak26 x y z) (cond ((not (< y x)) z) (else (tak27 (tak99 (- x 1) y z) (tak97 (- y 1) z x) (tak59 (- z 1) x y))))) (define (tak27 x y z) (cond ((not (< y x)) z) (else (tak28 (tak36 (- x 1) y z) (tak8 (- y 1) z x) (tak76 (- z 1) x y))))) (define (tak28 x y z) (cond ((not (< y x)) z) (else (tak29 (tak73 (- x 1) y z) (tak19 (- y 1) z x) (tak93 (- z 1) x y))))) (define (tak29 x y z) (cond ((not (< y x)) z) (else (tak30 (tak10 (- x 1) y z) (tak30 (- y 1) z x) (tak10 (- z 1) x y))))) (define (tak30 x y z) (cond ((not (< y x)) z) (else (tak31 (tak47 (- x 1) y z) (tak41 (- y 1) z x) (tak27 (- z 1) x y))))) (define (tak31 x y z) (cond ((not (< y x)) z) (else (tak32 (tak84 (- x 1) y z) (tak52 (- y 1) z x) (tak44 (- z 1) x y))))) (define (tak32 x y z) (cond ((not (< y x)) z) (else (tak33 (tak21 (- x 1) y z) (tak63 (- y 1) z x) (tak61 (- z 1) x y))))) (define (tak33 x y z) (cond ((not (< y x)) z) (else (tak34 (tak58 (- x 1) y z) (tak74 (- y 1) z x) (tak78 (- z 1) x y))))) (define (tak34 x y z) (cond ((not (< y x)) z) (else (tak35 (tak95 (- x 1) y z) (tak85 (- y 1) z x) (tak95 (- z 1) x y))))) (define (tak35 x y z) (cond ((not (< y x)) z) (else (tak36 (tak32 (- x 1) y z) (tak96 (- y 1) z x) (tak12 (- z 1) x y))))) (define (tak36 x y z) (cond ((not (< y x)) z) (else (tak37 (tak69 (- x 1) y z) (tak7 (- y 1) z x) (tak29 (- z 1) x y))))) (define (tak37 x y z) (cond ((not (< y x)) z) (else (tak38 (tak6 (- x 1) y z) (tak18 (- y 1) z x) (tak46 (- z 1) x y))))) (define (tak38 x y z) (cond ((not (< y x)) z) (else (tak39 (tak43 (- x 1) y z) (tak29 (- y 1) z x) (tak63 (- z 1) x y))))) (define (tak39 x y z) (cond ((not (< y x)) z) (else (tak40 (tak80 (- x 1) y z) (tak40 (- y 1) z x) (tak80 (- z 1) x y))))) (define (tak40 x y z) (cond ((not (< y x)) z) (else (tak41 (tak17 (- x 1) y z) (tak51 (- y 1) z x) (tak97 (- z 1) x y))))) (define (tak41 x y z) (cond ((not (< y x)) z) (else (tak42 (tak54 (- x 1) y z) (tak62 (- y 1) z x) (tak14 (- z 1) x y))))) (define (tak42 x y z) (cond ((not (< y x)) z) (else (tak43 (tak91 (- x 1) y z) (tak73 (- y 1) z x) (tak31 (- z 1) x y))))) (define (tak43 x y z) (cond ((not (< y x)) z) (else (tak44 (tak28 (- x 1) y z) (tak84 (- y 1) z x) (tak48 (- z 1) x y))))) (define (tak44 x y z) (cond ((not (< y x)) z) (else (tak45 (tak65 (- x 1) y z) (tak95 (- y 1) z x) (tak65 (- z 1) x y))))) (define (tak45 x y z) (cond ((not (< y x)) z) (else (tak46 (tak2 (- x 1) y z) (tak6 (- y 1) z x) (tak82 (- z 1) x y))))) (define (tak46 x y z) (cond ((not (< y x)) z) (else (tak47 (tak39 (- x 1) y z) (tak17 (- y 1) z x) (tak99 (- z 1) x y))))) (define (tak47 x y z) (cond ((not (< y x)) z) (else (tak48 (tak76 (- x 1) y z) (tak28 (- y 1) z x) (tak16 (- z 1) x y))))) (define (tak48 x y z) (cond ((not (< y x)) z) (else (tak49 (tak13 (- x 1) y z) (tak39 (- y 1) z x) (tak33 (- z 1) x y))))) (define (tak49 x y z) (cond ((not (< y x)) z) (else (tak50 (tak50 (- x 1) y z) (tak50 (- y 1) z x) (tak50 (- z 1) x y))))) (define (tak50 x y z) (cond ((not (< y x)) z) (else (tak51 (tak87 (- x 1) y z) (tak61 (- y 1) z x) (tak67 (- z 1) x y))))) (define (tak51 x y z) (cond ((not (< y x)) z) (else (tak52 (tak24 (- x 1) y z) (tak72 (- y 1) z x) (tak84 (- z 1) x y))))) (define (tak52 x y z) (cond ((not (< y x)) z) (else (tak53 (tak61 (- x 1) y z) (tak83 (- y 1) z x) (tak1 (- z 1) x y))))) (define (tak53 x y z) (cond ((not (< y x)) z) (else (tak54 (tak98 (- x 1) y z) (tak94 (- y 1) z x) (tak18 (- z 1) x y))))) (define (tak54 x y z) (cond ((not (< y x)) z) (else (tak55 (tak35 (- x 1) y z) (tak5 (- y 1) z x) (tak35 (- z 1) x y))))) (define (tak55 x y z) (cond ((not (< y x)) z) (else (tak56 (tak72 (- x 1) y z) (tak16 (- y 1) z x) (tak52 (- z 1) x y))))) (define (tak56 x y z) (cond ((not (< y x)) z) (else (tak57 (tak9 (- x 1) y z) (tak27 (- y 1) z x) (tak69 (- z 1) x y))))) (define (tak57 x y z) (cond ((not (< y x)) z) (else (tak58 (tak46 (- x 1) y z) (tak38 (- y 1) z x) (tak86 (- z 1) x y))))) (define (tak58 x y z) (cond ((not (< y x)) z) (else (tak59 (tak83 (- x 1) y z) (tak49 (- y 1) z x) (tak3 (- z 1) x y))))) (define (tak59 x y z) (cond ((not (< y x)) z) (else (tak60 (tak20 (- x 1) y z) (tak60 (- y 1) z x) (tak20 (- z 1) x y))))) (define (tak60 x y z) (cond ((not (< y x)) z) (else (tak61 (tak57 (- x 1) y z) (tak71 (- y 1) z x) (tak37 (- z 1) x y))))) (define (tak61 x y z) (cond ((not (< y x)) z) (else (tak62 (tak94 (- x 1) y z) (tak82 (- y 1) z x) (tak54 (- z 1) x y))))) (define (tak62 x y z) (cond ((not (< y x)) z) (else (tak63 (tak31 (- x 1) y z) (tak93 (- y 1) z x) (tak71 (- z 1) x y))))) (define (tak63 x y z) (cond ((not (< y x)) z) (else (tak64 (tak68 (- x 1) y z) (tak4 (- y 1) z x) (tak88 (- z 1) x y))))) (define (tak64 x y z) (cond ((not (< y x)) z) (else (tak65 (tak5 (- x 1) y z) (tak15 (- y 1) z x) (tak5 (- z 1) x y))))) (define (tak65 x y z) (cond ((not (< y x)) z) (else (tak66 (tak42 (- x 1) y z) (tak26 (- y 1) z x) (tak22 (- z 1) x y))))) (define (tak66 x y z) (cond ((not (< y x)) z) (else (tak67 (tak79 (- x 1) y z) (tak37 (- y 1) z x) (tak39 (- z 1) x y))))) (define (tak67 x y z) (cond ((not (< y x)) z) (else (tak68 (tak16 (- x 1) y z) (tak48 (- y 1) z x) (tak56 (- z 1) x y))))) (define (tak68 x y z) (cond ((not (< y x)) z) (else (tak69 (tak53 (- x 1) y z) (tak59 (- y 1) z x) (tak73 (- z 1) x y))))) (define (tak69 x y z) (cond ((not (< y x)) z) (else (tak70 (tak90 (- x 1) y z) (tak70 (- y 1) z x) (tak90 (- z 1) x y))))) (define (tak70 x y z) (cond ((not (< y x)) z) (else (tak71 (tak27 (- x 1) y z) (tak81 (- y 1) z x) (tak7 (- z 1) x y))))) (define (tak71 x y z) (cond ((not (< y x)) z) (else (tak72 (tak64 (- x 1) y z) (tak92 (- y 1) z x) (tak24 (- z 1) x y))))) (define (tak72 x y z) (cond ((not (< y x)) z) (else (tak73 (tak1 (- x 1) y z) (tak3 (- y 1) z x) (tak41 (- z 1) x y))))) (define (tak73 x y z) (cond ((not (< y x)) z) (else (tak74 (tak38 (- x 1) y z) (tak14 (- y 1) z x) (tak58 (- z 1) x y))))) (define (tak74 x y z) (cond ((not (< y x)) z) (else (tak75 (tak75 (- x 1) y z) (tak25 (- y 1) z x) (tak75 (- z 1) x y))))) (define (tak75 x y z) (cond ((not (< y x)) z) (else (tak76 (tak12 (- x 1) y z) (tak36 (- y 1) z x) (tak92 (- z 1) x y))))) (define (tak76 x y z) (cond ((not (< y x)) z) (else (tak77 (tak49 (- x 1) y z) (tak47 (- y 1) z x) (tak9 (- z 1) x y))))) (define (tak77 x y z) (cond ((not (< y x)) z) (else (tak78 (tak86 (- x 1) y z) (tak58 (- y 1) z x) (tak26 (- z 1) x y))))) (define (tak78 x y z) (cond ((not (< y x)) z) (else (tak79 (tak23 (- x 1) y z) (tak69 (- y 1) z x) (tak43 (- z 1) x y))))) (define (tak79 x y z) (cond ((not (< y x)) z) (else (tak80 (tak60 (- x 1) y z) (tak80 (- y 1) z x) (tak60 (- z 1) x y))))) (define (tak80 x y z) (cond ((not (< y x)) z) (else (tak81 (tak97 (- x 1) y z) (tak91 (- y 1) z x) (tak77 (- z 1) x y))))) (define (tak81 x y z) (cond ((not (< y x)) z) (else (tak82 (tak34 (- x 1) y z) (tak2 (- y 1) z x) (tak94 (- z 1) x y))))) (define (tak82 x y z) (cond ((not (< y x)) z) (else (tak83 (tak71 (- x 1) y z) (tak13 (- y 1) z x) (tak11 (- z 1) x y))))) (define (tak83 x y z) (cond ((not (< y x)) z) (else (tak84 (tak8 (- x 1) y z) (tak24 (- y 1) z x) (tak28 (- z 1) x y))))) (define (tak84 x y z) (cond ((not (< y x)) z) (else (tak85 (tak45 (- x 1) y z) (tak35 (- y 1) z x) (tak45 (- z 1) x y))))) (define (tak85 x y z) (cond ((not (< y x)) z) (else (tak86 (tak82 (- x 1) y z) (tak46 (- y 1) z x) (tak62 (- z 1) x y))))) (define (tak86 x y z) (cond ((not (< y x)) z) (else (tak87 (tak19 (- x 1) y z) (tak57 (- y 1) z x) (tak79 (- z 1) x y))))) (define (tak87 x y z) (cond ((not (< y x)) z) (else (tak88 (tak56 (- x 1) y z) (tak68 (- y 1) z x) (tak96 (- z 1) x y))))) (define (tak88 x y z) (cond ((not (< y x)) z) (else (tak89 (tak93 (- x 1) y z) (tak79 (- y 1) z x) (tak13 (- z 1) x y))))) (define (tak89 x y z) (cond ((not (< y x)) z) (else (tak90 (tak30 (- x 1) y z) (tak90 (- y 1) z x) (tak30 (- z 1) x y))))) (define (tak90 x y z) (cond ((not (< y x)) z) (else (tak91 (tak67 (- x 1) y z) (tak1 (- y 1) z x) (tak47 (- z 1) x y))))) (define (tak91 x y z) (cond ((not (< y x)) z) (else (tak92 (tak4 (- x 1) y z) (tak12 (- y 1) z x) (tak64 (- z 1) x y))))) (define (tak92 x y z) (cond ((not (< y x)) z) (else (tak93 (tak41 (- x 1) y z) (tak23 (- y 1) z x) (tak81 (- z 1) x y))))) (define (tak93 x y z) (cond ((not (< y x)) z) (else (tak94 (tak78 (- x 1) y z) (tak34 (- y 1) z x) (tak98 (- z 1) x y))))) (define (tak94 x y z) (cond ((not (< y x)) z) (else (tak95 (tak15 (- x 1) y z) (tak45 (- y 1) z x) (tak15 (- z 1) x y))))) (define (tak95 x y z) (cond ((not (< y x)) z) (else (tak96 (tak52 (- x 1) y z) (tak56 (- y 1) z x) (tak32 (- z 1) x y))))) (define (tak96 x y z) (cond ((not (< y x)) z) (else (tak97 (tak89 (- x 1) y z) (tak67 (- y 1) z x) (tak49 (- z 1) x y))))) (define (tak97 x y z) (cond ((not (< y x)) z) (else (tak98 (tak26 (- x 1) y z) (tak78 (- y 1) z x) (tak66 (- z 1) x y))))) (define (tak98 x y z) (cond ((not (< y x)) z) (else (tak99 (tak63 (- x 1) y z) (tak89 (- y 1) z x) (tak83 (- z 1) x y))))) (define (tak99 x y z) (cond ((not (< y x)) z) (else (tak0 (tak0 (- x 1) y z) (tak0 (- y 1) z x) (tak0 (- z 1) x y))))) ;;; call: (tak0 18 12 6) (tak0 18 12 6) uim-1.8.8/sigscheme/bench/Makefile.in0000644000175000017500000003542113275405265014354 00000000000000# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = bench ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_c___attribute__.m4 \ $(top_srcdir)/m4/ax_c_arithmetic_rshift.m4 \ $(top_srcdir)/m4/ax_c_referenceable_passed_va_list.m4 \ $(top_srcdir)/m4/ax_cflags_gcc_option.m4 \ $(top_srcdir)/m4/ax_check_page_aligned_malloc.m4 \ $(top_srcdir)/m4/ax_create_stdint_h.m4 \ $(top_srcdir)/m4/ax_feature_configurator.m4 \ $(top_srcdir)/m4/ax_func_getcontext.m4 \ $(top_srcdir)/m4/ax_func_sigsetjmp.m4 \ $(top_srcdir)/m4/ax_lib_glibc.m4 \ $(top_srcdir)/m4/check_gnu_make.m4 $(top_srcdir)/m4/libtool.m4 \ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/src/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = SOURCES = DIST_SOURCES = am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ ASCIIDOC = @ASCIIDOC@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ FGREP = @FGREP@ GCROOTS_CFLAGS = @GCROOTS_CFLAGS@ GCROOTS_LIBS = @GCROOTS_LIBS@ GCROOTS_REQ = @GCROOTS_REQ@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MD5 = @MD5@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PERL = @PERL@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ RANLIB = @RANLIB@ RUBY = @RUBY@ SED = @SED@ SET_MAKE = @SET_MAKE@ SH = @SH@ SHA1 = @SHA1@ SHELL = @SHELL@ SSCM_DEFS = @SSCM_DEFS@ SSCM_MASTER_PKG = @SSCM_MASTER_PKG@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ ifGNUmake = @ifGNUmake@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ scmlibdir = @scmlibdir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ use_backtrace = @use_backtrace@ use_char = @use_char@ use_compat_siod = @use_compat_siod@ use_compat_siod_bugs = @use_compat_siod_bugs@ use_const_list_literal = @use_const_list_literal@ use_const_vector_literal = @use_const_vector_literal@ use_continuation = @use_continuation@ use_debug = @use_debug@ use_deep_cadrs = @use_deep_cadrs@ use_default_encoding = @use_default_encoding@ use_euccn = @use_euccn@ use_eucjp = @use_eucjp@ use_euckr = @use_euckr@ use_eval_c_string = @use_eval_c_string@ use_fixnum = @use_fixnum@ use_hygienic_macro = @use_hygienic_macro@ use_int = @use_int@ use_internal_definitions = @use_internal_definitions@ use_legacy_macro = @use_legacy_macro@ use_load = @use_load@ use_multibyte_char = @use_multibyte_char@ use_number_io = @use_number_io@ use_port = @use_port@ use_promise = @use_promise@ use_quasiquote = @use_quasiquote@ use_r6rs_chars = @use_r6rs_chars@ use_r6rs_named_chars = @use_r6rs_named_chars@ use_reader = @use_reader@ use_sjis = @use_sjis@ use_srfi0 = @use_srfi0@ use_srfi1 = @use_srfi1@ use_srfi2 = @use_srfi2@ use_srfi22 = @use_srfi22@ use_srfi23 = @use_srfi23@ use_srfi28 = @use_srfi28@ use_srfi34 = @use_srfi34@ use_srfi38 = @use_srfi38@ use_srfi43 = @use_srfi43@ use_srfi48 = @use_srfi48@ use_srfi55 = @use_srfi55@ use_srfi6 = @use_srfi6@ use_srfi60 = @use_srfi60@ use_srfi69 = @use_srfi69@ use_srfi8 = @use_srfi8@ use_srfi9 = @use_srfi9@ use_srfi95 = @use_srfi95@ use_sscm_extensions = @use_sscm_extensions@ use_sscm_format_extension = @use_sscm_format_extension@ use_storage = @use_storage@ use_strict_argcheck = @use_strict_argcheck@ use_strict_null_form = @use_strict_null_form@ use_strict_r5rs = @use_strict_r5rs@ use_strict_toplevel_definitions = @use_strict_toplevel_definitions@ use_strict_vector_form = @use_strict_vector_form@ use_string = @use_string@ use_string_procedure = @use_string_procedure@ use_utf8 = @use_utf8@ use_vector = @use_vector@ use_writer = @use_writer@ EXTRA_DIST = \ bench-arithint.scm \ bench-case.scm \ bench-cpstak.scm \ bench-fib.scm \ bench-let-loop.scm \ bench-loop.scm \ bench-mem.scm \ bench-rec.scm \ bench-tak.scm \ bench-takl.scm \ bench-takr.scm all: all-am .SUFFIXES: $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign bench/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign bench/Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs tags TAGS: ctags CTAGS: cscope cscopelist: distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-generic dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-generic mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: all all-am check check-am clean clean-generic clean-libtool \ cscopelist-am ctags-am distclean distclean-generic \ distclean-libtool distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-pdf install-pdf-am install-ps install-ps-am \ install-strip installcheck installcheck-am installdirs \ maintainer-clean maintainer-clean-generic mostlyclean \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags-am uninstall uninstall-am .PRECIOUS: Makefile # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: uim-1.8.8/sigscheme/bench/bench-rec.scm0000644000175000017500000000020512532333147014623 00000000000000(define (test f g n) (if (= n 0) f (let ((m (- n 1))) ((f g f m) f g m) ((g f g m) g f m) g))) (test test test 10) uim-1.8.8/sigscheme/bench/bench-loop.scm0000644000175000017500000000014612532333147015027 00000000000000(define loop (lambda (i l) (if (< i l) (loop (+ 1 i) l) l))) (write (loop 0 8000)) (newline) uim-1.8.8/sigscheme/bench/bench-let-loop.scm0000644000175000017500000000022112532333147015603 00000000000000(define loop (lambda (i l) (let ((a 0) (b 1) (c 2)) (if (< i l) (loop (+ 1 i) l) l)))) (write (loop 0 20000)) (newline) uim-1.8.8/sigscheme/bench/bench-fib.scm0000644000175000017500000000014512532333147014615 00000000000000(define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) (write (fib 30)) (newline) uim-1.8.8/sigscheme/bench/bench-case.scm0000644000175000017500000000024012532333147014764 00000000000000(define loop (lambda (i l) (case 6 ((1 2 3 4 5) #f) ((6) (if (< i l) (loop (+ 1 i) l) l))))) (write (loop 0 20000)) (newline) uim-1.8.8/sigscheme/bench/bench-takl.scm0000644000175000017500000000102412532333147015005 00000000000000(define (listn n) (if (not (= 0 n)) (cons n (listn (- n 1))) '())) (define l18 (listn 18)) (define l12 (listn 12)) (define l6 (listn 6)) (define (mas x y z) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) (define (shorterp x y) (and (not (null? y)) (or (null? x) (shorterp (cdr x) (cdr y))))) ;;; call: (mas l18 l12 l6) (mas l18 l12 l6) uim-1.8.8/sigscheme/bench/bench-tak.scm0000644000175000017500000000021312532333147014630 00000000000000(define (tak x y z) (if (not (< y x)) z (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))) (tak 18 12 6) uim-1.8.8/sigscheme/bench/bench-arithint.scm0000644000175000017500000000026512532333147015702 00000000000000(define *max* 20001) (define (test x y) (if (= x *max*) x (test (- x (+ (* y 2) (/ x (abs y)))) (- y (+ (* x 2) (/ y (abs x))))))) (write (test 1 1)) (newline) uim-1.8.8/sigscheme/bench/bench-mem.scm0000644000175000017500000000045412532333147014636 00000000000000(define *lifetime* 100) (define *blocksize* 100) (define *vec* (make-vector *lifetime*)) (define (foo i j) (if (< i *lifetime*) (begin (vector-set! *vec* i (make-vector *blocksize*)) (foo (+ i 1) j)) (if (< 0 j) (foo 0 (- j 1)) '()))) (write (foo 0 100)) (newline) uim-1.8.8/sigscheme/Makefile.in0000644000175000017500000007566213275405265013310 00000000000000# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ @USE_LIBGCROOTS_BUNDLED_TRUE@am__append_1 = libgcroots subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_c___attribute__.m4 \ $(top_srcdir)/m4/ax_c_arithmetic_rshift.m4 \ $(top_srcdir)/m4/ax_c_referenceable_passed_va_list.m4 \ $(top_srcdir)/m4/ax_cflags_gcc_option.m4 \ $(top_srcdir)/m4/ax_check_page_aligned_malloc.m4 \ $(top_srcdir)/m4/ax_create_stdint_h.m4 \ $(top_srcdir)/m4/ax_feature_configurator.m4 \ $(top_srcdir)/m4/ax_func_getcontext.m4 \ $(top_srcdir)/m4/ax_func_sigsetjmp.m4 \ $(top_srcdir)/m4/ax_lib_glibc.m4 \ $(top_srcdir)/m4/check_gnu_make.m4 $(top_srcdir)/m4/libtool.m4 \ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ $(am__configure_deps) $(am__DIST_COMMON) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/src/config.h CONFIG_CLEAN_FILES = sigscheme.pc libgcroots.mk sigscheme.mk CONFIG_CLEAN_VPATH_FILES = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = SOURCES = DIST_SOURCES = RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ ctags-recursive dvi-recursive html-recursive info-recursive \ install-data-recursive install-dvi-recursive \ install-exec-recursive install-html-recursive \ install-info-recursive install-pdf-recursive \ install-ps-recursive install-recursive installcheck-recursive \ installdirs-recursive pdf-recursive ps-recursive \ tags-recursive uninstall-recursive am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } am__installdirs = "$(DESTDIR)$(pkgconfigdir)" DATA = $(pkgconfig_DATA) RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ distclean-recursive maintainer-clean-recursive am__recursive_targets = \ $(RECURSIVE_TARGETS) \ $(RECURSIVE_CLEAN_TARGETS) \ $(am__extra_recursive_targets) AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ cscope distdir dist dist-all distcheck am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags CSCOPE = cscope am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/libgcroots.mk.in \ $(srcdir)/sigscheme.mk.in $(srcdir)/sigscheme.pc.in AUTHORS \ COPYING ChangeLog INSTALL NEWS README TODO compile \ config.guess config.sub install-sh ltmain.sh missing DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ if test -d "$(distdir)"; then \ find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -rf "$(distdir)" \ || { sleep 5 && rm -rf "$(distdir)"; }; \ else :; fi am__post_remove_distdir = $(am__remove_distdir) am__relativize = \ dir0=`pwd`; \ sed_first='s,^\([^/]*\)/.*$$,\1,'; \ sed_rest='s,^[^/]*/*,,'; \ sed_last='s,^.*/\([^/]*\)$$,\1,'; \ sed_butlast='s,/*[^/]*$$,,'; \ while test -n "$$dir1"; do \ first=`echo "$$dir1" | sed -e "$$sed_first"`; \ if test "$$first" != "."; then \ if test "$$first" = ".."; then \ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ else \ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ if test "$$first2" = "$$first"; then \ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ else \ dir2="../$$dir2"; \ fi; \ dir0="$$dir0"/"$$first"; \ fi; \ fi; \ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ done; \ reldir="$$dir2" DIST_ARCHIVES = $(distdir).tar.gz $(distdir).tar.bz2 GZIP_ENV = --best DIST_TARGETS = dist-bzip2 dist-gzip distuninstallcheck_listfiles = find . -type f -print am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ ASCIIDOC = @ASCIIDOC@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ FGREP = @FGREP@ GCROOTS_CFLAGS = @GCROOTS_CFLAGS@ GCROOTS_LIBS = @GCROOTS_LIBS@ GCROOTS_REQ = @GCROOTS_REQ@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MD5 = @MD5@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PERL = @PERL@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ RANLIB = @RANLIB@ RUBY = @RUBY@ SED = @SED@ SET_MAKE = @SET_MAKE@ SH = @SH@ SHA1 = @SHA1@ SHELL = @SHELL@ SSCM_DEFS = @SSCM_DEFS@ SSCM_MASTER_PKG = @SSCM_MASTER_PKG@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ ifGNUmake = @ifGNUmake@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ scmlibdir = @scmlibdir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ use_backtrace = @use_backtrace@ use_char = @use_char@ use_compat_siod = @use_compat_siod@ use_compat_siod_bugs = @use_compat_siod_bugs@ use_const_list_literal = @use_const_list_literal@ use_const_vector_literal = @use_const_vector_literal@ use_continuation = @use_continuation@ use_debug = @use_debug@ use_deep_cadrs = @use_deep_cadrs@ use_default_encoding = @use_default_encoding@ use_euccn = @use_euccn@ use_eucjp = @use_eucjp@ use_euckr = @use_euckr@ use_eval_c_string = @use_eval_c_string@ use_fixnum = @use_fixnum@ use_hygienic_macro = @use_hygienic_macro@ use_int = @use_int@ use_internal_definitions = @use_internal_definitions@ use_legacy_macro = @use_legacy_macro@ use_load = @use_load@ use_multibyte_char = @use_multibyte_char@ use_number_io = @use_number_io@ use_port = @use_port@ use_promise = @use_promise@ use_quasiquote = @use_quasiquote@ use_r6rs_chars = @use_r6rs_chars@ use_r6rs_named_chars = @use_r6rs_named_chars@ use_reader = @use_reader@ use_sjis = @use_sjis@ use_srfi0 = @use_srfi0@ use_srfi1 = @use_srfi1@ use_srfi2 = @use_srfi2@ use_srfi22 = @use_srfi22@ use_srfi23 = @use_srfi23@ use_srfi28 = @use_srfi28@ use_srfi34 = @use_srfi34@ use_srfi38 = @use_srfi38@ use_srfi43 = @use_srfi43@ use_srfi48 = @use_srfi48@ use_srfi55 = @use_srfi55@ use_srfi6 = @use_srfi6@ use_srfi60 = @use_srfi60@ use_srfi69 = @use_srfi69@ use_srfi8 = @use_srfi8@ use_srfi9 = @use_srfi9@ use_srfi95 = @use_srfi95@ use_sscm_extensions = @use_sscm_extensions@ use_sscm_format_extension = @use_sscm_format_extension@ use_storage = @use_storage@ use_strict_argcheck = @use_strict_argcheck@ use_strict_null_form = @use_strict_null_form@ use_strict_r5rs = @use_strict_r5rs@ use_strict_toplevel_definitions = @use_strict_toplevel_definitions@ use_strict_vector_form = @use_strict_vector_form@ use_string = @use_string@ use_string_procedure = @use_string_procedure@ use_utf8 = @use_utf8@ use_vector = @use_vector@ use_writer = @use_writer@ ACLOCAL_AMFLAGS = -I m4 SUBDIRS = doc m4 tools $(am__append_1) include src lib test test-c \ bench # To make 'make distclean' workable on --with-libgcroots=tiny-subdir, # libgcroots must be eliminated from $DIST_SUBDIRS. DIST_SUBDIRS = $(SUBDIRS) # $(distdir) does work as a part of $(RELEASE_URL) when configured as a # subpackage. DIST_NAME = $(PACKAGE)-$(VERSION) #RELEASE_TAG = master RELEASE_TAG = $(DIST_NAME) DIST_SUM_LIST = $(DIST_NAME).sum EXTRA_DIST = \ sigscheme.pc.in libgcroots.mk.in sigscheme.mk.in autogen.sh \ RELNOTE TODO QALog \ compare-scm.sh runbench.sh runtest.sh runtest-tail-rec.sh \ make-report.sh make-dist.sh @USE_LIBSSCM_TRUE@pkgconfigdir = $(libdir)/pkgconfig @USE_LIBSSCM_TRUE@pkgconfig_DATA = sigscheme.pc DISTCLEANFILES = sigscheme.pc $(DIST_SUM_LIST) all: all-recursive .SUFFIXES: am--refresh: Makefile @: $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --foreign'; \ $(am__cd) $(srcdir) && $(AUTOMAKE) --foreign \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) $(am__cd) $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) $(am__aclocal_m4_deps): sigscheme.pc: $(top_builddir)/config.status $(srcdir)/sigscheme.pc.in cd $(top_builddir) && $(SHELL) ./config.status $@ libgcroots.mk: $(top_builddir)/config.status $(srcdir)/libgcroots.mk.in cd $(top_builddir) && $(SHELL) ./config.status $@ sigscheme.mk: $(top_builddir)/config.status $(srcdir)/sigscheme.mk.in cd $(top_builddir) && $(SHELL) ./config.status $@ mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs distclean-libtool: -rm -f libtool config.lt install-pkgconfigDATA: $(pkgconfig_DATA) @$(NORMAL_INSTALL) @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \ done uninstall-pkgconfigDATA: @$(NORMAL_UNINSTALL) @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir) # This directory's subdirectories are mostly independent; you can cd # into them and run 'make' without going through this Makefile. # To change the values of 'make' variables: instead of editing Makefiles, # (1) if the variable is set in 'config.status', edit 'config.status' # (which will cause the Makefiles to be regenerated when you run 'make'); # (2) otherwise, pass the desired values on the 'make' command line. $(am__recursive_targets): @fail=; \ if $(am__make_keepgoing); then \ failcom='fail=yes'; \ else \ failcom='exit 1'; \ fi; \ dot_seen=no; \ target=`echo $@ | sed s/-recursive//`; \ case "$@" in \ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ *) list='$(SUBDIRS)' ;; \ esac; \ for subdir in $$list; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ dot_seen=yes; \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done; \ if test "$$dot_seen" = "no"; then \ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ fi; test -z "$$fail" ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-recursive TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ include_option=--etags-include; \ empty_fix=.; \ else \ include_option=--include; \ empty_fix=; \ fi; \ list='$(SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test ! -f $$subdir/TAGS || \ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ fi; \ done; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-recursive CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscope: cscope.files test ! -s cscope.files \ || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) clean-cscope: -rm -f cscope.files cscope.files: clean-cscope cscopelist cscopelist: cscopelist-recursive cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -rm -f cscope.out cscope.in.out cscope.po.out cscope.files distdir: $(DISTFILES) $(am__remove_distdir) test -d "$(distdir)" || mkdir "$(distdir)" @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ $(am__make_dryrun) \ || test -d "$(distdir)/$$subdir" \ || $(MKDIR_P) "$(distdir)/$$subdir" \ || exit 1; \ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ $(am__relativize); \ new_distdir=$$reldir; \ dir1=$$subdir; dir2="$(top_distdir)"; \ $(am__relativize); \ new_top_distdir=$$reldir; \ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ ($(am__cd) $$subdir && \ $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$$new_top_distdir" \ distdir="$$new_distdir" \ am__remove_distdir=: \ am__skip_length_check=: \ am__skip_mode_fix=: \ distdir) \ || exit 1; \ fi; \ done -test -n "$(am__skip_mode_fix)" \ || find "$(distdir)" -type d ! -perm -755 \ -exec chmod u+rwx,go+rx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r "$(distdir)" dist-gzip: distdir tardir=$(distdir) && $(am__tar) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).tar.gz $(am__post_remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 $(am__post_remove_distdir) dist-lzip: distdir tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz $(am__post_remove_distdir) dist-xz: distdir tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz $(am__post_remove_distdir) dist-tarZ: distdir @echo WARNING: "Support for distribution archives compressed with" \ "legacy program 'compress' is deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__post_remove_distdir) dist-shar: distdir @echo WARNING: "Support for shar distribution archives is" \ "deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 shar $(distdir) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).shar.gz $(am__post_remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__post_remove_distdir) dist dist-all: $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' $(am__post_remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lz*) \ lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ *.tar.xz*) \ xz -dc $(distdir).tar.xz | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir) chmod u+w $(distdir) mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ && $(am__cd) $(distdir)/_build/sub \ && ../../configure \ $(AM_DISTCHECK_CONFIGURE_FLAGS) \ $(DISTCHECK_CONFIGURE_FLAGS) \ --srcdir=../.. --prefix="$$dc_install_base" \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ && cd "$$am__cwd" \ || exit 1 $(am__post_remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @test -n '$(distuninstallcheck_dir)' || { \ echo 'ERROR: trying to run $@ with an empty' \ '$$(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ $(am__cd) '$(distuninstallcheck_dir)' || { \ echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am check: check-recursive all-am: Makefile $(DATA) installdirs: installdirs-recursive installdirs-am: for dir in "$(DESTDIR)$(pkgconfigdir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-recursive install-exec: install-exec-recursive install-data: install-data-recursive uninstall: uninstall-recursive install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-recursive install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-recursive clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -f Makefile distclean-am: clean-am distclean-generic distclean-libtool \ distclean-tags dvi: dvi-recursive dvi-am: html: html-recursive html-am: info: info-recursive info-am: install-data-am: install-pkgconfigDATA install-dvi: install-dvi-recursive install-dvi-am: install-exec-am: install-html: install-html-recursive install-html-am: install-info: install-info-recursive install-info-am: install-man: install-pdf: install-pdf-recursive install-pdf-am: install-ps: install-ps-recursive install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-recursive mostlyclean-am: mostlyclean-generic mostlyclean-libtool pdf: pdf-recursive pdf-am: ps: ps-recursive ps-am: uninstall-am: uninstall-pkgconfigDATA .MAKE: $(am__recursive_targets) install-am install-strip .PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ am--refresh check check-am clean clean-cscope clean-generic \ clean-libtool cscope cscopelist-am ctags ctags-am dist \ dist-all dist-bzip2 dist-gzip dist-lzip dist-shar dist-tarZ \ dist-xz dist-zip distcheck distclean distclean-generic \ distclean-libtool distclean-tags distcleancheck distdir \ distuninstallcheck dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-pdf install-pdf-am install-pkgconfigDATA install-ps \ install-ps-am install-strip installcheck installcheck-am \ installdirs installdirs-am maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-generic \ mostlyclean-libtool pdf pdf-am ps ps-am tags tags-am uninstall \ uninstall-am uninstall-pkgconfigDATA .PRECIOUS: Makefile $(pkgconfig_DATA): config.status .PHONY: FORCE sum FORCE: sum: FORCE $(MD5) $(DIST_ARCHIVES) >$(DIST_SUM_LIST) $(SHA1) $(DIST_ARCHIVES) >>$(DIST_SUM_LIST) tag: git tag -a -m "$(VERSION) has been released!!!" $(VERSION) git push --tags # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: uim-1.8.8/sigscheme/install-sh0000755000175000017500000003546313275405265013242 00000000000000#!/bin/sh # install - install a program, script, or datafile scriptversion=2014-09-12.12; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. tab=' ' nl=' ' IFS=" $tab$nl" # Set DOITPROG to "echo" to test this script. doit=${DOITPROG-} doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) is_target_a_directory=always dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done # We allow the use of options -d and -T together, by making -d # take the precedence; this is for compatibility with GNU install. if test -n "$dir_arg"; then if test -n "$dst_arg"; then echo "$0: target directory not allowed when installing a directory." >&2 exit 1 fi fi if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then if test $# -gt 1 || test "$is_target_a_directory" = always; then if test ! -d "$dst_arg"; then echo "$0: $dst_arg: Is not a directory." >&2 exit 1 fi fi fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) # $RANDOM is not portable (e.g. dash); use it when possible to # lower collision chance tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null; exit $ret' 0 # As "mkdir -p" follows symlinks and we work in /tmp possibly; so # create the $tmpdir first (and fail if unsuccessful) to make sure # that nobody tries to guess the $tmpdir name. if (umask $mkdir_umask && $mkdirprog $mkdir_mode "$tmpdir" && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. test_tmpdir="$tmpdir/a" ls_ld_tmpdir=`ls -ld "$test_tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; [-=\(\)!]*) prefix='./';; *) prefix='';; esac oIFS=$IFS IFS=/ set -f set fnord $dstdir shift set +f IFS=$oIFS prefixes= for d do test X"$d" = X && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: uim-1.8.8/sigscheme/configure.ac0000644000175000017500000010450013274722367013515 00000000000000AC_PREREQ(2.60b) AC_INIT([SigScheme], [0.9.1], [sigscheme-ja@googlegroups.com], [sigscheme]) AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_SRCDIR([src/sigscheme.c]) AC_CONFIG_HEADERS([src/config.h]) AM_INIT_AUTOMAKE([1.10 foreign dist-bzip2]) # Enable this iff asprintf(3) or another GNU extension is needed. This macro # must be invoked immediately after initialization. #AC_GNU_SOURCE # --enable-maintainer-mode is requied to build Git repository version of # SigScheme. AM_MAINTAINER_MODE # # Checks for programs # AC_PROG_CC AC_PROG_LIBTOOL AC_PROG_LN_S AC_PROG_EGREP # Prefers GNU sed if found. GNU sed is required for generating # test-c/collect.sh from Git repository version of SigScheme. AC_PROG_SED # These programs are only needed on make dist AC_PATH_PROGS(RUBY, ruby18 ruby) AC_PATH_PROGS(PERL, perl5 perl) AC_PATH_PROG(ASCIIDOC, asciidoc) AC_PATH_PROG(SH, sh) AC_PATH_PROGS(MD5, md5 md5sum) AC_PATH_PROGS(SHA1, sha1 sha1sum) # # Checks for libraries # AX_LIB_GLIBC # # Checks for header files # AC_HEADER_STDC AC_CHECK_HEADERS([stdint.h inttypes.h sys/inttypes.h sys/types.h \ limits.h malloc.h stddef.h stdlib.h string.h \ strings.h unistd.h assert.h]) # # Checks for typedefs, structures, and compiler characteristics # # FIXME: depending on the internal variable name AC_DEFUN([AX_LANG_WNOERROR], [ac_[]_AC_LANG_ABBREV[]_werror_flag=]) AC_C_CONST AC_C_VOLATILE AC_C_STRINGIZE AC_C_RESTRICT AC_C_INLINE AC_C_CHAR_UNSIGNED AX_C_ARITHMETIC_RSHIFT AX_C___ATTRIBUTE__ #AX_C___ALIGNOF__ #AX_C_DATA_ALIGNED #if test "x$ax_cv_c_data_aligned" = xno; then # AC_MSG_ERROR([C data types are not aligned as we expected.]) #fi AX_C_REFERENCEABLE_PASSED_VA_LIST if test "x$ax_cv_c_referenceable_passed_va_list" = xno; then # Temporary workaround: Assumes that va_list passed via an arg equals to # &va_list[0]. AC_DEFINE(HAVE_AUTOREFERRED_PASSED_VA_LIST, 1, [Define to 1 if va_list is an array type.]) fi AC_C_BIGENDIAN if test "x$ac_cv_c_bigendian" = xyes; then ax_c_endian=big elif test "x$ac_cv_c_bigendian" = xno; then ax_c_endian=little else ax_c_endian=$ac_cv_c_bigendian fi # a submacro of ax_create_stdint_h.m4 AX_CHECK_DATA_MODEL AC_TYPE_LONG_LONG_INT AC_TYPE_UNSIGNED_LONG_LONG_INT AC_TYPE_LONG_DOUBLE AC_TYPE_LONG_DOUBLE_WIDER # stdint types AC_TYPE_INT8_T AC_TYPE_INT16_T AC_TYPE_INT32_T AC_TYPE_INT64_T AC_TYPE_INTMAX_T AC_TYPE_INTPTR_T AC_TYPE_UINT8_T AC_TYPE_UINT16_T AC_TYPE_UINT32_T AC_TYPE_UINT64_T AC_TYPE_UINTMAX_T AC_TYPE_UINTPTR_T AC_CHECK_SIZEOF(char) AC_CHECK_SIZEOF(short) AC_CHECK_SIZEOF(int) AC_CHECK_SIZEOF(long) AC_CHECK_SIZEOF(long long) AC_CHECK_SIZEOF(float) AC_CHECK_SIZEOF(double) AC_CHECK_SIZEOF(long double) AC_CHECK_SIZEOF(void *) AC_CHECK_SIZEOF(size_t) # Do not assume (sizeof(int32_t) == 4) and so on (i.e. do not (CHAR_BIT == 8)). AC_CHECK_SIZEOF(int8_t) AC_CHECK_SIZEOF(int16_t) AC_CHECK_SIZEOF(int32_t) AC_CHECK_SIZEOF(int64_t) AC_CHECK_SIZEOF(intmax_t) AC_CHECK_SIZEOF(intptr_t) #AC_CHECK_SIZEOF(int_least8_t) #AC_CHECK_SIZEOF(int_least16_t) #AC_CHECK_SIZEOF(int_least32_t) #AC_CHECK_SIZEOF(int_least64_t) #AC_CHECK_SIZEOF(int_fast8_t) #AC_CHECK_SIZEOF(int_fast16_t) #AC_CHECK_SIZEOF(int_fast32_t) #AC_CHECK_SIZEOF(int_fast64_t) AC_CHECK_ALIGNOF(char) AC_CHECK_ALIGNOF(short) AC_CHECK_ALIGNOF(int) AC_CHECK_ALIGNOF(long) AC_CHECK_ALIGNOF(long long) AC_CHECK_ALIGNOF(float) AC_CHECK_ALIGNOF(double) AC_CHECK_ALIGNOF(long double) AC_CHECK_ALIGNOF(void *) AC_CHECK_ALIGNOF(size_t) AC_CHECK_ALIGNOF(int8_t) AC_CHECK_ALIGNOF(int16_t) AC_CHECK_ALIGNOF(int32_t) AC_CHECK_ALIGNOF(int64_t) AC_CHECK_ALIGNOF(intmax_t) AC_CHECK_ALIGNOF(intptr_t) #AC_CHECK_ALIGNOF(int_least8_t) #AC_CHECK_ALIGNOF(int_least16_t) #AC_CHECK_ALIGNOF(int_least32_t) #AC_CHECK_ALIGNOF(int_least64_t) #AC_CHECK_ALIGNOF(int_fast8_t) #AC_CHECK_ALIGNOF(int_fast16_t) #AC_CHECK_ALIGNOF(int_fast32_t) #AC_CHECK_ALIGNOF(int_fast64_t) AC_TYPE_SIZE_T AC_TYPE_SSIZE_T #AC_TYPE_MBSTATE_T #AC_TYPE_MODE_T #AC_TYPE_OFF_T #AC_TYPE_PID_T #AC_TYPE_SIGNAL #AC_TYPE_UID_T if $CC --version >/dev/null 2>/dev/null; then ax_prog_cc_version=`$CC --version | head -n 1` else ax_prog_cc_version="unknown" fi AC_LANG_WERROR # Turn warning-only unknown options into error. AX_CFLAGS_GCC_OPTION([-pedantic]) AX_CFLAGS_GCC_OPTION([-Wall]) AX_CFLAGS_GCC_OPTION([-Wchar-subscripts]) AX_CFLAGS_GCC_OPTION([-Wmissing-declarations]) AX_CFLAGS_GCC_OPTION([-Wredundant-decls]) AX_CFLAGS_GCC_OPTION([-Wmissing-prototypes]) AX_CFLAGS_GCC_OPTION([-Wnested-externs]) AX_CFLAGS_GCC_OPTION([-Wpointer-arith]) AX_CFLAGS_GCC_OPTION([-Wcast-align]) AX_CFLAGS_GCC_OPTION([-Wsign-compare]) # Suppress warnings about strings longer than ISO C 89 maximum length (509). AX_CFLAGS_GCC_OPTION([-Wno-overlength-strings]) # Disable the problematic preprocessing on Mac OS X AX_CFLAGS_GCC_OPTION([-no-cpp-precomp]) AX_LANG_WNOERROR # end AC_LANG_WERROR # # Checks for library functions # AX_FUNC_GETCONTEXT AX_FUNC_SIGSETJMP AC_CHECK_FUNCS([strtoll strtoimax \ memalign \ fileno getcwd getpagesize]) AC_CHECK_FUNCS(posix_memalign, [ # For posix_memalign(3). although this value is overridden by _GNU_SOURCE # on glibc, keep this for other environments. AC_DEFINE(_POSIX_C_SOURCE, 200112L) ]) AH_VERBATIM(_POSIX_C_SOURCE, [/* Define to 200112L to enable posix_memalign(3). */ #if SCM_COMPILING_LIBSSCM #undef _POSIX_C_SOURCE #endif]) AC_CHECK_FUNCS(memalign) AC_CHECK_FUNCS(strdup, [ # Overrides _POSIX_C_SOURCE AC_DEFINE(_XOPEN_SOURCE, 500) ]) AH_VERBATIM(_XOPEN_SOURCE, [/* Define to 500 to enable strdup(3). */ #if SCM_COMPILING_LIBSSCM #undef _XOPEN_SOURCE #endif]) AC_CHECK_FUNCS(strcasecmp, [ if test "x$ax_cv_lib_glibc" = xyes; then AC_DEFINE(_BSD_SOURCE, 1) fi ], [ AC_LIBOBJ(strcasecmp) ]) AH_VERBATIM(_BSD_SOURCE, [/* Define to 1 if it is needed to enable strcasecmp(3). */ #if SCM_COMPILING_LIBSSCM #undef _BSD_SOURCE #endif]) AX_CHECK_PAGE_ALIGNED_MALLOC ##################### # Optional packages # ##################### AC_ARG_WITH(master-pkg, AS_HELP_STRING([--with-master-pkg@<:@=NAME@:>@], [specify alternative package name for pkgdatadir. @<:@default=sigscheme@:>@])) case "${with_master_pkg:=no}" in no|yes) SSCM_MASTER_PKG="sigscheme" ;; *) SSCM_MASTER_PKG="${with_master_pkg}" ;; esac AC_SUBST(SSCM_MASTER_PKG) AM_CONDITIONAL(WITH_MASTER_PKG, [test "x$with_master_pkg" != xno]) AC_ARG_WITH(libgcroots, AS_HELP_STRING([--with-libgcroots@<:@=WHICH@:>@], [use alternative libgcroots instead of package-bundled one. WHICH=(installed|tiny-subst) @<:@default=installed@:>@])) case "${with_libgcroots:=no}" in no) # bundled libgcroots package ac_configure_args="$ac_configure_args " AC_CONFIG_SUBDIRS([libgcroots]) # Specify absolute directories to make being usable from superordinate # packages such as uim. GCROOTS_LIBS='$(sscm_abs_top_builddir)/libgcroots/libgcroots.la' GCROOTS_CFLAGS='-I$(sscm_abs_top_srcdir)/libgcroots/include' use_libgcroots="bundled one" GCROOTS_REQ=gcroots ;; yes|installed) PKG_CHECK_MODULES(GCROOTS, [gcroots >= 0.2.3], [], [AC_MSG_ERROR([installed libgcroots is not found.])]) use_libgcroots="installed one" GCROOTS_REQ=gcroots ;; tiny-subst) # use src/gcroots/gcroots.[hc] with_libgcroots=tiny_subst GCROOTS_CFLAGS='-I$(sscm_abs_top_srcdir)/src/gcroots' use_libgcroots="tiny substitution in src/gcroots" ;; *) AC_MSG_ERROR([invalid argument for --with-libgcroots.]) ;; esac AC_SUBST(GCROOTS_REQ) AC_SUBST(GCROOTS_LIBS) AC_SUBST(GCROOTS_CFLAGS) AM_CONDITIONAL(USE_LIBGCROOTS, [test "x$with_libgcroots" != xtiny_subst]) AM_CONDITIONAL(USE_LIBGCROOTS_BUNDLED, [test "x$with_libgcroots" = xno]) AM_CONDITIONAL(USE_LIBGCROOTS_TINY_SUBST, [test "x$with_libgcroots" = xtiny_subst]) ######################################## # Configure features with dependencies # ######################################## # Init with default prefixes for shell var, AC_DEFINE, AM_CONDITIONAL AX_FEATURE_CONFIGURATOR([use_], [SCM_USE_], [USE_]) # # Acquire the feature configuration variables from user # # Pseudo feature as base dependency: Features that required to run current # SigScheme implementation depends on this. AX_FEATURE_VAR_Y(sigscheme, [pseudo feature for dependency resolution]) # Specify a set of default variable settings AX_FEATURE_ARG_X(conf, [select base configuration of SigScheme. CONF=(regular|full|small|r5rs|siod|dev|uim) @<:@regular@:>@], [regular], [^(regular|full|small|r5rs|siod|dev|uim)$], [ # multibyte char handlings case "$enable_conf" in full|dev) use_utf8=yes use_euccn=yes use_eucjp=yes use_euckr=yes use_sjis=yes ;; small|siod) use_default_encoding=singlebyte use_utf8=no use_euccn=no use_eucjp=no use_euckr=no use_sjis=no use_strict_encoding_check=no ;; uim) use_default_encoding=singlebyte use_utf8=yes use_euccn=no use_eucjp=yes use_euckr=no use_sjis=no use_strict_encoding_check=no ;; esac # R5RS behaviors case "$enable_conf" in r5rs) use_strict_r5rs=yes ;; full|dev) use_strict_r5rs=no #use_const_list_literal=yes use_const_vector_literal=yes #use_strict_null_form=yes use_strict_vector_form=yes use_strict_argcheck=yes use_strict_toplevel_definitions=yes use_internal_definitions=yes ;; uim) use_strict_r5rs=no #use_const_list_literal=yes use_const_vector_literal=yes use_strict_null_form=no use_strict_vector_form=yes use_strict_argcheck=yes use_strict_toplevel_definitions=yes use_internal_definitions=yes ;; small|siod) use_strict_r5rs=no use_const_list_literal=no use_const_vector_literal=no use_strict_null_form=no use_strict_vector_form=no use_strict_argcheck=no use_strict_toplevel_definitions=no use_internal_definitions=no ;; esac # R5RS features case "$enable_conf" in full|r5rs|dev) use_continuation=yes use_quasiquote=yes use_promise=yes use_int=yes use_numeric_io=yes use_char=yes use_string=yes use_string_procedures=yes use_deep_cadrs=yes use_vector=yes use_port=yes use_reader=yes use_writer=yes use_load=yes ;; small) use_continuation=no use_quasiquote=no use_promise=no use_int=yes use_numeric_io=yes use_char=yes use_string=yes use_string_procedures=yes use_deep_cadrs=no use_vector=no use_port=yes use_reader=yes use_writer=yes use_load=yes ;; siod) use_continuation=no use_quasiquote=no use_promise=no use_int=yes use_numeric_io=yes use_char=no use_string=yes use_string_procedures=no use_deep_cadrs=no use_vector=no use_port=yes use_reader=yes use_writer=yes use_load=yes ;; uim) use_continuation=yes use_quasiquote=yes use_promise=yes use_int=yes use_numeric_io=yes use_char=yes use_string=yes use_string_procedures=yes use_deep_cadrs=no use_vector=yes use_port=yes use_reader=yes use_writer=yes use_load=yes ;; esac # experimental features case "$enable_conf" in dev) use_hygienic_macro=yes ;; *) use_hygienic_macro=no ;; esac # SRFIs case "$enable_conf" in full|r5rs|dev|uim) use_srfi0=yes use_srfi1=yes use_srfi2=yes use_srfi6=yes use_srfi8=yes use_srfi9=yes use_srfi22=yes use_srfi23=yes use_srfi28=yes use_srfi34=yes use_srfi38=yes use_srfi43=yes use_srfi48=yes use_srfi55=yes use_srfi60=yes use_srfi69=yes use_srfi95=yes ;; small|siod) use_srfi0=no use_srfi1=no use_srfi2=no use_srfi6=no use_srfi8=no use_srfi9=no use_srfi22=no use_srfi23=no use_srfi28=no use_srfi34=no use_srfi38=no use_srfi43=no use_srfi48=no use_srfi55=no use_srfi60=no use_srfi69=no use_srfi95=no ;; esac # SigScheme-specific extensions case "$enable_conf" in full|r5rs|dev) use_legacy_macro=yes use_sscm_extensions=yes use_sscm_format_extension=yes use_compat_siod=no use_compat_siod_bugs=no use_eval_c_string=yes ;; small) use_legacy_macro=no use_sscm_extensions=no use_sscm_format_extension=no use_compat_siod=no use_compat_siod_bugs=no use_eval_c_string=no ;; siod) use_legacy_macro=no use_sscm_extensions=yes use_sscm_format_extension=no use_compat_siod=yes use_compat_siod_bugs=yes use_eval_c_string=yes ;; uim) use_legacy_macro=yes use_sscm_extensions=yes use_sscm_format_extension=yes use_compat_siod=yes use_compat_siod_bugs=no use_eval_c_string=yes ;; esac # R6RS features case "$enable_conf" in full|dev|uim) use_r6rs_named_chars=yes use_r6rs_chars=yes ;; r5rs|small|siod) use_r6rs_named_chars=no use_r6rs_chars=no ;; esac # Debugging features case "$enable_conf" in dev) use_backtrace=yes use_debug=yes use_warning_suppressor=yes ;; esac ]) # If the variable is preexisting, it is used as default value. explicit # --enable or --disable can override it. # Storage configuration AX_FEATURE_ARG_X(storage, [specify underlying storage implementation. STORAGE=(compact|fatty) @<:@compact@:>@], [compact], [^(compact|fatty)$]) AX_FEATURE_ARG_X(fixnum, [specify Scheme integer (fixnum) size. FIXNUM=(long|int|int32_t|int64_t) @<:@long@:>@], [long], [^(long|int|int32_t|int64_t)$]) AX_FEATURE_VAR_X(scmref, [specify scm_intref_t (don't touch)], [intptr_t], [^(intptr_t|int32_t|int64_t)$]) AX_FEATURE_VAR_N(valuecons, [valuecons for efficient multiple values handling]) AX_FEATURE_VAR_N(dump, [storage dump (not implemented yet)]) # String configuration #AX_FEATURE_VAR_N(const-width-string, [strings consist of constant-width characters (not implemented yet)]) AX_FEATURE_VAR_N(null-capable-string, [null character in a middle of a string (experimental)]) # Character encodings AX_FEATURE_VAR_N(multibyte, [multibyte character encodings]) AX_FEATURE_ARG_X(default-encoding, [specify default character encoding. ENCODING=(utf8|singlebyte|euccn|eucjp|euckr|sjis) @<:@utf8@:>@], [utf8], [^(utf8|singlebyte|euccn|eucjp|euckr|sjis)$]) AX_FEATURE_ARG_Y(utf8, [UTF-8 character encoding]) AX_FEATURE_ARG_N(euccn, [EUC-CN character encoding]) AX_FEATURE_ARG_N(eucjp, [EUC-JP character encoding]) AX_FEATURE_ARG_N(euckr, [EUC-KR character encoding]) AX_FEATURE_ARG_N(sjis, [Shift_JIS character encoding]) AX_FEATURE_ARG_Y(strict-encoding-check, [all feasible encoding error checks]) # Other internal SigScheme features AX_FEATURE_VAR_N(format, [intermediate format strings]) AX_FEATURE_VAR_N(raw-c-format, [internal format which takes raw C values from va_list]) # R5RS behaviors AX_FEATURE_ARG_N(strict-r5rs, [strict R5RS conformance checks]) AX_FEATURE_ARG_N(const-list-literal, [immutable list literals]) AX_FEATURE_ARG_Y(const-vector-literal, [immutable vector literals]) AX_FEATURE_ARG_N(strict-null-form, [rejecting quote-less ()]) AX_FEATURE_ARG_Y(strict-vector-form, [rejecting quote-less vector literal]) AX_FEATURE_ARG_Y(strict-argcheck, [strict check for form arguments]) AX_FEATURE_ARG_Y(strict-toplevel-definitions, [strict check for R5RS top-level definitions]) AX_FEATURE_ARG_Y(internal-definitions, [R5RS internal definitions]) # R5RS features AX_FEATURE_ARG_Y(continuation, [R5RS continuation]) AX_FEATURE_ARG_Y(quasiquote, [R5RS quasiquotation]) AX_FEATURE_ARG_N(hygienic-macro, [R5RS hygienic macros (experimental)]) AX_FEATURE_ARG_Y(promise, [R5RS promises]) AX_FEATURE_VAR_N(number, [R5RS numbers]) AX_FEATURE_ARG_Y(int, [R5RS integer numbers]) AX_FEATURE_VAR_N(rational, [R5RS rational numbers (not implemented yet)]) AX_FEATURE_VAR_N(real, [R5RS real numbers (not implemented yet)]) AX_FEATURE_VAR_N(complex, [R5RS complex numbers (not implemented yet)]) AX_FEATURE_ARG_Y(numeric-io, [R5RS 'number->string' and 'string->number']) AX_FEATURE_ARG_Y(char, [R5RS characters]) AX_FEATURE_ARG_Y(string, [primary procedures of R5RS strings]) AX_FEATURE_ARG_Y(string-procedures, [rest procedures of R5RS strings]) AX_FEATURE_ARG_Y(deep-cadrs, [all c@<:@ad@:>@+r procedures defined in R5RS]) AX_FEATURE_ARG_Y(vector, [R5RS vectors]) AX_FEATURE_ARG_Y(port, [R5RS ports]) AX_FEATURE_ARG_Y(reader, [R5RS 'read']) AX_FEATURE_ARG_Y(writer, [R5RS 'write' and 'display']) AX_FEATURE_ARG_Y(load, [R5RS 'load']) # SRFIs AX_FEATURE_ARG_Y(srfi0, [SRFI-0 'cond-expand']) AX_FEATURE_ARG_Y(srfi1, [SRFI-1 list library]) AX_FEATURE_ARG_Y(srfi2, [SRFI-2 'and-let*']) AX_FEATURE_ARG_Y(srfi6, [SRFI-6 basic string ports]) AX_FEATURE_ARG_Y(srfi8, [SRFI-8 'receive']) AX_FEATURE_ARG_Y(srfi9, [SRFI-9 defining record types]) AX_FEATURE_ARG_Y(srfi22, [SRFI-22 running scheme scripts on Unix (partial)]) AX_FEATURE_ARG_Y(srfi23, [SRFI-23 'error']) AX_FEATURE_ARG_Y(srfi28, [SRFI-28 'format']) AX_FEATURE_ARG_Y(srfi34, [SRFI-34 exception handling for programs]) AX_FEATURE_ARG_Y(srfi38, [SRFI-38 'write/ss' ('read/ss' is not provided)]) AX_FEATURE_ARG_Y(srfi43, [SRFI-43 vector library]) AX_FEATURE_ARG_Y(srfi48, [SRFI-48 'format' (superset of SRFI-28)]) AX_FEATURE_ARG_Y(srfi55, [SRFI-55 'require-extension']) AX_FEATURE_ARG_Y(srfi60, [SRFI-60 integers as bits (partial)]) AX_FEATURE_ARG_Y(srfi69, [SRFI-69 basic hash tables]) AX_FEATURE_ARG_Y(srfi95, [SRFI-95 sorting and merging]) # R6RS features (preliminary) AX_FEATURE_ARG_Y(r6rs-named-chars, [named characters of R6RS (preliminary)]) AX_FEATURE_ARG_Y(r6rs-chars, [R6RS characters (preliminary)]) # Common Scheme features AX_FEATURE_VAR_N(syntax-case, ['syntax-case' (not implemented yet)]) AX_FEATURE_VAR_N(unhygienic-macro, [syntactic closure (not implemented yet)]) AX_FEATURE_ARG_Y(legacy-macro, ['define-macro' syntactic closure]) # SigScheme-specific features AX_FEATURE_ARG_Y(sscm-extensions, [SigScheme-specific extensions]) AX_FEATURE_ARG_Y(sscm-format-extension, [SigScheme-specific 'format+']) AX_FEATURE_ARG_N(compat-siod, [some SIOD compatible features]) AX_FEATURE_ARG_N(compat-siod-bugs, [emulating the buggy behaviors of SIOD]) AX_FEATURE_ARG_Y(eval-c-string, [eval_c_string() of libsscm]) AX_FEATURE_ARG_N(backtrace, [showing backtrace on error]) AX_FEATURE_ARG_Y(libsscm, [building libsscm]) AX_FEATURE_ARG_Y(shell, [the 'sscm' interactive shell]) # Developer-only debugging features AX_FEATURE_ARG_N(debug, [debug mode]) AX_FEATURE_ARG_N(debug-port, [port debugging]) AX_FEATURE_ARG_N(debug-parser, [parser debugging]) AX_FEATURE_ARG_N(debug-macro, [macro and pattern matching debugging]) AX_FEATURE_ARG_N(debug-encoding, [encoding-related functions debugging]) AX_FEATURE_ARG_N(debug-backtrace-sep, [frame-separator on backtrace]) AX_FEATURE_ARG_N(debug-backtrace-val, [values printing on backtrace]) AX_FEATURE_ARG_N(soft-assert, [recovery from failed SCM_ASSERT()]) AX_FEATURE_ARG_N(accessor-assert, [type assertion on Scheme object accessors]) AX_FEATURE_ARG_Y(warning-suppressor, [suppressing compiler warnings]) # # Resolve dependency of the features # # Resolve required dependencies AX_FEATURE_RESOLVE_DEPENDENCIES([required], [ sigscheme: raw_c_format backtrace: continuation port writer debug: raw_c_format debug_backtrace_val: debug backtrace raw_c_format format: writer port string srfi28: format srfi48: format srfi28 sscm_format_extension: format srfi48 raw_c_format: format hygienic_macro: syntax_case: unhygienic_macro string_procedures: string_procedure string_procedure: string char reader: port writer: port raw_c_format load: port reader string sscm_extensions: load eval_c_string: reader srfi6 srfi0: load srfi55 legacy_macro srfi1 srfi23 srfi1: continuation deep_cadrs load sscm_extensions srfi8 srfi23 srfi6: port string srfi9: load vector srfi23 srfi34: continuation srfi23 srfi38: writer srfi43: load vector srfi8 srfi23 sscm_extensions srfi55: load sscm_extensions srfi60: int srfi69: load int string vector srfi9 srfi23 srfi95: load int r6rs_named_chars: char r6rs_chars: char utf8 reader r6rs_named_chars compat_siod: sscm_extensions srfi60 eval_c_string compat_siod_bugs: compat_siod strict_r5rs: strict_null_form strict_vector_form strict_argcheck internal_definitions strict_toplevel_definitions const_vector_literal int: number rational: number real: number complex: number numeric_io: number_io number_io: number string fixnum_long: long_fixnum fixnum_int: int_fixnum fixnum_int32_t: 32bit_fixnum fixnum_int64_t: 64bit_fixnum scmref_intptr_t: intptr_scmref scmref_int32_t: 32bit_scmref scmref_int64_t: 64bit_scmref multibyte: multibyte_char utf8: multibyte_char eucjp: multibyte_char euckr: multibyte_char euccn: multibyte_char sjis: multibyte_char default_encoding_utf8: utf8 utf8_as_default default_encoding_singlebyte: singlebyte_as_default default_encoding_euccn: euccn euccn_as_default default_encoding_eucjp: eucjp eucjp_as_default default_encoding_euckr: euckr euckr_as_default default_encoding_sjis: sjis sjis_as_default shell: libsscm ]) # Resolve recommended dependencies (not required) AX_FEATURE_RESOLVE_DEPENDENCIES([recommended], [ conf_dev: warning_suppressor storage_fatty: valuecons const_list_literal const_vector_literal debug: accessor_assert strict_argcheck strict_encoding_check backtrace: srfi38 srfi69: srfi38 ]) # Resolve weak dependencies required if and only if available dnl AX_FEATURE_RESOLVE_WEAK_DEPENDENCIES([ dnl strict_r5rs: const_list_literal dnl ]) # Check conflicts between the features AX_FEATURE_DETECT_CONFLICTS([ storage_fatty storage_compact storage_compact valuecons storage_compact const_list_literal debug_no null_capable_string strict_r5rs compat_siod_bugs strict_r5rs strict_vector_form_no strict_r5rs strict_null_form_no strict_r5rs strict_toplevel_definitions_no strict_r5rs internal_definitions_no compat_siod_bugs strict_null_form long_fixnum int_fixnum 32bit_fixnum 64bit_fixnum intptr_scmref 32bit_scmref 64bit_scmref singlebyte_as_default utf8_as_default eucjp_as_default euckr_as_default euccn_as_default sjis_as_default ], [if-conflict]) # # Define configured results # # Storage configuration AX_FEATURE_DEFINE(storage_compact) AX_FEATURE_DEFINE(storage_fatty) AX_FEATURE_DEFINE(long_fixnum) AX_FEATURE_DEFINE(int_fixnum) AX_FEATURE_DEFINE(32bit_fixnum) AX_FEATURE_DEFINE(64bit_fixnum) AX_FEATURE_DEFINE(intptr_scmref) AX_FEATURE_DEFINE(32bit_scmref) AX_FEATURE_DEFINE(64bit_scmref) AX_FEATURE_DEFINE(valuecons) AX_FEATURE_DEFINE(dump) # String configuration #AX_FEATURE_DEFINE(const_width_string) AX_FEATURE_DEFINE(null_capable_string) # Character encodings AX_FEATURE_DEFINE(multibyte_char) AX_FEATURE_DEFINE(utf8) AX_FEATURE_DEFINE(euccn) AX_FEATURE_DEFINE(eucjp) AX_FEATURE_DEFINE(euckr) AX_FEATURE_DEFINE(sjis) AX_FEATURE_DEFINE(utf8_as_default) AX_FEATURE_DEFINE(singlebyte_as_default) AX_FEATURE_DEFINE(euccn_as_default) AX_FEATURE_DEFINE(eucjp_as_default) AX_FEATURE_DEFINE(euckr_as_default) AX_FEATURE_DEFINE(sjis_as_default) AX_FEATURE_DEFINE(strict_encoding_check, SCM_STRICT_ENCODING_CHECK, STRICT_ENCODING_CHECK) # Other internal SigScheme features AX_FEATURE_DEFINE(format) AX_FEATURE_DEFINE(raw_c_format) # R5RS behaviors AX_FEATURE_DEFINE(strict_r5rs, SCM_STRICT_R5RS, STRICT_R5RS) AX_FEATURE_DEFINE(const_list_literal, SCM_CONST_LIST_LITERAL, CONST_LIST_LITERAL) AX_FEATURE_DEFINE(const_vector_literal, SCM_CONST_VECTOR_LITERAL, CONST_VECTOR_LITERAL) AX_FEATURE_DEFINE(strict_null_form, SCM_STRICT_NULL_FORM, STRICT_NULL_FORM) AX_FEATURE_DEFINE(strict_vector_form, SCM_STRICT_VECTOR_FORM, STRICT_VECTOR_FORM) AX_FEATURE_DEFINE(strict_argcheck, SCM_STRICT_ARGCHECK, STRICT_ARGCHECK) AX_FEATURE_DEFINE(strict_toplevel_definitions, SCM_STRICT_TOPLEVEL_DEFINITIONS, STRICT_TOPLEVEL_DEFINITIONS) AX_FEATURE_DEFINE(internal_definitions) # R5RS features AX_FEATURE_DEFINE(continuation) AX_FEATURE_DEFINE(quasiquote) AX_FEATURE_DEFINE(hygienic_macro) AX_FEATURE_DEFINE(promise) AX_FEATURE_DEFINE(number) AX_FEATURE_DEFINE(int) AX_FEATURE_DEFINE(rational) AX_FEATURE_DEFINE(real) AX_FEATURE_DEFINE(complex) AX_FEATURE_DEFINE(number_io) AX_FEATURE_DEFINE(char) AX_FEATURE_DEFINE(string) AX_FEATURE_DEFINE(string_procedure) AX_FEATURE_DEFINE(deep_cadrs) AX_FEATURE_DEFINE(vector) AX_FEATURE_DEFINE(port) AX_FEATURE_DEFINE(reader) AX_FEATURE_DEFINE(writer) AX_FEATURE_DEFINE(load) # SRFIs AX_FEATURE_DEFINE(srfi0) AX_FEATURE_DEFINE(srfi1) AX_FEATURE_DEFINE(srfi2) AX_FEATURE_DEFINE(srfi6) AX_FEATURE_DEFINE(srfi8) AX_FEATURE_DEFINE(srfi9) AX_FEATURE_DEFINE(srfi22) AX_FEATURE_DEFINE(srfi23) AX_FEATURE_DEFINE(srfi28) AX_FEATURE_DEFINE(srfi34) AX_FEATURE_DEFINE(srfi38) AX_FEATURE_DEFINE(srfi43) AX_FEATURE_DEFINE(srfi48) AX_FEATURE_DEFINE(srfi55) AX_FEATURE_DEFINE(srfi60) AX_FEATURE_DEFINE(srfi69) AX_FEATURE_DEFINE(srfi95) # R6RS features (preliminary) AX_FEATURE_DEFINE(r6rs_named_chars) AX_FEATURE_DEFINE(r6rs_chars) # Common Scheme features AX_FEATURE_DEFINE(syntax_case) AX_FEATURE_DEFINE(unhygienic_macro) AX_FEATURE_DEFINE(legacy_macro) # SigScheme-specific features AX_FEATURE_DEFINE(sscm_extensions) AX_FEATURE_DEFINE(sscm_format_extension) AX_FEATURE_DEFINE(compat_siod, SCM_COMPAT_SIOD, COMPAT_SIOD) AX_FEATURE_DEFINE(compat_siod_bugs, SCM_COMPAT_SIOD_BUGS, COMPAT_SIOD_BUGS) AX_FEATURE_DEFINE(eval_c_string) AX_FEATURE_DEFINE(backtrace) AX_FEATURE_DEFINE(libsscm) AX_FEATURE_DEFINE(shell) # Developer-only debugging features AX_FEATURE_DEFINE(debug, SCM_DEBUG, DEBUG) AX_FEATURE_DEFINE(debug_port, SCM_DEBUG_PORT, DEBUG_PORT) AX_FEATURE_DEFINE(debug_parser, SCM_DEBUG_PARSER, DEBUG_PARSER) AX_FEATURE_DEFINE(debug_macro, SCM_DEBUG_MACRO, DEBUG_MACRO) AX_FEATURE_DEFINE(debug_encoding, SCM_DEBUG_ENCODING, DEBUG_ENCODING) AX_FEATURE_DEFINE(debug_backtrace_sep, SCM_DEBUG_BACKTRACE_SEP, DEBUG_BACKTRACE_SEP) AX_FEATURE_DEFINE(debug_backtrace_val, SCM_DEBUG_BACKTRACE_VAL, DEBUG_BACKTRACE_VAL) AX_FEATURE_DEFINE(soft_assert, SCM_SOFT_ASSERT, SOFT_ASSERT) AX_FEATURE_DEFINE(accessor_assert, SCM_ACCESSOR_ASSERT, ACCESSOR_ASSERT) AX_FEATURE_DEFINE(warning_suppressor) AC_SUBST(use_storage) AC_SUBST(use_fixnum) AC_SUBST(use_multibyte_char) AC_SUBST(use_default_encoding) AC_SUBST(use_utf8) AC_SUBST(use_euccn) AC_SUBST(use_eucjp) AC_SUBST(use_euckr) AC_SUBST(use_sjis) AC_SUBST(use_strict_r5rs) AC_SUBST(use_const_list_literal) AC_SUBST(use_const_vector_literal) AC_SUBST(use_strict_null_form) AC_SUBST(use_strict_vector_form) AC_SUBST(use_strict_argcheck) AC_SUBST(use_strict_toplevel_definitions) AC_SUBST(use_internal_definitions) AC_SUBST(use_continuation) AC_SUBST(use_quasiquote) AC_SUBST(use_hygienic_macro) AC_SUBST(use_promise) AC_SUBST(use_int) AC_SUBST(use_number_io) AC_SUBST(use_char) AC_SUBST(use_string) AC_SUBST(use_string_procedure) AC_SUBST(use_deep_cadrs) AC_SUBST(use_vector) AC_SUBST(use_port) AC_SUBST(use_reader) AC_SUBST(use_writer) AC_SUBST(use_load) AC_SUBST(use_srfi0) AC_SUBST(use_srfi1) AC_SUBST(use_srfi2) AC_SUBST(use_srfi6) AC_SUBST(use_srfi8) AC_SUBST(use_srfi9) AC_SUBST(use_srfi22) AC_SUBST(use_srfi23) AC_SUBST(use_srfi28) AC_SUBST(use_srfi34) AC_SUBST(use_srfi38) AC_SUBST(use_srfi43) AC_SUBST(use_srfi48) AC_SUBST(use_srfi55) AC_SUBST(use_srfi60) AC_SUBST(use_srfi69) AC_SUBST(use_srfi95) AC_SUBST(use_r6rs_chars) AC_SUBST(use_r6rs_named_chars) AC_SUBST(use_legacy_macro) AC_SUBST(use_sscm_extensions) AC_SUBST(use_sscm_format_extension) AC_SUBST(use_compat_siod) AC_SUBST(use_compat_siod_bugs) AC_SUBST(use_eval_c_string) AC_SUBST(use_backtrace) AC_SUBST(use_debug) ######### # Fixup # ######### # # Hardwired configurations # AC_DEFINE(SCM_ENCODING_USE_WITH_SIGSCHEME, 1, [Define to 1 to adapt encoding.c to SigScheme.]) AC_DEFINE(SCM_SCMPORT_USE_WITH_SIGSCHEME, 1, [Define to 1 to adapt scmport*.[hc] to SigScheme.]) # # Compiler options # # Debugging-related flags if test "x$use_debug" = xyes; then if test "x$ac_cv_prog_cc_g" = xyes; then CFLAGS="$CFLAGS -g" fi # Restricting the C dialect tends to cause system library disfunction such as # on glibc and Darwin libc. So this option is only specified at debugging # mode. # # -std=gnu89 is required only for (old?) glibc. -std=c89 is sufficient for # other environments. AC_LANG_WERROR # Turn warning-only unknown options into error. if test "x$ax_cv_lib_glibc" = xyes; then AX_CFLAGS_GCC_OPTION([-std=gnu89]) else AX_CFLAGS_GCC_OPTION([-std=c89]) fi AX_LANG_WNOERROR # end AC_LANG_WERROR else CFLAGS="$CFLAGS -DNDEBUG" fi # # System directories # scmlibdir='${pkgdatadir}/lib' AC_SUBST(scmlibdir) SSCM_DEFS='-DPKGDATADIR="\"$(pkgdatadir)\"" -DSCMLIBDIR="\"$(scmlibdir)\""' AC_SUBST(SSCM_DEFS) ############################### # Output configuration result # ############################### # This include guard is required to prevent being overridden by # system-installed config.h on a source that is compiled on # !SCM_COMPILING_LIBSSCM such as test-c/test-*.c. AH_TOP([#ifndef __SIGSCHEME_CONFIG_H #define __SIGSCHEME_CONFIG_H]) # FIXME: temporary solution AH_BOTTOM([ /* FIXME: temporary solution */ #include "config-old.h" #endif /* __SIGSCHEME_CONFIG_H */]) AC_CONFIG_FILES([sigscheme.pc libgcroots.mk sigscheme.mk Makefile doc/Makefile m4/Makefile tools/Makefile include/Makefile include/sigscheme/Makefile src/Makefile lib/Makefile test/Makefile test/run-singletest.sh test-c/Makefile test-c/collect.sh bench/Makefile]) AC_OUTPUT AC_MSG_RESULT([[ SigScheme has been configured as follows: base config: $use_conf [Storage configuration] Storage impl: $use_storage Fixnum size: $use_fixnum getcontext: $ax_cv_func_getcontext libgcroots: $use_libgcroots [Multibyte character handlings] Multibyte chars: ${use_multibyte_char:-no} Default encoding: $use_default_encoding UTF-8 codec: $use_utf8 EUC-CN codec: $use_euccn EUC-JP codec: $use_eucjp EUC-KR codec: $use_euckr Shift_JIS codec: $use_sjis [R5RS behaviors] Strict R5RS: $use_strict_r5rs Const list literal: $use_const_list_literal Const vector literal: $use_const_vector_literal Strict null form: $use_strict_null_form Strict vector form: $use_strict_vector_form Strict argcheck: $use_strict_argcheck Strict top-level defs: $use_strict_toplevel_definitions Internal definitions: $use_internal_definitions [R5RS features] Continuation: $use_continuation Quasiquote: $use_quasiquote Hygienic macros: $use_hygienic_macro Promise: $use_promise Integer: $use_int Numeric I/O: ${use_number_io:-no} Charcters: $use_char Strings: $use_string String procedures: ${use_string_procedure:-no} Deep c[ad]+r procs: $use_deep_cadrs Vectors: $use_vector Ports: $use_port Reader: $use_reader Writer: $use_writer Load: $use_load [SRFIs] SRFI-0: $use_srfi0 SRFI-1: $use_srfi1 SRFI-2: $use_srfi2 SRFI-6: $use_srfi6 SRFI-8: $use_srfi8 SRFI-9: $use_srfi9 SRFI-22: $use_srfi22 SRFI-23: $use_srfi23 SRFI-28: $use_srfi28 SRFI-34: $use_srfi34 SRFI-38: $use_srfi38 SRFI-43: $use_srfi43 SRFI-48: $use_srfi48 SRFI-55: $use_srfi55 SRFI-60: $use_srfi60 SRFI-69: $use_srfi69 SRFI-95: $use_srfi95 [R6RS features (preliminary)] R6RS characters: $use_r6rs_chars R6RS named chars: $use_r6rs_named_chars [SigScheme-specific extensions] define-macro: $use_legacy_macro SigScheme extensions: $use_sscm_extensions format+ procedure: $use_sscm_format_extension SIOD compatibilities: $use_compat_siod SIOD bugs emulation: $use_compat_siod_bugs eval_c_string(): $use_eval_c_string Backtrace: $use_backtrace Library: $use_libsscm Interactive shell: $use_shell [Developer-only debugging features] Debug: $use_debug]]) if test "x$use_debug" = xyes; then AC_MSG_RESULT( [[Debug port: $use_debug Debug parser: $use_debug Debug macro: $use_debug Debug encoding: $use_debug Soft assert: $use_soft_assert Accessor assert: $use_accessor_assert Warning suppressor: $use_warning_suppressor]]) fi AC_MSG_RESULT([[ [Build information (provide this on bug reports)] Package: $PACKAGE_STRING build (compile on): $ac_cv_build host (compile for): $ac_cv_host host data model: $ac_cv_data_model host align (C/S/I/L/P): ${ac_cv_alignof_char}/${ac_cv_alignof_short}/${ac_cv_alignof_int}/${ac_cv_alignof_long}/${ac_cv_alignof_void_p} host endian: $ax_c_endian host char unsigned: $ac_cv_c_char_unsigned host arithmetic rshift: $ax_cv_c_arithmetic_rshift host safe va_list ref: $ax_cv_c_referenceable_passed_va_list Compiler: $CC Compiler version: $ax_prog_cc_version CFLAGS='$CFLAGS']]) uim-1.8.8/sigscheme/lib/0000755000175000017500000000000013275405526012051 500000000000000uim-1.8.8/sigscheme/lib/srfi-95.scm0000644000175000017500000001560112532333147013670 00000000000000;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) ;;; ;;; This code is in the public domain. ;;; Updated: 11 June 1991 ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 ;;; Updated: 19 June 1995 ;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 ;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 ;;; jaffer: 2006-10-08: ;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. ;;; jaffer: 2006-11-05: ;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once ;;; per element. ;;; jaffer: 2007-01-29: Final SRFI-95. ;;; Copyright (c) 2007-2008 SigScheme Project ;; ChangeLog ;; ;; 2007-07-13 yamaken - Imported from SLIB CVS HEAD (revision 1.14) ;; http://cvs.savannah.gnu.org/viewvc/*checkout*/slib/slib/sort.scm?revision=1.14 ;; and adapted to SigScheme ;;(require 'array) ;; For SigScheme (define array? (if (symbol-bound? 'array?) (symbol-value 'array) (lambda (x) #f))) (define identity (if (symbol-bound? 'identity) (symbol-value 'identity) (lambda (x) x))) ;;; (sorted? sequence less?) ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) ;;; such that for all 1 <= i <= m, ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). ;@ (define (sorted? seq less? . opt-key) (define key (if (null? opt-key) identity (car opt-key))) (cond ((null? seq) #t) ((array? seq) (let ((dimax (+ -1 (car (array-dimensions seq))))) (or (<= dimax 1) (let loop ((idx (+ -1 dimax)) (last (key (array-ref seq dimax)))) (or (negative? idx) (let ((nxt (key (array-ref seq idx)))) (and (less? nxt last) (loop (+ -1 idx) nxt)))))))) ((null? (cdr seq)) #t) (else (let loop ((last (key (car seq))) (next (cdr seq))) (or (null? next) (let ((nxt (key (car next)))) (and (not (less? nxt last)) (loop nxt (cdr next))))))))) ;;; (merge a b less?) ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) ;;; and returns a new list in which the elements of a and b have been stably ;;; interleaved so that (sorted? (merge a b less?) less?). ;;; Note: this does _not_ accept arrays. See below. ;@ (define (merge a b less? . opt-key) (define key (if (null? opt-key) identity (car opt-key))) (cond ((null? a) b) ((null? b) a) (else (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) (y (car b)) (ky (key (car b))) (b (cdr b))) ;; The loop handles the merging of non-empty lists. It has ;; been written this way to save testing and car/cdring. (if (less? ky kx) (if (null? b) (cons y (cons x a)) (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) ;; x <= y (if (null? a) (cons x (cons y b)) (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) (define (sort:merge! a b less? key) (define (loop r a kcara b kcarb) (cond ((less? kcarb kcara) (set-cdr! r b) (if (null? (cdr b)) (set-cdr! b a) (loop b a kcara (cdr b) (key (cadr b))))) (else ; (car a) <= (car b) (set-cdr! r a) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) (key (cadr a)) b kcarb))))) (cond ((null? a) b) ((null? b) a) (else (let ((kcara (key (car a))) (kcarb (key (car b)))) (cond ((less? kcarb kcara) (if (null? (cdr b)) (set-cdr! b a) (loop b a kcara (cdr b) (key (cadr b)))) b) (else ; (car a) <= (car b) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) (key (cadr a)) b kcarb)) a)))))) ;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; single sorted list including the elements of both. ;;; Note: this does _not_ accept arrays. ;@ (define (merge! a b less? . opt-key) (sort:merge! a b less? (if (null? opt-key) identity (car opt-key)))) (define (sort:sort-list! seq less? key) (define keyer (if key car identity)) (define (step n) (cond ((> n 2) (let* ((j (quotient n 2)) (a (step j)) (k (- n j)) (b (step k))) (sort:merge! a b less? keyer))) ((= n 2) (let ((x (car seq)) (y (cadr seq)) (p seq)) (set! seq (cddr seq)) (cond ((less? (keyer y) (keyer x)) (set-car! p y) (set-car! (cdr p) x))) (set-cdr! (cdr p) '()) p)) ((= n 1) (let ((p seq)) (set! seq (cdr seq)) (set-cdr! p '()) p)) (else '()))) (define (key-wrap! lst) (cond ((null? lst)) (else (set-car! lst (cons (key (car lst)) (car lst))) (key-wrap! (cdr lst))))) (define (key-unwrap! lst) (cond ((null? lst)) (else (set-car! lst (cdar lst)) (key-unwrap! (cdr lst))))) (cond (key (key-wrap! seq) (set! seq (step (length seq))) (key-unwrap! seq) seq) (else (step (length seq))))) (define (rank-1-array->list array) (define dimensions (array-dimensions array)) (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) (lst '() (cons (array-ref array idx) lst))) ((< idx 0) lst))) ;;; (sort! sequence less?) ;;; sorts the list, array, or string sequence destructively. It uses ;;; a version of merge-sort invented, to the best of my knowledge, by ;;; David H. D. Warren, and first used in the DEC-10 Prolog system. ;;; R. A. O'Keefe adapted it to work destructively in Scheme. ;;; A. Jaffer modified to always return the original list. ;@ (define (sort! seq less? . opt-key) (define key (if (null? opt-key) #f (car opt-key))) (cond ((array? seq) (let ((dims (array-dimensions seq))) (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) (cdr sorted)) (i 0 (+ i 1))) ((null? sorted) seq) (array-set! seq (car sorted) i)))) (else ; otherwise, assume it is a list (let ((ret (sort:sort-list! seq less? key))) (if (not (eq? ret seq)) (do ((crt ret (cdr crt))) ((eq? (cdr crt) seq) (set-cdr! crt ret) (let ((scar (car seq)) (scdr (cdr seq))) (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) (set-car! ret scar) (set-cdr! ret scdr))))) seq)))) ;;; (sort sequence less?) ;;; sorts a array, string, or list non-destructively. It does this ;;; by sorting a copy of the sequence. My understanding is that the ;;; Standard says that the result of append is always "newly ;;; allocated" except for sharing structure with "the last argument", ;;; so (append x '()) ought to be a standard way of copying a list x. ;@ (define (sort seq less? . opt-key) (define key (if (null? opt-key) #f (car opt-key))) (cond ((array? seq) (let ((dims (array-dimensions seq))) (define newra (apply make-array seq dims)) (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) (cdr sorted)) (i 0 (+ i 1))) ((null? sorted) newra) (array-set! newra (car sorted) i)))) (else (sort:sort-list! (append seq '()) less? key)))) uim-1.8.8/sigscheme/lib/srfi-43.scm0000644000175000017500000016145312532333147013670 00000000000000;;;;;; SRFI 43: Vector library -*- Scheme -*- ;;; Taylor Campbell wrote this code; he places it in the public domain. ;; ChangeLog ;; ;; 2007-08-28 yamaken - Imported from ;; http://srfi.schemers.org/srfi-43/vector-lib.scm ;; and adapted to SigScheme ;; 2007-09-08 yamaken - Fix an incorrect error message in check-indices ;;; -------------------- ;;; Exported procedure index ;;; ;;; * Constructors ;;; make-vector vector ;;; vector-unfold vector-unfold-right ;;; vector-copy vector-reverse-copy ;;; vector-append vector-concatenate ;;; ;;; * Predicates ;;; vector? ;;; vector-empty? ;;; vector= ;;; ;;; * Selectors ;;; vector-ref ;;; vector-length ;;; ;;; * Iteration ;;; vector-fold vector-fold-right ;;; vector-map vector-map! ;;; vector-for-each ;;; vector-count ;;; ;;; * Searching ;;; vector-index vector-skip ;;; vector-index-right vector-skip-right ;;; vector-binary-search ;;; vector-any vector-every ;;; ;;; * Mutators ;;; vector-set! ;;; vector-swap! ;;; vector-fill! ;;; vector-reverse! ;;; vector-copy! vector-reverse-copy! ;;; vector-reverse! ;;; ;;; * Conversion ;;; vector->list reverse-vector->list ;;; list->vector reverse-list->vector ;;; -------------------- ;;; Commentary on efficiency of the code ;;; This code is somewhat tuned for efficiency. There are several ;;; internal routines that can be optimized greatly to greatly improve ;;; the performance of much of the library. These internal procedures ;;; are already carefully tuned for performance, and lambda-lifted by ;;; hand. Some other routines are lambda-lifted by hand, but only the ;;; loops are lambda-lifted, and only if some routine has two possible ;;; loops -- a fast path and an n-ary case --, whereas _all_ of the ;;; internal routines' loops are lambda-lifted so as to never cons a ;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop), ;;; even in Scheme systems that perform no loop optimization (which is ;;; most of them, unfortunately). ;;; ;;; Fast paths are provided for common cases in most of the loops in ;;; this library. ;;; ;;; All calls to primitive vector operations are protected by a prior ;;; type check; they can be safely converted to use unsafe equivalents ;;; of the operations, if available. Ideally, the compiler should be ;;; able to determine this, but the state of Scheme compilers today is ;;; not a happy one. ;;; ;;; Efficiency of the actual algorithms is a rather mundane point to ;;; mention; vector operations are rarely beyond being straightforward. ;;; -------------------- ;;; Utilities ;;; SigScheme: Use native SRFI-8 ;;;;; SRFI 8, too trivial to put in the dependencies list. ;;(define-syntax receive ;; (syntax-rules () ;; ((receive ?formals ?producer ?body1 ?body2 ...) ;; (call-with-values (lambda () ?producer) ;; (lambda ?formals ?body1 ?body2 ...))))) ;;; SigScheme: Define let*-optionals as an alias to let-optionals* ;;;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's ;;;;; if it's available to you. ;;(define-syntax let*-optionals ;; (syntax-rules () ;; ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...) ;; (let ((args (?x ...))) ;; (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...))) ;; ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...) ;; (let*-optionals:aux ?args ?args ((?var ?default) ...) ;; ?body1 ?body2 ...)))) ;; ;;(define-syntax let*-optionals:aux ;; (syntax-rules () ;; ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...) ;; (if (null? ?args-var) ;; (let () ?body1 ?body2 ...) ;; (error "too many arguments" (length ?orig-args-var) ;; ?orig-args-var))) ;; ((aux ?orig-args-var ?args-var ;; ((?var ?default) ?more ...) ;; ?body1 ?body2 ...) ;; (if (null? ?args-var) ;; (let* ((?var ?default) ?more ...) ?body1 ?body2 ...) ;; (let ((?var (car ?args-var)) ;; (new-args (cdr ?args-var))) ;; (let*-optionals:aux ?orig-args-var new-args ;; (?more ...) ;; ?body1 ?body2 ...)))))) (define (nonneg-int? x) (and (integer? x) (not (negative? x)))) (define (between? x y z) (and (< x y) (<= y z))) (define (unspecified-value) (if #f #f)) ;++ This should be implemented more efficiently. It shouldn't cons a ;++ closure, and the cons cells used in the loops when using this could ;++ be reused. (define (vectors-ref vectors i) (map (lambda (v) (vector-ref v i)) vectors)) ;;; -------------------- ;;; Error checking ;;; Error signalling (not checking) is done in a way that tries to be ;;; as helpful to the person who gets the debugging prompt as possible. ;;; That said, error _checking_ tries to be as unredundant as possible. ;;; I don't use any sort of general condition mechanism; I use simply ;;; SRFI 23's ERROR, even in cases where it might be better to use such ;;; a general condition mechanism. Fix that when porting this to a ;;; Scheme implementation that has its own condition system. ;;; In argument checks, upon receiving an invalid argument, the checker ;;; procedure recursively calls itself, but in one of the arguments to ;;; itself is a call to ERROR; this mechanism is used in the hopes that ;;; the user may be thrown into a debugger prompt, proceed with another ;;; value, and let it be checked again. ;;; Type checking is pretty basic, but easily factored out and replaced ;;; with whatever your implementation's preferred type checking method ;;; is. I doubt there will be many other methods of index checking, ;;; though the index checkers might be better implemented natively. ;;; (CHECK-TYPE ) -> value ;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an ;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing ;;; that this happened while calling CALLEE. Return VALUE if no ;;; error was signalled. (define (check-type pred? value callee) (if (pred? value) value ;; Recur: when (or if) the user gets a debugger prompt, he can ;; proceed where the call to ERROR was with the correct value. (check-type pred? (error "erroneous value" (list pred? value) `(while calling ,callee)) callee))) ;;; (CHECK-INDEX ) -> index ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an ;;; error stating that it is not and that this happened in a call to ;;; CALLEE. Return INDEX when it is valid. (Note that this does NOT ;;; check that VECTOR is indeed a vector.) (define (check-index vec index callee) (let ((index (check-type integer? index callee))) (cond ((< index 0) (check-index vec (error "vector index too low" index `(into vector ,vec) `(while calling ,callee)) callee)) ((>= index (vector-length vec)) (check-index vec (error "vector index too high" index `(into vector ,vec) `(while calling ,callee)) callee)) (else index)))) ;;; (CHECK-INDICES ;;; ;;; ;;; ) -> [start end] ;;; Ensure that START and END are valid bounds of a range within ;;; VECTOR; if not, signal an error stating that they are not, with ;;; the message being informative about what the argument names were ;;; called -- by using START-NAME & END-NAME --, and that it occurred ;;; while calling CALLEE. Also ensure that VEC is in fact a vector. ;;; Returns no useful value. (define (check-indices vec start start-name end end-name callee) (let ((lose (lambda things (apply error "vector range out of bounds" (append things `(vector was ,vec) `(,start-name was ,start) `(,end-name was ,end) `(while calling ,callee))))) (start (check-type integer? start callee)) (end (check-type integer? end callee))) (cond ((> start end) ;; I'm not sure how well this will work. The intent is that ;; the programmer tells the debugger to proceed with both a ;; new START & a new END by returning multiple values ;; somewhere. (receive (new-start new-end) (lose `(,end-name < ,start-name)) (check-indices vec new-start start-name new-end end-name callee))) ((< start 0) (check-indices vec (lose `(,start-name < 0)) start-name end end-name callee)) ((>= start (vector-length vec)) (check-indices vec (lose `(,start-name >= len) `(len was ,(vector-length vec))) start-name end end-name callee)) ((> end (vector-length vec)) (check-indices vec start start-name (lose `(,end-name > len) `(len was ,(vector-length vec))) end-name callee)) (else (values start end))))) ;;; -------------------- ;;; Internal routines ;;; These should all be integrated, native, or otherwise optimized -- ;;; they're used a _lot_ --. All of the loops and LETs inside loops ;;; are lambda-lifted by hand, just so as not to cons closures in the ;;; loops. (If your compiler can do better than that if they're not ;;; lambda-lifted, then lambda-drop (?) them.) ;;; (VECTOR-PARSE-START+END ;;; ;;; ) ;;; -> [start end] ;;; Return two values, composing a valid range within VECTOR, as ;;; extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START ;;; and the length of VECTOR for END --; START-NAME and END-NAME are ;;; purely for error checking. (define (vector-parse-start+end vec args start-name end-name callee) (let ((len (vector-length vec))) (cond ((null? args) (values 0 len)) ((null? (cdr args)) (check-indices vec (car args) start-name len end-name callee)) ((null? (cddr args)) (check-indices vec (car args) start-name (cadr args) end-name callee)) (else (error "too many arguments" `(extra args were ,(cddr args)) `(while calling ,callee)))))) ;;; SigScheme: Defined in module-srfi43.c ;;(define-syntax let-vector-start+end ;; (syntax-rules () ;; ((let-vector-start+end ?callee ?vec ?args (?start ?end) ;; ?body1 ?body2 ...) ;; (let ((?vec (check-type vector? ?vec ?callee))) ;; (receive (?start ?end) ;; (vector-parse-start+end ?vec ?args '?start '?end ;; ?callee) ;; ?body1 ?body2 ...))))) ;;; (%SMALLEST-LENGTH ) ;;; -> exact, nonnegative integer ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is ;;; the length that is returned if VECTOR-LIST is empty. Common use ;;; of this is in n-ary vector routines: ;;; (define (f vec . vectors) ;;; (let ((vec (check-type vector? vec f))) ;;; ...(%smallest-length vectors (vector-length vec) f)...)) ;;; %SMALLEST-LENGTH takes care of the type checking -- which is what ;;; the CALLEE argument is for --; thus, the design is tuned for ;;; avoiding redundant type checks. (define %smallest-length (letrec ((loop (lambda (vector-list length callee) (if (null? vector-list) length (loop (cdr vector-list) (min (vector-length (check-type vector? (car vector-list) callee)) length) callee))))) loop)) ;;; (%VECTOR-COPY! ) ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, ;;; starting at TSTART in TARGET. ;;; ;;; Optimize this! Probably with some combination of: ;;; - Force it to be integrated. ;;; - Let it use unsafe vector element dereferencing routines: bounds ;;; checking already happens outside of it. (Or use a compiler ;;; that figures this out, but Olin Shivers' PhD thesis seems to ;;; have been largely ignored in actual implementations...) ;;; - Implement it natively as a VM primitive: the VM can undoubtedly ;;; perform much faster than it can make Scheme perform, even with ;;; bounds checking. ;;; - Implement it in assembly: you _want_ the fine control that ;;; assembly can give you for this. ;;; I already lambda-lift it by hand, but you should be able to make it ;;; even better than that. (define %vector-copy! (letrec ((loop/l->r (lambda (target source send i j) (cond ((< i send) (vector-set! target j (vector-ref source i)) (loop/l->r target source send (+ i 1) (+ j 1)))))) (loop/r->l (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop/r->l target source sstart (- i 1) (- j 1))))))) (lambda (target tstart source sstart send) (if (> sstart tstart) ; Make sure we don't copy over ; ourselves. (loop/l->r target source send sstart tstart) (loop/r->l target source sstart (- send 1) (+ -1 tstart send (- sstart))))))) ;;; (%VECTOR-REVERSE-COPY! ) ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the ;;; reverse order. (define %vector-reverse-copy! (letrec ((loop (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop target source sstart (- i 1) (+ j 1))))))) (lambda (target tstart source sstart send) (loop target source sstart (- send 1) tstart)))) ;;; (%VECTOR-REVERSE! ) (define %vector-reverse! (letrec ((loop (lambda (vec i j) (cond ((<= i j) (let ((v (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j v) (loop vec (+ i 1) (- j 1)))))))) (lambda (vec start end) (loop vec start (- end 1))))) ;;; (%VECTOR-FOLD1 ) -> knil' ;;; (KONS ) -> knil' (define %vector-fold1 (letrec ((loop (lambda (kons knil len vec i) (if (= i len) knil (loop kons (kons i knil (vector-ref vec i)) len vec (+ i 1)))))) (lambda (kons knil len vec) (loop kons knil len vec 0)))) ;;; (%VECTOR-FOLD2+ ...) -> knil' ;;; (KONS ...) -> knil' (define %vector-fold2+ (letrec ((loop (lambda (kons knil len vectors i) (if (= i len) knil (loop kons (apply kons i knil (vectors-ref vectors i)) len vectors (+ i 1)))))) (lambda (kons knil len vectors) (loop kons knil len vectors 0)))) ;;; (%VECTOR-MAP! ) -> target ;;; (F ) -> elt' (define %vector-map1! (letrec ((loop (lambda (f target vec i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (f j (vector-ref vec j))) (loop f target vec j)))))) (lambda (f target vec len) (loop f target vec len)))) ;;; (%VECTOR-MAP2+! ) -> target ;;; (F ...) -> elt' (define %vector-map2+! (letrec ((loop (lambda (f target vectors i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (apply f j (vectors-ref vectors j))) (loop f target vectors j)))))) (lambda (f target vectors len) (loop f target vectors len)))) ;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;; ;;; -------------------- ;;; Constructors ;;; (MAKE-VECTOR []) -> vector ;;; [R5RS] Create a vector of length LENGTH. If FILL is present, ;;; initialize each slot in the vector with it; if not, the vector's ;;; initial contents are unspecified. (define make-vector make-vector) ;;; (VECTOR ...) -> vector ;;; [R5RS] Create a vector containing ELEMENT ..., in order. (define vector vector) ;;; This ought to be able to be implemented much more efficiently -- if ;;; we have the number of arguments available to us, we can create the ;;; vector without using LENGTH to determine the number of elements it ;;; should have. ;(define (vector . elements) (list->vector elements)) ;;; (VECTOR-UNFOLD ...) -> vector ;;; (F ...) -> [elt seed' ...] ;;; The fundamental vector constructor. Creates a vector whose ;;; length is LENGTH and iterates across each index K between 0 and ;;; LENGTH, applying F at each iteration to the current index and the ;;; current seeds to receive N+1 values: first, the element to put in ;;; the Kth slot and then N new seeds for the next iteration. (define vector-unfold (letrec ((tabulate! ; Special zero-seed case. (lambda (f vec i len) (cond ((< i len) (vector-set! vec i (f i)) (tabulate! f vec (+ i 1) len))))) (unfold1! ; Fast path for one seed. (lambda (f vec i len seed) (if (< i len) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (+ i 1) len new-seed))))) (unfold2+! ; Slower variant for N seeds. (lambda (f vec i len seeds) (if (< i len) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (+ i 1) len new-seeds)))))) (lambda (f len . initial-seeds) (let ((f (check-type procedure? f vector-unfold)) (len (check-type nonneg-int? len vector-unfold))) (let ((vec (make-vector len))) (cond ((null? initial-seeds) (tabulate! f vec 0 len)) ((null? (cdr initial-seeds)) (unfold1! f vec 0 len (car initial-seeds))) (else (unfold2+! f vec 0 len initial-seeds))) vec))))) ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector ;;; (F ...) -> [seed' ...] ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to ;;; LENGTH as with VECTOR-UNFOLD. (define vector-unfold-right (letrec ((tabulate! (lambda (f vec i) (cond ((>= i 0) (vector-set! vec i (f i)) (tabulate! f vec (- i 1)))))) (unfold1! (lambda (f vec i seed) (if (>= i 0) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (- i 1) new-seed))))) (unfold2+! (lambda (f vec i seeds) (if (>= i 0) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (- i 1) new-seeds)))))) (lambda (f len . initial-seeds) (let ((f (check-type procedure? f vector-unfold-right)) (len (check-type nonneg-int? len vector-unfold-right))) (let ((vec (make-vector len)) (i (- len 1))) (cond ((null? initial-seeds) (tabulate! f vec i)) ((null? (cdr initial-seeds)) (unfold1! f vec i (car initial-seeds))) (else (unfold2+! f vec i initial-seeds))) vec))))) ;;; (VECTOR-COPY [ ]) -> vector ;;; Create a newly allocated vector containing the elements from the ;;; range [START,END) in VECTOR. START defaults to 0; END defaults ;;; to the length of VECTOR. END may be greater than the length of ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, ;;; the new locations from which there is no respective element in ;;; VECTOR are filled with FILL. (define (vector-copy vec . args) (let ((vec (check-type vector? vec vector-copy))) ;; We can't use LET-VECTOR-START+END, because we have one more ;; argument, and we want finer control, too. ;; ;; Olin's implementation of LET*-OPTIONALS would prove useful here: ;; the built-in argument-checks-as-you-go-along produces almost ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS. (receive (start end fill) (vector-copy:parse-args vec args) (let ((new-vector (make-vector (- end start) fill))) (%vector-copy! new-vector 0 vec start (if (> end (vector-length vec)) (vector-length vec) end)) new-vector)))) ;;; Auxiliary for VECTOR-COPY. (define (vector-copy:parse-args vec args) (if (null? args) (values 0 (vector-length vec) (unspecified-value)) (let ((start (check-index vec (car args) vector-copy))) (if (null? (cdr args)) (values start (vector-length vec) (unspecified-value)) (let ((end (check-type nonneg-int? (cadr args) vector-copy))) (cond ((>= start (vector-length vec)) (error "start bound out of bounds" `(start was ,start) `(end was ,end) `(vector was ,vec) `(while calling ,vector-copy))) ((> start end) (error "can't invert a vector copy!" `(start was ,start) `(end was ,end) `(vector was ,vec) `(while calling ,vector-copy))) ((null? (cddr args)) (values start end (unspecified-value))) (else (let ((fill (caddr args))) (if (null? (cdddr args)) (values start end fill) (error "too many arguments" vector-copy (cdddr args))))))))))) ;;; (VECTOR-REVERSE-COPY [ ]) -> vector ;;; Create a newly allocated vector whose elements are the reversed ;;; sequence of elements between START and END in VECTOR. START's ;;; default is 0; END's default is the length of VECTOR. (define (vector-reverse-copy vec . maybe-start+end) (let-vector-start+end vector-reverse-copy vec maybe-start+end (start end) (let ((new (make-vector (- end start)))) (%vector-reverse-copy! new 0 vec start end) new))) ;;; (VECTOR-APPEND ...) -> vector ;;; Append VECTOR ... into a newly allocated vector and return that ;;; new vector. (define (vector-append . vectors) (vector-concatenate:aux vectors vector-append)) ;;; (VECTOR-CONCATENATE ) -> vector ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to ;;; (apply vector-append VECTOR-LIST) ;;; but VECTOR-APPEND tends to be implemented in terms of ;;; VECTOR-CONCATENATE, and some Schemes bork when the list to apply ;;; a function to is too long. ;;; ;;; Actually, they're both implemented in terms of an internal routine. (define (vector-concatenate vector-list) (vector-concatenate:aux vector-list vector-concatenate)) ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE (define vector-concatenate:aux (letrec ((compute-length (lambda (vectors len callee) (if (null? vectors) len (let ((vec (check-type vector? (car vectors) callee))) (compute-length (cdr vectors) (+ (vector-length vec) len) callee))))) (concatenate! (lambda (vectors target to) (if (null? vectors) target (let* ((vec1 (car vectors)) (len (vector-length vec1))) (%vector-copy! target to vec1 0 len) (concatenate! (cdr vectors) target (+ to len))))))) (lambda (vectors callee) (cond ((null? vectors) ;+++ (make-vector 0)) ((null? (cdr vectors)) ;+++ ;; Blech, we still have to allocate a new one. (let* ((vec (check-type vector? (car vectors) callee)) (len (vector-length vec)) (new (make-vector len))) (%vector-copy! new 0 vec 0 len) new)) (else (let ((new-vector (make-vector (compute-length vectors 0 callee)))) (concatenate! vectors new-vector 0) new-vector)))))) ;;; -------------------- ;;; Predicates ;;; (VECTOR? ) -> boolean ;;; [R5RS] Return #T if VALUE is a vector and #F if not. (define vector? vector?) ;;; (VECTOR-EMPTY? ) -> boolean ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length ;;; is 0, and #F if not. (define (vector-empty? vec) (let ((vec (check-type vector? vec vector-empty?))) (zero? (vector-length vec)))) ;;; (VECTOR= ...) -> boolean ;;; (ELT=? ) -> boolean ;;; Determine vector equality generalized across element comparators. ;;; Vectors A and B are equal iff their lengths are the same and for ;;; each respective elements E_a and E_b (element=? E_a E_b) returns ;;; a true value. ELT=? is always applied to two arguments. Element ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a ;;; true value. This may be exploited to avoid multiple unnecessary ;;; element comparisons. (This implementation does, but does not deal ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary ;;; comparisons, but I believe this optimization is probably fairly ;;; insignificant.) ;;; ;;; If the number of vector arguments is zero or one, then #T is ;;; automatically returned. If there are N vector arguments, ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N ;;; are compared. The precise order in which ELT=? is applied is not ;;; specified. (define (vector= elt=? . vectors) (let ((elt=? (check-type procedure? elt=? vector=))) (cond ((null? vectors) #t) ((null? (cdr vectors)) (check-type vector? (car vectors) vector=) #t) (else (let loop ((vecs vectors)) (let ((vec1 (check-type vector? (car vecs) vector=)) (vec2+ (cdr vecs))) (or (null? vec2+) (and (binary-vector= elt=? vec1 (car vec2+)) (loop vec2+))))))))) (define (binary-vector= elt=? vector-a vector-b) (or (eq? vector-a vector-b) ;+++ (let ((length-a (vector-length vector-a)) (length-b (vector-length vector-b))) (letrec ((loop (lambda (i) (or (= i length-a) (and (< i length-b) (test (vector-ref vector-a i) (vector-ref vector-b i) i))))) (test (lambda (elt-a elt-b i) (and (or (eq? elt-a elt-b) ;+++ (elt=? elt-a elt-b)) (loop (+ i 1)))))) (and (= length-a length-b) (loop 0)))))) ;;; -------------------- ;;; Selectors ;;; (VECTOR-REF ) -> value ;;; [R5RS] Return the value that the location in VECTOR at INDEX is ;;; mapped to in the store. (define vector-ref vector-ref) ;;; (VECTOR-LENGTH ) -> exact, nonnegative integer ;;; [R5RS] Return the length of VECTOR. (define vector-length vector-length) ;;; -------------------- ;;; Iteration ;;; (VECTOR-FOLD ...) -> knil ;;; (KONS ...) -> knil' ; N vectors -> N+1 args ;;; The fundamental vector iterator. KONS is iterated over each ;;; index in all of the vectors in parallel, stopping at the end of ;;; the shortest; KONS is applied to an argument list of (list I ;;; STATE (vector-ref VEC I) ...), where STATE is the current state ;;; value -- the state value begins with KNIL and becomes whatever ;;; KONS returned at the respective iteration --, and I is the ;;; current index in the iteration. The iteration is strictly left- ;;; to-right. ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) (define (vector-fold kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold)) (vec (check-type vector? vec vector-fold))) (if (null? vectors) (%vector-fold1 kons knil (vector-length vec) vec) (%vector-fold2+ kons knil (%smallest-length vectors (vector-length vec) vector-fold) (cons vec vectors))))) ;;; (VECTOR-FOLD-RIGHT ...) -> knil ;;; (KONS ...) -> knil' ; N vectors => N+1 args ;;; The fundamental vector recursor. Iterates in parallel across ;;; VECTOR ... right to left, applying KONS to the elements and the ;;; current state value; the state value becomes what KONS returns ;;; at each next iteration. KNIL is the initial state value. ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) ;;; ;;; Not implemented in terms of a more primitive operations that might ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very ;;; useful elsewhere. (define vector-fold-right (letrec ((loop1 (lambda (kons knil vec i) (if (negative? i) knil (loop1 kons (kons i knil (vector-ref vec i)) vec (- i 1))))) (loop2+ (lambda (kons knil vectors i) (if (negative? i) knil (loop2+ kons (apply kons i knil (vectors-ref vectors i)) vectors (- i 1)))))) (lambda (kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold-right)) (vec (check-type vector? vec vector-fold-right))) (if (null? vectors) (loop1 kons knil vec (- (vector-length vec) 1)) (loop2+ kons knil (cons vec vectors) (- (%smallest-length vectors (vector-length vec) vector-fold-right) 1))))))) ;;; (VECTOR-MAP ...) -> vector ;;; (F ...) -> value ; N vectors -> N args ;;; Constructs a new vector of the shortest length of the vector ;;; arguments. Each element at index I of the new vector is mapped ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The ;;; dynamic order of application of F is unspecified. (define (vector-map f vec . vectors) (let ((f (check-type procedure? f vector-map)) (vec (check-type vector? vec vector-map))) (if (null? vectors) (let ((len (vector-length vec))) (%vector-map1! f (make-vector len) vec len)) (let ((len (%smallest-length vectors (vector-length vec) vector-map))) (%vector-map2+! f (make-vector len) (cons vec vectors) len))))) ;;; (VECTOR-MAP! ...) -> unspecified ;;; (F ...) -> element' ; N vectors -> N args ;;; Similar to VECTOR-MAP, but rather than mapping the new elements ;;; into a new vector, the new mapped elements are destructively ;;; inserted into the first vector. Again, the dynamic order of ;;; application of F is unspecified, so it is dangerous for F to ;;; manipulate the first VECTOR. (define (vector-map! f vec . vectors) (let ((f (check-type procedure? f vector-map!)) (vec (check-type vector? vec vector-map!))) (if (null? vectors) (%vector-map1! f vec vec (vector-length vec)) (%vector-map2+! f vec (cons vec vectors) (%smallest-length vectors (vector-length vec) vector-map!))) (unspecified-value))) ;;; (VECTOR-FOR-EACH ...) -> unspecified ;;; (F ...) ; N vectors -> N args ;;; Simple vector iterator: applies F to each index in the range [0, ;;; LENGTH), where LENGTH is the length of the smallest vector ;;; argument passed, and the respective element at that index. In ;;; contrast with VECTOR-MAP, F is reliably applied to each ;;; subsequent elements, starting at index 0 from left to right, in ;;; the vectors. (define vector-for-each (letrec ((for-each1 (lambda (f vec i len) (cond ((< i len) (f i (vector-ref vec i)) (for-each1 f vec (+ i 1) len))))) (for-each2+ (lambda (f vecs i len) (cond ((< i len) (apply f i (vectors-ref vecs i)) (for-each2+ f vecs (+ i 1) len)))))) (lambda (f vec . vectors) (let ((f (check-type procedure? f vector-for-each)) (vec (check-type vector? vec vector-for-each))) (if (null? vectors) (for-each1 f vec 0 (vector-length vec)) (for-each2+ f (cons vec vectors) 0 (%smallest-length vectors (vector-length vec) vector-for-each))))))) ;;; (VECTOR-COUNT ...) ;;; -> exact, nonnegative integer ;;; (PREDICATE? ...) ; N vectors -> N+1 args ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., ;;; and a count is tallied of the number of elements for which a ;;; true value is produced by PREDICATE?. This count is returned. (define (vector-count pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-count)) (vec (check-type vector? vec vector-count))) (if (null? vectors) (%vector-fold1 (lambda (index count elt) (if (pred? index elt) (+ count 1) count)) 0 (vector-length vec) vec) (%vector-fold2+ (lambda (index count . elts) (if (apply pred? index elts) (+ count 1) count)) 0 (%smallest-length vectors (vector-length vec) vector-count) (cons vec vectors))))) ;;; -------------------- ;;; Searching ;;; (VECTOR-INDEX ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Search left-to-right across VECTOR ... in parallel, returning the ;;; index of the first set of values VALUE ... such that (PREDICATE? ;;; VALUE ...) returns a true value; if no such set of elements is ;;; reached, return #F. (define (vector-index pred? vec . vectors) (vector-index/skip pred? vec vectors vector-index)) ;;; (VECTOR-SKIP ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) ;;; VECTOR ...) ;;; Like VECTOR-INDEX, but find the index of the first set of values ;;; that do _not_ satisfy PREDICATE?. (define (vector-skip pred? vec . vectors) (vector-index/skip (lambda elts (not (apply pred? elts))) vec vectors vector-skip)) ;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP (define vector-index/skip (letrec ((loop1 (lambda (pred? vec len i) (cond ((= i len) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec len (+ i 1)))))) (loop2+ (lambda (pred? vectors len i) (cond ((= i len) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors len (+ i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (vector-length vec) 0) (loop2+ pred? (cons vec vectors) (%smallest-length vectors (vector-length vec) callee) 0)))))) ;;; (VECTOR-INDEX-RIGHT ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-INDEX. (define (vector-index-right pred? vec . vectors) (vector-index/skip-right pred? vec vectors vector-index-right)) ;;; (VECTOR-SKIP-RIGHT ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-SKIP. (define (vector-skip-right pred? vec . vectors) (vector-index/skip-right (lambda elts (not (apply pred? elts))) vec vectors vector-index-right)) (define vector-index/skip-right (letrec ((loop1 (lambda (pred? vec i) (cond ((negative? i) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec (- i 1)))))) (loop2+ (lambda (pred? vectors i) (cond ((negative? i) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors (- i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (- (vector-length vec) 1)) (loop2+ pred? (cons vec vectors) (- (%smallest-length vectors (vector-length vec) callee) 1))))))) ;;; (VECTOR-BINARY-SEARCH [ ]) ;;; -> exact, nonnegative integer or #F ;;; (CMP ) -> integer ;;; positive -> VALUE1 > VALUE2 ;;; zero -> VALUE1 = VALUE2 ;;; negative -> VALUE1 < VALUE2 ;;; Perform a binary search through VECTOR for VALUE, comparing each ;;; element to VALUE with CMP. (define (vector-binary-search vec value cmp . maybe-start+end) (let ((cmp (check-type procedure? cmp vector-binary-search))) (let-vector-start+end vector-binary-search vec maybe-start+end (start end) (let loop ((start start) (end end) (j #f)) (let ((i (quotient (+ start end) 2))) (if (or (= start end) (and j (= i j))) #f (let ((comparison (check-type integer? (cmp (vector-ref vec i) value) `(,cmp for ,vector-binary-search)))) (cond ((zero? comparison) i) ((positive? comparison) (loop start i i)) (else (loop i end i)))))))))) ;;; (VECTOR-ANY ...) -> value ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? ;;; should ever return a true value, immediately stop and return that ;;; value; otherwise, when the shortest vector runs out, return #F. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-any (letrec ((loop1 (lambda (pred? vec i len len-1) (and (not (= i len)) (if (= i len-1) (pred? (vector-ref vec i)) (or (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (and (not (= i len)) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (or (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-any)) (vec (check-type vector? vec vector-any))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-any))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; (VECTOR-EVERY ...) -> value ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? ;;; should ever return #F, immediately stop and return #F; otherwise, ;;; if PRED? should return a true value for each element, stopping at ;;; the end of the shortest vector, return the last value that PRED? ;;; returned. In the case that there is an empty vector, return #T. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-every (letrec ((loop1 (lambda (pred? vec i len len-1) (or (= i len) (if (= i len-1) (pred? (vector-ref vec i)) (and (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (or (= i len) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (and (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-every)) (vec (check-type vector? vec vector-every))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-every))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; -------------------- ;;; Mutators ;;; (VECTOR-SET! ) -> unspecified ;;; [R5RS] Assign the location at INDEX in VECTOR to VALUE. (define vector-set! vector-set!) ;;; (VECTOR-SWAP! ) -> unspecified ;;; Swap the values in the locations at INDEX1 and INDEX2. (define (vector-swap! vec i j) (let ((vec (check-type vector? vec vector-swap!))) (let ((i (check-index vec i vector-swap!)) (j (check-index vec j vector-swap!))) (let ((x (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j x))))) ;;; (VECTOR-FILL! [ ]) -> unspecified ;;; [R5RS+] Fill the locations in VECTOR between START, whose default ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. ;;; ;;; This one can probably be made really fast natively. (define vector-fill! (let ((%vector-fill! vector-fill!)) ; Take the native one, under ; the assumption that it's ; faster, so we can use it if ; there are no optional ; arguments. (lambda (vec value . maybe-start+end) (if (null? maybe-start+end) (%vector-fill! vec value) ;+++ (let-vector-start+end vector-fill! vec maybe-start+end (start end) (do ((i start (+ i 1))) ((= i end)) (vector-set! vec i value))))))) ;;; (VECTOR-COPY! [ ]) ;;; -> unspecified ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to ;;; to TARGET, starting at TSTART in TARGET. (define (vector-copy! target tstart source . maybe-sstart+send) (let* ((target (check-type vector? target vector-copy!)) (tstart (check-index target tstart vector-copy!))) (let-vector-start+end vector-copy! source maybe-sstart+send (sstart send) (let* ((source-length (vector-length source)) (lose (lambda (argument) (error "vector range out of bounds" argument `(while calling ,vector-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send))))) (cond ((< sstart 0) (lose '(sstart < 0))) ((< send 0) (lose '(send < 0))) ((> sstart send) (lose '(sstart > send))) ((>= sstart source-length) (lose '(sstart >= source-length))) ((> send source-length) (lose '(send > source-length))) (else (%vector-copy! target tstart source sstart send))))))) ;;; (VECTOR-REVERSE-COPY! [ ]) (define (vector-reverse-copy! target tstart source . maybe-sstart+send) (let* ((target (check-type vector? target vector-reverse-copy!)) (tstart (check-index target tstart vector-reverse-copy!))) (let-vector-start+end vector-reverse-copy source maybe-sstart+send (sstart send) (let* ((source-length (vector-length source)) (lose (lambda (argument) (error "vector range out of bounds" argument `(while calling ,vector-reverse-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send))))) (cond ((< sstart 0) (lose '(sstart < 0))) ((< send 0) (lose '(send < 0))) ((> sstart send) (lose '(sstart > send))) ((>= sstart source-length) (lose '(sstart >= source-length))) ((> send source-length) (lose '(send > source-length))) ((and (eq? target source) (= sstart tstart)) (%vector-reverse! target tstart send)) ((and (eq? target source) (or (between? sstart tstart send) (between? tstart sstart (+ tstart (- send sstart))))) (error "vector range for self-copying overlaps" vector-reverse-copy! `(vector was ,target) `(tstart was ,tstart) `(sstart was ,sstart) `(send was ,send))) (else (%vector-reverse-copy! target tstart source sstart send))))))) ;;; (VECTOR-REVERSE! [ ]) -> unspecified ;;; Destructively reverse the contents of the sequence of locations ;;; in VECTOR between START, whose default is 0, and END, whose ;;; default is the length of VECTOR. (define (vector-reverse! vec . start+end) (let-vector-start+end vector-reverse! vec start+end (start end) (%vector-reverse! vec start end))) ;;; -------------------- ;;; Conversion ;;; (VECTOR->LIST [ ]) -> list ;;; [R5RS+] Produce a list containing the elements in the locations ;;; between START, whose default is 0, and END, whose default is the ;;; length of VECTOR, from VECTOR. (define vector->list (let ((%vector->list vector->list)) (lambda (vec . maybe-start+end) (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA. (%vector->list vec) ;+++ (let-vector-start+end vector->list vec maybe-start+end (start end) ;(unfold (lambda (i) ; No SRFI 1. ; (< i start)) ; (lambda (i) (vector-ref vec i)) ; (lambda (i) (- i 1)) ; (- end 1)) (do ((i (- end 1) (- i 1)) (result '() (cons (vector-ref vec i) result))) ((< i start) result))))))) ;;; (REVERSE-VECTOR->LIST [ ]) -> list ;;; Produce a list containing the elements in the locations between ;;; START, whose default is 0, and END, whose default is the length ;;; of VECTOR, from VECTOR, in reverse order. (define (reverse-vector->list vec . maybe-start+end) (let-vector-start+end reverse-vector->list vec maybe-start+end (start end) ;(unfold (lambda (i) (= i end)) ; No SRFI 1. ; (lambda (i) (vector-ref vec i)) ; (lambda (i) (+ i 1)) ; start) (do ((i start (+ i 1)) (result '() (cons (vector-ref vec i) result))) ((= i end) result)))) ;;; (LIST->VECTOR [ ]) -> vector ;;; [R5RS+] Produce a vector containing the elements in LIST, which ;;; must be a proper list, between START, whose default is 0, & END, ;;; whose default is the length of LIST. It is suggested that if the ;;; length of LIST is known in advance, the START and END arguments ;;; be passed, so that LIST->VECTOR need not call LENGTH to determine ;;; the the length. ;;; ;;; This implementation diverges on circular lists, unless LENGTH fails ;;; and causes - to fail as well. Given a LENGTH* that computes the ;;; length of a list's cycle, this wouldn't diverge, and would work ;;; great for circular lists. (define list->vector (let ((%list->vector list->vector)) (lambda (lst . maybe-start+end) ;; Checking the type of a proper list is expensive, so we do it ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it. (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA. (%list->vector lst) ;+++ ;; We can't use LET-VECTOR-START+END, because we're using the ;; bounds of a _list_, not a vector. (let*-optionals maybe-start+end ((start 0) (end (length lst))) ; Ugh -- LENGTH (let ((start (check-type nonneg-int? start list->vector)) (end (check-type nonneg-int? end list->vector))) ((lambda (f) (vector-unfold f (- end start) (list-tail lst start))) (lambda (index l) (cond ((null? l) (error "list was too short" `(list was ,lst) `(attempted end was ,end) `(while calling ,list->vector))) ((pair? l) (values (car l) (cdr l))) (else ;; Make this look as much like what CHECK-TYPE ;; would report as possible. (error "erroneous value" ;; We want SRFI 1's PROPER-LIST?, but it ;; would be a waste to link all of SRFI ;; 1 to this module for only the single ;; function PROPER-LIST?. (list list? lst) `(while calling ,list->vector)))))))))))) ;;; (REVERSE-LIST->VECTOR [ ]) -> vector ;;; Produce a vector containing the elements in LIST, which must be a ;;; proper list, between START, whose default is 0, and END, whose ;;; default is the length of LIST, in reverse order. It is suggested ;;; that if the length of LIST is known in advance, the START and END ;;; arguments be passed, so that REVERSE-LIST->VECTOR need not call ;;; LENGTH to determine the the length. ;;; ;;; This also diverges on circular lists unless, again, LENGTH returns ;;; something that makes - bork. (define (reverse-list->vector lst . maybe-start+end) (let*-optionals maybe-start+end ((start 0) (end (length lst))) ; Ugh -- LENGTH (let ((start (check-type nonneg-int? start reverse-list->vector)) (end (check-type nonneg-int? end reverse-list->vector))) ((lambda (f) (vector-unfold-right f (- end start) (list-tail lst start))) (lambda (index l) (cond ((null? l) (error "list too short" `(list was ,lst) `(attempted end was ,end) `(while calling ,reverse-list->vector))) ((pair? l) (values (car l) (cdr l))) (else (error "erroneous value" (list list? lst) `(while calling ,reverse-list->vector))))))))) uim-1.8.8/sigscheme/lib/Makefile.am0000644000175000017500000000126312532333147014021 00000000000000dist_scmlib_DATA = sigscheme-init.scm unittest.scm if USE_SRFI0 dist_scmlib_DATA += srfi-0.scm endif if USE_SRFI1 dist_scmlib_DATA += srfi-1.scm endif if USE_SRFI9 dist_scmlib_DATA += srfi-9.scm endif if USE_SRFI43 dist_scmlib_DATA += srfi-43.scm endif if USE_SRFI55 dist_scmlib_DATA += srfi-55.scm endif if USE_SRFI69 dist_scmlib_DATA += srfi-69.scm endif if USE_SRFI95 dist_scmlib_DATA += srfi-95.scm endif # Install into master package's pkgdatadir if --with-master-pkg is specified # e.g.) # --without-master-pkg -> /usr/share/sigscheme/lib/srfi-1.scm # --with-master-pkg=uim -> /usr/share/uim/lib/srfi-1.scm if WITH_MASTER_PKG pkgdatadir = ${datadir}/${SSCM_MASTER_PKG} endif uim-1.8.8/sigscheme/lib/srfi-9.scm0000644000175000017500000002145012532333147013602 00000000000000;; Copyright (C) Richard Kelsey (1999). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; ChangeLog ;; ;; 2007-07-23 yamaken - Imported from ;; http://srfi.schemers.org/srfi-9/srfi-9.html ;; and adapted to SigScheme ;; 2007-09-04 yamaken - Fix (real-eval `(lambda (vector?) ,exp)) ;; with (real-eval `(lambda (vector?) ,exp) env) ;; - Suppress overriding of 'eval' since current SigScheme ;; implementation (0.8.0) does not need the vector? ;; trick. It allows (interaction-environment). ;; This code is divided into three layers. In top-down order these are: ;; ;; 1. Syntax definitions for DEFINE-RECORD-TYPE and an auxillary macro. ;; 2. An implementation of record types with a procedural interface. Some ;; Scheme implementations already have something close to this. ;; 3. Vector-like records implemented in R5RS. This redefines some standard ;; Scheme procedures and therefor must be loaded before any other code, ;; including part 2 above. Note that these procedures can be used to ;; break the record-type abstraction (for example, RECORD-SET! can be ;; used to modify the type of a record). Access to these procedures ;; should be restricted. ;; ;; Syntax definitions ;; ; Definition of DEFINE-RECORD-TYPE ;;(define-syntax define-record-type ;; (syntax-rules () ;; ((define-record-type type ;; (constructor constructor-tag ...) ;; predicate ;; (field-tag accessor . more) ...) ;; (begin ;; (define type ;; (make-record-type 'type '(field-tag ...))) ;; (define constructor ;; (record-constructor type '(constructor-tag ...))) ;; (define predicate ;; (record-predicate type)) ;; (define-record-field type field-tag accessor . more) ;; ...)))) ; An auxilliary macro for define field accessors and modifiers. ; This is needed only because modifiers are optional. ;;(define-syntax define-record-field ;; (syntax-rules () ;; ((define-record-field type field-tag accessor) ;; (define accessor (record-accessor type 'field-tag))) ;; ((define-record-field type field-tag accessor modifier) ;; (begin ;; (define accessor (record-accessor type 'field-tag)) ;; (define modifier (record-modifier type 'field-tag)))))) ;; ;; Records ;; ; This implements a record abstraction that is identical to vectors, ; except that they are not vectors (VECTOR? returns false when given a ; record and RECORD? returns false when given a vector). The following ; procedures are provided: ; (record? ) -> ; (make-record ) -> ; (record-ref ) -> ; (record-set! ) -> ; ; These can implemented in R5RS Scheme as vectors with a distinguishing ; value at index zero, providing VECTOR? is redefined to be a procedure ; that returns false if its argument contains the distinguishing record ; value. EVAL is also redefined to use the new value of VECTOR?. ; Define the marker and redefine VECTOR? and EVAL. (define record-marker (list 'record-marker)) (define real-vector? vector?) (define (vector? x) (and (real-vector? x) (or (= 0 (vector-length x)) (not (eq? (vector-ref x 0) record-marker))))) (cond-expand (sigscheme ;; Current SigScheme implementation does not need the vector? trick. #t) (else ; This won't work if ENV is the interaction environment and someone has ; redefined LAMBDA there. (define eval (let ((real-eval eval)) (lambda (exp env) ((real-eval `(lambda (vector?) ,exp) env) vector?)))) )) ; Definitions of the record procedures. (define (record? x) (and (real-vector? x) (< 0 (vector-length x)) (eq? (vector-ref x 0) record-marker))) (define (make-record size) (let ((new (make-vector (+ size 1)))) (vector-set! new 0 record-marker) new)) (define (record-ref record index) (vector-ref record (+ index 1))) (define (record-set! record index value) (vector-set! record (+ index 1) value)) ;; ;; Record types ;; ; We define the following procedures: ; ; (make-record-type ) -> ; (record-constructor ) -> ; (record-predicate ) -> ; (record-accessor ) -> ; (record-modifier ) -> ; where ; ( ...) -> ; ( ) -> ; ( ) -> ; ( ) -> ; Record types are implemented using vector-like records. The first ; slot of each record contains the record's type, which is itself a ; record. (define (record-type record) (record-ref record 0)) ;---------------- ; Record types are themselves records, so we first define the type for ; them. Except for problems with circularities, this could be defined as: ; (define-record-type :record-type ; (make-record-type name field-tags) ; record-type? ; (name record-type-name) ; (field-tags record-type-field-tags)) ; As it is, we need to define everything by hand. (define :record-type (make-record 3)) (record-set! :record-type 0 :record-type) ; Its type is itself. (record-set! :record-type 1 ':record-type) (record-set! :record-type 2 '(name field-tags)) ; Now that :record-type exists we can define a procedure for making more ; record types. (define (make-record-type name field-tags) (let ((new (make-record 3))) (record-set! new 0 :record-type) (record-set! new 1 name) (record-set! new 2 field-tags) new)) ; Accessors for record types. (define (record-type-name record-type) (record-ref record-type 1)) (define (record-type-field-tags record-type) (record-ref record-type 2)) ;---------------- ; A utility for getting the offset of a field within a record. (define (field-index type tag) (let loop ((i 1) (tags (record-type-field-tags type))) (cond ((null? tags) (error "record type has no such field" type tag)) ((eq? tag (car tags)) i) (else (loop (+ i 1) (cdr tags)))))) ;---------------- ; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the ; procedures used by the macro expansion of DEFINE-RECORD-TYPE. (define (record-constructor type tags) (let ((size (length (record-type-field-tags type))) (arg-count (length tags)) (indexes (map (lambda (tag) (field-index type tag)) tags))) (lambda args (if (= (length args) arg-count) (let ((new (make-record (+ size 1)))) (record-set! new 0 type) (for-each (lambda (arg i) (record-set! new i arg)) args indexes) new) (error "wrong number of arguments to constructor" type args))))) (define (record-predicate type) (lambda (thing) (and (record? thing) (eq? (record-type thing) type)))) (define (record-accessor type tag) (let ((index (field-index type tag))) (lambda (thing) (if (and (record? thing) (eq? (record-type thing) type)) (record-ref thing index) (error "accessor applied to bad value" type tag thing))))) (define (record-modifier type tag) (let ((index (field-index type tag))) (lambda (thing value) (if (and (record? thing) (eq? (record-type thing) type)) (record-set! thing index value) (error "modifier applied to bad value" type tag thing))))) uim-1.8.8/sigscheme/lib/unittest.scm0000644000175000017500000002307412532333147014354 00000000000000;; Filename : unittest.scm ;; About : Simple unit test library ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; This unit-testing library should be replaced with standard SRFI-64 once the ;; hygienic-macros are well-implemented. To write new tests, use the SRFI-64 ;; compatible assertions contained at the bottom of this file. ;; -- YamaKen 2007-09-01 (cond-expand (sigscheme ;; To allow --disable-srfi55, don't use require-extension here. (%%require-module "srfi-6") (%%require-module "srfi-23") (%%require-module "srfi-34")) (else)) (define *test-track-progress* #f) ;; for locating SEGV point (define *total-testsuites* 1) ;; TODO: introduce test suites and defaults to 0 (define *total-testcases* 1) ;; TODO: introduce testcase and defaults to 0 (define *total-tests* 1) ;; TODO: introduce test group and defaults to 0 (define *total-failures* 0) (define *total-assertions* 0) (define *total-errors* 0) ;; TODO: recover unintended error and increment this (define test-filename "unspecified") (define test-display-result (lambda () (let ((header (if (zero? *total-failures*) "OK: " "FAILED: ")) (total-successes (- *total-assertions* *total-failures*))) (for-each display (list header *total-tests* " tests, " *total-assertions* " assertions, " total-successes " successes, " *total-failures* " failures, " *total-errors* " errors")) (newline)))) (define test-report-result (lambda () (test-display-result) (let ((EX_OK 0) (EX_SOFTWARE 70)) (exit (if (positive? *total-failures*) EX_SOFTWARE EX_OK))))) ;; Backward compatibility (define total-report test-report-result) (define report-error (lambda (err-msg) (begin (display "failed: ") (display err-msg) (newline)))) (define report-inequality (lambda (expected actual) (display " expected: <") (write expected) (display ">") (newline) (display " actual: <") (write actual) (display ">") (newline))) (define assert (let ((+ +)) ;; protect from redefinition (lambda (test-name err-msg exp) (set! *total-assertions* (+ *total-assertions* 1)) (if *test-track-progress* (begin (display "done: ") (display test-name) (newline))) (if exp #t (begin (set! *total-failures* (+ *total-failures* 1)) (report-error err-msg) #f))))) (define test-skip (lambda (reason) (display "SKIP: ") (display reason) (newline) (exit 77))) ;; special code for automake ;; ;; assertions for test writers ;; (define assert-fail (lambda (test-name err-msg) (assert test-name err-msg #f))) (define assert-true (lambda (test-name exp) (assert test-name test-name exp))) (define assert-false (lambda (test-name exp) (assert test-name test-name (not exp)))) (define assert-eq? (lambda (test-name expected actual) (or (assert test-name test-name (eq? expected actual)) (report-inequality expected actual)))) (define assert-equal? (lambda (test-name expected actual) (or (assert test-name test-name (equal? expected actual)) (report-inequality expected actual)))) (define assert-error (lambda (test-name proc) (or (procedure? proc) (error "assert-error: procedure required but got" proc)) (let ((errored (guard (err (else #t)) (proc) #f)) (err-msg (string-append "no error has occurred in test " test-name))) (assert test-name err-msg errored)))) (define assert-parse-error (lambda (test-name str) (assert-error test-name (lambda () (string-read str))))) (define assert-parseable (lambda (test-name str) (assert-true test-name (guard (err (else #f)) (string-read str) #t)))) ;; ;; misc ;; ;; SigScheme and Gauche surely returns # (define undef (lambda () (for-each values '()))) ;; SigScheme and Gauche surely returns # (define eof (lambda () (string-read ""))) (define obj->literal (lambda (obj) (let ((port (open-output-string))) (write obj port) (get-output-string port)))) (define string-read (lambda (str) (let ((port (open-input-string str))) (read port)))) (define string-eval (lambda (str) (eval (string-read str) (interaction-environment)))) (define test-name (let ((name "anonymous test") (serial 0) (+ +)) ;; protect from redefinition (lambda args (if (null? args) (begin (set! serial (+ serial 1)) (string-append name " #" (number->string serial))) (begin (set! name (car args)) (set! serial 0) #f))))) (define print-expected (lambda (expected) (display " expected print: ") (display expected) (newline) (display " actual print: "))) ;; ;; implementation information ;; (define sigscheme? (provided? "sigscheme")) (define fixnum-bits (and (symbol-bound? 'fixnum-width) (fixnum-width))) ;; ;; SRFI-64 compatibilities ;; ;; See test-unittest.scm to understand how to use these. (cond-expand (sigscheme ;; To allow --disable-srfi55, don't use require-extension here. (%%require-module "sscm-ext")) (else)) (define-macro test-begin (lambda (suite-name . opt-count) (let-optionals* opt-count ((count #f)) `(test-name ,suite-name)))) (define-macro test-end (lambda args (let-optionals* args ((suite-name #f)) '#f))) (define-macro test-assert (lambda (first . rest) (let-optionals* (reverse (cons first rest)) ((expr #f) (tname '(test-name))) `(assert-true ,tname ,expr)))) (define-macro test-equal (lambda args `(%test-equal equal? . ,args))) (define-macro test-eqv (lambda args `(%test-equal eqv? . ,args))) (define-macro test-eq (lambda args `(%test-equal eq? . ,args))) (define-macro %test-equal (lambda (= second third . rest) (let-optionals* (if (null? rest) (list '(test-name) second third) (cons second (cons third rest))) ((tname #f) (expected #f) (expr #f)) `(%test-equal2 ,= ,tname ,expected ,expr)))) (define %test-equal2 (lambda (= tname expected actual) (or (assert tname tname (= expected actual)) (report-inequality expected actual)))) (define-macro test-error (lambda (first . rest) (let-optionals* (reverse (cons first rest)) ((expr #f) (err-type #t) (tname '(test-name))) `(assert-error ,tname (lambda () (eval ',expr (interaction-environment))))))) (define test-read-eval-string (lambda (str) (let* ((port (open-input-string str)) (expr (read port))) (if (or (eof-object? expr) (guard (err (else #t)) (not (eof-object? (read-char port))))) (error "invalid expression string" str)) (eval expr (interaction-environment))))) ;; ;; Non-standard SRFI-64-like assertions ;; ;; I think that writing (test-assert ) and (test-assert (not )) is ;; cumbersome. -- YamaKen 2007-09-04 (define-macro test-true (lambda args `(test-assert . ,args))) (define-macro test-false (lambda (first . rest) (let-optionals* (reverse (cons first rest)) ((expr #f) (tname '(test-name))) `(test-assert ,tname (not ,expr))))) uim-1.8.8/sigscheme/lib/sigscheme-init.scm0000644000175000017500000001013112532333147015373 00000000000000;; Filename : sigscheme-init.scm ;; About : Initialization file for SigScheme ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define %with-guarded-char-codec (lambda (thunk) (let ((orig-codec (%%current-char-codec)) (thunk-codec (%%current-char-codec))) (dynamic-wind (lambda () (%%set-current-char-codec! thunk-codec)) thunk (lambda () (set! thunk-codec (%%current-char-codec)) (%%set-current-char-codec! orig-codec)))))) (define with-char-codec (lambda (codec thunk) (%with-guarded-char-codec (lambda () (%%set-current-char-codec! codec) (thunk))))) ;; Preserve original C implementation. (define %%load load) ;; Recover original char codec when an error is occurred on loading. (define load (if (provided? "multibyte-char") (lambda (file) (%with-guarded-char-codec (lambda () (%%load file)))) %%load)) ;; R5RS (define call-with-input-file (lambda (filename proc) (let* ((port (open-input-file filename)) (res (proc port))) (close-input-port port) res))) ;; R5RS (define call-with-output-file (lambda (filename proc) (let* ((port (open-output-file filename)) (res (proc port))) (close-output-port port) res))) ;; R5RS (define with-input-from-file (lambda (file thunk) (let ((orig-port (current-input-port)) (thunk-port (current-input-port))) (dynamic-wind (lambda () (%%set-current-input-port! thunk-port)) (lambda () (let* ((port (open-input-file file)) (res (begin (set! thunk-port port) (%%set-current-input-port! thunk-port) (thunk)))) (close-input-port port) res)) (lambda () (%%set-current-input-port! orig-port)))))) ;; R5RS (define with-output-to-file (lambda (file thunk) (let ((orig-port (current-output-port)) (thunk-port (current-output-port))) (dynamic-wind (lambda () (%%set-current-output-port! thunk-port)) (lambda () (let* ((port (open-output-file file)) (res (begin (set! thunk-port port) (%%set-current-output-port! thunk-port) (thunk)))) (close-output-port port) res)) (lambda () (%%set-current-output-port! orig-port)))))) uim-1.8.8/sigscheme/lib/srfi-0.scm0000644000175000017500000000661012532333147013572 00000000000000;; Filename : srfi-0.scm ;; About : SRFI-0 Feature-based conditional expansion construct ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (srfi 23)) (define-macro %cond-expand-dummy (lambda () #t)) (define %cond-expand-feature? (lambda (feature-exp) (cond ((symbol? feature-exp) (or (eq? feature-exp 'else) (provided? (symbol->string feature-exp)))) ((pair? feature-exp) (let ((directive (car feature-exp)) (args (cdr feature-exp))) (case directive ((and) ;;(every %cond-expand-feature? args)) (not (memq #f (map %cond-expand-feature? args)))) ((or) ;;(any %cond-expand-feature? args)) (not (not (memq #t (map %cond-expand-feature? args))))) ((not) (if (not (null? (cdr args))) (error "invalid feature expression")) (not (%cond-expand-feature? (car args)))) (else (error "invalid feature expression")))))))) (define-macro cond-expand (lambda clauses (if (null? clauses) (error "unfulfilled cond-expand") ;; (let ((clause (find (lambda (clause) ;; (%cond-expand-feature? (car clause))) ;; clauses))) (let ((clause (let rec ((rest clauses)) (cond ((null? rest) #f) ((%cond-expand-feature? (caar rest)) (car rest)) (else (rec (cdr rest))))))) (if clause `(begin ;; raise error if cond-expand is placed in non-toplevel (define-macro %cond-expand-dummy (lambda () #t)) . ,(cdr clause)) (error "unfulfilled cond-expand")))))) uim-1.8.8/sigscheme/lib/Makefile.in0000644000175000017500000004314613275405265014046 00000000000000# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ @USE_SRFI0_TRUE@am__append_1 = srfi-0.scm @USE_SRFI1_TRUE@am__append_2 = srfi-1.scm @USE_SRFI9_TRUE@am__append_3 = srfi-9.scm @USE_SRFI43_TRUE@am__append_4 = srfi-43.scm @USE_SRFI55_TRUE@am__append_5 = srfi-55.scm @USE_SRFI69_TRUE@am__append_6 = srfi-69.scm @USE_SRFI95_TRUE@am__append_7 = srfi-95.scm subdir = lib ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_c___attribute__.m4 \ $(top_srcdir)/m4/ax_c_arithmetic_rshift.m4 \ $(top_srcdir)/m4/ax_c_referenceable_passed_va_list.m4 \ $(top_srcdir)/m4/ax_cflags_gcc_option.m4 \ $(top_srcdir)/m4/ax_check_page_aligned_malloc.m4 \ $(top_srcdir)/m4/ax_create_stdint_h.m4 \ $(top_srcdir)/m4/ax_feature_configurator.m4 \ $(top_srcdir)/m4/ax_func_getcontext.m4 \ $(top_srcdir)/m4/ax_func_sigsetjmp.m4 \ $(top_srcdir)/m4/ax_lib_glibc.m4 \ $(top_srcdir)/m4/check_gnu_make.m4 $(top_srcdir)/m4/libtool.m4 \ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(am__dist_scmlib_DATA_DIST) \ $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/src/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = SOURCES = DIST_SOURCES = am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__dist_scmlib_DATA_DIST = sigscheme-init.scm unittest.scm srfi-0.scm \ srfi-1.scm srfi-9.scm srfi-43.scm srfi-55.scm srfi-69.scm \ srfi-95.scm am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } am__installdirs = "$(DESTDIR)$(scmlibdir)" DATA = $(dist_scmlib_DATA) am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) # Install into master package's pkgdatadir if --with-master-pkg is specified # e.g.) # --without-master-pkg -> /usr/share/sigscheme/lib/srfi-1.scm # --with-master-pkg=uim -> /usr/share/uim/lib/srfi-1.scm @WITH_MASTER_PKG_TRUE@pkgdatadir = ${datadir}/${SSCM_MASTER_PKG} ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ ASCIIDOC = @ASCIIDOC@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ FGREP = @FGREP@ GCROOTS_CFLAGS = @GCROOTS_CFLAGS@ GCROOTS_LIBS = @GCROOTS_LIBS@ GCROOTS_REQ = @GCROOTS_REQ@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MD5 = @MD5@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PERL = @PERL@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ RANLIB = @RANLIB@ RUBY = @RUBY@ SED = @SED@ SET_MAKE = @SET_MAKE@ SH = @SH@ SHA1 = @SHA1@ SHELL = @SHELL@ SSCM_DEFS = @SSCM_DEFS@ SSCM_MASTER_PKG = @SSCM_MASTER_PKG@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ ifGNUmake = @ifGNUmake@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ scmlibdir = @scmlibdir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ use_backtrace = @use_backtrace@ use_char = @use_char@ use_compat_siod = @use_compat_siod@ use_compat_siod_bugs = @use_compat_siod_bugs@ use_const_list_literal = @use_const_list_literal@ use_const_vector_literal = @use_const_vector_literal@ use_continuation = @use_continuation@ use_debug = @use_debug@ use_deep_cadrs = @use_deep_cadrs@ use_default_encoding = @use_default_encoding@ use_euccn = @use_euccn@ use_eucjp = @use_eucjp@ use_euckr = @use_euckr@ use_eval_c_string = @use_eval_c_string@ use_fixnum = @use_fixnum@ use_hygienic_macro = @use_hygienic_macro@ use_int = @use_int@ use_internal_definitions = @use_internal_definitions@ use_legacy_macro = @use_legacy_macro@ use_load = @use_load@ use_multibyte_char = @use_multibyte_char@ use_number_io = @use_number_io@ use_port = @use_port@ use_promise = @use_promise@ use_quasiquote = @use_quasiquote@ use_r6rs_chars = @use_r6rs_chars@ use_r6rs_named_chars = @use_r6rs_named_chars@ use_reader = @use_reader@ use_sjis = @use_sjis@ use_srfi0 = @use_srfi0@ use_srfi1 = @use_srfi1@ use_srfi2 = @use_srfi2@ use_srfi22 = @use_srfi22@ use_srfi23 = @use_srfi23@ use_srfi28 = @use_srfi28@ use_srfi34 = @use_srfi34@ use_srfi38 = @use_srfi38@ use_srfi43 = @use_srfi43@ use_srfi48 = @use_srfi48@ use_srfi55 = @use_srfi55@ use_srfi6 = @use_srfi6@ use_srfi60 = @use_srfi60@ use_srfi69 = @use_srfi69@ use_srfi8 = @use_srfi8@ use_srfi9 = @use_srfi9@ use_srfi95 = @use_srfi95@ use_sscm_extensions = @use_sscm_extensions@ use_sscm_format_extension = @use_sscm_format_extension@ use_storage = @use_storage@ use_strict_argcheck = @use_strict_argcheck@ use_strict_null_form = @use_strict_null_form@ use_strict_r5rs = @use_strict_r5rs@ use_strict_toplevel_definitions = @use_strict_toplevel_definitions@ use_strict_vector_form = @use_strict_vector_form@ use_string = @use_string@ use_string_procedure = @use_string_procedure@ use_utf8 = @use_utf8@ use_vector = @use_vector@ use_writer = @use_writer@ dist_scmlib_DATA = sigscheme-init.scm unittest.scm $(am__append_1) \ $(am__append_2) $(am__append_3) $(am__append_4) \ $(am__append_5) $(am__append_6) $(am__append_7) all: all-am .SUFFIXES: $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign lib/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign lib/Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs install-dist_scmlibDATA: $(dist_scmlib_DATA) @$(NORMAL_INSTALL) @list='$(dist_scmlib_DATA)'; test -n "$(scmlibdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(scmlibdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(scmlibdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(scmlibdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(scmlibdir)" || exit $$?; \ done uninstall-dist_scmlibDATA: @$(NORMAL_UNINSTALL) @list='$(dist_scmlib_DATA)'; test -n "$(scmlibdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(scmlibdir)'; $(am__uninstall_files_from_dir) tags TAGS: ctags CTAGS: cscope cscopelist: distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(DATA) installdirs: for dir in "$(DESTDIR)$(scmlibdir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-generic dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dist_scmlibDATA install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-generic mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-dist_scmlibDATA .MAKE: install-am install-strip .PHONY: all all-am check check-am clean clean-generic clean-libtool \ cscopelist-am ctags-am distclean distclean-generic \ distclean-libtool distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am \ install-dist_scmlibDATA install-dvi install-dvi-am \ install-exec install-exec-am install-html install-html-am \ install-info install-info-am install-man install-pdf \ install-pdf-am install-ps install-ps-am install-strip \ installcheck installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-generic \ mostlyclean-libtool pdf pdf-am ps ps-am tags-am uninstall \ uninstall-am uninstall-dist_scmlibDATA .PRECIOUS: Makefile # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: uim-1.8.8/sigscheme/lib/srfi-55.scm0000644000175000017500000000576512532333147013676 00000000000000;; Filename : srfi-55.scm ;; About : SRFI-55 require-extension ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define %require-extension-handler-srfi (lambda numbers (for-each (lambda (n) (let ((srfi-n (string-append "srfi-" (number->string n)))) (or (%%require-module srfi-n) (%require-sysfile srfi-n)))) numbers))) ;; Be quasiquote free to allow --disable-quasiquote (define %require-extension-alist (list (cons 'srfi %require-extension-handler-srfi))) (define %require-sysfile (lambda (ext-id) (or (provided? ext-id) (let* ((file (string-append ext-id ".scm")) (path (string-append (%%system-load-path) "/" file))) (load path) (provide ext-id))))) (define %require-extension (lambda clauses (for-each (lambda (clause) (let* ((id (car clause)) (args (cdr clause)) (id-str (symbol->string id)) (default-handler (lambda () (or (%%require-module id-str) (%require-sysfile id-str)))) (handler (cond ((assq id %require-extension-alist) => cdr) (else default-handler)))) (apply handler args))) clauses))) uim-1.8.8/sigscheme/lib/srfi-69.scm0000644000175000017500000002600612532333147013672 00000000000000;; Copyright (C) Panu Kalliokoski (2005). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be included ;; in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS ;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; Latest sources: ;; ;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/hash-srfi.ss ;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/test-hash.ss ;; ChangeLog ;; ;; 2007-07-23 yamaken - Imported from ;; http://srfi.schemers.org/srfi-69/srfi-69.html ;; and adapted to SigScheme ;; ;; SigScheme adaptation ;; (require-extension (srfi 9 23)) (define inexact? (lambda (x) #f)) (define real? inexact?) (define expt (lambda (x y) (let rec ((res 1) (cnt y)) (if (zero? cnt) res (rec (* res x) (- cnt 1)))))) ;; ;; Main implementation ;; ;; This implementation relies on SRFI-9 for distinctness of the hash table ;; type, and on SRFI-23 for error reporting. Otherwise, the implementation ;; is pure R5RS. (define *default-bound* (- (expt 2 29) 3)) (define (%string-hash s ch-conv bound) (let ((hash 31) (len (string-length s))) (do ((index 0 (+ index 1))) ((>= index len) (modulo hash bound)) (set! hash (modulo (+ (* 37 hash) (char->integer (ch-conv (string-ref s index)))) *default-bound*))))) (define (string-hash s . maybe-bound) (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) (%string-hash s (lambda (x) x) bound))) (define (string-ci-hash s . maybe-bound) (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) (%string-hash s char-downcase bound))) (define (symbol-hash s . maybe-bound) (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) (%string-hash (symbol->string s) (lambda (x) x) bound))) (define (hash obj . maybe-bound) (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) (cond ((integer? obj) (modulo obj bound)) ((string? obj) (string-hash obj bound)) ((symbol? obj) (symbol-hash obj bound)) ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound)) ((number? obj) (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj)))) bound)) ((char? obj) (modulo (char->integer obj) bound)) ((vector? obj) (vector-hash obj bound)) ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj)))) bound)) ((null? obj) 0) ((not obj) 0) ((procedure? obj) (error "hash: procedures cannot be hashed" obj)) (else 1)))) (define hash-by-identity hash) (define (vector-hash v bound) (let ((hashvalue 571) (len (vector-length v))) (do ((index 0 (+ index 1))) ((>= index len) (modulo hashvalue bound)) (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index))) *default-bound*))))) (define %make-hash-node cons) (define %hash-node-set-value! set-cdr!) (define %hash-node-key car) (define %hash-node-value cdr) (define-record-type (%make-hash-table size hash compare associate entries) hash-table? (size hash-table-size hash-table-set-size!) (hash hash-table-hash-function) (compare hash-table-equivalence-function) (associate hash-table-association-function) (entries hash-table-entries hash-table-set-entries!)) (define *default-table-size* 64) (define (appropriate-hash-function-for comparison) (or (and (eq? comparison eq?) hash-by-identity) (and (eq? comparison string=?) string-hash) (and (eq? comparison string-ci=?) string-ci-hash) hash)) (define (make-hash-table . args) (let* ((comparison (if (null? args) equal? (car args))) (hash (if (or (null? args) (null? (cdr args))) (appropriate-hash-function-for comparison) (cadr args))) (size (if (or (null? args) (null? (cdr args)) (null? (cddr args))) *default-table-size* (caddr args))) (association (or (and (eq? comparison eq?) assq) (and (eq? comparison eqv?) assv) (and (eq? comparison equal?) assoc) (letrec ((associate (lambda (val alist) (cond ((null? alist) #f) ((comparison val (caar alist)) (car alist)) (else (associate val (cdr alist))))))) associate)))) (%make-hash-table 0 hash comparison association (make-vector size '())))) (define (make-hash-table-maker comp hash) (lambda args (apply make-hash-table (cons comp (cons hash args))))) (define make-symbol-hash-table (make-hash-table-maker eq? symbol-hash)) (define make-string-hash-table (make-hash-table-maker string=? string-hash)) (define make-string-ci-hash-table (make-hash-table-maker string-ci=? string-ci-hash)) (define make-integer-hash-table (make-hash-table-maker = modulo)) (define (%hash-table-hash hash-table key) ((hash-table-hash-function hash-table) key (vector-length (hash-table-entries hash-table)))) (define (%hash-table-find entries associate hash key) (associate key (vector-ref entries hash))) (define (%hash-table-add! entries hash key value) (vector-set! entries hash (cons (%make-hash-node key value) (vector-ref entries hash)))) (define (%hash-table-delete! entries compare hash key) (let ((entrylist (vector-ref entries hash))) (cond ((null? entrylist) #f) ((compare key (caar entrylist)) (vector-set! entries hash (cdr entrylist)) #t) (else (let loop ((current (cdr entrylist)) (previous entrylist)) (cond ((null? current) #f) ((compare key (caar current)) (set-cdr! previous (cdr current)) #t) (else (loop (cdr current) current)))))))) (define (%hash-table-walk proc entries) (do ((index (- (vector-length entries) 1) (- index 1))) ((< index 0)) (for-each proc (vector-ref entries index)))) (define (%hash-table-maybe-resize! hash-table) (let* ((old-entries (hash-table-entries hash-table)) (hash-length (vector-length old-entries))) (if (> (hash-table-size hash-table) hash-length) (let* ((new-length (* 2 hash-length)) (new-entries (make-vector new-length '())) (hash (hash-table-hash-function hash-table))) (%hash-table-walk (lambda (node) (%hash-table-add! new-entries (hash (%hash-node-key node) new-length) (%hash-node-key node) (%hash-node-value node))) old-entries) (hash-table-set-entries! hash-table new-entries))))) (define (hash-table-ref hash-table key . maybe-default) (cond ((%hash-table-find (hash-table-entries hash-table) (hash-table-association-function hash-table) (%hash-table-hash hash-table key) key) => %hash-node-value) ((null? maybe-default) (error "hash-table-ref: no value associated with" key)) (else ((car maybe-default))))) (define (hash-table-ref/default hash-table key default) (hash-table-ref hash-table key (lambda () default))) (define (hash-table-set! hash-table key value) (let ((hash (%hash-table-hash hash-table key)) (entries (hash-table-entries hash-table))) (cond ((%hash-table-find entries (hash-table-association-function hash-table) hash key) => (lambda (node) (%hash-node-set-value! node value))) (else (%hash-table-add! entries hash key value) (hash-table-set-size! hash-table (+ 1 (hash-table-size hash-table))) (%hash-table-maybe-resize! hash-table))))) (define (hash-table-update! hash-table key function . maybe-default) (let ((hash (%hash-table-hash hash-table key)) (entries (hash-table-entries hash-table))) (cond ((%hash-table-find entries (hash-table-association-function hash-table) hash key) => (lambda (node) (%hash-node-set-value! node (function (%hash-node-value node))))) ((null? maybe-default) (error "hash-table-update!: no value exists for key" key)) (else (%hash-table-add! entries hash key (function ((car maybe-default)))) (hash-table-set-size! hash-table (+ 1 (hash-table-size hash-table))) (%hash-table-maybe-resize! hash-table))))) (define (hash-table-update!/default hash-table key function default) (hash-table-update! hash-table key function (lambda () default))) (define (hash-table-delete! hash-table key) (if (%hash-table-delete! (hash-table-entries hash-table) (hash-table-equivalence-function hash-table) (%hash-table-hash hash-table key) key) (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1)))) (define (hash-table-exists? hash-table key) (and (%hash-table-find (hash-table-entries hash-table) (hash-table-association-function hash-table) (%hash-table-hash hash-table key) key) #t)) (define (hash-table-walk hash-table proc) (%hash-table-walk (lambda (node) (proc (%hash-node-key node) (%hash-node-value node))) (hash-table-entries hash-table))) (define (hash-table-fold hash-table f acc) (hash-table-walk hash-table (lambda (key value) (set! acc (f key value acc)))) acc) (define (alist->hash-table alist . args) (let* ((comparison (if (null? args) equal? (car args))) (hash (if (or (null? args) (null? (cdr args))) (appropriate-hash-function-for comparison) (cadr args))) (size (if (or (null? args) (null? (cdr args)) (null? (cddr args))) (max *default-table-size* (* 2 (length alist))) (caddr args))) (hash-table (make-hash-table comparison hash size))) (for-each (lambda (elem) (hash-table-update!/default hash-table (car elem) (lambda (x) x) (cdr elem))) alist) hash-table)) (define (hash-table->alist hash-table) (hash-table-fold hash-table (lambda (key val acc) (cons (cons key val) acc)) '())) (define (hash-table-copy hash-table) (let ((new (make-hash-table (hash-table-equivalence-function hash-table) (hash-table-hash-function hash-table) (max *default-table-size* (* 2 (hash-table-size hash-table)))))) (hash-table-walk hash-table (lambda (key value) (hash-table-set! new key value))) new)) (define (hash-table-merge! hash-table1 hash-table2) (hash-table-walk hash-table2 (lambda (key value) (hash-table-set! hash-table1 key value))) hash-table1) (define (hash-table-keys hash-table) (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '())) (define (hash-table-values hash-table) (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '())) uim-1.8.8/sigscheme/lib/srfi-1.scm0000644000175000017500000015667712532333147013616 00000000000000;;; SRFI-1 list-processing library -*- Scheme -*- ;;; Reference implementation ;;; ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with ;;; this code as long as you do not remove this copyright notice or ;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;;; -Olin ;;; Copyright (c) 2007-2008 SigScheme Project ;; ChangeLog ;; ;; 2007-06-15 yamaken - Imported from ;; http://srfi.schemers.org/srfi-1/srfi-1-reference.scm ;; and adapted to SigScheme ;; - Add for-each ;; 2007-06-30 yamaken - Fix broken arguments receiving of delete-duplicates! ;; - Fix broken lset-difference call of lset-xor and ;; lset-xor! (as like as Scheme48) ;; 2007-07-01 yamaken - Fix broken comparison of list= on 3 or more lists ;; 2007-07-13 yamaken - Change default value for make-list to # ;;; This is a library of list- and pair-processing functions. I wrote it after ;;; carefully considering the functions provided by the libraries found in ;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common ;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty ;;; rich toolkit, providing a superset of the functionality found in any of ;;; the various Schemes I considered. ;;; This implementation is intended as a portable reference implementation ;;; for SRFI-1. See the porting notes below for more information. ;;; Exported: ;;; xcons tree-copy make-list list-tabulate cons* list-copy ;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= ;;; circular-list length+ ;;; iota ;;; first second third fourth fifth sixth seventh eighth ninth tenth ;;; car+cdr ;;; take drop ;;; take-right drop-right ;;; take! drop-right! ;;; split-at split-at! ;;; last last-pair ;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 ;;; count ;;; append! append-reverse append-reverse! concatenate concatenate! ;;; unfold fold pair-fold reduce ;;; unfold-right fold-right pair-fold-right reduce-right ;;; append-map append-map! map! pair-for-each filter-map map-in-order ;;; filter partition remove ;;; filter! partition! remove! ;;; find find-tail any every list-index ;;; take-while drop-while take-while! ;;; span break span! break! ;;; delete delete! ;;; alist-cons alist-copy ;;; delete-duplicates delete-duplicates! ;;; alist-delete alist-delete! ;;; reverse! ;;; lset<= lset= lset-adjoin ;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection ;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! ;;; ;;; In principle, the following R4RS list- and pair-processing procedures ;;; are also part of this package's exports, although they are not defined ;;; in this file: ;;; Primitives: cons pair? null? car cdr set-car! set-cdr! ;;; Non-primitives: list length append reverse cadr ... cddddr list-ref ;;; memq memv assq assv ;;; (The non-primitives are defined in this file, but commented out.) ;;; ;;; These R4RS procedures have extended definitions in SRFI-1 and are defined ;;; in this file: ;;; map for-each member assoc ;;; ;;; The remaining two R4RS list-processing procedures are not included: ;;; list-tail (use drop) ;;; list? (use proper-list?) ;;; A note on recursion and iteration/reversal: ;;; Many iterative list-processing algorithms naturally compute the elements ;;; of the answer list in the wrong order (left-to-right or head-to-tail) from ;;; the order needed to cons them into the proper answer (right-to-left, or ;;; tail-then-head). One style or idiom of programming these algorithms, then, ;;; loops, consing up the elements in reverse order, then destructively ;;; reverses the list at the end of the loop. I do not do this. The natural ;;; and efficient way to code these algorithms is recursively. This trades off ;;; intermediate temporary list structure for intermediate temporary stack ;;; structure. In a stack-based system, this improves cache locality and ;;; lightens the load on the GC system. Don't stand on your head to iterate! ;;; Recurse, where natural. Multiple-value returns make this even more ;;; convenient, when the recursion/iteration has multiple state values. ;;; Porting: ;;; This is carefully tuned code; do not modify casually. ;;; - It is careful to share storage when possible; ;;; - Side-effecting code tries not to perform redundant writes. ;;; ;;; That said, a port of this library to a specific Scheme system might wish ;;; to tune this code to exploit particulars of the implementation. ;;; The single most important compiler-specific optimisation you could make ;;; to this library would be to add rewrite rules or transforms to: ;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, ;;; LSET-UNION) into multiple applications of a primitive two-argument ;;; variant. ;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, ;;; ANY, EVERY) into open-coded loops. The killer here is that these ;;; functions are n-ary. Handling the general case is quite inefficient, ;;; requiring many intermediate data structures to be allocated and ;;; discarded. ;;; - transform applications of procedures that take optional arguments ;;; into calls to variants that do not take optional arguments. This ;;; eliminates unnecessary consing and parsing of the rest parameter. ;;; ;;; These transforms would provide BIG speedups. In particular, the n-ary ;;; mapping functions are particularly slow and cons-intensive, and are good ;;; candidates for tuning. I have coded fast paths for the single-list cases, ;;; but what you really want to do is exploit the fact that the compiler ;;; usually knows how many arguments are being passed to a particular ;;; application of these functions -- they are usually explicitly called, not ;;; passed around as higher-order values. If you can arrange to have your ;;; compiler produce custom code or custom linkages based on the number of ;;; arguments in the call, you can speed these functions up a *lot*. But this ;;; kind of compiler technology no longer exists in the Scheme world as far as ;;; I can see. ;;; ;;; Note that this code is, of course, dependent upon standard bindings for ;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound ;;; to the procedure that takes the car of a list. If your Scheme ;;; implementation allows user code to alter the bindings of these procedures ;;; in a manner that would be visible to these definitions, then there might ;;; be trouble. You could consider horrible kludgery along the lines of ;;; (define fact ;;; (let ((= =) (- -) (* *)) ;;; (letrec ((real-fact (lambda (n) ;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) ;;; real-fact))) ;;; Or you could consider shifting to a reasonable Scheme system that, say, ;;; has a module system protecting code from this kind of lossage. ;;; ;;; This code does a fair amount of run-time argument checking. If your ;;; Scheme system has a sophisticated compiler that can eliminate redundant ;;; error checks, this is no problem. However, if not, these checks incur ;;; some performance overhead -- and, in a safe Scheme implementation, they ;;; are in some sense redundant: if we don't check to see that the PROC ;;; parameter is a procedure, we'll find out anyway three lines later when ;;; we try to call the value. It's pretty easy to rip all this argument ;;; checking code out if it's inappropriate for your implementation -- just ;;; nuke every call to CHECK-ARG. ;;; ;;; On the other hand, if you *do* have a sophisticated compiler that will ;;; actually perform soft-typing and eliminate redundant checks (Rice's systems ;;; being the only possible candidate of which I'm aware), leaving these checks ;;; in can *help*, since their presence can be elided in redundant cases, ;;; and in cases where they are needed, performing the checks early, at ;;; procedure entry, can "lift" a check out of a loop. ;;; ;;; Finally, I have only checked the properties that can portably be checked ;;; with R5RS Scheme -- and this is not complete. You may wish to alter ;;; the CHECK-ARG parameter checks to perform extra, implementation-specific ;;; checks, such as procedure arity for higher-order values. ;;; ;;; The code has only these non-R4RS dependencies: ;;; A few calls to an ERROR procedure; ;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding ;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). ;;; Many calls to a parameter-checking procedure check-arg: ;;; (define (check-arg pred val caller) ;;; (let lp ((val val)) ;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) ;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing ;;; optional arguments. ;;; ;;; Most of these procedures use the NULL-LIST? test to trigger the ;;; base case in the inner loop or recursion. The NULL-LIST? function ;;; is defined to be a careful one -- it raises an error if passed a ;;; non-nil, non-pair value. The spec allows an implementation to use ;;; a less-careful implementation that simply defines NULL-LIST? to ;;; be NOT-PAIR?. This would speed up the inner loops of these procedures ;;; at the expense of having them silently accept dotted lists. ;;; A note on dotted lists: ;;; I, personally, take the view that the only consistent view of lists ;;; in Scheme is the view that *everything* is a list -- values such as ;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the ;;; fact that Scheme actually has no true list type. It has a pair type, ;;; and there is an *interpretation* of the trees built using this type ;;; as lists. ;;; ;;; I lobbied to have these list-processing procedures hew to this ;;; view, and accept any value as a list argument. I was overwhelmingly ;;; overruled during the SRFI discussion phase. So I am inserting this ;;; text in the reference lib and the SRFI spec as a sort of "minority ;;; opinion" dissent. ;;; ;;; Many of the procedures in this library can be trivially redefined ;;; to handle dotted lists, just by changing the NULL-LIST? base-case ;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be ;;; an empty list. For most of these procedures, that's all that is ;;; required. ;;; ;;; However, we have to do a little more work for some procedures that ;;; *produce* lists from other lists. Were we to extend these procedures to ;;; accept dotted lists, we would have to define how they terminate the lists ;;; produced as results when passed a dotted list. I designed a coherent set ;;; of termination rules for these cases; this was posted to the SRFI-1 ;;; discussion list. I additionally wrote an earlier version of this library ;;; that implemented that spec. It has been discarded during later phases of ;;; the definition and implementation of this library. ;;; ;;; The argument *against* defining these procedures to work on dotted ;;; lists is that dotted lists are the rare, odd case, and that by ;;; arranging for the procedures to handle them, we lose error checking ;;; in the cases where a dotted list is passed by accident -- e.g., when ;;; the programmer swaps a two arguments to a list-processing function, ;;; one being a scalar and one being a list. For example, ;;; (member '(1 3 5 7 9) 7) ;;; This would quietly return #f if we extended MEMBER to accept dotted ;;; lists. ;;; ;;; The SRFI discussion record contains more discussion on this topic. ;;; SigScheme adaptation ;;;;;;;;;;;;;;;;;;;;;;;; (require-extension (srfi 8 23)) (define %srfi-1:undefined (for-each values '())) (define (check-arg pred val caller) (let lp ((val val)) (if (pred val) val (lp (error "Bad argument" val pred caller))))) ;; If you need efficiency, define this once SRFI-1 has been enabled. ;;(define (check-arg . args) #f) (define :optional (lambda (opt default) (case (length opt) ((0) default) ((1) (car opt)) (else (error "superfluous arguments"))))) ;;; Constructors ;;;;;;;;;;;;;;;; ;;; Occasionally useful as a value to be passed to a fold or other ;;; higher-order procedure. (define (xcons d a) (cons a d)) ;;;; Recursively copy every cons. ;(define (tree-copy x) ; (let recur ((x x)) ; (if (not (pair? x)) x ; (cons (recur (car x)) (recur (cdr x)))))) ;;; Make a list of length LEN. (define (make-list len . maybe-elt) (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) (let ((elt (cond ((null? maybe-elt) %srfi-1:undefined) ; Default value ((null? (cdr maybe-elt)) (car maybe-elt)) (else (error "Too many arguments to MAKE-LIST" (cons len maybe-elt)))))) (do ((i len (- i 1)) (ans '() (cons elt ans))) ((<= i 0) ans)))) ;(define (list . ans) ans) ; R4RS ;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. (define (list-tabulate len proc) (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) (check-arg procedure? proc list-tabulate) (do ((i (- len 1) (- i 1)) (ans '() (cons (proc i) ans))) ((< i 0) ans))) ;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) ;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) ;;; ;;; (cons first (unfold not-pair? car cdr rest values)) (define (cons* first . rest) (let recur ((x first) (rest rest)) (if (pair? rest) (cons x (recur (car rest) (cdr rest))) x))) ;;; (unfold not-pair? car cdr lis values) (define (list-copy lis) (let recur ((lis lis)) (if (pair? lis) (cons (car lis) (recur (cdr lis))) lis))) ;;; IOTA count [start step] (start start+step ... start+(count-1)*step) (define (iota count . maybe-start+step) (check-arg integer? count iota) (if (< count 0) (error "Negative step count" iota count)) (let-optionals* maybe-start+step ((start 0) (step 1) . must-be-null) (check-arg number? start iota) (check-arg number? step iota) (if (not (null? must-be-null)) (error "superfluous arguments")) (let ((last-val (+ start (* (- count 1) step)))) (do ((count count (- count 1)) (val last-val (- val step)) (ans '() (cons val ans))) ((<= count 0) ans))))) ;;; I thought these were lovely, but the public at large did not share my ;;; enthusiasm... ;;; :IOTA to (0 ... to-1) ;;; :IOTA from to (from ... to-1) ;;; :IOTA from to step (from from+step ...) ;;; IOTA: to (1 ... to) ;;; IOTA: from to (from+1 ... to) ;;; IOTA: from to step (from+step from+2step ...) ;(define (%parse-iota-args arg1 rest-args proc) ; (let ((check (lambda (n) (check-arg integer? n proc)))) ; (check arg1) ; (if (pair? rest-args) ; (let ((arg2 (check (car rest-args))) ; (rest (cdr rest-args))) ; (if (pair? rest) ; (let ((arg3 (check (car rest))) ; (rest (cdr rest))) ; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) ; (values arg1 arg2 arg3))) ; (values arg1 arg2 1))) ; (values 0 arg1 1)))) ; ;(define (iota: arg1 . rest-args) ; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) ; (let* ((numsteps (floor (/ (- to from) step))) ; (last-val (+ from (* step numsteps)))) ; (if (< numsteps 0) (error "Negative step count" iota: from to step)) ; (do ((steps-left numsteps (- steps-left 1)) ; (val last-val (- val step)) ; (ans '() (cons val ans))) ; ((<= steps-left 0) ans))))) ; ; ;(define (:iota arg1 . rest-args) ; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) ; (let* ((numsteps (ceiling (/ (- to from) step))) ; (last-val (+ from (* step (- numsteps 1))))) ; (if (< numsteps 0) (error "Negative step count" :iota from to step)) ; (do ((steps-left numsteps (- steps-left 1)) ; (val last-val (- val step)) ; (ans '() (cons val ans))) ; ((<= steps-left 0) ans))))) (define (circular-list val1 . vals) (let ((ans (cons val1 vals))) (set-cdr! (last-pair ans) ans) ans)) ;;; ::= () ; Empty proper list ;;; | (cons ) ; Proper-list pair ;;; Note that this definition rules out circular lists -- and this ;;; function is required to detect this case and return false. (define (proper-list? x) (let lp ((x x) (lag x)) (if (pair? x) (let ((x (cdr x))) (if (pair? x) (let ((x (cdr x)) (lag (cdr lag))) (and (not (eq? x lag)) (lp x lag))) (null? x))) (null? x)))) ;;; A dotted list is a finite list (possibly of length 0) terminated ;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) ;;; is a dotted list of length 0. ;;; ;;; ::= ; Empty dotted list ;;; | (cons ) ; Proper-list pair (define (dotted-list? x) (let lp ((x x) (lag x)) (if (pair? x) (let ((x (cdr x))) (if (pair? x) (let ((x (cdr x)) (lag (cdr lag))) (and (not (eq? x lag)) (lp x lag))) (not (null? x)))) (not (null? x))))) (define (circular-list? x) (let lp ((x x) (lag x)) (and (pair? x) (let ((x (cdr x))) (and (pair? x) (let ((x (cdr x)) (lag (cdr lag))) (or (eq? x lag) (lp x lag)))))))) (define (not-pair? x) (not (pair? x))) ; Inline me. ;;; This is a legal definition which is fast and sloppy: ;;; (define null-list? not-pair?) ;;; but we'll provide a more careful one: (define (null-list? l) (cond ((pair? l) #f) ((null? l) #t) (else (error "null-list?: argument out of domain" l)))) (define (list= = . lists) (or (null? lists) ; special case (let lp1 ((list-a (car lists)) (others (cdr lists))) (or (null? others) (let ((list-b (car others)) (others (cdr others))) (if (eq? list-a list-b) ; EQ? => LIST= (lp1 list-b others) (let lp2 ((tail-a list-a) (tail-b list-b)) (if (null-list? tail-a) (and (null-list? tail-b) (lp1 list-b others)) (and (not (null-list? tail-b)) (= (car tail-a) (car tail-b)) (lp2 (cdr tail-a) (cdr tail-b))))))))))) ;;; R4RS, so commented out. ;(define (length x) ; LENGTH may diverge or ; (let lp ((x x) (len 0)) ; raise an error if X is ; (if (pair? x) ; a circular list. This version ; (lp (cdr x) (+ len 1)) ; diverges. ; len))) (define (length+ x) ; Returns #f if X is circular. (let lp ((x x) (lag x) (len 0)) (if (pair? x) (let ((x (cdr x)) (len (+ len 1))) (if (pair? x) (let ((x (cdr x)) (lag (cdr lag)) (len (+ len 1))) (and (not (eq? x lag)) (lp x lag len))) len)) len))) (define (zip list1 . more-lists) (apply map list list1 more-lists)) ;;; Selectors ;;;;;;;;;;;;; ;;; R4RS non-primitives: ;(define (caar x) (car (car x))) ;(define (cadr x) (car (cdr x))) ;(define (cdar x) (cdr (car x))) ;(define (cddr x) (cdr (cdr x))) ; ;(define (caaar x) (caar (car x))) ;(define (caadr x) (caar (cdr x))) ;(define (cadar x) (cadr (car x))) ;(define (caddr x) (cadr (cdr x))) ;(define (cdaar x) (cdar (car x))) ;(define (cdadr x) (cdar (cdr x))) ;(define (cddar x) (cddr (car x))) ;(define (cdddr x) (cddr (cdr x))) ; ;(define (caaaar x) (caaar (car x))) ;(define (caaadr x) (caaar (cdr x))) ;(define (caadar x) (caadr (car x))) ;(define (caaddr x) (caadr (cdr x))) ;(define (cadaar x) (cadar (car x))) ;(define (cadadr x) (cadar (cdr x))) ;(define (caddar x) (caddr (car x))) ;(define (cadddr x) (caddr (cdr x))) ;(define (cdaaar x) (cdaar (car x))) ;(define (cdaadr x) (cdaar (cdr x))) ;(define (cdadar x) (cdadr (car x))) ;(define (cdaddr x) (cdadr (cdr x))) ;(define (cddaar x) (cddar (car x))) ;(define (cddadr x) (cddar (cdr x))) ;(define (cdddar x) (cdddr (car x))) ;(define (cddddr x) (cdddr (cdr x))) (define first car) (define second cadr) (define third caddr) (define fourth cadddr) (define (fifth x) (car (cddddr x))) (define (sixth x) (cadr (cddddr x))) (define (seventh x) (caddr (cddddr x))) (define (eighth x) (cadddr (cddddr x))) (define (ninth x) (car (cddddr (cddddr x)))) (define (tenth x) (cadr (cddddr (cddddr x)))) (define (car+cdr pair) (values (car pair) (cdr pair))) ;;; take & drop (define (take lis k) (check-arg integer? k take) (let recur ((lis lis) (k k)) (if (zero? k) '() (cons (car lis) (recur (cdr lis) (- k 1)))))) (define (drop lis k) (check-arg integer? k drop) (let iter ((lis lis) (k k)) (if (zero? k) lis (iter (cdr lis) (- k 1))))) (define (take! lis k) (check-arg integer? k take!) (if (zero? k) '() (begin (set-cdr! (drop lis (- k 1)) '()) lis))) ;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, ;;; off by K, then chasing down the list until the lead pointer falls off ;;; the end. (define (take-right lis k) (check-arg integer? k take-right) (let lp ((lag lis) (lead (drop lis k))) (if (pair? lead) (lp (cdr lag) (cdr lead)) lag))) (define (drop-right lis k) (check-arg integer? k drop-right) (let recur ((lag lis) (lead (drop lis k))) (if (pair? lead) (cons (car lag) (recur (cdr lag) (cdr lead))) '()))) ;;; In this function, LEAD is actually K+1 ahead of LAG. This lets ;;; us stop LAG one step early, in time to smash its cdr to (). (define (drop-right! lis k) (check-arg integer? k drop-right!) (let ((lead (drop lis k))) (if (pair? lead) (let lp ((lag lis) (lead (cdr lead))) ; Standard case (if (pair? lead) (lp (cdr lag) (cdr lead)) (begin (set-cdr! lag '()) lis))) '()))) ; Special case dropping everything -- no cons to side-effect. ;(define (list-ref lis i) (car (drop lis i))) ; R4RS ;;; These use the APL convention, whereby negative indices mean ;;; "from the right." I liked them, but they didn't win over the ;;; SRFI reviewers. ;;; K >= 0: Take and drop K elts from the front of the list. ;;; K <= 0: Take and drop -K elts from the end of the list. ;(define (take lis k) ; (check-arg integer? k take) ; (if (negative? k) ; (list-tail lis (+ k (length lis))) ; (let recur ((lis lis) (k k)) ; (if (zero? k) '() ; (cons (car lis) ; (recur (cdr lis) (- k 1))))))) ; ;(define (drop lis k) ; (check-arg integer? k drop) ; (if (negative? k) ; (let recur ((lis lis) (nelts (+ k (length lis)))) ; (if (zero? nelts) '() ; (cons (car lis) ; (recur (cdr lis) (- nelts 1))))) ; (list-tail lis k))) ; ; ;(define (take! lis k) ; (check-arg integer? k take!) ; (cond ((zero? k) '()) ; ((positive? k) ; (set-cdr! (list-tail lis (- k 1)) '()) ; lis) ; (else (list-tail lis (+ k (length lis)))))) ; ;(define (drop! lis k) ; (check-arg integer? k drop!) ; (if (negative? k) ; (let ((nelts (+ k (length lis)))) ; (if (zero? nelts) '() ; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) ; lis))) ; (list-tail lis k))) (define (split-at x k) (check-arg integer? k split-at) (let recur ((lis x) (k k)) (if (zero? k) (values '() lis) (receive (prefix suffix) (recur (cdr lis) (- k 1)) (values (cons (car lis) prefix) suffix))))) (define (split-at! x k) (check-arg integer? k split-at!) (if (zero? k) (values '() x) (let* ((prev (drop x (- k 1))) (suffix (cdr prev))) (set-cdr! prev '()) (values x suffix)))) (define (last lis) (car (last-pair lis))) (define (last-pair lis) (check-arg pair? lis last-pair) (let lp ((lis lis)) (let ((tail (cdr lis))) (if (pair? tail) (lp tail) lis)))) ;;; Unzippers -- 1 through 5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (unzip1 lis) (map car lis)) (define (unzip2 lis) (let recur ((lis lis)) (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle (let ((elt (car lis))) ; dotted lists. (receive (a b) (recur (cdr lis)) (values (cons (car elt) a) (cons (cadr elt) b))))))) (define (unzip3 lis) (let recur ((lis lis)) (if (null-list? lis) (values lis lis lis) (let ((elt (car lis))) (receive (a b c) (recur (cdr lis)) (values (cons (car elt) a) (cons (cadr elt) b) (cons (caddr elt) c))))))) (define (unzip4 lis) (let recur ((lis lis)) (if (null-list? lis) (values lis lis lis lis) (let ((elt (car lis))) (receive (a b c d) (recur (cdr lis)) (values (cons (car elt) a) (cons (cadr elt) b) (cons (caddr elt) c) (cons (cadddr elt) d))))))) (define (unzip5 lis) (let recur ((lis lis)) (if (null-list? lis) (values lis lis lis lis lis) (let ((elt (car lis))) (receive (a b c d e) (recur (cdr lis)) (values (cons (car elt) a) (cons (cadr elt) b) (cons (caddr elt) c) (cons (cadddr elt) d) (cons (car (cddddr elt)) e))))))) ;;; append! append-reverse append-reverse! concatenate concatenate! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (append! . lists) ;; First, scan through lists looking for a non-empty one. (let lp ((lists lists) (prev '())) (if (not (pair? lists)) prev (let ((first (car lists)) (rest (cdr lists))) (if (not (pair? first)) (lp rest first) ;; Now, do the splicing. (let lp2 ((tail-cons (last-pair first)) (rest rest)) (if (pair? rest) (let ((next (car rest)) (rest (cdr rest))) (set-cdr! tail-cons next) (lp2 (if (pair? next) (last-pair next) tail-cons) rest)) first))))))) ;;; APPEND is R4RS. ;(define (append . lists) ; (if (pair? lists) ; (let recur ((list1 (car lists)) (lists (cdr lists))) ; (if (pair? lists) ; (let ((tail (recur (car lists) (cdr lists)))) ; (fold-right cons tail list1)) ; Append LIST1 & TAIL. ; list1)) ; '())) ;(define (append-reverse rev-head tail) (fold cons tail rev-head)) ;(define (append-reverse! rev-head tail) ; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) ; tail ; rev-head)) ;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. (define (append-reverse rev-head tail) (let lp ((rev-head rev-head) (tail tail)) (if (null-list? rev-head) tail (lp (cdr rev-head) (cons (car rev-head) tail))))) (define (append-reverse! rev-head tail) (let lp ((rev-head rev-head) (tail tail)) (if (null-list? rev-head) tail (let ((next-rev (cdr rev-head))) (set-cdr! rev-head tail) (lp next-rev rev-head))))) (define (concatenate lists) (reduce-right append '() lists)) (define (concatenate! lists) (reduce-right append! '() lists)) ;;; Fold/map internal utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These little internal utilities are used by the general ;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. ;;; One the other hand, the n-ary cases are painfully inefficient as it is. ;;; An aggressive implementation should simply re-write these functions ;;; for raw efficiency; I have written them for as much clarity, portability, ;;; and simplicity as can be achieved. ;;; ;;; I use the dreaded call/cc to do local aborts. A good compiler could ;;; handle this with extreme efficiency. An implementation that provides ;;; a one-shot, non-persistent continuation grabber could help the compiler ;;; out by using that in place of the call/cc's in these routines. ;;; ;;; These functions have funky definitions that are precisely tuned to ;;; the needs of the fold/map procs -- for example, to minimize the number ;;; of times the argument lists need to be examined. ;;; Return (map cdr lists). ;;; However, if any element of LISTS is empty, just abort and return '(). (define (%cdrs lists) (call-with-current-continuation (lambda (abort) (let recur ((lists lists)) (if (pair? lists) (let ((lis (car lists))) (if (null-list? lis) (abort '()) (cons (cdr lis) (recur (cdr lists))))) '()))))) (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) (let recur ((lists lists)) (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) ;;; LISTS is a (not very long) non-empty list of lists. ;;; Return two lists: the cars & the cdrs of the lists. ;;; However, if any of the lists is empty, just abort and return [() ()]. (define (%cars+cdrs lists) (call-with-current-continuation (lambda (abort) (let recur ((lists lists)) (if (pair? lists) (receive (list other-lists) (car+cdr lists) (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out (receive (a d) (car+cdr list) (receive (cars cdrs) (recur other-lists) (values (cons a cars) (cons d cdrs)))))) (values '() '())))))) ;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the ;;; cars list. What a hack. (define (%cars+cdrs+ lists cars-final) (call-with-current-continuation (lambda (abort) (let recur ((lists lists)) (if (pair? lists) (receive (list other-lists) (car+cdr lists) (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out (receive (a d) (car+cdr list) (receive (cars cdrs) (recur other-lists) (values (cons a cars) (cons d cdrs)))))) (values (list cars-final) '())))))) ;;; Like %CARS+CDRS, but blow up if any list is empty. (define (%cars+cdrs/no-test lists) (let recur ((lists lists)) (if (pair? lists) (receive (list other-lists) (car+cdr lists) (receive (a d) (car+cdr list) (receive (cars cdrs) (recur other-lists) (values (cons a cars) (cons d cdrs))))) (values '() '())))) ;;; count ;;;;;;;;; (define (count pred list1 . lists) (check-arg procedure? pred count) (if (pair? lists) ;; N-ary case (let lp ((list1 list1) (lists lists) (i 0)) (if (null-list? list1) i (receive (as ds) (%cars+cdrs lists) (if (null? as) i (lp (cdr list1) ds (if (apply pred (car list1) as) (+ i 1) i)))))) ;; Fast path (let lp ((lis list1) (i 0)) (if (null-list? lis) i (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) ;;; fold/unfold ;;;;;;;;;;;;;;; (define (unfold-right p f g seed . maybe-tail) (check-arg procedure? p unfold-right) (check-arg procedure? f unfold-right) (check-arg procedure? g unfold-right) (let lp ((seed seed) (ans (:optional maybe-tail '()))) (if (p seed) ans (lp (g seed) (cons (f seed) ans))))) (define (unfold p f g seed . maybe-tail-gen) (check-arg procedure? p unfold) (check-arg procedure? f unfold) (check-arg procedure? g unfold) (if (pair? maybe-tail-gen) (let ((tail-gen (car maybe-tail-gen))) (if (pair? (cdr maybe-tail-gen)) (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) (let recur ((seed seed)) (if (p seed) (tail-gen seed) (cons (f seed) (recur (g seed))))))) (let recur ((seed seed)) (if (p seed) '() (cons (f seed) (recur (g seed))))))) (define (fold kons knil lis1 . lists) (check-arg procedure? kons fold) (if (pair? lists) (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) (if (null? cars+ans) ans ; Done. (lp cdrs (apply kons cars+ans))))) (let lp ((lis lis1) (ans knil)) ; Fast path (if (null-list? lis) ans (lp (cdr lis) (kons (car lis) ans)))))) (define (fold-right kons knil lis1 . lists) (check-arg procedure? kons fold-right) (if (pair? lists) (let recur ((lists (cons lis1 lists))) ; N-ary case (let ((cdrs (%cdrs lists))) (if (null? cdrs) knil (apply kons (%cars+ lists (recur cdrs)))))) (let recur ((lis lis1)) ; Fast path (if (null-list? lis) knil (let ((head (car lis))) (kons head (recur (cdr lis)))))))) (define (pair-fold-right f zero lis1 . lists) (check-arg procedure? f pair-fold-right) (if (pair? lists) (let recur ((lists (cons lis1 lists))) ; N-ary case (let ((cdrs (%cdrs lists))) (if (null? cdrs) zero (apply f (append! lists (list (recur cdrs))))))) (let recur ((lis lis1)) ; Fast path (if (null-list? lis) zero (f lis (recur (cdr lis))))))) (define (pair-fold f zero lis1 . lists) (check-arg procedure? f pair-fold) (if (pair? lists) (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case (let ((tails (%cdrs lists))) (if (null? tails) ans (lp tails (apply f (append! lists (list ans))))))) (let lp ((lis lis1) (ans zero)) (if (null-list? lis) ans (let ((tail (cdr lis))) ; Grab the cdr now, (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. ;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. ;;; These cannot meaningfully be n-ary. (define (reduce f ridentity lis) (check-arg procedure? f reduce) (if (null-list? lis) ridentity (fold f (car lis) (cdr lis)))) (define (reduce-right f ridentity lis) (check-arg procedure? f reduce-right) (if (null-list? lis) ridentity (let recur ((head (car lis)) (lis (cdr lis))) (if (pair? lis) (f head (recur (car lis) (cdr lis))) head)))) ;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (append-map f lis1 . lists) (really-append-map append-map append f lis1 lists)) (define (append-map! f lis1 . lists) (really-append-map append-map! append! f lis1 lists)) (define (really-append-map who appender f lis1 lists) (check-arg procedure? f who) (if (pair? lists) (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) (if (null? cars) '() (let recur ((cars cars) (cdrs cdrs)) (let ((vals (apply f cars))) (receive (cars2 cdrs2) (%cars+cdrs cdrs) (if (null? cars2) vals (appender vals (recur cars2 cdrs2)))))))) ;; Fast path (if (null-list? lis1) '() (let recur ((elt (car lis1)) (rest (cdr lis1))) (let ((vals (f elt))) (if (null-list? rest) vals (appender vals (recur (car rest) (cdr rest))))))))) (define (pair-for-each proc lis1 . lists) (check-arg procedure? proc pair-for-each) (if (pair? lists) (let lp ((lists (cons lis1 lists))) (let ((tails (%cdrs lists))) (if (pair? tails) (begin (apply proc lists) (lp tails))))) ;; Fast path. (let lp ((lis lis1)) (if (not (null-list? lis)) (let ((tail (cdr lis))) ; Grab the cdr now, (proc lis) ; in case PROC SET-CDR!s LIS. (lp tail)))))) ;;; We stop when LIS1 runs out, not when any list runs out. (define (map! f lis1 . lists) (check-arg procedure? f map!) (if (pair? lists) (let lp ((lis1 lis1) (lists lists)) (if (not (null-list? lis1)) (receive (heads tails) (%cars+cdrs/no-test lists) (set-car! lis1 (apply f (car lis1) heads)) (lp (cdr lis1) tails)))) ;; Fast path. (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) lis1) ;;; Map F across L, and save up all the non-false results. (define (filter-map f lis1 . lists) (check-arg procedure? f filter-map) (if (pair? lists) (let recur ((lists (cons lis1 lists))) (receive (cars cdrs) (%cars+cdrs lists) (if (pair? cars) (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) (else (recur cdrs))) ; Tail call in this arm. '()))) ;; Fast path. (let recur ((lis lis1)) (if (null-list? lis) lis (let ((tail (recur (cdr lis)))) (cond ((f (car lis)) => (lambda (x) (cons x tail))) (else tail))))))) ;;; Map F across lists, guaranteeing to go left-to-right. ;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; ;;; in which case this procedure may simply be defined as a synonym for MAP. (define (map-in-order f lis1 . lists) (check-arg procedure? f map-in-order) (if (pair? lists) (let recur ((lists (cons lis1 lists))) (receive (cars cdrs) (%cars+cdrs lists) (if (pair? cars) (let ((x (apply f cars))) ; Do head first, (cons x (recur cdrs))) ; then tail. '()))) ;; Fast path. (let recur ((lis lis1)) (if (null-list? lis) lis (let ((tail (cdr lis)) (x (f (car lis)))) ; Do head first, (cons x (recur tail))))))) ; then tail. ;;; We extend MAP to handle arguments of unequal length. (define map map-in-order) ;; Added by yamaken 2007-06-15 (define for-each (lambda args (apply map-in-order args) %srfi-1:undefined)) ;;; filter, remove, partition ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not ;;; disorder the elements of their argument. ;; This FILTER shares the longest tail of L that has no deleted elements. ;; If Scheme had multi-continuation calls, they could be made more efficient. (define (filter pred lis) ; Sleazing with EQ? makes this (check-arg procedure? pred filter) ; one faster. (let recur ((lis lis)) (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. (let ((head (car lis)) (tail (cdr lis))) (if (pred head) (let ((new-tail (recur tail))) ; Replicate the RECUR call so (if (eq? tail new-tail) lis (cons head new-tail))) (recur tail)))))) ; this one can be a tail call. ;;; Another version that shares longest tail. ;(define (filter pred lis) ; (receive (ans no-del?) ; ;; (recur l) returns L with (pred x) values filtered. ; ;; It also returns a flag NO-DEL? if the returned value ; ;; is EQ? to L, i.e. if it didn't have to delete anything. ; (let recur ((l l)) ; (if (null-list? l) (values l #t) ; (let ((x (car l)) ; (tl (cdr l))) ; (if (pred x) ; (receive (ans no-del?) (recur tl) ; (if no-del? ; (values l #t) ; (values (cons x ans) #f))) ; (receive (ans no-del?) (recur tl) ; Delete X. ; (values ans #f)))))) ; ans)) ;(define (filter! pred lis) ; Things are much simpler ; (let recur ((lis lis)) ; if you are willing to ; (if (pair? lis) ; push N stack frames & do N ; (cond ((pred (car lis)) ; SET-CDR! writes, where N is ; (set-cdr! lis (recur (cdr lis))); the length of the answer. ; lis) ; (else (recur (cdr lis)))) ; lis))) ;;; This implementation of FILTER! ;;; - doesn't cons, and uses no stack; ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are ;;; usually expensive on modern machines, and can be extremely expensive on ;;; modern Schemes (e.g., ones that have generational GC's). ;;; It just zips down contiguous runs of in and out elts in LIS doing the ;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the ;;; beginning of the next. (define (filter! pred lis) (check-arg procedure? pred filter!) (let lp ((ans lis)) (cond ((null-list? ans) ans) ; Scan looking for ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. ;; ANS is the eventual answer. ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. ;; Scan over a contiguous segment of the list that ;; satisfies PRED. ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous ;; segment of the list that *doesn't* satisfy PRED. ;; When the segment ends, patch in a link from PREV ;; to the start of the next good segment, and jump to ;; SCAN-IN. (else (letrec ((scan-in (lambda (prev lis) (if (pair? lis) (if (pred (car lis)) (scan-in lis (cdr lis)) (scan-out prev (cdr lis)))))) (scan-out (lambda (prev lis) (let lp ((lis lis)) (if (pair? lis) (if (pred (car lis)) (begin (set-cdr! prev lis) (scan-in lis (cdr lis))) (lp (cdr lis))) (set-cdr! prev lis)))))) (scan-in ans (cdr ans)) ans))))) ;;; Answers share common tail with LIS where possible; ;;; the technique is slightly subtle. (define (partition pred lis) (check-arg procedure? pred partition) (let recur ((lis lis)) (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. (let ((elt (car lis)) (tail (cdr lis))) (receive (in out) (recur tail) (if (pred elt) (values (if (pair? out) (cons elt in) lis) out) (values in (if (pair? in) (cons elt out) lis)))))))) ;(define (partition! pred lis) ; Things are much simpler ; (let recur ((lis lis)) ; if you are willing to ; (if (null-list? lis) (values lis lis) ; push N stack frames & do N ; (let ((elt (car lis))) ; SET-CDR! writes, where N is ; (receive (in out) (recur (cdr lis)) ; the length of LIS. ; (cond ((pred elt) ; (set-cdr! lis in) ; (values lis out)) ; (else (set-cdr! lis out) ; (values in lis)))))))) ;;; This implementation of PARTITION! ;;; - doesn't cons, and uses no stack; ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are ;;; usually expensive on modern machines, and can be extremely expensive on ;;; modern Schemes (e.g., ones that have generational GC's). ;;; It just zips down contiguous runs of in and out elts in LIS doing the ;;; minimal number of SET-CDR!s to splice these runs together into the result ;;; lists. (define (partition! pred lis) (check-arg procedure? pred partition!) (if (null-list? lis) (values lis lis) ;; This pair of loops zips down contiguous in & out runs of the ;; list, splicing the runs together. The invariants are ;; SCAN-IN: (cdr in-prev) = LIS. ;; SCAN-OUT: (cdr out-prev) = LIS. (letrec ((scan-in (lambda (in-prev out-prev lis) (let lp ((in-prev in-prev) (lis lis)) (if (pair? lis) (if (pred (car lis)) (lp lis (cdr lis)) (begin (set-cdr! out-prev lis) (scan-out in-prev lis (cdr lis)))) (set-cdr! out-prev lis))))) ; Done. (scan-out (lambda (in-prev out-prev lis) (let lp ((out-prev out-prev) (lis lis)) (if (pair? lis) (if (pred (car lis)) (begin (set-cdr! in-prev lis) (scan-in lis out-prev (cdr lis))) (lp lis (cdr lis))) (set-cdr! in-prev lis)))))) ; Done. ;; Crank up the scan&splice loops. (if (pred (car lis)) ;; LIS begins in-list. Search for out-list's first pair. (let lp ((prev-l lis) (l (cdr lis))) (cond ((not (pair? l)) (values lis l)) ((pred (car l)) (lp l (cdr l))) (else (scan-out prev-l l (cdr l)) (values lis l)))) ; Done. ;; LIS begins out-list. Search for in-list's first pair. (let lp ((prev-l lis) (l (cdr lis))) (cond ((not (pair? l)) (values l lis)) ((pred (car l)) (scan-in l prev-l (cdr l)) (values l lis)) ; Done. (else (lp l (cdr l))))))))) ;;; Inline us, please. (define (remove pred l) (filter (lambda (x) (not (pred x))) l)) (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) ;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. ;;; (I don't actually think these are the world's most important ;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants ;;; are far more general.) ;;; ;;; Function Action ;;; --------------------------------------------------------------------------- ;;; remove pred lis Delete by general predicate ;;; delete x lis [=] Delete by element comparison ;;; ;;; find pred lis Search by general predicate ;;; find-tail pred lis Search by general predicate ;;; member x lis [=] Search by element comparison ;;; ;;; assoc key lis [=] Search alist by key comparison ;;; alist-delete key alist [=] Alist-delete by key comparison (define (delete x lis . maybe-=) (let ((= (:optional maybe-= equal?))) (filter (lambda (y) (not (= x y))) lis))) (define (delete! x lis . maybe-=) (let ((= (:optional maybe-= equal?))) (filter! (lambda (y) (not (= x y))) lis))) ;;; Extended from R4RS to take an optional comparison argument. (define (member x lis . maybe-=) (let ((= (:optional maybe-= equal?))) (find-tail (lambda (y) (= x y)) lis))) ;;; R4RS, hence we don't bother to define. ;;; The MEMBER and then FIND-TAIL call should definitely ;;; be inlined for MEMQ & MEMV. ;(define (memq x lis) (member x lis eq?)) ;(define (memv x lis) (member x lis eqv?)) ;;; right-duplicate deletion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; delete-duplicates delete-duplicates! ;;; ;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates ;;; in long lists, sort the list to bring duplicates together, then use a ;;; linear-time algorithm to kill the dups. Or use an algorithm based on ;;; element-marking. The former gives you O(n lg n), the latter is linear. (define (delete-duplicates lis . maybe-=) (let ((elt= (:optional maybe-= equal?))) (check-arg procedure? elt= delete-duplicates) (let recur ((lis lis)) (if (null-list? lis) lis (let* ((x (car lis)) (tail (cdr lis)) (new-tail (recur (delete x tail elt=)))) (if (eq? tail new-tail) lis (cons x new-tail))))))) (define (delete-duplicates! lis . maybe-=) (let ((elt= (:optional maybe-= equal?))) (check-arg procedure? elt= delete-duplicates!) (let recur ((lis lis)) (if (null-list? lis) lis (let* ((x (car lis)) (tail (cdr lis)) (new-tail (recur (delete! x tail elt=)))) (if (eq? tail new-tail) lis (cons x new-tail))))))) ;;; alist stuff ;;;;;;;;;;;;;;; ;;; Extended from R4RS to take an optional comparison argument. (define (assoc x lis . maybe-=) (let ((= (:optional maybe-= equal?))) (find (lambda (entry) (= x (car entry))) lis))) (define (alist-cons key datum alist) (cons (cons key datum) alist)) (define (alist-copy alist) (map (lambda (elt) (cons (car elt) (cdr elt))) alist)) (define (alist-delete key alist . maybe-=) (let ((= (:optional maybe-= equal?))) (filter (lambda (elt) (not (= key (car elt)))) alist))) (define (alist-delete! key alist . maybe-=) (let ((= (:optional maybe-= equal?))) (filter! (lambda (elt) (not (= key (car elt)))) alist))) ;;; find find-tail take-while drop-while span break any every list-index ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (find pred list) (cond ((find-tail pred list) => car) (else #f))) (define (find-tail pred list) (check-arg procedure? pred find-tail) (let lp ((list list)) (and (not (null-list? list)) (if (pred (car list)) list (lp (cdr list)))))) (define (take-while pred lis) (check-arg procedure? pred take-while) (let recur ((lis lis)) (if (null-list? lis) '() (let ((x (car lis))) (if (pred x) (cons x (recur (cdr lis))) '()))))) (define (drop-while pred lis) (check-arg procedure? pred drop-while) (let lp ((lis lis)) (if (null-list? lis) '() (if (pred (car lis)) (lp (cdr lis)) lis)))) (define (take-while! pred lis) (check-arg procedure? pred take-while!) (if (or (null-list? lis) (not (pred (car lis)))) '() (begin (let lp ((prev lis) (rest (cdr lis))) (if (pair? rest) (let ((x (car rest))) (if (pred x) (lp rest (cdr rest)) (set-cdr! prev '()))))) lis))) (define (span pred lis) (check-arg procedure? pred span) (let recur ((lis lis)) (if (null-list? lis) (values '() '()) (let ((x (car lis))) (if (pred x) (receive (prefix suffix) (recur (cdr lis)) (values (cons x prefix) suffix)) (values '() lis)))))) (define (span! pred lis) (check-arg procedure? pred span!) (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) (let ((suffix (let lp ((prev lis) (rest (cdr lis))) (if (null-list? rest) rest (let ((x (car rest))) (if (pred x) (lp rest (cdr rest)) (begin (set-cdr! prev '()) rest))))))) (values lis suffix)))) (define (break pred lis) (span (lambda (x) (not (pred x))) lis)) (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) (define (any pred lis1 . lists) (check-arg procedure? pred any) (if (pair? lists) ;; N-ary case (receive (heads tails) (%cars+cdrs (cons lis1 lists)) (and (pair? heads) (let lp ((heads heads) (tails tails)) (receive (next-heads next-tails) (%cars+cdrs tails) (if (pair? next-heads) (or (apply pred heads) (lp next-heads next-tails)) (apply pred heads)))))) ; Last PRED app is tail call. ;; Fast path (and (not (null-list? lis1)) (let lp ((head (car lis1)) (tail (cdr lis1))) (if (null-list? tail) (pred head) ; Last PRED app is tail call. (or (pred head) (lp (car tail) (cdr tail)))))))) ;(define (every pred list) ; Simple definition. ; (let lp ((list list)) ; Doesn't return the last PRED value. ; (or (not (pair? list)) ; (and (pred (car list)) ; (lp (cdr list)))))) (define (every pred lis1 . lists) (check-arg procedure? pred every) (if (pair? lists) ;; N-ary case (receive (heads tails) (%cars+cdrs (cons lis1 lists)) (or (not (pair? heads)) (let lp ((heads heads) (tails tails)) (receive (next-heads next-tails) (%cars+cdrs tails) (if (pair? next-heads) (and (apply pred heads) (lp next-heads next-tails)) (apply pred heads)))))) ; Last PRED app is tail call. ;; Fast path (or (null-list? lis1) (let lp ((head (car lis1)) (tail (cdr lis1))) (if (null-list? tail) (pred head) ; Last PRED app is tail call. (and (pred head) (lp (car tail) (cdr tail)))))))) (define (list-index pred lis1 . lists) (check-arg procedure? pred list-index) (if (pair? lists) ;; N-ary case (let lp ((lists (cons lis1 lists)) (n 0)) (receive (heads tails) (%cars+cdrs lists) (and (pair? heads) (if (apply pred heads) n (lp tails (+ n 1)))))) ;; Fast path (let lp ((lis lis1) (n 0)) (and (not (null-list? lis)) (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) ;;; Reverse ;;;;;;;;;;; ;R4RS, so not defined here. ;(define (reverse lis) (fold cons '() lis)) ;(define (reverse! lis) ; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) (define (reverse! lis) (let lp ((lis lis) (ans '())) (if (null-list? lis) ans (let ((tail (cdr lis))) (set-cdr! lis ans) (lp tail lis))))) ;;; Lists-as-sets ;;;;;;;;;;;;;;;;; ;;; This is carefully tuned code; do not modify casually. ;;; - It is careful to share storage when possible; ;;; - Side-effecting code tries not to perform redundant writes. ;;; - It tries to avoid linear-time scans in special cases where constant-time ;;; computations can be performed. ;;; - It relies on similar properties from the other list-lib procs it calls. ;;; For example, it uses the fact that the implementations of MEMBER and ;;; FILTER in this source code share longest common tails between args ;;; and results to get structure sharing in the lset procedures. (define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) (define (lset<= = . lists) (check-arg procedure? = lset<=) (or (not (pair? lists)) ; 0-ary case (let lp ((s1 (car lists)) (rest (cdr lists))) (or (not (pair? rest)) (let ((s2 (car rest)) (rest (cdr rest))) (and (or (eq? s2 s1) ; Fast path (%lset2<= = s1 s2)) ; Real test (lp s2 rest))))))) (define (lset= = . lists) (check-arg procedure? = lset=) (or (not (pair? lists)) ; 0-ary case (let lp ((s1 (car lists)) (rest (cdr lists))) (or (not (pair? rest)) (let ((s2 (car rest)) (rest (cdr rest))) (and (or (eq? s1 s2) ; Fast path (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test (lp s2 rest))))))) (define (lset-adjoin = lis . elts) (check-arg procedure? = lset-adjoin) (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) lis elts)) (define (lset-union = . lists) (check-arg procedure? = lset-union) (reduce (lambda (lis ans) ; Compute ANS + LIS. (cond ((null? lis) ans) ; Don't copy any lists ((null? ans) lis) ; if we don't have to. ((eq? lis ans) ans) (else (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) ans (cons elt ans))) ans lis)))) '() lists)) (define (lset-union! = . lists) (check-arg procedure? = lset-union!) (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. (cond ((null? lis) ans) ; Don't copy any lists ((null? ans) lis) ; if we don't have to. ((eq? lis ans) ans) (else (pair-fold (lambda (pair ans) (let ((elt (car pair))) (if (any (lambda (x) (= x elt)) ans) ans (begin (set-cdr! pair ans) pair)))) ans lis)))) '() lists)) (define (lset-intersection = lis1 . lists) (check-arg procedure? = lset-intersection) (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. (cond ((any null-list? lists) '()) ; Short cut ((null? lists) lis1) ; Short cut (else (filter (lambda (x) (every (lambda (lis) (member x lis =)) lists)) lis1))))) (define (lset-intersection! = lis1 . lists) (check-arg procedure? = lset-intersection!) (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. (cond ((any null-list? lists) '()) ; Short cut ((null? lists) lis1) ; Short cut (else (filter! (lambda (x) (every (lambda (lis) (member x lis =)) lists)) lis1))))) (define (lset-difference = lis1 . lists) (check-arg procedure? = lset-difference) (let ((lists (filter pair? lists))) ; Throw out empty lists. (cond ((null? lists) lis1) ; Short cut ((memq lis1 lists) '()) ; Short cut (else (filter (lambda (x) (every (lambda (lis) (not (member x lis =))) lists)) lis1))))) (define (lset-difference! = lis1 . lists) (check-arg procedure? = lset-difference!) (let ((lists (filter pair? lists))) ; Throw out empty lists. (cond ((null? lists) lis1) ; Short cut ((memq lis1 lists) '()) ; Short cut (else (filter! (lambda (x) (every (lambda (lis) (not (member x lis =))) lists)) lis1))))) (define (lset-xor = . lists) (check-arg procedure? = lset-xor) (reduce (lambda (b a) ; Compute A xor B: ;; Note that this code relies on the constant-time ;; short-cuts provided by LSET-DIFF+INTERSECTION, ;; LSET-DIFFERENCE & APPEND to provide constant-time short ;; cuts for the cases A = (), B = (), and A eq? B. It takes ;; a careful case analysis to see it, but it's carefully ;; built in. ;; Compute a-b and a^b, then compute b-(a^b) and ;; cons it onto the front of a-b. (receive (a-b a-int-b) (lset-diff+intersection = a b) (cond ((null? a-b) (lset-difference = b a)) ((null? a-int-b) (append b a)) (else (fold (lambda (xb ans) (if (member xb a-int-b =) ans (cons xb ans))) a-b b))))) '() lists)) (define (lset-xor! = . lists) (check-arg procedure? = lset-xor!) (reduce (lambda (b a) ; Compute A xor B: ;; Note that this code relies on the constant-time ;; short-cuts provided by LSET-DIFF+INTERSECTION, ;; LSET-DIFFERENCE & APPEND to provide constant-time short ;; cuts for the cases A = (), B = (), and A eq? B. It takes ;; a careful case analysis to see it, but it's carefully ;; built in. ;; Compute a-b and a^b, then compute b-(a^b) and ;; cons it onto the front of a-b. (receive (a-b a-int-b) (lset-diff+intersection! = a b) (cond ((null? a-b) (lset-difference! = b a)) ((null? a-int-b) (append! b a)) (else (pair-fold (lambda (b-pair ans) (if (member (car b-pair) a-int-b =) ans (begin (set-cdr! b-pair ans) b-pair))) a-b b))))) '() lists)) (define (lset-diff+intersection = lis1 . lists) (check-arg procedure? = lset-diff+intersection) (cond ((every null-list? lists) (values lis1 '())) ; Short cut ((memq lis1 lists) (values '() lis1)) ; Short cut (else (partition (lambda (elt) (not (any (lambda (lis) (member elt lis =)) lists))) lis1)))) (define (lset-diff+intersection! = lis1 . lists) (check-arg procedure? = lset-diff+intersection!) (cond ((every null-list? lists) (values lis1 '())) ; Short cut ((memq lis1 lists) (values '() lis1)) ; Short cut (else (partition! (lambda (elt) (not (any (lambda (lis) (member elt lis =)) lists))) lis1)))) uim-1.8.8/sigscheme/ChangeLog0000644000175000017500000000000012535512017012753 00000000000000uim-1.8.8/sigscheme/INSTALL0000644000175000017500000003661413274722141012260 00000000000000Installation Instructions ************************* Copyright (C) 1994-1996, 1999-2002, 2004-2016 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without warranty of any kind. Basic Installation ================== Briefly, the shell command './configure && make && make install' should configure, build, and install this package. The following more-detailed instructions are generic; see the 'README' file for instructions specific to this package. Some packages provide this 'INSTALL' file but do not implement all of the features documented below. The lack of an optional feature in a given package is not necessarily a bug. More recommendations for GNU packages can be found in *note Makefile Conventions: (standards)Makefile Conventions. The 'configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a 'Makefile' in each directory of the package. It may also create one or more '.h' files containing system-dependent definitions. Finally, it creates a shell script 'config.status' that you can run in the future to recreate the current configuration, and a file 'config.log' containing compiler output (useful mainly for debugging 'configure'). It can also use an optional file (typically called 'config.cache' and enabled with '--cache-file=config.cache' or simply '-C') that saves the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try to figure out how 'configure' could check whether to do them, and mail diffs or instructions to the address given in the 'README' so they can be considered for the next release. If you are using the cache, and at some point 'config.cache' contains results you don't want to keep, you may remove or edit it. The file 'configure.ac' (or 'configure.in') is used to create 'configure' by a program called 'autoconf'. You need 'configure.ac' if you want to change it or regenerate 'configure' using a newer version of 'autoconf'. The simplest way to compile this package is: 1. 'cd' to the directory containing the package's source code and type './configure' to configure the package for your system. Running 'configure' might take a while. While running, it prints some messages telling which features it is checking for. 2. Type 'make' to compile the package. 3. Optionally, type 'make check' to run any self-tests that come with the package, generally using the just-built uninstalled binaries. 4. Type 'make install' to install the programs and any data files and documentation. When installing into a prefix owned by root, it is recommended that the package be configured and built as a regular user, and only the 'make install' phase executed with root privileges. 5. Optionally, type 'make installcheck' to repeat any self-tests, but this time using the binaries in their final installed location. This target does not install anything. Running this target as a regular user, particularly if the prior 'make install' required root privileges, verifies that the installation completed correctly. 6. You can remove the program binaries and object files from the source code directory by typing 'make clean'. To also remove the files that 'configure' created (so you can compile the package for a different kind of computer), type 'make distclean'. There is also a 'make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. 7. Often, you can also type 'make uninstall' to remove the installed files again. In practice, not all packages have tested that uninstallation works correctly, even though it is required by the GNU Coding Standards. 8. Some packages, particularly those that use Automake, provide 'make distcheck', which can by used by developers to test that all other targets like 'make install' and 'make uninstall' work correctly. This target is generally not run by end users. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the 'configure' script does not know about. Run './configure --help' for details on some of the pertinent environment variables. You can give 'configure' initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you can use GNU 'make'. 'cd' to the directory where you want the object files and executables to go and run the 'configure' script. 'configure' automatically checks for the source code in the directory that 'configure' is in and in '..'. This is known as a "VPATH" build. With a non-GNU 'make', it is safer to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use 'make distclean' before reconfiguring for another architecture. On MacOS X 10.5 and later systems, you can create libraries and executables that work on multiple system types--known as "fat" or "universal" binaries--by specifying multiple '-arch' options to the compiler but only a single '-arch' option to the preprocessor. Like this: ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CPP="gcc -E" CXXCPP="g++ -E" This is not guaranteed to produce working output in all cases, you may have to build one architecture at a time and combine the results using the 'lipo' tool if you have problems. Installation Names ================== By default, 'make install' installs the package's commands under '/usr/local/bin', include files under '/usr/local/include', etc. You can specify an installation prefix other than '/usr/local' by giving 'configure' the option '--prefix=PREFIX', where PREFIX must be an absolute file name. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you pass the option '--exec-prefix=PREFIX' to 'configure', the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give options like '--bindir=DIR' to specify different values for particular kinds of files. Run 'configure --help' for a list of the directories you can set and what kinds of files go in them. In general, the default for these options is expressed in terms of '${prefix}', so that specifying just '--prefix' will affect all of the other directory specifications that were not explicitly provided. The most portable way to affect installation locations is to pass the correct locations to 'configure'; however, many packages provide one or both of the following shortcuts of passing variable assignments to the 'make install' command line to change installation locations without having to reconfigure or recompile. The first method involves providing an override variable for each affected directory. For example, 'make install prefix=/alternate/directory' will choose an alternate location for all directory configuration variables that were expressed in terms of '${prefix}'. Any directories that were specified during 'configure', but not in terms of '${prefix}', must each be overridden at install time for the entire installation to be relocated. The approach of makefile variable overrides for each directory variable is required by the GNU Coding Standards, and ideally causes no recompilation. However, some platforms have known limitations with the semantics of shared libraries that end up requiring recompilation when using this method, particularly noticeable in packages that use GNU Libtool. The second method involves providing the 'DESTDIR' variable. For example, 'make install DESTDIR=/alternate/directory' will prepend '/alternate/directory' before all installation names. The approach of 'DESTDIR' overrides is not required by the GNU Coding Standards, and does not work on platforms that have drive letters. On the other hand, it does better at avoiding recompilation issues, and works well even when some directory options were not specified in terms of '${prefix}' at 'configure' time. Optional Features ================= If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving 'configure' the option '--program-prefix=PREFIX' or '--program-suffix=SUFFIX'. Some packages pay attention to '--enable-FEATURE' options to 'configure', where FEATURE indicates an optional part of the package. They may also pay attention to '--with-PACKAGE' options, where PACKAGE is something like 'gnu-as' or 'x' (for the X Window System). The 'README' should mention any '--enable-' and '--with-' options that the package recognizes. For packages that use the X Window System, 'configure' can usually find the X include and library files automatically, but if it doesn't, you can use the 'configure' options '--x-includes=DIR' and '--x-libraries=DIR' to specify their locations. Some packages offer the ability to configure how verbose the execution of 'make' will be. For these packages, running './configure --enable-silent-rules' sets the default to minimal output, which can be overridden with 'make V=1'; while running './configure --disable-silent-rules' sets the default to verbose, which can be overridden with 'make V=0'. Particular systems ================== On HP-UX, the default C compiler is not ANSI C compatible. If GNU CC is not installed, it is recommended to use the following options in order to use an ANSI C compiler: ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" and if that doesn't work, install pre-built binaries of GCC for HP-UX. HP-UX 'make' updates targets which have the same time stamps as their prerequisites, which makes it generally unusable when shipped generated files such as 'configure' are involved. Use GNU 'make' instead. On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot parse its '' header file. The option '-nodtk' can be used as a workaround. If GNU CC is not installed, it is therefore recommended to try ./configure CC="cc" and if that doesn't work, try ./configure CC="cc -nodtk" On Solaris, don't put '/usr/ucb' early in your 'PATH'. This directory contains several dysfunctional programs; working variants of these programs are available in '/usr/bin'. So, if you need '/usr/ucb' in your 'PATH', put it _after_ '/usr/bin'. On Haiku, software installed for all users goes in '/boot/common', not '/usr/local'. It is recommended to use the following options: ./configure --prefix=/boot/common Specifying the System Type ========================== There may be some features 'configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the _same_ architectures, 'configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the '--build=TYPE' option. TYPE can either be a short name for the system type, such as 'sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM where SYSTEM can have one of these forms: OS KERNEL-OS See the file 'config.sub' for the possible values of each field. If 'config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should use the option '--target=TYPE' to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will eventually be run) with '--host=TYPE'. Sharing Defaults ================ If you want to set default values for 'configure' scripts to share, you can create a site shell script called 'config.site' that gives default values for variables like 'CC', 'cache_file', and 'prefix'. 'configure' looks for 'PREFIX/share/config.site' if it exists, then 'PREFIX/etc/config.site' if it exists. Or, you can set the 'CONFIG_SITE' environment variable to the location of the site script. A warning: not all 'configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to 'configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the 'configure' command line, using 'VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified 'gcc' to be used as the C compiler (unless it is overridden in the site shell script). Unfortunately, this technique does not work for 'CONFIG_SHELL' due to an Autoconf limitation. Until the limitation is lifted, you can use this workaround: CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash 'configure' Invocation ====================== 'configure' recognizes the following options to control how it operates. '--help' '-h' Print a summary of all of the options to 'configure', and exit. '--help=short' '--help=recursive' Print a summary of the options unique to this package's 'configure', and exit. The 'short' variant lists options used only in the top level, while the 'recursive' variant lists options also present in any nested packages. '--version' '-V' Print the version of Autoconf used to generate the 'configure' script, and exit. '--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, traditionally 'config.cache'. FILE defaults to '/dev/null' to disable caching. '--config-cache' '-C' Alias for '--cache-file=config.cache'. '--quiet' '--silent' '-q' Do not print messages saying which checks are being made. To suppress all normal output, redirect it to '/dev/null' (any error messages will still be shown). '--srcdir=DIR' Look for the package's source code in directory DIR. Usually 'configure' can determine that directory automatically. '--prefix=DIR' Use DIR as the installation prefix. *note Installation Names:: for more details, including other options available for fine-tuning the installation locations. '--no-create' '-n' Run the configure checks, but stop before creating any output files. 'configure' also accepts some other, not widely useful, options. Run 'configure --help' for more details. uim-1.8.8/sigscheme/README0000644000175000017500000000633513274233465012112 00000000000000What's SigScheme ---------------- SigScheme is a R5RS Scheme interpreter for embedded use. Homepage: http://code.google.com/p/sigscheme/ Git repository: git clone https://github.com/uim/sigscheme.git See following files for further information. - doc/spec.txt: specifications of SigScheme - QALog: quality assurance state Please report us if you find a problem. And if you have a time, run 'make-report.sh' and send us the result regardless of PASSed or FAILed. It greatly helps the development, especially for non-PC platforms. Mailinglist: sigscheme-ja@googlegroups.com Features -------- - Conforms to R5RS basically (not fully) - R5RS hygienic macros (experimental) - Supports Following SRFIs - SRFI-0 : Feature-based conditional expansion construct - SRFI-1 : List Library - SRFI-2 : AND-LET*: an AND with local bindings, a guarded LET* special form - SRFI-6 : Basic String Ports - SRFI-8 : receive: Binding to multiple values - SRFI-9 : Defining Record Types - SRFI-22 : Running Scheme Scripts on Unix (partial) - SRFI-23 : Error Reporting Mechanism - SRFI-28 : Basic Format Strings - SRFI-34 : Exception Handling for Programs - SRFI-38 : External Representation for Data with Shared Structure (partial) - SRFI-43 : Vector library - SRFI-48 : Intermediate Format Strings - SRFI-55 : require-extension - SRFI-60 : Integer as Bits (partial) - SRFI-69 : Basic hash tables - SRFI-95 : Sorting and Merging - R6RS: R6RS characters (partial and preliminary) - Multibyte character encodings support - define-macro - let-optionals* for optional argument processing - Partial SIOD compatibility See doc/spec.txt and doc/design.txt for furtuer information. How to build ------------ GNU make is requied to build. Run ./configure with some options at the top directory. $ ./configure [--enable-conf=CONF] [--enable-default-encoding=ENCODING] (1) --enable-conf=CONF This specifies a base configuration set. Select one from the list below suitable for your purpose. - full: compile with full features but broken ones - regular: (default) compile with typically needed features - small: compile with primary features only - r5rs: compile with strict R5RS conformances - siod: emulate some SIOD features and bugs - dev: developer-friendly configuration - uim: configure for uim (2) --enable-default-encoding=ENCODING SigScheme normally selects UTF-8 as default encoding. You can change it by this option as follows. $ ./configure --enable-default-encoding=eucjp Following encodings can be specified. - utf8 - euccn - eucjp - euckr - sjis (3) --enable-ENCODING In addition to (2), you can enable other optional and switchable character encodings. $ ./configure --enable-default-encoding=eucjp --enable-eucjp --enable-sjis Then type 'make' at the top directory. $ make Test ---- $ make check Installation ------------ $ make install How to use ---------- To run SigScheme in interactive mode, type as follows. $ sscm To execute a Scheme script, specify it as argument. $ sscm Acknowledgements ---------------- Some parts of this software had been funded by IPA (http://www.ipa.go.jp/) uim-1.8.8/sigscheme/runtest.sh0000755000175000017500000000152112532333147013257 00000000000000#!/bin/sh SSCM="src/sscm --system-load-path $PWD/lib" if test "x$1" != "x"; then while test "$#" -ne 0; do $SSCM "$1" shift done exit 0 fi run_test () { echo "Running test $1..." $SSCM $1 echo } echo "[ Run single ported tests ]" for test in test/stone-srfi1.scm test/oleg-srfi2.scm test/panu-srfi69.scm #test/r5rs_pitfall.scm do run_test $test done echo "[ Run tests ported from SCM]" for test in test/scm-*.scm do run_test $test done echo "[ Run tests ported from Bigloo]" for test in test/bigloo-*.scm do run_test $test done echo "[ Run tests ported from Gauche ]" for test in test/gauche-*.scm do run_test $test done echo "[ Run SigScheme tests ]" for test in `ls test/test-*.scm | egrep -v 'test-tail-rec\.scm'` do run_test $test done echo "Run also runtest-tail-rec.sh for proper tail recursions." uim-1.8.8/sigscheme/TODO0000644000175000017500000000743312532333147011714 00000000000000============================================================================== High priority tasks: * (0.9) Efficient macro - Fix infinite loop on test-srfi1-another.scm - Introduce compilation phase (see "Macros" subsection of spec.txt) - Make macro expansion performed on compilation phase - Make runtime syntax sugars interpretation into macro expansions on compilation phase (such as internal definition or implicit lambda on define) - Validate as production quality * (0.9) Provide a record type - Evaluate SRFI-9 and R6RS records * (0.9) Introduce a standard unit testing framework - SRFI-64 "A Scheme API for test suites" * grep "FIXME" and fix them ============================================================================== Low priority bugs: * fileport_byte_readyp() does not support a FILE based on a pipe, or opened by fdopen(3) ============================================================================== Extensions: (not required for now) * Dynamically loadable binary module which allows user-written procedure * Complete SLIB support - Resolve the conflict of 'require' and 'provided?' with SigScheme - Make the slib.scm installable - Fill some variables with configure (slib.scm.in) * Make Symbian OS and BREW support working (patches are welcome) * Implement numbers other than integer - Define SAL accessors considering SRFI-50 and other implementations - Evaluate R6RS Arithmetic * Add ISO-2022-JP support to encoding.[hc] and scmport-mbchar.c. It requires encoding API fix on int2str() which lacks post-write state update * Add GB18030 to encoding.c * Add Big5 to encoding.c ============================================================================== Performance improvements: * %%identity-hash, %%string-hash, %%symbol-hash, %%string-ci-hash for SRFI-69 * (not required for now) Introduce SCM_QNULL for (quote ()) to reduce cons cell consumption, and support shortcuts for it in read.c and eval.c * (not required for now) Simplify read.c by table-based tokenizer * (not required for now) Support string of constant-width char - Define SigScheme's own internal multi-CCS code - Make UCS2 selectable as canonical internal code ============================================================================== Properness improvements: (not required for now) * Import http://sisc.sourceforge.net/r5rs_pitfall.scm - Fix hygienic-macro incapability of module_srfi34.c to catch errors into a failed result in the 'should-be' macro * Support R6RS style symbol escaping such as |-sym| * Reorganize unit test for C - Remove GNU sed dependency of test-c/collect.sh.in - Separate SigScheme-dependent part and generic part of test-c, and generalize the unit testing utils as usable for uim - Name 'the testing utils' ============================================================================== Logical simplifications: * Remove valuecons to increase simplicity * Remove the concept 'freecell' from SAL (turn it into ordinary list with freecell maker) * Remove the concept 'ScmCell' from sigscheme.h * Add SCM_TYPESAFE_MACRO for all I?SAL macros * (not required for now) Encode argument type information into ScmFuncTypeCode to remove ENSURE_*() from each procedure implementation * (not required for now) Reorganize list (argument) extraction API * (not required for now) Reorganize encoding and char codec API ============================================================================== Namings and Cosmetic things: * Consider renaming about typenames (e.g. ScmObj -> scm_obj) * Rename STL names (string, list) to another such as str, lst * Define the coding style for indent(1) and reform *.[ch] by it * [uim] Rename uim-scm.c to uim-scm-sigscheme.c (after the merger) ============================================================================== uim-1.8.8/sigscheme/test/0000755000175000017500000000000013275405526012262 500000000000000uim-1.8.8/sigscheme/test/test-formal-syntax.scm0000755000175000017500000004045012532333147016467 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; -*- buffer-file-coding-system: utf-8 -*- ;; Filename : test-formal-syntax.scm ;; About : unit test for R5RS formal syntax ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (define *test-track-progress* #f) ;; See "7.1 Formal syntax" of R5RS ;; See also test-number-literal.scm (tn "invalid boolean") (if sigscheme? (begin (assert-parse-error (tn) "#F") (assert-parse-error (tn) "#T")) (begin (assert-true (tn) (boolean? (string-read "#F"))) (assert-true (tn) (boolean? (string-read "#T"))))) (tn "boolean") (assert-true (tn) (boolean? (string-read "#f"))) (assert-true (tn) (boolean? (string-read "#t"))) (tn "invalid identifier") (assert-parse-error (tn) "#") (assert-parse-error (tn) ".") (assert-parse-error (tn) "..") (assert-parse-error (tn) "....") (assert-parse-error (tn) ".a") (assert-parse-error (tn) "+a") (assert-parse-error (tn) "++") (assert-parse-error (tn) "--") (assert-parse-error (tn) "-=") (assert-parse-error (tn) "-$") (assert-parse-error (tn) "-.") (assert-parse-error (tn) "-@") (assert-parse-error (tn) "@") (assert-parse-error (tn) "1a") (assert-parse-error (tn) "-a") (tn "special initial identifier") (assert-true (tn) (symbol? (string-read "!"))) (assert-true (tn) (symbol? (string-read "$"))) (assert-true (tn) (symbol? (string-read "%"))) (assert-true (tn) (symbol? (string-read "&"))) (assert-true (tn) (symbol? (string-read "*"))) (assert-true (tn) (symbol? (string-read "/"))) (assert-true (tn) (symbol? (string-read ":"))) (assert-true (tn) (symbol? (string-read "<"))) (assert-true (tn) (symbol? (string-read "="))) (assert-true (tn) (symbol? (string-read ">"))) (assert-true (tn) (symbol? (string-read "?"))) (assert-true (tn) (symbol? (string-read "^"))) (assert-true (tn) (symbol? (string-read "_"))) (assert-true (tn) (symbol? (string-read "~"))) (tn "special initial identifier + number") (assert-true (tn) (symbol? (string-read "!1"))) (assert-true (tn) (symbol? (string-read "$1"))) (assert-true (tn) (symbol? (string-read "%1"))) (assert-true (tn) (symbol? (string-read "&1"))) (assert-true (tn) (symbol? (string-read "*1"))) (assert-true (tn) (symbol? (string-read "/1"))) (assert-true (tn) (symbol? (string-read ":1"))) (assert-true (tn) (symbol? (string-read "<1"))) (assert-true (tn) (symbol? (string-read "=1"))) (assert-true (tn) (symbol? (string-read ">1"))) (assert-true (tn) (symbol? (string-read "?1"))) (assert-true (tn) (symbol? (string-read "^1"))) (assert-true (tn) (symbol? (string-read "_1"))) (assert-true (tn) (symbol? (string-read "~1"))) (tn "special initial identifier + letter") (assert-true (tn) (symbol? (string-read "!a"))) (assert-true (tn) (symbol? (string-read "$a"))) (assert-true (tn) (symbol? (string-read "%a"))) (assert-true (tn) (symbol? (string-read "&a"))) (assert-true (tn) (symbol? (string-read "*a"))) (assert-true (tn) (symbol? (string-read "/a"))) (assert-true (tn) (symbol? (string-read ":a"))) (assert-true (tn) (symbol? (string-read "a"))) (assert-true (tn) (symbol? (string-read "?a"))) (assert-true (tn) (symbol? (string-read "^a"))) (assert-true (tn) (symbol? (string-read "_a"))) (assert-true (tn) (symbol? (string-read "~a"))) (tn "identifier") (assert-true (tn) (symbol? (string-read "..."))) (assert-true (tn) (symbol? (string-read "+"))) (assert-true (tn) (symbol? (string-read "-"))) (assert-true (tn) (symbol? (string-read "a."))) (assert-true (tn) (symbol? (string-read "a+"))) (assert-true (tn) (symbol? (string-read "a-"))) (assert-true (tn) (symbol? (string-read "a@"))) (assert-true (tn) (symbol? (string-read "a1"))) ;; SigScheme 0.7.0 and later disallows initial hyphen of an identifier. (if sigscheme? (begin (assert-error (tn) (lambda () (symbol? (string-read "-a")))) (assert-true (tn) (symbol? (string->symbol "-a"))))) (tn "invalid dot pair") (assert-parse-error (tn) "( . )") (assert-parse-error (tn) "( . \"foo\")") (assert-parse-error (tn) "( . \"foo\" \"bar\")") (assert-parse-error (tn) "(\"foo\" . )") (assert-parse-error (tn) "(\"foo\" \"bar\" . )") (assert-parse-error (tn) "(\"foo\" . \"bar\" \"baz\")") (assert-parse-error (tn) "(\"foo\" \"bar\" . \"baz\" \"quux\")") (tn "invalid dot pair without left space") (assert-parse-error (tn) "(. )") (assert-parse-error (tn) "(. \"foo\")") (assert-parse-error (tn) "(. \"foo\" \"bar\")") (assert-parse-error (tn) "(\"foo\". )") (assert-parse-error (tn) "(\"foo\" \"bar\". )") (assert-parse-error (tn) "(\"foo\". \"bar\" \"baz\")") (assert-parse-error (tn) "(\"foo\" \"bar\". \"baz\" \"quux\")") (tn "dot pair") (assert-parseable (tn) "(\"foo\" . \"bar\")") (assert-parseable (tn) "(\"foo\" \"bar\" . \"baz\")") (tn "dot pair without left space") (assert-parseable (tn) "(\"foo\". \"bar\")") (assert-parseable (tn) "(\"foo\" \"bar\". \"baz\")") (let ((assert (if (and (provided? "sigscheme") (not (provided? "strict-r5rs"))) assert-parse-error assert-parseable))) (tn "invalid dot pair without right space") (assert (tn) "( .)") (assert (tn) "( .\"foo\")") (assert (tn) "( .\"foo\" \"bar\")") (assert (tn) "(\"foo\" .)") (assert (tn) "(\"foo\" \"bar\" .)") (assert (tn) "(\"foo\" .\"bar\" \"baz\")") (assert (tn) "(\"foo\" \"bar\" .\"baz\" \"quux\")") (tn "invalid dot pair without both space") (assert (tn) "(.)") (assert (tn) "(.\"foo\")") (assert (tn) "(.\"foo\" \"bar\")") (assert (tn) "(\"foo\".)") (assert (tn) "(\"foo\" \"bar\".)") (assert (tn) "(\"foo\".\"bar\" \"baz\")") (assert (tn) "(\"foo\" \"bar\".\"baz\" \"quux\")") (tn "dot pair without right space") (assert (tn) "(\"foo\" .\"bar\")") (assert (tn) "(\"foo\" \"bar\" .\"baz\")") (tn "dot pair without both space") (assert (tn) "(\"foo\".\"bar\")") (assert (tn) "(\"foo\" \"bar\".\"baz\")")) (assert-error "invalid function calling: boolean" (lambda () (#t))) (assert-error "invalid function calling: integer" (lambda () (1))) (assert-error "invalid function calling: null" (lambda () ('()))) (assert-error "invalid function calling: pair" (lambda () ('(1 2)))) (assert-error "invalid function calling: char" (lambda () (#\a))) (assert-error "invalid function calling: string" (lambda () ("a"))) (assert-error "invalid function calling: vector" (lambda () (#(1)))) (tn "function calling fixed_0") (define f (lambda () #t)) (assert-equal? (tn) #t (f)) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-error (tn) (lambda () (f #t #t))) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_0") (define f (lambda args args)) (assert-equal? (tn) '() (f)) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) '(#t) (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t #t #t) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling fixed_1") (define f (lambda (x) x)) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) #t (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-error (tn) (lambda () (f #t #t))) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_1") (define f (lambda (x . rest) (list x rest))) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) '(#t ()) (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t (#t)) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t (#t #t)) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling fixed_2") (define f (lambda (x y) (list x y))) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_2") (define f (lambda (x y . rest) (list x y rest))) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t ()) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t #t (#t)) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling fixed_0 for define-created closure") (define (f) #t) (assert-equal? (tn) #t (f)) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-error (tn) (lambda () (f #t #t))) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_0 for define-created closure") (define (f . args) args) (assert-equal? (tn) '() (f)) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) '(#t) (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t #t #t) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling fixed_1 for define-created closure") (define (f x) x) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) #t (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-error (tn) (lambda () (f #t #t))) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_1 for define-created closure") (define (f x . rest) (list x rest)) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-equal? (tn) '(#t ()) (f #t)) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t (#t)) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t (#t #t)) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling fixed_2 for define-created closure") (define (f x y) (list x y)) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-error (tn) (lambda () (f #t #t #t))) (assert-error (tn) (lambda () (f #t #t #t . #t))) (tn "function calling variadic_2 for define-created closure") (define (f x y . rest) (list x y rest)) (assert-error (tn) (lambda () (f))) (assert-error (tn) (lambda () (f . #t))) (assert-error (tn) (lambda () (f #t))) (assert-error (tn) (lambda () (f #t . #t))) (assert-equal? (tn) '(#t #t ()) (f #t #t)) (assert-error (tn) (lambda () (f #t #t . #t))) (assert-equal? (tn) '(#t #t (#t)) (f #t #t #t)) (assert-error (tn) (lambda () (f #t #t #t . #t))) ;; Although SigScheme's eval facility itself does not ensure properness of ;; syntax args, each syntax implementation must check it. These tests only ;; indicate what should be done. (tn "syntax application fixed_0") ;; FIXME: no syntax with syntax_fixed_0 (assert-equal? (tn) #t ((lambda () #t))) (assert-error (tn) (lambda () ((lambda () #t) . #t))) (assert-error (tn) (lambda () ((lambda () #t) #t))) (assert-error (tn) (lambda () ((lambda () #t) #t . #t))) (assert-error (tn) (lambda () ((lambda () #t) #t #t))) (assert-error (tn) (lambda () ((lambda () #t) #t #t . #t))) (assert-error (tn) (lambda () ((lambda () #t) #t #t #t))) (assert-error (tn) (lambda () ((lambda () #t) #t #t #t . #t))) (tn "syntax application variadic_0") (assert-equal? (tn) #t (and)) (assert-error (tn) (lambda () (and . #t))) (assert-equal? (tn) #t (and #t)) (assert-error (tn) (lambda () (and #t . #t))) (assert-equal? (tn) #t (and #t #t)) (assert-error (tn) (lambda () (and #t #t . #t))) (assert-equal? (tn) #t (and #t #t #t)) (assert-error (tn) (lambda () (and #t #t #t . #t))) (tn "syntax application fixed_1") (assert-error (tn) (lambda () (quote))) (assert-error (tn) (lambda () (quote . #t))) (assert-equal? (tn) #t (quote #t)) (assert-error (tn) (lambda () (quote #t . #t))) (assert-error (tn) (lambda () (quote #t #t))) (assert-error (tn) (lambda () (quote #t #t . #t))) (assert-error (tn) (lambda () (quote #t #t #t))) (assert-error (tn) (lambda () (quote #t #t #t . #t))) (tn "syntax application variadic_1") (assert-error (tn) (lambda () (let*))) (assert-error (tn) (lambda () (let* . #t))) (assert-error (tn) (lambda () (let* ()))) (assert-error (tn) (lambda () (let* #t . #t))) (assert-equal? (tn) #t (let* () #t)) (assert-error (tn) (lambda () (let* #t #t . #t))) (assert-equal? (tn) #t (let* () #t #t)) (assert-error (tn) (lambda () (let* #t #t #t . #t))) (tn "syntax application fixed_2") (define foo #f) (assert-error (tn) (lambda () (set!))) (assert-error (tn) (lambda () (set! . #t))) (assert-error (tn) (lambda () (set! #t))) (assert-error (tn) (lambda () (set! #t . #t))) (if (and (provided? "sigscheme") (provided? "strict-r5rs")) (assert-equal? (tn) (undef) (set! foo #t)) (assert-equal? (tn) #t (set! foo #t))) (assert-error (tn) (lambda () (set! #t #t . #t))) (assert-error (tn) (lambda () (set! #t #t #t))) (assert-error (tn) (lambda () (set! #t #t #t . #t))) (tn "syntax application variadic_2") (assert-error (tn) (lambda () (if))) (assert-error (tn) (lambda () (if . #t))) (assert-error (tn) (lambda () (if #t))) (assert-error (tn) (lambda () (if #t . #t))) (assert-equal? (tn) #t (if #t #t)) (assert-error (tn) (lambda () (if #t #t . #t))) (assert-equal? (tn) #t (if #t #t #t)) (assert-error (tn) (lambda () (if #t #t #t . #t))) (tn "EOF immediately after quoter") ;; (quote #) is invalid (assert-error (tn) (lambda () (string-read "'"))) (assert-error (tn) (lambda () (string-read "`"))) (assert-error (tn) (lambda () (string-read ","))) (assert-error (tn) (lambda () (string-read ",@"))) (total-report) uim-1.8.8/sigscheme/test/test-list.scm0000644000175000017500000003307412532333147014637 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; -*- buffer-file-coding-system: utf-8 -*- ;; Filename : test-list.scm ;; About : unit test for list operations ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (define elm0 (list #t)) (define elm1 (list #t)) (define elm2 (list #t)) (define elm3 (list #t)) (define nil '()) (define cdr3 (cons elm3 nil)) (define cdr2 (cons elm2 cdr3)) (define cdr1 (cons elm1 cdr2)) (define cdr0 (cons elm0 cdr1)) (define lst cdr0) ;; circular lists (define clst1 (list 1)) (set-cdr! clst1 clst1) (define clst2 (list 1 2)) (set-cdr! (list-tail clst2 1) clst2) (define clst3 (list 1 2 3)) (set-cdr! (list-tail clst3 2) clst3) (define clst4 (list 1 2 3 4)) (set-cdr! (list-tail clst4 3) clst4) (tn "null?") (if (and (provided? "sigscheme") (provided? "siod-bugs")) (assert-eq? (tn) #t (null? #f)) (assert-eq? (tn) #f (null? #f))) (assert-eq? (tn) #f (null? #t)) (assert-eq? (tn) #t (null? '())) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (null? (eof))) (assert-eq? (tn) #f (null? (undef))))) (assert-eq? (tn) #f (null? 0)) (assert-eq? (tn) #f (null? 1)) (assert-eq? (tn) #f (null? 3)) (assert-eq? (tn) #f (null? -1)) (assert-eq? (tn) #f (null? -3)) (assert-eq? (tn) #f (null? 'symbol)) (assert-eq? (tn) #f (null? 'SYMBOL)) (assert-eq? (tn) #f (null? #\a)) (assert-eq? (tn) #f (null? #\ã‚)) (assert-eq? (tn) #f (null? "")) (assert-eq? (tn) #f (null? " ")) (assert-eq? (tn) #f (null? "a")) (assert-eq? (tn) #f (null? "A")) (assert-eq? (tn) #f (null? "aBc12!")) (assert-eq? (tn) #f (null? "ã‚")) (assert-eq? (tn) #f (null? "ã‚0イã†12!")) (assert-eq? (tn) #f (null? +)) (assert-eq? (tn) #f (null? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (null? else))) ;; expression keyword (assert-error (tn) (lambda () (null? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (null? k)))) (assert-eq? (tn) #f (null? (current-output-port))) (assert-eq? (tn) #f (null? '(#t . #t))) (assert-eq? (tn) #f (null? (cons #t #t))) (assert-eq? (tn) #f (null? '(0 1 2))) (assert-eq? (tn) #f (null? (list 0 1 2))) ;; improper lists (assert-eq? (tn) #f (null? '(0 . 1))) (assert-eq? (tn) #f (null? '(0 1 . 2))) (assert-eq? (tn) #f (null? '(0 1 2 . 3))) ;; circular lists (assert-eq? (tn) #f (null? clst1)) (assert-eq? (tn) #f (null? clst2)) (assert-eq? (tn) #f (null? clst3)) (assert-eq? (tn) #f (null? clst4)) (assert-eq? (tn) #f (null? '#())) (assert-eq? (tn) #f (null? (vector))) (assert-eq? (tn) #f (null? '#(0 1 2))) (assert-eq? (tn) #f (null? (vector 0 1 2))) (tn "list?") (if (and (provided? "sigscheme") (provided? "siod-bugs")) (assert-eq? (tn) #t (list? #f)) (assert-eq? (tn) #f (list? #f))) (assert-eq? (tn) #f (list? #t)) (assert-eq? (tn) #t (list? '())) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (list? (eof))) (assert-eq? (tn) #f (list? (undef))))) (assert-eq? (tn) #f (list? 0)) (assert-eq? (tn) #f (list? 1)) (assert-eq? (tn) #f (list? 3)) (assert-eq? (tn) #f (list? -1)) (assert-eq? (tn) #f (list? -3)) (assert-eq? (tn) #f (list? 'symbol)) (assert-eq? (tn) #f (list? 'SYMBOL)) (assert-eq? (tn) #f (list? #\a)) (assert-eq? (tn) #f (list? #\ã‚)) (assert-eq? (tn) #f (list? "")) (assert-eq? (tn) #f (list? " ")) (assert-eq? (tn) #f (list? "a")) (assert-eq? (tn) #f (list? "A")) (assert-eq? (tn) #f (list? "aBc12!")) (assert-eq? (tn) #f (list? "ã‚")) (assert-eq? (tn) #f (list? "ã‚0イã†12!")) (assert-eq? (tn) #f (list? +)) (assert-eq? (tn) #f (list? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (list? else))) ;; expression keyword (assert-error (tn) (lambda () (list? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (list? k)))) (assert-eq? (tn) #f (list? (current-output-port))) (assert-eq? (tn) #f (list? '(#t . #t))) (assert-eq? (tn) #f (list? (cons #t #t))) (assert-eq? (tn) #t (list? '(0 1 2))) (assert-eq? (tn) #t (list? (list 0 1 2))) ;; improper lists (assert-eq? (tn) #f (list? '(0 . 1))) (assert-eq? (tn) #f (list? '(0 1 . 2))) (assert-eq? (tn) #f (list? '(0 1 2 . 3))) ;; circular lists (assert-eq? (tn) #f (list? clst1)) (assert-eq? (tn) #f (list? clst2)) (assert-eq? (tn) #f (list? clst3)) (assert-eq? (tn) #f (list? clst4)) (assert-eq? (tn) #f (list? '#())) (assert-eq? (tn) #f (list? (vector))) (assert-eq? (tn) #f (list? '#(0 1 2))) (assert-eq? (tn) #f (list? (vector 0 1 2))) (tn "list? from R5RS examples") (assert-eq? (tn) #t (list? '(a b c))) (assert-eq? (tn) #t (list? '())) (assert-eq? (tn) #f (list? '(a . b))) (assert-eq? (tn) #f (list? '(a b . c))) (assert-eq? (tn) #f (let ((x (list 'a))) (set-cdr! x x) (list? x))) (tn "list") (assert-equal? (tn) '() (list)) (assert-equal? (tn) '(a) (list 'a)) (assert-equal? (tn) '(7) (list (+ 3 4))) (assert-equal? (tn) '(7 a c) (list (+ 3 4) 'a 'c)) (assert-equal? (tn) '(a 7 c) (list 'a (+ 3 4) 'c)) (assert-equal? (tn) '(a c 7) (list 'a 'c (+ 3 4))) (assert-error (tn) (lambda () (list . 0))) (assert-error (tn) (lambda () (list 0 . 1))) (tn "length proper lists") (assert-equal? (tn) 0 (length '())) (assert-equal? (tn) 1 (length '(1))) (assert-equal? (tn) 2 (length '(1 2))) (assert-equal? (tn) 3 (length '(1 2 3))) (assert-equal? (tn) 4 (length '(1 2 3 4))) (tn "length improper lists") (assert-error (tn) (lambda () (length #t))) (assert-error (tn) (lambda () (length '(#t . #t)))) (assert-error (tn) (lambda () (length '(#t #t . #t)))) (assert-error (tn) (lambda () (length '(#t #t #t . #t)))) (assert-error (tn) (lambda () (length '(#t #t #t #t . #t)))) (assert-error (tn) (lambda () (length 0))) (assert-error (tn) (lambda () (length '(1 . 2)))) (assert-error (tn) (lambda () (length '(1 2 . 3)))) (assert-error (tn) (lambda () (length '(1 2 3 . 4)))) (assert-error (tn) (lambda () (length '(1 2 3 4 . 5)))) (tn "length circular lists") (assert-error (tn) (lambda () (length clst1))) (assert-error (tn) (lambda () (length clst2))) (assert-error (tn) (lambda () (length clst3))) (assert-error (tn) (lambda () (length clst4))) (tn "length from R5RS examples") (assert-equal? (tn) 3 (length '(a b c))) (assert-equal? (tn) 3 (length '(a (b) (c d e)))) (assert-equal? (tn) 0 (length '())) (tn "append") (assert-equal? (tn) '() (append)) (assert-equal? (tn) '() (append '())) (assert-equal? (tn) '() (append '() '())) (assert-equal? (tn) '() (append '() '() '())) (assert-equal? (tn) '(a) (append '(a) '() '())) (assert-equal? (tn) '(a) (append '() '(a) '())) (assert-equal? (tn) '(a) (append '() '() '(a))) (assert-equal? (tn) 'a (append 'a)) (assert-error (tn) (lambda () (append 'a 'b))) (assert-error (tn) (lambda () (append 'a '(b)))) (assert-error (tn) (lambda () (append 'a '()))) (assert-equal? (tn) '(a . b) (append '(a . b))) (assert-error (tn) (lambda () (append '(a . b) '()))) (assert-error (tn) (lambda () (append '() '(a . b) '()))) (assert-equal? (tn) '(a . b) (append '() '() '(a . b))) (assert-equal? (tn) '(1 2 3 a . b) (append '(1) '(2 3) '(a . b))) (assert-equal? (tn) 7 (append (+ 3 4))) (assert-equal? (tn) '(+ 3 4) (append '(+ 3 4))) (assert-equal? (tn) '(x y) (append '(x) '(y))) (assert-equal? (tn) '(a b c d) (append '(a) '(b c d))) (assert-equal? (tn) '(a (b) (c)) (append '(a (b)) '((c)))) (define w '(n o)) (define x '(d o)) (define y '(car)) (define z '(why)) (assert-equal? (tn) '(n o d o car why . ta) (append w x y () z 'ta)) (assert-equal? (tn) '(n o) w) ; test non-destructiveness (assert-eq? (tn) x (cdr (append '((Calpis hosi-)) x))) ; share last (tn "append from R5RS examples") (assert-equal? (tn) '(x y) (append '(x) '(y))) (assert-equal? (tn) '(a b c d) (append '(a) '(b c d))) (assert-equal? (tn) '(a (b) (c)) (append '(a (b)) '((c)))) (assert-equal? (tn) '(a b c . d) (append '(a b) '(c . d))) (assert-equal? (tn) 'a (append '() 'a)) (tn "reverse") (assert-equal? (tn) '() (reverse '())) (assert-error (tn) (lambda () (reverse))) (assert-error (tn) (lambda () (reverse '(a . b)))) (assert-error (tn) (lambda () (reverse 'a))) (assert-error (tn) (lambda () (reverse '() '()))) (assert-error (tn) (lambda () (reverse '(a) '()))) (assert-error (tn) (lambda () (reverse '() '(a)))) (tn "reverse from R5RS examples") (assert-equal? (tn) '(c b a) (reverse '(a b c))) (assert-equal? (tn) '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) (tn "list-tail") (assert-equal? (tn) '(a b c) (list-tail '(a b c) 0)) (assert-equal? (tn) '(b c) (list-tail '(a b c) 1)) (assert-equal? (tn) '(c) (list-tail '(a b c) 2)) (assert-equal? (tn) '() (list-tail '(a b c) 3)) (assert-error (tn) (lambda () (list-tail '(a b c) 4))) (assert-error (tn) (lambda () (list-tail '(a b c) -1))) (assert-equal? (tn) '() (list-tail '() 0)) (assert-error (tn) (lambda () (list-tail '() 1))) (assert-error (tn) (lambda () (list-tail '() -1))) (assert-eq? (tn) cdr0 (list-tail lst 0)) (assert-eq? (tn) cdr1 (list-tail lst 1)) (assert-eq? (tn) cdr2 (list-tail lst 2)) (assert-eq? (tn) cdr3 (list-tail lst 3)) (assert-eq? (tn) nil (list-tail lst 4)) (assert-error (tn) (lambda () (list-tail lst 5))) (assert-error (tn) (lambda () (list-tail lst -1))) (tn "list-tail improper list") (assert-equal? (tn) '(a b c . d) (list-tail '(a b c . d) 0)) (assert-equal? (tn) '(b c . d) (list-tail '(a b c . d) 1)) (assert-equal? (tn) '(c . d) (list-tail '(a b c . d) 2)) (assert-equal? (tn) 'd (list-tail '(a b c . d) 3)) (assert-error (tn) (lambda () (list-tail '(a b c . d) 4))) (assert-error (tn) (lambda () (list-tail '(a b c . d) -1))) (assert-equal? (tn) 'a (list-tail 'a 0)) (assert-error (tn) (lambda () (list-tail 'a 1))) (assert-error (tn) (lambda () (list-tail 'a -1))) (tn "list-ref") (assert-equal? (tn) 'a (list-ref '(a b c d) 0)) (assert-equal? (tn) 'b (list-ref '(a b c d) 1)) (assert-equal? (tn) 'c (list-ref '(a b c d) 2)) (assert-equal? (tn) 'd (list-ref '(a b c d) 3)) (assert-error (tn) (lambda () (list-ref '(a b c d) 4))) (assert-error (tn) (lambda () (list-ref '(a b c d) -1))) (assert-error (tn) (lambda () (list-ref '() 0))) (assert-error (tn) (lambda () (list-ref '() 1))) (assert-error (tn) (lambda () (list-ref '() -1))) (assert-eq? (tn) elm0 (list-ref lst 0)) (assert-eq? (tn) elm1 (list-ref lst 1)) (assert-eq? (tn) elm2 (list-ref lst 2)) (assert-eq? (tn) elm3 (list-ref lst 3)) (assert-error (tn) (lambda () (list-ref lst 4))) (assert-error (tn) (lambda () (list-ref lst -1))) (tn "list-ref improper list") (assert-equal? (tn) 'a (list-ref '(a b c . d) 0)) (assert-equal? (tn) 'b (list-ref '(a b c . d) 1)) (assert-equal? (tn) 'c (list-ref '(a b c . d) 2)) (assert-error (tn) (lambda () (list-ref '(a b c . d) 3))) (assert-error (tn) (lambda () (list-ref '(a b c . d) 4))) (assert-error (tn) (lambda () (list-ref '(a b c . d) -1))) (assert-error (tn) (lambda () (list-ref 'a 0))) (assert-error (tn) (lambda () (list-ref 'a 1))) (assert-error (tn) (lambda () (list-ref 'a -1))) (if sigscheme? (begin (require-extension (sscm-ext)) (tn "length* proper list") (assert-equal? (tn) 0 (length* '())) (assert-equal? (tn) 1 (length* '(1))) (assert-equal? (tn) 2 (length* '(1 2))) (assert-equal? (tn) 3 (length* '(1 2 3))) (assert-equal? (tn) 4 (length* '(1 2 3 4))) (tn "length* dotted list") (assert-equal? (tn) -1 (length* 1)) (assert-equal? (tn) -2 (length* '(1 . 2))) (assert-equal? (tn) -3 (length* '(1 2 . 3))) (assert-equal? (tn) -4 (length* '(1 2 3 . 4))) (assert-equal? (tn) -5 (length* '(1 2 3 4 . 5))) (tn "length* circular list") (assert-eq? (tn) #f (length* clst1)) (assert-eq? (tn) #f (length* clst2)) (assert-eq? (tn) #f (length* clst3)) (assert-eq? (tn) #f (length* clst4)))) (total-report) uim-1.8.8/sigscheme/test/oleg-srfi2.scm0000644000175000017500000002116412532333147014655 00000000000000;; Ported from http://pobox.com/~oleg/ftp/Scheme/vland.scm ;; License terms: ;; ;; http://pobox.com/~oleg/ftp/ ;; ;; "Unless specified otherwise, all the code and the documentation on this site ;; is in public domain." ;; ChangeLog ;; ;; 2007-06-13 yamaken Copied from "vland.scm,v 2.0 2002/06/28" and adapted ;; to SigScheme ; A special form and-let* ; Validation code ; ; AND-LET* (formerly known as LAND*) is an AND with local bindings, a ; guarded LET* special form. It evaluates a sequence of forms one ; after another till the first one that yields #f; the non-#f result ; of a form can be bound to a fresh variable and used in the ; subsequent forms. ; ; It is defined in SRFI-2 ; ; Motivation: ; When an ordinary AND is formed of _proper_ boolean expressions: ; (AND E1 E2 ...) ; ; the expression E2, if it gets to be evaluated, knows that E1 has ; returned non-#f. Moreover, E2 knows exactly what the result of E1 ; was - #t - so E2 can use this knowledge to its advantage. If E1 ; however is an _extended_ boolean expression, E2 can no longer tell ; which particular non-#f value was returned by E1. Chances are it ; took a lot of work to evaluate E1, and the produced result (a ; number, a vector, a string, etc) may be of value to E2. Alas, the ; AND form merely checks that the result is not an #f, and throws it ; away. If E2 needs it, it has to recompute the value again. This ; proposed AND-LET* special form lets constituent expressions get hold ; of the results of already evaluated expressions, without re-doing ; their work. ; ; Syntax: ; AND-LET* (CLAWS) BODY ; ; where CLAWS is a list of expressions or bindings: ; CLAWS ::= '() | (cons CLAW CLAWS) ; Every element of the CLAWS list, a CLAW, must be one of the following: ; (VARIABLE EXPRESSION) ; or ; (EXPRESSION) ; or ; BOUND-VARIABLE ; These CLAWS are evaluated in the strict left-to-right order. For each ; CLAW, the EXPRESSION part is evaluated first ; (or BOUND-VARIABLE is looked up). ; ; If the result is #f, AND-LET* immediately returns #f, ; thus disregarding the rest of the CLAWS and the BODY. If the ; EXPRESSION evaluates to not-#f, and the CLAW is of the form ; (VARIABLE EXPRESSION) ; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is ; available for _the rest_ of the CLAWS, and the BODY. ; ; Thus AND-LET* is a sort of cross-breed between LET* and AND. ; ; Denotation semantics: ; ; Eval[ (AND-LET* (CLAW1 ...) BODY), Env] = ; EvalClaw[ CLAW1, Env ] andalso ; Eval[ (AND-LET* ( ...) BODY), ExtClawEnv[ CLAW1, Env]] ; ; Eval[ (AND-LET* (CLAW) ), Env] = EvalClaw[ CLAW, Env ] ; Eval[ (AND-LET* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ] ; Eval[ (AND-LET* () ), Env] = #t ; ; EvalClaw[ BOUND-VARIABLE, Env ] = Eval[ BOUND-VARIABLE, Env ] ; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ] ; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ] ; ; ExtClawEnv[ BOUND-VARIABLE, Env ] = Env ; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ] ; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] = ; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ], ; VARIABLE boundto Eval[ EXPRESSION, Env ]] ; ; If AND-LET* is implemented as a macro, it converts a AND-LET* expression ; into a "tree" of AND and LET expressions. For example, ; ; (AND-LET* ((my-list (compute-list)) ((not (null? my-list)))) ; (do-something my-list)) ; is transformed into ; (and (let ((my-list (compute-list))) ; (and my-list (not (null? my-list)) (begin (do-something my-list))))) ; ; Sample applications: ; ; The following piece of code (from my treap package) ; (let ((new-root (node:dispatch-on-key root key ...))) ; (if new-root (set! root new-root))) ; could be elegantly re-written as ; (and-let* ((new-root (node:dispatch-on-key root key ...))) ; (set! root new-root)) ; ; A very common application of and-let* is looking up a value ; associated with a given key in an assoc list, returning #f in case of a ; look-up failure: ; ; ; Standard implementation ; (define (look-up key alist) ; (let ((found-assoc (assq key alist))) ; (and found-assoc (cdr found-assoc)))) ; ; ; A more elegant solution ; (define (look-up key alist) ; (cdr (or (assq key alist) '(#f . #f)))) ; ; ; An implementation which is just as graceful as the latter ; ; and just as efficient as the former: ; (define (look-up key alist) ; (and-let* ((x (assq key alist))) (cdr x))) ; ; Generalized cond: ; ; (or ; (and-let* (bindings-cond1) body1) ; (and-let* (bindings-cond2) body2) ; (begin else-clause)) ; ; Unlike => (cond's send), AND-LET* applies beyond cond. AND-LET* can ; also be used to generalize cond, as => is limited to sending of ; a single value; AND-LET* allows as many bindings as necessary ; (which are performed in sequence) ; ; (or ; (and-let* ((c (read-char)) ((not (eof-object? c)))) ; (string-set! some-str i c) (++! i)) ; (begin (do-process-eof))) ; ; Another concept AND-LET* is reminiscent of is programming with guards: ; an AND-LET* form can be considered a sequence of _guarded_ expressions. ; In a regular program, forms may produce results, bind them to variables ; and let other forms use these results. AND-LET* differs in that it checks ; to make sure that every produced result "makes sense" (that is, not an #f). ; The first "failure" triggers the guard and aborts the rest of the ; sequence (which presumably would not make any sense to execute anyway). ; ; $Id: vland.scm,v 2.0 2002/06/28 19:50:32 oleg Exp oleg $ ; -- make sure the implementation of and-let* is included. It is usually ; the part of my prelude. ; We also assume the the myenv prelude is included at this point, ; as well as SRFI-12. For Gambit, do the following: ; (include "myenv.scm") ; (include "srf-12.scm") ; prior to evaluation of this file. ; For example: gsi -e '(include "myenv.scm")(include "srfi-12.scm")' vland.scm ; For Bigloo, the following command line can be used: ; echo '(module test (include "myenv-bigloo.scm") (include "srfi-12.scm") ; (include "vland.scm"))' | bigloo -i -- (require-extension (unittest)) (require-extension (srfi 2)) (if (not (provided? "srfi-2")) (test-skip "SRFI-2 is not enabled")) (define tn test-name) (define expect (lambda (form expected-result) (assert-equal? (tn) expected-result (eval form (interaction-environment))))) (define must-be-a-syntax-error (lambda (form) (assert-error (tn) (lambda () (eval form (interaction-environment)))))) ;--- Test cases ; No claws (tn "and-let* no claws") (expect '(and-let* () 1) 1) (expect '(and-let* () 1 2) 2) (expect '(and-let* () ) #t) (must-be-a-syntax-error '(and-let* #f #t) ) (must-be-a-syntax-error '(and-let* #f) ) ; One claw, no body (tn "and-let* one claw, no body") (expect '(let ((x #f)) (and-let* (x))) #f) (expect '(let ((x 1)) (and-let* (x))) 1) (expect '(let ((x 1)) (and-let* ( (x) ))) 1) (expect '(let ((x 1)) (and-let* ( ((+ x 1)) ))) 2) (expect '(and-let* ((x #f)) ) #f) (expect '(and-let* ((x 1)) ) 1) (must-be-a-syntax-error '(and-let* ( #f (x 1))) ) ; two claws, no body (tn "and-let* two claws, no body") (expect '(and-let* ( (#f) (x 1)) ) #f) (must-be-a-syntax-error '(and-let* (2 (x 1))) ) (expect '(and-let* ( (2) (x 1)) ) 1) (expect '(and-let* ( (x 1) (2)) ) 2) (expect '(and-let* ( (x 1) x) ) 1) (expect '(and-let* ( (x 1) (x)) ) 1) ; two claws, body (tn "and-let* two claws, body") (expect '(let ((x #f)) (and-let* (x) x)) #f) (expect '(let ((x "")) (and-let* (x) x)) "") (expect '(let ((x "")) (and-let* (x) )) "") (expect '(let ((x 1)) (and-let* (x) (+ x 1))) 2) (expect '(let ((x #f)) (and-let* (x) (+ x 1))) #f) (expect '(let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2) (expect '(let ((x 1)) (and-let* (((positive? x))) )) #t) (expect '(let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f) (expect '(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3) (expect '(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))) 4 ) (expect '(let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2) (expect '(let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2) (expect '(let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f) (expect '(let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f) (expect '(let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f) (expect '(let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) (expect '(let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) (expect '(let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) (expect '(let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) (/ 3 2)) (total-report) uim-1.8.8/sigscheme/test/test-string.scm0000644000175000017500000003043412532333147015167 00000000000000;; Filename : test-string.scm ;; About : unit test for R5RS string ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; See also test-string-{core,null,pred,proc}.scm (require-extension (unittest)) (if (not (symbol-bound? 'string?)) (test-skip "R5RS strings is not enabled")) (define tn test-name) (define cp string-copy) (if (and (provided? "sigscheme") (not (symbol-bound? 'make-string))) (test-skip "string part of R5RS is not enabled")) (tn "symbol->string") (assert-equal? (tn) "a" (symbol->string 'a)) (assert-equal? (tn) "ab" (symbol->string 'ab)) ;; TODO: need to investigate (string->symbol "") behavior (tn "string->symbol immutable") (assert-equal? (tn) 'a (string->symbol "a")) (assert-equal? (tn) 'ab (string->symbol "ab")) (tn "string->symbol mutable") (assert-equal? (tn) 'a (string->symbol (cp "a"))) (assert-equal? (tn) 'ab (string->symbol (cp "ab"))) ;; ;; escape sequences ;; (define integer->string (lambda (i) (list->string (list (integer->char i))))) ;; R5RS compliant (tn "R5RS escape sequence") (assert-equal? (tn) (integer->string 34) "\"") ;; 34 (assert-equal? (tn) (list->string '(#\")) "\"") ;; 34 (assert-equal? (tn) '(#\") (string->list "\"")) ;; 34 (assert-equal? (tn) (integer->string 92) "\\") ;; 92 (assert-equal? (tn) (list->string '(#\\)) "\\") ;; 92 (assert-equal? (tn) '(#\\) (string->list "\\")) ;; 92 (assert-equal? (tn) (integer->string 10) "\n") ;; 110 (assert-equal? (tn) (list->string '(#\newline)) "\n") ;; 110 (assert-equal? (tn) '(#\newline) (string->list "\n")) ;; 110 ;; R6RS(SRFI-75) compliant (tn "R6RS escape sequence") ;; See also test-string-null.scm for "\x00" tests (assert-equal? (tn) (integer->string 7) "\a") ;; 97 (assert-equal? (tn) (list->string '(#\alarm)) "\a") ;; 97 (assert-equal? (tn) '(#\alarm) (string->list "\a")) ;; 97 (assert-equal? (tn) (integer->string 8) "\b") ;; 98 (assert-equal? (tn) (list->string '(#\backspace)) "\b") ;; 98 (assert-equal? (tn) '(#\backspace) (string->list "\b")) ;; 98 (assert-equal? (tn) (integer->string 12) "\f") ;; 102 (assert-equal? (tn) (list->string '(#\page)) "\f") ;; 102 (assert-equal? (tn) '(#\page) (string->list "\f")) ;; 102 (assert-equal? (tn) (integer->string 13) "\r") ;; 114 (assert-equal? (tn) (list->string '(#\return)) "\r") ;; 114 (assert-equal? (tn) '(#\return) (string->list "\r")) ;; 114 (assert-equal? (tn) (integer->string 9) "\t") ;; 116 (assert-equal? (tn) (list->string '(#\tab)) "\t") ;; 116 (assert-equal? (tn) '(#\tab) (string->list "\t")) ;; 116 (assert-equal? (tn) (integer->string 11) "\v") ;; 118 (assert-equal? (tn) (list->string '(#\vtab)) "\v") ;; 118 (assert-equal? (tn) '(#\vtab) (string->list "\v")) ;; 118 ;; "\|" is removed from final R6RS ;;(assert-error (tn) (integer->string 124) "\|") ;; 124 ;; All these conventional escape sequences should cause parse error as defined ;; in SRFI-75: "Any other character in a string after a backslash is an ;; error". (tn "conventional escape sequence") ;; "\0" ;; 0 (assert-parse-error (tn) "\"\\ \"") ;; 32 (assert-parse-error (tn) "\"\\!\"") ;; 33 ;; "\"" ;; 34 (assert-parse-error (tn) "\"\\#\"") ;; 35 (assert-parse-error (tn) "\"\\$\"") ;; 36 (assert-parse-error (tn) "\"\\%\"") ;; 37 (assert-parse-error (tn) "\"\\&\"") ;; 38 (assert-parse-error (tn) "\"\\'\"") ;; 39 (assert-parse-error (tn) "\"\\(\"") ;; 40 (assert-parse-error (tn) "\"\\)\"") ;; 41 (assert-parse-error (tn) "\"\\*\"") ;; 42 (assert-parse-error (tn) "\"\\+\"") ;; 43 (assert-parse-error (tn) "\"\\,\"") ;; 44 (assert-parse-error (tn) "\"\\-\"") ;; 45 (assert-parse-error (tn) "\"\\.\"") ;; 46 (assert-parse-error (tn) "\"\\/\"") ;; 47 (assert-parse-error (tn) "\"\\0\"") ;; 48 (assert-parse-error (tn) "\"\\1\"") ;; 49 (assert-parse-error (tn) "\"\\2\"") ;; 50 (assert-parse-error (tn) "\"\\3\"") ;; 51 (assert-parse-error (tn) "\"\\4\"") ;; 52 (assert-parse-error (tn) "\"\\5\"") ;; 53 (assert-parse-error (tn) "\"\\6\"") ;; 54 (assert-parse-error (tn) "\"\\7\"") ;; 55 (assert-parse-error (tn) "\"\\8\"") ;; 56 (assert-parse-error (tn) "\"\\9\"") ;; 57 (assert-parse-error (tn) "\"\\:\"") ;; 58 (assert-parse-error (tn) "\"\\;\"") ;; 59 (assert-parse-error (tn) "\"\\<\"") ;; 60 (assert-parse-error (tn) "\"\\=\"") ;; 61 (assert-parse-error (tn) "\"\\>\"") ;; 62 (assert-parse-error (tn) "\"\\?\"") ;; 63 (assert-parse-error (tn) "\"\\@\"") ;; 64 (assert-parse-error (tn) "\"\\A\"") ;; 65 (assert-parse-error (tn) "\"\\B\"") ;; 66 (assert-parse-error (tn) "\"\\C\"") ;; 67 (assert-parse-error (tn) "\"\\D\"") ;; 68 (assert-parse-error (tn) "\"\\E\"") ;; 69 (assert-parse-error (tn) "\"\\F\"") ;; 70 (assert-parse-error (tn) "\"\\G\"") ;; 71 (assert-parse-error (tn) "\"\\H\"") ;; 72 (assert-parse-error (tn) "\"\\I\"") ;; 73 (assert-parse-error (tn) "\"\\J\"") ;; 74 (assert-parse-error (tn) "\"\\K\"") ;; 75 (assert-parse-error (tn) "\"\\L\"") ;; 76 (assert-parse-error (tn) "\"\\M\"") ;; 77 (assert-parse-error (tn) "\"\\N\"") ;; 78 (assert-parse-error (tn) "\"\\O\"") ;; 79 (assert-parse-error (tn) "\"\\P\"") ;; 80 (assert-parse-error (tn) "\"\\Q\"") ;; 81 (assert-parse-error (tn) "\"\\R\"") ;; 82 (assert-parse-error (tn) "\"\\S\"") ;; 83 (assert-parse-error (tn) "\"\\T\"") ;; 84 (assert-parse-error (tn) "\"\\U\"") ;; 85 (assert-parse-error (tn) "\"\\V\"") ;; 86 (assert-parse-error (tn) "\"\\W\"") ;; 87 (assert-parse-error (tn) "\"\\X\"") ;; 88 (assert-parse-error (tn) "\"\\Y\"") ;; 89 (assert-parse-error (tn) "\"\\Z\"") ;; 90 (assert-parse-error (tn) "\"\\[\"") ;; 91 ;; "\\" ;; 92 (assert-parse-error (tn) "\"\\]\"") ;; 93 (assert-parse-error (tn) "\"\\^\"") ;; 94 (assert-parse-error (tn) "\"\\_\"") ;; 95 (assert-parse-error (tn) "\"\\`\"") ;; 96 ;; "\a" ;; 97 ;; "\b" ;; 98 (assert-parse-error (tn) "\"\\c\"") ;; 99 (assert-parse-error (tn) "\"\\d\"") ;; 100 (assert-parse-error (tn) "\"\\e\"") ;; 101 ;; "\f" ;; 102 (assert-parse-error (tn) "\"\\g\"") ;; 103 (assert-parse-error (tn) "\"\\h\"") ;; 104 (assert-parse-error (tn) "\"\\i\"") ;; 105 (assert-parse-error (tn) "\"\\j\"") ;; 106 (assert-parse-error (tn) "\"\\k\"") ;; 107 (assert-parse-error (tn) "\"\\l\"") ;; 108 (assert-parse-error (tn) "\"\\m\"") ;; 109 ;; "\n" ;; 110 (assert-parse-error (tn) "\"\\o\"") ;; 111 (assert-parse-error (tn) "\"\\p\"") ;; 112 (assert-parse-error (tn) "\"\\q\"") ;; 113 ;; "\r" ;; 114 (assert-parse-error (tn) "\"\\s\"") ;; 115 ;; "\t" ;; 116 (assert-parse-error (tn) "\"\\u\"") ;; 117 ;; "\v" ;; 118 (assert-parse-error (tn) "\"\\w\"") ;; 119 (assert-parse-error (tn) "\"\\x\"") ;; 120 (assert-parse-error (tn) "\"\\y\"") ;; 121 (assert-parse-error (tn) "\"\\z\"") ;; 122 (assert-parse-error (tn) "\"\\{\"") ;; 123 ;; "\|" is removed from final R6RS (assert-parse-error (tn) "\"\\|\"") ;; 124 (assert-parse-error (tn) "\"\\}\"") ;; 125 (assert-parse-error (tn) "\"\\~\"") ;; 126 ;; raw control chars (tn "raw control char in string literal") ;; See also test-string-null.scm for "" (charcode 0) test (assert-equal? (tn) (integer->string 1) "") ;; 1 (assert-equal? (tn) (integer->string 2) "") ;; 2 (assert-equal? (tn) (integer->string 3) "") ;; 3 (assert-equal? (tn) (integer->string 4) "") ;; 4 (assert-equal? (tn) (integer->string 5) "") ;; 5 (assert-equal? (tn) (integer->string 6) "") ;; 6 (assert-equal? (tn) (integer->string 7) "") ;; 7 (assert-equal? (tn) (integer->string 8) "") ;; 8 ;; DON'T EDIT THIS LINE! (assert-equal? (tn) (integer->string 9) " ") ;; 9 (assert-equal? (tn) (integer->string 10) " ") ;; 10 ;; DON'T EDIT THIS LINE! (assert-equal? (tn) (integer->string 11) " ") ;; 11 (assert-equal? (tn) (integer->string 12) " ") ;; 12 (assert-equal? (tn) (integer->string 13) " ") ;; 13 ;; DON'T EDIT THIS LINE! (assert-equal? (tn) (integer->string 14) "") ;; 14 (assert-equal? (tn) (integer->string 15) "") ;; 15 (assert-equal? (tn) (integer->string 16) "") ;; 16 (assert-equal? (tn) (integer->string 17) "") ;; 17 (assert-equal? (tn) (integer->string 18) "") ;; 18 (assert-equal? (tn) (integer->string 19) "") ;; 19 (assert-equal? (tn) (integer->string 20) "") ;; 20 (assert-equal? (tn) (integer->string 21) "") ;; 21 (assert-equal? (tn) (integer->string 22) "") ;; 22 (assert-equal? (tn) (integer->string 23) "") ;; 23 (assert-equal? (tn) (integer->string 24) "") ;; 24 (assert-equal? (tn) (integer->string 25) "") ;; 25 ;; DON'T EDIT THIS LINE! (assert-equal? (tn) (integer->string 26) "") ;; 26 (assert-equal? (tn) (integer->string 27) "") ;; 27 (assert-equal? (tn) (integer->string 28) "") ;; 28 (assert-equal? (tn) (integer->string 29) "") ;; 29 (assert-equal? (tn) (integer->string 30) "") ;; 30 (assert-equal? (tn) (integer->string 31) "") ;; 31 (assert-equal? (tn) (integer->string 127) "") ;; 127 ;; escaped raw control chars (tn "escaped raw control char in string literal") ;; See also test-string-null.scm for "" (charcode 0) test (assert-parse-error (tn) "\"\\\"") ;; 1 (assert-parse-error (tn) "\"\\\"") ;; 2 (assert-parse-error (tn) "\"\\\"") ;; 3 (assert-parse-error (tn) "\"\\\"") ;; 4 (assert-parse-error (tn) "\"\\\"") ;; 5 (assert-parse-error (tn) "\"\\\"") ;; 6 (assert-parse-error (tn) "\"\\\"") ;; 7 (assert-parse-error (tn) "\"\\\"") ;; 8 ;; DON'T EDIT THIS LINE! (assert-parse-error (tn) "\"\\ \"") ;; 9 (assert-parse-error (tn) "\"\\ \"") ;; 10 ;; DON'T EDIT THIS LINE! (assert-parse-error (tn) "\"\\ \"") ;; 11 (assert-parse-error (tn) "\"\\ \"") ;; 12 (assert-parse-error (tn) "\"\\ \"") ;; 13 ;; DON'T EDIT THIS LINE! (assert-parse-error (tn) "\"\\\"") ;; 14 (assert-parse-error (tn) "\"\\\"") ;; 15 (assert-parse-error (tn) "\"\\\"") ;; 16 (assert-parse-error (tn) "\"\\\"") ;; 17 (assert-parse-error (tn) "\"\\\"") ;; 18 (assert-parse-error (tn) "\"\\\"") ;; 19 (assert-parse-error (tn) "\"\\\"") ;; 20 (assert-parse-error (tn) "\"\\\"") ;; 21 (assert-parse-error (tn) "\"\\\"") ;; 22 (assert-parse-error (tn) "\"\\\"") ;; 23 (assert-parse-error (tn) "\"\\\"") ;; 24 (assert-parse-error (tn) "\"\\\"") ;; 25 ;; DON'T EDIT THIS LINE! (assert-parse-error (tn) "\"\\\"") ;; 26 (assert-parse-error (tn) "\"\\\"") ;; 27 (assert-parse-error (tn) "\"\\\"") ;; 28 (assert-parse-error (tn) "\"\\\"") ;; 29 (assert-parse-error (tn) "\"\\\"") ;; 30 (assert-parse-error (tn) "\"\\\"") ;; 31 (assert-parse-error (tn) "\"\\\"") ;; 127 (total-report) uim-1.8.8/sigscheme/test/bigloo-quote.scm0000644000175000017500000001052712532333147015313 00000000000000;; A practical implementation for the Scheme programming language ;; ;; ,--^, ;; _ ___/ /|/ ;; ,;'( )__, ) ' ;; ;; // L__. ;; ' \\ / ' ;; ^ ^ ;; ;; Copyright (c) 1992-2004 Manuel Serrano ;; ;; Bug descriptions, use reports, comments or suggestions are ;; welcome. Send them to ;; bigloo@sophia.inria.fr ;; http://www.inria.fr/mimosa/fp/Bigloo ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. More precisely, ;; ;; - The compiler and the tools are distributed under the terms of the ;; GNU General Public License. ;; ;; - The Bigloo run-time system and the libraries are distributed under ;; the terms of the GNU Library General Public License. The source code ;; of the Bigloo runtime system is located in the ./runtime directory. ;; The source code of the FairThreads library is located in the ;; ./fthread directory. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/recette/kwote.scm */ ;* */ ;* Author : Manuel Serrano */ ;* Creation : Tue Nov 3 10:22:02 1992 */ ;* Last change : Fri Jul 6 09:37:50 2001 (serrano) */ ;* */ ;* On test l'expansion des kwote */ ;*---------------------------------------------------------------------*/ ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Bigloo 2.6e and adapted to SigScheme (load "./test/unittest-bigloo.scm") ;*---------------------------------------------------------------------*/ ;* test-quote ... */ ;*---------------------------------------------------------------------*/ (define (test-quote) (test "quote" `(list ,(+ 1 2) 4) '(list 3 4)) (test "quote" (let ((name 'a)) `(list ,name ',name)) '(list a (quote a))) (test "quote" `(a ,(+ 1 2) ,@(map (lambda (x) (+ 10 x)) '(4 -5 6)) b) '(a 3 14 5 16 b)) (test "quote" `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '((cons)))) '((foo 7) cons)) (test "quote" `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)) (test "quote" (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e)) (test "quote" (quasiquote (list (unquote (+ 1 2)) 4)) '(list 3 4)) (test "quote" '(quasiquote (list (unquote (+ 1 2)) 4)) '`(list ,(+ 1 2) 4)) (test "quote" `#(1 2 ,(+ 1 2) ,(+ 2 2)) '#(1 2 3 4)) (test "quote" `#(1 2 ,(+ 1 2) ,@(map (lambda (x) (+ 1 x)) '(3 4)) 6) '#(1 2 3 4 5 6))) (test-quote) (total-report) uim-1.8.8/sigscheme/test/gauche-euc-jp.scm0000644000175000017500000002174512532333147015326 00000000000000#! /usr/bin/env sscm -C EUC-JP ;; Copyright (c) 2000-2004 Shiro Kawai, All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the authors nor the names of its contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED ;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Gauche 0.8.5 and adapted to SigScheme (load "./test/unittest-gauche.scm") ;;------------------------------------------------------------------- (test "string" "¤¤¤íh¤Ë¤Û¤Øt" (lambda () (string #\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t))) (test "list->string" "¤¤¤íh¤Ë¤Û¤Øt" (lambda () (list->string '(#\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t)))) (test "make-string" "¤Ø¤Ø¤Ø¤Ø¤Ø" (lambda () (make-string 5 #\¤Ø))) (test "make-string" "" (lambda () (make-string 0 #\¤Ø))) (test "string->list" '(#\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t) (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt"))) ;; SRFI-13 ;;(test "string->list" '(#\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t) ;; (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt" 1))) ;;(test "string->list" '(#\¤í #\h #\¤Ë) ;; (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt" 1 4))) (test "string-copy" '("¤¡¤ã¦Í¤£" #f) (lambda () (let* ((x "¤¡¤ã¦Í¤£") (y (string-copy x))) (list y (eq? x y))))) ;; SRFI-13 ;;(test "string-copy" "¤ã¦Í¤£" (lambda () (string-copy "¤¡¤ã¦Í¤£" 1))) ;;(test "string-copy" "¤ã¦Í" (lambda () (string-copy "¤¡¤ã¦Í¤£" 1 3))) (test "string-ref" #\¤í (lambda () (string-ref "¤¤¤í¤Ï" 1))) (define x (string-copy "¤¤¤í¤Ï¤Ë¤Û")) (test "string-set!" "¤¤¤íZ¤Ë¤Û" (lambda () (string-set! x 2 #\Z) x)) (test "string-fill!" "¤Î¤Î¤Î¤Î¤Î¤Î" (lambda () (let ((s (string-copy "000000"))) (string-fill! s #\¤Î) s))) ;; SRFI-13 ;;(test "string-fill!" "000¤Î¤Î¤Î" ;; (lambda () (string-fill! (string-copy "000000") #\¤Î 3))) ;;(test "string-fill!" "000¤Î¤Î0" ;; (lambda () (string-fill! (string-copy "000000") #\¤Î 3 5))) ;(test "string-join" "¤Õ¤¥ ¤Ð¤¡ ¤Ð¤º" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º")))) ;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª"))) ;(test "string-join" "¤Õ¤¥¢ª¢«¤Ð¤¡¢ª¢«¤Ð¤º" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¢ª¢«" 'infix))) ;(test "string-join" "" ; (lambda () (string-join '() "¢ª¢«"))) ;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º¡ª" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'suffix))) ;(test "string-join" "¡ª¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'prefix))) ;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º" ; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'strict-infix))) ;(test "string-substitute!" "¤¦¤¨¤ªdefghi" ; (lambda () ; (let ((s (string-copy "abcdefghi"))) ; (string-substitute! s 0 "¤¦¤¨¤ª") ; s))) ;(test "string-substitute!" "abc¤¦¤¨¤ªghi" ; (lambda () ; (let ((s (string-copy "abcdefghi"))) ; (string-substitute! s 3 "¤¦¤¨¤ª") ; s))) ;;------------------------------------------------------------------- ;(test-section "string-pointer") ;(define sp #f) ;(test "make-string-pointer" #t ; (lambda () ; (set! sp (make-string-pointer "¤¤¤í¤Ï¤Ëho¤Ø¤È")) ; (string-pointer? sp))) ;(test "string-pointer-next!" #\¤¤ ; (lambda () (string-pointer-next! sp))) ;(test "string-pointer-next!" #\¤í ; (lambda () (string-pointer-next! sp))) ;(test "string-pointer-prev!" #\¤í ; (lambda () (string-pointer-prev! sp))) ;(test "string-pointer-prev!" #\¤¤ ; (lambda () (string-pointer-prev! sp))) ;(test "string-pointer-prev!" #t ; (lambda () (eof-object? (string-pointer-prev! sp)))) ;(test "string-pointer-index" 0 ; (lambda () (string-pointer-index sp))) ;(test "string-pointer-index" 8 ; (lambda () (do ((x (string-pointer-next! sp) (string-pointer-next! sp))) ; ((eof-object? x) (string-pointer-index sp))))) ;(test "string-pointer-substring" '("¤¤¤í¤Ï¤Ëho¤Ø¤È" "") ; (lambda () (list (string-pointer-substring sp) ; (string-pointer-substring sp :after #t)))) ;(test "string-pointer-substring" '("¤¤¤í¤Ï¤Ëh" "o¤Ø¤È") ; (lambda () ; (string-pointer-set! sp 5) ; (list (string-pointer-substring sp) ; (string-pointer-substring sp :after #t)))) ;(test "string-pointer-substring" '("" "¤¤¤í¤Ï¤Ëho¤Ø¤È") ; (lambda () ; (string-pointer-set! sp 0) ; (list (string-pointer-substring sp) ; (string-pointer-substring sp :after #t)))) ;;------------------------------------------------------------------- ;(require-extension (srfi 13)) ;(test "string-every" #t (lambda () (string-every #\¤¢ ""))) ;(test "string-every" #t (lambda () (string-every #\¤¢ "¤¢¤¢¤¢¤¢"))) ;(test "string-every" #f (lambda () (string-every #\¤¢ "¤¢¤¢¤¢a"))) ;(test "string-every" #t (lambda () (string-every #[¤¢-¤ó] "¤¢¤¢¤¤¤¢"))) ;(test "string-every" #f (lambda () (string-every #[¤¢-¤ó] "¤¢¤¢a¤¢"))) ;(test "string-every" #t (lambda () (string-every #[¤¢-¤ó] ""))) ;(test "string-every" #t (lambda () (string-every (lambda (x) (char-ci=? x #\¤¢)) "¤¢¤¢¤¢¤¢"))) ;(test "string-every" #f (lambda () (string-every (lambda (x) (char-ci=? x #\¤¢)) "¤¢¤¤¤¢¤¤"))) ;(test "string-any" #t (lambda () (string-any #\¤¢ "¤¢¤¢¤¢¤¢"))) ;(test "string-any" #f (lambda () (string-any #\¤¢ "¤¤¤¦¤¨¤ª"))) ;(test "string-any" #f (lambda () (string-any #\¤¢ ""))) ;(test "string-any" #t (lambda () (string-any #[¤¢-¤ó] "¤¹¤­¡¼¤à"))) ;(test "string-any" #f (lambda () (string-any #[¤¢-¤ó] "¥¹¥­¡¼¥à"))) ;(test "string-any" #f (lambda () (string-any #[¤¢-¤ó] ""))) ;(test "string-any" #t (lambda () (string-any (lambda (x) (char-ci=? x #\¤¢)) "¤é¤é¤é¤¢"))) ;(test "string-any" #f (lambda () (string-any (lambda (x) (char-ci=? x #\¤¢)) "¥é¥é¥é¥¢"))) ;(test "string-tabulate" "¥¢¥£¥¤¥¥¥¦" ; (lambda () ; (string-tabulate (lambda (code) ; (integer->char (+ code ; (char->integer #\¥¢)))) ; 5))) ;(test "reverse-list->string" "¤ó¤ò¤ï" ; (lambda () (reverse-list->string '(#\¤ï #\¤ò #\¤ó)))) ;(test "string-copy!" "ab¤¦¤¨¤ªfg" ; (lambda () (let ((x (string-copy "abcdefg"))) ; (string-copy! x 2 "¤¢¤¤¤¦¤¨¤ª¤«" 2 5) ; x))) ;(test "string-take" "¤¢¤¤¤¦¤¨" (lambda () (string-take "¤¢¤¤¤¦¤¨¤ª¤«" 4))) ;(test "string-drop" "¤ª¤«" (lambda () (string-drop "¤¢¤¤¤¦¤¨¤ª¤«" 4))) ;(test "string-take-right" "¤¦¤¨¤ª¤«" (lambda () (string-take-right "¤¢¤¤¤¦¤¨¤ª¤«" 4))) ;(test "string-drop-right" "¤¢¤¤" (lambda () (string-drop-right "¤¢¤¤¤¦¤¨¤ª¤«" 4))) ;(test "string-pad" "¢£¢£¥Ñ¥Ã¥É" (lambda () (string-pad "¥Ñ¥Ã¥É" 5 #\¢£))) ;(test "string-pad" "¥Ñ¥Ç¥£¥ó¥°" (lambda () (string-pad "¥Ñ¥Ç¥£¥ó¥°" 5 #\¢£))) ;(test "string-pad" "¥Ç¥£¥ó¥°¥¹" (lambda () (string-pad "¥Ñ¥Ç¥£¥ó¥°¥¹" 5 #\¢£))) ;(test "string-pad-right" "¥Ñ¥Ã¥É¢£¢£" (lambda () (string-pad-right "¥Ñ¥Ã¥É" 5 #\¢£))) ;(test "string-pad" "¥Ñ¥Ç¥£¥ó¥°" (lambda () (string-pad-right "¥Ñ¥Ç¥£¥ó¥°¥¹" 5 #\¢£))) ;;------------------------------------------------------------------- ;(require-extension (srfi 14)) ;(test "char-set" #t ; (lambda () (char-set= (char-set #\¤¢ #\¤¤ #\¤¦ #\¤¨ #\¤ª) ; (string->char-set "¤ª¤¦¤¨¤¤¤¢")))) ;(test "char-set" #t ; (lambda () (char-set= (list->char-set '(#\¤¢ #\¤¤ #\¤¦ #\¤ó)) ; (string->char-set "¤ó¤ó¤¤¤¤¤¤¤¢¤¢¤¦")))) ;(test "char-set" #t ; (lambda () (char-set<= (list->char-set '(#\¤Û #\¤²)) ; char-set:full))) ;(test "char-set" #t ; (lambda () ; (char-set= (->char-set "¤¡¤£¤¥¤§¤©¤¢¤¤¤¦¤¨") ; (integer-range->char-set (char->integer #\¤¡) ; (char->integer #\¤ª))))) (total-report) uim-1.8.8/sigscheme/test/Makefile.am0000644000175000017500000000653513274722224014243 00000000000000# Libraries EXTRA_DIST = unittest-bigloo.scm unittest-gauche.scm \ run-singletest.sh.in sscm_xfail_tests = test-fail.scm sscm_optional_tests = # Native tests of SigScheme sscm_tests = \ test-apply.scm \ test-assoc.scm \ test-begin.scm \ test-bool.scm \ test-char-cmp.scm \ test-char-pred.scm \ test-continuation.scm \ test-define.scm \ test-define-internal.scm \ test-do.scm \ test-dyn-extent.scm \ test-eq.scm \ test-eqv.scm \ test-equal.scm \ test-eval.scm \ test-fail.scm \ test-formal-syntax.scm \ test-formatplus.scm \ test-lambda.scm \ test-legacy-macro.scm \ test-let.scm \ test-letstar.scm \ test-letrec.scm \ test-list.scm \ test-map.scm \ test-member.scm \ test-misc.scm \ test-named-let.scm \ test-number-arith.scm \ test-number-cmp.scm \ test-number-literal.scm \ test-number-io.scm \ test-number-pred.scm \ test-obsolete.scm \ test-pair.scm \ test-quote.scm \ test-srfi0.scm \ test-srfi1-another.scm \ test-srfi1-obsolete.scm \ test-srfi2.scm \ test-srfi6.scm \ test-srfi8.scm \ test-srfi9.scm \ test-srfi28.scm \ test-srfi34.scm \ test-srfi34-2.scm \ test-srfi38.scm \ test-srfi43.scm \ test-srfi48.scm \ test-srfi55.scm \ test-srfi60.scm \ test-sscm-ext.scm \ test-string-cmp.scm \ test-string-core.scm \ test-string-null.scm \ test-string-proc.scm \ test-string.scm \ test-symbol.scm \ test-syntax-rules.scm \ test-syntax.scm \ test-unittest.scm \ test-values.scm \ test-vector.scm if USE_UTF8 sscm_optional_tests += test-enc-utf8.scm else sscm_xfail_tests += test-enc-utf8.scm endif EXTRA_DIST += test-enc-utf8.scm if USE_EUCCN sscm_optional_tests += test-enc-eucgeneric.scm else sscm_xfail_tests += test-enc-eucgeneric.scm endif EXTRA_DIST += test-enc-eucgeneric.scm if USE_EUCJP sscm_optional_tests += test-enc-eucjp.scm test-char.scm else sscm_xfail_tests += test-enc-eucjp.scm test-char.scm endif EXTRA_DIST += test-enc-eucjp.scm test-char.scm if USE_SJIS sscm_optional_tests += test-enc-sjis.scm else sscm_xfail_tests += test-enc-sjis.scm endif EXTRA_DIST += test-enc-sjis.scm EXTRA_DIST += test-tail-rec.scm # Imported foreign tests imported_tests = \ scm-r4rstest.scm \ bigloo-apply.scm \ bigloo-bchar.scm \ bigloo-bool.scm \ bigloo-case.scm \ bigloo-letrec.scm \ bigloo-list.scm \ bigloo-quote.scm \ bigloo-vector.scm \ gauche-euc-jp.scm \ gauche-let-optionals.scm \ gauche-primsyn.scm \ oleg-srfi2.scm # Not included to the distribution since their original license is unknown. #imported_tests += stone-srfi1.scm #imported_tests += panu-srfi69.scm EXTRA_DIST += $(sscm_tests) $(imported_tests) LOG_COMPILER = $(SH) AM_LOG_FLAGS = $(top_builddir)/test/run-singletest.sh if USE_SHELL TESTS = $(sscm_tests) $(sscm_optional_tests) XFAIL_TESTS = $(sscm_xfail_tests) else TESTS = XFAIL_TESTS = $(sscm_tests) $(sscm_xfail_tests) endif DISTCLEANFILES = run-singletest.sh uim-1.8.8/sigscheme/test/test-char-pred.scm0000644000175000017500000002630112532333147015524 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-char-pred.scm ;; About : unit test for R5RS char classification predicates ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (symbol-bound? 'char-alphabetic?)) (test-skip "R5RS characters is not enabled")) (define tn test-name) (tn "char-alphabetic?") (assert-false (tn) (char-alphabetic? #\x00)) (assert-false (tn) (char-alphabetic? #\newline)) (assert-false (tn) (char-alphabetic? #\space)) (assert-false (tn) (char-alphabetic? #\x09)) ;; horizontal tab (#\tab) (assert-false (tn) (char-alphabetic? #\x0b)) ;; vertical tab (#\vtab) (assert-false (tn) (char-alphabetic? #\x0c)) ;; form feed (#\page) (assert-false (tn) (char-alphabetic? #\x0d)) ;; carriage return (#\return) (assert-false (tn) (char-alphabetic? #\!)) (assert-false (tn) (char-alphabetic? #\0)) (assert-false (tn) (char-alphabetic? #\9)) (assert-true (tn) (char-alphabetic? #\A)) (assert-true (tn) (char-alphabetic? #\B)) (assert-true (tn) (char-alphabetic? #\Z)) (assert-false (tn) (char-alphabetic? #\_)) (assert-true (tn) (char-alphabetic? #\a)) (assert-true (tn) (char-alphabetic? #\b)) (assert-true (tn) (char-alphabetic? #\z)) (assert-false (tn) (char-alphabetic? #\~)) (assert-false (tn) (char-alphabetic? #\x7f)) (tn "char-alphabetic? non-ASCII") ;; SigScheme currently does not support non-ASCII charcter classification (assert-false (tn) (char-alphabetic? #\xa0)) ;; U+00A0 NO-BREAK SPACE (assert-false (tn) (char-alphabetic? #\xff)) ;; U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (assert-false (tn) (char-alphabetic? #\x2028)) ;; U+2028 LINE SEPARATOR (assert-false (tn) (char-alphabetic? #\x2029)) ;; U+2029 PARAGRAPH SEPARATOR (assert-false (tn) (char-alphabetic? #\ )) ;; U+3000 IDEOGRAPHIC SPACE (assert-false (tn) (char-alphabetic? #\ã‚)) ;; U+3042 HIRAGANA LETTER A (assert-false (tn) (char-alphabetic? #\ï¼)) ;; U+FF01 FULLWIDTH EXCLAMATION MARK (assert-false (tn) (char-alphabetic? #\ï¼)) ;; U+FF10 FULLWIDTH DIGIT ZERO (assert-false (tn) (char-alphabetic? #\A)) ;; U+FF21 FULLWIDTH LATIN CAPITAL LETTER A (assert-false (tn) (char-alphabetic? #\ï½)) ;; U+FF41 FULLWIDTH LATIN SMALL LETTER A (tn "char-numeric?") (assert-false (tn) (char-numeric? #\x00)) (assert-false (tn) (char-numeric? #\newline)) (assert-false (tn) (char-numeric? #\space)) (assert-false (tn) (char-numeric? #\x09)) ;; horizontal tab (#\tab) (assert-false (tn) (char-numeric? #\x0b)) ;; vertical tab (#\vtab) (assert-false (tn) (char-numeric? #\x0c)) ;; form feed (#\page) (assert-false (tn) (char-numeric? #\x0d)) ;; carriage return (#\return) (assert-false (tn) (char-numeric? #\!)) (assert-true (tn) (char-numeric? #\0)) (assert-true (tn) (char-numeric? #\9)) (assert-false (tn) (char-numeric? #\A)) (assert-false (tn) (char-numeric? #\B)) (assert-false (tn) (char-numeric? #\Z)) (assert-false (tn) (char-numeric? #\_)) (assert-false (tn) (char-numeric? #\a)) (assert-false (tn) (char-numeric? #\b)) (assert-false (tn) (char-numeric? #\z)) (assert-false (tn) (char-numeric? #\~)) (assert-false (tn) (char-numeric? #\x7f)) (tn "char-numeric? non-ASCII") ;; SigScheme currently does not support non-ASCII charcter classification (assert-false (tn) (char-numeric? #\xa0)) ;; U+00A0 NO-BREAK SPACE (assert-false (tn) (char-numeric? #\xff)) ;; U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (assert-false (tn) (char-numeric? #\x2028)) ;; U+2028 LINE SEPARATOR (assert-false (tn) (char-numeric? #\x2029)) ;; U+2029 PARAGRAPH SEPARATOR (assert-false (tn) (char-numeric? #\ )) ;; U+3000 IDEOGRAPHIC SPACE (assert-false (tn) (char-numeric? #\ã‚)) ;; U+3042 HIRAGANA LETTER A (assert-false (tn) (char-numeric? #\ï¼)) ;; U+FF01 FULLWIDTH EXCLAMATION MARK (assert-false (tn) (char-numeric? #\ï¼)) ;; U+FF10 FULLWIDTH DIGIT ZERO (assert-false (tn) (char-numeric? #\A)) ;; U+FF21 FULLWIDTH LATIN CAPITAL LETTER A (assert-false (tn) (char-numeric? #\ï½)) ;; U+FF41 FULLWIDTH LATIN SMALL LETTER A (tn "char-whitespace?") (assert-false (tn) (char-whitespace? #\x00)) (assert-true (tn) (char-whitespace? #\newline)) (assert-true (tn) (char-whitespace? #\space)) (assert-true (tn) (char-whitespace? #\x09)) ;; horizontal tab (#\tab) (assert-true (tn) (char-whitespace? #\x0b)) ;; vertical tab (#\vtab) (assert-true (tn) (char-whitespace? #\x0c)) ;; form feed (#\page) (assert-true (tn) (char-whitespace? #\x0d)) ;; carriage return (#\return) (assert-false (tn) (char-whitespace? #\!)) (assert-false (tn) (char-whitespace? #\0)) (assert-false (tn) (char-whitespace? #\9)) (assert-false (tn) (char-whitespace? #\A)) (assert-false (tn) (char-whitespace? #\B)) (assert-false (tn) (char-whitespace? #\Z)) (assert-false (tn) (char-whitespace? #\_)) (assert-false (tn) (char-whitespace? #\a)) (assert-false (tn) (char-whitespace? #\b)) (assert-false (tn) (char-whitespace? #\z)) (assert-false (tn) (char-whitespace? #\~)) (assert-false (tn) (char-whitespace? #\x7f)) (tn "char-whitespace? non-ASCII") ;; SigScheme currently does not support non-ASCII charcter classification (assert-false (tn) (char-whitespace? #\xa0)) ;; U+00A0 NO-BREAK SPACE (assert-false (tn) (char-whitespace? #\xff)) ;; U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (assert-false (tn) (char-whitespace? #\x2028)) ;; U+2028 LINE SEPARATOR (assert-false (tn) (char-whitespace? #\x2029)) ;; U+2029 PARAGRAPH SEPARATOR (assert-false (tn) (char-whitespace? #\ )) ;; U+3000 IDEOGRAPHIC SPACE (assert-false (tn) (char-whitespace? #\ã‚)) ;; U+3042 HIRAGANA LETTER A (assert-false (tn) (char-whitespace? #\ï¼)) ;; U+FF01 FULLWIDTH EXCLAMATION MARK (assert-false (tn) (char-whitespace? #\ï¼)) ;; U+FF10 FULLWIDTH DIGIT ZERO (assert-false (tn) (char-whitespace? #\A)) ;; U+FF21 FULLWIDTH LATIN CAPITAL LETTER A (assert-false (tn) (char-whitespace? #\ï½)) ;; U+FF41 FULLWIDTH LATIN SMALL LETTER A (tn "char-upper-case?") (assert-false (tn) (char-upper-case? #\x00)) (assert-false (tn) (char-upper-case? #\newline)) (assert-false (tn) (char-upper-case? #\space)) (assert-false (tn) (char-upper-case? #\x09)) ;; horizontal tab (#\tab) (assert-false (tn) (char-upper-case? #\x0b)) ;; vertical tab (#\vtab) (assert-false (tn) (char-upper-case? #\x0c)) ;; form feed (#\page) (assert-false (tn) (char-upper-case? #\x0d)) ;; carriage return (#\return) (assert-false (tn) (char-upper-case? #\!)) (assert-false (tn) (char-upper-case? #\0)) (assert-false (tn) (char-upper-case? #\9)) (assert-true (tn) (char-upper-case? #\A)) (assert-true (tn) (char-upper-case? #\B)) (assert-true (tn) (char-upper-case? #\Z)) (assert-false (tn) (char-upper-case? #\_)) (assert-false (tn) (char-upper-case? #\a)) (assert-false (tn) (char-upper-case? #\b)) (assert-false (tn) (char-upper-case? #\z)) (assert-false (tn) (char-upper-case? #\~)) (assert-false (tn) (char-upper-case? #\x7f)) (tn "char-upper-case? non-ASCII") ;; SigScheme currently does not support non-ASCII charcter classification (assert-false (tn) (char-upper-case? #\xa0)) ;; U+00A0 NO-BREAK SPACE (assert-false (tn) (char-upper-case? #\xff)) ;; U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (assert-false (tn) (char-upper-case? #\x2028)) ;; U+2028 LINE SEPARATOR (assert-false (tn) (char-upper-case? #\x2029)) ;; U+2029 PARAGRAPH SEPARATOR (assert-false (tn) (char-upper-case? #\ )) ;; U+3000 IDEOGRAPHIC SPACE (assert-false (tn) (char-upper-case? #\ã‚)) ;; U+3042 HIRAGANA LETTER A (assert-false (tn) (char-upper-case? #\ï¼)) ;; U+FF01 FULLWIDTH EXCLAMATION MARK (assert-false (tn) (char-upper-case? #\ï¼)) ;; U+FF10 FULLWIDTH DIGIT ZERO (assert-false (tn) (char-upper-case? #\A)) ;; U+FF21 FULLWIDTH LATIN CAPITAL LETTER A (assert-false (tn) (char-upper-case? #\ï½)) ;; U+FF41 FULLWIDTH LATIN SMALL LETTER A (tn "char-lower-case?") (assert-false (tn) (char-lower-case? #\x00)) (assert-false (tn) (char-lower-case? #\newline)) (assert-false (tn) (char-lower-case? #\space)) (assert-false (tn) (char-lower-case? #\x09)) ;; horizontal tab (#\tab) (assert-false (tn) (char-lower-case? #\x0b)) ;; vertical tab (#\vtab) (assert-false (tn) (char-lower-case? #\x0c)) ;; form feed (#\page) (assert-false (tn) (char-lower-case? #\x0d)) ;; carriage return (#\return) (assert-false (tn) (char-lower-case? #\!)) (assert-false (tn) (char-lower-case? #\0)) (assert-false (tn) (char-lower-case? #\9)) (assert-false (tn) (char-lower-case? #\A)) (assert-false (tn) (char-lower-case? #\B)) (assert-false (tn) (char-lower-case? #\Z)) (assert-false (tn) (char-lower-case? #\_)) (assert-true (tn) (char-lower-case? #\a)) (assert-true (tn) (char-lower-case? #\b)) (assert-true (tn) (char-lower-case? #\z)) (assert-false (tn) (char-lower-case? #\~)) (assert-false (tn) (char-lower-case? #\x7f)) (tn "char-lower-case? non-ASCII") ;; SigScheme currently does not support non-ASCII charcter classification (assert-false (tn) (char-lower-case? #\xa0)) ;; U+00A0 NO-BREAK SPACE (assert-false (tn) (char-lower-case? #\xff)) ;; U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (assert-false (tn) (char-lower-case? #\x2028)) ;; U+2028 LINE SEPARATOR (assert-false (tn) (char-lower-case? #\x2029)) ;; U+2029 PARAGRAPH SEPARATOR (assert-false (tn) (char-lower-case? #\ )) ;; U+3000 IDEOGRAPHIC SPACE (assert-false (tn) (char-lower-case? #\ã‚)) ;; U+3042 HIRAGANA LETTER A (assert-false (tn) (char-lower-case? #\ï¼)) ;; U+FF01 FULLWIDTH EXCLAMATION MARK (assert-false (tn) (char-lower-case? #\ï¼)) ;; U+FF10 FULLWIDTH DIGIT ZERO (assert-false (tn) (char-lower-case? #\A)) ;; U+FF21 FULLWIDTH LATIN CAPITAL LETTER A (assert-false (tn) (char-lower-case? #\ï½)) ;; U+FF41 FULLWIDTH LATIN SMALL LETTER A (total-report) uim-1.8.8/sigscheme/test/test-number-pred.scm0000644000175000017500000006575412532333147016116 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-number-pred.scm ;; About : unit tests for number predicates ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (symbol-bound? 'number?)) (test-skip "R5RS numbers is not enabled")) (define tn test-name) (tn "number?") (assert-eq? (tn) #f (number? #f)) (assert-eq? (tn) #f (number? #t)) (assert-eq? (tn) #f (number? '())) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (number? (eof))) (assert-eq? (tn) #f (number? (undef))))) ;; binary (assert-eq? (tn) #t (number? #b0)) (assert-eq? (tn) #t (number? #b-0)) (assert-eq? (tn) #t (number? #b+0)) (assert-eq? (tn) #t (number? #b1)) (assert-eq? (tn) #t (number? #b-1)) (assert-eq? (tn) #t (number? #b+1)) ;; octal (assert-eq? (tn) #t (number? #o0)) (assert-eq? (tn) #t (number? #o-0)) (assert-eq? (tn) #t (number? #o+0)) (assert-eq? (tn) #t (number? #o1)) (assert-eq? (tn) #t (number? #o-1)) (assert-eq? (tn) #t (number? #o+1)) (assert-eq? (tn) #t (number? #o3)) (assert-eq? (tn) #t (number? #o-3)) (assert-eq? (tn) #t (number? #o+3)) ;; decimal (implicit) (assert-eq? (tn) #t (number? 0)) (assert-eq? (tn) #t (number? -0)) (assert-eq? (tn) #t (number? +0)) (assert-eq? (tn) #t (number? 1)) (assert-eq? (tn) #t (number? -1)) (assert-eq? (tn) #t (number? +1)) (assert-eq? (tn) #t (number? 3)) (assert-eq? (tn) #t (number? -3)) (assert-eq? (tn) #t (number? +3)) ;; decimal (explicit) (assert-eq? (tn) #t (number? #d0)) (assert-eq? (tn) #t (number? #d-0)) (assert-eq? (tn) #t (number? #d+0)) (assert-eq? (tn) #t (number? #d1)) (assert-eq? (tn) #t (number? #d-1)) (assert-eq? (tn) #t (number? #d+1)) (assert-eq? (tn) #t (number? #d3)) (assert-eq? (tn) #t (number? #d-3)) (assert-eq? (tn) #t (number? #d+3)) ;; hexadecimal (assert-eq? (tn) #t (number? #x0)) (assert-eq? (tn) #t (number? #x-0)) (assert-eq? (tn) #t (number? #x+0)) (assert-eq? (tn) #t (number? #x1)) (assert-eq? (tn) #t (number? #x-1)) (assert-eq? (tn) #t (number? #x+1)) (assert-eq? (tn) #t (number? #x3)) (assert-eq? (tn) #t (number? #x-3)) (assert-eq? (tn) #t (number? #x+3)) (assert-eq? (tn) #t (number? #xa)) (assert-eq? (tn) #t (number? #x-a)) (assert-eq? (tn) #t (number? #x+a)) (assert-eq? (tn) #f (number? 'symbol)) (assert-eq? (tn) #f (number? 'SYMBOL)) (assert-eq? (tn) #f (number? #\a)) (assert-eq? (tn) #f (number? #\ã‚)) (assert-eq? (tn) #f (number? "")) (assert-eq? (tn) #f (number? " ")) (assert-eq? (tn) #f (number? "a")) (assert-eq? (tn) #f (number? "A")) (assert-eq? (tn) #f (number? "aBc12!")) (assert-eq? (tn) #f (number? "ã‚")) (assert-eq? (tn) #f (number? "ã‚0イã†12!")) (assert-eq? (tn) #f (number? +)) (assert-eq? (tn) #f (number? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (number? else))) ;; expression keyword (assert-error (tn) (lambda () (number? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (number? k)))) (assert-eq? (tn) #f (number? (current-output-port))) (assert-eq? (tn) #f (number? '(#t . #t))) (assert-eq? (tn) #f (number? (cons #t #t))) (assert-eq? (tn) #f (number? '(0 1 2))) (assert-eq? (tn) #f (number? (list 0 1 2))) (assert-eq? (tn) #f (number? '#())) (assert-eq? (tn) #f (number? (vector))) (assert-eq? (tn) #f (number? '#(0 1 2))) (assert-eq? (tn) #f (number? (vector 0 1 2))) (tn "integer?") (assert-eq? (tn) #f (integer? #f)) (assert-eq? (tn) #f (integer? #t)) (assert-eq? (tn) #f (integer? '())) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (integer? (eof))) (assert-eq? (tn) #f (integer? (undef))))) ;; binary (assert-eq? (tn) #t (integer? #b0)) (assert-eq? (tn) #t (integer? #b-0)) (assert-eq? (tn) #t (integer? #b+0)) (assert-eq? (tn) #t (integer? #b1)) (assert-eq? (tn) #t (integer? #b-1)) (assert-eq? (tn) #t (integer? #b+1)) ;; octal (assert-eq? (tn) #t (integer? #o0)) (assert-eq? (tn) #t (integer? #o-0)) (assert-eq? (tn) #t (integer? #o+0)) (assert-eq? (tn) #t (integer? #o1)) (assert-eq? (tn) #t (integer? #o-1)) (assert-eq? (tn) #t (integer? #o+1)) (assert-eq? (tn) #t (integer? #o3)) (assert-eq? (tn) #t (integer? #o-3)) (assert-eq? (tn) #t (integer? #o+3)) ;; decimal (implicit) (assert-eq? (tn) #t (integer? 0)) (assert-eq? (tn) #t (integer? -0)) (assert-eq? (tn) #t (integer? +0)) (assert-eq? (tn) #t (integer? 1)) (assert-eq? (tn) #t (integer? -1)) (assert-eq? (tn) #t (integer? +1)) (assert-eq? (tn) #t (integer? 3)) (assert-eq? (tn) #t (integer? -3)) (assert-eq? (tn) #t (integer? +3)) ;; decimal (explicit) (assert-eq? (tn) #t (integer? #d0)) (assert-eq? (tn) #t (integer? #d-0)) (assert-eq? (tn) #t (integer? #d+0)) (assert-eq? (tn) #t (integer? #d1)) (assert-eq? (tn) #t (integer? #d-1)) (assert-eq? (tn) #t (integer? #d+1)) (assert-eq? (tn) #t (integer? #d3)) (assert-eq? (tn) #t (integer? #d-3)) (assert-eq? (tn) #t (integer? #d+3)) ;; hexadecimal (assert-eq? (tn) #t (integer? #x0)) (assert-eq? (tn) #t (integer? #x-0)) (assert-eq? (tn) #t (integer? #x+0)) (assert-eq? (tn) #t (integer? #x1)) (assert-eq? (tn) #t (integer? #x-1)) (assert-eq? (tn) #t (integer? #x+1)) (assert-eq? (tn) #t (integer? #x3)) (assert-eq? (tn) #t (integer? #x-3)) (assert-eq? (tn) #t (integer? #x+3)) (assert-eq? (tn) #t (integer? #xa)) (assert-eq? (tn) #t (integer? #x-a)) (assert-eq? (tn) #t (integer? #x+a)) (assert-eq? (tn) #f (integer? 'symbol)) (assert-eq? (tn) #f (integer? 'SYMBOL)) (assert-eq? (tn) #f (integer? #\a)) (assert-eq? (tn) #f (integer? #\ã‚)) (assert-eq? (tn) #f (integer? "")) (assert-eq? (tn) #f (integer? " ")) (assert-eq? (tn) #f (integer? "a")) (assert-eq? (tn) #f (integer? "A")) (assert-eq? (tn) #f (integer? "aBc12!")) (assert-eq? (tn) #f (integer? "ã‚")) (assert-eq? (tn) #f (integer? "ã‚0イã†12!")) (assert-eq? (tn) #f (integer? +)) (assert-eq? (tn) #f (integer? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (integer? else))) ;; expression keyword (assert-error (tn) (lambda () (integer? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (integer? k)))) (assert-eq? (tn) #f (integer? (current-output-port))) (assert-eq? (tn) #f (integer? '(#t . #t))) (assert-eq? (tn) #f (integer? (cons #t #t))) (assert-eq? (tn) #f (integer? '(0 1 2))) (assert-eq? (tn) #f (integer? (list 0 1 2))) (assert-eq? (tn) #f (integer? '#())) (assert-eq? (tn) #f (integer? (vector))) (assert-eq? (tn) #f (integer? '#(0 1 2))) (assert-eq? (tn) #f (integer? (vector 0 1 2))) (tn "zero?") (assert-error (tn) (lambda () (zero? #f))) (assert-error (tn) (lambda () (zero? #t))) (assert-error (tn) (lambda () (zero? '()))) (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (zero? (eof)))) (assert-error (tn) (lambda () (zero? (undef)))))) ;; binary (assert-eq? (tn) #t (zero? #b0)) (assert-eq? (tn) #t (zero? #b-0)) (assert-eq? (tn) #t (zero? #b+0)) (assert-eq? (tn) #f (zero? #b1)) (assert-eq? (tn) #f (zero? #b-1)) (assert-eq? (tn) #f (zero? #b+1)) ;; octal (assert-eq? (tn) #t (zero? #o0)) (assert-eq? (tn) #t (zero? #o-0)) (assert-eq? (tn) #t (zero? #o+0)) (assert-eq? (tn) #f (zero? #o1)) (assert-eq? (tn) #f (zero? #o-1)) (assert-eq? (tn) #f (zero? #o+1)) (assert-eq? (tn) #f (zero? #o3)) (assert-eq? (tn) #f (zero? #o-3)) (assert-eq? (tn) #f (zero? #o+3)) ;; decimal (implicit) (assert-eq? (tn) #t (zero? 0)) (assert-eq? (tn) #t (zero? -0)) (assert-eq? (tn) #t (zero? +0)) (assert-eq? (tn) #f (zero? 1)) (assert-eq? (tn) #f (zero? -1)) (assert-eq? (tn) #f (zero? +1)) (assert-eq? (tn) #f (zero? 3)) (assert-eq? (tn) #f (zero? -3)) (assert-eq? (tn) #f (zero? +3)) ;; decimal (explicit) (assert-eq? (tn) #t (zero? #d0)) (assert-eq? (tn) #t (zero? #d-0)) (assert-eq? (tn) #t (zero? #d+0)) (assert-eq? (tn) #f (zero? #d1)) (assert-eq? (tn) #f (zero? #d-1)) (assert-eq? (tn) #f (zero? #d+1)) (assert-eq? (tn) #f (zero? #d3)) (assert-eq? (tn) #f (zero? #d-3)) (assert-eq? (tn) #f (zero? #d+3)) ;; hexadecimal (assert-eq? (tn) #t (zero? #x0)) (assert-eq? (tn) #t (zero? #x-0)) (assert-eq? (tn) #t (zero? #x+0)) (assert-eq? (tn) #f (zero? #x1)) (assert-eq? (tn) #f (zero? #x-1)) (assert-eq? (tn) #f (zero? #x+1)) (assert-eq? (tn) #f (zero? #x3)) (assert-eq? (tn) #f (zero? #x-3)) (assert-eq? (tn) #f (zero? #x+3)) (assert-eq? (tn) #f (zero? #xa)) (assert-eq? (tn) #f (zero? #x-a)) (assert-eq? (tn) #f (zero? #x+a)) (assert-error (tn) (lambda () (zero? 'symbol))) (assert-error (tn) (lambda () (zero? 'SYMBOL))) (assert-error (tn) (lambda () (zero? #\a))) (assert-error (tn) (lambda () (zero? #\ã‚))) (assert-error (tn) (lambda () (zero? ""))) (assert-error (tn) (lambda () (zero? " "))) (assert-error (tn) (lambda () (zero? "a"))) (assert-error (tn) (lambda () (zero? "A"))) (assert-error (tn) (lambda () (zero? "aBc12!"))) (assert-error (tn) (lambda () (zero? "ã‚"))) (assert-error (tn) (lambda () (zero? "ã‚0イã†12!"))) (assert-error (tn) (lambda () (zero? +))) (assert-error (tn) (lambda () (zero? (lambda () #t)))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (zero? else))) ;; expression keyword (assert-error (tn) (lambda () (zero? do))))) (call-with-current-continuation (lambda (k) (assert-error (tn) (lambda () (zero? k))))) (assert-error (tn) (lambda () (zero? (current-output-port)))) (assert-error (tn) (lambda () (zero? '(#t . #t)))) (assert-error (tn) (lambda () (zero? (cons #t #t)))) (assert-error (tn) (lambda () (zero? '(0 1 2)))) (assert-error (tn) (lambda () (zero? (list 0 1 2)))) (assert-error (tn) (lambda () (zero? '#()))) (assert-error (tn) (lambda () (zero? (vector)))) (assert-error (tn) (lambda () (zero? '#(0 1 2)))) (assert-error (tn) (lambda () (zero? (vector 0 1 2)))) (tn "positive?") (assert-error (tn) (lambda () (positive? #f))) (assert-error (tn) (lambda () (positive? #t))) (assert-error (tn) (lambda () (positive? '()))) (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (positive? (eof)))) (assert-error (tn) (lambda () (positive? (undef)))))) ;; binary (assert-eq? (tn) #f (positive? #b0)) (assert-eq? (tn) #f (positive? #b-0)) (assert-eq? (tn) #f (positive? #b+0)) (assert-eq? (tn) #t (positive? #b1)) (assert-eq? (tn) #f (positive? #b-1)) (assert-eq? (tn) #t (positive? #b+1)) ;; octal (assert-eq? (tn) #f (positive? #o0)) (assert-eq? (tn) #f (positive? #o-0)) (assert-eq? (tn) #f (positive? #o+0)) (assert-eq? (tn) #t (positive? #o1)) (assert-eq? (tn) #f (positive? #o-1)) (assert-eq? (tn) #t (positive? #o+1)) (assert-eq? (tn) #t (positive? #o3)) (assert-eq? (tn) #f (positive? #o-3)) (assert-eq? (tn) #t (positive? #o+3)) ;; decimal (implicit) (assert-eq? (tn) #f (positive? 0)) (assert-eq? (tn) #f (positive? -0)) (assert-eq? (tn) #f (positive? +0)) (assert-eq? (tn) #t (positive? 1)) (assert-eq? (tn) #f (positive? -1)) (assert-eq? (tn) #t (positive? +1)) (assert-eq? (tn) #t (positive? 3)) (assert-eq? (tn) #f (positive? -3)) (assert-eq? (tn) #t (positive? +3)) ;; decimal (explicit) (assert-eq? (tn) #f (positive? #d0)) (assert-eq? (tn) #f (positive? #d-0)) (assert-eq? (tn) #f (positive? #d+0)) (assert-eq? (tn) #t (positive? #d1)) (assert-eq? (tn) #f (positive? #d-1)) (assert-eq? (tn) #t (positive? #d+1)) (assert-eq? (tn) #t (positive? #d3)) (assert-eq? (tn) #f (positive? #d-3)) (assert-eq? (tn) #t (positive? #d+3)) ;; hexadecimal (assert-eq? (tn) #f (positive? #x0)) (assert-eq? (tn) #f (positive? #x-0)) (assert-eq? (tn) #f (positive? #x+0)) (assert-eq? (tn) #t (positive? #x1)) (assert-eq? (tn) #f (positive? #x-1)) (assert-eq? (tn) #t (positive? #x+1)) (assert-eq? (tn) #t (positive? #x3)) (assert-eq? (tn) #f (positive? #x-3)) (assert-eq? (tn) #t (positive? #x+3)) (assert-eq? (tn) #t (positive? #xa)) (assert-eq? (tn) #f (positive? #x-a)) (assert-eq? (tn) #t (positive? #x+a)) (assert-error (tn) (lambda () (positive? 'symbol))) (assert-error (tn) (lambda () (positive? 'SYMBOL))) (assert-error (tn) (lambda () (positive? #\a))) (assert-error (tn) (lambda () (positive? #\ã‚))) (assert-error (tn) (lambda () (positive? ""))) (assert-error (tn) (lambda () (positive? " "))) (assert-error (tn) (lambda () (positive? "a"))) (assert-error (tn) (lambda () (positive? "A"))) (assert-error (tn) (lambda () (positive? "aBc12!"))) (assert-error (tn) (lambda () (positive? "ã‚"))) (assert-error (tn) (lambda () (positive? "ã‚0イã†12!"))) (assert-error (tn) (lambda () (positive? +))) (assert-error (tn) (lambda () (positive? (lambda () #t)))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (positive? else))) ;; expression keyword (assert-error (tn) (lambda () (positive? do))))) (call-with-current-continuation (lambda (k) (assert-error (tn) (lambda () (positive? k))))) (assert-error (tn) (lambda () (positive? (current-output-port)))) (assert-error (tn) (lambda () (positive? '(#t . #t)))) (assert-error (tn) (lambda () (positive? (cons #t #t)))) (assert-error (tn) (lambda () (positive? '(0 1 2)))) (assert-error (tn) (lambda () (positive? (list 0 1 2)))) (assert-error (tn) (lambda () (positive? '#()))) (assert-error (tn) (lambda () (positive? (vector)))) (assert-error (tn) (lambda () (positive? '#(0 1 2)))) (assert-error (tn) (lambda () (positive? (vector 0 1 2)))) (tn "negative?") (assert-error (tn) (lambda () (negative? #f))) (assert-error (tn) (lambda () (negative? #t))) (assert-error (tn) (lambda () (negative? '()))) (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (negative? (eof)))) (assert-error (tn) (lambda () (negative? (undef)))))) ;; binary (assert-eq? (tn) #f (negative? #b0)) (assert-eq? (tn) #f (negative? #b-0)) (assert-eq? (tn) #f (negative? #b+0)) (assert-eq? (tn) #f (negative? #b1)) (assert-eq? (tn) #t (negative? #b-1)) (assert-eq? (tn) #f (negative? #b+1)) ;; octal (assert-eq? (tn) #f (negative? #o0)) (assert-eq? (tn) #f (negative? #o-0)) (assert-eq? (tn) #f (negative? #o+0)) (assert-eq? (tn) #f (negative? #o1)) (assert-eq? (tn) #t (negative? #o-1)) (assert-eq? (tn) #f (negative? #o+1)) (assert-eq? (tn) #f (negative? #o3)) (assert-eq? (tn) #t (negative? #o-3)) (assert-eq? (tn) #f (negative? #o+3)) ;; decimal (implicit) (assert-eq? (tn) #f (negative? 0)) (assert-eq? (tn) #f (negative? -0)) (assert-eq? (tn) #f (negative? +0)) (assert-eq? (tn) #f (negative? 1)) (assert-eq? (tn) #t (negative? -1)) (assert-eq? (tn) #f (negative? +1)) (assert-eq? (tn) #f (negative? 3)) (assert-eq? (tn) #t (negative? -3)) (assert-eq? (tn) #f (negative? +3)) ;; decimal (explicit) (assert-eq? (tn) #f (negative? #d0)) (assert-eq? (tn) #f (negative? #d-0)) (assert-eq? (tn) #f (negative? #d+0)) (assert-eq? (tn) #f (negative? #d1)) (assert-eq? (tn) #t (negative? #d-1)) (assert-eq? (tn) #f (negative? #d+1)) (assert-eq? (tn) #f (negative? #d3)) (assert-eq? (tn) #t (negative? #d-3)) (assert-eq? (tn) #f (negative? #d+3)) ;; hexadecimal (assert-eq? (tn) #f (negative? #x0)) (assert-eq? (tn) #f (negative? #x-0)) (assert-eq? (tn) #f (negative? #x+0)) (assert-eq? (tn) #f (negative? #x1)) (assert-eq? (tn) #t (negative? #x-1)) (assert-eq? (tn) #f (negative? #x+1)) (assert-eq? (tn) #f (negative? #x3)) (assert-eq? (tn) #t (negative? #x-3)) (assert-eq? (tn) #f (negative? #x+3)) (assert-eq? (tn) #f (negative? #xa)) (assert-eq? (tn) #t (negative? #x-a)) (assert-eq? (tn) #f (negative? #x+a)) (assert-error (tn) (lambda () (negative? 'symbol))) (assert-error (tn) (lambda () (negative? 'SYMBOL))) (assert-error (tn) (lambda () (negative? #\a))) (assert-error (tn) (lambda () (negative? #\ã‚))) (assert-error (tn) (lambda () (negative? ""))) (assert-error (tn) (lambda () (negative? " "))) (assert-error (tn) (lambda () (negative? "a"))) (assert-error (tn) (lambda () (negative? "A"))) (assert-error (tn) (lambda () (negative? "aBc12!"))) (assert-error (tn) (lambda () (negative? "ã‚"))) (assert-error (tn) (lambda () (negative? "ã‚0イã†12!"))) (assert-error (tn) (lambda () (negative? +))) (assert-error (tn) (lambda () (negative? (lambda () #t)))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (negative? else))) ;; expression keyword (assert-error (tn) (lambda () (negative? do))))) (call-with-current-continuation (lambda (k) (assert-error (tn) (lambda () (negative? k))))) (assert-error (tn) (lambda () (negative? (current-output-port)))) (assert-error (tn) (lambda () (negative? '(#t . #t)))) (assert-error (tn) (lambda () (negative? (cons #t #t)))) (assert-error (tn) (lambda () (negative? '(0 1 2)))) (assert-error (tn) (lambda () (negative? (list 0 1 2)))) (assert-error (tn) (lambda () (negative? '#()))) (assert-error (tn) (lambda () (negative? (vector)))) (assert-error (tn) (lambda () (negative? '#(0 1 2)))) (assert-error (tn) (lambda () (negative? (vector 0 1 2)))) (tn "odd?") (assert-error (tn) (lambda () (odd? #f))) (assert-error (tn) (lambda () (odd? #t))) (assert-error (tn) (lambda () (odd? '()))) (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (odd? (eof)))) (assert-error (tn) (lambda () (odd? (undef)))))) ;; binary (assert-eq? (tn) #f (odd? #b0)) (assert-eq? (tn) #f (odd? #b-0)) (assert-eq? (tn) #f (odd? #b+0)) (assert-eq? (tn) #t (odd? #b1)) (assert-eq? (tn) #t (odd? #b-1)) (assert-eq? (tn) #t (odd? #b+1)) (assert-eq? (tn) #f (odd? #b10)) (assert-eq? (tn) #f (odd? #b-10)) (assert-eq? (tn) #f (odd? #b+10)) (assert-eq? (tn) #t (odd? #b11)) (assert-eq? (tn) #t (odd? #b-11)) (assert-eq? (tn) #t (odd? #b+11)) (assert-eq? (tn) #f (odd? #b100)) (assert-eq? (tn) #f (odd? #b-100)) (assert-eq? (tn) #f (odd? #b+100)) ;; octal (assert-eq? (tn) #f (odd? #o0)) (assert-eq? (tn) #f (odd? #o-0)) (assert-eq? (tn) #f (odd? #o+0)) (assert-eq? (tn) #t (odd? #o1)) (assert-eq? (tn) #t (odd? #o-1)) (assert-eq? (tn) #t (odd? #o+1)) (assert-eq? (tn) #f (odd? #o2)) (assert-eq? (tn) #f (odd? #o-2)) (assert-eq? (tn) #f (odd? #o+2)) (assert-eq? (tn) #t (odd? #o3)) (assert-eq? (tn) #t (odd? #o-3)) (assert-eq? (tn) #t (odd? #o+3)) (assert-eq? (tn) #f (odd? #o4)) (assert-eq? (tn) #f (odd? #o-4)) (assert-eq? (tn) #f (odd? #o+4)) ;; decimal (implicit) (assert-eq? (tn) #f (odd? 0)) (assert-eq? (tn) #f (odd? -0)) (assert-eq? (tn) #f (odd? +0)) (assert-eq? (tn) #t (odd? 1)) (assert-eq? (tn) #t (odd? -1)) (assert-eq? (tn) #t (odd? +1)) (assert-eq? (tn) #f (odd? 2)) (assert-eq? (tn) #f (odd? -2)) (assert-eq? (tn) #f (odd? +2)) (assert-eq? (tn) #t (odd? 3)) (assert-eq? (tn) #t (odd? -3)) (assert-eq? (tn) #t (odd? +3)) (assert-eq? (tn) #f (odd? 4)) (assert-eq? (tn) #f (odd? -4)) (assert-eq? (tn) #f (odd? +4)) ;; decimal (explicit) (assert-eq? (tn) #f (odd? #d0)) (assert-eq? (tn) #f (odd? #d-0)) (assert-eq? (tn) #f (odd? #d+0)) (assert-eq? (tn) #t (odd? #d1)) (assert-eq? (tn) #t (odd? #d-1)) (assert-eq? (tn) #t (odd? #d+1)) (assert-eq? (tn) #f (odd? #d2)) (assert-eq? (tn) #f (odd? #d-2)) (assert-eq? (tn) #f (odd? #d+2)) (assert-eq? (tn) #t (odd? #d3)) (assert-eq? (tn) #t (odd? #d-3)) (assert-eq? (tn) #t (odd? #d+3)) (assert-eq? (tn) #f (odd? #d4)) (assert-eq? (tn) #f (odd? #d-4)) (assert-eq? (tn) #f (odd? #d+4)) ;; hexadecimal (assert-eq? (tn) #f (odd? #x0)) (assert-eq? (tn) #f (odd? #x-0)) (assert-eq? (tn) #f (odd? #x+0)) (assert-eq? (tn) #t (odd? #x1)) (assert-eq? (tn) #t (odd? #x-1)) (assert-eq? (tn) #t (odd? #x+1)) (assert-eq? (tn) #f (odd? #x2)) (assert-eq? (tn) #f (odd? #x-2)) (assert-eq? (tn) #f (odd? #x+2)) (assert-eq? (tn) #t (odd? #x3)) (assert-eq? (tn) #t (odd? #x-3)) (assert-eq? (tn) #t (odd? #x+3)) (assert-eq? (tn) #f (odd? #x4)) (assert-eq? (tn) #f (odd? #x-4)) (assert-eq? (tn) #f (odd? #x+4)) (assert-eq? (tn) #f (odd? #xa)) (assert-eq? (tn) #f (odd? #x-a)) (assert-eq? (tn) #f (odd? #x+a)) (assert-eq? (tn) #t (odd? #xb)) (assert-eq? (tn) #t (odd? #x-b)) (assert-eq? (tn) #t (odd? #x+b)) (assert-error (tn) (lambda () (odd? 'symbol))) (assert-error (tn) (lambda () (odd? 'SYMBOL))) (assert-error (tn) (lambda () (odd? #\a))) (assert-error (tn) (lambda () (odd? #\ã‚))) (assert-error (tn) (lambda () (odd? ""))) (assert-error (tn) (lambda () (odd? " "))) (assert-error (tn) (lambda () (odd? "a"))) (assert-error (tn) (lambda () (odd? "A"))) (assert-error (tn) (lambda () (odd? "aBc12!"))) (assert-error (tn) (lambda () (odd? "ã‚"))) (assert-error (tn) (lambda () (odd? "ã‚0イã†12!"))) (assert-error (tn) (lambda () (odd? +))) (assert-error (tn) (lambda () (odd? (lambda () #t)))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (odd? else))) ;; expression keyword (assert-error (tn) (lambda () (odd? do))))) (call-with-current-continuation (lambda (k) (assert-error (tn) (lambda () (odd? k))))) (assert-error (tn) (lambda () (odd? (current-output-port)))) (assert-error (tn) (lambda () (odd? '(#t . #t)))) (assert-error (tn) (lambda () (odd? (cons #t #t)))) (assert-error (tn) (lambda () (odd? '(0 1 2)))) (assert-error (tn) (lambda () (odd? (list 0 1 2)))) (assert-error (tn) (lambda () (odd? '#()))) (assert-error (tn) (lambda () (odd? (vector)))) (assert-error (tn) (lambda () (odd? '#(0 1 2)))) (assert-error (tn) (lambda () (odd? (vector 0 1 2)))) (tn "even?") (assert-error (tn) (lambda () (even? #f))) (assert-error (tn) (lambda () (even? #t))) (assert-error (tn) (lambda () (even? '()))) (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (even? (eof)))) (assert-error (tn) (lambda () (even? (undef)))))) ;; binary (assert-eq? (tn) #t (even? #b0)) (assert-eq? (tn) #t (even? #b-0)) (assert-eq? (tn) #t (even? #b+0)) (assert-eq? (tn) #f (even? #b1)) (assert-eq? (tn) #f (even? #b-1)) (assert-eq? (tn) #f (even? #b+1)) (assert-eq? (tn) #t (even? #b10)) (assert-eq? (tn) #t (even? #b-10)) (assert-eq? (tn) #t (even? #b+10)) (assert-eq? (tn) #f (even? #b11)) (assert-eq? (tn) #f (even? #b-11)) (assert-eq? (tn) #f (even? #b+11)) (assert-eq? (tn) #t (even? #b100)) (assert-eq? (tn) #t (even? #b-100)) (assert-eq? (tn) #t (even? #b+100)) ;; octal (assert-eq? (tn) #t (even? #o0)) (assert-eq? (tn) #t (even? #o-0)) (assert-eq? (tn) #t (even? #o+0)) (assert-eq? (tn) #f (even? #o1)) (assert-eq? (tn) #f (even? #o-1)) (assert-eq? (tn) #f (even? #o+1)) (assert-eq? (tn) #t (even? #o2)) (assert-eq? (tn) #t (even? #o-2)) (assert-eq? (tn) #t (even? #o+2)) (assert-eq? (tn) #f (even? #o3)) (assert-eq? (tn) #f (even? #o-3)) (assert-eq? (tn) #f (even? #o+3)) (assert-eq? (tn) #t (even? #o4)) (assert-eq? (tn) #t (even? #o-4)) (assert-eq? (tn) #t (even? #o+4)) ;; decimal (implicit) (assert-eq? (tn) #t (even? 0)) (assert-eq? (tn) #t (even? -0)) (assert-eq? (tn) #t (even? +0)) (assert-eq? (tn) #f (even? 1)) (assert-eq? (tn) #f (even? -1)) (assert-eq? (tn) #f (even? +1)) (assert-eq? (tn) #t (even? 2)) (assert-eq? (tn) #t (even? -2)) (assert-eq? (tn) #t (even? +2)) (assert-eq? (tn) #f (even? 3)) (assert-eq? (tn) #f (even? -3)) (assert-eq? (tn) #f (even? +3)) (assert-eq? (tn) #t (even? 4)) (assert-eq? (tn) #t (even? -4)) (assert-eq? (tn) #t (even? +4)) ;; decimal (explicit) (assert-eq? (tn) #t (even? #d0)) (assert-eq? (tn) #t (even? #d-0)) (assert-eq? (tn) #t (even? #d+0)) (assert-eq? (tn) #f (even? #d1)) (assert-eq? (tn) #f (even? #d-1)) (assert-eq? (tn) #f (even? #d+1)) (assert-eq? (tn) #t (even? #d2)) (assert-eq? (tn) #t (even? #d-2)) (assert-eq? (tn) #t (even? #d+2)) (assert-eq? (tn) #f (even? #d3)) (assert-eq? (tn) #f (even? #d-3)) (assert-eq? (tn) #f (even? #d+3)) (assert-eq? (tn) #t (even? #d4)) (assert-eq? (tn) #t (even? #d-4)) (assert-eq? (tn) #t (even? #d+4)) ;; hexadecimal (assert-eq? (tn) #t (even? #x0)) (assert-eq? (tn) #t (even? #x-0)) (assert-eq? (tn) #t (even? #x+0)) (assert-eq? (tn) #f (even? #x1)) (assert-eq? (tn) #f (even? #x-1)) (assert-eq? (tn) #f (even? #x+1)) (assert-eq? (tn) #t (even? #x2)) (assert-eq? (tn) #t (even? #x-2)) (assert-eq? (tn) #t (even? #x+2)) (assert-eq? (tn) #f (even? #x3)) (assert-eq? (tn) #f (even? #x-3)) (assert-eq? (tn) #f (even? #x+3)) (assert-eq? (tn) #t (even? #x4)) (assert-eq? (tn) #t (even? #x-4)) (assert-eq? (tn) #t (even? #x+4)) (assert-eq? (tn) #t (even? #xa)) (assert-eq? (tn) #t (even? #x-a)) (assert-eq? (tn) #t (even? #x+a)) (assert-eq? (tn) #f (even? #xb)) (assert-eq? (tn) #f (even? #x-b)) (assert-eq? (tn) #f (even? #x+b)) (assert-error (tn) (lambda () (even? 'symbol))) (assert-error (tn) (lambda () (even? 'SYMBOL))) (assert-error (tn) (lambda () (even? #\a))) (assert-error (tn) (lambda () (even? #\ã‚))) (assert-error (tn) (lambda () (even? ""))) (assert-error (tn) (lambda () (even? " "))) (assert-error (tn) (lambda () (even? "a"))) (assert-error (tn) (lambda () (even? "A"))) (assert-error (tn) (lambda () (even? "aBc12!"))) (assert-error (tn) (lambda () (even? "ã‚"))) (assert-error (tn) (lambda () (even? "ã‚0イã†12!"))) (assert-error (tn) (lambda () (even? +))) (assert-error (tn) (lambda () (even? (lambda () #t)))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (even? else))) ;; expression keyword (assert-error (tn) (lambda () (even? do))))) (call-with-current-continuation (lambda (k) (assert-error (tn) (lambda () (even? k))))) (assert-error (tn) (lambda () (even? (current-output-port)))) (assert-error (tn) (lambda () (even? '(#t . #t)))) (assert-error (tn) (lambda () (even? (cons #t #t)))) (assert-error (tn) (lambda () (even? '(0 1 2)))) (assert-error (tn) (lambda () (even? (list 0 1 2)))) (assert-error (tn) (lambda () (even? '#()))) (assert-error (tn) (lambda () (even? (vector)))) (assert-error (tn) (lambda () (even? '#(0 1 2)))) (assert-error (tn) (lambda () (even? (vector 0 1 2)))) (total-report) uim-1.8.8/sigscheme/test/bigloo-vector.scm0000644000175000017500000001173212532333147015457 00000000000000;; A practical implementation for the Scheme programming language ;; ;; ,--^, ;; _ ___/ /|/ ;; ,;'( )__, ) ' ;; ;; // L__. ;; ' \\ / ' ;; ^ ^ ;; ;; Copyright (c) 1992-2004 Manuel Serrano ;; ;; Bug descriptions, use reports, comments or suggestions are ;; welcome. Send them to ;; bigloo@sophia.inria.fr ;; http://www.inria.fr/mimosa/fp/Bigloo ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. More precisely, ;; ;; - The compiler and the tools are distributed under the terms of the ;; GNU General Public License. ;; ;; - The Bigloo run-time system and the libraries are distributed under ;; the terms of the GNU Library General Public License. The source code ;; of the Bigloo runtime system is located in the ./runtime directory. ;; The source code of the FairThreads library is located in the ;; ./fthread directory. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/recette/vector.scm */ ;* */ ;* Author : Manuel Serrano */ ;* Creation : Tue Nov 3 09:39:09 1992 */ ;* Last change : Mon Jun 7 11:46:40 2004 (serrano) */ ;* */ ;* On test les operations primitives sur les vecteurs */ ;*---------------------------------------------------------------------*/ ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Bigloo 2.6e and adapted to SigScheme (load "./test/unittest-bigloo.scm") ;*---------------------------------------------------------------------*/ ;* Tvector optimization check */ ;*---------------------------------------------------------------------*/ (define *number-images* (vector #\0 #\1 #\2)) (define *foo* (vector "toto" "toto")) (define (prin-integer n) (let ((x (vector-ref *number-images* 2))) x)) (define (foo n) (vector-ref (if (equal? 5 n) *number-images* *foo*) 0) (prin-integer n)) ;*---------------------------------------------------------------------*/ ;* test-vector ... */ ;*---------------------------------------------------------------------*/ (define (test-vector) (test "vector?" (vector? '#()) #t) (test "vector?" (vector? '#(1)) #t) (test "ref" (vector-ref '#(1 2 3 4) 2) 3) (test "set" (let ((v (make-vector 1 '()))) (vector-set! v 0 'toto) (vector-ref v 0)) 'toto) (test "length" (vector-length '#(1 2 3 4 5)) 5) (test "length" (vector-length (make-vector 5 'toto)) 5) (test "equal vector" (let ((v (make-vector 3 '()))) (vector-set! v 0 '(1 2 3)) (vector-set! v 1 '#(1 2 3)) (vector-set! v 2 'hello) v) '#((1 2 3) #(1 2 3) hello)) (test "vector-fill" (let ((v (make-vector 3 1))) (vector-fill! v 2) (+ (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) 6) (test "tvector.1" (let ((t '#(1 2 3))) (vector-ref t 2)) 3) ; (test "tvector2" ; (string? (with-output-to-string ; (lambda () ; (print (make-array-of-int 1 1))))) ; #t) (test "vector-ref" (foo 10) #\2) (test "vector-ref" (vector-ref (let ((v (vector 0 1 2))) v) 2) 2)) (test-vector) (total-report) uim-1.8.8/sigscheme/test/test-enc-sjis.scm0000755000175000017500000001765412532333147015410 00000000000000#! /usr/bin/env sscm -C Shift_JIS ;; -*- buffer-file-coding-system: shift_jisx0213 -*- ;; C-x RET c shift_jisx0213 C-x C-f test-enc-sjis.scm ;; Filename : test-enc-sjis.scm ;; About : unit test for SJIS string ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (and (provided? "shift-jis") (symbol-bound? 'char?) (symbol-bound? 'string?))) (test-skip "Shift_JIS codec is not enabled")) (define tn test-name) (assert-equal? "string 1" "”ül‚É‚Í" (string #\”ü #\l #\‚É #\‚Í)) (assert-equal? "list->string 1" "3“ú‚Å" (list->string '(#\3 #\“ú #\‚Å))) (assert-equal? "string->list 1" '(#\‚Ÿ #\‚« #\‚é) (string->list "‚Ÿ‚«‚é")) (assert-equal? "string-ref 1" #\•à (string-ref "Ž•hi•àÍ•à" 3)) (assert-equal? "make-string 1" "•à•à•à•à•à" (make-string 5 #\•à)) (assert-equal? "string-copy 1" "‹à‹â" (string-copy "‹à‹â")) (assert-equal? "string-set! 1" "‹àŒj‹Ê" (let ((s (string-copy "‹àŒj‚Æ"))) (string-set! s 2 #\‹Ê) s)) ;; The character after ™ is in JIS X 0213 plane 2. (define str1 "‚ Ëƒƒah–\\\–\n!!™ð@!") (define str1-list '(#\‚  #\Ë #\ƒƒ #\a #\h #\–\ #\\ #\–\ #\n #\! #\! #\™ #\ð@ #\!)) (assert-equal? "string 2" str1 (apply string str1-list)) (assert-equal? "list->string 2" str1-list (string->list str1)) ;; JIS X 0201 kana (single byte) (assert-equal? "JIS X 0201 kana" #\Ë (integer->char #xcb)) (assert-equal? "JIS X 0201 kana" #xcb (char->integer #\Ë)) (assert-equal? "JIS X 0201 kana" '(#\Ë) (string->list "Ë")) (assert-equal? "JIS X 0201 kana" "Ë" (list->string '(#\Ë))) (assert-equal? "JIS X 0208 kana #1" #\ƒ„ (integer->char #x8384)) (assert-equal? "JIS X 0208 kana #2" (car (string->list "ƒ„")) (integer->char #x8384)) (assert-equal? "JIS X 0208 kana #3" #x8384 (char->integer #\ƒ„)) (assert-equal? "JIS X 0208 kana #4" #x8384 (char->integer (integer->char #x8384))) (assert-equal? "JIS X 0208 kana #5" '(#\ƒ„) (string->list "ƒ„")) (assert-equal? "JIS X 0208 kana #6" "ƒ„" (list->string '(#\ƒ„))) (assert-equal? "JIS X 0208 kana #7" "ƒ„" (list->string (string->list "ƒ„"))) (assert-equal? "JIS X 0201 kana and 0208 kana" '(#\Ë #\ƒƒ) (string->list "˃ƒ")) (assert-equal? "JIS X 0201 kana and 0208 kana" "˃ƒ" (list->string '(#\Ë #\ƒƒ))) ;; SRFI-75 (tn "SRFI-75") (assert-parseable (tn) "#\\x63") (assert-parse-error (tn) "#\\u0063") (assert-parse-error (tn) "#\\U00000063") (assert-parse-error (tn) "\"\\x63\"") (assert-parse-error (tn) "\"\\u0063\"") (assert-parse-error (tn) "\"\\U00000063\"") (assert-parseable (tn) "'a") ;; Non-Unicode multibyte symbols are not allowed. (assert-parse-error (tn) "'‚ ") (tn "R6RS (R5.92RS) chars") (assert-parseable (tn) "#\\x") (assert-parseable (tn) "#\\x6") (assert-parseable (tn) "#\\xf") (assert-parseable (tn) "#\\x63") (assert-parseable (tn) "#\\x063") (assert-parseable (tn) "#\\x0063") (assert-parseable (tn) "#\\x00063") (assert-parseable (tn) "#\\x0000063") (assert-parseable (tn) "#\\x00000063") (assert-parse-error (tn) "#\\x000000063") (assert-parseable (tn) "#\\x3042") (assert-parse-error (tn) "#\\x-") (assert-parse-error (tn) "#\\x-6") (assert-parse-error (tn) "#\\x-f") (assert-parse-error (tn) "#\\x-63") (assert-parse-error (tn) "#\\x-063") (assert-parse-error (tn) "#\\x-0063") (assert-parse-error (tn) "#\\x-00063") (assert-parse-error (tn) "#\\x-0000063") (assert-parse-error (tn) "#\\x-00000063") (assert-parse-error (tn) "#\\x-000000063") (assert-parse-error (tn) "#\\x+") (assert-parse-error (tn) "#\\x+6") (assert-parse-error (tn) "#\\x+f") (assert-parse-error (tn) "#\\x+63") (assert-parse-error (tn) "#\\x+063") (assert-parse-error (tn) "#\\x+0063") (assert-parse-error (tn) "#\\x+00063") (assert-parse-error (tn) "#\\x+0000063") (assert-parse-error (tn) "#\\x+00000063") (assert-parse-error (tn) "#\\x+000000063") (tn "R6RS (R5.92RS) string hex escapes") (assert-parse-error (tn) "\"\\x\"") (assert-parse-error (tn) "\"\\x6\"") (assert-parse-error (tn) "\"\\xf\"") (assert-parse-error (tn) "\"\\x63\"") (assert-parse-error (tn) "\"\\x063\"") (assert-parse-error (tn) "\"\\x0063\"") (assert-parse-error (tn) "\"\\x00063\"") (assert-parse-error (tn) "\"\\x0000063\"") (assert-parse-error (tn) "\"\\x00000063\"") (assert-parse-error (tn) "\"\\x000000063\"") (assert-parse-error (tn) "\"\\x;\"") (assert-parseable (tn) "\"\\x6;\"") (assert-parseable (tn) "\"\\xf;\"") (assert-parseable (tn) "\"\\x63;\"") (assert-parseable (tn) "\"\\x063;\"") (assert-parseable (tn) "\"\\x0063;\"") (assert-parseable (tn) "\"\\x00063;\"") (assert-parseable (tn) "\"\\x0000063;\"") (assert-parseable (tn) "\"\\x00000063;\"") (assert-parse-error (tn) "\"\\x000000063;\"") (assert-parse-error (tn) "\"\\x-\"") (assert-parse-error (tn) "\"\\x-6\"") (assert-parse-error (tn) "\"\\x-f\"") (assert-parse-error (tn) "\"\\x-63\"") (assert-parse-error (tn) "\"\\x-063\"") (assert-parse-error (tn) "\"\\x-0063\"") (assert-parse-error (tn) "\"\\x-00063\"") (assert-parse-error (tn) "\"\\x-0000063\"") (assert-parse-error (tn) "\"\\x-00000063\"") (assert-parse-error (tn) "\"\\x-000000063\"") (assert-parse-error (tn) "\"\\x-;\"") (assert-parse-error (tn) "\"\\x-6;\"") (assert-parse-error (tn) "\"\\x-f;\"") (assert-parse-error (tn) "\"\\x-63;\"") (assert-parse-error (tn) "\"\\x-063;\"") (assert-parse-error (tn) "\"\\x-0063;\"") (assert-parse-error (tn) "\"\\x-00063;\"") (assert-parse-error (tn) "\"\\x-0000063;\"") (assert-parse-error (tn) "\"\\x-00000063;\"") (assert-parse-error (tn) "\"\\x-000000063;\"") (assert-parse-error (tn) "\"\\x+\"") (assert-parse-error (tn) "\"\\x+6\"") (assert-parse-error (tn) "\"\\x+f\"") (assert-parse-error (tn) "\"\\x+63\"") (assert-parse-error (tn) "\"\\x+063\"") (assert-parse-error (tn) "\"\\x+0063\"") (assert-parse-error (tn) "\"\\x+00063\"") (assert-parse-error (tn) "\"\\x+0000063\"") (assert-parse-error (tn) "\"\\x+00000063\"") (assert-parse-error (tn) "\"\\x+000000063\"") (assert-parse-error (tn) "\"\\x+;\"") (assert-parse-error (tn) "\"\\x+6;\"") (assert-parse-error (tn) "\"\\x+f;\"") (assert-parse-error (tn) "\"\\x+63;\"") (assert-parse-error (tn) "\"\\x+063;\"") (assert-parse-error (tn) "\"\\x+0063;\"") (assert-parse-error (tn) "\"\\x+00063;\"") (assert-parse-error (tn) "\"\\x+0000063;\"") (assert-parse-error (tn) "\"\\x+00000063;\"") (assert-parse-error (tn) "\"\\x+000000063;\"") (total-report) uim-1.8.8/sigscheme/test/gauche-primsyn.scm0000644000175000017500000001656112532333147015644 00000000000000;; Copyright (c) 2000-2004 Shiro Kawai, All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the authors nor the names of its contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED ;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Gauche 0.8.5 and adapted to SigScheme ;;; ;;; primitive syntax test ;;; (load "./test/unittest-gauche.scm") (require-extension (srfi 8)) ;;---------------------------------------------------------------- ;(test-section "contitionals") (test "if" 5 (lambda () (if #f 2 5))) (test "if" 2 (lambda () (if (not #f) 2 5))) (test "and" #t (lambda () (and))) (test "and" 5 (lambda () (and 5))) (test "and" #f (lambda () (and 5 #f 2))) (test "and" #f (lambda () (and 5 #f unbound-var))) (test "and" 'a (lambda () (and 3 4 'a))) (test "or" #f (lambda () (or))) (test "or" 3 (lambda () (or 3 9))) (test "or" 3 (lambda () (or #f 3 unbound-var))) ;(test "when" 4 (lambda () (when 3 5 4))) ;(test "when" (test-undef) (lambda () (when #f 5 4))) ;(test "unless" (test-undef) (lambda () (unless 3 5 4))) ;(test "unless" 4 (lambda () (unless #f 5 4))) ;(test "cond" (test-undef) (lambda () (cond (#f 2)))) (test "cond" 5 (lambda () (cond (#f 2) (else 5)))) (test "cond" 2 (lambda () (cond (1 2) (else 5)))) (test "cond" 8 (lambda () (cond (#f 2) (1 8) (else 5)))) (test "cond" 3 (lambda () (cond (1 => (lambda (x) (+ x 2))) (else 8)))) (test "case" #t (lambda () (case (+ 2 3) ((1 3 5 7 9) #t) ((0 2 4 6 8) #f)))) ;;---------------------------------------------------------------- ;(test-section "closure and saved env") (test "lambda" 5 (lambda () ((lambda (x) (car x)) '(5 6 7)))) (test "lambda" 12 (lambda () ((lambda (x y) ((lambda (z) (* (car z) (cdr z))) (cons x y))) 3 4))) (define (addN n) (lambda (a) (+ a n))) (test "lambda" 5 (lambda () ((addN 2) 3))) (define add3 (addN 3)) (test "lambda" 9 (lambda () (add3 6))) (define count (let ((c 0)) (lambda () (set! c (+ c 1)) c))) (test "lambda" 1 (lambda () (count))) (test "lambda" 2 (lambda () (count))) ;;---------------------------------------------------------------- ;(test-section "application") ;(test "apply" '(1 2 3) (lambda () (apply list 1 '(2 3)))) ;(test "apply" '(1 2 3) (lambda () (apply apply (list list 1 2 '(3))))) (test "map" '() (lambda () (map car '()))) (test "map" '(1 2 3) (lambda () (map car '((1) (2) (3))))) (test "map" '(() () ()) (lambda () (map cdr '((1) (2) (3))))) (test "map" '((1 . 4) (2 . 5) (3 . 6)) (lambda () (map cons '(1 2 3) '(4 5 6)))) ;;---------------------------------------------------------------- ;(test-section "loop") (define (fact-non-tail-rec n) (if (<= n 1) n (* n (fact-non-tail-rec (- n 1))))) (test "loop non-tail-rec" 120 (lambda () (fact-non-tail-rec 5))) (define (fact-tail-rec n r) (if (<= n 1) r (fact-tail-rec (- n 1) (* n r)))) (test "loop tail-rec" 120 (lambda () (fact-tail-rec 5 1))) (define (fact-named-let n) (let loop ((n n) (r 1)) (if (<= n 1) r (loop (- n 1) (* n r))))) (test "loop named-let" 120 (lambda () (fact-named-let 5))) (define (fact-int-define n) (define (rec n r) (if (<= n 1) r (rec (- n 1) (* n r)))) (rec n 1)) (test "loop int-define" 120 (lambda () (fact-int-define 5))) (define (fact-do n) (do ((n n (- n 1)) (r 1 (* n r))) ((<= n 1) r))) (test "loop do" 120 (lambda () (fact-do 5))) ;;---------------------------------------------------------------- ;(test-section "quasiquote") (test "qq" '(1 2 3) (lambda () `(1 2 3))) (test "qq" '() (lambda () `())) (test "qq," '((1 . 2)) (lambda () `(,(cons 1 2)))) (test "qq," '((1 . 2) 3) (lambda () `(,(cons 1 2) 3))) (test "qq@" '(1 2 3 4) (lambda () `(1 ,@(list 2 3) 4))) (test "qq@" '(1 2 3 4) (lambda () `(1 2 ,@(list 3 4)))) (test "qq." '(1 2 3 4) (lambda () `(1 2 . ,(list 3 4)))) (test "qq#," '#((1 . 2) 3) (lambda () `#(,(cons 1 2) 3))) (test "qq#@" '#(1 2 3 4) (lambda () `#(1 ,@(list 2 3) 4))) (test "qq#@" '#(1 2 3 4) (lambda () `#(1 2 ,@(list 3 4)))) (test "qq#" '#() (lambda () `#())) (test "qq#@" '#() (lambda () `#(,@(list)))) (test "qq@@" '(1 2 1 2) (lambda () `(,@(list 1 2) ,@(list 1 2)))) (test "qq@@" '(1 2 a 1 2) (lambda () `(,@(list 1 2) a ,@(list 1 2)))) (test "qq@@" '(a 1 2 1 2) (lambda () `(a ,@(list 1 2) ,@(list 1 2)))) (test "qq@@" '(1 2 1 2 a) (lambda () `(,@(list 1 2) ,@(list 1 2) a))) (test "qq@@" '(1 2 1 2 a b) (lambda () `(,@(list 1 2) ,@(list 1 2) a b))) (test "qq@." '(1 2 1 2 . a) (lambda () `(,@(list 1 2) ,@(list 1 2) . a))) (test "qq@." '(1 2 1 2 1 . 2) (lambda () `(,@(list 1 2) ,@(list 1 2) . ,(cons 1 2)))) (test "qq@." '(1 2 1 2 a 1 . 2) (lambda () `(,@(list 1 2) ,@(list 1 2) a . ,(cons 1 2)))) (test "qq#@@" '#(1 2 1 2) (lambda () `#(,@(list 1 2) ,@(list 1 2)))) (test "qq#@@" '#(1 2 a 1 2) (lambda () `#(,@(list 1 2) a ,@(list 1 2)))) (test "qq#@@" '#(a 1 2 1 2) (lambda () `#(a ,@(list 1 2) ,@(list 1 2)))) (test "qq#@@" '#(1 2 1 2 a) (lambda () `#(,@(list 1 2) ,@(list 1 2) a))) (test "qq#@@" '#(1 2 1 2 a b) (lambda () `#(,@(list 1 2) ,@(list 1 2) a b))) (test "qqq" '(1 `(1 ,2 ,3) 1) (lambda () `(1 `(1 ,2 ,,(+ 1 2)) 1))) (test "qqq" '(1 `(1 ,@2 ,@(1 2))) (lambda () `(1 `(1 ,@2 ,@,(list 1 2))))) (test "qqq#" '#(1 `(1 ,2 ,3) 1) (lambda () `#(1 `(1 ,2 ,,(+ 1 2)) 1))) (test "qqq#" '#(1 `(1 ,@2 ,@(1 2))) (lambda () `#(1 `(1 ,@2 ,@,(list 1 2))))) ;;---------------------------------------------------------------- ;(test-section "multiple values") (test "receive" '(1 2 3) (lambda () (receive (a b c) (values 1 2 3) (list a b c)))) (test "receive" '(1 2 3) (lambda () (receive (a . r) (values 1 2 3) (cons a r)))) (test "receive" '(1 2 3) (lambda () (receive x (values 1 2 3) x))) (test "receive" 1 (lambda () (receive (a) 1 a))) (test "call-with-values" '(1 2 3) (lambda () (call-with-values (lambda () (values 1 2 3)) list))) (test "call-with-values" '() (lambda () (call-with-values (lambda () (values)) list))) (total-report) uim-1.8.8/sigscheme/test/test-eq.scm0000644000175000017500000007057312532333147014276 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; -*- buffer-file-coding-system: utf-8 -*- ;; Filename : test-eq.scm ;; About : unit tests for eq? ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (define case-insensitive-symbol? #f) (tn "eq? invalid form") (assert-error (tn) (lambda () (eq?))) (assert-error (tn) (lambda () (eq? #f))) (assert-error (tn) (lambda () (eq? #f #f #f))) (tn "eq? different types") (assert-eq? (tn) #f (eq? 1 #\1)) (assert-eq? (tn) #f (eq? #\1 "1")) (assert-eq? (tn) #f (eq? #\1 '("1"))) (assert-eq? (tn) #f (eq? '#("1") '("1"))) (tn "eq? boolean") (assert-eq? (tn) #t (eq? #f #f)) (assert-eq? (tn) #f (eq? #f #t)) (assert-eq? (tn) #f (eq? #t #f)) (assert-eq? (tn) #t (eq? #t #t)) (tn "eq? null") (assert-eq? (tn) #t (eq? '() '())) (if (and (provided? "sigscheme") (provided? "siod-bugs")) (begin (assert-eq? (tn) #t (eq? #f '())) (assert-eq? (tn) #t (eq? '() #f))) (begin (assert-eq? (tn) #f (eq? #f '())) (assert-eq? (tn) #f (eq? '() #f)))) (if (symbol-bound? 'vector?) (begin (assert-eq? (tn) #f (eq? '() '#())) (assert-eq? (tn) #f (eq? '#() '())))) (tn "eq? #") (if (provided? "sigscheme") (begin (assert-eq? (tn) #t (eq? (eof) (eof))) (assert-eq? (tn) #f (eq? (eof) (undef))) (assert-eq? (tn) #f (eq? (undef) (eof))) (assert-eq? (tn) #f (eq? '() (eof))) (assert-eq? (tn) #f (eq? (eof) '())) (assert-eq? (tn) #f (eq? #f (eof))) (assert-eq? (tn) #f (eq? (eof) #f)))) (tn "eq? #") (if (provided? "sigscheme") (begin (assert-eq? (tn) #t (eq? (undef) (undef))) (assert-eq? (tn) #f (eq? (eof) (undef))) (assert-eq? (tn) #f (eq? (undef) (eof))) (assert-eq? (tn) #f (eq? '() (undef))) (assert-eq? (tn) #f (eq? (undef) '())) (assert-eq? (tn) #f (eq? #f (undef))) (assert-eq? (tn) #f (eq? (undef) #f)))) (tn "eq? integer") (if (and (provided? "sigscheme") (provided? "immediate-number-only")) (begin (assert-eq? (tn) #t (eq? 0 0)) (assert-eq? (tn) #t (eq? 1 1)) (assert-eq? (tn) #t (eq? 3 3)) (assert-eq? (tn) #t (eq? -1 -1)) (assert-eq? (tn) #t (eq? -3 -3)) (assert-eq? (tn) #f (eq? 0 1)) (assert-eq? (tn) #f (eq? 1 0)) (assert-eq? (tn) #f (eq? 1 3)) (assert-eq? (tn) #f (eq? 3 1)) (assert-eq? (tn) #f (eq? -1 1)) (assert-eq? (tn) #f (eq? 1 -1)) (assert-eq? (tn) #f (eq? -3 3)) (assert-eq? (tn) #f (eq? 3 -3)) (assert-eq? (tn) #f (eq? -1 -3)) (assert-eq? (tn) #f (eq? -3 -1)))) (tn "eq? symbol") (assert-eq? (tn) #t (eq? 'symbol 'symbol)) (assert-eq? (tn) #f (eq? 'symbol1 'symbol2)) (if (and (provided? "sigscheme") (provided? "strict-r5rs") case-insensitive-symbol?) (begin (assert-eq? (tn) #t (eq? 'symbol 'SYMBOL)) (assert-eq? (tn) #t (eq? 'SYMBOL 'symbol)) (assert-eq? (tn) #t (eq? 'symbol 'Symbol)) (assert-eq? (tn) #t (eq? 'Symbol 'symbol)) (assert-eq? (tn) #t (eq? 'symbol 'syMBoL)) (assert-eq? (tn) #t (eq? 'syMBoL 'symbol))) (begin (assert-eq? (tn) #f (eq? 'symbol 'SYMBOL)) (assert-eq? (tn) #f (eq? 'SYMBOL 'symbol)) (assert-eq? (tn) #f (eq? 'symbol 'Symbol)) (assert-eq? (tn) #f (eq? 'Symbol 'symbol)) (assert-eq? (tn) #f (eq? 'symbol 'syMBoL)) (assert-eq? (tn) #f (eq? 'syMBoL 'symbol)))) (tn "eq? singlebyte char") (if (provided? "sigscheme") (if (provided? "immediate-char-only") (begin (assert-eq? (tn) #t (eq? #\a #\a)) (assert-eq? (tn) #f (eq? #\a #\b)) (assert-eq? (tn) #f (eq? #\b #\a)) (assert-eq? (tn) #t (eq? #\b #\b))) (begin (assert-eq? (tn) #f (eq? #\a #\a)) (assert-eq? (tn) #f (eq? #\a #\b)) (assert-eq? (tn) #f (eq? #\b #\a)) (assert-eq? (tn) #f (eq? #\b #\b))))) (let ((c1 #\a) (c2 #\b)) (assert-eq? (tn) #t (eq? c1 c1)) (assert-eq? (tn) #t (eq? c2 c2))) (tn "eq? multibyte char") (if (provided? "sigscheme") (if (provided? "immediate-char-only") (begin (assert-eq? (tn) #t (eq? #\ã‚ #\ã‚)) (assert-eq? (tn) #f (eq? #\ã‚ #\ã„)) (assert-eq? (tn) #f (eq? #\ã„ #\ã‚)) (assert-eq? (tn) #t (eq? #\ã„ #\ã„))) (begin (assert-eq? (tn) #f (eq? #\ã‚ #\ã‚)) (assert-eq? (tn) #f (eq? #\ã‚ #\ã„)) (assert-eq? (tn) #f (eq? #\ã„ #\ã‚)) (assert-eq? (tn) #f (eq? #\ã„ #\ã„))))) (let ((c1 #\ã‚) (c2 #\ã„)) (assert-eq? (tn) #t (eq? c1 c1)) (assert-eq? (tn) #t (eq? c2 c2))) (tn "eq? singlebyte string") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? "" "")) (assert-eq? (tn) #f (eq? "a" "a")) (assert-eq? (tn) #f (eq? "b" "b")) (assert-eq? (tn) #f (eq? "aBc12!" "aBc12!")))) (let ((s1 "") (s2 "a") (s3 "b") (s4 "aBc12!")) (assert-eq? (tn) #t (eq? s1 s1)) (assert-eq? (tn) #t (eq? s2 s2)) (assert-eq? (tn) #t (eq? s3 s3)) (assert-eq? (tn) #t (eq? s4 s4))) (assert-eq? (tn) #f (eq? "" "a")) (assert-eq? (tn) #f (eq? "a" "")) (assert-eq? (tn) #f (eq? "a" "b")) (assert-eq? (tn) #f (eq? "b" "a")) (assert-eq? (tn) #f (eq? "a" "A")) (assert-eq? (tn) #f (eq? "A" "a")) (assert-eq? (tn) #f (eq? "aBc123!" "aBc12!")) (assert-eq? (tn) #f (eq? "aBc12!" "aBc123!")) (tn "eq? multibyte string") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? "ã‚" "ã‚")) (assert-eq? (tn) #f (eq? "ã„" "ã„")) (assert-eq? (tn) #f (eq? "ã‚0イã†12!" "ã‚0イã†12!")))) (let ((s1 "ã‚") (s2 "ã„") (s3 "ã‚0イã†12!")) (assert-eq? (tn) #t (eq? s1 s1)) (assert-eq? (tn) #t (eq? s2 s2)) (assert-eq? (tn) #t (eq? s3 s3))) (assert-eq? (tn) #f (eq? "" "ã‚")) (assert-eq? (tn) #f (eq? "ã‚" "")) (assert-eq? (tn) #f (eq? "ã‚" "ã„")) (assert-eq? (tn) #f (eq? "ã„" "ã‚")) (assert-eq? (tn) #f (eq? "ã‚" "ã‚¢")) (assert-eq? (tn) #f (eq? "ã‚¢" "ã‚")) (assert-eq? (tn) #f (eq? "ã‚0イã†ã‡12!" "ã‚0イã†12!")) (assert-eq? (tn) #f (eq? "ã‚0イã†12!" "ã‚0イã†ã‡12!")) (tn "eq? procedure") (assert-eq? (tn) #t (eq? + +)) (assert-eq? (tn) #f (eq? + -)) (assert-eq? (tn) #f (eq? - +)) (assert-eq? (tn) #t (eq? - -)) (let ((plus +)) (assert-eq? (tn) #t (eq? + plus)) (assert-eq? (tn) #t (eq? plus +)) (assert-eq? (tn) #t (eq? plus plus))) (tn "eq? syntax") (assert-error (tn) (lambda () (eq? if if))) (assert-error (tn) (lambda () (eq? if set!))) (assert-error (tn) (lambda () (eq? set! if))) (assert-error (tn) (lambda () (eq? set! set!))) ;; (define syntax if) is an invalid form (tn "eq? macro") (if (symbol-bound? 'let-syntax) (let-syntax ((macro1 (syntax-rules () ((_) 'macro1-expanded))) (macro2 (syntax-rules () ((_) 'macro2-expanded)))) ;; syntactic keyword as value (assert-error (tn) (lambda () (eq? macro1 macro1))) (assert-error (tn) (lambda () (eq? macro2 macro1))) (assert-error (tn) (lambda () (eq? macro1 macro2))) (assert-error (tn) (lambda () (eq? macro2 macro2))))) (tn "eq? closure") (let ((closure (lambda () #t))) (assert-eq? (tn) #t (eq? closure closure)) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? closure (lambda () #t))) (assert-eq? (tn) #f (eq? (lambda () #t) closure)) (assert-eq? (tn) #f (eq? (lambda () #t) (lambda () #t)))))) (tn "eq? stateful closure") (let ((stateful (lambda () (let ((state 0)) (lambda () (set! state (+ state 1)) state))))) (assert-eq? (tn) #t (eq? stateful stateful)) (assert-eq? (tn) #f (eq? (stateful) (stateful)))) (let ((may-be-optimized-out (lambda () (let ((state 0)) (lambda () (set! state (+ state 1)) 0))))) (assert-eq? (tn) #t (eq? may-be-optimized-out may-be-optimized-out)) (if (provided? "sigscheme") (assert-eq? (tn) #f (eq? (may-be-optimized-out) (may-be-optimized-out))))) (letrec ((may-be-unified1 (lambda () (if (eq? may-be-unified1 may-be-unified2) 'optimized-out 'not-unified1))) (may-be-unified2 (lambda () (if (eq? may-be-unified1 may-be-unified2) 'optimized-out 'not-unified2)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? may-be-unified1 may-be-unified2)) (assert-eq? (tn) #f (eq? (may-be-unified1) (may-be-unified2)))) (begin ;; other implementations may pass this ;;(assert-eq? (tn) #t (eq? may-be-unified1 may-be-unified2)) ;;(assert-eq? (tn) #t (eq? (may-be-unified1) (may-be-unified2))) ))) (tn "eq? continuation") (call-with-current-continuation (lambda (k1) (call-with-current-continuation (lambda (k2) (assert-eq? (tn) #t (eq? k1 k1)) (assert-eq? (tn) #f (eq? k1 k2)) (assert-eq? (tn) #f (eq? k2 k1)) (assert-eq? (tn) #t (eq? k2 k2)) (let ((cont k1)) (assert-eq? (tn) #t (eq? cont cont)) (assert-eq? (tn) #t (eq? cont k1)) (assert-eq? (tn) #t (eq? k1 cont)) (assert-eq? (tn) #f (eq? cont k2)) (assert-eq? (tn) #f (eq? k2 cont))))))) (tn "eq? port") (assert-eq? (tn) #t (eq? (current-output-port) (current-output-port))) (assert-eq? (tn) #f (eq? (current-input-port) (current-output-port))) (assert-eq? (tn) #f (eq? (current-output-port) (current-input-port))) (assert-eq? (tn) #t (eq? (current-input-port) (current-input-port))) (let ((port (current-input-port))) (assert-eq? (tn) #t (eq? port port)) (assert-eq? (tn) #t (eq? (current-input-port) port)) (assert-eq? (tn) #t (eq? port (current-input-port))) (assert-eq? (tn) #f (eq? (current-output-port) port)) (assert-eq? (tn) #f (eq? port (current-output-port)))) (tn "eq? pair") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '(#t . #t) '(#t . #t))) (assert-eq? (tn) #f (eq? '(#f . #t) '(#f . #t))) (assert-eq? (tn) #f (eq? '(#t . #f) '(#t . #f))) (assert-eq? (tn) #f (eq? '(#f . #t) '(#t . #f))) (assert-eq? (tn) #f (eq? '(#\a . #\a) '(#\a . #\a))) (assert-eq? (tn) #f (eq? '(#\a . #\b) '(#\a . #\b))) (assert-eq? (tn) #f (eq? '(#\b . #\a) '(#\b . #\a))) (assert-eq? (tn) #f (eq? '(#\a . #\b) '(#\b . #\a))) (assert-eq? (tn) #f (eq? '("a" . "a") '("a" . "a"))) (assert-eq? (tn) #f (eq? '("a" . "b") '("a" . "b"))) (assert-eq? (tn) #f (eq? '("b" . "a") '("b" . "a"))) (assert-eq? (tn) #f (eq? '("a" . "b") '("b" . "a"))))) (assert-eq? (tn) #f (eq? (cons #t #t) (cons #t #t))) (assert-eq? (tn) #f (eq? (cons #f #t) (cons #f #t))) (assert-eq? (tn) #f (eq? (cons #t #f) (cons #t #f))) (assert-eq? (tn) #f (eq? (cons #f #t) (cons #t #f))) (assert-eq? (tn) #f (eq? (cons #\a #\a) (cons #\a #\a))) (assert-eq? (tn) #f (eq? (cons #\a #\b) (cons #\a #\b))) (assert-eq? (tn) #f (eq? (cons #\b #\a) (cons #\b #\a))) (assert-eq? (tn) #f (eq? (cons #\a #\b) (cons #\b #\a))) (assert-eq? (tn) #f (eq? (cons "a" "a") (cons "a" "a"))) (assert-eq? (tn) #f (eq? (cons "a" "b") (cons "a" "b"))) (assert-eq? (tn) #f (eq? (cons "b" "a") (cons "b" "a"))) (assert-eq? (tn) #f (eq? (cons "a" "b") (cons "b" "a"))) (tn "eq? list") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '(#f) '(#f))) (assert-eq? (tn) #f (eq? '(#f) '(#t))) (assert-eq? (tn) #f (eq? '(#t) '(#f))) (assert-eq? (tn) #f (eq? '(#t) '(#t))) (assert-eq? (tn) #f (eq? '((#f)) '((#f)))) (assert-eq? (tn) #f (eq? '((#f)) '((#t)))) (assert-eq? (tn) #f (eq? '((#t)) '((#f)))) (assert-eq? (tn) #f (eq? '((#t)) '((#t)))) (assert-eq? (tn) #f (eq? '(1) '(1))) (assert-eq? (tn) #f (eq? '(1) '(0))) (assert-eq? (tn) #f (eq? '(1 3 5 0 13) '(1 3 5 0 13))) (assert-eq? (tn) #f (eq? '(1 3 2 0 13) '(1 3 5 0 13))) (assert-eq? (tn) #f (eq? '(1 3 (5 0 13)) '(1 3 (5 0 13)))) (assert-eq? (tn) #f (eq? '(1 3 (2 0 13)) '(1 3 (5 0 13)))) (assert-eq? (tn) #f (eq? '((1)) '((1)))) (assert-eq? (tn) #f (eq? '((1)) '((0)))) (assert-eq? (tn) #f (eq? '((1) (3) (5) (0) (13)) '((1) (3) (5) (0) (13)))) (assert-eq? (tn) #f (eq? '((1) (3) (2) (0) (13)) '((1) (3) (5) (0) (13)))) (assert-eq? (tn) #f (eq? '(#\a) '(#\a))) (assert-eq? (tn) #f (eq? '(#\a) '(#\b))) (assert-eq? (tn) #f (eq? '(#\b) '(#\a))) (assert-eq? (tn) #f (eq? '((#\a)) '((#\a)))) (assert-eq? (tn) #f (eq? '((#\a)) '((#\b)))) (assert-eq? (tn) #f (eq? '((#\b)) '((#\a)))))) (assert-eq? (tn) #f (eq? (list #f) (list #f))) (assert-eq? (tn) #f (eq? (list #f) (list #t))) (assert-eq? (tn) #f (eq? (list #t) (list #f))) (assert-eq? (tn) #f (eq? (list #t) (list #t))) (assert-eq? (tn) #f (eq? (list (list #f)) (list (list #f)))) (assert-eq? (tn) #f (eq? (list (list #f)) (list (list #t)))) (assert-eq? (tn) #f (eq? (list (list #t)) (list (list #f)))) (assert-eq? (tn) #f (eq? (list (list #t)) (list (list #t)))) (assert-eq? (tn) #f (eq? (list 1) (list 1))) (assert-eq? (tn) #f (eq? (list 1) (list 0))) (assert-eq? (tn) #f (eq? (list 1 3 5 0 13) (list 1 3 5 0 13))) (assert-eq? (tn) #f (eq? (list 1 3 2 0 13) (list 1 3 5 0 13))) (assert-eq? (tn) #f (eq? (list 1 3 (list 5 0 13)) (list 1 3 (list 5 0 13)))) (assert-eq? (tn) #f (eq? (list 1 3 (list 2 0 13)) (list 1 3 (list 5 0 13)))) (assert-eq? (tn) #f (eq? (list (list 1)) (list (list 1)))) (assert-eq? (tn) #f (eq? (list (list 1)) (list (list 0)))) (assert-eq? (tn) #f (eq? (list (list 1) (list 3) (list 5) (list 0) (list 13)) (list (list 1) (list 3) (list 5) (list 0) (list 13)))) (assert-eq? (tn) #f (eq? (list (list 1) (list 3) (list 2) (list 0) (list 13)) (list (list 1) (list 3) (list 5) (list 0) (list 13)))) (assert-eq? (tn) #f (eq? (list #\a) (list #\a))) (assert-eq? (tn) #f (eq? (list #\a) (list #\b))) (assert-eq? (tn) #f (eq? (list #\b) (list #\a))) (assert-eq? (tn) #f (eq? (list (list #\a)) (list (list #\a)))) (assert-eq? (tn) #f (eq? (list (list #\a)) (list (list #\b)))) (assert-eq? (tn) #f (eq? (list (list #\b)) (list (list #\a)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '("") '(""))) (assert-eq? (tn) #f (eq? '(("")) '(("")))) (assert-eq? (tn) #f (eq? '("aBc12!") '("aBc12!"))) (assert-eq? (tn) #f (eq? '("ã‚0イã†12!") '("ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? '("a" "" "aB1" ("3c" "d") "a") '("a" "" "aB1" ("3c" "d") "a"))) (assert-eq? (tn) #f (eq? '(("aBc12!")) '(("aBc12!")))) (assert-eq? (tn) #f (eq? '(("ã‚0イã†12!")) '(("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eq? (list "") (list ""))) (assert-eq? (tn) #f (eq? (list (list "")) (list (list "")))) (assert-eq? (tn) #f (eq? (list "aBc12!") (list "aBc12!"))) (assert-eq? (tn) #f (eq? (list "ã‚0イã†12!") (list "ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? (list "a" "" "aB1" (list "3c" "d") "a") (list "a" "" "aB1" (list "3c" "d") "a"))) (assert-eq? (tn) #f (eq? (list (list "aBc12!")) (list (list "aBc12!")))) (assert-eq? (tn) #f (eq? (list (list "ã‚0イã†12!")) (list (list "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '("aBc123!") '("aBc12!"))) (assert-eq? (tn) #f (eq? '("ã‚0イã…12!") '("ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? '("a" "" "aB1" ("3c" "e") "a") '("a" "" "aB1" ("3c" "d") "a"))) (assert-eq? (tn) #f (eq? '(("aBc123!")) '(("aBc12!")))) (assert-eq? (tn) #f (eq? '(("ã‚0イã…12!")) '(("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eq? (list "aBc123!") (list "aBc12!"))) (assert-eq? (tn) #f (eq? (list "ã‚0イã…12!") (list "ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? (list "a" "" "aB1" (list "3c" "e") "a") (list "a" "" "aB1" (list "3c" "d") "a"))) (assert-eq? (tn) #f (eq? (list (list "aBc123!")) (list (list "aBc12!")))) (assert-eq? (tn) #f (eq? (list (list "ã‚0イã…12!")) (list (list "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eq? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("L")) #t))) (assert-eq? (tn) #f (eq? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" ("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eq? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eq? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))))) (assert-eq? (tn) #f (eq? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eq? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("L")) #t))) (assert-eq? (tn) #f (eq? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (list "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eq? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eq? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (tn "eq? empty vector") (if (provided? "sigscheme") (assert-eq? (tn) #f (eq? '#() '#()))) (assert-eq? (tn) #f (eq? (vector) (vector))) (let ((v1 '#()) (v2 (vector))) (assert-eq? (tn) #t (eq? v1 v1)) (assert-eq? (tn) #t (eq? v2 v2)) (assert-eq? (tn) #f (eq? v1 v2))) (tn "eq? vector") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '#(#f) '#(#f))) (assert-eq? (tn) #f (eq? '#(#f) '#(#t))) (assert-eq? (tn) #f (eq? '#(#t) '#(#f))) (assert-eq? (tn) #f (eq? '#(#t) '#(#t))) (assert-eq? (tn) #f (eq? '#(#(#f)) '#(#(#f)))) (assert-eq? (tn) #f (eq? '#(#(#f)) '#(#(#t)))) (assert-eq? (tn) #f (eq? '#(#(#t)) '#(#(#f)))) (assert-eq? (tn) #f (eq? '#(#(#t)) '#(#(#t)))) (assert-eq? (tn) #f (eq? '#(1) '#(1))) (assert-eq? (tn) #f (eq? '#(1) '#(0))) (assert-eq? (tn) #f (eq? '#(1 3 5 0 13) '#(1 3 5 0 13))) (assert-eq? (tn) #f (eq? '#(1 3 2 0 13) '#(1 3 5 0 13))) (assert-eq? (tn) #f (eq? '#(1 3 #(5 0 13)) '#(1 3 #(5 0 13)))) (assert-eq? (tn) #f (eq? '#(1 3 #(2 0 13)) '#(1 3 #(5 0 13)))) (assert-eq? (tn) #f (eq? '#(#(1)) '#(#(1)))) (assert-eq? (tn) #f (eq? '#(#(1)) '#(#(0)))) (assert-eq? (tn) #f (eq? '#(#(1) #(3) #(5) #(0) #(13)) '#(#(1) #(3) #(5) #(0) #(13)))) (assert-eq? (tn) #f (eq? '#(#(1) #(3) #(2) #(0) #(13)) '#(#(1) #(3) #(5) #(0) #(13)))) (assert-eq? (tn) #f (eq? '#(#\a) '#(#\a))) (assert-eq? (tn) #f (eq? '#(#\a) '#(#\b))) (assert-eq? (tn) #f (eq? '#(#\b) '#(#\a))) (assert-eq? (tn) #f (eq? '#(#(#\a)) '#(#(#\a)))) (assert-eq? (tn) #f (eq? '#(#(#\a)) '#(#(#\b)))) (assert-eq? (tn) #f (eq? '#(#(#\b)) '#(#(#\a)))))) (assert-eq? (tn) #f (eq? (vector #f) (vector #f))) (assert-eq? (tn) #f (eq? (vector #f) (vector #t))) (assert-eq? (tn) #f (eq? (vector #t) (vector #f))) (assert-eq? (tn) #f (eq? (vector #t) (vector #t))) (assert-eq? (tn) #f (eq? (vector (vector #f)) (vector (vector #f)))) (assert-eq? (tn) #f (eq? (vector (vector #f)) (vector (vector #t)))) (assert-eq? (tn) #f (eq? (vector (vector #t)) (vector (vector #f)))) (assert-eq? (tn) #f (eq? (vector (vector #t)) (vector (vector #t)))) (assert-eq? (tn) #f (eq? (vector 1) (vector 1))) (assert-eq? (tn) #f (eq? (vector 1) (vector 0))) (assert-eq? (tn) #f (eq? (vector 1 3 5 0 13) (vector 1 3 5 0 13))) (assert-eq? (tn) #f (eq? (vector 1 3 2 0 13) (vector 1 3 5 0 13))) (assert-eq? (tn) #f (eq? (vector 1 3 (vector 5 0 13)) (vector 1 3 (vector 5 0 13)))) (assert-eq? (tn) #f (eq? (vector 1 3 (vector 2 0 13)) (vector 1 3 (vector 5 0 13)))) (assert-eq? (tn) #f (eq? (vector (vector 1)) (vector (vector 1)))) (assert-eq? (tn) #f (eq? (vector (vector 1)) (vector (vector 0)))) (assert-eq? (tn) #f (eq? (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)) (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)))) (assert-eq? (tn) #f (eq? (vector (vector 1) (vector 3) (vector 2) (vector 0) (vector 13)) (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)))) (assert-eq? (tn) #f (eq? (vector #\a) (vector #\a))) (assert-eq? (tn) #f (eq? (vector #\a) (vector #\b))) (assert-eq? (tn) #f (eq? (vector #\b) (vector #\a))) (assert-eq? (tn) #f (eq? (vector (vector #\a)) (vector (vector #\a)))) (assert-eq? (tn) #f (eq? (vector (vector #\a)) (vector (vector #\b)))) (assert-eq? (tn) #f (eq? (vector (vector #\b)) (vector (vector #\a)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '#("") '#(""))) (assert-eq? (tn) #f (eq? '#(#("")) '#(#("")))) (assert-eq? (tn) #f (eq? '#("aBc12!") '#("aBc12!"))) (assert-eq? (tn) #f (eq? '#("ã‚0イã†12!") '#("ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? '#("a" "" "aB1" #("3c" "d") "a") '#("a" "" "aB1" #("3c" "d") "a"))) (assert-eq? (tn) #f (eq? '#(#("aBc12!")) '#(#("aBc12!")))) (assert-eq? (tn) #f (eq? '#(#("ã‚0イã†12!")) '#(#("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eq? (vector "") (vector ""))) (assert-eq? (tn) #f (eq? (vector (vector "")) (vector (vector "")))) (assert-eq? (tn) #f (eq? (vector "aBc12!") (vector "aBc12!"))) (assert-eq? (tn) #f (eq? (vector "ã‚0イã†12!") (vector "ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? (vector "a" "" "aB1" (vector "3c" "d") "a") (vector "a" "" "aB1" (vector "3c" "d") "a"))) (assert-eq? (tn) #f (eq? (vector (vector "aBc12!")) (vector (vector "aBc12!")))) (assert-eq? (tn) #f (eq? (vector (vector "ã‚0イã†12!")) (vector (vector "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '#("aBc123!") '#("aBc12!"))) (assert-eq? (tn) #f (eq? '#("ã‚0イã…12!") '#("ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? '#("a" "" "aB1" #("3c" "e") "a") '#("a" "" "aB1" #("3c" "d") "a"))) (assert-eq? (tn) #f (eq? '#(#("aBc123!")) '#(#("aBc12!")))) (assert-eq? (tn) #f (eq? '#(#("ã‚0イã…12!")) '#(#("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eq? (vector "aBc123!") (vector "aBc12!"))) (assert-eq? (tn) #f (eq? (vector "ã‚0イã…12!") (vector "ã‚0イã†12!"))) (assert-eq? (tn) #f (eq? (vector "a" "" "aB1" (vector "3c" "e") "a") (vector "a" "" "aB1" (vector "3c" "d") "a"))) (assert-eq? (tn) #f (eq? (vector (vector "aBc123!")) (vector (vector "aBc12!")))) (assert-eq? (tn) #f (eq? (vector (vector "ã‚0イã…12!")) (vector (vector "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eq? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eq? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("L")) #t))) (assert-eq? (tn) #f (eq? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" ("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eq? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eq? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))))) (assert-eq? (tn) #f (eq? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eq? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("L")) #t))) (assert-eq? (tn) #f (eq? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (list "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eq? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eq? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (total-report) uim-1.8.8/sigscheme/test/test-named-let.scm0000644000175000017500000010623312532333147015530 00000000000000;; Filename : test-named-let.scm ;; About : unit test for R5RS named let ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; ;; named let ;; (tn "named let invalid form") ;; bindings and body required (assert-error (tn) (lambda () (let loop))) (assert-error (tn) (lambda () (let loop ()))) (assert-error (tn) (lambda () (let loop ((a))))) (assert-error (tn) (lambda () (let loop ((a 1))))) (assert-error (tn) (lambda () (let loop (a 1)))) (assert-error (tn) (lambda () (let loop a))) (assert-error (tn) (lambda () (let loop #()))) (assert-error (tn) (lambda () (let loop #f))) (assert-error (tn) (lambda () (let loop #t))) ;; bindings must be a list (assert-error (tn) (lambda () (let loop a 'val))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let loop #f 'val)) (assert-error (tn) (lambda () (let loop #f 'val)))) (assert-error (tn) (lambda () (let loop #() 'val))) (assert-error (tn) (lambda () (let loop #t 'val))) ;; each binding must be a 2-elem list (assert-error (tn) (lambda () (let loop (a 1)))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let loop ((a)) 'val)) (assert-error (tn) (lambda () (let loop ((a)) 'val)))) (assert-error (tn) (lambda () (let loop ((a 1 'excessive)) 'val))) (assert-error (tn) (lambda () (let loop ((a 1) . (b 2)) 'val))) (assert-error (tn) (lambda () (let loop ((a . 1)) 'val))) (assert-error (tn) (lambda () (let loop ((a 1)) . a))) (assert-error (tn) (lambda () (let loop ((a 1)) 'val . a))) (assert-error (tn) (lambda () (let loop (1) #t))) (tn "named let binding syntactic keyword") (assert-equal? (tn) 1 (let loop ((else 1)) else)) (assert-equal? (tn) 2 (let loop ((=> 2)) =>)) (assert-equal? (tn) 3 (let loop ((unquote 3)) unquote)) (assert-error (tn) (lambda () else)) (assert-error (tn) (lambda () =>)) (assert-error (tn) (lambda () unquote)) (tn "named let env isolation") (assert-error (tn) (lambda () (let loop ((var1 1) (var2 var1)) 'result))) (assert-error (tn) (lambda () (let loop ((var1 var2) (var2 2)) 'result))) (assert-error (tn) (lambda () (let loop ((var1 var2) (var2 var1)) 'result))) (assert-error (tn) (lambda () (let loop ((var1 1) (var2 loop)) 'result))) ;; 'loop' is not bound at outer env (assert-error (tn) (lambda () (let loop () 'result) (loop))) (assert-equal? (tn) '(#f #f #f) (let loop ((var1 (symbol-bound? 'loop)) (var2 (symbol-bound? 'loop)) (var3 (symbol-bound? 'loop))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let loop ((var1 (symbol-bound? 'var1)) (var2 (symbol-bound? 'var1)) (var3 (symbol-bound? 'var1))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let loop ((var1 (symbol-bound? 'var2)) (var2 (symbol-bound? 'var2)) (var3 (symbol-bound? 'var2))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let loop ((var1 (symbol-bound? 'var3)) (var2 (symbol-bound? 'var3)) (var3 (symbol-bound? 'var3))) (list var1 var2 var3))) (tn "named let internal definitions lacking sequence part") ;; at least one is required (assert-error (tn) (lambda () (let loop () (define var1 1)))) (assert-error (tn) (lambda () (let loop () (define (proc1) 1)))) (assert-error (tn) (lambda () (let loop () (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let loop () (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let loop () (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let loop () (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let loop () (begin)))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1))))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define var2 2))))) ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let loop () (begin (define var1 1) 'val)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) 'val)))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define var2 2) 'val)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define var2 2) 'val)))) (tn "named let internal definitions cross reference") ;; R5RS: 5.2.2 Internal definitions ;; Just as for the equivalent `letrec' expression, it must be possible to ;; evaluate each of every internal definition in a without ;; assigning or referring to the value of any being defined. (assert-error (tn) (lambda () (let loop () (define var1 1) (define var2 var1) 'val))) (assert-error (tn) (lambda () (let loop () (define var1 var2) (define var2 2) 'val))) (assert-error (tn) (lambda () (let loop () (define var1 var1) 'val))) (assert-equal? (tn) '(0 0 0 0 0) (let loop ((var0 0)) (define var1 var0) (define var2 var0) (begin (define var3 var0) (begin (define var4 var0))) (define var5 var0) (list var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let loop ((var0 (symbol-bound? 'var1))) (define var1 (symbol-bound? 'var1)) (define var2 (symbol-bound? 'var1)) (begin (define var3 (symbol-bound? 'var1)) (begin (define var4 (symbol-bound? 'var1)))) (define var5 (symbol-bound? 'var1)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let loop ((var0 (symbol-bound? 'var2))) (define var1 (symbol-bound? 'var2)) (define var2 (symbol-bound? 'var2)) (begin (define var3 (symbol-bound? 'var2)) (begin (define var4 (symbol-bound? 'var2)))) (define var5 (symbol-bound? 'var2)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let loop ((var0 (symbol-bound? 'var3))) (define var1 (symbol-bound? 'var3)) (define var2 (symbol-bound? 'var3)) (begin (define var3 (symbol-bound? 'var3)) (begin (define var4 (symbol-bound? 'var3)))) (define var5 (symbol-bound? 'var3)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let loop ((var0 (symbol-bound? 'var4))) (define var1 (symbol-bound? 'var4)) (define var2 (symbol-bound? 'var4)) (begin (define var3 (symbol-bound? 'var4)) (begin (define var4 (symbol-bound? 'var4)))) (define var5 (symbol-bound? 'var4)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let loop ((var0 (symbol-bound? 'var5))) (define var1 (symbol-bound? 'var5)) (define var2 (symbol-bound? 'var5)) (begin (define var3 (symbol-bound? 'var5)) (begin (define var4 (symbol-bound? 'var5)))) (define var5 (symbol-bound? 'var5)) (list var0 var1 var2 var3 var4 var5))) ;; outer let cannot refer internal variable (assert-error (tn) (lambda () (let loop ((var0 (lambda () var1))) (define var1 (lambda () 1)) (eq? (var0) var0)))) ;; defining procedure can refer other (and self) variables as if letrec (assert-equal? (tn) '(#t #t #t #t #t) (let loop ((var0 (lambda () 0))) (define var1 (lambda () var0)) (define var2 (lambda () var0)) (begin (define var3 (lambda () var0)) (begin (define var4 (lambda () var0)))) (define var5 (lambda () var0)) (list (eq? (var1) var0) (eq? (var2) var0) (eq? (var3) var0) (eq? (var4) var0) (eq? (var5) var0)))) (assert-equal? (tn) '(#t #t #t #t #t) (let loop () (define var1 (lambda () var1)) (define var2 (lambda () var1)) (begin (define var3 (lambda () var1)) (begin (define var4 (lambda () var1)))) (define var5 (lambda () var1)) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1) (eq? (var4) var1) (eq? (var5) var1)))) (assert-equal? (tn) '(#t #t #t #t #t) (let loop () (define var1 (lambda () var2)) (define var2 (lambda () var2)) (begin (define var3 (lambda () var2)) (begin (define var4 (lambda () var2)))) (define var5 (lambda () var2)) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2) (eq? (var4) var2) (eq? (var5) var2)))) (assert-equal? (tn) '(#t #t #t #t #t) (let loop () (define var1 (lambda () var3)) (define var2 (lambda () var3)) (begin (define var3 (lambda () var3)) (begin (define var4 (lambda () var3)))) (define var5 (lambda () var3)) (list (eq? (var1) var3) (eq? (var2) var3) (eq? (var3) var3) (eq? (var4) var3) (eq? (var5) var3)))) (assert-equal? (tn) '(#t #t #t #t #t) (let loop () (define var1 (lambda () var4)) (define var2 (lambda () var4)) (begin (define var3 (lambda () var4)) (begin (define var4 (lambda () var4)))) (define var5 (lambda () var4)) (list (eq? (var1) var4) (eq? (var2) var4) (eq? (var3) var4) (eq? (var4) var4) (eq? (var5) var4)))) (assert-equal? (tn) '(#t #t #t #t #t) (let loop () (define var1 (lambda () var5)) (define var2 (lambda () var5)) (begin (define var3 (lambda () var5)) (begin (define var4 (lambda () var5)))) (define var5 (lambda () var5)) (list (eq? (var1) var5) (eq? (var2) var5) (eq? (var3) var5) (eq? (var4) var5) (eq? (var5) var5)))) (tn "named let internal definitions valid forms") ;; valid internal definitions (assert-equal? (tn) '(1) (let loop () (define var1 1) (list var1))) (assert-equal? (tn) '(1) (let loop () (define (proc1) 1) (list (proc1)))) (assert-equal? (tn) '(1 2) (let loop () (define var1 1) (define var2 2) (list var1 var2))) (assert-equal? (tn) '(1 2) (let loop () (define (proc1) 1) (define (proc2) 2) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let loop () (define var1 1) (define (proc2) 2) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let loop () (define (proc1) 1) (define var2 2) (list (proc1) var2))) ;; SigScheme accepts '(begin)' as valid internal definition '(begin ;; *)' as defined in "7.1.6 Programs and definitions" of R5RS ;; although it is rejected as expression '(begin )' as defined in ;; "7.1.3 Expressions". (assert-equal? (tn) 1 (let loop () (begin) 1)) (assert-equal? (tn) 1 (let loop () (begin) (define var1 1) (begin) 1)) (assert-equal? (tn) '(1) (let loop () (begin (define var1 1)) (list var1))) (assert-equal? (tn) '(1) (let loop () (begin (define (proc1) 1)) (list (proc1)))) (assert-equal? (tn) '(1 2) (let loop () (begin (define var1 1) (define var2 2)) (list var1 var2))) (assert-equal? (tn) '(1 2) (let loop () (begin (define (proc1) 1) (define (proc2) 2)) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let loop () (begin (define var1 1) (define (proc2) 2)) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let loop () (begin (define (proc1) 1) (define var2 2)) (list (proc1) var2))) (assert-equal? (tn) '(1 2 3 4 5 6) (let loop () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6))) ;; begin block and single definition mixed (assert-equal? (tn) '(1 2 3 4 5 6) (let loop () (begin) (define (proc1) 1) (begin (define var2 2) (begin (define (proc3) 3) (begin) (define var4 4))) (begin) (define (proc5) 5) (begin (begin (begin (begin))) (define var6 6) (begin)) (begin) (list (proc1) var2 (proc3) var4 (proc5) var6))) (tn "named let internal definitions invalid begin blocks") ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let loop () (begin (define var1 1) 'val) (list var1)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) 'val) (list (proc1))))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define var2 2) 'val) (list var1 var2)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define (proc2) 2) 'val) (list (proc1) (proc2))))) (assert-error (tn) (lambda () (let loop () (begin (define var1 1) (define (proc2) 2) 'val) (list var1 (proc2))))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define var2 2) 'val) (list (proc1) var2)))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6) 'val))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "named let internal definitions invalid placement") ;; a non-definition expression prior to internal definition is invalid (assert-error (tn) (lambda () (let loop () 'val (define var1 1)))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1)))) (assert-error (tn) (lambda () (let loop () 'val (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let loop () 'val (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let loop () 'val (begin)))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define var2 2))))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) (assert-error (tn) (lambda () (let loop () (begin (define (proc1) 1) (define var2 2) 'val (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) ;; a non-definition expression prior to internal definition is invalid even if ;; expression(s) is following the internal definition (assert-error (tn) (lambda () (let loop () 'val (define var1 1) 'val))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1) 'val))) (assert-error (tn) (lambda () (let loop () 'val (define var1 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let loop () 'val (define var1 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let loop () 'val (define (proc1) 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define var1 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let loop () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "named let binding syntactic keywords") (assert-error (tn) (lambda () (let loop ((syn define)) #t))) (assert-error (tn) (lambda () (let loop ((syn if)) #t))) (assert-error (tn) (lambda () (let loop ((syn and)) #t))) (assert-error (tn) (lambda () (let loop ((syn cond)) #t))) (assert-error (tn) (lambda () (let loop ((syn begin)) #t))) (assert-error (tn) (lambda () (let loop ((syn do)) #t))) (assert-error (tn) (lambda () (let loop ((syn delay)) #t))) (assert-error (tn) (lambda () (let loop ((syn let*)) #t))) (assert-error (tn) (lambda () (let loop ((syn else)) #t))) (assert-error (tn) (lambda () (let loop ((syn =>)) #t))) (assert-error (tn) (lambda () (let loop ((syn quote)) #t))) (assert-error (tn) (lambda () (let loop ((syn quasiquote)) #t))) (assert-error (tn) (lambda () (let loop ((syn unquote)) #t))) (assert-error (tn) (lambda () (let loop ((syn unquote-splicing)) #t))) (tn "named let") ;; empty bindings is allowed by the formal syntax spec (assert-equal? (tn) 'yes (let loop () (if (procedure? loop) 'yes 'no))) ;; duplicate variable name (assert-error (tn) (lambda () (let loop ((var1 1) (var1 2)) 'result))) ;; masked variable name (assert-equal? (tn) '(100 200 300) (let ((cnt 100) (cnt2 200) (cnt3 300)) (let loop ((cnt (+ -3 3)) (cnt2 0) (cnt3 (length '(#t #t #t)))) (if (not (>= cnt 3)) (begin (set! cnt (+ cnt 1)) (set! cnt2 (- cnt2 1)) (set! cnt3 (* cnt3 3)) (loop cnt cnt2 cnt3)))) (list cnt cnt2 cnt3))) (assert-equal? (tn) '(4 5 3) (let loop1 ((var1 1) (var2 2) (var3 3)) (let loop2 ((var1 4) (var2 5)) (list var1 var2 var3)))) (assert-equal? (tn) '(1 2 3) (let loop1 ((var1 1) (var2 2) (var3 3)) (let loop2 ((var1 4) (var2 5)) 'dummy) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 9) (let loop1 ((var1 1) (var2 2) (var3 3)) (let loop2 ((var1 4) (var2 5)) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 30) (let loop1 ((var1 1) (var2 2) (var3 3)) (let loop2 ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 3 (10 20)) (let loop1 ((var1 1) (var2 2) (var3 3) (var4 (let loop2 ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (list var1 var2)))) (list var1 var2 var3 var4))) (assert-error (tn) (lambda () (let loop1 ((var1 1) (var2 2) (var3 3) (var4 (let loop2 ((var1 4) (var2 5)) (set! var3 10)))) (list var1 var2 var3 var4)))) ;; no arg (assert-equal? (tn) 3 (let ((cnt 0)) (let loop () (if (>= cnt 3) cnt (begin (set! cnt (+ cnt 1)) (loop)))))) ;; 1 arg (assert-equal? (tn) 3 (let loop ((cnt 0)) (if (>= cnt 3) cnt (loop (+ cnt 1))))) ;; 3 arg + init with evaled value (assert-equal? (tn) '(3 -3 81) (let loop ((cnt (+ -3 3)) (cnt2 0) (cnt3 (length '(#t #t #t)))) (if (>= cnt 3) (list cnt cnt2 cnt3) (loop (+ cnt 1) (- cnt2 1) (* cnt3 3))))) (assert-equal? (tn) '((2 54 -8) (-33 1 29 3)) (let loop ((lst '(3 29 -8 54 1 -33 2)) (even '()) (odd '())) (cond ((null? lst) (list even odd)) ((even? (car lst)) (loop (cdr lst) (cons (car lst) even) odd)) (else (loop (cdr lst) even (cons (car lst) odd)))))) (tn "named let lexical scope") (define count-namedlet (let loop ((count-namedlet 0)) ;; intentionally same name (lambda () (set! count-namedlet (+ count-namedlet 1)) count-namedlet))) (assert-true (tn) (procedure? count-namedlet)) (assert-equal? (tn) 1 (count-namedlet)) (assert-equal? (tn) 2 (count-namedlet)) (assert-equal? (tn) 3 (count-namedlet)) (total-report) uim-1.8.8/sigscheme/test/test-number-io.scm0000644000175000017500000005545612532333147015571 00000000000000;; Filename : test-number-io.scm ;; About : unit test for R5RS number<->string conversion procedures ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) ;; ;; number->string ;; (tn "number->string invalid radix") (assert-error (tn) (lambda () (number->string 0 -16))) (assert-error (tn) (lambda () (number->string 0 -10))) (assert-error (tn) (lambda () (number->string 0 -8))) (assert-error (tn) (lambda () (number->string 0 -2))) (assert-error (tn) (lambda () (number->string 0 -1))) (assert-error (tn) (lambda () (number->string 0 0))) (assert-error (tn) (lambda () (number->string 0 1))) (assert-error (tn) (lambda () (number->string 0 3))) (assert-error (tn) (lambda () (number->string 0 4))) (assert-error (tn) (lambda () (number->string 0 7))) (assert-error (tn) (lambda () (number->string 0 9))) (assert-error (tn) (lambda () (number->string 0 11))) (assert-error (tn) (lambda () (number->string 0 15))) (assert-error (tn) (lambda () (number->string 0 17))) (tn "number->string invalid forms") (assert-error (tn) (lambda () (number->string))) (assert-error (tn) (lambda () (number->string "0"))) (assert-error (tn) (lambda () (number->string #\0))) (assert-error (tn) (lambda () (number->string #f))) (assert-error (tn) (lambda () (number->string '()))) (assert-error (tn) (lambda () (number->string "0" 2))) (assert-error (tn) (lambda () (number->string 0 "2"))) (assert-error (tn) (lambda () (number->string 0 2 #f))) (tn "number->string implicit decimal") (assert-equal? (tn) "-100" (number->string -100)) (assert-equal? (tn) "-10" (number->string -10)) (assert-equal? (tn) "-1" (number->string -1)) (assert-equal? (tn) "0" (number->string 0)) (assert-equal? (tn) "1" (number->string 1)) (assert-equal? (tn) "10" (number->string 10)) (assert-equal? (tn) "100" (number->string 100)) (if (>= fixnum-bits 60) (begin (tn "number->string implicit decimal 64-bit") (string-eval "(assert-equal? (tn) \"956397711204\" (number->string 956397711204))") (string-eval "(assert-equal? (tn) \"-956397711204\" (number->string -956397711204))"))) (tn "number->string explicit decimal") (assert-equal? (tn) "-100" (number->string -100 10)) (assert-equal? (tn) "-10" (number->string -10 10)) (assert-equal? (tn) "-1" (number->string -1 10)) (assert-equal? (tn) "0" (number->string 0 10)) (assert-equal? (tn) "1" (number->string 1 10)) (assert-equal? (tn) "10" (number->string 10 10)) (assert-equal? (tn) "100" (number->string 100 10)) (if (>= fixnum-bits 60) (begin (tn "number->string explicit decimal 64-bit") (string-eval "(assert-equal? (tn) \"956397711204\" (number->string 956397711204 10))") (string-eval "(assert-equal? (tn) \"-956397711204\" (number->string -956397711204 10))"))) (tn "number->string hexadecimal") (assert-equal? (tn) "-64" (number->string -100 16)) (assert-equal? (tn) "-a" (number->string -10 16)) (assert-equal? (tn) "-1" (number->string -1 16)) (assert-equal? (tn) "0" (number->string 0 16)) (assert-equal? (tn) "1" (number->string 1 16)) (assert-equal? (tn) "a" (number->string 10 16)) (assert-equal? (tn) "64" (number->string 100 16)) (if (>= fixnum-bits 60) (begin (tn "number->string hexadecimal 64-bit") (string-eval "(assert-equal? (tn) \"deadbeef64\" (number->string 956397711204 16))") (string-eval "(assert-equal? (tn) \"-deadbeef64\" (number->string -956397711204 16))"))) (tn "number->string octal") (assert-equal? (tn) "-144" (number->string -100 8)) (assert-equal? (tn) "-12" (number->string -10 8)) (assert-equal? (tn) "-1" (number->string -1 8)) (assert-equal? (tn) "0" (number->string 0 8)) (assert-equal? (tn) "1" (number->string 1 8)) (assert-equal? (tn) "12" (number->string 10 8)) (assert-equal? (tn) "144" (number->string 100 8)) (if (>= fixnum-bits 60) (begin (tn "number->string octal 64-bit") (string-eval "(assert-equal? (tn) \"15725557567544\" (number->string 956397711204 8))") (string-eval "(assert-equal? (tn) \"-15725557567544\" (number->string -956397711204 8))"))) (tn "number->string binary") (assert-equal? (tn) "-1100100" (number->string -100 2)) (assert-equal? (tn) "-1010" (number->string -10 2)) (assert-equal? (tn) "-1" (number->string -1 2)) (assert-equal? (tn) "0" (number->string 0 2)) (assert-equal? (tn) "1" (number->string 1 2)) (assert-equal? (tn) "1010" (number->string 10 2)) (assert-equal? (tn) "1100100" (number->string 100 2)) (if (>= fixnum-bits 60) (begin (tn "number->string binary 64-bit") (string-eval "(assert-equal? (tn) \"1101111010101101101111101110111101100100\" (number->string 956397711204 2))") (string-eval "(assert-equal? (tn) \"-1101111010101101101111101110111101100100\" (number->string -956397711204 2))"))) (tn "number->string boundary numbers") (if (and (symbol-bound? 'greatest-fixnum) (symbol-bound? 'least-fixnum)) (case fixnum-bits ((28) (assert-equal? (tn) "134217727" (number->string (greatest-fixnum))) (assert-equal? (tn) "-134217728" (number->string (least-fixnum))) (assert-equal? (tn) "111111111111111111111111111" (number->string (greatest-fixnum) 2)) (assert-equal? (tn) "-1000000000000000000000000000" (number->string (least-fixnum) 2)) (assert-equal? (tn) "-111111111111111111111111111" (number->string (+ (least-fixnum) 1) 2))) ((32) (assert-equal? (tn) "2147483647" (number->string (greatest-fixnum))) (assert-equal? (tn) "-2147483648" (number->string (least-fixnum))) (assert-equal? (tn) "1111111111111111111111111111111" (number->string (greatest-fixnum) 2)) (assert-equal? (tn) "-10000000000000000000000000000000" (number->string (least-fixnum) 2)) (assert-equal? (tn) "-1111111111111111111111111111111" (number->string (+ (least-fixnum) 1) 2))) ((60) (assert-equal? (tn) "576460752303423487" (number->string (greatest-fixnum))) (assert-equal? (tn) "-576460752303423488" (number->string (least-fixnum))) (assert-equal? (tn) "11111111111111111111111111111111111111111111111111111111111" (number->string (greatest-fixnum) 2)) (assert-equal? (tn) "-100000000000000000000000000000000000000000000000000000000000" (number->string (least-fixnum) 2)) (assert-equal? (tn) "-11111111111111111111111111111111111111111111111111111111111" (number->string (+ (least-fixnum) 1) 2))) ((64) (assert-equal? (tn) "9223372036854775807" (number->string (greatest-fixnum))) (assert-equal? (tn) "-9223372036854775808" (number->string (least-fixnum))) (assert-equal? (tn) "111111111111111111111111111111111111111111111111111111111111111" (number->string (greatest-fixnum) 2)) (assert-equal? (tn) "-1000000000000000000000000000000000000000000000000000000000000000" (number->string (least-fixnum) 2)) (assert-equal? (tn) "-111111111111111111111111111111111111111111111111111111111111111" (number->string (+ (least-fixnum) 1) 2))) (else (assert-fail (tn) "unknown int bitwidth")))) ;; ;; string->number ;; (tn "string->number invalid radix") (assert-error (tn) (lambda () (string->number "0" -16))) (assert-error (tn) (lambda () (string->number "0" -10))) (assert-error (tn) (lambda () (string->number "0" -8))) (assert-error (tn) (lambda () (string->number "0" -2))) (assert-error (tn) (lambda () (string->number "0" -1))) (assert-error (tn) (lambda () (string->number "0" 0))) (assert-error (tn) (lambda () (string->number "0" 1))) (assert-error (tn) (lambda () (string->number "0" 3))) (assert-error (tn) (lambda () (string->number "0" 4))) (assert-error (tn) (lambda () (string->number "0" 7))) (assert-error (tn) (lambda () (string->number "0" 9))) (assert-error (tn) (lambda () (string->number "0" 11))) (assert-error (tn) (lambda () (string->number "0" 15))) (assert-error (tn) (lambda () (string->number "0" 17))) (tn "string->number invalid forms") (assert-error (tn) (lambda () (string->number))) (assert-error (tn) (lambda () (string->number 0))) (assert-error (tn) (lambda () (string->number 0 2))) (assert-error (tn) (lambda () (string->number "0" "2"))) (assert-error (tn) (lambda () (string->number "0" 2 #f))) (tn "string->number invalid strings") (assert-eq? (tn) #f (string->number "")) (assert-eq? (tn) #f (string->number "a")) (assert-eq? (tn) #f (string->number "a" 10)) (assert-eq? (tn) #f (string->number "g" 16)) (assert-eq? (tn) #f (string->number "0xf" 16)) (assert-eq? (tn) #f (string->number "8" 8)) (assert-eq? (tn) #f (string->number "2" 2)) (assert-eq? (tn) #f (string->number "- 9")) (assert-eq? (tn) #f (string->number "- 9" 10)) (assert-eq? (tn) #f (string->number "- f" 16)) (assert-eq? (tn) #f (string->number "- 0xf" 16)) (assert-eq? (tn) #f (string->number "- 7" 8)) (assert-eq? (tn) #f (string->number "- 1" 2)) (assert-eq? (tn) #f (string->number "-a")) (assert-eq? (tn) #f (string->number "-a" 10)) (assert-eq? (tn) #f (string->number "-g" 16)) (assert-eq? (tn) #f (string->number "-0xf" 16)) (assert-eq? (tn) #f (string->number "-8" 8)) (assert-eq? (tn) #f (string->number "-2" 2)) (assert-eq? (tn) #f (string->number "+a")) (assert-eq? (tn) #f (string->number "+a" 10)) (assert-eq? (tn) #f (string->number "+g" 16)) (assert-eq? (tn) #f (string->number "+0xf" 16)) (assert-eq? (tn) #f (string->number "+8" 8)) (assert-eq? (tn) #f (string->number "+2" 2)) (assert-eq? (tn) #f (string->number " 1")) (assert-eq? (tn) #f (string->number " -1")) (assert-eq? (tn) #f (string->number " +1")) (assert-eq? (tn) #f (string->number " 01")) (assert-eq? (tn) #f (string->number "1 ")) (assert-eq? (tn) #f (string->number "-")) (assert-eq? (tn) #f (string->number "+")) (assert-eq? (tn) #f (string->number "+-0")) (assert-eq? (tn) #f (string->number "-+0")) (assert-eq? (tn) #f (string->number "++0")) (assert-eq? (tn) #f (string->number "--0")) (tn "string->number implicit decimal") (assert-equal? (tn) -100 (string->number "-100")) (assert-equal? (tn) -10 (string->number "-10")) (assert-equal? (tn) -1 (string->number "-1")) (assert-equal? (tn) 0 (string->number "-0")) (assert-equal? (tn) 0 (string->number "0")) (assert-equal? (tn) 0 (string->number "+0")) (assert-equal? (tn) 1 (string->number "1")) (assert-equal? (tn) 1 (string->number "+1")) (assert-equal? (tn) 10 (string->number "10")) (assert-equal? (tn) 10 (string->number "+10")) (assert-equal? (tn) 100 (string->number "100")) (assert-equal? (tn) 100 (string->number "+100")) (assert-equal? (tn) 238975 (string->number "0238975")) (assert-equal? (tn) 238975 (string->number "238975")) (assert-equal? (tn) 238975 (string->number "+238975")) (assert-equal? (tn) 238975 (string->number "+0238975")) (assert-equal? (tn) -238975 (string->number "-238975")) (assert-equal? (tn) -238975 (string->number "-0238975")) (if (>= fixnum-bits 60) (begin (tn "string->number implicit decimal 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"0956397711204\"))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"956397711204\"))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+956397711204\"))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+0956397711204\"))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-956397711204\"))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-0956397711204\"))"))) (tn "string->number explicit decimal") (assert-equal? (tn) -100 (string->number "-100" 10)) (assert-equal? (tn) -10 (string->number "-10" 10)) (assert-equal? (tn) -1 (string->number "-1" 10)) (assert-equal? (tn) 0 (string->number "-0" 10)) (assert-equal? (tn) 0 (string->number "0" 10)) (assert-equal? (tn) 0 (string->number "+0" 10)) (assert-equal? (tn) 1 (string->number "1" 10)) (assert-equal? (tn) 1 (string->number "+1" 10)) (assert-equal? (tn) 10 (string->number "10" 10)) (assert-equal? (tn) 10 (string->number "+10" 10)) (assert-equal? (tn) 100 (string->number "100" 10)) (assert-equal? (tn) 100 (string->number "+100" 10)) (assert-equal? (tn) 238975 (string->number "0238975" 10)) (assert-equal? (tn) 238975 (string->number "238975" 10)) (assert-equal? (tn) 238975 (string->number "+238975" 10)) (assert-equal? (tn) 238975 (string->number "+0238975" 10)) (assert-equal? (tn) -238975 (string->number "-238975" 10)) (assert-equal? (tn) -238975 (string->number "-0238975" 10)) (if (>= fixnum-bits 60) (begin (tn "string->number explicit decimal 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"0956397711204\" 10))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"956397711204\" 10))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+956397711204\" 10))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+0956397711204\" 10))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-956397711204\" 10))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-0956397711204\" 10))"))) (tn "string->number hexadecimal") (assert-equal? (tn) -256 (string->number "-100" 16)) (assert-equal? (tn) -16 (string->number "-10" 16)) (assert-equal? (tn) -1 (string->number "-1" 16)) (assert-equal? (tn) 0 (string->number "-0" 16)) (assert-equal? (tn) 0 (string->number "0" 16)) (assert-equal? (tn) 0 (string->number "+0" 16)) (assert-equal? (tn) 1 (string->number "1" 16)) (assert-equal? (tn) 1 (string->number "+1" 16)) (assert-equal? (tn) 16 (string->number "10" 16)) (assert-equal? (tn) 16 (string->number "+10" 16)) (assert-equal? (tn) 256 (string->number "100" 16)) (assert-equal? (tn) 256 (string->number "+100" 16)) (assert-equal? (tn) -10 (string->number "-a" 16)) (assert-equal? (tn) -10 (string->number "-A" 16)) (assert-equal? (tn) 10 (string->number "a" 16)) (assert-equal? (tn) 10 (string->number "+a" 16)) (assert-equal? (tn) 10 (string->number "A" 16)) (assert-equal? (tn) 10 (string->number "+A" 16)) (assert-equal? (tn) 14593330 (string->number "0deAd32" 16)) (assert-equal? (tn) 14593330 (string->number "deAd32" 16)) (assert-equal? (tn) 14593330 (string->number "+dEad32" 16)) (assert-equal? (tn) 14593330 (string->number "+0dEad32" 16)) (assert-equal? (tn) -14593330 (string->number "-deaD32" 16)) (assert-equal? (tn) -14593330 (string->number "-0deaD32" 16)) (assert-equal? (tn) 3333805 (string->number "32deAd" 16)) (assert-equal? (tn) 3333805 (string->number "+32dEad" 16)) (assert-equal? (tn) -3333805 (string->number "-32deaD" 16)) (if (>= fixnum-bits 60) (begin (tn "string->number hexadecimal 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"0deAdbeef64\" 16))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"deAdbeef64\" 16))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+dEadBeef64\" 16))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+0dEadBeef64\" 16))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-dEadBeef64\" 16))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-0deaDbeeF64\" 16))"))) (tn "string->number octal") (assert-equal? (tn) -64 (string->number "-100" 8)) (assert-equal? (tn) -8 (string->number "-10" 8)) (assert-equal? (tn) -1 (string->number "-1" 8)) (assert-equal? (tn) 0 (string->number "-0" 8)) (assert-equal? (tn) 0 (string->number "0" 8)) (assert-equal? (tn) 0 (string->number "+0" 8)) (assert-equal? (tn) 1 (string->number "1" 8)) (assert-equal? (tn) 1 (string->number "+1" 8)) (assert-equal? (tn) 8 (string->number "10" 8)) (assert-equal? (tn) 8 (string->number "+10" 8)) (assert-equal? (tn) 64 (string->number "100" 8)) (assert-equal? (tn) 64 (string->number "+100" 8)) (assert-equal? (tn) 1556392 (string->number "05737650" 8)) (assert-equal? (tn) 1556392 (string->number "5737650" 8)) (assert-equal? (tn) +1556392 (string->number "+5737650" 8)) (assert-equal? (tn) +1556392 (string->number "+05737650" 8)) (assert-equal? (tn) -1556392 (string->number "-5737650" 8)) (assert-equal? (tn) -1556392 (string->number "-05737650" 8)) (if (>= fixnum-bits 60) (begin (tn "string->number octal 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"015725557567544\" 8))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"15725557567544\" 8))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+15725557567544\" 8))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+015725557567544\" 8))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-15725557567544\" 8))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-015725557567544\" 8))"))) (tn "string->number binary") (assert-equal? (tn) -4 (string->number "-100" 2)) (assert-equal? (tn) -2 (string->number "-10" 2)) (assert-equal? (tn) -1 (string->number "-1" 2)) (assert-equal? (tn) 0 (string->number "-0" 2)) (assert-equal? (tn) 0 (string->number "0" 2)) (assert-equal? (tn) 0 (string->number "+0" 2)) (assert-equal? (tn) 1 (string->number "1" 2)) (assert-equal? (tn) 1 (string->number "+1" 2)) (assert-equal? (tn) 2 (string->number "10" 2)) (assert-equal? (tn) 2 (string->number "+10" 2)) (assert-equal? (tn) 4 (string->number "100" 2)) (assert-equal? (tn) 4 (string->number "+100" 2)) (assert-equal? (tn) 2990842 (string->number "01011011010001011111010" 2)) (assert-equal? (tn) 2990842 (string->number "1011011010001011111010" 2)) (assert-equal? (tn) +2990842 (string->number "+1011011010001011111010" 2)) (assert-equal? (tn) +2990842 (string->number "+01011011010001011111010" 2)) (assert-equal? (tn) -2990842 (string->number "-1011011010001011111010" 2)) (assert-equal? (tn) -2990842 (string->number "-01011011010001011111010" 2)) (if (>= fixnum-bits 60) (begin (tn "string->number binary 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"01101111010101101101111101110111101100100\" 2))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"1101111010101101101111101110111101100100\" 2))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+1101111010101101101111101110111101100100\" 2))") (string-eval "(assert-equal? (tn) 956397711204 (string->number \"+01101111010101101101111101110111101100100\" 2))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-1101111010101101101111101110111101100100\" 2))") (string-eval "(assert-equal? (tn) -956397711204 (string->number \"-01101111010101101101111101110111101100100\" 2))"))) (tn "string->number boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 134217727 (string->number \"134217727\"))") (string-eval "(assert-equal? (tn) -134217728 (string->number \"-134217728\"))") (assert-false (tn) (string->number "134217728")) (assert-false (tn) (string->number "-134217729"))) ((32) (string-eval "(assert-equal? (tn) 2147483647 (string->number \"2147483647\"))") (string-eval "(assert-equal? (tn) -2147483648 (string->number \"-2147483648\"))") (assert-false (tn) (string->number "2147483648")) (assert-false (tn) (string->number "-2147483649"))) ((60) (string-eval "(assert-equal? (tn) 576460752303423487 (string->number \"576460752303423487\"))") (string-eval "(assert-equal? (tn) -576460752303423488 (string->number \"-576460752303423488\")))") (assert-false (tn) (string->number "576460752303423488")) (assert-false (tn) (string->number "-576460752303423489"))) ((64) (string-eval "(assert-equal? (tn) 9223372036854775807 (string->number \"9223372036854775807\"))") (string-eval "(assert-equal? (tn) -9223372036854775808 (string->number \"-9223372036854775808\")))") (assert-false (tn) (string->number "9223372036854775808")) (assert-false (tn) (string->number "-9223372036854775809"))) (else (assert-fail (tn) "unknown int bitwidth"))) (total-report) uim-1.8.8/sigscheme/test/test-srfi48.scm0000644000175000017500000007735713274233500015013 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-srfi48.scm ;; About : unit test for SRFI-48 ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; All tests in this file are passed against r3170 (new repository) (require-extension (unittest)) (require-extension (srfi 6 38 48)) (if (not (provided? "srfi-48")) (test-skip "SRFI-48 is not enabled")) ;; test SRFI-28 compatible part of SRFI-48 (load "./test/test-srfi28.scm") (newline) (define tn test-name) (define testing-format+? (and (symbol-bound? 'format+) (eq? format format+))) (define cl (list 0 1)) (set-cdr! (cdr cl) cl) (tn "SRFI-48 format invalid form") (assert-error (tn) (lambda () (format 0 "~~"))) (assert-error (tn) (lambda () (format #\a "~~"))) (assert-error (tn) (lambda () (format "a" "~~"))) (assert-error (tn) (lambda () (format '(0 1) "~~"))) (assert-error (tn) (lambda () (format '#(0 1) "~~"))) (assert-error (tn) (lambda () (format 0 "~s" 0))) (assert-error (tn) (lambda () (format #\a "~s" #\a))) (assert-error (tn) (lambda () (format "a" "~s" "aBc"))) (assert-error (tn) (lambda () (format '(0 1) "~s" '(0 1)))) (assert-error (tn) (lambda () (format '#(0 1) "~s" '#(0 1)))) (assert-error (tn) (lambda () (format "~"))) (assert-error (tn) (lambda () (format "a~"))) (tn "SRFI-48 format explicit port") (assert-equal? (tn) "\"aBc\"" (format #f "~s" "aBc")) (display "expected output: \"aBc\"") (newline) (display "actual output: ") (assert-equal? (tn) (undef) (format #t "~s" "aBc")) (newline) (let ((port (open-output-string))) (assert-equal? (tn) (undef) (format port "~s" "aBc")) (assert-equal? (tn) "\"aBc\"" (get-output-string port))) (tn "format ~w") (assert-error (tn) (lambda () (format "~w"))) (assert-error (tn) (lambda () (format "~w" 0 1))) (assert-error (tn) (lambda () (format "~1w" 1))) (assert-equal? (tn) (if (and (provided? "sigscheme") (provided? "siod-bugs")) "()" "#f") (format "~w" #f)) (assert-equal? (tn) "#t" (format "~w" #t)) (assert-equal? (tn) "123" (format "~w" 123)) (assert-equal? (tn) "#\\a" (format "~w" #\a)) (assert-equal? (tn) "\"\"" (format "~w" "")) (assert-equal? (tn) "\"\\\"\"" (format "~w" "\"")) (assert-equal? (tn) "\"aBc\"" (format "~w" "aBc")) (assert-equal? (tn) "(#t 123 #\\a \"aBc\" (0))" (format "~w" '(#t 123 #\a "aBc" (0)))) (assert-equal? (tn) "#(#t 123 #\\a \"aBc\" (0))" (format "~w" '#(#t 123 #\a "aBc" (0)))) (assert-equal? (tn) (if (provided? "sigscheme") "#1=(0 1 . #1#)" ;; SigScheme starts the index with 1 "#0=(0 1 . #0#)") (format "~w" cl)) (assert-equal? (tn) "#t" (format "~W" #t)) (tn "format ~d") (assert-error (tn) (lambda () (format "~d"))) (assert-error (tn) (lambda () (format "~d" 0 1))) (assert-error (tn) (lambda () (format "~d" #t))) (assert-error (tn) (lambda () (format "~d" #\a))) (assert-error (tn) (lambda () (format "~d" "aBc"))) (assert-error (tn) (lambda () (format "~d" '(0 1)))) (assert-error (tn) (lambda () (format "~d" '#(0 1)))) (if (not testing-format+?) (assert-error (tn) (lambda () (format "~1d" 1)))) (assert-equal? (tn) "-100" (format "~d" -100)) (assert-equal? (tn) "-10" (format "~d" -10)) (assert-equal? (tn) "-1" (format "~d" -1)) (assert-equal? (tn) "0" (format "~d" 0)) (assert-equal? (tn) "1" (format "~d" 1)) (assert-equal? (tn) "10" (format "~d" 10)) (assert-equal? (tn) "100" (format "~d" 100)) (assert-equal? (tn) "10" (format "~D" 10)) (tn "format ~x") (assert-error (tn) (lambda () (format "~x"))) (assert-error (tn) (lambda () (format "~x" 0 1))) (assert-error (tn) (lambda () (format "~x" #t))) (assert-error (tn) (lambda () (format "~x" #\a))) (assert-error (tn) (lambda () (format "~x" "aBc"))) (assert-error (tn) (lambda () (format "~x" '(0 1)))) (assert-error (tn) (lambda () (format "~x" '#(0 1)))) (if (not testing-format+?) (assert-error (tn) (lambda () (format "~1x" 1)))) (assert-equal? (tn) "-64" (format "~x" -100)) (assert-equal? (tn) "-a" (format "~x" -10)) (assert-equal? (tn) "-1" (format "~x" -1)) (assert-equal? (tn) "0" (format "~x" 0)) (assert-equal? (tn) "1" (format "~x" 1)) (assert-equal? (tn) "a" (format "~x" 10)) (assert-equal? (tn) "64" (format "~x" 100)) (assert-equal? (tn) "a" (format "~X" 10)) (tn "format ~o") (assert-error (tn) (lambda () (format "~o"))) (assert-error (tn) (lambda () (format "~o" 0 1))) (assert-error (tn) (lambda () (format "~o" #t))) (assert-error (tn) (lambda () (format "~o" #\a))) (assert-error (tn) (lambda () (format "~o" "aBc"))) (assert-error (tn) (lambda () (format "~o" '(0 1)))) (assert-error (tn) (lambda () (format "~o" '#(0 1)))) (if (not testing-format+?) (assert-error (tn) (lambda () (format "~1o" 1)))) (assert-equal? (tn) "-144" (format "~o" -100)) (assert-equal? (tn) "-12" (format "~o" -10)) (assert-equal? (tn) "-1" (format "~o" -1)) (assert-equal? (tn) "0" (format "~o" 0)) (assert-equal? (tn) "1" (format "~o" 1)) (assert-equal? (tn) "12" (format "~o" 10)) (assert-equal? (tn) "144" (format "~o" 100)) (assert-equal? (tn) "12" (format "~O" 10)) (tn "format ~b") (assert-error (tn) (lambda () (format "~b"))) (assert-error (tn) (lambda () (format "~b" 0 1))) (assert-error (tn) (lambda () (format "~b" #t))) (assert-error (tn) (lambda () (format "~b" #\a))) (assert-error (tn) (lambda () (format "~b" "aBc"))) (assert-error (tn) (lambda () (format "~b" '(0 1)))) (assert-error (tn) (lambda () (format "~b" '#(0 1)))) (if (not testing-format+?) (assert-error (tn) (lambda () (format "~1b" 1)))) (assert-equal? (tn) "-1100100" (format "~b" -100)) (assert-equal? (tn) "-1010" (format "~b" -10)) (assert-equal? (tn) "-1" (format "~b" -1)) (assert-equal? (tn) "0" (format "~b" 0)) (assert-equal? (tn) "1" (format "~b" 1)) (assert-equal? (tn) "1010" (format "~b" 10)) (assert-equal? (tn) "1100100" (format "~b" 100)) (assert-equal? (tn) "1010" (format "~B" 10)) (if (and (symbol-bound? 'greatest-fixnum) (symbol-bound? 'least-fixnum)) (case fixnum-bits ((28) (tn "format 28bit fixnum") (assert-equal? (tn) "-134217728" (format "~d" (least-fixnum))) (assert-equal? (tn) "111111111111111111111111111" (format "~b" (greatest-fixnum))) (assert-equal? (tn) "-1000000000000000000000000000" (format "~b" (least-fixnum))) (assert-equal? (tn) "-111111111111111111111111111" (format "~b" (+ (least-fixnum) 1)))) ((32) (tn "format 32bit fixnum") (assert-equal? (tn) "-2147483648" (format "~d" (least-fixnum))) (assert-equal? (tn) "1111111111111111111111111111111" (format "~b" (greatest-fixnum))) (assert-equal? (tn) "-10000000000000000000000000000000" (format "~b" (least-fixnum))) (assert-equal? (tn) "-1111111111111111111111111111111" (format "~b" (+ (least-fixnum) 1)))) ((60) (tn "format 60bit fixnum") (assert-equal? (tn) "-576460752303423488" (format "~d" (least-fixnum))) (assert-equal? (tn) "11111111111111111111111111111111111111111111111111111111111" (format "~b" (greatest-fixnum))) (assert-equal? (tn) "-100000000000000000000000000000000000000000000000000000000000" (format "~b" (least-fixnum))) (assert-equal? (tn) "-11111111111111111111111111111111111111111111111111111111111" (format "~b" (+ (least-fixnum) 1)))) ((64) (tn "format 64bit fixnum") (assert-equal? (tn) "-9223372036854775808" (format "~d" (least-fixnum))) (assert-equal? (tn) "111111111111111111111111111111111111111111111111111111111111111" (format "~b" (greatest-fixnum))) (assert-equal? (tn) "-1000000000000000000000000000000000000000000000000000000000000000" (format "~b" (least-fixnum))) (assert-equal? (tn) "-111111111111111111111111111111111111111111111111111111111111111" (format "~b" (+ (least-fixnum) 1)))) (else (error "unknown int bitwidth")))) (tn "format ~c") (assert-error (tn) (lambda () (format "~c"))) (assert-error (tn) (lambda () (format "~c" #\a #\b))) (assert-error (tn) (lambda () (format "~c" #t))) (assert-error (tn) (lambda () (format "~c" 0))) (assert-error (tn) (lambda () (format "~c" "aBc"))) (assert-error (tn) (lambda () (format "~c" '(#\a #\b)))) (assert-error (tn) (lambda () (format "~c" '#(#\a #\b)))) (assert-error (tn) (lambda () (format "~1c" #\a))) (assert-equal? (tn) "a" (format "~c" #\a)) (assert-equal? (tn) "\"" (format "~c" #\")) (assert-equal? (tn) "ã‚" (format "~c" #\ã‚)) (tn "format ~f (number)") (assert-error (tn) (lambda () (format "~f"))) (assert-error (tn) (lambda () (format "~f" 0 1))) (assert-error (tn) (lambda () (format "~f" #t))) (assert-error (tn) (lambda () (format "~f" #\a))) (assert-error (tn) (lambda () (format "~f" '(0 1)))) (assert-error (tn) (lambda () (format "~f" '#(0 1)))) (assert-error (tn) (lambda () (format "0128f" 1))) (assert-error (tn) (lambda () (format "0128,1f" 1))) (assert-error (tn) (lambda () (format "1,0128f" 1))) (assert-error (tn) (lambda () (format "01024f" 1))) (assert-error (tn) (lambda () (format "01024,1f" 1))) (assert-error (tn) (lambda () (format "1,01024f" 1))) (assert-error (tn) (lambda () (format "~-1f" 1))) (assert-error (tn) (lambda () (format "~-0f" 1))) (assert-error (tn) (lambda () (format "~0,-0f" 1))) (assert-error (tn) (lambda () (format "~0,-1f" 1))) (assert-error (tn) (lambda () (format "~1,-0f" 1))) (assert-error (tn) (lambda () (format "~1,-1f" 1))) (assert-error (tn) (lambda () (format "~-0,0f" 1))) (assert-error (tn) (lambda () (format "~-0,1f" 1))) (assert-error (tn) (lambda () (format "~-1,0f" 1))) (assert-error (tn) (lambda () (format "~-1,1f" 1))) (assert-error (tn) (lambda () (format "~-0,-0f" 1))) (assert-error (tn) (lambda () (format "~-0,-1f" 1))) (assert-error (tn) (lambda () (format "~-1,-0f" 1))) (assert-error (tn) (lambda () (format "~-1,-1f" 1))) (assert-error (tn) (lambda () (format "~,f" 1))) (assert-error (tn) (lambda () (format "~,1f" 1))) (assert-error (tn) (lambda () (format "~1,f" 1))) (assert-equal? (tn) "-100" (format "~f" -100)) (assert-equal? (tn) "-10" (format "~f" -10)) (assert-equal? (tn) "-1" (format "~f" -1)) (assert-equal? (tn) "0" (format "~f" 0)) (assert-equal? (tn) "1" (format "~f" 1)) (assert-equal? (tn) "10" (format "~f" 10)) (assert-equal? (tn) "100" (format "~f" 100)) (if (not testing-format+?) (begin (assert-equal? (tn) "-100" (format "~0f" -100)) (assert-equal? (tn) "-10" (format "~0f" -10)) (assert-equal? (tn) "-1" (format "~0f" -1)) (assert-equal? (tn) "0" (format "~0f" 0)) (assert-equal? (tn) "1" (format "~0f" 1)) (assert-equal? (tn) "10" (format "~0f" 10)) (assert-equal? (tn) "100" (format "~0f" 100)))) (assert-equal? (tn) "-100" (format "~1f" -100)) (assert-equal? (tn) "-10" (format "~1f" -10)) (assert-equal? (tn) "-1" (format "~1f" -1)) (assert-equal? (tn) "0" (format "~1f" 0)) (assert-equal? (tn) "1" (format "~1f" 1)) (assert-equal? (tn) "10" (format "~1f" 10)) (assert-equal? (tn) "100" (format "~1f" 100)) (assert-equal? (tn) "-100" (format "~2f" -100)) (assert-equal? (tn) "-10" (format "~2f" -10)) (assert-equal? (tn) "-1" (format "~2f" -1)) (assert-equal? (tn) " 0" (format "~2f" 0)) (assert-equal? (tn) " 1" (format "~2f" 1)) (assert-equal? (tn) "10" (format "~2f" 10)) (assert-equal? (tn) "100" (format "~2f" 100)) (assert-equal? (tn) "-100" (format "~3f" -100)) (assert-equal? (tn) "-10" (format "~3f" -10)) (assert-equal? (tn) " -1" (format "~3f" -1)) (assert-equal? (tn) " 0" (format "~3f" 0)) (assert-equal? (tn) " 1" (format "~3f" 1)) (assert-equal? (tn) " 10" (format "~3f" 10)) (assert-equal? (tn) "100" (format "~3f" 100)) (assert-equal? (tn) "-100" (format "~4f" -100)) (assert-equal? (tn) " -10" (format "~4f" -10)) (assert-equal? (tn) " -1" (format "~4f" -1)) (assert-equal? (tn) " 0" (format "~4f" 0)) (assert-equal? (tn) " 1" (format "~4f" 1)) (assert-equal? (tn) " 10" (format "~4f" 10)) (assert-equal? (tn) " 100" (format "~4f" 100)) (assert-equal? (tn) " -100" (format "~5f" -100)) (assert-equal? (tn) " -10" (format "~5f" -10)) (assert-equal? (tn) " -1" (format "~5f" -1)) (assert-equal? (tn) " 0" (format "~5f" 0)) (assert-equal? (tn) " 1" (format "~5f" 1)) (assert-equal? (tn) " 10" (format "~5f" 10)) (assert-equal? (tn) " 100" (format "~5f" 100)) (if (not testing-format+?) (begin (assert-equal? (tn) "-100" (format "~0,0f" -100)) (assert-equal? (tn) "-10" (format "~0,0f" -10)) (assert-equal? (tn) "-1" (format "~0,0f" -1)) (assert-equal? (tn) "0" (format "~0,0f" 0)) (assert-equal? (tn) "1" (format "~0,0f" 1)) (assert-equal? (tn) "10" (format "~0,0f" 10)) (assert-equal? (tn) "100" (format "~0,0f" 100)))) (if (not testing-format+?) (begin (assert-equal? (tn) " -100" (format "~05f" -100)) (assert-equal? (tn) " -10" (format "~05f" -10)) (assert-equal? (tn) " -1" (format "~05f" -1)) (assert-equal? (tn) " 0" (format "~05f" 0)) (assert-equal? (tn) " 1" (format "~05f" 1)) (assert-equal? (tn) " 10" (format "~05f" 10)) (assert-equal? (tn) " 100" (format "~05f" 100)))) (if (symbol-bound? 'exact->inexact) (begin (assert-equal? (tn) "-100.0" (format "~5,0f" -100)) (assert-equal? (tn) "-10.0" (format "~5,0f" -10)) (assert-equal? (tn) " -1.0" (format "~5,0f" -1)) (assert-equal? (tn) " 0.0" (format "~5,0f" 0)) (assert-equal? (tn) " 1.0" (format "~5,0f" 1)) (assert-equal? (tn) " 10.0" (format "~5,0f" 10)) (assert-equal? (tn) "100.0" (format "~5,0f" 100)) (assert-equal? (tn) "-100.0" (format "~5,1f" -100)) (assert-equal? (tn) "-10.0" (format "~5,1f" -10)) (assert-equal? (tn) " -1.0" (format "~5,1f" -1)) (assert-equal? (tn) " 0.0" (format "~5,1f" 0)) (assert-equal? (tn) " 1.0" (format "~5,1f" 1)) (assert-equal? (tn) " 10.0" (format "~5,1f" 10)) (assert-equal? (tn) "100.0" (format "~5,1f" 100)) (assert-equal? (tn) "-100.00" (format "~5,2f" -100)) (assert-equal? (tn) "-10.00" (format "~5,2f" -10)) (assert-equal? (tn) "-1.00" (format "~5,2f" -1)) (assert-equal? (tn) " 0.00" (format "~5,2f" 0)) (assert-equal? (tn) " 1.00" (format "~5,2f" 1)) (assert-equal? (tn) "10.00" (format "~5,2f" 10)) (assert-equal? (tn) "100.00" (format "~5,2f" 100)) (if (not testing-format+?) (begin (assert-equal? (tn) "-100.00" (format "~05,02f" -100)) (assert-equal? (tn) "-10.00" (format "~05,02f" -10)) (assert-equal? (tn) "-1.00" (format "~05,02f" -1)) (assert-equal? (tn) " 0.00" (format "~05,02f" 0)) (assert-equal? (tn) " 1.00" (format "~05,02f" 1)) (assert-equal? (tn) "10.00" (format "~05,02f" 10)) (assert-equal? (tn) "100.00" (format "~05,02f" 100)))) (assert-equal? (tn) "100.0" (format "~5,1F" 100)))) (assert-equal? (tn) " 123" (format "~127f" 123)) (if (not testing-format+?) (assert-equal? (tn) " 123" (format "~0127f" 123))) (assert-equal? (tn) "10" (format "~F" 10)) (assert-equal? (tn) " 100" (format "~5F" 100)) (tn "format ~f (string)") (assert-error (tn) (lambda () (format "~f" "a" "b"))) (assert-error (tn) (lambda () (format "~f" '("a" "b")))) (assert-error (tn) (lambda () (format "~f" '#("a" "b")))) (assert-error (tn) (lambda () (format "0100f" "a"))) (assert-error (tn) (lambda () (format "0100,1f" "a"))) (assert-error (tn) (lambda () (format "1,0100f" "a"))) (assert-error (tn) (lambda () (format "~-1f" "a"))) (assert-error (tn) (lambda () (format "~-0f" "a"))) (assert-error (tn) (lambda () (format "~0,-0f" "a"))) (assert-error (tn) (lambda () (format "~0,-1f" "a"))) (assert-error (tn) (lambda () (format "~1,-0f" "a"))) (assert-error (tn) (lambda () (format "~1,-1f" "a"))) (assert-error (tn) (lambda () (format "~-0,0f" "a"))) (assert-error (tn) (lambda () (format "~-0,1f" "a"))) (assert-error (tn) (lambda () (format "~-1,0f" "a"))) (assert-error (tn) (lambda () (format "~-1,1f" "a"))) (assert-error (tn) (lambda () (format "~-0,-0f" "a"))) (assert-error (tn) (lambda () (format "~-0,-1f" "a"))) (assert-error (tn) (lambda () (format "~-1,-0f" "a"))) (assert-error (tn) (lambda () (format "~-1,-1f" "a"))) (assert-equal? (tn) "" (format "~f" "")) (assert-equal? (tn) "\"" (format "~f" "\"")) (assert-equal? (tn) "aBc" (format "~f" "aBc")) (assert-equal? (tn) "ã‚bã†" (format "~f" "ã‚bã†")) (assert-equal? (tn) "" (format "~0f" "")) (assert-equal? (tn) "\"" (format "~0f" "\"")) (assert-equal? (tn) "aBc" (format "~0f" "aBc")) (assert-equal? (tn) "ã‚bã†" (format "~0f" "ã‚bã†")) (assert-equal? (tn) " " (format "~1f" "")) (assert-equal? (tn) "\"" (format "~1f" "\"")) (assert-equal? (tn) "aBc" (format "~1f" "aBc")) (assert-equal? (tn) "ã‚bã†" (format "~1f" "ã‚bã†")) (assert-equal? (tn) " " (format "~2f" "")) (assert-equal? (tn) " \"" (format "~2f" "\"")) (assert-equal? (tn) "aBc" (format "~2f" "aBc")) (assert-equal? (tn) "ã‚bã†" (format "~2f" "ã‚bã†")) (assert-equal? (tn) " " (format "~3f" "")) (assert-equal? (tn) " \"" (format "~3f" "\"")) (assert-equal? (tn) "aBc" (format "~3f" "aBc")) (assert-equal? (tn) "ã‚bã†" (format "~3f" "ã‚bã†")) (assert-equal? (tn) " " (format "~4f" "")) (assert-equal? (tn) " \"" (format "~4f" "\"")) (assert-equal? (tn) " aBc" (format "~4f" "aBc")) (assert-equal? (tn) " ã‚bã†" (format "~4f" "ã‚bã†")) (assert-equal? (tn) " " (format "~5f" "")) (assert-equal? (tn) " \"" (format "~5f" "\"")) (assert-equal? (tn) " aBc" (format "~5f" "aBc")) (assert-equal? (tn) " ã‚bã†" (format "~5f" "ã‚bã†")) (assert-equal? (tn) " " (format "~05f" "")) (assert-equal? (tn) " \"" (format "~05f" "\"")) (assert-equal? (tn) " aBc" (format "~05f" "aBc")) (assert-equal? (tn) " ã‚bã†" (format "~05f" "ã‚bã†")) (assert-equal? (tn) " " (format "~5,2f" "")) (assert-equal? (tn) " \"" (format "~5,2f" "\"")) (assert-equal? (tn) " aBc" (format "~5,2f" "aBc")) (assert-equal? (tn) " ã‚bã†" (format "~5,2f" "ã‚bã†")) (assert-equal? (tn) " " (format "~05,02f" "")) (assert-equal? (tn) " \"" (format "~05,02f" "\"")) (assert-equal? (tn) " aBc" (format "~05,02f" "aBc")) (assert-equal? (tn) " ã‚bã†" (format "~05,02f" "ã‚bã†")) (assert-equal? (tn) " aBc" (format "~127f" "aBc")) (assert-equal? (tn) " aBc" (format "~0127f" "aBc")) (assert-equal? (tn) "aBc" (format "~F" "aBc")) (assert-equal? (tn) " aBc" (format "~5F" "aBc")) (assert-equal? (tn) " aBc" (format "~05F" "aBc")) (assert-equal? (tn) " aBc" (format "~5,2F" "aBc")) (tn "format ~?") (assert-error (tn) (lambda () (format "~?"))) (assert-error (tn) (lambda () (format "~?" "~~"))) (assert-error (tn) (lambda () (format "~?" "a"))) (assert-error (tn) (lambda () (format "~?" "a" '() "b"))) (assert-error (tn) (lambda () (format "~1?" "a" '()))) (assert-error (tn) (lambda () (format "~?" "~a" '()))) (assert-error (tn) (lambda () (format "~?" "~a" '(0 1)))) (assert-error (tn) (lambda () (format "~?" "~?" '("~a")))) (assert-error (tn) (lambda () (format "~?" "~?" '("~a" (0 1))))) (assert-error (tn) (lambda () (format "~?" #t '()))) (assert-error (tn) (lambda () (format "~?" 0 '()))) (assert-error (tn) (lambda () (format "~?" #\a '()))) (assert-error (tn) (lambda () (format "~?" '(0 1) '()))) (assert-error (tn) (lambda () (format "~?" '#(0 1) '()))) (assert-equal? (tn) "~" (format "~?" "~~" '())) (assert-equal? (tn) " " (format "~?" "~_" '())) (assert-equal? (tn) "\n" (format "~?" "~%" '())) (assert-equal? (tn) "\n" (format "~?" "~&" '())) ;; hard to be this on current port implementation ;;(assert-equal? (tn) "\n" (format "~?" "~%~?" '("~&" ()))) (assert-equal? (tn) "\n\n" (format "~?" "~%~?" '("~&" ()))) (assert-equal? (tn) "\n \n" (format "~?" "~% ~?" '("~&" ()))) (assert-equal? (tn) "\n \n" (format "~?" "~%~?" '(" ~&" ()))) (assert-equal? (tn) "aBc" (format "~?" "aBc" '())) (assert-equal? (tn) "0aBc1" (format "~?" "0~a1" '("aBc"))) (assert-equal? (tn) "02aBc31" (format "~?" "0~?1" '("2~a3" ("aBc")))) (assert-equal? (tn) "024aBc531" (format "~?" "0~?1" '("2~?3" ("4~a5" ("aBc"))))) (assert-equal? (tn) (if (and (provided? "sigscheme") (provided? "siod-bugs")) "()" "#f") (format "~?" "~w" '(#f))) (assert-equal? (tn) "#t" (format "~?" "~w" '(#t))) (assert-equal? (tn) "123" (format "~?" "~w" '(123))) (assert-equal? (tn) "#\\a" (format "~?" "~w" '(#\a))) (assert-equal? (tn) "\"\"" (format "~?" "~w" '(""))) (assert-equal? (tn) "\"\\\"\"" (format "~?" "~w" '("\""))) (assert-equal? (tn) "\"aBc\"" (format "~?" "~w" '("aBc"))) (assert-equal? (tn) "(#t 123 #\\a \"aBc\" (0))" (format "~?" "~w" '((#t 123 #\a "aBc" (0))))) (assert-equal? (tn) "#(#t 123 #\\a \"aBc\" (0))" (format "~?" "~w" '(#(#t 123 #\a "aBc" (0))))) (assert-equal? (tn) (if (provided? "sigscheme") "#1=(0 1 . #1#)" ;; SigScheme starts the index with 1 "#0=(0 1 . #0#)") (format "~?" "~w" (list cl))) ;; alias of ~? (tn "format ~k") (assert-error (tn) (lambda () (format "~k"))) (assert-error (tn) (lambda () (format "~k" "~~"))) (assert-error (tn) (lambda () (format "~k" "a"))) (assert-error (tn) (lambda () (format "~k" "a" '() "b"))) (assert-error (tn) (lambda () (format "~1k" "a" '()))) (assert-error (tn) (lambda () (format "~k" "~a" '()))) (assert-error (tn) (lambda () (format "~k" "~a" '(0 1)))) (assert-error (tn) (lambda () (format "~k" "~k" '("~a")))) (assert-error (tn) (lambda () (format "~k" "~k" '("~a" (0 1))))) (assert-error (tn) (lambda () (format "~k" #t '()))) (assert-error (tn) (lambda () (format "~k" 0 '()))) (assert-error (tn) (lambda () (format "~k" #\a '()))) (assert-error (tn) (lambda () (format "~k" '(0 1) '()))) (assert-error (tn) (lambda () (format "~k" '#(0 1) '()))) (assert-equal? (tn) "~" (format "~k" "~~" '())) (assert-equal? (tn) "02aBc31" (format "~k" "0~k1" '("2~a3" ("aBc")))) (assert-error (tn) (lambda () (format "~K"))) (assert-error (tn) (lambda () (format "~K" "~~"))) (assert-error (tn) (lambda () (format "~K" "a"))) (assert-error (tn) (lambda () (format "~K" "a" '() "b"))) (assert-error (tn) (lambda () (format "~1K" "a" '()))) (assert-error (tn) (lambda () (format "~K" "~a" '()))) (assert-error (tn) (lambda () (format "~K" "~a" '(0 1)))) (assert-error (tn) (lambda () (format "~K" "~K" '("~a")))) (assert-error (tn) (lambda () (format "~K" "~K" '("~a" (0 1))))) (assert-error (tn) (lambda () (format "~K" #t '()))) (assert-error (tn) (lambda () (format "~K" 0 '()))) (assert-error (tn) (lambda () (format "~K" #\a '()))) (assert-error (tn) (lambda () (format "~K" '(0 1) '()))) (assert-error (tn) (lambda () (format "~K" '#(0 1) '()))) (assert-equal? (tn) "~" (format "~K" "~~" '())) (assert-equal? (tn) "02aBc31" (format "~K" "0~K1" '("2~a3" ("aBc")))) (tn "format ~y") (assert-error (tn) (lambda () (format "~y"))) (assert-error (tn) (lambda () (format "~y" 0 1))) (assert-error (tn) (lambda () (format "~1y" 1))) (assert-equal? (tn) (if (and (provided? "sigscheme") (provided? "siod-bugs")) "()" "#f") (format "~y" #f)) (assert-equal? (tn) "#t" (format "~y" #t)) (assert-equal? (tn) "123" (format "~y" 123)) (assert-equal? (tn) "#\\a" (format "~y" #\a)) (assert-equal? (tn) "\"\"" (format "~y" "")) (assert-equal? (tn) "\"\\\"\"" (format "~y" "\"")) (assert-equal? (tn) "\"aBc\"" (format "~y" "aBc")) ;; no pretty-print procedure (assert-equal? (tn) "(#t 123 #\\a \"aBc\" (0))" (format "~y" '(#t 123 #\a "aBc" (0)))) (assert-equal? (tn) "#(#t 123 #\\a \"aBc\" (0))" (format "~y" '#(#t 123 #\a "aBc" (0)))) (tn "format ~y with explicit port to pretty-print") (let ((p (open-output-string))) (format p "~y" 123) (assert-equal? (tn) "123" (get-output-string p))) (define pretty-print write) (let ((p (open-output-string))) (format p "~y" 123) (assert-equal? (tn) "123" (get-output-string p))) (define pretty-print #f) (let ((p (open-output-string))) (assert-error (tn) (lambda () (format p "~y" 123)))) (tn "format ~t") (assert-error (tn) (lambda () (format "~t" #t))) (assert-error (tn) (lambda () (format "~t" 0))) (assert-error (tn) (lambda () (format "~t" #\a))) (assert-error (tn) (lambda () (format "~t" "aBc"))) (assert-error (tn) (lambda () (format "~t" '(0 1)))) (assert-error (tn) (lambda () (format "~t" '#(0 1)))) (assert-error (tn) (lambda () (format "~1t"))) (assert-equal? (tn) " " (format "~t")) (assert-equal? (tn) "\t" (format "~t")) (assert-equal? (tn) "\t" (format "~T")) (tn "format ~_") (assert-error (tn) (lambda () (format "~_" #t))) (assert-error (tn) (lambda () (format "~_" 0))) (assert-error (tn) (lambda () (format "~_" #\a))) (assert-error (tn) (lambda () (format "~_" "aBc"))) (assert-error (tn) (lambda () (format "~_" '(0 1)))) (assert-error (tn) (lambda () (format "~_" '#(0 1)))) (assert-error (tn) (lambda () (format "~1_"))) (assert-equal? (tn) " " (format "~_")) (tn "format ~&") (assert-error (tn) (lambda () (format "~&" #t))) (assert-error (tn) (lambda () (format "~&" 0))) (assert-error (tn) (lambda () (format "~&" #\a))) (assert-error (tn) (lambda () (format "~&" "aBc"))) (assert-error (tn) (lambda () (format "~&" '(0 1)))) (assert-error (tn) (lambda () (format "~&" '#(0 1)))) (assert-error (tn) (lambda () (format "~1&"))) (assert-equal? (tn) " " (format "~&")) (assert-equal? (tn) "\n" (format "~&")) (assert-equal? (tn) "\n" (format "~&~&")) (assert-equal? (tn) "\n" (format "~&~&~&")) (assert-equal? (tn) "\n" (format "~%~&")) (assert-equal? (tn) "\n" (format "~%~&~&")) (assert-equal? (tn) "\n\n" (format "~&~%")) (assert-equal? (tn) "\n\n" (format "~&~%~&")) (assert-equal? (tn) "\n" (format "\n~&")) (assert-equal? (tn) "\n\n" (format "~&\n")) (assert-equal? (tn) "\n\n" (format "~&\n~&")) (assert-equal? (tn) " \n" (format " ~&")) (assert-equal? (tn) "\n \n \n" (format "\n ~& ~&")) (tn "format ~h") (define help-str "(format [] [...]) - is #t, #f or an output-port - any escape sequence is case insensitive SEQ MNEMONIC DESCRIPTION ~H [Help] output this text ~A [Any] (display arg) for humans ~S [Slashified] (write arg) for parsers ~W [WriteCircular] like ~s but outputs with write/ss ~~ [Tilde] output a tilde ~T [Tab] output a tab character ~% [Newline] output a newline character ~& [Freshline] output a newline if the previous output was not a newline ~D [Decimal] the arg is a number which is output in decimal radix ~X [heXadecimal] the arg is a number which is output in hexdecimal radix ~O [Octal] the arg is a number which is output in octal radix ~B [Binary] the arg is a number which is output in binary radix ~F ~wF [Fixed] the arg is a string or number which has width w and ~w,dF d digits after the decimal ~C [Character] character arg is output by write-char ~_ [Space] a single space character is output ~Y [Yuppify] the list arg is pretty-printed to the output ~? [Indirection] recursive format: next 2 args are format-string and list of arguments ~K [Indirection] same as ~? ") (if (not testing-format+?) (begin (assert-error (tn) (lambda () (format "~h" #t))) (assert-error (tn) (lambda () (format "~h" 0))) (assert-error (tn) (lambda () (format "~h" #\a))) (assert-error (tn) (lambda () (format "~h" "aBc"))) (assert-error (tn) (lambda () (format "~h" '(0 1)))) (assert-error (tn) (lambda () (format "~h" '#(0 1)))) (assert-error (tn) (lambda () (format "~1h"))) (assert-equal? (tn) help-str (format "~h")) (assert-equal? (tn) help-str (format "~H")))) (if (not testing-format+?) (total-report)) uim-1.8.8/sigscheme/test/test-srfi60.scm0000644000175000017500000001643412532333147014776 00000000000000;; Filename : test-srfi60.scm ;; About : unit test for SRFI-60 integers as bits ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (require-extension (srfi 60)) (if (not (provided? "srfi-60")) (test-skip "SRFI-60 is not enabled")) (define tn test-name) ;; ;; Bitwise Operations ;; (tn "logand invalid form") (assert-error (tn) (lambda () (logand #\a))) (assert-error (tn) (lambda () (logand #\a 1))) (assert-error (tn) (lambda () (logand 1 #\a))) (assert-error (tn) (lambda () (logand 1 1 #\a))) (tn "logand") (assert-equal? (tn) -1 (logand)) (assert-equal? (tn) 0 (logand 0)) (assert-equal? (tn) -1 (logand -1)) (assert-equal? (tn) 1 (logand 1)) (assert-equal? (tn) #b11 (logand #b11)) (assert-equal? (tn) #b10 (logand #b1010 #b10)) (assert-equal? (tn) 0 (logand #b1010 #b100)) (assert-equal? (tn) #b1010 (logand #b1010 #b1110)) (assert-equal? (tn) #b1000 (logand #b1010 #b1110 #b101000)) (assert-equal? (tn) 0 (logand #b1010 #b1110 #b101000 0)) (if (and (symbol-bound? 'least-fixnum) (symbol-bound? 'greatest-fixnum)) (begin (assert-equal? (tn) (least-fixnum) (logior 0 (least-fixnum))) (assert-equal? (tn) (greatest-fixnum) (logior 0 (greatest-fixnum))) (assert-equal? (tn) (least-fixnum) (logand -1 (least-fixnum))) (assert-equal? (tn) (greatest-fixnum) (logand -1 (greatest-fixnum))) (assert-equal? (tn) 0 (logand (least-fixnum) (greatest-fixnum))))) (tn "logior invalid form") (assert-error (tn) (lambda () (logior #\a))) (assert-error (tn) (lambda () (logior #\a 1))) (assert-error (tn) (lambda () (logior 1 #\a))) (assert-error (tn) (lambda () (logior 1 1 #\a))) (tn "logior") (assert-equal? (tn) 0 (logior)) (assert-equal? (tn) 0 (logior 0)) (assert-equal? (tn) #b11 (logior #b11)) (assert-equal? (tn) #b1010 (logior #b1010 #b10)) (assert-equal? (tn) #b1110 (logior #b1010 #b100)) (assert-equal? (tn) #b1110 (logior #b1010 #b1110)) (assert-equal? (tn) #b101110 (logior #b1010 #b1110 #b101000)) (assert-equal? (tn) #b101110 (logior #b1010 #b1110 #b101000 0)) (if (and (symbol-bound? 'least-fixnum) (symbol-bound? 'greatest-fixnum)) (begin (assert-equal? (tn) (least-fixnum) (logior 0 (least-fixnum))) (assert-equal? (tn) (greatest-fixnum) (logior 0 (greatest-fixnum))) (assert-equal? (tn) -1 (logior -1 (least-fixnum))) (assert-equal? (tn) -1 (logior -1 (greatest-fixnum))) (assert-equal? (tn) -1 (logior (least-fixnum) (greatest-fixnum))))) (tn "logxor invalid form") (assert-error (tn) (lambda () (logxor #\a))) (assert-error (tn) (lambda () (logxor #\a 1))) (assert-error (tn) (lambda () (logxor 1 #\a))) (assert-error (tn) (lambda () (logxor 1 1 #\a))) (tn "logxor") (assert-equal? (tn) 0 (logxor)) (assert-equal? (tn) 0 (logxor 0)) (assert-equal? (tn) #b11 (logxor #b11)) (assert-equal? (tn) #b1000 (logxor #b1010 #b10)) (assert-equal? (tn) #b1110 (logxor #b1010 #b100)) (assert-equal? (tn) #b0100 (logxor #b1010 #b1110)) (assert-equal? (tn) #b101100 (logxor #b1010 #b1110 #b101000)) (assert-equal? (tn) #b101100 (logxor #b1010 #b1110 #b101000 0)) (if (and (symbol-bound? 'least-fixnum) (symbol-bound? 'greatest-fixnum)) (begin (assert-equal? (tn) (least-fixnum) (logxor 0 (least-fixnum))) (assert-equal? (tn) (greatest-fixnum) (logxor 0 (greatest-fixnum))) (assert-equal? (tn) (greatest-fixnum) (logxor -1 (least-fixnum))) (assert-equal? (tn) (least-fixnum) (logxor -1 (greatest-fixnum))) (assert-equal? (tn) -1 (logxor (least-fixnum) (greatest-fixnum))))) (tn "lognot invalid forms") (assert-error (tn) (lambda () (lognot))) (assert-error (tn) (lambda () (lognot 0 0))) (tn "lognot") (assert-equal? (tn) -1 (lognot 0)) (assert-equal? (tn) 0 (lognot -1)) (assert-equal? (tn) -2 (lognot 1)) (assert-equal? (tn) 1 (lognot -2)) (assert-equal? (tn) (- -1 #b1010) (lognot #b1010)) (assert-equal? (tn) (- -1 #b0101) (lognot #b0101)) (if (and (symbol-bound? 'least-fixnum) (symbol-bound? 'greatest-fixnum)) (begin (assert-equal? (tn) -1 (lognot 0)) (assert-equal? (tn) 0 (lognot -1)) (assert-equal? (tn) (greatest-fixnum) (lognot (least-fixnum))) (assert-equal? (tn) (least-fixnum) (lognot (greatest-fixnum))))) (tn "bitwise-if invalid forms") (assert-error (tn) (lambda () (bitwise-if))) (assert-error (tn) (lambda () (bitwise-if 0))) (assert-error (tn) (lambda () (bitwise-if 0 0))) (tn "bitwise-if") (assert-equal? (tn) 0 (bitwise-if 0 0 0)) (assert-equal? (tn) 0 (bitwise-if 0 1 0)) (assert-equal? (tn) 1 (bitwise-if 0 0 1)) (assert-equal? (tn) 1 (bitwise-if 0 1 1)) (assert-equal? (tn) 0 (bitwise-if 1 0 0)) (assert-equal? (tn) 1 (bitwise-if 1 1 0)) (assert-equal? (tn) 0 (bitwise-if 1 0 1)) (assert-equal? (tn) 1 (bitwise-if 1 1 1)) (assert-equal? (tn) #b0010100 (bitwise-if #b11100 #b1010101 #b0000000)) (assert-equal? (tn) #b0110110 (bitwise-if #b11100 #b1010101 #b0101010)) (assert-equal? (tn) #b0100010 (bitwise-if #b11100 #b0000000 #b0101010)) (tn "logtest") (assert-eq? (tn) #f (logtest 0 0)) (assert-eq? (tn) #f (logtest 1 0)) (assert-eq? (tn) #f (logtest 0 1)) (assert-eq? (tn) #t (logtest 1 1)) (assert-eq? (tn) #t (logtest #b1010 #b10)) (assert-eq? (tn) #f (logtest #b1010 #b100)) (assert-eq? (tn) #t (logtest #b1010 #b1110)) ;; SRFI-33 aliases (assert-eq? "bitwise-and" bitwise-and logand) (assert-eq? "bitwise-ior" bitwise-ior logior) (assert-eq? "bitwise-xor" bitwise-xor logxor) (assert-eq? "bitwise-not" bitwise-not lognot) (assert-eq? "bitwise-merge" bitwise-merge bitwise-if) (assert-eq? "any-bits-set?" any-bits-set? logtest) (total-report) uim-1.8.8/sigscheme/test/test-tail-rec.scm0000644000175000017500000007137412532333147015371 00000000000000;; Filename : test-tail-rec.scm ;; About : unit test for the proper tail recursion ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; FILE HISTORY: ;; 2005-08-07 contributed by YamaKen (yamaken AT bp.iij4u.or.jp) ;; This file is provided to test the proper tail recursion functionality. See ;; "3.5 Proper tail recursion" of R5RS for the accurate specification. ;; ;; This test must be run as follows to take effect. Use runtest-tail-rec.sh. ;; ;; $ (ulimit -s 128 && ulimit -d 2048 && ./sscm test/test-tail-rec.scm || echo 'exploded') ;; ;; And compare the result with another R5RS implementation (gosh). ;; ;; $ (ulimit -s 128 && ulimit -d 2048 && gosh -I. test/test-tail-rec.scm || echo 'exploded') (require-extension (srfi 8 23 34)) (require-extension (unittest)) (define test-eval? #f) (define test-and? #t) ;; #t is required to conform to R5RS (define test-or? #t) ;; #t is required to conform to R5RS (define test-improper-and? #f) ;; R5RS compliant implementation explodes if #t (define test-improper-or? #f) ;; R5RS compliant implementation explodes if #t (define test-with-exception-handler? #f) ;; improper (define test-guard? #f) ;; improper (define KB 1024) (define heap-limit (* 2048 KB)) ;; specify this by ulimit -d (define cell-size 8) ;; minimum cell size (32-bit storage-compact) (define explosive-count (/ heap-limit cell-size)) (define assert-orig assert) (define assert (lambda (test-name err-msg exp) ;; current assert implementation cannot print msg before exp has ;; been evaluated (display err-msg) (assert-orig test-name err-msg exp) (display " ...OK\n"))) (define rec-by-eval (lambda (cnt) (if (zero? cnt) 'succeeded (eval (list 'rec-by-eval (- cnt 1)) (interaction-environment))))) (define rec-by-apply (lambda (cnt) (if (zero? cnt) 'succeeded (apply rec-by-apply (list (- cnt 1)))))) (define rec-by-apply-with-apply (lambda (cnt) (if (zero? cnt) 'succeeded (apply apply (list rec-by-apply-with-apply (list (- cnt 1))))))) (define rec-by-if-consequent (lambda (cnt) (if (not (zero? cnt)) (rec-by-if-consequent (- cnt 1)) 'succeeded))) (define rec-by-if-consequent-with-begin (lambda (cnt) (if (not (zero? cnt)) (begin (+ 1 2) ;; dummy (rec-by-if-consequent-with-begin (- cnt 1))) 'succeeded))) (define rec-by-if-consequent-with-let (lambda (cnt) (if (not (zero? cnt)) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-if-consequent-with-let (- cnt 1))) 'succeeded))) (define rec-by-if-consequent-with-let* (lambda (cnt) (if (not (zero? cnt)) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-if-consequent-with-let* (- cnt 1))) 'succeeded))) (define rec-by-if-consequent-with-letrec (lambda (cnt) (if (not (zero? cnt)) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-if-consequent-with-letrec (- cnt 1))) 'succeeded))) (define rec-by-if-alternate (lambda (cnt) (if (zero? cnt) 'succeeded (rec-by-if-alternate (- cnt 1))))) (define rec-by-if-alternate-with-begin (lambda (cnt) (if (not (zero? cnt)) (begin (+ 1 2) ;; dummy (rec-by-if-alternate-with-begin (- cnt 1))) 'succeeded))) (define rec-by-if-alternate-with-let (lambda (cnt) (if (not (zero? cnt)) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-if-alternate-with-let (- cnt 1))) 'succeeded))) (define rec-by-if-alternate-with-let* (lambda (cnt) (if (not (zero? cnt)) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-if-alternate-with-let* (- cnt 1))) 'succeeded))) (define rec-by-if-alternate-with-letrec (lambda (cnt) (if (not (zero? cnt)) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-if-alternate-with-letrec (- cnt 1))) 'succeeded))) (define rec-by-cond-1st (lambda (cnt) (cond ((positive? cnt) (rec-by-cond-1st (- cnt 1))) ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-1st-with-begin (lambda (cnt) (cond ((positive? cnt) (begin (+ 1 2) ;; dummy (rec-by-cond-1st-with-begin (- cnt 1)))) ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-1st-with-let (lambda (cnt) (cond ((positive? cnt) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-cond-1st-with-let (- cnt 1)))) ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-1st-with-let* (lambda (cnt) (cond ((positive? cnt) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-cond-1st-with-let* (- cnt 1)))) ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-1st-with-letrec (lambda (cnt) (cond ((positive? cnt) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-cond-1st-with-letrec (- cnt 1)))) ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-2nd (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((positive? cnt) (rec-by-cond-2nd (- cnt 1))) ((negative? cnt) 'dummy) (else 'dummy)))) (define rec-by-cond-3rd (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((positive? cnt) (rec-by-cond-3rd (- cnt 1))) (else 'dummy)))) (define rec-by-cond-3rd-with-=> (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((- cnt 1) => rec-by-cond-3rd-with-=>) (else 'dummy)))) (define rec-by-cond-last (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((positive? cnt) (rec-by-cond-last (- cnt 1)))))) (define rec-by-cond-else (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((not (positive? cnt)) 'dummy) (else (rec-by-cond-else (- cnt 1)))))) (define rec-by-cond-else-with-begin (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((not (positive? cnt)) 'dummy) (else (begin (+ 1 2) ;; dummy (rec-by-cond-else (- cnt 1))))))) (define rec-by-cond-else-with-let (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((not (positive? cnt)) 'dummy) (else (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-cond-else (- cnt 1))))))) (define rec-by-cond-else-with-let* (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((not (positive? cnt)) 'dummy) (else (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-cond-else (- cnt 1))))))) (define rec-by-cond-else-with-letrec (lambda (cnt) (cond ((zero? cnt) 'succeeded) ((negative? cnt) 'dummy) ((not (positive? cnt)) 'dummy) (else (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-cond-else (- cnt 1))))))) (define rec-by-case-1st (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((1) (rec-by-case-1st (- cnt 1))) ((0) 'succeeded) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-1st-with-begin (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((1) (begin (+ 1 2) ;; dummy (rec-by-case-1st-with-begin (- cnt 1)))) ((0) 'succeeded) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-1st-with-let (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((1) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-case-1st-with-let (- cnt 1)))) ((0) 'succeeded) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-1st-with-let* (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((1) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-case-1st-with-let* (- cnt 1)))) ((0) 'succeeded) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-1st-with-letrec (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((1) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-case-1st-with-letrec (- cnt 1)))) ((0) 'succeeded) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-2nd (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((1) (rec-by-case-2nd (- cnt 1))) ((-1) 'dummy) (else 'dummy)))) (define rec-by-case-3rd (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((1) (rec-by-case-3rd (- cnt 1))) (else 'dummy)))) (define rec-by-case-last (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((1) (rec-by-case-last (- cnt 1)))))) (define rec-by-case-else (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((2) 'dummy) (else (rec-by-case-else (- cnt 1)))))) (define rec-by-case-else-with-begin (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((2) 'dummy) (else (begin (+ 1 2) ;; dummy (rec-by-case-else (- cnt 1))))))) (define rec-by-case-else-with-let (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((2) 'dummy) (else (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-case-else (- cnt 1))))))) (define rec-by-case-else-with-let* (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((2) 'dummy) (else (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-case-else (- cnt 1))))))) (define rec-by-case-else-with-letrec (lambda (cnt) (case (if (positive? cnt) 1 cnt) ((0) 'succeeded) ((-1) 'dummy) ((2) 'dummy) (else (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-case-else (- cnt 1))))))) (define rec-by-and-tail (lambda (cnt) (and (not (zero? cnt)) (rec-by-and-tail (- cnt 1))))) (define rec-by-and-tail-with-begin (lambda (cnt) (and (not (zero? cnt)) (begin (+ 1 2) ;; dummy (rec-by-and-tail-with-begin (- cnt 1)))))) (define rec-by-and-tail-with-let (lambda (cnt) (and (not (zero? cnt)) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-and-tail-with-let (- cnt 1)))))) (define rec-by-and-tail-with-let* (lambda (cnt) (and (not (zero? cnt)) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-and-tail-with-let* (- cnt 1)))))) (define rec-by-and-tail-with-letrec (lambda (cnt) (and (not (zero? cnt)) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-and-tail-with-letrec (- cnt 1)))))) (define improper-rec-by-and-tail (lambda (cnt) (and (not (zero? cnt)) (improper-rec-by-and-tail (- cnt 1))) 'succeeded)) (define rec-by-or-tail (lambda (cnt) (or (zero? cnt) (rec-by-or-tail (- cnt 1))))) (define rec-by-or-tail-with-begin (lambda (cnt) (or (zero? cnt) (begin (+ 1 2) ;; dummy (rec-by-or-tail-with-begin (- cnt 1)))))) (define rec-by-or-tail-with-let (lambda (cnt) (or (zero? cnt) (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-by-or-tail-with-let (- cnt 1)))))) (define rec-by-or-tail-with-let* (lambda (cnt) (or (zero? cnt) (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-by-or-tail-with-let* (- cnt 1)))))) (define rec-by-or-tail-with-letrec (lambda (cnt) (or (zero? cnt) (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-by-or-tail-with-letrec (- cnt 1)))))) (define improper-rec-by-or-tail (lambda (cnt) (or (zero? cnt) (improper-rec-by-or-tail (- cnt 1))) 'succeeded)) (define rec-even? (lambda (n) (if (zero? n) #t (rec-odd? (- n 1))))) (define rec-odd? (lambda (n) (if (zero? n) #f (rec-even? (- n 1))))) (define rec-even-with-begin? (lambda (n) (if (zero? n) #t (begin (+ 1 2) ;; dummy (rec-odd-with-begin? (- n 1)))))) (define rec-odd-with-begin? (lambda (n) (if (zero? n) #f (begin (+ 1 2) ;; dummy (rec-even-with-begin? (- n 1)))))) (define rec-even-with-let? (lambda (n) (if (zero? n) #t (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-odd-with-let? (- n 1)))))) (define rec-odd-with-let? (lambda (n) (if (zero? n) #f (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (rec-even-with-let? (- n 1)))))) (define rec-even-with-let*? (lambda (n) (if (zero? n) #t (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-odd-with-let*? (- n 1)))))) (define rec-odd-with-let*? (lambda (n) (if (zero? n) #f (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (rec-even-with-let*? (- n 1)))))) (define rec-even-with-letrec? (lambda (n) (if (zero? n) #t (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-odd-with-letrec? (- n 1)))))) (define rec-odd-with-letrec? (lambda (n) (if (zero? n) #f (letrec ((dummy (lambda () dummy2)) (dummy2 (lambda () dummy))) (rec-even-with-letrec? (- n 1)))))) (define rec-continuation (lambda (n) (if (zero? n) 'succeeded (call-with-current-continuation (lambda (cont) (rec-continuation (- n 1))))))) (define rec-call-with-values (lambda (n) (if (zero? n) 'succeeded (call-with-values (lambda () (values 2 3 n)) (lambda (dummy1 dummy2 n) (rec-call-with-values (- n 1))))))) (define rec-call-with-values-2 (lambda (n) (letrec ((producer (lambda () (if (zero? n) (values values (lambda () 'succeeded)) (begin (set! n (- n 1)) (values producer call-with-values)))))) (call-with-values producer call-with-values)))) (define rec-with-exception-handler (lambda (n) (if (zero? n) 'succeeded (with-exception-handler (lambda (x) (error "handler called")) (rec-with-exception-handler (- n 1)))))) (define rec-guard (lambda (n) (if (zero? n) 'succeeded (guard (e (#f #f)) (rec-guard (- n 1)))))) (define rec-receive (lambda (n) (if (zero? n) 'succeeded (receive (dummy1 dummy2 n) (values 2 3 n) (rec-receive (- n 1)))))) (define rec-proper-infinite (lambda (cnt) (rec-proper-infinite (+ cnt 1)))) (define rec-improper-infinite (lambda (cnt) (if (zero? cnt) (error "explicit explosion of improper infinite tail recursion failed") (rec-improper-infinite (- cnt 1))) 'dummy)) ;; eval ;; SigScheme, Guile 1.6.7 and Gauche 0.8.6 fail. Should we make this test ;; passed? -- YamaKen 2006-09-25 (if test-eval? (assert-equal? "proper tail recursion by eval" 'succeeded (rec-by-eval explosive-count))) ;; apply (assert-equal? "proper tail recursion by apply" 'succeeded (rec-by-apply explosive-count)) (assert-equal? "proper tail recursion by apply with apply" 'succeeded (rec-by-apply-with-apply explosive-count)) ;; if (assert-equal? "proper tail recursion by if-consequent" 'succeeded (rec-by-if-consequent explosive-count)) (assert-equal? "proper tail recursion by if-consequent with begin" 'succeeded (rec-by-if-consequent-with-begin explosive-count)) (assert-equal? "proper tail recursion by if-consequent with let" 'succeeded (rec-by-if-consequent-with-let explosive-count)) (assert-equal? "proper tail recursion by if-consequent with let*" 'succeeded (rec-by-if-consequent-with-let* explosive-count)) (assert-equal? "proper tail recursion by if-consequent with letrec" 'succeeded (rec-by-if-consequent-with-letrec explosive-count)) (assert-equal? "proper tail recursion by if-alternate" 'succeeded (rec-by-if-alternate explosive-count)) (assert-equal? "proper tail recursion by if-alternate with begin" 'succeeded (rec-by-if-alternate-with-begin explosive-count)) (assert-equal? "proper tail recursion by if-alternate with let" 'succeeded (rec-by-if-alternate-with-let explosive-count)) (assert-equal? "proper tail recursion by if-alternate with let*" 'succeeded (rec-by-if-alternate-with-let* explosive-count)) (assert-equal? "proper tail recursion by if-alternate with letrec" 'succeeded (rec-by-if-alternate-with-letrec explosive-count)) ;; cond (assert-equal? "proper tail recursion by 1st clause of cond" 'succeeded (rec-by-cond-1st explosive-count)) (assert-equal? "proper tail recursion by 1st clause of cond with begin" 'succeeded (rec-by-cond-1st-with-begin explosive-count)) (assert-equal? "proper tail recursion by 1st clause of cond with let" 'succeeded (rec-by-cond-1st-with-let explosive-count)) (assert-equal? "proper tail recursion by 1st clause of cond with let*" 'succeeded (rec-by-cond-1st-with-let* explosive-count)) (assert-equal? "proper tail recursion by 1st clause of cond with letrec" 'succeeded (rec-by-cond-1st-with-letrec explosive-count)) (assert-equal? "proper tail recursion by 2nd clause of cond" 'succeeded (rec-by-cond-2nd explosive-count)) (assert-equal? "proper tail recursion by 3rd clause of cond" 'succeeded (rec-by-cond-3rd explosive-count)) (assert-equal? "proper tail recursion by 3rd clause of cond with => expression" 'succeeded (rec-by-cond-3rd-with-=> explosive-count)) (assert-equal? "proper tail recursion by last clause of cond" 'succeeded (rec-by-cond-last explosive-count)) (assert-equal? "proper tail recursion by cond-else" 'succeeded (rec-by-cond-else explosive-count)) (assert-equal? "proper tail recursion by cond-else with begin" 'succeeded (rec-by-cond-else-with-begin explosive-count)) (assert-equal? "proper tail recursion by cond-else with let" 'succeeded (rec-by-cond-else-with-let explosive-count)) (assert-equal? "proper tail recursion by cond-else with let*" 'succeeded (rec-by-cond-else-with-let* explosive-count)) (assert-equal? "proper tail recursion by cond-else with letrec" 'succeeded (rec-by-cond-else-with-letrec explosive-count)) ;; case (assert-equal? "proper tail recursion by 1st clause of case" 'succeeded (rec-by-case-1st explosive-count)) (assert-equal? "proper tail recursion by 1st clause of case with begin" 'succeeded (rec-by-case-1st-with-begin explosive-count)) (assert-equal? "proper tail recursion by 1st clause of case with let" 'succeeded (rec-by-case-1st-with-let explosive-count)) (assert-equal? "proper tail recursion by 1st clause of case with let*" 'succeeded (rec-by-case-1st-with-let* explosive-count)) (assert-equal? "proper tail recursion by 1st clause of case with letrec" 'succeeded (rec-by-case-1st-with-letrec explosive-count)) (assert-equal? "proper tail recursion by 2nd clause of case" 'succeeded (rec-by-case-2nd explosive-count)) (assert-equal? "proper tail recursion by 3rd clause of case" 'succeeded (rec-by-case-3rd explosive-count)) (assert-equal? "proper tail recursion by last clause of case" 'succeeded (rec-by-case-last explosive-count)) (assert-equal? "proper tail recursion by case-else" 'succeeded (rec-by-case-else explosive-count)) (assert-equal? "proper tail recursion by case-else with begin" 'succeeded (rec-by-case-else-with-begin explosive-count)) (assert-equal? "proper tail recursion by case-else with let" 'succeeded (rec-by-case-else-with-let explosive-count)) (assert-equal? "proper tail recursion by case-else with let*" 'succeeded (rec-by-case-else-with-let* explosive-count)) (assert-equal? "proper tail recursion by case-else with letrec" 'succeeded (rec-by-case-else-with-letrec explosive-count)) ;; and (if test-and? (begin (assert-equal? "proper tail recursion by and-tail" 'succeeded (or (rec-by-and-tail explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by and-tail with begin" 'succeeded (or (rec-by-and-tail-with-begin explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by and-tail with let" 'succeeded (or (rec-by-and-tail-with-let explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by and-tail with let*" 'succeeded (or (rec-by-and-tail-with-let* explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by and-tail with letrec" 'succeeded (or (rec-by-and-tail-with-letrec explosive-count) 'succeeded)))) ;; improper and: intentionally explodes (if test-improper-and? (assert-equal? "improper tail recursion by and-tail" 'succeeded (improper-rec-by-and-tail explosive-count))) ;; or (if test-or? (begin (assert-equal? "proper tail recursion by or-tail" 'succeeded (and (rec-by-or-tail explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by or-tail with begin" 'succeeded (and (rec-by-or-tail-with-begin explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by or-tail with let" 'succeeded (and (rec-by-or-tail-with-let explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by or-tail with let*" 'succeeded (and (rec-by-or-tail-with-let* explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by or-tail with letrec" 'succeeded (and (rec-by-or-tail-with-letrec explosive-count) 'succeeded)))) ;; improper or: intentionally explodes (if test-improper-or? (assert-equal? "improper tail recursion by or-tail" 'succeeded (improper-rec-by-or-tail explosive-count))) ;; do (assert-equal? "iteration by do" 'succeeded (do ((cnt explosive-count (- cnt 1)) (dummy 0 (+ dummy 1))) ((zero? cnt) 'succeeded) (+ cnt dummy))) (assert-equal? "proper tail recursion with do" 'succeeded (let loop ((loop-cnt explosive-count)) (if (zero? loop-cnt) 'succeeded (do ((cnt 3 (- cnt 1)) (dummy 0 (+ dummy 1))) ((zero? cnt) (loop (- loop-cnt 1))) (+ cnt dummy))))) ;; flip-flop procs (assert-equal? "proper tail recursion by flip-flop procs" 'succeeded (and (rec-even? explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by flip-flop procs with begin" 'succeeded (and (rec-even-with-begin? explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by flip-flop procs with let" 'succeeded (and (rec-even-with-let? explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by flip-flop procs with let*" 'succeeded (and (rec-even-with-let*? explosive-count) 'succeeded)) (assert-equal? "proper tail recursion by flip-flop procs with letrec" 'succeeded (and (rec-even-with-letrec? explosive-count) 'succeeded)) ;; flip-flop procs in letrec (assert-equal? "proper tail recursion by flip-flop procs defined by letrec" 'succeeded (letrec ((my-even? (lambda (n) (if (zero? n) #t (my-odd? (- n 1))))) (my-odd? (lambda (n) (if (zero? n) #f (my-even? (- n 1)))))) (and (my-even? explosive-count) 'succeeded))) ;; named let (assert-equal? "proper tail recursion by named let" 'succeeded (let loop ((cnt explosive-count)) (if (zero? cnt) 'succeeded (loop (- cnt 1))))) (assert-equal? "proper tail recursion by named let with begin" 'succeeded (let loop ((cnt explosive-count)) (if (zero? cnt) 'succeeded (begin (+ 1 2) ;; dummy (loop (- cnt 1)))))) (assert-equal? "proper tail recursion by named let with let" 'succeeded (let loop ((cnt explosive-count)) (if (zero? cnt) 'succeeded (let ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (loop (- cnt 1)))))) (assert-equal? "proper tail recursion by named let with let*" 'succeeded (let loop ((cnt explosive-count)) (if (zero? cnt) 'succeeded (let* ((dummy (+ 1 2)) (dummy2 (+ dummy 3))) (loop (- cnt 1)))))) (assert-equal? "proper tail recursion by named let with letrec" 'succeeded (let loop ((cnt explosive-count)) (if (zero? cnt) 'succeeded (letrec ((dummy (+ 1 2)) (dummy2 (+ 3 4))) (loop (- cnt 1)))))) ;; call/cc ;; Current SigScheme implementation cannot run this test as proper tail ;; recursion. The stack grows. (if (not (and (provided? "sigscheme") (provided? "nested-continuation-only"))) (assert-equal? "proper tail recursion by call/cc" 'succeeded (rec-continuation explosive-count))) ;; call-with-values (assert-equal? "proper tail recursion by call-with-values #1" 'succeeded (rec-call-with-values explosive-count)) ;; call-with-values (assert-equal? "proper tail recursion by call-with-values #2" 'succeeded (rec-call-with-values-2 explosive-count)) ;; with-exception-handler (not properly recursive because of underlying ;; dynamic-wind) (if test-with-exception-handler? (assert-equal? "improper tail recursion by with-exception-handler" 'succeeded (rec-with-exception-handler explosive-count))) ;; guard (not properly recursive because of underlying dynamic-wind) (if test-guard? (assert-equal? "improper tail recursion by guard" 'succeeded (rec-guard explosive-count))) ;; receive (assert-equal? "proper tail recursion by receive" 'succeeded (rec-receive explosive-count)) ;; This test is succeeded if reported as follows. ;; ;; OK: 1 tests, ?? assertions, ?? successes, 0 failures, 0 errors ;; All normal tests have been passed. ;; ;; All tests finished successfully only if the message "All normal tests have been passed" and subsequent segmentation fault message are printed above. (total-report) (display "All normal tests have been passed.") (newline) ;; test whether the explosive-count is actually explosive (assert-equal? "improper infinite tail recursion" 'succeeded (rec-improper-infinite explosive-count)) ;; test failed if reached here uim-1.8.8/sigscheme/test/test-formatplus.scm0000644000175000017500000002400712532333147016054 00000000000000;; Filename : test-formatplus.scm ;; About : unit test for SigScheme-specific procedure format+ ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; All tests in this file are passed against r3170 (new repository) (require-extension (unittest)) (require-extension (srfi 48)) (if (not (symbol-bound? 'format+)) (test-skip "format+ is not enabled")) ;; test SRFI-48 compatible part of format+ (define format format+) (load "./test/test-srfi48.scm") (newline) (define tn test-name) (tn "format+ ~d") (assert-error (tn) (lambda () (format+ "0128d" 1))) (assert-error (tn) (lambda () (format+ "0128,1d" 1))) (assert-error (tn) (lambda () (format+ "1,0128d" 1))) (assert-error (tn) (lambda () (format+ "01024d" 1))) (assert-error (tn) (lambda () (format+ "01024,1d" 1))) (assert-error (tn) (lambda () (format+ "1,01024d" 1))) (assert-equal? (tn) "-100" (format+ "~0d" -100)) (assert-equal? (tn) "-10" (format+ "~0d" -10)) (assert-equal? (tn) "-1" (format+ "~0d" -1)) (assert-equal? (tn) "0" (format+ "~0d" 0)) (assert-equal? (tn) "1" (format+ "~0d" 1)) (assert-equal? (tn) "10" (format+ "~0d" 10)) (assert-equal? (tn) "100" (format+ "~0d" 100)) (assert-equal? (tn) "-100" (format+ "~03d" -100)) (assert-equal? (tn) "-10" (format+ "~03d" -10)) (assert-equal? (tn) "-01" (format+ "~03d" -1)) (assert-equal? (tn) "000" (format+ "~03d" 0)) (assert-equal? (tn) "001" (format+ "~03d" 1)) (assert-equal? (tn) "010" (format+ "~03d" 10)) (assert-equal? (tn) "100" (format+ "~03d" 100)) (assert-equal? (tn) " 123" (format+ "~127d" 123)) (assert-equal? (tn) "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000123" (format+ "~0127d" 123)) (tn "format+ ~x") (assert-error (tn) (lambda () (format+ "0128x" 1))) (assert-error (tn) (lambda () (format+ "0128,1x" 1))) (assert-error (tn) (lambda () (format+ "1,0128x" 1))) (assert-error (tn) (lambda () (format+ "01024x" 1))) (assert-error (tn) (lambda () (format+ "01024,1x" 1))) (assert-error (tn) (lambda () (format+ "1,01024x" 1))) (assert-equal? (tn) "-64" (format+ "~0x" -100)) (assert-equal? (tn) "-a" (format+ "~0x" -10)) (assert-equal? (tn) "-1" (format+ "~0x" -1)) (assert-equal? (tn) "0" (format+ "~0x" 0)) (assert-equal? (tn) "1" (format+ "~0x" 1)) (assert-equal? (tn) "a" (format+ "~0x" 10)) (assert-equal? (tn) "64" (format+ "~0x" 100)) (assert-equal? (tn) "-64" (format+ "~03x" -100)) (assert-equal? (tn) "-0a" (format+ "~03x" -10)) (assert-equal? (tn) "-01" (format+ "~03x" -1)) (assert-equal? (tn) "000" (format+ "~03x" 0)) (assert-equal? (tn) "001" (format+ "~03x" 1)) (assert-equal? (tn) "00a" (format+ "~03x" 10)) (assert-equal? (tn) "064" (format+ "~03x" 100)) (assert-equal? (tn) " 1ac" (format+ "~127x" #x1ac)) (assert-equal? (tn) "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001ac" (format+ "~0127x" #x1ac)) (tn "format+ ~o") (assert-error (tn) (lambda () (format+ "0128o" 1))) (assert-error (tn) (lambda () (format+ "0128,1o" 1))) (assert-error (tn) (lambda () (format+ "1,0128o" 1))) (assert-error (tn) (lambda () (format+ "01024o" 1))) (assert-error (tn) (lambda () (format+ "01024,1o" 1))) (assert-error (tn) (lambda () (format+ "1,01024o" 1))) (assert-equal? (tn) "-144" (format+ "~0o" -100)) (assert-equal? (tn) "-12" (format+ "~0o" -10)) (assert-equal? (tn) "-1" (format+ "~0o" -1)) (assert-equal? (tn) "0" (format+ "~0o" 0)) (assert-equal? (tn) "1" (format+ "~0o" 1)) (assert-equal? (tn) "12" (format+ "~0o" 10)) (assert-equal? (tn) "144" (format+ "~0o" 100)) (assert-equal? (tn) "-144" (format+ "~03o" -100)) (assert-equal? (tn) "-12" (format+ "~03o" -10)) (assert-equal? (tn) "-01" (format+ "~03o" -1)) (assert-equal? (tn) "000" (format+ "~03o" 0)) (assert-equal? (tn) "001" (format+ "~03o" 1)) (assert-equal? (tn) "012" (format+ "~03o" 10)) (assert-equal? (tn) "144" (format+ "~03o" 100)) (assert-equal? (tn) " 123" (format+ "~127o" #o123)) (assert-equal? (tn) "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000123" (format+ "~0127o" #o123)) (tn "format+ ~b") (assert-error (tn) (lambda () (format+ "0128b" 1))) (assert-error (tn) (lambda () (format+ "0128,1b" 1))) (assert-error (tn) (lambda () (format+ "1,0128b" 1))) (assert-error (tn) (lambda () (format+ "01024b" 1))) (assert-error (tn) (lambda () (format+ "01024,1b" 1))) (assert-error (tn) (lambda () (format+ "1,01024b" 1))) (assert-equal? (tn) "-1100100" (format+ "~0b" -100)) (assert-equal? (tn) "-1010" (format+ "~0b" -10)) (assert-equal? (tn) "-1" (format+ "~0b" -1)) (assert-equal? (tn) "0" (format+ "~0b" 0)) (assert-equal? (tn) "1" (format+ "~0b" 1)) (assert-equal? (tn) "1010" (format+ "~0b" 10)) (assert-equal? (tn) "1100100" (format+ "~0b" 100)) (assert-equal? (tn) "-1100100" (format+ "~05b" -100)) (assert-equal? (tn) "-1010" (format+ "~05b" -10)) (assert-equal? (tn) "-0001" (format+ "~05b" -1)) (assert-equal? (tn) "00000" (format+ "~05b" 0)) (assert-equal? (tn) "00001" (format+ "~05b" 1)) (assert-equal? (tn) "01010" (format+ "~05b" 10)) (assert-equal? (tn) "1100100" (format+ "~05b" 100)) (assert-equal? (tn) " 101" (format+ "~127b" #b101)) (assert-equal? (tn) "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000101" (format+ "~0127b" #b101)) (tn "format+ ~f (number)") (assert-equal? (tn) "-100" (format+ "~0f" -100)) (assert-equal? (tn) "-10" (format+ "~0f" -10)) (assert-equal? (tn) "-1" (format+ "~0f" -1)) (assert-equal? (tn) "0" (format+ "~0f" 0)) (assert-equal? (tn) "1" (format+ "~0f" 1)) (assert-equal? (tn) "10" (format+ "~0f" 10)) (assert-equal? (tn) "100" (format+ "~0f" 100)) (assert-equal? (tn) "-100" (format "~03f" -100)) (assert-equal? (tn) "-10" (format "~03f" -10)) (assert-equal? (tn) "-01" (format "~03f" -1)) (assert-equal? (tn) "000" (format "~03f" 0)) (assert-equal? (tn) "001" (format "~03f" 1)) (assert-equal? (tn) "010" (format "~03f" 10)) (assert-equal? (tn) "100" (format "~03f" 100)) (if (symbol-bound? 'exact->inexact) (begin (assert-equal? (tn) "-100.00" (format+ "~06,02f" -100)) (assert-equal? (tn) "-10.00" (format+ "~06,02f" -10)) (assert-equal? (tn) "-01.00" (format+ "~06,02f" -1)) (assert-equal? (tn) "000.00" (format+ "~06,02f" 0)) (assert-equal? (tn) "001.00" (format+ "~06,02f" 1)) (assert-equal? (tn) "010.00" (format+ "~06,02f" 10)) (assert-equal? (tn) "100.00" (format+ "~06,02f" 100)))) (assert-equal? (tn) "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000123" (format+ "~0127f" 123)) (tn "format ~h") (define help-str "(format+ [] [...]) - is #t, #f or an output-port - any escape sequence is case insensitive The format+ procedure is a SigScheme-specific superset of SRFI-48. Following directives accept optional width w and d digits after the decimal, and w accepts leading zero as zero-digit-padding specifier. All other rules are same as SRFI-48. See also the help message for SRFI-48. SEQ MNEMONIC DESCRIPTION ~[w[,d]]D [Decimal] the arg is a number output in decimal radix ~[w[,d]]X [heXadecimal] the arg is a number output in hexdecimal radix ~[w[,d]]O [Octal] the arg is a number output in octal radix ~[w[,d]]B [Binary] the arg is a number output in binary radix ~[w[,d]]F [Fixed] the arg is a string or number ") (assert-equal? (tn) help-str (format "~h")) (assert-equal? (tn) help-str (format "~H")) (total-report) uim-1.8.8/sigscheme/test/test-eqv.scm0000644000175000017500000006776312532333147014473 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; -*- buffer-file-coding-system: utf-8 -*- ;; Filename : test-eqv.scm ;; About : unit tests for eqv? ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (define case-insensitive-symbol? #f) (tn "eqv? invalid form") (assert-error (tn) (lambda () (eqv?))) (assert-error (tn) (lambda () (eqv? #f))) (assert-error (tn) (lambda () (eqv? #f #f #f))) (tn "eqv? different types") (assert-eq? (tn) #f (eqv? 1 #\1)) (assert-eq? (tn) #f (eqv? #\1 "1")) (assert-eq? (tn) #f (eqv? #\1 '("1"))) (assert-eq? (tn) #f (eqv? '#("1") '("1"))) (tn "eqv? boolean") (assert-eq? (tn) #t (eqv? #f #f)) (assert-eq? (tn) #f (eqv? #f #t)) (assert-eq? (tn) #f (eqv? #t #f)) (assert-eq? (tn) #t (eqv? #t #t)) (tn "eqv? null") (assert-eq? (tn) #t (eqv? '() '())) (if (and (provided? "sigscheme") (provided? "siod-bugs")) (begin (assert-eq? (tn) #t (eqv? #f '())) (assert-eq? (tn) #t (eqv? '() #f))) (begin (assert-eq? (tn) #f (eqv? #f '())) (assert-eq? (tn) #f (eqv? '() #f)))) (if (symbol-bound? 'vector?) (begin (assert-eq? (tn) #f (eqv? '() '#())) (assert-eq? (tn) #f (eqv? '#() '())))) (tn "eqv? #") (if (provided? "sigscheme") (begin (assert-eq? (tn) #t (eqv? (eof) (eof))) (assert-eq? (tn) #f (eqv? (eof) (undef))) (assert-eq? (tn) #f (eqv? (undef) (eof))) (assert-eq? (tn) #f (eqv? '() (eof))) (assert-eq? (tn) #f (eqv? (eof) '())) (assert-eq? (tn) #f (eqv? #f (eof))) (assert-eq? (tn) #f (eqv? (eof) #f)))) (tn "eqv? #") (if (provided? "sigscheme") (begin (assert-eq? (tn) #t (eqv? (undef) (undef))) (assert-eq? (tn) #f (eqv? (eof) (undef))) (assert-eq? (tn) #f (eqv? (undef) (eof))) (assert-eq? (tn) #f (eqv? '() (undef))) (assert-eq? (tn) #f (eqv? (undef) '())) (assert-eq? (tn) #f (eqv? #f (undef))) (assert-eq? (tn) #f (eqv? (undef) #f)))) (tn "eqv? integer") (assert-eq? (tn) #t (eqv? 0 0)) (assert-eq? (tn) #t (eqv? 1 1)) (assert-eq? (tn) #t (eqv? 3 3)) (assert-eq? (tn) #t (eqv? -1 -1)) (assert-eq? (tn) #t (eqv? -3 -3)) (assert-eq? (tn) #f (eqv? 0 1)) (assert-eq? (tn) #f (eqv? 1 0)) (assert-eq? (tn) #f (eqv? 1 3)) (assert-eq? (tn) #f (eqv? 3 1)) (assert-eq? (tn) #f (eqv? -1 1)) (assert-eq? (tn) #f (eqv? 1 -1)) (assert-eq? (tn) #f (eqv? -3 3)) (assert-eq? (tn) #f (eqv? 3 -3)) (assert-eq? (tn) #f (eqv? -1 -3)) (assert-eq? (tn) #f (eqv? -3 -1)) (tn "eqv? symbol") (assert-eq? (tn) #t (eqv? 'symbol 'symbol)) (assert-eq? (tn) #f (eqv? 'symbol1 'symbol2)) (if (and (provided? "sigscheme") (provided? "strict-r5rs") case-insensitive-symbol?) (begin (assert-eq? (tn) #t (eqv? 'symbol 'SYMBOL)) (assert-eq? (tn) #t (eqv? 'SYMBOL 'symbol)) (assert-eq? (tn) #t (eqv? 'symbol 'Symbol)) (assert-eq? (tn) #t (eqv? 'Symbol 'symbol)) (assert-eq? (tn) #t (eqv? 'symbol 'syMBoL)) (assert-eq? (tn) #t (eqv? 'syMBoL 'symbol))) (begin (assert-eq? (tn) #f (eqv? 'symbol 'SYMBOL)) (assert-eq? (tn) #f (eqv? 'SYMBOL 'symbol)) (assert-eq? (tn) #f (eqv? 'symbol 'Symbol)) (assert-eq? (tn) #f (eqv? 'Symbol 'symbol)) (assert-eq? (tn) #f (eqv? 'symbol 'syMBoL)) (assert-eq? (tn) #f (eqv? 'syMBoL 'symbol)))) (tn "eqv? singlebyte char") (assert-eq? (tn) #t (eqv? #\a #\a)) (assert-eq? (tn) #f (eqv? #\a #\b)) (assert-eq? (tn) #f (eqv? #\b #\a)) (assert-eq? (tn) #t (eqv? #\b #\b)) (let ((c1 #\a) (c2 #\b)) (assert-eq? (tn) #t (eqv? c1 c1)) (assert-eq? (tn) #t (eqv? c2 c2))) (tn "eqv? multibyte char") (assert-eq? (tn) #t (eqv? #\ã‚ #\ã‚)) (assert-eq? (tn) #f (eqv? #\ã‚ #\ã„)) (assert-eq? (tn) #f (eqv? #\ã„ #\ã‚)) (assert-eq? (tn) #t (eqv? #\ã„ #\ã„)) (let ((c1 #\ã‚) (c2 #\ã„)) (assert-eq? (tn) #t (eqv? c1 c1)) (assert-eq? (tn) #t (eqv? c2 c2))) (tn "eqv? singlebyte string") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? "" "")) (assert-eq? (tn) #f (eqv? "a" "a")) (assert-eq? (tn) #f (eqv? "b" "b")) (assert-eq? (tn) #f (eqv? "aBc12!" "aBc12!")))) (let ((s1 "") (s2 "a") (s3 "b") (s4 "aBc12!")) (assert-eq? (tn) #t (eqv? s1 s1)) (assert-eq? (tn) #t (eqv? s2 s2)) (assert-eq? (tn) #t (eqv? s3 s3)) (assert-eq? (tn) #t (eqv? s4 s4))) (assert-eq? (tn) #f (eqv? "" "a")) (assert-eq? (tn) #f (eqv? "a" "")) (assert-eq? (tn) #f (eqv? "a" "b")) (assert-eq? (tn) #f (eqv? "b" "a")) (assert-eq? (tn) #f (eqv? "a" "A")) (assert-eq? (tn) #f (eqv? "A" "a")) (assert-eq? (tn) #f (eqv? "aBc123!" "aBc12!")) (assert-eq? (tn) #f (eqv? "aBc12!" "aBc123!")) (tn "eqv? multibyte string") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? "ã‚" "ã‚")) (assert-eq? (tn) #f (eqv? "ã„" "ã„")) (assert-eq? (tn) #f (eqv? "ã‚0イã†12!" "ã‚0イã†12!")))) (let ((s1 "ã‚") (s2 "ã„") (s3 "ã‚0イã†12!")) (assert-eq? (tn) #t (eqv? s1 s1)) (assert-eq? (tn) #t (eqv? s2 s2)) (assert-eq? (tn) #t (eqv? s3 s3))) (assert-eq? (tn) #f (eqv? "" "ã‚")) (assert-eq? (tn) #f (eqv? "ã‚" "")) (assert-eq? (tn) #f (eqv? "ã‚" "ã„")) (assert-eq? (tn) #f (eqv? "ã„" "ã‚")) (assert-eq? (tn) #f (eqv? "ã‚" "ã‚¢")) (assert-eq? (tn) #f (eqv? "ã‚¢" "ã‚")) (assert-eq? (tn) #f (eqv? "ã‚0イã†ã‡12!" "ã‚0イã†12!")) (assert-eq? (tn) #f (eqv? "ã‚0イã†12!" "ã‚0イã†ã‡12!")) (tn "eqv? procedure") (assert-eq? (tn) #t (eqv? + +)) (assert-eq? (tn) #f (eqv? + -)) (assert-eq? (tn) #f (eqv? - +)) (assert-eq? (tn) #t (eqv? - -)) (let ((plus +)) (assert-eq? (tn) #t (eqv? + plus)) (assert-eq? (tn) #t (eqv? plus +)) (assert-eq? (tn) #t (eqv? plus plus))) (tn "eqv? syntax") (assert-error (tn) (lambda () (eqv? if if))) (assert-error (tn) (lambda () (eqv? if set!))) (assert-error (tn) (lambda () (eqv? set! if))) (assert-error (tn) (lambda () (eqv? set! set!))) ;; (define syntax if) is an invalid form (tn "eqv? macro") (if (symbol-bound? 'let-syntax) (let-syntax ((macro1 (syntax-rules () ((_) 'macro1-expanded))) (macro2 (syntax-rules () ((_) 'macro2-expanded)))) ;; syntactic keyword as value (assert-error (tn) (lambda () (eqv? macro1 macro1))) (assert-error (tn) (lambda () (eqv? macro2 macro1))) (assert-error (tn) (lambda () (eqv? macro1 macro2))) (assert-error (tn) (lambda () (eqv? macro2 macro2))))) (tn "eqv? closure") (let ((closure (lambda () #t))) (assert-eq? (tn) #t (eqv? closure closure)) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? closure (lambda () #t))) (assert-eq? (tn) #f (eqv? (lambda () #t) closure)) (assert-eq? (tn) #f (eqv? (lambda () #t) (lambda () #t)))))) (tn "eqv? stateful closure") (let ((stateful (lambda () (let ((state 0)) (lambda () (set! state (+ state 1)) state))))) (assert-eq? (tn) #t (eqv? stateful stateful)) (assert-eq? (tn) #f (eqv? (stateful) (stateful)))) (let ((may-be-optimized-out (lambda () (let ((state 0)) (lambda () (set! state (+ state 1)) 0))))) (assert-eq? (tn) #t (eqv? may-be-optimized-out may-be-optimized-out)) (if (provided? "sigscheme") (assert-eq? (tn) #f (eqv? (may-be-optimized-out) (may-be-optimized-out))))) (letrec ((may-be-unified1 (lambda () (if (eqv? may-be-unified1 may-be-unified2) 'optimized-out 'not-unified1))) (may-be-unified2 (lambda () (if (eqv? may-be-unified1 may-be-unified2) 'optimized-out 'not-unified2)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? may-be-unified1 may-be-unified2)) (assert-eq? (tn) #f (eqv? (may-be-unified1) (may-be-unified2)))) (begin ;; other implementations may pass this ;;(assert-eq? (tn) #t (eqv? may-be-unified1 may-be-unified2)) ;;(assert-eq? (tn) #t (eqv? (may-be-unified1) (may-be-unified2))) ))) (tn "eqv? continuation") (call-with-current-continuation (lambda (k1) (call-with-current-continuation (lambda (k2) (assert-eq? (tn) #t (eqv? k1 k1)) (assert-eq? (tn) #f (eqv? k1 k2)) (assert-eq? (tn) #f (eqv? k2 k1)) (assert-eq? (tn) #t (eqv? k2 k2)) (let ((cont k1)) (assert-eq? (tn) #t (eqv? cont cont)) (assert-eq? (tn) #t (eqv? cont k1)) (assert-eq? (tn) #t (eqv? k1 cont)) (assert-eq? (tn) #f (eqv? cont k2)) (assert-eq? (tn) #f (eqv? k2 cont))))))) (tn "eqv? port") (assert-eq? (tn) #t (eqv? (current-output-port) (current-output-port))) (assert-eq? (tn) #f (eqv? (current-input-port) (current-output-port))) (assert-eq? (tn) #f (eqv? (current-output-port) (current-input-port))) (assert-eq? (tn) #t (eqv? (current-input-port) (current-input-port))) (let ((port (current-input-port))) (assert-eq? (tn) #t (eqv? port port)) (assert-eq? (tn) #t (eqv? (current-input-port) port)) (assert-eq? (tn) #t (eqv? port (current-input-port))) (assert-eq? (tn) #f (eqv? (current-output-port) port)) (assert-eq? (tn) #f (eqv? port (current-output-port)))) (tn "eqv? pair") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '(#t . #t) '(#t . #t))) (assert-eq? (tn) #f (eqv? '(#f . #t) '(#f . #t))) (assert-eq? (tn) #f (eqv? '(#t . #f) '(#t . #f))) (assert-eq? (tn) #f (eqv? '(#f . #t) '(#t . #f))) (assert-eq? (tn) #f (eqv? '(#\a . #\a) '(#\a . #\a))) (assert-eq? (tn) #f (eqv? '(#\a . #\b) '(#\a . #\b))) (assert-eq? (tn) #f (eqv? '(#\b . #\a) '(#\b . #\a))) (assert-eq? (tn) #f (eqv? '(#\a . #\b) '(#\b . #\a))) (assert-eq? (tn) #f (eqv? '("a" . "a") '("a" . "a"))) (assert-eq? (tn) #f (eqv? '("a" . "b") '("a" . "b"))) (assert-eq? (tn) #f (eqv? '("b" . "a") '("b" . "a"))) (assert-eq? (tn) #f (eqv? '("a" . "b") '("b" . "a"))))) (assert-eq? (tn) #f (eqv? (cons #t #t) (cons #t #t))) (assert-eq? (tn) #f (eqv? (cons #f #t) (cons #f #t))) (assert-eq? (tn) #f (eqv? (cons #t #f) (cons #t #f))) (assert-eq? (tn) #f (eqv? (cons #f #t) (cons #t #f))) (assert-eq? (tn) #f (eqv? (cons #\a #\a) (cons #\a #\a))) (assert-eq? (tn) #f (eqv? (cons #\a #\b) (cons #\a #\b))) (assert-eq? (tn) #f (eqv? (cons #\b #\a) (cons #\b #\a))) (assert-eq? (tn) #f (eqv? (cons #\a #\b) (cons #\b #\a))) (assert-eq? (tn) #f (eqv? (cons "a" "a") (cons "a" "a"))) (assert-eq? (tn) #f (eqv? (cons "a" "b") (cons "a" "b"))) (assert-eq? (tn) #f (eqv? (cons "b" "a") (cons "b" "a"))) (assert-eq? (tn) #f (eqv? (cons "a" "b") (cons "b" "a"))) (tn "eqv? list") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '(#f) '(#f))) (assert-eq? (tn) #f (eqv? '(#f) '(#t))) (assert-eq? (tn) #f (eqv? '(#t) '(#f))) (assert-eq? (tn) #f (eqv? '(#t) '(#t))) (assert-eq? (tn) #f (eqv? '((#f)) '((#f)))) (assert-eq? (tn) #f (eqv? '((#f)) '((#t)))) (assert-eq? (tn) #f (eqv? '((#t)) '((#f)))) (assert-eq? (tn) #f (eqv? '((#t)) '((#t)))) (assert-eq? (tn) #f (eqv? '(1) '(1))) (assert-eq? (tn) #f (eqv? '(1) '(0))) (assert-eq? (tn) #f (eqv? '(1 3 5 0 13) '(1 3 5 0 13))) (assert-eq? (tn) #f (eqv? '(1 3 2 0 13) '(1 3 5 0 13))) (assert-eq? (tn) #f (eqv? '(1 3 (5 0 13)) '(1 3 (5 0 13)))) (assert-eq? (tn) #f (eqv? '(1 3 (2 0 13)) '(1 3 (5 0 13)))) (assert-eq? (tn) #f (eqv? '((1)) '((1)))) (assert-eq? (tn) #f (eqv? '((1)) '((0)))) (assert-eq? (tn) #f (eqv? '((1) (3) (5) (0) (13)) '((1) (3) (5) (0) (13)))) (assert-eq? (tn) #f (eqv? '((1) (3) (2) (0) (13)) '((1) (3) (5) (0) (13)))) (assert-eq? (tn) #f (eqv? '(#\a) '(#\a))) (assert-eq? (tn) #f (eqv? '(#\a) '(#\b))) (assert-eq? (tn) #f (eqv? '(#\b) '(#\a))) (assert-eq? (tn) #f (eqv? '((#\a)) '((#\a)))) (assert-eq? (tn) #f (eqv? '((#\a)) '((#\b)))) (assert-eq? (tn) #f (eqv? '((#\b)) '((#\a)))))) (assert-eq? (tn) #f (eqv? (list #f) (list #f))) (assert-eq? (tn) #f (eqv? (list #f) (list #t))) (assert-eq? (tn) #f (eqv? (list #t) (list #f))) (assert-eq? (tn) #f (eqv? (list #t) (list #t))) (assert-eq? (tn) #f (eqv? (list (list #f)) (list (list #f)))) (assert-eq? (tn) #f (eqv? (list (list #f)) (list (list #t)))) (assert-eq? (tn) #f (eqv? (list (list #t)) (list (list #f)))) (assert-eq? (tn) #f (eqv? (list (list #t)) (list (list #t)))) (assert-eq? (tn) #f (eqv? (list 1) (list 1))) (assert-eq? (tn) #f (eqv? (list 1) (list 0))) (assert-eq? (tn) #f (eqv? (list 1 3 5 0 13) (list 1 3 5 0 13))) (assert-eq? (tn) #f (eqv? (list 1 3 2 0 13) (list 1 3 5 0 13))) (assert-eq? (tn) #f (eqv? (list 1 3 (list 5 0 13)) (list 1 3 (list 5 0 13)))) (assert-eq? (tn) #f (eqv? (list 1 3 (list 2 0 13)) (list 1 3 (list 5 0 13)))) (assert-eq? (tn) #f (eqv? (list (list 1)) (list (list 1)))) (assert-eq? (tn) #f (eqv? (list (list 1)) (list (list 0)))) (assert-eq? (tn) #f (eqv? (list (list 1) (list 3) (list 5) (list 0) (list 13)) (list (list 1) (list 3) (list 5) (list 0) (list 13)))) (assert-eq? (tn) #f (eqv? (list (list 1) (list 3) (list 2) (list 0) (list 13)) (list (list 1) (list 3) (list 5) (list 0) (list 13)))) (assert-eq? (tn) #f (eqv? (list #\a) (list #\a))) (assert-eq? (tn) #f (eqv? (list #\a) (list #\b))) (assert-eq? (tn) #f (eqv? (list #\b) (list #\a))) (assert-eq? (tn) #f (eqv? (list (list #\a)) (list (list #\a)))) (assert-eq? (tn) #f (eqv? (list (list #\a)) (list (list #\b)))) (assert-eq? (tn) #f (eqv? (list (list #\b)) (list (list #\a)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '("") '(""))) (assert-eq? (tn) #f (eqv? '(("")) '(("")))) (assert-eq? (tn) #f (eqv? '("aBc12!") '("aBc12!"))) (assert-eq? (tn) #f (eqv? '("ã‚0イã†12!") '("ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? '("a" "" "aB1" ("3c" "d") "a") '("a" "" "aB1" ("3c" "d") "a"))) (assert-eq? (tn) #f (eqv? '(("aBc12!")) '(("aBc12!")))) (assert-eq? (tn) #f (eqv? '(("ã‚0イã†12!")) '(("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eqv? (list "") (list ""))) (assert-eq? (tn) #f (eqv? (list (list "")) (list (list "")))) (assert-eq? (tn) #f (eqv? (list "aBc12!") (list "aBc12!"))) (assert-eq? (tn) #f (eqv? (list "ã‚0イã†12!") (list "ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? (list "a" "" "aB1" (list "3c" "d") "a") (list "a" "" "aB1" (list "3c" "d") "a"))) (assert-eq? (tn) #f (eqv? (list (list "aBc12!")) (list (list "aBc12!")))) (assert-eq? (tn) #f (eqv? (list (list "ã‚0イã†12!")) (list (list "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '("aBc123!") '("aBc12!"))) (assert-eq? (tn) #f (eqv? '("ã‚0イã…12!") '("ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? '("a" "" "aB1" ("3c" "e") "a") '("a" "" "aB1" ("3c" "d") "a"))) (assert-eq? (tn) #f (eqv? '(("aBc123!")) '(("aBc12!")))) (assert-eq? (tn) #f (eqv? '(("ã‚0イã…12!")) '(("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eqv? (list "aBc123!") (list "aBc12!"))) (assert-eq? (tn) #f (eqv? (list "ã‚0イã…12!") (list "ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? (list "a" "" "aB1" (list "3c" "e") "a") (list "a" "" "aB1" (list "3c" "d") "a"))) (assert-eq? (tn) #f (eqv? (list (list "aBc123!")) (list (list "aBc12!")))) (assert-eq? (tn) #f (eqv? (list (list "ã‚0イã…12!")) (list (list "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eqv? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("L")) #t))) (assert-eq? (tn) #f (eqv? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" ("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eqv? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eqv? '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t) '(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))))) (assert-eq? (tn) #f (eqv? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eqv? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("L")) #t))) (assert-eq? (tn) #f (eqv? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (list "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eqv? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eqv? (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t) (list 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (list -1 #\b '("Ls")) #t))) (tn "eqv? empty vector") (if (provided? "sigscheme") (assert-eq? (tn) #f (eqv? '#() '#()))) (assert-eq? (tn) #f (eqv? (vector) (vector))) (let ((v1 '#()) (v2 (vector))) (assert-eq? (tn) #t (eqv? v1 v1)) (assert-eq? (tn) #t (eqv? v2 v2)) (assert-eq? (tn) #f (eqv? v1 v2))) (tn "eqv? vector") (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '#(#f) '#(#f))) (assert-eq? (tn) #f (eqv? '#(#f) '#(#t))) (assert-eq? (tn) #f (eqv? '#(#t) '#(#f))) (assert-eq? (tn) #f (eqv? '#(#t) '#(#t))) (assert-eq? (tn) #f (eqv? '#(#(#f)) '#(#(#f)))) (assert-eq? (tn) #f (eqv? '#(#(#f)) '#(#(#t)))) (assert-eq? (tn) #f (eqv? '#(#(#t)) '#(#(#f)))) (assert-eq? (tn) #f (eqv? '#(#(#t)) '#(#(#t)))) (assert-eq? (tn) #f (eqv? '#(1) '#(1))) (assert-eq? (tn) #f (eqv? '#(1) '#(0))) (assert-eq? (tn) #f (eqv? '#(1 3 5 0 13) '#(1 3 5 0 13))) (assert-eq? (tn) #f (eqv? '#(1 3 2 0 13) '#(1 3 5 0 13))) (assert-eq? (tn) #f (eqv? '#(1 3 #(5 0 13)) '#(1 3 #(5 0 13)))) (assert-eq? (tn) #f (eqv? '#(1 3 #(2 0 13)) '#(1 3 #(5 0 13)))) (assert-eq? (tn) #f (eqv? '#(#(1)) '#(#(1)))) (assert-eq? (tn) #f (eqv? '#(#(1)) '#(#(0)))) (assert-eq? (tn) #f (eqv? '#(#(1) #(3) #(5) #(0) #(13)) '#(#(1) #(3) #(5) #(0) #(13)))) (assert-eq? (tn) #f (eqv? '#(#(1) #(3) #(2) #(0) #(13)) '#(#(1) #(3) #(5) #(0) #(13)))) (assert-eq? (tn) #f (eqv? '#(#\a) '#(#\a))) (assert-eq? (tn) #f (eqv? '#(#\a) '#(#\b))) (assert-eq? (tn) #f (eqv? '#(#\b) '#(#\a))) (assert-eq? (tn) #f (eqv? '#(#(#\a)) '#(#(#\a)))) (assert-eq? (tn) #f (eqv? '#(#(#\a)) '#(#(#\b)))) (assert-eq? (tn) #f (eqv? '#(#(#\b)) '#(#(#\a)))))) (assert-eq? (tn) #f (eqv? (vector #f) (vector #f))) (assert-eq? (tn) #f (eqv? (vector #f) (vector #t))) (assert-eq? (tn) #f (eqv? (vector #t) (vector #f))) (assert-eq? (tn) #f (eqv? (vector #t) (vector #t))) (assert-eq? (tn) #f (eqv? (vector (vector #f)) (vector (vector #f)))) (assert-eq? (tn) #f (eqv? (vector (vector #f)) (vector (vector #t)))) (assert-eq? (tn) #f (eqv? (vector (vector #t)) (vector (vector #f)))) (assert-eq? (tn) #f (eqv? (vector (vector #t)) (vector (vector #t)))) (assert-eq? (tn) #f (eqv? (vector 1) (vector 1))) (assert-eq? (tn) #f (eqv? (vector 1) (vector 0))) (assert-eq? (tn) #f (eqv? (vector 1 3 5 0 13) (vector 1 3 5 0 13))) (assert-eq? (tn) #f (eqv? (vector 1 3 2 0 13) (vector 1 3 5 0 13))) (assert-eq? (tn) #f (eqv? (vector 1 3 (vector 5 0 13)) (vector 1 3 (vector 5 0 13)))) (assert-eq? (tn) #f (eqv? (vector 1 3 (vector 2 0 13)) (vector 1 3 (vector 5 0 13)))) (assert-eq? (tn) #f (eqv? (vector (vector 1)) (vector (vector 1)))) (assert-eq? (tn) #f (eqv? (vector (vector 1)) (vector (vector 0)))) (assert-eq? (tn) #f (eqv? (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)) (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)))) (assert-eq? (tn) #f (eqv? (vector (vector 1) (vector 3) (vector 2) (vector 0) (vector 13)) (vector (vector 1) (vector 3) (vector 5) (vector 0) (vector 13)))) (assert-eq? (tn) #f (eqv? (vector #\a) (vector #\a))) (assert-eq? (tn) #f (eqv? (vector #\a) (vector #\b))) (assert-eq? (tn) #f (eqv? (vector #\b) (vector #\a))) (assert-eq? (tn) #f (eqv? (vector (vector #\a)) (vector (vector #\a)))) (assert-eq? (tn) #f (eqv? (vector (vector #\a)) (vector (vector #\b)))) (assert-eq? (tn) #f (eqv? (vector (vector #\b)) (vector (vector #\a)))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '#("") '#(""))) (assert-eq? (tn) #f (eqv? '#(#("")) '#(#("")))) (assert-eq? (tn) #f (eqv? '#("aBc12!") '#("aBc12!"))) (assert-eq? (tn) #f (eqv? '#("ã‚0イã†12!") '#("ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? '#("a" "" "aB1" #("3c" "d") "a") '#("a" "" "aB1" #("3c" "d") "a"))) (assert-eq? (tn) #f (eqv? '#(#("aBc12!")) '#(#("aBc12!")))) (assert-eq? (tn) #f (eqv? '#(#("ã‚0イã†12!")) '#(#("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eqv? (vector "") (vector ""))) (assert-eq? (tn) #f (eqv? (vector (vector "")) (vector (vector "")))) (assert-eq? (tn) #f (eqv? (vector "aBc12!") (vector "aBc12!"))) (assert-eq? (tn) #f (eqv? (vector "ã‚0イã†12!") (vector "ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? (vector "a" "" "aB1" (vector "3c" "d") "a") (vector "a" "" "aB1" (vector "3c" "d") "a"))) (assert-eq? (tn) #f (eqv? (vector (vector "aBc12!")) (vector (vector "aBc12!")))) (assert-eq? (tn) #f (eqv? (vector (vector "ã‚0イã†12!")) (vector (vector "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '#("aBc123!") '#("aBc12!"))) (assert-eq? (tn) #f (eqv? '#("ã‚0イã…12!") '#("ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? '#("a" "" "aB1" #("3c" "e") "a") '#("a" "" "aB1" #("3c" "d") "a"))) (assert-eq? (tn) #f (eqv? '#(#("aBc123!")) '#(#("aBc12!")))) (assert-eq? (tn) #f (eqv? '#(#("ã‚0イã…12!")) '#(#("ã‚0イã†12!")))))) (assert-eq? (tn) #f (eqv? (vector "aBc123!") (vector "aBc12!"))) (assert-eq? (tn) #f (eqv? (vector "ã‚0イã…12!") (vector "ã‚0イã†12!"))) (assert-eq? (tn) #f (eqv? (vector "a" "" "aB1" (vector "3c" "e") "a") (vector "a" "" "aB1" (vector "3c" "d") "a"))) (assert-eq? (tn) #f (eqv? (vector (vector "aBc123!")) (vector (vector "aBc12!")))) (assert-eq? (tn) #f (eqv? (vector (vector "ã‚0イã…12!")) (vector (vector "ã‚0イã†12!")))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (eqv? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eqv? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("L")) #t))) (assert-eq? (tn) #f (eqv? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" ("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))) (assert-eq? (tn) #f (eqv? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eqv? '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" #t) '#(0 #\a "" #("vE" -1 (#\?)) 23 + "aBc" (-1 #\b ("Ls")) #t))))) (assert-eq? (tn) #f (eqv? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eqv? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("L")) #t))) (assert-eq? (tn) #f (eqv? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (list "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (assert-eq? (tn) #f (eqv? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t))) (assert-eq? (tn) #f (eqv? (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" #t) (vector 0 #\a "" (vector "vE" -1 '(#\?)) 23 + "aBc" (vector -1 #\b '("Ls")) #t))) (total-report) uim-1.8.8/sigscheme/test/test-string-proc.scm0000644000175000017500000016777312532333147016151 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-string-proc.scm ;; About : unit test for R5RS string procedures ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (sscm-ext)) (require-extension (unittest)) (if (and sigscheme? (not (symbol-bound? 'make-string))) (test-skip "non-core string procedures of R5RS is not enabled")) (define tn test-name) (define cp string-copy) (define mutable? (if sigscheme? %%string-mutable? (lambda (s) #t))) (define pair-mutable? (if sigscheme? %%pair-mutable? (lambda (kons) #t))) ;; ;; All procedures that take a string as argument are tested with ;; both immutable and mutable string. ;; ;; See "3.4 Storage model" of R5RS ;; (tn "make-string invalid forms") (assert-error (tn) (lambda () (make-string -2))) (assert-error (tn) (lambda () (make-string -1))) (assert-error (tn) (lambda () (make-string -2 #\a))) (assert-error (tn) (lambda () (make-string -1 #\a))) (assert-error (tn) (lambda () (make-string #\a))) (assert-error (tn) (lambda () (make-string 1 32))) (tn "make-string") (assert-equal? (tn) "" (make-string 0)) (assert-equal? (tn) "?" (make-string 1)) (assert-equal? (tn) "??" (make-string 2)) (assert-equal? (tn) "???" (make-string 3)) (assert-equal? (tn) "" (make-string 0 #\a)) (assert-equal? (tn) "a" (make-string 1 #\a)) (assert-equal? (tn) "aa" (make-string 2 #\a)) (assert-equal? (tn) "aaa" (make-string 3 #\a)) (assert-equal? (tn) "" (make-string 0 #\ã‚)) (assert-equal? (tn) "ã‚" (make-string 1 #\ã‚)) (assert-equal? (tn) "ã‚ã‚" (make-string 2 #\ã‚)) (assert-equal? (tn) "ã‚ã‚ã‚" (make-string 3 #\ã‚)) (tn "make-string NUL filler") (assert-equal? (tn) "" (make-string 0 #x00)) (if (and sigscheme? (not (provided? "null-capable-string"))) (begin (assert-error (tn) (lambda () (make-string 1 #x00))) (assert-error (tn) (lambda () (make-string 2 #x00))) (assert-error (tn) (lambda () (make-string 3 #x00))))) (tn "string invalid forms") (assert-error (tn) (lambda () (string #t))) (assert-error (tn) (lambda () (string "a"))) (tn "string") (assert-equal? (tn) "" (string)) (assert-equal? (tn) "a" (string #\a)) (assert-equal? (tn) "ab" (string #\a #\b)) (assert-equal? (tn) "ã‚" (string #\ã‚)) (assert-equal? (tn) "ã‚ã†" (string #\ã‚ #\ã†)) (assert-equal? (tn) "aã‚b" (string #\a #\ã‚ #\b)) (assert-equal? (tn) "ã‚aã†" (string #\ã‚ #\a #\ã†)) (assert-equal? (tn) "aã‚bã†" (string #\a #\ã‚ #\b #\ã†)) (assert-equal? (tn) "ã‚aã†b" (string #\ã‚ #\a #\ㆠ#\b)) (tn "string mutability") (assert-true (tn) (mutable? (string))) (assert-true (tn) (mutable? (string #\a))) (assert-true (tn) (mutable? (string #\a #\b))) (assert-true (tn) (mutable? (string #\ã‚))) (assert-true (tn) (mutable? (string #\ã‚ #\ã†))) (assert-true (tn) (mutable? (string #\a #\ã‚ #\b))) (assert-true (tn) (mutable? (string #\ã‚ #\a #\ã†))) (assert-true (tn) (mutable? (string #\a #\ã‚ #\b #\ã†))) (assert-true (tn) (mutable? (string #\ã‚ #\a #\ㆠ#\b))) (tn "string with NUL args") (if (and sigscheme? (not (provided? "null-capable-string"))) (begin (assert-error (tn) (lambda () (string #x00))) (assert-error (tn) (lambda () (string #\a #x00))) (assert-error (tn) (lambda () (string #x00 #\a))) (assert-error (tn) (lambda () (string #\a #x00 #\a))))) (tn "string-ref invalid forms") (assert-error (tn) (lambda () (string-ref #\a 0))) (assert-error (tn) (lambda () (string-ref "a" #\1))) (tn "string-ref immutable") (assert-error (tn) (lambda () (string-ref "" -2))) (assert-error (tn) (lambda () (string-ref "" -1))) (assert-error (tn) (lambda () (string-ref "" 0))) (assert-error (tn) (lambda () (string-ref "" 1))) (assert-error (tn) (lambda () (string-ref "" 2))) (assert-error (tn) (lambda () (string-ref "a" -2))) (assert-error (tn) (lambda () (string-ref "a" -1))) (assert-equal? (tn) #\a (string-ref "a" 0)) (assert-error (tn) (lambda () (string-ref "a" 1))) (assert-error (tn) (lambda () (string-ref "a" 2))) (assert-error (tn) (lambda () (string-ref "ab" -2))) (assert-error (tn) (lambda () (string-ref "ab" -1))) (assert-equal? (tn) #\a (string-ref "ab" 0)) (assert-equal? (tn) #\b (string-ref "ab" 1)) (assert-error (tn) (lambda () (string-ref "ab" 2))) (assert-error (tn) (lambda () (string-ref "ab" 3))) (assert-error (tn) (lambda () (string-ref "ã‚" -2))) (assert-error (tn) (lambda () (string-ref "ã‚" -1))) (assert-equal? (tn) #\ã‚ (string-ref "ã‚" 0)) (assert-error (tn) (lambda () (string-ref "ã‚" 1))) (assert-error (tn) (lambda () (string-ref "ã‚" 2))) (assert-error (tn) (lambda () (string-ref "ã‚ã†" -2))) (assert-error (tn) (lambda () (string-ref "ã‚ã†" -1))) (assert-equal? (tn) #\ã‚ (string-ref "ã‚ã†" 0)) (assert-equal? (tn) #\ㆠ(string-ref "ã‚ã†" 1)) (assert-error (tn) (lambda () (string-ref "ã‚ã†" 2))) (assert-error (tn) (lambda () (string-ref "ã‚ã†" 3))) (assert-error (tn) (lambda () (string-ref "aã‚b" -2))) (assert-error (tn) (lambda () (string-ref "aã‚b" -1))) (assert-equal? (tn) #\a (string-ref "aã‚b" 0)) (assert-equal? (tn) #\ã‚ (string-ref "aã‚b" 1)) (assert-equal? (tn) #\b (string-ref "aã‚b" 2)) (assert-error (tn) (lambda () (string-ref "aã‚b" 3))) (assert-error (tn) (lambda () (string-ref "aã‚b" 4))) (assert-error (tn) (lambda () (string-ref "ã‚aã†" -2))) (assert-error (tn) (lambda () (string-ref "ã‚aã†" -1))) (assert-equal? (tn) #\ã‚ (string-ref "ã‚aã†" 0)) (assert-equal? (tn) #\a (string-ref "ã‚aã†" 1)) (assert-equal? (tn) #\ㆠ(string-ref "ã‚aã†" 2)) (assert-error (tn) (lambda () (string-ref "ã‚aã†" 3))) (assert-error (tn) (lambda () (string-ref "ã‚aã†" 4))) (assert-error (tn) (lambda () (string-ref "aã‚bã†" -2))) (assert-error (tn) (lambda () (string-ref "aã‚bã†" -1))) (assert-equal? (tn) #\a (string-ref "aã‚bã†" 0)) (assert-equal? (tn) #\ã‚ (string-ref "aã‚bã†" 1)) (assert-equal? (tn) #\b (string-ref "aã‚bã†" 2)) (assert-equal? (tn) #\ㆠ(string-ref "aã‚bã†" 3)) (assert-error (tn) (lambda () (string-ref "aã‚bã†" 4))) (assert-error (tn) (lambda () (string-ref "aã‚bã†" 5))) (assert-error (tn) (lambda () (string-ref "ã‚aã†b" -2))) (assert-error (tn) (lambda () (string-ref "ã‚aã†b" -1))) (assert-equal? (tn) #\ã‚ (string-ref "ã‚aã†b" 0)) (assert-equal? (tn) #\a (string-ref "ã‚aã†b" 1)) (assert-equal? (tn) #\ㆠ(string-ref "ã‚aã†b" 2)) (assert-equal? (tn) #\b (string-ref "ã‚aã†b" 3)) (assert-error (tn) (lambda () (string-ref "ã‚aã†b" 4))) (assert-error (tn) (lambda () (string-ref "ã‚aã†b" 5))) (tn "string-ref mutable") (assert-error (tn) (lambda () (string-ref (cp "") -2))) (assert-error (tn) (lambda () (string-ref (cp "") -1))) (assert-error (tn) (lambda () (string-ref (cp "") 0))) (assert-error (tn) (lambda () (string-ref (cp "") 1))) (assert-error (tn) (lambda () (string-ref (cp "") 2))) (assert-error (tn) (lambda () (string-ref (cp "a") -2))) (assert-error (tn) (lambda () (string-ref (cp "a") -1))) (assert-equal? (tn) #\a (string-ref (cp "a") 0)) (assert-error (tn) (lambda () (string-ref (cp "a") 1))) (assert-error (tn) (lambda () (string-ref (cp "a") 2))) (assert-error (tn) (lambda () (string-ref (cp "ab") -2))) (assert-error (tn) (lambda () (string-ref (cp "ab") -1))) (assert-equal? (tn) #\a (string-ref (cp "ab") 0)) (assert-equal? (tn) #\b (string-ref (cp "ab") 1)) (assert-error (tn) (lambda () (string-ref (cp "ab") 2))) (assert-error (tn) (lambda () (string-ref (cp "ab") 3))) (assert-error (tn) (lambda () (string-ref (cp "ã‚") -2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚") -1))) (assert-equal? (tn) #\ã‚ (string-ref (cp "ã‚") 0)) (assert-error (tn) (lambda () (string-ref (cp "ã‚") 1))) (assert-error (tn) (lambda () (string-ref (cp "ã‚") 2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚ã†") -2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚ã†") -1))) (assert-equal? (tn) #\ã‚ (string-ref (cp "ã‚ã†") 0)) (assert-equal? (tn) #\ㆠ(string-ref (cp "ã‚ã†") 1)) (assert-error (tn) (lambda () (string-ref (cp "ã‚ã†") 2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚ã†") 3))) (assert-error (tn) (lambda () (string-ref (cp "aã‚b") -2))) (assert-error (tn) (lambda () (string-ref (cp "aã‚b") -1))) (assert-equal? (tn) #\a (string-ref (cp "aã‚b") 0)) (assert-equal? (tn) #\ã‚ (string-ref (cp "aã‚b") 1)) (assert-equal? (tn) #\b (string-ref (cp "aã‚b") 2)) (assert-error (tn) (lambda () (string-ref (cp "aã‚b") 3))) (assert-error (tn) (lambda () (string-ref (cp "aã‚b") 4))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†") -2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†") -1))) (assert-equal? (tn) #\ã‚ (string-ref (cp "ã‚aã†") 0)) (assert-equal? (tn) #\a (string-ref (cp "ã‚aã†") 1)) (assert-equal? (tn) #\ㆠ(string-ref (cp "ã‚aã†") 2)) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†") 3))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†") 4))) (assert-error (tn) (lambda () (string-ref (cp "aã‚bã†") -2))) (assert-error (tn) (lambda () (string-ref (cp "aã‚bã†") -1))) (assert-equal? (tn) #\a (string-ref (cp "aã‚bã†") 0)) (assert-equal? (tn) #\ã‚ (string-ref (cp "aã‚bã†") 1)) (assert-equal? (tn) #\b (string-ref (cp "aã‚bã†") 2)) (assert-equal? (tn) #\ㆠ(string-ref (cp "aã‚bã†") 3)) (assert-error (tn) (lambda () (string-ref (cp "aã‚bã†") 4))) (assert-error (tn) (lambda () (string-ref (cp "aã‚bã†") 5))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†b") -2))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†b") -1))) (assert-equal? (tn) #\ã‚ (string-ref (cp "ã‚aã†b") 0)) (assert-equal? (tn) #\a (string-ref (cp "ã‚aã†b") 1)) (assert-equal? (tn) #\ㆠ(string-ref (cp "ã‚aã†b") 2)) (assert-equal? (tn) #\b (string-ref (cp "ã‚aã†b") 3)) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†b") 4))) (assert-error (tn) (lambda () (string-ref (cp "ã‚aã†b") 5))) (tn "string-set! invalid forms") (assert-error (tn) (lambda () (string-set! #\a 0 #\z))) (assert-error (tn) (lambda () (string-set! (cp "a") #\1 #\z))) (assert-error (tn) (lambda () (string-set! (cp "a") 0 #t))) (tn "string-set! immutable") (assert-error (tn) (lambda () (string-set! "" -2 #\z))) (assert-error (tn) (lambda () (string-set! "" -1 #\z))) (assert-error (tn) (lambda () (string-set! "" 0 #\z))) (assert-error (tn) (lambda () (string-set! "" 1 #\z))) (assert-error (tn) (lambda () (string-set! "" 2 #\z))) (assert-error (tn) (lambda () (string-set! "a" -2 #\z))) (assert-error (tn) (lambda () (string-set! "a" -1 #\z))) (assert-error (tn) (lambda () (string-set! "a" 0 #\z))) (assert-error (tn) (lambda () (string-set! "a" 1 #\z))) (assert-error (tn) (lambda () (string-set! "a" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ab" -2 #\z))) (assert-error (tn) (lambda () (string-set! "ab" -1 #\z))) (assert-error (tn) (lambda () (string-set! "ab" 0 #\z))) (assert-error (tn) (lambda () (string-set! "ab" 1 #\z))) (assert-error (tn) (lambda () (string-set! "ab" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ab" 3 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚" -2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚" -1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚" 0 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚" 1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" -2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" -1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 0 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 3 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" -2 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" -1 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" 0 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" 1 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" 2 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" 3 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚b" 4 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" -2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" -1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 0 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 3 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 4 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" -2 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" -1 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 0 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 1 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 2 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 3 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 4 #\z))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 5 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" -2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" -1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 0 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 1 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 2 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 3 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 4 #\z))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 5 #\z))) (tn "string-set! multibyte immutable") (assert-error (tn) (lambda () (string-set! "" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "a" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "a" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "a" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "a" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "a" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ab" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚ã†" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚b" 4 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†" 4 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 4 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "aã‚bã†" 5 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" -2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" -1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 0 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 1 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 2 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 3 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 4 #\ã‚“))) (assert-error (tn) (lambda () (string-set! "ã‚aã†b" 5 #\ã‚“))) (define my-string-set! (lambda (str k ch) (string-set! str k ch) str)) (tn "string-set! mutable") (assert-equal? (tn) (undef) (string-set! (cp "a") 0 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "") -1 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "") 0 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "") 1 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "") 2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "a") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "a") -1 #\z))) (assert-equal? (tn) "z" (my-string-set! (cp "a") 0 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "a") 1 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "a") 2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") -1 #\z))) (assert-equal? (tn) "zb" (my-string-set! (cp "ab") 0 #\z)) (assert-equal? (tn) "az" (my-string-set! (cp "ab") 1 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "ab") 2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") 3 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") -1 #\z))) (assert-equal? (tn) "z" (my-string-set! (cp "ã‚") 0 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") 1 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") 2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") -1 #\z))) (assert-equal? (tn) "zã†" (my-string-set! (cp "ã‚ã†") 0 #\z)) (assert-equal? (tn) "ã‚z" (my-string-set! (cp "ã‚ã†") 1 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") 2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") 3 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") -1 #\z))) (assert-equal? (tn) "zã‚b" (my-string-set! (cp "aã‚b") 0 #\z)) (assert-equal? (tn) "azb" (my-string-set! (cp "aã‚b") 1 #\z)) (assert-equal? (tn) "aã‚z" (my-string-set! (cp "aã‚b") 2 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") 3 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") 4 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") -1 #\z))) (assert-equal? (tn) "zaã†" (my-string-set! (cp "ã‚aã†") 0 #\z)) (assert-equal? (tn) "ã‚zã†" (my-string-set! (cp "ã‚aã†") 1 #\z)) (assert-equal? (tn) "ã‚az" (my-string-set! (cp "ã‚aã†") 2 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") 3 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") 4 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") -1 #\z))) (assert-equal? (tn) "zã‚bã†" (my-string-set! (cp "aã‚bã†") 0 #\z)) (assert-equal? (tn) "azbã†" (my-string-set! (cp "aã‚bã†") 1 #\z)) (assert-equal? (tn) "aã‚zã†" (my-string-set! (cp "aã‚bã†") 2 #\z)) (assert-equal? (tn) "aã‚bz" (my-string-set! (cp "aã‚bã†") 3 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") 4 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") 5 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") -2 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") -1 #\z))) (assert-equal? (tn) "zaã†b" (my-string-set! (cp "ã‚aã†b") 0 #\z)) (assert-equal? (tn) "ã‚zã†b" (my-string-set! (cp "ã‚aã†b") 1 #\z)) (assert-equal? (tn) "ã‚azb" (my-string-set! (cp "ã‚aã†b") 2 #\z)) (assert-equal? (tn) "ã‚aã†z" (my-string-set! (cp "ã‚aã†b") 3 #\z)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") 4 #\z))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") 5 #\z))) (tn "string-set! multibyte mutable") (assert-error (tn) (lambda () (my-string-set! (cp "") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "") -1 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "") 0 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "") 1 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "") 2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "a") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "a") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“" (my-string-set! (cp "a") 0 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "a") 1 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "a") 2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“b" (my-string-set! (cp "ab") 0 #\ã‚“)) (assert-equal? (tn) "aã‚“" (my-string-set! (cp "ab") 1 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "ab") 2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ab") 3 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“" (my-string-set! (cp "ã‚") 0 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") 1 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚") 2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“ã†" (my-string-set! (cp "ã‚ã†") 0 #\ã‚“)) (assert-equal? (tn) "ã‚ã‚“" (my-string-set! (cp "ã‚ã†") 1 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") 2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚ã†") 3 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“ã‚b" (my-string-set! (cp "aã‚b") 0 #\ã‚“)) (assert-equal? (tn) "aã‚“b" (my-string-set! (cp "aã‚b") 1 #\ã‚“)) (assert-equal? (tn) "aã‚ã‚“" (my-string-set! (cp "aã‚b") 2 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") 3 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚b") 4 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“aã†" (my-string-set! (cp "ã‚aã†") 0 #\ã‚“)) (assert-equal? (tn) "ã‚ã‚“ã†" (my-string-set! (cp "ã‚aã†") 1 #\ã‚“)) (assert-equal? (tn) "ã‚aã‚“" (my-string-set! (cp "ã‚aã†") 2 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") 3 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†") 4 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“ã‚bã†" (my-string-set! (cp "aã‚bã†") 0 #\ã‚“)) (assert-equal? (tn) "aã‚“bã†" (my-string-set! (cp "aã‚bã†") 1 #\ã‚“)) (assert-equal? (tn) "aã‚ã‚“ã†" (my-string-set! (cp "aã‚bã†") 2 #\ã‚“)) (assert-equal? (tn) "aã‚bã‚“" (my-string-set! (cp "aã‚bã†") 3 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") 4 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "aã‚bã†") 5 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") -2 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") -1 #\ã‚“))) (assert-equal? (tn) "ã‚“aã†b" (my-string-set! (cp "ã‚aã†b") 0 #\ã‚“)) (assert-equal? (tn) "ã‚ã‚“ã†b" (my-string-set! (cp "ã‚aã†b") 1 #\ã‚“)) (assert-equal? (tn) "ã‚aã‚“b" (my-string-set! (cp "ã‚aã†b") 2 #\ã‚“)) (assert-equal? (tn) "ã‚aã†ã‚“" (my-string-set! (cp "ã‚aã†b") 3 #\ã‚“)) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") 4 #\ã‚“))) (assert-error (tn) (lambda () (my-string-set! (cp "ã‚aã†b") 5 #\ã‚“))) (tn "string-set! NUL mutable") (if (and sigscheme? (not (provided? "null-capable-string"))) (begin (assert-error (tn) (lambda () (string-set! (cp "") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "a") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "a") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "a") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "a") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "a") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ab") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚ã†") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚b") 4 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†") 4 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 4 #x00))) (assert-error (tn) (lambda () (string-set! (cp "aã‚bã†") 5 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") -2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") -1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 0 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 1 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 2 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 3 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 4 #x00))) (assert-error (tn) (lambda () (string-set! (cp "ã‚aã†b") 5 #x00))))) ;; Tests for the bug fixed in r5040 (tn "string-set! multibyte char modification") (assert-equal? (tn) "Aabcde" (my-string-set! (cp "ã‚abcde") 0 #\A)) (assert-equal? (tn) "Aaã†" (my-string-set! (cp "ã‚aã†") 0 #\A)) (assert-equal? (tn) "Aaã†b" (my-string-set! (cp "ã‚aã†b") 0 #\A)) (tn "substring invalid forms") (assert-error (tn) (lambda () (substring #\a 0 0))) (assert-error (tn) (lambda () (substring "" #\0 0))) (assert-error (tn) (lambda () (substring "" 0 #\0))) (tn "substring length 0 immutable") (assert-error (tn) (lambda () (substring "" -1 -2))) (assert-error (tn) (lambda () (substring "" -1 -1))) (assert-error (tn) (lambda () (substring "" -1 0))) (assert-error (tn) (lambda () (substring "" -1 1))) (assert-error (tn) (lambda () (substring "" 0 -1))) (assert-equal? (tn) "" (substring "" 0 0)) (assert-error (tn) (lambda () (substring "" 0 1))) (assert-error (tn) (lambda () (substring "" 1 -1))) (assert-error (tn) (lambda () (substring "" 1 0))) (assert-error (tn) (lambda () (substring "" 1 1))) (assert-error (tn) (lambda () (substring "" 1 2))) (assert-error (tn) (lambda () (substring "" 2 -1))) (assert-error (tn) (lambda () (substring "" 2 0))) (assert-error (tn) (lambda () (substring "" 2 1))) (assert-error (tn) (lambda () (substring "" 2 2))) (assert-error (tn) (lambda () (substring "" 2 3))) (tn "substring length 1 immutable") (assert-error (tn) (lambda () (substring "a" -1 -2))) (assert-error (tn) (lambda () (substring "a" -1 -1))) (assert-error (tn) (lambda () (substring "a" -1 0))) (assert-error (tn) (lambda () (substring "a" -1 1))) (assert-error (tn) (lambda () (substring "a" 0 -1))) (assert-equal? (tn) "" (substring "a" 0 0)) (assert-equal? (tn) "a" (substring "a" 0 1)) (assert-error (tn) (lambda () (substring "a" 0 2))) (assert-error (tn) (lambda () (substring "a" 1 -1))) (assert-error (tn) (lambda () (substring "a" 1 0))) (assert-equal? (tn) "" (substring "a" 1 1)) (assert-error (tn) (lambda () (substring "a" 1 2))) (assert-error (tn) (lambda () (substring "a" 2 -1))) (assert-error (tn) (lambda () (substring "a" 2 0))) (assert-error (tn) (lambda () (substring "a" 2 1))) (assert-error (tn) (lambda () (substring "a" 2 2))) (assert-error (tn) (lambda () (substring "a" 2 3))) (tn "substring length 2 immutable") (assert-error (tn) (lambda () (substring "ab" -1 -2))) (assert-error (tn) (lambda () (substring "ab" -1 -1))) (assert-error (tn) (lambda () (substring "ab" -1 0))) (assert-error (tn) (lambda () (substring "ab" -1 1))) (assert-error (tn) (lambda () (substring "ab" 0 -1))) (assert-equal? (tn) "" (substring "ab" 0 0)) (assert-equal? (tn) "a" (substring "ab" 0 1)) (assert-equal? (tn) "ab" (substring "ab" 0 2)) (assert-error (tn) (lambda () (substring "ab" 0 3))) (assert-error (tn) (lambda () (substring "ab" 1 -1))) (assert-error (tn) (lambda () (substring "ab" 1 0))) (assert-equal? (tn) "" (substring "ab" 1 1)) (assert-equal? (tn) "b" (substring "ab" 1 2)) (assert-error (tn) (lambda () (substring "ab" 1 3))) (assert-error (tn) (lambda () (substring "ab" 2 -1))) (assert-error (tn) (lambda () (substring "ab" 2 0))) (assert-error (tn) (lambda () (substring "ab" 2 1))) (assert-equal? (tn) "" (substring "ab" 2 2)) (assert-error (tn) (lambda () (substring "ab" 2 3))) (assert-error (tn) (lambda () (substring "ab" 3 -1))) (assert-error (tn) (lambda () (substring "ab" 3 0))) (assert-error (tn) (lambda () (substring "ab" 3 1))) (assert-error (tn) (lambda () (substring "ab" 3 2))) (assert-error (tn) (lambda () (substring "ab" 3 3))) (assert-error (tn) (lambda () (substring "ab" 3 4))) (tn "substring length 3 immutable") (assert-error (tn) (lambda () (substring "abc" -1 -2))) (assert-error (tn) (lambda () (substring "abc" -1 -1))) (assert-error (tn) (lambda () (substring "abc" -1 0))) (assert-error (tn) (lambda () (substring "abc" -1 1))) (assert-error (tn) (lambda () (substring "abc" 0 -1))) (assert-equal? (tn) "" (substring "abc" 0 0)) (assert-equal? (tn) "a" (substring "abc" 0 1)) (assert-equal? (tn) "ab" (substring "abc" 0 2)) (assert-equal? (tn) "abc" (substring "abc" 0 3)) (assert-error (tn) (lambda () (substring "abc" 0 4))) (assert-error (tn) (lambda () (substring "abc" 1 -1))) (assert-error (tn) (lambda () (substring "abc" 1 0))) (assert-equal? (tn) "" (substring "abc" 1 1)) (assert-equal? (tn) "b" (substring "abc" 1 2)) (assert-equal? (tn) "bc" (substring "abc" 1 3)) (assert-error (tn) (lambda () (substring "abc" 1 4))) (assert-error (tn) (lambda () (substring "abc" 2 -1))) (assert-error (tn) (lambda () (substring "abc" 2 0))) (assert-error (tn) (lambda () (substring "abc" 2 1))) (assert-equal? (tn) "" (substring "abc" 2 2)) (assert-equal? (tn) "c" (substring "abc" 2 3)) (assert-error (tn) (lambda () (substring "abc" 2 4))) (assert-error (tn) (lambda () (substring "abc" 3 -1))) (assert-error (tn) (lambda () (substring "abc" 3 0))) (assert-error (tn) (lambda () (substring "abc" 3 1))) (assert-error (tn) (lambda () (substring "abc" 3 2))) (assert-equal? (tn) "" (substring "abc" 3 3)) (assert-error (tn) (lambda () (substring "abc" 3 4))) (assert-error (tn) (lambda () (substring "abc" 4 -1))) (assert-error (tn) (lambda () (substring "abc" 4 0))) (assert-error (tn) (lambda () (substring "abc" 4 1))) (assert-error (tn) (lambda () (substring "abc" 4 2))) (assert-error (tn) (lambda () (substring "abc" 4 3))) (assert-error (tn) (lambda () (substring "abc" 4 4))) (assert-error (tn) (lambda () (substring "abc" 4 5))) (tn "substring length 4 immutable") (assert-error (tn) (lambda () (substring "abcd" -1 -2))) (assert-error (tn) (lambda () (substring "abcd" -1 -1))) (assert-error (tn) (lambda () (substring "abcd" -1 0))) (assert-error (tn) (lambda () (substring "abcd" -1 1))) (assert-error (tn) (lambda () (substring "abcd" 0 -1))) (assert-equal? (tn) "" (substring "abcd" 0 0)) (assert-equal? (tn) "a" (substring "abcd" 0 1)) (assert-equal? (tn) "ab" (substring "abcd" 0 2)) (assert-equal? (tn) "abc" (substring "abcd" 0 3)) (assert-equal? (tn) "abcd" (substring "abcd" 0 4)) (assert-error (tn) (lambda () (substring "abcd" 0 5))) (assert-error (tn) (lambda () (substring "abcd" 1 -1))) (assert-error (tn) (lambda () (substring "abcd" 1 0))) (assert-equal? (tn) "" (substring "abcd" 1 1)) (assert-equal? (tn) "b" (substring "abcd" 1 2)) (assert-equal? (tn) "bc" (substring "abcd" 1 3)) (assert-equal? (tn) "bcd" (substring "abcd" 1 4)) (assert-error (tn) (lambda () (substring "abcd" 1 5))) (assert-error (tn) (lambda () (substring "abcd" 2 -1))) (assert-error (tn) (lambda () (substring "abcd" 2 0))) (assert-error (tn) (lambda () (substring "abcd" 2 1))) (assert-equal? (tn) "" (substring "abcd" 2 2)) (assert-equal? (tn) "c" (substring "abcd" 2 3)) (assert-equal? (tn) "cd" (substring "abcd" 2 4)) (assert-error (tn) (lambda () (substring "abcd" 2 5))) (assert-error (tn) (lambda () (substring "abcd" 3 -1))) (assert-error (tn) (lambda () (substring "abcd" 3 0))) (assert-error (tn) (lambda () (substring "abcd" 3 1))) (assert-error (tn) (lambda () (substring "abcd" 3 2))) (assert-equal? (tn) "" (substring "abcd" 3 3)) (assert-equal? (tn) "d" (substring "abcd" 3 4)) (assert-error (tn) (lambda () (substring "abcd" 3 5))) (assert-error (tn) (lambda () (substring "abcd" 4 -1))) (assert-error (tn) (lambda () (substring "abcd" 4 0))) (assert-error (tn) (lambda () (substring "abcd" 4 1))) (assert-error (tn) (lambda () (substring "abcd" 4 2))) (assert-error (tn) (lambda () (substring "abcd" 4 3))) (assert-equal? (tn) "" (substring "abcd" 4 4)) (assert-error (tn) (lambda () (substring "abcd" 4 5))) (assert-error (tn) (lambda () (substring "abcd" 5 -1))) (assert-error (tn) (lambda () (substring "abcd" 5 0))) (assert-error (tn) (lambda () (substring "abcd" 5 1))) (assert-error (tn) (lambda () (substring "abcd" 5 2))) (assert-error (tn) (lambda () (substring "abcd" 5 3))) (assert-error (tn) (lambda () (substring "abcd" 5 4))) (assert-error (tn) (lambda () (substring "abcd" 5 5))) (assert-error (tn) (lambda () (substring "abcd" 5 6))) (tn "substring multibyte length 1 immutable") (assert-error (tn) (lambda () (substring "ã‚" -1 -2))) (assert-error (tn) (lambda () (substring "ã‚" -1 -1))) (assert-error (tn) (lambda () (substring "ã‚" -1 0))) (assert-error (tn) (lambda () (substring "ã‚" -1 1))) (assert-error (tn) (lambda () (substring "ã‚" 0 -1))) (assert-equal? (tn) "" (substring "ã‚" 0 0)) (assert-equal? (tn) "ã‚" (substring "ã‚" 0 1)) (assert-error (tn) (lambda () (substring "ã‚" 0 2))) (assert-error (tn) (lambda () (substring "ã‚" 1 -1))) (assert-error (tn) (lambda () (substring "ã‚" 1 0))) (assert-equal? (tn) "" (substring "ã‚" 1 1)) (assert-error (tn) (lambda () (substring "ã‚" 1 2))) (assert-error (tn) (lambda () (substring "ã‚" 2 -1))) (assert-error (tn) (lambda () (substring "ã‚" 2 0))) (assert-error (tn) (lambda () (substring "ã‚" 2 1))) (assert-error (tn) (lambda () (substring "ã‚" 2 2))) (assert-error (tn) (lambda () (substring "ã‚" 2 3))) (tn "substring multibyte length 2 immutable") (assert-error (tn) (lambda () (substring "ã‚ã„" -1 -2))) (assert-error (tn) (lambda () (substring "ã‚ã„" -1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„" -1 0))) (assert-error (tn) (lambda () (substring "ã‚ã„" -1 1))) (assert-error (tn) (lambda () (substring "ã‚ã„" 0 -1))) (assert-equal? (tn) "" (substring "ã‚ã„" 0 0)) (assert-equal? (tn) "ã‚" (substring "ã‚ã„" 0 1)) (assert-equal? (tn) "ã‚ã„" (substring "ã‚ã„" 0 2)) (assert-error (tn) (lambda () (substring "ã‚ã„" 0 3))) (assert-error (tn) (lambda () (substring "ã‚ã„" 1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„" 1 0))) (assert-equal? (tn) "" (substring "ã‚ã„" 1 1)) (assert-equal? (tn) "ã„" (substring "ã‚ã„" 1 2)) (assert-error (tn) (lambda () (substring "ã‚ã„" 1 3))) (assert-error (tn) (lambda () (substring "ã‚ã„" 2 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„" 2 0))) (assert-error (tn) (lambda () (substring "ã‚ã„" 2 1))) (assert-equal? (tn) "" (substring "ã‚ã„" 2 2)) (assert-error (tn) (lambda () (substring "ã‚ã„" 2 3))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 0))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 1))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 2))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 3))) (assert-error (tn) (lambda () (substring "ã‚ã„" 3 4))) (tn "substring multibyte length 3 immutable") (assert-error (tn) (lambda () (substring "ã‚ã„ã†" -1 -2))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" -1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" -1 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" -1 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 0 -1))) (assert-equal? (tn) "" (substring "ã‚ã„ã†" 0 0)) (assert-equal? (tn) "ã‚" (substring "ã‚ã„ã†" 0 1)) (assert-equal? (tn) "ã‚ã„" (substring "ã‚ã„ã†" 0 2)) (assert-equal? (tn) "ã‚ã„ã†" (substring "ã‚ã„ã†" 0 3)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 0 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 1 0))) (assert-equal? (tn) "" (substring "ã‚ã„ã†" 1 1)) (assert-equal? (tn) "ã„" (substring "ã‚ã„ã†" 1 2)) (assert-equal? (tn) "ã„ã†" (substring "ã‚ã„ã†" 1 3)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 1 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 2 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 2 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 2 1))) (assert-equal? (tn) "" (substring "ã‚ã„ã†" 2 2)) (assert-equal? (tn) "ã†" (substring "ã‚ã„ã†" 2 3)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 2 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 3 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 3 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 3 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 3 2))) (assert-equal? (tn) "" (substring "ã‚ã„ã†" 3 3)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 3 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 2))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 3))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†" 4 5))) (tn "substring multibyte length 4 immutable") (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" -1 -2))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" -1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" -1 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" -1 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 0 -1))) (assert-equal? (tn) "" (substring "ã‚ã„ã†ãˆ" 0 0)) (assert-equal? (tn) "ã‚" (substring "ã‚ã„ã†ãˆ" 0 1)) (assert-equal? (tn) "ã‚ã„" (substring "ã‚ã„ã†ãˆ" 0 2)) (assert-equal? (tn) "ã‚ã„ã†" (substring "ã‚ã„ã†ãˆ" 0 3)) (assert-equal? (tn) "ã‚ã„ã†ãˆ" (substring "ã‚ã„ã†ãˆ" 0 4)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 0 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 1 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 1 0))) (assert-equal? (tn) "" (substring "ã‚ã„ã†ãˆ" 1 1)) (assert-equal? (tn) "ã„" (substring "ã‚ã„ã†ãˆ" 1 2)) (assert-equal? (tn) "ã„ã†" (substring "ã‚ã„ã†ãˆ" 1 3)) (assert-equal? (tn) "ã„ã†ãˆ" (substring "ã‚ã„ã†ãˆ" 1 4)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 1 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 2 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 2 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 2 1))) (assert-equal? (tn) "" (substring "ã‚ã„ã†ãˆ" 2 2)) (assert-equal? (tn) "ã†" (substring "ã‚ã„ã†ãˆ" 2 3)) (assert-equal? (tn) "ã†ãˆ" (substring "ã‚ã„ã†ãˆ" 2 4)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 2 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 3 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 3 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 3 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 3 2))) (assert-equal? (tn) "" (substring "ã‚ã„ã†ãˆ" 3 3)) (assert-equal? (tn) "ãˆ" (substring "ã‚ã„ã†ãˆ" 3 4)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 3 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 2))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 3))) (assert-equal? (tn) "" (substring "ã‚ã„ã†ãˆ" 4 4)) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 4 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 -1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 0))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 1))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 2))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 3))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 4))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 5))) (assert-error (tn) (lambda () (substring "ã‚ã„ã†ãˆ" 5 6))) (tn "substring mixed multibyte and singlebyte immutable") (assert-error (tn) (lambda () (substring "aã„uãˆ" -1 -2))) (assert-error (tn) (lambda () (substring "aã„uãˆ" -1 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" -1 0))) (assert-error (tn) (lambda () (substring "aã„uãˆ" -1 1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 0 -1))) (assert-equal? (tn) "" (substring "aã„uãˆ" 0 0)) (assert-equal? (tn) "a" (substring "aã„uãˆ" 0 1)) (assert-equal? (tn) "aã„" (substring "aã„uãˆ" 0 2)) (assert-equal? (tn) "aã„u" (substring "aã„uãˆ" 0 3)) (assert-equal? (tn) "aã„uãˆ" (substring "aã„uãˆ" 0 4)) (assert-error (tn) (lambda () (substring "aã„uãˆ" 0 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 1 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 1 0))) (assert-equal? (tn) "" (substring "aã„uãˆ" 1 1)) (assert-equal? (tn) "ã„" (substring "aã„uãˆ" 1 2)) (assert-equal? (tn) "ã„u" (substring "aã„uãˆ" 1 3)) (assert-equal? (tn) "ã„uãˆ" (substring "aã„uãˆ" 1 4)) (assert-error (tn) (lambda () (substring "aã„uãˆ" 1 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 2 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 2 0))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 2 1))) (assert-equal? (tn) "" (substring "aã„uãˆ" 2 2)) (assert-equal? (tn) "u" (substring "aã„uãˆ" 2 3)) (assert-equal? (tn) "uãˆ" (substring "aã„uãˆ" 2 4)) (assert-error (tn) (lambda () (substring "aã„uãˆ" 2 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 3 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 3 0))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 3 1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 3 2))) (assert-equal? (tn) "" (substring "aã„uãˆ" 3 3)) (assert-equal? (tn) "ãˆ" (substring "aã„uãˆ" 3 4)) (assert-error (tn) (lambda () (substring "aã„uãˆ" 3 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 0))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 2))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 3))) (assert-equal? (tn) "" (substring "aã„uãˆ" 4 4)) (assert-error (tn) (lambda () (substring "aã„uãˆ" 4 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 -1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 0))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 1))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 2))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 3))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 4))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 5))) (assert-error (tn) (lambda () (substring "aã„uãˆ" 5 6))) (tn "substring mutable") (assert-equal? (tn) "" (substring (cp "") 0 0)) (assert-equal? (tn) "a" (substring (cp "a") 0 1)) (assert-equal? (tn) "ã‚" (substring (cp "ã‚") 0 1)) (assert-equal? (tn) "ã„uãˆ" (substring (cp "aã„uãˆ") 1 4)) (tn "substring result mutability") (assert-true (tn) (mutable? (substring "" 0 0))) (assert-true (tn) (mutable? (substring "a" 0 1))) (assert-true (tn) (mutable? (substring "ã‚" 0 1))) (assert-true (tn) (mutable? (substring "aã„uãˆ" 1 4))) (assert-true (tn) (mutable? (substring (cp "") 0 0))) (assert-true (tn) (mutable? (substring (cp "a") 0 1))) (assert-true (tn) (mutable? (substring (cp "ã‚") 0 1))) (assert-true (tn) (mutable? (substring (cp "aã„uãˆ") 1 4))) (tn "string->list invalid forms") (assert-error (tn) (lambda () (string->list '()))) (assert-error (tn) (lambda () (string->list '(#\a)))) (assert-error (tn) (lambda () (string->list #\a))) (tn "string->list immutable") (assert-equal? (tn) '() (string->list "")) (assert-equal? (tn) '(#\a) (string->list "a")) (assert-equal? (tn) '(#\a #\b) (string->list "ab")) (assert-equal? (tn) '(#\ã‚) (string->list "ã‚")) (assert-equal? (tn) '(#\ã‚ #\ã†) (string->list "ã‚ã†")) (assert-equal? (tn) '(#\a #\ã‚ #\b) (string->list "aã‚b")) (assert-equal? (tn) '(#\ã‚ #\a #\ã†) (string->list "ã‚aã†")) (assert-equal? (tn) '(#\a #\ã‚ #\b #\ã†) (string->list "aã‚bã†")) (assert-equal? (tn) '(#\ã‚ #\a #\ㆠ#\b) (string->list "ã‚aã†b")) (tn "string->list mutable") (assert-equal? (tn) '() (string->list (cp ""))) (assert-equal? (tn) '(#\a) (string->list (cp "a"))) (assert-equal? (tn) '(#\a #\b) (string->list (cp "ab"))) (assert-equal? (tn) '(#\ã‚) (string->list (cp "ã‚"))) (assert-equal? (tn) '(#\ã‚ #\ã†) (string->list (cp "ã‚ã†"))) (assert-equal? (tn) '(#\a #\ã‚ #\b) (string->list (cp "aã‚b"))) (assert-equal? (tn) '(#\ã‚ #\a #\ã†) (string->list (cp "ã‚aã†"))) (assert-equal? (tn) '(#\a #\ã‚ #\b #\ã†) (string->list (cp "aã‚bã†"))) (assert-equal? (tn) '(#\ã‚ #\a #\ㆠ#\b) (string->list (cp "ã‚aã†b"))) (tn "string->list mutability") (assert-true (tn) (pair-mutable? (string->list "a"))) (assert-true (tn) (pair-mutable? (string->list "ab"))) (assert-true (tn) (pair-mutable? (string->list "ã‚"))) (assert-true (tn) (pair-mutable? (string->list "ã‚ã†"))) (assert-true (tn) (pair-mutable? (string->list "aã‚b"))) (assert-true (tn) (pair-mutable? (string->list "ã‚aã†"))) (assert-true (tn) (pair-mutable? (string->list "aã‚bã†"))) (assert-true (tn) (pair-mutable? (string->list "ã‚aã†b"))) (tn "list->string invalid forms") (assert-error (tn) (lambda () (list->string #t))) (assert-error (tn) (lambda () (list->string '(#t)))) (assert-error (tn) (lambda () (list->string '(#\a . #t)))) (tn "list->string") (assert-equal? (tn) "" (list->string '())) (assert-equal? (tn) "a" (list->string '(#\a))) (assert-equal? (tn) "ab" (list->string '(#\a #\b))) (assert-equal? (tn) "ã‚" (list->string '(#\ã‚))) (assert-equal? (tn) "ã‚ã†" (list->string '(#\ã‚ #\ã†))) (assert-equal? (tn) "aã‚b" (list->string '(#\a #\ã‚ #\b))) (assert-equal? (tn) "ã‚aã†" (list->string '(#\ã‚ #\a #\ã†))) (assert-equal? (tn) "aã‚bã†" (list->string '(#\a #\ã‚ #\b #\ã†))) (assert-equal? (tn) "ã‚aã†b" (list->string '(#\ã‚ #\a #\ㆠ#\b))) (tn "list->string mutability") (assert-true (tn) (mutable? (list->string '()))) (assert-true (tn) (mutable? (list->string '(#\a)))) (assert-true (tn) (mutable? (list->string '(#\a #\b)))) (assert-true (tn) (mutable? (list->string '(#\ã‚)))) (assert-true (tn) (mutable? (list->string '(#\ã‚ #\ã†)))) (assert-true (tn) (mutable? (list->string '(#\a #\ã‚ #\b)))) (assert-true (tn) (mutable? (list->string '(#\ã‚ #\a #\ã†)))) (assert-true (tn) (mutable? (list->string '(#\a #\ã‚ #\b #\ã†)))) (assert-true (tn) (mutable? (list->string '(#\ã‚ #\a #\ㆠ#\b)))) (tn "list->string with NUL args") (if (and sigscheme? (not (provided? "null-capable-string"))) (begin (assert-error (tn) (lambda () (list->string '(#x00)))) (assert-error (tn) (lambda () (list->string '(#\a #x00)))) (assert-error (tn) (lambda () (list->string '(#x00 #\a)))) (assert-error (tn) (lambda () (list->string '(#\a #x00 #\a)))))) (tn "list->string improper lists") (assert-error (tn) (lambda () (list->string '(#\ã‚ #\a #\ㆠ. #\b)))) ;; circular lists (define clst1 (list #\a)) (set-cdr! clst1 clst1) (define clst2 (list #\a #\b)) (set-cdr! (list-tail clst2 1) clst2) (define clst3 (list #\a #\b #\c)) (set-cdr! (list-tail clst3 2) clst3) (define clst4 (list #\a #\b #\c #\d)) (set-cdr! (list-tail clst4 3) clst4) (if (and sigscheme? (provided? "strict-argcheck")) (begin (assert-error (tn) (lambda () (list->string clst1))) (assert-error (tn) (lambda () (list->string clst2))) (assert-error (tn) (lambda () (list->string clst3))) (assert-error (tn) (lambda () (list->string clst4))))) (tn "string-fill! immutable") (assert-error (tn) (lambda () (string-fill! "" #\z))) (assert-error (tn) (lambda () (string-fill! "a" #\z))) (assert-error (tn) (lambda () (string-fill! "ab" #\z))) (assert-error (tn) (lambda () (string-fill! "ã‚" #\z))) (assert-error (tn) (lambda () (string-fill! "ã‚ã†" #\z))) (assert-error (tn) (lambda () (string-fill! "aã‚b" #\z))) (assert-error (tn) (lambda () (string-fill! "ã‚aã†" #\z))) (assert-error (tn) (lambda () (string-fill! "aã‚bã†" #\z))) (assert-error (tn) (lambda () (string-fill! "ã‚aã†b" #\z))) (tn "string-fill! multibyte immutable") (assert-error (tn) (lambda () (string-fill! "" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "a" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "ab" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "ã‚" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "ã‚ã†" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "aã‚b" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "ã‚aã†" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "aã‚bã†" #\ã‚“))) (assert-error (tn) (lambda () (string-fill! "ã‚aã†b" #\ã‚“))) (define my-string-fill! (lambda (str ch) (string-fill! str ch) str)) (tn "string-fill! mutable") (assert-equal? (tn) (undef) (string-fill! (cp "a") #\z)) (assert-equal? (tn) "" (my-string-fill! (cp "") #\z)) (assert-equal? (tn) "z" (my-string-fill! (cp "a") #\z)) (assert-equal? (tn) "zz" (my-string-fill! (cp "ab") #\z)) (assert-equal? (tn) "z" (my-string-fill! (cp "ã‚") #\z)) (assert-equal? (tn) "zz" (my-string-fill! (cp "ã‚ã†") #\z)) (assert-equal? (tn) "zzz" (my-string-fill! (cp "aã‚b") #\z)) (assert-equal? (tn) "zzz" (my-string-fill! (cp "ã‚aã†") #\z)) (assert-equal? (tn) "zzzz" (my-string-fill! (cp "aã‚bã†") #\z)) (assert-equal? (tn) "zzzz" (my-string-fill! (cp "ã‚aã†b") #\z)) (tn "string-fill! multibyte mutable") (assert-equal? (tn) (undef) (string-fill! (cp "a") #\ã‚“)) (assert-equal? (tn) "" (my-string-fill! (cp "") #\ã‚“)) (assert-equal? (tn) "ã‚“" (my-string-fill! (cp "a") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“" (my-string-fill! (cp "ab") #\ã‚“)) (assert-equal? (tn) "ã‚“" (my-string-fill! (cp "ã‚") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“" (my-string-fill! (cp "ã‚ã†") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“ã‚“" (my-string-fill! (cp "aã‚b") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“ã‚“" (my-string-fill! (cp "ã‚aã†") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“ã‚“ã‚“" (my-string-fill! (cp "aã‚bã†") #\ã‚“)) (assert-equal? (tn) "ã‚“ã‚“ã‚“ã‚“" (my-string-fill! (cp "ã‚aã†b") #\ã‚“)) (tn "string-fill! mutability") (assert-true (tn) (mutable? (my-string-fill! (cp "") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "a") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "ab") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "ã‚") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "ã‚ã†") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "aã‚b") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "ã‚aã†") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "aã‚bã†") #\z))) (assert-true (tn) (mutable? (my-string-fill! (cp "ã‚aã†b") #\z))) (tn "%%string-reconstruct!") (assert-error (tn) (lambda () (%%string-reconstruct! ""))) (assert-error (tn) (lambda () (%%string-reconstruct! "const str"))) (assert-error (tn) (lambda () (%%string-reconstruct! "ã‚aã†"))) (assert-equal? (tn) 0 (string-length (string-copy ""))) (assert-equal? (tn) 9 (string-length (string-copy "const str"))) (assert-equal? (tn) 3 (string-length (string-copy "ã‚aã†"))) (assert-equal? (tn) 0 (string-length (with-char-codec "ISO-8859-1" (lambda () (%%string-reconstruct! (string-copy "")))))) (assert-equal? (tn) 9 (string-length (with-char-codec "ISO-8859-1" (lambda () (%%string-reconstruct! (string-copy "const str")))))) (assert-equal? (tn) 7 (string-length (with-char-codec "ISO-8859-1" (lambda () (%%string-reconstruct! (string-copy "ã‚aã†")))))) (let ((byte-str (with-char-codec "ISO-8859-1" (lambda () (%%string-reconstruct! (string-copy "ã‚aã†")))))) (assert-equal? (tn) 7 (string-length byte-str)) ;; reconstruct as UTF-8 string (assert-equal? (tn) 3 (string-length (%%string-reconstruct! byte-str)))) (total-report) uim-1.8.8/sigscheme/test/test-eval.scm0000644000175000017500000002255712532333147014617 00000000000000;; Filename : test-eval.scm ;; About : unit test for evaluation ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (tn "eval") (assert-equal? (tn) 3 (eval '(+ 1 2) (interaction-environment))) (assert-equal? (tn) 3 (eval '((lambda (x y) (+ x y)) 1 2) (interaction-environment))) (tn "eval with invalid environment specifiers") (assert-error (tn) (lambda () (eval '(+ 1 2) 3))) (assert-error (tn) (lambda () (eval '(+ 1 2) 'symbol))) (assert-error (tn) (lambda () (eval '(+ 1 2) "string"))) (assert-error (tn) (lambda () (eval '(+ 1 2) #\a))) ;; R5RS: 4.1.3 Procedure calls ;; > Procedure calls may return any number of values (see values in section see ;; > section 6.4 Control features). With the exception of `values' the ;; > procedures available in the initial environment return one value or, for ;; > procedures such as `apply', pass on the values returned by a call to one ;; > of their arguments. ;; SigScheme apply this specification for 'eval' also. -- YamaKen 2006-09-02 (tn "eval that returns multiple values") (call-with-values (lambda () (eval '(values 1 2 3) (interaction-environment))) (lambda vals (assert-equal? (tn) '(1 2 3) vals))) (call-with-values (lambda () (eval '(apply values '(1 2 3)) (interaction-environment))) (lambda vals (assert-equal? (tn) '(1 2 3) vals))) (tn "scheme-report-environment") (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () (eval '(+ 1 2) (scheme-report-environment 4)))) (assert-error (tn) (lambda () (eval '(+ 1 2) (scheme-report-environment 6)))))) (assert-error (tn) (lambda () (eval '(+ 1 2) (scheme-report-environment 'symbol)))) (assert-error (tn) (lambda () (eval '(+ 1 2) (scheme-report-environment "string")))) (assert-error (tn) (lambda () (eval '(+ 1 2) (scheme-report-environment #\a)))) (assert-equal? (tn) 3 (eval '(+ 1 2) (scheme-report-environment 5))) ;; R5RS: 6.5 Eval ;; `eval' is not allowed to create new bindings in the environments associated ;; with `null-environment' or `scheme-report-environment'. ;; FIXME: SigScheme does not support this yet. (if (and #f (provided? "sigscheme")) (begin (assert-error (tn) (lambda () ;; Although other implementations evaluate this ;; expression without error (with or without 'foo' ;; defined), SigScheme will adopt this behavior. (eval '(define foo 1) (scheme-report-environment 5)))) (assert-error (tn) (lambda () (eval 'use (scheme-report-environment 5)))))) (tn "null-environment") (if (and #f (provided? "sigscheme")) (begin (assert-error (tn) (lambda () (eval '(+ 1 2) (null-environment 4)))) (assert-error (tn) (lambda () (eval '(+ 1 2) (null-environment 6)))))) (assert-error (tn) (lambda () (eval '(+ 1 2) (null-environment 'symbol)))) (assert-error (tn) (lambda () (eval '(+ 1 2) (null-environment "string")))) (assert-error (tn) (lambda () (eval '(+ 1 2) (null-environment #\a)))) (assert-equal? (tn) 3 (eval '(+ 1 2) (null-environment 5))) ;; R5RS: 6.5 Eval ;; `eval' is not allowed to create new bindings in the environments associated ;; with `null-environment' or `scheme-report-environment'. ;; FIXME: SigScheme does not support this yet. (if (and #f (provided? "sigscheme")) (begin (assert-error (tn) (lambda () ;; Although other implementations evaluate this ;; expression without error (with or without 'foo' ;; defined), SigScheme will adopt this behavior. (eval '(define foo 1) (null-environment 5)))) (assert-error (tn) (lambda () (eval 'use (null-environment 5)))) (assert-error (tn) (lambda () (eval 'procedure? (null-environment 5)))))) (if (provided? "sigscheme") (begin (tn "eval with handmade env") ;; single frame (assert-equal? (tn) 10 (eval '(+ x y) '(((x y) . (4 6))))) ;; 2 frames (assert-equal? (tn) 15 (eval '(+ x y z) '(((x y) . (4 6)) ((z) . (5))))) ;; 3 frames (assert-equal? (tn) 14 (eval '(+ x y z v w) '(((x y) . (4 6)) ((v w) . (0 -1)) ((z) . (5))))) ;; dotted arg as formals (assert-equal? (tn) 44 (eval '(apply + lst) '(((x y . lst) . (4 6 8 10 12 14)) ((z) . (5))))) ;; symbol as formals (assert-equal? (tn) 54 (eval '(apply + lst) '((lst . (4 6 8 10 12 14)) ((z) . (5))))) (tn "eval with invalid handmade env") ;; improper frame list (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y) . (4 6)) . #t)))) ;; actuals shortage (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y z) . (4 6)))))) ;; actuals shortage #2 (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y . z) . (4)))))) ;; superfluous actuals (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y) . (4 6 8)))))) ;; dotted actuals (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y) . (4 . 6)))))) ;; dotted actuals #2 (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x y) . (4 6 . 8)))))) ;; dotted actuals #3 ;; This pattern has been allowd when let-optionals* is introduced. (assert-equal? (tn) '(4 (6 . 8)) (eval '(list x y) '(((x . y) . (4 6 . 8))))) ;; not a symbol in formals (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x 3) . (4 6)))))) ;; not a list as actuals (assert-error (tn) (lambda () (eval '(+ 1 2) '(((x) . 4) ((y) . 6))))) ;; not a list as both formals and actuals ;; This pattern has been allowd when let-optionals* is introduced. (assert-equal? (tn) '(4 6) (eval '(list x y) '((x . 4) (y . 6)))))) (total-report) uim-1.8.8/sigscheme/test/bigloo-letrec.scm0000644000175000017500000001115112532333147015426 00000000000000;; A practical implementation for the Scheme programming language ;; ;; ,--^, ;; _ ___/ /|/ ;; ,;'( )__, ) ' ;; ;; // L__. ;; ' \\ / ' ;; ^ ^ ;; ;; Copyright (c) 1992-2004 Manuel Serrano ;; ;; Bug descriptions, use reports, comments or suggestions are ;; welcome. Send them to ;; bigloo@sophia.inria.fr ;; http://www.inria.fr/mimosa/fp/Bigloo ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. More precisely, ;; ;; - The compiler and the tools are distributed under the terms of the ;; GNU General Public License. ;; ;; - The Bigloo run-time system and the libraries are distributed under ;; the terms of the GNU Library General Public License. The source code ;; of the Bigloo runtime system is located in the ./runtime directory. ;; The source code of the FairThreads library is located in the ;; ./fthread directory. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/recette/letrec.scm */ ;* */ ;* Author : Manuel Serrano */ ;* Creation : Tue Nov 17 19:18:37 1992 */ ;* Last change : Fri Jul 6 09:38:02 2001 (serrano) */ ;* */ ;* On test `letrec' */ ;*---------------------------------------------------------------------*/ ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Bigloo 2.6e and adapted to SigScheme (load "./test/unittest-bigloo.scm") ;*---------------------------------------------------------------------*/ ;* test1 ... */ ;*---------------------------------------------------------------------*/ (define (test1 y) (letrec ((x (number->string y)) (foo (lambda (string) (string->symbol (string-append string x))))) foo)) ;*---------------------------------------------------------------------*/ ;* plante1 */ ;* ------------------------------------------------------------- */ ;* un test qui plantait a la compilation */ ;*---------------------------------------------------------------------*/ (define (foo a) (letrec ((foo (lambda (x) (bar 0) (set! foo 8) 'done)) (bar (lambda (x) (if (= x 0) 'done (foo x))))) (foo a))) ;*---------------------------------------------------------------------*/ ;* test-letrec ... */ ;*---------------------------------------------------------------------*/ (define (test-letrec) (test "letrec" ((test1 1) "TOTO") 'TOTO1) (test "letrec" (foo 10) 'done) ;; implementation-dependent test -- YamaKen 2007-07-18 ;;(test "delay" (procedure? (letrec ((foo (delay foo))) (force foo))) #t) ) (test-letrec) (total-report) uim-1.8.8/sigscheme/test/Makefile.in0000644000175000017500000014737413275405265014267 00000000000000# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ @USE_UTF8_TRUE@am__append_1 = test-enc-utf8.scm @USE_UTF8_FALSE@am__append_2 = test-enc-utf8.scm @USE_EUCCN_TRUE@am__append_3 = test-enc-eucgeneric.scm @USE_EUCCN_FALSE@am__append_4 = test-enc-eucgeneric.scm @USE_EUCJP_TRUE@am__append_5 = test-enc-eucjp.scm test-char.scm @USE_EUCJP_FALSE@am__append_6 = test-enc-eucjp.scm test-char.scm @USE_SJIS_TRUE@am__append_7 = test-enc-sjis.scm @USE_SJIS_FALSE@am__append_8 = test-enc-sjis.scm @USE_SHELL_TRUE@TESTS = $(sscm_tests) $(sscm_optional_tests) subdir = test ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_c___attribute__.m4 \ $(top_srcdir)/m4/ax_c_arithmetic_rshift.m4 \ $(top_srcdir)/m4/ax_c_referenceable_passed_va_list.m4 \ $(top_srcdir)/m4/ax_cflags_gcc_option.m4 \ $(top_srcdir)/m4/ax_check_page_aligned_malloc.m4 \ $(top_srcdir)/m4/ax_create_stdint_h.m4 \ $(top_srcdir)/m4/ax_feature_configurator.m4 \ $(top_srcdir)/m4/ax_func_getcontext.m4 \ $(top_srcdir)/m4/ax_func_sigsetjmp.m4 \ $(top_srcdir)/m4/ax_lib_glibc.m4 \ $(top_srcdir)/m4/check_gnu_make.m4 $(top_srcdir)/m4/libtool.m4 \ $(top_srcdir)/m4/ltoptions.m4 $(top_srcdir)/m4/ltsugar.m4 \ $(top_srcdir)/m4/ltversion.m4 $(top_srcdir)/m4/lt~obsolete.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/src/config.h CONFIG_CLEAN_FILES = run-singletest.sh CONFIG_CLEAN_VPATH_FILES = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = SOURCES = DIST_SOURCES = am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) am__tty_colors_dummy = \ mgn= red= grn= lgn= blu= brg= std=; \ am__color_tests=no am__tty_colors = { \ $(am__tty_colors_dummy); \ if test "X$(AM_COLOR_TESTS)" = Xno; then \ am__color_tests=no; \ elif test "X$(AM_COLOR_TESTS)" = Xalways; then \ am__color_tests=yes; \ elif test "X$$TERM" != Xdumb && { test -t 1; } 2>/dev/null; then \ am__color_tests=yes; \ fi; \ if test $$am__color_tests = yes; then \ red=''; \ grn=''; \ lgn=''; \ blu=''; \ mgn=''; \ brg=''; \ std=''; \ fi; \ } am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } am__recheck_rx = ^[ ]*:recheck:[ ]* am__global_test_result_rx = ^[ ]*:global-test-result:[ ]* am__copy_in_global_log_rx = ^[ ]*:copy-in-global-log:[ ]* # A command that, given a newline-separated list of test names on the # standard input, print the name of the tests that are to be re-run # upon "make recheck". am__list_recheck_tests = $(AWK) '{ \ recheck = 1; \ while ((rc = (getline line < ($$0 ".trs"))) != 0) \ { \ if (rc < 0) \ { \ if ((getline line2 < ($$0 ".log")) < 0) \ recheck = 0; \ break; \ } \ else if (line ~ /$(am__recheck_rx)[nN][Oo]/) \ { \ recheck = 0; \ break; \ } \ else if (line ~ /$(am__recheck_rx)[yY][eE][sS]/) \ { \ break; \ } \ }; \ if (recheck) \ print $$0; \ close ($$0 ".trs"); \ close ($$0 ".log"); \ }' # A command that, given a newline-separated list of test names on the # standard input, create the global log from their .trs and .log files. am__create_global_log = $(AWK) ' \ function fatal(msg) \ { \ print "fatal: making $@: " msg | "cat >&2"; \ exit 1; \ } \ function rst_section(header) \ { \ print header; \ len = length(header); \ for (i = 1; i <= len; i = i + 1) \ printf "="; \ printf "\n\n"; \ } \ { \ copy_in_global_log = 1; \ global_test_result = "RUN"; \ while ((rc = (getline line < ($$0 ".trs"))) != 0) \ { \ if (rc < 0) \ fatal("failed to read from " $$0 ".trs"); \ if (line ~ /$(am__global_test_result_rx)/) \ { \ sub("$(am__global_test_result_rx)", "", line); \ sub("[ ]*$$", "", line); \ global_test_result = line; \ } \ else if (line ~ /$(am__copy_in_global_log_rx)[nN][oO]/) \ copy_in_global_log = 0; \ }; \ if (copy_in_global_log) \ { \ rst_section(global_test_result ": " $$0); \ while ((rc = (getline line < ($$0 ".log"))) != 0) \ { \ if (rc < 0) \ fatal("failed to read from " $$0 ".log"); \ print line; \ }; \ printf "\n"; \ }; \ close ($$0 ".trs"); \ close ($$0 ".log"); \ }' # Restructured Text title. am__rst_title = { sed 's/.*/ & /;h;s/./=/g;p;x;s/ *$$//;p;g' && echo; } # Solaris 10 'make', and several other traditional 'make' implementations, # pass "-e" to $(SHELL), and POSIX 2008 even requires this. Work around it # by disabling -e (using the XSI extension "set +e") if it's set. am__sh_e_setup = case $$- in *e*) set +e;; esac # Default flags passed to test drivers. am__common_driver_flags = \ --color-tests "$$am__color_tests" \ --enable-hard-errors "$$am__enable_hard_errors" \ --expect-failure "$$am__expect_failure" # To be inserted before the command running the test. Creates the # directory for the log if needed. Stores in $dir the directory # containing $f, in $tst the test, in $log the log. Executes the # developer- defined test setup AM_TESTS_ENVIRONMENT (if any), and # passes TESTS_ENVIRONMENT. Set up options for the wrapper that # will run the test scripts (or their associated LOG_COMPILER, if # thy have one). am__check_pre = \ $(am__sh_e_setup); \ $(am__vpath_adj_setup) $(am__vpath_adj) \ $(am__tty_colors); \ srcdir=$(srcdir); export srcdir; \ case "$@" in \ */*) am__odir=`echo "./$@" | sed 's|/[^/]*$$||'`;; \ *) am__odir=.;; \ esac; \ test "x$$am__odir" = x"." || test -d "$$am__odir" \ || $(MKDIR_P) "$$am__odir" || exit $$?; \ if test -f "./$$f"; then dir=./; \ elif test -f "$$f"; then dir=; \ else dir="$(srcdir)/"; fi; \ tst=$$dir$$f; log='$@'; \ if test -n '$(DISABLE_HARD_ERRORS)'; then \ am__enable_hard_errors=no; \ else \ am__enable_hard_errors=yes; \ fi; \ case " $(XFAIL_TESTS) " in \ *[\ \ ]$$f[\ \ ]* | *[\ \ ]$$dir$$f[\ \ ]*) \ am__expect_failure=yes;; \ *) \ am__expect_failure=no;; \ esac; \ $(AM_TESTS_ENVIRONMENT) $(TESTS_ENVIRONMENT) # A shell command to get the names of the tests scripts with any registered # extension removed (i.e., equivalently, the names of the test logs, with # the '.log' extension removed). The result is saved in the shell variable # '$bases'. This honors runtime overriding of TESTS and TEST_LOGS. Sadly, # we cannot use something simpler, involving e.g., "$(TEST_LOGS:.log=)", # since that might cause problem with VPATH rewrites for suffix-less tests. # See also 'test-harness-vpath-rewrite.sh' and 'test-trs-basic.sh'. am__set_TESTS_bases = \ bases='$(TEST_LOGS)'; \ bases=`for i in $$bases; do echo $$i; done | sed 's/\.log$$//'`; \ bases=`echo $$bases` RECHECK_LOGS = $(TEST_LOGS) AM_RECURSIVE_TARGETS = check recheck TEST_SUITE_LOG = test-suite.log TEST_EXTENSIONS = @EXEEXT@ .test LOG_DRIVER = $(SHELL) $(top_srcdir)/test-driver LOG_COMPILE = $(LOG_COMPILER) $(AM_LOG_FLAGS) $(LOG_FLAGS) am__set_b = \ case '$@' in \ */*) \ case '$*' in \ */*) b='$*';; \ *) b=`echo '$@' | sed 's/\.log$$//'`; \ esac;; \ *) \ b='$*';; \ esac am__test_logs1 = $(TESTS:=.log) am__test_logs2 = $(am__test_logs1:@EXEEXT@.log=.log) TEST_LOGS = $(am__test_logs2:.test.log=.log) TEST_LOG_DRIVER = $(SHELL) $(top_srcdir)/test-driver TEST_LOG_COMPILE = $(TEST_LOG_COMPILER) $(AM_TEST_LOG_FLAGS) \ $(TEST_LOG_FLAGS) am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/run-singletest.sh.in \ $(top_srcdir)/test-driver DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ ASCIIDOC = @ASCIIDOC@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ FGREP = @FGREP@ GCROOTS_CFLAGS = @GCROOTS_CFLAGS@ GCROOTS_LIBS = @GCROOTS_LIBS@ GCROOTS_REQ = @GCROOTS_REQ@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MD5 = @MD5@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ PERL = @PERL@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ RANLIB = @RANLIB@ RUBY = @RUBY@ SED = @SED@ SET_MAKE = @SET_MAKE@ SH = @SH@ SHA1 = @SHA1@ SHELL = @SHELL@ SSCM_DEFS = @SSCM_DEFS@ SSCM_MASTER_PKG = @SSCM_MASTER_PKG@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ ifGNUmake = @ifGNUmake@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ runstatedir = @runstatedir@ sbindir = @sbindir@ scmlibdir = @scmlibdir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ subdirs = @subdirs@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ use_backtrace = @use_backtrace@ use_char = @use_char@ use_compat_siod = @use_compat_siod@ use_compat_siod_bugs = @use_compat_siod_bugs@ use_const_list_literal = @use_const_list_literal@ use_const_vector_literal = @use_const_vector_literal@ use_continuation = @use_continuation@ use_debug = @use_debug@ use_deep_cadrs = @use_deep_cadrs@ use_default_encoding = @use_default_encoding@ use_euccn = @use_euccn@ use_eucjp = @use_eucjp@ use_euckr = @use_euckr@ use_eval_c_string = @use_eval_c_string@ use_fixnum = @use_fixnum@ use_hygienic_macro = @use_hygienic_macro@ use_int = @use_int@ use_internal_definitions = @use_internal_definitions@ use_legacy_macro = @use_legacy_macro@ use_load = @use_load@ use_multibyte_char = @use_multibyte_char@ use_number_io = @use_number_io@ use_port = @use_port@ use_promise = @use_promise@ use_quasiquote = @use_quasiquote@ use_r6rs_chars = @use_r6rs_chars@ use_r6rs_named_chars = @use_r6rs_named_chars@ use_reader = @use_reader@ use_sjis = @use_sjis@ use_srfi0 = @use_srfi0@ use_srfi1 = @use_srfi1@ use_srfi2 = @use_srfi2@ use_srfi22 = @use_srfi22@ use_srfi23 = @use_srfi23@ use_srfi28 = @use_srfi28@ use_srfi34 = @use_srfi34@ use_srfi38 = @use_srfi38@ use_srfi43 = @use_srfi43@ use_srfi48 = @use_srfi48@ use_srfi55 = @use_srfi55@ use_srfi6 = @use_srfi6@ use_srfi60 = @use_srfi60@ use_srfi69 = @use_srfi69@ use_srfi8 = @use_srfi8@ use_srfi9 = @use_srfi9@ use_srfi95 = @use_srfi95@ use_sscm_extensions = @use_sscm_extensions@ use_sscm_format_extension = @use_sscm_format_extension@ use_storage = @use_storage@ use_strict_argcheck = @use_strict_argcheck@ use_strict_null_form = @use_strict_null_form@ use_strict_r5rs = @use_strict_r5rs@ use_strict_toplevel_definitions = @use_strict_toplevel_definitions@ use_strict_vector_form = @use_strict_vector_form@ use_string = @use_string@ use_string_procedure = @use_string_procedure@ use_utf8 = @use_utf8@ use_vector = @use_vector@ use_writer = @use_writer@ # Libraries # Not included to the distribution since their original license is unknown. #imported_tests += stone-srfi1.scm #imported_tests += panu-srfi69.scm EXTRA_DIST = unittest-bigloo.scm unittest-gauche.scm \ run-singletest.sh.in test-enc-utf8.scm test-enc-eucgeneric.scm \ test-enc-eucjp.scm test-char.scm test-enc-sjis.scm \ test-tail-rec.scm $(sscm_tests) $(imported_tests) sscm_xfail_tests = test-fail.scm $(am__append_2) $(am__append_4) \ $(am__append_6) $(am__append_8) sscm_optional_tests = $(am__append_1) $(am__append_3) $(am__append_5) \ $(am__append_7) # Native tests of SigScheme sscm_tests = \ test-apply.scm \ test-assoc.scm \ test-begin.scm \ test-bool.scm \ test-char-cmp.scm \ test-char-pred.scm \ test-continuation.scm \ test-define.scm \ test-define-internal.scm \ test-do.scm \ test-dyn-extent.scm \ test-eq.scm \ test-eqv.scm \ test-equal.scm \ test-eval.scm \ test-fail.scm \ test-formal-syntax.scm \ test-formatplus.scm \ test-lambda.scm \ test-legacy-macro.scm \ test-let.scm \ test-letstar.scm \ test-letrec.scm \ test-list.scm \ test-map.scm \ test-member.scm \ test-misc.scm \ test-named-let.scm \ test-number-arith.scm \ test-number-cmp.scm \ test-number-literal.scm \ test-number-io.scm \ test-number-pred.scm \ test-obsolete.scm \ test-pair.scm \ test-quote.scm \ test-srfi0.scm \ test-srfi1-another.scm \ test-srfi1-obsolete.scm \ test-srfi2.scm \ test-srfi6.scm \ test-srfi8.scm \ test-srfi9.scm \ test-srfi28.scm \ test-srfi34.scm \ test-srfi34-2.scm \ test-srfi38.scm \ test-srfi43.scm \ test-srfi48.scm \ test-srfi55.scm \ test-srfi60.scm \ test-sscm-ext.scm \ test-string-cmp.scm \ test-string-core.scm \ test-string-null.scm \ test-string-proc.scm \ test-string.scm \ test-symbol.scm \ test-syntax-rules.scm \ test-syntax.scm \ test-unittest.scm \ test-values.scm \ test-vector.scm # Imported foreign tests imported_tests = \ scm-r4rstest.scm \ bigloo-apply.scm \ bigloo-bchar.scm \ bigloo-bool.scm \ bigloo-case.scm \ bigloo-letrec.scm \ bigloo-list.scm \ bigloo-quote.scm \ bigloo-vector.scm \ gauche-euc-jp.scm \ gauche-let-optionals.scm \ gauche-primsyn.scm \ oleg-srfi2.scm LOG_COMPILER = $(SH) AM_LOG_FLAGS = $(top_builddir)/test/run-singletest.sh @USE_SHELL_FALSE@XFAIL_TESTS = $(sscm_tests) $(sscm_xfail_tests) @USE_SHELL_TRUE@XFAIL_TESTS = $(sscm_xfail_tests) DISTCLEANFILES = run-singletest.sh all: all-am .SUFFIXES: .SUFFIXES: .log .test .test$(EXEEXT) .trs $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign test/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --foreign test/Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): run-singletest.sh: $(top_builddir)/config.status $(srcdir)/run-singletest.sh.in cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs tags TAGS: ctags CTAGS: cscope cscopelist: # Recover from deleted '.trs' file; this should ensure that # "rm -f foo.log; make foo.trs" re-run 'foo.test', and re-create # both 'foo.log' and 'foo.trs'. Break the recipe in two subshells # to avoid problems with "make -n". .log.trs: rm -f $< $@ $(MAKE) $(AM_MAKEFLAGS) $< # Leading 'am--fnord' is there to ensure the list of targets does not # expand to empty, as could happen e.g. with make check TESTS=''. am--fnord $(TEST_LOGS) $(TEST_LOGS:.log=.trs): $(am__force_recheck) am--force-recheck: @: $(TEST_SUITE_LOG): $(TEST_LOGS) @$(am__set_TESTS_bases); \ am__f_ok () { test -f "$$1" && test -r "$$1"; }; \ redo_bases=`for i in $$bases; do \ am__f_ok $$i.trs && am__f_ok $$i.log || echo $$i; \ done`; \ if test -n "$$redo_bases"; then \ redo_logs=`for i in $$redo_bases; do echo $$i.log; done`; \ redo_results=`for i in $$redo_bases; do echo $$i.trs; done`; \ if $(am__make_dryrun); then :; else \ rm -f $$redo_logs && rm -f $$redo_results || exit 1; \ fi; \ fi; \ if test -n "$$am__remaking_logs"; then \ echo "fatal: making $(TEST_SUITE_LOG): possible infinite" \ "recursion detected" >&2; \ elif test -n "$$redo_logs"; then \ am__remaking_logs=yes $(MAKE) $(AM_MAKEFLAGS) $$redo_logs; \ fi; \ if $(am__make_dryrun); then :; else \ st=0; \ errmsg="fatal: making $(TEST_SUITE_LOG): failed to create"; \ for i in $$redo_bases; do \ test -f $$i.trs && test -r $$i.trs \ || { echo "$$errmsg $$i.trs" >&2; st=1; }; \ test -f $$i.log && test -r $$i.log \ || { echo "$$errmsg $$i.log" >&2; st=1; }; \ done; \ test $$st -eq 0 || exit 1; \ fi @$(am__sh_e_setup); $(am__tty_colors); $(am__set_TESTS_bases); \ ws='[ ]'; \ results=`for b in $$bases; do echo $$b.trs; done`; \ test -n "$$results" || results=/dev/null; \ all=` grep "^$$ws*:test-result:" $$results | wc -l`; \ pass=` grep "^$$ws*:test-result:$$ws*PASS" $$results | wc -l`; \ fail=` grep "^$$ws*:test-result:$$ws*FAIL" $$results | wc -l`; \ skip=` grep "^$$ws*:test-result:$$ws*SKIP" $$results | wc -l`; \ xfail=`grep "^$$ws*:test-result:$$ws*XFAIL" $$results | wc -l`; \ xpass=`grep "^$$ws*:test-result:$$ws*XPASS" $$results | wc -l`; \ error=`grep "^$$ws*:test-result:$$ws*ERROR" $$results | wc -l`; \ if test `expr $$fail + $$xpass + $$error` -eq 0; then \ success=true; \ else \ success=false; \ fi; \ br='==================='; br=$$br$$br$$br$$br; \ result_count () \ { \ if test x"$$1" = x"--maybe-color"; then \ maybe_colorize=yes; \ elif test x"$$1" = x"--no-color"; then \ maybe_colorize=no; \ else \ echo "$@: invalid 'result_count' usage" >&2; exit 4; \ fi; \ shift; \ desc=$$1 count=$$2; \ if test $$maybe_colorize = yes && test $$count -gt 0; then \ color_start=$$3 color_end=$$std; \ else \ color_start= color_end=; \ fi; \ echo "$${color_start}# $$desc $$count$${color_end}"; \ }; \ create_testsuite_report () \ { \ result_count $$1 "TOTAL:" $$all "$$brg"; \ result_count $$1 "PASS: " $$pass "$$grn"; \ result_count $$1 "SKIP: " $$skip "$$blu"; \ result_count $$1 "XFAIL:" $$xfail "$$lgn"; \ result_count $$1 "FAIL: " $$fail "$$red"; \ result_count $$1 "XPASS:" $$xpass "$$red"; \ result_count $$1 "ERROR:" $$error "$$mgn"; \ }; \ { \ echo "$(PACKAGE_STRING): $(subdir)/$(TEST_SUITE_LOG)" | \ $(am__rst_title); \ create_testsuite_report --no-color; \ echo; \ echo ".. contents:: :depth: 2"; \ echo; \ for b in $$bases; do echo $$b; done \ | $(am__create_global_log); \ } >$(TEST_SUITE_LOG).tmp || exit 1; \ mv $(TEST_SUITE_LOG).tmp $(TEST_SUITE_LOG); \ if $$success; then \ col="$$grn"; \ else \ col="$$red"; \ test x"$$VERBOSE" = x || cat $(TEST_SUITE_LOG); \ fi; \ echo "$${col}$$br$${std}"; \ echo "$${col}Testsuite summary for $(PACKAGE_STRING)$${std}"; \ echo "$${col}$$br$${std}"; \ create_testsuite_report --maybe-color; \ echo "$$col$$br$$std"; \ if $$success; then :; else \ echo "$${col}See $(subdir)/$(TEST_SUITE_LOG)$${std}"; \ if test -n "$(PACKAGE_BUGREPORT)"; then \ echo "$${col}Please report to $(PACKAGE_BUGREPORT)$${std}"; \ fi; \ echo "$$col$$br$$std"; \ fi; \ $$success || exit 1 check-TESTS: @list='$(RECHECK_LOGS)'; test -z "$$list" || rm -f $$list @list='$(RECHECK_LOGS:.log=.trs)'; test -z "$$list" || rm -f $$list @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) @set +e; $(am__set_TESTS_bases); \ log_list=`for i in $$bases; do echo $$i.log; done`; \ trs_list=`for i in $$bases; do echo $$i.trs; done`; \ log_list=`echo $$log_list`; trs_list=`echo $$trs_list`; \ $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) TEST_LOGS="$$log_list"; \ exit $$?; recheck: all @test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) @set +e; $(am__set_TESTS_bases); \ bases=`for i in $$bases; do echo $$i; done \ | $(am__list_recheck_tests)` || exit 1; \ log_list=`for i in $$bases; do echo $$i.log; done`; \ log_list=`echo $$log_list`; \ $(MAKE) $(AM_MAKEFLAGS) $(TEST_SUITE_LOG) \ am__force_recheck=am--force-recheck \ TEST_LOGS="$$log_list"; \ exit $$? test-apply.scm.log: test-apply.scm @p='test-apply.scm'; \ b='test-apply.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-assoc.scm.log: test-assoc.scm @p='test-assoc.scm'; \ b='test-assoc.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-begin.scm.log: test-begin.scm @p='test-begin.scm'; \ b='test-begin.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-bool.scm.log: test-bool.scm @p='test-bool.scm'; \ b='test-bool.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-char-cmp.scm.log: test-char-cmp.scm @p='test-char-cmp.scm'; \ b='test-char-cmp.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-char-pred.scm.log: test-char-pred.scm @p='test-char-pred.scm'; \ b='test-char-pred.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-continuation.scm.log: test-continuation.scm @p='test-continuation.scm'; \ b='test-continuation.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-define.scm.log: test-define.scm @p='test-define.scm'; \ b='test-define.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-define-internal.scm.log: test-define-internal.scm @p='test-define-internal.scm'; \ b='test-define-internal.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-do.scm.log: test-do.scm @p='test-do.scm'; \ b='test-do.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-dyn-extent.scm.log: test-dyn-extent.scm @p='test-dyn-extent.scm'; \ b='test-dyn-extent.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-eq.scm.log: test-eq.scm @p='test-eq.scm'; \ b='test-eq.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-eqv.scm.log: test-eqv.scm @p='test-eqv.scm'; \ b='test-eqv.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-equal.scm.log: test-equal.scm @p='test-equal.scm'; \ b='test-equal.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-eval.scm.log: test-eval.scm @p='test-eval.scm'; \ b='test-eval.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-fail.scm.log: test-fail.scm @p='test-fail.scm'; \ b='test-fail.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-formal-syntax.scm.log: test-formal-syntax.scm @p='test-formal-syntax.scm'; \ b='test-formal-syntax.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-formatplus.scm.log: test-formatplus.scm @p='test-formatplus.scm'; \ b='test-formatplus.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-lambda.scm.log: test-lambda.scm @p='test-lambda.scm'; \ b='test-lambda.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-legacy-macro.scm.log: test-legacy-macro.scm @p='test-legacy-macro.scm'; \ b='test-legacy-macro.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-let.scm.log: test-let.scm @p='test-let.scm'; \ b='test-let.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-letstar.scm.log: test-letstar.scm @p='test-letstar.scm'; \ b='test-letstar.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-letrec.scm.log: test-letrec.scm @p='test-letrec.scm'; \ b='test-letrec.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-list.scm.log: test-list.scm @p='test-list.scm'; \ b='test-list.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-map.scm.log: test-map.scm @p='test-map.scm'; \ b='test-map.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-member.scm.log: test-member.scm @p='test-member.scm'; \ b='test-member.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-misc.scm.log: test-misc.scm @p='test-misc.scm'; \ b='test-misc.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-named-let.scm.log: test-named-let.scm @p='test-named-let.scm'; \ b='test-named-let.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-number-arith.scm.log: test-number-arith.scm @p='test-number-arith.scm'; \ b='test-number-arith.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-number-cmp.scm.log: test-number-cmp.scm @p='test-number-cmp.scm'; \ b='test-number-cmp.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-number-literal.scm.log: test-number-literal.scm @p='test-number-literal.scm'; \ b='test-number-literal.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-number-io.scm.log: test-number-io.scm @p='test-number-io.scm'; \ b='test-number-io.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-number-pred.scm.log: test-number-pred.scm @p='test-number-pred.scm'; \ b='test-number-pred.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-obsolete.scm.log: test-obsolete.scm @p='test-obsolete.scm'; \ b='test-obsolete.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-pair.scm.log: test-pair.scm @p='test-pair.scm'; \ b='test-pair.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-quote.scm.log: test-quote.scm @p='test-quote.scm'; \ b='test-quote.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi0.scm.log: test-srfi0.scm @p='test-srfi0.scm'; \ b='test-srfi0.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi1-another.scm.log: test-srfi1-another.scm @p='test-srfi1-another.scm'; \ b='test-srfi1-another.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi1-obsolete.scm.log: test-srfi1-obsolete.scm @p='test-srfi1-obsolete.scm'; \ b='test-srfi1-obsolete.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi2.scm.log: test-srfi2.scm @p='test-srfi2.scm'; \ b='test-srfi2.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi6.scm.log: test-srfi6.scm @p='test-srfi6.scm'; \ b='test-srfi6.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi8.scm.log: test-srfi8.scm @p='test-srfi8.scm'; \ b='test-srfi8.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi9.scm.log: test-srfi9.scm @p='test-srfi9.scm'; \ b='test-srfi9.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi28.scm.log: test-srfi28.scm @p='test-srfi28.scm'; \ b='test-srfi28.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi34.scm.log: test-srfi34.scm @p='test-srfi34.scm'; \ b='test-srfi34.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi34-2.scm.log: test-srfi34-2.scm @p='test-srfi34-2.scm'; \ b='test-srfi34-2.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi38.scm.log: test-srfi38.scm @p='test-srfi38.scm'; \ b='test-srfi38.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi43.scm.log: test-srfi43.scm @p='test-srfi43.scm'; \ b='test-srfi43.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi48.scm.log: test-srfi48.scm @p='test-srfi48.scm'; \ b='test-srfi48.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi55.scm.log: test-srfi55.scm @p='test-srfi55.scm'; \ b='test-srfi55.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-srfi60.scm.log: test-srfi60.scm @p='test-srfi60.scm'; \ b='test-srfi60.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-sscm-ext.scm.log: test-sscm-ext.scm @p='test-sscm-ext.scm'; \ b='test-sscm-ext.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-string-cmp.scm.log: test-string-cmp.scm @p='test-string-cmp.scm'; \ b='test-string-cmp.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-string-core.scm.log: test-string-core.scm @p='test-string-core.scm'; \ b='test-string-core.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-string-null.scm.log: test-string-null.scm @p='test-string-null.scm'; \ b='test-string-null.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-string-proc.scm.log: test-string-proc.scm @p='test-string-proc.scm'; \ b='test-string-proc.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-string.scm.log: test-string.scm @p='test-string.scm'; \ b='test-string.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-symbol.scm.log: test-symbol.scm @p='test-symbol.scm'; \ b='test-symbol.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-syntax-rules.scm.log: test-syntax-rules.scm @p='test-syntax-rules.scm'; \ b='test-syntax-rules.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-syntax.scm.log: test-syntax.scm @p='test-syntax.scm'; \ b='test-syntax.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-unittest.scm.log: test-unittest.scm @p='test-unittest.scm'; \ b='test-unittest.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-values.scm.log: test-values.scm @p='test-values.scm'; \ b='test-values.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-vector.scm.log: test-vector.scm @p='test-vector.scm'; \ b='test-vector.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-enc-utf8.scm.log: test-enc-utf8.scm @p='test-enc-utf8.scm'; \ b='test-enc-utf8.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-enc-eucgeneric.scm.log: test-enc-eucgeneric.scm @p='test-enc-eucgeneric.scm'; \ b='test-enc-eucgeneric.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-enc-eucjp.scm.log: test-enc-eucjp.scm @p='test-enc-eucjp.scm'; \ b='test-enc-eucjp.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-char.scm.log: test-char.scm @p='test-char.scm'; \ b='test-char.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) test-enc-sjis.scm.log: test-enc-sjis.scm @p='test-enc-sjis.scm'; \ b='test-enc-sjis.scm'; \ $(am__check_pre) $(LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_LOG_DRIVER_FLAGS) $(LOG_DRIVER_FLAGS) -- $(LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) .test.log: @p='$<'; \ $(am__set_b); \ $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ --log-file $$b.log --trs-file $$b.trs \ $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ "$$tst" $(AM_TESTS_FD_REDIRECT) @am__EXEEXT_TRUE@.test$(EXEEXT).log: @am__EXEEXT_TRUE@ @p='$<'; \ @am__EXEEXT_TRUE@ $(am__set_b); \ @am__EXEEXT_TRUE@ $(am__check_pre) $(TEST_LOG_DRIVER) --test-name "$$f" \ @am__EXEEXT_TRUE@ --log-file $$b.log --trs-file $$b.trs \ @am__EXEEXT_TRUE@ $(am__common_driver_flags) $(AM_TEST_LOG_DRIVER_FLAGS) $(TEST_LOG_DRIVER_FLAGS) -- $(TEST_LOG_COMPILE) \ @am__EXEEXT_TRUE@ "$$tst" $(AM_TESTS_FD_REDIRECT) distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am $(MAKE) $(AM_MAKEFLAGS) check-TESTS check: check-am all-am: Makefile installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: -test -z "$(TEST_LOGS)" || rm -f $(TEST_LOGS) -test -z "$(TEST_LOGS:.log=.trs)" || rm -f $(TEST_LOGS:.log=.trs) -test -z "$(TEST_SUITE_LOG)" || rm -f $(TEST_SUITE_LOG) clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-generic dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-generic mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: check-am install-am install-strip .PHONY: all all-am check check-TESTS check-am clean clean-generic \ clean-libtool cscopelist-am ctags-am distclean \ distclean-generic distclean-libtool distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-generic \ mostlyclean-libtool pdf pdf-am ps ps-am recheck tags-am \ uninstall uninstall-am .PRECIOUS: Makefile # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: uim-1.8.8/sigscheme/test/test-begin.scm0000644000175000017500000003464212532333147014752 00000000000000;; Filename : test-begin.scm ;; About : unit test for R5RS begin ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; R5RS: 7.1.6 Programs and definitions ;; ;; --> * ;; --> ;; | ;; | ;; | (begin +) ;; --> (define ) ;; | (define ( ) ) ;; | (begin *) ;; --> * ;; | * . ;; --> ;; (define-syntax ) (tn "top-level begin invalid forms") ;; 'if', 'and', 'or', 'cond', 'case' do not make environment so these ;; '(begin)'s are not internal definitions and invalid. ;; See also test-do.scm for more invalid definitions. ;; See also test-define.scm for top-level definitions. (if (provided? "strict-toplevel-definitions") (begin (assert-error (tn) (lambda () (eval '(if #t (begin)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(if #f #t (begin)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(and (begin)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(or (begin)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (#t (begin))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (else (begin))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (#t (begin))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (else (begin))) (interaction-environment)))))) (tn "top-level begin invalid forms (strict)") (if (provided? "strict-toplevel-definitions") (begin (assert-error (tn) (lambda () (eval '(if #t (begin (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(if #t (begin (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(if #f #t (begin (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(if #f #t (begin (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(and (begin (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(and (begin (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(or (begin (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(or (begin (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (#t (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (#t (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (else (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (else (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key ((key) (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key ((key) (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (else (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (else (begin (define var0 1) #t))) (interaction-environment)))))) (tn "top-level begin invalid forms (strict) 2") ;; top-level define cannot be placed under a non-begin structure even if ;; wrapped into top-level begin. (if (provided? "strict-toplevel-definitions") (begin (assert-error (tn) (lambda () (eval '(begin (if #t (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (if #t (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (if #f #t (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (if #f #t (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (and (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (and (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (or (begin (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (or (begin (define var0 1) #t))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (#t (begin (define var0 1))))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (#t (begin (define var0 1) #t)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (else (begin (define var0 1))))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (else (begin (define var0 1) #t)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key ((key) (begin (define var0 1))))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key ((key) (begin (define var0 1) #t)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key (else (begin (define var0 1))))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key (else (begin (define var0 1) #t)))) (interaction-environment)))))) (tn "top-level begin invalid forms (strict) 3") (if (provided? "strict-toplevel-definitions") (begin ;; top-level define cannot be placed under a non-begin structure even if ;; wrapped into top-level begin. (assert-error (tn) (lambda () (eval '(begin (if #t (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (if #f #t (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (and (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (or (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (#t (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (else (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key ((key) (define var0 1)))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key (else (define var0 1)))) (interaction-environment)))) ;; test being evaled at non-tail part of 'begin' (assert-error (tn) (lambda () (eval '(begin (if #t (define var0 1)) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (if #f #t (define var0 1)) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (and (define var0 1)) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (or (define var0 1)) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (#t (define var0 1))) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (cond (else (define var0 1))) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key ((key) (define var0 1))) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(begin (case 'key (else (define var0 1))) #t) (interaction-environment)))))) (tn "top-level begin valid forms") ;; '(begin)' is allowd at toplevel (if (provided? "sigscheme") (begin (assert-equal? (tn) (undef) (eval '(begin) (interaction-environment))) (assert-equal? (tn) (undef) (eval '(begin (begin)) (interaction-environment))))) ;; 'begin' does not create an environment (assert-false (tn) (symbol-bound? 'var1)) (begin (define var1 1)) (assert-equal? (tn) 1 var1) ;; duplicate definition is allowed (begin (define var1 3)) (assert-equal? (tn) 3 var1) (begin (define var1 4) (define var1 5)) (assert-equal? (tn) 5 var1) ;; intermixing expression and definition on top-level is valid (begin (+ 1 2) (define var2 1)) (assert-equal? (tn) 1 var2) (begin (define var3 1) (+ 1 2)) (assert-equal? (tn) 1 var3) (begin (define var4 1) (+ 1 2) (begin (define var5 1))) (assert-equal? (tn) 1 var4) (assert-equal? (tn) 1 var5) (total-report) uim-1.8.8/sigscheme/test/test-quote.scm0000644000175000017500000005315112532333147015017 00000000000000;; Filename : test-quote.scm ;; About : unit test for quote and quasiquote ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (symbol-bound? 'quasiquote)) (test-skip "R5RS quasiquote is not enabled")) (define tn test-name) (define *test-track-progress* #f) (tn "quote") (assert-equal? (tn) #f '#f) (assert-equal? (tn) #t '#t) (assert-equal? (tn) #\a '#\a) (assert-equal? (tn) #\a '#\a) (assert-equal? (tn) 1 '1) (assert-equal? (tn) -1 '-1) (assert-equal? (tn) 1 '#b1) (assert-equal? (tn) 1 '#o1) (assert-equal? (tn) 1 '#d1) (assert-equal? (tn) 1 '#x1) (assert-equal? (tn) "a" '"a") (assert-equal? (tn) (string->symbol "sym") 'sym) (assert-equal? (tn) (quote sym) 'sym) (assert-equal? (tn) (quote (quote sym)) ''sym) (assert-equal? (tn) (quote (quote (quote sym))) '''sym) (assert-equal? (tn) (list) '()) (assert-equal? (tn) (list 1) '(1)) (assert-equal? (tn) (vector) '#()) (assert-equal? (tn) (vector 1) '#(1)) (assert-true "quasiquote check #1" (equal? '(1 2 3) `(1 2 3))) (assert-true "quasiquote check #2" (equal? '(5) `(,(+ 2 3)))) (assert-true "unquote check" (equal? `(1 2 3) `(1 ,(+ 1 1) ,(+ 1 2)))) (assert-true "unquote-splicing check" (equal? `(1 2 3) `(1 ,@(cdr '(1 2)) 3))) (assert-true "mixed check" (equal? '(a 3 c 7 8 9) `(a ,(+ 1 2) c ,@(cdr '(6 7 8 9))))) (assert-equal? "nested quasiquote check #1" '(a `(b c ,() 0) 1) `(a `(b c ,(,@() ,@()) 0) 1)) (assert-equal? "nested quasiquote check #2" '(0 1) `(0 . ,(list 1))) (assert-equal? "nested quasiquote check #3" '(0 . 1) `(0 . ,'1)) (assert-equal? "nested quasiquote check #4" '(0 quasiquote (unquote 1)) `(0 . `,,(+ 1))) (assert-true "vector quasiquote check #1" (equal? '#(#(a b c d) e) `#(,@() #(a ,@(list 'b 'c) d) e))) (assert-equal? "vector quasiquote check #2" '(1 . #(2 3)) `(1 . #(,(+ 1 1) 3))) (assert-equal? "vector quasiquote check #3" '(0 . #(1 2 3 4 5 6)) `(0 . #(1 ,2 ,@(list 3 4) 5 ,6 ,@()))) (assert-equal? "vector quasiquote check #3" '#(a b) `#(,@(list 'a 'b))) (tn "quasiquote reference test of R5RS") (if (not (symbol-bound? 'sqrt)) (eval '(define sqrt (lambda (x) (cdr (assv x '((4 . 2) (9 . 3) (16 . 4)))))) (interaction-environment))) (assert-equal? (tn) '(list 3 4) `(list ,(+ 1 2) 4)) (assert-equal? (tn) '(list a (quote a)) (let ((name 'a)) `(list ,name ',name))) (assert-equal? (tn) '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) ;; Commented out since the test seems to wrong. Even if the interpretation for ;; the quote after foo (foo') may varied by implementation, at least the ;; quasiquote before foo (`foo) must be remained. ;; ;; SigScheme: (((quasiquote foo') 7) . cons) ;; Gauche: ((`foo '7) . cons) ;; Guile: (((quasiquote foo') 7) . cons) ;; Bigloo: (((quasiquote foo') 7) . cons) ;; Scheme48: (((quasiquote foo) '7) . cons) ;; SCM: (((quasiquote foo\') 7) . cons) ;; PLT: read: illegal use of backquote ;;(assert-equal? (tn) ;; '((foo 7) . cons) ;; `((`foo' ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) (assert-equal? (tn) '#(10 5 2 4 3 8) `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) (assert-equal? (tn) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) (assert-equal? (tn) '(a `(b ,x ,'y d) e) (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) (assert-equal? (tn) '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4))) (assert-equal? (tn) '`(list ,(+ 1 2) 4) '(quasiquote (list (unquote (+ 1 2)) 4))) (tn "quasiquote valid form") (assert-equal? (tn) ''1 `'1) (assert-equal? (tn) '`1 ``1) (assert-equal? (tn) 1 `,1) (assert-equal? (tn) ''1 `',1) (assert-equal? (tn) '(quote 1) `'1) (assert-equal? (tn) '(quasiquote 1) ``1) (assert-equal? (tn) '(quote 1) `',1) (assert-equal? (tn) '() `()) (assert-equal? (tn) '('1) `('1)) (assert-equal? (tn) '(`1) `(`1)) (assert-equal? (tn) '(1) `(,1)) (assert-equal? (tn) '('1) `(',1)) (assert-equal? (tn) '(1) `(,'1)) (assert-equal? (tn) '(1) `(,`1)) (assert-equal? (tn) '((quote 1)) `('1)) (assert-equal? (tn) '((quasiquote 1)) `(`1)) (assert-equal? (tn) '(1) `(,1)) (assert-equal? (tn) '((quote 1)) `(',1)) (assert-equal? (tn) '#() `#()) (assert-equal? (tn) '#('1) `#('1)) (assert-equal? (tn) '#(`1) `#(`1)) (assert-equal? (tn) '#(1) `#(,1)) (assert-equal? (tn) '#('1) `#(',1)) (assert-equal? (tn) '#(1) `#(,'1)) (assert-equal? (tn) '#(1) `#(,`1)) (tn "quasiquote nested") (assert-equal? (tn) '((quasiquote q) q) `(`q ,`q)) (assert-equal? (tn) '((quasiquote q) (q (quasiquote q))) `(`q ,`(q `q))) (assert-equal? (tn) '((quasiquote q) (q q)) `(`q ,`(q ,`q))) (assert-equal? (tn) '((quasiquote q) (q q (quasiquote q))) `(`q ,`(q ,`q `q))) (assert-equal? (tn) '((quasiquote q) (q q (quasiquote (unquote q)))) `(`q ,`(q ,`q `,q))) (assert-equal? (tn) '((quasiquote q) (q q (quasiquote (unquote (quasiquote q))))) `(`q ,`(q ,`q `,`q))) (assert-equal? (tn) '((quasiquote q) (q q (quasiquote (unquote q)))) `(`q ,`(q ,`q `,,`q))) (tn "unquote-splicing nested") (assert-equal? (tn) '(1 2) `(,@(list 1 2))) (assert-equal? (tn) '(quasiquote ((unquote-splicing (list 1 2)))) ``(,@(list 1 2))) (assert-equal? (tn) '(quasiquote (unquote (1 2))) ``,(,@(list 1 2))) ;; These tests show implementation-dependent behavior. But I believe that ;; SigScheme's implementation is conforming to following R5RS specification ;; better. Let me know if I'm misunderstanding. -- YamaKen 2006-06-25 ;; ;; R5RS: 7.1.4 Quasiquotations ;; ;; In s, a can sometimes be confused with ;; either an or a . The interpretation ;; as an or takes precedence. ;; Guile, Gauche, Bigloo, SCM ;;(assert-equal? (tn) ;; '(quasiquote ((unquote (unquote-splicing (list 1 2))))) ;; ``(,,@(list 1 2))) ;;(assert-equal? (tn) ;; '(quasiquote ((unquote (unquote-splicing (list 1 2))))) ;; (quasiquote ;; (quasiquote ;; ((unquote (unquote-splicing (list 1 2))))))) ;; SigScheme, Scheme48 (assert-equal? (tn) '(quasiquote ((unquote 1 2))) ``(,,@(list 1 2))) (assert-equal? (tn) '(quasiquote ((unquote 1 2))) (quasiquote (quasiquote ((unquote (unquote-splicing (list 1 2))))))) (assert-equal? (tn) '(quasiquote (list 1 2 (unquote-splicing (list 1 2)))) ``(list 1 2 ,@(list 1 2))) ;; Guile, Gauche, Bigloo, SCM ;;(assert-equal? (tn) ;; '(quasiquote ;; (list 1 2 (unquote (unquote-splicing (list 1 2))))) ;; ``(list 1 2 ,,@(list 1 2))) ;;(assert-equal? (tn) ;; '(quasiquote ;; (list 1 2 (unquote (unquote-splicing (list 1 2))))) ;; (quasiquote ;; (quasiquote ;; (list 1 2 (unquote (unquote-splicing (list 1 2))))))) ;; SigScheme, Scheme48 (assert-equal? (tn) '(quasiquote (list 1 2 (unquote 1 2))) ``(list 1 2 ,,@(list 1 2))) (assert-equal? (tn) '(quasiquote (list 1 2 (unquote 1 2))) (quasiquote (quasiquote (list 1 2 (unquote (unquote-splicing (list 1 2))))))) ;; Guile, Gauche, Bigloo, SCM ;;(assert-equal? (tn) ;; '((+ 1 2) ;; 3 ;; (list (+ 1 2) 3 1 2) ;; `(list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) ;; `(list ,(+ 1 2) ,3 ,,@(list 1 2))) ;; `((+ 1 2) ;; ,(+ 1 2) ;; (list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) ;; `(list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) ;; `(list ,(+ 1 2) ,,(+ 1 2) ,,@(list 1 2)))) ;; SigScheme, Scheme48 (assert-equal? (tn) '((+ 1 2) 3 (list (+ 1 2) 3 1 2) `(list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) `(list ,(+ 1 2) ,3 (unquote 1 2))) `((+ 1 2) ,(+ 1 2) (list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) `(list (+ 1 2) ,(+ 1 2) ,@(list 1 2)) `(list ,(+ 1 2) ,,(+ 1 2) ,,@(list 1 2)))) ;; R5RS allows these forms to be an error (tn "quasiquote implementation-dependent form") (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () `((quasiquote)))) (assert-error (tn) (lambda () `((quasiquote . 0)))) (assert-error (tn) (lambda () `((quasiquote 0 1)))) (assert-error (tn) (lambda () `((quasiquote 0 . 1)))) (assert-error (tn) (lambda () `(0 quasiquote))) (assert-error (tn) (lambda () `(0 . (quasiquote)))) (assert-error (tn) (lambda () `(0 quasiquote 2 3))) (assert-error (tn) (lambda () `(0 . (quasiquote 2 3)))) (assert-error (tn) (lambda () `(0 quasiquote 2 3 4))) (assert-error (tn) (lambda () `(0 . (quasiquote 2 3 4)))) (assert-error (tn) (lambda () `(0 quasiquote . 0))) (assert-error (tn) (lambda () `(0 . (quasiquote . 0)))) (assert-error (tn) (lambda () `(0 quasiquote 2 3 . 0))) (assert-error (tn) (lambda () `(0 . (quasiquote 2 3 . 0)))) (assert-error (tn) (lambda () `(0 quasiquote 2 3 4 . 0))) (assert-error (tn) (lambda () `(0 . (quasiquote 2 3 4 . 0)))))) (tn "unquote implementation-dependent form") (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () `((unquote)))) (assert-error (tn) (lambda () `((unquote . 0)))) (assert-error (tn) (lambda () `((unquote 0 1)))) (assert-error (tn) (lambda () `((unquote 0 . 1)))) (assert-error (tn) (lambda () `(0 unquote))) (assert-error (tn) (lambda () `(0 . (unquote)))) (assert-error (tn) (lambda () `(0 unquote 2 3))) (assert-error (tn) (lambda () `(0 . (unquote 2 3)))) (assert-error (tn) (lambda () `(0 unquote 2 3 4))) (assert-error (tn) (lambda () `(0 . (unquote 2 3 4)))) (assert-error (tn) (lambda () `(0 unquote . 0))) (assert-error (tn) (lambda () `(0 . (unquote . 0)))) (assert-error (tn) (lambda () `(0 unquote 2 3 . 0))) (assert-error (tn) (lambda () `(0 . (unquote 2 3 . 0)))) (assert-error (tn) (lambda () `(0 unquote 2 3 4 . 0))) (assert-error (tn) (lambda () `(0 . (unquote 2 3 4 . 0)))))) (tn "unquote-splicing implementation-dependent form") (if (provided? "sigscheme") (begin (assert-error (tn) (lambda () `(0 unquote-splicing))) (assert-error (tn) (lambda () `(0 . (unquote-splicing)))) (assert-error (tn) (lambda () `(0 unquote-splicing 2 3))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3)))) (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 4))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 4)))) (assert-error (tn) (lambda () `(0 unquote-splicing . 0))) (assert-error (tn) (lambda () `(0 . (unquote-splicing . 0)))) (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 . 0))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 . 0)))) (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 4 . 0))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 4 . 0)))) (assert-error (tn) (lambda () `((unquote-splicing)))) (assert-error (tn) (lambda () `((unquote-splicing . 0)))) (assert-error (tn) (lambda () `((unquote-splicing 0 1)))) (assert-error (tn) (lambda () `((unquote-splicing 0 . 1)))))) (tn "quasiquote dotted list") (assert-equal? (tn) '(0 . '1) `(0 . '1)) (assert-equal? (tn) '(0 . `1) `(0 . `1)) (assert-equal? (tn) '(0 . 1) `(0 . ,1)) (assert-equal? (tn) '(0 . (quote 1)) `(0 . '1)) (assert-equal? (tn) '(0 . (quasiquote 1)) `(0 . `1)) (assert-equal? (tn) '(0 . #(1)) `(0 . ,'#(1))) (assert-equal? (tn) '(0 . #(1)) `(0 . ,`#(1))) (assert-equal? (tn) '(0 . #(1 3)) `(0 . ,`#(1 ,(+ 1 2)))) (assert-equal? (tn) '(0 . #(1 -1 -2)) `(0 . ,`#(1 ,@(list (- 1) (- 2))))) (assert-error (tn) (lambda () `(0 . ,@()))) (assert-error (tn) (lambda () `(0 . ,@(list)))) (assert-error (tn) (lambda () `(0 . ,@(list 1)))) (assert-error (tn) (lambda () `(0 . ,@(list 1 2)))) (assert-error (tn) (lambda () `(0 . ,@(list 1 2 3)))) (assert-error (tn) (lambda () `(0 . ,@#t))) (assert-error (tn) (lambda () `(0 . ,@1))) (assert-error (tn) (lambda () `(0 . ,@#\a))) (assert-error (tn) (lambda () `(0 . ,@"str"))) (assert-error (tn) (lambda () `(0 . ,@'sym))) (assert-error (tn) (lambda () `(0 . ,@sym))) (assert-error (tn) (lambda () `(0 . ,@var))) (assert-error (tn) (lambda () `(0 . ,@(lambda () #f)))) (assert-error (tn) (lambda () `(0 . ,@(+ 1 2)))) (assert-error (tn) (lambda () `(0 . ,@#(1 2)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing ())))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (list))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1 2))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1 2 3))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing #t)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 1)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing #\a)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing "str")))) (assert-error (tn) (lambda () `(0 . (unquote-splicing 'sym)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing sym)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing var)))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (lambda () #f))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing (+ 1 2))))) (assert-error (tn) (lambda () `(0 . (unquote-splicing #(1 2))))) (tn "unquote valid form") (assert-equal? (tn) 1 `,1) (assert-equal? (tn) ',1 ',1) (assert-equal? (tn) '(quasiquote 1) ``1) (assert-equal? (tn) '(quasiquote (unquote 1)) ``,1) (assert-equal? (tn) '(quasiquote (unquote 1)) ``,,1) (assert-equal? (tn) '(quasiquote (+ 1 2)) ``(+ 1 2)) (assert-equal? (tn) '(quasiquote (unquote (+ 1 2))) ``,(+ 1 2)) (assert-equal? (tn) '(quasiquote (unquote 3)) ``,,(+ 1 2)) (assert-equal? (tn) '(quasiquote (list 1 2 (+ 1 2))) ``(list 1 2 (+ 1 2))) (assert-equal? (tn) '(quasiquote (unquote (list 1 2 (+ 1 2)))) ``,(list 1 2 (+ 1 2))) (assert-equal? (tn) '(quasiquote (unquote (1 2 3))) ``,,(list 1 2 (+ 1 2))) (assert-equal? (tn) '(quasiquote (list 1 2 (unquote (+ 1 2)))) ``(list 1 2 ,(+ 1 2))) (assert-equal? (tn) '(quasiquote (list 1 2 (unquote 3))) ``(list 1 2 ,,(+ 1 2))) (assert-equal? (tn) '(quasiquote (list 1 2)) ``(list 1 2)) (assert-equal? (tn) '(quasiquote (unquote (list 1 2))) ``,(list 1 2)) (assert-equal? (tn) '(quasiquote (unquote (1 2))) ``,,(list 1 2)) (assert-equal? (tn) 1 `,`,1) (assert-equal? (tn) 3 `,(+ 1 2)) (assert-equal? (tn) ',(+ 1 2) ',(+ 1 2)) (assert-equal? (tn) '(+ 1 2) (cadr ',(+ 1 2))) (assert-equal? (tn) '(quasiquote (unquote 3)) ``,,(+ 1 2)) (assert-equal? (tn) 3 `,`,(+ 1 2)) ;; list (assert-equal? (tn) '(1) `(,1)) (assert-equal? (tn) '(quasiquote ((unquote 1))) ``(,,1)) (assert-equal? (tn) '(1) `(,`,1)) (assert-equal? (tn) '(quasiquote (quasiquote ((unquote (unquote 1))))) ```(,,,1)) (assert-equal? (tn) '(3) `(,(+ 1 2))) (assert-equal? (tn) '(quasiquote ((unquote 3))) ``(,,(+ 1 2))) ;; vector (assert-equal? (tn) '#(1) `#(,1)) (assert-equal? (tn) '(quasiquote #((unquote 1))) ``#(,,1)) (assert-equal? (tn) '#(1) `#(,`,1)) (assert-equal? (tn) '(quasiquote (quasiquote #((unquote (unquote 1))))) ```#(,,,1)) (assert-equal? (tn) '#(3) `#(,(+ 1 2))) (assert-equal? (tn) '(quasiquote #((unquote 3))) ``#(,,(+ 1 2))) (tn "unquote invalid form") (assert-error (tn) (lambda () ,1)) (assert-error (tn) (lambda () ,,1)) (assert-error (tn) (lambda () `,,1)) (assert-error (tn) (lambda () ,(+ 1 2))) (assert-error (tn) (lambda () ,,(+ 1 2))) (assert-error (tn) (lambda () `,,(+ 1 2))) (assert-error (tn) (lambda () `(,,1))) (assert-error (tn) (lambda () ``(,,,1))) (assert-error (tn) (lambda () `(,,(+ 1 2)))) (assert-error (tn) (lambda () ``(,,,(+ 1 2)))) (assert-error (tn) (lambda () `#(,,1))) (assert-error (tn) (lambda () ``#(,,,1))) (assert-error (tn) (lambda () `#(,,(+ 1 2)))) (assert-error (tn) (lambda () ``#(,,,(+ 1 2)))) (tn "unquote-splicing valid form") (assert-equal? (tn) '() `(,@())) (assert-equal? (tn) '() `(,@() ,@())) (assert-equal? (tn) '() `(,@() ,@() ,@())) (assert-equal? (tn) '(0) `(0 ,@())) (assert-equal? (tn) '(1) `(,@() 1)) (assert-equal? (tn) '(0 1) `(0 ,@() 1)) (assert-equal? (tn) '() `(,@(list))) (assert-equal? (tn) '(1) `(,@(list 1))) (assert-equal? (tn) '(1 2) `(,@(list 1 2))) (assert-equal? (tn) '(1 2 3) `(,@(list 1 2 3))) (assert-equal? (tn) '(0 1 2 3) `(0 ,@(list 1 2 3))) (assert-equal? (tn) '(1 2 3 4) `(,@(list 1 2 3) 4)) (assert-equal? (tn) '(0 1 2 3 4) `(0 ,@(list 1 2 3) 4)) (assert-equal? (tn) '(1 2 3) `(,@((lambda () '(1 2 3))))) (assert-equal? (tn) '(0 1 2 3 4) `(0 ,@((lambda () '(1 2 3))) 4)) (assert-equal? (tn) '#() `#(,@())) (assert-equal? (tn) '#() `#(,@() ,@())) (assert-equal? (tn) '#() `#(,@() ,@() ,@())) (assert-equal? (tn) '#(0) `#(0 ,@())) (assert-equal? (tn) '#(1) `#(,@() 1)) (assert-equal? (tn) '#(0 1) `#(0 ,@() 1)) ;; negative growth for vectran (assert-equal? (tn) '#(0 1) `#(0 ,@() ,@() ,@() ,@() 1 ,@())) (assert-equal? (tn) '#(1 2 3) `#(,@((lambda () '(1 2 3))))) (assert-equal? (tn) '#(0 1 2 3 4) `#(0 ,@((lambda () '(1 2 3))) 4)) (tn "unquote-splicing invalid form") (define sym 'sym) (define var 3) (assert-error (tn) (lambda () `,@())) (assert-error (tn) (lambda () `,@(list))) (assert-error (tn) (lambda () `,@(list 1))) (assert-error (tn) (lambda () `,@(list 1 2))) (assert-error (tn) (lambda () `,@(list 1 2 3))) (assert-error (tn) (lambda () `(,@(,@())))) (assert-error (tn) (lambda () `(,@(`,@())))) (assert-error (tn) (lambda () `(,@(,1)))) (assert-error (tn) (lambda () `(,@(`(,,1))))) (assert-error (tn) (lambda () `#(,@(,@())))) (assert-error (tn) (lambda () `#(,@(`,@())))) (assert-error (tn) (lambda () `#(,@(,1)))) (assert-error (tn) (lambda () `#(,@(`(,,1))))) (assert-error (tn) (lambda () `(0 ,@((lambda () '(1 2 . 3))) 4))) (assert-error (tn) (lambda () `#(0 ,@((lambda () '(1 2 . 3))) 4))) (assert-error (tn) (lambda () `,@#t)) (assert-error (tn) (lambda () `,@1)) (assert-error (tn) (lambda () `,@1)) (assert-error (tn) (lambda () `,@#\a)) (assert-error (tn) (lambda () `,@"str")) (assert-error (tn) (lambda () `,@'sym)) (assert-error (tn) (lambda () `,@sym)) (assert-error (tn) (lambda () `,@var)) (assert-error (tn) (lambda () `,@(lambda () #f))) (assert-error (tn) (lambda () `,@(+ 1 2))) (assert-error (tn) (lambda () `,@#(1 2))) (assert-error (tn) (lambda () `(,@#t))) (assert-error (tn) (lambda () `(,@1))) (assert-error (tn) (lambda () `(,@#\a))) (assert-error (tn) (lambda () `(,@"str"))) (assert-error (tn) (lambda () `(,@'sym))) (assert-error (tn) (lambda () `(,@sym))) (assert-error (tn) (lambda () `(,@var))) (assert-error (tn) (lambda () `(,@(lambda () #f)))) (assert-error (tn) (lambda () `(,@(+ 1 2)))) (assert-error (tn) (lambda () `(,@#(1 2)))) (total-report) uim-1.8.8/sigscheme/test/test-values.scm0000644000175000017500000002173012532333147015157 00000000000000;; Filename : test-values.scm ;; About : unit tests for multiple values ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) ;; ;; values ;; ;; These tests use explicit equivalence predicates instead of assert-equal?, to ;; avoid being affected by multiple-values -specific behavior. (tn "values invalid forms") ;; Normal continuations accept exactly one value only. (assert-error (tn) (lambda () (eq? '() (values)))) (assert-error (tn) (lambda () (eq? '() (apply values '())))) (assert-error (tn) (lambda () (eq? '() (values . 1)))) (assert-error (tn) (lambda () (eq? '() (values 1 2)))) (assert-error (tn) (lambda () (eq? '() (apply values '(1 2))))) (assert-error (tn) (lambda () (eq? '() (values 1 . 2)))) (tn "values disallowed places") ;; top-level variable (assert-error (tn) (lambda () (eval '(define foo (values 1 2 3)) (interaction-environment)))) (define foo 1) (assert-error (tn) (lambda () (eval '(set! foo (values 1 2 3)) (interaction-environment)))) ;; internal variable (assert-error (tn) (lambda () (define bar (values 1 2 3)))) ;; others (assert-error (tn) (lambda () (let ((bar (values 1 2 3))) #t))) (assert-error (tn) (lambda () (let* ((bar (values 1 2 3))) #t))) (assert-error (tn) (lambda () (letrec ((bar (values 1 2 3))) #t))) (assert-error (tn) (lambda () (if (values 1 2 3) #t))) (assert-error (tn) (lambda () (and (values 1 2 3) #t))) (assert-error (tn) (lambda () (or (values 1 2 3) #t))) (assert-error (tn) (lambda () (cond ((values 1 2 3) #t) (else #t)))) (assert-error (tn) (lambda () (case (values 1 2 3) (else #t)))) (assert-error (tn) (lambda () (begin (values 1 2 3) #t))) (assert-error (tn) (lambda () ((lambda () (values 1 2 3) #t)))) (tn "values") ;; Exactly one value. (assert-true (tn) (eqv? 1 (values 1))) (assert-true (tn) (eqv? 1 (apply values '(1)))) (assert-true (tn) (eq? '() (values '()))) (assert-true (tn) (eq? '() (apply values '(())))) (assert-true (tn) (eq? #f (values #f))) (assert-true (tn) (eq? #f (apply values '(#f)))) ;; Returning multiple values in top-level is allowed (SigScheme-specific). ;; These forms test whether evaluations are passed without blowing up. (values) (values 1 2 3) (apply values '()) (apply values '(1 2 3)) (begin (values)) (begin (values 1 2 3)) (begin (apply values '())) (begin (apply values '(1 2 3))) ;; ;; call-with-values ;; (tn "call-with-values invalid forms") (assert-error (tn) (lambda () (call-with-values))) (assert-error (tn) (lambda () (call-with-values even?))) (assert-error (tn) (lambda () (call-with-values even? #t))) (assert-error (tn) (lambda () (call-with-values #t even?))) (tn "call-with-values") (assert-equal? (tn) -1 (call-with-values * -)) (assert-equal? (tn) 'ok (call-with-values (lambda () (values)) (lambda () 'ok))) (assert-equal? (tn) '() (call-with-values (lambda () (values)) (lambda args args))) (assert-equal? (tn) 'ok (call-with-values (lambda () (apply values '())) (lambda () 'ok))) (assert-equal? (tn) '() (call-with-values (lambda () (apply values '())) (lambda args args))) (assert-equal? (tn) 1 (call-with-values (lambda () (values 1)) (lambda (x) x))) (assert-equal? (tn) '(1) (call-with-values (lambda () (values 1)) (lambda args args))) (assert-equal? (tn) 1 (call-with-values (lambda () (apply values '(1))) (lambda (x) x))) (assert-equal? (tn) '(1) (call-with-values (lambda () (apply values '(1))) (lambda args args))) (assert-equal? (tn) '(1 2) (call-with-values (lambda () (values 1 2)) (lambda (x y) (list x y)))) (assert-equal? (tn) '(1 2) (call-with-values (lambda () (values 1 2)) (lambda args args))) (assert-equal? (tn) '(1 2) (call-with-values (lambda () (apply values '(1 2))) (lambda (x y) (list x y)))) (assert-equal? (tn) '(1 2) (call-with-values (lambda () (apply values '(1 2))) (lambda args args))) (tn "call-with-values by apply") (assert-equal? (tn) -1 (apply call-with-values (list * -))) (assert-equal? (tn) 'ok (apply call-with-values (list (lambda () (values)) (lambda () 'ok)))) (assert-equal? (tn) '() (apply call-with-values (list (lambda () (values)) (lambda args args)))) (assert-equal? (tn) 'ok (apply call-with-values (list (lambda () (apply values '())) (lambda () 'ok)))) (assert-equal? (tn) '() (apply call-with-values (list (lambda () (apply values '())) (lambda args args)))) (assert-equal? (tn) 1 (apply call-with-values (list (lambda () (values 1)) (lambda (x) x)))) (assert-equal? (tn) '(1) (apply call-with-values (list (lambda () (values 1)) (lambda args args)))) (assert-equal? (tn) 1 (apply call-with-values (list (lambda () (apply values '(1))) (lambda (x) x)))) (assert-equal? (tn) '(1) (apply call-with-values (list (lambda () (apply values '(1))) (lambda args args)))) (assert-equal? (tn) '(1 2) (apply call-with-values (list (lambda () (values 1 2)) (lambda (x y) (list x y))))) (assert-equal? (tn) '(1 2) (apply call-with-values (list (lambda () (values 1 2)) (lambda args args)))) (assert-equal? (tn) '(1 2) (apply call-with-values (list (lambda () (apply values '(1 2))) (lambda (x y) (list x y))))) (assert-equal? (tn) '(1 2) (apply call-with-values (list (lambda () (apply values '(1 2))) (lambda args args)))) (tn "call-with-values misc") ;; test whether the variable is properly bound (assert-equal? (tn) 1 ((lambda (n) (call-with-values (lambda () (values 2 3 n)) (lambda (dummy1 dummy2 n2) n2))) 1)) (total-report) uim-1.8.8/sigscheme/test/test-letstar.scm0000644000175000017500000010022412532333147015332 00000000000000;; Filename : test-letstar.scm ;; About : unit test for R5RS let* ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; ;; let* ;; (tn "let* invalid form") ;; bindings and body required (assert-error (tn) (lambda () (let*))) (assert-error (tn) (lambda () (let* ()))) (assert-error (tn) (lambda () (let* ((a))))) (assert-error (tn) (lambda () (let* ((a 1))))) (assert-error (tn) (lambda () (let* (a 1)))) (assert-error (tn) (lambda () (let* a))) (assert-error (tn) (lambda () (let* #()))) (assert-error (tn) (lambda () (let* #f))) (assert-error (tn) (lambda () (let* #t))) ;; bindings must be a list (assert-error (tn) (lambda () (let* a 'val))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let* #f 'val)) (assert-error (tn) (lambda () (let* #f 'val)))) (assert-error (tn) (lambda () (let* #() 'val))) (assert-error (tn) (lambda () (let* #t 'val))) ;; each binding must be a 2-elem list (assert-error (tn) (lambda () (let* (a 1)))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let* ((a)) 'val)) (assert-error (tn) (lambda () (let* ((a)) 'val)))) (assert-error (tn) (lambda () (let* ((a 1 'excessive)) 'val))) (assert-error (tn) (lambda () (let* ((a 1) . (b 2)) 'val))) (assert-error (tn) (lambda () (let* ((a . 1)) 'val))) (assert-error (tn) (lambda () (let* ((a 1)) . a))) (assert-error (tn) (lambda () (let* ((a 1)) 'val . a))) (assert-error (tn) (lambda () (let* (1) #t))) (tn "let* binding syntactic keyword") (assert-equal? (tn) 4 (let* ((else 4)) else)) (assert-equal? (tn) 5 (let* ((=> 5)) =>)) (assert-equal? (tn) 6 (let* ((unquote 6)) unquote)) (assert-error (tn) (lambda () else)) (assert-error (tn) (lambda () =>)) (assert-error (tn) (lambda () unquote)) (tn "let* env isolation") (assert-equal? (tn) 1 (let* ((var1 1) (var2 var1)) var2)) (assert-error (tn) (lambda () (let* ((var1 var2) (var2 2)) 'result))) ;; The environment is extended even if empty bindings on ;; !SCM_STRICT_DEFINE_PLACEMENT (assert-equal? (tn) 1 (let ((var1 1)) (let* () (define var1 2) 'dummy) var1)) (if (provided? "sigscheme") (begin (assert-equal? (tn) '(#f #t #t) (let* ((var1 (symbol-bound? 'var1 (%%current-environment))) (var2 (symbol-bound? 'var1 (%%current-environment))) (var3 (symbol-bound? 'var1 (%%current-environment)))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #t) (let* ((var1 (symbol-bound? 'var2 (%%current-environment))) (var2 (symbol-bound? 'var2 (%%current-environment))) (var3 (symbol-bound? 'var2 (%%current-environment)))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let* ((var1 (symbol-bound? 'var3 (%%current-environment))) (var2 (symbol-bound? 'var3 (%%current-environment))) (var3 (symbol-bound? 'var3 (%%current-environment)))) (list var1 var2 var3))))) (tn "let* internal definitions lacking sequence part") ;; at least one is required (assert-error (tn) (lambda () (let* () (define var1 1)))) (assert-error (tn) (lambda () (let* () (define (proc1) 1)))) (assert-error (tn) (lambda () (let* () (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let* () (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let* () (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let* () (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let* () (begin)))) (assert-error (tn) (lambda () (let* () (begin (define var1 1))))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define var2 2))))) ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let* () (begin (define var1 1) 'val)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) 'val)))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define var2 2) 'val)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define var2 2) 'val)))) (tn "let* internal definitions cross reference") ;; R5RS: 5.2.2 Internal definitions ;; Just as for the equivalent `letrec' expression, it must be possible to ;; evaluate each of every internal definition in a without ;; assigning or referring to the value of any being defined. (assert-error (tn) (lambda () (let* () (define var1 1) (define var2 var1) 'val))) (assert-error (tn) (lambda () (let* () (define var1 var2) (define var2 2) 'val))) (assert-error (tn) (lambda () (let* () (define var1 var1) 'val))) (assert-equal? (tn) '(0 0 0 0 0) (let* ((var0 0)) (define var1 var0) (define var2 var0) (begin (define var3 var0) (begin (define var4 var0))) (define var5 var0) (list var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let* ((var0 (symbol-bound? 'var1))) (define var1 (symbol-bound? 'var1)) (define var2 (symbol-bound? 'var1)) (begin (define var3 (symbol-bound? 'var1)) (begin (define var4 (symbol-bound? 'var1)))) (define var5 (symbol-bound? 'var1)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let* ((var0 (symbol-bound? 'var2))) (define var1 (symbol-bound? 'var2)) (define var2 (symbol-bound? 'var2)) (begin (define var3 (symbol-bound? 'var2)) (begin (define var4 (symbol-bound? 'var2)))) (define var5 (symbol-bound? 'var2)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let* ((var0 (symbol-bound? 'var3))) (define var1 (symbol-bound? 'var3)) (define var2 (symbol-bound? 'var3)) (begin (define var3 (symbol-bound? 'var3)) (begin (define var4 (symbol-bound? 'var3)))) (define var5 (symbol-bound? 'var3)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let* ((var0 (symbol-bound? 'var4))) (define var1 (symbol-bound? 'var4)) (define var2 (symbol-bound? 'var4)) (begin (define var3 (symbol-bound? 'var4)) (begin (define var4 (symbol-bound? 'var4)))) (define var5 (symbol-bound? 'var4)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let* ((var0 (symbol-bound? 'var5))) (define var1 (symbol-bound? 'var5)) (define var2 (symbol-bound? 'var5)) (begin (define var3 (symbol-bound? 'var5)) (begin (define var4 (symbol-bound? 'var5)))) (define var5 (symbol-bound? 'var5)) (list var0 var1 var2 var3 var4 var5))) ;; outer let cannot refer internal variable (assert-error (tn) (lambda () (let* ((var0 (lambda () var1))) (define var1 (lambda () 1)) (eq? (var0) var0)))) ;; defining procedure can refer other (and self) variables as if letrec (assert-equal? (tn) '(#t #t #t #t #t) (let* ((var0 (lambda () 0))) (define var1 (lambda () var0)) (define var2 (lambda () var0)) (begin (define var3 (lambda () var0)) (begin (define var4 (lambda () var0)))) (define var5 (lambda () var0)) (list (eq? (var1) var0) (eq? (var2) var0) (eq? (var3) var0) (eq? (var4) var0) (eq? (var5) var0)))) (assert-equal? (tn) '(#t #t #t #t #t) (let* () (define var1 (lambda () var1)) (define var2 (lambda () var1)) (begin (define var3 (lambda () var1)) (begin (define var4 (lambda () var1)))) (define var5 (lambda () var1)) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1) (eq? (var4) var1) (eq? (var5) var1)))) (assert-equal? (tn) '(#t #t #t #t #t) (let* () (define var1 (lambda () var2)) (define var2 (lambda () var2)) (begin (define var3 (lambda () var2)) (begin (define var4 (lambda () var2)))) (define var5 (lambda () var2)) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2) (eq? (var4) var2) (eq? (var5) var2)))) (assert-equal? (tn) '(#t #t #t #t #t) (let* () (define var1 (lambda () var3)) (define var2 (lambda () var3)) (begin (define var3 (lambda () var3)) (begin (define var4 (lambda () var3)))) (define var5 (lambda () var3)) (list (eq? (var1) var3) (eq? (var2) var3) (eq? (var3) var3) (eq? (var4) var3) (eq? (var5) var3)))) (assert-equal? (tn) '(#t #t #t #t #t) (let* () (define var1 (lambda () var4)) (define var2 (lambda () var4)) (begin (define var3 (lambda () var4)) (begin (define var4 (lambda () var4)))) (define var5 (lambda () var4)) (list (eq? (var1) var4) (eq? (var2) var4) (eq? (var3) var4) (eq? (var4) var4) (eq? (var5) var4)))) (assert-equal? (tn) '(#t #t #t #t #t) (let* () (define var1 (lambda () var5)) (define var2 (lambda () var5)) (begin (define var3 (lambda () var5)) (begin (define var4 (lambda () var5)))) (define var5 (lambda () var5)) (list (eq? (var1) var5) (eq? (var2) var5) (eq? (var3) var5) (eq? (var4) var5) (eq? (var5) var5)))) (tn "let* internal definitions valid forms") ;; valid internal definitions (assert-equal? (tn) '(1) (let* () (define var1 1) (list var1))) (assert-equal? (tn) '(1) (let* () (define (proc1) 1) (list (proc1)))) (assert-equal? (tn) '(1 2) (let* () (define var1 1) (define var2 2) (list var1 var2))) (assert-equal? (tn) '(1 2) (let* () (define (proc1) 1) (define (proc2) 2) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let* () (define var1 1) (define (proc2) 2) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let* () (define (proc1) 1) (define var2 2) (list (proc1) var2))) ;; SigScheme accepts '(begin)' as valid internal definition '(begin ;; *)' as defined in "7.1.6 Programs and definitions" of R5RS ;; although it is rejected as expression '(begin )' as defined in ;; "7.1.3 Expressions". (assert-equal? (tn) 1 (let* () (begin) 1)) (assert-equal? (tn) 1 (let* () (begin) (define var1 1) (begin) 1)) (assert-equal? (tn) '(1) (let* () (begin (define var1 1)) (list var1))) (assert-equal? (tn) '(1) (let* () (begin (define (proc1) 1)) (list (proc1)))) (assert-equal? (tn) '(1 2) (let* () (begin (define var1 1) (define var2 2)) (list var1 var2))) (assert-equal? (tn) '(1 2) (let* () (begin (define (proc1) 1) (define (proc2) 2)) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let* () (begin (define var1 1) (define (proc2) 2)) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let* () (begin (define (proc1) 1) (define var2 2)) (list (proc1) var2))) (assert-equal? (tn) '(1 2 3 4 5 6) (let* () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6))) ;; begin block and single definition mixed (assert-equal? (tn) '(1 2 3 4 5 6) (let* () (begin) (define (proc1) 1) (begin (define var2 2) (begin (define (proc3) 3) (begin) (define var4 4))) (begin) (define (proc5) 5) (begin (begin (begin (begin))) (define var6 6) (begin)) (begin) (list (proc1) var2 (proc3) var4 (proc5) var6))) (tn "let* internal definitions invalid begin blocks") ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let* () (begin (define var1 1) 'val) (list var1)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) 'val) (list (proc1))))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define var2 2) 'val) (list var1 var2)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define (proc2) 2) 'val) (list (proc1) (proc2))))) (assert-error (tn) (lambda () (let* () (begin (define var1 1) (define (proc2) 2) 'val) (list var1 (proc2))))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define var2 2) 'val) (list (proc1) var2)))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6) 'val))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "let* internal definitions invalid placement") ;; a non-definition expression prior to internal definition is invalid (assert-error (tn) (lambda () (let* () 'val (define var1 1)))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1)))) (assert-error (tn) (lambda () (let* () 'val (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let* () 'val (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let* () 'val (begin)))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1))))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define var2 2))))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) (assert-error (tn) (lambda () (let* () (begin (define (proc1) 1) (define var2 2) 'val (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) ;; a non-definition expression prior to internal definition is invalid even if ;; expression(s) is following the internal definition (assert-error (tn) (lambda () (let* () 'val (define var1 1) 'val))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1) 'val))) (assert-error (tn) (lambda () (let* () 'val (define var1 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let* () 'val (define var1 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let* () 'val (define (proc1) 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define var1 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let* () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "let* binding syntactic keywords") (assert-error (tn) (lambda () (let* ((syn define)) #t))) (assert-error (tn) (lambda () (let* ((syn if)) #t))) (assert-error (tn) (lambda () (let* ((syn and)) #t))) (assert-error (tn) (lambda () (let* ((syn cond)) #t))) (assert-error (tn) (lambda () (let* ((syn begin)) #t))) (assert-error (tn) (lambda () (let* ((syn do)) #t))) (assert-error (tn) (lambda () (let* ((syn delay)) #t))) (assert-error (tn) (lambda () (let* ((syn let*)) #t))) (assert-error (tn) (lambda () (let* ((syn else)) #t))) (assert-error (tn) (lambda () (let* ((syn =>)) #t))) (assert-error (tn) (lambda () (let* ((syn quote)) #t))) (assert-error (tn) (lambda () (let* ((syn quasiquote)) #t))) (assert-error (tn) (lambda () (let* ((syn unquote)) #t))) (assert-error (tn) (lambda () (let* ((syn unquote-splicing)) #t))) (tn "let*") ;; empty bindings is allowed by the formal syntax spec (assert-equal? (tn) 'result (let* () 'result)) ;; duplicate variable name is allowd on let* (assert-equal? (tn) 2 (let* ((var1 1) (var1 2)) var1)) ;; masked variable name (assert-equal? (tn) '(4 5 3) (let* ((var1 1) (var2 2) (var3 3)) (let* ((var1 4) (var2 5)) (list var1 var2 var3)))) (assert-equal? (tn) '(1 2 3) (let* ((var1 1) (var2 2) (var3 3)) (let* ((var1 4) (var2 5)) 'dummy) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 9) (let* ((var1 1) (var2 2) (var3 3)) (let* ((var1 4) (var2 5)) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 30) (let* ((var1 1) (var2 2) (var3 3)) (let* ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 30 (10 20 30)) (let* ((var1 1) (var2 2) (var3 3) (var4 (let* ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (set! var3 30) (list var1 var2 var3)))) (list var1 var2 var3 var4))) ;; normal case(s) (assert-equal? (tn) '(1 2 3) (let* ((var1 1) (var2 (+ var1 1)) (var3 (+ var2 1))) (list var1 var2 var3))) (tn "let* lexical scope") (define count-let* (let* ((count-let* 0)) ;; intentionally same name (lambda () (set! count-let* (+ count-let* 1)) count-let*))) (assert-true (tn) (procedure? count-let*)) (assert-equal? (tn) 1 (count-let*)) (assert-equal? (tn) 2 (count-let*)) (assert-equal? (tn) 3 (count-let*)) (total-report) uim-1.8.8/sigscheme/test/test-letrec.scm0000644000175000017500000010674312532333147015146 00000000000000;; Filename : test-letrec.scm ;; About : unit test for R5RS letrec ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; ;; letrec ;; (tn "letrec invalid form") ;; bindings and body required (assert-error (tn) (lambda () (letrec))) (assert-error (tn) (lambda () (letrec ()))) (assert-error (tn) (lambda () (letrec ((a))))) (assert-error (tn) (lambda () (letrec ((a 1))))) (assert-error (tn) (lambda () (letrec (a 1)))) (assert-error (tn) (lambda () (letrec a))) (assert-error (tn) (lambda () (letrec #()))) (assert-error (tn) (lambda () (letrec #f))) (assert-error (tn) (lambda () (letrec #t))) ;; bindings must be a list (assert-error (tn) (lambda () (letrec a 'val))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (letrec #f 'val)) (assert-error (tn) (lambda () (letrec #f 'val)))) (assert-error (tn) (lambda () (letrec #() 'val))) (assert-error (tn) (lambda () (letrec #t 'val))) ;; each binding must be a 2-elem list (assert-error (tn) (lambda () (letrec (a 1) 'val))) (assert-error (tn) (lambda () (letrec ((a)) 'val))) (assert-error (tn) (lambda () (letrec ((a 1 'excessive)) 'val))) (assert-error (tn) (lambda () (letrec ((a 1) . (b 2)) 'val))) (assert-error (tn) (lambda () (letrec ((a . 1)) 'val))) (assert-error (tn) (lambda () (letrec ((a 1)) . a))) (assert-error (tn) (lambda () (letrec ((a 1)) 'val . a))) (assert-error (tn) (lambda () (letrec (1) #t))) (tn "letrec binding syntactic keyword") (assert-equal? (tn) 7 (letrec ((else 7)) else)) (assert-equal? (tn) 8 (letrec ((=> 8)) =>)) (assert-equal? (tn) 9 (letrec ((unquote 9)) unquote)) (assert-error (tn) (lambda () else)) (assert-error (tn) (lambda () =>)) (assert-error (tn) (lambda () unquote)) (tn "letrec env isolation") ;; referencing a variable within bindings evaluation is invalid (assert-error (tn) (lambda () (letrec ((var1 1) (var2 var1)) 'result))) (assert-error (tn) (lambda () (letrec ((var1 var2) (var2 2)) 'result))) ;; all variables are kept unbound until body evaluation (assert-equal? (tn) '(#f #f #f) (letrec ((var1 (symbol-bound? 'var1)) (var2 (symbol-bound? 'var1)) (var3 (symbol-bound? 'var1))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (letrec ((var1 (symbol-bound? 'var2)) (var2 (symbol-bound? 'var2)) (var3 (symbol-bound? 'var2))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (letrec ((var1 (symbol-bound? 'var3)) (var2 (symbol-bound? 'var3)) (var3 (symbol-bound? 'var3))) (list var1 var2 var3))) ;; all variables can be referred from any position of the bindings (assert-equal? (tn) '(#t #t #t) (letrec ((var1 (lambda () var1)) (var2 (lambda () var1)) (var3 (lambda () var1))) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1)))) (assert-equal? (tn) '(#t #t #t) (letrec ((var1 (lambda () var2)) (var2 (lambda () var2)) (var3 (lambda () var2))) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2)))) (assert-equal? (tn) '(#t #t #t) (letrec ((var1 (lambda () var3)) (var2 (lambda () var3)) (var3 (lambda () var3))) (list (eq? (var1) var3) (eq? (var2) var3) (eq? (var3) var3)))) (tn "letrec internal definitions lacking sequence part") ;; at least one is required (assert-error (tn) (lambda () (letrec () (define var1 1)))) (assert-error (tn) (lambda () (letrec () (define (proc1) 1)))) (assert-error (tn) (lambda () (letrec () (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (letrec () (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (letrec () (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (letrec () (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (letrec () (begin)))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1))))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define var2 2))))) ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (letrec () (begin (define var1 1) 'val)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) 'val)))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define var2 2) 'val)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define var2 2) 'val)))) (tn "letrec internal definitions cross reference") ;; R5RS: 5.2.2 Internal definitions ;; Just as for the equivalent `letrec' expression, it must be possible to ;; evaluate each of every internal definition in a without ;; assigning or referring to the value of any being defined. (assert-error (tn) (lambda () (letrec () (define var1 1) (define var2 var1) 'val))) (assert-error (tn) (lambda () (letrec () (define var1 var2) (define var2 2) 'val))) (assert-error (tn) (lambda () (letrec () (define var1 var1) 'val))) (assert-equal? (tn) '(0 0 0 0 0) (letrec ((var0 0)) (define var1 var0) (define var2 var0) (begin (define var3 var0) (begin (define var4 var0))) (define var5 var0) (list var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (letrec ((var0 (symbol-bound? 'var1))) (define var1 (symbol-bound? 'var1)) (define var2 (symbol-bound? 'var1)) (begin (define var3 (symbol-bound? 'var1)) (begin (define var4 (symbol-bound? 'var1)))) (define var5 (symbol-bound? 'var1)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (letrec ((var0 (symbol-bound? 'var2))) (define var1 (symbol-bound? 'var2)) (define var2 (symbol-bound? 'var2)) (begin (define var3 (symbol-bound? 'var2)) (begin (define var4 (symbol-bound? 'var2)))) (define var5 (symbol-bound? 'var2)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (letrec ((var0 (symbol-bound? 'var3))) (define var1 (symbol-bound? 'var3)) (define var2 (symbol-bound? 'var3)) (begin (define var3 (symbol-bound? 'var3)) (begin (define var4 (symbol-bound? 'var3)))) (define var5 (symbol-bound? 'var3)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (letrec ((var0 (symbol-bound? 'var4))) (define var1 (symbol-bound? 'var4)) (define var2 (symbol-bound? 'var4)) (begin (define var3 (symbol-bound? 'var4)) (begin (define var4 (symbol-bound? 'var4)))) (define var5 (symbol-bound? 'var4)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (letrec ((var0 (symbol-bound? 'var5))) (define var1 (symbol-bound? 'var5)) (define var2 (symbol-bound? 'var5)) (begin (define var3 (symbol-bound? 'var5)) (begin (define var4 (symbol-bound? 'var5)))) (define var5 (symbol-bound? 'var5)) (list var0 var1 var2 var3 var4 var5))) ;; outer let cannot refer internal variable even if letrec (assert-error (tn) (lambda () (letrec ((var0 (lambda () var1))) (define var1 (lambda () 1)) (eq? (var0) var0)))) ;; defining procedure can refer other (and self) variables as if letrec (assert-equal? (tn) '(#t #t #t #t #t) (letrec ((var0 (lambda () 0))) (define var1 (lambda () var0)) (define var2 (lambda () var0)) (begin (define var3 (lambda () var0)) (begin (define var4 (lambda () var0)))) (define var5 (lambda () var0)) (list (eq? (var1) var0) (eq? (var2) var0) (eq? (var3) var0) (eq? (var4) var0) (eq? (var5) var0)))) (assert-equal? (tn) '(#t #t #t #t #t) (letrec () (define var1 (lambda () var1)) (define var2 (lambda () var1)) (begin (define var3 (lambda () var1)) (begin (define var4 (lambda () var1)))) (define var5 (lambda () var1)) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1) (eq? (var4) var1) (eq? (var5) var1)))) (assert-equal? (tn) '(#t #t #t #t #t) (letrec () (define var1 (lambda () var2)) (define var2 (lambda () var2)) (begin (define var3 (lambda () var2)) (begin (define var4 (lambda () var2)))) (define var5 (lambda () var2)) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2) (eq? (var4) var2) (eq? (var5) var2)))) (assert-equal? (tn) '(#t #t #t #t #t) (letrec () (define var1 (lambda () var3)) (define var2 (lambda () var3)) (begin (define var3 (lambda () var3)) (begin (define var4 (lambda () var3)))) (define var5 (lambda () var3)) (list (eq? (var1) var3) (eq? (var2) var3) (eq? (var3) var3) (eq? (var4) var3) (eq? (var5) var3)))) (assert-equal? (tn) '(#t #t #t #t #t) (letrec () (define var1 (lambda () var4)) (define var2 (lambda () var4)) (begin (define var3 (lambda () var4)) (begin (define var4 (lambda () var4)))) (define var5 (lambda () var4)) (list (eq? (var1) var4) (eq? (var2) var4) (eq? (var3) var4) (eq? (var4) var4) (eq? (var5) var4)))) (assert-equal? (tn) '(#t #t #t #t #t) (letrec () (define var1 (lambda () var5)) (define var2 (lambda () var5)) (begin (define var3 (lambda () var5)) (begin (define var4 (lambda () var5)))) (define var5 (lambda () var5)) (list (eq? (var1) var5) (eq? (var2) var5) (eq? (var3) var5) (eq? (var4) var5) (eq? (var5) var5)))) (tn "letrec internal definitions valid forms") ;; valid internal definitions (assert-equal? (tn) '(1) (letrec () (define var1 1) (list var1))) (assert-equal? (tn) '(1) (letrec () (define (proc1) 1) (list (proc1)))) (assert-equal? (tn) '(1 2) (letrec () (define var1 1) (define var2 2) (list var1 var2))) (assert-equal? (tn) '(1 2) (letrec () (define (proc1) 1) (define (proc2) 2) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (letrec () (define var1 1) (define (proc2) 2) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (letrec () (define (proc1) 1) (define var2 2) (list (proc1) var2))) ;; SigScheme accepts '(begin)' as valid internal definition '(begin ;; *)' as defined in "7.1.6 Programs and definitions" of R5RS ;; although it is rejected as expression '(begin )' as defined in ;; "7.1.3 Expressions". (assert-equal? (tn) 1 (letrec () (begin) 1)) (assert-equal? (tn) 1 (letrec () (begin) (define var1 1) (begin) 1)) (assert-equal? (tn) '(1) (letrec () (begin (define var1 1)) (list var1))) (assert-equal? (tn) '(1) (letrec () (begin (define (proc1) 1)) (list (proc1)))) (assert-equal? (tn) '(1 2) (letrec () (begin (define var1 1) (define var2 2)) (list var1 var2))) (assert-equal? (tn) '(1 2) (letrec () (begin (define (proc1) 1) (define (proc2) 2)) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (letrec () (begin (define var1 1) (define (proc2) 2)) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (letrec () (begin (define (proc1) 1) (define var2 2)) (list (proc1) var2))) (assert-equal? (tn) '(1 2 3 4 5 6) (letrec () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6))) ;; begin block and single definition mixed (assert-equal? (tn) '(1 2 3 4 5 6) (letrec () (begin) (define (proc1) 1) (begin (define var2 2) (begin (define (proc3) 3) (begin) (define var4 4))) (begin) (define (proc5) 5) (begin (begin (begin (begin))) (define var6 6) (begin)) (begin) (list (proc1) var2 (proc3) var4 (proc5) var6))) (tn "letrec internal definitions invalid begin blocks") ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (letrec () (begin (define var1 1) 'val) (list var1)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) 'val) (list (proc1))))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define var2 2) 'val) (list var1 var2)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define (proc2) 2) 'val) (list (proc1) (proc2))))) (assert-error (tn) (lambda () (letrec () (begin (define var1 1) (define (proc2) 2) 'val) (list var1 (proc2))))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define var2 2) 'val) (list (proc1) var2)))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6) 'val))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "letrec internal definitions invalid placement") ;; a non-definition expression prior to internal definition is invalid (assert-error (tn) (lambda () (letrec () 'val (define var1 1)))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1)))) (assert-error (tn) (lambda () (letrec () 'val (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (letrec () 'val (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (letrec () 'val (begin)))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define var2 2))))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) (assert-error (tn) (lambda () (letrec () (begin (define (proc1) 1) (define var2 2) 'val (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) ;; a non-definition expression prior to internal definition is invalid even if ;; expression(s) is following the internal definition (assert-error (tn) (lambda () (letrec () 'val (define var1 1) 'val))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1) 'val))) (assert-error (tn) (lambda () (letrec () 'val (define var1 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (letrec () 'val (define var1 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (letrec () 'val (define (proc1) 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define var1 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (letrec () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "letrec binding syntactic keywords") (assert-error (tn) (lambda () (letrec ((syn define)) #t))) (assert-error (tn) (lambda () (letrec ((syn if)) #t))) (assert-error (tn) (lambda () (letrec ((syn and)) #t))) (assert-error (tn) (lambda () (letrec ((syn cond)) #t))) (assert-error (tn) (lambda () (letrec ((syn begin)) #t))) (assert-error (tn) (lambda () (letrec ((syn do)) #t))) (assert-error (tn) (lambda () (letrec ((syn delay)) #t))) (assert-error (tn) (lambda () (letrec ((syn let*)) #t))) (assert-error (tn) (lambda () (letrec ((syn else)) #t))) (assert-error (tn) (lambda () (letrec ((syn =>)) #t))) (assert-error (tn) (lambda () (letrec ((syn quote)) #t))) (assert-error (tn) (lambda () (letrec ((syn quasiquote)) #t))) (assert-error (tn) (lambda () (letrec ((syn unquote)) #t))) (assert-error (tn) (lambda () (letrec ((syn unquote-splicing)) #t))) (tn "letrec") ;; empty bindings is allowed by the formal syntax spec (assert-equal? (tn) 'result (letrec () 'result)) ;; duplicate variable name (assert-error (tn) (lambda () (letrec ((var1 1) (var1 2)) 'result))) ;; masked variable name (assert-equal? (tn) '(#t #t #t #t #f #f #t #t #f #t) (letrec ((var1 (lambda () var3)) (var2 (lambda () var4)) (var3 (lambda () var3)) (var4 (lambda () var4)) (var1in #f) (var2in #f) (var5in #f)) (letrec ((var1 (lambda () var1)) (var2 (lambda () var1)) (var5 (lambda () var3))) (set! var1in var1) (set! var2in var2) (set! var5in var5)) (list (eq? (var1) var3) (eq? (var2) var4) (eq? (var3) var3) (eq? (var4) var4) (eq? (var1in) var1) (eq? (var2in) var1) (eq? (var1in) var1in) (eq? (var2in) var1in) (eq? (var2in) var2in) (eq? (var5in) var3)))) (assert-equal? (tn) '(4 5 3) (letrec ((var1 1) (var2 2) (var3 3)) (letrec ((var1 4) (var2 5)) (list var1 var2 var3)))) (assert-equal? (tn) '(1 2 3) (letrec ((var1 1) (var2 2) (var3 3)) (letrec ((var1 4) (var2 5)) 'dummy) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 9) (letrec ((var1 1) (var2 2) (var3 3)) (letrec ((var1 4) (var2 5)) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 30) (letrec ((var1 1) (var2 2) (var3 3)) (letrec ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 3 (10 20)) (letrec ((var1 1) (var2 2) (var3 3) (var4 (letrec ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (list var1 var2)))) (list var1 var2 var3 var4))) (assert-error (tn) (lambda () (letrec ((var1 1) (var2 2) (var3 3) (var4 (letrec ((var1 4) (var2 5)) (set! var3 10)))) (list var1 var2 var3 var4)))) ;; variable reference (assert-equal? (tn) 3 (letrec ((proc (lambda () var)) (var 3)) (proc))) ;; ordinary recursions (assert-equal? (tn) 4 (letrec ((proc1 (lambda (n) (+ n 1))) (proc2 (lambda (n) (proc1 n)))) (proc2 3))) (assert-equal? (tn) 6 (letrec ((proc1 (lambda (n) (proc2 n))) (proc2 (lambda (n) (+ n 1)))) (proc1 5))) (assert-equal? (tn) #t (letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) (even? 88))) (assert-equal? (tn) #f (letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) (odd? 88))) (tn "letrec lexical scope") (define count-letrec (letrec ((count-letrec 0)) ;; intentionally same name (lambda () (set! count-letrec (+ count-letrec 1)) count-letrec))) (assert-true (tn) (procedure? count-letrec)) (assert-equal? (tn) 1 (count-letrec)) (assert-equal? (tn) 2 (count-letrec)) (assert-equal? (tn) 3 (count-letrec)) (total-report) uim-1.8.8/sigscheme/test/test-enc-eucgeneric.scm0000755000175000017500000001641512532333147016543 00000000000000#! /usr/bin/env sscm -C EUC-CN ;; -*- buffer-file-coding-system: euc-jp -*- ;; Filename : test-enc-eucgeneric.scm ;; About : unit test for EUC string ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (and (provided? "euc-jp") (symbol-bound? 'char?) (symbol-bound? 'string?))) (test-skip "EUC-JP codec is not enabled")) (define tn test-name) ;; This file provides a fallback test unit for all EUC systems. It's ;; just a copy of test-enc-eucjp.scm with EUCJP-specific character ;; sequences removed, so some characters may be undefined in other EUC ;; systems. (assert-equal? "string 1" "Èþ¿Í¤Ë¤Ï" (string #\Èþ #\¿Í #\¤Ë #\¤Ï)) (assert-equal? "list->string 1" "3Æü¤Ç" (list->string '(#\3 #\Æü #\¤Ç))) (assert-equal? "string->list 1" '(#\¤¡ #\¤­ #\¤ë) (string->list "¤¡¤­¤ë")) ;; since single shift is only supported in EUC-JP in SigScheme, the JIS X 0201 ;; kana character is replaced to JIS x 0208. -- YamaKen 2005-11-25 (assert-equal? "string-ref 1" #\Êâ (string-ref "»õhiÊâ¤ØÊâ" 3)) (assert-equal? "make-string 1" "ÊâÊâÊâÊâÊâ" (make-string 5 #\Êâ)) (assert-equal? "string-copy 1" "¶â¶ä¹á" (string-copy "¶â¶ä¹á")) (assert-equal? "string-set! 1" "¶â·Ë¶Ì" (let ((s (string-copy "¶â·Ë¤È"))) (string-set! s 2 #\¶Ì) s)) (define str1 "¤¢¥ãah˽\\˽n!¡ù¡ý!") (define str1-list '(#\¤¢ #\¥ã #\a #\h #\˽ #\\ #\˽ #\n #\! #\¡ù #\¡ý #\!)) (assert-equal? "string 2" str1 (apply string str1-list)) (assert-equal? "list->string 2" str1-list (string->list str1)) ;; unsupported SRFI-75 literals cause error (tn "SRFI-75") (assert-parseable (tn) "#\\x63") (assert-parse-error (tn) "#\\u0063") (assert-parse-error (tn) "#\\U00000063") (assert-parse-error (tn) "\"\\x63\"") (assert-parse-error (tn) "\"\\u0063\"") (assert-parse-error (tn) "\"\\U00000063\"") (assert-parseable (tn) "'a") ;; Non-Unicode multibyte symbols are not allowed. (assert-parse-error (tn) "'¤¢") (tn "R6RS (R5.92RS) chars") (assert-parseable (tn) "#\\x") (assert-parseable (tn) "#\\x6") (assert-parseable (tn) "#\\xf") (assert-parseable (tn) "#\\x63") (assert-parseable (tn) "#\\x063") (assert-parseable (tn) "#\\x0063") (assert-parseable (tn) "#\\x00063") (assert-parseable (tn) "#\\x0000063") (assert-parseable (tn) "#\\x00000063") (assert-parse-error (tn) "#\\x000000063") (assert-parseable (tn) "#\\x3042") (assert-parse-error (tn) "#\\x-") (assert-parse-error (tn) "#\\x-6") (assert-parse-error (tn) "#\\x-f") (assert-parse-error (tn) "#\\x-63") (assert-parse-error (tn) "#\\x-063") (assert-parse-error (tn) "#\\x-0063") (assert-parse-error (tn) "#\\x-00063") (assert-parse-error (tn) "#\\x-0000063") (assert-parse-error (tn) "#\\x-00000063") (assert-parse-error (tn) "#\\x-000000063") (assert-parse-error (tn) "#\\x+") (assert-parse-error (tn) "#\\x+6") (assert-parse-error (tn) "#\\x+f") (assert-parse-error (tn) "#\\x+63") (assert-parse-error (tn) "#\\x+063") (assert-parse-error (tn) "#\\x+0063") (assert-parse-error (tn) "#\\x+00063") (assert-parse-error (tn) "#\\x+0000063") (assert-parse-error (tn) "#\\x+00000063") (assert-parse-error (tn) "#\\x+000000063") (tn "R6RS (R5.92RS) string hex escapes") (assert-parse-error (tn) "\"\\x\"") (assert-parse-error (tn) "\"\\x6\"") (assert-parse-error (tn) "\"\\xf\"") (assert-parse-error (tn) "\"\\x63\"") (assert-parse-error (tn) "\"\\x063\"") (assert-parse-error (tn) "\"\\x0063\"") (assert-parse-error (tn) "\"\\x00063\"") (assert-parse-error (tn) "\"\\x0000063\"") (assert-parse-error (tn) "\"\\x00000063\"") (assert-parse-error (tn) "\"\\x000000063\"") (assert-parse-error (tn) "\"\\x;\"") (assert-parseable (tn) "\"\\x6;\"") (assert-parseable (tn) "\"\\xf;\"") (assert-parseable (tn) "\"\\x63;\"") (assert-parseable (tn) "\"\\x063;\"") (assert-parseable (tn) "\"\\x0063;\"") (assert-parseable (tn) "\"\\x00063;\"") (assert-parseable (tn) "\"\\x0000063;\"") (assert-parseable (tn) "\"\\x00000063;\"") (assert-parse-error (tn) "\"\\x000000063;\"") (assert-parse-error (tn) "\"\\x-\"") (assert-parse-error (tn) "\"\\x-6\"") (assert-parse-error (tn) "\"\\x-f\"") (assert-parse-error (tn) "\"\\x-63\"") (assert-parse-error (tn) "\"\\x-063\"") (assert-parse-error (tn) "\"\\x-0063\"") (assert-parse-error (tn) "\"\\x-00063\"") (assert-parse-error (tn) "\"\\x-0000063\"") (assert-parse-error (tn) "\"\\x-00000063\"") (assert-parse-error (tn) "\"\\x-000000063\"") (assert-parse-error (tn) "\"\\x-;\"") (assert-parse-error (tn) "\"\\x-6;\"") (assert-parse-error (tn) "\"\\x-f;\"") (assert-parse-error (tn) "\"\\x-63;\"") (assert-parse-error (tn) "\"\\x-063;\"") (assert-parse-error (tn) "\"\\x-0063;\"") (assert-parse-error (tn) "\"\\x-00063;\"") (assert-parse-error (tn) "\"\\x-0000063;\"") (assert-parse-error (tn) "\"\\x-00000063;\"") (assert-parse-error (tn) "\"\\x-000000063;\"") (assert-parse-error (tn) "\"\\x+\"") (assert-parse-error (tn) "\"\\x+6\"") (assert-parse-error (tn) "\"\\x+f\"") (assert-parse-error (tn) "\"\\x+63\"") (assert-parse-error (tn) "\"\\x+063\"") (assert-parse-error (tn) "\"\\x+0063\"") (assert-parse-error (tn) "\"\\x+00063\"") (assert-parse-error (tn) "\"\\x+0000063\"") (assert-parse-error (tn) "\"\\x+00000063\"") (assert-parse-error (tn) "\"\\x+000000063\"") (assert-parse-error (tn) "\"\\x+;\"") (assert-parse-error (tn) "\"\\x+6;\"") (assert-parse-error (tn) "\"\\x+f;\"") (assert-parse-error (tn) "\"\\x+63;\"") (assert-parse-error (tn) "\"\\x+063;\"") (assert-parse-error (tn) "\"\\x+0063;\"") (assert-parse-error (tn) "\"\\x+00063;\"") (assert-parse-error (tn) "\"\\x+0000063;\"") (assert-parse-error (tn) "\"\\x+00000063;\"") (assert-parse-error (tn) "\"\\x+000000063;\"") (total-report) uim-1.8.8/sigscheme/test/test-apply.scm0000644000175000017500000001025412532333147015004 00000000000000;; Filename : test-apply.scm ;; About : unit test for R5RS apply ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (tn "apply invalid form") (assert-error (tn) (lambda () (apply #f '()))) (assert-error (tn) (lambda () (apply and '()))) (assert-error (tn) (lambda () (apply +))) (assert-error (tn) (lambda () (apply + 1))) (assert-error (tn) (lambda () (apply + 1 2))) (assert-error (tn) (lambda () (apply + 1 2 3))) (assert-error (tn) (lambda () (apply + 1 2 . 3))) (tn "apply single-argument") (assert-equal? (tn) 0 (apply + '())) (assert-equal? (tn) 1 (apply + '(1))) (assert-equal? (tn) 3 (apply + '(1 2))) (assert-equal? (tn) 6 (apply + '(1 2 3))) (tn "apply multi-arguments") (assert-equal? (tn) 1 (apply + 1 '())) (assert-equal? (tn) 3 (apply + 1 2 '())) (assert-equal? (tn) 3 (apply + 1 '(2))) (assert-equal? (tn) 6 (apply + 1 2 3 '())) (assert-equal? (tn) 6 (apply + 1 2 '(3))) (assert-equal? (tn) 6 (apply + 1 '(2 3))) ;; Further tests exist on bigloo-apply.scm (tn "apply that returns multiple values") (call-with-values (lambda () (apply values '(1 2 3))) (lambda vals (assert-equal? (tn) '(1 2 3) vals))) (call-with-values (lambda () (apply values 1 2 '(3))) (lambda vals (assert-equal? (tn) '(1 2 3) vals))) ;; check apply (assert-equal? "apply check1" #t (apply = '(1 1 1))) (assert-equal? "apply check2" 6 (apply + `(1 2 ,(+ 1 2)))) (assert-equal? "apply check3" '(3) (apply cddr '((1 2 3)))) (assert-equal? "apply check4" #t (apply equal? '((1 2) (1 2)))) (assert-equal? "apply check5" "iu" (apply substring '("aiueo" 1 3))) (assert-equal? "apply check6" 4 (apply (lambda (x y) (+ x y)) '(1 3))) (assert-equal? "apply check7" 4 (apply (lambda (x y) (+ x y)) '(1 3))) (assert-equal? "apply check8" '(1 2 3) (apply (lambda x x) '(1 2 3))) (assert-equal? "apply check9" 1 (apply (lambda (x) x) '(1))) (assert-equal? "apply check10" '(1) (apply (lambda x x) '(1))) (assert-equal? "apply check11" 2 (apply (lambda x x 2) '(1))) (assert-equal? "apply check12" '() (apply (lambda (a . b) b) '(1))) (assert-equal? "apply check13" '(2) (apply (lambda (a . b) b) '(1 2))) (assert-equal? "apply check13" '() (apply (lambda (a b . c) c) '(1 2))) (define (dotarg-2 x . y) (+ x (car y))) (assert-equal? "sequence dot-arg func apply check" 4 (apply dotarg-2 '(1 3))) (assert-equal? "sequence dot-arg func apply check" 4 (apply dotarg-2 '(1 3))) (define compose (lambda (f g) (lambda args (f (apply g args))))) (assert-equal? "apply check5" "100" ((compose number->string *) 4 25)) (total-report) uim-1.8.8/sigscheme/test/test-syntax.scm0000644000175000017500000003377412532333147015221 00000000000000;; Filename : test-syntax.scm ;; About : unit test for R5RS syntaxes ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) (define tee #t) (define ef #f) ;; ;; if ;; (tn "if invalid form") (assert-error (tn) (lambda () (if))) (assert-error (tn) (lambda () (if #t))) (assert-error (tn) (lambda () (if #f))) (assert-error (tn) (lambda () (if #t 'true 'false 'excessive))) (assert-error (tn) (lambda () (if #f 'true 'false 'excessive))) (tn "if") (assert-equal? (tn) 'true (if #t 'true 'false)) (assert-equal? (tn) 'true (if #t 'true)) (assert-equal? (tn) 'false (if #f 'true 'false)) ;; check that does not cause error (assert-equal? (tn) (if #f 'true) (if #f 'true)) ;; check that is evaluated (assert-equal? (tn) 'true (if tee 'true 'false)) (assert-equal? (tn) 'false (if ef 'true 'false)) ;; ;; set! ;; (tn "set! invalid form") (define test-var #f) (assert-error (tn) (lambda () (set!))) (assert-error (tn) (lambda () (set! test-unbound))) (assert-error (tn) (lambda () (set! test-var))) (assert-error (tn) (lambda () (set! test-var #t #t))) (assert-error (tn) (lambda () (set! 1 #t))) (tn "set!") (assert-true (tn) (set! test-var 'foo)) (assert-equal? (tn) 'foo test-var) (assert-true (tn) (let ((test-var #f)) (set! test-var 'bar))) (assert-equal? (tn) 'foo test-var) (assert-true (tn) (let ((test-var #f)) (let ((test-var2 #f)) (set! test-var 'baz)) (assert-equal? (tn) 'baz test-var))) (assert-equal? (tn) 'foo test-var) (assert-error (tn) (lambda () (set! test-unbound 'foo))) (assert-error (tn) (lambda () (let ((test-var #f)) (set! test-unbound 'foo)))) ;; ;; cond ;; (tn "cond invalid form") ;; 'cond' must contain at least one clause (assert-error (tn) (lambda () (cond))) ;; empty clause (assert-error (tn) (lambda () (cond ()))) ;; empty clause with 'else' (assert-error (tn) (lambda () (cond () (else #t)))) ;; 'else' followed by another caluse (assert-error (tn) (lambda () (cond (else #t) (#t)))) ;; 'else' clause must contain at least one expression (7.1.3 Expressions) (assert-error (tn) (lambda () (cond (else)))) ;; '=>' is interpreted as unbound symbol if not followed by (assert-error (tn) (lambda () (cond (#t =>)))) ;; '=>' is interpreted as unbound symbol (assert-error (tn) (lambda () (cond (=>)))) ;; evaluation of '=>' causes error even if 'else' clause exists (assert-error (tn) (lambda () (cond (#t =>) (else #t)))) ;; '=>' is interpreted as unbound symbol even if in 'else' clause (assert-error (tn) (lambda () (cond (else =>)))) ;; '=>' is interpreted as unbound symbol even if in 'else' clause (assert-error (tn) (lambda () (cond (else => 1 3)))) ;; not a procedure (assert-error (tn) (lambda () (cond (#t => #t)))) (assert-error (tn) (lambda () (cond (#t => #f)))) ;; procedure but argument number mismatch (assert-error (tn) (lambda () (cond (#t => eq?)))) ;; not a procedure but a syntax (assert-error (tn) (lambda () (cond (#t => delay)))) ;; '=>' is not applicable at 'else' clause (assert-error (tn) (lambda () (cond (else => values)))) (tn "cond unspecified behavior") ;; not specified in R5RS, but SigScheme surely returns # (if (provided? "sigscheme") (assert-equal? (tn) (undef) (cond (#f)))) (if (provided? "sigscheme") (assert-equal? (tn) (undef) (cond ((even? 3) #f) ((positive? -1) #f)))) (tn "cond") ;; R5RS: If the selected contains only the and no ;; s, then the value of the is returned as the result. (assert-equal? (tn) #t (cond (#t))) (assert-equal? (tn) 3 (cond (#f) (3))) (assert-equal? (tn) 3 (cond ((not #t)) ((+ 1 2)))) (assert-equal? (tn) 3 (cond (#f) (3) (4))) (assert-equal? (tn) 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) (assert-equal? (tn) 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) (assert-equal? (tn) #t (cond ((> 3 2)) ((< 3 4) 'less) (else 'equal))) (assert-equal? (tn) 2 (cond ((assv 'b '((a 1) (b 2))) => cadr) (else #f))) (assert-equal? (tn) 2 (cond ((assv 'b '((a 1) (b 2))) => (car (list cadr cdar))) (else #f))) (assert-equal? (tn) #f (cond ((assv 'c '((a 1) (b 2))) => cadr) (else #f))) (assert-equal? (tn) 'greater1 (cond ((> 3 2) 'greater0 'greater1) (else #f))) ;; single 'else' clause is allowed (assert-equal? (tn) 'else (cond (else 'else))) ;; '=>' is interpreted as ordinary symbol if not followed by exactly one (assert-equal? (tn) 'defined (let ((=> 'defined)) (cond (#t =>)))) (assert-equal? (tn) 3 (let ((=> 'defined)) (cond (#t => 1 3)))) ;; ;; case ;; (tn "case invalid form") (assert-error (tn) (lambda () (case))) (assert-error (tn) (lambda () (case 'key))) (assert-error (tn) (lambda () (case 'key ()))) ;; case requires at least one in a clause (assert-error (tn) (lambda () (case 'key ((key))))) (assert-error (tn) (lambda () (case 'key ((1 key))))) (assert-error (tn) (lambda () (case 'key (1)))) (assert-error (tn) (lambda () (case 'key ((1 . 2))))) ;; not a (( ...) ...) style clause (assert-error (tn) (lambda () (case 'key (1 'matched)))) (assert-error (tn) (lambda () (case 'key (key 'matched)))) (assert-error (tn) (lambda () (case 'key (#(key) 'matched)))) (if (provided? "sigscheme") (begin ;; improper clause does not cause error if not evaled (assert-equal? (tn) (undef) (case 'key ((1) . 2))) (assert-equal? (tn) (undef) (case 'key ((1) #t . 2))) ;; causes error when evaled (assert-error (tn) (lambda () (case 1 ((1) . 2)))) (assert-error (tn) (lambda () (case 1 ((1) #t . 2)))))) (assert-error (tn) (lambda () (case 'key () (else #t)))) ;; 'else' followed by another caluse (assert-error (tn) (lambda () (case 'key (else #t) (#t)))) ;; not specified in R5RS, but SigScheme should cause error (if (provided? "sigscheme") (assert-error (tn) (lambda () (case 'key (else))))) (assert-error (tn) (lambda () (case 'key (=>)))) (assert-error (tn) (lambda () (case 'key (#t =>)))) (assert-error (tn) (lambda () (case 'key (#t =>) (else #t)))) (assert-error (tn) (lambda () (case 'key (else =>)))) (assert-error (tn) (lambda () (case 'key (else => symbol?)))) (assert-error (tn) (lambda () (case 'key (else => #t)))) ;; ( => ) clause is not supported by 'case' (assert-error (tn) (lambda () (case 'key ((key) => values)))) (assert-error (tn) (lambda () (case 'key ((key) => eq?)))) (assert-error (tn) (lambda () (case 'key ((key) => delay)))) (assert-error (tn) (lambda () (case 'key ((key) => #t)))) (assert-error (tn) (lambda () (case 'key ((key) => #f)))) (tn "case unspecified behavior") ;; not specified in R5RS, but SigScheme surely returns # (if (provided? "sigscheme") (assert-equal? (tn) (undef) (case 'key ((#f) #f)))) (if (provided? "sigscheme") (assert-equal? (tn) (undef) (case 'key ((foo) #f) ((bar) #f)))) (tn "case") (assert-equal? (tn) 'odd (case 3 ((1 3 5) 'odd) ((2 4 6) 'even))) (assert-equal? (tn) 'unknown (case 0 ((1 3 5) 'odd) ((2 4 6) 'even) (else 'unknown))) (assert-equal? (tn) 'odd (case (+ 1 2) ((1 3 5) 'odd) ((2 4 6) 'even) (else 'unknown))) (assert-equal? (tn) 'second (case 3 ((1 3 5) 'first 'second) ((2 4 6) 'even) (else 'unknown))) (assert-equal? (tn) 'second (case (+ 1 2) ((1 3 5) 'first 'second) ((2 4 6) 'even) (else 'unknown))) (assert-equal? (tn) 'third (case 'key ((1 foo 5) 'first 'second) ((2 key 6) 'third) (else 'unknown))) (assert-equal? (tn) 'third (case (cadr '(foo key bar)) ((1 foo 5) 'first 'second) ((2 key 6) 'third) (else 'unknown))) ;; single 'else' clause is allowed (assert-equal? (tn) 'else (case 'key (else 'else))) ;; ;; and ;; (tn "and") (assert-error (tn) (lambda () (and . #t))) (assert-error (tn) (lambda () (and #t . #t))) (assert-equal? (tn) #t (and)) (assert-equal? (tn) #t (and (= 2 2) (> 2 1))) (assert-equal? (tn) #f (and (= 2 2) (< 2 1))) (assert-equal? (tn) '(f g) (and 1 2 'c '(f g))) (assert-equal? (tn) #f (and #t #f)) (assert-equal? (tn) 3 (and #t (+ 1 2))) (assert-equal? (tn) #f (and #t (not 3) (+ 1 2))) ;; ;; or ;; (tn "or") (assert-error (tn) (lambda () (or . #t))) (assert-error (tn) (lambda () (or #t . #t))) (assert-equal? (tn) #f (or)) (assert-equal? (tn) #t (or (= 2 2) (> 2 1))) (assert-equal? (tn) #t (or (= 2 2) (< 2 1))) (assert-equal? (tn) #f (or #f #f #f)) (assert-equal? (tn) '(b c) (or (memq 'b '(a b c)) (/ 3 0))) (assert-equal? (tn) 3 (or #f (+ 1 2))) (assert-equal? (tn) 3 (or #f (not 3) (+ 1 2) (not 4))) (total-report) uim-1.8.8/sigscheme/test/test-define-internal.scm0000644000175000017500000005747012532333147016736 00000000000000;; Filename : test-define-internal.scm ;; About : unit test for R5RS internal definitions ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; internal definitions in 'let' variants are writtin at test-let.scm (require-extension (unittest)) (if (not (provided? "internal-definitions")) (test-skip "R5RS internal definitions is not enabled")) (define tn test-name) (define *test-track-progress* #f) (tn "internal defintions") (assert-equal? (tn) 14 (let ((x 5)) (+ (let () (define x 6) (+ x 3)) x))) (assert-equal? (tn) 14 (let ((x 5)) (+ (let* () (define x 6) (+ x 3)) x))) (assert-equal? (tn) 14 (let ((x 5)) (+ (letrec () (define x 6) (+ x 3)) x))) (assert-equal? (tn) 14 (let ((x 5)) (+ ((lambda () (define x 6) (+ x 3))) x))) (assert-equal? (tn) 14 (let ((x 5)) (+ (let () (define (f) (define x 6) (+ x 3)) (f)) x))) (tn "internal defintions: letrec-like behavior") (assert-equal? (tn) 45 (let ((x 5)) (define foo (lambda (y) (bar x y))) (define bar (lambda (a b) (+ (* a b) a))) (foo (+ x 3)))) (assert-equal? (tn) 45 (let ((x 5)) (define bar (lambda (a b) (+ (* a b) a))) (define foo (lambda (y) (bar x y))) (foo (+ x 3)))) (assert-error (tn) (lambda () (let ((x 5)) (define foo bar) (define bar (lambda (a b) (+ (* a b) a))) (foo x (+ x 3))))) (assert-error (tn) (lambda () (let ((x 5)) (define bar (lambda (a b) (+ (* a b) a))) (define foo bar) (foo x (+ x 3))))) (assert-error (tn) (lambda () (let () (define foo 1) (define bar (+ foo 1)) (+ foo bar)))) (assert-error (tn) (lambda () (let () (define bar (+ foo 1)) (define foo 1) (+ foo bar)))) (assert-error (tn) (lambda () (let ((foo 3)) (define foo 1) (define bar (+ foo 1)) (+ foo bar)))) (assert-error (tn) (lambda () (let ((foo 3)) (define bar (+ foo 1)) (define foo 1) (+ foo bar)))) (tn "internal defintions: non-beginning of block") (assert-error (tn) (lambda () (let () (define foo 1) (set! foo 5) (define bar 2) (+ foo bar)))) (assert-error (tn) (lambda () (let* () (define foo 1) (set! foo 5) (define bar 2) (+ foo bar)))) (assert-error (tn) (lambda () (letrec () (define foo 1) (set! foo 5) (define bar 2) (+ foo bar)))) (assert-error (tn) (lambda () ((lambda () (define foo 1) (set! foo 5) (define bar 2) (+ foo bar))))) (assert-error (tn) (lambda () (define (f) (define foo 1) (set! foo 5) (define bar 2) (+ foo bar)) (f))) (tn "internal defintions: non-beginning of block (in begin)") (assert-error (tn) (lambda () (let () (define foo 1) (set! foo 5) (begin (define bar 2)) (+ foo bar)))) (assert-error (tn) (lambda () (let* () (define foo 1) (set! foo 5) (begin (define bar 2)) (+ foo bar)))) (assert-error (tn) (lambda () (letrec () (define foo 1) (set! foo 5) (begin (define bar 2)) (+ foo bar)))) (assert-error (tn) (lambda () ((lambda () (define foo 1) (set! foo 5) (begin (define bar 2)) (+ foo bar))))) (assert-error (tn) (lambda () (define (f) (define foo 1) (set! foo 5) (begin (define bar 2)) (+ foo bar)) (f))) (tn "internal defintions: non-beginning of block (in eval)") (assert-equal? (tn) 7 (let () (define foo 1) (set! foo 5) (eval '(define bar 2) (interaction-environment)) (+ foo bar))) (assert-equal? (tn) 7 (let* () (define foo 1) (set! foo 5) (eval '(define bar 2) (interaction-environment)) (+ foo bar))) (assert-equal? (tn) 7 (letrec () (define foo 1) (set! foo 5) (eval '(define bar 2) (interaction-environment)) (+ foo bar))) (assert-equal? (tn) 7 ((lambda () (define foo 1) (set! foo 5) (eval '(define bar 2) (interaction-environment)) (+ foo bar)))) (assert-equal? (tn) 7 (let () (define (f) (define foo 1) (set! foo 5) (eval '(define bar 2) (interaction-environment)) (+ foo bar)) (f))) ;; As specified as follows in R5RS, definitions in following forms are invalid. ;; ;; 5.2 Definitions ;; ;; Definitions are valid in some, but not all, contexts where expressions are ;; allowed. They are valid only at the top level of a and at the ;; beginning of a . ;; ;; 5.2.2 Internal definitions ;; ;; Definitions may occur at the beginning of a (that is, the body of a ;; lambda, let, let*, letrec, let-syntax, or letrec-syntax expression or that ;; of a definition of an appropriate form). ;; ;; Wherever an internal definition may occur (begin ...) is ;; equivalent to the sequence of definitions that form the body of the begin. (tn "definition in do") (assert-error (tn) (lambda () (do ((i 0 (+ i 1))) ((= i 1) (+ x 3)) (define x 6)))) (assert-error (tn) (lambda () (do ((i 0 (+ i 1))) ((= i 1) (+ x 3)) (begin (define x 6))))) (assert-equal? (tn) 9 (do ((i 0 (+ i 1))) ((= i 1) (+ x 3)) (eval '(define x 6) (interaction-environment)))) (tn "definition in if") (assert-error (tn) (lambda () (if #t (define x 6)))) (assert-error (tn) (lambda () (if #t (begin (define x 6))))) (assert-equal? (tn) 'x (if #t (eval '(define x 6) (interaction-environment)))) (tn "func-form define internal definitions lacking sequence part") ;; at least one is required (define (f) (define var1 1)) (assert-error (tn) (lambda () (f))) (define (f) (define (proc1) 1)) (assert-error (tn) (lambda () (f))) (define (f) (define var1 1) (define var2 2)) (assert-error (tn) (lambda () (f))) (define (f) (define (proc1) 1) (define (proc2) 2)) (assert-error (tn) (lambda () (f))) (define (f) (define var1 1) (define (proc2) 2)) (assert-error (tn) (lambda () (f))) (define (f) (define (proc1) 1) (define var2 2)) (assert-error (tn) (lambda () (f))) (define (f) (begin)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define var2 2))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define (proc2) 2))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define (proc2) 2))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define var2 2))) (assert-error (tn) (lambda () (f))) ;; appending a non-definition expression into a begin block is invalid (define (f) (begin (define var1 1) 'val)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) 'val)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define var2 2) 'val)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define (proc2) 2) 'val)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define (proc2) 2) 'val)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define var2 2) 'val)) (assert-error (tn) (lambda () (f))) (tn "func-form define internal definitions cross reference") ;; R5RS: 5.2.2 Internal definitions ;; Just as for the equivalent `letrec' expression, it must be possible to ;; evaluate each of every internal definition in a without ;; assigning or referring to the value of any being defined. (define (f) (define var1 1) (define var2 var1) 'val) (assert-error (tn) (lambda () (f))) (define (f) (define var1 var2) (define var2 2) 'val) (assert-error (tn) (lambda () (f))) (define (f) (define var1 var1) 'val) (assert-error (tn) (lambda () (f))) (define (f var0) (define var1 var0) (define var2 var0) (begin (define var3 var0) (begin (define var4 var0))) (define var5 var0) (list var1 var2 var3 var4 var5)) (assert-equal? (tn) '(0 0 0 0 0) (f 0)) (assert-equal? (tn) '(#f #f #f #f #f #f) (list (symbol-bound? 'var0) (symbol-bound? 'var1) (symbol-bound? 'var2) (symbol-bound? 'var3) (symbol-bound? 'var4) (symbol-bound? 'var5))) (define (f var0) (define var1 (symbol-bound? 'var1)) (define var2 (symbol-bound? 'var1)) (begin (define var3 (symbol-bound? 'var1)) (begin (define var4 (symbol-bound? 'var1)))) (define var5 (symbol-bound? 'var1)) (list var0 var1 var2 var3 var4 var5)) (assert-equal? (tn) '(#f #f #f #f #f #f) (f #f)) (define (f var0) (define var1 (symbol-bound? 'var3)) (define var2 (symbol-bound? 'var3)) (begin (define var3 (symbol-bound? 'var3)) (begin (define var4 (symbol-bound? 'var3)))) (define var5 (symbol-bound? 'var3)) (list var0 var1 var2 var3 var4 var5)) (assert-equal? (tn) '(#f #f #f #f #f #f) (f #f)) (define (f var0) (define var1 (symbol-bound? 'var4)) (define var2 (symbol-bound? 'var4)) (begin (define var3 (symbol-bound? 'var4)) (begin (define var4 (symbol-bound? 'var4)))) (define var5 (symbol-bound? 'var4)) (list var0 var1 var2 var3 var4 var5)) (assert-equal? (tn) '(#f #f #f #f #f #f) (f #f)) (define (f var0) (define var1 (symbol-bound? 'var5)) (define var2 (symbol-bound? 'var5)) (begin (define var3 (symbol-bound? 'var5)) (begin (define var4 (symbol-bound? 'var5)))) (define var5 (symbol-bound? 'var5)) (list var0 var1 var2 var3 var4 var5)) (assert-equal? (tn) '(#f #f #f #f #f #f) (f #f)) ;; defining procedure can refer other (and self) variables as if letrec (define (f var0) (define var1 (lambda () var0)) (define var2 (lambda () var0)) (begin (define var3 (lambda () var0)) (begin (define var4 (lambda () var0)))) (define var5 (lambda () var0)) (list (eq? (var1) var0) (eq? (var2) var0) (eq? (var3) var0) (eq? (var4) var0) (eq? (var5) var0))) (assert-equal? (tn) '(#t #t #t #t #t) (f (lambda () 0))) (define (f) (define var1 (lambda () var1)) (define var2 (lambda () var1)) (begin (define var3 (lambda () var1)) (begin (define var4 (lambda () var1)))) (define var5 (lambda () var1)) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1) (eq? (var4) var1) (eq? (var5) var1))) (assert-equal? (tn) '(#t #t #t #t #t) (f)) (define (f) (define var1 (lambda () var2)) (define var2 (lambda () var2)) (begin (define var3 (lambda () var2)) (begin (define var4 (lambda () var2)))) (define var5 (lambda () var2)) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2) (eq? (var4) var2) (eq? (var5) var2))) (assert-equal? (tn) '(#t #t #t #t #t) (f)) (define (f) (define var1 (lambda () var4)) (define var2 (lambda () var4)) (begin (define var3 (lambda () var4)) (begin (define var4 (lambda () var4)))) (define var5 (lambda () var4)) (list (eq? (var1) var4) (eq? (var2) var4) (eq? (var3) var4) (eq? (var4) var4) (eq? (var5) var4))) (assert-equal? (tn) '(#t #t #t #t #t) (f)) (define (f) (define var1 (lambda () var5)) (define var2 (lambda () var5)) (begin (define var3 (lambda () var5)) (begin (define var4 (lambda () var5)))) (define var5 (lambda () var5)) (list (eq? (var1) var5) (eq? (var2) var5) (eq? (var3) var5) (eq? (var4) var5) (eq? (var5) var5))) (assert-equal? (tn) '(#t #t #t #t #t) (f)) (tn "func-form define internal definitions valid forms") ;; valid internal definitions (define (f) (define var1 1) (list var1)) (assert-equal? (tn) '(1) (f)) (define (f) (define (proc1) 1) (list (proc1))) (assert-equal? (tn) '(1) (f)) (define (f) (define var1 1) (define var2 2) (list var1 var2)) (assert-equal? (tn) '(1 2) (f)) (define (f) (define (proc1) 1) (define (proc2) 2) (list (proc1) (proc2))) (assert-equal? (tn) '(1 2) (f)) (define (f) (define var1 1) (define (proc2) 2) (list var1 (proc2))) (assert-equal? (tn) '(1 2) (f)) (define (f) (define (proc1) 1) (define var2 2) (list (proc1) var2)) (assert-equal? (tn) '(1 2) (f)) ;; SigScheme accepts '(begin)' as valid internal definition '(begin ;; *)' as defined in "7.1.6 Programs and definitions" of R5RS ;; although it is rejected as expression '(begin )' as defined in ;; "7.1.3 Expressions". (define (f) (begin) 1) (assert-equal? (tn) 1 (f)) (define (f) (begin) (define var1 1) (begin) 1) (assert-equal? (tn) 1 (f)) (define (f) (begin (define var1 1)) (list var1)) (assert-equal? (tn) '(1) (f)) (define (f) (begin (define (proc1) 1)) (list (proc1))) (assert-equal? (tn) '(1) (f)) (define (f) (begin (define var1 1) (define var2 2)) (list var1 var2)) (assert-equal? (tn) '(1 2) (f)) (define (f) (begin (define (proc1) 1) (define (proc2) 2)) (list (proc1) (proc2))) (assert-equal? (tn) '(1 2) (f)) (define (f) (begin (define var1 1) (define (proc2) 2)) (list var1 (proc2))) (assert-equal? (tn) '(1 2) (f)) (define (f) (begin (define (proc1) 1) (define var2 2)) (list (proc1) var2)) (assert-equal? (tn) '(1 2) (f)) (define (f) (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)) (assert-equal? (tn) '(1 2 3 4 5 6) (f)) ;; begin block and single definition mixed (define (f) (begin) (define (proc1) 1) (begin (define var2 2) (begin (define (proc3) 3) (begin) (define var4 4))) (begin) (define (proc5) 5) (begin (begin (begin (begin))) (define var6 6) (begin)) (begin) (list (proc1) var2 (proc3) var4 (proc5) var6)) (assert-equal? (tn) '(1 2 3 4 5 6) (f)) (tn "func-form define internal definitions invalid begin blocks") (define (f) (begin (define var1 1) 'val) (list var1)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) 'val) (list (proc1))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define var2 2) 'val) (list var1 var2)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define (proc2) 2) 'val) (list (proc1) (proc2))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define var1 1) (define (proc2) 2) 'val) (list var1 (proc2))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define var2 2) 'val) (list (proc1) var2)) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6) 'val))) (list (proc1) var2 (proc3) var4 (proc5) var6)) (tn "func-form define internal definitions invalid placement") ;; a non-definition expression prior to internal definition is invalid (assert-error (tn) (lambda () (f))) (define (f) 'val (define var1 1)) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1)) (assert-error (tn) (lambda () (f))) (define (f) 'val (define var1 1) (define var2 2)) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1) (define (proc2) 2)) (assert-error (tn) (lambda () (f))) (define (f) 'val (define var1 1) (define (proc2) 2)) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1) (define var2 2)) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin)) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1) (define var2 2))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define (proc2) 2))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1) (define (proc2) 2))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define var2 2))) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))) (assert-error (tn) (lambda () (f))) (define (f) (begin (define (proc1) 1) (define var2 2) 'val (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))) (assert-error (tn) (lambda () (f))) ;; a non-definition expression prior to internal definition is invalid even if ;; expression(s) is following the internal definition (define (f) 'val (define var1 1) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (define var1 1) (define var2 2) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1) (define (proc2) 2) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (define var1 1) (define (proc2) 2) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (define (proc1) 1) (define var2 2) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1) (define var2 2)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define (proc2) 2)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define var1 1) (define (proc2) 2)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define var2 2)) 'val) (assert-error (tn) (lambda () (f))) (define (f) 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)) (assert-error (tn) (lambda () (f))) (total-report) uim-1.8.8/sigscheme/test/test-srfi6.scm0000644000175000017500000000763612532333147014722 00000000000000;; Filename : test-srfi6.scm ;; About : unit test for SRFI-6 Basic String Ports ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (require-extension (srfi 6)) (if (not (provided? "srfi-6")) (test-skip "SRFI-6 is not enabled")) (define tn test-name) ;; ;; open-input-string ;; (tn "open-input-string invalid forms") (assert-error (tn) (lambda () (open-input-string))) (assert-error (tn) (lambda () (open-input-string '()))) (assert-error (tn) (lambda () (open-input-string (current-input-port)))) (assert-error (tn) (lambda () (open-input-string "" ""))) ;; immutable (define p (open-input-string "(a . (b . (c . ()))) 34")) (tn "open-input-string immutable") (assert-true (tn) (input-port? p)) (assert-equal? (tn) '(a b c) (read p)) (assert-equal? (tn) 34 (read p)) (assert-true (tn) (eof-object? (read p))) (assert-true (tn) (eof-object? (read-char (open-input-string "")))) ;; mutable (define p2 (open-input-string (string-copy "(a . (b . (c . ()))) 34"))) (tn "open-input-string mutable") (assert-true (tn) (input-port? p2)) (assert-equal? (tn) '(a b c) (read p2)) (assert-equal? (tn) 34 (read p2)) (assert-true (tn) (eof-object? (read p2))) (assert-true (tn) (eof-object? (read-char (open-input-string (string-copy ""))))) ;; ;; open-output-string and get-output-string ;; (tn "open-output-string invalid forms") (assert-error (tn) (lambda () (open-output-string '()))) (assert-error (tn) (lambda () (open-output-string (current-input-port)))) (assert-error (tn) (lambda () (open-output-string ""))) (tn "get-output-string invalid forms") (assert-error (tn) (lambda () (get-output-string))) (assert-error (tn) (lambda () (get-output-string (current-output-port)))) (tn "output string") (assert-equal? (tn) "a(b c)" (let ((q (open-output-string)) (x '(a b c))) (write (car x) q) (write (cdr x) q) (get-output-string q))) (assert-equal? (tn) "aB" (let ((q (open-output-string))) (write-char #\a q) (write-char #\B q) (get-output-string q))) (assert-equal? (tn) "" (get-output-string (open-output-string))) (total-report) uim-1.8.8/sigscheme/test/test-sscm-ext.scm0000644000175000017500000002001113274233465015420 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-sscm-ext.scm ;; About : unit tests for SigScheme specific extensions ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (sscm-ext)) (require-extension (unittest)) (if (not (symbol-bound? 'let-optionals*)) (test-skip "SigScheme extensions are not enabled")) (define tn test-name) (define ud (undef)) (tn "sscm-version") (assert-equal? (tn) "0.9.0" (sscm-version)) (tn "%%current-char-codec") (assert-equal? (tn) "UTF-8" (%%current-char-codec)) (tn "%%set-current-char-codec!") (assert-error (tn) (lambda () (%%set-current-char-codec! ""))) (assert-error (tn) (lambda () (%%set-current-char-codec! "UTF-32"))) (assert-equal? (tn) "UTF-8" (%%set-current-char-codec! "UTF-8")) (assert-equal? (tn) "UTF-8" (%%current-char-codec)) (assert-equal? (tn) "ISO-8859-1" (%%set-current-char-codec! "ISO-8859-1")) (assert-equal? (tn) "ISO-8859-1" (%%current-char-codec)) (assert-error (tn) (lambda () (%%set-current-char-codec! "UTF-32"))) (assert-equal? (tn) "ISO-8859-1" (%%current-char-codec)) (assert-equal? (tn) "UTF-8" (%%set-current-char-codec! "UTF-8")) (assert-equal? (tn) "UTF-8" (%%current-char-codec)) ;; sigscheme-init.scm (tn "with-char-codec") (assert-equal? (tn) "UTF-8" (%%current-char-codec)) (assert-equal? (tn) "ISO-8859-1" (with-char-codec "ISO-8859-1" (lambda () (%%current-char-codec)))) (assert-equal? (tn) "UTF-8" (with-char-codec "UTF-8" (lambda () (%%current-char-codec)))) (assert-equal? (tn) "UTF-8" (begin (guard (err (else #f)) (with-char-codec "ISO-8859-1" (lambda () (error "error in the thunk")))) (%%current-char-codec))) (assert-equal? (tn) "UTF-8" (begin (call-with-current-continuation (lambda (k) (with-char-codec "ISO-8859-1" (lambda () (k #f))))) (%%current-char-codec))) (tn "let-optionals* invalid forms") (assert-error (tn) (lambda () (let-optionals* '() ()))) (assert-error (tn) (lambda () (let-optionals* #(0) () #t))) (assert-error (tn) (lambda () (let-optionals* #(0) args args))) (assert-error (tn) (lambda () (let-optionals* '() #(0) #t))) (assert-error (tn) (lambda () (let-optionals* '() (0) #t))) (assert-error (tn) (lambda () (let-optionals* '(0 1 2) (a . 3) #t))) (tn "let-optionals* null bindings") (assert-equal? (tn) 'ok (let-optionals* '() () 'ok)) (assert-equal? (tn) 'ok (let-optionals* '(0) () 'ok)) (assert-equal? (tn) 'ok (let-optionals* '(0 1) () 'ok)) (assert-equal? (tn) 'ok (let-optionals* '(0 1 2) () 'ok)) ;; Conforms to the undocumented behavior of Gauche 0.8.8. (tn "let-optionals* restvar-only") (assert-equal? (tn) '() (let-optionals* '() args args)) (assert-equal? (tn) '(0) (let-optionals* '(0) args args)) (assert-equal? (tn) '(0 1) (let-optionals* '(0 1) args args)) (assert-equal? (tn) '(0 1 2) (let-optionals* '(0 1 2) args args)) (tn "let-optionals* var-only single binding") (assert-equal? (tn) (undef) (let-optionals* '() (a) a)) (assert-equal? (tn) 0 (let-optionals* '(0) (a) a)) (assert-equal? (tn) 0 (let-optionals* '(0 1) (a) a)) (tn "let-optionals* var-only bindings") (assert-equal? (tn) (list ud ud) (let-optionals* '() (a b) (list a b))) (assert-equal? (tn) (list 0 ud) (let-optionals* '(0) (a b) (list a b))) (assert-equal? (tn) '(0 1) (let-optionals* '(0 1) (a b) (list a b))) (assert-equal? (tn) '(0 1) (let-optionals* '(0 1 2) (a b) (list a b))) (tn "let-optionals* var-only bindings with restvar") (assert-equal? (tn) (list ud ud '()) (let-optionals* '() (a b . c) (list a b c))) (assert-equal? (tn) (list 0 ud '()) (let-optionals* '(0) (a b . c) (list a b c))) (assert-equal? (tn) '(0 1 ()) (let-optionals* '(0 1) (a b . c) (list a b c))) (assert-equal? (tn) '(0 1 (2)) (let-optionals* '(0 1 2) (a b . c) (list a b c))) (assert-equal? (tn) '(0 1 (2 3)) (let-optionals* '(0 1 2 3) (a b . c) (list a b c))) (tn "let-optionals* var-defaultval single binding") (assert-equal? (tn) 'A (let-optionals* '() ((a 'A)) a)) (assert-equal? (tn) 0 (let-optionals* '(0) ((a 'A)) a)) (assert-equal? (tn) 0 (let-optionals* '(0 1) ((a 'A)) a)) (tn "let-optionals* var-defaultval bindings") (assert-equal? (tn) '(A B) (let-optionals* '() ((a 'A) (b 'B)) (list a b))) (assert-equal? (tn) '(0 B) (let-optionals* '(0) ((a 'A) (b 'B)) (list a b))) (assert-equal? (tn) '(0 1) (let-optionals* '(0 1) ((a 'A) (b 'B)) (list a b))) (assert-equal? (tn) '(0 1) (let-optionals* '(0 1 2) ((a 'A) (b 'B)) (list a b))) (tn "let-optionals* var-defaultval bindings with restvar") (assert-equal? (tn) '(A B ()) (let-optionals* '() ((a 'A) (b 'B) . c) (list a b c))) (assert-equal? (tn) '(0 B ()) (let-optionals* '(0) ((a 'A) (b 'B) . c) (list a b c))) (assert-equal? (tn) '(0 1 ()) (let-optionals* '(0 1) ((a 'A) (b 'B) . c) (list a b c))) (assert-equal? (tn) '(0 1 (2)) (let-optionals* '(0 1 2) ((a 'A) (b 'B) . c) (list a b c))) (assert-equal? (tn) '(0 1 (2 3)) (let-optionals* '(0 1 2 3) ((a 'A) (b 'B) . c) (list a b c))) (tn "let-optionals* sequencial evaluation") (assert-equal? (tn) '(2 5 10) (let-optionals* '() ((a 2) (b (+ a 3)) (c (* a b))) (list a b c))) (assert-equal? (tn) '(3 6 18) (let-optionals* '(3 6) ((a 2) (b (+ a 3)) (c (* a b))) (list a b c))) (tn "let-optionals* normal cases") (assert-equal? (tn) '(21 3) (let-optionals* '(7) ((a 2) (b 3)) (set! a (* a b)) (list a b))) (assert-equal? (tn) '(21 3) (let-optionals* '(7) (a (b 3)) (set! a (* a b)) (list a b))) (total-report) uim-1.8.8/sigscheme/test/test-string-null.scm0000644000175000017500000000475312532333147016144 00000000000000;; Filename : test-string-null.scm ;; About : unit test for strings that contain NUL character ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (if (and (provided? "sigscheme") (not (provided? "null-capable-string"))) (test-skip "null character in a middle of string is not enabled")) ;; R6RS(SRFI-75) compliant (tn "R6RS escape sequence") (assert-equal? (tn) (integer->string 0) "\x00") ;; 0 (assert-equal? (tn) (list->string '(#\nul)) "\x00") ;; 0 (assert-equal? (tn) '(#\nul) (string->list "\x00")) ;; 0 ;; raw control chars (tn "raw control char in string literal") (assert-equal? (tn) (integer->string 0) "") ;; 0 ;; escaped raw control chars (tn "escaped raw control char in string literal") ;;(assert-parse-error (tn) "\"\\\"") ;; 0 ;; cannot read by string port (total-report) uim-1.8.8/sigscheme/test/test-do.scm0000644000175000017500000004756112532333147014274 00000000000000;; Filename : test-do.scm ;; About : unit test for R5RS 'do' syntax ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; ;; do ;; (tn "do invalid form") (assert-error (tn) (lambda () (do))) (assert-error (tn) (lambda () (do v))) (assert-error (tn) (lambda () (do (v 1)))) (assert-error (tn) (lambda () (do ((v 1)) ))) (assert-error (tn) (lambda () (do ((v)) 'eval))) (assert-error (tn) (lambda () (do ((v 1)) 'unknow-value))) (assert-error (tn) (lambda () (do ((v 1 2 'excessive)) 'eval))) (tn "do invalid form: no test") (assert-error (tn) (lambda () (do ((v 1)) () 'eval))) (tn "do invalid form: non-list test form") (assert-error (tn) (lambda () (do ((v 1)) 'test 'eval))) (assert-error (tn) (lambda () (do ((v 1)) 1 'eval))) (tn "do invalid form: non-list bindings form") (assert-error (tn) (lambda () (do 'bindings (#t #t) 'eval))) (assert-error (tn) (lambda () (do 1 (#t #t) 'eval))) (tn "do invalid form: non-symbol variable name") (assert-error (tn) (lambda () (do ((1 1)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((#t 1)) (#t #t) #t))) (assert-error (tn) (lambda () (do (("a" 1)) (#t #t) #t))) (tn "do invalid form: duplicate variable name") (assert-error (tn) (lambda () (do ((v 1) (v 2)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((v 1) (w 0) (v 2)) (#t #t) #t))) (tn "do invalid form: improper binding") (assert-error (tn) (lambda () (do ((v . 1)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((v 1 . v)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((v 1) . 1) (#t #t) #t))) (tn "do invalid form: improper exps") (assert-error (tn) (lambda () (do ((v 1)) (#t . #t) #t))) (assert-error (tn) (lambda () (do ((v 1)) (#t #t . #t) #t))) (tn "do invalid form: improper commands") (assert-error (tn) (lambda () (do ((v 1)) (#t #t) #t . #t))) (assert-error (tn) (lambda () (do ((v 1 (+ v 1))) ((= v 2) #t) #t . #t))) (tn "do invalid form: 'define' at ") ;; Since s are evaled in toplevel env, these tests cause error only when ;; SCM_STRICT_TOPLEVEL_DEFINITIONS. (if (provided? "strict-toplevel-definitions") (begin (assert-error (tn) (lambda () (eval '(do ((i (define var1 1))) (#t #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i (begin))) (#t #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i (begin (define var1 1)))) (#t #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i (begin (define var1 1) 1))) (#t #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i (begin 1 (define var1 1)))) (#t #t) ) (interaction-environment)))))) (tn "do invalid form: 'define' at ") (assert-error (tn) (lambda () (eval '(do ((i 0 (define var1 1))) (#f #t) ) (interaction-environment)))) (if (provided? "strict-toplevel-definitions") (assert-error (tn) (lambda () (eval '(do ((i 0 (begin))) (#f #t) ) (interaction-environment))))) (assert-error (tn) (lambda () (eval '(do ((i 0 (begin (define var1 1)))) (#f #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0 (begin (define var1 1) 1))) (#f #t) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0 (begin 1 (define var1 1)))) (#f #t) ) (interaction-environment)))) (tn "do invalid form: 'define' at s") (assert-error (tn) (lambda () (eval '(do ((i 0)) (#t (define var1 1)) ) (interaction-environment)))) (if (provided? "strict-toplevel-definitions") (assert-error (tn) (lambda () (eval '(do ((i 0)) (#t (begin)) ) (interaction-environment))))) (assert-error (tn) (lambda () (eval '(do ((i 0)) (#t (begin (define var1 1))) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0)) (#t (begin (define var1 1) 1)) ) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0)) (#t (begin 1 (define var1 1))) ) (interaction-environment)))) (tn "do invalid form: 'define' at s") (assert-error (tn) (lambda () (eval '(do ((i 0 (+ i 1))) ((= i 1) #t) (define var1 1)) (interaction-environment)))) (if (provided? "strict-toplevel-definitions") (assert-error (tn) (lambda () (eval '(do ((i 0 (+ i 1))) ((= i 1) #t) (begin)) (interaction-environment))))) (assert-error (tn) (lambda () (eval '(do ((i 0 (+ i 1))) ((= i 1) #t) (begin (define var1 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0 (+ i 1))) ((= i 1) #t) (begin (define var1 1) 1)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(do ((i 0 (+ i 1))) ((= i 1) #t) (begin 1 (define var1 1))) (interaction-environment)))) (tn "do invalid form: binding syntactic keywords on ") (assert-error (tn) (lambda () (do ((syn define)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn if)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn and)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn cond)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn begin)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn do)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn delay)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn let*)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn else)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn =>)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn quote)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn quasiquote)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn unquote)) (#t #t) #t))) (assert-error (tn) (lambda () (do ((syn unquote-splicing)) (#t #t) #t))) (tn "do invalid form: binding syntactic keywords on ") (assert-error (tn) (lambda () (do ((syn #t define)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t if)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t and)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t cond)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t begin)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t do)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t delay)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t let*)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t else)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t =>)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t quote)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t quasiquote)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t unquote)) (#f #t) #t))) (assert-error (tn) (lambda () (do ((syn #t unquote-splicing)) (#f #t) #t))) (tn "do valid form: no bindings") (assert-true (tn) (lambda () (do () (#t #t) 'foo))) (assert-true (tn) (lambda () (do () (#t) 'foo))) (assert-true (tn) (lambda () (do () (#t #t) ))) (assert-true (tn) (lambda () (do () (#t) ))) (tn "do valid form: no commands") (assert-true (tn) (lambda () (do ((v 1)) (#t #t) ))) (assert-true (tn) (lambda () (do ((v 1)) (#t) ))) (tn "do valid form: no exps") (if (provided? "sigscheme") (assert-equal? (tn) (undef) (do ((v 1)) (#t) 'foo))) (tn "do inter-iteration variable isolation") (assert-equal? (tn) '(2 1 0) (do ((v '() (cons i v)) (i 0 (+ i 1))) ((= i 3) v) )) (assert-equal? (tn) '(2 1 0) (do ((i 0 (+ i 1)) (v '() (cons i v))) ((= i 3) v) )) (tn "do initialize-time variable isolation") (assert-error (tn) (lambda () (do ((v 1) (w v)) (#t #t) ))) (assert-error (tn) (lambda () (do ((w v) (v 1)) (#t #t) ))) (tn "do exp is evaluated exactly once") (assert-equal? (tn) '(+ v w) (do ((v 1) (w 2)) (#t '(+ v w)) )) (tn "do iteration count") (assert-equal? (tn) 0 (do ((i 0 (+ i 1)) (evaled 0)) (#t evaled) (set! evaled (+ evaled 1)))) (assert-equal? (tn) 0 (do ((i 0 (+ i 1)) (evaled 0)) ((= i 0) evaled) (set! evaled (+ evaled 1)))) (assert-equal? (tn) 1 (do ((i 0 (+ i 1)) (evaled 0)) ((= i 1) evaled) (set! evaled (+ evaled 1)))) (assert-equal? (tn) 2 (do ((i 0 (+ i 1)) (evaled 0)) ((= i 2) evaled) (set! evaled (+ evaled 1)))) (tn "do variable update") (assert-equal? (tn) 10 (do ((v 1) (w 2)) (#t (set! v (+ v 1)) (set! w (+ w v)) (set! v (+ v w)) (+ w v)) )) (assert-equal? (tn) 16 (do ((i 0 (+ i 1)) (v 1) (w 2)) ((= i 1) (set! v (+ v 1)) (set! w (+ w v)) (set! v (+ v w)) (+ w v)) (set! v 3))) (assert-equal? (tn) 20 (do ((i 0 (+ i 1)) (v 1) (w 2)) ((= i 1) (set! v (+ v 1)) (set! w (+ w v)) (set! v (+ v w)) (+ w v)) (set! v 3) (set! w 4))) (tn "do per-iteration env isolation") (assert-equal? (tn) '(4 3 2 1 0) (do ((i 0 (+ i 1)) (procs '() (cons (lambda () i) procs))) ((= i 5) (map (lambda (p) (p)) procs)) )) (assert-equal? (tn) '(8 6 4 2 0) (do ((i 0 (+ i 1)) (procs '() (cons (lambda () (set! i (* i 2)) i) procs))) ((= i 5) (map (lambda (p) (p)) procs)) )) (assert-equal? (tn) '(4 3 2 1 0) (do ((i 0 (+ i 1)) (procs '() (cons (lambda () i) procs))) ((= i 5) (set! i 1024) (map (lambda (p) (p)) procs)) )) (assert-equal? "do test1" '#(0 1 2 3 4) (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))) (assert-equal? "do test2" 25 (let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum)))) (define (expt-do x n) (do ((i 0 (+ i 1)) (y 1)) ((= i n) y) (set! y (* x y)))) (assert-equal? "do test3" 1024 (expt-do 2 10)) (define (nreverse rev-it) (do ((reved '() rev-it) (rev-cdr (cdr rev-it) (cdr rev-cdr)) (rev-it rev-it rev-cdr)) ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))) (assert-equal? "do test4" '(c b a) (nreverse (list 'a 'b 'c))) (assert-equal? "do test5" '((5 6) (3 4) (1 2)) (nreverse (list '(1 2) '(3 4) '(5 6)))) ;; scm_s_do() has been changed as specified in R5RS. -- YamaKen 2006-01-11 ;; R5RS: If no s are present, then the value of the `do' expression ;; is unspecified. ;;(assert-equal? "do test6" 1 (do ((a 1)) (a) 'some)) ;;(assert-equal? "do test7" #t (do ((a 1)) (#t) 'some)) (if (provided? "sigscheme") (begin (assert-equal? "do test6" (undef) (do ((a 1)) (a) 'some)) (assert-equal? "do test7" (undef) (do ((a 1)) (#t) 'some)))) ;; (do ((a 1)) 'eval) => (do ((a 1)) (quote eval)) (assert-equal? "do test8" eval (do ((a 1)) 'eval)) (total-report) uim-1.8.8/sigscheme/test/bigloo-apply.scm0000644000175000017500000002560412532333147015305 00000000000000;; A practical implementation for the Scheme programming language ;; ;; ,--^, ;; _ ___/ /|/ ;; ,;'( )__, ) ' ;; ;; // L__. ;; ' \\ / ' ;; ^ ^ ;; ;; Copyright (c) 1992-2004 Manuel Serrano ;; ;; Bug descriptions, use reports, comments or suggestions are ;; welcome. Send them to ;; bigloo@sophia.inria.fr ;; http://www.inria.fr/mimosa/fp/Bigloo ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. More precisely, ;; ;; - The compiler and the tools are distributed under the terms of the ;; GNU General Public License. ;; ;; - The Bigloo run-time system and the libraries are distributed under ;; the terms of the GNU Library General Public License. The source code ;; of the Bigloo runtime system is located in the ./runtime directory. ;; The source code of the FairThreads library is located in the ;; ./fthread directory. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/recette/apply.scm */ ;* */ ;* Author : Manuel Serrano */ ;* Creation : Tue Nov 3 10:58:26 1992 */ ;* Last change : Tue Aug 24 15:06:18 2004 (serrano) */ ;* */ ;* On test differentes sortes d'apply */ ;*---------------------------------------------------------------------*/ ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Bigloo 2.6e and adapted to SigScheme (load "./test/unittest-bigloo.scm") ;*---------------------------------------------------------------------*/ ;* gtest1 ... */ ;*---------------------------------------------------------------------*/ (define gtest1 (lambda (x y) (+ x y))) ;*---------------------------------------------------------------------*/ ;* gtest2 ... */ ;*---------------------------------------------------------------------*/ (define (gtest2 . x) (+ (car x) (cadr x))) ;*---------------------------------------------------------------------*/ ;* gtest3 ... */ ;*---------------------------------------------------------------------*/ (define (gtest3 x . y) (+ x (car y))) ;*---------------------------------------------------------------------*/ ;* gtest4 ... */ ;*---------------------------------------------------------------------*/ (define (gtest4) 'foo) ;*---------------------------------------------------------------------*/ ;* gtest4b ... */ ;*---------------------------------------------------------------------*/ (define (gtest4b . x) 'foo) ;*---------------------------------------------------------------------*/ ;* gtest5 ... */ ;*---------------------------------------------------------------------*/ (define (gtest5) (lambda () 'foo)) ;*---------------------------------------------------------------------*/ ;* gtest6 ... */ ;*---------------------------------------------------------------------*/ (define (gtest6) (lambda x 'foo)) ;*---------------------------------------------------------------------*/ ;* ltest1 ... */ ;*---------------------------------------------------------------------*/ (define (ltest1 a b) (let ((foo (lambda (x y) (+ x y)))) (apply foo (list (+ 1 a) (+ 1 b))))) ;*---------------------------------------------------------------------*/ ;* ltest2 ... */ ;*---------------------------------------------------------------------*/ (define (ltest2 a b) (let ((foo (lambda (x y) (+ x (+ y (+ a b)))))) foo)) ;*---------------------------------------------------------------------*/ ;* ltest3 ... */ ;*---------------------------------------------------------------------*/ (define (ltest3 a) (let ((foo (lambda (z . x) (let loop ((x x)) (if (null? x) a (+ (car x) (loop (cdr x)))))))) foo)) ;*---------------------------------------------------------------------*/ ;* extern-apply ... */ ;*---------------------------------------------------------------------*/ (define (extern-apply x) (apply foo1 x)) ;*---------------------------------------------------------------------*/ ;* apply-dummy ... */ ;* ------------------------------------------------------------- */ ;* Bigloo1.9 was unable to compile this extern apply form. */ ;*---------------------------------------------------------------------*/ (define (apply-dummy x y) (apply c-dummy (cons x y))) ;*---------------------------------------------------------------------*/ ;* test-apply ... */ ;*---------------------------------------------------------------------*/ (define (test-apply) (test "extern apply" (extern-apply '(1)) 1) (test "gapply" (apply gtest1 '(1 3)) 4) (test "gapply" ((begin gtest1) 1 3) 4) (test "gapply" (apply gtest2 '(1 3)) 4) (test "gapply" ((begin gtest2) 1 3) 4) (test "gapply" (apply gtest3 '(1 3)) 4) (test "gapply" ((begin gtest3) 1 3) 4) (test "gapply" (apply (begin gtest1) '(1 3)) 4) (test "gapply" (apply (begin gtest2) '(1 3)) 4) (test "gapply" (apply (begin gtest3) '(1 3)) 4) (test "gapply" (apply gtest4 '()) 'foo) (test "gapply" (apply gtest4b '()) 'foo) (test "gapply" (apply (gtest5) '()) 'foo) (test "gapply" (apply (gtest6) '()) 'foo) (test "lapply" (ltest1 1 2) 5) (test "lapply" ((ltest2 2 3) 1 2) 8) (test "lapply" (apply (ltest2 2 3) (list 1 2)) 8) (test "lapply" ((ltest3 1) 0 2 3 4) 10) (test "lapply" (apply (ltest3 1) (list 0 2 3 4)) 10) (test "lapply" (apply (lambda (x y) (list x y)) '(1 2)) '(1 2)) (test "napply" (apply cons 1 '(2)) '(1 . 2)) (test "napply" (apply cons 1 2 '()) '(1 . 2)) (test "aapply" (apply apply cons (list 1 2 '())) '(1 . 2)) (test "mapply" (apply (lambda (z) z) 1 '()) 1) (test "mapply" (apply (lambda (z) z) '(1)) 1) (test "mapply" (apply (lambda (a z) z) '(1 2)) 2) (test "mapply" (apply (lambda (a z) z) 1 '(2)) 2) (test "mapply" (apply (lambda (a z) z) 1 2 '()) 2) (test "mapply" (apply (lambda (a b c z) z) '(1 2 3 4)) 4) (test "mapply" (apply (lambda (a b c z) z) 1 '(2 3 4)) 4) (test "mapply" (apply (lambda (a b c z) z) 1 2 '(3 4)) 4) (test "mapply" (apply (lambda (a b c z) z) 1 2 3 '(4)) 4) (test "mapply" (apply (lambda (a b c z) z) 1 2 3 4 '()) 4) (test "mapply" (apply (lambda (a b c d z) z) 1 2 3 4 '(5))5) (test "mapply" (apply (lambda (a b c d z) z) 1 2 3 4 5 '()) 5) (test "mapply" (apply (lambda (a b c d e z) z) 1 2 3 4 '(5 6)) 6) (test "mapply" (apply (lambda (a b c d e f z) z) 1 2 3 4 '(5 6 7)) 7) (test "mapply" (apply (lambda (a b . z) (car z)) 1 2 3 4 5 '(6 7)) 3) (test "mapply" (apply (lambda (a . z) (car z)) 1 2 3 4 '(5 6 7)) 2) (test "mapply" (apply (lambda (a b c d . z) (car z)) 1 2 3 4 '(5 6 7)) 5) (test "mapply" (apply (lambda (a b c d e . z) (car z)) 1 '(2 3 4 5 6 7)) 6) (test "mapply" (apply (lambda (a b c d e f . z) (car z)) 1 2 3 4 '(5 6 7)) 7) (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32)) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)) (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32)) (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32)) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32))) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)) (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 . a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32)) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 (32)))) (test-apply) (total-report) uim-1.8.8/sigscheme/test/test-misc.scm0000644000175000017500000000777412532333147014627 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-misc.scm ;; About : unit tests for miscellaneous procedures ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (tn "procedure?") (assert-eq? (tn) #f (procedure? #f)) (assert-eq? (tn) #f (procedure? #t)) (assert-eq? (tn) #f (procedure? '())) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (procedure? (eof))) (assert-eq? (tn) #f (procedure? (undef))))) (assert-eq? (tn) #f (procedure? 0)) (assert-eq? (tn) #f (procedure? 1)) (assert-eq? (tn) #f (procedure? 3)) (assert-eq? (tn) #f (procedure? -1)) (assert-eq? (tn) #f (procedure? -3)) (assert-eq? (tn) #f (procedure? 'symbol)) (assert-eq? (tn) #f (procedure? 'SYMBOL)) (assert-eq? (tn) #f (procedure? #\a)) (assert-eq? (tn) #f (procedure? #\ã‚)) (assert-eq? (tn) #f (procedure? "")) (assert-eq? (tn) #f (procedure? " ")) (assert-eq? (tn) #f (procedure? "a")) (assert-eq? (tn) #f (procedure? "A")) (assert-eq? (tn) #f (procedure? "aBc12!")) (assert-eq? (tn) #f (procedure? "ã‚")) (assert-eq? (tn) #f (procedure? "ã‚0イã†12!")) (assert-eq? (tn) #t (procedure? car)) (assert-eq? (tn) #f (procedure? 'car)) (assert-eq? (tn) #t (procedure? +)) (assert-eq? (tn) #t (procedure? (lambda () #t))) (assert-eq? (tn) #f (procedure? '(lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (procedure? else))) ;; expression keyword (assert-error (tn) (lambda () (procedure? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #t (procedure? k)))) (assert-eq? (tn) #t (call-with-current-continuation procedure?)) (assert-eq? (tn) #f (procedure? (current-output-port))) (assert-eq? (tn) #f (procedure? '(#t . #t))) (assert-eq? (tn) #f (procedure? (cons #t #t))) (assert-eq? (tn) #f (procedure? '(0 1 2))) (assert-eq? (tn) #f (procedure? (list 0 1 2))) (assert-eq? (tn) #f (procedure? '#())) (assert-eq? (tn) #f (procedure? (vector))) (assert-eq? (tn) #f (procedure? '#(0 1 2))) (assert-eq? (tn) #f (procedure? (vector 0 1 2))) (tn "Optional argument modification") ;; Dotted (assert-equal? (tn) '(a . #t) ((lambda args (set-cdr! args #t) args) 'a 'b 'c)) ;; Circular (assert-equal? (tn) 'a (caddr ((lambda args (set-cdr! args args) args) 'a 'b))) (total-report) uim-1.8.8/sigscheme/test/unittest-bigloo.scm0000644000175000017500000000064012532333147016030 00000000000000(require-extension (unittest)) ;*---------------------------------------------------------------------*/ ;* For Bigloo Test */ ;*---------------------------------------------------------------------*/ (define (test name val expected-val) (assert-equal? name expected-val val)) (define (foo1 x) x) (define (foo2 . x) x) (define (foo3 x . y) (cons x y)) uim-1.8.8/sigscheme/test/test-srfi34.scm0000644000175000017500000004344012532333147014774 00000000000000;; Filename : test-srfi34.scm ;; About : unit test for SRFI-34 ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (require-extension (srfi 8 34)) (if (not (provided? "srfi-34")) (test-skip "SRFI-34 is not enabled")) (set! *test-track-progress* #f) (define tn test-name) (define my-assert-error (lambda (test-name proc) (assert-error test-name (lambda () (guard (var ;; not an error but user-raised object ((eq? var 'obj) #f)) (proc)))))) ;; ;; raise ;; (tn "raise") ;; no arg (assert-error (tn) (lambda () (raise))) ;; multiple values are not allowed (assert-error (tn) (lambda () (raise (values 1 2 3)))) ;; no guard or raw exception handler (assert-error (tn) (lambda () (raise 'exception))) ;; ;; with-exception-handler ;; (tn "with-exception-handler invalid form") ;; handler is not a procedure (my-assert-error (tn) (lambda () (with-exception-handler 'a-handler-must-not-return (lambda () (+ 1 (raise 'obj)))))) ;; handler is a procedure but takes 2 arguments (my-assert-error (tn) (lambda () (with-exception-handler eq? (lambda () (+ 1 (raise 'obj)))))) ;; thunk is not a procedure (my-assert-error (tn) (lambda () (with-exception-handler (lambda (x) 'a-handler-must-not-return) 'an-error))) ;; thunk is a procedure but takes an argument (my-assert-error (tn) (lambda () (with-exception-handler (lambda (x) 'a-handler-must-not-return) (lambda (dummy) (+ 1 (raise 'obj)))))) (tn "with-exception-handler") ;; Although the behavior when a handler returned is not specified in SRFI-34, ;; SigScheme should produce an error to prevent being misused by users. (if sigscheme? (my-assert-error (tn) (lambda () (with-exception-handler (lambda (x) 'a-handler-must-not-return) (lambda () (+ 1 (raise 'obj))))))) (assert-error (tn) (lambda () (with-exception-handler (lambda (x) (assert-equal? (tn) 'an-error x) 'a-handler-must-not-return) (lambda () (+ 1 (raise 'an-error)))))) (assert-equal? (tn) 6 (with-exception-handler (lambda (x) 'not-reaches-here) (lambda () (+ 1 2 3)))) (assert-equal? (tn) 'success (with-exception-handler (lambda (x) 'not-reaches-here) (lambda () 'success))) ;; multiple values are allowed for thunk (assert-equal? (tn) '(1 2 3) (receive vals (with-exception-handler (lambda (x) 'not-reaches-here) (lambda () (values 1 2 3))) vals)) ;; ;; guard ;; (tn "guard") (assert-equal? (tn) 'exception (guard (condition (else (assert-equal? (tn) 'an-error condition) 'exception)) (+ 1 (raise 'an-error)))) (assert-equal? (tn) 3 (guard (condition (else 'exception)) (+ 1 2))) (assert-equal? (tn) 'success (guard (condition (else 'exception)) 'success)) (assert-equal? (tn) 'exception (guard (condition (else 'exception)) (+ 1 (raise 'error)))) (assert-equal? (tn) 42 (guard (condition ((assq 'a condition) => cdr) ((assq 'b condition)) (else (display condition) (newline))) (raise (list (cons 'a 42))))) (assert-equal? (tn) '(b . 23) (guard (condition ((assq 'a condition) => cdr) ((assq 'b condition)) (else (display condition) (newline))) (raise (list (cons 'b 23))))) ;; not matched against => and fall through to else (assert-equal? (tn) 'else (guard (condition ((assv condition '((a 1) (b 2))) => cadr) (else 'else)) (raise 'c))) ;; ;; handler part of guard ;; (tn "guard handler invalid form") (my-assert-error (tn) (lambda () (guard (var) (raise 'obj)))) (my-assert-error (tn) (lambda () (guard (var ()) (raise 'obj)))) (my-assert-error (tn) (lambda () (guard (var () (else #t)) (raise 'obj)))) ;; 'else' followed by another caluse (my-assert-error (tn) (lambda () (guard (var (else #t) (#t)) (raise 'obj)))) ;; not specified in R5RS 'case', but SigScheme should cause error (if (provided? "sigscheme") (my-assert-error (tn) (lambda () (guard (var (else)) (raise 'obj))))) (my-assert-error (tn) (lambda () (guard (var (#t =>)) (raise 'obj)))) (my-assert-error (tn) (lambda () (guard (var (#t =>) (else #t)) (raise 'obj)))) (my-assert-error (tn) (lambda () (guard (var (else =>)) (raise 'obj)))) ;; not a procedure (my-assert-error (tn) (lambda () (guard (var (#t => #t)) (raise 'obj)))) ;; not a procedure but #f (my-assert-error (tn) (lambda () (guard (var (#t => #f)) (raise 'obj)))) ;; procedure but argument number mismatch (my-assert-error (tn) (lambda () (guard (var (#t => eq?)) (raise 'obj)))) ;; not a procedure but a syntax (my-assert-error (tn) (lambda () (guard (var (#t => delay)) (raise 'obj)))) (tn "guard namespace taintlessness") (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'lex-env))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'cond-catch))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'body))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'condition))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'guard-k))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'handler-k))) (assert-false (tn) (guard (var (#f var)) (symbol-bound? 'var))) (tn "guard handler namespace taintlessness") (assert-false (tn) (guard (var (else (symbol-bound? 'lex-env))) (raise 'err))) (assert-false (tn) (guard (var (else (symbol-bound? 'cond-catch))) (raise 'err))) (assert-false (tn) (guard (var (else (symbol-bound? 'body))) (raise 'err))) (assert-false (tn) (guard (var (else (symbol-bound? 'condition))) (raise 'err))) (assert-false (tn) (guard (var (else (symbol-bound? 'guard-k))) (raise 'err))) (assert-false (tn) (guard (var (else (symbol-bound? 'handler-k))) (raise 'err))) (tn "guard handler condition variable") (assert-equal? (tn) 'err (guard (var (else var)) (raise 'err))) ;; the variable can be modified (assert-equal? (tn) 'ERR (guard (var (#t (set! var 'ERR) var)) (raise 'err))) ;; the variable does not affect outer environment (define var 'global-var) (assert-equal? (tn) 'outer (let ((var 'outer)) (guard (var (#t (set! var 'ERR))) (raise 'err)) var)) ;; the variable does not affect global one (define var 'global-var) (assert-equal? (tn) 'global-var (begin (guard (var (#t (set! var 'ERR))) (raise 'err)) var)) (tn "guard evaluation count exactness") (assert-equal? (tn) 7 (guard (var (else var)) (+ 3 4))) (assert-equal? (tn) 7 (guard (var (else var)) (raise (+ 3 4)))) (assert-equal? (tn) 7 (guard (var (else (+ 3 4))) (raise 'err))) (assert-equal? (tn) 7 (let ((a 3) (b 4)) (guard (var (else var)) (+ a b)))) (assert-equal? (tn) 7 (let ((a 3) (b 4)) (guard (var (else var)) (raise (+ a b))))) (assert-equal? (tn) 7 (let ((a 3) (b 4)) (guard (var (else (+ a b))) (raise 'err)))) (assert-equal? (tn) (list + 3 4) ;; not 7 (let ((a 3) (b 4)) (guard (var (else var)) (list + a b)))) (assert-equal? (tn) (list + 3 4) ;; not 7 (let ((a 3) (b 4)) (guard (var (else var)) (raise (list + a b))))) (assert-equal? (tn) (list + 3 4) ;; not 7 (let ((a 3) (b 4)) (guard (var (else (list + a b))) (raise 'err)))) (tn "guard with multiple values") (assert-equal? (tn) '(1 2) (receive vals (guard (var (else var)) (values 1 2)) vals)) (assert-equal? (tn) '(1 2) (receive vals (guard (var (else (values 1 2))) (raise 'err)) vals)) (if (provided? "sigscheme") (assert-error (tn) (lambda () (guard (var ((not (%%error-object? var)) var)) (raise (values 1 2)))))) (tn "guard handler reraise") (assert-equal? (tn) 'reraised (guard (var ((eq? var 'error) 'reraised)) (guard (var (#f)) (raise 'error)))) (assert-equal? (tn) 'reraised (guard (var ((eq? var 'error) 'reraised)) (guard (var ((even? 3) #f) ((positive? -1) #f)) (raise 'error)))) (assert-error (tn) (lambda () (guard (condition ((positive? condition) 'positive) ((negative? condition) 'negative)) (raise 0)))) (tn "guard handler tested value as result") ;; R5RS: If the selected contains only the and no ;; s, then the value of the is returned as the result. (assert-equal? (tn) #t (guard (var (#t)) (raise 'error))) (assert-equal? (tn) 3 (guard (var (#f) (3)) (raise 'error))) (assert-equal? (tn) 3 (guard(var (#f) (3) (4)) (raise 'error))) ;; ;; mixed use of with-exception-handler and guard ;; (tn "mixed exception handling") (assert-equal? (tn) 'guard-ret (with-exception-handler (lambda (x) (k 'with-exception-ret)) (lambda () (guard (condition (else 'guard-ret)) (raise 1))))) (assert-error (tn) (lambda () (with-exception-handler (lambda (x) 'with-exception-ret ;; a exception handler must not ;; return (as specified in SRFI-34) ) (lambda () (guard (condition ((negative? condition) 'guard-ret)) (raise 1)))))) (assert-equal? (tn) 'positive (call-with-current-continuation (lambda (k) (with-exception-handler (lambda (x) (k 'zero)) (lambda () (guard (condition ((positive? condition) 'positive) ((negative? condition) 'negative)) (raise 1))))))) (assert-equal? (tn) 'negative (call-with-current-continuation (lambda (k) (with-exception-handler (lambda (x) (k 'zero)) (lambda () (guard (condition ((positive? condition) 'positive) ((negative? condition) 'negative)) (raise -1))))))) (assert-equal? (tn) 'zero (call-with-current-continuation (lambda (k) (with-exception-handler (lambda (x) (k 'zero)) (lambda () (guard (condition ((positive? condition) 'positive) ((negative? condition) 'negative)) (raise 0))))))) (total-report) uim-1.8.8/sigscheme/test/test-srfi55.scm0000644000175000017500000000546412532333147015003 00000000000000;; Filename : test-srfi55.scm ;; About : unit test for SRFI-55 ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) ;; SRFI-55 is enabled by default if exists. (if (not (provided? "srfi-55")) (test-skip "SRFI-55 is not enabled")) (define tn test-name) (tn "require-extension") ;; sscm-ext is enabled by default for SRFI-55 (assert-true (tn) (provided? "sscm-ext")) (require-extension (sscm-ext)) (assert-true (tn) (provided? "sscm-ext")) (tn "require-extension SRFIs") (assert-false (tn) (provided? "srfi-1")) (assert-false (tn) (provided? "srfi-2")) (assert-false (tn) (provided? "srfi-48")) (assert-false (tn) (provided? "srfi-60")) (require-extension (srfi 1 48 2 60)) (assert-true (tn) (provided? "srfi-1")) (assert-true (tn) (provided? "srfi-2")) (assert-true (tn) (provided? "srfi-48")) (assert-true (tn) (provided? "srfi-60")) ;; mixed (require-extension (sscm-ext) (srfi 1 8 2 60) (sscm-ext) (srfi 23)) (assert-true (tn) (provided? "srfi-1")) (assert-true (tn) (provided? "srfi-2")) (assert-true (tn) (provided? "srfi-8")) (assert-true (tn) (provided? "srfi-23")) (assert-true (tn) (provided? "srfi-48")) (assert-true (tn) (provided? "srfi-60")) (assert-true (tn) (provided? "sscm-ext")) (total-report) uim-1.8.8/sigscheme/test/test-number-arith.scm0000644000175000017500000025226112532333147016262 00000000000000;; Filename : test-number-arith.scm ;; About : unit tests for arithmetic procedures ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (symbol-bound? 'number?)) (test-skip "R5RS numbers is not enabled")) (define tn test-name) (tn "max invalid forms") (assert-error (tn) (lambda () (max))) (assert-error (tn) (lambda () (max #t))) (assert-error (tn) (lambda () (max #f))) (assert-error (tn) (lambda () (max '()))) (tn "max 2 args") (assert-equal? (tn) -2 (max -2 -2)) (assert-equal? (tn) -1 (max -2 -1)) (assert-equal? (tn) 0 (max -2 0)) (assert-equal? (tn) 1 (max -2 1)) (assert-equal? (tn) 2 (max -2 2)) (assert-equal? (tn) -1 (max -1 -2)) (assert-equal? (tn) -1 (max -1 -1)) (assert-equal? (tn) 0 (max -1 0)) (assert-equal? (tn) 1 (max -1 1)) (assert-equal? (tn) 2 (max -1 2)) (assert-equal? (tn) 0 (max 0 -2)) (assert-equal? (tn) 0 (max 0 -1)) (assert-equal? (tn) 0 (max 0 0)) (assert-equal? (tn) 1 (max 0 1)) (assert-equal? (tn) 2 (max 0 2)) (assert-equal? (tn) 1 (max 1 -2)) (assert-equal? (tn) 1 (max 1 -1)) (assert-equal? (tn) 1 (max 1 0)) (assert-equal? (tn) 1 (max 1 1)) (assert-equal? (tn) 2 (max 1 2)) (assert-equal? (tn) 2 (max 2 -2)) (assert-equal? (tn) 2 (max 2 -1)) (assert-equal? (tn) 2 (max 2 0)) (assert-equal? (tn) 2 (max 2 1)) (assert-equal? (tn) 2 (max 2 2)) (if (>= fixnum-bits 60) (begin (tn "max 2 args 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (max 956397711204 956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (max 956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (max -956397711204 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (max -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (max 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 956397711204 (max 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) -956397711204 (max -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 -956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (max -13121090146595 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (max -13121090146595 -956397711204))"))) (tn "max 3 args") (assert-equal? (tn) -2 (max -2 -2 -2)) (assert-equal? (tn) -1 (max -2 -2 -1)) (assert-equal? (tn) 0 (max -2 -2 0)) (assert-equal? (tn) 1 (max -2 -2 1)) (assert-equal? (tn) 2 (max -2 -2 2)) (assert-equal? (tn) -1 (max -2 -1 -2)) (assert-equal? (tn) -1 (max -2 -1 -1)) (assert-equal? (tn) 0 (max -2 -1 0)) (assert-equal? (tn) 1 (max -2 -1 1)) (assert-equal? (tn) 2 (max -2 -1 2)) (assert-equal? (tn) 0 (max -2 0 -2)) (assert-equal? (tn) 0 (max -2 0 -1)) (assert-equal? (tn) 0 (max -2 0 0)) (assert-equal? (tn) 1 (max -2 0 1)) (assert-equal? (tn) 2 (max -2 0 2)) (assert-equal? (tn) 1 (max -2 1 -2)) (assert-equal? (tn) 1 (max -2 1 -1)) (assert-equal? (tn) 1 (max -2 1 0)) (assert-equal? (tn) 1 (max -2 1 1)) (assert-equal? (tn) 2 (max -2 1 2)) (assert-equal? (tn) 2 (max -2 2 -2)) (assert-equal? (tn) 2 (max -2 2 -1)) (assert-equal? (tn) 2 (max -2 2 0)) (assert-equal? (tn) 2 (max -2 2 1)) (assert-equal? (tn) 2 (max -2 2 2)) (assert-equal? (tn) -1 (max -1 -2 -2)) (assert-equal? (tn) -1 (max -1 -2 -1)) (assert-equal? (tn) 0 (max -1 -2 0)) (assert-equal? (tn) 1 (max -1 -2 1)) (assert-equal? (tn) 2 (max -1 -2 2)) (assert-equal? (tn) -1 (max -1 -1 -2)) (assert-equal? (tn) -1 (max -1 -1 -1)) (assert-equal? (tn) 0 (max -1 -1 0)) (assert-equal? (tn) 1 (max -1 -1 1)) (assert-equal? (tn) 2 (max -1 -1 2)) (assert-equal? (tn) 0 (max -1 0 -2)) (assert-equal? (tn) 0 (max -1 0 -1)) (assert-equal? (tn) 0 (max -1 0 0)) (assert-equal? (tn) 1 (max -1 0 1)) (assert-equal? (tn) 2 (max -1 0 2)) (assert-equal? (tn) 1 (max -1 1 -2)) (assert-equal? (tn) 1 (max -1 1 -1)) (assert-equal? (tn) 1 (max -1 1 0)) (assert-equal? (tn) 1 (max -1 1 1)) (assert-equal? (tn) 2 (max -1 1 2)) (assert-equal? (tn) 2 (max -1 2 -2)) (assert-equal? (tn) 2 (max -1 2 -1)) (assert-equal? (tn) 2 (max -1 2 0)) (assert-equal? (tn) 2 (max -1 2 1)) (assert-equal? (tn) 2 (max -1 2 2)) (assert-equal? (tn) 0 (max 0 -2 -2)) (assert-equal? (tn) 0 (max 0 -2 -1)) (assert-equal? (tn) 0 (max 0 -2 0)) (assert-equal? (tn) 1 (max 0 -2 1)) (assert-equal? (tn) 2 (max 0 -2 2)) (assert-equal? (tn) 0 (max 0 -1 -2)) (assert-equal? (tn) 0 (max 0 -1 -1)) (assert-equal? (tn) 0 (max 0 -1 0)) (assert-equal? (tn) 1 (max 0 -1 1)) (assert-equal? (tn) 2 (max 0 -1 2)) (assert-equal? (tn) 0 (max 0 0 -2)) (assert-equal? (tn) 0 (max 0 0 -1)) (assert-equal? (tn) 0 (max 0 0 0)) (assert-equal? (tn) 1 (max 0 0 1)) (assert-equal? (tn) 2 (max 0 0 2)) (assert-equal? (tn) 1 (max 0 1 -2)) (assert-equal? (tn) 1 (max 0 1 -1)) (assert-equal? (tn) 1 (max 0 1 0)) (assert-equal? (tn) 1 (max 0 1 1)) (assert-equal? (tn) 2 (max 0 1 2)) (assert-equal? (tn) 2 (max 0 2 -2)) (assert-equal? (tn) 2 (max 0 2 -1)) (assert-equal? (tn) 2 (max 0 2 0)) (assert-equal? (tn) 2 (max 0 2 1)) (assert-equal? (tn) 2 (max 0 2 2)) (assert-equal? (tn) 1 (max 1 -2 -2)) (assert-equal? (tn) 1 (max 1 -2 -1)) (assert-equal? (tn) 1 (max 1 -2 0)) (assert-equal? (tn) 1 (max 1 -2 1)) (assert-equal? (tn) 2 (max 1 -2 2)) (assert-equal? (tn) 1 (max 1 -1 -2)) (assert-equal? (tn) 1 (max 1 -1 -1)) (assert-equal? (tn) 1 (max 1 -1 0)) (assert-equal? (tn) 1 (max 1 -1 1)) (assert-equal? (tn) 2 (max 1 -1 2)) (assert-equal? (tn) 1 (max 1 0 -2)) (assert-equal? (tn) 1 (max 1 0 -1)) (assert-equal? (tn) 1 (max 1 0 0)) (assert-equal? (tn) 1 (max 1 0 1)) (assert-equal? (tn) 2 (max 1 0 2)) (assert-equal? (tn) 1 (max 1 1 -2)) (assert-equal? (tn) 1 (max 1 1 -1)) (assert-equal? (tn) 1 (max 1 1 0)) (assert-equal? (tn) 1 (max 1 1 1)) (assert-equal? (tn) 2 (max 1 1 2)) (assert-equal? (tn) 2 (max 1 2 -2)) (assert-equal? (tn) 2 (max 1 2 -1)) (assert-equal? (tn) 2 (max 1 2 0)) (assert-equal? (tn) 2 (max 1 2 1)) (assert-equal? (tn) 2 (max 1 2 2)) (assert-equal? (tn) 2 (max 2 -2 -2)) (assert-equal? (tn) 2 (max 2 -2 -1)) (assert-equal? (tn) 2 (max 2 -2 0)) (assert-equal? (tn) 2 (max 2 -2 1)) (assert-equal? (tn) 2 (max 2 -2 2)) (assert-equal? (tn) 2 (max 2 -1 -2)) (assert-equal? (tn) 2 (max 2 -1 -1)) (assert-equal? (tn) 2 (max 2 -1 0)) (assert-equal? (tn) 2 (max 2 -1 1)) (assert-equal? (tn) 2 (max 2 -1 2)) (assert-equal? (tn) 2 (max 2 0 -2)) (assert-equal? (tn) 2 (max 2 0 -1)) (assert-equal? (tn) 2 (max 2 0 0)) (assert-equal? (tn) 2 (max 2 0 1)) (assert-equal? (tn) 2 (max 2 0 2)) (assert-equal? (tn) 2 (max 2 1 -2)) (assert-equal? (tn) 2 (max 2 1 -1)) (assert-equal? (tn) 2 (max 2 1 0)) (assert-equal? (tn) 2 (max 2 1 1)) (assert-equal? (tn) 2 (max 2 1 2)) (assert-equal? (tn) 2 (max 2 2 -2)) (assert-equal? (tn) 2 (max 2 2 -1)) (assert-equal? (tn) 2 (max 2 2 0)) (assert-equal? (tn) 2 (max 2 2 1)) (assert-equal? (tn) 2 (max 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "max 3 args 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (max 956397711204 956397711204 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (max -956397711204 -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (max 0 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max 0 -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 956397711204 (max 0 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (max 0 -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) 956397711204 (max -13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) 0 (max -13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) 13121090146595 (max 956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max -956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) 956397711204 (max 956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (max -956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (max 13121090146595 0 -956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (max -13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) 0 (max -13121090146595 0 -956397711204))"))) (tn "max many args") (assert-equal? (tn) 2 (max 2 2 2 2)) (assert-equal? (tn) 2 (max 0 2 2 2)) (assert-equal? (tn) 2 (max 2 0 2 2)) (assert-equal? (tn) 2 (max 2 2 0 2)) (assert-equal? (tn) 2 (max 2 2 2 0)) (assert-equal? (tn) 2 (max -2 -1 0 1 2)) (assert-equal? (tn) 2 (max 2 1 0 -1 -2)) (assert-equal? (tn) 2 (max -2 -1 0 -1 1 2)) (assert-equal? (tn) 2 (max 2 1 0 -1 1 -2)) (assert-equal? (tn) 2 (max -2 -2 -1 -1 0 0 1 1 2 2)) (assert-equal? (tn) 2 (max 2 2 1 1 0 0 -1 -1 -2 -2)) (assert-equal? (tn) 13 (max 3 1 5 -7 2 13)) (tn "min invalid forms") (assert-error (tn) (lambda () (min))) (assert-error (tn) (lambda () (min #t))) (assert-error (tn) (lambda () (min #f))) (assert-error (tn) (lambda () (min '()))) (tn "min 2 args") (assert-equal? (tn) -2 (min -2 -2)) (assert-equal? (tn) -2 (min -2 -1)) (assert-equal? (tn) -2 (min -2 0)) (assert-equal? (tn) -2 (min -2 1)) (assert-equal? (tn) -2 (min -2 2)) (assert-equal? (tn) -2 (min -1 -2)) (assert-equal? (tn) -1 (min -1 -1)) (assert-equal? (tn) -1 (min -1 0)) (assert-equal? (tn) -1 (min -1 1)) (assert-equal? (tn) -1 (min -1 2)) (assert-equal? (tn) -2 (min 0 -2)) (assert-equal? (tn) -1 (min 0 -1)) (assert-equal? (tn) 0 (min 0 0)) (assert-equal? (tn) 0 (min 0 1)) (assert-equal? (tn) 0 (min 0 2)) (assert-equal? (tn) -2 (min 1 -2)) (assert-equal? (tn) -1 (min 1 -1)) (assert-equal? (tn) 0 (min 1 0)) (assert-equal? (tn) 1 (min 1 1)) (assert-equal? (tn) 1 (min 1 2)) (assert-equal? (tn) -2 (min 2 -2)) (assert-equal? (tn) -1 (min 2 -1)) (assert-equal? (tn) 0 (min 2 0)) (assert-equal? (tn) 1 (min 2 1)) (assert-equal? (tn) 2 (min 2 2)) (if (>= fixnum-bits 60) (begin (tn "min 2 args 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (min 956397711204 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min 956397711204 -956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min -956397711204 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (min 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -956397711204 (min -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 956397711204 (min 13121090146595 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min 13121090146595 -956397711204))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 956397711204))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 -956397711204))"))) (tn "min 3 args") (assert-equal? (tn) -2 (min -2 -2 -2)) (assert-equal? (tn) -2 (min -2 -2 -1)) (assert-equal? (tn) -2 (min -2 -2 0)) (assert-equal? (tn) -2 (min -2 -2 1)) (assert-equal? (tn) -2 (min -2 -2 2)) (assert-equal? (tn) -2 (min -2 -1 -2)) (assert-equal? (tn) -2 (min -2 -1 -1)) (assert-equal? (tn) -2 (min -2 -1 0)) (assert-equal? (tn) -2 (min -2 -1 1)) (assert-equal? (tn) -2 (min -2 -1 2)) (assert-equal? (tn) -2 (min -2 0 -2)) (assert-equal? (tn) -2 (min -2 0 -1)) (assert-equal? (tn) -2 (min -2 0 0)) (assert-equal? (tn) -2 (min -2 0 1)) (assert-equal? (tn) -2 (min -2 0 2)) (assert-equal? (tn) -2 (min -2 1 -2)) (assert-equal? (tn) -2 (min -2 1 -1)) (assert-equal? (tn) -2 (min -2 1 0)) (assert-equal? (tn) -2 (min -2 1 1)) (assert-equal? (tn) -2 (min -2 1 2)) (assert-equal? (tn) -2 (min -2 2 -2)) (assert-equal? (tn) -2 (min -2 2 -1)) (assert-equal? (tn) -2 (min -2 2 0)) (assert-equal? (tn) -2 (min -2 2 1)) (assert-equal? (tn) -2 (min -2 2 2)) (assert-equal? (tn) -2 (min -1 -2 -2)) (assert-equal? (tn) -2 (min -1 -2 -1)) (assert-equal? (tn) -2 (min -1 -2 0)) (assert-equal? (tn) -2 (min -1 -2 1)) (assert-equal? (tn) -2 (min -1 -2 2)) (assert-equal? (tn) -2 (min -1 -1 -2)) (assert-equal? (tn) -1 (min -1 -1 -1)) (assert-equal? (tn) -1 (min -1 -1 0)) (assert-equal? (tn) -1 (min -1 -1 1)) (assert-equal? (tn) -1 (min -1 -1 2)) (assert-equal? (tn) -2 (min -1 0 -2)) (assert-equal? (tn) -1 (min -1 0 -1)) (assert-equal? (tn) -1 (min -1 0 0)) (assert-equal? (tn) -1 (min -1 0 1)) (assert-equal? (tn) -1 (min -1 0 2)) (assert-equal? (tn) -2 (min -1 1 -2)) (assert-equal? (tn) -1 (min -1 1 -1)) (assert-equal? (tn) -1 (min -1 1 0)) (assert-equal? (tn) -1 (min -1 1 1)) (assert-equal? (tn) -1 (min -1 1 2)) (assert-equal? (tn) -2 (min -1 2 -2)) (assert-equal? (tn) -1 (min -1 2 -1)) (assert-equal? (tn) -1 (min -1 2 0)) (assert-equal? (tn) -1 (min -1 2 1)) (assert-equal? (tn) -1 (min -1 2 2)) (assert-equal? (tn) -2 (min 0 -2 -2)) (assert-equal? (tn) -2 (min 0 -2 -1)) (assert-equal? (tn) -2 (min 0 -2 0)) (assert-equal? (tn) -2 (min 0 -2 1)) (assert-equal? (tn) -2 (min 0 -2 2)) (assert-equal? (tn) -2 (min 0 -1 -2)) (assert-equal? (tn) -1 (min 0 -1 -1)) (assert-equal? (tn) -1 (min 0 -1 0)) (assert-equal? (tn) -1 (min 0 -1 1)) (assert-equal? (tn) -1 (min 0 -1 2)) (assert-equal? (tn) -2 (min 0 0 -2)) (assert-equal? (tn) -1 (min 0 0 -1)) (assert-equal? (tn) 0 (min 0 0 0)) (assert-equal? (tn) 0 (min 0 0 1)) (assert-equal? (tn) 0 (min 0 0 2)) (assert-equal? (tn) -2 (min 0 1 -2)) (assert-equal? (tn) -1 (min 0 1 -1)) (assert-equal? (tn) 0 (min 0 1 0)) (assert-equal? (tn) 0 (min 0 1 1)) (assert-equal? (tn) 0 (min 0 1 2)) (assert-equal? (tn) -2 (min 0 2 -2)) (assert-equal? (tn) -1 (min 0 2 -1)) (assert-equal? (tn) 0 (min 0 2 0)) (assert-equal? (tn) 0 (min 0 2 1)) (assert-equal? (tn) 0 (min 0 2 2)) (assert-equal? (tn) -2 (min 1 -2 -2)) (assert-equal? (tn) -2 (min 1 -2 -1)) (assert-equal? (tn) -2 (min 1 -2 0)) (assert-equal? (tn) -2 (min 1 -2 1)) (assert-equal? (tn) -2 (min 1 -2 2)) (assert-equal? (tn) -2 (min 1 -1 -2)) (assert-equal? (tn) -1 (min 1 -1 -1)) (assert-equal? (tn) -1 (min 1 -1 0)) (assert-equal? (tn) -1 (min 1 -1 1)) (assert-equal? (tn) -1 (min 1 -1 2)) (assert-equal? (tn) -2 (min 1 0 -2)) (assert-equal? (tn) -1 (min 1 0 -1)) (assert-equal? (tn) 0 (min 1 0 0)) (assert-equal? (tn) 0 (min 1 0 1)) (assert-equal? (tn) 0 (min 1 0 2)) (assert-equal? (tn) -2 (min 1 1 -2)) (assert-equal? (tn) -1 (min 1 1 -1)) (assert-equal? (tn) 0 (min 1 1 0)) (assert-equal? (tn) 1 (min 1 1 1)) (assert-equal? (tn) 1 (min 1 1 2)) (assert-equal? (tn) -2 (min 1 2 -2)) (assert-equal? (tn) -1 (min 1 2 -1)) (assert-equal? (tn) 0 (min 1 2 0)) (assert-equal? (tn) 1 (min 1 2 1)) (assert-equal? (tn) 1 (min 1 2 2)) (assert-equal? (tn) -2 (min 2 -2 -2)) (assert-equal? (tn) -2 (min 2 -2 -1)) (assert-equal? (tn) -2 (min 2 -2 0)) (assert-equal? (tn) -2 (min 2 -2 1)) (assert-equal? (tn) -2 (min 2 -2 2)) (assert-equal? (tn) -2 (min 2 -1 -2)) (assert-equal? (tn) -1 (min 2 -1 -1)) (assert-equal? (tn) -1 (min 2 -1 0)) (assert-equal? (tn) -1 (min 2 -1 1)) (assert-equal? (tn) -1 (min 2 -1 2)) (assert-equal? (tn) -2 (min 2 0 -2)) (assert-equal? (tn) -1 (min 2 0 -1)) (assert-equal? (tn) 0 (min 2 0 0)) (assert-equal? (tn) 0 (min 2 0 1)) (assert-equal? (tn) 0 (min 2 0 2)) (assert-equal? (tn) -2 (min 2 1 -2)) (assert-equal? (tn) -1 (min 2 1 -1)) (assert-equal? (tn) 0 (min 2 1 0)) (assert-equal? (tn) 1 (min 2 1 1)) (assert-equal? (tn) 1 (min 2 1 2)) (assert-equal? (tn) -2 (min 2 2 -2)) (assert-equal? (tn) -1 (min 2 2 -1)) (assert-equal? (tn) 0 (min 2 2 0)) (assert-equal? (tn) 1 (min 2 2 1)) (assert-equal? (tn) 2 (min 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "min 3 args 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (min 956397711204 956397711204 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min -956397711204 -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 0 (min 0 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -956397711204 (min 0 -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min 0 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min 0 -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (min 13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) -956397711204 (min 13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) 0 (min 956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) -956397711204 (min -956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min 956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (min -956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (min 13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (min 13121090146595 0 -956397711204))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) -13121090146595 (min -13121090146595 0 -956397711204))"))) (tn "min many args") (assert-equal? (tn) 2 (min 2 2 2 2)) (assert-equal? (tn) 0 (min 0 2 2 2)) (assert-equal? (tn) 0 (min 2 0 2 2)) (assert-equal? (tn) 0 (min 2 2 0 2)) (assert-equal? (tn) 0 (min 2 2 2 0)) (assert-equal? (tn) -2 (min -2 -1 0 1 2)) (assert-equal? (tn) -2 (min 2 1 0 -1 -2)) (assert-equal? (tn) -2 (min -2 -1 0 -1 1 2)) (assert-equal? (tn) -2 (min 2 1 0 -1 1 -2)) (assert-equal? (tn) -2 (min -2 -2 -1 -1 0 0 1 1 2 2)) (assert-equal? (tn) -2 (min 2 2 1 1 0 0 -1 -1 -2 -2)) (assert-equal? (tn) -7 (min 3 1 5 -7 2 13)) (tn "+ invalid forms") (assert-error (tn) (lambda () (+ #t))) (assert-error (tn) (lambda () (+ #f))) (assert-error (tn) (lambda () (+ '()))) (assert-error (tn) (lambda () (+ 1 #t))) (assert-error (tn) (lambda () (+ 1 #f))) (assert-error (tn) (lambda () (+ 1 '()))) (assert-error (tn) (lambda () (+ 1 2 #t))) (assert-error (tn) (lambda () (+ 1 2 #f))) (assert-error (tn) (lambda () (+ 1 2 '()))) (tn "+ 0 arg") (assert-equal? (tn) 0 (+)) (tn "+ 1 arg") (assert-equal? (tn) -2 (+ -2)) (assert-equal? (tn) -1 (+ -1)) (assert-equal? (tn) 0 (+ 0)) (assert-equal? (tn) 1 (+ 1)) (assert-equal? (tn) 2 (+ 2)) (if (>= fixnum-bits 60) (begin (tn "+ 1 arg 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (+ 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (+ -956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (+ 13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (+ -13121090146595))"))) (tn "+ 2 args") (assert-equal? (tn) -4 (+ -2 -2)) (assert-equal? (tn) -3 (+ -2 -1)) (assert-equal? (tn) -2 (+ -2 0)) (assert-equal? (tn) -1 (+ -2 1)) (assert-equal? (tn) 0 (+ -2 2)) (assert-equal? (tn) -3 (+ -1 -2)) (assert-equal? (tn) -2 (+ -1 -1)) (assert-equal? (tn) -1 (+ -1 0)) (assert-equal? (tn) 0 (+ -1 1)) (assert-equal? (tn) 1 (+ -1 2)) (assert-equal? (tn) -2 (+ 0 -2)) (assert-equal? (tn) -1 (+ 0 -1)) (assert-equal? (tn) 0 (+ 0 0)) (assert-equal? (tn) 1 (+ 0 1)) (assert-equal? (tn) 2 (+ 0 2)) (assert-equal? (tn) -1 (+ 1 -2)) (assert-equal? (tn) 0 (+ 1 -1)) (assert-equal? (tn) 1 (+ 1 0)) (assert-equal? (tn) 2 (+ 1 1)) (assert-equal? (tn) 3 (+ 1 2)) (assert-equal? (tn) 0 (+ 2 -2)) (assert-equal? (tn) 1 (+ 2 -1)) (assert-equal? (tn) 2 (+ 2 0)) (assert-equal? (tn) 3 (+ 2 1)) (assert-equal? (tn) 4 (+ 2 2)) (if (>= fixnum-bits 60) (begin (tn "+ 2 args 64-bit") (string-eval "(assert-equal? (tn) 1912795422408 (+ 956397711204 956397711204))") (string-eval "(assert-equal? (tn) 0 (+ 956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 0 (+ -956397711204 956397711204))") (string-eval "(assert-equal? (tn) -1912795422408 (+ -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (+ -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -12164692435391 (+ 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) -14077487857799 (+ -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 13121090146595 956397711204))") (string-eval "(assert-equal? (tn) 12164692435391 (+ 13121090146595 -956397711204))") (string-eval "(assert-equal? (tn) -12164692435391 (+ -13121090146595 956397711204))") (string-eval "(assert-equal? (tn) -14077487857799 (+ -13121090146595 -956397711204))"))) (tn "+ 3 args") (assert-equal? (tn) -6 (+ -2 -2 -2)) (assert-equal? (tn) -5 (+ -2 -2 -1)) (assert-equal? (tn) -4 (+ -2 -2 0)) (assert-equal? (tn) -3 (+ -2 -2 1)) (assert-equal? (tn) -2 (+ -2 -2 2)) (assert-equal? (tn) -5 (+ -2 -1 -2)) (assert-equal? (tn) -4 (+ -2 -1 -1)) (assert-equal? (tn) -3 (+ -2 -1 0)) (assert-equal? (tn) -2 (+ -2 -1 1)) (assert-equal? (tn) -1 (+ -2 -1 2)) (assert-equal? (tn) -4 (+ -2 0 -2)) (assert-equal? (tn) -3 (+ -2 0 -1)) (assert-equal? (tn) -2 (+ -2 0 0)) (assert-equal? (tn) -1 (+ -2 0 1)) (assert-equal? (tn) 0 (+ -2 0 2)) (assert-equal? (tn) -3 (+ -2 1 -2)) (assert-equal? (tn) -2 (+ -2 1 -1)) (assert-equal? (tn) -1 (+ -2 1 0)) (assert-equal? (tn) 0 (+ -2 1 1)) (assert-equal? (tn) 1 (+ -2 1 2)) (assert-equal? (tn) -2 (+ -2 2 -2)) (assert-equal? (tn) -1 (+ -2 2 -1)) (assert-equal? (tn) 0 (+ -2 2 0)) (assert-equal? (tn) 1 (+ -2 2 1)) (assert-equal? (tn) 2 (+ -2 2 2)) (assert-equal? (tn) -5 (+ -1 -2 -2)) (assert-equal? (tn) -4 (+ -1 -2 -1)) (assert-equal? (tn) -3 (+ -1 -2 0)) (assert-equal? (tn) -2 (+ -1 -2 1)) (assert-equal? (tn) -1 (+ -1 -2 2)) (assert-equal? (tn) -4 (+ -1 -1 -2)) (assert-equal? (tn) -3 (+ -1 -1 -1)) (assert-equal? (tn) -2 (+ -1 -1 0)) (assert-equal? (tn) -1 (+ -1 -1 1)) (assert-equal? (tn) 0 (+ -1 -1 2)) (assert-equal? (tn) -3 (+ -1 0 -2)) (assert-equal? (tn) -2 (+ -1 0 -1)) (assert-equal? (tn) -1 (+ -1 0 0)) (assert-equal? (tn) 0 (+ -1 0 1)) (assert-equal? (tn) 1 (+ -1 0 2)) (assert-equal? (tn) -2 (+ -1 1 -2)) (assert-equal? (tn) -1 (+ -1 1 -1)) (assert-equal? (tn) 0 (+ -1 1 0)) (assert-equal? (tn) 1 (+ -1 1 1)) (assert-equal? (tn) 2 (+ -1 1 2)) (assert-equal? (tn) -1 (+ -1 2 -2)) (assert-equal? (tn) 0 (+ -1 2 -1)) (assert-equal? (tn) 1 (+ -1 2 0)) (assert-equal? (tn) 2 (+ -1 2 1)) (assert-equal? (tn) 3 (+ -1 2 2)) (assert-equal? (tn) -4 (+ 0 -2 -2)) (assert-equal? (tn) -3 (+ 0 -2 -1)) (assert-equal? (tn) -2 (+ 0 -2 0)) (assert-equal? (tn) -1 (+ 0 -2 1)) (assert-equal? (tn) 0 (+ 0 -2 2)) (assert-equal? (tn) -3 (+ 0 -1 -2)) (assert-equal? (tn) -2 (+ 0 -1 -1)) (assert-equal? (tn) -1 (+ 0 -1 0)) (assert-equal? (tn) 0 (+ 0 -1 1)) (assert-equal? (tn) 1 (+ 0 -1 2)) (assert-equal? (tn) -2 (+ 0 0 -2)) (assert-equal? (tn) -1 (+ 0 0 -1)) (assert-equal? (tn) 0 (+ 0 0 0)) (assert-equal? (tn) 1 (+ 0 0 1)) (assert-equal? (tn) 2 (+ 0 0 2)) (assert-equal? (tn) -1 (+ 0 1 -2)) (assert-equal? (tn) 0 (+ 0 1 -1)) (assert-equal? (tn) 1 (+ 0 1 0)) (assert-equal? (tn) 2 (+ 0 1 1)) (assert-equal? (tn) 3 (+ 0 1 2)) (assert-equal? (tn) 0 (+ 0 2 -2)) (assert-equal? (tn) 1 (+ 0 2 -1)) (assert-equal? (tn) 2 (+ 0 2 0)) (assert-equal? (tn) 3 (+ 0 2 1)) (assert-equal? (tn) 4 (+ 0 2 2)) (assert-equal? (tn) -3 (+ 1 -2 -2)) (assert-equal? (tn) -2 (+ 1 -2 -1)) (assert-equal? (tn) -1 (+ 1 -2 0)) (assert-equal? (tn) 0 (+ 1 -2 1)) (assert-equal? (tn) 1 (+ 1 -2 2)) (assert-equal? (tn) -2 (+ 1 -1 -2)) (assert-equal? (tn) -1 (+ 1 -1 -1)) (assert-equal? (tn) 0 (+ 1 -1 0)) (assert-equal? (tn) 1 (+ 1 -1 1)) (assert-equal? (tn) 2 (+ 1 -1 2)) (assert-equal? (tn) -1 (+ 1 0 -2)) (assert-equal? (tn) 0 (+ 1 0 -1)) (assert-equal? (tn) 1 (+ 1 0 0)) (assert-equal? (tn) 2 (+ 1 0 1)) (assert-equal? (tn) 3 (+ 1 0 2)) (assert-equal? (tn) 0 (+ 1 1 -2)) (assert-equal? (tn) 1 (+ 1 1 -1)) (assert-equal? (tn) 2 (+ 1 1 0)) (assert-equal? (tn) 3 (+ 1 1 1)) (assert-equal? (tn) 4 (+ 1 1 2)) (assert-equal? (tn) 1 (+ 1 2 -2)) (assert-equal? (tn) 2 (+ 1 2 -1)) (assert-equal? (tn) 3 (+ 1 2 0)) (assert-equal? (tn) 4 (+ 1 2 1)) (assert-equal? (tn) 5 (+ 1 2 2)) (assert-equal? (tn) -2 (+ 2 -2 -2)) (assert-equal? (tn) -1 (+ 2 -2 -1)) (assert-equal? (tn) 0 (+ 2 -2 0)) (assert-equal? (tn) 1 (+ 2 -2 1)) (assert-equal? (tn) 2 (+ 2 -2 2)) (assert-equal? (tn) -1 (+ 2 -1 -2)) (assert-equal? (tn) 0 (+ 2 -1 -1)) (assert-equal? (tn) 1 (+ 2 -1 0)) (assert-equal? (tn) 2 (+ 2 -1 1)) (assert-equal? (tn) 3 (+ 2 -1 2)) (assert-equal? (tn) 0 (+ 2 0 -2)) (assert-equal? (tn) 1 (+ 2 0 -1)) (assert-equal? (tn) 2 (+ 2 0 0)) (assert-equal? (tn) 3 (+ 2 0 1)) (assert-equal? (tn) 4 (+ 2 0 2)) (assert-equal? (tn) 1 (+ 2 1 -2)) (assert-equal? (tn) 2 (+ 2 1 -1)) (assert-equal? (tn) 3 (+ 2 1 0)) (assert-equal? (tn) 4 (+ 2 1 1)) (assert-equal? (tn) 5 (+ 2 1 2)) (assert-equal? (tn) 2 (+ 2 2 -2)) (assert-equal? (tn) 3 (+ 2 2 -1)) (assert-equal? (tn) 4 (+ 2 2 0)) (assert-equal? (tn) 5 (+ 2 2 1)) (assert-equal? (tn) 6 (+ 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "+ 3 args 64-bit") (string-eval "(assert-equal? (tn) 2869193133612 (+ 956397711204 956397711204 956397711204))") (string-eval "(assert-equal? (tn) -2869193133612 (+ -956397711204 -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 0 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (+ 0 -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -12164692435391 (+ 0 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) -14077487857799 (+ 0 -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) 12164692435391 (+ 13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) -12164692435391 (+ -13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) -14077487857799 (+ -13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (+ -956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) -12164692435391 (+ 956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) -14077487857799 (+ -956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (+ 13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) 12164692435391 (+ 13121090146595 0 -956397711204))") (string-eval "(assert-equal? (tn) -12164692435391 (+ -13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) -14077487857799 (+ -13121090146595 0 -956397711204))"))) (tn "+ many args") (assert-equal? (tn) 8 (+ 2 2 2 2)) (assert-equal? (tn) 6 (+ 0 2 2 2)) (assert-equal? (tn) 6 (+ 2 0 2 2)) (assert-equal? (tn) 6 (+ 2 2 0 2)) (assert-equal? (tn) 6 (+ 2 2 2 0)) (assert-equal? (tn) 0 (+ -2 -1 0 1 2)) (assert-equal? (tn) 0 (+ 2 1 0 -1 -2)) (assert-equal? (tn) -1 (+ -2 -1 0 -1 1 2)) (assert-equal? (tn) 1 (+ 2 1 0 -1 1 -2)) (assert-equal? (tn) 0 (+ -2 -2 -1 -1 0 0 1 1 2 2)) (assert-equal? (tn) 0 (+ 2 2 1 1 0 0 -1 -1 -2 -2)) (assert-equal? (tn) 17 (+ 3 1 5 -7 2 13)) (tn "+ boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-error (tn) (lambda () (+ 134217727 1)))") (string-eval "(assert-error (tn) (lambda () (+ -134217728 -1)))") (string-eval "(assert-error (tn) (lambda () (+ 134217727 134217727)))") (string-eval "(assert-equal? (tn) 0 (+ 134217727 -134217727))") (string-eval "(assert-equal? (tn) -1 (+ 134217727 -134217728))") (string-eval "(assert-equal? (tn) 0 (+ -134217727 134217727))") (string-eval "(assert-equal? (tn) -1 (+ -134217728 134217727))") (string-eval "(assert-error (tn) (lambda () (+ -134217728 -134217728)))")) ((32) (string-eval "(assert-error (tn) (lambda () (+ 2147483647 1)))") (string-eval "(assert-error (tn) (lambda () (+ -2147483648 -1)))") (string-eval "(assert-error (tn) (lambda () (+ 2147483647 2147483647)))") (string-eval "(assert-equal? (tn) 0 (+ 2147483647 -2147483647))") (string-eval "(assert-equal? (tn) -1 (+ 2147483647 -2147483648))") (string-eval "(assert-equal? (tn) 0 (+ -2147483647 2147483647))") (string-eval "(assert-equal? (tn) -1 (+ -2147483648 2147483647))") (string-eval "(assert-error (tn) (lambda () (+ -2147483648 -2147483648)))")) ((60) (string-eval "(assert-error (tn) (lambda () (+ 576460752303423487 1)))") (string-eval "(assert-error (tn) (lambda () (+ -576460752303423488 -1)))") (string-eval "(assert-error (tn) (lambda () (+ 576460752303423487 576460752303423487)))") (string-eval "(assert-equal? (tn) 0 (+ 576460752303423487 -576460752303423487))") (string-eval "(assert-equal? (tn) -1 (+ 576460752303423487 -576460752303423488))") (string-eval "(assert-equal? (tn) 0 (+ -576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) -1 (+ -576460752303423488 576460752303423487))") (string-eval "(assert-error (tn) (lambda () (+ -576460752303423488 -576460752303423488)))")) ((64) (string-eval "(assert-error (tn) (lambda () (+ 9223372036854775807 1)))") (string-eval "(assert-error (tn) (lambda () (+ -9223372036854775808 -1)))") (string-eval "(assert-error (tn) (lambda () (+ 9223372036854775807 9223372036854775807)))") (string-eval "(assert-equal? (tn) 0 (+ 9223372036854775807 -9223372036854775807))") (string-eval "(assert-equal? (tn) -1 (+ 9223372036854775807 -9223372036854775808))") (string-eval "(assert-equal? (tn) 0 (+ -9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) -1 (+ -9223372036854775808 9223372036854775807))") (string-eval "(assert-error (tn) (lambda () (+ -9223372036854775808 -9223372036854775808)))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "* invalid forms") (assert-error (tn) (lambda () (* #t))) (assert-error (tn) (lambda () (* #f))) (assert-error (tn) (lambda () (* '()))) (assert-error (tn) (lambda () (* 1 #t))) (assert-error (tn) (lambda () (* 1 #f))) (assert-error (tn) (lambda () (* 1 '()))) (assert-error (tn) (lambda () (* 1 2 #t))) (assert-error (tn) (lambda () (* 1 2 #f))) (assert-error (tn) (lambda () (* 1 2 '()))) (tn "* 0 arg") (assert-equal? (tn) 1 (*)) (tn "* 1 arg") (assert-equal? (tn) -2 (* -2)) (assert-equal? (tn) -1 (* -1)) (assert-equal? (tn) 0 (* 0)) (assert-equal? (tn) 1 (* 1)) (assert-equal? (tn) 2 (* 2)) (if (>= fixnum-bits 60) (begin (tn "* 1 arg 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (* 956397711204))") (string-eval "(assert-equal? (tn) -956397711204 (* -956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (* 13121090146595))") (string-eval "(assert-equal? (tn) -13121090146595 (* -13121090146595))"))) (tn "* 2 args") (assert-equal? (tn) 4 (* -2 -2)) (assert-equal? (tn) 2 (* -2 -1)) (assert-equal? (tn) 0 (* -2 0)) (assert-equal? (tn) -2 (* -2 1)) (assert-equal? (tn) -4 (* -2 2)) (assert-equal? (tn) 2 (* -1 -2)) (assert-equal? (tn) 1 (* -1 -1)) (assert-equal? (tn) 0 (* -1 0)) (assert-equal? (tn) -1 (* -1 1)) (assert-equal? (tn) -2 (* -1 2)) (assert-equal? (tn) 0 (* 0 -2)) (assert-equal? (tn) 0 (* 0 -1)) (assert-equal? (tn) 0 (* 0 0)) (assert-equal? (tn) 0 (* 0 1)) (assert-equal? (tn) 0 (* 0 2)) (assert-equal? (tn) -2 (* 1 -2)) (assert-equal? (tn) -1 (* 1 -1)) (assert-equal? (tn) 0 (* 1 0)) (assert-equal? (tn) 1 (* 1 1)) (assert-equal? (tn) 2 (* 1 2)) (assert-equal? (tn) -4 (* 2 -2)) (assert-equal? (tn) -2 (* 2 -1)) (assert-equal? (tn) 0 (* 2 0)) (assert-equal? (tn) 2 (* 2 1)) (assert-equal? (tn) 4 (* 2 2)) (if (>= fixnum-bits 60) (begin (tn "* 2 args 64-bit") (string-eval "(assert-equal? (tn) 67193102640712995 (* 13121090146595 5121))") (string-eval "(assert-equal? (tn) -67193102640712995 (* 13121090146595 -5121))") (string-eval "(assert-equal? (tn) -67193102640712995 (* -13121090146595 5121))") (string-eval "(assert-equal? (tn) 67193102640712995 (* -13121090146595 -5121))") (string-eval "(assert-equal? (tn) 0 (* 13121090146595 0))") (string-eval "(assert-equal? (tn) 0 (* -13121090146595 0))") (string-eval "(assert-equal? (tn) 67193102640712995 (* 5121 13121090146595))") (string-eval "(assert-equal? (tn) -67193102640712995 (* -5121 13121090146595))") (string-eval "(assert-equal? (tn) -67193102640712995 (* 5121 -13121090146595))") (string-eval "(assert-equal? (tn) 67193102640712995 (* -5121 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (* 0 13121090146595))") (string-eval "(assert-equal? (tn) 0 (* 0 -13121090146595))"))) (tn "* 3 args") (assert-equal? (tn) -8 (* -2 -2 -2)) (assert-equal? (tn) -4 (* -2 -2 -1)) (assert-equal? (tn) 0 (* -2 -2 0)) (assert-equal? (tn) 4 (* -2 -2 1)) (assert-equal? (tn) 8 (* -2 -2 2)) (assert-equal? (tn) -4 (* -2 -1 -2)) (assert-equal? (tn) -2 (* -2 -1 -1)) (assert-equal? (tn) 0 (* -2 -1 0)) (assert-equal? (tn) 2 (* -2 -1 1)) (assert-equal? (tn) 4 (* -2 -1 2)) (assert-equal? (tn) 0 (* -2 0 -2)) (assert-equal? (tn) 0 (* -2 0 -1)) (assert-equal? (tn) 0 (* -2 0 0)) (assert-equal? (tn) 0 (* -2 0 1)) (assert-equal? (tn) 0 (* -2 0 2)) (assert-equal? (tn) 4 (* -2 1 -2)) (assert-equal? (tn) 2 (* -2 1 -1)) (assert-equal? (tn) 0 (* -2 1 0)) (assert-equal? (tn) -2 (* -2 1 1)) (assert-equal? (tn) -4 (* -2 1 2)) (assert-equal? (tn) 8 (* -2 2 -2)) (assert-equal? (tn) 4 (* -2 2 -1)) (assert-equal? (tn) 0 (* -2 2 0)) (assert-equal? (tn) -4 (* -2 2 1)) (assert-equal? (tn) -8 (* -2 2 2)) (assert-equal? (tn) -4 (* -1 -2 -2)) (assert-equal? (tn) -2 (* -1 -2 -1)) (assert-equal? (tn) 0 (* -1 -2 0)) (assert-equal? (tn) 2 (* -1 -2 1)) (assert-equal? (tn) 4 (* -1 -2 2)) (assert-equal? (tn) -2 (* -1 -1 -2)) (assert-equal? (tn) -1 (* -1 -1 -1)) (assert-equal? (tn) 0 (* -1 -1 0)) (assert-equal? (tn) 1 (* -1 -1 1)) (assert-equal? (tn) 2 (* -1 -1 2)) (assert-equal? (tn) 0 (* -1 0 -2)) (assert-equal? (tn) 0 (* -1 0 -1)) (assert-equal? (tn) 0 (* -1 0 0)) (assert-equal? (tn) 0 (* -1 0 1)) (assert-equal? (tn) 0 (* -1 0 2)) (assert-equal? (tn) 2 (* -1 1 -2)) (assert-equal? (tn) 1 (* -1 1 -1)) (assert-equal? (tn) 0 (* -1 1 0)) (assert-equal? (tn) -1 (* -1 1 1)) (assert-equal? (tn) -2 (* -1 1 2)) (assert-equal? (tn) 4 (* -1 2 -2)) (assert-equal? (tn) 2 (* -1 2 -1)) (assert-equal? (tn) 0 (* -1 2 0)) (assert-equal? (tn) -2 (* -1 2 1)) (assert-equal? (tn) -4 (* -1 2 2)) (assert-equal? (tn) 0 (* 0 -2 -2)) (assert-equal? (tn) 0 (* 0 -2 -1)) (assert-equal? (tn) 0 (* 0 -2 0)) (assert-equal? (tn) 0 (* 0 -2 1)) (assert-equal? (tn) 0 (* 0 -2 2)) (assert-equal? (tn) 0 (* 0 -1 -2)) (assert-equal? (tn) 0 (* 0 -1 -1)) (assert-equal? (tn) 0 (* 0 -1 0)) (assert-equal? (tn) 0 (* 0 -1 1)) (assert-equal? (tn) 0 (* 0 -1 2)) (assert-equal? (tn) 0 (* 0 0 -2)) (assert-equal? (tn) 0 (* 0 0 -1)) (assert-equal? (tn) 0 (* 0 0 0)) (assert-equal? (tn) 0 (* 0 0 1)) (assert-equal? (tn) 0 (* 0 0 2)) (assert-equal? (tn) 0 (* 0 1 -2)) (assert-equal? (tn) 0 (* 0 1 -1)) (assert-equal? (tn) 0 (* 0 1 0)) (assert-equal? (tn) 0 (* 0 1 1)) (assert-equal? (tn) 0 (* 0 1 2)) (assert-equal? (tn) 0 (* 0 2 -2)) (assert-equal? (tn) 0 (* 0 2 -1)) (assert-equal? (tn) 0 (* 0 2 0)) (assert-equal? (tn) 0 (* 0 2 1)) (assert-equal? (tn) 0 (* 0 2 2)) (assert-equal? (tn) 4 (* 1 -2 -2)) (assert-equal? (tn) 2 (* 1 -2 -1)) (assert-equal? (tn) 0 (* 1 -2 0)) (assert-equal? (tn) -2 (* 1 -2 1)) (assert-equal? (tn) -4 (* 1 -2 2)) (assert-equal? (tn) 2 (* 1 -1 -2)) (assert-equal? (tn) 1 (* 1 -1 -1)) (assert-equal? (tn) 0 (* 1 -1 0)) (assert-equal? (tn) -1 (* 1 -1 1)) (assert-equal? (tn) -2 (* 1 -1 2)) (assert-equal? (tn) 0 (* 1 0 -2)) (assert-equal? (tn) 0 (* 1 0 -1)) (assert-equal? (tn) 0 (* 1 0 0)) (assert-equal? (tn) 0 (* 1 0 1)) (assert-equal? (tn) 0 (* 1 0 2)) (assert-equal? (tn) -2 (* 1 1 -2)) (assert-equal? (tn) -1 (* 1 1 -1)) (assert-equal? (tn) 0 (* 1 1 0)) (assert-equal? (tn) 1 (* 1 1 1)) (assert-equal? (tn) 2 (* 1 1 2)) (assert-equal? (tn) -4 (* 1 2 -2)) (assert-equal? (tn) -2 (* 1 2 -1)) (assert-equal? (tn) 0 (* 1 2 0)) (assert-equal? (tn) 2 (* 1 2 1)) (assert-equal? (tn) 4 (* 1 2 2)) (assert-equal? (tn) 8 (* 2 -2 -2)) (assert-equal? (tn) 4 (* 2 -2 -1)) (assert-equal? (tn) 0 (* 2 -2 0)) (assert-equal? (tn) -4 (* 2 -2 1)) (assert-equal? (tn) -8 (* 2 -2 2)) (assert-equal? (tn) 4 (* 2 -1 -2)) (assert-equal? (tn) 2 (* 2 -1 -1)) (assert-equal? (tn) 0 (* 2 -1 0)) (assert-equal? (tn) -2 (* 2 -1 1)) (assert-equal? (tn) -4 (* 2 -1 2)) (assert-equal? (tn) 0 (* 2 0 -2)) (assert-equal? (tn) 0 (* 2 0 -1)) (assert-equal? (tn) 0 (* 2 0 0)) (assert-equal? (tn) 0 (* 2 0 1)) (assert-equal? (tn) 0 (* 2 0 2)) (assert-equal? (tn) -4 (* 2 1 -2)) (assert-equal? (tn) -2 (* 2 1 -1)) (assert-equal? (tn) 0 (* 2 1 0)) (assert-equal? (tn) 2 (* 2 1 1)) (assert-equal? (tn) 4 (* 2 1 2)) (assert-equal? (tn) -8 (* 2 2 -2)) (assert-equal? (tn) -4 (* 2 2 -1)) (assert-equal? (tn) 0 (* 2 2 0)) (assert-equal? (tn) 4 (* 2 2 1)) (assert-equal? (tn) 8 (* 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "* 3 args 64-bit") (string-eval "(assert-equal? (tn) 470351718484990965 (* 13121090146595 5121 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 13121090146595 -5121 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -13121090146595 5121 7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -13121090146595 -5121 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 13121090146595 5121 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* 13121090146595 -5121 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -13121090146595 5121 -7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -13121090146595 -5121 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* 5121 13121090146595 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -5121 13121090146595 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 5121 -13121090146595 7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -5121 -13121090146595 7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 5121 13121090146595 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -5121 13121090146595 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* 5121 -13121090146595 -7))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -5121 -13121090146595 -7))") (string-eval "(assert-equal? (tn) 470351718484990965 (* 5121 7 13121090146595))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -5121 7 13121090146595))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 5121 7 -13121090146595))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -5121 7 -13121090146595))") (string-eval "(assert-equal? (tn) -470351718484990965 (* 5121 -7 13121090146595))") (string-eval "(assert-equal? (tn) 470351718484990965 (* -5121 -7 13121090146595))") (string-eval "(assert-equal? (tn) 470351718484990965 (* 5121 -7 -13121090146595))") (string-eval "(assert-equal? (tn) -470351718484990965 (* -5121 -7 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (* 0 13121090146595 5121))") (string-eval "(assert-equal? (tn) 0 (* 13121090146595 0 5121))") (string-eval "(assert-equal? (tn) 0 (* 13121090146595 5121 0))") (string-eval "(assert-equal? (tn) 0 (* 0 -13121090146595 5121))") (string-eval "(assert-equal? (tn) 0 (* -13121090146595 0 5121))") (string-eval "(assert-equal? (tn) 0 (* -13121090146595 5121 0))"))) (tn "* many args") (assert-equal? (tn) 16 (* 2 2 2 2)) (assert-equal? (tn) 0 (* 0 2 2 2)) (assert-equal? (tn) 0 (* 2 0 2 2)) (assert-equal? (tn) 0 (* 2 2 0 2)) (assert-equal? (tn) 0 (* 2 2 2 0)) (assert-equal? (tn) 0 (* -2 -1 0 1 2)) (assert-equal? (tn) 0 (* 2 1 0 -1 -2)) (assert-equal? (tn) 0 (* -2 -1 0 -1 1 2)) (assert-equal? (tn) 0 (* 2 1 0 -1 1 -2)) (assert-equal? (tn) 0 (* -2 -2 -1 -1 0 0 1 1 2 2)) (assert-equal? (tn) 0 (* 2 2 1 1 0 0 -1 -1 -2 -2)) (assert-equal? (tn) -2730 (* 3 1 5 -7 2 13)) (tn "* boundary numbers") ;; SigScheme does not check overflow on '*' (if sigscheme? (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) -2 (* 134217727 2))") (string-eval "(assert-equal? (tn) 0 (* -134217728 2))") (string-eval "(assert-equal? (tn) 134217725 (* 134217727 3))") (string-eval "(assert-equal? (tn) -134217728 (* -134217728 3))")) ((32) (string-eval "(assert-equal? (tn) -2 (* 2147483647 2))") (string-eval "(assert-equal? (tn) 0 (* -2147483648 2))") (string-eval "(assert-equal? (tn) 2147483645 (* 2147483647 3))") (string-eval "(assert-equal? (tn) -2147483648 (* -2147483648 3))")) ((60) (string-eval "(assert-equal? (tn) -2 (* 576460752303423487 2))") (string-eval "(assert-equal? (tn) 0 (* -576460752303423488 2))") (string-eval "(assert-equal? (tn) 576460752303423485 (* 576460752303423487 3))") (string-eval "(assert-equal? (tn) -576460752303423488 (* -576460752303423488 3))")) ((64) (string-eval "(assert-equal? (tn) -2 (* 9223372036854775807 2))") (string-eval "(assert-equal? (tn) 0 (* -9223372036854775808 2))") (string-eval "(assert-equal? (tn) 9223372036854775805 (* 9223372036854775807 3))") (string-eval "(assert-equal? (tn) -9223372036854775808 (* -9223372036854775808 3))")) (else (assert-fail (tn) "unknown int bitwidth")))) (tn "- invalid forms") (assert-error (tn) (lambda () (-))) (assert-error (tn) (lambda () (- #t))) (assert-error (tn) (lambda () (- #f))) (assert-error (tn) (lambda () (- '()))) (assert-error (tn) (lambda () (- #t #t))) (assert-error (tn) (lambda () (- #f #f))) (assert-error (tn) (lambda () (- '() '()))) (assert-error (tn) (lambda () (- 1 #t))) (assert-error (tn) (lambda () (- 1 #f))) (assert-error (tn) (lambda () (- 1 '()))) (assert-error (tn) (lambda () (- 1 2 #t))) (assert-error (tn) (lambda () (- 1 2 #f))) (assert-error (tn) (lambda () (- 1 2 '()))) (tn "- 1 arg") (assert-equal? (tn) 2 (- -2)) (assert-equal? (tn) 1 (- -1)) (assert-equal? (tn) 0 (- 0)) (assert-equal? (tn) -1 (- 1)) (assert-equal? (tn) -2 (- 2)) (if (>= fixnum-bits 60) (begin (tn "- 1 arg 64-bit") (string-eval "(assert-equal? (tn) -956397711204 (- 956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (- -956397711204))") (string-eval "(assert-equal? (tn) -13121090146595 (- 13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (- -13121090146595))"))) (tn "- 2 args") (assert-equal? (tn) 0 (- -2 -2)) (assert-equal? (tn) -1 (- -2 -1)) (assert-equal? (tn) -2 (- -2 0)) (assert-equal? (tn) -3 (- -2 1)) (assert-equal? (tn) -4 (- -2 2)) (assert-equal? (tn) 1 (- -1 -2)) (assert-equal? (tn) 0 (- -1 -1)) (assert-equal? (tn) -1 (- -1 0)) (assert-equal? (tn) -2 (- -1 1)) (assert-equal? (tn) -3 (- -1 2)) (assert-equal? (tn) 2 (- 0 -2)) (assert-equal? (tn) 1 (- 0 -1)) (assert-equal? (tn) 0 (- 0 0)) (assert-equal? (tn) -1 (- 0 1)) (assert-equal? (tn) -2 (- 0 2)) (assert-equal? (tn) 3 (- 1 -2)) (assert-equal? (tn) 2 (- 1 -1)) (assert-equal? (tn) 1 (- 1 0)) (assert-equal? (tn) 0 (- 1 1)) (assert-equal? (tn) -1 (- 1 2)) (assert-equal? (tn) 4 (- 2 -2)) (assert-equal? (tn) 3 (- 2 -1)) (assert-equal? (tn) 2 (- 2 0)) (assert-equal? (tn) 1 (- 2 1)) (assert-equal? (tn) 0 (- 2 2)) (if (>= fixnum-bits 60) (begin (tn "- 2 args 64-bit") (string-eval "(assert-equal? (tn) 0 (- 956397711204 956397711204))") (string-eval "(assert-equal? (tn) 1912795422408 (- 956397711204 -956397711204))") (string-eval "(assert-equal? (tn) -1912795422408 (- -956397711204 956397711204))") (string-eval "(assert-equal? (tn) 0 (- -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) -12164692435391 (- 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -14077487857799 (- -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (- 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- 13121090146595 956397711204))") (string-eval "(assert-equal? (tn) 14077487857799 (- 13121090146595 -956397711204))") (string-eval "(assert-equal? (tn) -14077487857799 (- -13121090146595 956397711204))") (string-eval "(assert-equal? (tn) -12164692435391 (- -13121090146595 -956397711204))"))) (tn "- 3 args") (assert-equal? (tn) 2 (- -2 -2 -2)) (assert-equal? (tn) 1 (- -2 -2 -1)) (assert-equal? (tn) 0 (- -2 -2 0)) (assert-equal? (tn) -1 (- -2 -2 1)) (assert-equal? (tn) -2 (- -2 -2 2)) (assert-equal? (tn) 1 (- -2 -1 -2)) (assert-equal? (tn) 0 (- -2 -1 -1)) (assert-equal? (tn) -1 (- -2 -1 0)) (assert-equal? (tn) -2 (- -2 -1 1)) (assert-equal? (tn) -3 (- -2 -1 2)) (assert-equal? (tn) 0 (- -2 0 -2)) (assert-equal? (tn) -1 (- -2 0 -1)) (assert-equal? (tn) -2 (- -2 0 0)) (assert-equal? (tn) -3 (- -2 0 1)) (assert-equal? (tn) -4 (- -2 0 2)) (assert-equal? (tn) -1 (- -2 1 -2)) (assert-equal? (tn) -2 (- -2 1 -1)) (assert-equal? (tn) -3 (- -2 1 0)) (assert-equal? (tn) -4 (- -2 1 1)) (assert-equal? (tn) -5 (- -2 1 2)) (assert-equal? (tn) -2 (- -2 2 -2)) (assert-equal? (tn) -3 (- -2 2 -1)) (assert-equal? (tn) -4 (- -2 2 0)) (assert-equal? (tn) -5 (- -2 2 1)) (assert-equal? (tn) -6 (- -2 2 2)) (assert-equal? (tn) 3 (- -1 -2 -2)) (assert-equal? (tn) 2 (- -1 -2 -1)) (assert-equal? (tn) 1 (- -1 -2 0)) (assert-equal? (tn) 0 (- -1 -2 1)) (assert-equal? (tn) -1 (- -1 -2 2)) (assert-equal? (tn) 2 (- -1 -1 -2)) (assert-equal? (tn) 1 (- -1 -1 -1)) (assert-equal? (tn) 0 (- -1 -1 0)) (assert-equal? (tn) -1 (- -1 -1 1)) (assert-equal? (tn) -2 (- -1 -1 2)) (assert-equal? (tn) 1 (- -1 0 -2)) (assert-equal? (tn) 0 (- -1 0 -1)) (assert-equal? (tn) -1 (- -1 0 0)) (assert-equal? (tn) -2 (- -1 0 1)) (assert-equal? (tn) -3 (- -1 0 2)) (assert-equal? (tn) 0 (- -1 1 -2)) (assert-equal? (tn) -1 (- -1 1 -1)) (assert-equal? (tn) -2 (- -1 1 0)) (assert-equal? (tn) -3 (- -1 1 1)) (assert-equal? (tn) -4 (- -1 1 2)) (assert-equal? (tn) -1 (- -1 2 -2)) (assert-equal? (tn) -2 (- -1 2 -1)) (assert-equal? (tn) -3 (- -1 2 0)) (assert-equal? (tn) -4 (- -1 2 1)) (assert-equal? (tn) -5 (- -1 2 2)) (assert-equal? (tn) 4 (- 0 -2 -2)) (assert-equal? (tn) 3 (- 0 -2 -1)) (assert-equal? (tn) 2 (- 0 -2 0)) (assert-equal? (tn) 1 (- 0 -2 1)) (assert-equal? (tn) 0 (- 0 -2 2)) (assert-equal? (tn) 3 (- 0 -1 -2)) (assert-equal? (tn) 2 (- 0 -1 -1)) (assert-equal? (tn) 1 (- 0 -1 0)) (assert-equal? (tn) 0 (- 0 -1 1)) (assert-equal? (tn) -1 (- 0 -1 2)) (assert-equal? (tn) 2 (- 0 0 -2)) (assert-equal? (tn) 1 (- 0 0 -1)) (assert-equal? (tn) 0 (- 0 0 0)) (assert-equal? (tn) -1 (- 0 0 1)) (assert-equal? (tn) -2 (- 0 0 2)) (assert-equal? (tn) 1 (- 0 1 -2)) (assert-equal? (tn) 0 (- 0 1 -1)) (assert-equal? (tn) -1 (- 0 1 0)) (assert-equal? (tn) -2 (- 0 1 1)) (assert-equal? (tn) -3 (- 0 1 2)) (assert-equal? (tn) 0 (- 0 2 -2)) (assert-equal? (tn) -1 (- 0 2 -1)) (assert-equal? (tn) -2 (- 0 2 0)) (assert-equal? (tn) -3 (- 0 2 1)) (assert-equal? (tn) -4 (- 0 2 2)) (assert-equal? (tn) 5 (- 1 -2 -2)) (assert-equal? (tn) 4 (- 1 -2 -1)) (assert-equal? (tn) 3 (- 1 -2 0)) (assert-equal? (tn) 2 (- 1 -2 1)) (assert-equal? (tn) 1 (- 1 -2 2)) (assert-equal? (tn) 4 (- 1 -1 -2)) (assert-equal? (tn) 3 (- 1 -1 -1)) (assert-equal? (tn) 2 (- 1 -1 0)) (assert-equal? (tn) 1 (- 1 -1 1)) (assert-equal? (tn) 0 (- 1 -1 2)) (assert-equal? (tn) 3 (- 1 0 -2)) (assert-equal? (tn) 2 (- 1 0 -1)) (assert-equal? (tn) 1 (- 1 0 0)) (assert-equal? (tn) 0 (- 1 0 1)) (assert-equal? (tn) -1 (- 1 0 2)) (assert-equal? (tn) 2 (- 1 1 -2)) (assert-equal? (tn) 1 (- 1 1 -1)) (assert-equal? (tn) 0 (- 1 1 0)) (assert-equal? (tn) -1 (- 1 1 1)) (assert-equal? (tn) -2 (- 1 1 2)) (assert-equal? (tn) 1 (- 1 2 -2)) (assert-equal? (tn) 0 (- 1 2 -1)) (assert-equal? (tn) -1 (- 1 2 0)) (assert-equal? (tn) -2 (- 1 2 1)) (assert-equal? (tn) -3 (- 1 2 2)) (assert-equal? (tn) 6 (- 2 -2 -2)) (assert-equal? (tn) 5 (- 2 -2 -1)) (assert-equal? (tn) 4 (- 2 -2 0)) (assert-equal? (tn) 3 (- 2 -2 1)) (assert-equal? (tn) 2 (- 2 -2 2)) (assert-equal? (tn) 5 (- 2 -1 -2)) (assert-equal? (tn) 4 (- 2 -1 -1)) (assert-equal? (tn) 3 (- 2 -1 0)) (assert-equal? (tn) 2 (- 2 -1 1)) (assert-equal? (tn) 1 (- 2 -1 2)) (assert-equal? (tn) 4 (- 2 0 -2)) (assert-equal? (tn) 3 (- 2 0 -1)) (assert-equal? (tn) 2 (- 2 0 0)) (assert-equal? (tn) 1 (- 2 0 1)) (assert-equal? (tn) 0 (- 2 0 2)) (assert-equal? (tn) 3 (- 2 1 -2)) (assert-equal? (tn) 2 (- 2 1 -1)) (assert-equal? (tn) 1 (- 2 1 0)) (assert-equal? (tn) 0 (- 2 1 1)) (assert-equal? (tn) -1 (- 2 1 2)) (assert-equal? (tn) 2 (- 2 2 -2)) (assert-equal? (tn) 1 (- 2 2 -1)) (assert-equal? (tn) 0 (- 2 2 0)) (assert-equal? (tn) -1 (- 2 2 1)) (assert-equal? (tn) -2 (- 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "- 3 args 64-bit") (string-eval "(assert-equal? (tn) -956397711204 (- 956397711204 956397711204 956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (- -956397711204 -956397711204 -956397711204))") (string-eval "(assert-equal? (tn) -14077487857799 (- 0 956397711204 13121090146595))") (string-eval "(assert-equal? (tn) -12164692435391 (- 0 -956397711204 13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- 0 956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (- 0 -956397711204 -13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- 13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) 14077487857799 (- 13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) -14077487857799 (- -13121090146595 956397711204 0))") (string-eval "(assert-equal? (tn) -12164692435391 (- -13121090146595 -956397711204 0))") (string-eval "(assert-equal? (tn) -12164692435391 (- 956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) -14077487857799 (- -956397711204 0 13121090146595))") (string-eval "(assert-equal? (tn) 14077487857799 (- 956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- -956397711204 0 -13121090146595))") (string-eval "(assert-equal? (tn) 12164692435391 (- 13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) 14077487857799 (- 13121090146595 0 -956397711204))") (string-eval "(assert-equal? (tn) -14077487857799 (- -13121090146595 0 956397711204))") (string-eval "(assert-equal? (tn) -12164692435391 (- -13121090146595 0 -956397711204))"))) (tn "- many args") (assert-equal? (tn) -4 (- 2 2 2 2)) (assert-equal? (tn) -6 (- 0 2 2 2)) (assert-equal? (tn) -2 (- 2 0 2 2)) (assert-equal? (tn) -2 (- 2 2 0 2)) (assert-equal? (tn) -2 (- 2 2 2 0)) (assert-equal? (tn) -4 (- -2 -1 0 1 2)) (assert-equal? (tn) 4 (- 2 1 0 -1 -2)) (assert-equal? (tn) -3 (- -2 -1 0 -1 1 2)) (assert-equal? (tn) 3 (- 2 1 0 -1 1 -2)) (assert-equal? (tn) -4 (- -2 -2 -1 -1 0 0 1 1 2 2)) (assert-equal? (tn) 4 (- 2 2 1 1 0 0 -1 -1 -2 -2)) (assert-equal? (tn) -11 (- 3 1 5 -7 2 13)) (tn "- boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-error (tn) (lambda () (- -134217728)))") (string-eval "(assert-error (tn) (lambda () (- -134217728 1)))") (string-eval "(assert-equal? (tn) -134217727 (- 134217727))") (string-eval "(assert-equal? (tn) 134217727 (- -134217727))") (string-eval "(assert-equal? (tn) 0 (- 134217727 134217727))") (string-eval "(assert-equal? (tn) 0 (- -134217728 -134217728))")) ((32) (string-eval "(assert-error (tn) (lambda () (- -2147483648)))") (string-eval "(assert-error (tn) (lambda () (- -2147483648 1)))") (string-eval "(assert-equal? (tn) -2147483647 (- 2147483647))") (string-eval "(assert-equal? (tn) 2147483647 (- -2147483647))") (string-eval "(assert-equal? (tn) 0 (- 2147483647 2147483647))") (string-eval "(assert-equal? (tn) 0 (- -2147483648 -2147483648))")) ((60) (string-eval "(assert-error (tn) (lambda () (- -576460752303423488)))") (string-eval "(assert-error (tn) (lambda () (- -576460752303423488 1)))") (string-eval "(assert-equal? (tn) -576460752303423487 (- 576460752303423487))") (string-eval "(assert-equal? (tn) 576460752303423487 (- -576460752303423487))") (string-eval "(assert-equal? (tn) 0 (- 576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) 0 (- -576460752303423488 -576460752303423488))")) ((64) (string-eval "(assert-error (tn) (lambda () (- -9223372036854775808)))") (string-eval "(assert-error (tn) (lambda () (- -9223372036854775808 1)))") (string-eval "(assert-equal? (tn) -9223372036854775807 (- 9223372036854775807))") (string-eval "(assert-equal? (tn) 9223372036854775807 (- -9223372036854775807))") (string-eval "(assert-equal? (tn) 0 (- 9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) 0 (- -9223372036854775808 -9223372036854775808))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "/ invalid forms") (assert-error (tn) (lambda () (/))) (assert-error (tn) (lambda () (/ #t))) (assert-error (tn) (lambda () (/ #f))) (assert-error (tn) (lambda () (/ '()))) (assert-error (tn) (lambda () (/ #t #t))) (assert-error (tn) (lambda () (/ #f #f))) (assert-error (tn) (lambda () (/ '() '()))) (assert-error (tn) (lambda () (/ 1 #t))) (assert-error (tn) (lambda () (/ 1 #f))) (assert-error (tn) (lambda () (/ 1 '()))) (assert-error (tn) (lambda () (/ 1 2 #t))) (assert-error (tn) (lambda () (/ 1 2 #f))) (assert-error (tn) (lambda () (/ 1 2 '()))) (if (symbol-bound? 'inexact?) (assert-fail "/" "no tests for inexact results") (begin (tn "/ 1 arg") (assert-equal? (tn) 0 (/ -2)) (assert-equal? (tn) -1 (/ -1)) (assert-error (tn) (lambda () (/ 0))) (assert-equal? (tn) 1 (/ 1)) (assert-equal? (tn) 0 (/ 2)) (if (>= fixnum-bits 60) (begin (tn "/ 1 arg 64-bit") (string-eval "(assert-equal? (tn) 0 (/ 956397711204))") (string-eval "(assert-equal? (tn) 0 (/ -956397711204))") (string-eval "(assert-equal? (tn) 0 (/ 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -13121090146595))"))) (tn "/ 2 args") (assert-equal? (tn) 1 (/ -2 -2)) (assert-equal? (tn) 2 (/ -2 -1)) (assert-error (tn) (lambda () (/ -2 0))) (assert-equal? (tn) -2 (/ -2 1)) (assert-equal? (tn) -1 (/ -2 2)) (assert-equal? (tn) 0 (/ -1 -2)) (assert-equal? (tn) 1 (/ -1 -1)) (assert-error (tn) (lambda () (/ -1 0))) (assert-equal? (tn) -1 (/ -1 1)) (assert-equal? (tn) 0 (/ -1 2)) (assert-equal? (tn) 0 (/ 0 -2)) (assert-equal? (tn) 0 (/ 0 -1)) (assert-error (tn) (lambda () (/ 0 0))) (assert-equal? (tn) 0 (/ 0 1)) (assert-equal? (tn) 0 (/ 0 2)) (assert-equal? (tn) 0 (/ 1 -2)) (assert-equal? (tn) -1 (/ 1 -1)) (assert-error (tn) (lambda () (/ 1 0))) (assert-equal? (tn) 1 (/ 1 1)) (assert-equal? (tn) 0 (/ 1 2)) (assert-equal? (tn) -1 (/ 2 -2)) (assert-equal? (tn) -2 (/ 2 -1)) (assert-error (tn) (lambda () (/ 2 0))) (assert-equal? (tn) 2 (/ 2 1)) (assert-equal? (tn) 1 (/ 2 2)) (if (>= fixnum-bits 60) (begin (tn "/ 2 args 64-bit") (string-eval "(assert-equal? (tn) 2 (/ 13121090146595 5121297354163))") (string-eval "(assert-equal? (tn) -2 (/ 13121090146595 -5121297354163))") (string-eval "(assert-equal? (tn) -2 (/ -13121090146595 5121297354163))") (string-eval "(assert-equal? (tn) 2 (/ -13121090146595 -5121297354163))") (string-eval "(assert-error (tn) (lambda () (/ 13121090146595 0)))") (string-eval "(assert-error (tn) (lambda () (/ -13121090146595 0)))") (string-eval "(assert-equal? (tn) 0 (/ 5121297354163 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121297354163 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 5121297354163 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121297354163 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 0 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 0 -13121090146595))"))) (tn "/ 3 args") (assert-equal? (tn) 0 (/ -2 -2 -2)) (assert-equal? (tn) -1 (/ -2 -2 -1)) (assert-error (tn) (lambda () (/ -2 -2 0))) (assert-equal? (tn) 1 (/ -2 -2 1)) (assert-equal? (tn) 0 (/ -2 -2 2)) (assert-equal? (tn) -1 (/ -2 -1 -2)) (assert-equal? (tn) -2 (/ -2 -1 -1)) (assert-error (tn) (lambda () (/ -2 -1 0))) (assert-equal? (tn) 2 (/ -2 -1 1)) (assert-equal? (tn) 1 (/ -2 -1 2)) (assert-error (tn) (lambda () (/ -2 0 -2))) (assert-error (tn) (lambda () (/ -2 0 -1))) (assert-error (tn) (lambda () (/ -2 0 0))) (assert-error (tn) (lambda () (/ -2 0 1))) (assert-error (tn) (lambda () (/ -2 0 2))) (assert-equal? (tn) 1 (/ -2 1 -2)) (assert-equal? (tn) 2 (/ -2 1 -1)) (assert-error (tn) (lambda () (/ -2 1 0))) (assert-equal? (tn) -2 (/ -2 1 1)) (assert-equal? (tn) -1 (/ -2 1 2)) (assert-equal? (tn) 0 (/ -2 2 -2)) (assert-equal? (tn) 1 (/ -2 2 -1)) (assert-error (tn) (lambda () (/ -2 2 0))) (assert-equal? (tn) -1 (/ -2 2 1)) (assert-equal? (tn) 0 (/ -2 2 2)) (assert-equal? (tn) 0 (/ -1 -2 -2)) (assert-equal? (tn) 0 (/ -1 -2 -1)) (assert-error (tn) (lambda () (/ -1 -2 0))) (assert-equal? (tn) 0 (/ -1 -2 1)) (assert-equal? (tn) 0 (/ -1 -2 2)) (assert-equal? (tn) 0 (/ -1 -1 -2)) (assert-equal? (tn) -1 (/ -1 -1 -1)) (assert-error (tn) (lambda () (/ -1 -1 0))) (assert-equal? (tn) 1 (/ -1 -1 1)) (assert-equal? (tn) 0 (/ -1 -1 2)) (assert-error (tn) (lambda () (/ -1 0 -2))) (assert-error (tn) (lambda () (/ -1 0 -1))) (assert-error (tn) (lambda () (/ -1 0 0))) (assert-error (tn) (lambda () (/ -1 0 1))) (assert-error (tn) (lambda () (/ -1 0 2))) (assert-equal? (tn) 0 (/ -1 1 -2)) (assert-equal? (tn) 1 (/ -1 1 -1)) (assert-error (tn) (lambda () (/ -1 1 0))) (assert-equal? (tn) -1 (/ -1 1 1)) (assert-equal? (tn) 0 (/ -1 1 2)) (assert-equal? (tn) 0 (/ -1 2 -2)) (assert-equal? (tn) 0 (/ -1 2 -1)) (assert-error (tn) (lambda () (/ -1 2 0))) (assert-equal? (tn) 0 (/ -1 2 1)) (assert-equal? (tn) 0 (/ -1 2 2)) (assert-equal? (tn) 0 (/ 0 -2 -2)) (assert-equal? (tn) 0 (/ 0 -2 -1)) (assert-error (tn) (lambda () (/ 0 -2 0))) (assert-equal? (tn) 0 (/ 0 -2 1)) (assert-equal? (tn) 0 (/ 0 -2 2)) (assert-equal? (tn) 0 (/ 0 -1 -2)) (assert-equal? (tn) 0 (/ 0 -1 -1)) (assert-error (tn) (lambda () (/ 0 -1 0))) (assert-equal? (tn) 0 (/ 0 -1 1)) (assert-equal? (tn) 0 (/ 0 -1 2)) (assert-error (tn) (lambda () (/ 0 0 -2))) (assert-error (tn) (lambda () (/ 0 0 -1))) (assert-error (tn) (lambda () (/ 0 0 0))) (assert-error (tn) (lambda () (/ 0 0 1))) (assert-error (tn) (lambda () (/ 0 0 2))) (assert-equal? (tn) 0 (/ 0 1 -2)) (assert-equal? (tn) 0 (/ 0 1 -1)) (assert-error (tn) (lambda () (/ 0 1 0))) (assert-equal? (tn) 0 (/ 0 1 1)) (assert-equal? (tn) 0 (/ 0 1 2)) (assert-equal? (tn) 0 (/ 0 2 -2)) (assert-equal? (tn) 0 (/ 0 2 -1)) (assert-error (tn) (lambda () (/ 0 2 0))) (assert-equal? (tn) 0 (/ 0 2 1)) (assert-equal? (tn) 0 (/ 0 2 2)) (assert-equal? (tn) 0 (/ 1 -2 -2)) (assert-equal? (tn) 0 (/ 1 -2 -1)) (assert-error (tn) (lambda () (/ 1 -2 0))) (assert-equal? (tn) 0 (/ 1 -2 1)) (assert-equal? (tn) 0 (/ 1 -2 2)) (assert-equal? (tn) 0 (/ 1 -1 -2)) (assert-equal? (tn) 1 (/ 1 -1 -1)) (assert-error (tn) (lambda () (/ 1 -1 0))) (assert-equal? (tn) -1 (/ 1 -1 1)) (assert-equal? (tn) 0 (/ 1 -1 2)) (assert-error (tn) (lambda () (/ 1 0 -2))) (assert-error (tn) (lambda () (/ 1 0 -1))) (assert-error (tn) (lambda () (/ 1 0 0))) (assert-error (tn) (lambda () (/ 1 0 1))) (assert-error (tn) (lambda () (/ 1 0 2))) (assert-equal? (tn) 0 (/ 1 1 -2)) (assert-equal? (tn) -1 (/ 1 1 -1)) (assert-error (tn) (lambda () (/ 1 1 0))) (assert-equal? (tn) 1 (/ 1 1 1)) (assert-equal? (tn) 0 (/ 1 1 2)) (assert-equal? (tn) 0 (/ 1 2 -2)) (assert-equal? (tn) 0 (/ 1 2 -1)) (assert-error (tn) (lambda () (/ 1 2 0))) (assert-equal? (tn) 0 (/ 1 2 1)) (assert-equal? (tn) 0 (/ 1 2 2)) (assert-equal? (tn) 0 (/ 2 -2 -2)) (assert-equal? (tn) 1 (/ 2 -2 -1)) (assert-error (tn) (lambda () (/ 2 -2 0))) (assert-equal? (tn) -1 (/ 2 -2 1)) (assert-equal? (tn) 0 (/ 2 -2 2)) (assert-equal? (tn) 1 (/ 2 -1 -2)) (assert-equal? (tn) 2 (/ 2 -1 -1)) (assert-error (tn) (lambda () (/ 2 -1 0))) (assert-equal? (tn) -2 (/ 2 -1 1)) (assert-equal? (tn) -1 (/ 2 -1 2)) (assert-error (tn) (lambda () (/ 2 0 -2))) (assert-error (tn) (lambda () (/ 2 0 -1))) (assert-error (tn) (lambda () (/ 2 0 0))) (assert-error (tn) (lambda () (/ 2 0 1))) (assert-error (tn) (lambda () (/ 2 0 2))) (assert-equal? (tn) -1 (/ 2 1 -2)) (assert-equal? (tn) -2 (/ 2 1 -1)) (assert-error (tn) (lambda () (/ 2 1 0))) (assert-equal? (tn) 2 (/ 2 1 1)) (assert-equal? (tn) 1 (/ 2 1 2)) (assert-equal? (tn) 0 (/ 2 2 -2)) (assert-equal? (tn) -1 (/ 2 2 -1)) (assert-error (tn) (lambda () (/ 2 2 0))) (assert-equal? (tn) 1 (/ 2 2 1)) (assert-equal? (tn) 0 (/ 2 2 2)) (if (>= fixnum-bits 60) (begin (tn "/ 3 args 64-bit") (string-eval "(assert-equal? (tn) 366030355 (/ 13121090146595 5121 7))") (string-eval "(assert-equal? (tn) -366030355 (/ 13121090146595 -5121 7))") (string-eval "(assert-equal? (tn) -366030355 (/ -13121090146595 5121 7))") (string-eval "(assert-equal? (tn) 366030355 (/ -13121090146595 -5121 7))") (string-eval "(assert-equal? (tn) -366030355 (/ 13121090146595 5121 -7))") (string-eval "(assert-equal? (tn) 366030355 (/ 13121090146595 -5121 -7))") (string-eval "(assert-equal? (tn) 366030355 (/ -13121090146595 5121 -7))") (string-eval "(assert-equal? (tn) -366030355 (/ -13121090146595 -5121 -7))") (string-eval "(assert-equal? (tn) 0 (/ 5121 13121090146595 7))") (string-eval "(assert-equal? (tn) 0 (/ -5121 13121090146595 7))") (string-eval "(assert-equal? (tn) 0 (/ 5121 -13121090146595 7))") (string-eval "(assert-equal? (tn) 0 (/ -5121 -13121090146595 7))") (string-eval "(assert-equal? (tn) 0 (/ 5121 13121090146595 -7))") (string-eval "(assert-equal? (tn) 0 (/ -5121 13121090146595 -7))") (string-eval "(assert-equal? (tn) 0 (/ 5121 -13121090146595 -7))") (string-eval "(assert-equal? (tn) 0 (/ -5121 -13121090146595 -7))") (string-eval "(assert-equal? (tn) 0 (/ 5121 7 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121 7 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 5121 7 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121 7 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 5121 -7 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121 -7 13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 5121 -7 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ -5121 -7 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (/ 0 13121090146595 5121))") (string-eval "(assert-error (tn) (lambda () (/ 13121090146595 0 5121)))") (string-eval "(assert-error (tn) (lambda () (/ 13121090146595 5121 0)))") (string-eval "(assert-equal? (tn) 0 (/ 0 -13121090146595 5121))") (string-eval "(assert-error (tn) (lambda () (/ -13121090146595 0 5121)))") (string-eval "(assert-error (tn) (lambda () (/ -13121090146595 5121 0)))"))) (tn "/ many args") (assert-equal? (tn) 0 (/ 2 2 2 2)) (assert-equal? (tn) 0 (/ 0 2 2 2)) (assert-error (tn) (lambda () (/ 2 0 2 2))) (assert-error (tn) (lambda () (/ 2 2 0 2))) (assert-error (tn) (lambda () (/ 2 2 2 0))) (assert-error (tn) (lambda () (/ -2 -1 0 1 2))) (assert-error (tn) (lambda () (/ 2 1 0 -1 -2))) (assert-error (tn) (lambda () (/ -2 -1 0 -1 1 2))) (assert-error (tn) (lambda () (/ 2 1 0 -1 1 -2))) (assert-error (tn) (lambda () (/ -2 -2 -1 -1 0 0 1 1 2 2))) (assert-error (tn) (lambda () (/ 2 2 1 1 0 0 -1 -1 -2 -2))) (assert-equal? (tn) 121 (/ 2349873 8 23 21 5)))) (tn "/ boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 1 (/ 134217727 134217727))") (string-eval "(assert-equal? (tn) 1 (/ -134217728 -134217728))")) ((32) (string-eval "(assert-equal? (tn) 1 (/ 2147483647 2147483647))") (string-eval "(assert-equal? (tn) 1 (/ -2147483648 -2147483648))")) ((60) (string-eval "(assert-equal? (tn) 1 (/ 576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) 1 (/ -576460752303423488 -576460752303423488))")) ((64) (string-eval "(assert-equal? (tn) 1 (/ 9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) 1 (/ -9223372036854775808 -9223372036854775808))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "abs invalid forms") (assert-error (tn) (lambda () (abs))) (assert-error (tn) (lambda () (abs #t))) (assert-error (tn) (lambda () (abs #f))) (assert-error (tn) (lambda () (abs '()))) (assert-error (tn) (lambda () (abs #t #t))) (assert-error (tn) (lambda () (abs #f #f))) (assert-error (tn) (lambda () (abs '() '()))) (assert-error (tn) (lambda () (abs 1 2))) (assert-error (tn) (lambda () (abs 1 #t))) (assert-error (tn) (lambda () (abs 1 #f))) (assert-error (tn) (lambda () (abs 1 '()))) (tn "abs") (assert-equal? (tn) 3 (abs -3)) (assert-equal? (tn) 2 (abs -2)) (assert-equal? (tn) 1 (abs -1)) (assert-equal? (tn) 0 (abs 0)) (assert-equal? (tn) 1 (abs 1)) (assert-equal? (tn) 2 (abs 2)) (assert-equal? (tn) 3 (abs 3)) (assert-equal? (tn) 5921370 (abs #x-5a5a5a)) (assert-equal? (tn) 5921370 (abs #x5a5a5a)) (if (>= fixnum-bits 60) (begin (tn "abs 64-bit") (string-eval "(assert-equal? (tn) 956397711204 (abs 956397711204))") (string-eval "(assert-equal? (tn) 956397711204 (abs -956397711204))") (string-eval "(assert-equal? (tn) 13121090146595 (abs 13121090146595))") (string-eval "(assert-equal? (tn) 13121090146595 (abs -13121090146595))"))) (tn "abs boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 134217727 (abs 134217727))") (string-eval "(assert-equal? (tn) 134217727 (abs -134217727))") (string-eval "(assert-error (tn) (lambda () (abs -134217728)))")) ((32) (string-eval "(assert-equal? (tn) 2147483647 (abs 2147483647))") (string-eval "(assert-equal? (tn) 2147483647 (abs -2147483647))") (string-eval "(assert-error (tn) (lambda () (abs -2147483648)))")) ((60) (string-eval "(assert-equal? (tn) 576460752303423487 (abs 576460752303423487))") (string-eval "(assert-equal? (tn) 576460752303423487 (abs -576460752303423487))") (string-eval "(assert-error (tn) (lambda () (abs -576460752303423488)))")) ((64) (string-eval "(assert-equal? (tn) 9223372036854775807 (abs 9223372036854775807))") (string-eval "(assert-equal? (tn) 9223372036854775807 (abs -9223372036854775807))") (string-eval "(assert-error (tn) (lambda () (abs -9223372036854775808))))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "quotient invalid forms") (assert-error (tn) (lambda () (quotient))) (assert-error (tn) (lambda () (quotient #t))) (assert-error (tn) (lambda () (quotient #f))) (assert-error (tn) (lambda () (quotient '()))) (assert-error (tn) (lambda () (quotient #t #t))) (assert-error (tn) (lambda () (quotient #f #f))) (assert-error (tn) (lambda () (quotient '() '()))) (assert-error (tn) (lambda () (quotient 1))) (assert-error (tn) (lambda () (quotient 1 #t))) (assert-error (tn) (lambda () (quotient 1 #f))) (assert-error (tn) (lambda () (quotient 1 '()))) (assert-error (tn) (lambda () (quotient 1 2 #t))) (assert-error (tn) (lambda () (quotient 1 2 #f))) (assert-error (tn) (lambda () (quotient 1 2 '()))) (tn "quotient") (assert-equal? (tn) 1 (quotient -2 -2)) (assert-equal? (tn) 2 (quotient -2 -1)) (assert-error (tn) (lambda () (quotient -2 0))) (assert-equal? (tn) -2 (quotient -2 1)) (assert-equal? (tn) -1 (quotient -2 2)) (assert-equal? (tn) 0 (quotient -1 -2)) (assert-equal? (tn) 1 (quotient -1 -1)) (assert-error (tn) (lambda () (quotient -1 0))) (assert-equal? (tn) -1 (quotient -1 1)) (assert-equal? (tn) 0 (quotient -1 2)) (assert-equal? (tn) 0 (quotient 0 -2)) (assert-equal? (tn) 0 (quotient 0 -1)) (assert-error (tn) (lambda () (quotient 0 0))) (assert-equal? (tn) 0 (quotient 0 1)) (assert-equal? (tn) 0 (quotient 0 2)) (assert-equal? (tn) 0 (quotient 1 -2)) (assert-equal? (tn) -1 (quotient 1 -1)) (assert-error (tn) (lambda () (quotient 1 0))) (assert-equal? (tn) 1 (quotient 1 1)) (assert-equal? (tn) 0 (quotient 1 2)) (assert-equal? (tn) -1 (quotient 2 -2)) (assert-equal? (tn) -2 (quotient 2 -1)) (assert-error (tn) (lambda () (quotient 2 0))) (assert-equal? (tn) 2 (quotient 2 1)) (assert-equal? (tn) 1 (quotient 2 2)) (assert-equal? (tn) 17 (quotient 121 7)) (assert-equal? (tn) -17 (quotient 121 -7)) (assert-equal? (tn) -17 (quotient -121 7)) (assert-equal? (tn) 17 (quotient -121 -7)) (if (>= fixnum-bits 60) (begin (tn "quotient 64-bit") (string-eval "(assert-equal? (tn) 2 (quotient 13121090146595 5121297354163))") (string-eval "(assert-equal? (tn) -2 (quotient 13121090146595 -5121297354163))") (string-eval "(assert-equal? (tn) -2 (quotient -13121090146595 5121297354163))") (string-eval "(assert-equal? (tn) 2 (quotient -13121090146595 -5121297354163))") (string-eval "(assert-error (tn) (lambda () (quotient 13121090146595 0)))") (string-eval "(assert-error (tn) (lambda () (quotient -13121090146595 0)))") (string-eval "(assert-equal? (tn) 0 (quotient 5121 13121090146595))") (string-eval "(assert-equal? (tn) 0 (quotient -5121 13121090146595))") (string-eval "(assert-equal? (tn) 0 (quotient 5121 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (quotient -5121 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (quotient 0 13121090146595))") (string-eval "(assert-equal? (tn) 0 (quotient 0 -13121090146595))"))) (tn "quotient boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 1 (quotient 134217727 134217727))") (string-eval "(assert-equal? (tn) 1 (quotient -134217728 -134217728))")) ((32) (string-eval "(assert-equal? (tn) 1 (quotient 2147483647 2147483647))") (string-eval "(assert-equal? (tn) 1 (quotient -2147483648 -2147483648))")) ((60) (string-eval "(assert-equal? (tn) 1 (quotient 576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) 1 (quotient -576460752303423488 -576460752303423488))")) ((64) (string-eval "(assert-equal? (tn) 1 (quotient 9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) 1 (quotient -9223372036854775808 -9223372036854775808))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "remainder invalid forms") (assert-error (tn) (lambda () (remainder))) (assert-error (tn) (lambda () (remainder #t))) (assert-error (tn) (lambda () (remainder #f))) (assert-error (tn) (lambda () (remainder '()))) (assert-error (tn) (lambda () (remainder #t #t))) (assert-error (tn) (lambda () (remainder #f #f))) (assert-error (tn) (lambda () (remainder '() '()))) (assert-error (tn) (lambda () (remainder 1))) (assert-error (tn) (lambda () (remainder 1 #t))) (assert-error (tn) (lambda () (remainder 1 #f))) (assert-error (tn) (lambda () (remainder 1 '()))) (assert-error (tn) (lambda () (remainder 1 2 #t))) (assert-error (tn) (lambda () (remainder 1 2 #f))) (assert-error (tn) (lambda () (remainder 1 2 '()))) (tn "remainder") (assert-equal? (tn) 0 (remainder -2 -2)) (assert-equal? (tn) 0 (remainder -2 -1)) (assert-error (tn) (lambda () (remainder -2 0))) (assert-equal? (tn) 0 (remainder -2 1)) (assert-equal? (tn) 0 (remainder -2 2)) (assert-equal? (tn) -1 (remainder -1 -2)) (assert-equal? (tn) 0 (remainder -1 -1)) (assert-error (tn) (lambda () (remainder -1 0))) (assert-equal? (tn) 0 (remainder -1 1)) (assert-equal? (tn) -1 (remainder -1 2)) (assert-equal? (tn) 0 (remainder 0 -2)) (assert-equal? (tn) 0 (remainder 0 -1)) (assert-error (tn) (lambda () (remainder 0 0))) (assert-equal? (tn) 0 (remainder 0 1)) (assert-equal? (tn) 0 (remainder 0 2)) (assert-equal? (tn) 1 (remainder 1 -2)) (assert-equal? (tn) 0 (remainder 1 -1)) (assert-error (tn) (lambda () (remainder 1 0))) (assert-equal? (tn) 0 (remainder 1 1)) (assert-equal? (tn) 1 (remainder 1 2)) (assert-equal? (tn) 0 (remainder 2 -2)) (assert-equal? (tn) 0 (remainder 2 -1)) (assert-error (tn) (lambda () (remainder 2 0))) (assert-equal? (tn) 0 (remainder 2 1)) (assert-equal? (tn) 0 (remainder 2 2)) (assert-equal? (tn) 2 (remainder 121 7)) (assert-equal? (tn) 2 (remainder 121 -7)) (assert-equal? (tn) -2 (remainder -121 7)) (assert-equal? (tn) -2 (remainder -121 -7)) (tn "remainder R5RS examples") (assert-equal? (tn) 1 (remainder 13 4)) (assert-equal? (tn) -1 (remainder -13 4)) (assert-equal? (tn) 1 (remainder 13 -4)) (assert-equal? (tn) -1 (remainder -13 -4)) (if (>= fixnum-bits 60) (begin (tn "remainder 64-bit") (string-eval "(assert-equal? (tn) 668 (remainder 13121090146595 5121))") (string-eval "(assert-equal? (tn) 668 (remainder 13121090146595 -5121))") (string-eval "(assert-equal? (tn) -668 (remainder -13121090146595 5121))") (string-eval "(assert-equal? (tn) -668 (remainder -13121090146595 -5121))") (string-eval "(assert-error (tn) (lambda () (remainder 13121090146595 0)))") (string-eval "(assert-error (tn) (lambda () (remainder -13121090146595 0)))") (string-eval "(assert-equal? (tn) 5121 (remainder 5121 13121090146595))") (string-eval "(assert-equal? (tn) -5121 (remainder -5121 13121090146595))") (string-eval "(assert-equal? (tn) 5121 (remainder 5121 -13121090146595))") (string-eval "(assert-equal? (tn) -5121 (remainder -5121 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (remainder 0 13121090146595))") (string-eval "(assert-equal? (tn) 0 (remainder 0 -13121090146595))"))) (tn "remainder boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 0 (remainder 134217727 134217727))") (string-eval "(assert-equal? (tn) 0 (remainder -134217728 -134217728))")) ((32) (string-eval "(assert-equal? (tn) 0 (remainder 2147483647 2147483647))") (string-eval "(assert-equal? (tn) 0 (remainder -2147483648 -2147483648))")) ((60) (string-eval "(assert-equal? (tn) 0 (remainder 576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) 0 (remainder -576460752303423488 -576460752303423488))")) ((64) (string-eval "(assert-equal? (tn) 0 (remainder 9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) 0 (remainder -9223372036854775808 -9223372036854775808))")) (else (assert-fail (tn) "unknown int bitwidth"))) (tn "modulo invalid forms") (assert-error (tn) (lambda () (modulo))) (assert-error (tn) (lambda () (modulo #t))) (assert-error (tn) (lambda () (modulo #f))) (assert-error (tn) (lambda () (modulo '()))) (assert-error (tn) (lambda () (modulo #t #t))) (assert-error (tn) (lambda () (modulo #f #f))) (assert-error (tn) (lambda () (modulo '() '()))) (assert-error (tn) (lambda () (modulo 1))) (assert-error (tn) (lambda () (modulo 1 #t))) (assert-error (tn) (lambda () (modulo 1 #f))) (assert-error (tn) (lambda () (modulo 1 '()))) (assert-error (tn) (lambda () (modulo 1 2 #t))) (assert-error (tn) (lambda () (modulo 1 2 #f))) (assert-error (tn) (lambda () (modulo 1 2 '()))) (tn "modulo") (assert-equal? (tn) 0 (modulo -2 -2)) (assert-equal? (tn) 0 (modulo -2 -1)) (assert-error (tn) (lambda () (modulo -2 0))) (assert-equal? (tn) 0 (modulo -2 1)) (assert-equal? (tn) 0 (modulo -2 2)) (assert-equal? (tn) -1 (modulo -1 -2)) (assert-equal? (tn) 0 (modulo -1 -1)) (assert-error (tn) (lambda () (modulo -1 0))) (assert-equal? (tn) 0 (modulo -1 1)) (assert-equal? (tn) 1 (modulo -1 2)) (assert-equal? (tn) 0 (modulo 0 -2)) (assert-equal? (tn) 0 (modulo 0 -1)) (assert-error (tn) (lambda () (modulo 0 0))) (assert-equal? (tn) 0 (modulo 0 1)) (assert-equal? (tn) 0 (modulo 0 2)) (assert-equal? (tn) -1 (modulo 1 -2)) (assert-equal? (tn) 0 (modulo 1 -1)) (assert-error (tn) (lambda () (modulo 1 0))) (assert-equal? (tn) 0 (modulo 1 1)) (assert-equal? (tn) 1 (modulo 1 2)) (assert-equal? (tn) 0 (modulo 2 -2)) (assert-equal? (tn) 0 (modulo 2 -1)) (assert-error (tn) (lambda () (modulo 2 0))) (assert-equal? (tn) 0 (modulo 2 1)) (assert-equal? (tn) 0 (modulo 2 2)) (assert-equal? (tn) 2 (modulo 121 7)) (assert-equal? (tn) -5 (modulo 121 -7)) (assert-equal? (tn) 5 (modulo -121 7)) (assert-equal? (tn) -2 (modulo -121 -7)) (tn "modulo R5RS examples") (assert-equal? (tn) 1 (modulo 13 4)) (assert-equal? (tn) 3 (modulo -13 4)) (assert-equal? (tn) -3 (modulo 13 -4)) (assert-equal? (tn) -1 (modulo -13 -4)) (if (>= fixnum-bits 60) (begin (tn "modulo 64-bit") (string-eval "(assert-equal? (tn) 668 (modulo 13121090146595 5121))") (string-eval "(assert-equal? (tn) -4453 (modulo 13121090146595 -5121))") (string-eval "(assert-equal? (tn) 4453 (modulo -13121090146595 5121))") (string-eval "(assert-equal? (tn) -668 (modulo -13121090146595 -5121))") (string-eval "(assert-error (tn) (lambda () (modulo 13121090146595 0)))") (string-eval "(assert-error (tn) (lambda () (modulo -13121090146595 0)))") (string-eval "(assert-equal? (tn) 5121 (modulo 5121 13121090146595))") (string-eval "(assert-equal? (tn) 13121090141474 (modulo -5121 13121090146595))") (string-eval "(assert-equal? (tn) -13121090141474 (modulo 5121 -13121090146595))") (string-eval "(assert-equal? (tn) -5121 (modulo -5121 -13121090146595))") (string-eval "(assert-equal? (tn) 0 (modulo 0 13121090146595))") (string-eval "(assert-equal? (tn) 0 (modulo 0 -13121090146595))"))) (tn "modulo boundary numbers") (case fixnum-bits ((28) (string-eval "(assert-equal? (tn) 0 (modulo 134217727 134217727))") (string-eval "(assert-equal? (tn) 0 (modulo -134217728 -134217728))")) ((32) (string-eval "(assert-equal? (tn) 0 (modulo 2147483647 2147483647))") (string-eval "(assert-equal? (tn) 0 (modulo -2147483648 -2147483648))")) ((60) (string-eval "(assert-equal? (tn) 0 (modulo 576460752303423487 576460752303423487))") (string-eval "(assert-equal? (tn) 0 (modulo -576460752303423488 -576460752303423488))")) ((64) (string-eval "(assert-equal? (tn) 0 (modulo 9223372036854775807 9223372036854775807))") (string-eval "(assert-equal? (tn) 0 (modulo -9223372036854775808 -9223372036854775808))")) (else (assert-fail (tn) "unknown int bitwidth"))) (total-report) uim-1.8.8/sigscheme/test/test-srfi9.scm0000644000175000017500000002535212532333147014720 00000000000000;; Filename : test-srfi9.scm ;; About : unit tests for SRFI-9 ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define orig-vector? vector?) (define orig-eval eval) (require-extension (unittest) (srfi 9)) (test-begin "SRFI-9 overridden R5RS procedures") (test-false (eq? vector? orig-vector?)) (cond-expand (sigscheme (test-true (eq? eval orig-eval))) (else (test-false (eq? eval orig-eval)))) (test-eq #t (vector? (vector))) (test-eq #f (vector? (list))) ;; Overridden 'eval' must be capable of (interaction-environment). (test-read-eval-string "(define foo 3)") ;; Original reference implementation of SRFI-9 lacks environment argument ;; handling. (test-error (eval '(+ 2 3))) (test-eqv 5 (eval '(+ 2 3) (interaction-environment))) ;; 'vector? must be evaluated to the redefined vector?. (test-eq vector? (eval 'vector? (interaction-environment))) (test-end) (test-begin "SRFI-9 invalid forms") ;; invalid definition placement (test-error (if #t (define-record-type my-rec (make-my-rec) my-rec?))) (test-error (test-read-eval-string "(if #t (define-record-type my-rec (make-my-rec) my-rec?))")) ;; invalid record names (test-error (define-record-type 'my-rec (make-my-rec) my-rec?)) (test-error (define-record-type "my-rec" (make-my-rec) my-rec?)) ;; invalid predicate names (test-error (define-record-type my-rec (make-my-rec) 'my-rec?)) (test-error (define-record-type my-rec (make-my-rec) "my-rec?")) ;; invalid constructor (test-error (define-record-type my-rec make-my-rec my-rec?)) (test-error (define-record-type my-rec '(make-my-rec) my-rec?)) (test-error (define-record-type my-rec (list make-my-rec) my-rec?)) (test-error (define-record-type my-rec (list 'make-my-rec) my-rec?)) (test-error (define-record-type my-rec #(make-my-rec) my-rec?)) (test-error (define-record-type my-rec '#(make-my-rec) my-rec?)) ;; non-existent field name in constructor (test-error (define-record-type my-rec (make-my-rec x) my-rec?)) ;; without accessor (test-error (define-record-type my-rec (make-my-rec x) my-rec? (x))) (test-end) (test-begin "SRFI-9 no-field record") (test-false (symbol-bound? 'make-my-null)) (test-false (symbol-bound? 'my-null?)) (test-eq (undef) (define-record-type my-null (make-my-null) my-null?)) (test-true (procedure? make-my-null)) (test-true (procedure? my-null?)) (test-error (make-my-null 0)) (test-eq #t (record? (make-my-null))) (test-true (not (vector? (make-my-null)))) (test-eq #t (my-null? (make-my-null))) (test-false (my-null? (vector))) (test-end) (test-begin "SRFI-9 2-field record") (define x (list 'x)) (define y (list 'y)) (define z (list 'z)) (test-false (symbol-bound? 'make-my-pair)) (test-false (symbol-bound? 'my-pair?)) (test-false (symbol-bound? 'my-pair-kar)) (test-false (symbol-bound? 'my-pair-kdr)) (test-false (symbol-bound? 'my-pair-set-kar!)) (test-false (symbol-bound? 'my-pair-set-kdr!)) (test-eq (undef) (define-record-type my-pair (make-my-pair kar kdr) my-pair? (kar my-pair-kar my-pair-set-kar!) (kdr my-pair-kdr my-pair-set-kdr!))) (test-true (procedure? make-my-pair)) (test-true (procedure? my-pair?)) (test-true (procedure? my-pair-kar)) (test-true (procedure? my-pair-kdr)) (test-true (procedure? my-pair-set-kar!)) (test-true (procedure? my-pair-set-kdr!)) (test-error (make-my-pair)) (test-error (make-my-pair x)) (test-error (make-my-pair x y z)) (test-eq #t (record? (make-my-pair x y))) (test-true (not (vector? (make-my-pair x y)))) (test-eq #t (my-pair? (make-my-pair x y))) (test-false (my-pair? (vector x y))) (test-false (my-pair? (make-my-null))) (test-eq x (my-pair-kar (make-my-pair x y))) (test-eq y (my-pair-kdr (make-my-pair x y))) (define foo (make-my-pair x y)) (test-eq x (my-pair-kar foo)) (test-eq y (my-pair-kdr foo)) (test-eq (undef) (my-pair-set-kar! foo z)) (test-eq z (my-pair-kar foo)) (test-eq y (my-pair-kdr foo)) (test-eq (undef) (my-pair-set-kdr! foo x)) (test-eq z (my-pair-kar foo)) (test-eq x (my-pair-kdr foo)) (test-end) (test-begin "SRFI-9 2-field record with swapped constructor tags") (define x (list 'x)) (define y (list 'y)) (define z (list 'z)) (test-false (symbol-bound? 'make-my-pair2)) (test-false (symbol-bound? 'my-pair2?)) (test-false (symbol-bound? 'my-pair2-kar)) (test-false (symbol-bound? 'my-pair2-kdr)) (test-false (symbol-bound? 'my-pair2-set-kar!)) (test-false (symbol-bound? 'my-pair2-set-kdr!)) (test-eq (undef) (define-record-type my-pair2 (make-my-pair2 kdr kar) my-pair2? (kar my-pair2-kar my-pair2-set-kar!) (kdr my-pair2-kdr my-pair2-set-kdr!))) (test-true (procedure? make-my-pair2)) (test-true (procedure? my-pair2?)) (test-true (procedure? my-pair2-kar)) (test-true (procedure? my-pair2-kdr)) (test-true (procedure? my-pair2-set-kar!)) (test-true (procedure? my-pair2-set-kdr!)) (test-error (make-my-pair2)) (test-error (make-my-pair2 x)) (test-error (make-my-pair2 x y z)) (test-eq #t (record? (make-my-pair2 x y))) (test-true (not (vector? (make-my-pair2 x y)))) (test-eq #t (my-pair2? (make-my-pair2 x y))) (test-false (my-pair2? (vector x y))) (test-eq y (my-pair2-kar (make-my-pair2 x y))) (test-eq x (my-pair2-kdr (make-my-pair2 x y))) (define foo (make-my-pair2 x y)) (test-eq y (my-pair2-kar foo)) (test-eq x (my-pair2-kdr foo)) (test-eq (undef) (my-pair2-set-kar! foo z)) (test-eq z (my-pair2-kar foo)) (test-eq x (my-pair2-kdr foo)) (test-eq (undef) (my-pair2-set-kdr! foo y)) (test-eq z (my-pair2-kar foo)) (test-eq y (my-pair2-kdr foo)) (test-end) (test-begin "SRFI-9 2-field record with partial constructor tags") (define x (list 'x)) (define y (list 'y)) (define z (list 'z)) (test-false (symbol-bound? 'make-my-pair3)) (test-false (symbol-bound? 'my-pair3?)) (test-false (symbol-bound? 'my-pair3-kar)) (test-false (symbol-bound? 'my-pair3-kdr)) (test-false (symbol-bound? 'my-pair3-set-kar!)) (test-false (symbol-bound? 'my-pair3-set-kdr!)) (test-eq (undef) (define-record-type my-pair3 (make-my-pair3 kdr) my-pair3? (kar my-pair3-kar my-pair3-set-kar!) (kdr my-pair3-kdr my-pair3-set-kdr!))) (test-true (procedure? make-my-pair3)) (test-true (procedure? my-pair3?)) (test-true (procedure? my-pair3-kar)) (test-true (procedure? my-pair3-kdr)) (test-true (procedure? my-pair3-set-kar!)) (test-true (procedure? my-pair3-set-kdr!)) (test-error (make-my-pair3)) (test-error (make-my-pair3 x y)) (test-error (make-my-pair3 x y z)) (test-eq #t (record? (make-my-pair3 x))) (test-true (not (vector? (make-my-pair3 x)))) (test-eq #t (my-pair3? (make-my-pair3 x))) (test-false (my-pair3? (vector x y))) (test-false (my-pair3? (make-my-null))) (test-eq (undef) (my-pair3-kar (make-my-pair3 x))) (test-eq x (my-pair3-kdr (make-my-pair3 x))) (define foo (make-my-pair3 x)) (test-eq (undef) (my-pair3-kar foo)) (test-eq x (my-pair3-kdr foo)) (test-eq (undef) (my-pair3-set-kar! foo z)) (test-eq z (my-pair3-kar foo)) (test-eq x (my-pair3-kdr foo)) (test-eq (undef) (my-pair3-set-kdr! foo y)) (test-eq z (my-pair3-kar foo)) (test-eq y (my-pair3-kdr foo)) (test-end) (test-begin "SRFI-9 2-field record without constructor tags") (define x (list 'x)) (define y (list 'y)) (define z (list 'z)) (test-false (symbol-bound? 'make-my-pair4)) (test-false (symbol-bound? 'my-pair4?)) (test-false (symbol-bound? 'my-pair4-kar)) (test-false (symbol-bound? 'my-pair4-kdr)) (test-false (symbol-bound? 'my-pair4-set-kar!)) (test-false (symbol-bound? 'my-pair4-set-kdr!)) (test-eq (undef) (define-record-type my-pair4 (make-my-pair4) my-pair4? (kar my-pair4-kar my-pair4-set-kar!) (kdr my-pair4-kdr my-pair4-set-kdr!))) (test-true (procedure? make-my-pair4)) (test-true (procedure? my-pair4?)) (test-true (procedure? my-pair4-kar)) (test-true (procedure? my-pair4-kdr)) (test-true (procedure? my-pair4-set-kar!)) (test-true (procedure? my-pair4-set-kdr!)) (test-error (make-my-pair4 x)) (test-error (make-my-pair4 x y)) (test-error (make-my-pair4 x y z)) (test-eq #t (record? (make-my-pair4))) (test-true (not (vector? (make-my-pair4)))) (test-eq #t (my-pair4? (make-my-pair4))) (test-false (my-pair4? (vector x y))) (test-eq (undef) (my-pair4-kar (make-my-pair4))) (test-eq (undef) (my-pair4-kdr (make-my-pair4))) (define foo (make-my-pair4)) (test-eq (undef) (my-pair4-kar foo)) (test-eq (undef) (my-pair4-kdr foo)) (test-eq (undef) (my-pair4-set-kar! foo z)) (test-eq z (my-pair4-kar foo)) (test-eq (undef) (my-pair4-kdr foo)) (test-eq (undef) (my-pair4-set-kdr! foo x)) (test-eq z (my-pair4-kar foo)) (test-eq x (my-pair4-kdr foo)) (test-end) (test-begin "SRFI-9 2-field record without modifiers") (test-false (symbol-bound? 'make-my-pair5)) (test-false (symbol-bound? 'my-pair5?)) (test-false (symbol-bound? 'my-pair5-kar)) (test-false (symbol-bound? 'my-pair5-kdr)) (test-eq (undef) (define-record-type my-pair5 (make-my-pair5 kar kdr) my-pair5? (kar my-pair5-kar) (kdr my-pair5-kdr))) (test-true (procedure? make-my-pair5)) (test-true (procedure? my-pair5?)) (test-true (procedure? my-pair5-kar)) (test-true (procedure? my-pair5-kdr)) (test-end) (test-report-result) uim-1.8.8/sigscheme/test/test-let.scm0000644000175000017500000007764412532333147014463 00000000000000;; Filename : test-let.scm ;; About : unit test for R5RS let ;; ;; Copyright (C) 2005-2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define *test-track-progress* #f) (define tn test-name) ;; ;; let ;; (tn "let invalid form") ;; bindings and body required (assert-error (tn) (lambda () (let))) (assert-error (tn) (lambda () (let ()))) (assert-error (tn) (lambda () (let ((a))))) (assert-error (tn) (lambda () (let ((a 1))))) (assert-error (tn) (lambda () (let (a 1)))) (assert-error (tn) (lambda () (let a))) (assert-error (tn) (lambda () (let #()))) (assert-error (tn) (lambda () (let #f))) (assert-error (tn) (lambda () (let #t))) ;; bindings must be a list (assert-error (tn) (lambda () (let a 'val))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let #f 'val)) (assert-error (tn) (lambda () (let #f 'val)))) (assert-error (tn) (lambda () (let #() 'val))) (assert-error (tn) (lambda () (let #t 'val))) ;; each binding must be a 2-elem list (assert-error (tn) (lambda () (let (a 1) 'val))) (if (provided? "siod-bugs") (assert-equal? (tn) 'val (let ((a)) 'val)) (assert-error (tn) (lambda () (let ((a)) 'val)))) (assert-error (tn) (lambda () (let ((a 1 'excessive)) 'val))) (assert-error (tn) (lambda () (let ((a 1) . (b 2)) 'val))) (assert-error (tn) (lambda () (let ((a . 1)) 'val))) (assert-error (tn) (lambda () (let ((a 1)) . a))) (assert-error (tn) (lambda () (let ((a 1)) 'val . a))) (assert-error (tn) (lambda () (let (1) #t))) (tn "let binding syntactic keyword") (assert-equal? (tn) 1 (let ((else 1)) else)) (assert-equal? (tn) 2 (let ((=> 2)) =>)) (assert-equal? (tn) 3 (let ((unquote 3)) unquote)) (assert-error (tn) (lambda () else)) (assert-error (tn) (lambda () =>)) (assert-error (tn) (lambda () unquote)) (tn "let env isolation") (assert-error (tn) (lambda () (let ((var1 1) (var2 var1)) 'result))) (assert-error (tn) (lambda () (let ((var1 var2) (var2 2)) 'result))) (assert-error (tn) (lambda () (let ((var1 var2) (var2 var1)) 'result))) (assert-equal? (tn) '(#f #f #f) (let ((var1 (symbol-bound? 'var1)) (var2 (symbol-bound? 'var1)) (var3 (symbol-bound? 'var1))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let ((var1 (symbol-bound? 'var2)) (var2 (symbol-bound? 'var2)) (var3 (symbol-bound? 'var2))) (list var1 var2 var3))) (assert-equal? (tn) '(#f #f #f) (let ((var1 (symbol-bound? 'var3)) (var2 (symbol-bound? 'var3)) (var3 (symbol-bound? 'var3))) (list var1 var2 var3))) (tn "let internal definitions lacking sequence part") ;; at least one is required (assert-error (tn) (lambda () (let () (define var1 1)))) (assert-error (tn) (lambda () (let () (define (proc1) 1)))) (assert-error (tn) (lambda () (let () (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let () (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let () (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let () (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let () (begin)))) (assert-error (tn) (lambda () (let () (begin (define var1 1))))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define var2 2))))) ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let () (begin (define var1 1) 'val)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) 'val)))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define var2 2) 'val)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define (proc2) 2) 'val)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define var2 2) 'val)))) (tn "let internal definitions cross reference") ;; R5RS: 5.2.2 Internal definitions ;; Just as for the equivalent `letrec' expression, it must be possible to ;; evaluate each of every internal definition in a without ;; assigning or referring to the value of any being defined. (assert-error (tn) (lambda () (let () (define var1 1) (define var2 var1) 'val))) (assert-error (tn) (lambda () (let () (define var1 var2) (define var2 2) 'val))) (assert-error (tn) (lambda () (let () (define var1 var1) 'val))) (assert-equal? (tn) '(0 0 0 0 0) (let ((var0 0)) (define var1 var0) (define var2 var0) (begin (define var3 var0) (begin (define var4 var0))) (define var5 var0) (list var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let ((var0 (symbol-bound? 'var1))) (define var1 (symbol-bound? 'var1)) (define var2 (symbol-bound? 'var1)) (begin (define var3 (symbol-bound? 'var1)) (begin (define var4 (symbol-bound? 'var1)))) (define var5 (symbol-bound? 'var1)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let ((var0 (symbol-bound? 'var2))) (define var1 (symbol-bound? 'var2)) (define var2 (symbol-bound? 'var2)) (begin (define var3 (symbol-bound? 'var2)) (begin (define var4 (symbol-bound? 'var2)))) (define var5 (symbol-bound? 'var2)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let ((var0 (symbol-bound? 'var3))) (define var1 (symbol-bound? 'var3)) (define var2 (symbol-bound? 'var3)) (begin (define var3 (symbol-bound? 'var3)) (begin (define var4 (symbol-bound? 'var3)))) (define var5 (symbol-bound? 'var3)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let ((var0 (symbol-bound? 'var4))) (define var1 (symbol-bound? 'var4)) (define var2 (symbol-bound? 'var4)) (begin (define var3 (symbol-bound? 'var4)) (begin (define var4 (symbol-bound? 'var4)))) (define var5 (symbol-bound? 'var4)) (list var0 var1 var2 var3 var4 var5))) (assert-equal? (tn) '(#f #f #f #f #f #f) (let ((var0 (symbol-bound? 'var5))) (define var1 (symbol-bound? 'var5)) (define var2 (symbol-bound? 'var5)) (begin (define var3 (symbol-bound? 'var5)) (begin (define var4 (symbol-bound? 'var5)))) (define var5 (symbol-bound? 'var5)) (list var0 var1 var2 var3 var4 var5))) ;; outer let cannot refer internal variable (assert-error (tn) (lambda () (let ((var0 (lambda () var1))) (define var1 (lambda () 1)) (eq? (var0) var0)))) ;; defining procedure can refer other (and self) variables as if letrec (assert-equal? (tn) '(#t #t #t #t #t) (let ((var0 (lambda () 0))) (define var1 (lambda () var0)) (define var2 (lambda () var0)) (begin (define var3 (lambda () var0)) (begin (define var4 (lambda () var0)))) (define var5 (lambda () var0)) (list (eq? (var1) var0) (eq? (var2) var0) (eq? (var3) var0) (eq? (var4) var0) (eq? (var5) var0)))) (assert-equal? (tn) '(#t #t #t #t #t) (let () (define var1 (lambda () var1)) (define var2 (lambda () var1)) (begin (define var3 (lambda () var1)) (begin (define var4 (lambda () var1)))) (define var5 (lambda () var1)) (list (eq? (var1) var1) (eq? (var2) var1) (eq? (var3) var1) (eq? (var4) var1) (eq? (var5) var1)))) (assert-equal? (tn) '(#t #t #t #t #t) (let () (define var1 (lambda () var2)) (define var2 (lambda () var2)) (begin (define var3 (lambda () var2)) (begin (define var4 (lambda () var2)))) (define var5 (lambda () var2)) (list (eq? (var1) var2) (eq? (var2) var2) (eq? (var3) var2) (eq? (var4) var2) (eq? (var5) var2)))) (assert-equal? (tn) '(#t #t #t #t #t) (let () (define var1 (lambda () var3)) (define var2 (lambda () var3)) (begin (define var3 (lambda () var3)) (begin (define var4 (lambda () var3)))) (define var5 (lambda () var3)) (list (eq? (var1) var3) (eq? (var2) var3) (eq? (var3) var3) (eq? (var4) var3) (eq? (var5) var3)))) (assert-equal? (tn) '(#t #t #t #t #t) (let () (define var1 (lambda () var4)) (define var2 (lambda () var4)) (begin (define var3 (lambda () var4)) (begin (define var4 (lambda () var4)))) (define var5 (lambda () var4)) (list (eq? (var1) var4) (eq? (var2) var4) (eq? (var3) var4) (eq? (var4) var4) (eq? (var5) var4)))) (assert-equal? (tn) '(#t #t #t #t #t) (let () (define var1 (lambda () var5)) (define var2 (lambda () var5)) (begin (define var3 (lambda () var5)) (begin (define var4 (lambda () var5)))) (define var5 (lambda () var5)) (list (eq? (var1) var5) (eq? (var2) var5) (eq? (var3) var5) (eq? (var4) var5) (eq? (var5) var5)))) (tn "let internal definitions valid forms") ;; valid internal definitions (assert-equal? (tn) '(1) (let () (define var1 1) (list var1))) (assert-equal? (tn) '(1) (let () (define (proc1) 1) (list (proc1)))) (assert-equal? (tn) '(1 2) (let () (define var1 1) (define var2 2) (list var1 var2))) (assert-equal? (tn) '(1 2) (let () (define (proc1) 1) (define (proc2) 2) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let () (define var1 1) (define (proc2) 2) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let () (define (proc1) 1) (define var2 2) (list (proc1) var2))) ;; SigScheme accepts '(begin)' as valid internal definition '(begin ;; *)' as defined in "7.1.6 Programs and definitions" of R5RS ;; although it is rejected as expression '(begin )' as defined in ;; "7.1.3 Expressions". (assert-equal? (tn) 1 (let () (begin) 1)) (assert-equal? (tn) 1 (let () (begin) (define var1 1) (begin) 1)) (assert-equal? (tn) '(1) (let () (begin (define var1 1)) (list var1))) (assert-equal? (tn) '(1) (let () (begin (define (proc1) 1)) (list (proc1)))) (assert-equal? (tn) '(1 2) (let () (begin (define var1 1) (define var2 2)) (list var1 var2))) (assert-equal? (tn) '(1 2) (let () (begin (define (proc1) 1) (define (proc2) 2)) (list (proc1) (proc2)))) (assert-equal? (tn) '(1 2) (let () (begin (define var1 1) (define (proc2) 2)) (list var1 (proc2)))) (assert-equal? (tn) '(1 2) (let () (begin (define (proc1) 1) (define var2 2)) (list (proc1) var2))) (assert-equal? (tn) '(1 2 3 4 5 6) (let () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6))) ;; begin block and single definition mixed (assert-equal? (tn) '(1 2 3 4 5 6) (let () (begin) (define (proc1) 1) (begin (define var2 2) (begin (define (proc3) 3) (begin) (define var4 4))) (begin) (define (proc5) 5) (begin (begin (begin (begin))) (define var6 6) (begin)) (begin) (list (proc1) var2 (proc3) var4 (proc5) var6))) (tn "let internal definitions invalid begin blocks") ;; appending a non-definition expression into a begin block is invalid (assert-error (tn) (lambda () (let () (begin (define var1 1) 'val) (list var1)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) 'val) (list (proc1))))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define var2 2) 'val) (list var1 var2)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define (proc2) 2) 'val) (list (proc1) (proc2))))) (assert-error (tn) (lambda () (let () (begin (define var1 1) (define (proc2) 2) 'val) (list var1 (proc2))))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define var2 2) 'val) (list (proc1) var2)))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6) 'val))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "let internal definitions invalid placement") ;; a non-definition expression prior to internal definition is invalid (assert-error (tn) (lambda () (let () 'val (define var1 1)))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1)))) (assert-error (tn) (lambda () (let () 'val (define var1 1) (define var2 2)))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let () 'val (define var1 1) (define (proc2) 2)))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1) (define var2 2)))) (assert-error (tn) (lambda () (let () 'val (begin)))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1))))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1))))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1) (define var2 2))))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1) (define (proc2) 2))))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define var2 2))))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) (assert-error (tn) (lambda () (let () (begin (define (proc1) 1) (define var2 2) 'val (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6))))))) ;; a non-definition expression prior to internal definition is invalid even if ;; expression(s) is following the internal definition (assert-error (tn) (lambda () (let () 'val (define var1 1) 'val))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1) 'val))) (assert-error (tn) (lambda () (let () 'val (define var1 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let () 'val (define var1 1) (define (proc2) 2) 'val))) (assert-error (tn) (lambda () (let () 'val (define (proc1) 1) (define var2 2) 'val))) (assert-error (tn) (lambda () (let () 'val (begin) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define var1 1) (define (proc2) 2)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define var2 2)) 'val))) (assert-error (tn) (lambda () (let () 'val (begin (define (proc1) 1) (define var2 2) (begin (define (proc3) 3) (define var4 4) (begin (define (proc5) 5) (define var6 6)))) (list (proc1) var2 (proc3) var4 (proc5) var6)))) (tn "let binding syntactic keywords") (assert-error (tn) (lambda () (let ((syn define)) #t))) (assert-error (tn) (lambda () (let ((syn if)) #t))) (assert-error (tn) (lambda () (let ((syn and)) #t))) (assert-error (tn) (lambda () (let ((syn cond)) #t))) (assert-error (tn) (lambda () (let ((syn begin)) #t))) (assert-error (tn) (lambda () (let ((syn do)) #t))) (assert-error (tn) (lambda () (let ((syn delay)) #t))) (assert-error (tn) (lambda () (let ((syn let*)) #t))) (assert-error (tn) (lambda () (let ((syn else)) #t))) (assert-error (tn) (lambda () (let ((syn =>)) #t))) (assert-error (tn) (lambda () (let ((syn quote)) #t))) (assert-error (tn) (lambda () (let ((syn quasiquote)) #t))) (assert-error (tn) (lambda () (let ((syn unquote)) #t))) (assert-error (tn) (lambda () (let ((syn unquote-splicing)) #t))) (tn "let") ;; empty bindings is allowed by the formal syntax spec (assert-equal? (tn) 'result (let () 'result)) ;; duplicate variable name (assert-error (tn) (lambda () (let ((var1 1) (var1 2)) 'result))) ;; masked variable name (assert-equal? (tn) '(4 5 3) (let ((var1 1) (var2 2) (var3 3)) (let ((var1 4) (var2 5)) (list var1 var2 var3)))) (assert-equal? (tn) '(1 2 3) (let ((var1 1) (var2 2) (var3 3)) (let ((var1 4) (var2 5)) 'dummy) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 9) (let ((var1 1) (var2 2) (var3 3)) (let ((var1 4) (var2 5)) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 30) (let ((var1 1) (var2 2) (var3 3)) (let ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (set! var3 (+ var1 var2))) (list var1 var2 var3))) (assert-equal? (tn) '(1 2 3 (10 20)) (let ((var1 1) (var2 2) (var3 3) (var4 (let ((var1 4) (var2 5)) (set! var1 10) (set! var2 20) (list var1 var2)))) (list var1 var2 var3 var4))) (assert-error (tn) (lambda () (let ((var1 1) (var2 2) (var3 3) (var4 (let ((var1 4) (var2 5)) (set! var3 10)))) (list var1 var2 var3 var4)))) ;; normal case(s) (assert-equal? (tn) 12 (let ((var1 5) (var2 3)) (set! var1 (+ var2 1)) (* var1 var2))) ;; evaled value (assert-equal? (tn) '(3 7) (let ((var1 (+ 1 2)) (var2 (+ 3 4))) (list var1 var2))) (tn "let lexical scope") (define count-let (let ((count-let 0)) ;; intentionally same name (lambda () (set! count-let (+ count-let 1)) count-let))) (assert-true (tn) (procedure? count-let)) (assert-equal? (tn) 1 (count-let)) (assert-equal? (tn) 2 (count-let)) (assert-equal? (tn) 3 (count-let)) (total-report) uim-1.8.8/sigscheme/test/test-assoc.scm0000644000175000017500000005046612532333147015000 00000000000000;; Filename : test-assoc.scm ;; About : unit tests for assq, assv, assoc ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) (define elm0 (lambda () 0)) (define elm1 (lambda () 1)) (define elm2 (lambda () 2)) (define elm3 (lambda () 3)) (define nil '()) (define cdr3 (cons (cons elm3 3) nil)) (define cdr2 (cons (cons elm2 2) cdr3)) (define cdr1 (cons (cons elm1 1) cdr2)) (define cdr0 (cons (cons elm0 0) cdr1)) (define alist cdr0) ;; Remake char object to avoid constant optimization. If the implementation ;; does not have neither immediate char nor preallocated char objects, (eq? c ;; (char c)) will be false. (define char (lambda (c) (integer->char (char->integer c)))) ;; ;; assq ;; (tn "assq symbols") (assert-error (tn) (lambda () (assq 'a '(a)))) (assert-error (tn) (lambda () (assq 'a '((A . 0) a)))) (assert-false (tn) (assq 'a '())) (assert-equal? (tn) '(a . 0) (assq 'a '((a . 0)))) (assert-false (tn) (assq 'b '((a . 0)))) (assert-equal? (tn) '(A . 0) (assq 'A '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(a . 1) (assq 'a '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(b . 2) (assq 'b '((A . 0) (a . 1) (b . 2)))) (assert-false (tn) (assq 'c '((A . 0) (a . 1) (b . 2)))) (tn "assq builtin procedures") (assert-false (tn) (assq + (list))) (assert-equal? (tn) (cons + 0) (assq + (list (cons + 0)))) (assert-false (tn) (assq - (list (cons + 0)))) (assert-equal? (tn) (cons + 0) (assq + (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons - 1) (assq - (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons * 2) (assq * (list (cons + 0) (cons - 1) (cons * 2)))) (assert-false (tn) (assq / (list (cons + 0) (cons - 1) (cons * 2)))) (tn "assq closures") (assert-equal? (tn) (car cdr3) (assq elm3 alist)) (assert-equal? (tn) (car cdr2) (assq elm2 alist)) (assert-equal? (tn) (car cdr1) (assq elm1 alist)) (assert-equal? (tn) (car cdr0) (assq elm0 alist)) (assert-false (tn) (assq (lambda() #f) alist)) (tn "assq strings with non-constant key") ;; These tests assume that (string #\a) is not optimized as constant string. (assert-false (tn) (assq (string #\a) '())) (assert-false (tn) (assq (string #\a) '(("a" . a)))) (assert-false (tn) (assq (string #\b) '(("a" . a)))) (assert-false (tn) (assq (string #\a) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assq (string #\b) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assq (string #\c) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assq (string #\d) '(("a" . a) ("b" . b) ("c" . c)))) (tn "assq lists with non-constant key") ;; These tests assume that the keys are not optimized as constant object. (assert-false (tn) (assq (list (string #\a)) '())) (assert-false (tn) (assq (list (string #\a)) '((("a") . a)))) (assert-false (tn) (assq (list (string #\b)) '((("a") . a)))) (assert-false (tn) (assq (list (string #\a)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assq (list (string #\b)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assq (list (string #\c)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assq (list (string #\d)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assq (list (string #\a #\B #\c) (list (string #\d) (list (string #\e)))) '((("aBc" ("d" ("E"))) 0) (("aBc" ("d" ("e"))) 1) ("f") ("g")))) (tn "assq improper lists: symbols") (assert-error (tn) (lambda () (assq 'a 'a))) (assert-equal? (tn) '(a . 1) (assq 'a '((A . 0) (a . 1) (b . 2) . 3))) (assert-error (tn) (lambda () (assq 'c '((A . 0) (a . 1) (b . 2) . 3)))) (tn "assq improper lists: builtin procedures") (assert-error (tn) (lambda () (assq '+ '+))) (assert-equal? (tn) '(- . 1) (assq '- '((+ . 0) (- . 1) (* . 2) . 3))) (assert-error (tn) (lambda () (assq '/ '((+ . 0) (- . 1) (* . 2) . 3)))) (tn "assq improper lists: strings") (assert-error (tn) (lambda () (assq (string #\b) '(("a" . 0) ("b" . 1) ("c" . 2) . 3)))) (tn "assq improper lists: lists") (assert-error (tn) (lambda () (assq (list (string #\b)) '((("a") . 0) (("b") . 1) (("c") . 2) . 3)))) (tn "assq from R5RS examples") (define e '((a 1) (b 2) (c 3))) (assert-equal? (tn) '(a 1) (assq 'a e)) (assert-equal? (tn) '(b 2) (assq 'b e)) (assert-false (tn) (assq 'd e)) (assert-false (tn) (assq (list 'a) '(((a)) ((b)) ((c))))) ;; ;; assv ;; (tn "assv symbols") (assert-error (tn) (lambda () (assv 'a '(a)))) (assert-error (tn) (lambda () (assv 'a '((A . 0) a)))) (assert-false (tn) (assv 'a '())) (assert-equal? (tn) '(a . 0) (assv 'a '((a . 0)))) (assert-false (tn) (assv 'b '((a . 0)))) (assert-equal? (tn) '(A . 0) (assv 'A '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(a . 1) (assv 'a '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(b . 2) (assv 'b '((A . 0) (a . 1) (b . 2)))) (assert-false (tn) (assv 'c '((A . 0) (a . 1) (b . 2)))) (tn "assv builtin procedures") (assert-false (tn) (assv + (list))) (assert-equal? (tn) (cons + 0) (assv + (list (cons + 0)))) (assert-false (tn) (assv - (list (cons + 0)))) (assert-equal? (tn) (cons + 0) (assv + (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons - 1) (assv - (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons * 2) (assv * (list (cons + 0) (cons - 1) (cons * 2)))) (assert-false (tn) (assv / (list (cons + 0) (cons - 1) (cons * 2)))) (tn "assv closures") (assert-equal? (tn) (car cdr3) (assv elm3 alist)) (assert-equal? (tn) (car cdr2) (assv elm2 alist)) (assert-equal? (tn) (car cdr1) (assv elm1 alist)) (assert-equal? (tn) (car cdr0) (assv elm0 alist)) (assert-false (tn) (assv (lambda() #f) alist)) (tn "assv numbers") (assert-false (tn) (assv 0 '())) (assert-equal? (tn) '(0 . a) (assv 0 '((0 . a)))) (assert-false (tn) (assv 1 '((0 . a)))) (assert-equal? (tn) '(0 . a) (assv 0 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(1 . b) (assv 1 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(2 . c) (assv 2 '((0 . a) (1 . b) (2 . c)))) (assert-false (tn) (assv 3 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) ;; R5RS (tn "assv chars") (assert-false (tn) (assv #\a '())) (assert-equal? (tn) '(#\a . a) (assv #\a '((#\a . a)))) (assert-false (tn) (assv #\b '((#\a . a)))) (assert-equal? (tn) '(#\a . a) (assv #\a '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\b . b) (assv #\b '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\c . c) (assv #\c '((#\a . a) (#\b . b) (#\c . c)))) (assert-false (tn) (assv #\d '((#\a . a) (#\b . b) (#\c . c)))) (tn "assv chars with non-constant key") (assert-false (tn) (assv (char #\a) '())) (assert-equal? (tn) '(#\a . a) (assv (char #\a) '((#\a . a)))) (assert-false (tn) (assv (char #\b) '((#\a . a)))) (assert-equal? (tn) '(#\a . a) (assv (char #\a) '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\b . b) (assv (char #\b) '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\c . c) (assv (char #\c) '((#\a . a) (#\b . b) (#\c . c)))) (assert-false (tn) (assv (char #\d) '((#\a . a) (#\b . b) (#\c . c)))) (tn "assv strings with non-constant key") ;; These tests assume that (string #\a) is not optimized as constant string. (assert-false (tn) (assv (string #\a) '())) (assert-false (tn) (assv (string #\a) '(("a" . a)))) (assert-false (tn) (assv (string #\b) '(("a" . a)))) (assert-false (tn) (assv (string #\a) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assv (string #\b) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assv (string #\c) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assv (string #\d) '(("a" . a) ("b" . b) ("c" . c)))) (tn "assv lists with non-constant key") ;; These tests assume that the keys are not optimized as constant object. (assert-false (tn) (assv (list (string #\a)) '())) (assert-false (tn) (assv (list (string #\a)) '((("a") . a)))) (assert-false (tn) (assv (list (string #\b)) '((("a") . a)))) (assert-false (tn) (assv (list (string #\a)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assv (list (string #\b)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assv (list (string #\c)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assv (list (string #\d)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assv (list (string #\a #\B #\c) (list (string #\d) (list (string #\e)))) '((("aBc" ("d" ("E"))) 0) (("aBc" ("d" ("e"))) 1) ("f") ("g")))) (tn "assv improper lists: symbols") (assert-error (tn) (lambda () (assv 'a 'a))) (assert-equal? (tn) '(a . 1) (assv 'a '((A . 0) (a . 1) (b . 2) . 3))) (assert-error (tn) (lambda () (assv 'c '((A . 0) (a . 1) (b . 2) . 3)))) (tn "assv improper lists: builtin procedures") (assert-error (tn) (lambda () (assv '+ '+))) (assert-equal? (tn) '(- . 1) (assv '- '((+ . 0) (- . 1) (* . 2) . 3))) (assert-error (tn) (lambda () (assv '/ '((+ . 0) (- . 1) (* . 2) . 3)))) (tn "assv improper lists: numbers") (assert-error (tn) (lambda () (assv 0 '0))) (assert-equal? (tn) '(1 . b) (assv 1 '((0 . a) (1 . b) (3 . c) . d))) (assert-error (tn) (lambda () (assv 4 '((0 . a) (1 . b) (3 . c) . d)))) (tn "assv improper lists: chars") (assert-error (tn) (lambda () (assv #\a #\a))) (assert-equal? (tn) '(#\b . 1) (assv #\b '((#\a . 0) (#\b . 1) (#\c . 2) . 3))) (assert-equal? (tn) '(#\b . 1) (assv (char #\b) '((#\a . 0) (#\b . 1) (#\c . 2) . 3))) (assert-error (tn) (lambda () (assv #\d '((#\a . 0) (#\b . 1) (#\c . 2) . 3)))) (tn "assv improper lists: strings") (assert-error (tn) (lambda () (assv (string #\b) '(("a" . 0) ("b" . 1) ("c" . 2) . 3)))) (tn "assv improper lists: lists") (assert-error (tn) (lambda () (assv (list (string #\b)) '((("a") . 0) (("b") . 1) (("c") . 2) . 3)))) ;; ;; assoc ;; (tn "assoc symbols") (assert-error (tn) (lambda () (assoc 'a '(a)))) (assert-error (tn) (lambda () (assoc 'a '((A . 0) a)))) (assert-false (tn) (assoc 'a '())) (assert-equal? (tn) '(a . 0) (assoc 'a '((a . 0)))) (assert-false (tn) (assoc 'b '((a . 0)))) (assert-equal? (tn) '(A . 0) (assoc 'A '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(a . 1) (assoc 'a '((A . 0) (a . 1) (b . 2)))) (assert-equal? (tn) '(b . 2) (assoc 'b '((A . 0) (a . 1) (b . 2)))) (assert-false (tn) (assoc 'c '((A . 0) (a . 1) (b . 2)))) (tn "assoc builtin procedures") (assert-false (tn) (assoc + (list))) (assert-equal? (tn) (cons + 0) (assoc + (list (cons + 0)))) (assert-false (tn) (assoc - (list (cons + 0)))) (assert-equal? (tn) (cons + 0) (assoc + (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons - 1) (assoc - (list (cons + 0) (cons - 1) (cons * 2)))) (assert-equal? (tn) (cons * 2) (assoc * (list (cons + 0) (cons - 1) (cons * 2)))) (assert-false (tn) (assoc / (list (cons + 0) (cons - 1) (cons * 2)))) (tn "assoc closures") (assert-equal? (tn) (car cdr3) (assoc elm3 alist)) (assert-equal? (tn) (car cdr2) (assoc elm2 alist)) (assert-equal? (tn) (car cdr1) (assoc elm1 alist)) (assert-equal? (tn) (car cdr0) (assoc elm0 alist)) (assert-false (tn) (assoc (lambda() #f) alist)) (tn "assoc numbers") (assert-false (tn) (assoc 0 '())) (assert-equal? (tn) '(0 . a) (assoc 0 '((0 . a)))) (assert-false (tn) (assoc 1 '((0 . a)))) (assert-equal? (tn) '(0 . a) (assoc 0 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(1 . b) (assoc 1 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(2 . c) (assoc 2 '((0 . a) (1 . b) (2 . c)))) (assert-false (tn) (assoc 3 '((0 . a) (1 . b) (2 . c)))) (assert-equal? (tn) '(5 7) (assoc 5 '((2 3) (5 7) (11 13)))) ;; R5RS (tn "assoc chars") (assert-false (tn) (assoc #\a '())) (assert-equal? (tn) '(#\a . a) (assoc #\a '((#\a . a)))) (assert-false (tn) (assoc #\b '((#\a . a)))) (assert-equal? (tn) '(#\a . a) (assoc #\a '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\b . b) (assoc #\b '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\c . c) (assoc #\c '((#\a . a) (#\b . b) (#\c . c)))) (assert-false (tn) (assoc #\d '((#\a . a) (#\b . b) (#\c . c)))) (tn "assoc chars with non-constant key") (assert-false (tn) (assoc (char #\a) '())) (assert-equal? (tn) '(#\a . a) (assoc (char #\a) '((#\a . a)))) (assert-false (tn) (assoc (char #\b) '((#\a . a)))) (assert-equal? (tn) '(#\a . a) (assoc (char #\a) '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\b . b) (assoc (char #\b) '((#\a . a) (#\b . b) (#\c . c)))) (assert-equal? (tn) '(#\c . c) (assoc (char #\c) '((#\a . a) (#\b . b) (#\c . c)))) (assert-false (tn) (assoc (char #\d) '((#\a . a) (#\b . b) (#\c . c)))) (tn "assoc strings") (assert-false (tn) (assoc "a" '())) (assert-equal? (tn) '("a" . a) (assoc "a" '(("a" . a)))) (assert-false (tn) (assoc "b" '(("a" . a)))) (assert-equal? (tn) '("a" . a) (assoc "a" '(("a" . a) ("b" . b) ("c" . c)))) (assert-equal? (tn) '("b" . b) (assoc "b" '(("a" . a) ("b" . b) ("c" . c)))) (assert-equal? (tn) '("c" . c) (assoc "c" '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assoc "d" '(("a" . a) ("b" . b) ("c" . c)))) (tn "assoc strings with non-constant key") ;; These tests assume that (string #\a) is not optimized as constant string. (assert-false (tn) (assoc (string #\a) '())) (assert-equal? (tn) '("a" . a) (assoc (string #\a) '(("a" . a)))) (assert-false (tn) (assoc (string #\b) '(("a" . a)))) (assert-equal? (tn) '("a" . a) (assoc (string #\a) '(("a" . a) ("b" . b) ("c" . c)))) (assert-equal? (tn) '("b" . b) (assoc (string #\b) '(("a" . a) ("b" . b) ("c" . c)))) (assert-equal? (tn) '("c" . c) (assoc (string #\c) '(("a" . a) ("b" . b) ("c" . c)))) (assert-false (tn) (assoc (string #\d) '(("a" . a) ("b" . b) ("c" . c)))) (tn "assoc lists") ;; These tests assume that the keys are not optimized as constant object. (assert-false (tn) (assoc '("a") '())) (assert-equal? (tn) '(("a") . a) (assoc '("a") '((("a") . a)))) (assert-false (tn) (assoc '("b") '((("a") . a)))) (assert-equal? (tn) '(("a") . a) (assoc '("a") '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("b") . b) (assoc '("b") '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("c") . c) (assoc '("c") '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assoc '("d") '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("aBc" ("d" ("e"))) 1) (assoc '("aBc" ("d" ("e"))) '((("aBc" ("d" ("E"))) 0) (("aBc" ("d" ("e"))) 1) ("f") ("g")))) (tn "assoc lists with non-constant key") (assert-false (tn) (assoc (list (string #\a)) '())) (assert-equal? (tn) '(("a") . a) (assoc (list (string #\a)) '((("a") . a)))) (assert-false (tn) (assoc (list (string #\b)) '((("a") . a)))) (assert-equal? (tn) '(("a") . a) (assoc (list (string #\a)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("b") . b) (assoc (list (string #\b)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("c") . c) (assoc (list (string #\c)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-false (tn) (assoc (list (string #\d)) '((("a") . a) (("b") . b) (("c") . c)))) (assert-equal? (tn) '(("aBc" ("d" ("e"))) 1) (assoc (list (string #\a #\B #\c) (list (string #\d) (list (string #\e)))) '((("aBc" ("d" ("E"))) 0) (("aBc" ("d" ("e"))) 1) ("f") ("g")))) (assert-equal? (tn) '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) ;; R5RS (tn "assoc improper lists: symbols") (assert-error (tn) (lambda () (assoc 'a 'a))) (assert-equal? (tn) '(a . 1) (assoc 'a '((A . 0) (a . 1) (b . 2) . 3))) (assert-error (tn) (lambda () (assoc 'c '((A . 0) (a . 1) (b . 2) . 3)))) (tn "assoc improper lists: builtin procedures") (assert-error (tn) (lambda () (assoc '+ '+))) (assert-equal? (tn) '(- . 1) (assoc '- '((+ . 0) (- . 1) (* . 2) . 3))) (assert-error (tn) (lambda () (assoc '/ '((+ . 0) (- . 1) (* . 2) . 3)))) (tn "assoc improper lists: numbers") (assert-error (tn) (lambda () (assoc 0 '0))) (assert-equal? (tn) '(1 . b) (assoc 1 '((0 . a) (1 . b) (3 . c) . d))) (assert-error (tn) (lambda () (assoc 4 '((0 . a) (1 . b) (3 . c) . d)))) (tn "assoc improper lists: chars") (assert-error (tn) (lambda () (assoc #\a #\a))) (assert-equal? (tn) '(#\b . 1) (assoc #\b '((#\a . 0) (#\b . 1) (#\c . 2) . 3))) (assert-equal? (tn) '(#\b . 1) (assoc (char #\b) '((#\a . 0) (#\b . 1) (#\c . 2) . 3))) (assert-error (tn) (lambda () (assoc #\d '((#\a . 0) (#\b . 1) (#\c . 2) . 3)))) (tn "assoc improper lists: strings") (assert-error (tn) (lambda () (assoc "a" "a"))) (assert-equal? (tn) '("b" . 1) (assoc "b" '(("a" . 0) ("b" . 1) ("c" . 2) . 3))) (assert-equal? (tn) '("b" . 1) (assoc (string #\b) '(("a" . 0) ("b" . 1) ("c" . 2) . 3))) (assert-error (tn) (lambda () (assoc "d" '(("a" . 0) ("b" . 1) ("c" . 2) . 3)))) (tn "assoc improper lists: lists") (assert-error (tn) (lambda () (assoc ("a") ("a")))) (assert-equal? (tn) '(("b") . 1) (assoc '("b") '((("a") . 0) (("b") . 1) (("c") . 2) . 3))) (assert-equal? (tn) '(("b") . 1) (assoc (list (string #\b)) '((("a") . 0) (("b") . 1) (("c") . 2) . 3))) (assert-error (tn) (lambda () (assoc ("d") '((("a") . 0) (("b") . 1) (("c") . 2) . 3)))) (total-report) uim-1.8.8/sigscheme/test/test-srfi1-another.scm0000644000175000017500000033463412532333147016354 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; Filename : test-srfi1-another.scm ;; About : unit test for SRFI-1 (another version) ;; ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (require-extension (srfi 1 6 23 38)) (if (not (provided? "srfi-1")) (test-skip "SRFI-1 is not enabled")) (define tn test-name) ;;(define drop list-tail) ;; To prevent being affected from possible bug of the C implementation of ;; list-tail, tests in this file use this R5RS definition of list-tail. (define my-list-tail (lambda (x k) (if (zero? k) x (my-list-tail (cdr x) (- k 1))))) ;; unique objects (define elm0 (list 0)) (define elm1 (list 1)) (define elm2 (list 2)) (define elm3 (list 3)) (define elm4 (list 4)) (define elm5 (list 5)) (define elm6 (list 6)) (define elm7 (list 7)) (define elm8 (list 8)) (define elm9 (list 9)) ;; sublists (define cdr9 (cons elm9 '())) (define cdr8 (cons elm8 cdr9)) (define cdr7 (cons elm7 cdr8)) (define cdr6 (cons elm6 cdr7)) (define cdr5 (cons elm5 cdr6)) (define cdr4 (cons elm4 cdr5)) (define cdr3 (cons elm3 cdr4)) (define cdr2 (cons elm2 cdr3)) (define cdr1 (cons elm1 cdr2)) (define cdr0 (cons elm0 cdr1)) (define lst cdr0) ;; circular lists (define clst1 (list 1)) (set-cdr! clst1 clst1) (define clst2 (list 1 2)) (set-cdr! (my-list-tail clst2 1) clst2) (define clst3 (list 1 2 3)) (set-cdr! (my-list-tail clst3 2) clst3) (define clst4 (list 1 2 3 4)) (set-cdr! (my-list-tail clst4 3) clst4) ;; ;; Constructors ;; (tn "xcons") (assert-equal? (tn) (cons elm1 elm0) (xcons elm0 elm1)) (assert-eq? (tn) elm1 (car (xcons elm0 elm1))) (assert-eq? (tn) elm0 (cdr (xcons elm0 elm1))) (tn "cons* invalid forms") (assert-error (tn) (lambda () (cons*))) (tn "cons*") (assert-eq? (tn) elm0 (cons* elm0)) (assert-equal? (tn) (cons elm0 elm1) (cons* elm0 elm1)) (assert-equal? (tn) (cons elm0 (cons elm1 elm2)) (cons* elm0 elm1 elm2)) (assert-equal? (tn) lst (cons* elm0 elm1 elm2 cdr3)) (assert-false (tn) (eq? lst (cons* elm0 elm1 elm2 cdr3))) (assert-false (tn) (eq? cdr2 (my-list-tail (cons* elm0 elm1 elm2 cdr3) 2))) (assert-true (tn) (eq? cdr3 (my-list-tail (cons* elm0 elm1 elm2 cdr3) 3))) (assert-equal? (tn) '(1 2 3 4 5 6) (cons* 1 2 3 '(4 5 6))) (tn "cons* SRFI-1 examples") (assert-equal? (tn) '(1 2 3 . 4) (cons* 1 2 3 4)) (assert-equal? (tn) 1 (cons* 1)) (tn "make-list invalid forms") (assert-error (tn) (lambda () (make-list #t))) (assert-error (tn) (lambda () (make-list -1))) (assert-error (tn) (lambda () (make-list 0 #t #t))) (tn "make-list") (define fill (if sigscheme? (undef) (error "filler value of make-list is unknown"))) (assert-equal? (tn) '() (make-list 0)) (assert-equal? (tn) (list fill) (make-list 1)) (assert-equal? (tn) (list fill fill) (make-list 2)) (assert-equal? (tn) (list fill fill fill) (make-list 3)) (assert-equal? (tn) (list fill fill fill fill) (make-list 4)) (assert-equal? (tn) '() (make-list 0 elm0)) (assert-equal? (tn) (list elm0) (make-list 1 elm0)) (assert-equal? (tn) (list elm0 elm0) (make-list 2 elm0)) (assert-equal? (tn) (list elm0 elm0 elm0) (make-list 3 elm0)) (assert-equal? (tn) (list elm0 elm0 elm0 elm0) (make-list 4 elm0)) (tn "list-tabulate invalid forms") (assert-error (tn) (lambda () (list-tabulate 0))) (assert-error (tn) (lambda () (list-tabulate 0 number->string #t))) (assert-error (tn) (lambda () (list-tabulate 0 #t #t))) (assert-error (tn) (lambda () (list-tabulate 1 string->number))) (tn "list-tabulate") (assert-equal? (tn) '() (list-tabulate 0 number->string)) (assert-equal? (tn) '("0") (list-tabulate 1 number->string)) (assert-equal? (tn) '("0" "1") (list-tabulate 2 number->string)) (assert-equal? (tn) '("0" "1" "2") (list-tabulate 3 number->string)) (assert-equal? (tn) '("0" "1" "2" "3") (list-tabulate 4 number->string)) (tn "list-tabulate SRFI-1 examples") (assert-equal? (tn) '(0 1 2 3) (list-tabulate 4 values)) (tn "list-copy invalid forms") (assert-error (tn) (lambda () (list-copy))) (tn "list-copy") (assert-equal? (tn) lst (list-copy lst)) (assert-false (tn) (eq? lst (list-copy lst))) (assert-false (tn) (eq? (my-list-tail lst 1) (my-list-tail (list-copy lst) 1))) (assert-false (tn) (eq? (my-list-tail lst 2) (my-list-tail (list-copy lst) 2))) (assert-false (tn) (eq? (my-list-tail lst 9) (my-list-tail (list-copy lst) 9))) ;; null terminator (assert-true (tn) (eq? (my-list-tail lst 10) (my-list-tail (list-copy lst) 10))) (tn "circular-list invalid forms") (assert-error (tn) (lambda () (circular-list))) (tn "circular-list length 1") (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 0))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 1))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 2))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 3))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 4))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 5))) (tn "circular-list length 2") (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 0))) (assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 1))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 2))) (assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 3))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 4))) (assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 5))) (tn "circular-list length 3") (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 0))) (assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1 elm2) 1))) (assert-eq? (tn) elm2 (car (my-list-tail (circular-list elm0 elm1 elm2) 2))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 3))) (assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1 elm2) 4))) (assert-eq? (tn) elm2 (car (my-list-tail (circular-list elm0 elm1 elm2) 5))) (assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 6))) (tn "iota invalid forms") (assert-error (tn) (lambda () (iota))) (assert-error (tn) (lambda () (iota -1))) (assert-error (tn) (lambda () (iota -1 0 1))) (assert-error (tn) (lambda () (iota -1 0 1))) (assert-error (tn) (lambda () (iota 0 0 0 0))) (assert-error (tn) (lambda () (iota 1 0 0 0))) (tn "iota count only") (assert-equal? (tn) '() (iota 0)) (assert-equal? (tn) '(0) (iota 1)) (assert-equal? (tn) '(0 1) (iota 2)) (assert-equal? (tn) '(0 1 2) (iota 3)) (assert-equal? (tn) '(0 1 2 3) (iota 4)) (tn "iota count and start") (assert-equal? (tn) '() (iota 0 2)) (assert-equal? (tn) '(2) (iota 1 2)) (assert-equal? (tn) '(2 3) (iota 2 2)) (assert-equal? (tn) '(2 3 4) (iota 3 2)) (assert-equal? (tn) '(2 3 4 5) (iota 4 2)) ;; nagative start (assert-equal? (tn) '() (iota 0 -2)) (assert-equal? (tn) '(-2) (iota 1 -2)) (assert-equal? (tn) '(-2 -1) (iota 2 -2)) (assert-equal? (tn) '(-2 -1 0) (iota 3 -2)) (assert-equal? (tn) '(-2 -1 0 1) (iota 4 -2)) (tn "iota count, start and step") (assert-equal? (tn) '() (iota 0 2 3)) (assert-equal? (tn) '(2) (iota 1 2 3)) (assert-equal? (tn) '(2 5) (iota 2 2 3)) (assert-equal? (tn) '(2 5 8) (iota 3 2 3)) (assert-equal? (tn) '(2 5 8 11) (iota 4 2 3)) ;; negative step (assert-equal? (tn) '() (iota 0 2 -3)) (assert-equal? (tn) '(2) (iota 1 2 -3)) (assert-equal? (tn) '(2 -1) (iota 2 2 -3)) (assert-equal? (tn) '(2 -1 -4) (iota 3 2 -3)) (assert-equal? (tn) '(2 -1 -4 -7) (iota 4 2 -3)) ;; zero step (assert-equal? (tn) '() (iota 0 2 0)) (assert-equal? (tn) '(2) (iota 1 2 0)) (assert-equal? (tn) '(2 2) (iota 2 2 0)) (assert-equal? (tn) '(2 2 2) (iota 3 2 0)) (assert-equal? (tn) '(2 2 2 2) (iota 4 2 0)) ;; ;; Predicates ;; ;; proper-list? (tn "proper-list? proper list") (assert-eq? (tn) #t (proper-list? '())) (assert-eq? (tn) #t (proper-list? '(1))) (assert-eq? (tn) #t (proper-list? '(1 2))) (assert-eq? (tn) #t (proper-list? '(1 2 3))) (assert-eq? (tn) #t (proper-list? '(1 2 3 4))) (tn "proper-list? dotted list") (assert-eq? (tn) #f (proper-list? 1)) (assert-eq? (tn) #f (proper-list? '(1 . 2))) (assert-eq? (tn) #f (proper-list? '(1 2 . 3))) (assert-eq? (tn) #f (proper-list? '(1 2 3 . 4))) (assert-eq? (tn) #f (proper-list? '(1 2 3 4 . 5))) (tn "proper-list? circular list") (assert-eq? (tn) #f (proper-list? clst1)) (assert-eq? (tn) #f (proper-list? clst2)) (assert-eq? (tn) #f (proper-list? clst3)) (assert-eq? (tn) #f (proper-list? clst4)) (tn "proper-list? all kind of Scheme objects") (if (and sigscheme? (provided? "siod-bugs")) (assert-eq? (tn) #t (proper-list? #f)) (assert-eq? (tn) #f (proper-list? #f))) (assert-eq? (tn) #f (proper-list? #t)) (assert-eq? (tn) #t (proper-list? '())) (if sigscheme? (begin (assert-eq? (tn) #f (proper-list? (eof))) (assert-eq? (tn) #f (proper-list? (undef))))) (assert-eq? (tn) #f (proper-list? 0)) (assert-eq? (tn) #f (proper-list? 1)) (assert-eq? (tn) #f (proper-list? 3)) (assert-eq? (tn) #f (proper-list? -1)) (assert-eq? (tn) #f (proper-list? -3)) (assert-eq? (tn) #f (proper-list? 'symbol)) (assert-eq? (tn) #f (proper-list? 'SYMBOL)) (assert-eq? (tn) #f (proper-list? #\a)) (assert-eq? (tn) #f (proper-list? #\ã‚)) (assert-eq? (tn) #f (proper-list? "")) (assert-eq? (tn) #f (proper-list? " ")) (assert-eq? (tn) #f (proper-list? "a")) (assert-eq? (tn) #f (proper-list? "A")) (assert-eq? (tn) #f (proper-list? "aBc12!")) (assert-eq? (tn) #f (proper-list? "ã‚")) (assert-eq? (tn) #f (proper-list? "ã‚0イã†12!")) (assert-eq? (tn) #f (proper-list? +)) (assert-eq? (tn) #f (proper-list? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (proper-list? else))) ;; expression keyword (assert-error (tn) (lambda () (proper-list? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (proper-list? k)))) (assert-eq? (tn) #f (proper-list? (current-output-port))) (assert-eq? (tn) #f (proper-list? '(#t . #t))) (assert-eq? (tn) #f (proper-list? (cons #t #t))) (assert-eq? (tn) #t (proper-list? '(0 1 2))) (assert-eq? (tn) #t (proper-list? (list 0 1 2))) (assert-eq? (tn) #f (proper-list? '#())) (assert-eq? (tn) #f (proper-list? (vector))) (assert-eq? (tn) #f (proper-list? '#(0 1 2))) (assert-eq? (tn) #f (proper-list? (vector 0 1 2))) ;; circular-list? (tn "circular-list? proper list") (assert-eq? (tn) #f (circular-list? '())) (assert-eq? (tn) #f (circular-list? '(1))) (assert-eq? (tn) #f (circular-list? '(1 2))) (assert-eq? (tn) #f (circular-list? '(1 2 3))) (assert-eq? (tn) #f (circular-list? '(1 2 3 4))) (tn "circular-list? dotted list") (assert-eq? (tn) #f (circular-list? 1)) (assert-eq? (tn) #f (circular-list? '(1 . 2))) (assert-eq? (tn) #f (circular-list? '(1 2 . 3))) (assert-eq? (tn) #f (circular-list? '(1 2 3 . 4))) (assert-eq? (tn) #f (circular-list? '(1 2 3 4 . 5))) (tn "circular-list? circular list") (assert-eq? (tn) #t (circular-list? clst1)) (assert-eq? (tn) #t (circular-list? clst2)) (assert-eq? (tn) #t (circular-list? clst3)) (assert-eq? (tn) #t (circular-list? clst4)) (tn "circular-list? all kind of Scheme objects") (if (and sigscheme? (provided? "siod-bugs")) (assert-eq? (tn) #f (circular-list? #f)) (assert-eq? (tn) #f (circular-list? #f))) (assert-eq? (tn) #f (circular-list? #t)) (assert-eq? (tn) #f (circular-list? '())) (if sigscheme? (begin (assert-eq? (tn) #f (circular-list? (eof))) (assert-eq? (tn) #f (circular-list? (undef))))) (assert-eq? (tn) #f (circular-list? 0)) (assert-eq? (tn) #f (circular-list? 1)) (assert-eq? (tn) #f (circular-list? 3)) (assert-eq? (tn) #f (circular-list? -1)) (assert-eq? (tn) #f (circular-list? -3)) (assert-eq? (tn) #f (circular-list? 'symbol)) (assert-eq? (tn) #f (circular-list? 'SYMBOL)) (assert-eq? (tn) #f (circular-list? #\a)) (assert-eq? (tn) #f (circular-list? #\ã‚)) (assert-eq? (tn) #f (circular-list? "")) (assert-eq? (tn) #f (circular-list? " ")) (assert-eq? (tn) #f (circular-list? "a")) (assert-eq? (tn) #f (circular-list? "A")) (assert-eq? (tn) #f (circular-list? "aBc12!")) (assert-eq? (tn) #f (circular-list? "ã‚")) (assert-eq? (tn) #f (circular-list? "ã‚0イã†12!")) (assert-eq? (tn) #f (circular-list? +)) (assert-eq? (tn) #f (circular-list? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (circular-list? else))) ;; expression keyword (assert-error (tn) (lambda () (circular-list? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (circular-list? k)))) (assert-eq? (tn) #f (circular-list? (current-output-port))) (assert-eq? (tn) #f (circular-list? '(#t . #t))) (assert-eq? (tn) #f (circular-list? (cons #t #t))) (assert-eq? (tn) #f (circular-list? '(0 1 2))) (assert-eq? (tn) #f (circular-list? (list 0 1 2))) (assert-eq? (tn) #f (circular-list? '#())) (assert-eq? (tn) #f (circular-list? (vector))) (assert-eq? (tn) #f (circular-list? '#(0 1 2))) (assert-eq? (tn) #f (circular-list? (vector 0 1 2))) ;; dotted-list? (tn "dotted-list? proper list") (assert-eq? (tn) #f (dotted-list? '())) (assert-eq? (tn) #f (dotted-list? '(1))) (assert-eq? (tn) #f (dotted-list? '(1 2))) (assert-eq? (tn) #f (dotted-list? '(1 2 3))) (assert-eq? (tn) #f (dotted-list? '(1 2 3 4))) (tn "dotted-list? dotted list") (assert-eq? (tn) #t (dotted-list? 1)) (assert-eq? (tn) #t (dotted-list? '(1 . 2))) (assert-eq? (tn) #t (dotted-list? '(1 2 . 3))) (assert-eq? (tn) #t (dotted-list? '(1 2 3 . 4))) (assert-eq? (tn) #t (dotted-list? '(1 2 3 4 . 5))) (tn "dotted-list? circular list") (assert-eq? (tn) #f (dotted-list? clst1)) (assert-eq? (tn) #f (dotted-list? clst2)) (assert-eq? (tn) #f (dotted-list? clst3)) (assert-eq? (tn) #f (dotted-list? clst4)) (tn "dotted-list? all kind of Scheme objects") (if (and sigscheme? (provided? "siod-bugs")) (assert-eq? (tn) #f (dotted-list? #f)) (assert-eq? (tn) #t (dotted-list? #f))) (assert-eq? (tn) #t (dotted-list? #t)) (assert-eq? (tn) #f (dotted-list? '())) (if sigscheme? (begin (assert-eq? (tn) #t (dotted-list? (eof))) (assert-eq? (tn) #t (dotted-list? (undef))))) (assert-eq? (tn) #t (dotted-list? 0)) (assert-eq? (tn) #t (dotted-list? 1)) (assert-eq? (tn) #t (dotted-list? 3)) (assert-eq? (tn) #t (dotted-list? -1)) (assert-eq? (tn) #t (dotted-list? -3)) (assert-eq? (tn) #t (dotted-list? 'symbol)) (assert-eq? (tn) #t (dotted-list? 'SYMBOL)) (assert-eq? (tn) #t (dotted-list? #\a)) (assert-eq? (tn) #t (dotted-list? #\ã‚)) (assert-eq? (tn) #t (dotted-list? "")) (assert-eq? (tn) #t (dotted-list? " ")) (assert-eq? (tn) #t (dotted-list? "a")) (assert-eq? (tn) #t (dotted-list? "A")) (assert-eq? (tn) #t (dotted-list? "aBc12!")) (assert-eq? (tn) #t (dotted-list? "ã‚")) (assert-eq? (tn) #t (dotted-list? "ã‚0イã†12!")) (assert-eq? (tn) #t (dotted-list? +)) (assert-eq? (tn) #t (dotted-list? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (dotted-list? else))) ;; expression keyword (assert-error (tn) (lambda () (dotted-list? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #t (dotted-list? k)))) (assert-eq? (tn) #t (dotted-list? (current-output-port))) (assert-eq? (tn) #t (dotted-list? '(#t . #t))) (assert-eq? (tn) #t (dotted-list? (cons #t #t))) (assert-eq? (tn) #f (dotted-list? '(0 1 2))) (assert-eq? (tn) #f (dotted-list? (list 0 1 2))) (assert-eq? (tn) #t (dotted-list? '#())) (assert-eq? (tn) #t (dotted-list? (vector))) (assert-eq? (tn) #t (dotted-list? '#(0 1 2))) (assert-eq? (tn) #t (dotted-list? (vector 0 1 2))) ;; null-list? (tn "null-list? proper list") (assert-eq? (tn) #t (null-list? '())) (assert-eq? (tn) #f (null-list? '(1))) (assert-eq? (tn) #f (null-list? '(1 2))) (assert-eq? (tn) #f (null-list? '(1 2 3))) (assert-eq? (tn) #f (null-list? '(1 2 3 4))) ;; SRFI-1: List is a proper or circular list. It is an error to pass this ;; procedure a value which is not a proper or circular list. (tn "null-list? dotted list") (if sigscheme? (begin ;; SigScheme (SRFI-1 reference implementation) specific behavior (assert-error (tn) (lambda () (null-list? 1))) (assert-eq? (tn) #f (null-list? '(1 . 2))) (assert-eq? (tn) #f (null-list? '(1 2 . 3))) (assert-eq? (tn) #f (null-list? '(1 2 3 . 4))) (assert-eq? (tn) #f (null-list? '(1 2 3 4 . 5))))) (tn "null-list? circular list") (assert-eq? (tn) #f (null-list? clst1)) (assert-eq? (tn) #f (null-list? clst2)) (assert-eq? (tn) #f (null-list? clst3)) (assert-eq? (tn) #f (null-list? clst4)) ;; not-pair? (tn "not-pair? proper list") (assert-eq? (tn) #t (not-pair? '())) (assert-eq? (tn) #f (not-pair? '(1))) (assert-eq? (tn) #f (not-pair? '(1 2))) (assert-eq? (tn) #f (not-pair? '(1 2 3))) (assert-eq? (tn) #f (not-pair? '(1 2 3 4))) (tn "not-pair? dotted list") (assert-eq? (tn) #t (not-pair? 1)) (assert-eq? (tn) #f (not-pair? '(1 . 2))) (assert-eq? (tn) #f (not-pair? '(1 2 . 3))) (assert-eq? (tn) #f (not-pair? '(1 2 3 . 4))) (assert-eq? (tn) #f (not-pair? '(1 2 3 4 . 5))) (tn "not-pair? circular list") (assert-eq? (tn) #f (not-pair? clst1)) (assert-eq? (tn) #f (not-pair? clst2)) (assert-eq? (tn) #f (not-pair? clst3)) (assert-eq? (tn) #f (not-pair? clst4)) (tn "not-pair? all kind of Scheme objects") (assert-eq? (tn) #t (not-pair? #f)) (assert-eq? (tn) #t (not-pair? #t)) (assert-eq? (tn) #t (not-pair? '())) (if sigscheme? (begin (assert-eq? (tn) #t (not-pair? (eof))) (assert-eq? (tn) #t (not-pair? (undef))))) (assert-eq? (tn) #t (not-pair? 0)) (assert-eq? (tn) #t (not-pair? 1)) (assert-eq? (tn) #t (not-pair? 3)) (assert-eq? (tn) #t (not-pair? -1)) (assert-eq? (tn) #t (not-pair? -3)) (assert-eq? (tn) #t (not-pair? 'symbol)) (assert-eq? (tn) #t (not-pair? 'SYMBOL)) (assert-eq? (tn) #t (not-pair? #\a)) (assert-eq? (tn) #t (not-pair? #\ã‚)) (assert-eq? (tn) #t (not-pair? "")) (assert-eq? (tn) #t (not-pair? " ")) (assert-eq? (tn) #t (not-pair? "a")) (assert-eq? (tn) #t (not-pair? "A")) (assert-eq? (tn) #t (not-pair? "aBc12!")) (assert-eq? (tn) #t (not-pair? "ã‚")) (assert-eq? (tn) #t (not-pair? "ã‚0イã†12!")) (assert-eq? (tn) #t (not-pair? +)) (assert-eq? (tn) #t (not-pair? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (not-pair? else))) ;; expression keyword (assert-error (tn) (lambda () (not-pair? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #t (not-pair? k)))) (assert-eq? (tn) #t (not-pair? (current-output-port))) (assert-eq? (tn) #f (not-pair? '(#t . #t))) (assert-eq? (tn) #f (not-pair? (cons #t #t))) (assert-eq? (tn) #f (not-pair? '(0 1 2))) (assert-eq? (tn) #f (not-pair? (list 0 1 2))) (assert-eq? (tn) #t (not-pair? '#())) (assert-eq? (tn) #t (not-pair? (vector))) (assert-eq? (tn) #t (not-pair? '#(0 1 2))) (assert-eq? (tn) #t (not-pair? (vector 0 1 2))) ;; list= (tn "list= SRFI-1 examples") (assert-eq? (tn) #t (list= eq?)) (assert-eq? (tn) #t (list= eq? '(a))) (tn "list= 1 list") (assert-eq? (tn) #t (list= eq? '())) (assert-eq? (tn) #t (list= equal? '())) (assert-eq? (tn) #t (list= eq? lst)) (assert-eq? (tn) #t (list= equal? lst)) (assert-eq? (tn) #t (list= eq? (list elm0))) (assert-eq? (tn) #t (list= equal? (list elm0))) (assert-eq? (tn) #t (list= equal? '("a" "b" "c"))) (assert-eq? (tn) #t (list= equal? (list "a" "b" "c"))) (tn "list= 2 lists") (assert-eq? (tn) #t (list= eq? '() '())) (assert-eq? (tn) #t (list= equal? '() '())) (assert-eq? (tn) #t (list= eq? lst lst)) (assert-eq? (tn) #t (list= equal? lst lst)) (assert-eq? (tn) #t (list= eq? (list elm0) (list elm0))) (assert-eq? (tn) #t (list= equal? (list elm0) (list elm0))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c"))) (assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c"))) (tn "list= 2 lists unequal length") (assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1))) (assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '())) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '())) (tn "list= 3 lists") (assert-eq? (tn) #t (list= eq? '() '() '())) (assert-eq? (tn) #t (list= equal? '() '() '())) (assert-eq? (tn) #t (list= eq? lst lst lst)) (assert-eq? (tn) #t (list= equal? lst lst lst)) (assert-eq? (tn) #t (list= eq? (list elm0) (list elm0) (list elm0))) (assert-eq? (tn) #t (list= equal? (list elm0) (list elm0) (list elm0))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c") '("a" "b" "c"))) ;; This test is failed on the original srfi-1-reference.scm (assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c") (list "a" "b" "c"))) (tn "list= 3 lists unequal length") (assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1))) (assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) '())) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) '())) (tn "list= 4 lists") (assert-eq? (tn) #t (list= eq? '() '() '() '())) (assert-eq? (tn) #t (list= equal? '() '() '() '())) (assert-eq? (tn) #t (list= eq? lst lst lst lst)) (assert-eq? (tn) #t (list= equal? lst lst lst lst)) (assert-eq? (tn) #t (list= eq? (list elm0) (list elm0) (list elm0) (list elm0))) (assert-eq? (tn) #t (list= equal? (list elm0) (list elm0) (list elm0) (list elm0))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1) (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1) (list elm0 elm1) (list elm0 elm1))) (assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c") '("a" "b" "c") '("a" "b" "c"))) ;; This test is failed on the original srfi-1-reference.scm (assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c") (list "a" "b" "c") (list "a" "b" "c"))) (tn "list= 4 lists unequal length") (assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '() (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '() (list elm0 elm1 elm2) (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) '() (list elm0 elm1 elm2))) (assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2) '())) (assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2) (list elm0 elm1 elm2) '())) ;; ;; Selectors ;; (tn "first") (assert-eq? (tn) elm0 (first lst)) (tn "second") (assert-eq? (tn) elm1 (second lst)) (tn "third") (assert-eq? (tn) elm2 (third lst)) (tn "fourth") (assert-eq? (tn) elm3 (fourth lst)) (tn "fifth") (assert-eq? (tn) elm4 (fifth lst)) (tn "sixth") (assert-eq? (tn) elm5 (sixth lst)) (tn "seventh") (assert-eq? (tn) elm6 (seventh lst)) (tn "eighth") (assert-eq? (tn) elm7 (eighth lst)) (tn "ninth") (assert-eq? (tn) elm8 (ninth lst)) (tn "tenth") (assert-eq? (tn) elm9 (tenth lst)) (tn "car+cdr") (assert-true (tn) (call-with-values (lambda () (car+cdr (cons elm0 elm1))) (lambda (kar kdr) (and (eq? kar elm0) (eq? kdr elm1))))) ;; take ;; ;; SRFI-1: take returns the first i elements of list x. ;; x may be any value -- a proper, circular, or dotted list. (tn "take proper list invalid forms") (assert-error (tn) (lambda () (take '() -1))) (assert-error (tn) (lambda () (take '(1 2) -1))) (tn "take proper list index 0") (assert-equal? (tn) '() (take '() 0)) (assert-equal? (tn) '() (take '(1) 0)) (assert-equal? (tn) '() (take '(1 2) 0)) (assert-equal? (tn) '() (take '(1 2 3) 0)) (assert-equal? (tn) '() (take '(1 2 3 4) 0)) (assert-eq? (tn) '() (take lst 0)) (assert-eq? (tn) '() (take cdr9 0)) (tn "take proper list index 1") (assert-error (tn) (lambda () (take '() 1))) (assert-equal? (tn) '(1) (take '(1) 1)) (assert-equal? (tn) '(1) (take '(1 2) 1)) (assert-equal? (tn) '(1) (take '(1 2 3) 1)) (assert-equal? (tn) '(1) (take '(1 2 3 4) 1)) (assert-equal? (tn) (list elm0) (take lst 1)) (assert-equal? (tn) (list elm8) (take cdr8 1)) (assert-equal? (tn) (list elm9) (take cdr9 1)) (tn "take proper list index 2") (assert-error (tn) (lambda () (take '() 2))) (assert-error (tn) (lambda () (take '(1) 2))) (assert-equal? (tn) '(1 2) (take '(1 2) 2)) (assert-equal? (tn) '(1 2) (take '(1 2 3) 2)) (assert-equal? (tn) '(1 2) (take '(1 2 3 4) 2)) (assert-equal? (tn) (list elm0 elm1) (take lst 2)) (assert-equal? (tn) (list elm7 elm8) (take cdr7 2)) (assert-equal? (tn) (list elm8 elm9) (take cdr8 2)) (assert-error (tn) (lambda () (take cdr9 2))) (tn "take proper list index 3") (assert-error (tn) (lambda () (take '() 3))) (assert-error (tn) (lambda () (take '(1) 3))) (assert-error (tn) (lambda () (take '(1 2) 3))) (assert-equal? (tn) '(1 2 3) (take '(1 2 3) 3)) (assert-equal? (tn) '(1 2 3) (take '(1 2 3 4) 3)) (assert-equal? (tn) (list elm0 elm1 elm2) (take lst 3)) (assert-equal? (tn) (list elm6 elm7 elm8) (take cdr6 3)) (assert-equal? (tn) (list elm7 elm8 elm9) (take cdr7 3)) (assert-error (tn) (lambda () (take cdr8 3))) (assert-error (tn) (lambda () (take cdr9 3))) (tn "take proper list index 4") (assert-error (tn) (lambda () (take '() 4))) (assert-error (tn) (lambda () (take '(1) 4))) (assert-error (tn) (lambda () (take '(1 2) 4))) (assert-error (tn) (lambda () (take '(1 2 3) 4))) (assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4) 4)) (assert-equal? (tn) (list elm0 elm1 elm2 elm3) (take lst 4)) (assert-equal? (tn) (list elm5 elm6 elm7 elm8) (take cdr5 4)) (assert-equal? (tn) (list elm6 elm7 elm8 elm9) (take cdr6 4)) (assert-error (tn) (lambda () (take cdr7 4))) (assert-error (tn) (lambda () (take cdr8 4))) (assert-error (tn) (lambda () (take cdr9 4))) (tn "take proper list index 5") (assert-error (tn) (lambda () (take '() 5))) (assert-error (tn) (lambda () (take '(1) 5))) (assert-error (tn) (lambda () (take '(1 2) 5))) (assert-error (tn) (lambda () (take '(1 2 3) 5))) (assert-error (tn) (lambda () (take '(1 2 3 4) 5))) (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4) (take lst 5)) (assert-equal? (tn) (list elm4 elm5 elm6 elm7 elm8) (take cdr4 5)) (assert-equal? (tn) (list elm5 elm6 elm7 elm8 elm9) (take cdr5 5)) (assert-error (tn) (lambda () (take cdr6 5))) (assert-error (tn) (lambda () (take cdr7 5))) (assert-error (tn) (lambda () (take cdr8 5))) (assert-error (tn) (lambda () (take cdr9 5))) (tn "take proper list other indices") (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4 elm5) (take lst 6)) (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4 elm5 elm6) (take lst 7)) (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7) (take lst 8)) (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8) (take lst 9)) (assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8 elm9) (take lst 10)) (assert-error (tn) (lambda () (take lst 11))) (tn "take dotted list invalid forms") (assert-error (tn) (lambda () (take 1 -1))) (assert-error (tn) (lambda () (take '(1 . 2) -1))) (tn "take dotted list index 0") (assert-equal? (tn) '() (take 1 0)) (assert-equal? (tn) '() (take '(1 . 2) 0)) (assert-equal? (tn) '() (take '(1 2 . 3) 0)) (assert-equal? (tn) '() (take '(1 2 3 . 4) 0)) (assert-equal? (tn) '() (take '(1 2 3 4 . 5) 0)) (tn "take dotted list index 1") (assert-error (tn) (lambda () (take 1 1))) (assert-equal? (tn) '(1) (take '(1 . 2) 1)) (assert-equal? (tn) '(1) (take '(1 2 . 3) 1)) (assert-equal? (tn) '(1) (take '(1 2 3 . 4) 1)) (assert-equal? (tn) '(1) (take '(1 2 3 4 . 5) 1)) (tn "take dotted list index 2") (assert-error (tn) (lambda () (take 1 2))) (assert-error (tn) (lambda () (take '(1 . 2) 2))) (assert-equal? (tn) '(1 2) (take '(1 2 . 3) 2)) (assert-equal? (tn) '(1 2) (take '(1 2 3 . 4) 2)) (assert-equal? (tn) '(1 2) (take '(1 2 3 4 . 5) 2)) (tn "take dotted list index 3") (assert-error (tn) (lambda () (take 1 3))) (assert-error (tn) (lambda () (take '(1 . 2) 3))) (assert-error (tn) (lambda () (take '(1 2 . 3) 3))) (assert-equal? (tn) '(1 2 3) (take '(1 2 3 . 4) 3)) (assert-equal? (tn) '(1 2 3) (take '(1 2 3 4 . 5) 3)) (tn "take dotted list index 4") (assert-error (tn) (lambda () (take 1 4))) (assert-error (tn) (lambda () (take '(1 . 2) 4))) (assert-error (tn) (lambda () (take '(1 2 . 3) 4))) (assert-error (tn) (lambda () (take '(1 2 3 . 4) 4))) (assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4 . 5) 4)) (tn "take dotted list index 5") (assert-error (tn) (lambda () (take 1 5))) (assert-error (tn) (lambda () (take '(1 . 2) 5))) (assert-error (tn) (lambda () (take '(1 2 . 3) 5))) (assert-error (tn) (lambda () (take '(1 2 3 . 4) 5))) (assert-error (tn) (lambda () (take '(1 2 3 4 . 5) 5))) (tn "take circular list invalid forms") ;; SigScheme's implementation does not detect negative index on circular list ;; since it is an user error. It goes an infinite loop. ;;(assert-error (tn) (lambda () (take clst1 -1))) ;;(assert-error (tn) (lambda () (take clst2 -1))) (tn "take circular list index 0") (assert-eq? (tn) '() (take clst1 0)) (assert-eq? (tn) '() (take clst2 0)) (assert-eq? (tn) '() (take clst3 0)) (assert-eq? (tn) '() (take clst4 0)) (tn "take circular list index 1") (assert-equal? (tn) (list (list-ref clst1 0)) (take clst1 1)) (assert-equal? (tn) (list (list-ref clst2 0)) (take clst2 1)) (assert-equal? (tn) (list (list-ref clst3 0)) (take clst3 1)) (assert-equal? (tn) (list (list-ref clst4 0)) (take clst4 1)) (tn "take circular list index 2") (assert-equal? (tn) (list (list-ref clst1 0) (list-ref clst1 0)) (take clst1 2)) (assert-equal? (tn) (list (list-ref clst2 0) (list-ref clst2 1)) (take clst2 2)) (assert-equal? (tn) (list (list-ref clst3 0) (list-ref clst3 1)) (take clst3 2)) (assert-equal? (tn) (list (list-ref clst4 0) (list-ref clst4 1)) (take clst4 2)) (tn "take circular list index 3") (assert-equal? (tn) (list (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0)) (take clst1 3)) (assert-equal? (tn) (list (list-ref clst2 0) (list-ref clst2 1) (list-ref clst2 0)) (take clst2 3)) (assert-equal? (tn) (list (list-ref clst3 0) (list-ref clst3 1) (list-ref clst3 2)) (take clst3 3)) (assert-equal? (tn) (list (list-ref clst4 0) (list-ref clst4 1) (list-ref clst4 2)) (take clst4 3)) (tn "take circular list index 4") (assert-equal? (tn) (list (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0)) (take clst1 4)) (assert-equal? (tn) (list (list-ref clst2 0) (list-ref clst2 1) (list-ref clst2 0) (list-ref clst2 1)) (take clst2 4)) (assert-equal? (tn) (list (list-ref clst3 0) (list-ref clst3 1) (list-ref clst3 2) (list-ref clst3 0)) (take clst3 4)) (assert-equal? (tn) (list (list-ref clst4 0) (list-ref clst4 1) (list-ref clst4 2) (list-ref clst4 3)) (take clst4 4)) (tn "take circular list index 5") (assert-equal? (tn) (list (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0) (list-ref clst1 0)) (take clst1 5)) (assert-equal? (tn) (list (list-ref clst2 0) (list-ref clst2 1) (list-ref clst2 0) (list-ref clst2 1) (list-ref clst2 0)) (take clst2 5)) (assert-equal? (tn) (list (list-ref clst3 0) (list-ref clst3 1) (list-ref clst3 2) (list-ref clst3 0) (list-ref clst3 1)) (take clst3 5)) (assert-equal? (tn) (list (list-ref clst4 0) (list-ref clst4 1) (list-ref clst4 2) (list-ref clst4 3) (list-ref clst4 0)) (take clst4 5)) (tn "take freshly-allocated entire list") ;; SRFI-1: If the argument is a list of non-zero length, take is guaranteed to ;; return a freshly-allocated list, even in the case where the entire list is ;; taken, e.g. (take lis (length lis)). (assert-false (tn) (eq? lst (take lst (length lst)))) (assert-true (tn) (equal? lst (take lst (length lst)))) (define find-pair (lambda (x lst) (let rec ((rest lst)) (if (null? rest) #f (or (eq? x rest) (rec (cdr rest))))))) ;; Check uniqueness for each pair in the new list. (assert-true (tn) (let rec ((rest (take lst (length lst)))) (if (null? rest) #t (and (not (find-pair rest lst)) (rec (cdr rest)))))) (tn "take SRFI-1 examples") (assert-equal? (tn) '(a b) (take '(a b c d e) 2)) (assert-equal? (tn) '(1 2) (take '(1 2 3 . d) 2)) (assert-equal? (tn) '(1 2 3) (take '(1 2 3 . d) 3)) ;; drop ;; ;; SRFI-1: drop returns all but the first i elements of list x. ;; x may be any value -- a proper, circular, or dotted list. (tn "drop proper list invalid forms") (assert-error (tn) (lambda () (drop '() -1))) (assert-error (tn) (lambda () (drop '(1 2) -1))) (tn "drop proper list index 0") (assert-equal? (tn) '() (drop '() 0)) (assert-equal? (tn) '(1) (drop '(1) 0)) (assert-equal? (tn) '(1 2) (drop '(1 2) 0)) (assert-equal? (tn) '(1 2 3) (drop '(1 2 3) 0)) (assert-equal? (tn) '(1 2 3 4) (drop '(1 2 3 4) 0)) (assert-eq? (tn) cdr0 (drop lst 0)) (assert-eq? (tn) cdr9 (drop cdr9 0)) (tn "drop proper list index 1") (assert-error (tn) (lambda () (drop '() 1))) (assert-equal? (tn) '() (drop '(1) 1)) (assert-equal? (tn) '(2) (drop '(1 2) 1)) (assert-equal? (tn) '(2 3) (drop '(1 2 3) 1)) (assert-equal? (tn) '(2 3 4) (drop '(1 2 3 4) 1)) (assert-eq? (tn) cdr1 (drop lst 1)) (assert-eq? (tn) cdr9 (drop cdr8 1)) (assert-eq? (tn) '() (drop cdr9 1)) (tn "drop proper list index 2") (assert-error (tn) (lambda () (drop '() 2))) (assert-error (tn) (lambda () (drop '(1) 2))) (assert-equal? (tn) '() (drop '(1 2) 2)) (assert-equal? (tn) '(3) (drop '(1 2 3) 2)) (assert-equal? (tn) '(3 4) (drop '(1 2 3 4) 2)) (assert-eq? (tn) cdr2 (drop lst 2)) (assert-eq? (tn) cdr9 (drop cdr7 2)) (assert-eq? (tn) '() (drop cdr8 2)) (assert-error (tn) (lambda () (drop cdr9 2))) (tn "drop proper list index 3") (assert-error (tn) (lambda () (drop '() 3))) (assert-error (tn) (lambda () (drop '(1) 3))) (assert-error (tn) (lambda () (drop '(1 2) 3))) (assert-equal? (tn) '() (drop '(1 2 3) 3)) (assert-equal? (tn) '(4) (drop '(1 2 3 4) 3)) (assert-eq? (tn) cdr3 (drop lst 3)) (assert-eq? (tn) cdr9 (drop cdr6 3)) (assert-eq? (tn) '() (drop cdr7 3)) (assert-error (tn) (lambda () (drop cdr8 3))) (assert-error (tn) (lambda () (drop cdr9 3))) (tn "drop proper list index 4") (assert-error (tn) (lambda () (drop '() 4))) (assert-error (tn) (lambda () (drop '(1) 4))) (assert-error (tn) (lambda () (drop '(1 2) 4))) (assert-error (tn) (lambda () (drop '(1 2 3) 4))) (assert-equal? (tn) '() (drop '(1 2 3 4) 4)) (assert-eq? (tn) cdr4 (drop lst 4)) (assert-eq? (tn) cdr9 (drop cdr5 4)) (assert-eq? (tn) '() (drop cdr6 4)) (assert-error (tn) (lambda () (drop cdr7 4))) (assert-error (tn) (lambda () (drop cdr8 4))) (assert-error (tn) (lambda () (drop cdr9 4))) (tn "drop proper list index 5") (assert-error (tn) (lambda () (drop '() 5))) (assert-error (tn) (lambda () (drop '(1) 5))) (assert-error (tn) (lambda () (drop '(1 2) 5))) (assert-error (tn) (lambda () (drop '(1 2 3) 5))) (assert-error (tn) (lambda () (drop '(1 2 3 4) 5))) (assert-eq? (tn) cdr5 (drop lst 5)) (assert-eq? (tn) cdr9 (drop cdr4 5)) (assert-eq? (tn) '() (drop cdr5 5)) (assert-error (tn) (lambda () (drop cdr6 5))) (assert-error (tn) (lambda () (drop cdr7 5))) (assert-error (tn) (lambda () (drop cdr8 5))) (assert-error (tn) (lambda () (drop cdr9 5))) (tn "drop proper list other indices") (assert-eq? (tn) cdr6 (drop lst 6)) (assert-eq? (tn) cdr7 (drop lst 7)) (assert-eq? (tn) cdr8 (drop lst 8)) (assert-eq? (tn) cdr9 (drop lst 9)) (assert-eq? (tn) '() (drop lst 10)) (assert-error (tn) (lambda () (drop lst 11))) (tn "drop dotted list invalid forms") (assert-error (tn) (lambda () (drop 1 -1))) (assert-error (tn) (lambda () (drop '(1 . 2) -1))) (tn "drop dotted list index 0") (assert-equal? (tn) 1 (drop 1 0)) (assert-equal? (tn) '(1 . 2) (drop '(1 . 2) 0)) (assert-equal? (tn) '(1 2 . 3) (drop '(1 2 . 3) 0)) (assert-equal? (tn) '(1 2 3 . 4) (drop '(1 2 3 . 4) 0)) (assert-equal? (tn) '(1 2 3 4 . 5) (drop '(1 2 3 4 . 5) 0)) (tn "drop dotted list index 1") (assert-error (tn) (lambda () (drop 1 1))) (assert-equal? (tn) 2 (drop '(1 . 2) 1)) (assert-equal? (tn) '(2 . 3) (drop '(1 2 . 3) 1)) (assert-equal? (tn) '(2 3 . 4) (drop '(1 2 3 . 4) 1)) (assert-equal? (tn) '(2 3 4 . 5) (drop '(1 2 3 4 . 5) 1)) (tn "drop dotted list index 2") (assert-error (tn) (lambda () (drop 1 2))) (assert-error (tn) (lambda () (drop '(1 . 2) 2))) (assert-equal? (tn) 3 (drop '(1 2 . 3) 2)) (assert-equal? (tn) '(3 . 4) (drop '(1 2 3 . 4) 2)) (assert-equal? (tn) '(3 4 . 5) (drop '(1 2 3 4 . 5) 2)) (tn "drop dotted list index 3") (assert-error (tn) (lambda () (drop 1 3))) (assert-error (tn) (lambda () (drop '(1 . 2) 3))) (assert-error (tn) (lambda () (drop '(1 2 . 3) 3))) (assert-equal? (tn) 4 (drop '(1 2 3 . 4) 3)) (assert-equal? (tn) '(4 . 5) (drop '(1 2 3 4 . 5) 3)) (tn "drop dotted list index 4") (assert-error (tn) (lambda () (drop 1 4))) (assert-error (tn) (lambda () (drop '(1 . 2) 4))) (assert-error (tn) (lambda () (drop '(1 2 . 3) 4))) (assert-error (tn) (lambda () (drop '(1 2 3 . 4) 4))) (assert-equal? (tn) 5 (drop '(1 2 3 4 . 5) 4)) (tn "drop dotted list index 5") (assert-error (tn) (lambda () (drop 1 5))) (assert-error (tn) (lambda () (drop '(1 . 2) 5))) (assert-error (tn) (lambda () (drop '(1 2 . 3) 5))) (assert-error (tn) (lambda () (drop '(1 2 3 . 4) 5))) (assert-error (tn) (lambda () (drop '(1 2 3 4 . 5) 5))) (tn "drop circular list invalid forms") ;; SigScheme's implementation does not detect negative index on circular list ;; since it is an user error. It goes an infinite loop. ;;(assert-error (tn) (lambda () (drop clst1 -1))) ;;(assert-error (tn) (lambda () (drop clst2 -1))) (tn "drop circular list index 0") (assert-eq? (tn) clst1 (drop clst1 0)) (assert-eq? (tn) clst2 (drop clst2 0)) (assert-eq? (tn) clst3 (drop clst3 0)) (assert-eq? (tn) clst4 (drop clst4 0)) (tn "drop circular list index 1") (assert-eq? (tn) clst1 (drop clst1 1)) (assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 1)) (assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 1)) (assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 1)) (tn "drop circular list index 2") (assert-eq? (tn) clst1 (drop clst1 2)) (assert-eq? (tn) clst2 (drop clst2 2)) (assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 2)) (assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 2)) (tn "drop circular list index 3") (assert-eq? (tn) clst1 (drop clst1 3)) (assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 3)) (assert-eq? (tn) clst3 (drop clst3 3)) (assert-eq? (tn) (my-list-tail clst4 3) (drop clst4 3)) (tn "drop circular list index 4") (assert-eq? (tn) clst1 (drop clst1 4)) (assert-eq? (tn) clst2 (drop clst2 4)) (assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 4)) (assert-eq? (tn) clst4 (drop clst4 4)) (tn "drop circular list index 5") (assert-eq? (tn) clst1 (drop clst1 5)) (assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 5)) (assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 5)) (assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 5)) (tn "drop circular list index 6") (assert-eq? (tn) clst1 (drop clst1 6)) (assert-eq? (tn) clst2 (drop clst2 6)) (assert-eq? (tn) clst3 (drop clst3 6)) (assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 6)) (tn "drop SRFI-1 examples") (assert-equal? (tn) '(c d e) (drop '(a b c d e) 2)) (assert-equal? (tn) '(3 . d) (drop '(1 2 3 . d) 2)) (assert-equal? (tn) 'd (drop '(1 2 3 . d) 3)) ;; take-right ;; drop-right ;; take! ;; drop-right! ;; split-at ;; split-at! ;; last ;; ;; SRFI-1: last returns the last element of the non-empty, finite list pair. (tn "last invalid forms") (assert-error (tn) (lambda () (last '()))) (assert-error (tn) (lambda () (last 1))) (tn "last") (assert-eq? (tn) elm9 (last lst)) (assert-eq? (tn) elm9 (last cdr7)) (assert-eq? (tn) elm9 (last cdr8)) (assert-eq? (tn) elm9 (last cdr9)) (assert-equal? (tn) 1 (last '(1 . 2))) (assert-equal? (tn) 2 (last '(1 2 . 3))) (assert-equal? (tn) 3 (last '(1 2 3 . 4))) ;; last-pair ;; ;; SRFI-1: last-pair returns the last pair in the non-empty, finite list pair. (tn "last-pair invalid forms") (assert-error (tn) (lambda () (last-pair '()))) (assert-error (tn) (lambda () (last-pair 1))) (tn "last-pair") (assert-eq? (tn) cdr9 (last-pair lst)) (assert-eq? (tn) cdr9 (last-pair cdr7)) (assert-eq? (tn) cdr9 (last-pair cdr8)) (assert-eq? (tn) cdr9 (last-pair cdr9)) (assert-equal? (tn) '(1 . 2) (last-pair '(1 . 2))) (assert-equal? (tn) '(2 . 3) (last-pair '(1 2 . 3))) (assert-equal? (tn) '(3 . 4) (last-pair '(1 2 3 . 4))) ;; ;; Miscellaneous: length, append, concatenate, reverse, zip & count ;; ;; length+ (tn "length+ proper list") (assert-equal? (tn) 0 (length+ '())) (assert-equal? (tn) 1 (length+ '(1))) (assert-equal? (tn) 2 (length+ '(1 2))) (assert-equal? (tn) 3 (length+ '(1 2 3))) (assert-equal? (tn) 4 (length+ '(1 2 3 4))) (tn "length+ dotted list") ;; Although the behavior on dotted list is not defined in SRFI-1 itself, the ;; reference implementation returns its length. So SigScheme followed it. (if sigscheme? (begin (assert-equal? (tn) 0 (length+ 1)) (assert-equal? (tn) 1 (length+ '(1 . 2))) (assert-equal? (tn) 2 (length+ '(1 2 . 3))) (assert-equal? (tn) 3 (length+ '(1 2 3 . 4))) (assert-equal? (tn) 4 (length+ '(1 2 3 4 . 5))))) (tn "length+ circular list") (assert-eq? (tn) #f (length+ clst1)) (assert-eq? (tn) #f (length+ clst2)) (assert-eq? (tn) #f (length+ clst3)) (assert-eq? (tn) #f (length+ clst4)) ;; append! (tn "append!") (assert-equal? (tn) '() (append!)) (assert-equal? (tn) '() (append! '())) (assert-equal? (tn) '() (append! '() '())) (assert-equal? (tn) '() (append! '() '() '())) (assert-equal? (tn) '(a) (append! (list 'a) '() '())) (assert-equal? (tn) '(a) (append! '() (list 'a) '())) (assert-equal? (tn) '(a) (append! '() '() '(a))) (assert-equal? (tn) 'a (append! 'a)) (assert-equal? (tn) '(a . b) (append! '(a . b))) (assert-equal? (tn) '(a . b) (append! '() '() '(a . b))) (assert-equal? (tn) '(1 2 3 a . b) (append! (list 1) (list 2 3) '(a . b))) (assert-equal? (tn) 7 (append! (+ 3 4))) (assert-equal? (tn) '(+ 3 4) (append! '(+ 3 4))) (assert-equal? (tn) '(a b) (append! '(a b))) (assert-equal? (tn) '(c d e a b) (append! (list 'c) (list 'd 'e) '(a b))) ;; The reference implementation does not cause error on non-tail dotted list. ;;(assert-error (tn) (lambda () (append! 'a 'b))) ;;(assert-error (tn) (lambda () (append! 'a '(b)))) ;;(assert-error (tn) (lambda () (append! 'a '()))) ;;(assert-error (tn) (lambda () (append! (cons 'a 'b) '()))) ;;(assert-error (tn) (lambda () (append! '() (cons 'a 'b) '()))) (tn "append! shared tail") ;; SRFI-1: The last argument is never altered; the result list shares structure ;; with this parameter. (assert-equal? (tn) (list 1 2 3 elm8 elm9) (append! (list 1) (list 2 3) cdr8)) (assert-eq? (tn) cdr8 (my-list-tail (append! (list 1) (list 2 3) cdr8) 3)) ;; concatenate (tn "concatenate invalid forms") (assert-error (tn) (lambda () (concatenate))) (assert-error (tn) (lambda () (concatenate #t))) (tn "concatenate") (assert-equal? (tn) '() (concatenate '())) (assert-equal? (tn) '() (concatenate '(()))) (assert-equal? (tn) '() (concatenate '(() ()))) (assert-equal? (tn) '() (concatenate '(() () ()))) (assert-equal? (tn) '(a) (concatenate '((a) () ()))) (assert-equal? (tn) '(a) (concatenate '(() (a) ()))) (assert-equal? (tn) '(a) (concatenate '(() () (a)))) (assert-equal? (tn) 'a (concatenate '(a))) (assert-equal? (tn) '(a . b) (concatenate '((a . b)))) (assert-equal? (tn) '(a . b) (concatenate '(() () (a . b)))) (assert-equal? (tn) '(1 2 3 a . b) (concatenate '((1) (2 3) (a . b)))) (assert-equal? (tn) 7 (concatenate (list (+ 3 4)))) (assert-equal? (tn) '(+ 3 4) (concatenate '((+ 3 4)))) (assert-equal? (tn) '(a b) (concatenate '((a b)))) (assert-equal? (tn) '(c d e a b) (concatenate '((c) (d e) (a b)))) ;; concatenate! (tn "concatenate! invalid forms") (assert-error (tn) (lambda () (concatenate!))) (assert-error (tn) (lambda () (concatenate! #t))) (tn "concatenate!") (assert-equal? (tn) '() (concatenate! '())) (assert-equal? (tn) '() (concatenate! (list '()))) (assert-equal? (tn) '() (concatenate! (list '() '()))) (assert-equal? (tn) '() (concatenate! (list '() '() '()))) (assert-equal? (tn) '(a) (concatenate! (list (list 'a) '() '()))) (assert-equal? (tn) '(a) (concatenate! (list '() (list 'a) '()))) (assert-equal? (tn) '(a) (concatenate! (list '() '() '(a)))) (assert-equal? (tn) 'a (concatenate! '(a))) (assert-equal? (tn) '(a . b) (concatenate! '((a . b)))) (assert-equal? (tn) '(a . b) (concatenate! (list '() '() '(a . b)))) (assert-equal? (tn) '(1 2 3 a . b) (concatenate! (list (list 1) (list 2 3) '(a . b)))) (assert-equal? (tn) 7 (concatenate! (list (+ 3 4)))) (assert-equal? (tn) '(+ 3 4) (concatenate! '((+ 3 4)))) (assert-equal? (tn) '(a b) (concatenate! '((a b)))) (assert-equal? (tn) '(c d e a b) (concatenate! (list (list 'c) (list 'd 'e) '(a b)))) ;; reverse! ;;append-reverse (tn "append-reverse invalid forms") (assert-error (tn) (lambda () (append-reverse #t '()))) (tn "append-reverse") (assert-equal? (tn) '() (append-reverse '() '())) (assert-equal? (tn) '(3 2 1) (append-reverse '(1 2 3) '())) (assert-equal? (tn) '(3 2 1 4 5 6) (append-reverse '(1 2 3) '(4 5 6))) (assert-equal? (tn) '(4 5 6) (append-reverse '() '(4 5 6))) (assert-equal? (tn) '(3 2 1 . #t) (append-reverse '(1 2 3) #t)) (assert-equal? (tn) #t (append-reverse '() #t)) ;; append-reverse! ;; ;; SRFI-1: it is allowed, but not required, to alter rev-head's cons cells to ;; construct the result. (tn "append-reverse! invalid forms") (assert-error (tn) (lambda () (append-reverse! #t '()))) (tn "append-reverse!") (assert-equal? (tn) '() (append-reverse! '() '())) (assert-equal? (tn) '(3 2 1) (append-reverse! (list 1 2 3) '())) (assert-equal? (tn) '(3 2 1 4 5 6) (append-reverse! (list 1 2 3) '(4 5 6))) (assert-equal? (tn) '(4 5 6) (append-reverse! '() '(4 5 6))) (assert-equal? (tn) '(3 2 1 . #t) (append-reverse! (list 1 2 3) #t)) (assert-equal? (tn) #t (append-reverse! '() #t)) ;; zip (tn "zip invalid forms") (assert-error (tn) (lambda () (zip))) (tn "zip single list") (assert-equal? (tn) '() (zip '())) (assert-equal? (tn) '((1)) (zip '(1))) (assert-equal? (tn) '((1) (2)) (zip '(1 2))) (assert-equal? (tn) '((1) (2) (3)) (zip '(1 2 3))) (tn "zip 3 lists") (assert-equal? (tn) '() (zip '() '() '())) (assert-equal? (tn) '((1 4 7)) (zip '(1) '(4) '(7))) (assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2) '(4 5) '(7 8))) (assert-equal? (tn) '((1 4 7) (2 5 8) (3 6 9)) (zip '(1 2 3) '(4 5 6) '(7 8 9))) (tn "zip 3 lists unequal length") (assert-equal? (tn) '() (zip '() '(4) '(7))) (assert-equal? (tn) '() (zip '(1) '() '(7))) (assert-equal? (tn) '() (zip '(1) '(4) '())) (assert-equal? (tn) '((1 4 7)) (zip '(1) '(4 5) '(7 8))) (assert-equal? (tn) '((1 4 7)) (zip '(1 2) '(4) '(7 8))) (assert-equal? (tn) '((1 4 7)) (zip '(1 2) '(4 5) '(7))) (assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2) '(4 5 6) '(7 8 9))) (assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2 3) '(4 5) '(7 8 9))) (assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2 3) '(4 5 6) '(7 8))) (tn "zip SRFI-1 examples") (assert-equal? (tn) '((one 1 odd) (two 2 even) (three 3 odd)) (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even))) (assert-equal? (tn) '((1) (2) (3)) (zip '(1 2 3))) ;; SRFI-1: At least one of the argument lists must be finite. (assert-equal? (tn) '((3 #f) (1 #t) (4 #f) (1 #t)) (zip '(3 1 4 1) (circular-list #f #t))) ;; unzip1 ;; unzip2 ;; unzip3 ;; unzip4 ;; unzip5 ;; count ;; ;; Fold, unfold & map ;; ;; fold (tn "fold invalid forms") (assert-error (tn) (lambda () (fold cons))) (assert-error (tn) (lambda () (fold cons '()))) (assert-error (tn) (lambda () (fold cons '#()))) (assert-error (tn) (lambda () (fold cons '(1) '#(2)))) (assert-error (tn) (lambda () (fold #\a '()))) (tn "fold single list") (assert-equal? (tn) '() (fold cons '() '())) (assert-equal? (tn) '(1) (fold cons '() '(1))) (assert-equal? (tn) '(2 1) (fold cons '() '(1 2))) (assert-equal? (tn) '(3 2 1) (fold cons '() '(1 2 3))) (tn "fold 3 lists") (assert-equal? (tn) "cCzbByaAxNIL" (fold string-append "NIL" '("a" "b" "c") '("A" "B" "C") '("x" "y" "z"))) ;; unequal length (assert-equal? (tn) "bByaAxNIL" (fold string-append "NIL" '("a" "b" "c") '("A" "B") '("x" "y" "z"))) (assert-equal? (tn) "NIL" (fold string-append "NIL" '("a" "b" "c") '() '("x" "y" "z"))) (tn "fold SRFI-1 examples") ;; Add up the elements of list. (assert-equal? (tn) 15 (fold + 0 '(1 2 3 4 5))) ;; Reverse LST. (assert-equal? (tn) (list elm9 elm8 elm7 elm6 elm5 elm4 elm3 elm2 elm1 elm0) (fold cons '() lst)) ;; See APPEND-REVERSE. (assert-equal? (tn) '(10 9 8 1 2 3) (let ((tail '(1 2 3)) (rev-head '(8 9 10))) (fold cons tail rev-head))) ;; How many symbols in list? (assert-equal? (tn) 0 (fold (lambda (x count) (if (symbol? x) (+ count 1) count)) 0 lst)) (assert-equal? (tn) 3 (fold (lambda (x count) (if (symbol? x) (+ count 1) count)) 0 '(0 #\a a "a" b (0) c))) ;; Length of the longest string in list: (assert-equal? (tn) 17 (fold (lambda (s max-len) (max max-len (string-length s))) 0 '("" "string-append" "str" "SigScheme Project" "SRFI-1"))) ;; unequal length lists (assert-equal? (tn) '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5))) ;; fold-right ;; pair-fold ;; pair-fold-right ;; reduce (tn "reduce invalid forms") (assert-error (tn) (lambda () (reduce cons))) (assert-error (tn) (lambda () (reduce cons '()))) (assert-error (tn) (lambda () (reduce cons '#()))) (assert-error (tn) (lambda () (reduce cons '() '#(2)))) (assert-error (tn) (lambda () (reduce #\a '()))) (tn "reduce") (assert-equal? (tn) 0 (reduce + 0 '())) (assert-equal? (tn) 1 (reduce + 0 '(1))) (assert-equal? (tn) 3 (reduce + 0 '(1 2))) (assert-equal? (tn) 6 (reduce + 0 '(1 2 3))) (assert-equal? (tn) "" (reduce string-append "" '())) (assert-equal? (tn) "a" (reduce string-append "" '("a"))) (assert-equal? (tn) "ba" (reduce string-append "" '("a" "b"))) (assert-equal? (tn) "cba" (reduce string-append "" '("a" "b" "c"))) (assert-equal? (tn) '() (reduce cons '() '())) (assert-equal? (tn) '(1) (reduce cons '() '(() 1))) (assert-equal? (tn) '(2 1) (reduce cons '() '(() 1 2))) (assert-equal? (tn) '(3 2 1) (reduce cons '() '(() 1 2 3))) (tn "reduce SRFI-1 examples") ;; Take the max of a list of non-negative integers. (assert-equal? (tn) 43 (reduce max 0 '(0 7 8 8 43 -4))) ;; reduce-right ;; unfold (tn "unfold invalid forms") (assert-error (tn) (lambda () (unfold #\c car cdr '(1 2 3)))) (assert-error (tn) (lambda () (unfold cons #\a cdr '(1 2 3)))) (assert-error (tn) (lambda () (unfold cons car #\d '(1 2 3)))) (assert-error (tn) (lambda () (unfold cons car cdr '#(1 2 3)))) (assert-error (tn) (lambda () (unfold cons car cdr '(1 2 3) '()))) (assert-error (tn) (lambda () (unfold cons car cdr '(1 2 3) values '()))) (tn "unfold") (assert-equal? (tn) '() (unfold null? car cdr '())) (assert-error (tn) (lambda () (unfold null? car cdr 1))) (assert-equal? (tn) '() (unfold not-pair? car cdr 1)) (assert-equal? (tn) 1 (unfold not-pair? car cdr 1 values)) (assert-equal? (tn) '(1 2 3 4) (unfold null? car cdr '(1 2 3 4))) (assert-error (tn) (lambda () (unfold null? car cdr '(1 2 3 4 . 5)))) (assert-equal? (tn) '(1 2 3 4) (unfold not-pair? car cdr '(1 2 3 4 . 5))) (assert-equal? (tn) '(1 2 3 4 . 5) (unfold not-pair? car cdr '(1 2 3 4 . 5) values)) (tn "unfold SRFI-1 examples") ;; List of squares: 1^2 ... 10^2 (assert-equal? (tn) '(1 4 9 16 25 36 49 64 81 100) (unfold (lambda (x) (> x 10)) (lambda (x) (* x x)) (lambda (x) (+ x 1)) 1)) ;; Copy a proper list. (assert-true (tn) (equal? lst (unfold null-list? car cdr lst))) (assert-false (tn) (eq? lst (unfold null-list? car cdr lst))) ;; Read current input port into a list of values. (assert-equal? (tn) '((equal? lst (unfold null-list? car cdr lst))) (let ((p (open-input-string "(equal? lst (unfold null-list? car cdr lst))"))) (unfold eof-object? values (lambda (x) (read p)) (read p)))) ;; Copy a possibly non-proper list: (assert-true (tn) (equal? lst (unfold not-pair? car cdr lst values))) (assert-false (tn) (eq? lst (unfold not-pair? car cdr lst values))) (let ((dlst (cons elm0 (cons elm1 (cons elm2 elm3))))) (assert-true (tn) (equal? dlst (unfold not-pair? car cdr dlst values))) (assert-false (tn) (eq? dlst (unfold not-pair? car cdr dlst values)))) ;; Append HEAD onto TAIL: (assert-equal? (tn) '(1 2 3 4 5 6) (let ((head '(1 2 3)) (tail '(4 5 6))) (unfold null-list? car cdr head (lambda (x) tail)))) ;; unfold-right ;; map (tn "map invalid forms") (assert-error (tn) (lambda () (map +))) (assert-error (tn) (lambda () (map + '#()))) (assert-error (tn) (lambda () (map + '(1) '#(2)))) (assert-error (tn) (lambda () (map #\a '(1)))) (tn "map single list") (assert-equal? (tn) '() (map + '())) (assert-equal? (tn) '() (map even? '())) (assert-equal? (tn) '(2 4 6 8) (map + '(2 4 6 8))) (assert-equal? (tn) '(#t #t #t #t) (map even? '(2 4 6 8))) (assert-equal? (tn) '(#f #t #t #t #t) (map even? '(3 2 4 6 8))) (assert-equal? (tn) '(#t #t #f #t #t) (map even? '(2 4 3 6 8))) (assert-equal? (tn) '(#t #t #t #t #f) (map even? '(2 4 6 8 3))) (tn "map 3 lists") (assert-equal? (tn) '() (map + '() '() '())) (assert-equal? (tn) '(12 17 22 27) (map + '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) '(12 #f 22 #f) (map (lambda args (let ((sum (apply + args))) (and (even? sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) '(12 18 22 28) (map (lambda args (let ((sum (apply + args))) (and (even? sum) sum))) '(2 4 6 8) '(1 4 5 8) '(9 10 11 12))) (tn "map 3 lists unequal length") (assert-equal? (tn) '(12 17 22) (map + '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) '(12 17 22) (map + '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) '(12 17 22) (map + '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) '() (map + '() '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) '() (map + '(2 4 6 8) '() '(9 10 11 12))) (assert-equal? (tn) '() (map + '(2 4 6 8) '(1 3 5 7) '())) (tn "map 3 lists with circular list") (assert-equal? (tn) '(11 15 17 21) (map + clst2 '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) '(11 15 17 21) (map + '(1 3 5 7) clst2 '(9 10 11 12))) (assert-equal? (tn) '(11 15 17 21) (map + '(1 3 5 7) '(9 10 11 12) clst2)) (tn "map SRFI-1 examples") (assert-equal? (tn) '(b e h) (map cadr '((a b) (d e) (g h)))) (define expt (lambda (x y) (apply * (make-list y x)))) (assert-equal? (tn) '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) (assert-equal? (tn) '(5 7 9) (map + '(1 2 3) '(4 5 6))) (assert-true (tn) (let ((result (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))))) (or (equal? result '(1 2)) (equal? result '(2 1))))) (assert-equal? (tn) '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0))) ;; for-each ;; append-map (tn "append-map invalid forms") (assert-error (tn) (lambda () (append-map values))) (assert-error (tn) (lambda () (append-map #\a '()))) (assert-error (tn) (lambda () (append-map values '#()))) (assert-error (tn) (lambda () (append-map list '(1) '#(2)))) (tn "append-map single list") (assert-equal? (tn) '() (append-map values '())) (assert-equal? (tn) '(1 2 3 4 5 6 7) (append-map values '((1) (2 3) (4) (5 6 7)))) (assert-equal? (tn) '(1 3 2 4 7 6 5) (append-map reverse '((1) (2 3) (4) (5 6 7)))) (tn "append-map 3 lists") (assert-equal? (tn) '() (append-map list '() '() '())) (assert-equal? (tn) '(1 4 7 2 5 8 3 6 9) (append-map list '(1 2 3) '(4 5 6) '(7 8 9))) (tn "append-map 3 lists unequal length") (assert-equal? (tn) '(1 4 7 2 5 8) (append-map list '(1 2) '(4 5 6) '(7 8 9))) (assert-equal? (tn) '(1 4 7 2 5 8) (append-map list '(1 2 3) '(4 5) '(7 8 9))) (assert-equal? (tn) '(1 4 7 2 5 8) (append-map list '(1 2 3) '(4 5 6) '(7 8))) (assert-equal? (tn) '() (append-map list '() '(4 5 6) '(7 8 9))) (assert-equal? (tn) '() (append-map list '(1 2 3) '() '(7 8 9))) (assert-equal? (tn) '() (append-map list '(1 2 3) '(4 5 6) '())) (tn "append-map 3 lists with circular list") ;; SRFI-1: At least one of the list arguments must be finite. (assert-equal? (tn) '(1 4 7 2 5 8 1 6 9) (append-map list clst2 '(4 5 6) '(7 8 9))) (assert-equal? (tn) '(1 1 7 2 2 8 3 1 9) (append-map list '(1 2 3) clst2 '(7 8 9))) (assert-equal? (tn) '(1 4 1 2 5 2 3 6 1) (append-map list '(1 2 3) '(4 5 6) clst2)) (tn "append-map SRFI-1 examples") (assert-equal? (tn) '(1 -1 3 -3 8 -8) (append-map (lambda (x) (list x (- x))) '(1 3 8))) ;; append-map! (tn "append-map! invalid forms") (assert-error (tn) (lambda () (append-map! values))) (assert-error (tn) (lambda () (append-map! #\a '()))) (assert-error (tn) (lambda () (append-map! values '#()))) (assert-error (tn) (lambda () (append-map! list '(1) '#(2)))) (tn "append-map! single list") (assert-equal? (tn) '() (append-map! values '())) (assert-equal? (tn) '(1 2 3 4 5 6 7) (append-map! values (list (list 1) (list 2 3) (list 4) (list 5 6 7)))) (assert-equal? (tn) '(1 3 2 4 7 6 5) (append-map! reverse '((1) (2 3) (4) (5 6 7)))) (tn "append-map! 3 lists") (assert-equal? (tn) '() (append-map! list '() '() '())) (assert-equal? (tn) '(1 4 7 2 5 8 3 6 9) (append-map! list '(1 2 3) '(4 5 6) '(7 8 9))) (tn "append-map! 3 lists unequal length") (assert-equal? (tn) '(1 4 7 2 5 8) (append-map! list '(1 2) '(4 5 6) '(7 8 9))) (assert-equal? (tn) '(1 4 7 2 5 8) (append-map! list '(1 2 3) '(4 5) '(7 8 9))) (assert-equal? (tn) '(1 4 7 2 5 8) (append-map! list '(1 2 3) '(4 5 6) '(7 8))) (assert-equal? (tn) '() (append-map! list '() '(4 5 6) '(7 8 9))) (assert-equal? (tn) '() (append-map! list '(1 2 3) '() '(7 8 9))) (assert-equal? (tn) '() (append-map! list '(1 2 3) '(4 5 6) '())) (tn "append-map! 3 lists with circular list") ;; SRFI-1: At least one of the list arguments must be finite. (assert-equal? (tn) '(1 4 7 2 5 8 1 6 9) (append-map! list clst2 '(4 5 6) '(7 8 9))) (assert-equal? (tn) '(1 1 7 2 2 8 3 1 9) (append-map! list '(1 2 3) clst2 '(7 8 9))) (assert-equal? (tn) '(1 4 1 2 5 2 3 6 1) (append-map! list '(1 2 3) '(4 5 6) clst2)) (tn "append-map! SRFI-1 examples") (assert-equal? (tn) '(1 -1 3 -3 8 -8) (append-map! (lambda (x) (list x (- x))) '(1 3 8))) ;; map! ;; map-in-order (tn "map-in-order") ;; derived from SRFI-1 example of map (assert-equal? (tn) '() (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '()))) (assert-equal? (tn) '(1 2) (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '(a b)))) (assert-equal? (tn) '(1 2 3) (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '(a b c)))) (assert-equal? (tn) '(1 2 3 4) (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '(a b c d)))) ;; pair-for-each ;; filter-map (tn "filter-map invalid forms") (assert-error (tn) (lambda () (filter-map even?))) (assert-error (tn) (lambda () (filter-map #\a '()))) (assert-error (tn) (lambda () (filter-map + '#(1)))) (assert-error (tn) (lambda () (filter-map + '(1) '#(2)))) (tn "filter-map single list") (assert-equal? (tn) '() (filter-map even? '())) (assert-equal? (tn) '(2 -8 12) (filter-map (lambda (x) (and (even? x) x)) '(2 7 3 -8 5 -3 9 12))) (assert-equal? (tn) '() (filter-map pair? '(2 7 3 -8 5 -3 9 12))) (tn "filter-map 3 lists") (assert-equal? (tn) '(112 320 72 27) (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) '(6 -2 38 -2 8 4 3) '(-1 -7 -5 2 8 -6 1))) (tn "filter-map 3 lists unequal length") (assert-equal? (tn) '(112 320) (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) '(6 -2 38 -2 8) '(-1 -7 -5 2 8 -6))) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '() '(6 -2 38 -2 8) '(-1 -7 -5 2 8 -6))) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) '() '(-1 -7 -5 2 8 -6))) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) '(6 -2 38 -2 8) '())) (tn "filter-map 3 lists unequal length with circular list") ;; SRFI-1: At least one of the list arguments must be finite. (assert-equal? (tn) '(24 40 36) (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) clst4 '(-1 -7 -5 2 8 -6))) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '() clst4 '(-1 -7 -5 2 8 -6))) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) '() clst4)) (assert-equal? (tn) '() (filter-map (lambda args (let ((res (apply * args))) (and (positive? res) res))) '(2 8 7 3 5 -3 9) clst4 '())) (tn "filter-map SRFI-1 examples") (assert-equal? (tn) '(1 9 49) (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7))) ;; ;; Filtering & partitioning ;; ;; filter (tn "filter invalid forms") (assert-error (tn) (lambda () (filter #\a '(1 2)))) (assert-error (tn) (lambda () (filter cons '(1 2)))) (assert-error (tn) (lambda () (filter cons '(1 2) '(3 4)))) (assert-error (tn) (lambda () (filter even? '(1 2) '(3 4)))) (tn "filter") (assert-equal? (tn) '() (filter even? '())) (assert-equal? (tn) '(2 4 6) (filter even? '(1 2 3 4 5 6))) (assert-equal? (tn) '(1 3 5) (filter odd? '(1 2 3 4 5 6))) (assert-equal? (tn) '(1 2 3 4 5 6) (filter number? '(1 2 3 4 5 6))) (assert-equal? (tn) '() (filter pair? '(1 2 3 4 5 6))) (tn "filter SRFI-1 examples") (assert-equal? (tn) '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4))) ;; partition ;; remove (tn "remove invalid forms") (assert-error (tn) (lambda () (remove #\a '(1 2)))) (assert-error (tn) (lambda () (remove cons '(1 2)))) (assert-error (tn) (lambda () (remove cons '(1 2) '(3 4)))) (assert-error (tn) (lambda () (remove even? '(1 2) '(3 4)))) (tn "remove") (assert-equal? (tn) '() (remove even? '())) (assert-equal? (tn) '(0 8 8 -4) (remove odd? '(0 7 8 8 43 -4))) (assert-equal? (tn) '() (remove number? '(0 7 8 8 43 -4))) (assert-equal? (tn) '(0 7 8 8 43 -4) (remove pair? '(0 7 8 8 43 -4))) (tn "remove SRFI-1 examples") (assert-equal? (tn) '(7 43) (remove even? '(0 7 8 8 43 -4))) ;; filter! ;; partition! ;; remove! ;; ;; Searching ;; ;; find (tn "find invalid forms") (assert-error (tn) (lambda () (find even? '#(1 2)))) (assert-error (tn) (lambda () (find 1 '(1 2)))) (tn "find proper list") (assert-false (tn) (find even? '())) (assert-false (tn) (find (lambda (x) #f) lst)) (assert-eq? (tn) elm0 (find (lambda (x) (eq? x elm0)) lst)) (assert-eq? (tn) elm1 (find (lambda (x) (eq? x elm1)) lst)) (assert-eq? (tn) elm2 (find (lambda (x) (eq? x elm2)) lst)) (assert-eq? (tn) elm8 (find (lambda (x) (eq? x elm8)) lst)) (assert-eq? (tn) elm9 (find (lambda (x) (eq? x elm9)) lst)) (tn "find dotted list") (assert-error (tn) (lambda () (find even? 1))) (assert-equal? (tn) 1 (find (lambda (x) (= x 1)) '(1 . 2))) (assert-equal? (tn) 2 (find (lambda (x) (= x 2)) '(1 2 . 3))) (assert-equal? (tn) 3 (find (lambda (x) (= x 3)) '(1 2 3 . 4))) (assert-error (tn) (lambda () (find even? '(1 . 2)))) (assert-equal? (tn) 2 (find even? '(1 2 . 3))) (assert-equal? (tn) 2 (find even? '(1 2 3 . 4))) (assert-equal? (tn) 1 (find odd? '(1 . 2))) (assert-equal? (tn) 1 (find odd? '(1 2 . 3))) (assert-equal? (tn) 1 (find odd? '(1 2 3 . 4))) (tn "find circular list") ;; Rotates the circular list as like as find-tail. (assert-equal? (tn) 1 (find (lambda (x) (= x 1)) clst4)) (assert-equal? (tn) 2 (find (lambda (x) (= x 2)) clst4)) (assert-equal? (tn) 3 (find (lambda (x) (= x 3)) clst4)) (assert-equal? (tn) 4 (find (lambda (x) (= x 4)) clst4)) (assert-equal? (tn) 1 (let ((cnt 2)) (find (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) (assert-equal? (tn) 2 (let ((cnt 2)) (find (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 2))) clst4))) (assert-equal? (tn) 3 (let ((cnt 2)) (find (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 3))) clst4))) (assert-equal? (tn) 1 (let ((cnt 3)) (find (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) (assert-equal? (tn) 1 (let ((cnt 4)) (find (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) ;; find-tail (tn "find-tail invalid forms") (assert-error (tn) (lambda () (find-tail even? '#(1 2)))) (assert-error (tn) (lambda () (find-tail 1 '(1 2)))) (tn "find-tail proper list") ;; Although the behavior on null list is not explicitly defined in SRFI-1 ;; itself, the reference implementation returns #f So SigScheme followed it. (assert-false (tn) (find-tail even? '())) (assert-false (tn) (find-tail (lambda (x) #f) lst)) (assert-eq? (tn) lst (find-tail (lambda (x) (eq? x elm0)) lst)) (assert-eq? (tn) cdr1 (find-tail (lambda (x) (eq? x elm1)) lst)) (assert-eq? (tn) cdr2 (find-tail (lambda (x) (eq? x elm2)) lst)) (assert-eq? (tn) cdr8 (find-tail (lambda (x) (eq? x elm8)) lst)) (assert-eq? (tn) cdr9 (find-tail (lambda (x) (eq? x elm9)) lst)) (tn "find-tail dotted list") (assert-error (tn) (lambda () (find-tail even? 1))) ;; Although the behavior on dotted list is not defined in SRFI-1 itself, the ;; reference implementation returns the last pair. So SigScheme followed it. (assert-equal? (tn) '(1 . 2) (find-tail (lambda (x) (= x 1)) '(1 . 2))) (assert-equal? (tn) '(2 . 3) (find-tail (lambda (x) (= x 2)) '(1 2 . 3))) (assert-equal? (tn) '(3 . 4) (find-tail (lambda (x) (= x 3)) '(1 2 3 . 4))) (assert-error (tn) (lambda () (find-tail even? '(1 . 2)))) (assert-equal? (tn) '(2 . 3) (find-tail even? '(1 2 . 3))) (assert-equal? (tn) '(2 3 . 4) (find-tail even? '(1 2 3 . 4))) (assert-equal? (tn) '(1 . 2) (find-tail odd? '(1 . 2))) (assert-equal? (tn) '(1 2 . 3) (find-tail odd? '(1 2 . 3))) (assert-equal? (tn) '(1 2 3 . 4) (find-tail odd? '(1 2 3 . 4))) (tn "find-tail circular list") ;; SRFI-1: In the circular-list case, this procedure "rotates" the list. (assert-eq? (tn) clst4 (find-tail (lambda (x) (= x 1)) clst4)) (assert-eq? (tn) (my-list-tail clst4 1) (find-tail (lambda (x) (= x 2)) clst4)) (assert-eq? (tn) (my-list-tail clst4 2) (find-tail (lambda (x) (= x 3)) clst4)) (assert-eq? (tn) (my-list-tail clst4 3) (find-tail (lambda (x) (= x 4)) clst4)) (assert-eq? (tn) clst4 (let ((cnt 2)) (find-tail (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) (assert-eq? (tn) (my-list-tail clst4 1) (let ((cnt 2)) (find-tail (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 2))) clst4))) (assert-eq? (tn) (my-list-tail clst4 2) (let ((cnt 2)) (find-tail (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 3))) clst4))) (assert-eq? (tn) clst4 (let ((cnt 3)) (find-tail (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) (assert-eq? (tn) clst4 (let ((cnt 4)) (find-tail (lambda (x) (if (= x 1) (set! cnt (- cnt 1))) (and (zero? cnt) (= x 1))) clst4))) ;; take-while ;; take-while! ;; drop-while ;; span ;; span! ;; break ;; break! ;; any (tn "any invalid forms") (assert-error (tn) (lambda () (any +))) (assert-error (tn) (lambda () (any + '#()))) (assert-error (tn) (lambda () (any + '(1) '#(2)))) (assert-error (tn) (lambda () (any #\a '(1)))) (tn "any single list") (assert-equal? (tn) #f (any + '())) (assert-equal? (tn) #f (any even? '())) (assert-equal? (tn) 2 (any + '(2 4 6 8))) (assert-equal? (tn) #f (any odd? '(2 4 6 8))) (assert-equal? (tn) #t (any odd? '(3 2 4 6 8))) (assert-equal? (tn) #t (any odd? '(2 4 3 6 8))) (assert-equal? (tn) #t (any odd? '(2 4 6 8 3))) (tn "any 3 lists") (assert-equal? (tn) #f (any + '() '() '())) (assert-equal? (tn) 12 (any + '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 17 (any (lambda args (let ((sum (apply + args))) (and (odd? sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (any (lambda args (let ((sum (apply + args))) (and (odd? sum) sum))) '(2 4 6 8) '(1 4 5 8) '(9 10 11 12))) (tn "any 3 lists unequal length") (assert-equal? (tn) 22 (any (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 22 (any (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) 22 (any (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) #f (any (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (any (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) #f (any (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) #f (any + '() '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (any + '(2 4 6 8) '() '(9 10 11 12))) (assert-equal? (tn) #f (any + '(2 4 6 8) '(1 3 5 7) '())) (tn "any 3 lists with circular list") (assert-equal? (tn) 11 (any + clst2 '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 21 (any (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) clst2 '(1 3 5 7) '(9 10 11 12))) (tn "any 3 SRFI-1 examples") ;;(assert-eq? (tn) #t (any integer? '(a 3 b 2.7))) (assert-eq? (tn) #t (any integer? '(a 3 b #\2))) ;;(assert-eq? (tn) #f (any integer? '(a 3.1 b 2.7))) (assert-eq? (tn) #f (any integer? '(a #\3 b #\2))) (assert-eq? (tn) #t (any < '(3 1 4 1 5) '(2 7 1 8 2))) ;; every (tn "every invalid forms") (assert-error (tn) (lambda () (every +))) (assert-error (tn) (lambda () (every + '#()))) (assert-error (tn) (lambda () (every + '(1) '#(2)))) (assert-error (tn) (lambda () (every #\a '(1)))) (tn "every single list") (assert-equal? (tn) #t (every + '())) (assert-equal? (tn) #t (every even? '())) (assert-equal? (tn) 8 (every + '(2 4 6 8))) (assert-equal? (tn) #t (every even? '(2 4 6 8))) (assert-equal? (tn) #f (every even? '(3 2 4 6 8))) (assert-equal? (tn) #f (every even? '(2 4 3 6 8))) (assert-equal? (tn) #f (every even? '(2 4 6 8 3))) (tn "every 3 lists") (assert-equal? (tn) #t (every + '() '() '())) (assert-equal? (tn) 27 (every + '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (every (lambda args (let ((sum (apply + args))) (and (even? sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 28 (every (lambda args (let ((sum (apply + args))) (and (even? sum) sum))) '(2 4 6 8) '(1 4 5 8) '(9 10 11 12))) (tn "every 3 lists unequal length") (assert-equal? (tn) 22 (every + '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 22 (every + '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) 22 (every + '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) #t (every + '() '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #t (every + '(2 4 6 8) '() '(9 10 11 12))) (assert-equal? (tn) #t (every + '(2 4 6 8) '(1 3 5 7) '())) (tn "every 3 lists with circular list") (assert-equal? (tn) 21 (every + clst2 '(1 3 5 7) '(9 10 11 12))) ;; list-index (tn "list-index invalid forms") (assert-error (tn) (lambda () (list-index even?))) (assert-error (tn) (lambda () (list-index even? '#()))) (assert-error (tn) (lambda () (list-index #\a '(1)))) (assert-error (tn) (lambda () (list-index + '(1) '#(2)))) (tn "list-index single list") (assert-false (tn) (list-index even? '())) (assert-false (tn) (list-index even? '(1))) (assert-equal? (tn) 1 (list-index even? '(1 2))) (assert-equal? (tn) 1 (list-index even? '(1 2 3))) (assert-false (tn) (list-index odd? '(2 4 6 8))) (assert-equal? (tn) 0 (list-index odd? '(3 2 4 6 8))) (assert-equal? (tn) 2 (list-index odd? '(2 4 3 6 8))) (assert-equal? (tn) 4 (list-index odd? '(2 4 6 8 3))) (tn "list-index 3 lists") (assert-false (tn) (list-index + '() '() '())) (assert-equal? (tn) 0 (list-index + '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 1 (list-index (lambda args (let ((sum (apply + args))) (and (odd? sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (list-index (lambda args (let ((sum (apply + args))) (and (odd? sum) sum))) '(2 4 6 8) '(1 4 5 8) '(9 10 11 12))) (tn "list-index 3 lists unequal length") (assert-equal? (tn) 2 (list-index (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) 2 (list-index (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) 2 (list-index (lambda args (let ((sum (apply + args))) (and (< 20 sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) #f (list-index (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6) '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (list-index (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6 8) '(1 3 5) '(9 10 11 12))) (assert-equal? (tn) #f (list-index (lambda args (let ((sum (apply + args))) (and (< 25 sum) sum))) '(2 4 6 8) '(1 3 5 7) '(9 10 11))) (assert-equal? (tn) #f (list-index + '() '(1 3 5 7) '(9 10 11 12))) (assert-equal? (tn) #f (list-index + '(2 4 6 8) '() '(9 10 11 12))) (assert-equal? (tn) #f (list-index + '(2 4 6 8) '(1 3 5 7) '())) (tn "list-index SRFI-1 examples") (assert-equal? (tn) 2 (list-index even? '(3 1 4 1 5 9))) (assert-equal? (tn) 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2))) (assert-equal? (tn) #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2))) ;; member (tn "member invalid forms") (assert-error (tn) (lambda () (member 1))) (assert-error (tn) (lambda () (member 1 '#(1)))) (assert-error (tn) (lambda () (member 1 '(1) #\a))) (assert-error (tn) (lambda () (member 1 '(1) = '()))) (tn "member") (assert-eq? (tn) #f (member 1 '())) (assert-eq? (tn) #f (member 1 '() eq?)) (assert-eq? (tn) #f (member 1 '() equal?)) (assert-eq? (tn) cdr3 (member elm3 lst)) (assert-eq? (tn) cdr3 (member elm3 lst eq?)) (assert-eq? (tn) cdr3 (member elm3 lst equal?)) (assert-eq? (tn) cdr3 (member (list-copy elm3) lst)) (assert-false (tn) (member (list-copy elm3) lst eq?)) (assert-eq? (tn) cdr3 (member (list-copy elm3) lst equal?)) ;; ;; Deleting ;; ;; delete (tn "delete invalid forms") (assert-error (tn) (lambda () (delete 1))) (assert-error (tn) (lambda () (delete 1 '#(1)))) (assert-error (tn) (lambda () (delete 1 '(1) #\a))) (assert-error (tn) (lambda () (delete 1 '(1) = '()))) (tn "delete") (assert-equal? (tn) '() (delete 1 '())) (assert-equal? (tn) '() (delete 1 '() eq?)) (assert-equal? (tn) '() (delete 1 '() equal?)) (assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2))) (assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2) eq?)) (assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2) equal?)) (assert-equal? (tn) (list cdr0 cdr2) (delete (list-copy cdr1) (list cdr0 cdr1 cdr2))) (assert-equal? (tn) (list cdr0 cdr1 cdr2) (delete (list-copy cdr1) (list cdr0 cdr1 cdr2) eq?)) (assert-equal? (tn) (list cdr0 cdr2) (delete (list-copy cdr1) (list cdr0 cdr1 cdr2) equal?)) (tn "delete SRFI-1 examples") (assert-equal? (tn) '(0 -4) (delete 5 '(0 7 8 8 43 -4) <)) ;; delete! (tn "delete! invalid forms") (assert-error (tn) (lambda () (delete! 1))) (assert-error (tn) (lambda () (delete! 1 (vector 1)))) (assert-error (tn) (lambda () (delete! 1 (list 1) #\a))) (assert-error (tn) (lambda () (delete! 1 (list 1) = '()))) (tn "delete!") (assert-equal? (tn) '() (delete! 1 '())) (assert-equal? (tn) '() (delete! 1 '() eq?)) (assert-equal? (tn) '() (delete! 1 '() equal?)) (assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2))) (assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2) eq?)) (assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2) equal?)) (assert-equal? (tn) (list cdr0 cdr2) (delete! (list-copy cdr1) (list cdr0 cdr1 cdr2))) (assert-equal? (tn) (list cdr0 cdr1 cdr2) (delete! (list-copy cdr1) (list cdr0 cdr1 cdr2) eq?)) (assert-equal? (tn) (list cdr0 cdr2) (delete! (list-copy cdr1) (list cdr0 cdr1 cdr2) equal?)) (tn "delete! SRFI-1 examples") (assert-equal? (tn) '(0 -4) (delete! 5 (list 0 7 8 8 43 -4) <)) ;; delete-duplicates ;; delete-duplicates! ;; ;; Association lists ;; (define alist-s '(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3))) (define alist-n '((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g))) ;; assoc (tn "assoc (SRFI-1 extended) invalid forms") (assert-error (tn) (lambda () (assoc "a" alist-s #\a))) (assert-error (tn) (lambda () (assoc "a" alist-s string=? values))) (tn "assoc (SRFI-1 extended)") (assert-equal? (tn) '("b" . 2) (assoc "b" alist-s)) (assert-equal? (tn) '("a" . 1) (assoc "a" alist-s)) (assert-equal? (tn) '("d" . 4) (assoc "d" alist-s)) (assert-equal? (tn) '("c" . 3) (assoc "c" alist-s)) (assert-false (tn) (assoc "A" alist-s)) (assert-equal? (tn) '("b" . 2) (assoc "b" alist-s string=?)) (assert-equal? (tn) '("a" . 1) (assoc "a" alist-s string=?)) (assert-equal? (tn) '("d" . 4) (assoc "d" alist-s string=?)) (assert-equal? (tn) '("c" . 3) (assoc "c" alist-s string=?)) (assert-false (tn) (assoc "A" alist-s string=?)) ;; alist-cons (tn "alist-cons") (assert-equal? (tn) '(("A" . 1)) (alist-cons "A" 1 '())) (assert-equal? (tn) (cons '("A" . 1) alist-s) (alist-cons "A" 1 alist-s)) (assert-eq? (tn) alist-s (cdr (alist-cons "A" 1 alist-s))) ;; alist-copy (tn "alist-copy") (assert-equal? (tn) '() (alist-copy '())) (assert-equal? (tn) alist-s (alist-copy alist-s)) (assert-false (tn) (eq? (list-ref alist-s 0) (list-ref (alist-copy alist-s) 0))) (assert-true (tn) (eq? (car (list-ref alist-s 0)) (car (list-ref (alist-copy alist-s) 0)))) (assert-true (tn) (eq? (cdr (list-ref alist-s 0)) (cdr (list-ref (alist-copy alist-s) 0)))) (assert-false (tn) (eq? (list-ref alist-s 1) (list-ref (alist-copy alist-s) 1))) (assert-true (tn) (eq? (car (list-ref alist-s 1)) (car (list-ref (alist-copy alist-s) 1)))) (assert-true (tn) (eq? (cdr (list-ref alist-s 1)) (cdr (list-ref (alist-copy alist-s) 1)))) (assert-false (tn) (eq? (list-ref alist-s 2) (list-ref (alist-copy alist-s) 2))) (assert-true (tn) (eq? (car (list-ref alist-s 2)) (car (list-ref (alist-copy alist-s) 2)))) (assert-true (tn) (eq? (cdr (list-ref alist-s 2)) (cdr (list-ref (alist-copy alist-s) 2)))) ;; alist-delete (tn "alist-delete invalid forms") (assert-error (tn) (lambda () (alist-delete "A" '#()))) (assert-error (tn) (lambda () (alist-delete "A" '(("a" . 1)) #\a))) (assert-error (tn) (lambda () (alist-delete #\a '(("a" . 1)) string=?))) (tn "alist-delete") (assert-equal? (tn) '() (alist-delete "A" '())) (assert-equal? (tn) '() (alist-delete "A" '() string=?)) (assert-equal? (tn) '(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3)) (alist-delete "A" alist-s)) (assert-equal? (tn) '(("b" . 2) ("d" . 4) ("b" . 5) ("c" . 3)) (alist-delete "a" alist-s)) (assert-equal? (tn) '(("a" . 1) ("d" . 4) ("c" . 3)) (alist-delete "b" alist-s)) (assert-equal? (tn) '(("a" . 1) ("d" . 4) ("c" . 3)) (alist-delete "b" alist-s string=?)) (assert-equal? (tn) '((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g)) (alist-delete -1 alist-n)) (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (5 . e) (7 . g)) (alist-delete 6 alist-n)) (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (5 . e) (7 . g)) (alist-delete 6 alist-n =)) (tn "alist-delete SRFI-1 examples") (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (5 . e)) (alist-delete 5 alist-n <)) ;; alist-delete! (tn "alist-delete! invalid forms") (assert-error (tn) (lambda () (alist-delete! "A" (vector)))) (assert-error (tn) (lambda () (alist-delete! "A" (list (cons "a" 1)) #\a))) (assert-error (tn) (lambda () (alist-delete! #\a (list (cons "a" 1)) string=?))) (tn "alist-delete!") (assert-equal? (tn) '() (alist-delete! "A" '())) (assert-equal? (tn) '() (alist-delete! "A" '() string=?)) (assert-equal? (tn) '(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3)) (alist-delete! "A" (alist-copy alist-s))) (assert-equal? (tn) '(("b" . 2) ("d" . 4) ("b" . 5) ("c" . 3)) (alist-delete! "a" (alist-copy alist-s))) (assert-equal? (tn) '(("a" . 1) ("d" . 4) ("c" . 3)) (alist-delete! "b" (alist-copy alist-s))) (assert-equal? (tn) '(("a" . 1) ("d" . 4) ("c" . 3)) (alist-delete! "b" (alist-copy alist-s) string=?)) (assert-equal? (tn) '((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g)) (alist-delete! -1 (alist-copy alist-n))) (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (5 . e) (7 . g)) (alist-delete! 6 (alist-copy alist-n))) (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (7 . g) (5 . e) (7 . g)) (alist-delete! 6 (alist-copy alist-n) =)) (tn "alist-delete! SRFI-1 examples") (assert-equal? (tn) '((1 . a) (5 . e) (2 . b) (4 . d) (3 . c) (4 . d) (3 . c) (5 . e)) (alist-delete! 5 (alist-copy alist-n) <)) ;; ;; Set operations on lists ;; ;; lset<= ;; lset= ;; lset-adjoin ;; lset-union ;; lset-intersection ;; lset-difference ;; lset-xor (tn "lset-xor") ;; To test the bug of the original srfi-1-reference.scm (assert-equal? (tn) '("d") (lset-xor equal? '("a" "b" "c") '("d" "c" "a" "b"))) ;; lset-diff+intersection ;; lset-union! ;; lset-intersection! ;; lset-difference! ;; lset-xor! (tn "lset-xor!") ;; To test the bug of the original srfi-1-reference.scm (assert-equal? (tn) '("d") (lset-xor equal? (list "a" "b" "c") (list "d" "c" "a" "b"))) ;; lset-diff+intersection! (total-report) uim-1.8.8/sigscheme/test/test-define.scm0000644000175000017500000004140712532333147015115 00000000000000;; Filename : test-define.scm ;; About : unit test for R5RS 'define' ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; internal definitions in 'define' are writtin at test-define-internal.scm ;; internal definitions in 'let' variants are writtin at test-let.scm ;; see also test-begin.scm for top-level definitions (require-extension (unittest)) (define tn test-name) (define *test-track-progress* #f) (tn "define invalid form") (assert-error (tn) (lambda () (define))) (assert-error (tn) (lambda () (define . a))) (assert-error (tn) (lambda () (define a))) (assert-error (tn) (lambda () (define a . 2))) (assert-error (tn) (lambda () (define a 1 'excessive))) (assert-error (tn) (lambda () (define a 1 . 'excessive))) ;; is not a symbol (assert-error (tn) (lambda () (define 1))) (assert-error (tn) (lambda () (define 1 . 1))) (assert-error (tn) (lambda () (define 1 1))) (assert-error (tn) (lambda () (define #t 1))) (assert-error (tn) (lambda () (define #f 1))) (assert-error (tn) (lambda () (define 1 1 'excessive))) (assert-error (tn) (lambda () (define 1 1 . 'excessive))) ;; function forms (assert-error (tn) (lambda () (define ()))) (assert-error (tn) (lambda () (define () 1))) (assert-error (tn) (lambda () (define (f)))) (assert-error (tn) (lambda () (define (f) . 1))) (assert-error (tn) (lambda () (define (f) 1 . 1))) (assert-error (tn) (lambda () (define (f x)))) (assert-error (tn) (lambda () (define (f x) . 1))) (assert-error (tn) (lambda () (define (f x) 1 . 1))) (assert-error (tn) (lambda () (define (f . x)))) (assert-error (tn) (lambda () (define (f . x) . 1))) (assert-error (tn) (lambda () (define (f . x) 1 . 1))) (tn "define syntactic keywords as value") (assert-error (tn) (lambda () (eval '(define syn define) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn if) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn and) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn cond) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn begin) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn do) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn delay) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn let*) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn else) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn =>) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn quote) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn quasiquote) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn unquote) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(define syn unquote-splicing) (interaction-environment)))) (tn "define syntactic keywords as value internally") (assert-error (tn) (lambda () (let () (define syn define) #t))) (assert-error (tn) (lambda () (let () (define syn if) #t))) (assert-error (tn) (lambda () (let () (define syn and) #t))) (assert-error (tn) (lambda () (let () (define syn cond) #t))) (assert-error (tn) (lambda () (let () (define syn begin) #t))) (assert-error (tn) (lambda () (let () (define syn do) #t))) (assert-error (tn) (lambda () (let () (define syn delay) #t))) (assert-error (tn) (lambda () (let () (define syn let*) #t))) (assert-error (tn) (lambda () (let () (define syn else) #t))) (assert-error (tn) (lambda () (let () (define syn =>) #t))) (assert-error (tn) (lambda () (let () (define syn quote) #t))) (assert-error (tn) (lambda () (let () (define syn quasiquote) #t))) (assert-error (tn) (lambda () (let () (define syn unquote) #t))) (assert-error (tn) (lambda () (let () (define syn unquote-splicing) #t))) (tn "define syntactic keyword internally") (assert-equal? (tn) 7 ((lambda () (define else 7) else))) (assert-equal? (tn) 8 ((lambda () (define => 8) =>))) (assert-equal? (tn) 9 ((lambda () (define do 9) do))) (assert-error (tn) (lambda () else)) (assert-error (tn) (lambda () =>)) (assert-error (tn) (lambda () do)) (tn "define syntactic keyword as top-level variable") (define else 3) (assert-equal? (tn) 3 else) (define => 4) (assert-equal? (tn) 4 =>) (define do 5) (assert-equal? (tn) 5 do) (if (and sigscheme? (provided? "strict-argcheck")) (begin (tn "define function form: boolean as an arg") (assert-error (tn) (lambda () (define (f . #t) #t))) (assert-error (tn) (lambda () (define (f #t) #t))) (assert-error (tn) (lambda () (define (f x #t) #t))) (assert-error (tn) (lambda () (define (f #t x) #t))) (assert-error (tn) (lambda () (define (f x . #t) #t))) (assert-error (tn) (lambda () (define (f #t . x) #t))) (assert-error (tn) (lambda () (define (f x y #t) #t))) (assert-error (tn) (lambda () (define (f x y . #t) #t))) (assert-error (tn) (lambda () (define (f x #t y) #t))) (assert-error (tn) (lambda () (define (f x #t . y) #t))) (tn "define function form: intger as an arg") (assert-error (tn) (lambda () (define (f . 1) #t))) (assert-error (tn) (lambda () (define (f 1) #t))) (assert-error (tn) (lambda () (define (f x 1) #t))) (assert-error (tn) (lambda () (define (f 1 x) #t))) (assert-error (tn) (lambda () (define (f x . 1) #t))) (assert-error (tn) (lambda () (define (f 1 . x) #t))) (assert-error (tn) (lambda () (define (f x y 1) #t))) (assert-error (tn) (lambda () (define (f x y . 1) #t))) (assert-error (tn) (lambda () (define (f x 1 y) #t))) (assert-error (tn) (lambda () (define (f x 1 . y) #t))) (tn "define function form: null as an arg") (assert-true (tn) (define (f . ()) #t)) (assert-error (tn) (lambda () (define (f ()) #t))) (assert-error (tn) (lambda () (define (f x ()) #t))) (assert-error (tn) (lambda () (define (f () x) #t))) (assert-true (tn) (define (f x . ()) #t)) (assert-error (tn) (lambda () (define (f () . x) #t))) (assert-error (tn) (lambda () (define (f x y ()) #t))) (assert-true (tn) (define (f x y . ()) #t)) (assert-error (tn) (lambda () (define (f x () y) #t))) (assert-error (tn) (lambda () (define (f x () . y) #t))) (tn "define function form: pair as an arg") (assert-true (tn) (define (f . (a)) #t)) (assert-error (tn) (lambda () (define (f (a)) #t))) (assert-error (tn) (lambda () (define (f x (a)) #t))) (assert-error (tn) (lambda () (define (f (a) x) #t))) (assert-true (tn) (define (f x . (a)) #t)) (assert-error (tn) (lambda () (define (f (a) . x) #t))) (assert-error (tn) (lambda () (define (f x y (a)) #t))) (assert-true (tn) (define (f x y . (a)) #t)) (assert-error (tn) (lambda () (define (f x (a) y) #t))) (assert-error (tn) (lambda () (define (f x (a) . y) #t))) (tn "define function form: char as an arg") (assert-error (tn) (lambda () (define (f . #\a) #t))) (assert-error (tn) (lambda () (define (f #\a) #t))) (assert-error (tn) (lambda () (define (f x #\a) #t))) (assert-error (tn) (lambda () (define (f #\a x) #t))) (assert-error (tn) (lambda () (define (f x . #\a) #t))) (assert-error (tn) (lambda () (define (f #\a . x) #t))) (assert-error (tn) (lambda () (define (f x y #\a) #t))) (assert-error (tn) (lambda () (define (f x y . #\a) #t))) (assert-error (tn) (lambda () (define (f x #\a y) #t))) (assert-error (tn) (lambda () (define (f x #\a . y) #t))) (tn "define function form: string as an arg") (assert-error (tn) (lambda () (define (f . "a") #t))) (assert-error (tn) (lambda () (define (f "a") #t))) (assert-error (tn) (lambda () (define (f x "a") #t))) (assert-error (tn) (lambda () (define (f "a" x) #t))) (assert-error (tn) (lambda () (define (f x . "a") #t))) (assert-error (tn) (lambda () (define (f "a" . x) #t))) (assert-error (tn) (lambda () (define (f x y "a") #t))) (assert-error (tn) (lambda () (define (f x y . "a") #t))) (assert-error (tn) (lambda () (define (f x "a" y) #t))) (assert-error (tn) (lambda () (define (f x "a" . y) #t))) (tn "define function form: vector as an arg") (assert-error (tn) (lambda () (define (f . #(a)) #t))) (assert-error (tn) (lambda () (define (f #(a)) #t))) (assert-error (tn) (lambda () (define (f x #(a)) #t))) (assert-error (tn) (lambda () (define (f #(a) x) #t))) (assert-error (tn) (lambda () (define (f x . #(a)) #t))) (assert-error (tn) (lambda () (define (f #(a) . x) #t))) (assert-error (tn) (lambda () (define (f x y #(a)) #t))) (assert-error (tn) (lambda () (define (f x y . #(a)) #t))) (assert-error (tn) (lambda () (define (f x #(a) y) #t))) (assert-error (tn) (lambda () (define (f x #(a) . y) #t))))) (tn "top-level definition invalid forms") ;; top-level define cannot be placed under a non-begin structure. ;; See also test-begin.scm for top-level definitions. (if (provided? "strict-toplevel-definitions") (begin (assert-error (tn) (lambda () (eval '(if #t (define var0 1)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(if #f #t (define var0 1)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(and (define var0 1)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(or (define var0 1)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (#t (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (else (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key ((key) (define var0 1))) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (else (define var0 1))) (interaction-environment)))) (tn "ttt") ;; test being evaled at non-tail part of (assert-error (tn) (lambda () (eval '(and (define var0 1) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(or (define var0 1) #t) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (#t (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(cond (else (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key ((key) (define var0 1) #t)) (interaction-environment)))) (assert-error (tn) (lambda () (eval '(case 'key (else (define var0 1) #t)) (interaction-environment)))))) ; basic define (define val1 3) (assert-equal? "basic define check" 3 val1) ; redefine (define val1 5) (assert-equal? "redefine check" 5 val1) ; define lambda (define (what? x) "DEADBEEF" x) (assert-equal? "func define" 10 (what? 10)) (define what2? (lambda (x) "DEADBEEF" x)) (assert-equal? "func define" 10 (what2? 10)) (define (nullarg) "nullarg") (assert-equal? "nullarg test" "nullarg" (nullarg)) (define (add x y) (+ x y)) (assert-equal? "func define" 10 (add 2 8)) ; tests for dot list arguments (define (dotarg1 . a) a) (assert-equal? "dot arg test 1" '(1 2) (dotarg1 1 2)) (define (dotarg2 a . b) a) (assert-equal? "dot arg test 2" 1 (dotarg2 1 2)) (define (dotarg3 a . b) b) (assert-equal? "dot arg test 3" '(2) (dotarg3 1 2)) (assert-equal? "dot arg test 4" '(2 3) (dotarg3 1 2 3)) (define (dotarg4 a b . c) b) (assert-equal? "dot arg test 5" 2 (dotarg4 1 2 3)) (define (dotarg5 a b . c) c) (assert-equal? "dot arg test 6" '(3 4) (dotarg5 1 2 3 4)) ; set! (define (set-dot a . b) (set! b '(1 2)) b) (assert-equal? "set dot test" '(1 2) (set-dot '())) ; test for internal define ; more comprehensive tests are written at test-define-internal.scm (define (idefine-o a) (define (idefine-i c) (+ c 3)) (idefine-i a)) (assert-equal? "internal define1" 5 (idefine-o 2)) (define (idefine0 a) (define (idefine1 . args) (apply + args)) (define (idefine2 c) (+ c 2)) (+ (idefine1 1 2 3 4 5) (idefine2 a))) (assert-equal? "internal define2" 17 (idefine0 0)) (total-report) uim-1.8.8/sigscheme/test/bigloo-bool.scm0000644000175000017500000001364112532333147015111 00000000000000;; A practical implementation for the Scheme programming language ;; ;; ,--^, ;; _ ___/ /|/ ;; ,;'( )__, ) ' ;; ;; // L__. ;; ' \\ / ' ;; ^ ^ ;; ;; Copyright (c) 1992-2004 Manuel Serrano ;; ;; Bug descriptions, use reports, comments or suggestions are ;; welcome. Send them to ;; bigloo@sophia.inria.fr ;; http://www.inria.fr/mimosa/fp/Bigloo ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. More precisely, ;; ;; - The compiler and the tools are distributed under the terms of the ;; GNU General Public License. ;; ;; - The Bigloo run-time system and the libraries are distributed under ;; the terms of the GNU Library General Public License. The source code ;; of the Bigloo runtime system is located in the ./runtime directory. ;; The source code of the FairThreads library is located in the ;; ./fthread directory. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;*---------------------------------------------------------------------*/ ;* serrano/prgm/project/bigloo/recette/bool.scm */ ;* */ ;* Author : Manuel Serrano */ ;* Creation : Tue Nov 3 09:16:12 1992 */ ;* Last change : Wed Apr 1 14:05:49 1998 (serrano) */ ;* */ ;* On test les operations booleenes. */ ;*---------------------------------------------------------------------*/ ;; ChangeLog ;; ;; 2005-08-18 kzk Copied from Bigloo 2.6e and adapted to SigScheme (load "./test/unittest-bigloo.scm") ;*---------------------------------------------------------------------*/ ;* predicat ... */ ;*---------------------------------------------------------------------*/ (define (predicat x) (> x 5)) ;*---------------------------------------------------------------------*/ ;* faux-predicat ... */ ;*---------------------------------------------------------------------*/ (define (faux-predicat x) (> x 5)) ;*---------------------------------------------------------------------*/ ;* encore-faux ... */ ;*---------------------------------------------------------------------*/ (define (encore-faux x) (> x 5)) ;*---------------------------------------------------------------------*/ ;* local-pred-1 ... */ ;*---------------------------------------------------------------------*/ (define (local-pred-1 x) (let ((pred (lambda (x) (< x 3)))) (if (pred x) #t #f))) ;*---------------------------------------------------------------------*/ ;* local-pred-2 ... */ ;*---------------------------------------------------------------------*/ (define (local-pred-2 x) (let* ((foo (lambda (x) (< x 3))) (bar (lambda (x) (if (foo x) 3 4))) (gee (lambda (x) (if (foo x) 3 4)))) bar gee (if (foo x) #t #f))) ;*---------------------------------------------------------------------*/ ;* local-pred-3 ... */ ;*---------------------------------------------------------------------*/ (define (local-pred-3 x) (let ((pred (lambda (x) (< x 3)))) (pred x))) ;*---------------------------------------------------------------------*/ ;* test-bool ... */ ;*---------------------------------------------------------------------*/ (define (test-bool) (test "or" (or #f #f) #f) (test "not" (not #f) #t) (test "and" (and #t #t) #t) (test "and" (and #t #f) #f) (test "if" (let ((x 1)) (if x x)) 1) (test "ifnot" (let ((x 1)) (if (not x) #t #f)) #f) (test "ifor" (let ((x 1) (y #f)) (if (or x y) x y)) 1) (test "ifand" (let ((x 1) (y #f)) (if (and x y) #t #f)) #f) (test "pred" (if (predicat 6) #t #f) #t) (test "faux" (if (faux-predicat 6) (faux-predicat 7) (faux-predicat 3)) #t) (test "encore-faux" (if (encore-faux 6) #t #f) #t) (test "local-pred-1" (local-pred-1 1) #t) (test "local-pred-2" (local-pred-2 1) #t) (test "local-pred-3" (if (local-pred-3 1) #t #f) #t)) (test-bool) (total-report) uim-1.8.8/sigscheme/test/test-srfi38.scm0000644000175000017500000001010312532333147014766 00000000000000;; Filename : test-srfi38.scm ;; About : unit test for SRFI-38 ;; ;; Copyright (C) 2005-2006 Kazuki Ohta ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (require-extension (srfi 6 38)) (if (not (provided? "srfi-38")) (test-skip "SRFI-38 is not enabled")) (define tn test-name) (if (not (symbol-bound? 'cadddr)) (define cadddr (lambda (lst) (caddr (cdr lst))))) (tn "write/ss short-name alias") (if sigscheme? (begin (assert-true (tn) (symbol-bound? 'write/ss)) (assert-true (tn) (string-eval "(eq? write/ss write-with-shared-structure)")))) (tn "write/ss invalid form") (assert-error (tn) (lambda () (write-with-shared-structure))) (assert-error (tn) (lambda () (write-with-shared-structure #f . (current-output-port)))) (assert-error (tn) (lambda () (write-with-shared-structure #f (current-output-port) . #t))) (if sigscheme? (assert-error (tn) (lambda () (write-with-shared-structure #f (current-output-port) #t . #t)))) (tn "write/ss with implicit port") (print-expected "\"abc\"") (write-with-shared-structure "abc") (newline) (tn "write/ss with explicit port arg") (let* ((outs (open-output-string)) (s "abc") (convolution `(,s 1 #(,s b) ,(list 2) () ,s))) ; go crazy with mutators (set-car! (cdr convolution) convolution) (vector-set! (caddr convolution) 1 (cddr convolution)) (set-cdr! (cadddr convolution) (cdr convolution)) (write-with-shared-structure convolution outs) (assert-equal? (tn) "#1=(#2=\"abc\" . #3=(#1# . #4=(#(#2# #4#) (2 . #3#) () #2#)))" (get-output-string outs))) (let* ((outs (open-output-string)) (a-pair (cons 'kar 'kdr)) (convolution (eval (list 'lambda () a-pair) (scheme-report-environment 5)))) (set-cdr! a-pair convolution) (write-with-shared-structure convolution outs) (assert-equal? (tn) "#1=#" (get-output-string outs))) (tn "write/ss with explicit port arg and optarg") (let ((p (open-output-string))) (write-with-shared-structure "abc" p #t) (assert-equal? (tn) "\"abc\"" (get-output-string p))) (if sigscheme? (let ((p (open-output-string))) (write-with-shared-structure "abc" p #t #t) ;; accepts 2+ optarg (assert-equal? (tn) "\"abc\"" (get-output-string p)))) (total-report) uim-1.8.8/sigscheme/test/test-bool.scm0000644000175000017500000001732612532333147014621 00000000000000#! /usr/bin/env sscm -C UTF-8 ;; -*- buffer-file-coding-system: utf-8 -*- ;; Filename : test-bool.scm ;; About : unit tests for boolean ;; ;; Copyright (C) 2006 YAMAMOTO Kengo ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (define tn test-name) ;; To sense boolean values accurately, these tests use '(assert-true (if ;; #t #f))' form to test a boolean expression instead of '(assert-true )' ;; of '(assert-equal? #t )'. -- YamaKen 2006-09-07 (tn "R5RS upper-case boolean literal") (if (provided? "sigscheme") (begin ;; not supported by SigScheme (assert-parse-error (tn) "#F") (assert-parse-error (tn) "#T")) (begin (assert-false (tn) (if (string-read "#F") #t #f)) (assert-true (tn) (if (string-read "#T") #t #f)))) (tn "boolean self-evaluation") (assert-true (tn) (eq? #f '#f)) (assert-true (tn) (eq? #t '#t)) (tn "boolean values") (assert-false (tn) (if #f #t #f)) (assert-true (tn) (if #t #t #f)) (if (and (provided? "sigscheme") (provided? "siod-bugs")) (begin (assert-false (tn) '()) (assert-true (tn) (eq? #f '()))) (begin (assert-true (tn) '()) (assert-false (tn) (eq? #f '())))) (if (provided? "sigscheme") (begin (assert-true (tn) (if (eof) #t #f)) (assert-true (tn) (if (undef) #t #f)))) (assert-true (tn) (if 0 #t #f)) (assert-true (tn) (if 1 #t #f)) (assert-true (tn) (if 3 #t #f)) (assert-true (tn) (if -1 #t #f)) (assert-true (tn) (if -3 #t #f)) (assert-true (tn) (if 'symbol #t #f)) (assert-true (tn) (if 'SYMBOL #t #f)) (assert-true (tn) (if #\a #t #f)) (assert-true (tn) (if #\ã‚ #t #f)) (assert-true (tn) (if "" #t #f)) (assert-true (tn) (if " " #t #f)) (assert-true (tn) (if "a" #t #f)) (assert-true (tn) (if "A" #t #f)) (assert-true (tn) (if "aBc12!" #t #f)) (assert-true (tn) (if "ã‚" #t #f)) (assert-true (tn) (if "ã‚0イã†12!" #t #f)) (assert-true (tn) (if + #t #f)) (assert-true (tn) (if (lambda () #t) #t #f)) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (if else #t #f))) ;; expression keyword (assert-error (tn) (lambda () (if do #t #f))))) (call-with-current-continuation (lambda (k) (assert-true (tn) (if k #t #f)))) (assert-true (tn) (if (current-output-port) #t #f)) (assert-true (tn) (if '(#t . #t) #t #f)) (assert-true (tn) (if (cons #t #t) #t #f)) (assert-true (tn) (if '(0 1 2) #t #f)) (assert-true (tn) (if (list 0 1 2) #t #f)) (assert-true (tn) (if '#() #t #f)) (assert-true (tn) (if (vector) #t #f)) (assert-true (tn) (if '#(0 1 2) #t #f)) (assert-true (tn) (if (vector 0 1 2) #t #f)) (tn "not") ;; 'not' must return exact #t ;; > R5RS: 6.3 Other data types ;; > `Not' returns #t if obj is false, and returns #f otherwise. (assert-eq? (tn) #t (not #f)) (assert-eq? (tn) #f (not #t)) (if (and (provided? "sigscheme") (provided? "siod-bugs")) (assert-eq? (tn) #t (not '())) (assert-eq? (tn) #f (not '()))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (not (eof))) (assert-eq? (tn) #f (not (undef))))) (assert-eq? (tn) #f (not 0)) (assert-eq? (tn) #f (not 1)) (assert-eq? (tn) #f (not 3)) (assert-eq? (tn) #f (not -1)) (assert-eq? (tn) #f (not -3)) (assert-eq? (tn) #f (not 'symbol)) (assert-eq? (tn) #f (not 'SYMBOL)) (assert-eq? (tn) #f (not #\a)) (assert-eq? (tn) #f (not #\ã‚)) (assert-eq? (tn) #f (not "")) (assert-eq? (tn) #f (not " ")) (assert-eq? (tn) #f (not "a")) (assert-eq? (tn) #f (not "A")) (assert-eq? (tn) #f (not "aBc12!")) (assert-eq? (tn) #f (not "ã‚")) (assert-eq? (tn) #f (not "ã‚0イã†12!")) (assert-eq? (tn) #f (not +)) (assert-eq? (tn) #f (not (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (not else))) ;; expression keyword (assert-error (tn) (lambda () (not do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (not k)))) (assert-eq? (tn) #f (not (current-output-port))) (assert-eq? (tn) #f (not '(#t . #t))) (assert-eq? (tn) #f (not (cons #t #t))) (assert-eq? (tn) #f (not '(0 1 2))) (assert-eq? (tn) #f (not (list 0 1 2))) (assert-eq? (tn) #f (not '#())) (assert-eq? (tn) #f (not (vector))) (assert-eq? (tn) #f (not '#(0 1 2))) (assert-eq? (tn) #f (not (vector 0 1 2))) (tn "boolean?") (assert-eq? (tn) #t (boolean? #f)) (assert-eq? (tn) #t (boolean? #t)) (if (and (provided? "sigscheme") (provided? "siod-bugs")) (assert-eq? (tn) #t (boolean? '())) (assert-eq? (tn) #f (boolean? '()))) (if (provided? "sigscheme") (begin (assert-eq? (tn) #f (boolean? (eof))) (assert-eq? (tn) #f (boolean? (undef))))) (assert-eq? (tn) #f (boolean? 0)) (assert-eq? (tn) #f (boolean? 1)) (assert-eq? (tn) #f (boolean? 3)) (assert-eq? (tn) #f (boolean? -1)) (assert-eq? (tn) #f (boolean? -3)) (assert-eq? (tn) #f (boolean? 'symbol)) (assert-eq? (tn) #f (boolean? 'SYMBOL)) (assert-eq? (tn) #f (boolean? #\a)) (assert-eq? (tn) #f (boolean? #\ã‚)) (assert-eq? (tn) #f (boolean? "")) (assert-eq? (tn) #f (boolean? " ")) (assert-eq? (tn) #f (boolean? "a")) (assert-eq? (tn) #f (boolean? "A")) (assert-eq? (tn) #f (boolean? "aBc12!")) (assert-eq? (tn) #f (boolean? "ã‚")) (assert-eq? (tn) #f (boolean? "ã‚0イã†12!")) (assert-eq? (tn) #f (boolean? +)) (assert-eq? (tn) #f (boolean? (lambda () #t))) ;; syntactic keywords should not be appeared as operand (if sigscheme? (begin ;; pure syntactic keyword (assert-error (tn) (lambda () (boolean? else))) ;; expression keyword (assert-error (tn) (lambda () (boolean? do))))) (call-with-current-continuation (lambda (k) (assert-eq? (tn) #f (boolean? k)))) (assert-eq? (tn) #f (boolean? (current-output-port))) (assert-eq? (tn) #f (boolean? '(#t . #t))) (assert-eq? (tn) #f (boolean? (cons #t #t))) (assert-eq? (tn) #f (boolean? '(0 1 2))) (assert-eq? (tn) #f (boolean? (list 0 1 2))) (assert-eq? (tn) #f (boolean? '#())) (assert-eq? (tn) #f (boolean? (vector))) (assert-eq? (tn) #f (boolean? '#(0 1 2))) (assert-eq? (tn) #f (boolean? (vector 0 1 2))) (total-report) uim-1.8.8/sigscheme/test/test-syntax-rules.scm0000644000175000017500000007527112532333147016347 00000000000000;; Filename : test-syntax-rules.scm ;; About : unit test for R5RS hygienic macro ;; ;; Copyright (C) 2006 Jun Inoue ;; Copyright (c) 2007-2008 SigScheme Project ;; ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of authors nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS ;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require-extension (unittest)) (if (not (symbol-bound? 'syntax-rules)) (test-skip "R5RS hygienic macros is not enabled")) ;; Uncomment these if the interpreter crashes somewhere ; (define-syntax assert-equal? ; (syntax-rules () ; ((_ name expected expr) ; (begin ; (display name)(newline) ; (assert name name (equal? expected expr)))))) ; (define-syntax assert-eq? ; (syntax-rules () ; ((_ name expected expr) ; (begin ; (display name)(newline) ; (assert name name (eq? expected expr)))))) (assert-eq? "syntax-rules unwrap in quote" 'syntax-rules (let-syntax ((macro (syntax-rules () ((_) 'syntax-rules)))) (macro))) (assert-equal? "syntax-rules unwrap in quote inside recursive macro" '(,#(bad) ,(bar . baz) ,foo) (letrec-syntax ((foo (syntax-rules () ((_ datum) (bar datum)) ((_ (parts ...) arg args ...) (foo (,arg parts ...) args ...)))) (bar (syntax-rules () ((_ datum) 'datum)))) (foo () foo (bar . baz) #(bad)))) (assert-equal? "syntax-rules unwrap in quasiquote (lists)" '(sym (sym . sym) (quasiquote ((unquote sym) unquote sym)) ((quasiquote (unquote-splicing sym))) (0 0 . 0)) (let ((sym 0)) (let-syntax ((macro (syntax-rules () ((_) (list `sym `(sym . sym) ``(,sym . ,sym) `(`,@sym) `(,@(list sym) ,sym . ,sym)))))) (macro)))) (assert-equal? "syntax-rules unwrap in quasiquote (vectors)" '(#() #(sym) #(sym 0) #((quasiquote (unquote sym)) 0)) (let ((sym 0)) (let-syntax ((macro (syntax-rules () ((_) (list `#() `#(sym) `#(sym ,sym) `#(`,sym ,@(list sym))))))) (macro)))) (assert-equal? "syntax-rules unwrap in case" 'ok (let ((f (lambda () 'f))) (let-syntax ((macro (syntax-rules () ((_ key) (case key ((0 f) 'ok) (else 'nok)))))) (macro (f))))) (assert-equal? "syntax-rules unwrap in case (else clause)" 'ok (letrec ((f (lambda () f))) (let-syntax ((macro (syntax-rules () ((_ key) (case key ((0 f) 'nok) (else 'ok)))))) (macro (f))))) (assert-equal? "syntax-rules pattern matching" '(match match match match2 match3 match3 match3) (let-syntax ((macro (syntax-rules () ((_ #() "abc" def ...) 'match) ((_ #(b ...) "abc" (1)) 'match2) ((_ a ...) 'match3) ((_ . _) 'mismatch)))) (list (macro #() "abc" 0 1 a b 2) (macro #() "abc") (macro #() "abc" (1)) (macro #("") "abc" (1)) (macro 0 1 2) (macro #() ()) (macro)))) (assert-equal? "syntax-rules pattern matching 2" '(match mismatch match mismatch mismatch) (let-syntax ((macro (syntax-rules () ((_ (a ...)) 'match) ((_ . _) 'mismatch)))) (list (macro (0 1 2)) (macro (3 4 . 5)) (macro ()) (macro #()) (macro)))) (assert-equal? "syntax-rules repeatable subpattern" '(((0 3) (1 4) (2 5) 0 1 2) ((6 8) (7 9) 6 7) ()) (let-syntax ((macro (syntax-rules () ((_ ((a ...) (b ...)) ...) '(((a b) ... a ...) ...))))) (macro ((0 1 2) (3 4 5)) ((6 7) (8 9)) (() ())))) (assert-equal? "syntax-rules repeatable subpattern 2" '(((1 2 1 2 0) (4 4 3)) ((6 7 6 7 5) (8))) (let-syntax ((macro (syntax-rules () ((_ ((b a ...) ...) ...) '(((a ... a ... b) ...) ...))))) (macro ((0 1 2) (3 4)) ((5 6 7) (8))))) (assert-equal? "syntax-rules repeatable subpattern matched against improper list" 'mismatch (let-syntax ((macro (syntax-rules () ((_ (a ...)) 'match) ((_ . _) 'mismatch)))) (macro (0 1 . 2)))) ;; Pop quiz! What does LISP stand for? (assert-equal? "syntax-rules deeply nested ellipses" '( (()) ((((((((((((((((((((((1 2) (1 2)) (() ()) (#(3) #(3)) (4 4) (5 5) 0)))))))))))))))))))) #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(((1 2) (1 2)) (#(3) #(3)) (4 4) (5 5) 0)))))))))))))))))))) mismatch mismatch mismatch mismatch ) (let-syntax ((macro (syntax-rules () ; Make the nests deeper if you've increased ; DEFAULT_INDEX_BUF_SIZE in macro.c. ((_ (((((((((((((((((((a b ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)...) ; 20 deep '(((((((((((((((((((((b b) ... a) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) ((_ #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(a b ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) '#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#((b b) ... a) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) ((_ . _) 'mismatch) ))) (list (macro ()) (macro (((((((((((((((((((0 (1 2) () #(3) 4 5)))))))))))))))))))) (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 (1 2) #(3) 4 5))))))))))))))))))))) (macro ((((((((((((((((((0 (1 2) () #(3) 4 5))))))))))))))))))) ; too shallow (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 (1 2) #(3) 4 5)))))))))))))))))))) (macro (((((((((((((((((((0 (1 2) () #(3) 4 5) 6))))))))))))))))))) ; 6 doesn't match (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 (1 2) #(3) 4 5) 6)))))))))))))))))))) ) )) ;; The buffer is re-allocated twice for these (assert-equal? "syntax-rules more deeply nested ellipses" '(() (((((((((((((((((((((((((((((((((((1 1) ((2 . 3) (2 . 3)) (#(4) #(4)) (() ()) 0)))) ())))))))))))))) ())))))))))))))))) #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#((1 1) ((2 . 3) (2 . 3)) (#(4) #(4)) (() ()) 0)) #())))))))))))))))) #())))))))))))))))) mismatch mismatch mismatch mismatch) (let-syntax ((macro (syntax-rules () ;; Should be at least ;; DEFAULT_INDEX_BUF_SIZE * 2 + 1 levels ((_ ((((((((((((((((((((((((((((((((((a b ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) ; 33 deep '(((((((((((((((((((((((((((((((((((b b) ... a) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) ((_ #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(a b ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) '#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#((b b) ... a) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...) ...)) ((_ . _) 'mismatch) ))) (list (macro ()) (macro ((((((((((((((((((((((((((((((((((0 1 (2 . 3) #(4) ())))) ())))))))))))))) ()))))))))))))))))) (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 1 (2 . 3) #(4) ())) #())))))))))))))))) #()))))))))))))))))) (macro (((((((((((((((((((((((((((((((((0 1 (2 . 3) #(4) ()))))))))))))))))) ()))))))))))))))))) ; too shallow (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 1 (2 . 3) #(4) ())) #()))))))))))))))) #()))))))))))))))))) (macro ((((((((((((((((((((((((((((((((((0 1 (2 . 3) #(4) ()) 5))) ())))))))))))))) ()))))))))))))))))) ; 5 doesn't match (macro #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(0 1 (2 . 3) #(4) ()) 5) #())))))))))))))))) #()))))))))))))))))) ))) (assert-equal? "syntax-rules repeatable subpattern inside vector" '(((0 3) (1 4) (2 5)) ()) (let-syntax ((macro (syntax-rules () ((_ #((a ...) (b ...)) ...) '(((a b) ...) ...)) ((_ . else) 'mismatch)))) (macro #((0 1 2) (3 4 5)) #(() ())))) (assert-equal? "syntax-rules ability to discern #(a ...) and #((a ...))" '(a-1 a-2 b-1 b-2) (let-syntax ((macro-a (syntax-rules () ((_ #(0 ...)) 'a-1) ((_ #((0 ...))) 'a-2) ((_ . else) 'mismatch))) (macro-b (syntax-rules () ((_ #((0 ...))) 'b-1) ((_ #(0 ...)) 'b-2) ((_ . else) 'mismatch)))) (list (macro-a #(0)) (macro-a #((0))) (macro-b #((0))) (macro-b #(0))))) (assert-equal? "syntax-rules basic hygiene" '(0 1 2) (let ((x 0)) (let-syntax ((macro (syntax-rules () ((_ arg) (cons x (let ((x 1)) (list x arg))))))) (let ((x 2)) (macro x))))) (assert-equal? "syntax-rules literals" '(ex mismatch) (let ((x 'ex) (y 'why)) (let-syntax ((macro (syntax-rules (x y) ((_ x) x) ((_ y) y) ((_ a) 'mismatch)))) (let ((y 1)) (list (macro x) (macro y)))))) (define-syntax tl-macro (syntax-rules (x) ((_ x) 'match) ((_ y) 'mismatch))) (assert-equal? "syntax-rules literals 2" '(match mismatch mismatch (match mismatch)) (list (tl-macro x) (tl-macro z) (let ((x 0)) (tl-macro x)) (let-syntax ((foo (syntax-rules () ((_) (tl-macro x)))) (bar (syntax-rules () ((_) (tl-macro z))))) (list (foo) (bar))))) (assert-equal? "syntax-rules literals in nested macro" 'mismatch (let-syntax ((foo (syntax-rules () ((_) (let-syntax ((insert (syntax-rules () ((_ ex) (let ((x 0)) (let-syntax ((macro (syntax-rules (x) ((_ x) 'match) ((_ _) 'mismatch)))) (macro ex))))))) (insert x)))))) (foo))) (assert-equal? "syntax-rules literals in nested macro 2" 'match ;; the y in (foo y) and x in (_ x) are both timestamped ;; once but at different times (let-syntax ((baz (syntax-rules () ((_ arg) (let-syntax ((bar (syntax-rules () ((_ y) (let-syntax ((foo (syntax-rules (x) ((_ x) 'match) ((_ _) 'mismatch)))) (foo y)))))) (bar arg)))))) (baz x)) ) (assert-equal? "syntax-rules hygiene in simple recursion" '(0 1 2) (let ((x 2)) (letrec-syntax ((foo (syntax-rules () ((_ x) (cons x (let ((x 1)) (bar x)))) ((_ y %) (list y)))) (bar (syntax-rules () ((_ arg) (cons arg (foo x %)))))) (let ((x 0)) (foo x))))) (assert-equal? "syntax-rules binding of symbol passed to submacro via vector" '(0 1 2) (let ((y 0)) (let-syntax ((foo (syntax-rules () ((_ x) (let-syntax ((bar (syntax-rules () ((_ #(a b c)) (list a b c))))) (let ((t 2)) (bar #(y x t)))))))) (let ((z 1)) (foo z))))) (assert-equal? "syntax-rules binding of symbol passed to submacro via literal expression" '(0 1) (let-syntax ((foo (syntax-rules () ((_ a) (let-syntax ((bar (syntax-rules () ((_ '(b c)) (list b c))))) (let ((x 1)) (bar '(a x)))))))) (let ((x 0)) (foo x)))) (assert-equal? "syntax-rules heavy recursion" '(0 1 2 3 4) (let ((x 0)) (letrec-syntax ((foo (syntax-rules (x z) ((_ x) (cons x (bar 1))) ((_ z) 'bindings-disregarded) ((_ y) (cons y (bar x))) ((_) (cons 4 (bar))) ((_ . _) 'foo-mismatch))) (bar (syntax-rules (x) ((_ x) (cons 3 (foo))) ((_ y) (cons y (let ((z 2)) (foo z)))) ((_) '())))) (foo x)))) (assert-equal? "syntax-rules whether literal identifier comparison is sensitive to binding" '(0 #f) (let ((sym 0)) (let-syntax ((macro (syntax-rules (sym) ((_ sym) sym) ((_ . *) #f)))) (list (macro sym) (let ((sym 1)) (macro sym)))))) (assert-equal? "syntax-rules renamed identifier in " '(mismatch match mismatch match match mismatch) (let-syntax ((macro (syntax-rules () ((_ a b c) (let ((x 0) (b 0)) (let-syntax ((lx (syntax-rules (x) ((_ x) 'match) ((_ s) 'mismatch))) (ly (syntax-rules (y) ((_ y) 'match) ((_ s) 'mismatch))) (lz (syntax-rules (z) ((_ z) 'match) ((_ s) 'mismatch)))) (let ((z 0)) (list (lx a) (lx x) (ly b) (ly y) (lz c) (lz z) )))) ) ))) (macro x y z))) (assert-equal? "syntax-rules doubly time-stamped identifier in " 'match (let-syntax ((foo (syntax-rules () ((_ a) (let-syntax ((bar (syntax-rules () ((_ b) (let-syntax ((baz (syntax-rules (x) ((_ x) 'match) ((_ s) 'mismatch)))) (baz b)))))) (bar a)))))) (foo x))) (assert-equal? "syntax-rules identifier from macro use in " '(ay ex ay ex) (let-syntax ((foo (syntax-rules () ((_ a) (let-syntax ((bar (syntax-rules (a) ((_ a) 'ay) ((_ x) 'ex) ((_ y) 'mismatch)))) (list (bar a) (let ((a 0)) (bar a)) (bar x) (let ((x 0)) (bar x))) ))))) (foo x))) ;; An identifier in and another in are considered ;; identical only if they're eq? assuming the renaming rules outlined ;; in src/macro.c. (assert-equal? "syntax-rules comparing id in with another in pattern" '(match match) (let-syntax ((foo (syntax-rules () ((_ a) (let-syntax ((ax (syntax-rules (a) ((_ x) 'match) ((_ s) 'mismatch))) (xa (syntax-rules (x) ((_ a) 'match) ((_ s) 'mismatch)))) (list (ax !?) (xa !?))))))) (foo x))) (assert-equal? "syntax-rules pattern in with same name as one in