conservatory
/
vx-scheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

initial import 

git-svn-id: svn://localhost/root/svnrepo/trunk@2 bee25f81-8ba7-4b93-944d-dfac3d1a11cc
This commit is contained in:
colin.smith 2006-08-12 19:00:13 +00:00
parent ce7d25b3e5
commit 839e25059a
114 changed files with 25051 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
vx-scheme/LICENSE Normal file
View File

@ -0,0 +1,125 @@
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End

9
vx-scheme/README Executable file
View File

@ -0,0 +1,9 @@
Vx-Scheme: Copyright (c) 2002-2006 Colin Smith. See the file 'LICENSE'
for licensing information.
Contact the author at colin.smith@gmail.com
Point your browser at http://colin-smith.net/vx-scheme/ for documentation.
Thank you!

2
vx-scheme/lib/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
slib_101
slibcat

338
vx-scheme/lib/vx-scheme.init Normal file
View File

@ -0,0 +1,338 @@
;;; "vx-scheme.init" configuration template of *features* for Scheme -*-scheme-*-
;;; Author: Chris Gaskett
;;;
;;; This code is in the public domain.
;;; this version for vx-scheme under cygwin (at least)
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
;(define (scheme-implementation-type) 'vx-scheme)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
;(define (scheme-implementation-home-page)
; "http://colin-smith.net/vx-scheme/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
;(define (scheme-implementation-version) *version*)
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity) "")
; (case (software-type)
; ((UNIX) "/usr/local/src/scheme/")
; ((VMS) "scheme$src:")
; ((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
; (define library-vicinity
; (let ((library-path
; (or
; ;; Use this getenv if your implementation supports it.
; ; (getenv "SCHEME_LIBRARY_PATH")
; ;; Use this path if your scheme does not support GETENV
; ;; or if SCHEME_LIBRARY_PATH is not set.
; (case (software-type)
; ((UNIX) "/usr/local/lib/slib/")
; ((VMS) "lib$scheme:")
; ((MS-DOS) "C:\\SLIB\\")
; (else "")))))
; (lambda () library-path)))
;(define (library-vicinity) "/usr/local/lib/slib/")
(define (library-vicinity) "/usr/share/guile/slib/")
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define (home-vicinity) "")
; (define (home-vicinity)
; (let ((home (getenv "HOME")))
; (and home
; (case (software-type)
; ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
; (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
; home
; (string-append home "/")))
; (else home)))))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
;;; @TODO@ some of these are wrong
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
;; Scheme report features
; rev5-report ;conforms to
; eval ;R5RS two-argument eval
; values ;R5RS multiple values
; dynamic-wind ;R5RS dynamic-wind
; macro ;R5RS high level macros
delay ;has DELAY and FORCE
multiarg-apply ;APPLY can take more than 2 args.
char-ready?
; rationalize
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
rev4-report ;conforms to
ieee-p1178 ;conforms to
; rev3-report ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
; object-hash ;has OBJECT-HASH
; multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
;Floating-Point Arithmetic.
full-continuation ;can return multiple times
;; Other common features
; srfi ;srfi-0, COND-EXPAND finds all srfi-*
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
defmacro ;has Common Lisp DEFMACRO
; record ;has user defined data structures
; string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; sort
; pretty-print
; object->string
; format ;Common-lisp output formatting
; trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
; system ;posix (system <string>)
; getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; current-time ;returns time in seconds since 1/1/1970
;; Implementation Specific features
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port (current-output-port)))
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (FILE-EXISTS? <string>)
;; provided in custom version of vx-scheme
;;(define (file-exists? f) #f)
;;; (DELETE-FILE <string>)
(define (delete-file f) #f)
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg) #t)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
;;; "rationalize" adjunct procedures.
;;(define (find-ratio x e)
;; (let ((rat (rationalize x e)))
;; (list (numerator rat) (denominator rat))))
;;(define (find-ratio-between x y)
;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x0FFFFFFF)
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e)
(let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e)
(let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (defmacro:load <pathname>)
(slib:eval-load <pathname> defmacro:eval))
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display #\ cep) (write x cep)) args)
(newline cep))))
;;; define an error procedure for the library
;; error function in vx-scheme expects one string
;; so this is a copy of the warn function above
;;(define (slib:error . args)
;; (if (provided? 'trace) (print-call-stack (current-error-port)))
;; (apply error args))
(define slib:error
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Error: " cep)
(for-each (lambda (x) (display #\ cep) (write x cep)) args)
(newline cep))))
(define (make-exchanger obj)
(lambda (rep) (let ((old obj)) (set! obj rep) old)))
(define (open-file filename modes)
(case modes
((r rb) (open-input-file filename))
((w wb) (open-output-file filename))
(else (slib:error 'open-file 'mode? modes))))
(define (port? obj) (or (input-port? port) (output-port? port)))
(define (call-with-open-ports . ports)
(define proc (car ports))
(cond ((procedure? proc) (set! ports (cdr ports)))
(else (set! ports (reverse ports))
(set! proc (car ports))
(set! ports (reverse (cdr ports)))))
(let ((ans (apply proc ports)))
(for-each close-port ports)
ans))
(define (close-port port)
(cond ((input-port? port)
(close-input-port port)
(if (output-port? port) (close-output-port port)))
((output-port? port) (close-output-port port))
(else (slib:error 'close-port 'port? port))))
(define (browse-url url)
(define (try cmd end) (zero? (system (string-append cmd url end))))
(or (try "netscape-remote -remote 'openURL(" ")'")
(try "netscape -remote 'openURL(" ")'")
(try "netscape '" "'&")
(try "netscape '" "'")))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit (lambda args #f))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (load (string-append f ".scm")))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))

17
vx-scheme/lib/vx-slib-test.scm Normal file
View File

@ -0,0 +1,17 @@
(load "vx-scheme.init")
(defmacro (slib-test module expression expected-result)
`(begin
(require ,module)
(display (if (equal? ,expression ,expected-result)
"PASS"
"FAIL"))
(display ": ") (display ,module)
(newline)))
(slib-test 'sort (sorted? (sort '(6 5 7 4 8 3 9 1) <) <) #t)
(slib-test 'factor (factor 105) '(7 3 5))
(slib-test 'object->string (object->string '(2 3)) "(2 3)")

8
vx-scheme/src/.cvsignore Normal file
View File

@ -0,0 +1,8 @@
tmp[123]
vxs-interp
vxs-bootstrap
vx-scheme
vx-scheme.exe
_compiler.cpp
Scheme.ncb
Scheme.suo

179
vx-scheme/src/Makefile Executable file
View File

@ -0,0 +1,179 @@
VERSION = 0.7
PKG = vx-scheme-$(VERSION)
OBJ = cell.o ctx.o subr.o io.o symtab.o
# Three flavors
INTERP_OBJ = $(OBJ) interp.o
BOOTSTRAP_OBJ = $(OBJ) interp.o vm.o
VM_OBJ = $(OBJ) vm.o lib.o _library.o
VM_COMP_OBJ = $(VM_OBJ) _compiler.o
#
UNIX_OBJ = u-main.o
PROGRAM = vx-scheme
DEFVER = -DVERSION=$(VERSION)
CFLAGS = -ansi -g -O2 -fno-exceptions -fno-rtti -Wall $(DEFVER)
CC = gcc
TC = ../testcases
all: vxs-interp vx-scheme
vxs-interp: $(INTERP_OBJ) $(UNIX_OBJ)
$(CC) $(CFLAGS) -o $@ $^ -lstdc++ -lc -lm
vxs-bootstrap: $(BOOTSTRAP_OBJ) $(UNIX_OBJ)
$(CC) $(CFLAGS) -o $@ $^ -lstdc++ -lc -lm
vx-scheme: $(VM_COMP_OBJ) $(UNIX_OBJ)
$(CC) $(CFLAGS) -o $@ $^ -lstdc++ -lc -lm
_library.cpp _compiler.cpp: compiler.scm bootstrap.scm library.scm vxs-bootstrap
./vxs-bootstrap . < bootstrap.scm
# Build the standalone scheme compiler. This runs the compile-file.scm
# script on itself, producing c code, which is then compiled and linked.
scheme-compiler: $(VM_COMP_OBJ) $(UNIX_OBJ) compile-file.scm vx-scheme
./vx-scheme ./compile-file.scm < compile-file.scm \
> _compile-file.cpp
$(CC) $(CFLAGS) -c _compile-file.cpp
$(CC) -o $@ $(VM_COMP_OBJ) $(UNIX_OBJ) \
_compile-file.o -lstdc++ -lm
# Precompiled objects! Run the scheme-compiler to produce bytecode in
# C++ format, compile and link. The result is a standalone executable
# with no compiler, just the raw bytecode and the VM. This rule will
# build a standalone executable for anything in the testcases
# directory. Example: "make pi".
%: ../testcases/%.scm scheme-compiler
./scheme-compiler $< > _$(basename $(notdir $<)).cpp
$(CC) $(CFLAGS) -c _$(basename $(notdir $<)).cpp
$(CC) $(CFLAGS) -o $@ $(VM_OBJ) $(UNIX_OBJ) \
_$(basename $(notdir $<)).o -lstdc++ -lm
# Standard object compilation rule
%.o: %.cpp
$(CC) $(CFLAGS) -c $<
# warning: this clean is pretty thorough!
clean:
rm -f *.o *.a *.exe vxs-interp vxs-bootstrap vx-scheme
rm -f scheme-compiler
rm -f _compile-file.cpp _*.cpp
find .. -name '*~' -print | xargs rm -f
find .. -name '#*#' -print | xargs rm -f
find .. -name '.#*' -print | xargs rm -f
rm -rf $(TC)/*.out $(TC)/tmp[123]
rm -rf *.core *.stackdump $(TC)/*.core $(TC)/*.stackdump
rm -rf ../tornado/target-shell/default/*
rm -f ../tornado/target-shell/Makefile
rm -rf ../tornado/vx-scheme/SIMNTgnu/*
rm -rf ../tornado/vx-scheme/SIMNTgnu/.*.swp
rm -f ../tornado/vx-scheme/Makefile
rm -f ../lib/slib_* ../lib/slibcat
rm -f core core.*
# We don't want to distribute any Wind River simulator binary--just
# the project files. So we clean before rolling a distro. We nuke
# the tornado makefiles so that the dependencies will be generated
# with the correct absolute pathnames.
distro: clean
(cd ../..; tar czhf $(PKG).tgz $(PKG)/)
(cd ../..; zip -q -r $(PKG).zip $(PKG)/)
# Testing: run the test suite. If SLIB is installed, smoke-test it.
test: test-interp test-compile
TESTARENA = SLABSIZE=1000000
test-interp: vxs-interp
@echo '========== TESTING INTERPRETER =========='
@if [ -d /usr/share/guile/slib ]; then \
(cd ../lib; ../src/vxs-interp < vx-slib-test.scm); \
fi
@(cd ../testcases; $(TESTARENA) ../src/vxs-interp < vx-test.scm)
test-compile: vx-scheme
@echo '========== TESTING COMPILER =========='
@if [ -d /usr/share/guile/slib ]; then \
(cd ../lib; ../src/vx-scheme < vx-slib-test.scm); \
fi
@(cd ../testcases; $(TESTARENA) ../src/vx-scheme < vx-test.scm)
#----------------------------------------------------------------------
#
# OS Adaptations (Don't try these, you don't have the right compiler.
# For VxWorks architectures, create new builds in the Tornado project.
#
OUT = scheme.out
VX_CFLAGS = $(CFLAGS) -DVXWORKS -I/w/gnu-t3/target/h
$(ARCH)-OBJ = $(OBJ:%=obj-$(ARCH)/%) obj-$(ARCH)/vx-main.o
$(ARCH)-ALLOBJ = $($(ARCH)-OBJ) obj-$(ARCH)/_ctdt.o
obj-$(ARCH):
mkdir $@
obj-$(ARCH)/%.o: %.cpp
$($(ARCH)-GC++) $(VX_CFLAGS) -c $^ -o $@
obj-$(ARCH)/_ctdt.o: obj-$(ARCH)/_ctdt.c
$($(ARCH)-GCC) -o $@ -c $^
obj-$(ARCH)/_ctdt.c: $($(ARCH)-OBJ)
$($(ARCH)-NM) $($(ARCH)-OBJ) | $(MUNCH) > $@
obj-$(ARCH)/$(OUT): obj-$(ARCH) $($(ARCH)-ALLOBJ)
$($(ARCH)-LD) -r -o $@ $($(ARCH)-ALLOBJ)
obj-$(ARCH)/size.out: obj-$(ARCH)/$(OUT) $($(ARCH)-ALLOBJ)
$($(ARCH)-SIZE) $^ | tee $@
$(ARCH)-GC++ = $($(ARCH)-GC)-c++
$(ARCH)-GCC = $($(ARCH)-GC)-gcc
$(ARCH)-LD = $($(ARCH)-GC)-ld
$(ARCH)-NM = $($(ARCH)-GC)-nm
$(ARCH)-SIZE = $($(ARCH)-GC)-size
MUNCH = tclsh8.3 /w/gnu-t3/host/src/hutils/munch.tcl
GCC_BASE = /w/gnu-t3/host/x86-freebsd/bin
#-----------------------------------------------------------------------
#
# Architecture-specific material
#
simpc-GC = $(GCC_BASE)/i386-pc-mingw32
simpc:
$(MAKE) ARCH=simpc obj-simpc/$(OUT)
arm-GC = $(GCC_BASE)/arm-wrs-vxworks
arm:
$(MAKE) ARCH=arm obj-arm/$(OUT)
ppc-GC = $(GCC_BASE)/powerpc-wrs-vxworks
ppc:
$(MAKE) ARCH=ppc obj-ppc/$(OUT)
m68k-GC = $(GCC_BASE)/m68k-wrs-vxworks
m68k:
$(MAKE) ARCH=m68k obj-m68k/$(OUT)
#------------------------------------------------------------------------
#
# Dependencies
#
cell.o: cell.cpp vx-scheme.h
vm.o: vm.cpp vx-scheme.h
subr.o: subr.cpp vx-scheme.h
io.o: io.cpp vx-scheme.h
lib.o: lib.cpp vx-scheme.h
interp.o: interp.cpp vx-scheme.h
symtab.o: symtab.cpp vx-scheme.h
u-main.o: u-main.cpp vx-scheme.h
vx-main.o: vx-main.cpp vx-scheme.h
_compiler.o: _compiler.cpp
#------------------------------------------------------------------------

37
vx-scheme/src/Scheme.sln Executable file
View File

@ -0,0 +1,37 @@
Microsoft Visual Studio Solution File, Format Version 8.00
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "vxs-interp", "win32\vxs-interp\vxs-interp.vcproj", "{FAB1057D-6292-457F-8509-34F3879528BB}"
ProjectSection(ProjectDependencies) = postProject
EndProjectSection
EndProject
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "vxs-bootstrap", "win32\vxs-bootstrap\vxs-bootstrap.vcproj", "{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}"
ProjectSection(ProjectDependencies) = postProject
EndProjectSection
EndProject
Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "vx-scheme", "win32\vx-scheme\vx-scheme.vcproj", "{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}"
ProjectSection(ProjectDependencies) = postProject
EndProjectSection
EndProject
Global
GlobalSection(SolutionConfiguration) = preSolution
Debug = Debug
Release = Release
EndGlobalSection
GlobalSection(ProjectConfiguration) = postSolution
{FAB1057D-6292-457F-8509-34F3879528BB}.Debug.ActiveCfg = Debug|Win32
{FAB1057D-6292-457F-8509-34F3879528BB}.Debug.Build.0 = Debug|Win32
{FAB1057D-6292-457F-8509-34F3879528BB}.Release.ActiveCfg = Release|Win32
{FAB1057D-6292-457F-8509-34F3879528BB}.Release.Build.0 = Release|Win32
{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}.Debug.ActiveCfg = Debug|Win32
{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}.Debug.Build.0 = Debug|Win32
{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}.Release.ActiveCfg = Release|Win32
{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}.Release.Build.0 = Release|Win32
{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}.Debug.ActiveCfg = Debug|Win32
{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}.Debug.Build.0 = Debug|Win32
{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}.Release.ActiveCfg = Release|Win32
{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}.Release.Build.0 = Release|Win32
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
EndGlobalSection
GlobalSection(ExtensibilityAddIns) = postSolution
EndGlobalSection
EndGlobal

144
vx-scheme/src/bootstrap.scm Normal file
View File

@ -0,0 +1,144 @@
;;
;; Copyright (c) 2004,2006 Colin Smith.
;;
;; bootstrap.scm: bootstraps the Scheme compiler by compiling itself
;; and serializing it to C.
;;
;; Expected arguments:
;; 1) Directory to "chdir" to
;; 2) Name of output file
(chdir (vector-ref *argv* 0))
(load "compiler.scm")
(define (comp-run exp)
(execute (link2 (compile exp))))
;; load a file via the compiler's execution path
;; essentially this is a REPL into comp-run
(define (comp-load file)
(let ((input (open-input-file file)))
(do ((form (read input) (read input)))
((eof-object? form) #t)
(comp-run form))))
(define (emit-compiled-procedures proc-list filename)
; for-each is a library procedure that we must compile; therefore
; it can't be used in the bootstrapper. We provide a local replacement
; here.
(define (_for-each proc list)
(let loop ((rest list))
(if (null? rest) #t
(begin (proc (car rest))
(loop (cdr rest))))))
; replace characters in a string, under a mapping represened in
; association-list form (e.g, the mapping '((#\a . #\b)) would
; map a's to b's). If the right had side of the association is
; #f, then the matching character is deleted.
(define (remap-characters mapping str)
(let loop ((result "")
(rest (string->list str)))
(if (null? rest) result
(let ((ch (car rest))
(map-entry (assq (car rest) mapping)))
(if (not map-entry) (loop (string-append result (string ch))
(cdr rest))
(if (cdr map-entry)
(loop (string-append result (string (cdr map-entry)))
(cdr rest))
(loop result
(cdr rest))))))))
; C++ symbols can't have hyphens, so we map them to underscores.
; This is not a general solution to the problem that Scheme
; identifiers draw from a richer character set than C++ identifiers:
; but it is sufficient for our purpose of bootstrapping the compiler.
(define (c-name-from-scheme-name str)
(remap-characters '((#\- . #\_) (#\. . #\_)) str))
(define (c-name-from-symbol sym)
(c-name-from-scheme-name (symbol->string sym)))
; We need to compile an 'eval' procedure, but actually compiling
; an eval would prevent the bootstrap interpreter from using eval,
; and that turns out to be annoying. Instead we compile _eval,
; and use this routine to strip _'s from symbol names when
; serializing them. Thus, when the _eval procedure is loaded in
; by the non-bootstrap VM, it will be called 'eval'.
(define (scheme-name-from-symbol sym)
(remap-characters '((#\_ . #f)) (symbol->string sym)))
(with-output-to-file filename
(lambda ()
(let ((module-name (string-append (c-name-from-scheme-name filename)
"_ext")))
(display "#include \"vx-scheme.h\"\n\n")
(_for-each
(lambda (proc)
(write-compiled-procedure (eval proc) (c-name-from-symbol proc)))
proc-list)
(display* "class " module-name " : SchemeExtension { \n"
"public:\n"
" " module-name "() {\n"
" Register(this);\n"
" }\n"
" virtual void Install(Context* ctx, Cell* envt) { \n"
" static struct {const char* n; vm_cproc* cp;} b[] = {\n")
(_for-each
(lambda (proc)
(display* " { \"" (scheme-name-from-symbol proc) "\", &"
(c-name-from-symbol proc) " },\n"))
proc-list)
(display*
" };\n const int nb = sizeof(b) / sizeof(*b);\n"
" for (int ix = 0; ix < nb; ++ix) {\n"
" // NB: GC is disabled during the loading of extensions.\n"
" ctx->set_var(envt, intern(b[ix].n),\n"
" ctx->load_compiled_procedure(b[ix].cp));\n"
" };\n"
" };\n"
"};\n\n"
"static " module-name " _ext;\n")
))))
(define apply-code '#((code #((apply.)
(return)))
(proc)
(return)))
(define apply (execute (link2 apply-code)))
(define callcc-code '#((code #((extend 1)
(cc)
(lref 0 0)
(apply 1)
(return)))
(proc)
(return)))
(define _call-with-current-continuation (execute (link2 callcc-code)))
(comp-load "compiler.scm")
(comp-load "library.scm")
(comp-run '(define (_eval expr) (execute (link2 (compile expr)))))
(emit-compiled-procedures '(compile
assemble
link2)
"_compiler.cpp")
(emit-compiled-procedures '(apply
map
call-with-input-file
call-with-output-file
load
_eval
_call-with-current-continuation
for-each)
"_library.cpp")

1199
vx-scheme/src/cell.cpp Normal file
View File

File diff suppressed because it is too large Load Diff

9
vx-scheme/src/compile Normal file
View File

@ -0,0 +1,9 @@
RUNTIME="vm.o cell.o subr.o ctx.o io.o symtab.o u-main.o lib.o"
#./vx-scheme ../testcases/pi.scm < compile-file.scm > pi.cc
#gcc -g -c pi.cc
#g++ -g -o pi vm.o cell.o subr.o ctx.o io.o symtab.o u-main.o pi.o
./vx-scheme compile-file.scm < compile-file.scm > _compile-file.cc
g++ -g -c _compile-file.cc
g++ -g -o compile-file ${RUNTIME} _compiler.o _compile-file.o

90
vx-scheme/src/compile-file.scm Executable file
View File

@ -0,0 +1,90 @@
;;
;; Copyright (c) 2005,2006 and onwards Colin Smith.
;;
;; compile-file.scm: reads a file and compiles it to bytecode; dumps the
;; bytecode which can then be linked to a compiler-free VM. This essentially
;; allows for the the translation of Scheme code to VM code with the minimum
;; runtime (that this implementation allows for, anyway).
;;
;; Arguments expected:
;;
;; 1) Name of source file
(display "#include \"vx-scheme.h\"\n\n")
(define form-counter 0)
(define (get-form-name)
(set! form-counter (+ form-counter 1))
(string-append "__f" (number->string form-counter)))
(define filename (vector-ref *argv* 0))
(with-input-from-file filename
(lambda ()
(let loop ((form (read)))
(if (eof-object? form) '/**/
(begin
(write-compiled-procedure (link2 (compile form)) (get-form-name))
(loop (read)))))))
;; rewind the form counter and generate an expression that will invoke each
;; of the forms in turn.
(define form-count form-counter)
(set! form-counter 0)
(define executor-form
(do
((form '(begin) (append form
(list (list (string->symbol (get-form-name))))))
(i 0 (+ i 1)))
((= i form-count) form)))
(write-compiled-procedure (link2 (compile executor-form)) "__RUN")
;; Now write a load-and-go routine.
(set! form-counter 0)
(let ((module-name "module"))
(display*
"class " module-name " : SchemeExtension { \n"
"public:\n"
" " module-name "() {\n"
" Register(this);\n"
" }\n"
" virtual ~" module-name "() {}\n"
" struct expression_table {\n"
" const char* n; // expression name\n"
" vm_cproc* cp; // compiled form of expression\n"
" Cell* c; // cell holding procedure object\n"
" };\n"
" static expression_table exptab[];\n"
" static const int num_exps;\n"
" virtual void Install(Context* ctx, Cell* envt) { \n"
" for (int ix = 0; ix < num_exps; ++ix) {\n"
" exptab[ix].c = ctx->load_compiled_procedure(exptab[ix].cp);\n"
" ctx->set_var(envt, intern(exptab[ix].n), exptab[ix].c);\n"
" }\n"
" MainProcedure(this);\n"
" }\n"
" virtual Cell* Run(Context* ctx) {\n"
" return ctx->execute(exptab[num_exps-1].c, nil);\n"
" };\n"
"};\n\n"
"static " module-name " _mod;\n\n"
"module::expression_table module::exptab[] = {\n")
(do
((i 0 (+ i 1))
(form-name (get-form-name) (get-form-name)))
((= i form-count) (display* " { \"__RUN\", &__RUN, 0 }, \n"))
(display* " { \"" form-name "\", &" form-name ", 0 },\n"))
(display*
"};\n"
"const int module::num_exps = "
"sizeof(module::exptab) / sizeof(*module::exptab);\n"))

971
vx-scheme/src/compiler.scm Normal file
View File

@ -0,0 +1,971 @@
;; Compiler for Vx-Scheme
;;
;; Copyright (c) 2003,2006 and onwards Colin Smith
;;
;; You may distribute under the terms of the Artistic License,
;; as specified in the LICENSE file.
;;
;; Based on ideas from [PAIP]: "Paradigms of Artificial Intelligence
;; Programming: Case Studies in Common Lisp," 1992, Peter Norvig, and
;; [SICP]: "Structure and Interpretation of Computer Programs," 2ed.,
;; 1996, Harold Abelson and Gerald Jay Sussman with Julie Sussman, MIT
;; Press,
; =========
; ASSEMBLER
; =========
(define (assemble insns)
(define (branch? opcode)
(memq opcode '(goto false? false?p true? true?p save)))
(let ((nonlabels '())
(labelmap '())
(counter 0))
;; pass 1: count non label instructions and memorize label positions.
(let pass1 ((insn insns))
(let* ((i (car insn))
(opcode (car i)))
(if (eq? opcode 'label)
(set! labelmap (cons (cons (cadr i) counter) labelmap))
(set! counter (+ counter 1)))
(if (not (null? (cdr insn)))
(pass1 (cdr insn)))))
;; pass 2: pack instructions into vector, while replacing labels with
;; indices.
(let pass2 ((outseq (make-vector counter))
(insn insns)
(ix 0))
(let* ((i (car insn))
(opcode (car i)))
(if (not (eq? opcode 'label))
(begin
(cond
((branch? opcode)
(vector-set! outseq ix
(list opcode (cdr (assq (cadr i) labelmap)))))
(else
(vector-set! outseq ix i)))
(if (not (null? (cdr insn)))
(pass2 outseq (cdr insn) (+ ix 1))))
(if (not (null? (cdr insn)))
(pass2 outseq (cdr insn) ix))))
outseq)))
;;; ========
;;; COMPILER
;;; ========
;; This is an association list of macro definitions:
;; ((name . (arglist . body))...)
(define __macro_table '())
(define (compile form)
(define *inline-procedures* '(+ * - quotient remainder
vector-ref vector-set! car cdr
zero? not null? eq? pair? cons))
(define (builtin? proc)
(memq proc '(if quote cond begin lambda or and let set! define letrec
let* do case quasiquote delay defmacro define-macro)))
;; We provide two simplified replacements for the library function map
;; (one for one arguments, the other for two), neither of which uses
;; the 'apply' primitive. The reason: map must apply its procedure
;; argument to the input list(s). While the interpreter knows how to
;; apply a compiled procedure, compiled Scheme code cannot invoke a
;; procedure in the interpreter, as this would reenter the interpreter
;; when the compiler compiles itself. We avoid this by supplying
;; two apply-less map substitutes here.
(define (_map func lst)
(let loop ((result '())
(rest lst))
(if (null? rest)
result
(loop (nconc result (list (func (car rest)))) (cdr rest)))))
(define (_map2 func lst1 lst2)
(let loop ((result '())
(rest1 lst1)
(rest2 lst2))
(if (null? rest1)
result
(loop (append result
(list (func (car rest1) (car rest2))))
(cdr rest1) (cdr rest2)))))
;; starts-with: frequently used in [PAIP]; we define it here.
;;
;; Return #t if l is a list whose first element is x.
(define (starts-with l x)
(and (pair? l) (eq? (car l) x)))
(define unspecified (if #f #f))
(define make-label
(let ((label-counter 0))
(lambda (name)
(set! label-counter (+ label-counter 1))
(string->symbol (string-append
(symbol->string name)
(number->string label-counter))))))
(define (extend-environment env args)
(cons args env))
(define (form-returning value more? val? . args)
(append
args
(if val?
(cond
((null? value) '((nil)))
((eq? value (if #f #f)) '((unspc)))
((eq? value #f) '((false)))
((eq? value #t) '((true)))
((integer? value) `((int ,value)))
;; ((symbol? value) `((const ,value)))
(else `((const ,value))))
'())
(if (not more?) `((return)) '())))
; emit insns if condition? is true.
;
(define (code-if condition? . insns)
(if condition? insns '()))
(define (compile-compound form env more? val?)
(let ((proc (car form))
(args (cdr form)))
(cond
((builtin? proc)
;; SPECIAL FORM
(compile-builtin proc args env more? val?))
((assq proc __macro_table)
;; MACRO
=> (lambda (macro) (compile-macro macro args env more? val?)))
(else
;; PROCEDURE APPLICATION
(compile-apply proc args env more? val?)))))
(define (locate-local-variable env var)
(define (locate-within env var)
(let var-loop ((v env)
(nv 0))
(if (null? v) #f
(if (eq? (car v) var)
nv
(var-loop (cdr v) (+ nv 1))))))
(let env-loop ((e env)
(ne 0))
(if (null? e) #f ; game over: ran out of environments without finding it.
(let ((location (locate-within (car e) var)))
(if location
(cons ne location)
(env-loop (cdr e) (+ ne 1)))))))
;; -------------------------
;; THE BUILTIN SPECIAL FORMS
;; -------------------------
(define (compile-builtin proc args env more? val?)
(cond
((eq? proc 'quote)
(form-returning (car args) more? val?))
((eq? proc 'if)
(let* ((test (car args))
(then-part (cadr args))
(have-else-part (not (null? (cddr args))))
(else-part (if have-else-part (caddr args) #f))
(label1 (make-label 'if))
(rendezvous (if more? (make-label 'if) #f)))
(append
(compile-exp test env #t #t)
(list `(false?p ,label1))
(compile-exp then-part env more? val?)
(code-if rendezvous `(goto ,rendezvous))
(list `(label ,label1))
(if have-else-part
(compile-exp else-part env more? val?)
(form-returning unspecified more? val?))
(code-if rendezvous `(label ,rendezvous)))))
((eq? proc 'cond)
(let ((rendezvous (make-label 'cond-x)))
(append
(let clause-loop ((clauses args)
(code '()))
(if (null? clauses)
;; if we get here, there was no else clause. We need to
;; arrange it so a evaluating a cond none of whose tests
;; are satisfied returns an unspecified value.
(append code (form-returning unspecified more? val?))
;; Continue compiling clauses.
(clause-loop
(cdr clauses)
(append
code
;; Generate the code for one clause.
(let* ((clause (car clauses))
(test (car clause))
(actions (cdr clause))
(skip-label (make-label 'cond)))
(append
(if (eq? test 'else)
;; An else clause is always executed.
(begin
(if (not (null? (cdr clauses)))
(error "else must be the last clause of a cond"))
(compile-sequence actions env more? val?))
;; Consider the action list. Look for => in the
;; first slot.
(if (starts-with actions '=>)
;; a => clause.
(let ((t-label (make-label 'cond-t))
(continuation (and more? (make-label 'cont))))
(append
(compile-exp test env #t #t)
`((true? ,t-label)
(pop)
(goto ,skip-label)
(label ,t-label))
;; XXX We now have the magic number '3'
;; to apologize for here.
(code-if continuation
`(save ,continuation)
'(take 3)) ; cont goes before argument
(compile-exp (cadr actions) env #t #t)
`((apply 1))
(code-if continuation `(label ,continuation))
(code-if (not val?) '(pop))
(code-if (and more? (not (null? (cdr clauses))))
`(goto ,rendezvous))))
;; a regular clause.
(begin
(append
(compile-exp test env #t #t)
`((false?p ,skip-label))
(compile-sequence actions env more? val?)))))
;; Now we have the value.
(code-if more? `(goto ,rendezvous))
`((label ,skip-label))))))))
(code-if rendezvous `(label ,rendezvous)))))
((eq? proc 'case)
;; Accomplished by rewriting:
;;
;; (case m -> (let ((value m))
;; ((u1 u2...) x1 x2...)... -> (cond ((member? m (u1 u2...)) x1 x2...)
;; (else y1 y2...)) -> (else y1 y2...))
;;
(let* ((selector (car args))
(clauses (cdr args))
(value (make-label 'case-var))
(cond-clauses (let loop ((code '())
(rest clauses))
(if (null? rest)
code
(loop
(append code
(if (eq? (caar rest) 'else)
`((else ,@(cdar rest)))
`(((member ,value ',(caar rest)) ,@(cdar rest)))))
(cdr rest)))))
(augmented-code `(let ((,value ,selector))
(cond ,@cond-clauses))))
(compile-exp augmented-code env more? val?)))
;; (let [name]? ((u1 v1) (u2 v2)...) x1 x2...)
((eq? proc 'let)
(let* ((named (and (symbol? (car args))
(car args))) ; if named let, record name
(args (if named (cdr args) args))) ; and advance to bindings
(let* ((bindings (car args))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(compile-let named variables initializers body env more? val?))))
((eq? proc 'letrec)
(let* ((bindings (car args))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(compile-letrec variables initializers body env more? val?)))
((eq? proc 'let*)
;; Accomplished by rewriting:
;;
;; (let* ((u1 v1) (u2 v2)...) x1 x2...) -> (let ((u1 v1))
;; (let* ((u2 v2)...)
;; x1 x2...))
;; When we're down to the last binding, we just compile as a
;; simple let.
(let* ((bindings (car args))
(nbindings (length bindings))
(variables (_map car bindings))
(initializers (_map cadr bindings))
(body (cdr args)))
(cond ((= nbindings 0) ; (let* () ...) --> (begin ...)
(compile-sequence body env more? val?))
((= nbindings 1) ; only one binding (left); simple let.
(compile-let #f variables initializers body env more? val?))
(else ; reduce one step.
(compile-let #f
(list (car variables))
(list (car initializers))
`((let* ,(cdr bindings)
,@body))
env more? val?)))))
((eq? proc 'begin)
;; Note: according to R4RS, internal definitions are not recognized
;; in a begin (only lambda, let, let*, letrec, define). This is
;; why we call compile-simple-sequence instead of compile-sequence.
(compile-simple-sequence args env more? val?))
((eq? proc 'lambda)
(append (compile-procedure-body #f (car args) (cdr args) env #f #t)
'((proc))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))
((eq? proc 'or)
(if (null? args)
(form-returning #f more? val?)
(let ((end-label (make-label 'or)))
(append
(let or-loop ((rest args)
(code '()))
(if (null? (cdr rest))
(append code (compile-exp (car rest) env more? val?))
(or-loop (cdr rest)
(append code
(compile-exp (car rest) env #t #t)
`((true? ,end-label)
(pop))))))
`((label ,end-label))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))))
((eq? proc 'and)
(if (null? args)
(form-returning #t more? val?)
(let ((end-label (make-label 'and)))
(append
(let and-loop ((rest args)
(code '()))
(if (null? (cdr rest))
(append code (compile-exp (car rest) env more? val?))
(and-loop (cdr rest)
(append code
(compile-exp (car rest) env #t #t)
`((false? ,end-label)
(pop))))))
`((label ,end-label))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))))
((eq? proc 'set!)
(let ((var (car args))
(value (cadr args)))
(append
(compile-exp value env #t #t)
(compile-assignment env var more? val?))))
((eq? proc 'define)
(append
(let ((target (car args)))
(cond ((symbol? target) ; (define v x...)
(append
(compile-exp (cadr args) env #t #t)
`((gset ,target))))
((pair? target) ; (define (f v...) x...)
(let ((proc (car target))
(args (cdr target))
(body (cdr args)))
(append
(compile-procedure-body #f args body env #f #t)
`((proc)
(gset ,proc)))))
(else (error "incomprehensible definition"))))
(form-returning unspecified more? val?)))
;; Defmacro. We expand the quasiquotation at compile time, and
;; then compile the result, for evaluation at runtime.
((or (eq? proc 'defmacro) ; XXX this is deprecated; or, use CL syntax
(eq? proc 'define-macro) )
(let* ((name (caar args))
(arglist (cdar args))
(body (cdr args))
(new-macro (cons arglist body)))
;; Find out if we already have a definition for this macro, and
;; if so, supersede it; else prepend the new definition to the
;; list.
(cond ((assq name __macro_table) => (lambda (assoc)
(set-cdr! assoc new-macro)))
(else
(set! __macro_table (cons (cons name new-macro)
__macro_table)))))
;;
(form-returning unspecified more? val?))
((eq? proc 'do)
(compile-do args env more? val?))
((eq? proc 'quasiquote)
;; expand quasiquotation and compile result.
(let ((expansion (expand-quasiquotation (car args))))
(compile-exp expansion env more? val?)))
((eq? proc 'delay)
;; (delay X) is a bit like (lambda () X). Compile the code for X,
;; and emit an instruction to wrap it in promise form.
(append (compile-procedure-body #f '() args env #f #t)
'((promise))
(code-if (not val?) '(pop))
(code-if (not more?) '(return))))
(else
(error "unknown builtin"))))
(define (compile-assignment env var more? val?)
(let ((location (locate-local-variable env var)))
(form-returning unspecified more? val?
(if location
`(lset ,(car location) ,(cdr location))
`(gset ,var)))))
(define (compile-sequence body env more? val?)
(let* ((result (scan-out-defines body))
(definitions (car result))
(simple-body (cdr result)))
(if (not (null? definitions))
;; wrap simple-body in a letrec that establishes the
;; definitions.
(let ((items
(let clause-loop ((variables '())
(initializers '())
(rest definitions))
(if (null? rest)
(cons variables initializers)
(let ((clause (cdar rest))) ; skip past 'define
(if (pair? (car clause)) ; procedure definition
(clause-loop
(append variables (list (caar clause)))
(append initializers
(list `(lambda ,(cdar clause) ,@(cdr clause))))
(cdr rest))
(clause-loop ; scalar definition
(append variables (list (car clause)))
(append initializers (list (cadr clause)))
(cdr rest))))))))
(compile-letrec (car items) (cdr items) simple-body env more? val?))
;; if no internal definitions, immediately delegate to
;; compile-simple-sequence.
(compile-simple-sequence body env more? val?))))
;; scan-out-defines: given a sequence of forms, separate the internal
;; definitions from the body forms. Return the twain in a cons.
;; (This way of handling internal definitions comes from [SICP].
;; The compiler in [PAIP] doesn't handle internal definitions. Norvig
;; uses letrec in the examples where this would matter.)
(define (scan-out-defines body)
(let loop ((defines '())
(simple-body '())
(rest body))
(cond
((null? rest)
(cons defines simple-body))
((starts-with (car rest) 'define)
(loop (append defines (list (car rest)))
simple-body
(cdr rest)))
(else
(loop defines
(append simple-body (list (car rest)))
(cdr rest))))))
;; compile-simple-sequence: compile a body sequence (list of forms)
;; known not to contain any internal definitions (these will have
;; been removed with (scan-out-defines).
(define (compile-simple-sequence body env more? val?)
(if (null? body)
(form-returning unspecified more? val?)
(append
(let loop ((code '())
(rest body))
(if (null? (cdr rest)) ; last in sequence
(append code (compile-exp (car rest) env more? val?))
(loop (append code (compile-exp (car rest) env #t #f))
(cdr rest))))
; Q: why do we need this return?
; (code-if (not more?) '(return))
)))
(define (compile-let name variables initializers body env more? val?)
; in the event of named-let, we add a new variable binding to
; contain the procedure value itself.
(let ((let-env (if name (extend-environment env (list name)) env))
(nvars (length variables))
(continuation (and more? (make-label 'let))))
(append
; The body of the let will be in the form of a compiled procedure we
; will invoke with APPLY. If we're not in tail context, we need to
; catch that apply so that execution can proceed in line.
(if continuation `((save ,continuation)) '())
(let init-loop ((rest initializers) ; generate code for all the
(code '())) ; initializers.
(if (null? rest)
code
(init-loop (cdr rest)
(append code
; NB: for named let, the initializers
; are _not_ compiled in an evironment
; containing the procedure body.
(compile-exp (car rest) env #t #t)))))
(compile-procedure-body #f variables body let-env #f #t)
; Named-let: the closure must be created in an environment where
; the let-name is bound, but we can't bind the value until the
; closure is created.
(code-if name '(unassn)
'(extend!)) ; reserve envt space
`((proc)) ; create closure
(if name `((dup) (lset 0 0)) '()) ; install in env, if named
`((apply ,nvars)) ; invoke procedure
(code-if (not val?) `(pop)) ; discard value if it's not wanted
(code-if continuation `(label ,continuation))
(code-if (not more?) '(return)))))
; compile-letrec: letrec is tricky. We compile the form
;
; (letrec ((u1 v1) (u2 v2)...) x1 x2...)
;
; as though it were written
;
; (let ((u1 *) (u2 *)...)
; (set! u1 v1)
; (set! u2 v2)...
; x1 x2...)
;
; The *'s represent values which will signal if an lref
; instruction tries to fetch them out of the environment.
(define (compile-letrec variables initializers body env more? val?)
(let ((prologue (_map2 (lambda (var init) `(set! ,var ,init))
variables
initializers))
(continuation (and more? (make-label 'letrec))))
(append
;; We will call the letrec body with apply, so we must
;; save a continuation if we are not in tail context.
(code-if continuation `(save ,continuation))
;; push enough unspecified values to bind all the letrec
;; values
(_map (lambda (_) '(unassn)) variables)
(compile-procedure-body prologue variables body env #f #t)
`((proc)
(apply ,(length variables)))
(code-if continuation `(label ,continuation))
(code-if (not val?) '(pop))
(code-if (not more?) '(return)))))
(define (compile-arguments args env)
(let loop ((rest args)
(code '()))
(if (null? rest)
code
(loop (cdr rest)
; an argument slot cannot be tail-recursive, so we
; set more? to #t when compiling arguments. Likewise,
; their values are always needed.
(append code (compile-exp (car rest) env #t #t))))))
; Arg-shape: analyze an argument list. Returns a list; the
; first element is the number of mandatory arguments and
; the second is #t if there are optional arguments. The
; third element is the 'smoothed' list of argument names.
;
; arg list shape
; x (0 #t (x))
; (u v) (2 #f (u v))
; (u . x) (1 #t (u x))
(define (arg-shape args)
(let loop ((regular-args 0)
(rest args)
(flat '()))
(cond
((null? rest)
(list regular-args #f flat))
((pair? rest)
(loop (+ regular-args 1) (cdr rest) (append flat (list (car rest)))))
(else
(list regular-args #t (append flat (list rest)))))))
; compile-procedure-body
;
; Generate code to leave a compiled procedure on the top of the stack.
;
; Args is the argument list. This can be improper, as can the first
; argument of (lambda). Prologue contains a code sequence that should
; logically precede the execution of the body, but be evaluated in an
; environment in which all arguments and internal definitions are
; accessible (example: installation of the values of a letrec
; expression). Body is the instruction sequence itself, which can
; contain internal defines. Env, more?, val? are used in the typical
; way.
(define (compile-procedure-body prologue args body env more? val?)
(let* ((shape (arg-shape args))
(nargs (car shape))
(extender (if (cadr shape) 'extend. 'extend))
(extended-env (extend-environment env (caddr shape))))
; Do we need to scan out defines?
(list `(code ,(assemble
(append
`((,extender ,nargs))
(if prologue
(compile-simple-sequence prologue extended-env #t #f)
'())
(compile-sequence body extended-env more? val?)
; procedures end with 'return': it's just that simple!
'((return))
))))))
;; determine whether the code fragment in proc-code is merely a
;; one-instruction reference to a symbol in the global environment,
;; and that symbol is a member of the set of inline procedures
;; we wish to invoke using the subr opcode (or a dedicated opcode).
;; If so, return the invoking code, else #f.
(define (inline-procedure-exp? proc-code n-args)
(and
(= (length proc-code) 1)
(eq? (caar proc-code) 'gref)
(let ((symbol (cadar proc-code)))
(cond ((memq symbol *inline-procedures*)
`((,symbol ,n-args)))
; Check to see if the function is a primitive procedure
; in this implementation: we can use a shortcut form
; of function invocation in that case.
((and (bound? symbol)
(primitive-procedure? (symbol-value symbol)))
`((subr ,symbol ,n-args)))
(else #f)))))
(define (compile-apply proc args env more? val?)
(let* ((proc-code (compile-exp proc env #t #t))
(n-args (length args))
(inline-procedure (inline-procedure-exp? proc-code n-args))
(continuation (and more?
(not inline-procedure)
(make-label 'cont))))
(append
(code-if continuation `(save ,continuation))
(compile-arguments args env)
(or inline-procedure
(append
proc-code
`((apply ,n-args))))
(code-if continuation `(label ,continuation))
(if (not val?) `((pop)) '())
(if (not more?)
`((return))
'()))))
(define (compile-do args env more? val?)
(let* ((bindings (car args))
(test-exit (cadr args))
(test (car test-exit))
(exit (cdr test-exit))
(iterate (cddr args))
(loop-symbol 'do-loop)) ; XXX (gensym)
(let* ((increment (let loop ((rest bindings)
(code '()))
(if (null? rest)
code
(if (null? (cddar rest))
(loop (cdr rest)
; no step-expression: continue with
; variable name
(append code (list (caar rest))))
(loop (cdr rest)
; insert step expression
(append code (list (caddar rest))))))))
(augmented-body `((if ,test
(begin ,@exit)
(begin ,@iterate
(,loop-symbol ,@increment))))))
(compile-let loop-symbol
(_map car bindings)
(_map cadr bindings)
augmented-body
env more? val?))))
;;; =========================
;;; MACROS AND QUASIQUOTATION
;;; =========================
;; compile a macro: construct a let-expression which will bind the
;; formals to the unevaluated actuals, including the body of the
;; macro. Evaluate this, and then compile the resulting code.
(define (compile-macro macro args env more? val?)
(let* ((formals (cadr macro))
(body (caddr macro))
(let-bindings (let loop ((bindings '())
(rest-formals formals)
(rest-actuals args))
(if (null? rest-formals) bindings
(loop
(append bindings
`((,(car rest-formals)
(quote ,(car rest-actuals)))))
(cdr rest-formals)
(cdr rest-actuals)))))
(macro-form `(let ,let-bindings ,body))
(expansion (eval macro-form)))
(compile-exp expansion env more? val?)))
;;; This Quasiquotation expander is based on that given in [PAIP p. 824],
;;; translated into Scheme. That implementation does not keep track of the
;;; "quasiquotation depth" as required by the R4/5 standard; that's fixed
;;; in the version here.
(define (expand-quasiquotation form)
(define (quasi-q depth x)
(cond
((vector? x)
(list 'list->vector (quasi-q depth (vector->list x))))
((not (pair? x))
(if (constant? x) x (list 'quote x)))
((starts-with x 'unquote)
(if (= depth 0)
(cadr x)
(combine-quasiquote (list 'quote 'unquote)
(quasi-q (- depth 1) (cdr x)) x)))
((starts-with x 'quasiquote)
; PAIP: (quasi-q (quasi-q (cadr x))))
(combine-quasiquote (list 'quote 'quasiquote)
(quasi-q (+ depth 1) (cdr x)) x))
((starts-with (car x) 'unquote-splicing)
; XXX respect QQ depth for unquote-splicing too!
(if (null? (cdr x))
(cadr (car x))
(list 'append (cadr (car x)) (quasi-q depth (cdr x)))))
(else
(combine-quasiquote (quasi-q depth (car x))
(quasi-q depth (cdr x)) x))))
(define (combine-quasiquote left right x)
(cond ((and (constant? left) (constant? right))
(let ((eval-left (eval left))
(eval-right (eval right)))
(if (and (eqv? eval-left (car x))
(eqv? eval-right (cdr x)))
(list 'quote x)
(list 'quote (cons eval-left eval-right)))))
((null? right)
(list 'list left))
((starts-with right 'list)
(apply list 'list left (cdr right)))
(else
(list 'cons left right))))
;; Main entry point: Initiate quasiquotation expansion at depth zero.
(quasi-q 0 form))
;;; Quasi-q refers to Common Lisp's (constantp); we implement
;;; that here as (constant?).
(define (self-evaluating? form)
(not (or (pair? form)
(symbol? form))))
;; For the purposes of quasiquotation, a form is Constant if
;; it's self-evaluating but not a symbol, or is the trivially
;; constant form (quote <something>).
(define (constant? x)
(or (self-evaluating? x)
(starts-with x 'quote)))
;;; ----------------------------------------------------------------------
(define (compile-exp form env more? val?)
(cond
((pair? form)
;; we must compute a compound's value no matter what,
;; in the event there are side-effects; if the value
;; is not wanted, we discard it.
(append (compile-compound form env more? #t)
(if val? '() '((pop)))))
((symbol? form)
(append
(if val?
(let ((location (locate-local-variable env form)))
(if location
(list `(lref ,(car location) ,(cdr location)))
(list `(gref ,form))))
'())
(if (not more?)
'((return))
'())))
(else ;self-evaluating
(form-returning form more? val?))))
(assemble (compile-exp form '() #f #t)))
;; ======
;; LINKER
;; ======
;;
;; The code produced from the compiler in the form of a tree of vectors,
;; and each instruction is represented in the form '(op arg...). The
;; "linker" phase collapses the nested vectors into a single linear
;; vector, fixing up offsets as it goes. It also stores instructions
;; in a compact atom format using by calling into make-instruction.
;; The instruction-vector returned from this procedure is suitable for
;; execution by the C-language virtual machine.
;; XXX add instruction factory parameter and unify with link2.
(define (link program)
(let ((output (make-vector 0))
(output-index 0)
(procedure-queue (make-vector 1 (cons program #f)))
(literal-queue (make-vector 0)))
(define (segment-relative-operand? opcode)
(memq opcode '(save true? true?p false? false?p goto)))
(define (process-one-procedure proc)
(let* ((insns (car proc))
(n-insns (vector-length insns))
(section-offset (vector-length output))
(fixup (cdr proc)))
(if fixup
;; verify that the indicated slot has the fixup
;; token in it, then install the current output
;; index.
(if (eq? (vector-ref output fixup) 'fixup)
(vector-set! output fixup (list
'consti
(vector-length output)))
(begin
(display (vector-ref output fixup))
(error "bad fixup"))))
;; process instructions
(do ((i 0 (+ i 1)))
((= i n-insns) 'ok)
(let* ((insn (vector-ref insns i))
(opcode (car insn)))
(cond
((eq? opcode 'code)
;; we found another vector of instructions: add it
;; to the queue to be flattened, consed with this
;; instruction's address, so the address can be
;; patched later. Leave a fixup token in this insn
;; slot.
(vector-push! output 'fixup)
(vector-push! procedure-queue (cons (cadr insn)
(- (vector-length output) 1))))
((segment-relative-operand? opcode)
;; if it's a branch or save instruction, the operand
;; is an index relative to this segment, which must
;; be fixed up.
(vector-push! output (list opcode
(+ (cadr insn) section-offset))))
(else
;; ordinary instruction
(vector-push! output insn)))))))
;; while there are still procedures on the queue, process them.
(let loop ()
(if (> (vector-length procedure-queue) 0)
(begin
(process-one-procedure (vector-shift! procedure-queue))
(loop))))
output))
(define (link2 program)
(let ((output (make-vector 0))
(output-index 0)
(procedure-queue (make-vector 1 (cons program #f)))
(literal-queue (make-vector 0)))
(define (segment-relative-operand? opcode)
(memq opcode '(save true? true?p false? false?p goto)))
(define (add-literal literal-queue literal)
;; Add the given literal to the vector and return the index.
;; Re-use an entry if one is already there. XXX: linear search.
(let loop ((index 0))
(cond
((= index (vector-length literal-queue))
;; item wasn't found. Add it.
(vector-push! literal-queue literal)
(- (vector-length literal-queue) 1))
((equal? literal (vector-ref literal-queue index))
;; found item: return index
index)
(else
;; keep looking
(loop (+ index 1))))))
(define (process-one-procedure proc)
(let* ((insns (car proc))
(n-insns (vector-length insns))
(section-offset (vector-length output))
(fixup (cdr proc)))
(if fixup
;; verify that the indicated slot has the fixup
;; token in it, then install the current output
;; index.
(if (eq? (vector-ref output fixup) 'fixup)
(vector-set! output fixup
(make-instruction 'consti (vector-length output)))
(begin
(display (vector-ref output fixup))
(error "bad fixup"))))
;; process instructions
(do ((i 0 (+ i 1)))
((= i n-insns) 'ok)
(let* ((insn (vector-ref insns i))
(opcode (car insn)))
(cond
((eq? opcode 'code)
;; we found another vector of instructions: add it
;; to the queue to be flattened, consed with this
;; instruction's address, so the address can be
;; patched later. Leave a fixup token in this insn
;; slot.
(vector-push! output 'fixup)
(vector-push! procedure-queue
(cons (cadr insn)
(- (vector-length output) 1))))
((segment-relative-operand? opcode)
;; if it's a branch or save instruction, the operand
;; is an index relative to this segment, which must
;; be fixed up.
(vector-push! output (make-instruction
opcode
(+ (cadr insn) section-offset))))
((eq? opcode 'const)
;; pushing a literal value. Add the value to the literal
;; queue, and substitute and instruction that will reference
;; it.
(let* ((operand (cadr insn))
(literal-index (add-literal literal-queue operand)))
(vector-push! output (make-instruction 'lit literal-index))))
(else
;; ordinary instruction
(vector-push! output (apply make-instruction insn))))))))
;; while there are still procedures on the queue, process them.
(let loop ()
(if (> (vector-length procedure-queue) 0)
(begin
(process-one-procedure (vector-shift! procedure-queue))
(loop))))
;; The internal format of a compiled procedure is a vector
;; containing the instruction vector and the literal pool.
(make-compiled-procedure output literal-queue)))

105
vx-scheme/src/cp-test.scm Normal file
View File

@ -0,0 +1,105 @@
(load "compiler.scm")
(load "simulator.scm")
;(compile '(lambda () 1))
(sim-load "library.scm")
(display "foo\n")
(sim-load "r4rstest.scm")
(display "bar\n")
;
;(display "setup complete\n")
;(sim-load "r4rstest.scm")
; Note: the "add3" test in r4rstest.scm fails because we open-code +,
; so the redefinition of + is not effective in compiled code. What
; to do?
;(sim-load "../testcases/maze.scm")
;(sim-load "../testcases/scheme.scm")
;; run an expression in the compiler's execution path
;;(define (compile-file file)
; (let ((input (open-input-file file)))
; (do ((form (read input) (read input)))
; ((eof-object? form) 'ok)
; (compile form))))
;
;
;(define apply-code '#((code #((apply.)
; (return)))
; (proc)
; (return)))
;
;apply-code
;(link2 apply-code)
;
;(define apply (execute (link2 apply-code)))
;
;apply
;
;(display "---\n")
;(display* "->" (comp-run '(apply list '(1 2 3 4 5))) "<-\n")
;(display* "->" (comp-run '(apply + '(1 2 3 4 5))) "<-\n")
;(display* "->" (comp-run '(apply list 'a 'b '(1 2 3 4 5))) "<-\n")
;(display* "->" (comp-run '(apply list 'c '(1 2 3 4 5))) "<-\n")
;(display "---\n")
;
;;(define (g v) (lambda (u) (+ u v)))
;;(display ((g 4) 7))
;
;
;(comp-run '(define (f v) (lambda (u) (+ u v))))
;
;;class VmExtension : SchemeExtension
;;{
;;public:
;; VmExtension () {
;; Register (this);
;; }
;; virtual void install (Context * ctx, Cell * envt) {
;; static struct {
;; const char* name;
;; subr_f subr;
;; } bindings[] = {
;; { "make-instruction", make_instruction },
;; { "make-compiled-procedure", make_compiled_procedure },
;; { "write-compiled-procedure", write_compiled_procedure },
;; { "disassemble", disassemble },
;; { "execute", execute },
;; };
;; static const unsigned int n_bindings = sizeof(bindings)/sizeof(*bindings);
;; for (unsigned int ix = 0; ix < n_bindings; ++ix) {
;; ctx->bind_subr(bindings[ix].name, bindings[ix].subr);
;; }
;; // Attach VM execution function to context, so the interpreter may
;; // invoke compiled procedures.
;; ctx->vm_execute = &Context::execute;
;; }
;;};
;;
;
;;(comp-run '((f 4) 7))
;;(write-compiled-procedure compile "compile")
;
;;(comp-load "../testcases/maze.scm")
;
;(time (comp-load "../testcases/pi.scm"))
;;(time (comp-load "../testcases/boyer.scm"))
;;(time (comp-load "../testcases/maze.scm"))
;;(comp-load "compiler.scm")
;;(time (compile-file "compiler.scm"))
;;(time (comp-load "library.scm"))
;;(comp-load "../testcases/dderiv.scm")
;;(comp-load "../testcases/puzzle.scm")
;;(comp-load "../testcases/ack.scm")
;;(comp-load "library.scm")
;;(comp-load "r4rstest.scm")
;
;
;

178
vx-scheme/src/ctx.cpp Normal file
View File

@ -0,0 +1,178 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// ctx.cpp : Common material for a Scheme execution context, indpendent
// of whether the interpreter or the compiler is in use
#include "vx-scheme.h"
// --------------------------------------------------------------------------
// Initialize Static Data
//
const char * Cell::typeName [] =
{ "int", "symbol", "unique", "string",
"real", "subr", "lambda", "vector",
"char", "iport", "oport", "promise",
"cont", "builtin", "magic", "insn",
"cproc", "cpromise", "cons" };
INTERN_SYM (s_unquote, "unquote");
INTERN_SYM (s_unquote_splicing, "unquote-splicing");
INTERN_SYM (s_dot, ".");
INTERN_SYM (s_quasiquote, "quasiquote");
INTERN_SYM (s_quote, "quote");
// --------------------------------------------------------------------------
// The Universal Cells
//
ALIGN8 Cell Cell::Nil;
ALIGN8 Cell Cell::Unspecified ("#<unspecified>");
ALIGN8 Cell Cell::Unassigned ("#<unassigned>");
ALIGN8 Cell Cell::Eof_Object ("#<eof-object>");
ALIGN8 Cell Cell::Bool_T ("#t");
ALIGN8 Cell Cell::Bool_F ("#f");
ALIGN8 Cell Cell::Error ("#<error>");
ALIGN8 Cell Cell::Halt ("#<halt>");
ALIGN8 Cell Cell::Unimplemented ("#<unimplemented>");
int Cell::typeCount [] = { 0 };
Cell * nil = &Cell::Nil;
Cell * unspecified = &Cell::Unspecified;
Cell * unassigned = &Cell::Unassigned;
Cell * unimplemented = &Cell::Unimplemented;
Context::Context ()
{
// Conceivably, if the memory budget is very low, we could run
// out while we're setting up all the builtin bindings. We can't
// GC, though, before the VM is set up.
ok_to_gc = false;
// Fresh environment.
cellsAlloc = cellsTotal = 0;
istack.push (make_iport (stdin));
ostack.push (make_oport (stdout));
envt = nil;
// Clear out the function pointers that pertain to the interpreter
// and bytecode VM; some of these will get filled in during the provision
// step depending on which components are linked with the executable.
vm_execute = 0;
vm_eval = 0;
interp_eval = 0;
eval_cproc = 0;
cc_procedure = 0;
empty_vector = 0;
root_envt = envt = extend (envt);
provision ();
init_machine ();
ok_to_gc = true;
}
void Context::init_machine ()
{
// Initialize machine registers
r_exp = r_val = r_proc = r_unev = r_elt = r_nu = r_tmp = nil;
r_env = envt;
r_cproc = r_envt = nil;
m_stack.clear();
clear (r_argl);
clear (r_varl);
}
// Context::using_vm - return true if we are using the bytecode vm.
bool Context::using_vm() const {
return vm_eval && !interp_eval;
}
// Context::eval
// Switchyard for evaluator. If the interpreter is present, we use
// it (perhaps we're bootstrapping the compiler?) Else we use the
// bytecode virtual machine.
Cell* Context::eval(Cell* form) {
if (using_vm()) return (this->*vm_eval)(form);
else if (interp_eval) return (this->*interp_eval)(form);
error("no evaluator");
return make_boolean(false);
}
void error (const char * message, const char * m2 /* = 0 */)
{
static const int ebufsize = 256;
static char errbuf [ebufsize];
int ix = 0;
const char *p;
char *q;
// Concatenate the two strings into a static buffer.
for (p = message, ix = 0, q = errbuf; *p && ix < ebufsize-1; ++ix)
*q++ = *p++;
if (m2)
for (p = m2; *p && ix < ebufsize-1; ++ix)
*q++ = *p++;
*q = '\0';
OS::exception (errbuf);
}
Cell * Context::extend (Cell * env)
{
r_nu = make_vector (0);
return make (r_nu, env);
}
// Context::find_var: find a variable in the given environment. If
// index is not NULL, return the index of the variable (if found). If
// the variable binding does not exist, NULL is returned and *index is
// unmolested.
Cell* Context::find_var(Cell* envt, psymbol var, unsigned int* index) {
cellvector * bindings = car(envt)->VectorValue();
for (int ix = 0; ix < bindings->size(); ++ix) {
Cell * z = bindings->get(ix);
if (car(z)->SymbolValue() == var) {
if (index) *index = ix;
return z;
}
}
return 0;
}
void Context::set_var(Cell* envt, psymbol var, Cell* value, unsigned int* index) {
Cell * binding = find_var(envt, var, index);
if (binding) {
Cell::setcdr(binding, value);
return;
}
// binding not found: add a new one
binding = gc_protect(make_symbol(var));
cellvector* v = car(envt)->VectorValue();
v->push (cons(binding, gc_protect(value)));
if (index) *index = v->size() - 1;
gc_unprotect(2);
}
Cell* Context::RunMain() {
if (SchemeExtension::HaveMain())
return SchemeExtension::RunMain(this);
return NULL;
}

1627
vx-scheme/src/interp.cpp Normal file
View File

File diff suppressed because it is too large Load Diff

603
vx-scheme/src/io.cpp Normal file
View File

@ -0,0 +1,603 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// io.cpp : reading and printing S-expressions.
#include "vx-scheme.h"
#include <errno.h>
static const char * delim = "\t\n\r) ";
// --------------------------------------------------------------------------
// token - return the next token (sequence of characters until delimiter).
// the delimiter is left on the stream.
//
void token (sio & in, sstring & ss)
{
int c;
TOP:
if ((c = in.get ()) < 0)
return;
// if (in.eof ())
// return;
// XXX
if (strchr (delim, c))
{
in.unget ();
return;
}
ss.append (c);
if (c == '\\')
ss.append (in.get ());
goto TOP;
}
#define READ_RETURN(value) do { retval = value; goto FINISH; } while (0)
// --------------------------------------------------------------------------
// read: convert source text to internal form
//
Cell * Context::read (sio & in)
{
char c;
Cell * retval = unimplemented;
save (r_nu);
save (r_tmp);
TOP:
c = in.get ();
if (c == EOF)
READ_RETURN (0);
if (isspace (c))
goto TOP;
if (c == ';')
{
// ';' introduces a comment. Text up to the next newline
// is discarded, and the parser restarts at the top.
while (c != '\n')
{
c = in.get ();
if (c == EOF)
READ_RETURN (0);
}
goto TOP;
}
if (c == '(')
{
// '(' introduces a list. We invoke the parser recursively,
// accumulating elements until we see a matching ')'.
// One wrinkle is improper lists, formed by placing a `.'
// before the last element; this has the effect of placing
// the tail element directly in the cdr instead of in the
// car of a node pointed to by the cdr. (In particular,
// this allows the syntax `(a . b)' to produce a "raw
// cons."
clear (r_argl);
int dotmode = 0;
LISTLOOP:
save (r_argl);
r_nu = read (in);
restore (r_argl);
if (r_nu == NULL)
READ_RETURN (Cell::car (&r_argl));
if (dotmode == 1)
{
l_appendtail (r_argl, r_nu);
dotmode = 2; // expecting: )
}
else if (r_nu->is_symbol (s_dot))
{
dotmode = 1; // expecting: cdr
}
else if (dotmode == 2)
{
// Uh-oh: something came between `. cdr' and `)'
error ("bad . list syntax");
}
else
l_append (r_argl, r_nu);
goto LISTLOOP;
}
else if (c == ')')
{
READ_RETURN (0);
}
else if (c == '\'')
{
r_nu = read (in);
if (r_nu)
{
r_nu = make (r_nu);
r_tmp = make_symbol (s_quote);
READ_RETURN (cons (r_tmp, r_nu));
}
error ("unexpected eof");
}
else if (c == '`')
{
if ((r_nu = read (in)) != NULL)
{
r_tmp = make_symbol (s_quasiquote);
r_nu = make (r_nu);
READ_RETURN (cons (r_tmp, r_nu));
}
error ("unexpected eof");
}
else if (c == ',')
{
psymbol wrap = s_unquote;
if (in.peek () == '@')
{
in.ignore ();
wrap = s_unquote_splicing;
}
if ((r_nu = read (in)) != NULL)
{
r_nu = make (r_nu);
r_tmp = make_symbol (wrap);
READ_RETURN (cons (r_tmp, r_nu));
}
error ("unexpected eof");
}
else if (c == '#')
{
// First we must treat the read-syntax for vectors #(...) .
if (in.peek () == '(')
{
// Vector.
int vl = 0;
clear (r_argl);
in.get (); // drop the '('
VECLOOP:
save (r_argl);
r_nu = read (in);
restore (r_argl);
if (r_nu == NULL)
{
r_nu = make_vector (vl);
cellvector * vec = r_nu->VectorValue ();
int ix = 0;
FOR_EACH (elt, Cell::car (&r_argl))
vec->set (ix++, Cell::car (elt));
READ_RETURN (r_nu);
}
l_append (r_argl, r_nu);
++vl;
goto VECLOOP;
}
sstring lexeme;
token (in, lexeme);
if (lexeme == "t")
READ_RETURN (make_boolean (true));
else if (lexeme == "f")
READ_RETURN (make_boolean (false));
else if (lexeme [0] == '\\')
{
// This is #\a syntax for characters. But
// we must also be careful to recognize
// #\space and #\newline.
if (lexeme == "\\newline")
READ_RETURN (make_char ('\n'));
if (lexeme == "\\space" || lexeme == "\\Space")
READ_RETURN (make_char (' '));
if (lexeme.length () == 2)
READ_RETURN (make_char (lexeme [1]));
error ("indecipherable #\\ constant: ", lexeme.str ());
}
else if (lexeme [0] == 'x' || lexeme [0] == 'X')
{
// hex constant. Drop the 'x' and convert with strtoul.
char * endptr;
unsigned long ul = strtoul (lexeme.str () + 1, &endptr, 16);
if (*endptr == '\0')
READ_RETURN (make_int (ul));
error ("indecipherable #x constant");
}
else if (lexeme [0] == 'o' || lexeme [0] == 'O')
{
// octal constant. Drop the 'o' and convert with stroul.
char * endptr;
unsigned long ul = strtoul (lexeme.str () + 1, &endptr, 8);
if (*endptr == '\0')
READ_RETURN (make_int (ul));
error ("indecipherable #o constant");
}
error ("indecipherable #constant");
}
else if (c == '"')
{
bool quote = false;
bool done = false;
sstring ss;
while (!done)
{
c = in.get();
if (c == EOF)
done = true;
else
{
if (quote)
{
switch (c)
{
case 'r': ss.append ('\r'); break;
case 'n': ss.append ('\n'); break;
case 'a': ss.append ('\a'); break;
case 't': ss.append ('\t'); break;
// XXX deal with \octal, \hex for i18n
default: ss.append (c);
}
quote = false;
}
else
{
if (c == '\\')
quote = true;
else if (c == '"')
done = true;
else
ss.append (c);
}
}
}
READ_RETURN (make_string (ss.str ()));
}
else
{
// At this point it is either a number or an identifier.
// Scheme's syntax for identifiers is _very_ loose
// (e.g., 3.14f is a perfectly good variable name.)
// So we must be precise about what we accept as a number.
// The following is a state machine meant to recognize
// the following regular expression for a floating-point
// or integer number (`2' stands for any decimal digit):
//
// -?2*(.2*)?([Ee][+-]?2+)?
//
// State 0 is the initial state, and state X rejects
// (i.e., classifies the lexeme as an identifier--there
// may be more of it to read!). States 3, 4, and 6 are
// accepting.
//
// CLASS
// STATE +/- [0-9] . E/e comment
// -------------------------------------------------------------
// 0 1 3 2 X Initial state.
// 1 X 3 2 X Saw sign; read digits or .
// 2 X 4 X X Saw .; read a digit
// (3) X 3 4 5 Read digits, e, or '.'
// (4) X 4 X 5 Have .; read digits or 'e'
// 5 6 6 X X Have e, read a digit or sign
// (6) X 6 X X Have e, read digits
static const unsigned char tmatrix [7][4] = {
{ 1, 3, 2, 0 },
{ 0, 3, 2, 0 },
{ 0, 4, 0, 0 },
{ 0, 3, 4, 5 },
{ 0, 4, 0, 5 },
{ 6, 6, 0, 0 },
{ 0, 6, 0, 0 },
};
static const bool accept [7] = {
false, false, false, true, true, false, true
};
sstring lexeme;
lexeme.append (c);
token (in, lexeme);
int state = 0;
bool inexact = false;
for (size_t ix = 0; ix < lexeme.length (); ++ix)
{
char lch = lexeme [ix];
if (lch == '-' || lch == '+')
state = tmatrix [state][0];
else if (isdigit (lch))
state = tmatrix [state][1];
else if (lch == '.')
{ inexact = true; state = tmatrix [state][2]; }
else if (lch == 'e' || lch == 'E')
{ inexact = true; state = tmatrix [state][3]; }
if (state == 0)
break;
}
// Did the state machine land in an accepting state?
// if so, we have a number.
if (accept [state])
if (inexact)
READ_RETURN (make_real (strtod (lexeme.str (), 0)));
else
{
errno = 0;
long l = strtol (lexeme.str (), 0, 0);
if (errno == ERANGE)
// too big to fit in an integer?
READ_RETURN (make_real (strtod (lexeme.str (), 0)));
READ_RETURN (make_int (l));
}
// If the machine lands in a non-accepting state,
// then we have an identifier.
READ_RETURN (make_symbol (intern (lexeme.str ())));
}
FINISH:
restore (r_tmp);
restore (r_nu);
return retval;
}
Cell * Context::read (FILE * fp)
{
file_sio fsio (fp);
return read (fsio);
}
void Cell::real_to_string (double d, char * buf, int nbytes)
{
sprintf (buf, "%.15g", d);
// Now if buf contains neither a `.' nor an `e', then
// the number was whole, and it won't "read back" as
// a Real, as desired. We tack on a decimal point in
// that event.
if (!strpbrk (buf, ".eE"))
strcat (buf, ".");
}
void Cell::write(FILE* out) const {
sstring output;
write(output);
fprintf(out, output.str());
}
void Cell::write (sstring& ss) const {
if (this == &Nil)
ss.append("()");
else {
Type t = type ();
switch(t) {
case Int: {
char buf[40];
sprintf(buf, "%d", IntValue());
ss.append(buf);
break;
}
case Symbol:
ss.append(SymbolValue()->key);
break;
case Builtin:
ss.append("#<builtin ");
ss.append(BuiltinValue()->key);
ss.append(">");
break;
case Char:
ss.append("#\\");
// XXX escaping?
ss.append(CharValue());
break;
case Iport:
ss.append("#<input-port>");
break;
case Oport:
ss.append("#<output-port>");
break;
case Subr:
ss.append("#<subr ");
ss.append(SubrValue()->name);
ss.append('>');
break;
case Cont:
ss.append("#<continuation>");
break;
case Real: {
char buf [80];
real_to_string (RealValue(), buf, sizeof(buf));
ss.append(buf);
break;
}
case Unique:
// "Unique" objects (like #t and EOF) keep their
// printed representations in their cdrs.
ss.append(cd.u);
break;
case Cons: {
const Cell * d;
ss.append('(');
for (d = this; d->type() == Cons; d = cdr(d)) {
if (d == nil) {
ss.append(')');
return;
}
car(d)->write(ss);
if (cdr(d) != nil)
ss.append(' ');
}
ss.append(". ");
d->write(ss);
ss.append(')');
break;
}
case String: {
char * p = StringValue ();
char ch;
ss.append('"');
while ((ch = *p++)) {
if (ch == '"')
ss.append("\\\"");
else if (ch == '\\')
ss.append("\\\\");
else if (ch == '\n')
ss.append("\\n");
else
ss.append(ch);
}
ss.append('"');
break;
}
case Vec: {
cellvector * v = VectorValue ();
ss.append("#(");
for (int ix = 0; ix < v->size(); ++ix) {
if (ix != 0)
ss.append(' ');
v->get(ix)->write(ss);
}
ss.append(')');
break;
}
case Lambda: {
Procedure proc = LambdaValue ();
ss.append(flag (MACRO) ? "#<macro " : "#<lambda ");
if (OS::flag (DEBUG_PRINT_PROCEDURES)) {
proc.arglist->write(ss);
ss.append(' ');
proc.body->write(ss);
ss.append('>');
} else {
proc.arglist->write(ss);
ss.append(" ...>");
}
break;
}
case Promise:
ss.append("#<promise ");
PromiseValue()->write(ss);
ss.append('>');
break;
case Cproc:
ss.append("#<compiled-procedure>");
break;
case Cpromise:
ss.append(flag(FORCED)
? "#<forced-compiled-promise>"
: "#<compiled-promise>");
break;
case Insn:
ss.append("#<vm-instruction>");
break;
default:
ss.append("#<?>");
}
}
}
void Cell::display (FILE * out)
{
switch (type ())
{
case Char:
fputc (CharValue (), out);
break;
case String:
fputs (StringValue (), out);
break;
default:
write (out);
}
fflush (out);
}
bool Context::read_eval_print
(
FILE * in,
FILE * out,
bool interactive
)
{
Cell * result;
Cell * expr;
sstring text;
file_sio sio (in);
if (interactive) {
fputs ("=> ", out);
fflush (out);
}
while (expr = read (sio))
{
// Don't bother printing the unspecified value as result.
if ((result = eval (expr)) != unspecified)
{
result->write (out);
fputc ('\n', out);
fflush (out);
}
gc_if_needed ();
return true;
}
return false;
}

94
vx-scheme/src/lib.cpp Normal file
View File

@ -0,0 +1,94 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// lib.cpp : A few extra library functions used in the compiled-code VM
//
#include "vx-scheme.h"
static Cell* force(Context* ctx, Cell* arglist) {
return ctx->force_compiled_promise(car(arglist));
}
// XXX: I'm not sure if the following two interact correctly
// with call-with-current-continuation. They should probably
// become opcodes (sigh)
static Cell* with_input_from_file(Context* ctx, Cell* arglist) {
ctx->with_input(car(arglist)->StringValue());
Cell* val = ctx->execute(cadr(arglist), nil);
ctx->without_input();
return val;
}
static Cell* with_output_to_file(Context* ctx, Cell* arglist) {
ctx->with_output(car(arglist)->StringValue());
Cell* val = ctx->execute(cadr(arglist), nil);
ctx->without_output();
return val;
}
static Cell* time(Context* ctx, Cell* arglist) {
double t0 = OS::get_time();
Cell* val = ctx->execute(car(arglist), nil);
double t1 = OS::get_time();
ctx->gc_protect(val);
Cell* d = ctx->make_real(t1 - t0);
ctx->gc_protect(d);
return ctx->cons(d, val);
}
// When call-with-current-continuation is used, the value supplied
// is in the form of a procedure which when invoked will resume
// the computation at the correct point. This is the body of that
// procedure, written here in "assembly language." (We can't write
// it in scheme because the resume instruction is not reachable from
// there.)
static vm_insn _callcc_procedure_insns[] = {
{ 13,0,(void*)1 }, // extend 1 XXX magic number
{ 5,0,(void*)0x10000 }, // lref 1,0 " "
{ 5,0,0x0 }, // lref 0,0 " "
{ 22,0,0 }, // resume " "
};
static vm_cproc _callcc_procedure = {
_callcc_procedure_insns,
sizeof(_callcc_procedure_insns)/sizeof(*_callcc_procedure_insns),
0, // literals
0, // # literals
0, // starting insn
};
class VmLibExtension : SchemeExtension {
public:
VmLibExtension () {
Register (this);
}
virtual void Install (Context * ctx, Cell * envt) {
static struct {
const char* name;
subr_f subr;
} bindings[] = {
{ "force", force },
{ "with-output-to-file", with_output_to_file },
{ "with-input-from-file", with_input_from_file },
{ "time", time },
};
static const unsigned int n_bindings = sizeof(bindings)/sizeof(*bindings);
for (unsigned int ix = 0; ix < n_bindings; ++ix) {
ctx->bind_subr(bindings[ix].name, bindings[ix].subr);
}
// Compile the procedure stub for a saved continuation
ctx->cc_procedure = ctx->load_instructions(&_callcc_procedure);
ctx->empty_vector = ctx->make_vector(0);
ctx->set_var(envt, intern("__callcc_procedure"), ctx->cc_procedure);
}
};
static VmLibExtension vm_lib_extension;

81
vx-scheme/src/library.scm Normal file
View File

@ -0,0 +1,81 @@
;; Library functions for Vx-Scheme
;;
;; Copyright (c) 2003,2006 and onwards Colin Smith
;;
;; These are procedures designed to run in the virtual machine. They
;; cannot be implemented in C, because each of these arguments takes a
;; parameter of procedure type. The C implementation would then be
;; forced to reenter the virtual machine, which is not allowed. By
;; implementing these procedures in Scheme itself, we can produce
;; bytecode that the VM can execute.
;;
;;
; =================
; LIBRARY FUNCTIONS
; =================
(define (map fn . arglists)
(define (map0 fn arglists)
(let loop ((results '())
(rest arglists))
(if (null? (car rest))
results
(loop (append
results
(list
(apply fn
(let car-loop ((rest1 rest)
(args '()))
(if (null? rest1)
args
(car-loop (cdr rest1)
(append args (list (caar rest1)))))))))
(let cdr-loop ((rest1 rest)
(args '()))
(if (null? rest1)
args
(cdr-loop (cdr rest1)
(append args (list (cdar rest1))))))))))
(map0 fn arglists))
(define (for-each fn . arglists)
(define (for-each0 fn arglists)
(let loop ((rest arglists))
(if (null? (car rest))
(if #f #f) ; unspecified
(begin
(apply fn
(let car-loop ((rest1 rest)
(args '()))
(if (null? rest1)
args
(car-loop (cdr rest1)
(append args (list (caar rest1)))))))
(loop (let cdr-loop ((rest1 rest)
(args '()))
(if (null? rest1)
args
(cdr-loop (cdr rest1)
(append args (list (cdar rest1)))))))))))
(for-each0 fn arglists))
(define (call-with-input-file filename procedure)
(let ((open-file (open-input-file filename)))
(procedure open-file)))
(define (call-with-output-file filename procedure)
(let* ((open-file (open-output-file filename))
(value (procedure open-file)))
(close-output-port open-file)
value))
(define (load file)
(let ((input (open-input-file file)))
(do ((form (read input) (read input)))
((eof-object? form) 'ok)
(eval form))))

561
vx-scheme/src/simulator.scm Normal file
View File

@ -0,0 +1,561 @@
;; VM Simulator for Vx-Scheme
;;
;; Copyright (c) 2003,2006 and onwards Colin Smith
;;
;; This program can execute the machine code generated by the compiler
;; in compiler.scm. It's meant as a testbed for compiler development,
;; not for production use; the C implementation of the VM in vm.cpp
;; is considerably faster.
;;
;;; -------------------
;;; COMPILED PROCEDURES
;;; -------------------
(define (tagged-list? tag obj)
(and (list? obj)
(not (null? obj))
(eq? tag (car obj))))
(define (make-procedure env code start)
(list '*cproc* code start env))
(define (compiled-procedure? obj)
(tagged-list? '*cproc* obj))
(define (compiled-procedure-code cproc)
(cadr cproc))
(define (compiled-procedure-start cproc)
(caddr cproc))
(define (compiled-procedure-env cproc)
(cadddr cproc))
;;; ------------
;;; ENVIRONMENTS
;;; ------------
(define (make-empty-environment)
'())
(define (extend-environment env args)
(cons (cons 'E: args) env))
; attach a new entry to the end of the first environment
; in the list.
(define (adjoin-environment! env arg)
(set-car! env (append (car env) (list arg))))
; =========================
; VIRTUAL MACHINE SIMULATOR
; =========================
; ---------------
; VM global state
;
; This are kept global, so that (run) may be called multiple
; times, with subsequent runs seeing bindings established in
; previous runs. Call (init-vm) to prepare a clean slate for
; execution.
(define global-env '())
(define (init-vm)
(set! global-env '()))
(define (set-global-var! var value)
(cond ((assq var global-env) => (lambda (assoc) (set-cdr! assoc value)))
(else
(set! global-env (cons (cons var value) global-env)))))
(define (sim-execute insns)
(let* ((stack '())
(env '())
(n-args 0))
;; XXX: this needs to be kept in sync with the compiler
(define *inline-procedures*
'(+ * - quotient remainder vector-ref vector-set! car cdr
zero? null? not eq? pair? cons))
(define (push x)
(set! stack (cons x stack)))
(define (pop)
(let ((value (car stack)))
(set! stack (cdr stack))
value))
(define (take n L)
;; Take the n'th item from the list (zero-based) and move it to the
;; head. We use append, so the performance is poor, but in this
;; simulator n is always very small so we can get away with this
;; cheap implementation.
(let loop ((head '())
(tail L)
(i n))
(if (= i 0) (append (list (car tail)) head (cdr tail))
(loop (append head (list (car tail))) (cdr tail) (- i 1)))))
(define (empty?)
(null? stack))
(define (top)
(if (empty?) 'empty (car stack)))
(define (pop-list n)
(let loop ((l '())
(i n))
(if (= i 0) l
(loop (cons (pop) l) (- i 1)))))
(define (push-list l)
(let loop ((rest l))
(if (not (null? rest))
(begin
(push (car rest))
(loop (cdr rest))))))
(define (globally-bound? var)
(assq var global-env))
(define (global-ref var)
(cdr (assq var global-env)))
;;
;; Local Variables
;;
(define (local-variable-ref env eloc vloc)
(list-ref (cdr (list-ref env eloc)) vloc))
(define (local-variable-set! env eloc vloc value)
(let ((e (list-ref env eloc)))
(let ((cell (let loop ((i vloc)
(rest (cdr e)))
(if (= i 0)
rest
(loop (- i 1)
(cdr rest))))))
(set-car! cell value))))
(define (sim-procedure? p)
(or (procedure? p)
(compiled-procedure? p)))
(define (sim-output thing output stream)
;; While running in the VM, don't allow display/write to operate on
;; compiled procedures (due to the captured environment, these
;; objects may contain cycles).
(if (not (pair? thing))
(output thing stream)
(cond ((compiled-procedure? thing)
(display "#<sim-cproc>" stream))
((tagged-list? '*cont* thing)
(display "#<cont>" stream))
(else
(display "(" stream)
(let loop ((rest thing))
(cond ((null? (cdr rest))
(sim-output (car rest) output stream))
((pair? (cdr rest))
(sim-output (car rest) output stream)
(display " " stream)
(loop (cdr rest)))
(else
(sim-output (car rest) output stream)
(display " . " stream)
(sim-output (cdr rest) output stream))))
(display ")" stream)))))
;; intercept application attempts to run certain procedures and
;; substitute adjusted versions.
(define (remap-sim-procedure proc)
(cond ((eq? proc procedure?)
sim-procedure?)
((eq? proc display)
(lambda (e . stream) (sim-output e display
(if (null? stream)
(current-output-port)
(car stream)))))
((eq? proc write)
(lambda (e . stream) (sim-output e write
(if (null? stream)
(current-output-port)
(car stream)))))
((eq? proc load)
sim-load)
((eq? proc pair?)
; our compiled procedures are implemented as lists but
; they shouldn't appear to be pairs
(lambda (p) (and (pair? p) (not (compiled-procedure? p)))))
(else
proc)))
; set up a dummy continuation to catch the return to toplevel
(set! stack (list 'halt))
(call-with-current-continuation
(lambda (exit-with-value)
(let execute-instruction ((pc 0))
(define (make-continuation label)
(list '*cont* env insns label))
(define (continuation? obj)
(tagged-list? '*cont* obj))
(define (resume continuation)
(if (eq? continuation 'halt)
(begin
(let ((value (pop)))
(if (> (length stack) 0)
(begin
(display "program left material on stack:")
(display stack)
(newline)))
(exit-with-value value)))
(begin
(set! env (list-ref continuation 1))
(set! insns (list-ref continuation 2))
(execute-instruction (list-ref continuation 3)))))
(define (return)
(let ((value (pop))
(continuation (pop)))
(push value)
(resume continuation)))
(define (dump-stack)
(let loop ((rest stack))
(if (null? rest) 'ok
(let ((item (car rest)))
(cond ((continuation? item)
(display "<cont ")
(display (list-ref item 3))
(display "> "))
((compiled-procedure? item)
(display "<cproc> "))
((and (list? item)
(not (null? item))
(list? (car item))
(not (null? (car item)))
(eq? (caar item) 'e:))
(display "<env> "))
(else
(display item)
(display " ")))
(loop (cdr rest))))))
(define (trace insn)
(display insn) (display "\t| ")
(dump-stack)
(newline))
; If we fall off the end of the instruction list, we treat
; that like a return instruction.
(if (>= pc (vector-length insns))
(return))
; Fetch an instruction.
(let* ((insn (vector-ref insns pc))
(opcode (car insn))
(operand (if (null? (cdr insn)) #f (cadr insn)))
(operand2 (if (or (null? (cdr insn)) (null? (cddr insn))) #f
(caddr insn))))
;(trace insn)
; Dispatch.
(cond
;; ------------------------
;; THE MACHINE INSTRUCTIONS
;; ------------------------
;;
;; CONST x : push x onto stack.
;; CONSTI x : push x onto stack (x is a small integer).
;; INT x : push x onto stack (x is an integer).
((memq opcode '(const consti int))
(push operand))
;; UNSPC : push the unspecified value.
((eq? opcode 'unspc)
(push (if #f #f)))
;; UNASSN : push a signalling unassigned value
((eq? opcode 'unassn)
(push '*unassigned*)) ; xxx: arrange for signal-on-reference
;; NIL : push nil
((eq? opcode 'nil)
(push '()))
;; CODE c : just like CONST, but used when the top of stack
;; contains a vector of instructions.
((eq? opcode 'code)
(push operand))
; GREF s : push value of global variable s onto stack.
((eq? opcode 'gref)
(let ((value (cond ((globally-bound? operand)
(global-ref operand))
; snarf an implementation from the
; enclosing scheme
((and (symbol? operand)
(procedure? (eval operand)))
(eval operand))
(else "error: no global variable " operand))))
(push value)))
; GSET v : pop value; bind it to v in the global environment.
((eq? opcode 'gset)
(set-global-var! operand (pop)))
; LREF e i : push local variable from relative frame e, index i.
((eq? opcode 'lref)
(push (local-variable-ref env operand operand2)))
; LSET e i : pop stack, and set local variable from relative
; frame e, index i, to this value.
((eq? opcode 'lset)
(local-variable-set! env operand operand2 (pop)))
; GOTO n : goto instruction n
((eq? opcode 'goto)
(execute-instruction operand))
; FALSE?P n : pop stack; if that value is false, GOTO n
((eq? opcode 'false?p)
(if (not (pop))
(execute-instruction operand)))
; FALSE? n : if top of stack is #f, GOTO n
((eq? opcode 'false?)
(if (not (top))
(execute-instruction operand)))
; TRUE?P n : pop stack; if that value is true, GOTO n
((eq? opcode 'true?p)
(if (pop)
(execute-instruction operand)))
; TRUE? n : if top of stack is not #f, GOTO n
((eq? opcode 'true?)
(if (top)
(execute-instruction operand)))
; TRUE : push a true value
((eq? opcode 'true)
(push #t))
; FALSE : push a false value
((eq? opcode 'false)
(push #f))
; PROC : pop stack; join the code in that value with the
; the current environment to form a closure.
((eq? opcode 'proc)
; if the top of the stack held a vector of instructions, we
; understand the procedure to start at the first instruction
; in that vector. If the TOS is an integer, we regard that as
; an index into the current instruction vector. In either
; case, what we store is a cons of the vector and the correct
; index within it.
(let* ((code (pop))
(procedure (if (vector? code)
(make-procedure env code 0)
(make-procedure env insns code))))
(push procedure)))
((eq? opcode 'promise)
;; like proc, but we create a promise instead. A
;; promise (in the simulator) is a list with a flag indicating
;; whether the value has been forced, and the code.
(let* ((code (pop))
(procedure (if (vector? code)
(make-procedure env code 0)
(make-procedure env insns code))))
(push `(*promise* #f ,procedure))))
; EXTEND n : take n items from stack and bind them in env
((eq? opcode 'extend)
(if (< n-args operand) (error "VM: too few arguments"))
(set! env (extend-environment env (pop-list operand))))
; EXTEND! : take 1 argument (guaranteed to be on stack
; and extend the environment
((eq? opcode 'extend!)
(set! env (extend-environment env (list (pop)))))
; EXTEND. n : take n items from the stack and bind them; then
; take the remaining items and bind them as a list
; (used for (lambda (u v . x) ...))
((eq? opcode 'extend.)
(if (< n-args operand) (error "VM: too few arguments"))
(let ((rest-args (pop-list (- n-args operand))))
(set! env (extend-environment env (pop-list operand)))
(adjoin-environment! env rest-args)))
; SAVE c : create a continuation for label c on the stack
((eq? opcode 'save)
(push (make-continuation operand)))
; RETURN : resume continuation under value
((eq? opcode 'return)
(return))
; POP : discard the value at the top of the stack
((eq? opcode 'pop)
(pop))
; DUP : duplicate: push the value at the top of the stack.
((eq? opcode 'dup)
(push (top)))
; TAKE n : extract n'th element of stack (zero-based count)
; and place it at the top.
((eq? opcode 'take)
(set! stack (take operand stack)))
; CC : take a continuation from the stack and replace it
; with a procedure that will resume it.
((eq? opcode 'cc)
(push (make-procedure
(extend-environment env (list stack))
(assemble
`((extend 1)
(lref 1 0)
(lref 0 0)
(resume)))
0)))
; RESUME : take a return value and a continuation from the
; stack, and resume the continuation with the given
; return value
((eq? opcode 'resume)
(let ((retval (pop))
(newstack (pop)))
(set! stack newstack)
(push retval)
(return)))
; APPLY n : pop stack; apply that proc to next n stack entries
; APPLY. : reorganize the stack from the format
; (a1 a2... rest proc)
; where a1... are individual arguments, rest is a
; list, and proc is a procedure, into the form
; (proc rest a2 a1)
; where rest is reversed and spliced in. Then proceed
; as in apply.
((or (eq? opcode 'apply)
(eq? opcode 'apply.))
(if (eq? opcode 'apply.)
(begin
(set! operand (+ (length (top)) (- n-args 2)))
(let* ((arglist (do ((i (- n-args 2) (- i 1))
(arglist (pop) (cons (pop) arglist)))
((= i 0) arglist)))
(proc (pop)))
(push-list arglist)
(push proc))))
(let ((proc (pop)))
(cond
((compiled-procedure? proc)
; A compiled procedure. Establish the environment,
; and branch to the code.
(set! env (compiled-procedure-env proc))
(set! n-args operand)
(set! insns (compiled-procedure-code proc))
(execute-instruction (compiled-procedure-start proc)))
((procedure? proc)
; A primitive procedure.
; Collect the indicated number of arguments into a list.
; We intercept certain procedures (like display and
; procedure?) where the enclosing Scheme implementation
; isn't quite what we want.
(let ((arglist (pop-list operand))
(continuation (pop))
(the-proc (remap-sim-procedure proc)))
(push (apply the-proc arglist))
; primitive procedures aren't implemented in the virtual
; machine so they have no RETURN instruction at the end;
; we perform it here.
(resume continuation)))
(else
(display "-->") (display proc) (display "<--\n")
(error "can't apply that.")))))
;; SUBR f n : pop n entries from stack and apply primitive
;; procedure f to those arguments. Since the
;; call has been coded as a subr, this means
;; the compiler knows the function is primitive
;; and isn't expecting us to pop a continuation
;; and resume it.
((eq? opcode 'subr)
(let* ((arglist (pop-list operand2))
(real-proc (eval operand))
(the-proc (remap-sim-procedure real-proc)))
(push (apply the-proc arglist))))
;; <INLINE-FUNCTION> n : we inline certian functions (like car)
;; as opocdes. The one operand is the
;; number of arguments on the stack. From
;; the simulator's point of view, this
;; is simply a rearrangement of SUBR above,
;; but in the C VM, procedures like this
;; are handled in the VM's internal loop.
((memq opcode *inline-procedures*)
(let* ((arglist (pop-list operand))
(real-proc (eval opcode))
(the-proc (remap-sim-procedure real-proc)))
(display* "opcode=" opcode ", n=" operand ", alist=" arglist ", value=" (apply the-proc arglist) "\n")
(push (apply the-proc arglist))))
(else
(display opcode)
(error "bad opcode"))))
; Advance pc and continue.
(execute-instruction (+ pc 1)))))))
;; --------------------------
;; INTERFACE TO THE SIMULATOR
;; --------------------------
;; run an expression in the simulator's execution path
(define (sim-run exp)
(sim-execute (link (compile exp))))
;; load a file via the simulator's execution path
;; essentially this is a REPL into sim-run
(define (sim-load file)
(let ((input (open-input-file file)))
(do ((form (read input) (read input)))
((eof-object? form) 'ok)
(sim-run form))))
(sim-load "library.scm")
(set-global-var! 'apply
(make-procedure
(make-empty-environment)
(assemble `((apply.)))
0))
(set-global-var! 'call-with-current-continuation
(make-procedure
(make-empty-environment)
(assemble `((extend 1)
(cc)
(lref 0 0)
(apply 1)))
0))
(sim-run '(define (force promise)
(if (not (eq? (car promise) '*promise*))
(error "can't force that")
(if (cadr promise)
(caddr promise)
(let ((putative-value ((caddr promise))))
(if (cadr promise)
(caddr promise)
(begin
(set-car! (cdr promise) #t)
(set-car! (cddr promise) putative-value)
putative-value)))))))
;; ============
;; DISASSEMBLER
;; ============
;;
;; The disassembler just pretty-prints the output of the compile step
;; above (which produces code in the form of a tree of vectors). This
;; procedure uses indentation to display the internal procedures.
(define (sim-disassemble proc)
(define (dis insns indent)
(let loop ((rest insns))
(if (not (null? rest))
(let* ((insn (car rest))
(opcode (car insn))
(opnd1 (and (not (null? (cdr insn))) (cadr insn)))
(opnd2 (and opnd1 (not (null? (cddr insn))) (caddr insn))))
(if (eq? opcode 'code)
(dis (vector->list opnd1) (string-append " " indent))
(begin
(display indent) (display opcode)
(if opnd1 (begin (display "\t") (display opnd1)
(if opnd2 (begin (display ",")
(display opnd2)))))))
(newline)
(loop (cdr rest))))))
(cond
((symbol? proc) ; disassemble a function known to the global environment
(dis (vector->list (caddr (assq proc global-env))) ""))
((vector? proc) ; disassemble a vector of instructions
(dis (vector->list proc) ""))
(else
(error "don't know how to disassemble that."))))

1895
vx-scheme/src/subr.cpp Normal file
View File

File diff suppressed because it is too large Load Diff

410
vx-scheme/src/symtab.cpp Normal file
View File

@ -0,0 +1,410 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// symtab.cpp : symbol table with copied strings in an AVL tree.
#include <stddef.h>
#include "vx-scheme.h"
static inline char * string_dup (const char * s)
{
char * x = (char *) malloc (strlen (s) + 1);
strcpy (x, s);
return x;
}
static psymbol newnode (const char * key)
{
psymbol n = (psymbol) malloc (sizeof (symbol));
memset (n, 0, sizeof (symbol));
n->key = string_dup (key);
return n;
}
// This is unguarded global data. Symbols stored in this tree
// could be shared among multiple threads, though, so it would
// be easy to protect this table with a mutex.
static symbol _head = { 0, 0, 0, 0 };
static psymbol head = &_head;
static psymbol symtab_insert (const char *);
// intern: place the string in the symbol table in standard case.
psymbol intern
(
const char * name
)
{
sstring ss;
size_t l;
psymbol q;
ss.append (name);
l = ss.length ();
for (size_t ix = 0; ix < l; ++ix)
ss [ix] = tolower (ss [ix]);
if (strcmp (ss.str (), name))
{
// Name was not given in standard case! We store it both as
// it was given and in standard case.
q = intern_stet (ss.str ());
q->truename = string_dup (name);
return q;
}
q = intern_stet (name);
q->truename = q->key;
return q;
}
// intern_stet: place the string in the symbol table exactly as given.
psymbol intern_stet
(
const char * name
)
{
return symtab_insert (name);
}
// An implementation of Knuth's Algorithm 6.2.3A "Balanced Tree Search
// and Insertion," from [TAoCP (3ed.) vol III p.462]. The insert
// function follows the structure of Knuth's algorithm closely, even
// using the same variable names and labels he chooses. Hence, we
// refer the reader his book for further documentation of this
// routine.
static psymbol symtab_insert
(
const char * K
)
{
psymbol P, Q, R, S, T;
int c, a;
if (!head->rlink)
{
return (head->rlink = newnode (K));
}
//A1: /* Initialize. */
T = head;
S = P = head->rlink;
A2: c = strcmp (K, P->key); /* Compare. */
if (c < 0) goto A3;
if (c > 0) goto A4;
return P;
A3: Q = P->llink; /* Move left. */
if (Q == 0)
{
Q = newnode (K);
P->llink = Q;
goto A5;
}
proceed:
if (Q->b != 0)
{
T = P;
S = Q;
}
P = Q;
goto A2;
A4: Q = P->rlink; /* Move right. */
if (Q == 0)
{
Q = newnode (K);
P->rlink = Q;
goto A5;
}
goto proceed;
A5: /* The "Insert" step is handled in the newnode function. */
//A6: /* Adjust balance factors. */
a = (strcmp (K, S->key) < 0) ? -1 : +1;
R = P = (a < 0 ? S->llink : S->rlink);
while (P != Q)
{
c = strcmp (K, P->key);
if (c < 0)
{
P->b = -1;
P = P->llink;
}
else if (c > 0)
{
P->b = +1;
P = P->rlink;
}
}
//A7:
if (S->b == 0) /* Balancing act. */
{
S->b = a;
++head->b; /* Keep track of tree height: */
return Q; /* Knuth uses LLINK but we use B. */
}
if (S->b == -a)
{
S->b = 0;
return Q;
}
if (S->b == a)
{
if (R->b == a)
goto A8;
else if (R->b == -a)
goto A9;
}
A8: P = R; /* Single rotation. */
if (a < 0)
{
S->llink = R->rlink;
R->rlink = S;
}
else
{
S->rlink = R->llink;
R->llink = S;
}
S->b = R->b = 0;
goto A10;
A9: if (a < 0) /* Double rotation. */
{
P = R->rlink;
R->rlink = P->llink;
P->llink = R;
S->llink = P->rlink;
P->rlink = S;
}
else
{
P = R->llink;
R->llink = P->rlink;
P->rlink = R;
S->rlink = P->llink;
P->llink = S;
}
if (P->b == a)
{
S->b = -a;
R->b = 0;
}
else if (P->b == -a)
{
S->b = 0;
R->b = a;
}
else
{
S->b = R->b = 0;
}
P->b = 0;
A10: if (S == T->rlink) /* Finishing touch. */
T->rlink = P;
else
T->llink = P;
return Q;
}
// sstring class
//
// simple, extensible string. Tries to work efficiently for small
// strings by using a static buffer, which "spills" into a region on
// the heap if necessary. Aims for compactness. We maintain
// null-termination at all times. A "claim" operation is supported,
// which means that malloc'd string storage won't be freed when the
// sstring is destructed. This can help avoid excess strdup's for the
// consumers of strings created this way. STL strings are fine, but
// their template-based implementation leads to "bloat" (in the
// context of an application like this which is aiming for embedded
// compactness).
//
// ** We maintain null termination at all times.
sstring::sstring ()
{
// Initially, we use our static buffer, abandoning it for storage
// obtained with malloc if we need to.
sz = 0;
base = c; // base points to base of allocation.
*base = '\0';
alloc = stat_size; // How much allocated (statically or otherwise).
end = base; // End will point to the first free character.
pos = base; // read position
claimed = false; // freeing the storage is our job
}
sstring::~sstring ()
{
// If we've spilled, and the caller hasn't claimed the buffer,
// free it.
if (base != c && !claimed)
free (base);
}
void sstring::append (const char ch)
{
append (&ch, 1);
}
void sstring::append (const char * s)
{
append (s, strlen (s));
}
void sstring::append (const char * s, size_t len)
{
size_t required = sz + len + 1;
ptrdiff_t read_offset = pos - base;
// Will it fit in the current allocation?
TOP: if (required < alloc)
{
memcpy (end, s, len);
end += len;
sz += len;
end [0] = '\0';
return;
}
// No. We will have to allocate more storage (perhaps for
// the first time). Double the size (unless that won't be
// enough to accept this append.
size_t new_alloc = 2 * alloc;
if (required > new_alloc)
new_alloc = required;
char * new_buf = (char *) malloc (new_alloc);
if (!new_buf)
error ("out of memory");
memcpy (new_buf, base, sz);
if (base != c)
free (base);
base = new_buf;
end = base + sz;
end [0] = '\0';
alloc = new_alloc;
pos = base + read_offset;
// It should work now.
goto TOP;
}
void sstring::claim ()
{
if (base == c)
{
// We were getting away with using the little static buffer,
// but now the user wants to hand off the buffer as if it were
// malloc'd. We have to clone it now.
base = (char *) malloc (sz + 1);
strcpy (base, c);
}
claimed = true;
}
int sstring::get ()
{
if (pos >= base && pos < end)
return *pos++;
return EOF;
}
int sstring::peek ()
{
if (pos >= base && pos < end)
return *pos;
return EOF;
}
void sstring::unget ()
{
if (pos > base)
--pos;
}
void sstring::ignore ()
{
if (pos < end)
++pos;
}
#ifdef TEST
// Unit test: with TEST defined, this module becomes a standalone
// program which will sort its input. It prints the height of the tree
// at the end, which ought to be about log2 (number of input records).
void print (psymbol n)
{
// traverse the tree inorder, and print.
if (!n)
return;
print (n->llink);
printf ("%s\n", n->key);
print (n->rlink);
}
int main ()
{
char buf [80];
int i = 1;
psymbol Q;
while (fgets (buf, sizeof (buf), stdin))
{
int l = strlen (buf);
if (buf [l-1] == '\n')
buf [l-1] = '\0'; /* chomp newline */
Q = intern_stet (buf);
}
print (head->rlink);
printf ("height: %d\n", head->b);
return 0;
}
void error (const char * s1, const char * s2)
{
fputs (s1, stderr);
fputs (s2, stderr);
exit (1);
}
#endif

138
vx-scheme/src/u-main.cpp Normal file
View File

@ -0,0 +1,138 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// u-main.cpp : startup code for UNIX, Cygwin or Win32 environments.
#include <stdio.h>
#include <time.h>
#include "vx-scheme.h"
#ifndef WIN32
#include <sys/time.h>
#include <unistd.h>
#else
#include <windows.h>
#endif
#include <setjmp.h>
static jmp_buf jb;
static bool jmpbuf_set = false;
//----------------------------------------------------------------------------
//
// OS-SPECIFIC FEATURES
//
// This area fills in definitions for OS-specific features named
// in class OS.
//
double OS::get_time() {
double sec;
#ifdef WIN32
FILETIME filetime;
GetSystemTimeAsFileTime(&filetime);
ULARGE_INTEGER ul;
ul.HighPart = filetime.dwHighDateTime;
ul.LowPart = filetime.dwLowDateTime;
// FILETIMES are in 100ns units.
sec = ul.QuadPart / 100000000.;
sec += ul.QuadPart % 100000000;
#else
struct timeval t;
gettimeofday (&t, 0);
sec = t.tv_sec;
sec += t.tv_usec / 1e6;
#endif
return sec;
}
unsigned int OS::flags ()
{
static bool env_checked = false;
static unsigned int f = 0;
if (! env_checked)
{
char * c;
if ((c = getenv ("T")) != NULL)
f = strtol (c, 0, 0);
env_checked = true;
}
return f;
}
bool OS::interactive (int fd)
{
return isatty (fd) != 0;
}
Cell * OS::undef (Context * ctx, const char * name)
{
return 0;
}
void OS::exception (const char * s) {
if (jmpbuf_set) longjmp (jb, reinterpret_cast <int> (s));
fputs(s, stderr);
fputs("\n", stderr);
exit(1);
}
void interact (Context * ctx)
{
bool interactive = OS::interactive(0);
while (ctx->read_eval_print (stdin, stdout, interactive))
;
if (OS::flag (DEBUG_MEMSTATS_AT_EXIT)) {
ctx->print_mem_stats (stdout);
Cell::stats ();
}
exit (0);
}
int main (int argc, char **argv) {
const char *jv;
Context ctx;
Cell* scheme_argv = ctx.gc_protect(ctx.make_vector(0));
cellvector* argvec = scheme_argv->VectorValue();
--argc;
++argv;
while (argc > 0) {
argvec->push(ctx.make_string(*argv));
--argc;
++argv;
}
// Establish *argv* in global environment
ctx.set_var(intern("*argv*"), scheme_argv, 0);
ctx.gc_unprotect();
// See if we have a canned main procedure.
Cell* result = ctx.RunMain();
if (result) {
if (result != unspecified) result->write(stdout);
} else {
// Interact
while (1) {
if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0) {
jmpbuf_set = true;
interact (&ctx);
} else {
fprintf (stderr, "caught: %s\n", jv);
}
}
}
}

1028
vx-scheme/src/vm.cpp Normal file
View File

File diff suppressed because it is too large Load Diff

239
vx-scheme/src/vx-main.cpp Normal file
View File

@ -0,0 +1,239 @@
//----------------------------------------------------------------------
// vx-scheme : Scheme interpreter.
// Copyright (c) 2002,2003,2006 and onwards Colin Smith.
//
// You may distribute under the terms of the Artistic License,
// as specified in the LICENSE file.
//
// vx-main.cpp : startup code for VxWorks execution environment.
#include "vx-scheme.h"
#include "tickLib.h"
#include "sysSymTbl.h"
#include "setjmp.h"
static jmp_buf jb;
static psymbol s_vx_invoke;
static psymbol s_args;
int vxSchemeDebug = 0;
extern "C" int sysClkRateGet ();
typedef int (* VX_FUNC) (...);
//----------------------------------------------------------------------------
//
// OS-SPECIFIC FEATURES
//
// This area fills in definitions for OS-specific features named
// in class OS.
//
double OS::get_time() {
double t = tickGet ();
return t / sysClkRateGet();
}
unsigned int OS::flags() {
return vxSchemeDebug;
}
bool OS::interactive (int fd)
{
return isatty (fd);
}
Cell * mget (Context * ctx, void * key)
{
int * pi = (int *) key;
int val = *pi;
return ctx->make_int (val);
}
void mset (Context * ctx, void * key, Cell * rhs)
{
int value;
Cell::Type t = rhs->type ();
if (t == Cell::Int)
value = rhs->IntValue ();
else if (t == Cell::String)
value = reinterpret_cast <int> (rhs->StringValue ());
else if (t == Cell::Char)
value = rhs->CharValue ();
else
error ("cannot convert rvalue to compatible type");
int * pi = static_cast <int *> (key);
*pi = value;
}
Cell * OS::undef (Context * ctx, const char * name)
{
char * value;
SYM_TYPE type;
// See if it's a symbol.
if (symFindByCName (sysSymTbl,
const_cast <char*> (name),
&value,
&type) == OK)
{
switch (type)
{
case SYM_GLOBAL | SYM_BSS:
case SYM_GLOBAL | SYM_DATA:
// It's a global in a data section. Treat
// it as an integer variable.
return ctx->make_magic (value, mset, mget);
case SYM_GLOBAL | SYM_TEXT:
// It's a global in a text section. Treat
// it as a function. To do this, we construct
// a lambda which will call the VxWorks
// function below:
//
// (lambda args (vx-invoke <function-address> args))
Cell *vx_invoke, *addr, *args, *nu;
vx_invoke = ctx->make_symbol (s_vx_invoke);
ctx->gc_protect (vx_invoke);
addr = ctx->make_int (reinterpret_cast <int> (value));
ctx->gc_protect (addr);
args = ctx->make_symbol (s_args);
ctx->gc_protect (args);
nu = ctx->make_list3 (vx_invoke, addr, args);
ctx->gc_protect (nu);
nu = ctx->cons (nu, nil);
ctx->gc_unprotect (4);
return ctx->make_procedure (ctx->root (), nu, args);
}
}
return 0;
}
Cell * vx_invoke (Context * ctx, Cell * arglist)
{
Cell * cfunc = car (arglist);
Cell * alist = cadr (arglist);
const int nargs = 10;
int a [nargs];
int ix = 0;
VX_FUNC vx_func = reinterpret_cast <VX_FUNC> (cfunc->IntValue ());
// Fill up argument array. We support integer and string
// arguments (which we pass by address). If we see a
// symbol (most likely someone wrote, e.g., 'taskDelay),
// we look up its value in the VxWorks symbol table. This
// makes "(sp 'taskDelay 100)" work (if the quote were omitted,
// then taskDelay would receive a procedure value, rather than
// a numeric one).
FOR_EACH (arg, alist)
{
Cell * ar = car (arg);
Cell::Type t = ar->type ();
if (t == Cell::Int)
a [ix++] = ar->IntValue ();
else if (t == Cell::String)
a [ix++] = reinterpret_cast <int> (ar->StringValue ());
else if (t == Cell::Symbol)
{
const char * name = ar->SymbolValue ()->truename;
char * value;
SYM_TYPE type;
if (symFindByCName (sysSymTbl,
const_cast <char *> (name),
&value,
&type) == OK)
a [ix++] = reinterpret_cast <int> (value);
else
error ("symbol absent from sysSymTbl");
}
else
error ("incompatible argument type");
}
// Fill up the remaining argument slots with '0'.
for (; ix < nargs; ++ix)
a [ix] = 0;
// Invoke VxWorks function. Make an integer cell of the
// return value.
return ctx->make_int (vx_func (a[0],a[1],a[2],a[3],a[4],
a[5],a[6],a[7],a[8],a[9]));
}
void OS::exception (const char * s)
{
longjmp (jb, reinterpret_cast <int> (s));
}
void interact (Context * ctx)
{
bool interactive = isatty (0);
while (ctx->read_eval_print (stdin, stdout, interactive))
;
if (OS::flag (DEBUG_MEMSTATS_AT_EXIT))
ctx->print_mem_stats (stdout);
exit (0);
}
extern "C" int scheme (char * a0)
{
const char * jv;
Context ctx;
// Sanity check: we need to make sure that the "unique cells"
// (e.g., things like nil, etc.) are 8-byte aligned. If this
// scheme image has been dynamically loaded to a VxWorks system,
// this is not easy to guarantee! We try to favor this outcome by
// making env.o (where these objects are defined) first in the
// link order, but we make sure that whatever happens things have
// worked out ok. The garbage collector will be very unhappy if
// any cells are not 8-aligned.
if (((int) nil) & 7)
{
printf ("code module error: standard cells not 8-aligned\n");
exit (1);
}
s_args = intern ("args");
s_vx_invoke = intern ("vx-invoke");
ctx.bind (ctx.make_symbol (intern ("vx-invoke")),
ctx.make_subr (vx_invoke, "vx-invoke"));
if (a0 != 0)
{
sstring ss;
ss.append (a0);
Cell * result = ctx.eval (ctx.read (ss));
if (result != unspecified)
{
result->write (stdout);
fputc ('\n', stdout);
}
}
else while (1)
{
if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0)
interact (&ctx);
else
fprintf (stderr, "caught: %s\n", jv);
}
}

1223
vx-scheme/src/vx-scheme.h Normal file
View File

File diff suppressed because it is too large Load Diff

2
vx-scheme/src/win32/vx-scheme/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
Debug
Release

185
vx-scheme/src/win32/vx-scheme/vx-scheme.vcproj Executable file
View File

@ -0,0 +1,185 @@
<?xml version="1.0" encoding="Windows-1252"?>
<VisualStudioProject
ProjectType="Visual C++"
Version="7.10"
Name="vx-scheme"
ProjectGUID="{F6385AAC-CBC3-4795-9C0C-2CA79D627E90}"
RootNamespace="vx-scheme"
Keyword="Win32Proj">
<Platforms>
<Platform
Name="Win32"/>
</Platforms>
<Configurations>
<Configuration
Name="Debug|Win32"
OutputDirectory="Debug"
IntermediateDirectory="Debug"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
Optimization="0"
PreprocessorDefinitions="WIN32;_DEBUG;_CONSOLE"
MinimalRebuild="TRUE"
BasicRuntimeChecks="3"
RuntimeLibrary="5"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="4"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vx-scheme.exe"
LinkIncremental="2"
GenerateDebugInformation="TRUE"
ProgramDatabaseFile="$(OutDir)/vx-scheme.pdb"
SubSystem="1"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
<Configuration
Name="Release|Win32"
OutputDirectory="Release"
IntermediateDirectory="Release"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
PreprocessorDefinitions="WIN32;NDEBUG;_CONSOLE"
RuntimeLibrary="4"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="3"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vx-scheme.exe"
LinkIncremental="1"
GenerateDebugInformation="TRUE"
SubSystem="1"
OptimizeReferences="2"
EnableCOMDATFolding="2"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
</Configurations>
<References>
</References>
<Files>
<Filter
Name="Source Files"
Filter="cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx"
UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}">
<File
RelativePath="..\..\_compiler.cpp">
</File>
<File
RelativePath="..\..\bootstrap.scm">
</File>
<File
RelativePath="..\..\cell.cpp">
</File>
<File
RelativePath="..\..\compiler.scm">
<FileConfiguration
Name="Debug|Win32">
<Tool
Name="VCCustomBuildTool"
Description="Compiling Compiler"
CommandLine="$(ProjectDir)..\vxs-bootstrap\$(ConfigurationName)\vxs-bootstrap.exe $(SolutionDir) _compiler.cpp &lt; $(SolutionDir)bootstrap.scm
"
AdditionalDependencies="$(ProjectDir)..\bootstrap.scm"
Outputs="$(SolutionDir)_compiler.cpp"/>
</FileConfiguration>
<FileConfiguration
Name="Release|Win32">
<Tool
Name="VCCustomBuildTool"
Description="Compiling Compiler"
CommandLine="$(ProjectDir)..\vxs-bootstrap\$(ConfigurationName)\vxs-bootstrap.exe $(SolutionDir) _compiler.cpp &lt; $(SolutionDir)bootstrap.scm
"
Outputs="_compiler.cpp"/>
</FileConfiguration>
</File>
<File
RelativePath="..\..\ctx.cpp">
</File>
<File
RelativePath="..\..\io.cpp">
</File>
<File
RelativePath="..\..\lib.cpp">
</File>
<File
RelativePath="..\..\subr.cpp">
</File>
<File
RelativePath="..\..\symtab.cpp">
</File>
<File
RelativePath="..\..\u-main.cpp">
</File>
<File
RelativePath="..\..\vm.cpp">
</File>
</Filter>
<Filter
Name="Header Files"
Filter="h;hpp;hxx;hm;inl;inc;xsd"
UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}">
<File
RelativePath="..\..\vx-scheme.h">
</File>
</Filter>
<Filter
Name="Resource Files"
Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}">
</Filter>
</Files>
<Globals>
</Globals>
</VisualStudioProject>

2
vx-scheme/src/win32/vxs-bootstrap/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
Debug
Release

159
vx-scheme/src/win32/vxs-bootstrap/vxs-bootstrap.vcproj Executable file
View File

@ -0,0 +1,159 @@
<?xml version="1.0" encoding="Windows-1252"?>
<VisualStudioProject
ProjectType="Visual C++"
Version="7.10"
Name="vxs-bootstrap"
ProjectGUID="{04F48FCA-DCE6-484B-B6BA-C3F63BFEBD6C}"
RootNamespace="vxs-bootstrap"
Keyword="Win32Proj">
<Platforms>
<Platform
Name="Win32"/>
</Platforms>
<Configurations>
<Configuration
Name="Debug|Win32"
OutputDirectory="Debug"
IntermediateDirectory="Debug"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
Optimization="0"
PreprocessorDefinitions="WIN32;_DEBUG;_CONSOLE"
MinimalRebuild="TRUE"
BasicRuntimeChecks="3"
RuntimeLibrary="5"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="4"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vxs-bootstrap.exe"
LinkIncremental="2"
GenerateDebugInformation="TRUE"
ProgramDatabaseFile="$(OutDir)/vxs-bootstrap.pdb"
SubSystem="1"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"
CommandLine="$(TargetPath) &lt; $(ProjectDir)\..\bootstrap.scm
"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
<Configuration
Name="Release|Win32"
OutputDirectory="Release"
IntermediateDirectory="Release"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
PreprocessorDefinitions="WIN32;NDEBUG;_CONSOLE"
RuntimeLibrary="4"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="3"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vxs-bootstrap.exe"
LinkIncremental="1"
GenerateDebugInformation="TRUE"
SubSystem="1"
OptimizeReferences="2"
EnableCOMDATFolding="2"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
</Configurations>
<References>
</References>
<Files>
<Filter
Name="Source Files"
Filter="cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx"
UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}">
<File
RelativePath="..\..\cell.cpp">
</File>
<File
RelativePath="..\..\ctx.cpp">
</File>
<File
RelativePath="..\..\interp.cpp">
</File>
<File
RelativePath="..\..\io.cpp">
</File>
<File
RelativePath="..\..\subr.cpp">
</File>
<File
RelativePath="..\..\symtab.cpp">
</File>
<File
RelativePath="..\..\u-main.cpp">
</File>
<File
RelativePath="..\..\vm.cpp">
</File>
</Filter>
<Filter
Name="Header Files"
Filter="h;hpp;hxx;hm;inl;inc;xsd"
UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}">
<File
RelativePath="..\..\vx-scheme.h">
</File>
</Filter>
<Filter
Name="Resource Files"
Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}">
</Filter>
</Files>
<Globals>
</Globals>
</VisualStudioProject>

2
vx-scheme/src/win32/vxs-interp/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
Debug
Release

154
vx-scheme/src/win32/vxs-interp/vxs-interp.vcproj Executable file
View File

@ -0,0 +1,154 @@
<?xml version="1.0" encoding="Windows-1252"?>
<VisualStudioProject
ProjectType="Visual C++"
Version="7.10"
Name="vxs-interp"
ProjectGUID="{FAB1057D-6292-457F-8509-34F3879528BB}"
RootNamespace="vxs-interp"
Keyword="Win32Proj">
<Platforms>
<Platform
Name="Win32"/>
</Platforms>
<Configurations>
<Configuration
Name="Debug|Win32"
OutputDirectory="Debug"
IntermediateDirectory="Debug"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
Optimization="0"
PreprocessorDefinitions="WIN32;_DEBUG;_CONSOLE"
MinimalRebuild="TRUE"
BasicRuntimeChecks="3"
RuntimeLibrary="5"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="4"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vxs-interp.exe"
LinkIncremental="2"
GenerateDebugInformation="TRUE"
ProgramDatabaseFile="$(OutDir)/vxs-interp.pdb"
SubSystem="1"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
<Configuration
Name="Release|Win32"
OutputDirectory="Release"
IntermediateDirectory="Release"
ConfigurationType="1"
CharacterSet="2">
<Tool
Name="VCCLCompilerTool"
PreprocessorDefinitions="WIN32;NDEBUG;_CONSOLE"
RuntimeLibrary="4"
UsePrecompiledHeader="0"
WarningLevel="3"
Detect64BitPortabilityProblems="TRUE"
DebugInformationFormat="3"/>
<Tool
Name="VCCustomBuildTool"/>
<Tool
Name="VCLinkerTool"
OutputFile="$(OutDir)/vxs-interp.exe"
LinkIncremental="1"
GenerateDebugInformation="TRUE"
SubSystem="1"
OptimizeReferences="2"
EnableCOMDATFolding="2"
TargetMachine="1"/>
<Tool
Name="VCMIDLTool"/>
<Tool
Name="VCPostBuildEventTool"/>
<Tool
Name="VCPreBuildEventTool"/>
<Tool
Name="VCPreLinkEventTool"/>
<Tool
Name="VCResourceCompilerTool"/>
<Tool
Name="VCWebServiceProxyGeneratorTool"/>
<Tool
Name="VCXMLDataGeneratorTool"/>
<Tool
Name="VCWebDeploymentTool"/>
<Tool
Name="VCManagedWrapperGeneratorTool"/>
<Tool
Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
</Configuration>
</Configurations>
<References>
</References>
<Files>
<Filter
Name="Source Files"
Filter="cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx"
UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}">
<File
RelativePath="..\..\cell.cpp">
</File>
<File
RelativePath="..\..\ctx.cpp">
</File>
<File
RelativePath="..\..\interp.cpp">
</File>
<File
RelativePath="..\..\io.cpp">
</File>
<File
RelativePath="..\..\subr.cpp">
</File>
<File
RelativePath="..\..\symtab.cpp">
</File>
<File
RelativePath="..\..\u-main.cpp">
</File>
</Filter>
<Filter
Name="Header Files"
Filter="h;hpp;hxx;hm;inl;inc;xsd"
UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}">
<File
RelativePath="..\..\vx-scheme.h">
</File>
</Filter>
<Filter
Name="Resource Files"
Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}">
</Filter>
</Files>
<Globals>
</Globals>
</VisualStudioProject>

2
vx-scheme/testcases/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
*.out
tmp?

9
vx-scheme/testcases/ack.scm Normal file
View File

@ -0,0 +1,9 @@
(define (ack m n)
(cond ((= m 0) (+ n 1))
((= n 0) (ack (- m 1) 1))
(else (ack (- m 1) (ack m (- n 1))))))
(display (ack 3 5)) (newline)
(display (ack 3 6)) (newline)
(display (ack 3 7)) (newline)

291
vx-scheme/testcases/boyer.scm Normal file
View File

@ -0,0 +1,291 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File: boyer.sc
;;; Description: The Boyer benchmark
;;; Author: Bob Boyer
;;; Created: 5-Apr-85
;;; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
;;; 22-Jul-87 (Will Clinger)
;;; 23-May-94 (Qobi)
;;; 31-Mar-98 (Qobi)
;;; 26-Mar-00 (flw)
;;; Language: Scheme (but see note)
;;; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note: This benchmark uses property lists. The procedures that must
;;; be supplied are get and put, where (put x y z) is equivalent to Common
;;; Lisp's (setf (get x y) z).
;;; Note: The Common Lisp version of this benchmark returns the wrong
;;; answer because it uses the Common Lisp equivalent of memv instead of
;;; member in the falsep and truep procedures. (The error arose because
;;; memv is called member in Common Lisp. Don't ask what member is called,
;;; unless you want to learn about keyword arguments.) This Scheme version
;;; may run a few percent slower than it would if it were equivalent to
;;; the Common Lisp version, but it works.
;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
;;; Vx-Scheme: As in SICP 2ed. p. 271, our "get" primitive returns
;;; #f for a nonexistent property. This code, on the other hand,
;;; is expecting to receive '() in that case. We've changed all
;;; the existing 'gets' to cl-get, defined below.
(if (eq? (scheme-implementation-type) 'vx-scheme)
(define (cl-get symbol prop)
(or (get symbol prop) '())))
(define unify-subst '()) ;Qobi
(define temp-temp #f) ;Qobi
(define (add-lemma term)
(cond ((and (pair? term) (eq? (car term) 'equal) (pair? (cadr term)))
(put (car (cadr term))
'lemmas
(cons term (cl-get (car (cadr term)) 'lemmas))))
(else (display "ADD-LEMMA did not like term: ") ;Qobi
(display term) ;Qobi
(newline)))) ;Qobi
(define (add-lemma-lst lst)
(cond ((null? lst) #t)
(else (add-lemma (car lst)) (add-lemma-lst (cdr lst)))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(cond ((begin (set! temp-temp (assq term alist)) temp-temp)
(cdr temp-temp))
(else term)))
(else (cons (car term) (apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst) '()) ;Qobi
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (falsep x lst) (or (equal? x '(f)) (member x lst)))
(define (one-way-unify term1 term2)
(set! unify-subst '()) ;Qobi
(one-way-unify1 term1 term2))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(cond ((begin (set! temp-temp (assq term2 unify-subst)) temp-temp)
(equal? term1 (cdr temp-temp)))
(else (set! unify-subst (cons (cons term2 term1) unify-subst))
#t)))
((not (pair? term1)) #f)
((eq? (car term1) (car term2))
(one-way-unify1-lst (cdr term1) (cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1) #t)
((one-way-unify1 (car lst1) (car lst2))
(one-way-unify1-lst (cdr lst1) (cdr lst2)))
(else #f)))
(define (rewrite term)
(cond ((not (pair? term)) term)
(else (rewrite-with-lemmas (cons (car term) (rewrite-args (cdr term)))
(cl-get (car term) 'lemmas)))))
(define (rewrite-args lst)
(cond ((null? lst) '()) ;Qobi
(else (cons (rewrite (car lst)) (rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst) term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define (setup)
(add-lemma-lst
'((equal (compile form) (reverse (codegen (optimize form) (nil))))
(equal (eqp x y) (equal (fix x) (fix y)))
(equal (greaterp x y) (lessp y x))
(equal (lesseqp x y) (not (lessp y x)))
(equal (greatereqp x y) (not (lessp x y)))
(equal (boolean x) (or (equal x (t)) (equal x (f))))
(equal (iff x y) (and (implies x y) (implies y x)))
(equal (even1 x) (if (zerop x) (t) (odd (sub1 x)))) ;Qobi
(equal (countps- l pred) (countps-loop l pred (zero)))
(equal (fact- i) (fact-loop i (one)))
(equal (reverse- x) (reverse-loop x (nil)))
(equal (divides x y) (zerop (remainder y x)))
(equal (assume-true var alist) (cons (cons var (t)) alist))
(equal (assume-false var alist) (cons (cons var (f)) alist))
(equal (tautology-checker x) (tautologyp (normalize x) (nil)))
(equal (falsify x) (falsify1 (normalize x) (nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x)))) ;Qobi
(equal (and p q) (if p (if q (t) (f)) (f)))
(equal (or p q) (if p (t) (if q (t) (f)) (f)))
(equal (not p) (if p (f) (t)))
(equal (implies p q) (if p (if q (t) (f)) (t)))
(equal (fix x) (if (numberp x) x (zero)))
(equal (if (if a b c) d e) (if a (if b d e) (if c d e)))
(equal (zerop x) (or (equal x (zero)) (not (numberp x))))
(equal (plus (plus x y) z) (plus x (plus y z)))
(equal (equal (plus a b) (zero)) (and (zerop a) (zerop b)))
(equal (difference x x) (zero))
(equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c)))
(equal (equal (zero) (difference x y)) (not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x) (or (equal x (zero)) (zerop y))))
(equal (meaning (plus-tree (append x y)) a)
(plus (meaning (plus-tree x) a) (meaning (plus-tree y) a)))
(equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a)))
(equal (append (append x y) z) (append x (append y z)))
(equal (reverse (append a b)) (append (reverse b) (reverse a)))
(equal (times x (plus y z)) (plus (times x y) (times x z)))
(equal (times (times x y) z) (times x (times y z)))
(equal (equal (times x y) (zero)) (or (zerop x) (zerop y)))
(equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn))
(equal (mc-flatten x y) (append (flatten x) y))
(equal (member x (append a b)) (or (member x a) (member x b)))
(equal (member x (reverse y)) (member x y))
(equal (length (reverse x)) (length x))
(equal (member a (intersect b c)) (and (member a b) (member a c)))
(equal (nth (zero) i) (zero))
(equal (exp i (plus j k)) (times (exp i j) (exp i k)))
(equal (exp i (times j k)) (exp (exp i j) k))
(equal (reverse-loop x y) (append (reverse x) y))
(equal (reverse-loop x (nil)) (reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x) (count-list z y)))
(equal (equal (append a b) (append a c)) (equal b c))
(equal (plus (remainder x y) (times y (quotient x y))) (fix x))
(equal (power-eval (big-plus1 l i base) base)
(plus (power-eval l base) i))
(equal (power-eval (big-plus x y i base) base)
(plus i (plus (power-eval x base) (power-eval y base))))
(equal (remainder y (one)) (zero))
(equal (lessp (remainder x y) y) (not (zerop y)))
(equal (remainder x x) (zero))
(equal (lessp (quotient i j) i)
(and (not (zerop i)) (or (zerop j) (not (equal j (one))))))
(equal (lessp (remainder x y) x)
(and (not (zerop y)) (not (zerop x)) (not (lessp x y))))
(equal (power-eval (power-rep i base) base) (fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y) (gcd y x))
(equal (nth (append a b) i)
(append (nth a i) (nth b (difference i (length a)))))
(equal (difference (plus x y) x) (fix y))
(equal (difference (plus y x) x) (fix y))
(equal (difference (plus x y) (plus x z)) (difference y z))
(equal (times x (difference c w)) (difference (times c x) (times w x)))
(equal (remainder (times x z) z) (zero))
(equal (difference (plus b (plus a c)) a) (plus b c))
(equal (difference (add1 (plus y z)) z) (add1 y))
(equal (lessp (plus x y) (plus x z)) (lessp y z))
(equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y)))
(equal (lessp y (plus x y)) (not (zerop x)))
(equal (gcd (times x z) (times y z)) (times z (gcd x y)))
(equal (value (normalize x) a) (value x a))
(equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y)))
(equal (listp (gopher x)) (listp x))
(equal (samefringe x y) (equal (flatten x) (flatten y)))
(equal (equal (greatest-factor x y) (zero))
(and (or (zerop y) (equal y (one))) (equal x (zero))))
(equal (equal (greatest-factor x y) (one)) (equal x (one)))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y) (equal y (one))) (not (numberp x)))))
(equal (times-list (append x y)) (times (times-list x) (times-list y)))
(equal (prime-list (append x y)) (and (prime-list x) (prime-list y)))
(equal (equal z (times w z))
(and (numberp z) (or (equal z (zero)) (equal w (one)))))
(equal (greatereqpr x y) (not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero)) (and (numberp x) (equal y (one)))))
(equal (remainder (times y x) y) (zero))
(equal (equal (times a b) (one))
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a) (zero)) ;Qobi
(equal (sub1 b) (zero)))) ;Qobi
(equal (lessp (length (delete x l)) (length l)) (member x l))
(equal (sort2 (delete x l)) (delete x (sort2 l)))
(equal (dsort x) (sort2 x))
(equal (length
(cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7)))))))
(plus (six) (length x7)))
(equal (difference (add1 (add1 x)) (two)) (fix x))
(equal (quotient (plus x (plus x y)) (two)) (plus x (quotient y (two))))
(equal (sigma (zero) i) (quotient (times i (add1 i)) (two)))
(equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x)))
(equal (equal (difference x y) (difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z)))))
(equal (meaning (plus-tree (delete x y)) a)
(if (member x y)
(difference (meaning (plus-tree y) a) (meaning x a))
(meaning (plus-tree y) a)))
(equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x)))
(equal (nth (nil) i) (if (zerop i) (nil) (zero)))
(equal (last (append a b))
(if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b)))
(equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z)))
(equal (assignment x (append a b))
(if (assignedp x a) (assignment x a) (assignment x b)))
(equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x) (cdr (flatten x)) (cons (zero) (nil))))
(equal (quotient (times y x) y) (if (zerop y) (zero) (fix x)))
(equal (cl-get j (set i val mem)) (if (eqp j i) val (cl-get j mem))))))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst) #t)
((falsep x false-lst) #f)
((not (pair? x)) #f)
((eq? (car x) 'if)
(cond ((truep (cadr x) true-lst)
(tautologyp (caddr x) true-lst false-lst))
((falsep (cadr x) false-lst)
(tautologyp (cadddr x) true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x) true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x) false-lst))))))
(else #f)))
(define (tautp x) (tautologyp (rewrite x) '() '())) ;Qobi
(define (test)
(define ans #f)
(define term #f)
(set! term
(apply-subst
'((x f (plus (plus a b) (plus c (zero))))
(y f (times (times a b) (plus c d)))
(z f (reverse (append (append a b) (nil))))
(u equal (plus a b) (difference x y))
(w lessp (remainder a b) (member a (length b))))
'(implies (and (implies x y)
(and (implies y z) (and (implies z u) (implies u w))))
(implies x w))))
(set! ans (tautp term))
ans)
(define (truep x lst) (or (equal? x '(t)) (member x lst)))
(setup)
(display (test))
(newline)

3
vx-scheme/testcases/c-good/ack.good Executable file
View File

@ -0,0 +1,3 @@
253
509
1021

1
vx-scheme/testcases/c-good/boyer.good Normal file
View File

@ -0,0 +1 @@
#t

65
vx-scheme/testcases/c-good/cf.good Normal file
View File

@ -0,0 +1,65 @@
1
1
1
1
1
(1 1 1.)
(2 1 2.)
(3 2 1.5)
(5 3 1.66666666666667)
(8 5 1.6)
(13 8 1.625)
(21 13 1.61538461538462)
(34 21 1.61904761904762)
(55 34 1.61764705882353)
(89 55 1.61818181818182)
(144 89 1.61797752808989)
(233 144 1.61805555555556)
(377 233 1.61802575107296)
(610 377 1.61803713527851)
(987 610 1.61803278688525)
(1597 987 1.61803444782168)
(2584 1597 1.61803381340013)
(4181 2584 1.61803405572755)
(6765 4181 1.61803396316671)
(10946 6765 1.6180339985218)
(17711 10946 1.61803398501736)
(28657 17711 1.6180339901756)
(46368 28657 1.61803398820532)
(75025 46368 1.6180339889579)
(121393 75025 1.61803398867044)
(196418 121393 1.61803398878024)
(317811 196418 1.6180339887383)
(514229 317811 1.61803398875432)
(832040 514229 1.6180339887482)
(1346269 832040 1.61803398875054)
(2178309 1346269 1.61803398874965)
(3524578 2178309 1.61803398874999)
(5702887 3524578 1.61803398874986)
(9227465 5702887 1.61803398874991)
(14930352 9227465 1.61803398874989)
(24157817 14930352 1.6180339887499)
(39088169 24157817 1.61803398874989)
(63245986 39088169 1.6180339887499)
(102334155 63245986 1.61803398874989)
(165580141 102334155 1.61803398874989)
1.61803398874989(2 1 2.)
(5 2 2.5)
(12 5 2.4)
(29 12 2.41666666666667)
(70 29 2.41379310344828)
(169 70 2.41428571428571)
(408 169 2.41420118343195)
(985 408 2.41421568627451)
(2378 985 2.41421319796954)
(5741 2378 2.41421362489487)
(1 1 1.)
(3 2 1.5)
(4 3 1.33333333333333)
(11 8 1.375)
(15 11 1.36363636363636)
(41 30 1.36666666666667)
(56 41 1.36585365853659)
(153 112 1.36607142857143)
(209 153 1.36601307189542)
(571 418 1.36602870813397)

1
vx-scheme/testcases/c-good/dderiv.good Normal file
View File

@ -0,0 +1 @@
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) (* (* b x) (+ (/ 0 b) (/ 1 x))) 0)

1
vx-scheme/testcases/c-good/dynamic.good Normal file
View File

@ -0,0 +1 @@
((218 . 437) (6 . 1892) (2204 . 441))

1
vx-scheme/testcases/c-good/earley.good Normal file
View File

@ -0,0 +1 @@
1430

42
vx-scheme/testcases/c-good/maze.good Normal file
View File

@ -0,0 +1,42 @@
_ _ _
_/ \_/ \_/.\
/ \ \_ . /.\
\ \ /. _/.\ /
/ \_/. _/ \_ .\
\ / \ / _/ \_/
/ _/.\ / \ / \
\ / \ / _/ /
/ \ /.\ /.\_/ \
\_/ \ /. _ .\ /
/ \_ . _/ \ \
\_ \_/ _/.\ /
/ _/ / \ / \
\_ \ / \_ .\_/
/ \_ \_ \_ .\
\_ \_/ _/.\ /
/ \_ \ /.\ .\
\ /.\_ . /.\ /
/ . _/.\ / \
\ /.\_/.\_ .\ /
/ \_ . / _/ \
\_ \_/.\_ \_/
/ _/ \ / \_ \
\_/ _/.\_ \_/
/ \ / _ . _ \
\ / \_/. _ \_/
/ _ \ \_/ \
\_/.\_ .\_/ _/
/ \ . _/ / \
\ /.\_/ \_/.\ /
/ \_ . _/. \
\ . /.\_/
/ \_/ \_/ \_ .\
\_/ / \_/. /
/ / _ \ / \
\_/ \_/ \_/.\_/
/ \_/ _/ \_ .\
\ _/. /. _/
/ \ /. / \_ .\
\_/. _/.\_/.\ /
/ _ .\_ . _ .\
\_/ \ / \_/ \_/

7
vx-scheme/testcases/c-good/pi.good Executable file
View File

@ -0,0 +1,7 @@
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
08128 48111 74502 84102 70193 85211 05559 64462 29489 54930
38196 44288 10975 66593 34461 28475 64823 37867 83165 27120
19091 45648 56692 34603 48610 45432 66482 13393 60726 02491
41273

19
vx-scheme/testcases/c-good/puzzle.good Normal file
View File

@ -0,0 +1,19 @@
Piece 1 at 1.
Piece 8 at 354.
Piece 7 at 330.
Piece 3 at 291.
Piece 13 at 278.
Piece 12 at 276.
Piece 5 at 275.
Piece 1 at 267.
Piece 1 at 219.
Piece 3 at 203.
Piece 1 at 202.
Piece 1 at 154.
Piece 9 at 138.
Piece 2 at 110.
Piece 2 at 108.
Piece 1 at 106.
Piece 3 at 90.
Success in 2005 trials.

772
vx-scheme/testcases/c-good/r4rstest.good Normal file
View File

@ -0,0 +1,772 @@
SECTION(2 1)
SECTION(3 4)
#<subr boolean?>
#<subr char?>
#<subr null?>
#<subr number?>
#<subr pair?>
#<subr procedure?>
#<subr string?>
#<subr symbol?>
#<subr vector?>
(#t #f #f #f #f #f #f #f #f)#t
(#t #f #f #f #f #f #f #f #f)#f
(#f #t #f #f #f #f #f #f #f)#\a
(#f #f #t #f #f #f #f #f #f)()
(#f #f #f #t #f #f #f #f #f)9739
(#f #f #f #f #t #f #f #f #f)(test)
(#f #f #f #f #f #t #f #f #f)#<compiled-procedure>
(#f #f #f #f #f #f #t #f #f)"test"
(#f #f #f #f #f #f #t #f #f)""
(#f #f #f #f #f #f #f #t #f)test
(#f #f #f #f #f #f #f #f #t)#()
(#f #f #f #f #f #f #f #f #t)#(a b c)
SECTION(4 1 2)
(quote (quote a)) ==> (quote a)
(quote (quote a)) ==> (quote a)
SECTION(4 1 3)
(#<subr *> 3 4) ==> 12
SECTION(4 1 4)
(#<compiled-procedure> 4) ==> 8
(#<compiled-procedure> 7 10) ==> 3
(#<compiled-procedure> 6) ==> 10
(#<compiled-procedure> 3 4 5 6) ==> (3 4 5 6)
(#<compiled-procedure> 3 4 5 6) ==> (5 6)
SECTION(4 1 5)
(if yes) ==> yes
(if no) ==> no
(if 1) ==> 1
SECTION(4 1 6)
(define 3) ==> 3
(set! 5) ==> 5
SECTION(4 2 1)
(cond greater) ==> greater
(cond equal) ==> equal
(cond 2) ==> 2
(case composite) ==> composite
(case consonant) ==> consonant
(and #t) ==> #t
(and #f) ==> #f
(and (f g)) ==> (f g)
(and #t) ==> #t
(or #t) ==> #t
(or #t) ==> #t
(or #f) ==> #f
(or #f) ==> #f
(or (b c)) ==> (b c)
SECTION(4 2 2)
(let 6) ==> 6
(let 35) ==> 35
(let* 70) ==> 70
(letrec #t) ==> #t
(let 5) ==> 5
(let 34) ==> 34
(let 6) ==> 6
(let 34) ==> 34
(let* 7) ==> 7
(let* 34) ==> 34
(let* 8) ==> 8
(let* 34) ==> 34
(letrec 9) ==> 9
(letrec 34) ==> 34
(letrec 10) ==> 10
(letrec 34) ==> 34
SECTION(4 2 3)
(begin 6) ==> 6
SECTION(4 2 4)
(do #(0 1 2 3 4)) ==> #(0 1 2 3 4)
(do 25) ==> 25
(let 1) ==> 1
(let ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
(let -1) ==> -1
SECTION(4 2 6)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (list a (quote a))) ==> (list a (quote a))
(quasiquote (a 3 4 5 6 b)) ==> (a 3 4 5 6 b)
(quasiquote ((foo 7) . cons)) ==> ((foo 7) . cons)
(quasiquote #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
(quasiquote 5) ==> 5
(quasiquote (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)) ==> (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)
(quasiquote (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)) ==> (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) ==> (quasiquote (list (unquote (+ 1 2)) 4))
SECTION(5 2 1)
(define 6) ==> 6
(define 1) ==> 1
(#<compiled-procedure> 6) ==> 9
SECTION(5 2 2)
(define 45) ==> 45
(#<compiled-procedure>) ==> 5
(define 34) ==> 34
(#<compiled-procedure>) ==> 5
(define 34) ==> 34
(#<compiled-procedure> 88) ==> 88
(#<compiled-procedure> 4) ==> 4
(define 34) ==> 34
(internal-define 99) ==> 99
(internal-define 77) ==> 77
SECTION(6 1)
(#<subr not> #t) ==> #f
(#<subr not> 3) ==> #f
(#<subr not> (3)) ==> #f
(#<subr not> #f) ==> #t
(#<subr not> ()) ==> #f
(#<subr not> ()) ==> #f
(#<subr not> nil) ==> #f
SECTION(6 2)
(#<subr eqv?> a a) ==> #t
(#<subr eqv?> a b) ==> #f
(#<subr eqv?> 2 2) ==> #t
(#<subr eqv?> () ()) ==> #t
(#<subr eqv?> 10000 10000) ==> #t
(#<subr eqv?> (1 . 2) (1 . 2)) ==> #f
(#<subr eqv?> #<compiled-procedure> #<compiled-procedure>) ==> #f
(#<subr eqv?> #f nil) ==> #f
(#<subr eqv?> #<compiled-procedure> #<compiled-procedure>) ==> #t
(#<subr eqv?> #<compiled-procedure> #<compiled-procedure>) ==> #t
(#<subr eqv?> #<compiled-procedure> #<compiled-procedure>) ==> #f
(#<subr eqv?> #<compiled-procedure> #<compiled-procedure>) ==> #f
(#<subr eq?> a a) ==> #t
(#<subr eq?> (a) (a)) ==> #f
(#<subr eq?> () ()) ==> #t
(#<subr eq?> #<subr car> #<subr car>) ==> #t
(#<subr eq?> (a) (a)) ==> #t
(#<subr eq?> #() #()) ==> #t
(#<subr eq?> #<compiled-procedure> #<compiled-procedure>) ==> #t
(#<subr equal?> a a) ==> #t
(#<subr equal?> (a) (a)) ==> #t
(#<subr equal?> (a (b) c) (a (b) c)) ==> #t
(#<subr equal?> "abc" "abc") ==> #t
(#<subr equal?> 2 2) ==> #t
(#<subr equal?> #(a a a a a) #(a a a a a)) ==> #t
SECTION(6 3)
(dot (a b c d e)) ==> (a b c d e)
(#<subr list?> (a b c)) ==> #t
(set-cdr! (a . 4)) ==> (a . 4)
(#<subr eqv?> (a . 4) (a . 4)) ==> #t
(dot (a b c . d)) ==> (a b c . d)
(#<subr list?> (a . 4)) ==> #f
(list? #f) ==> #f
(#<subr cons> a ()) ==> (a)
(#<subr cons> (a) (b c d)) ==> ((a) b c d)
(#<subr cons> "a" (b c)) ==> ("a" b c)
(#<subr cons> a 3) ==> (a . 3)
(#<subr cons> (a b) c) ==> ((a b) . c)
(#<subr car> (a b c)) ==> a
(#<subr car> ((a) b c d)) ==> (a)
(#<subr car> (1 . 2)) ==> 1
(#<subr cdr> ((a) b c d)) ==> (b c d)
(#<subr cdr> (1 . 2)) ==> 2
(#<subr list> a 7 c) ==> (a 7 c)
(#<subr list>) ==> ()
(#<subr length> (a b c)) ==> 3
(#<subr length> (a (b) (c d e))) ==> 3
(#<subr length> ()) ==> 0
(#<subr append> (x) (y)) ==> (x y)
(#<subr append> (a) (b c d)) ==> (a b c d)
(#<subr append> (a (b)) ((c))) ==> (a (b) (c))
(#<subr append>) ==> ()
(#<subr append> (a b) (c . d)) ==> (a b c . d)
(#<subr append> () a) ==> a
(#<subr reverse> (a b c)) ==> (c b a)
(#<subr reverse> (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a)
(#<subr list-ref> (a b c d) 2) ==> c
(#<subr memq> a (a b c)) ==> (a b c)
(#<subr memq> b (a b c)) ==> (b c)
(#<subr memq> a (b c d)) ==> #f
(#<subr memq> (a) (b (a) c)) ==> #f
(#<subr member> (a) (b (a) c)) ==> ((a) c)
(#<subr memv> 101 (100 101 102)) ==> (101 102)
(#<subr assq> a ((a 1) (b 2) (c 3))) ==> (a 1)
(#<subr assq> b ((a 1) (b 2) (c 3))) ==> (b 2)
(#<subr assq> d ((a 1) (b 2) (c 3))) ==> #f
(#<subr assq> (a) (((a)) ((b)) ((c)))) ==> #f
(#<subr assoc> (a) (((a)) ((b)) ((c)))) ==> ((a))
(#<subr assv> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
SECTION(6 4)
(#<subr symbol?> a) ==> #t
(standard-case #t) ==> #t
(standard-case #t) ==> #t
(#<subr symbol->string> flying-fish) ==> "flying-fish"
(#<subr symbol->string> martin) ==> "martin"
(#<subr symbol->string> Malvina) ==> "Malvina"
(standard-case #t) ==> #t
(string-set! "cb") ==> "cb"
(#<subr symbol->string> ab) ==> "ab"
(#<subr string->symbol> "ab") ==> ab
(#<subr eq?> mississippi mississippi) ==> #t
(string->symbol #f) ==> #f
(#<subr string->symbol> "jollywog") ==> jollywog
SECTION(6 5 5)
(#<subr number?> 3) ==> #t
(#<subr complex?> 3) ==> #t
(#<subr real?> 3) ==> #t
(#<subr rational?> 3) ==> #t
(#<subr integer?> 3) ==> #t
(#<subr exact?> 3) ==> #t
(#<subr inexact?> 3) ==> #f
(#<subr => 22 22 22) ==> #t
(#<subr => 22 22) ==> #t
(#<subr => 34 34 35) ==> #f
(#<subr => 34 35) ==> #f
(#<subr >> 3 -6246) ==> #t
(#<subr >> 9 9 -2424) ==> #f
(#<subr >=> 3 -4 -6246) ==> #t
(#<subr >=> 9 9) ==> #t
(#<subr >=> 8 9) ==> #f
(#<subr <> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <> -1 2 3 4 4 5 6 7) ==> #f
(#<subr <=> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <=> -1 2 3 4 4 5 6 7) ==> #t
(#<subr <> 1 3 2) ==> #f
(#<subr >=> 1 3 2) ==> #f
(#<subr zero?> 0) ==> #t
(#<subr zero?> 1) ==> #f
(#<subr zero?> -1) ==> #f
(#<subr zero?> -100) ==> #f
(#<subr positive?> 4) ==> #t
(#<subr positive?> -4) ==> #f
(#<subr positive?> 0) ==> #f
(#<subr negative?> 4) ==> #f
(#<subr negative?> -4) ==> #t
(#<subr negative?> 0) ==> #f
(#<subr odd?> 3) ==> #t
(#<subr odd?> 2) ==> #f
(#<subr odd?> -4) ==> #f
(#<subr odd?> -1) ==> #t
(#<subr even?> 3) ==> #f
(#<subr even?> 2) ==> #t
(#<subr even?> -4) ==> #t
(#<subr even?> -1) ==> #f
(#<subr max> 34 5 7 38 6) ==> 38
(#<subr min> 3 5 5 330 4 -24) ==> -24
(#<subr +> 3 4) ==> 7
(#<subr +> 3) ==> 3
(#<subr +>) ==> 0
(#<subr *> 4) ==> 4
(#<subr *>) ==> 1
(#<subr -> 3 4) ==> -1
(#<subr -> 3) ==> -3
(#<subr abs> -7) ==> 7
(#<subr abs> 7) ==> 7
(#<subr abs> 0) ==> 0
(#<subr quotient> 35 7) ==> 5
(#<subr quotient> -35 7) ==> -5
(#<subr quotient> 35 -7) ==> -5
(#<subr quotient> -35 -7) ==> 5
(#<subr modulo> 13 4) ==> 1
(#<subr remainder> 13 4) ==> 1
(#<subr modulo> -13 4) ==> 3
(#<subr remainder> -13 4) ==> -1
(#<subr modulo> 13 -4) ==> -3
(#<subr remainder> 13 -4) ==> 1
(#<subr modulo> -13 -4) ==> -1
(#<subr remainder> -13 -4) ==> -1
(#<subr modulo> 0 86400) ==> 0
(#<subr modulo> 0 -86400) ==> 0
(#<compiled-procedure> 238 9) ==> #t
(#<compiled-procedure> -238 9) ==> #t
(#<compiled-procedure> 238 -9) ==> #t
(#<compiled-procedure> -238 -9) ==> #t
(#<subr gcd> 0 4) ==> 4
(#<subr gcd> -4 0) ==> 4
(#<subr gcd> 32 -36) ==> 4
(#<subr gcd>) ==> 0
(#<subr lcm> 32 -36) ==> 288
(#<subr lcm>) ==> 1
SECTION(6 5 9)
(#<subr number->string> 0) ==> "0"
(#<subr number->string> 100) ==> "100"
(#<subr number->string> 256 16) ==> "100"
(#<subr string->number> "100") ==> 100
(#<subr string->number> "100" 16) ==> 256
(#<subr string->number> "") ==> #f
(#<subr string->number> ".") ==> #f
(#<subr string->number> "d") ==> #f
(#<subr string->number> "D") ==> #f
(#<subr string->number> "i") ==> #f
(#<subr string->number> "I") ==> #f
(#<subr string->number> "3i") ==> #f
(#<subr string->number> "3I") ==> #f
(#<subr string->number> "33i") ==> #f
(#<subr string->number> "33I") ==> #f
(#<subr string->number> "3.3i") ==> #f
(#<subr string->number> "3.3I") ==> #f
(#<subr string->number> "-") ==> #f
(#<subr string->number> "+") ==> #f
SECTION(6 6)
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr char?> #\a) ==> #t
(#<subr char?> #\() ==> #t
(#<subr char?> #\ ) ==> #t
(#<subr char?> #\
) ==> #t
(#<subr char=?> #\A #\B) ==> #f
(#<subr char=?> #\a #\b) ==> #f
(#<subr char=?> #\9 #\0) ==> #f
(#<subr char=?> #\A #\A) ==> #t
(#<subr char<?> #\A #\B) ==> #t
(#<subr char<?> #\a #\b) ==> #t
(#<subr char<?> #\9 #\0) ==> #f
(#<subr char<?> #\A #\A) ==> #f
(#<subr char>?> #\A #\B) ==> #f
(#<subr char>?> #\a #\b) ==> #f
(#<subr char>?> #\9 #\0) ==> #t
(#<subr char>?> #\A #\A) ==> #f
(#<subr char<=?> #\A #\B) ==> #t
(#<subr char<=?> #\a #\b) ==> #t
(#<subr char<=?> #\9 #\0) ==> #f
(#<subr char<=?> #\A #\A) ==> #t
(#<subr char>=?> #\A #\B) ==> #f
(#<subr char>=?> #\a #\b) ==> #f
(#<subr char>=?> #\9 #\0) ==> #t
(#<subr char>=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\B) ==> #f
(#<subr char-ci=?> #\a #\B) ==> #f
(#<subr char-ci=?> #\A #\b) ==> #f
(#<subr char-ci=?> #\a #\b) ==> #f
(#<subr char-ci=?> #\9 #\0) ==> #f
(#<subr char-ci=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\a) ==> #t
(#<subr char-ci<?> #\A #\B) ==> #t
(#<subr char-ci<?> #\a #\B) ==> #t
(#<subr char-ci<?> #\A #\b) ==> #t
(#<subr char-ci<?> #\a #\b) ==> #t
(#<subr char-ci<?> #\9 #\0) ==> #f
(#<subr char-ci<?> #\A #\A) ==> #f
(#<subr char-ci<?> #\A #\a) ==> #f
(#<subr char-ci>?> #\A #\B) ==> #f
(#<subr char-ci>?> #\a #\B) ==> #f
(#<subr char-ci>?> #\A #\b) ==> #f
(#<subr char-ci>?> #\a #\b) ==> #f
(#<subr char-ci>?> #\9 #\0) ==> #t
(#<subr char-ci>?> #\A #\A) ==> #f
(#<subr char-ci>?> #\A #\a) ==> #f
(#<subr char-ci<=?> #\A #\B) ==> #t
(#<subr char-ci<=?> #\a #\B) ==> #t
(#<subr char-ci<=?> #\A #\b) ==> #t
(#<subr char-ci<=?> #\a #\b) ==> #t
(#<subr char-ci<=?> #\9 #\0) ==> #f
(#<subr char-ci<=?> #\A #\A) ==> #t
(#<subr char-ci<=?> #\A #\a) ==> #t
(#<subr char-ci>=?> #\A #\B) ==> #f
(#<subr char-ci>=?> #\a #\B) ==> #f
(#<subr char-ci>=?> #\A #\b) ==> #f
(#<subr char-ci>=?> #\a #\b) ==> #f
(#<subr char-ci>=?> #\9 #\0) ==> #t
(#<subr char-ci>=?> #\A #\A) ==> #t
(#<subr char-ci>=?> #\A #\a) ==> #t
(#<subr char-alphabetic?> #\a) ==> #t
(#<subr char-alphabetic?> #\A) ==> #t
(#<subr char-alphabetic?> #\z) ==> #t
(#<subr char-alphabetic?> #\Z) ==> #t
(#<subr char-alphabetic?> #\0) ==> #f
(#<subr char-alphabetic?> #\9) ==> #f
(#<subr char-alphabetic?> #\ ) ==> #f
(#<subr char-alphabetic?> #\;) ==> #f
(#<subr char-numeric?> #\a) ==> #f
(#<subr char-numeric?> #\A) ==> #f
(#<subr char-numeric?> #\z) ==> #f
(#<subr char-numeric?> #\Z) ==> #f
(#<subr char-numeric?> #\0) ==> #t
(#<subr char-numeric?> #\9) ==> #t
(#<subr char-numeric?> #\ ) ==> #f
(#<subr char-numeric?> #\;) ==> #f
(#<subr char-whitespace?> #\a) ==> #f
(#<subr char-whitespace?> #\A) ==> #f
(#<subr char-whitespace?> #\z) ==> #f
(#<subr char-whitespace?> #\Z) ==> #f
(#<subr char-whitespace?> #\0) ==> #f
(#<subr char-whitespace?> #\9) ==> #f
(#<subr char-whitespace?> #\ ) ==> #t
(#<subr char-whitespace?> #\;) ==> #f
(#<subr char-upper-case?> #\0) ==> #f
(#<subr char-upper-case?> #\9) ==> #f
(#<subr char-upper-case?> #\ ) ==> #f
(#<subr char-upper-case?> #\;) ==> #f
(#<subr char-lower-case?> #\0) ==> #f
(#<subr char-lower-case?> #\9) ==> #f
(#<subr char-lower-case?> #\ ) ==> #f
(#<subr char-lower-case?> #\;) ==> #f
(#<subr integer->char> 46) ==> #\.
(#<subr integer->char> 65) ==> #\A
(#<subr integer->char> 97) ==> #\a
(#<subr char-upcase> #\A) ==> #\A
(#<subr char-upcase> #\a) ==> #\A
(#<subr char-downcase> #\A) ==> #\a
(#<subr char-downcase> #\a) ==> #\a
SECTION(6 7)
(#<subr string?> "The word \"recursion\\\" has many meanings.") ==> #t
(string-set! "?**") ==> "?**"
(#<subr string> #\a #\b #\c) ==> "abc"
(#<subr string>) ==> ""
(#<subr string-length> "abc") ==> 3
(#<subr string-ref> "abc" 0) ==> #\a
(#<subr string-ref> "abc" 2) ==> #\c
(#<subr string-length> "") ==> 0
(#<subr substring> "ab" 0 0) ==> ""
(#<subr substring> "ab" 1 1) ==> ""
(#<subr substring> "ab" 2 2) ==> ""
(#<subr substring> "ab" 0 1) ==> "a"
(#<subr substring> "ab" 1 2) ==> "b"
(#<subr substring> "ab" 0 2) ==> "ab"
(#<subr string-append> "foo" "bar") ==> "foobar"
(#<subr string-append> "foo") ==> "foo"
(#<subr string-append> "foo" "") ==> "foo"
(#<subr string-append> "" "foo") ==> "foo"
(#<subr string-append>) ==> ""
(#<subr make-string> 0) ==> ""
(#<subr string=?> "" "") ==> #t
(#<subr string<?> "" "") ==> #f
(#<subr string>?> "" "") ==> #f
(#<subr string<=?> "" "") ==> #t
(#<subr string>=?> "" "") ==> #t
(#<subr string-ci=?> "" "") ==> #t
(#<subr string-ci<?> "" "") ==> #f
(#<subr string-ci>?> "" "") ==> #f
(#<subr string-ci<=?> "" "") ==> #t
(#<subr string-ci>=?> "" "") ==> #t
(#<subr string=?> "A" "B") ==> #f
(#<subr string=?> "a" "b") ==> #f
(#<subr string=?> "9" "0") ==> #f
(#<subr string=?> "A" "A") ==> #t
(#<subr string<?> "A" "B") ==> #t
(#<subr string<?> "a" "b") ==> #t
(#<subr string<?> "9" "0") ==> #f
(#<subr string<?> "A" "A") ==> #f
(#<subr string>?> "A" "B") ==> #f
(#<subr string>?> "a" "b") ==> #f
(#<subr string>?> "9" "0") ==> #t
(#<subr string>?> "A" "A") ==> #f
(#<subr string<=?> "A" "B") ==> #t
(#<subr string<=?> "a" "b") ==> #t
(#<subr string<=?> "9" "0") ==> #f
(#<subr string<=?> "A" "A") ==> #t
(#<subr string>=?> "A" "B") ==> #f
(#<subr string>=?> "a" "b") ==> #f
(#<subr string>=?> "9" "0") ==> #t
(#<subr string>=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "B") ==> #f
(#<subr string-ci=?> "a" "B") ==> #f
(#<subr string-ci=?> "A" "b") ==> #f
(#<subr string-ci=?> "a" "b") ==> #f
(#<subr string-ci=?> "9" "0") ==> #f
(#<subr string-ci=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "a") ==> #t
(#<subr string-ci<?> "A" "B") ==> #t
(#<subr string-ci<?> "a" "B") ==> #t
(#<subr string-ci<?> "A" "b") ==> #t
(#<subr string-ci<?> "a" "b") ==> #t
(#<subr string-ci<?> "9" "0") ==> #f
(#<subr string-ci<?> "A" "A") ==> #f
(#<subr string-ci<?> "A" "a") ==> #f
(#<subr string-ci>?> "A" "B") ==> #f
(#<subr string-ci>?> "a" "B") ==> #f
(#<subr string-ci>?> "A" "b") ==> #f
(#<subr string-ci>?> "a" "b") ==> #f
(#<subr string-ci>?> "9" "0") ==> #t
(#<subr string-ci>?> "A" "A") ==> #f
(#<subr string-ci>?> "A" "a") ==> #f
(#<subr string-ci<=?> "A" "B") ==> #t
(#<subr string-ci<=?> "a" "B") ==> #t
(#<subr string-ci<=?> "A" "b") ==> #t
(#<subr string-ci<=?> "a" "b") ==> #t
(#<subr string-ci<=?> "9" "0") ==> #f
(#<subr string-ci<=?> "A" "A") ==> #t
(#<subr string-ci<=?> "A" "a") ==> #t
(#<subr string-ci>=?> "A" "B") ==> #f
(#<subr string-ci>=?> "a" "B") ==> #f
(#<subr string-ci>=?> "A" "b") ==> #f
(#<subr string-ci>=?> "a" "b") ==> #f
(#<subr string-ci>=?> "9" "0") ==> #t
(#<subr string-ci>=?> "A" "A") ==> #t
(#<subr string-ci>=?> "A" "a") ==> #t
SECTION(6 8)
(#<subr vector?> #(0 (2 2 2 2) "Anna")) ==> #t
(#<subr vector> a b c) ==> #(a b c)
(#<subr vector>) ==> #()
(#<subr vector-length> #(0 (2 2 2 2) "Anna")) ==> 3
(#<subr vector-length> #()) ==> 0
(#<subr vector-ref> #(1 1 2 3 5 8 13 21) 5) ==> 8
(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
(#<subr make-vector> 2 hi) ==> #(hi hi)
(#<subr make-vector> 0) ==> #()
(#<subr make-vector> 0 a) ==> #()
SECTION(6 9)
(#<subr procedure?> #<subr car>) ==> #t
(#<subr procedure?> #<compiled-procedure>) ==> #t
(#<subr procedure?> (lambda (x) (* x x))) ==> #f
(#<compiled-procedure> #<subr procedure?>) ==> #t
(#<compiled-procedure> #<subr +> (3 4)) ==> 7
(#<compiled-procedure> #<compiled-procedure> (3 4)) ==> 7
(#<compiled-procedure> #<subr +> 10 (3 4)) ==> 17
(#<compiled-procedure> #<subr list> ()) ==> ()
(#<compiled-procedure> 12 75) ==> 30
(#<compiled-procedure> #<subr cadr> ((a b) (d e) (g h))) ==> (b e h)
(#<compiled-procedure> #<subr +> (1 2 3) (4 5 6)) ==> (5 7 9)
(#<compiled-procedure> #<subr +> (1 2 3)) ==> (1 2 3)
(#<compiled-procedure> #<subr *> (1 2 3)) ==> (1 2 3)
(#<compiled-procedure> #<subr -> (1 2 3)) ==> (-1 -2 -3)
(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16)
(#<compiled-procedure> #<compiled-procedure>) ==> -3
(#<compiled-procedure> (1 2 3 4)) ==> 4
(#<compiled-procedure> (a b . c)) ==> #f
(#<compiled-procedure> #<subr cadr> ()) ==> ()
SECTION(6 10 1)
(#<subr input-port?> #<input-port>) ==> #t
(#<subr output-port?> #<output-port>) ==> #t
(#<compiled-procedure> "r4rstest.scm" #<subr input-port?>) ==> #t
(#<subr input-port?> #<input-port>) ==> #t
SECTION(6 10 2)
(#<subr peek-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (define cur-section (quote ()))
(#<subr peek-char> #<input-port>) ==> #\(
(#<subr read> #<input-port>) ==> (define errs (quote ()))
SECTION(6 10 3)
(#<compiled-procedure> "tmp1" #<compiled-procedure>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr output-port?> #<output-port>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
Passed all tests
;testing inexact numbers;
SECTION(6 5 5)
(#<subr inexact?> 3.9) ==> #t
(inexact? #t) ==> #t
(max 4.) ==> 4.
(exact->inexact 4.) ==> 4.
(#<subr round> -4.5) ==> -4.
(#<subr round> -3.5) ==> -4.
(#<subr round> -3.9) ==> -4.
(#<subr round> 0.) ==> 0.
(#<subr round> 0.25) ==> 0.
(#<subr round> 0.8) ==> 1.
(#<subr round> 3.5) ==> 4.
(#<subr round> 4.5) ==> 4.
(#<subr expt> 0 0) ==> 1
(#<subr expt> 0 1) ==> 0
(#<compiled-procedure> "tmp3" #<compiled-procedure>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (0.25 -3.25)
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(pentium-fdiv-bug #t) ==> #t
Passed all tests
SECTION(6 5 6)
(float-print-test #t) ==> #t
Number readback failure for (+ 1. (* -100 1.11022302462516e-16))
0.999999999999989
Number readback failure for (+ 10. (* -100 1.77635683940025e-15))
9.99999999999982
Number readback failure for (+ 100. (* -100 1.4210854715202e-14))
99.9999999999986
Number readback failure for (+ 1e+20 (* -100 16384.))
9.99999999999984e+19
Number readback failure for (+ 1e+50 (* -100 2.07691874341393e+34))
9.99999999999979e+49
Number readback failure for (+ 1e+100 (* -100 1.94266889222573e+84))
9.99999999999981e+99
Number readback failure for (+ 0.1 (* -100 1.38777878078145e-17))
0.0999999999999986
Number readback failure for (+ 0.01 (* -100 1.73472347597681e-18))
0.00999999999999983
Number readback failure for (+ 0.001 (* -100 2.16840434497101e-19))
0.000999999999999978
Number readback failure for (+ 1e-20 (* -100 1.50463276905253e-36))
9.99999999999985e-21
Number readback failure for (+ 1e-50 (* -100 1.18694596821997e-66))
9.99999999999988e-51
Number readback failure for (+ 1e-100 (* -100 1.26897091865782e-116))
9.99999999999987e-101
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3. (* -100 4.44089209850063e-16))
2.99999999999996
Number readback failure for (+ 30. (* -100 3.5527136788005e-15))
29.9999999999996
Number readback failure for (+ 300. (* -100 5.6843418860808e-14))
299.999999999994
Number readback failure for (+ 3e+20 (* -100 65536.))
2.99999999999993e+20
Number readback failure for (+ 3e+50 (* -100 4.15383748682786e+34))
2.99999999999996e+50
Number readback failure for (+ 3e+100 (* -100 3.88533778445146e+84))
2.99999999999996e+100
Number readback failure for (+ 0.3 (* -100 5.55111512312578e-17))
0.299999999999994
Number readback failure for (+ 0.03 (* -100 3.46944695195361e-18))
0.0299999999999997
Number readback failure for (+ 0.003 (* -100 4.33680868994202e-19))
0.00299999999999996
Number readback failure for (+ 3e-20 (* -100 6.01853107621011e-36))
2.99999999999994e-20
Number readback failure for (+ 3e-50 (* -100 4.7477838728799e-66))
2.99999999999995e-50
Number readback failure for (+ 3e-100 (* -100 5.0758836746313e-116))
2.99999999999995e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 7. (* -100 8.88178419700125e-16))
6.99999999999991
Number readback failure for (+ 70. (* -100 1.4210854715202e-14))
69.9999999999986
Number readback failure for (+ 700. (* -100 1.13686837721616e-13))
699.999999999989
Number readback failure for (+ 7e+20 (* -100 131072.))
6.99999999999987e+20
Number readback failure for (+ 7e+50 (* -100 8.30767497365572e+34))
6.99999999999992e+50
Number readback failure for (+ 7e+100 (* -100 1.55413511378058e+85))
6.99999999999984e+100
Number readback failure for (+ 0.7 (* -99 1.11022302462516e-16))
0.699999999999989
Number readback failure for (+ 0.07 (* -100 1.38777878078145e-17))
0.0699999999999986
Number readback failure for (+ 0.007 (* -100 8.67361737988404e-19))
0.00699999999999991
Number readback failure for (+ 7e-20 (* -99 1.20370621524202e-35))
6.99999999999988e-20
Number readback failure for (+ 7e-50 (* -100 9.4955677457598e-66))
6.9999999999999e-50
Number readback failure for (+ 7e-100 (* -100 1.01517673492626e-115))
6.9999999999999e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3.14159265358979 (* -100 4.44089209850063e-16))
3.14159265358975
Number readback failure for (+ 31.4159265358979 (* -100 3.5527136788005e-15))
31.4159265358976
Number readback failure for (+ 314.159265358979 (* -100 5.6843418860808e-14))
314.159265358974
Number readback failure for (+ 3.14159265358979e+20 (* -100 65536.))
3.14159265358973e+20
Number readback failure for (+ 3.14159265358979e+50 (* -100 4.15383748682786e+34))
3.14159265358975e+50
Number readback failure for (+ 3.14159265358979e+100 (* -100 3.88533778445146e+84))
3.14159265358975e+100
Number readback failure for (+ 0.314159265358979 (* -100 5.55111512312578e-17))
0.314159265358974
Number readback failure for (+ 0.0314159265358979 (* -100 6.93889390390723e-18))
0.0314159265358972
Number readback failure for (+ 0.00314159265358979 (* -99 4.33680868994202e-19))
0.00314159265358975
Number readback failure for (+ 3.14159265358979e-20 (* -100 6.01853107621011e-36))
3.14159265358973e-20
Number readback failure for (+ 3.14159265358979e-50 (* -100 4.7477838728799e-66))
3.14159265358975e-50
Number readback failure for (+ 3.14159265358979e-100 (* -100 5.0758836746313e-116))
3.14159265358974e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 2.71828182845905 (* -100 4.44089209850063e-16))
2.718281828459
Number readback failure for (+ 27.1828182845905 (* -100 3.5527136788005e-15))
27.1828182845901
Number readback failure for (+ 271.828182845905 (* -100 5.6843418860808e-14))
271.828182845899
Number readback failure for (+ 2.71828182845905e+20 (* -100 32768.))
2.71828182845901e+20
Number readback failure for (+ 2.71828182845905e+50 (* -100 4.15383748682786e+34))
2.718281828459e+50
Number readback failure for (+ 2.71828182845905e+100 (* -100 3.88533778445146e+84))
2.71828182845901e+100
Number readback failure for (+ 0.271828182845905 (* -99 5.55111512312578e-17))
0.271828182845899
Number readback failure for (+ 0.0271828182845905 (* -100 3.46944695195361e-18))
0.0271828182845901
Number readback failure for (+ 0.00271828182845905 (* -100 4.33680868994202e-19))
0.002718281828459
Number readback failure for (+ 2.71828182845904e-20 (* -100 6.01853107621011e-36))
2.71828182845898e-20
Number readback failure for (+ 2.71828182845905e-50 (* -100 4.7477838728799e-66))
2.718281828459e-50
Number readback failure for (+ 2.71828182845905e-100 (* -100 5.0758836746313e-116))
2.71828182845899e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
To fully test continuations do:
(test-cont)
;testing scheme 4 functions;
SECTION(6 7)
(#<subr string->list> "P l") ==> (#\P #\ #\l)
(#<subr string->list> "") ==> ()
(#<subr list->string> (#\1 #\\ #\")) ==> "1\\\""
(#<subr list->string> ()) ==> ""
SECTION(6 8)
(#<subr vector->list> #(dah dah didah)) ==> (dah dah didah)
(#<subr vector->list> #()) ==> ()
(#<subr list->vector> (dididit dah)) ==> #(dididit dah)
(#<subr list->vector> ()) ==> #()
SECTION(6 10 4)
(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
;testing DELAY and FORCE;
SECTION(6 9)
(delay 3) ==> 3
(delay (3 3)) ==> (3 3)
(delay 2) ==> 2
(#<subr force> #<compiled-promise>) ==> 6
(#<subr force> #<forced-compiled-promise>) ==> 6
(force 3) ==> 3
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
;testing continuations;
SECTION(6 9)
(#<compiled-procedure> (a (b (c))) ((a) b c)) ==> #t
(#<compiled-procedure> (a (b (c))) ((a) b c d)) ==> #f
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))

1
vx-scheme/testcases/c-good/scheme.good Normal file
View File

@ -0,0 +1 @@
("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two")

54
vx-scheme/testcases/c-good/series.good Normal file
View File

@ -0,0 +1,54 @@
1.
1.5
1.41666666666667
1.41421568627451
1.41421356237469
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1
3
6
10
15
21
28
36
45
55
4.
2.66666666666667
3.46666666666667
2.8952380952381
3.33968253968254
2.97604617604618
3.28373848373848
3.01707181707182
3.25236593471888
3.0418396189294
3.16666666666667
3.13333333333333
3.1452380952381
3.13968253968254
3.14271284271284
3.14088134088134
3.14207181707182
3.14125482360777
3.1418396189294
3.1414067184965
4.
3.16666666666667
3.14210526315789
3.141599357319
3.14159271403378
3.14159265397529
3.14159265359118
3.14159265358978
3.1415926535898
3.14159265358979

1
vx-scheme/testcases/c-good/sieve.good Executable file
View File

@ -0,0 +1 @@
1993

40
vx-scheme/testcases/cf.scm Normal file
View File

@ -0,0 +1,40 @@
(load "stream.scm")
;
; Given a continued fraction in the form of a stream of
; integers, return the stream of convergents. (The stream
; actually returns a list (num denom quotient) ).
;
(define (cf->convergents cf-stream)
(define (produce n-2 n-1 rest)
(let ((nextval (+ (* n-1 (stream-car rest)) n-2)))
(cons-stream nextval (produce n-1 nextval (stream-cdr rest)))))
(define (cf-num cf-stream)
(let* ((a0 (stream-car cf-stream))
(a1 (stream-car (stream-cdr cf-stream)))
(n1 (+ (* a0 a1) 1))
(rest (stream-cdr (stream-cdr cf-stream))))
(cons-stream a0 (cons-stream n1 (produce a0 n1 rest)))))
(define (cf-denom cf-stream)
(let ((a0 1)
(a1 (stream-car (stream-cdr cf-stream)))
(rest (stream-cdr (stream-cdr cf-stream))))
(cons-stream a0 (cons-stream a1 (produce a0 a1 rest)))))
(stream-map (lambda (n d) (list n d (/ n d)))
(cf-num cf-stream)
(cf-denom cf-stream)))
(define ones (cons-stream 1 ones))
(define twos (cons-stream 2 twos))
(define onetwo (interleave ones twos))
(display-stream-n ones 5)
(display-stream-n (cf->convergents ones) 40)
(display (/ (+ 1 (sqrt 5)) 2))
(display-stream-n (cf->convergents twos) 10)
(display-stream-n (cf->convergents onetwo) 10)

17
vx-scheme/testcases/cyclic.scm Normal file
View File

@ -0,0 +1,17 @@
;;
;; Run all the tests we have in the same interpreter context,
;; many times.
;;
(let test-loop ((i 0))
(if (= i 500)
'ok
(begin
(map
(lambda (test)
(load (string-append test ".scm"))
(display "#complete: ")
(display test)
(newline))
'("ack" "cf" "pi" "series" "sieve" "r4rstest"))
(test-loop (+ i 1)))))

79
vx-scheme/testcases/dderiv.scm Normal file
View File

@ -0,0 +1,79 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File: dderiv.sc
;;; Description: DDERIV benchmark from the Gabriel tests
;;; Author: Vaughan Pratt
;;; Created: 8-Apr-85
;;; Modified: 10-Apr-85 14:53:29 (Bob Shaw)
;;; 23-Jul-87 (Will Clinger)
;;; 9-Feb-88 (Will Clinger)
;;; 21-Mar-94 (Qobi)
;;; 31-Mar-98 (Qobi)
;;; 26-Mar-00 (flw)
;;; Language: Scheme (but see note below)
;;; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note: This benchmark uses property lists. The procedures that must
;;; be supplied are get and put, where (put x y z) is equivalent to Common
;;; Lisp's (setf (get x y) z).
;;; DDERIV -- Symbolic derivative benchmark written by Vaughan Pratt.
;;; This benchmark is a variant of the simple symbolic derivative program
;;; (DERIV). The main change is that it is `table-driven.' Instead of using a
;;; large COND that branches on the CAR of the expression, this program finds
;;; the code that will take the derivative on the property list of the atom in
;;; the CAR position. So, when the expression is (+ . <rest>), the code
;;; stored under the atom '+ with indicator DERIV will take <rest> and
;;; return the derivative for '+. The way that MacLisp does this is with the
;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
;;; atomic name in that it expects an argument list and the compiler compiles
;;; code, but the name of the function with that code is stored on the
;;; property list of FOO under the indicator BAR, in this case. You may have
;;; to do something like:
;;; :property keyword is not Common Lisp.
(define (dderiv-aux a) (list '/ (dderiv a) a))
(define (+dderiv a) (cons '+ (map dderiv a)))
(put '+ 'dderiv +dderiv) ; install procedure on the property list
(define (-dderiv a) (cons '- (map dderiv a)))
(put '- 'dderiv -dderiv) ; install procedure on the property list
(define (*dderiv a) (list '* (cons '* a) (cons '+ (map dderiv-aux a))))
(put '* 'dderiv *dderiv) ; install procedure on the property list
(define (/dderiv a)
(list '-
(list '/ (dderiv (car a)) (cadr a))
(list '/
(car a)
(list '* (cadr a) (cadr a) (dderiv (cadr a))))))
(put '/ 'dderiv /dderiv) ; install procedure on the property list
(define (dderiv a)
(cond ((not (pair? a)) (cond ((eq? a 'x) 1) (else 0)))
(else (let ((dderiv (get (car a) 'dderiv)))
(cond (dderiv (dderiv (cdr a)))
(else 'error))))))
(define (run)
(do ((i 0 (+ i 1))) ((= i 1000))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;(time (do ((i 10 (- i 1))) ((zero? i)) (run)))
(run)
(display (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))
(newline)

2319
vx-scheme/testcases/dynamic.scm Normal file
View File

File diff suppressed because it is too large Load Diff

647
vx-scheme/testcases/earley.scm Normal file
View File

@ -0,0 +1,647 @@
;;; EARLEY -- Earley's parser, written by Marc Feeley.
; (make-parser grammar lexer) is used to create a parser from the grammar
; description `grammar' and the lexer function `lexer'.
;
; A grammar is a list of definitions. Each definition defines a non-terminal
; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
; A given non-terminal can only be defined once. The first non-terminal
; defined is the grammar's goal. Each rule is a possibly empty list of
; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
; can be any scheme value. Note that all grammar symbols are treated as
; non-terminals. This is fine though because the lexer will be outputing
; non-terminals.
;
; The lexer defines what a token is and the mapping between tokens and
; the grammar's non-terminals. It is a function of one argument, the input,
; that returns the list of tokens corresponding to the input. Each token is
; represented by a list. The first element is some `user-defined' information
; associated with the token and the rest represents the token's class(es) (as a
; list of non-terminals that this token corresponds to).
;
; The result of `make-parser' is a function that parses the single input it
; is given into the grammar's goal. The result is a `parse' which can be
; manipulated with the procedures: `parse->parsed?', `parse->trees'
; and `parse->nb-trees' (see below).
;
; Let's assume that we want a parser for the grammar
;
; S -> x = E
; E -> E + E | V
; V -> V y |
;
; and that the input to the parser is a string of characters. Also, assume we
; would like to map the characters `x', `y', `+' and `=' into the corresponding
; non-terminals in the grammar. Such a parser could be created with
;
; (make-parser
; '(
; (s (x = e))
; (e (e + e) (v))
; (v (v y) ())
; )
; (lambda (str)
; (map (lambda (char)
; (list char ; user-info = the character itself
; (case char
; ((#\x) 'x)
; ((#\y) 'y)
; ((#\+) '+)
; ((#\=) '=)
; (else (fatal-error "lexer error")))))
; (string->list str)))
; )
;
; An alternative definition (that does not check for lexical errors) is
;
; (make-parser
; '(
; (s (#\x #\= e))
; (e (e #\+ e) (v))
; (v (v #\y) ())
; )
; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
; )
;
; To help with the rest of the discussion, here are a few definitions:
;
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
; It indicates a point between two input tokens (0 = beginning, `n' = end).
; For example, if `n' = 4, there are 5 input pointers:
;
; input token1 token2 token3 token4
; input pointers 0 1 2 3 4
;
; A configuration indicates the extent to which a given rule is parsed (this
; is the common `dot notation'). For simplicity, a configuration is
; represented as an integer, with successive configurations in the same
; rule associated with successive integers. It is assumed that the grammar
; has been extended with rules to aid scanning. These rules are of the
; form `nt ->', and there is one such rule for every non-terminal. Note
; that these rules are special because they only apply when the corresponding
; non-terminal is returned by the lexer.
;
; A configuration set is a configuration grouped with the set of input pointers
; representing where the head non-terminal of the configuration was predicted.
;
; Here are the rules and configurations for the grammar given above:
;
; S -> . \
; 0 |
; x -> . |
; 1 |
; = -> . |
; 2 |
; E -> . |
; 3 > special rules (for scanning)
; + -> . |
; 4 |
; V -> . |
; 5 |
; y -> . |
; 6 /
; S -> . x . = . E .
; 7 8 9 10
; E -> . E . + . E .
; 11 12 13 14
; E -> . V .
; 15 16
; V -> . V . y .
; 17 18 19
; V -> .
; 20
;
; Starters of the non-terminal `nt' are configurations that are leftmost
; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
; configurations that are rightmost in any rule for `nt'. Predictors of the
; non-terminal `nt' are configurations that are directly to the left of `nt'
; in any rule.
;
; For the grammar given above,
;
; Starters of V = (17 20)
; Enders of V = (5 19 20)
; Predictors of V = (15 17)
(define (make-parser grammar lexer)
(define (non-terminals grammar) ; return vector of non-terminals in grammar
(define (add-nt nt nts)
(if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
(let def-loop ((defs grammar) (nts '()))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def))
(nts (add-nt head nts)))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nts nts))
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts))))
(def-loop (cdr defs) nts))))
(list->vector (reverse nts))))) ; goal non-terminal must be at index 0
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (nb-configurations grammar) ; return nb of configurations in grammar
(let def-loop ((defs grammar) (nb-confs 0))
(if (pair? defs)
(let ((def (car defs)))
(let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nb-confs nb-confs))
(if (pair? l)
(loop (cdr l) (+ nb-confs 1))
(rule-loop (cdr rules) (+ nb-confs 1)))))
(def-loop (cdr defs) nb-confs))))
nb-confs)))
; First, associate a numeric identifier to every non-terminal in the
; grammar (with the goal non-terminal associated with 0).
;
; So, for the grammar given above we get:
;
; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
(let* ((nts (non-terminals grammar)) ; id map = list of non-terms
(nb-nts (vector-length nts)) ; the number of non-terms
(nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
(starters (make-vector nb-nts '())) ; starters for every non-term
(enders (make-vector nb-nts '())) ; enders for every non-term
(predictors (make-vector nb-nts '())) ; predictors for every non-term
(steps (make-vector nb-confs #f)) ; what to do in a given conf
(names (make-vector nb-confs #f))) ; name of rules
(define (setup-tables grammar nts starters enders predictors steps names)
(define (add-conf conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))
(let ((nb-nts (vector-length nts)))
(let nt-loop ((i (- nb-nts 1)))
(if (>= i 0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) 0))
(vector-set! enders i (list i))
(nt-loop (- i 1)))))
(let def-loop ((defs grammar) (conf (vector-length nts)))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
(if (pair? rules)
(let ((rule (car rules)))
(vector-set! names conf (list head rule-num))
(add-conf conf head nts starters)
(let loop ((l rule) (conf conf))
(if (pair? l)
(let ((nt (car l)))
(vector-set! steps conf (ind nt nts))
(add-conf conf nt nts predictors)
(loop (cdr l) (+ conf 1)))
(begin
(vector-set! steps conf (- (ind head nts) nb-nts))
(add-conf conf head nts enders)
(rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
(def-loop (cdr defs) conf))))))))
; Now, for each non-terminal, compute the starters, enders and predictors and
; the names and steps tables.
(setup-tables grammar nts starters enders predictors steps names)
; Build the parser description
(let ((parser-descr (vector lexer
nts
starters
enders
predictors
steps
names)))
(lambda (input)
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (comp-tok tok nts) ; transform token to parsing format
(let loop ((l1 (cdr tok)) (l2 '()))
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i
(loop (cdr l1) (cons i l2))
(loop (cdr l1) l2)))
(cons (car tok) (reverse l2)))))
(define (input->tokens input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
(define (make-states nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks 1) #f)))
(let loop ((i nb-toks))
(if (>= i 0)
(let ((v (make-vector (+ nb-confs 1) #f)))
(vector-set! v 0 -1)
(vector-set! states i v)
(loop (- i 1)))
states))))
(define (conf-set-get state conf)
(vector-ref state (+ conf 1)))
(define (conf-set-get* state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num 6) #f)))
(vector-set! conf-set 1 -3) ; old elems tail (points to head)
(vector-set! conf-set 2 -1) ; old elems head
(vector-set! conf-set 3 -1) ; new elems tail (points to head)
(vector-set! conf-set 4 -1) ; new elems head
(vector-set! state (+ conf 1) conf-set)
conf-set))))
(define (conf-set-merge-new! conf-set)
(vector-set! conf-set
(+ (vector-ref conf-set 1) 5)
(vector-ref conf-set 4))
(vector-set! conf-set 1 (vector-ref conf-set 3))
(vector-set! conf-set 3 -1)
(vector-set! conf-set 4 -1))
(define (conf-set-head conf-set)
(vector-ref conf-set 2))
(define (conf-set-next conf-set i)
(vector-ref conf-set (+ i 5)))
(define (conf-set-member? state conf i)
(let ((conf-set (vector-ref state (+ conf 1))))
(if conf-set
(conf-set-next conf-set i)
#f)))
(define (conf-set-adjoin state conf-set conf i)
(let ((tail (vector-ref conf-set 3))) ; put new element at tail
(vector-set! conf-set (+ i 5) -1)
(vector-set! conf-set (+ tail 5) i)
(vector-set! conf-set 3 i)
(if (< tail 0)
(begin
(vector-set! conf-set 0 (vector-ref state 0))
(vector-set! state 0 conf)))))
(define (conf-set-adjoin* states state-num l i)
(let ((state (vector-ref states state-num)))
(let loop ((l1 l))
(if (pair? l1)
(let* ((conf (car l1))
(conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1))))))))
(define (conf-set-adjoin** states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let* ((state* (vector-ref states* state-num))
(conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i))
#t)
#f)))
(define (conf-set-union state conf-set conf other-set)
(let loop ((i (conf-set-head other-set)))
(if (>= i 0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i))))))
(define (forw states state-num starters enders predictors steps nts)
(define (predict state state-num conf-set conf nt starters enders)
; add configurations which start the non-terminal `nt' to the
; right of the dot
(let loop1 ((l (vector-ref starters nt)))
(if (pair? l)
(let* ((starter (car l))
(starter-set (conf-set-get* state state-num starter)))
(if (not (conf-set-next starter-set state-num))
(begin
(conf-set-adjoin state starter-set starter state-num)
(loop1 (cdr l)))
(loop1 (cdr l))))))
; check for possible completion of the non-terminal `nt' to the
; right of the dot
(let loop2 ((l (vector-ref enders nt)))
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let* ((next (+ conf 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next conf-set)
(loop2 (cdr l)))
(loop2 (cdr l)))))))
(define (reduce states state state-num conf-set head preds)
; a non-terminal is now completed so check for reductions that
; are now possible at the configurations `preds'
(let loop1 ((l preds))
(if (pair? l)
(let ((pred (car l)))
(let loop2 ((i head))
(if (>= i 0)
(let ((pred-set (conf-set-get (vector-ref states i) pred)))
(if pred-set
(let* ((next (+ pred 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next pred-set)))
(loop2 (conf-set-next conf-set i)))
(loop1 (cdr l))))))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
(let loop ()
(let ((conf (vector-ref state 0)))
(if (>= conf 0)
(let* ((step (vector-ref steps conf))
(conf-set (vector-ref state (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(if (>= step 0)
(predict state state-num conf-set conf step starters enders)
(let ((preds (vector-ref predictors (+ step nb-nts))))
(reduce states state state-num conf-set head preds)))
(loop)))))))
(define (forward starters enders predictors steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(states (make-states nb-toks nb-confs))
(goal-starters (vector-ref starters 0)))
(conf-set-adjoin* states 0 goal-starters 0) ; predict goal
(forw states 0 starters enders predictors steps nts)
(let loop ((i 0))
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
(forw states (+ i 1) starters enders predictors steps nts)
(loop (+ i 1)))))
states))
(define (produce conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf 1)))
(if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
(let loop1 ((l (vector-ref enders (vector-ref steps prev))))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)))
(if (>= k 0)
(begin
(and (>= k i)
(conf-set-adjoin** states states* k prev i)
(conf-set-adjoin** states states* j ender k))
(loop2 (conf-set-next ender-set k)))
(loop1 (cdr l))))
(loop1 (cdr l)))))))))
(define (back states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
(let loop1 ()
(let ((conf (vector-ref state* 0)))
(if (>= conf 0)
(let* ((conf-set (vector-ref state* (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state* 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(let loop2 ((i head))
(if (>= i 0)
(begin
(produce conf i state-num enders steps
toks states states* nb-nts)
(loop2 (conf-set-next conf-set i)))
(loop1)))))))))
(define (backward states enders steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(nb-nts (vector-length nts))
(states* (make-states nb-toks nb-confs))
(goal-enders (vector-ref enders 0)))
(let loop1 ((l goal-enders))
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin** states states* nb-toks conf 0)
(loop1 (cdr l)))))
(let loop2 ((i nb-toks))
(if (>= i 0)
(begin
(back states states* i enders steps nb-nts toks)
(loop2 (- i 1)))))
states*))
(define (parsed? nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
#t
(loop (cdr l))))
#f)))
#f)))
(define (deriv-trees conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name ; `conf' is at the start of a rule (either special or not)
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf 1)))
(let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
(l2 '()))
(if (pair? l1)
(let* ((ender (car l1))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (l2 l2))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((prev-trees
(deriv-trees prev i k enders steps names
toks states nb-nts))
(ender-trees
(deriv-trees ender k j enders steps names
toks states nb-nts)))
(let loop3 ((l3 ender-trees) (l2 l2))
(if (pair? l3)
(let ((ender-tree (list (car l3))))
(let loop4 ((l4 prev-trees) (l2 l2))
(if (pair? l4)
(loop4 (cdr l4)
(cons (append (car l4)
ender-tree)
l2))
(loop3 (cdr l3) l2))))
(loop2 (conf-set-next ender-set k) l2))))
(loop2 (conf-set-next ender-set k) l2))
(loop1 (cdr l1) l2)))
(loop1 (cdr l1) l2)))
l2))))))
(define (deriv-trees* nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (trees '()))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(append (deriv-trees conf i j enders steps names
toks states nb-nts)
trees))
(loop (cdr l) trees)))
trees)))
#f)))
(define (nb-deriv-trees conf i j enders steps toks states nb-nts)
(let ((prev (- conf 1)))
(if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
1
(let loop1 ((l (vector-ref enders (vector-ref steps prev)))
(n 0))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (n n))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((nb-prev-trees
(nb-deriv-trees prev i k enders steps
toks states nb-nts))
(nb-ender-trees
(nb-deriv-trees ender k j enders steps
toks states nb-nts)))
(loop2 (conf-set-next ender-set k)
(+ n (* nb-prev-trees nb-ender-trees))))
(loop2 (conf-set-next ender-set k) n))
(loop1 (cdr l) n)))
(loop1 (cdr l) n)))
n)))))
(define (nb-deriv-trees* nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (nb-trees 0))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(+ (nb-deriv-trees conf i j enders steps
toks states nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees)))
#f)))
(let* ((lexer (vector-ref parser-descr 0))
(nts (vector-ref parser-descr 1))
(starters (vector-ref parser-descr 2))
(enders (vector-ref parser-descr 3))
(predictors (vector-ref parser-descr 4))
(steps (vector-ref parser-descr 5))
(names (vector-ref parser-descr 6))
(toks (input->tokens input lexer nts)))
(vector nts
starters
enders
predictors
steps
names
toks
(backward (forward starters enders predictors steps nts toks)
enders steps nts toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))
(define (parse->parsed? parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(states (vector-ref parse 7))
(parsed? (vector-ref parse 8)))
(parsed? nt i j nts enders states)))
(define (parse->trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(names (vector-ref parse 5))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(deriv-trees* (vector-ref parse 9)))
(deriv-trees* nt i j nts enders steps names toks states)))
(define (parse->nb-trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(nb-deriv-trees* (vector-ref parse 10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))
(define (test)
(let ((p (make-parser '( (s (a) (s s)) )
(lambda (l) (map (lambda (x) (list x x)) l)))))
(let ((x (p '(a a a a a a a a a))))
(length (parse->trees x 's 0 9)))))
(display (test))
(newline)

3
vx-scheme/testcases/good/ack.good Executable file
View File

@ -0,0 +1,3 @@
253
509
1021

1
vx-scheme/testcases/good/boyer.good Normal file
View File

@ -0,0 +1 @@
#t

65
vx-scheme/testcases/good/cf.good Normal file
View File

@ -0,0 +1,65 @@
1
1
1
1
1
(1 1 1.)
(2 1 2.)
(3 2 1.5)
(5 3 1.66666666666667)
(8 5 1.6)
(13 8 1.625)
(21 13 1.61538461538462)
(34 21 1.61904761904762)
(55 34 1.61764705882353)
(89 55 1.61818181818182)
(144 89 1.61797752808989)
(233 144 1.61805555555556)
(377 233 1.61802575107296)
(610 377 1.61803713527851)
(987 610 1.61803278688525)
(1597 987 1.61803444782168)
(2584 1597 1.61803381340013)
(4181 2584 1.61803405572755)
(6765 4181 1.61803396316671)
(10946 6765 1.6180339985218)
(17711 10946 1.61803398501736)
(28657 17711 1.6180339901756)
(46368 28657 1.61803398820532)
(75025 46368 1.6180339889579)
(121393 75025 1.61803398867044)
(196418 121393 1.61803398878024)
(317811 196418 1.6180339887383)
(514229 317811 1.61803398875432)
(832040 514229 1.6180339887482)
(1346269 832040 1.61803398875054)
(2178309 1346269 1.61803398874965)
(3524578 2178309 1.61803398874999)
(5702887 3524578 1.61803398874986)
(9227465 5702887 1.61803398874991)
(14930352 9227465 1.61803398874989)
(24157817 14930352 1.6180339887499)
(39088169 24157817 1.61803398874989)
(63245986 39088169 1.6180339887499)
(102334155 63245986 1.61803398874989)
(165580141 102334155 1.61803398874989)
1.61803398874989(2 1 2.)
(5 2 2.5)
(12 5 2.4)
(29 12 2.41666666666667)
(70 29 2.41379310344828)
(169 70 2.41428571428571)
(408 169 2.41420118343195)
(985 408 2.41421568627451)
(2378 985 2.41421319796954)
(5741 2378 2.41421362489487)
(1 1 1.)
(3 2 1.5)
(4 3 1.33333333333333)
(11 8 1.375)
(15 11 1.36363636363636)
(41 30 1.36666666666667)
(56 41 1.36585365853659)
(153 112 1.36607142857143)
(209 153 1.36601307189542)
(571 418 1.36602870813397)

1
vx-scheme/testcases/good/dderiv.good Normal file
View File

@ -0,0 +1 @@
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) (* (* b x) (+ (/ 0 b) (/ 1 x))) 0)

1
vx-scheme/testcases/good/dynamic.good Normal file
View File

@ -0,0 +1 @@
((218 . 437) (6 . 1892) (2204 . 441))

1
vx-scheme/testcases/good/earley.good Normal file
View File

@ -0,0 +1 @@
1430

42
vx-scheme/testcases/good/maze.good Normal file
View File

@ -0,0 +1,42 @@
_ _ _
_/ \_/ \_/.\
/ \ \_ . /.\
\ \ /. _/.\ /
/ \_/. _/ \_ .\
\ / \ / _/ \_/
/ _/.\ / \ / \
\ / \ / _/ /
/ \ /.\ /.\_/ \
\_/ \ /. _ .\ /
/ \_ . _/ \ \
\_ \_/ _/.\ /
/ _/ / \ / \
\_ \ / \_ .\_/
/ \_ \_ \_ .\
\_ \_/ _/.\ /
/ \_ \ /.\ .\
\ /.\_ . /.\ /
/ . _/.\ / \
\ /.\_/.\_ .\ /
/ \_ . / _/ \
\_ \_/.\_ \_/
/ _/ \ / \_ \
\_/ _/.\_ \_/
/ \ / _ . _ \
\ / \_/. _ \_/
/ _ \ \_/ \
\_/.\_ .\_/ _/
/ \ . _/ / \
\ /.\_/ \_/.\ /
/ \_ . _/. \
\ . /.\_/
/ \_/ \_/ \_ .\
\_/ / \_/. /
/ / _ \ / \
\_/ \_/ \_/.\_/
/ \_/ _/ \_ .\
\ _/. /. _/
/ \ /. / \_ .\
\_/. _/.\_/.\ /
/ _ .\_ . _ .\
\_/ \ / \_/ \_/

7
vx-scheme/testcases/good/pi.good Executable file
View File

@ -0,0 +1,7 @@
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
08128 48111 74502 84102 70193 85211 05559 64462 29489 54930
38196 44288 10975 66593 34461 28475 64823 37867 83165 27120
19091 45648 56692 34603 48610 45432 66482 13393 60726 02491
41273

19
vx-scheme/testcases/good/puzzle.good Normal file
View File

@ -0,0 +1,19 @@
Piece 1 at 1.
Piece 8 at 354.
Piece 7 at 330.
Piece 3 at 291.
Piece 13 at 278.
Piece 12 at 276.
Piece 5 at 275.
Piece 1 at 267.
Piece 1 at 219.
Piece 3 at 203.
Piece 1 at 202.
Piece 1 at 154.
Piece 9 at 138.
Piece 2 at 110.
Piece 2 at 108.
Piece 1 at 106.
Piece 3 at 90.
Success in 2005 trials.

772
vx-scheme/testcases/good/r4rstest.good Normal file
View File

@ -0,0 +1,772 @@
SECTION(2 1)
SECTION(3 4)
#<subr boolean?>
#<subr char?>
#<subr null?>
#<subr number?>
#<subr pair?>
#<subr procedure?>
#<subr string?>
#<subr symbol?>
#<subr vector?>
(#t #f #f #f #f #f #f #f #f)#t
(#t #f #f #f #f #f #f #f #f)#f
(#f #t #f #f #f #f #f #f #f)#\a
(#f #f #t #f #f #f #f #f #f)()
(#f #f #f #t #f #f #f #f #f)9739
(#f #f #f #f #t #f #f #f #f)(test)
(#f #f #f #f #f #t #f #f #f)#<lambda (e) ...>
(#f #f #f #f #f #f #t #f #f)"test"
(#f #f #f #f #f #f #t #f #f)""
(#f #f #f #f #f #f #f #t #f)test
(#f #f #f #f #f #f #f #f #t)#()
(#f #f #f #f #f #f #f #f #t)#(a b c)
SECTION(4 1 2)
(quote (quote a)) ==> (quote a)
(quote (quote a)) ==> (quote a)
SECTION(4 1 3)
(#<subr *> 3 4) ==> 12
SECTION(4 1 4)
(#<lambda (x) ...> 4) ==> 8
(#<lambda (x y) ...> 7 10) ==> 3
(#<lambda (y) ...> 6) ==> 10
(#<lambda x ...> 3 4 5 6) ==> (3 4 5 6)
(#<lambda (x y . z) ...> 3 4 5 6) ==> (5 6)
SECTION(4 1 5)
(if yes) ==> yes
(if no) ==> no
(if 1) ==> 1
SECTION(4 1 6)
(define 3) ==> 3
(set! 5) ==> 5
SECTION(4 2 1)
(cond greater) ==> greater
(cond equal) ==> equal
(cond 2) ==> 2
(case composite) ==> composite
(case consonant) ==> consonant
(and #t) ==> #t
(and #f) ==> #f
(and (f g)) ==> (f g)
(and #t) ==> #t
(or #t) ==> #t
(or #t) ==> #t
(or #f) ==> #f
(or #f) ==> #f
(or (b c)) ==> (b c)
SECTION(4 2 2)
(let 6) ==> 6
(let 35) ==> 35
(let* 70) ==> 70
(letrec #t) ==> #t
(let 5) ==> 5
(let 34) ==> 34
(let 6) ==> 6
(let 34) ==> 34
(let* 7) ==> 7
(let* 34) ==> 34
(let* 8) ==> 8
(let* 34) ==> 34
(letrec 9) ==> 9
(letrec 34) ==> 34
(letrec 10) ==> 10
(letrec 34) ==> 34
SECTION(4 2 3)
(begin 6) ==> 6
SECTION(4 2 4)
(do #(0 1 2 3 4)) ==> #(0 1 2 3 4)
(do 25) ==> 25
(let 1) ==> 1
(let ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
(let -1) ==> -1
SECTION(4 2 6)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (list a (quote a))) ==> (list a (quote a))
(quasiquote (a 3 4 5 6 b)) ==> (a 3 4 5 6 b)
(quasiquote ((foo 7) . cons)) ==> ((foo 7) . cons)
(quasiquote #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
(quasiquote 5) ==> 5
(quasiquote (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)) ==> (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)
(quasiquote (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)) ==> (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) ==> (quasiquote (list (unquote (+ 1 2)) 4))
SECTION(5 2 1)
(define 6) ==> 6
(define 1) ==> 1
(#<lambda (x) ...> 6) ==> 9
SECTION(5 2 2)
(define 45) ==> 45
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda (x) ...> 88) ==> 88
(#<lambda (x) ...> 4) ==> 4
(define 34) ==> 34
(internal-define 99) ==> 99
(internal-define 77) ==> 77
SECTION(6 1)
(#<subr not> #t) ==> #f
(#<subr not> 3) ==> #f
(#<subr not> (3)) ==> #f
(#<subr not> #f) ==> #t
(#<subr not> ()) ==> #f
(#<subr not> ()) ==> #f
(#<subr not> nil) ==> #f
SECTION(6 2)
(#<subr eqv?> a a) ==> #t
(#<subr eqv?> a b) ==> #f
(#<subr eqv?> 2 2) ==> #t
(#<subr eqv?> () ()) ==> #t
(#<subr eqv?> 10000 10000) ==> #t
(#<subr eqv?> (1 . 2) (1 . 2)) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #f nil) ==> #f
(#<subr eqv?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eq?> a a) ==> #t
(#<subr eq?> (a) (a)) ==> #f
(#<subr eq?> () ()) ==> #t
(#<subr eq?> #<subr car> #<subr car>) ==> #t
(#<subr eq?> (a) (a)) ==> #t
(#<subr eq?> #() #()) ==> #t
(#<subr eq?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr equal?> a a) ==> #t
(#<subr equal?> (a) (a)) ==> #t
(#<subr equal?> (a (b) c) (a (b) c)) ==> #t
(#<subr equal?> "abc" "abc") ==> #t
(#<subr equal?> 2 2) ==> #t
(#<subr equal?> #(a a a a a) #(a a a a a)) ==> #t
SECTION(6 3)
(dot (a b c d e)) ==> (a b c d e)
(#<subr list?> (a b c)) ==> #t
(set-cdr! (a . 4)) ==> (a . 4)
(#<subr eqv?> (a . 4) (a . 4)) ==> #t
(dot (a b c . d)) ==> (a b c . d)
(#<subr list?> (a . 4)) ==> #f
(list? #f) ==> #f
(#<subr cons> a ()) ==> (a)
(#<subr cons> (a) (b c d)) ==> ((a) b c d)
(#<subr cons> "a" (b c)) ==> ("a" b c)
(#<subr cons> a 3) ==> (a . 3)
(#<subr cons> (a b) c) ==> ((a b) . c)
(#<subr car> (a b c)) ==> a
(#<subr car> ((a) b c d)) ==> (a)
(#<subr car> (1 . 2)) ==> 1
(#<subr cdr> ((a) b c d)) ==> (b c d)
(#<subr cdr> (1 . 2)) ==> 2
(#<subr list> a 7 c) ==> (a 7 c)
(#<subr list>) ==> ()
(#<subr length> (a b c)) ==> 3
(#<subr length> (a (b) (c d e))) ==> 3
(#<subr length> ()) ==> 0
(#<subr append> (x) (y)) ==> (x y)
(#<subr append> (a) (b c d)) ==> (a b c d)
(#<subr append> (a (b)) ((c))) ==> (a (b) (c))
(#<subr append>) ==> ()
(#<subr append> (a b) (c . d)) ==> (a b c . d)
(#<subr append> () a) ==> a
(#<subr reverse> (a b c)) ==> (c b a)
(#<subr reverse> (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a)
(#<subr list-ref> (a b c d) 2) ==> c
(#<subr memq> a (a b c)) ==> (a b c)
(#<subr memq> b (a b c)) ==> (b c)
(#<subr memq> a (b c d)) ==> #f
(#<subr memq> (a) (b (a) c)) ==> #f
(#<subr member> (a) (b (a) c)) ==> ((a) c)
(#<subr memv> 101 (100 101 102)) ==> (101 102)
(#<subr assq> a ((a 1) (b 2) (c 3))) ==> (a 1)
(#<subr assq> b ((a 1) (b 2) (c 3))) ==> (b 2)
(#<subr assq> d ((a 1) (b 2) (c 3))) ==> #f
(#<subr assq> (a) (((a)) ((b)) ((c)))) ==> #f
(#<subr assoc> (a) (((a)) ((b)) ((c)))) ==> ((a))
(#<subr assv> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
SECTION(6 4)
(#<subr symbol?> a) ==> #t
(standard-case #t) ==> #t
(standard-case #t) ==> #t
(#<subr symbol->string> flying-fish) ==> "flying-fish"
(#<subr symbol->string> martin) ==> "martin"
(#<subr symbol->string> Malvina) ==> "Malvina"
(standard-case #t) ==> #t
(string-set! "cb") ==> "cb"
(#<subr symbol->string> ab) ==> "ab"
(#<subr string->symbol> "ab") ==> ab
(#<subr eq?> mississippi mississippi) ==> #t
(string->symbol #f) ==> #f
(#<subr string->symbol> "jollywog") ==> jollywog
SECTION(6 5 5)
(#<subr number?> 3) ==> #t
(#<subr complex?> 3) ==> #t
(#<subr real?> 3) ==> #t
(#<subr rational?> 3) ==> #t
(#<subr integer?> 3) ==> #t
(#<subr exact?> 3) ==> #t
(#<subr inexact?> 3) ==> #f
(#<subr => 22 22 22) ==> #t
(#<subr => 22 22) ==> #t
(#<subr => 34 34 35) ==> #f
(#<subr => 34 35) ==> #f
(#<subr >> 3 -6246) ==> #t
(#<subr >> 9 9 -2424) ==> #f
(#<subr >=> 3 -4 -6246) ==> #t
(#<subr >=> 9 9) ==> #t
(#<subr >=> 8 9) ==> #f
(#<subr <> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <> -1 2 3 4 4 5 6 7) ==> #f
(#<subr <=> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <=> -1 2 3 4 4 5 6 7) ==> #t
(#<subr <> 1 3 2) ==> #f
(#<subr >=> 1 3 2) ==> #f
(#<subr zero?> 0) ==> #t
(#<subr zero?> 1) ==> #f
(#<subr zero?> -1) ==> #f
(#<subr zero?> -100) ==> #f
(#<subr positive?> 4) ==> #t
(#<subr positive?> -4) ==> #f
(#<subr positive?> 0) ==> #f
(#<subr negative?> 4) ==> #f
(#<subr negative?> -4) ==> #t
(#<subr negative?> 0) ==> #f
(#<subr odd?> 3) ==> #t
(#<subr odd?> 2) ==> #f
(#<subr odd?> -4) ==> #f
(#<subr odd?> -1) ==> #t
(#<subr even?> 3) ==> #f
(#<subr even?> 2) ==> #t
(#<subr even?> -4) ==> #t
(#<subr even?> -1) ==> #f
(#<subr max> 34 5 7 38 6) ==> 38
(#<subr min> 3 5 5 330 4 -24) ==> -24
(#<subr +> 3 4) ==> 7
(#<subr +> 3) ==> 3
(#<subr +>) ==> 0
(#<subr *> 4) ==> 4
(#<subr *>) ==> 1
(#<subr -> 3 4) ==> -1
(#<subr -> 3) ==> -3
(#<subr abs> -7) ==> 7
(#<subr abs> 7) ==> 7
(#<subr abs> 0) ==> 0
(#<subr quotient> 35 7) ==> 5
(#<subr quotient> -35 7) ==> -5
(#<subr quotient> 35 -7) ==> -5
(#<subr quotient> -35 -7) ==> 5
(#<subr modulo> 13 4) ==> 1
(#<subr remainder> 13 4) ==> 1
(#<subr modulo> -13 4) ==> 3
(#<subr remainder> -13 4) ==> -1
(#<subr modulo> 13 -4) ==> -3
(#<subr remainder> 13 -4) ==> 1
(#<subr modulo> -13 -4) ==> -1
(#<subr remainder> -13 -4) ==> -1
(#<subr modulo> 0 86400) ==> 0
(#<subr modulo> 0 -86400) ==> 0
(#<lambda (n1 n2) ...> 238 9) ==> #t
(#<lambda (n1 n2) ...> -238 9) ==> #t
(#<lambda (n1 n2) ...> 238 -9) ==> #t
(#<lambda (n1 n2) ...> -238 -9) ==> #t
(#<subr gcd> 0 4) ==> 4
(#<subr gcd> -4 0) ==> 4
(#<subr gcd> 32 -36) ==> 4
(#<subr gcd>) ==> 0
(#<subr lcm> 32 -36) ==> 288
(#<subr lcm>) ==> 1
SECTION(6 5 9)
(#<subr number->string> 0) ==> "0"
(#<subr number->string> 100) ==> "100"
(#<subr number->string> 256 16) ==> "100"
(#<subr string->number> "100") ==> 100
(#<subr string->number> "100" 16) ==> 256
(#<subr string->number> "") ==> #f
(#<subr string->number> ".") ==> #f
(#<subr string->number> "d") ==> #f
(#<subr string->number> "D") ==> #f
(#<subr string->number> "i") ==> #f
(#<subr string->number> "I") ==> #f
(#<subr string->number> "3i") ==> #f
(#<subr string->number> "3I") ==> #f
(#<subr string->number> "33i") ==> #f
(#<subr string->number> "33I") ==> #f
(#<subr string->number> "3.3i") ==> #f
(#<subr string->number> "3.3I") ==> #f
(#<subr string->number> "-") ==> #f
(#<subr string->number> "+") ==> #f
SECTION(6 6)
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr char?> #\a) ==> #t
(#<subr char?> #\() ==> #t
(#<subr char?> #\ ) ==> #t
(#<subr char?> #\
) ==> #t
(#<subr char=?> #\A #\B) ==> #f
(#<subr char=?> #\a #\b) ==> #f
(#<subr char=?> #\9 #\0) ==> #f
(#<subr char=?> #\A #\A) ==> #t
(#<subr char<?> #\A #\B) ==> #t
(#<subr char<?> #\a #\b) ==> #t
(#<subr char<?> #\9 #\0) ==> #f
(#<subr char<?> #\A #\A) ==> #f
(#<subr char>?> #\A #\B) ==> #f
(#<subr char>?> #\a #\b) ==> #f
(#<subr char>?> #\9 #\0) ==> #t
(#<subr char>?> #\A #\A) ==> #f
(#<subr char<=?> #\A #\B) ==> #t
(#<subr char<=?> #\a #\b) ==> #t
(#<subr char<=?> #\9 #\0) ==> #f
(#<subr char<=?> #\A #\A) ==> #t
(#<subr char>=?> #\A #\B) ==> #f
(#<subr char>=?> #\a #\b) ==> #f
(#<subr char>=?> #\9 #\0) ==> #t
(#<subr char>=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\B) ==> #f
(#<subr char-ci=?> #\a #\B) ==> #f
(#<subr char-ci=?> #\A #\b) ==> #f
(#<subr char-ci=?> #\a #\b) ==> #f
(#<subr char-ci=?> #\9 #\0) ==> #f
(#<subr char-ci=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\a) ==> #t
(#<subr char-ci<?> #\A #\B) ==> #t
(#<subr char-ci<?> #\a #\B) ==> #t
(#<subr char-ci<?> #\A #\b) ==> #t
(#<subr char-ci<?> #\a #\b) ==> #t
(#<subr char-ci<?> #\9 #\0) ==> #f
(#<subr char-ci<?> #\A #\A) ==> #f
(#<subr char-ci<?> #\A #\a) ==> #f
(#<subr char-ci>?> #\A #\B) ==> #f
(#<subr char-ci>?> #\a #\B) ==> #f
(#<subr char-ci>?> #\A #\b) ==> #f
(#<subr char-ci>?> #\a #\b) ==> #f
(#<subr char-ci>?> #\9 #\0) ==> #t
(#<subr char-ci>?> #\A #\A) ==> #f
(#<subr char-ci>?> #\A #\a) ==> #f
(#<subr char-ci<=?> #\A #\B) ==> #t
(#<subr char-ci<=?> #\a #\B) ==> #t
(#<subr char-ci<=?> #\A #\b) ==> #t
(#<subr char-ci<=?> #\a #\b) ==> #t
(#<subr char-ci<=?> #\9 #\0) ==> #f
(#<subr char-ci<=?> #\A #\A) ==> #t
(#<subr char-ci<=?> #\A #\a) ==> #t
(#<subr char-ci>=?> #\A #\B) ==> #f
(#<subr char-ci>=?> #\a #\B) ==> #f
(#<subr char-ci>=?> #\A #\b) ==> #f
(#<subr char-ci>=?> #\a #\b) ==> #f
(#<subr char-ci>=?> #\9 #\0) ==> #t
(#<subr char-ci>=?> #\A #\A) ==> #t
(#<subr char-ci>=?> #\A #\a) ==> #t
(#<subr char-alphabetic?> #\a) ==> #t
(#<subr char-alphabetic?> #\A) ==> #t
(#<subr char-alphabetic?> #\z) ==> #t
(#<subr char-alphabetic?> #\Z) ==> #t
(#<subr char-alphabetic?> #\0) ==> #f
(#<subr char-alphabetic?> #\9) ==> #f
(#<subr char-alphabetic?> #\ ) ==> #f
(#<subr char-alphabetic?> #\;) ==> #f
(#<subr char-numeric?> #\a) ==> #f
(#<subr char-numeric?> #\A) ==> #f
(#<subr char-numeric?> #\z) ==> #f
(#<subr char-numeric?> #\Z) ==> #f
(#<subr char-numeric?> #\0) ==> #t
(#<subr char-numeric?> #\9) ==> #t
(#<subr char-numeric?> #\ ) ==> #f
(#<subr char-numeric?> #\;) ==> #f
(#<subr char-whitespace?> #\a) ==> #f
(#<subr char-whitespace?> #\A) ==> #f
(#<subr char-whitespace?> #\z) ==> #f
(#<subr char-whitespace?> #\Z) ==> #f
(#<subr char-whitespace?> #\0) ==> #f
(#<subr char-whitespace?> #\9) ==> #f
(#<subr char-whitespace?> #\ ) ==> #t
(#<subr char-whitespace?> #\;) ==> #f
(#<subr char-upper-case?> #\0) ==> #f
(#<subr char-upper-case?> #\9) ==> #f
(#<subr char-upper-case?> #\ ) ==> #f
(#<subr char-upper-case?> #\;) ==> #f
(#<subr char-lower-case?> #\0) ==> #f
(#<subr char-lower-case?> #\9) ==> #f
(#<subr char-lower-case?> #\ ) ==> #f
(#<subr char-lower-case?> #\;) ==> #f
(#<subr integer->char> 46) ==> #\.
(#<subr integer->char> 65) ==> #\A
(#<subr integer->char> 97) ==> #\a
(#<subr char-upcase> #\A) ==> #\A
(#<subr char-upcase> #\a) ==> #\A
(#<subr char-downcase> #\A) ==> #\a
(#<subr char-downcase> #\a) ==> #\a
SECTION(6 7)
(#<subr string?> "The word \"recursion\\\" has many meanings.") ==> #t
(string-set! "?**") ==> "?**"
(#<subr string> #\a #\b #\c) ==> "abc"
(#<subr string>) ==> ""
(#<subr string-length> "abc") ==> 3
(#<subr string-ref> "abc" 0) ==> #\a
(#<subr string-ref> "abc" 2) ==> #\c
(#<subr string-length> "") ==> 0
(#<subr substring> "ab" 0 0) ==> ""
(#<subr substring> "ab" 1 1) ==> ""
(#<subr substring> "ab" 2 2) ==> ""
(#<subr substring> "ab" 0 1) ==> "a"
(#<subr substring> "ab" 1 2) ==> "b"
(#<subr substring> "ab" 0 2) ==> "ab"
(#<subr string-append> "foo" "bar") ==> "foobar"
(#<subr string-append> "foo") ==> "foo"
(#<subr string-append> "foo" "") ==> "foo"
(#<subr string-append> "" "foo") ==> "foo"
(#<subr string-append>) ==> ""
(#<subr make-string> 0) ==> ""
(#<subr string=?> "" "") ==> #t
(#<subr string<?> "" "") ==> #f
(#<subr string>?> "" "") ==> #f
(#<subr string<=?> "" "") ==> #t
(#<subr string>=?> "" "") ==> #t
(#<subr string-ci=?> "" "") ==> #t
(#<subr string-ci<?> "" "") ==> #f
(#<subr string-ci>?> "" "") ==> #f
(#<subr string-ci<=?> "" "") ==> #t
(#<subr string-ci>=?> "" "") ==> #t
(#<subr string=?> "A" "B") ==> #f
(#<subr string=?> "a" "b") ==> #f
(#<subr string=?> "9" "0") ==> #f
(#<subr string=?> "A" "A") ==> #t
(#<subr string<?> "A" "B") ==> #t
(#<subr string<?> "a" "b") ==> #t
(#<subr string<?> "9" "0") ==> #f
(#<subr string<?> "A" "A") ==> #f
(#<subr string>?> "A" "B") ==> #f
(#<subr string>?> "a" "b") ==> #f
(#<subr string>?> "9" "0") ==> #t
(#<subr string>?> "A" "A") ==> #f
(#<subr string<=?> "A" "B") ==> #t
(#<subr string<=?> "a" "b") ==> #t
(#<subr string<=?> "9" "0") ==> #f
(#<subr string<=?> "A" "A") ==> #t
(#<subr string>=?> "A" "B") ==> #f
(#<subr string>=?> "a" "b") ==> #f
(#<subr string>=?> "9" "0") ==> #t
(#<subr string>=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "B") ==> #f
(#<subr string-ci=?> "a" "B") ==> #f
(#<subr string-ci=?> "A" "b") ==> #f
(#<subr string-ci=?> "a" "b") ==> #f
(#<subr string-ci=?> "9" "0") ==> #f
(#<subr string-ci=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "a") ==> #t
(#<subr string-ci<?> "A" "B") ==> #t
(#<subr string-ci<?> "a" "B") ==> #t
(#<subr string-ci<?> "A" "b") ==> #t
(#<subr string-ci<?> "a" "b") ==> #t
(#<subr string-ci<?> "9" "0") ==> #f
(#<subr string-ci<?> "A" "A") ==> #f
(#<subr string-ci<?> "A" "a") ==> #f
(#<subr string-ci>?> "A" "B") ==> #f
(#<subr string-ci>?> "a" "B") ==> #f
(#<subr string-ci>?> "A" "b") ==> #f
(#<subr string-ci>?> "a" "b") ==> #f
(#<subr string-ci>?> "9" "0") ==> #t
(#<subr string-ci>?> "A" "A") ==> #f
(#<subr string-ci>?> "A" "a") ==> #f
(#<subr string-ci<=?> "A" "B") ==> #t
(#<subr string-ci<=?> "a" "B") ==> #t
(#<subr string-ci<=?> "A" "b") ==> #t
(#<subr string-ci<=?> "a" "b") ==> #t
(#<subr string-ci<=?> "9" "0") ==> #f
(#<subr string-ci<=?> "A" "A") ==> #t
(#<subr string-ci<=?> "A" "a") ==> #t
(#<subr string-ci>=?> "A" "B") ==> #f
(#<subr string-ci>=?> "a" "B") ==> #f
(#<subr string-ci>=?> "A" "b") ==> #f
(#<subr string-ci>=?> "a" "b") ==> #f
(#<subr string-ci>=?> "9" "0") ==> #t
(#<subr string-ci>=?> "A" "A") ==> #t
(#<subr string-ci>=?> "A" "a") ==> #t
SECTION(6 8)
(#<subr vector?> #(0 (2 2 2 2) "Anna")) ==> #t
(#<subr vector> a b c) ==> #(a b c)
(#<subr vector>) ==> #()
(#<subr vector-length> #(0 (2 2 2 2) "Anna")) ==> 3
(#<subr vector-length> #()) ==> 0
(#<subr vector-ref> #(1 1 2 3 5 8 13 21) 5) ==> 8
(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
(#<subr make-vector> 2 hi) ==> #(hi hi)
(#<subr make-vector> 0) ==> #()
(#<subr make-vector> 0 a) ==> #()
SECTION(6 9)
(#<subr procedure?> #<subr car>) ==> #t
(#<subr procedure?> #<lambda (x) ...>) ==> #t
(#<subr procedure?> (lambda (x) (* x x))) ==> #f
(#<builtin call-with-current-continuation> #<subr procedure?>) ==> #t
(#<builtin apply> #<subr +> (3 4)) ==> 7
(#<builtin apply> #<lambda (a b) ...> (3 4)) ==> 7
(#<builtin apply> #<subr +> 10 (3 4)) ==> 17
(#<builtin apply> #<subr list> ()) ==> ()
(#<lambda args ...> 12 75) ==> 30
(#<builtin map> #<subr cadr> ((a b) (d e) (g h))) ==> (b e h)
(#<builtin map> #<subr +> (1 2 3) (4 5 6)) ==> (5 7 9)
(#<builtin map> #<subr +> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr *> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr -> (1 2 3)) ==> (-1 -2 -3)
(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16)
(#<builtin call-with-current-continuation> #<lambda (exit) ...>) ==> -3
(#<lambda (obj) ...> (1 2 3 4)) ==> 4
(#<lambda (obj) ...> (a b . c)) ==> #f
(#<builtin map> #<subr cadr> ()) ==> ()
SECTION(6 10 1)
(#<subr input-port?> #<input-port>) ==> #t
(#<subr output-port?> #<output-port>) ==> #t
(#<builtin call-with-input-file> "r4rstest.scm" #<subr input-port?>) ==> #t
(#<subr input-port?> #<input-port>) ==> #t
SECTION(6 10 2)
(#<subr peek-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (define cur-section (quote ()))
(#<subr peek-char> #<input-port>) ==> #\(
(#<subr read> #<input-port>) ==> (define errs (quote ()))
SECTION(6 10 3)
(#<builtin call-with-output-file> "tmp1" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr output-port?> #<output-port>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
Passed all tests
;testing inexact numbers;
SECTION(6 5 5)
(#<subr inexact?> 3.9) ==> #t
(inexact? #t) ==> #t
(max 4.) ==> 4.
(exact->inexact 4.) ==> 4.
(#<subr round> -4.5) ==> -4.
(#<subr round> -3.5) ==> -4.
(#<subr round> -3.9) ==> -4.
(#<subr round> 0.) ==> 0.
(#<subr round> 0.25) ==> 0.
(#<subr round> 0.8) ==> 1.
(#<subr round> 3.5) ==> 4.
(#<subr round> 4.5) ==> 4.
(#<subr expt> 0 0) ==> 1
(#<subr expt> 0 1) ==> 0
(#<builtin call-with-output-file> "tmp3" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (0.25 -3.25)
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(pentium-fdiv-bug #t) ==> #t
Passed all tests
SECTION(6 5 6)
(float-print-test #t) ==> #t
Number readback failure for (+ 1. (* -100 1.11022302462516e-16))
0.999999999999989
Number readback failure for (+ 10. (* -100 1.77635683940025e-15))
9.99999999999982
Number readback failure for (+ 100. (* -100 1.4210854715202e-14))
99.9999999999986
Number readback failure for (+ 1e+20 (* -100 16384.))
9.99999999999984e+19
Number readback failure for (+ 1e+50 (* -100 2.07691874341393e+34))
9.99999999999979e+49
Number readback failure for (+ 1e+100 (* -100 1.94266889222573e+84))
9.99999999999981e+99
Number readback failure for (+ 0.1 (* -100 1.38777878078145e-17))
0.0999999999999986
Number readback failure for (+ 0.01 (* -100 1.73472347597681e-18))
0.00999999999999983
Number readback failure for (+ 0.001 (* -100 2.16840434497101e-19))
0.000999999999999978
Number readback failure for (+ 1e-20 (* -100 1.50463276905253e-36))
9.99999999999985e-21
Number readback failure for (+ 1e-50 (* -100 1.18694596821997e-66))
9.99999999999988e-51
Number readback failure for (+ 1e-100 (* -100 1.26897091865782e-116))
9.99999999999987e-101
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3. (* -100 4.44089209850063e-16))
2.99999999999996
Number readback failure for (+ 30. (* -100 3.5527136788005e-15))
29.9999999999996
Number readback failure for (+ 300. (* -100 5.6843418860808e-14))
299.999999999994
Number readback failure for (+ 3e+20 (* -100 65536.))
2.99999999999993e+20
Number readback failure for (+ 3e+50 (* -100 4.15383748682786e+34))
2.99999999999996e+50
Number readback failure for (+ 3e+100 (* -100 3.88533778445146e+84))
2.99999999999996e+100
Number readback failure for (+ 0.3 (* -100 5.55111512312578e-17))
0.299999999999994
Number readback failure for (+ 0.03 (* -100 3.46944695195361e-18))
0.0299999999999997
Number readback failure for (+ 0.003 (* -100 4.33680868994202e-19))
0.00299999999999996
Number readback failure for (+ 3e-20 (* -100 6.01853107621011e-36))
2.99999999999994e-20
Number readback failure for (+ 3e-50 (* -100 4.7477838728799e-66))
2.99999999999995e-50
Number readback failure for (+ 3e-100 (* -100 5.0758836746313e-116))
2.99999999999995e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 7. (* -100 8.88178419700125e-16))
6.99999999999991
Number readback failure for (+ 70. (* -100 1.4210854715202e-14))
69.9999999999986
Number readback failure for (+ 700. (* -100 1.13686837721616e-13))
699.999999999989
Number readback failure for (+ 7e+20 (* -100 131072.))
6.99999999999987e+20
Number readback failure for (+ 7e+50 (* -100 8.30767497365572e+34))
6.99999999999992e+50
Number readback failure for (+ 7e+100 (* -100 1.55413511378058e+85))
6.99999999999984e+100
Number readback failure for (+ 0.7 (* -99 1.11022302462516e-16))
0.699999999999989
Number readback failure for (+ 0.07 (* -100 1.38777878078145e-17))
0.0699999999999986
Number readback failure for (+ 0.007 (* -100 8.67361737988404e-19))
0.00699999999999991
Number readback failure for (+ 7e-20 (* -99 1.20370621524202e-35))
6.99999999999988e-20
Number readback failure for (+ 7e-50 (* -100 9.4955677457598e-66))
6.9999999999999e-50
Number readback failure for (+ 7e-100 (* -100 1.01517673492626e-115))
6.9999999999999e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3.14159265358979 (* -100 4.44089209850063e-16))
3.14159265358975
Number readback failure for (+ 31.4159265358979 (* -100 3.5527136788005e-15))
31.4159265358976
Number readback failure for (+ 314.159265358979 (* -100 5.6843418860808e-14))
314.159265358974
Number readback failure for (+ 3.14159265358979e+20 (* -100 65536.))
3.14159265358973e+20
Number readback failure for (+ 3.14159265358979e+50 (* -100 4.15383748682786e+34))
3.14159265358975e+50
Number readback failure for (+ 3.14159265358979e+100 (* -100 3.88533778445146e+84))
3.14159265358975e+100
Number readback failure for (+ 0.314159265358979 (* -100 5.55111512312578e-17))
0.314159265358974
Number readback failure for (+ 0.0314159265358979 (* -100 6.93889390390723e-18))
0.0314159265358972
Number readback failure for (+ 0.00314159265358979 (* -99 4.33680868994202e-19))
0.00314159265358975
Number readback failure for (+ 3.14159265358979e-20 (* -100 6.01853107621011e-36))
3.14159265358973e-20
Number readback failure for (+ 3.14159265358979e-50 (* -100 4.7477838728799e-66))
3.14159265358975e-50
Number readback failure for (+ 3.14159265358979e-100 (* -100 5.0758836746313e-116))
3.14159265358974e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 2.71828182845905 (* -100 4.44089209850063e-16))
2.718281828459
Number readback failure for (+ 27.1828182845905 (* -100 3.5527136788005e-15))
27.1828182845901
Number readback failure for (+ 271.828182845905 (* -100 5.6843418860808e-14))
271.828182845899
Number readback failure for (+ 2.71828182845905e+20 (* -100 32768.))
2.71828182845901e+20
Number readback failure for (+ 2.71828182845905e+50 (* -100 4.15383748682786e+34))
2.718281828459e+50
Number readback failure for (+ 2.71828182845905e+100 (* -100 3.88533778445146e+84))
2.71828182845901e+100
Number readback failure for (+ 0.271828182845905 (* -99 5.55111512312578e-17))
0.271828182845899
Number readback failure for (+ 0.0271828182845905 (* -100 3.46944695195361e-18))
0.0271828182845901
Number readback failure for (+ 0.00271828182845905 (* -100 4.33680868994202e-19))
0.002718281828459
Number readback failure for (+ 2.71828182845904e-20 (* -100 6.01853107621011e-36))
2.71828182845898e-20
Number readback failure for (+ 2.71828182845905e-50 (* -100 4.7477838728799e-66))
2.718281828459e-50
Number readback failure for (+ 2.71828182845905e-100 (* -100 5.0758836746313e-116))
2.71828182845899e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
To fully test continuations do:
(test-cont)
;testing scheme 4 functions;
SECTION(6 7)
(#<subr string->list> "P l") ==> (#\P #\ #\l)
(#<subr string->list> "") ==> ()
(#<subr list->string> (#\1 #\\ #\")) ==> "1\\\""
(#<subr list->string> ()) ==> ""
SECTION(6 8)
(#<subr vector->list> #(dah dah didah)) ==> (dah dah didah)
(#<subr vector->list> #()) ==> ()
(#<subr list->vector> (dididit dah)) ==> #(dididit dah)
(#<subr list->vector> ()) ==> #()
SECTION(6 10 4)
(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
;testing DELAY and FORCE;
SECTION(6 9)
(delay 3) ==> 3
(delay (3 3)) ==> (3 3)
(delay 2) ==> 2
(#<builtin force> #<promise #<lambda () ...>>) ==> 6
(#<builtin force> #<promise 6>) ==> 6
(force 3) ==> 3
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
;testing continuations;
SECTION(6 9)
(#<lambda (x y) ...> (a (b (c))) ((a) b c)) ==> #t
(#<lambda (x y) ...> (a (b (c))) ((a) b c d)) ==> #f
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))

1
vx-scheme/testcases/good/scheme.good Normal file
View File

@ -0,0 +1 @@
("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two")

54
vx-scheme/testcases/good/series.good Normal file
View File

@ -0,0 +1,54 @@
1.
1.5
1.41666666666667
1.41421568627451
1.41421356237469
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1
3
6
10
15
21
28
36
45
55
4.
2.66666666666667
3.46666666666667
2.8952380952381
3.33968253968254
2.97604617604618
3.28373848373848
3.01707181707182
3.25236593471888
3.0418396189294
3.16666666666667
3.13333333333333
3.1452380952381
3.13968253968254
3.14271284271284
3.14088134088134
3.14207181707182
3.14125482360777
3.1418396189294
3.1414067184965
4.
3.16666666666667
3.14210526315789
3.141599357319
3.14159271403378
3.14159265397529
3.14159265359118
3.14159265358978
3.1415926535898
3.14159265358979

1
vx-scheme/testcases/good/sieve.good Executable file
View File

@ -0,0 +1 @@
1993

683
vx-scheme/testcases/maze.scm Normal file
View File

@ -0,0 +1,683 @@
;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
; 18/07/01 (felix): 100 iterations
;------------------------------------------------------------------------------
; Was file "rand.scm".
; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit
;;; tweaked for vx-scheme testsuite by Colin Smith
(define bitwise-and logand)
(define bitwise-not lognot)
;;; Rehacked by Olin 4/1995.
(define (random-state n)
(cons n #f))
(define (rand state)
(let ((seed (car state))
(A 2813) ; 48271
(M 8388607) ; 2147483647
(Q 2787) ; 44488
(R 2699)) ; 3399
(let* ((hi (quotient seed Q))
(lo (modulo seed Q))
(test (- (* A lo) (* R hi)))
(val (if (> test 0) test (+ test M))))
(set-car! state val)
val)))
(define (random-int n state)
(modulo (rand state) n))
; poker test
; seed 1
; cards 0-9 inclusive (random 10)
; five cards per hand
; 10000 hands
;
; Poker Hand Example Probability Calculated
; 5 of a kind (aaaaa) 0.0001 0
; 4 of a kind (aaaab) 0.0045 0.0053
; Full house (aaabb) 0.009 0.0093
; 3 of a kind (aaabc) 0.072 0.0682
; two pairs (aabbc) 0.108 0.1104
; Pair (aabcd) 0.504 0.501
; Bust (abcde) 0.3024 0.3058
; (define (random n)
; (let* ((M 2147483647)
; (slop (modulo M n)))
; (let loop ((r (rand)))
; (if (> r slop)
; (modulo r n)
; (loop (rand))))))
;
; (define (rngtest)
; (display "implementation ")
; (srand 1)
; (let loop ((n 0))
; (if (< n 10000)
; (begin
; (rand)
; (loop (1+ n)))))
; (if (= *seed* 399268537)
; (display "looks correct.")
; (begin
; (display "failed.")
; (newline)
; (display " current seed ") (display *seed*)
; (newline)
; (display " correct seed 399268537")))
; (newline))
;------------------------------------------------------------------------------
; Was file "uf.scm".
;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;; Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;; Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;; Unions the two sets -- SET1 and SET2 are now considered the same set
;;; by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;; Returns true <==> the two sets are the same.
;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.
;;; The speed of the algorithm comes because when we chase links to find
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
(define (base-set nelts) (cons nelts '()))
;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.
(define (get-set-root s)
(let lp ((r s)) ; Find the last pair
(let ((next (cdr r))) ; in the list. That's
(cond ((pair? next) (lp next)) ; the root r.
(else
(if (not (eq? r s)) ; Now zip down the list again,
(let lp ((x s)) ; changing everyone's cdr to r.
(let ((next (cdr x)))
(cond ((not (eq? r next))
(set-cdr! x r)
(lp next))))))
r))))) ; Then return r.
(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
(define (set-size s) (car (get-set-root s)))
(define (union! s1 s2)
(let* ((r1 (get-set-root s1))
(r2 (get-set-root s2))
(n1 (set-size r1))
(n2 (set-size r2))
(n (+ n1 n2)))
(cond ((> n1 n2)
(set-cdr! r2 r1)
(set-car! r1 n))
(else
(set-cdr! r1 r2)
(set-car! r2 n)))))
;------------------------------------------------------------------------------
; Was file "maze.scm".
;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions
; (define-record wall
; owner ; Cell that owns this wall.
; neighbor ; The other cell bordering this wall.
; bit) ; Integer -- a bit identifying this wall in OWNER's cell.
; (define-record cell
; reachable ; Union/find set -- all reachable cells.
; id ; Identifying info (e.g., the coords of the cell).
; (walls -1) ; A bitset telling which walls are still standing.
; (parent #f) ; For DFS spanning tree construction.
; (mark #f)) ; For marking the solution path.
(define (make-wall owner neighbor bit)
(vector 'wall owner neighbor bit))
(define (wall:owner o) (vector-ref o 1))
(define (set-wall:owner o v) (vector-set! o 1 v))
(define (wall:neighbor o) (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o) (vector-ref o 3))
(define (set-wall:bit o v) (vector-set! o 3 v))
(define (make-cell reachable id)
(vector 'cell reachable id -1 #f #f))
(define (cell:reachable o) (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o) (vector-ref o 2))
(define (set-cell:id o v) (vector-set! o 2 v))
(define (cell:walls o) (vector-ref o 3))
(define (set-cell:walls o v) (vector-set! o 3 v))
(define (cell:parent o) (vector-ref o 4))
(define (set-cell:parent o v) (vector-set! o 4 v))
(define (cell:mark o) (vector-ref o 5))
(define (set-cell:mark o v) (vector-set! o 5 v))
;;; Iterates in reverse order.
(define (vector-for-each proc v)
(let lp ((i (- (vector-length v) 1)))
(cond ((>= i 0)
(proc (vector-ref v i))
(lp (- i 1))))))
;;; Randomly permute a vector.
(define (permute-vec! v random-state)
(let lp ((i (- (vector-length v) 1)))
(cond ((> i 1)
(let ((elt-i (vector-ref v i))
(j (random-int i random-state))) ; j in [0,i)
(vector-set! v i (vector-ref v j))
(vector-set! v j elt-i))
(lp (- i 1)))))
v)
;;; This is the core of the algorithm.
(define (dig-maze walls ncells)
(call-with-current-continuation
(lambda (quit)
(vector-for-each
(lambda (wall) ; For each wall,
(let* ((c1 (wall:owner wall)) ; find the cells on
(set1 (cell:reachable c1))
(c2 (wall:neighbor wall)) ; each side of the wall
(set2 (cell:reachable c2)))
;; If there is no path from c1 to c2, knock down the
;; wall and union the two sets of reachable cells.
;; If the new set of reachable cells is the whole set
;; of cells, quit.
(if (not (set-equal? set1 set2))
(let ((walls (cell:walls c1))
(wall-mask (bitwise-not (wall:bit wall))))
(union! set1 set2)
(set-cell:walls c1 (bitwise-and walls wall-mask))
(if (= (set-size set1) ncells) (quit #f))))))
walls))))
;;; Some simple DFS routines useful for determining path length
;;; through the maze.
;;; Build a DFS tree from ROOT.
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.
(define (dfs-maze maze root do-children)
(let search ((node root) (parent #f))
(set-cell:parent node parent)
(do-children (lambda (child)
(if (not (eq? child parent))
(search child node)))
maze node)))
;;; Move the root to NEW-ROOT.
(define (reroot-maze new-root)
(let lp ((node new-root) (new-parent #f))
(let ((old-parent (cell:parent node)))
(set-cell:parent node new-parent)
(if old-parent (lp old-parent node)))))
;;; How far from CELL to the root?
(define (path-length cell)
(do ((len 0 (+ len 1))
(node (cell:parent cell) (cell:parent node)))
((not node) len)))
;;; Mark the nodes from NODE back to root. Used to mark the winning path.
(define (mark-path node)
(let lp ((node node))
(set-cell:mark node #t)
(cond ((cell:parent node) => lp))))
;------------------------------------------------------------------------------
; Was file "harr.scm".
;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - define-record
;;; ___ ___ ___
;;; / \ / \ / \
;;; ___/ A \___/ A \___/ A \___
;;; / \ / \ / \ / \
;;; / A \___/ A \___/ A \___/ A \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;; Center coord row/column
;;; ------------ ----------
;;; (x, y) -> (y/2, x/3)
;;; (3c, 2r + c&1) <- (r, c)
; (define-record harr
; nrows
; ncols
; elts)
(define (make-harr nrows ncols elts)
(vector 'harr nrows ncols elts))
(define (harr:nrows o) (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o) (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o) (vector-ref o 3))
(define (set-harr:elts o v) (vector-set! o 3 v))
(define (harr r c)
(make-harr r c (make-vector (* r c))))
(define (href ha x y)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c))))
(define (hset! ha x y val)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-set! (harr:elts ha)
(+ (* (harr:ncols ha) r) c)
val)))
(define (href/rc ha r c)
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c)))
;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).
(define (harr-tabulate nrows ncols proc)
(let ((v (make-vector (* nrows ncols))))
(do ((r (- nrows 1) (- r 1)))
((< r 0))
(do ((c 0 (+ c 1))
(i (* r ncols) (+ i 1)))
((= c ncols))
(vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
(make-harr nrows ncols v)))
(define (harr-for-each proc harr)
(vector-for-each proc (harr:elts harr)))
;------------------------------------------------------------------------------
; Was file "hex.scm".
;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.
;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;; (translate (point 2 1) maze))
;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;; means the first, third, ... columns (indices 0, 2, ...).
;;; - An odd column is one whose column index is odd. That
;;; means the second, fourth... columns (indices 1, 3, ...).
;;; The even/odd flip-flop is confusing; be careful to keep it
;;; straight. The *even* columns are the low ones. The *odd*
;;; columns are the high ones.
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; 0 1 2 3
(define south-west 1)
(define south 2)
(define south-east 4)
(define (gen-maze-array r c)
(harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
;;; This could be made more efficient.
(define (make-wall-vec harr)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(xmax (* 3 (- ncols 1)))
;; Accumulate walls.
(walls '())
(add-wall (lambda (o n b) ; owner neighbor bit
(set! walls (cons (make-wall o n b) walls)))))
;; Do everything but the bottom row.
(do ((x (* (- ncols 1) 3) (- x 3)))
((< x 0))
(do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
(- y 2)))
((<= y 1)) ; Don't do bottom row.
(let ((hex (href harr x y)))
(if (not (zero? x))
(add-wall hex (href harr (- x 3) (- y 1)) south-west))
(add-wall hex (href harr x (- y 2)) south)
(if (< x xmax)
(add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
;; Do the SE and SW walls of the odd columns on the bottom row.
;; If the rightmost bottom hex lies in an odd column, however,
;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
(if (> ncols 1)
(let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
;; Do rightmost odd col.
(let ((rmoc-hex (href harr rmoc-x 1)))
(if (< rmoc-x xmax) ; Not a corner -- do E wall.
(add-wall rmoc-hex (href harr xmax 0) south-east))
(add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
(do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
(- x 6)))
((< x 3)) ; 3 is X coord of leftmost odd column.
(add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
(add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
(list->vector walls)))
;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop.
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
(define (pick-entrances harr)
(dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
(let ((nrows (harr:nrows harr))
(ncols (harr:ncols harr)))
(let tp-lp ((max-len -1)
(entrance #f)
(exit #f)
(tcol (- ncols 1)))
(if (< tcol 0) (vector entrance exit)
(let ((top-cell (href/rc harr (- nrows 1) tcol)))
(reroot-maze top-cell)
(let ((result
(let bt-lp ((max-len max-len)
(entrance entrance)
(exit exit)
(bcol (- ncols 1)))
; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
(if (< bcol 0) (vector max-len entrance exit)
(let ((this-len (path-length (href/rc harr 0 bcol))))
(if (> this-len max-len)
(bt-lp this-len tcol bcol (- bcol 1))
(bt-lp max-len entrance exit (- bcol 1))))))))
(let ((max-len (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(tp-lp max-len entrance exit (- tcol 1)))))))))
;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
(let* ((walls (cell:walls cell))
(id (cell:id cell))
(x (car id))
(y (cdr id))
(nr (harr:nrows harr))
(nc (harr:ncols harr))
(maxy (* 2 (- nr 1)))
(maxx (* 3 (- nc 1))))
(if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
(if (not (bit-test walls south)) (proc (href harr x (- y 2))))
(if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
(if (and (> x 0) ; Not in first column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((nw (href harr (- x 3) (+ y 1))))
(if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
;; N neighbor, if there is one (we may be on top row).
(if (< y maxy) ; Not on top row
(let ((n (href harr x (+ y 2))))
(if (not (bit-test (cell:walls n) south)) (proc n))))
;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
(if (and (< x maxx) ; Not in last column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((ne (href harr (+ x 3) (+ y 1))))
(if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
;;; The top-level
(define (make-maze nrows ncols)
(let* ((cells (gen-maze-array nrows ncols))
(walls (permute-vec! (make-wall-vec cells) (random-state 20))))
(dig-maze walls (* nrows ncols))
(let ((result (pick-entrances cells)))
(let ((entrance (vector-ref result 0))
(exit (vector-ref result 1)))
(let* ((exit-cell (href/rc cells 0 exit))
(walls (cell:walls exit-cell)))
(reroot-maze (href/rc cells (- nrows 1) entrance))
(mark-path exit-cell)
(set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
(vector cells entrance exit))))))
(define (pmaze nrows ncols)
(let ((result (make-maze nrows ncols)))
(let ((cells (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(print-hexmaze cells entrance))))
;------------------------------------------------------------------------------
; Was file "hexprint.scm".
;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - hex array code
;;; - hex cell code
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; Top part of top row looks like this:
;;; _ _ _ _
;;; _/ \_/ \/ \_/ \
;;; /
(define output #f) ; the list of all characters written out, in reverse order.
(define (write-ch c)
(set! output (cons c output)))
(define (print-hexmaze harr entrance)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(ncols2 (* 2 (quotient ncols 2))))
;; Print out the flat tops for the top row's odd cols.
(do ((c 1 (+ c 2)))
((>= c ncols))
; (display " ")
(write-ch #\space)
(write-ch #\space)
(write-ch #\space)
(write-ch (if (= c entrance) #\space #\_)))
; (newline)
(write-ch #\newline)
;; Print out the slanted tops for the top row's odd cols
;; and the flat tops for the top row's even cols.
(write-ch #\space)
(do ((c 0 (+ c 2)))
((>= c ncols2))
; (format #t "~a/~a\\"
; (if (= c entrance) #\space #\_)
; (dot/space harr (- nrows 1) (+ c 1)))
(write-ch (if (= c entrance) #\space #\_))
(write-ch #\/)
(write-ch (dot/space harr (- nrows 1) (+ c 1)))
(write-ch #\\))
(if (odd? ncols)
(write-ch (if (= entrance (- ncols 1)) #\space #\_)))
; (newline)
(write-ch #\newline)
(do ((r (- nrows 1) (- r 1)))
((< r 0))
;; Do the bottoms for row r's odd cols.
(write-ch #\/)
(do ((c 1 (+ c 2)))
((>= c ncols2))
;; The dot/space for the even col just behind c.
(write-ch (dot/space harr r (- c 1)))
(display-hexbottom (cell:walls (href/rc harr r c))))
(cond ((odd? ncols)
(write-ch (dot/space harr r (- ncols 1)))
(write-ch #\\)))
; (newline)
(write-ch #\newline)
;; Do the bottoms for row r's even cols.
(do ((c 0 (+ c 2)))
((>= c ncols2))
(display-hexbottom (cell:walls (href/rc harr r c)))
;; The dot/space is for the odd col just after c, on row below.
(write-ch (dot/space harr (- r 1) (+ c 1))))
(cond ((odd? ncols)
(display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
((not (zero? r)) (write-ch #\\)))
; (newline)
(write-ch #\newline))))
(define (bit-test j bit)
(not (zero? (bitwise-and j bit))))
;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
(if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
(write-ch (if (bit-test hexwalls south-west) #\\ #\space))
(write-ch (if (bit-test hexwalls south ) #\_ #\space))
(write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;------------------------------------------------------------------------------
(set! output '())
(pmaze 20 7)
(display (list->string (reverse output)))

27
vx-scheme/testcases/pi.scm Normal file
View File

@ -0,0 +1,27 @@
(define (pi n . args)
(let* ((d (car args))
(r (do ((s 1 (* 10 s))
(i d (- i 1)))
((zero? i) s)))
(n (+ (quotient n d) 1))
(m (quotient (* n d 3322) 1000))
(a (make-vector (+ 1 m) 2)))
(vector-set! a m 4)
(do ((j 1 (+ 1 j))
(q 0 0)
(b 2 (remainder q r)))
((> j n))
(do ((k m (- k 1)))
((zero? k))
(set! q (+ q (* (vector-ref a k) r)))
(let ((t (+ 1 (* 2 k))))
(vector-set! a k (remainder q t))
(set! q (* k (quotient q t)))))
(let ((s (number->string (+ b (quotient q r)))))
(do ((l (string-length s) (+ 1 l)))
((>= l d) (display s))
(display #\0)))
(if (zero? (modulo j 10)) (newline) (display #\ )))
(newline)))
(pi 300 5)

168
vx-scheme/testcases/puzzle.scm Normal file
View File

@ -0,0 +1,168 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: puzzle.sch
; Description: PUZZLE benchmark
; Author: Richard Gabriel, after Forrest Baskett
; Created: 12-Apr-85
; Modified: 12-Apr-85 14:20:23 (Bob Shaw)
; 11-Aug-87 (Will Clinger)
; 22-Jan-88 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (iota n)
(do ((n n (- n 1))
(list '() (cons (- n 1) list)))
((zero? n) list)))
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(define size 511)
(define classmax 3)
(define typemax 12)
(define *iii* 0)
(define *kount* 0)
(define *d* 8)
(define *piececount* (make-vector (+ classmax 1) 0))
(define *class* (make-vector (+ typemax 1) 0))
(define *piecemax* (make-vector (+ typemax 1) 0))
(define *puzzle* (make-vector (+ size 1)))
(define *p* (make-vector (+ typemax 1)))
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
(iota (+ typemax 1)))
(define (fit i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((or (> k end)
(and (vector-ref (vector-ref *p* i) k)
(vector-ref *puzzle* (+ j k))))
(if (> k end) #t #f)))))
(define (place i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #t)
#t)))
(vector-set! *piececount*
(vector-ref *class* i)
(- (vector-ref *piececount* (vector-ref *class* i)) 1))
(do ((k j (+ k 1)))
((or (> k size) (not (vector-ref *puzzle* k)))
; (newline)
; (display "*Puzzle* filled")
(if (> k size) 0 k)))))
(define (puzzle-remove i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #f)
#f)))
(vector-set! *piececount*
(vector-ref *class* i)
(+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
(define (trial j)
(let ((k 0))
(call-with-current-continuation
(lambda (return)
(do ((i 0 (+ i 1)))
((> i typemax) (set! *kount* (+ *kount* 1)) #f)
(cond
((not
(zero?
(vector-ref *piececount* (vector-ref *class* i))))
(cond
((fit i j)
(set! k (place i j))
(cond
((or (trial k) (zero? k))
(trial-output (+ i 1) (+ k 1))
(set! *kount* (+ *kount* 1))
(return #t))
(else (puzzle-remove i j))))))))))))
(define (trial-output x y)
(newline)
(display (string-append "Piece "
(number->string x)
" at "
(number->string y)
".")))
(define (definePiece iclass ii jj kk)
(let ((index 0))
(do ((i 0 (+ i 1)))
((> i ii))
(do ((j 0 (+ j 1)))
((> j jj))
(do ((k 0 (+ k 1)))
((> k kk))
(set! index (+ i (* *d* (+ j (* *d* k)))))
(vector-set! (vector-ref *p* *iii*) index #t))))
(vector-set! *class* *iii* iclass)
(vector-set! *piecemax* *iii* index)
(cond ((not (= *iii* typemax))
(set! *iii* (+ *iii* 1))))))
(define (start)
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! *puzzle* m #t))
(do ((i 1 (+ i 1)))
((> i 5))
(do ((j 1 (+ j 1)))
((> j 5))
(do ((k 1 (+ k 1)))
((> k 5))
(vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
(do ((i 0 (+ i 1)))
((> i typemax))
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! (vector-ref *p* i) m #f)))
(set! *iii* 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(vector-set! *piececount* 0 13)
(vector-set! *piececount* 1 3)
(vector-set! *piececount* 2 1)
(vector-set! *piececount* 3 1)
(let ((m (+ (* *d* (+ *d* 1)) 1))
(n 0))
(cond ((fit 0 m) (set! n (place 0 m)))
(else (begin (newline) (display "Error."))))
(cond ((trial n)
(begin (newline)
(display "Success in ")
(write *kount*)
(display " trials.")))
(else (begin (newline) (display "Failure."))))))
;;; call: (start)
(start)
(newline)

12
vx-scheme/testcases/q.scm Normal file
View File

@ -0,0 +1,12 @@
(define l '(-5 -4 -3 -2 -1 1 2 3 4 5))
(for-each
(lambda (n)
(for-each
(lambda (d)
(display (quotient n d))
(newline))
l))
l)

1197
vx-scheme/testcases/r4rstest.scm Normal file
View File

File diff suppressed because it is too large Load Diff

1083
vx-scheme/testcases/scheme.scm Normal file
View File

File diff suppressed because it is too large Load Diff

72
vx-scheme/testcases/series.scm Normal file
View File

@ -0,0 +1,72 @@
;;
;; Several infinite series computations from, e.g., SICP 2ed. s. 3.5.3
;;
(load "stream.scm")
(define (average x y)
(/ (+ x y) 2))
(define (sqrt-improve guess x)
(average guess (/ x guess)))
(define (sqrt-stream x)
(define guesses
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
guesses)))
guesses)
(display-stream-n (sqrt-stream 2) 10)
(newline)
(define (partial-sums s)
(cons-stream
(stream-car s)
(partial-sums (cons-stream (+ (stream-car s) (stream-car (stream-cdr s)))
(stream-cdr (stream-cdr s))))))
(display-stream-n (partial-sums integers) 10)
(newline)
(define (pi-summands n)
(cons-stream (/ n)
(stream-map - (pi-summands (+ n 2)))))
(define pi-stream
(scale-stream (partial-sums (pi-summands 1)) 4))
(display-stream-n pi-stream 10)
(newline)
(define (square x) (* x x))
(define (euler-transform s)
(let ((s0 (stream-ref s 0))
(s1 (stream-ref s 1))
(s2 (stream-ref s 2)))
(cons-stream (- s2 (/ (square (- s2 s1))
(+ s0 (* -2 s1) s2)))
(euler-transform (stream-cdr s)))))
(display-stream-n (euler-transform pi-stream) 10)
(newline)
(define (make-tableau transform s)
(cons-stream s
(make-tableau transform
(transform s))))
(define (accelerated-sequence transform s)
(stream-map stream-car
(make-tableau transform s)))
(display-stream-n (accelerated-sequence euler-transform
pi-stream)
10)

43
vx-scheme/testcases/sicp.scm Normal file
View File

@ -0,0 +1,43 @@
;;
;; Two dimensional table, from: [SICP 2ed. p. 271]
;;
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;;
;; Tagged list from [SICP 2ed. p. 369]
;;
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))

20
vx-scheme/testcases/sieve.scm Normal file
View File

@ -0,0 +1,20 @@
;;
;; The prime-stream example [SICP 2ed. p. 327]
;;
(load "stream.scm")
(define (divisible? x y) (= (remainder x y) 0))
(define (sieve stream)
(cons-stream
(stream-car stream)
(sieve (stream-filter
(lambda (x)
(not (divisible? x (stream-car stream))))
(stream-cdr stream)))))
(define primes (sieve (integers-starting-from 2)))
(display (stream-ref primes 300))
(newline)

80
vx-scheme/testcases/stream.scm Normal file
View File

@ -0,0 +1,80 @@
;;
;; basic STREAM procedures as discussed in SICP ss. 3.5.1 - 3.5.3
;;
(defmacro (cons-stream a b)
`(cons ,a (delay ,b)))
(define the-empty-stream '())
(define (stream-null? s) (eq? s the-empty-stream))
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define (stream-filter pred stream)
(cond ((null? stream) '())
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
(define (stream-ref s n)
(if (= n 0)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-map proc . argstreams)
(if (null? (car argstreams))
'()
(cons-stream (apply proc (map stream-car argstreams))
(apply stream-map proc (map stream-cdr argstreams)))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(define (stream-add stream addend)
(stream-map (lambda (e) (+ e addend)) stream))
(define (scale-stream stream factor)
(stream-map (lambda (x) (* x factor)) stream))
(define (stream+ s t)
(stream-map + s t))
(define (stream/ s t)
(stream-map / s t))
(define (display-stream s)
(if (null? s)
'ok
(begin
(newline)
(display (stream-car s))
(display-stream (stream-cdr s)))))
(define (display-stream-n s n)
(let loop ((i 0) (rest s))
(if (= i n) 'ok
(begin
(display (stream-car rest))
(newline)
(loop (+ i 1) (stream-cdr rest))))))
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(define integers (integers-starting-from 1))

3
vx-scheme/testcases/vx-good/ack.good Executable file
View File

@ -0,0 +1,3 @@
253
509
1021

1
vx-scheme/testcases/vx-good/boyer.good Normal file
View File

@ -0,0 +1 @@
#t

65
vx-scheme/testcases/vx-good/cf.good Executable file
View File

@ -0,0 +1,65 @@
1
1
1
1
1
(1 1 1.)
(2 1 2.)
(3 2 1.5)
(5 3 1.66666666666667)
(8 5 1.6)
(13 8 1.625)
(21 13 1.61538461538462)
(34 21 1.61904761904762)
(55 34 1.61764705882353)
(89 55 1.61818181818182)
(144 89 1.61797752808989)
(233 144 1.61805555555556)
(377 233 1.61802575107296)
(610 377 1.61803713527851)
(987 610 1.61803278688525)
(1597 987 1.61803444782168)
(2584 1597 1.61803381340013)
(4181 2584 1.61803405572755)
(6765 4181 1.61803396316671)
(10946 6765 1.6180339985218)
(17711 10946 1.61803398501736)
(28657 17711 1.6180339901756)
(46368 28657 1.61803398820533)
(75025 46368 1.6180339889579)
(121393 75025 1.61803398867044)
(196418 121393 1.61803398878024)
(317811 196418 1.6180339887383)
(514229 317811 1.61803398875432)
(832040 514229 1.6180339887482)
(1346269 832040 1.61803398875054)
(2178309 1346269 1.61803398874965)
(3524578 2178309 1.61803398874999)
(5702887 3524578 1.61803398874986)
(9227465 5702887 1.61803398874991)
(14930352 9227465 1.61803398874989)
(24157817 14930352 1.6180339887499)
(39088169 24157817 1.61803398874989)
(63245986 39088169 1.6180339887499)
(102334155 63245986 1.61803398874989)
(165580141 102334155 1.61803398874989)
1.61803398874989(2 1 2.)
(5 2 2.5)
(12 5 2.4)
(29 12 2.41666666666667)
(70 29 2.41379310344828)
(169 70 2.41428571428571)
(408 169 2.41420118343195)
(985 408 2.41421568627451)
(2378 985 2.41421319796954)
(5741 2378 2.41421362489487)
(1 1 1.)
(3 2 1.5)
(4 3 1.33333333333333)
(11 8 1.375)
(15 11 1.36363636363636)
(41 30 1.36666666666667)
(56 41 1.36585365853659)
(153 112 1.36607142857143)
(209 153 1.36601307189542)
(571 418 1.36602870813397)

1
vx-scheme/testcases/vx-good/dderiv.good Normal file
View File

@ -0,0 +1 @@
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) (* (* b x) (+ (/ 0 b) (/ 1 x))) 0)

1
vx-scheme/testcases/vx-good/dynamic.good Executable file
View File

@ -0,0 +1 @@
((218 . 437) (6 . 1892) (2204 . 441))

1
vx-scheme/testcases/vx-good/earley.good Executable file
View File

@ -0,0 +1 @@
1430

42
vx-scheme/testcases/vx-good/maze.good Executable file
View File

@ -0,0 +1,42 @@
_ _ _
_/ \_/ \_/.\
/ \ \_ . /.\
\ \ /. _/.\ /
/ \_/. _/ \_ .\
\ / \ / _/ \_/
/ _/.\ / \ / \
\ / \ / _/ /
/ \ /.\ /.\_/ \
\_/ \ /. _ .\ /
/ \_ . _/ \ \
\_ \_/ _/.\ /
/ _/ / \ / \
\_ \ / \_ .\_/
/ \_ \_ \_ .\
\_ \_/ _/.\ /
/ \_ \ /.\ .\
\ /.\_ . /.\ /
/ . _/.\ / \
\ /.\_/.\_ .\ /
/ \_ . / _/ \
\_ \_/.\_ \_/
/ _/ \ / \_ \
\_/ _/.\_ \_/
/ \ / _ . _ \
\ / \_/. _ \_/
/ _ \ \_/ \
\_/.\_ .\_/ _/
/ \ . _/ / \
\ /.\_/ \_/.\ /
/ \_ . _/. \
\ . /.\_/
/ \_/ \_/ \_ .\
\_/ / \_/. /
/ / _ \ / \
\_/ \_/ \_/.\_/
/ \_/ _/ \_ .\
\ _/. /. _/
/ \ /. / \_ .\
\_/. _/.\_/.\ /
/ _ .\_ . _ .\
\_/ \ / \_/ \_/

7
vx-scheme/testcases/vx-good/pi.good Executable file
View File

@ -0,0 +1,7 @@
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
08128 48111 74502 84102 70193 85211 05559 64462 29489 54930
38196 44288 10975 66593 34461 28475 64823 37867 83165 27120
19091 45648 56692 34603 48610 45432 66482 13393 60726 02491
41273

19
vx-scheme/testcases/vx-good/puzzle.good Normal file
View File

@ -0,0 +1,19 @@
Piece 1 at 1.
Piece 8 at 354.
Piece 7 at 330.
Piece 3 at 291.
Piece 13 at 278.
Piece 12 at 276.
Piece 5 at 275.
Piece 1 at 267.
Piece 1 at 219.
Piece 3 at 203.
Piece 1 at 202.
Piece 1 at 154.
Piece 9 at 138.
Piece 2 at 110.
Piece 2 at 108.
Piece 1 at 106.
Piece 3 at 90.
Success in 2005 trials.

778
vx-scheme/testcases/vx-good/r4rstest.good Executable file
View File

@ -0,0 +1,778 @@
SECTION(2 1)
SECTION(3 4)
#<subr boolean?>
#<subr char?>
#<subr null?>
#<subr number?>
#<subr pair?>
#<subr procedure?>
#<subr string?>
#<subr symbol?>
#<subr vector?>
(#t #f #f #f #f #f #f #f #f)#t
(#t #f #f #f #f #f #f #f #f)#f
(#f #t #f #f #f #f #f #f #f)#\a
(#f #f #t #f #f #f #f #f #f)()
(#f #f #f #t #f #f #f #f #f)9739
(#f #f #f #f #t #f #f #f #f)(test)
(#f #f #f #f #f #t #f #f #f)#<lambda (e) ...>
(#f #f #f #f #f #f #t #f #f)"test"
(#f #f #f #f #f #f #t #f #f)""
(#f #f #f #f #f #f #f #t #f)test
(#f #f #f #f #f #f #f #f #t)#()
(#f #f #f #f #f #f #f #f #t)#(a b c)
SECTION(4 1 2)
(quote (quote a)) ==> (quote a)
(quote (quote a)) ==> (quote a)
SECTION(4 1 3)
(#<subr *> 3 4) ==> 12
SECTION(4 1 4)
(#<lambda (x) ...> 4) ==> 8
(#<lambda (x y) ...> 7 10) ==> 3
(#<lambda (y) ...> 6) ==> 10
(#<lambda x ...> 3 4 5 6) ==> (3 4 5 6)
(#<lambda (x y . z) ...> 3 4 5 6) ==> (5 6)
SECTION(4 1 5)
(if yes) ==> yes
(if no) ==> no
(if 1) ==> 1
SECTION(4 1 6)
(define 3) ==> 3
(set! 5) ==> 5
SECTION(4 2 1)
(cond greater) ==> greater
(cond equal) ==> equal
(cond 2) ==> 2
(case composite) ==> composite
(case consonant) ==> consonant
(and #t) ==> #t
(and #f) ==> #f
(and (f g)) ==> (f g)
(and #t) ==> #t
(or #t) ==> #t
(or #t) ==> #t
(or #f) ==> #f
(or #f) ==> #f
(or (b c)) ==> (b c)
SECTION(4 2 2)
(let 6) ==> 6
(let 35) ==> 35
(let* 70) ==> 70
(letrec #t) ==> #t
(let 5) ==> 5
(let 34) ==> 34
(let 6) ==> 6
(let 34) ==> 34
(let* 7) ==> 7
(let* 34) ==> 34
(let* 8) ==> 8
(let* 34) ==> 34
(letrec 9) ==> 9
(letrec 34) ==> 34
(letrec 10) ==> 10
(letrec 34) ==> 34
SECTION(4 2 3)
(begin 6) ==> 6
SECTION(4 2 4)
(do #(0 1 2 3 4)) ==> #(0 1 2 3 4)
(do 25) ==> 25
(let 1) ==> 1
(let ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
(let -1) ==> -1
SECTION(4 2 6)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (list a (quote a))) ==> (list a (quote a))
(quasiquote (a 3 4 5 6 b)) ==> (a 3 4 5 6 b)
(quasiquote ((foo 7) . cons)) ==> ((foo 7) . cons)
(quasiquote #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
(quasiquote 5) ==> 5
(quasiquote (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)) ==> (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)
(quasiquote (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)) ==> (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) ==> (quasiquote (list (unquote (+ 1 2)) 4))
SECTION(5 2 1)
(define 6) ==> 6
(define 1) ==> 1
(#<lambda (x) ...> 6) ==> 9
SECTION(5 2 2)
(define 45) ==> 45
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda (x) ...> 88) ==> 88
(#<lambda (x) ...> 4) ==> 4
(define 34) ==> 34
(internal-define 99) ==> 99
(internal-define 77) ==> 77
SECTION(6 1)
(#<subr not> #t) ==> #f
(#<subr not> 3) ==> #f
(#<subr not> (3)) ==> #f
(#<subr not> #f) ==> #t
(#<subr not> ()) ==> #f
(#<subr not> ()) ==> #f
(#<subr not> nil) ==> #f
SECTION(6 2)
(#<subr eqv?> a a) ==> #t
(#<subr eqv?> a b) ==> #f
(#<subr eqv?> 2 2) ==> #t
(#<subr eqv?> () ()) ==> #t
(#<subr eqv?> 10000 10000) ==> #t
(#<subr eqv?> (1 . 2) (1 . 2)) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #f nil) ==> #f
(#<subr eqv?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eq?> a a) ==> #t
(#<subr eq?> (a) (a)) ==> #f
(#<subr eq?> () ()) ==> #t
(#<subr eq?> #<subr car> #<subr car>) ==> #t
(#<subr eq?> (a) (a)) ==> #t
(#<subr eq?> #() #()) ==> #t
(#<subr eq?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr equal?> a a) ==> #t
(#<subr equal?> (a) (a)) ==> #t
(#<subr equal?> (a (b) c) (a (b) c)) ==> #t
(#<subr equal?> "abc" "abc") ==> #t
(#<subr equal?> 2 2) ==> #t
(#<subr equal?> #(a a a a a) #(a a a a a)) ==> #t
SECTION(6 3)
(dot (a b c d e)) ==> (a b c d e)
(#<subr list?> (a b c)) ==> #t
(set-cdr! (a . 4)) ==> (a . 4)
(#<subr eqv?> (a . 4) (a . 4)) ==> #t
(dot (a b c . d)) ==> (a b c . d)
(#<subr list?> (a . 4)) ==> #f
(list? #f) ==> #f
(#<subr cons> a ()) ==> (a)
(#<subr cons> (a) (b c d)) ==> ((a) b c d)
(#<subr cons> "a" (b c)) ==> ("a" b c)
(#<subr cons> a 3) ==> (a . 3)
(#<subr cons> (a b) c) ==> ((a b) . c)
(#<subr car> (a b c)) ==> a
(#<subr car> ((a) b c d)) ==> (a)
(#<subr car> (1 . 2)) ==> 1
(#<subr cdr> ((a) b c d)) ==> (b c d)
(#<subr cdr> (1 . 2)) ==> 2
(#<subr list> a 7 c) ==> (a 7 c)
(#<subr list>) ==> ()
(#<subr length> (a b c)) ==> 3
(#<subr length> (a (b) (c d e))) ==> 3
(#<subr length> ()) ==> 0
(#<subr append> (x) (y)) ==> (x y)
(#<subr append> (a) (b c d)) ==> (a b c d)
(#<subr append> (a (b)) ((c))) ==> (a (b) (c))
(#<subr append>) ==> ()
(#<subr append> (a b) (c . d)) ==> (a b c . d)
(#<subr append> () a) ==> a
(#<subr reverse> (a b c)) ==> (c b a)
(#<subr reverse> (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a)
(#<subr list-ref> (a b c d) 2) ==> c
(#<subr memq> a (a b c)) ==> (a b c)
(#<subr memq> b (a b c)) ==> (b c)
(#<subr memq> a (b c d)) ==> #f
(#<subr memq> (a) (b (a) c)) ==> #f
(#<subr member> (a) (b (a) c)) ==> ((a) c)
(#<subr memv> 101 (100 101 102)) ==> (101 102)
(#<subr assq> a ((a 1) (b 2) (c 3))) ==> (a 1)
(#<subr assq> b ((a 1) (b 2) (c 3))) ==> (b 2)
(#<subr assq> d ((a 1) (b 2) (c 3))) ==> #f
(#<subr assq> (a) (((a)) ((b)) ((c)))) ==> #f
(#<subr assoc> (a) (((a)) ((b)) ((c)))) ==> ((a))
(#<subr assv> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
SECTION(6 4)
(#<subr symbol?> a) ==> #t
(standard-case #t) ==> #t
(standard-case #t) ==> #t
(#<subr symbol->string> flying-fish) ==> "flying-fish"
(#<subr symbol->string> martin) ==> "martin"
(#<subr symbol->string> Malvina) ==> "Malvina"
(standard-case #t) ==> #t
(string-set! "cb") ==> "cb"
(#<subr symbol->string> ab) ==> "ab"
(#<subr string->symbol> "ab") ==> ab
(#<subr eq?> mississippi mississippi) ==> #t
(string->symbol #f) ==> #f
(#<subr string->symbol> "jollywog") ==> jollywog
SECTION(6 5 5)
(#<subr number?> 3) ==> #t
(#<subr complex?> 3) ==> #t
(#<subr real?> 3) ==> #t
(#<subr rational?> 3) ==> #t
(#<subr integer?> 3) ==> #t
(#<subr exact?> 3) ==> #t
(#<subr inexact?> 3) ==> #f
(#<subr => 22 22 22) ==> #t
(#<subr => 22 22) ==> #t
(#<subr => 34 34 35) ==> #f
(#<subr => 34 35) ==> #f
(#<subr >> 3 -6246) ==> #t
(#<subr >> 9 9 -2424) ==> #f
(#<subr >=> 3 -4 -6246) ==> #t
(#<subr >=> 9 9) ==> #t
(#<subr >=> 8 9) ==> #f
(#<subr <> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <> -1 2 3 4 4 5 6 7) ==> #f
(#<subr <=> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <=> -1 2 3 4 4 5 6 7) ==> #t
(#<subr <> 1 3 2) ==> #f
(#<subr >=> 1 3 2) ==> #f
(#<subr zero?> 0) ==> #t
(#<subr zero?> 1) ==> #f
(#<subr zero?> -1) ==> #f
(#<subr zero?> -100) ==> #f
(#<subr positive?> 4) ==> #t
(#<subr positive?> -4) ==> #f
(#<subr positive?> 0) ==> #f
(#<subr negative?> 4) ==> #f
(#<subr negative?> -4) ==> #t
(#<subr negative?> 0) ==> #f
(#<subr odd?> 3) ==> #t
(#<subr odd?> 2) ==> #f
(#<subr odd?> -4) ==> #f
(#<subr odd?> -1) ==> #t
(#<subr even?> 3) ==> #f
(#<subr even?> 2) ==> #t
(#<subr even?> -4) ==> #t
(#<subr even?> -1) ==> #f
(#<subr max> 34 5 7 38 6) ==> 38
(#<subr min> 3 5 5 330 4 -24) ==> -24
(#<subr +> 3 4) ==> 7
(#<subr +> 3) ==> 3
(#<subr +>) ==> 0
(#<subr *> 4) ==> 4
(#<subr *>) ==> 1
(#<subr -> 3 4) ==> -1
(#<subr -> 3) ==> -3
(#<subr abs> -7) ==> 7
(#<subr abs> 7) ==> 7
(#<subr abs> 0) ==> 0
(#<subr quotient> 35 7) ==> 5
(#<subr quotient> -35 7) ==> -5
(#<subr quotient> 35 -7) ==> -5
(#<subr quotient> -35 -7) ==> 5
(#<subr modulo> 13 4) ==> 1
(#<subr remainder> 13 4) ==> 1
(#<subr modulo> -13 4) ==> 3
(#<subr remainder> -13 4) ==> -1
(#<subr modulo> 13 -4) ==> -3
(#<subr remainder> 13 -4) ==> 1
(#<subr modulo> -13 -4) ==> -1
(#<subr remainder> -13 -4) ==> -1
(#<subr modulo> 0 86400) ==> 0
(#<subr modulo> 0 -86400) ==> 0
(#<lambda (n1 n2) ...> 238 9) ==> #t
(#<lambda (n1 n2) ...> -238 9) ==> #t
(#<lambda (n1 n2) ...> 238 -9) ==> #t
(#<lambda (n1 n2) ...> -238 -9) ==> #t
(#<subr gcd> 0 4) ==> 4
(#<subr gcd> -4 0) ==> 4
(#<subr gcd> 32 -36) ==> 4
(#<subr gcd>) ==> 0
(#<subr lcm> 32 -36) ==> 288
(#<subr lcm>) ==> 1
SECTION(6 5 9)
(#<subr number->string> 0) ==> "0"
(#<subr number->string> 100) ==> "100"
(#<subr number->string> 256 16) ==> "100"
(#<subr string->number> "100") ==> 100
(#<subr string->number> "100" 16) ==> 256
(#<subr string->number> "") ==> #f
(#<subr string->number> ".") ==> #f
(#<subr string->number> "d") ==> #f
(#<subr string->number> "D") ==> #f
(#<subr string->number> "i") ==> #f
(#<subr string->number> "I") ==> #f
(#<subr string->number> "3i") ==> #f
(#<subr string->number> "3I") ==> #f
(#<subr string->number> "33i") ==> #f
(#<subr string->number> "33I") ==> #f
(#<subr string->number> "3.3i") ==> #f
(#<subr string->number> "3.3I") ==> #f
(#<subr string->number> "-") ==> #f
(#<subr string->number> "+") ==> #f
SECTION(6 6)
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr char?> #\a) ==> #t
(#<subr char?> #\() ==> #t
(#<subr char?> #\ ) ==> #t
(#<subr char?> #\
) ==> #t
(#<subr char=?> #\A #\B) ==> #f
(#<subr char=?> #\a #\b) ==> #f
(#<subr char=?> #\9 #\0) ==> #f
(#<subr char=?> #\A #\A) ==> #t
(#<subr char<?> #\A #\B) ==> #t
(#<subr char<?> #\a #\b) ==> #t
(#<subr char<?> #\9 #\0) ==> #f
(#<subr char<?> #\A #\A) ==> #f
(#<subr char>?> #\A #\B) ==> #f
(#<subr char>?> #\a #\b) ==> #f
(#<subr char>?> #\9 #\0) ==> #t
(#<subr char>?> #\A #\A) ==> #f
(#<subr char<=?> #\A #\B) ==> #t
(#<subr char<=?> #\a #\b) ==> #t
(#<subr char<=?> #\9 #\0) ==> #f
(#<subr char<=?> #\A #\A) ==> #t
(#<subr char>=?> #\A #\B) ==> #f
(#<subr char>=?> #\a #\b) ==> #f
(#<subr char>=?> #\9 #\0) ==> #t
(#<subr char>=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\B) ==> #f
(#<subr char-ci=?> #\a #\B) ==> #f
(#<subr char-ci=?> #\A #\b) ==> #f
(#<subr char-ci=?> #\a #\b) ==> #f
(#<subr char-ci=?> #\9 #\0) ==> #f
(#<subr char-ci=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\a) ==> #t
(#<subr char-ci<?> #\A #\B) ==> #t
(#<subr char-ci<?> #\a #\B) ==> #t
(#<subr char-ci<?> #\A #\b) ==> #t
(#<subr char-ci<?> #\a #\b) ==> #t
(#<subr char-ci<?> #\9 #\0) ==> #f
(#<subr char-ci<?> #\A #\A) ==> #f
(#<subr char-ci<?> #\A #\a) ==> #f
(#<subr char-ci>?> #\A #\B) ==> #f
(#<subr char-ci>?> #\a #\B) ==> #f
(#<subr char-ci>?> #\A #\b) ==> #f
(#<subr char-ci>?> #\a #\b) ==> #f
(#<subr char-ci>?> #\9 #\0) ==> #t
(#<subr char-ci>?> #\A #\A) ==> #f
(#<subr char-ci>?> #\A #\a) ==> #f
(#<subr char-ci<=?> #\A #\B) ==> #t
(#<subr char-ci<=?> #\a #\B) ==> #t
(#<subr char-ci<=?> #\A #\b) ==> #t
(#<subr char-ci<=?> #\a #\b) ==> #t
(#<subr char-ci<=?> #\9 #\0) ==> #f
(#<subr char-ci<=?> #\A #\A) ==> #t
(#<subr char-ci<=?> #\A #\a) ==> #t
(#<subr char-ci>=?> #\A #\B) ==> #f
(#<subr char-ci>=?> #\a #\B) ==> #f
(#<subr char-ci>=?> #\A #\b) ==> #f
(#<subr char-ci>=?> #\a #\b) ==> #f
(#<subr char-ci>=?> #\9 #\0) ==> #t
(#<subr char-ci>=?> #\A #\A) ==> #t
(#<subr char-ci>=?> #\A #\a) ==> #t
(#<subr char-alphabetic?> #\a) ==> #t
(#<subr char-alphabetic?> #\A) ==> #t
(#<subr char-alphabetic?> #\z) ==> #t
(#<subr char-alphabetic?> #\Z) ==> #t
(#<subr char-alphabetic?> #\0) ==> #f
(#<subr char-alphabetic?> #\9) ==> #f
(#<subr char-alphabetic?> #\ ) ==> #f
(#<subr char-alphabetic?> #\;) ==> #f
(#<subr char-numeric?> #\a) ==> #f
(#<subr char-numeric?> #\A) ==> #f
(#<subr char-numeric?> #\z) ==> #f
(#<subr char-numeric?> #\Z) ==> #f
(#<subr char-numeric?> #\0) ==> #t
(#<subr char-numeric?> #\9) ==> #t
(#<subr char-numeric?> #\ ) ==> #f
(#<subr char-numeric?> #\;) ==> #f
(#<subr char-whitespace?> #\a) ==> #f
(#<subr char-whitespace?> #\A) ==> #f
(#<subr char-whitespace?> #\z) ==> #f
(#<subr char-whitespace?> #\Z) ==> #f
(#<subr char-whitespace?> #\0) ==> #f
(#<subr char-whitespace?> #\9) ==> #f
(#<subr char-whitespace?> #\ ) ==> #t
(#<subr char-whitespace?> #\;) ==> #f
(#<subr char-upper-case?> #\0) ==> #f
(#<subr char-upper-case?> #\9) ==> #f
(#<subr char-upper-case?> #\ ) ==> #f
(#<subr char-upper-case?> #\;) ==> #f
(#<subr char-lower-case?> #\0) ==> #f
(#<subr char-lower-case?> #\9) ==> #f
(#<subr char-lower-case?> #\ ) ==> #f
(#<subr char-lower-case?> #\;) ==> #f
(#<subr integer->char> 46) ==> #\.
(#<subr integer->char> 65) ==> #\A
(#<subr integer->char> 97) ==> #\a
(#<subr char-upcase> #\A) ==> #\A
(#<subr char-upcase> #\a) ==> #\A
(#<subr char-downcase> #\A) ==> #\a
(#<subr char-downcase> #\a) ==> #\a
SECTION(6 7)
(#<subr string?> "The word \"recursion\\\" has many meanings.") ==> #t
(string-set! "?**") ==> "?**"
(#<subr string> #\a #\b #\c) ==> "abc"
(#<subr string>) ==> ""
(#<subr string-length> "abc") ==> 3
(#<subr string-ref> "abc" 0) ==> #\a
(#<subr string-ref> "abc" 2) ==> #\c
(#<subr string-length> "") ==> 0
(#<subr substring> "ab" 0 0) ==> ""
(#<subr substring> "ab" 1 1) ==> ""
(#<subr substring> "ab" 2 2) ==> ""
(#<subr substring> "ab" 0 1) ==> "a"
(#<subr substring> "ab" 1 2) ==> "b"
(#<subr substring> "ab" 0 2) ==> "ab"
(#<subr string-append> "foo" "bar") ==> "foobar"
(#<subr string-append> "foo") ==> "foo"
(#<subr string-append> "foo" "") ==> "foo"
(#<subr string-append> "" "foo") ==> "foo"
(#<subr string-append>) ==> ""
(#<subr make-string> 0) ==> ""
(#<subr string=?> "" "") ==> #t
(#<subr string<?> "" "") ==> #f
(#<subr string>?> "" "") ==> #f
(#<subr string<=?> "" "") ==> #t
(#<subr string>=?> "" "") ==> #t
(#<subr string-ci=?> "" "") ==> #t
(#<subr string-ci<?> "" "") ==> #f
(#<subr string-ci>?> "" "") ==> #f
(#<subr string-ci<=?> "" "") ==> #t
(#<subr string-ci>=?> "" "") ==> #t
(#<subr string=?> "A" "B") ==> #f
(#<subr string=?> "a" "b") ==> #f
(#<subr string=?> "9" "0") ==> #f
(#<subr string=?> "A" "A") ==> #t
(#<subr string<?> "A" "B") ==> #t
(#<subr string<?> "a" "b") ==> #t
(#<subr string<?> "9" "0") ==> #f
(#<subr string<?> "A" "A") ==> #f
(#<subr string>?> "A" "B") ==> #f
(#<subr string>?> "a" "b") ==> #f
(#<subr string>?> "9" "0") ==> #t
(#<subr string>?> "A" "A") ==> #f
(#<subr string<=?> "A" "B") ==> #t
(#<subr string<=?> "a" "b") ==> #t
(#<subr string<=?> "9" "0") ==> #f
(#<subr string<=?> "A" "A") ==> #t
(#<subr string>=?> "A" "B") ==> #f
(#<subr string>=?> "a" "b") ==> #f
(#<subr string>=?> "9" "0") ==> #t
(#<subr string>=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "B") ==> #f
(#<subr string-ci=?> "a" "B") ==> #f
(#<subr string-ci=?> "A" "b") ==> #f
(#<subr string-ci=?> "a" "b") ==> #f
(#<subr string-ci=?> "9" "0") ==> #f
(#<subr string-ci=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "a") ==> #t
(#<subr string-ci<?> "A" "B") ==> #t
(#<subr string-ci<?> "a" "B") ==> #t
(#<subr string-ci<?> "A" "b") ==> #t
(#<subr string-ci<?> "a" "b") ==> #t
(#<subr string-ci<?> "9" "0") ==> #f
(#<subr string-ci<?> "A" "A") ==> #f
(#<subr string-ci<?> "A" "a") ==> #f
(#<subr string-ci>?> "A" "B") ==> #f
(#<subr string-ci>?> "a" "B") ==> #f
(#<subr string-ci>?> "A" "b") ==> #f
(#<subr string-ci>?> "a" "b") ==> #f
(#<subr string-ci>?> "9" "0") ==> #t
(#<subr string-ci>?> "A" "A") ==> #f
(#<subr string-ci>?> "A" "a") ==> #f
(#<subr string-ci<=?> "A" "B") ==> #t
(#<subr string-ci<=?> "a" "B") ==> #t
(#<subr string-ci<=?> "A" "b") ==> #t
(#<subr string-ci<=?> "a" "b") ==> #t
(#<subr string-ci<=?> "9" "0") ==> #f
(#<subr string-ci<=?> "A" "A") ==> #t
(#<subr string-ci<=?> "A" "a") ==> #t
(#<subr string-ci>=?> "A" "B") ==> #f
(#<subr string-ci>=?> "a" "B") ==> #f
(#<subr string-ci>=?> "A" "b") ==> #f
(#<subr string-ci>=?> "a" "b") ==> #f
(#<subr string-ci>=?> "9" "0") ==> #t
(#<subr string-ci>=?> "A" "A") ==> #t
(#<subr string-ci>=?> "A" "a") ==> #t
SECTION(6 8)
(#<subr vector?> #(0 (2 2 2 2) "Anna")) ==> #t
(#<subr vector> a b c) ==> #(a b c)
(#<subr vector>) ==> #()
(#<subr vector-length> #(0 (2 2 2 2) "Anna")) ==> 3
(#<subr vector-length> #()) ==> 0
(#<subr vector-ref> #(1 1 2 3 5 8 13 21) 5) ==> 8
(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
(#<subr make-vector> 2 hi) ==> #(hi hi)
(#<subr make-vector> 0) ==> #()
(#<subr make-vector> 0 a) ==> #()
SECTION(6 9)
(#<subr procedure?> #<subr car>) ==> #t
(#<subr procedure?> #<lambda (x) ...>) ==> #t
(#<subr procedure?> (lambda (x) (* x x))) ==> #f
(#<builtin call-with-current-continuation> #<subr procedure?>) ==> #t
(#<builtin apply> #<subr +> (3 4)) ==> 7
(#<builtin apply> #<lambda (a b) ...> (3 4)) ==> 7
(#<builtin apply> #<subr +> 10 (3 4)) ==> 17
(#<builtin apply> #<subr list> ()) ==> ()
(#<lambda args ...> 12 75) ==> 30
(#<builtin map> #<subr cadr> ((a b) (d e) (g h))) ==> (b e h)
(#<builtin map> #<subr +> (1 2 3) (4 5 6)) ==> (5 7 9)
(#<builtin map> #<subr +> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr *> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr -> (1 2 3)) ==> (-1 -2 -3)
(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16)
(#<builtin call-with-current-continuation> #<lambda (exit) ...>) ==> -3
(#<lambda (obj) ...> (1 2 3 4)) ==> 4
(#<lambda (obj) ...> (a b . c)) ==> #f
(#<builtin map> #<subr cadr> ()) ==> ()
SECTION(6 10 1)
(#<subr input-port?> #<input-port>) ==> #t
(#<subr output-port?> #<output-port>) ==> #t
(#<builtin call-with-input-file> "r4rstest.scm" #<subr input-port?>) ==> #t
(#<subr input-port?> #<input-port>) ==> #t
SECTION(6 10 2)
(#<subr peek-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (define cur-section (quote ()))
(#<subr peek-char> #<input-port>) ==> #\(
(#<subr read> #<input-port>) ==> (define errs (quote ()))
SECTION(6 10 3)
(#<builtin call-with-output-file> "tmp1" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr output-port?> #<output-port>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
Passed all tests
;testing inexact numbers;
SECTION(6 5 5)
(#<subr inexact?> 3.9) ==> #t
(inexact? #t) ==> #t
(max 4.) ==> 4.
(exact->inexact 4.) ==> 4.
(#<subr round> -4.5) ==> -4.
(#<subr round> -3.5) ==> -4.
(#<subr round> -3.9) ==> -4.
(#<subr round> 0.) ==> 0.
(#<subr round> 0.25) ==> 0.
(#<subr round> 0.8) ==> 1.
(#<subr round> 3.5) ==> 4.
(#<subr round> 4.5) ==> 4.
(#<subr expt> 0 0) ==> 1
(#<subr expt> 0 1) ==> 0
(#<builtin call-with-output-file> "tmp3" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (0.25 -3.25)
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(pentium-fdiv-bug #t) ==> #t
Passed all tests
SECTION(6 5 6)
Number readback failure for (+ 0. (* -100 4.94065645841247e-324))
-4.94065645841247e-322
(float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 1. (* -100 1.11022302462516e-16))
0.999999999999989
Number readback failure for (+ 10. (* -100 1.77635683940025e-15))
9.99999999999982
Number readback failure for (+ 100. (* -100 1.4210854715202e-14))
99.9999999999986
Number readback failure for (+ 1e+20 (* -100 16384.))
9.99999999999984e+19
Number readback failure for (+ 1e+50 (* -100 2.07691874341393e+34))
9.99999999999979e+49
Number readback failure for (+ 1e+100 (* -100 1.94266889222573e+84))
9.9999999999998e+99
Number readback failure for (+ 0.1 (* -100 1.38777878078145e-17))
0.0999999999999986
Number readback failure for (+ 0.01 (* -100 1.73472347597681e-18))
0.00999999999999983
Number readback failure for (+ 0.001 (* -100 2.16840434497101e-19))
0.000999999999999979
Number readback failure for (+ 1e-20 (* -100 1.50463276905253e-36))
9.99999999999985e-21
Number readback failure for (+ 1e-50 (* -100 1.18694596821998e-66))
9.99999999999989e-51
Number readback failure for (+ 1e-100 (* -100 1.26897091865783e-116))
9.99999999999989e-101
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3. (* -100 4.44089209850063e-16))
2.99999999999996
Number readback failure for (+ 30. (* -100 3.5527136788005e-15))
29.9999999999996
Number readback failure for (+ 300. (* -100 5.6843418860808e-14))
299.999999999994
Number readback failure for (+ 3e+20 (* -100 65536.))
2.99999999999994e+20
Number readback failure for (+ 3e+50 (* -100 4.15383748682786e+34))
2.99999999999996e+50
Number readback failure for (+ 3e+100 (* -100 3.88533778445146e+84))
2.99999999999996e+100
Number readback failure for (+ 0.3 (* -100 5.55111512312578e-17))
0.299999999999994
Number readback failure for (+ 0.03 (* -100 3.46944695195361e-18))
0.0299999999999996
Number readback failure for (+ 0.003 (* -100 4.33680868994202e-19))
0.00299999999999996
Number readback failure for (+ 3e-20 (* -100 6.01853107621011e-36))
2.99999999999994e-20
Number readback failure for (+ 3e-50 (* -100 4.7477838728799e-66))
2.99999999999995e-50
Number readback failure for (+ 3e-100 (* -100 5.0758836746313e-116))
2.99999999999995e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 7. (* -100 8.88178419700125e-16))
6.99999999999991
Number readback failure for (+ 70. (* -100 1.4210854715202e-14))
69.9999999999986
Number readback failure for (+ 700. (* -100 1.13686837721616e-13))
699.999999999989
Number readback failure for (+ 7e+20 (* -100 131072.))
6.99999999999987e+20
Number readback failure for (+ 7e+50 (* -100 8.30767497365573e+34))
6.99999999999992e+50
Number readback failure for (+ 7e+100 (* -100 1.55413511378058e+85))
6.99999999999985e+100
Number readback failure for (+ 0.7 (* -99 1.11022302462516e-16))
0.699999999999989
Number readback failure for (+ 0.07 (* -100 1.38777878078145e-17))
0.0699999999999986
Number readback failure for (+ 0.007 (* -100 8.67361737988404e-19))
0.00699999999999991
Number readback failure for (+ 7e-20 (* -100 1.20370621524202e-35))
6.99999999999988e-20
Number readback failure for (+ 7e-50 (* -100 9.4955677457598e-66))
6.99999999999991e-50
Number readback failure for (+ 7.00000000000001e-100 (* -100 1.01517673492626e-115))
6.9999999999999e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3.14159265358979 (* -100 4.44089209850063e-16))
3.14159265358975
Number readback failure for (+ 31.4159265358979 (* -100 3.5527136788005e-15))
31.4159265358976
Number readback failure for (+ 314.159265358979 (* -100 5.6843418860808e-14))
314.159265358974
Number readback failure for (+ 3.14159265358979e+20 (* -100 65536.))
3.14159265358973e+20
Number readback failure for (+ 3.14159265358979e+50 (* -100 4.15383748682786e+34))
3.14159265358975e+50
Number readback failure for (+ 3.14159265358979e+100 (* -100 3.88533778445146e+84))
3.14159265358976e+100
Number readback failure for (+ 0.314159265358979 (* -100 5.55111512312578e-17))
0.314159265358974
Number readback failure for (+ 0.0314159265358979 (* -100 6.93889390390723e-18))
0.0314159265358972
Number readback failure for (+ 0.00314159265358979 (* -100 4.33680868994202e-19))
0.00314159265358975
Number readback failure for (+ 3.14159265358979e-20 (* -100 6.01853107621011e-36))
3.14159265358973e-20
Number readback failure for (+ 3.14159265358979e-50 (* -100 4.7477838728799e-66))
3.14159265358975e-50
Number readback failure for (+ 3.14159265358979e-100 (* -100 5.0758836746313e-116))
3.14159265358975e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 2.71828182845904 (* -100 4.44089209850063e-16))
2.718281828459
Number readback failure for (+ 27.1828182845904 (* -100 3.5527136788005e-15))
27.1828182845901
Number readback failure for (+ 271.828182845904 (* -100 5.6843418860808e-14))
271.828182845899
Number readback failure for (+ 2.71828182845904e+20 (* -100 32768.))
2.71828182845901e+20
Number readback failure for (+ 2.71828182845905e+50 (* -100 4.15383748682786e+34))
2.718281828459e+50
Number readback failure for (+ 2.71828182845905e+100 (* -100 3.88533778445146e+84))
2.71828182845901e+100
Number readback failure for (+ 0.271828182845904 (* -100 5.55111512312578e-17))
0.271828182845899
Number readback failure for (+ 0.0271828182845904 (* -99 3.46944695195361e-18))
0.0271828182845901
Number readback failure for (+ 0.00271828182845904 (* -100 4.33680868994202e-19))
0.002718281828459
Number readback failure for (+ 2.71828182845904e-20 (* -100 6.01853107621011e-36))
2.71828182845898e-20
Number readback failure for (+ 2.71828182845905e-50 (* -100 4.7477838728799e-66))
2.718281828459e-50
Number readback failure for (+ 2.71828182845905e-100 (* -100 5.0758836746313e-116))
2.718281828459e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
To fully test continuations do:
(test-cont)
;testing scheme 4 functions;
SECTION(6 7)
(#<subr string->list> "P l") ==> (#\P #\ #\l)
(#<subr string->list> "") ==> ()
(#<subr list->string> (#\1 #\\ #\")) ==> "1\\\""
(#<subr list->string> ()) ==> ""
SECTION(6 8)
(#<subr vector->list> #(dah dah didah)) ==> (dah dah didah)
(#<subr vector->list> #()) ==> ()
(#<subr list->vector> (dididit dah)) ==> #(dididit dah)
(#<subr list->vector> ()) ==> #()
SECTION(6 10 4)
(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))
;testing DELAY and FORCE;
SECTION(6 9)
(delay 3) ==> 3
(delay (3 3)) ==> (3 3)
(delay 2) ==> 2
(#<builtin force> #<promise #<lambda () ...>>) ==> 6
(#<builtin force> #<promise 6>) ==> 6
(force 3) ==> 3
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))
;testing continuations;
SECTION(6 9)
(#<lambda (x y) ...> (a (b (c))) ((a) b c)) ==> #t
(#<lambda (x y) ...> (a (b (c))) ((a) b c d)) ==> #f
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))

1
vx-scheme/testcases/vx-good/scheme.good Executable file
View File

@ -0,0 +1 @@
("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two")

54
vx-scheme/testcases/vx-good/series.good Executable file
View File

@ -0,0 +1,54 @@
1.
1.5
1.41666666666667
1.41421568627451
1.41421356237469
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1.41421356237309
1
3
6
10
15
21
28
36
45
55
4.
2.66666666666667
3.46666666666667
2.8952380952381
3.33968253968254
2.97604617604618
3.28373848373848
3.01707181707182
3.25236593471888
3.0418396189294
3.16666666666667
3.13333333333333
3.1452380952381
3.13968253968254
3.14271284271284
3.14088134088134
3.14207181707182
3.14125482360777
3.1418396189294
3.1414067184965
4.
3.16666666666667
3.14210526315789
3.141599357319
3.14159271403378
3.14159265397529
3.14159265359118
3.14159265358978
3.1415926535898
3.14159265358979

1
vx-scheme/testcases/vx-good/sieve.good Executable file
View File

@ -0,0 +1 @@
1993

65
vx-scheme/testcases/vx-test.scm Normal file
View File

@ -0,0 +1,65 @@
(define gf-prefix
(cond
((eq? (scheme-implementation-type) 'scm) "good/")
((eq? (scheme-implementation-platform) 'VxWorks) "vx-good")
((and (eq? (scheme-implementation-type) 'vx-scheme)
(eq? (vx-scheme-implementation-type) 'vm)) "c-good/")
((eq? (scheme-implementation-platform) 'win32) "w32-good/")
(else "good/")))
;; some of our testcases use notation like 'bitwise-and' for 'logand';
;; we supply the needed bindings
(define bitwise-and logand)
(define bitwise-not lognot)
(define (file=? f1 f2) ; compare two open files for
(let loop ((c1 (read-char f1)) ; bytewise equality.
(c2 (read-char f2)))
(cond ((eof-object? c1) ; if both files EOF at the
(eof-object? c2)) ; same time, we win, else
((eof-object? c2) ; the streams aren't equal.
#f)
(else
(if (eqv? c1 c2) ; two equal chars? keep going
(loop (read-char f1)
(read-char f2))
#f))))) ; unequal characters: lose.
(define testcases '("r4rstest" "pi" "scheme" "dynamic" "earley" "maze"
"dderiv" "boyer" "puzzle" "ack" "sieve" "cf" "series"))
(define (run-testcase t) ; run one testcase
(gc) ; give each test a clean start
(let* ((infile (string-append t ".scm"))
(outfile (string-append t ".out"))
(goodfile (string-append gf-prefix t ".good"))
(result
(time (lambda ()
(with-output-to-file outfile
(lambda () (load infile))))))
(ok (file=? (open-input-file outfile) ; compare it with good output
(open-input-file goodfile))))
(cons ok (car result)))) ; return (pass? . elapsed time)
(let ((total-time 0.0))
(for-each ; run all testcases
(lambda (testcase)
(let ((result (run-testcase testcase)))
(if (car result)
(begin
(display "PASS: ")
(display (cdr result))
(display " ")
(set! total-time (+ total-time (cdr result))))
(else
(display "FAIL: ")))
(display testcase)
(newline)))
testcases)
(display "total time: ")
(display total-time)
(newline))

3
vx-scheme/testcases/w32-good/ack.good Executable file
View File

@ -0,0 +1,3 @@
253
509
1021

1
vx-scheme/testcases/w32-good/boyer.good Normal file
View File

@ -0,0 +1 @@
#t

65
vx-scheme/testcases/w32-good/cf.good Normal file
View File

@ -0,0 +1,65 @@
1
1
1
1
1
(1 1 1.)
(2 1 2.)
(3 2 1.5)
(5 3 1.66666666666667)
(8 5 1.6)
(13 8 1.625)
(21 13 1.61538461538462)
(34 21 1.61904761904762)
(55 34 1.61764705882353)
(89 55 1.61818181818182)
(144 89 1.61797752808989)
(233 144 1.61805555555556)
(377 233 1.61802575107296)
(610 377 1.61803713527851)
(987 610 1.61803278688525)
(1597 987 1.61803444782168)
(2584 1597 1.61803381340013)
(4181 2584 1.61803405572755)
(6765 4181 1.61803396316671)
(10946 6765 1.6180339985218)
(17711 10946 1.61803398501736)
(28657 17711 1.6180339901756)
(46368 28657 1.61803398820533)
(75025 46368 1.6180339889579)
(121393 75025 1.61803398867044)
(196418 121393 1.61803398878024)
(317811 196418 1.6180339887383)
(514229 317811 1.61803398875432)
(832040 514229 1.6180339887482)
(1346269 832040 1.61803398875054)
(2178309 1346269 1.61803398874965)
(3524578 2178309 1.61803398874999)
(5702887 3524578 1.61803398874986)
(9227465 5702887 1.61803398874991)
(14930352 9227465 1.61803398874989)
(24157817 14930352 1.6180339887499)
(39088169 24157817 1.61803398874989)
(63245986 39088169 1.6180339887499)
(102334155 63245986 1.61803398874989)
(165580141 102334155 1.61803398874989)
1.61803398874989(2 1 2.)
(5 2 2.5)
(12 5 2.4)
(29 12 2.41666666666667)
(70 29 2.41379310344828)
(169 70 2.41428571428571)
(408 169 2.41420118343195)
(985 408 2.41421568627451)
(2378 985 2.41421319796954)
(5741 2378 2.41421362489487)
(1 1 1.)
(3 2 1.5)
(4 3 1.33333333333333)
(11 8 1.375)
(15 11 1.36363636363636)
(41 30 1.36666666666667)
(56 41 1.36585365853659)
(153 112 1.36607142857143)
(209 153 1.36601307189542)
(571 418 1.36602870813397)

1
vx-scheme/testcases/w32-good/dderiv.good Normal file
View File

@ -0,0 +1 @@
(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) (* (* b x) (+ (/ 0 b) (/ 1 x))) 0)

1
vx-scheme/testcases/w32-good/dynamic.good Normal file
View File

@ -0,0 +1 @@
((218 . 437) (6 . 1892) (2204 . 441))

1
vx-scheme/testcases/w32-good/earley.good Normal file
View File

@ -0,0 +1 @@
1430

42
vx-scheme/testcases/w32-good/maze.good Normal file
View File

@ -0,0 +1,42 @@
_ _ _
_/ \_/ \_/.\
/ \ \_ . /.\
\ \ /. _/.\ /
/ \_/. _/ \_ .\
\ / \ / _/ \_/
/ _/.\ / \ / \
\ / \ / _/ /
/ \ /.\ /.\_/ \
\_/ \ /. _ .\ /
/ \_ . _/ \ \
\_ \_/ _/.\ /
/ _/ / \ / \
\_ \ / \_ .\_/
/ \_ \_ \_ .\
\_ \_/ _/.\ /
/ \_ \ /.\ .\
\ /.\_ . /.\ /
/ . _/.\ / \
\ /.\_/.\_ .\ /
/ \_ . / _/ \
\_ \_/.\_ \_/
/ _/ \ / \_ \
\_/ _/.\_ \_/
/ \ / _ . _ \
\ / \_/. _ \_/
/ _ \ \_/ \
\_/.\_ .\_/ _/
/ \ . _/ / \
\ /.\_/ \_/.\ /
/ \_ . _/. \
\ . /.\_/
/ \_/ \_/ \_ .\
\_/ / \_/. /
/ / _ \ / \
\_/ \_/ \_/.\_/
/ \_/ _/ \_ .\
\ _/. /. _/
/ \ /. / \_ .\
\_/. _/.\_/.\ /
/ _ .\_ . _ .\
\_/ \ / \_/ \_/

7
vx-scheme/testcases/w32-good/pi.good Executable file
View File

@ -0,0 +1,7 @@
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
08128 48111 74502 84102 70193 85211 05559 64462 29489 54930
38196 44288 10975 66593 34461 28475 64823 37867 83165 27120
19091 45648 56692 34603 48610 45432 66482 13393 60726 02491
41273

19
vx-scheme/testcases/w32-good/puzzle.good Normal file
View File

@ -0,0 +1,19 @@
Piece 1 at 1.
Piece 8 at 354.
Piece 7 at 330.
Piece 3 at 291.
Piece 13 at 278.
Piece 12 at 276.
Piece 5 at 275.
Piece 1 at 267.
Piece 1 at 219.
Piece 3 at 203.
Piece 1 at 202.
Piece 1 at 154.
Piece 9 at 138.
Piece 2 at 110.
Piece 2 at 108.
Piece 1 at 106.
Piece 3 at 90.
Success in 2005 trials.

778
vx-scheme/testcases/w32-good/r4rstest.good Normal file
View File

@ -0,0 +1,778 @@
SECTION(2 1)
SECTION(3 4)
#<subr boolean?>
#<subr char?>
#<subr null?>
#<subr number?>
#<subr pair?>
#<subr procedure?>
#<subr string?>
#<subr symbol?>
#<subr vector?>
(#t #f #f #f #f #f #f #f #f)#t
(#t #f #f #f #f #f #f #f #f)#f
(#f #t #f #f #f #f #f #f #f)#\a
(#f #f #t #f #f #f #f #f #f)()
(#f #f #f #t #f #f #f #f #f)9739
(#f #f #f #f #t #f #f #f #f)(test)
(#f #f #f #f #f #t #f #f #f)#<lambda (e) ...>
(#f #f #f #f #f #f #t #f #f)"test"
(#f #f #f #f #f #f #t #f #f)""
(#f #f #f #f #f #f #f #t #f)test
(#f #f #f #f #f #f #f #f #t)#()
(#f #f #f #f #f #f #f #f #t)#(a b c)
SECTION(4 1 2)
(quote (quote a)) ==> (quote a)
(quote (quote a)) ==> (quote a)
SECTION(4 1 3)
(#<subr *> 3 4) ==> 12
SECTION(4 1 4)
(#<lambda (x) ...> 4) ==> 8
(#<lambda (x y) ...> 7 10) ==> 3
(#<lambda (y) ...> 6) ==> 10
(#<lambda x ...> 3 4 5 6) ==> (3 4 5 6)
(#<lambda (x y . z) ...> 3 4 5 6) ==> (5 6)
SECTION(4 1 5)
(if yes) ==> yes
(if no) ==> no
(if 1) ==> 1
SECTION(4 1 6)
(define 3) ==> 3
(set! 5) ==> 5
SECTION(4 2 1)
(cond greater) ==> greater
(cond equal) ==> equal
(cond 2) ==> 2
(case composite) ==> composite
(case consonant) ==> consonant
(and #t) ==> #t
(and #f) ==> #f
(and (f g)) ==> (f g)
(and #t) ==> #t
(or #t) ==> #t
(or #t) ==> #t
(or #f) ==> #f
(or #f) ==> #f
(or (b c)) ==> (b c)
SECTION(4 2 2)
(let 6) ==> 6
(let 35) ==> 35
(let* 70) ==> 70
(letrec #t) ==> #t
(let 5) ==> 5
(let 34) ==> 34
(let 6) ==> 6
(let 34) ==> 34
(let* 7) ==> 7
(let* 34) ==> 34
(let* 8) ==> 8
(let* 34) ==> 34
(letrec 9) ==> 9
(letrec 34) ==> 34
(letrec 10) ==> 10
(letrec 34) ==> 34
SECTION(4 2 3)
(begin 6) ==> 6
SECTION(4 2 4)
(do #(0 1 2 3 4)) ==> #(0 1 2 3 4)
(do 25) ==> 25
(let 1) ==> 1
(let ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
(let -1) ==> -1
SECTION(4 2 6)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (list a (quote a))) ==> (list a (quote a))
(quasiquote (a 3 4 5 6 b)) ==> (a 3 4 5 6 b)
(quasiquote ((foo 7) . cons)) ==> ((foo 7) . cons)
(quasiquote #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
(quasiquote 5) ==> 5
(quasiquote (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)) ==> (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)
(quasiquote (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)) ==> (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)
(quasiquote (list 3 4)) ==> (list 3 4)
(quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) ==> (quasiquote (list (unquote (+ 1 2)) 4))
SECTION(5 2 1)
(define 6) ==> 6
(define 1) ==> 1
(#<lambda (x) ...> 6) ==> 9
SECTION(5 2 2)
(define 45) ==> 45
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda () ...>) ==> 5
(define 34) ==> 34
(#<lambda (x) ...> 88) ==> 88
(#<lambda (x) ...> 4) ==> 4
(define 34) ==> 34
(internal-define 99) ==> 99
(internal-define 77) ==> 77
SECTION(6 1)
(#<subr not> #t) ==> #f
(#<subr not> 3) ==> #f
(#<subr not> (3)) ==> #f
(#<subr not> #f) ==> #t
(#<subr not> ()) ==> #f
(#<subr not> ()) ==> #f
(#<subr not> nil) ==> #f
SECTION(6 2)
(#<subr eqv?> a a) ==> #t
(#<subr eqv?> a b) ==> #f
(#<subr eqv?> 2 2) ==> #t
(#<subr eqv?> () ()) ==> #t
(#<subr eqv?> 10000 10000) ==> #t
(#<subr eqv?> (1 . 2) (1 . 2)) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #f nil) ==> #f
(#<subr eqv?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #t
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eqv?> #<lambda () ...> #<lambda () ...>) ==> #f
(#<subr eq?> a a) ==> #t
(#<subr eq?> (a) (a)) ==> #f
(#<subr eq?> () ()) ==> #t
(#<subr eq?> #<subr car> #<subr car>) ==> #t
(#<subr eq?> (a) (a)) ==> #t
(#<subr eq?> #() #()) ==> #t
(#<subr eq?> #<lambda (x) ...> #<lambda (x) ...>) ==> #t
(#<subr equal?> a a) ==> #t
(#<subr equal?> (a) (a)) ==> #t
(#<subr equal?> (a (b) c) (a (b) c)) ==> #t
(#<subr equal?> "abc" "abc") ==> #t
(#<subr equal?> 2 2) ==> #t
(#<subr equal?> #(a a a a a) #(a a a a a)) ==> #t
SECTION(6 3)
(dot (a b c d e)) ==> (a b c d e)
(#<subr list?> (a b c)) ==> #t
(set-cdr! (a . 4)) ==> (a . 4)
(#<subr eqv?> (a . 4) (a . 4)) ==> #t
(dot (a b c . d)) ==> (a b c . d)
(#<subr list?> (a . 4)) ==> #f
(list? #f) ==> #f
(#<subr cons> a ()) ==> (a)
(#<subr cons> (a) (b c d)) ==> ((a) b c d)
(#<subr cons> "a" (b c)) ==> ("a" b c)
(#<subr cons> a 3) ==> (a . 3)
(#<subr cons> (a b) c) ==> ((a b) . c)
(#<subr car> (a b c)) ==> a
(#<subr car> ((a) b c d)) ==> (a)
(#<subr car> (1 . 2)) ==> 1
(#<subr cdr> ((a) b c d)) ==> (b c d)
(#<subr cdr> (1 . 2)) ==> 2
(#<subr list> a 7 c) ==> (a 7 c)
(#<subr list>) ==> ()
(#<subr length> (a b c)) ==> 3
(#<subr length> (a (b) (c d e))) ==> 3
(#<subr length> ()) ==> 0
(#<subr append> (x) (y)) ==> (x y)
(#<subr append> (a) (b c d)) ==> (a b c d)
(#<subr append> (a (b)) ((c))) ==> (a (b) (c))
(#<subr append>) ==> ()
(#<subr append> (a b) (c . d)) ==> (a b c . d)
(#<subr append> () a) ==> a
(#<subr reverse> (a b c)) ==> (c b a)
(#<subr reverse> (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a)
(#<subr list-ref> (a b c d) 2) ==> c
(#<subr memq> a (a b c)) ==> (a b c)
(#<subr memq> b (a b c)) ==> (b c)
(#<subr memq> a (b c d)) ==> #f
(#<subr memq> (a) (b (a) c)) ==> #f
(#<subr member> (a) (b (a) c)) ==> ((a) c)
(#<subr memv> 101 (100 101 102)) ==> (101 102)
(#<subr assq> a ((a 1) (b 2) (c 3))) ==> (a 1)
(#<subr assq> b ((a 1) (b 2) (c 3))) ==> (b 2)
(#<subr assq> d ((a 1) (b 2) (c 3))) ==> #f
(#<subr assq> (a) (((a)) ((b)) ((c)))) ==> #f
(#<subr assoc> (a) (((a)) ((b)) ((c)))) ==> ((a))
(#<subr assv> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
SECTION(6 4)
(#<subr symbol?> a) ==> #t
(standard-case #t) ==> #t
(standard-case #t) ==> #t
(#<subr symbol->string> flying-fish) ==> "flying-fish"
(#<subr symbol->string> martin) ==> "martin"
(#<subr symbol->string> Malvina) ==> "Malvina"
(standard-case #t) ==> #t
(string-set! "cb") ==> "cb"
(#<subr symbol->string> ab) ==> "ab"
(#<subr string->symbol> "ab") ==> ab
(#<subr eq?> mississippi mississippi) ==> #t
(string->symbol #f) ==> #f
(#<subr string->symbol> "jollywog") ==> jollywog
SECTION(6 5 5)
(#<subr number?> 3) ==> #t
(#<subr complex?> 3) ==> #t
(#<subr real?> 3) ==> #t
(#<subr rational?> 3) ==> #t
(#<subr integer?> 3) ==> #t
(#<subr exact?> 3) ==> #t
(#<subr inexact?> 3) ==> #f
(#<subr => 22 22 22) ==> #t
(#<subr => 22 22) ==> #t
(#<subr => 34 34 35) ==> #f
(#<subr => 34 35) ==> #f
(#<subr >> 3 -6246) ==> #t
(#<subr >> 9 9 -2424) ==> #f
(#<subr >=> 3 -4 -6246) ==> #t
(#<subr >=> 9 9) ==> #t
(#<subr >=> 8 9) ==> #f
(#<subr <> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <> -1 2 3 4 4 5 6 7) ==> #f
(#<subr <=> -1 2 3 4 5 6 7 8) ==> #t
(#<subr <=> -1 2 3 4 4 5 6 7) ==> #t
(#<subr <> 1 3 2) ==> #f
(#<subr >=> 1 3 2) ==> #f
(#<subr zero?> 0) ==> #t
(#<subr zero?> 1) ==> #f
(#<subr zero?> -1) ==> #f
(#<subr zero?> -100) ==> #f
(#<subr positive?> 4) ==> #t
(#<subr positive?> -4) ==> #f
(#<subr positive?> 0) ==> #f
(#<subr negative?> 4) ==> #f
(#<subr negative?> -4) ==> #t
(#<subr negative?> 0) ==> #f
(#<subr odd?> 3) ==> #t
(#<subr odd?> 2) ==> #f
(#<subr odd?> -4) ==> #f
(#<subr odd?> -1) ==> #t
(#<subr even?> 3) ==> #f
(#<subr even?> 2) ==> #t
(#<subr even?> -4) ==> #t
(#<subr even?> -1) ==> #f
(#<subr max> 34 5 7 38 6) ==> 38
(#<subr min> 3 5 5 330 4 -24) ==> -24
(#<subr +> 3 4) ==> 7
(#<subr +> 3) ==> 3
(#<subr +>) ==> 0
(#<subr *> 4) ==> 4
(#<subr *>) ==> 1
(#<subr -> 3 4) ==> -1
(#<subr -> 3) ==> -3
(#<subr abs> -7) ==> 7
(#<subr abs> 7) ==> 7
(#<subr abs> 0) ==> 0
(#<subr quotient> 35 7) ==> 5
(#<subr quotient> -35 7) ==> -5
(#<subr quotient> 35 -7) ==> -5
(#<subr quotient> -35 -7) ==> 5
(#<subr modulo> 13 4) ==> 1
(#<subr remainder> 13 4) ==> 1
(#<subr modulo> -13 4) ==> 3
(#<subr remainder> -13 4) ==> -1
(#<subr modulo> 13 -4) ==> -3
(#<subr remainder> 13 -4) ==> 1
(#<subr modulo> -13 -4) ==> -1
(#<subr remainder> -13 -4) ==> -1
(#<subr modulo> 0 86400) ==> 0
(#<subr modulo> 0 -86400) ==> 0
(#<lambda (n1 n2) ...> 238 9) ==> #t
(#<lambda (n1 n2) ...> -238 9) ==> #t
(#<lambda (n1 n2) ...> 238 -9) ==> #t
(#<lambda (n1 n2) ...> -238 -9) ==> #t
(#<subr gcd> 0 4) ==> 4
(#<subr gcd> -4 0) ==> 4
(#<subr gcd> 32 -36) ==> 4
(#<subr gcd>) ==> 0
(#<subr lcm> 32 -36) ==> 288
(#<subr lcm>) ==> 1
SECTION(6 5 9)
(#<subr number->string> 0) ==> "0"
(#<subr number->string> 100) ==> "100"
(#<subr number->string> 256 16) ==> "100"
(#<subr string->number> "100") ==> 100
(#<subr string->number> "100" 16) ==> 256
(#<subr string->number> "") ==> #f
(#<subr string->number> ".") ==> #f
(#<subr string->number> "d") ==> #f
(#<subr string->number> "D") ==> #f
(#<subr string->number> "i") ==> #f
(#<subr string->number> "I") ==> #f
(#<subr string->number> "3i") ==> #f
(#<subr string->number> "3I") ==> #f
(#<subr string->number> "33i") ==> #f
(#<subr string->number> "33I") ==> #f
(#<subr string->number> "3.3i") ==> #f
(#<subr string->number> "3.3I") ==> #f
(#<subr string->number> "-") ==> #f
(#<subr string->number> "+") ==> #f
SECTION(6 6)
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr eqv?> #\ #\ ) ==> #t
(#<subr char?> #\a) ==> #t
(#<subr char?> #\() ==> #t
(#<subr char?> #\ ) ==> #t
(#<subr char?> #\
) ==> #t
(#<subr char=?> #\A #\B) ==> #f
(#<subr char=?> #\a #\b) ==> #f
(#<subr char=?> #\9 #\0) ==> #f
(#<subr char=?> #\A #\A) ==> #t
(#<subr char<?> #\A #\B) ==> #t
(#<subr char<?> #\a #\b) ==> #t
(#<subr char<?> #\9 #\0) ==> #f
(#<subr char<?> #\A #\A) ==> #f
(#<subr char>?> #\A #\B) ==> #f
(#<subr char>?> #\a #\b) ==> #f
(#<subr char>?> #\9 #\0) ==> #t
(#<subr char>?> #\A #\A) ==> #f
(#<subr char<=?> #\A #\B) ==> #t
(#<subr char<=?> #\a #\b) ==> #t
(#<subr char<=?> #\9 #\0) ==> #f
(#<subr char<=?> #\A #\A) ==> #t
(#<subr char>=?> #\A #\B) ==> #f
(#<subr char>=?> #\a #\b) ==> #f
(#<subr char>=?> #\9 #\0) ==> #t
(#<subr char>=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\B) ==> #f
(#<subr char-ci=?> #\a #\B) ==> #f
(#<subr char-ci=?> #\A #\b) ==> #f
(#<subr char-ci=?> #\a #\b) ==> #f
(#<subr char-ci=?> #\9 #\0) ==> #f
(#<subr char-ci=?> #\A #\A) ==> #t
(#<subr char-ci=?> #\A #\a) ==> #t
(#<subr char-ci<?> #\A #\B) ==> #t
(#<subr char-ci<?> #\a #\B) ==> #t
(#<subr char-ci<?> #\A #\b) ==> #t
(#<subr char-ci<?> #\a #\b) ==> #t
(#<subr char-ci<?> #\9 #\0) ==> #f
(#<subr char-ci<?> #\A #\A) ==> #f
(#<subr char-ci<?> #\A #\a) ==> #f
(#<subr char-ci>?> #\A #\B) ==> #f
(#<subr char-ci>?> #\a #\B) ==> #f
(#<subr char-ci>?> #\A #\b) ==> #f
(#<subr char-ci>?> #\a #\b) ==> #f
(#<subr char-ci>?> #\9 #\0) ==> #t
(#<subr char-ci>?> #\A #\A) ==> #f
(#<subr char-ci>?> #\A #\a) ==> #f
(#<subr char-ci<=?> #\A #\B) ==> #t
(#<subr char-ci<=?> #\a #\B) ==> #t
(#<subr char-ci<=?> #\A #\b) ==> #t
(#<subr char-ci<=?> #\a #\b) ==> #t
(#<subr char-ci<=?> #\9 #\0) ==> #f
(#<subr char-ci<=?> #\A #\A) ==> #t
(#<subr char-ci<=?> #\A #\a) ==> #t
(#<subr char-ci>=?> #\A #\B) ==> #f
(#<subr char-ci>=?> #\a #\B) ==> #f
(#<subr char-ci>=?> #\A #\b) ==> #f
(#<subr char-ci>=?> #\a #\b) ==> #f
(#<subr char-ci>=?> #\9 #\0) ==> #t
(#<subr char-ci>=?> #\A #\A) ==> #t
(#<subr char-ci>=?> #\A #\a) ==> #t
(#<subr char-alphabetic?> #\a) ==> #t
(#<subr char-alphabetic?> #\A) ==> #t
(#<subr char-alphabetic?> #\z) ==> #t
(#<subr char-alphabetic?> #\Z) ==> #t
(#<subr char-alphabetic?> #\0) ==> #f
(#<subr char-alphabetic?> #\9) ==> #f
(#<subr char-alphabetic?> #\ ) ==> #f
(#<subr char-alphabetic?> #\;) ==> #f
(#<subr char-numeric?> #\a) ==> #f
(#<subr char-numeric?> #\A) ==> #f
(#<subr char-numeric?> #\z) ==> #f
(#<subr char-numeric?> #\Z) ==> #f
(#<subr char-numeric?> #\0) ==> #t
(#<subr char-numeric?> #\9) ==> #t
(#<subr char-numeric?> #\ ) ==> #f
(#<subr char-numeric?> #\;) ==> #f
(#<subr char-whitespace?> #\a) ==> #f
(#<subr char-whitespace?> #\A) ==> #f
(#<subr char-whitespace?> #\z) ==> #f
(#<subr char-whitespace?> #\Z) ==> #f
(#<subr char-whitespace?> #\0) ==> #f
(#<subr char-whitespace?> #\9) ==> #f
(#<subr char-whitespace?> #\ ) ==> #t
(#<subr char-whitespace?> #\;) ==> #f
(#<subr char-upper-case?> #\0) ==> #f
(#<subr char-upper-case?> #\9) ==> #f
(#<subr char-upper-case?> #\ ) ==> #f
(#<subr char-upper-case?> #\;) ==> #f
(#<subr char-lower-case?> #\0) ==> #f
(#<subr char-lower-case?> #\9) ==> #f
(#<subr char-lower-case?> #\ ) ==> #f
(#<subr char-lower-case?> #\;) ==> #f
(#<subr integer->char> 46) ==> #\.
(#<subr integer->char> 65) ==> #\A
(#<subr integer->char> 97) ==> #\a
(#<subr char-upcase> #\A) ==> #\A
(#<subr char-upcase> #\a) ==> #\A
(#<subr char-downcase> #\A) ==> #\a
(#<subr char-downcase> #\a) ==> #\a
SECTION(6 7)
(#<subr string?> "The word \"recursion\\\" has many meanings.") ==> #t
(string-set! "?**") ==> "?**"
(#<subr string> #\a #\b #\c) ==> "abc"
(#<subr string>) ==> ""
(#<subr string-length> "abc") ==> 3
(#<subr string-ref> "abc" 0) ==> #\a
(#<subr string-ref> "abc" 2) ==> #\c
(#<subr string-length> "") ==> 0
(#<subr substring> "ab" 0 0) ==> ""
(#<subr substring> "ab" 1 1) ==> ""
(#<subr substring> "ab" 2 2) ==> ""
(#<subr substring> "ab" 0 1) ==> "a"
(#<subr substring> "ab" 1 2) ==> "b"
(#<subr substring> "ab" 0 2) ==> "ab"
(#<subr string-append> "foo" "bar") ==> "foobar"
(#<subr string-append> "foo") ==> "foo"
(#<subr string-append> "foo" "") ==> "foo"
(#<subr string-append> "" "foo") ==> "foo"
(#<subr string-append>) ==> ""
(#<subr make-string> 0) ==> ""
(#<subr string=?> "" "") ==> #t
(#<subr string<?> "" "") ==> #f
(#<subr string>?> "" "") ==> #f
(#<subr string<=?> "" "") ==> #t
(#<subr string>=?> "" "") ==> #t
(#<subr string-ci=?> "" "") ==> #t
(#<subr string-ci<?> "" "") ==> #f
(#<subr string-ci>?> "" "") ==> #f
(#<subr string-ci<=?> "" "") ==> #t
(#<subr string-ci>=?> "" "") ==> #t
(#<subr string=?> "A" "B") ==> #f
(#<subr string=?> "a" "b") ==> #f
(#<subr string=?> "9" "0") ==> #f
(#<subr string=?> "A" "A") ==> #t
(#<subr string<?> "A" "B") ==> #t
(#<subr string<?> "a" "b") ==> #t
(#<subr string<?> "9" "0") ==> #f
(#<subr string<?> "A" "A") ==> #f
(#<subr string>?> "A" "B") ==> #f
(#<subr string>?> "a" "b") ==> #f
(#<subr string>?> "9" "0") ==> #t
(#<subr string>?> "A" "A") ==> #f
(#<subr string<=?> "A" "B") ==> #t
(#<subr string<=?> "a" "b") ==> #t
(#<subr string<=?> "9" "0") ==> #f
(#<subr string<=?> "A" "A") ==> #t
(#<subr string>=?> "A" "B") ==> #f
(#<subr string>=?> "a" "b") ==> #f
(#<subr string>=?> "9" "0") ==> #t
(#<subr string>=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "B") ==> #f
(#<subr string-ci=?> "a" "B") ==> #f
(#<subr string-ci=?> "A" "b") ==> #f
(#<subr string-ci=?> "a" "b") ==> #f
(#<subr string-ci=?> "9" "0") ==> #f
(#<subr string-ci=?> "A" "A") ==> #t
(#<subr string-ci=?> "A" "a") ==> #t
(#<subr string-ci<?> "A" "B") ==> #t
(#<subr string-ci<?> "a" "B") ==> #t
(#<subr string-ci<?> "A" "b") ==> #t
(#<subr string-ci<?> "a" "b") ==> #t
(#<subr string-ci<?> "9" "0") ==> #f
(#<subr string-ci<?> "A" "A") ==> #f
(#<subr string-ci<?> "A" "a") ==> #f
(#<subr string-ci>?> "A" "B") ==> #f
(#<subr string-ci>?> "a" "B") ==> #f
(#<subr string-ci>?> "A" "b") ==> #f
(#<subr string-ci>?> "a" "b") ==> #f
(#<subr string-ci>?> "9" "0") ==> #t
(#<subr string-ci>?> "A" "A") ==> #f
(#<subr string-ci>?> "A" "a") ==> #f
(#<subr string-ci<=?> "A" "B") ==> #t
(#<subr string-ci<=?> "a" "B") ==> #t
(#<subr string-ci<=?> "A" "b") ==> #t
(#<subr string-ci<=?> "a" "b") ==> #t
(#<subr string-ci<=?> "9" "0") ==> #f
(#<subr string-ci<=?> "A" "A") ==> #t
(#<subr string-ci<=?> "A" "a") ==> #t
(#<subr string-ci>=?> "A" "B") ==> #f
(#<subr string-ci>=?> "a" "B") ==> #f
(#<subr string-ci>=?> "A" "b") ==> #f
(#<subr string-ci>=?> "a" "b") ==> #f
(#<subr string-ci>=?> "9" "0") ==> #t
(#<subr string-ci>=?> "A" "A") ==> #t
(#<subr string-ci>=?> "A" "a") ==> #t
SECTION(6 8)
(#<subr vector?> #(0 (2 2 2 2) "Anna")) ==> #t
(#<subr vector> a b c) ==> #(a b c)
(#<subr vector>) ==> #()
(#<subr vector-length> #(0 (2 2 2 2) "Anna")) ==> 3
(#<subr vector-length> #()) ==> 0
(#<subr vector-ref> #(1 1 2 3 5 8 13 21) 5) ==> 8
(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
(#<subr make-vector> 2 hi) ==> #(hi hi)
(#<subr make-vector> 0) ==> #()
(#<subr make-vector> 0 a) ==> #()
SECTION(6 9)
(#<subr procedure?> #<subr car>) ==> #t
(#<subr procedure?> #<lambda (x) ...>) ==> #t
(#<subr procedure?> (lambda (x) (* x x))) ==> #f
(#<builtin call-with-current-continuation> #<subr procedure?>) ==> #t
(#<builtin apply> #<subr +> (3 4)) ==> 7
(#<builtin apply> #<lambda (a b) ...> (3 4)) ==> 7
(#<builtin apply> #<subr +> 10 (3 4)) ==> 17
(#<builtin apply> #<subr list> ()) ==> ()
(#<lambda args ...> 12 75) ==> 30
(#<builtin map> #<subr cadr> ((a b) (d e) (g h))) ==> (b e h)
(#<builtin map> #<subr +> (1 2 3) (4 5 6)) ==> (5 7 9)
(#<builtin map> #<subr +> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr *> (1 2 3)) ==> (1 2 3)
(#<builtin map> #<subr -> (1 2 3)) ==> (-1 -2 -3)
(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16)
(#<builtin call-with-current-continuation> #<lambda (exit) ...>) ==> -3
(#<lambda (obj) ...> (1 2 3 4)) ==> 4
(#<lambda (obj) ...> (a b . c)) ==> #f
(#<builtin map> #<subr cadr> ()) ==> ()
SECTION(6 10 1)
(#<subr input-port?> #<input-port>) ==> #t
(#<subr output-port?> #<output-port>) ==> #t
(#<builtin call-with-input-file> "r4rstest.scm" #<subr input-port?>) ==> #t
(#<subr input-port?> #<input-port>) ==> #t
SECTION(6 10 2)
(#<subr peek-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (define cur-section (quote ()))
(#<subr peek-char> #<input-port>) ==> #\(
(#<subr read> #<input-port>) ==> (define errs (quote ()))
SECTION(6 10 3)
(#<builtin call-with-output-file> "tmp1" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr output-port?> #<output-port>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
(#<subr read> #<input-port>) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
Passed all tests
;testing inexact numbers;
SECTION(6 5 5)
(#<subr inexact?> 3.9) ==> #t
(inexact? #t) ==> #t
(max 4.) ==> 4.
(exact->inexact 4.) ==> 4.
(#<subr round> -4.5) ==> -4.
(#<subr round> -3.5) ==> -4.
(#<subr round> -3.9) ==> -4.
(#<subr round> 0.) ==> 0.
(#<subr round> 0.25) ==> 0.
(#<subr round> 0.8) ==> 1.
(#<subr round> 3.5) ==> 4.
(#<subr round> 4.5) ==> 4.
(#<subr expt> 0 0) ==> 1
(#<subr expt> 0 1) ==> 0
(#<builtin call-with-output-file> "tmp3" #<lambda (test-file) ...>) ==> #t
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(#<subr eof-object?> #<eof-object>) ==> #t
(#<subr eof-object?> #<eof-object>) ==> #t
(input-port? #t) ==> #t
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read-char> #<input-port>) ==> #\;
(#<subr read> #<input-port>) ==> (0.25 -3.25)
(#<subr read> #<input-port>) ==> (define foo (quote (0.25 -3.25)))
(pentium-fdiv-bug #t) ==> #t
Passed all tests
SECTION(6 5 6)
Number readback failure for (+ 0. (* -100 4.94065645841247e-324))
-4.94065645841247e-322
(float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 1. (* -100 1.11022302462516e-016))
0.999999999999989
Number readback failure for (+ 10. (* -100 1.77635683940025e-015))
9.99999999999982
Number readback failure for (+ 100. (* -100 1.4210854715202e-014))
99.9999999999986
Number readback failure for (+ 1e+020 (* -100 16384.))
9.99999999999984e+019
Number readback failure for (+ 1e+050 (* -100 2.07691874341393e+034))
9.99999999999979e+049
Number readback failure for (+ 1e+100 (* -100 1.94266889222573e+084))
9.99999999999981e+099
Number readback failure for (+ 0.1 (* -100 1.38777878078145e-017))
0.0999999999999986
Number readback failure for (+ 0.01 (* -100 1.73472347597681e-018))
0.00999999999999983
Number readback failure for (+ 0.001 (* -100 2.16840434497101e-019))
0.000999999999999978
Number readback failure for (+ 1e-020 (* -100 1.50463276905253e-036))
9.99999999999985e-021
Number readback failure for (+ 1e-050 (* -100 1.18694596821997e-066))
9.99999999999988e-051
Number readback failure for (+ 1e-100 (* -100 1.26897091865782e-116))
9.99999999999987e-101
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3. (* -100 4.44089209850063e-016))
2.99999999999996
Number readback failure for (+ 30. (* -100 3.5527136788005e-015))
29.9999999999996
Number readback failure for (+ 300. (* -100 5.6843418860808e-014))
299.999999999994
Number readback failure for (+ 3e+020 (* -100 65536.))
2.99999999999993e+020
Number readback failure for (+ 3e+050 (* -100 4.15383748682786e+034))
2.99999999999996e+050
Number readback failure for (+ 3e+100 (* -100 3.88533778445146e+084))
2.99999999999996e+100
Number readback failure for (+ 0.3 (* -100 5.55111512312578e-017))
0.299999999999994
Number readback failure for (+ 0.03 (* -100 3.46944695195361e-018))
0.0299999999999997
Number readback failure for (+ 0.003 (* -100 4.33680868994202e-019))
0.00299999999999996
Number readback failure for (+ 3e-020 (* -100 6.01853107621011e-036))
2.99999999999994e-020
Number readback failure for (+ 3e-050 (* -100 4.7477838728799e-066))
2.99999999999995e-050
Number readback failure for (+ 3e-100 (* -100 5.0758836746313e-116))
2.99999999999995e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 7. (* -100 8.88178419700125e-016))
6.99999999999991
Number readback failure for (+ 70. (* -100 1.4210854715202e-014))
69.9999999999986
Number readback failure for (+ 700. (* -100 1.13686837721616e-013))
699.999999999989
Number readback failure for (+ 7e+020 (* -100 131072.))
6.99999999999987e+020
Number readback failure for (+ 7e+050 (* -100 8.30767497365572e+034))
6.99999999999992e+050
Number readback failure for (+ 7e+100 (* -100 1.55413511378058e+085))
6.99999999999984e+100
Number readback failure for (+ 0.7 (* -99 1.11022302462516e-016))
0.699999999999989
Number readback failure for (+ 0.07 (* -100 1.38777878078145e-017))
0.0699999999999986
Number readback failure for (+ 0.007 (* -100 8.67361737988404e-019))
0.00699999999999991
Number readback failure for (+ 7e-020 (* -99 1.20370621524202e-035))
6.99999999999988e-020
Number readback failure for (+ 7e-050 (* -100 9.4955677457598e-066))
6.99999999999991e-050
Number readback failure for (+ 7e-100 (* -100 1.01517673492626e-115))
6.9999999999999e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 3.14159265358979 (* -100 4.44089209850063e-016))
3.14159265358975
Number readback failure for (+ 31.4159265358979 (* -100 3.5527136788005e-015))
31.4159265358976
Number readback failure for (+ 314.159265358979 (* -100 5.6843418860808e-014))
314.159265358974
Number readback failure for (+ 3.14159265358979e+020 (* -100 65536.))
3.14159265358973e+020
Number readback failure for (+ 3.14159265358979e+050 (* -100 4.15383748682786e+034))
3.14159265358975e+050
Number readback failure for (+ 3.14159265358979e+100 (* -100 3.88533778445146e+084))
3.14159265358975e+100
Number readback failure for (+ 0.314159265358979 (* -100 5.55111512312578e-017))
0.314159265358974
Number readback failure for (+ 0.0314159265358979 (* -100 6.93889390390723e-018))
0.0314159265358972
Number readback failure for (+ 0.00314159265358979 (* -99 4.33680868994202e-019))
0.00314159265358975
Number readback failure for (+ 3.14159265358979e-020 (* -100 6.01853107621011e-036))
3.14159265358973e-020
Number readback failure for (+ 3.14159265358979e-050 (* -100 4.7477838728799e-066))
3.14159265358975e-050
Number readback failure for (+ 3.14159265358979e-100 (* -100 5.0758836746313e-116))
3.14159265358974e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
Number readback failure for (+ 2.71828182845905 (* -100 4.44089209850063e-016))
2.718281828459
Number readback failure for (+ 27.1828182845905 (* -100 3.5527136788005e-015))
27.1828182845901
Number readback failure for (+ 271.828182845905 (* -100 5.6843418860808e-014))
271.828182845899
Number readback failure for (+ 2.71828182845905e+020 (* -100 32768.))
2.71828182845901e+020
Number readback failure for (+ 2.71828182845905e+050 (* -100 4.15383748682786e+034))
2.718281828459e+050
Number readback failure for (+ 2.71828182845905e+100 (* -100 3.88533778445146e+084))
2.71828182845901e+100
Number readback failure for (+ 0.271828182845905 (* -99 5.55111512312578e-017))
0.271828182845899
Number readback failure for (+ 0.0271828182845905 (* -100 3.46944695195361e-018))
0.0271828182845901
Number readback failure for (+ 0.00271828182845905 (* -100 4.33680868994202e-019))
0.002718281828459
Number readback failure for (+ 2.71828182845904e-020 (* -100 6.01853107621011e-036))
2.71828182845898e-020
Number readback failure for (+ 2.71828182845905e-050 (* -100 4.7477838728799e-066))
2.718281828459e-050
Number readback failure for (+ 2.71828182845905e-100 (* -100 5.0758836746313e-116))
2.71828182845899e-100
(mult-float-print-test #f) ==> #f
BUT EXPECTED #t
To fully test continuations do:
(test-cont)
;testing scheme 4 functions;
SECTION(6 7)
(#<subr string->list> "P l") ==> (#\P #\ #\l)
(#<subr string->list> "") ==> ()
(#<subr list->string> (#\1 #\\ #\")) ==> "1\\\""
(#<subr list->string> ()) ==> ""
SECTION(6 8)
(#<subr vector->list> #(dah dah didah)) ==> (dah dah didah)
(#<subr vector->list> #()) ==> ()
(#<subr list->vector> (dididit dah)) ==> #(dididit dah)
(#<subr list->vector> ()) ==> #()
SECTION(6 10 4)
(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))
;testing DELAY and FORCE;
SECTION(6 9)
(delay 3) ==> 3
(delay (3 3)) ==> (3 3)
(delay 2) ==> 2
(#<builtin force> #<promise #<lambda () ...>>) ==> 6
(#<builtin force> #<promise 6>) ==> 6
(force 3) ==> 3
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))
;testing continuations;
SECTION(6 9)
(#<lambda (x y) ...> (a (b (c))) ((a) b c)) ==> #t
(#<lambda (x y) ...> (a (b (c))) ((a) b c d)) ==> #f
errors were:
(SECTION (got expected (call)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (mult-float-print-test #f)))
((6 5 6) (#f #t (float-print-test #f)))

Some files were not shown because too many files have changed in this diff Show More