From 839e25059a717a109989d6098fd5f647129b6b70 Mon Sep 17 00:00:00 2001 From: "colin.smith" Date: Sat, 12 Aug 2006 19:00:13 +0000 Subject: [PATCH] initial import git-svn-id: svn://localhost/root/svnrepo/trunk@2 bee25f81-8ba7-4b93-944d-dfac3d1a11cc --- vx-scheme/LICENSE | 125 + vx-scheme/README | 9 + vx-scheme/lib/.cvsignore | 2 + vx-scheme/lib/vx-scheme.init | 338 +++ vx-scheme/lib/vx-slib-test.scm | 17 + vx-scheme/src/.cvsignore | 8 + vx-scheme/src/Makefile | 179 ++ vx-scheme/src/Scheme.sln | 37 + vx-scheme/src/bootstrap.scm | 144 + vx-scheme/src/cell.cpp | 1199 +++++++++ vx-scheme/src/compile | 9 + vx-scheme/src/compile-file.scm | 90 + vx-scheme/src/compiler.scm | 971 +++++++ vx-scheme/src/cp-test.scm | 105 + vx-scheme/src/ctx.cpp | 178 ++ vx-scheme/src/interp.cpp | 1627 ++++++++++++ vx-scheme/src/io.cpp | 603 +++++ vx-scheme/src/lib.cpp | 94 + vx-scheme/src/library.scm | 81 + vx-scheme/src/simulator.scm | 561 ++++ vx-scheme/src/subr.cpp | 1895 ++++++++++++++ vx-scheme/src/symtab.cpp | 410 +++ vx-scheme/src/u-main.cpp | 138 + vx-scheme/src/vm.cpp | 1028 ++++++++ vx-scheme/src/vx-main.cpp | 239 ++ vx-scheme/src/vx-scheme.h | 1223 +++++++++ vx-scheme/src/win32/vx-scheme/.cvsignore | 2 + .../src/win32/vx-scheme/vx-scheme.vcproj | 185 ++ vx-scheme/src/win32/vxs-bootstrap/.cvsignore | 2 + .../win32/vxs-bootstrap/vxs-bootstrap.vcproj | 159 ++ vx-scheme/src/win32/vxs-interp/.cvsignore | 2 + .../src/win32/vxs-interp/vxs-interp.vcproj | 154 ++ vx-scheme/testcases/.cvsignore | 2 + vx-scheme/testcases/ack.scm | 9 + vx-scheme/testcases/boyer.scm | 291 +++ vx-scheme/testcases/c-good/ack.good | 3 + vx-scheme/testcases/c-good/boyer.good | 1 + vx-scheme/testcases/c-good/cf.good | 65 + vx-scheme/testcases/c-good/dderiv.good | 1 + vx-scheme/testcases/c-good/dynamic.good | 1 + vx-scheme/testcases/c-good/earley.good | 1 + vx-scheme/testcases/c-good/maze.good | 42 + vx-scheme/testcases/c-good/pi.good | 7 + vx-scheme/testcases/c-good/puzzle.good | 19 + vx-scheme/testcases/c-good/r4rstest.good | 772 ++++++ vx-scheme/testcases/c-good/scheme.good | 1 + vx-scheme/testcases/c-good/series.good | 54 + vx-scheme/testcases/c-good/sieve.good | 1 + vx-scheme/testcases/cf.scm | 40 + vx-scheme/testcases/cyclic.scm | 17 + vx-scheme/testcases/dderiv.scm | 79 + vx-scheme/testcases/dynamic.scm | 2319 +++++++++++++++++ vx-scheme/testcases/earley.scm | 647 +++++ vx-scheme/testcases/good/ack.good | 3 + vx-scheme/testcases/good/boyer.good | 1 + vx-scheme/testcases/good/cf.good | 65 + vx-scheme/testcases/good/dderiv.good | 1 + vx-scheme/testcases/good/dynamic.good | 1 + vx-scheme/testcases/good/earley.good | 1 + vx-scheme/testcases/good/maze.good | 42 + vx-scheme/testcases/good/pi.good | 7 + vx-scheme/testcases/good/puzzle.good | 19 + vx-scheme/testcases/good/r4rstest.good | 772 ++++++ vx-scheme/testcases/good/scheme.good | 1 + vx-scheme/testcases/good/series.good | 54 + vx-scheme/testcases/good/sieve.good | 1 + vx-scheme/testcases/maze.scm | 683 +++++ vx-scheme/testcases/pi.scm | 27 + vx-scheme/testcases/puzzle.scm | 168 ++ vx-scheme/testcases/q.scm | 12 + vx-scheme/testcases/r4rstest.scm | 1197 +++++++++ vx-scheme/testcases/scheme.scm | 1083 ++++++++ vx-scheme/testcases/series.scm | 72 + vx-scheme/testcases/sicp.scm | 43 + vx-scheme/testcases/sieve.scm | 20 + vx-scheme/testcases/stream.scm | 80 + vx-scheme/testcases/vx-good/ack.good | 3 + vx-scheme/testcases/vx-good/boyer.good | 1 + vx-scheme/testcases/vx-good/cf.good | 65 + vx-scheme/testcases/vx-good/dderiv.good | 1 + vx-scheme/testcases/vx-good/dynamic.good | 1 + vx-scheme/testcases/vx-good/earley.good | 1 + vx-scheme/testcases/vx-good/maze.good | 42 + vx-scheme/testcases/vx-good/pi.good | 7 + vx-scheme/testcases/vx-good/puzzle.good | 19 + vx-scheme/testcases/vx-good/r4rstest.good | 778 ++++++ vx-scheme/testcases/vx-good/scheme.good | 1 + vx-scheme/testcases/vx-good/series.good | 54 + vx-scheme/testcases/vx-good/sieve.good | 1 + vx-scheme/testcases/vx-test.scm | 65 + vx-scheme/testcases/w32-good/ack.good | 3 + vx-scheme/testcases/w32-good/boyer.good | 1 + vx-scheme/testcases/w32-good/cf.good | 65 + vx-scheme/testcases/w32-good/dderiv.good | 1 + vx-scheme/testcases/w32-good/dynamic.good | 1 + vx-scheme/testcases/w32-good/earley.good | 1 + vx-scheme/testcases/w32-good/maze.good | 42 + vx-scheme/testcases/w32-good/pi.good | 7 + vx-scheme/testcases/w32-good/puzzle.good | 19 + vx-scheme/testcases/w32-good/r4rstest.good | 778 ++++++ vx-scheme/testcases/w32-good/scheme.good | 1 + vx-scheme/testcases/w32-good/series.good | 54 + vx-scheme/testcases/w32-good/sieve.good | 1 + vx-scheme/tornado/target-shell/linkSyms.c | 299 +++ vx-scheme/tornado/target-shell/prjComps.h | 123 + vx-scheme/tornado/target-shell/prjConfig.c | 345 +++ vx-scheme/tornado/target-shell/prjObjs.lst | 4 + vx-scheme/tornado/target-shell/prjParams.h | 485 ++++ vx-scheme/tornado/target-shell/startup | 3 + .../tornado/target-shell/target-shell.wpj | 843 ++++++ vx-scheme/tornado/target-shell/usrAppInit.c | 30 + vx-scheme/tornado/vx-scheme.wsp | 15 + vx-scheme/tornado/vx-scheme/prjObjs.lst | 6 + vx-scheme/tornado/vx-scheme/vx-scheme.wpj | 346 +++ 114 files changed, 25051 insertions(+) create mode 100644 vx-scheme/LICENSE create mode 100755 vx-scheme/README create mode 100644 vx-scheme/lib/.cvsignore create mode 100644 vx-scheme/lib/vx-scheme.init create mode 100644 vx-scheme/lib/vx-slib-test.scm create mode 100644 vx-scheme/src/.cvsignore create mode 100755 vx-scheme/src/Makefile create mode 100755 vx-scheme/src/Scheme.sln create mode 100644 vx-scheme/src/bootstrap.scm create mode 100644 vx-scheme/src/cell.cpp create mode 100644 vx-scheme/src/compile create mode 100755 vx-scheme/src/compile-file.scm create mode 100644 vx-scheme/src/compiler.scm create mode 100644 vx-scheme/src/cp-test.scm create mode 100644 vx-scheme/src/ctx.cpp create mode 100644 vx-scheme/src/interp.cpp create mode 100644 vx-scheme/src/io.cpp create mode 100644 vx-scheme/src/lib.cpp create mode 100644 vx-scheme/src/library.scm create mode 100644 vx-scheme/src/simulator.scm create mode 100644 vx-scheme/src/subr.cpp create mode 100644 vx-scheme/src/symtab.cpp create mode 100644 vx-scheme/src/u-main.cpp create mode 100644 vx-scheme/src/vm.cpp create mode 100644 vx-scheme/src/vx-main.cpp create mode 100644 vx-scheme/src/vx-scheme.h create mode 100644 vx-scheme/src/win32/vx-scheme/.cvsignore create mode 100755 vx-scheme/src/win32/vx-scheme/vx-scheme.vcproj create mode 100644 vx-scheme/src/win32/vxs-bootstrap/.cvsignore create mode 100755 vx-scheme/src/win32/vxs-bootstrap/vxs-bootstrap.vcproj create mode 100644 vx-scheme/src/win32/vxs-interp/.cvsignore create mode 100755 vx-scheme/src/win32/vxs-interp/vxs-interp.vcproj create mode 100644 vx-scheme/testcases/.cvsignore create mode 100644 vx-scheme/testcases/ack.scm create mode 100644 vx-scheme/testcases/boyer.scm create mode 100755 vx-scheme/testcases/c-good/ack.good create mode 100644 vx-scheme/testcases/c-good/boyer.good create mode 100644 vx-scheme/testcases/c-good/cf.good create mode 100644 vx-scheme/testcases/c-good/dderiv.good create mode 100644 vx-scheme/testcases/c-good/dynamic.good create mode 100644 vx-scheme/testcases/c-good/earley.good create mode 100644 vx-scheme/testcases/c-good/maze.good create mode 100755 vx-scheme/testcases/c-good/pi.good create mode 100644 vx-scheme/testcases/c-good/puzzle.good create mode 100644 vx-scheme/testcases/c-good/r4rstest.good create mode 100644 vx-scheme/testcases/c-good/scheme.good create mode 100644 vx-scheme/testcases/c-good/series.good create mode 100755 vx-scheme/testcases/c-good/sieve.good create mode 100644 vx-scheme/testcases/cf.scm create mode 100644 vx-scheme/testcases/cyclic.scm create mode 100644 vx-scheme/testcases/dderiv.scm create mode 100644 vx-scheme/testcases/dynamic.scm create mode 100644 vx-scheme/testcases/earley.scm create mode 100755 vx-scheme/testcases/good/ack.good create mode 100644 vx-scheme/testcases/good/boyer.good create mode 100644 vx-scheme/testcases/good/cf.good create mode 100644 vx-scheme/testcases/good/dderiv.good create mode 100644 vx-scheme/testcases/good/dynamic.good create mode 100644 vx-scheme/testcases/good/earley.good create mode 100644 vx-scheme/testcases/good/maze.good create mode 100755 vx-scheme/testcases/good/pi.good create mode 100644 vx-scheme/testcases/good/puzzle.good create mode 100644 vx-scheme/testcases/good/r4rstest.good create mode 100644 vx-scheme/testcases/good/scheme.good create mode 100644 vx-scheme/testcases/good/series.good create mode 100755 vx-scheme/testcases/good/sieve.good create mode 100644 vx-scheme/testcases/maze.scm create mode 100644 vx-scheme/testcases/pi.scm create mode 100644 vx-scheme/testcases/puzzle.scm create mode 100644 vx-scheme/testcases/q.scm create mode 100644 vx-scheme/testcases/r4rstest.scm create mode 100644 vx-scheme/testcases/scheme.scm create mode 100644 vx-scheme/testcases/series.scm create mode 100644 vx-scheme/testcases/sicp.scm create mode 100644 vx-scheme/testcases/sieve.scm create mode 100644 vx-scheme/testcases/stream.scm create mode 100755 vx-scheme/testcases/vx-good/ack.good create mode 100644 vx-scheme/testcases/vx-good/boyer.good create mode 100755 vx-scheme/testcases/vx-good/cf.good create mode 100644 vx-scheme/testcases/vx-good/dderiv.good create mode 100755 vx-scheme/testcases/vx-good/dynamic.good create mode 100755 vx-scheme/testcases/vx-good/earley.good create mode 100755 vx-scheme/testcases/vx-good/maze.good create mode 100755 vx-scheme/testcases/vx-good/pi.good create mode 100644 vx-scheme/testcases/vx-good/puzzle.good create mode 100755 vx-scheme/testcases/vx-good/r4rstest.good create mode 100755 vx-scheme/testcases/vx-good/scheme.good create mode 100755 vx-scheme/testcases/vx-good/series.good create mode 100755 vx-scheme/testcases/vx-good/sieve.good create mode 100644 vx-scheme/testcases/vx-test.scm create mode 100755 vx-scheme/testcases/w32-good/ack.good create mode 100644 vx-scheme/testcases/w32-good/boyer.good create mode 100644 vx-scheme/testcases/w32-good/cf.good create mode 100644 vx-scheme/testcases/w32-good/dderiv.good create mode 100644 vx-scheme/testcases/w32-good/dynamic.good create mode 100644 vx-scheme/testcases/w32-good/earley.good create mode 100644 vx-scheme/testcases/w32-good/maze.good create mode 100755 vx-scheme/testcases/w32-good/pi.good create mode 100644 vx-scheme/testcases/w32-good/puzzle.good create mode 100644 vx-scheme/testcases/w32-good/r4rstest.good create mode 100644 vx-scheme/testcases/w32-good/scheme.good create mode 100644 vx-scheme/testcases/w32-good/series.good create mode 100755 vx-scheme/testcases/w32-good/sieve.good create mode 100755 vx-scheme/tornado/target-shell/linkSyms.c create mode 100755 vx-scheme/tornado/target-shell/prjComps.h create mode 100755 vx-scheme/tornado/target-shell/prjConfig.c create mode 100755 vx-scheme/tornado/target-shell/prjObjs.lst create mode 100755 vx-scheme/tornado/target-shell/prjParams.h create mode 100644 vx-scheme/tornado/target-shell/startup create mode 100755 vx-scheme/tornado/target-shell/target-shell.wpj create mode 100755 vx-scheme/tornado/target-shell/usrAppInit.c create mode 100755 vx-scheme/tornado/vx-scheme.wsp create mode 100755 vx-scheme/tornado/vx-scheme/prjObjs.lst create mode 100755 vx-scheme/tornado/vx-scheme/vx-scheme.wpj diff --git a/vx-scheme/LICENSE b/vx-scheme/LICENSE new file mode 100644 index 0000000..7e6e18c --- /dev/null +++ b/vx-scheme/LICENSE @@ -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 diff --git a/vx-scheme/README b/vx-scheme/README new file mode 100755 index 0000000..269cfe7 --- /dev/null +++ b/vx-scheme/README @@ -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! diff --git a/vx-scheme/lib/.cvsignore b/vx-scheme/lib/.cvsignore new file mode 100644 index 0000000..f05f16c --- /dev/null +++ b/vx-scheme/lib/.cvsignore @@ -0,0 +1,2 @@ +slib_101 +slibcat diff --git a/vx-scheme/lib/vx-scheme.init b/vx-scheme/lib/vx-scheme.init new file mode 100644 index 0000000..338e3ad --- /dev/null +++ b/vx-scheme/lib/vx-scheme.init @@ -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 ) + ; getenv ;posix (getenv ) + ; program-arguments ;returns list of strings (argv) + ; current-time ;returns time in seconds since 1/1/1970 + + ;; Implementation Specific features + + )) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(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? ) +;; provided in custom version of vx-scheme +;;(define (file-exists? f) #f) + +;;; (DELETE-FILE ) +(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 ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-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")) diff --git a/vx-scheme/lib/vx-slib-test.scm b/vx-scheme/lib/vx-slib-test.scm new file mode 100644 index 0000000..65a6cf4 --- /dev/null +++ b/vx-scheme/lib/vx-slib-test.scm @@ -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)") + + + + diff --git a/vx-scheme/src/.cvsignore b/vx-scheme/src/.cvsignore new file mode 100644 index 0000000..a46b6b8 --- /dev/null +++ b/vx-scheme/src/.cvsignore @@ -0,0 +1,8 @@ +tmp[123] +vxs-interp +vxs-bootstrap +vx-scheme +vx-scheme.exe +_compiler.cpp +Scheme.ncb +Scheme.suo diff --git a/vx-scheme/src/Makefile b/vx-scheme/src/Makefile new file mode 100755 index 0000000..ff3ef74 --- /dev/null +++ b/vx-scheme/src/Makefile @@ -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 + +#------------------------------------------------------------------------ + + + diff --git a/vx-scheme/src/Scheme.sln b/vx-scheme/src/Scheme.sln new file mode 100755 index 0000000..f4eff3b --- /dev/null +++ b/vx-scheme/src/Scheme.sln @@ -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 diff --git a/vx-scheme/src/bootstrap.scm b/vx-scheme/src/bootstrap.scm new file mode 100644 index 0000000..5fafc81 --- /dev/null +++ b/vx-scheme/src/bootstrap.scm @@ -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") + + diff --git a/vx-scheme/src/cell.cpp b/vx-scheme/src/cell.cpp new file mode 100644 index 0000000..e63e787 --- /dev/null +++ b/vx-scheme/src/cell.cpp @@ -0,0 +1,1199 @@ +//---------------------------------------------------------------------- +// vx-scheme : Scheme interpreter. +// Copyright (c) 2002,2003,2006 Colin Smith. +// +// You may distribute under the terms of the Artistic License, +// as specified in the LICENSE file. +// +// cell.cpp : cell creation, storage management, garbage collection. + +#include "vx-scheme.h" + +static const char * nomem_error = "out of memory"; + +Cell * Context::make () + { + Cell * c = alloc (Cell::Cons); + c->ca.p = c->cd.p = &Cell::Nil; + return c; + } + +Cell * Context::make_int (int i) + { + // SHORT INTEGER support: if the integer fits in 24 bits, + // then return a phony pointer with the short flag set and + // the integer in the upper 24. This avoids storage allocation + // and the attendant eventual garbage. +#if 1 + if ((i << 8) >> 8 == i) { + return reinterpret_cast ((i << 8) | Cell::SHORT | Cell::ATOM); + } +#endif + Cell * c = alloc (Cell::Int); + c->cd.i = i; + + return c; + } + +Cell * Context::make_char (char ch) + { + Cell * c = alloc (Cell::Char); + c->cd.c = ch; + + return c; + } + +Cell * Context::make_real (double d) + { + Cell * c = alloc (Cell::Real); + double *pd = (double*) malloc(sizeof(double)); + *pd = d; + c->cd.d = pd; + return c; + } + +// Context::make_string +// Makes a string of the indicated length -- it is UNINITIALIZED + +Cell * Context::make_string (size_t len) + { + Cell * c = alloc (Cell::String); + size_t boxsize = sizeof(Cell::StringBox) + len + 1; + Cell::StringBox* pbox = (Cell::StringBox*) xmalloc (boxsize); + pbox->length = len; + c->cd.s = pbox; + return c; + } + +Cell * Context::make_string (int len, char ch) + { + Cell * c = make_string (len); + memset (c->cd.s->s, ch, len); + c->cd.s->s[len] = '\0'; + return c; + } + +Cell * Context::make_string (const char * s) + { + return make_string (s, strlen (s)); + } + +Cell * Context::make_string (const char * s, size_t len) + { + Cell * c = make_string (len); + strncpy(c->cd.s->s, s, len); + c->cd.s->s[len] = '\0'; + return c; + } + +Cell * Context::make_subr (subr_f s, const char * name) + { + Cell * c = alloc (Cell::Subr); + Cell::SubrBox * psubr = new Cell::SubrBox (); + psubr->subr = s; + psubr->name = name; + c->cd.f = psubr; + return c; + } + +Cell * Context::make_builtin (psymbol y) + { + Cell * c = alloc (Cell::Builtin); + c->cd.y = y; + return c; + } + +Cell * Context::make_symbol (psymbol y) + { + Cell * c = alloc (Cell::Symbol); + c->cd.y = y; + + return c; + } + +Cell * Context::make_boolean (bool b) + { + return b ? &Cell::Bool_T : &Cell::Bool_F; + } + +Cell * Context::make_vector (int n, Cell * init /* = &Unspecified */) + { + Cell * c = alloc (Cell::Vec); + c->cd.cv = cellvector::alloc(n); + c->flag (Cell::VREF, true); + + for (int ix = 0; ix < n; ++ix) + c->cd.cv->set (ix, init); + + return c; + } + +Cell * Context::make_iport (const char * fname) + { + FILE * ip = fopen (fname, "r"); + if (ip) + return make_iport (ip); + + error ("unable to open stream for reading"); + return nil; + } + +Cell * Context::make_iport (FILE * ip) + { + Cell * c = alloc (Cell::Iport); + c->cd.ip = ip; + + return c; + } + +Cell * Context::make_oport (const char * fname) + { + FILE * ofs = fopen (fname, "w"); + if (ofs) + return make_oport (ofs); + + + error ("unable to open stream for writing"); + return nil; + } + +Cell * Context::make_oport (FILE * op) + { + Cell * c = alloc (Cell::Oport); + c->cd.op = op; + + return c; + } + +Cell * Context::make (Cell * ca, Cell * cd /* = &Nil*/) + { + Cell * c = alloc (Cell::Cons); + c->ca.p = ca; + c->cd.p = cd; + return c; + } + +Cell * Context::make_magic (void * key, magic_set_f set_f, magic_get_f get_f) + { + Cell * c = alloc (Cell::Magic); + Cell::MagicBox* mbox = (Cell::MagicBox*) xmalloc(sizeof(Cell::MagicBox)); + mbox->key = key; + mbox->set_f = set_f; + mbox->get_f = get_f; + return c; + } + +Cell * Cell::notcons () + { + error ("expecting a Cons"); + return nil; + } + +bool Cell::ispair() { + return type () == Cell::Cons + && this != unspecified + && this != nil; +} + +void Cell::sanity_check () + { + int bad = 0; + + printf ("size = %Zu, typebits = %d, typemask = %x, numtypes = %d\n", + sizeof (Cell), TYPEBITS, TYPEMASK, NUM_TYPES); + + // Make sure that there are enough typebits to contain + // all the types we know about. + + if ((1 << TYPEBITS) < NUM_ATOMS) + ++bad, printf ("Not enough typebits!\n"); + + // Make sure that the size of a cell has not become greater + // than two machine pointers (car & cdr). + + if (sizeof (Cell) > 2 * sizeof (void *)) + printf ("Cell (%Zu) is larger than CAR+CDR!\n", sizeof (Cell)); + + // Make sure that the "zero zone" (the least significant + // bits of a pointer to a cell) is wide enough to accomodate + // the type and GC information stored there, assuming that + // a Cell is aligned to its own size in memory + + if (sizeof (Cell) < (1 << TAGBITS)) + ++bad, printf ("Too many tag bits for cell size\n"); + + if (bad) + exit (bad); + }; + +bool Cell::eq (Cell * that) + { + if (this == that) // the easy case + return true; + if (short_atom (this) || short_atom (that)) + return false; // then the above case would have detected equality + if (long_atom(ca.p) && long_atom(that->ca.p)) + { + bool part1 = (ca.i & IGN_MASK) == (that->ca.i & IGN_MASK) + && cd.i == that->cd.i; + + return part1; + } + // If both are conses, they are eq iff they are the same cons. + // But that would have been detected by the first test. + return false; + } + + +bool Cell::equal (Cell * c) + { + Type t0 = type (); + Type t1 = c->type (); + + if (this == &Nil && c == &Nil) + return true; + else if (t0 == Cons && t1 == Cons) + return ca.p->equal (c->ca.p) && cd.p->equal (c->cd.p); + else if (t0 == Vec && t1 == Vec) + { + cellvector * cv = VectorValue(); + cellvector * ocv = c->VectorValue (); + int s = cv->size (); + + if (s != ocv->size ()) + return false; + + for (int ix = 0; ix < s; ++ix) + if (! cv->get (ix)->equal (ocv->get (ix))) + return false; + + return true; + } + else if (t0 == String && t1 == String) + return !strcmp (StringValue (), c->StringValue ()); + else if (t0 == Real && t1 == Real) + return RealValue () == c->RealValue (); + else + return eq (c); + } + +//------------------------------------------------------------------------ +// +// Access/Mutate Cons Cells. These are checked calls, in that they +// will verify that they are traversing a set of cons cells at each +// step, using "assert_cons", which throws a C++ exception if this is +// not found to be true. + +Cell * Cell::caar (Cell * c) {return Cell::car (Cell::car (c));} +Cell * Cell::cadr (Cell * c) {return Cell::car (Cell::cdr (c));} +Cell * Cell::cdar (Cell * c) {return Cell::cdr (Cell::car (c));} +Cell * Cell::cddr (Cell * c) {return Cell::cdr (Cell::cdr (c));} +Cell * Cell::caaar (Cell * c) {return Cell::car (Cell::caar (c));} +Cell * Cell::caadr (Cell * c) {return Cell::car (Cell::cadr (c));} +Cell * Cell::cadar (Cell * c) {return Cell::car (Cell::cdar (c));} +Cell * Cell::caddr (Cell * c) {return Cell::car (Cell::cddr (c));} +Cell * Cell::cdaar (Cell * c) {return Cell::cdr (Cell::caar (c));} +Cell * Cell::cdadr (Cell * c) {return Cell::cdr (Cell::cadr (c));} +Cell * Cell::cddar (Cell * c) {return Cell::cdr (Cell::cdar (c));} +Cell * Cell::cdddr (Cell * c) {return Cell::cdr (Cell::cddr (c));} +Cell * Cell::caaaar (Cell * c) {return Cell::car (Cell::caaar (c));} +Cell * Cell::caaadr (Cell * c) {return Cell::car (Cell::caadr (c));} +Cell * Cell::caadar (Cell * c) {return Cell::car (Cell::cadar (c));} +Cell * Cell::caaddr (Cell * c) {return Cell::car (Cell::caddr (c));} +Cell * Cell::cadaar (Cell * c) {return Cell::car (Cell::cdaar (c));} +Cell * Cell::cadadr (Cell * c) {return Cell::car (Cell::cdadr (c));} +Cell * Cell::caddar (Cell * c) {return Cell::car (Cell::cddar (c));} +Cell * Cell::cadddr (Cell * c) {return Cell::car (Cell::cdddr (c));} +Cell * Cell::cdaaar (Cell * c) {return Cell::cdr (Cell::caaar (c));} +Cell * Cell::cdaadr (Cell * c) {return Cell::cdr (Cell::caadr (c));} +Cell * Cell::cdadar (Cell * c) {return Cell::cdr (Cell::cadar (c));} +Cell * Cell::cdaddr (Cell * c) {return Cell::cdr (Cell::caddr (c));} +Cell * Cell::cddaar (Cell * c) {return Cell::cdr (Cell::cdaar (c));} +Cell * Cell::cddadr (Cell * c) {return Cell::cdr (Cell::cdadr (c));} +Cell * Cell::cdddar (Cell * c) {return Cell::cdr (Cell::cddar (c));} +Cell * Cell::cddddr (Cell * c) {return Cell::cdr (Cell::cdddr (c));} + +psymbol Cell::SymbolValue () const + { + typecheck (Symbol); + return cd.y; + } + +void Cell::stats () + { + for (int ix = 0; ix < NUM_TYPES; ++ix) + printf ("%s %d ", typeName [ix], typeCount [ix]); + + printf ("\n"); + } + +//====================================================================== +// +// Value Extractors +// +//====================================================================== + +int Cell::IntValue () const + { + if (short_atom (this)) + return reinterpret_cast (this) >> 8; + + typecheck (Int); return cd.i; + } + +char Cell::CharValue () const + { + typecheck (Char); + return cd.c; + } + +Cell::SubrBox* Cell::SubrValue () const + { + typecheck (Subr); + return cd.f; + } + +char * Cell::StringValue () const + { + typecheck (String); + return cd.s->s; + } + +size_t Cell::StringLength () const + { + typecheck (String); + return cd.s->length; + } + +FILE * Cell::IportValue () const + { + typecheck (Iport); return cd.ip; + } + +FILE * Cell::OportValue () const + { + typecheck (Oport); return cd.op; + } + +void * Cell::ContValue () const + { + typecheck (Cont); return cd.j; + } + +cellvector * Cell::VectorValue () const + { + typecheck(Vec); return cd.cv; + } + +cellvector * Cell::CProcValue () const + { + typecheck(Cproc); return cd.cv; + } + +Cell * Cell::PromiseValue () const + { + typecheck (Promise); + return cd.cv->get (0); + } + +psymbol Cell::BuiltinValue () const + { + typecheck (Builtin); return cd.y; + } + +Cell::Procedure Cell::LambdaValue () const + { + typecheck (Lambda); + return Procedure (cd.cv->get (0), cd.cv->get (1), cd.cv->get (2)); + } + +double Cell::RealValue () const + { + typecheck (Real); + return *(cd.d); + } + +const char * Cell::name () const + { + return typeName [type ()]; + } + +void Cell::typefail (Type t1, Type t2) const + { + static char buf [128]; // XXX not reentrant, and fixed buffer dangerous + sprintf (buf, "type check failure: wanted %s, got %s", + typeName [t2], typeName [t1]); /* XXX sprintf into fixed buf */ + + OS::exception (buf); + } + +void Cell::dump (FILE * out) + { + Type t = type (); + fprintf (out, "[%p ", this); + if (ca.i == (FREE|ATOM)) fputs ("free ", out); + else + { + if (ca.i & MARK) fputs ("mark ", out); + if (short_atom (ca.p)) + { + printf ("short %d ", ca.p->IntValue ()); + } + else + { + if (ca.i & ATOM) + { + printf ("atom %04x ", ca.i); + if (ca.i & FORCED) fputs ("forced ", out); + if (ca.i & QUICK) fputs ("quick ", out); + if (ca.i & MACRO) fputs ("macro ", out); + if (ca.i & VREF) fputs ("vref ", out); + } + + fputs (typeName [t], out); + + switch (t) + { + case Cons: + fputs (" ", out); + if (ca.p == nil) + fputs ("nil", out); + else + fprintf (out, "%p", ca.p); + fputs (" ", out); + if (cd.p == nil) + fputs ("nil", out); + else + fprintf (out, "%p", cd.p); + break; + + case Int: fprintf (out, " %d", cd.i); break; + case Real: fprintf (out, " %g", RealValue ()); break; + case Unique: fprintf (out, " %s", cd.u); break; + case Symbol: fprintf (out, " %s", SymbolValue ()->key); + default: break; + } + } + } + fputc (']', out); + } + + +//====================================================================== +// +// Cell Vectors +// +//====================================================================== + +cellvector::cellvector (int size /* = 0 */) + { + int allocate = (size == 0 ? 10 : size); + make_cv (size, allocate); + } + +cellvector::cellvector (int size, int alloc) + { + make_cv (size, alloc); + } + +void cellvector::make_cv (int size, int alloc) + { + v = (Cell **) malloc (alloc * sizeof (Cell *)); + if (!v) + error (nomem_error); + allocated = alloc; + + for (int ix = 0; ix < alloc; ++ix) + v [ix] = nil; + + gc_index = 0; + gc_uplink = 0; + sz = size; + } + +Cell *& cellvector::operator [] (int ix) + { + if (ix < 0 || ix >= sz) + vref_error (); + + return v [ix]; + } + +void cellvector::set + ( + int ix, + Cell * c + ) + + { + if (ix < 0 || ix >= sz) + vref_error (); + + v [ix] = c; + } + +void cellvector::expand () + { + // Must expand vector: double size. + int new_alloc = 2 * allocated; + Cell ** v2 = (Cell **) malloc (new_alloc * sizeof (Cell *)); + + if (!v2) + error (nomem_error); + + memcpy (v2, v, allocated * sizeof (Cell *)); + ::free (v); + v = v2; + allocated = new_alloc; + } + +Cell * cellvector::shift () + { + Cell * val = v[0]; + for (int ix = 0; ix < sz - 1; ++ix) + v [ix] = v [ix+1]; + pop (); + return val; + } + +void cellvector::unshift (Cell * val) + { + push (nil); + for (int ix = sz-1; ix > 0; --ix) + v [ix] = v [ix-1]; + v[0] = val; + } + +void cellvector::vref_error () + { + error ("vector reference out of bounds"); + } + +void cellvector::clear () + { + sz = 0; + } + +cellvector::~cellvector () + { + ::free (v); + sz = 0; + allocated = 0; + v = 0; + } + +// Cellvector freelist management + +cellvector* cellvector::freelist_head[cellvector::keep_size+1]; +int cellvector::freelist_count[cellvector::keep_size+1]; + +cellvector* cellvector::alloc(int size) { + int allocate = size; + if (allocate == 0) allocate = 2; + return alloc(size, allocate); +} + +cellvector* cellvector::alloc(int size, int allocate) { + cellvector* result; + if (allocate <= keep_size) { + if ((result = freelist_head[allocate])) { + freelist_head[allocate] = result->next_free; + for (int ix = 0; ix < allocate; ++ix) + result->v[ix] = nil; + result->sz = size; + result->next_free = 0; + --freelist_count[allocate]; + return result; + } + } + return new cellvector(size, allocate); +} + +void cellvector::free() { + if (allocated <= keep_size && freelist_count[allocated] <= keep_count) { + next_free = freelist_head[allocated]; + ++freelist_count[allocated]; + freelist_head[allocated] = this; + } else { + delete this; + } +} + +//====================================================================== +// +// Memory Allocation and Garbage Collection +// +//====================================================================== + +class Slab + { + public: + + Cell * alloc () + { + if (next + 1 > end) + return 0; + + Cell * r = next; + ++next; + return r; + } + + int remaining () + { + return static_cast(end - next); + } + + void reset () + { + next = start; + } + + void sweep (Context *); + + Slab (Context * ctx) + { + // We avoid the temptation to call new Cell [slabsize], + // since that would invoke the constructor on each cell, + // which we don't need (alloc will take care of preparing + // cells for use). + // + // It is essential that Cells be 8-aligned to preserve + // three bits for type and GC information. If new has + // stiffed us with 4-aligned memory, we "burn" 4 bytes + // of it. + + int storage_size = slabsize * sizeof (Cell) + 4; + storage = (char *) malloc (storage_size); + + if (!storage) + error ("out of memory"); + + // Supposedly the ANSI library guarantees that storage + // is 4-aligned! + + if (((int) storage) & 3) + abort (); + + // But if it's not 8-aligned we can fix that using the + // extra 4 bytes we allocated. + + if (((int) storage) & 7) + start = reinterpret_cast (storage + 4); + else + start = reinterpret_cast (storage); + + memset (storage, 0, storage_size); + + ctx->cellsTotal += slabsize; + end = start + slabsize; + reset (); + } + + ~Slab () + { + free (storage); + } + + static int slabsize; + + private: + + Cell * start; + Cell * end; + Cell * next; + char * storage; + }; + +int Slab::slabsize = 10000; + +Cell * Context::alloc (Cell::Type t) + { + Cell * a; + + mem.last_alloc_gc = false; + // Select a cell from the free list if one is available. + +TOP: + if ((a = mem.free)) + { + ++cellsAlloc; + mem.free = a->cd.p; + a->ca.i = a->cd.i = 0; + a->set_type (t); + --mem.c_free; + return a; + } + + // IF there aren't any slabs in the active pool, + // we must never have allocated any slabs at all + // yet, so allocate the first one. + + if (mem.active.size () == 0) + { + // Configurable slabsize + + char * c; + if ((c = getenv ("SLABSIZE")) != NULL) + Slab::slabsize = atoi (c); + + mem.active.push ((Cell *) new Slab (this)); + mem.free = 0; + mem.low_water = false; + mem.no_inline_gc = OS::flag (DEBUG_NO_INLINE_GC); + } + + // Check the "top" slab to see if there's any room + // left in it. + + if ((a = mem.current ()->alloc ())) + { + ++cellsAlloc; + a->cd.i = 0; + a->set_type (t); + return a; + } + + // There wasn't any room in the top slab. We can try + // to GC. If we do, and still 80% of the allocated + // memory is occupied, we set a flag admitting that + // the last GC was "unproductive", and next time 'round + // we'll allocate a new slab. + + if (mem.no_inline_gc || mem.last_alloc_gc || mem.low_water) + { + mem.active.push ((Cell *) new Slab (this)); // trip to the well + mem.low_water = false; // low_water is a one-shot + } + else + { + mem.last_alloc_gc = true; + gc (); + } + + goto TOP; + } + +//---------------------------------------------------------------------- +// GARBAGE COLLECTION +// + + +inline Cell * Cell::untagged (Cell * c) + { + return reinterpret_cast + (reinterpret_cast (c) & ~Cell::TAGMASK); + } + +inline void Cell::gc_set_car (Cell * src) + { + unsigned int tagbits = ca.i & TAGMASK; + ca.p = src; + ca.i |= tagbits; + } + +inline void Cell::gc_set_cdr (Cell * src) + { + unsigned int tagbits = cd.i & TAGMASK; + setcdr (this, src); + cd.i |= tagbits; + } + + +//---------------------------------------------------------------------- +// Marking for Garbage Collection +// +// This implementation is Knuth's Algorithm 2.3.5E (TAoCP 3ed. vol I +// p. 418) We follow Knuth's presentation carefully (using the same +// variable names and statement labels). Like the evaluator, this +// code has to take some care to avoid recursion: we want to be able +// to perform a GC mark wihtout allocating any additional space (not +// even C stack space). That accounts for some of the complexity in +// this routine. The other part is that, due to vectors, we have to +// support n-way marking instead of just 2-way marking. + +void Context::mark (Cell * P) + { + bool traceall = OS::flag (TRACE_GC_ALL); + if (P == nil || P == 0 || Cell::short_atom(P) || P->ca.i & Cell::MARK) + return; + + // In Knuth's presentation, a NODE contains two pointers + // (which he calls ALINK and BLINK, we car and cdr), and + // MARK and ATOM fields. In his layout, the MARK and + // ATOM fields can be manipulated easily without changing + // ALINK and BLINK, but in our case we store MARK and ATOM + // in the lower three bits of ALINK. We must therefore + // be cautious when transcribing the algorithm to avoid, + // e.g., clearing MARK and ATOM when copying a `car' pointer. + // We use "gc_set_car" and "gc_set_cdr" for this purpose. + + // Secondly, Knuth occasionally sets the ATOM bit of a CONS + // to determine which of the pointers has been placed on + // the stack of deferred objects. But short atoms makes this + // difficult for us, as it's possible to have a cons of two + // short integers, say: then we need both ATOM fields of the + // CONS to contain that information. Instead of using the ATOM + // field, we use the MARK field of the cdr, which is not used + // for GC purposes. + +//E1: + Cell * T = nil; + Cell * Q = nil; + +E2: P->ca.i |= Cell::MARK; + if (traceall) { printf ("m "); P->dump (stdout); putchar ('\n'); } + + // -- EXTENSION to Knuth's Step E2 + // + // If the cell is a cons, Knuth's algorithm will take care of + // marking the things referenced as a result quite handily. But + // there are some atoms that can hold references too. Knuth's + // algorithm works for binary trees, but to deal with vectors et + // al. we need to make it work for n-way trees. + // + // When an atom can hold references to other cells, we organize + // these into a cellvector. In this way, we can treat all of them + // the same way. + // + // Whereas Knuth uses an atom bit to tell which side of a cons + // (car or cdr) he has stashed the pointer back to the + // as-yet-unmarked cells, when we traverse a vector we use an + // auxiliary integer field to tell us how many vector slots we + // have marked so far. + + if (Cell::atomic (P)) + { + if (P->flag (Cell::VREF)) + { + // Getting "here" in the code means that we're seeing the + // vector of additional cell references for the first time + // (otherwise the mark bit will already be set). Our job is + // to kick off the iteration by stashing the back-link and + // starting the mark counter. The rest of the iteration will + // be handled in the "up" step below. + + if (P->cd.cv->size () > 0) + { + P->cd.cv->gc_uplink = T; + P->cd.cv->gc_index = 0; + T = P; + } + } + else if (P->type () == Cell::Symbol) + { + // Symbols have property-list vectors, and so receive + // similar treatment to the above. But don't do this + // if we've already started to mark the properties + // (gc_uplink will be non-NULL in that case). + + psymbol ps = P->SymbolValue (); + if (ps->plist + && ps->plist->gc_uplink == 0 + && ps->plist->size () > 0) + { + ps->plist->gc_uplink = T; + ps->plist->gc_index = 0; + T = P; + } + } + + goto E6; // E3 + } + + if (!Cell::short_atom(P->ca.p)) + { + Q = Cell::untagged (P->ca.p); // E4 + if (Q != nil && !(Q->ca.i & Cell::MARK)) + { + //if (!Cell::short_atom(P->cd.p)) + // { + // P->cd.i |= Cell::ATOM; + P->cd.i |= Cell::MARK; + // END + P->gc_set_car (T); + T = P; + // } + P = Q; + goto E2; + } + } + +E5: if (!Cell::short_atom(P->cd.p)) + { + Q = Cell::untagged (P->cd.p); + if (Q != nil && !(Q->ca.i & Cell::MARK)) + { + P->gc_set_cdr (T); + T = P; + P = Q; + + goto E2; + } + } + +E6: if (T == nil) + return; + + Q = T; + + if (Q->flag (Cell::VREF)) + { + // We are popping a vector cell from the GC stack. + // If there are more cells to mark within it, keep + // going. + + next_element: + + int i = Q->cd.cv->gc_index++; + + if (i >= Q->cd.cv->size ()) // all done? + { + T = Q->cd.cv->gc_uplink; + Q->cd.cv->gc_index = 0; // reset for next time + P = Q; + goto E6; + } + else // resume iteration + { + P = Q->cd.cv->get (i); // with next element + + // One wrinkle: captured continuations are implemented + // as vectors, and like the machine stack, these vectors + // can contain integer VM codes as well as cell pointers. + // These latter are marked with the ATOM flag. + + if (reinterpret_cast (P) & Cell::ATOM) + goto next_element; + + // Otherwise we mark, if not marked already. + if (P->ca.i & Cell::MARK) + goto next_element; + + P = Cell::untagged (P); + if (P == nil) + goto next_element; + + goto E2; + } + } + else if (Q->type () == Cell::Symbol) + { + // Continue iterating over the property list of a symbol. + psymbol ps = Q->SymbolValue (); + + next_property: + int i = ps->plist->gc_index++; + if (i >= ps->plist->size ()) // all done? + { + T = ps->plist->gc_uplink; + ps->plist->gc_index = 0; + ps->plist->gc_uplink = 0; + P = Q; + goto E6; + } + else + { + P = ps->plist->get (i); + if (P->ca.i & Cell::MARK) + goto next_property; + P = Cell::untagged (P); + if (P == nil) + goto next_property; + goto E2; + } + } + +// if (Q->cd.i & Cell::ATOM) + if (Q->cd.i & Cell::MARK) + { + // Q->cd.i &= ~Cell::ATOM; + Q->cd.i &= ~Cell::MARK; + T = Cell::untagged (Q->ca.p); + Q->gc_set_car (P); + P = Q; + goto E5; + } + else + { + T = Cell::untagged (Q->cd.p); + Q->gc_set_cdr (P); + P = Q; + goto E6; + } + } + +void Slab::sweep (Context * ctx) + { + bool traceall = OS::flag (TRACE_GC_ALL); + + for (Cell * p = start; p < next; ++p) + { + unsigned int word = p->ca.i; + + if (word & Cell::MARK) + { + p->ca.i &= ~Cell::MARK; + } + else if (word != (Cell::FREE|Cell::ATOM)) + { + // FINALIZATION + // + + if (traceall) { printf ("s "); p->dump (stdout); putchar ('\n'); } + Cell::Type t = p->type (); + + switch (t) + { + case Cell::Cont: + case Cell::Promise: + case Cell::Cproc: + case Cell::Cpromise: + case Cell::Lambda: + case Cell::Vec: // Free the vector of cell pointers. + p->cd.cv->free(); + // XXX delete p->cd.cv; + p->cd.cv = 0; + break; + + case Cell::Iport: // Ports hold streams + fclose (p->cd.ip); + break; + + case Cell::Oport: // Ports hold streams + fclose (p->cd.op); + break; + + case Cell::Real: // Reals hold a malloc'd double + free (p->cd.d); + break; + + case Cell::Subr: // Subrs hold a SubrBox + free (p->cd.f); + break; + + case Cell::Magic: // Magic cells hold a MagicBox + free (p->cd.m); + break; + + case Cell::String: // Strings hold StringBoxes + free (p->cd.s); + break; + + default: // Ordinarily cells hold no other storage. + ; + } + + --ctx->cellsAlloc; + p->ca.i = Cell::FREE | Cell::ATOM; + p->cd.p = ctx->mem.free; + ctx->mem.free = p; + ++ctx->mem.c_free; + } + } + } + +void Context::gc () + { + bool gc_verbose = OS::flag (TRACE_GC); + Cell * p; + + if (!ok_to_gc) + { + fprintf (stderr, "initial memory budget insufficient to set up VM\n" + "Try setting the environment variable SLABSIZE to\n" + "something greater than %d\n", Slab::slabsize); + exit (1); + } + if (gc_verbose) + printf ("; start gc: %d/%d\n", cellsAlloc, cellsTotal); + + // + // MARK PHASE + // + // We have to mark everything reachable from the "register machine" + // registers. + + mark (root_envt); + mark (r_env); + mark (Cell::car (&r_argl)); + mark (Cell::cdr (&r_argl)); + mark (Cell::car (&r_varl)); + mark (Cell::cdr (&r_varl)); + mark (r_proc); + mark (r_exp); + mark (r_unev); + mark (r_val); + mark (r_tmp); + mark (r_elt); + mark (r_nu); + mark (cc_procedure); + mark (empty_vector); + + // Mark the things is the compiler VM. + // + + mark (r_cproc); + mark (r_envt); + + // Mark everything reachable from the machine stack. Watch out + // for integers hiding in the machine stack, though! They are + // marked with the ATOM flag. + + for (int ix = 0; ix < m_stack.size (); ++ix) + if ((reinterpret_cast ((p = m_stack [ix])) & Cell::ATOM) == 0) + mark (p); + + // Mark the I/O ports referenced in this environment stack. + + for (int ix = 0; ix < istack.size (); ++ix) + mark (istack [ix]); + for (int ix = 0; ix < ostack.size (); ++ix) + mark (ostack [ix]); + + // Mark the things that "C" implementations of Scheme functions + // have requested protection for. + + for (int ix = 0; ix < r_gcp.size (); ++ix) + mark (r_gcp [ix]); + + // + // SWEEP PHASE + // + + for (int ix = 0; ix < mem.active.size (); ++ix) + ((Slab *) mem.active [ix])->sweep (this); + + // If this mark/sweep phase managed to reduce the cell utilization + // to <= 80% of the allocated cells, we consider that success. On + // the other hand, if the GC produced less than 20% free cells, we + // set a flag which will provoke the allocation of a new slab at + // the next allocation failure. In this way we hope to avoid + // "grinding away" at the last few cells in a slab. + + if ((double) cellsAlloc / cellsTotal > 0.8) + mem.low_water = true; + + if (gc_verbose) + printf ("; end gc: %d/%d %s\n", cellsAlloc, cellsTotal, + mem.low_water ? " low" : " ok"); + } + +void Context::gc_if_needed () + { + if (cellsAlloc >= cellsTotal / 4 * 3) + gc (); + } + +void Context::print_mem_stats (FILE * out) + { + fprintf (out, "; mem %d/%d\n", cellsAlloc, cellsTotal); + } + +void * Context::xmalloc (size_t sz) + { + void * v = malloc (sz); + if (!v) + error ("out of heap memory"); + return v; + } diff --git a/vx-scheme/src/compile b/vx-scheme/src/compile new file mode 100644 index 0000000..fd1861d --- /dev/null +++ b/vx-scheme/src/compile @@ -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 diff --git a/vx-scheme/src/compile-file.scm b/vx-scheme/src/compile-file.scm new file mode 100755 index 0000000..2589fa6 --- /dev/null +++ b/vx-scheme/src/compile-file.scm @@ -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")) + + diff --git a/vx-scheme/src/compiler.scm b/vx-scheme/src/compiler.scm new file mode 100644 index 0000000..ee7494e --- /dev/null +++ b/vx-scheme/src/compiler.scm @@ -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 ). + + (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))) + diff --git a/vx-scheme/src/cp-test.scm b/vx-scheme/src/cp-test.scm new file mode 100644 index 0000000..603923b --- /dev/null +++ b/vx-scheme/src/cp-test.scm @@ -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") +; +; +; diff --git a/vx-scheme/src/ctx.cpp b/vx-scheme/src/ctx.cpp new file mode 100644 index 0000000..7a50516 --- /dev/null +++ b/vx-scheme/src/ctx.cpp @@ -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 ("#"); +ALIGN8 Cell Cell::Unassigned ("#"); +ALIGN8 Cell Cell::Eof_Object ("#"); +ALIGN8 Cell Cell::Bool_T ("#t"); +ALIGN8 Cell Cell::Bool_F ("#f"); +ALIGN8 Cell Cell::Error ("#"); +ALIGN8 Cell Cell::Halt ("#"); +ALIGN8 Cell Cell::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; +} + + diff --git a/vx-scheme/src/interp.cpp b/vx-scheme/src/interp.cpp new file mode 100644 index 0000000..19b1d70 --- /dev/null +++ b/vx-scheme/src/interp.cpp @@ -0,0 +1,1627 @@ +//---------------------------------------------------------------------- +// 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. +// +// interp.cpp : SICP-style R4Rs-compliant Scheme interpreter + +#include "vx-scheme.h" + + +// -------------------------------------------------------------------------- +// Populate the symbol table with builtins. +// + +INTERN_SYM (s_and, "and"); +INTERN_SYM (s_apply, "apply"); +INTERN_SYM (s_begin, "begin"); +INTERN_SYM (s_callcc, "call-with-current-continuation"); +INTERN_SYM (s_callwif, "call-with-input-file"); +INTERN_SYM (s_callwof, "call-with-output-file"); +INTERN_SYM (s_case, "case"); +INTERN_SYM (s_cond, "cond"); +INTERN_SYM (s_define, "define"); +INTERN_SYM (s_defmacro, "defmacro"); +INTERN_SYM (s_delay, "delay"); +INTERN_SYM (s_do, "do"); +INTERN_SYM (s_else, "else"); +INTERN_SYM (s_eval, "eval"); +INTERN_SYM (s_force, "force"); +INTERN_SYM (s_foreach, "for-each"); +INTERN_SYM (s_if, "if"); +INTERN_SYM (s_lambda, "lambda"); +INTERN_SYM (s_let, "let"); +INTERN_SYM (s_letrec, "letrec"); +INTERN_SYM (s_letstar, "let*"); +INTERN_SYM (s_load, "load"); +INTERN_SYM (s_map, "map"); +INTERN_SYM (s_or, "or"); +INTERN_SYM (s_passto, "=>"); +INTERN_SYM (s_set, "set!"); +INTERN_SYM (s_time, "time"); +INTERN_SYM (s_withinput, "with-input-from-file"); +INTERN_SYM (s_withoutput, "with-output-to-file"); + +// -------------------------------------------------------------------------- +// Unsafe Accessors +// +// These are versions of car and cdr that do not check to ensure that +// they are applied to conses. The program can crash if this precondition +// is not meant. They are only safe to use when the implementation can +// guarantee that they are applied to conses (and so we only use them +// on lists that we manage explicitly). + +#define CAR(c) ((c)->ca.p) +#define CDR(c) ((c)->cd.p) + +void Context::bind (Cell * env, Cell * c, Cell * value) + { + cellvector * vec = car (env)->VectorValue (); + psymbol s = c->SymbolValue (); + + if (c->flag (Cell::QUICK) && c->e_skip() == 0) + { + // We have a quick binding, and, as we expect, + // it's within this frame. We can establish + // it without searching. + + int b_skip = c->b_skip(); + int sz = vec->size (); + + if (b_skip == sz) + { + r_nu = cons (c, value); + vec->push (r_nu); + } + else if (b_skip < 0 || b_skip > sz) + error ("internal error: invalid lexical address: ", + c->SymbolValue ()->key); + else + Cell::setcdr (vec->get (b_skip), value); + } + else + { + for (int ix = 0; ix < vec->size (); ++ix) + { + Cell * c = vec->get (ix); + if (car (c)->SymbolValue () == s) + { + Cell::setcdr (c, value); + return; + } + } + // construct new binding element (being carful that + // intermediate material is reachable from the register + // set. + r_nu = make_symbol (s); + r_nu = cons (r_nu, value); + vec->push (r_nu); + } + } + +// This is a list of "states" the evaluator can be in. The names +// were chosen to harmonize with those chosen in SICP. + +enum { + eval_dispatch, + eval_complete, + ev_application, ev_application2, + ev_args1, ev_args2, + ev_sequence, + ev_sequence_continue, + apply_dispatch, apply_dispatch2, + ev_if, + ev_if_decide, + ev_finish, + ev_define, + ev_define_1, + ev_eval, + ev_eval1, + ev_set, + ev_set_1, + ev_or, ev_or2, + ev_and, ev_and2, + macro_subst, + ev_let, + ev_let_init, + let_accumulate_binding, + ev_letstar, + ev_letstar_init, + ev_letstar_bind, + ev_do, + ev_do_init, + ev_do_bind, + ev_do_test, + ev_after_test, + ev_do_step, + ev_step_1, + ev_step_bind, + ev_step_finish, + ev_do_step_2, + ev_cond, + ev_cond_test, + ev_apply, + ev_apply2, + ev_apply3, + macro_subst2, + ev_cond_passto, + ev_quasiquote, ev_unquote, ev_qq0, ev_qq1, ev_qq2, ev_qq3, + ev_qq_decrease, ev_qqd_1, ev_qq_finish, + ev_apply4, + ev_unq_spl, + ev_unq_spl2, + ev_letrec, ev_letrec1, ev_letrec2, + ev_case, ev_case2, + ev_foreach, ev_foreach1, ev_foreach2, ev_foreach3, ev_foreach4, + ev_force, ev_force2, + ev_map, ev_map1, ev_map2, ev_map3, + ev_withinput, ev_withinput1, ev_withinput2, + ev_withoutput, ev_withoutput1, ev_withoutput2, + ev_load, ev_load2, ev_callwof, ev_callwof2, ev_time, ev_time1, + }; + +// These are the above states in string form. This is only used +// for debugging, to dump the evaluator's state transitions. + +static const char * state_name [] = + { + "eval_dispatch", + "eval_complete", + "ev_application", "ev_application2", + "ev_args1", "ev_args2", + "ev_sequence", + "ev_sequence_continue", + "apply_dispatch", "apply_dispatch2", + "ev_eval", "ev_eval1", + "ev_if", + "ev_if_decide", + "ev_finish", + "ev_define", + "ev_define_1", + "ev_set", + "ev_set_1", + "ev_or", "ev_or2", + "ev_and", "ev_and2", + "macro_subst", + "ev_let", + "ev_let_init", + "let_accumulate_binding", + "ev_letstar", + "ev_letstar_init", + "ev_letstar_bind", + "ev_do", + "ev_do_init", + "ev_do_bind", + "ev_do_test", + "ev_after_test", + "ev_do_step", + "ev_step_1", + "ev_step_bind", + "ev_step_finish", + "ev_do_step_2", + "ev_cond", + "ev_cond_test", + "ev_apply", + "ev_apply2", + "ev_apply3", + "macro_subst2", + "ev_cond_passto", + "ev_quasiquote", "ev_unquote", "ev_qq0", "ev_qq1", "ev_qq2", "ev_qq3", + "ev_qq_decrease", "ev_qqd_1", "ev_qq_finish", + "ev_apply4", + "ev_unq_spl", + "ev_unq_spl2", + "ev_letrec", "ev_letrec1", "ev_letrec2", + "ev_case", "ev_case2", + "ev_foreach", "ev_foreach1", "ev_foreach2", "ev_foreach3", "ev_foreach4", + "ev_force", "ev_force2", + "ev_map", "ev_map1", "ev_map2", "ev_map3", + "ev_withinput", "ev_withinput2", "ev_withoutput", "ev_withoutput2", + "ev_load", "ev_load2", "ev_callwof", "ev_callwof2", "ev_time", "ev_time1", + }; + +// Here it is: a >1000 line function that consists of a giant switch +// statement, and it's peppered with goto's! +// +// This would be inexcusable, except it has to do its job (evaulation +// Scheme expressions) without using the C stack as a resource. This +// could be thought of as a sort of microcode, using a set of virtual +// machine registers (r_exp, r_unev, etc.: the uses of these registers +// is described in SICP). +// +// I've followed this approach because I wanted to be able to capture +// continuations and collect garbage without having to know any details +// about how the C stack operates. This evaluator is somewhat more +// complicated than the one described in SICP since it supports many +// language features not discussed in that chapter. +// +// For these reasons, eval should not be recursed into by anyone, +// including itself. + +Cell* Context::interp_evaluator(Cell * form) + { + psymbol s; + Cell::Type t; + Cell::Procedure lambda; + int flag = 0; + double t1; + bool trace; + psymbol p; + sstring read_sstr; + init_machine (); + state = eval_dispatch; + r_cont = eval_complete; + r_exp = form; + r_qq = 0; + trace = OS::flag (TRACE_EVAL); + +#define GOTO(x) do { \ + state = x; \ + goto TOP; \ + } while (0) + +#define EVAL_DISPATCH() do { \ + if (r_exp == nil) \ + { \ + r_val = nil; \ + GOTO (r_cont); \ + } \ + Cell::Type __t = (r_exp)->type(); \ + if (__t == Cell::Cons) \ + GOTO (ev_application); \ + if (__t == Cell::Symbol) \ + r_val = get (r_env, r_exp); \ + else \ + r_val = r_exp; \ + GOTO (r_cont); \ + } while (0) + +#define RETURN_VALUE(v) do { \ + r_val = (v); \ + restore (r_cont); \ + GOTO (r_cont); \ + } while (0) + + +// If the exp is self-evaluating or a variable, handle it +// immediately. Else call eval_dispatch in a context +// where r_env end r_unev are saved/restored. + +#define CALL_EVAL(label) \ + t = (r_exp)->type(); \ + if (t == Cell::Symbol) \ + { \ + r_val = get (r_env, r_exp); \ + goto label##__2; \ + } \ + else if (t != Cell::Cons) \ + { \ + r_val = r_exp; \ + goto label##__2; \ + } \ + else \ + { \ + save (r_env); \ + save (r_unev); \ + r_cont = label; \ + GOTO (eval_dispatch); \ + } \ + case label: \ + restore (r_unev); \ + restore (r_env); \ + label##__2: + +TOP: + + if (trace) + print_vm_state (); + + switch (state) + { + case eval_dispatch: + + if (r_exp == nil) + { + r_val = nil; + GOTO (r_cont); + } + + switch (r_exp->type ()) + { + case Cell::Symbol: + r_val = get (r_env, r_exp); + GOTO (r_cont); + case Cell::Cons: + GOTO (ev_application); + default: // self-evaluating + r_val = r_exp; + GOTO (r_cont); + } + + case eval_complete: + return r_val; + + case ev_application: + save (r_cont); + r_unev = cdr (r_exp); + r_exp = car (r_exp); + CALL_EVAL (ev_application2); + r_proc = r_val; + + case apply_dispatch: + + if (!r_proc->flag (Cell::MACRO)) + { + // It's not a special form: evaluate all the arguments + // in unev and collect them into r_argl. + + clear (r_argl); + save (r_proc); + + case ev_args1: + if (r_unev == nil) + { + restore (r_proc); + GOTO (apply_dispatch2); + } + + save (r_argl); + r_exp = car (r_unev); + r_unev = cdr (r_unev); + CALL_EVAL (ev_args2); + restore (r_argl); + l_append (r_argl, r_val); + GOTO (ev_args1); + } + + case apply_dispatch2: + + switch (r_proc->type ()) + { + case Cell::Builtin: + // ================================================= + // THE BUILTIN SPECIAL FORMS + // ================================================= + + s = r_proc->BuiltinValue (); + + if (s == s_if) GOTO (ev_if); + else if (s == s_define) GOTO (ev_define); + else if (s == s_begin) GOTO (ev_sequence); + else if (s == s_set) GOTO (ev_set); + else if (s == s_let) GOTO (ev_let); + else if (s == s_letstar) GOTO (ev_letstar); + else if (s == s_letrec) GOTO (ev_letrec); + else if (s == s_do) GOTO (ev_do); + else if (s == s_cond) GOTO (ev_cond); + else if (s == s_case) GOTO (ev_case); + else if (s == s_eval) GOTO (ev_eval); + else if (s == s_foreach) GOTO (ev_foreach); + else if (s == s_load) GOTO (ev_load); + else if (s == s_map) GOTO (ev_map); + else if (s == s_apply) GOTO (ev_apply); + else if (s == s_force) GOTO (ev_force); + else if (s == s_quote) r_val = car (r_unev); + else if (s == s_or) { r_val = &Cell::Bool_F; + GOTO (ev_or); } + else if (s == s_and) { r_val = &Cell::Bool_T; + GOTO (ev_and); } + else if (s == s_delay) r_val = make_promise (r_env, + r_unev); + else if (s == s_quasiquote) { r_unev = car (r_unev); + GOTO (ev_quasiquote); } + else if (s == s_lambda) r_val = make_procedure + (r_env, cdr (r_unev), + car (r_unev)); + else if (s == s_defmacro) { r_proc = make_macro (r_env, + cdr (r_unev), + cdar (r_unev)); + bind (r_env, caar (r_unev), + r_proc); + r_val = unspecified; } + else if (s == s_time) GOTO (ev_time); + else if (s == s_withinput) GOTO (ev_withinput); + else if (s == s_withoutput) GOTO (ev_withoutput); + else if (s == s_callwof) GOTO (ev_callwof); + else if (s == s_callwif) + { + r_proc = Cell::cadar (&r_argl); + r_tmp = make_iport (Cell::caar (&r_argl)->StringValue ()); + r_tmp = cons (r_tmp, nil); + Cell::setcar (&r_argl, r_tmp); + GOTO (apply_dispatch2); + } + else if (s == s_callcc) + { + r_proc = Cell::caar (&r_argl); + r_tmp = make_continuation (); + r_tmp = cons (r_tmp, nil); + Cell::setcar (&r_argl, r_tmp); + GOTO (apply_dispatch2); + } + else + error ("unimplemented builtin ", s->key); + break; + + case Cell::Subr: + r_val = r_proc->SubrValue ()->subr (this, + Cell::car (&r_argl)); + break; + + case Cell::Lambda: + lambda = r_proc->LambdaValue (); + + if (r_proc->flag (Cell::MACRO)) + { + save (r_env); + + r_env = extend (lambda.envt); + bind_arguments (r_env, lambda.arglist, r_unev); + save (macro_subst); // continuation + } + else + { + r_env = extend (lambda.envt); + bind_arguments (r_env, lambda.arglist, + Cell::car (&r_argl)); + } + + r_unev = lambda.body; + GOTO (ev_sequence); + + case Cell::Cont: + r_val = Cell::caar(&r_argl); + load_continuation (r_proc); + break; + + case Cell::Cproc: + if (vm_execute) { + (this->*vm_execute) (r_proc, Cell::car (&r_argl)); + } else { + error ("VM not loaded: can't dispatch a compiled procedure"); + } + break; + + default: + r_proc->dump (stdout); + error ("can't dispatch one of those."); + } + + restore (r_cont); + GOTO (r_cont); + + case ev_eval: + // The eval special form. (Can't let eval recurse, so + // we take care of it here in the VM). + + r_exp = Cell::caar (&r_argl); + save (r_env); + r_env = root_envt; + CALL_EVAL (ev_eval1); + restore (r_env); + RETURN_VALUE (r_val); + + case ev_time: + // Call the supplied procedure while timing it. + // Return a cons of the elapsed time and the proc's + // value. + + r_proc = Cell::caar(&r_argl); + + clear(r_argl); + save(make_real(OS::get_time())); + save(ev_time1); // cont + GOTO(apply_dispatch2); + + case ev_time1: + + t1 = OS::get_time(); + restore(r_tmp); + r_tmp = make_real(t1 - r_tmp->RealValue()); + RETURN_VALUE (cons (r_tmp, r_val)); + + case ev_sequence: + r_exp = car (r_unev); + + if (r_exp == nil) + RETURN_VALUE (unspecified); + + if (cdr (r_unev) == nil) + { + restore (r_cont); + EVAL_DISPATCH (); + } + + CALL_EVAL (ev_sequence_continue); + + r_unev = cdr (r_unev); + GOTO (ev_sequence); + + // ev_if, etc., is a deviation from the presentation in SICP. + // In brief we are not dispatched by syntax analysis, but by + // finding a Builtin in the functor position. We get here via + // apply dispatch. Our job is to compute `r_val', pop the + // continuation and branch there. + // + // Had we followed SICP strictly, then special forms like + // "if" would have no visible definition at all, and could + // never be redefined. Most Scheme interpretations do allow + // for the redefinition of builtin symbols. Hence we use + // builtins as a sort of "flag" that invokes the internal + // sytnax-directed implementation to proceed. + + case ev_if: + r_exp = car (r_unev); + r_unev = cdr (r_unev); + CALL_EVAL (ev_if_decide); + + restore (r_cont); + + if (r_val->istrue ()) + { + r_exp = car (r_unev); + EVAL_DISPATCH (); + } + else + { + if ((r_exp = cdr (r_unev)) != nil) + { + r_exp = car (r_exp); + EVAL_DISPATCH (); + } + else + { + r_val = unspecified; + GOTO (r_cont); + } + } + + case ev_define: + r_tmp = car (r_unev); + + if (r_tmp->type () == Cell::Symbol) + { + save (r_env); + save (r_unev); + r_exp = cadr (r_unev); + r_cont = ev_define_1; + EVAL_DISPATCH (); + } + else + { + r_proc = make_procedure (r_env, cdr (r_unev), cdr (r_tmp)); + bind (r_env, car (r_tmp), r_proc); + RETURN_VALUE (unspecified); + } + + case ev_define_1: + restore (r_unev); + restore (r_env); + bind (r_env, car (r_unev), r_val); + RETURN_VALUE (unspecified); + + case ev_set: + r_exp = cadr (r_unev); + CALL_EVAL (ev_set_1); + + set (r_env, car (r_unev), r_val); + RETURN_VALUE (unspecified); + + case ev_or: + if (r_unev == nil || r_val->istrue ()) + { + restore (r_cont); + GOTO (r_cont); + } + + r_exp = car (r_unev); + CALL_EVAL (ev_or2); + r_unev = cdr (r_unev); + GOTO (ev_or); + + case ev_and: + if (r_unev == nil || !r_val->istrue ()) + { + restore (r_cont); + GOTO (r_cont); + } + + r_exp = car (r_unev); + CALL_EVAL (ev_and2); + r_unev = cdr (r_unev); + GOTO (ev_and); + + case macro_subst: + + // The macro has been expanded. One more trip through + // eval, please. + + restore (r_env); + restore (r_cont); + r_exp = r_val; + EVAL_DISPATCH (); + + case ev_let: + // (let [name?] ((v e) ...) x...) + // The plan is to accumulate the list of variables (v) in + // r_varl, and the list of initializers (e) in r_argl. + + if (car (r_unev)->type () == Cell::Symbol) + { + r_proc = car (r_unev); // named let: stash in r_proc + r_unev = cdr (r_unev); + } + else + r_proc = nil; + + clear (r_argl); + clear (r_varl); + + if (car (r_unev) == nil) + { + r_unev = cdr (r_unev); // (let () x...) + r_env = extend (r_env); + goto let_noargs; + } + + save (r_proc); + save (cdr (r_unev)); + r_unev = car (r_unev); // fall through + + case ev_let_init: + save (r_argl); + save (r_varl); + r_exp = cadar (r_unev); + + CALL_EVAL (let_accumulate_binding); + + restore (r_varl); + restore (r_argl); + + l_append (r_varl, caar (r_unev)); + l_append (r_argl, r_val); + r_unev = cdr (r_unev); + if (r_unev == nil) + { + restore (r_unev); + restore (r_proc); + let_noargs: + if (r_proc != nil) + { + r_env = extend (r_env); + r_tmp = make_procedure (r_env, + r_unev, + Cell::car (&r_varl)); + bind (r_env, r_proc, r_tmp); + } + r_env = extend (r_env); + bind_arguments (r_env, + Cell::car (&r_varl), + Cell::car (&r_argl)); + GOTO (ev_sequence); + } + + GOTO (ev_let_init); + + case ev_letstar: + // (let* ((v e) ...) x1 ...) + // We unpack, bind, and extend in a loop, until we're + // ready for the sequence. + if (car (r_unev) == nil) + { + r_env = extend (r_env); + r_unev = cdr (r_unev); + GOTO (ev_sequence); + } + + save (cdr (r_unev)); + r_unev = car (r_unev); + + /* fall thru */ + + case ev_letstar_init: + save (r_env); + save (r_unev); + r_exp = cadar (r_unev); + r_cont = ev_letstar_bind; + EVAL_DISPATCH (); + + case ev_letstar_bind: + restore (r_unev); + restore (r_env); + r_env = extend (r_env); + bind (r_env, caar (r_unev), r_val); + r_unev = cdr (r_unev); + if (r_unev == nil) + { + restore (r_unev); + GOTO (ev_sequence); + } + + GOTO (ev_letstar_init); + + case ev_letrec: + // we have: (((v1 i1) (v2 i2)...) x1 x2...) + clear (r_varl); + clear (r_argl); + save (cdr (r_unev)); + + r_env = extend (r_env); + for (r_exp = car (r_unev); r_exp != nil; r_exp = cdr (r_exp)) + { + l_append (r_varl, caar (r_exp)); + bind (r_env, caar (r_exp), &Cell::Error); + } + + save (r_varl); + r_unev = car (r_unev); + + case ev_letrec1: + if (r_unev != nil) + { + r_exp = cadar (r_unev); + save (r_argl); + CALL_EVAL (ev_letrec2); + restore (r_argl); + l_append (r_argl, r_val); + r_unev = cdr (r_unev); + GOTO (ev_letrec1); + } + + restore (r_varl); + restore (r_unev); + bind_arguments (r_env, Cell::car (&r_varl), Cell::car (&r_argl)); + GOTO (ev_sequence); + + case ev_do: + // (do ((var init step)...) (test x...) y...) + // Like let, accumulate variables (v) and + // initializers (i) into r_varl and r_argl. + + save (r_unev); // (((var init step)...) (test x...) y...) + r_unev = car (r_unev); // ((var init step)...) + clear (r_argl); + clear (r_varl); + /* fall through */ + + case ev_do_init: + save (r_argl); + save (r_varl); + save (r_env); + save (r_unev); + r_exp = cadar (r_unev); + r_cont = ev_do_bind; + EVAL_DISPATCH (); + + case ev_do_bind: + restore (r_unev); + restore (r_env); + restore (r_varl); + restore (r_argl); + + l_append (r_varl, caar (r_unev)); + l_append (r_argl, r_val); + r_unev = cdr (r_unev); + + if (r_unev == nil) + { + // All done with inits. Create environment and start testing. + r_env = extend (r_env); + bind_arguments (r_env, + Cell::car (&r_varl), + Cell::car (&r_argl)); + restore (r_unev); // (((var init step)...) (test x...) y...) + GOTO (ev_do_test); + } + + GOTO (ev_do_init); + + case ev_do_test: + r_exp = caadr (r_unev); + CALL_EVAL (ev_after_test); + + if (r_val->istrue ()) + { + // test passed: end iteration. Evaulate + // `x' expressions as a sequence. + + r_unev = cdadr (r_unev); + + if (r_unev == nil) // no consequent expressions? + RETURN_VALUE (unspecified); + + GOTO (ev_sequence); + } + + // otherwise, evaluate the y expressions for effect, if there + // are any + + if (cddr (r_unev) == nil) + GOTO (ev_do_step_2); + + save (r_unev); + save (r_env); + r_unev = cddr (r_unev); + save (ev_do_step); + GOTO (ev_sequence); + + case ev_do_step: + // then use the step expressions (if any) to rebind the + // variables, and retest. + + restore (r_env); + restore (r_unev); // (((var init step)...) (test x...) y...) + + case ev_do_step_2: + save (r_unev); + r_unev = car (r_unev); // ((var init step) ...) + clear (r_argl); + clear (r_varl); + /* fall through */ + + case ev_step_1: + if (r_unev == nil) + { + // all done. + + GOTO (ev_step_finish); + } + + r_tmp = cddar (r_unev); + if (r_tmp == nil) + { + r_unev = cdr (r_unev); + GOTO (ev_step_1); + } + + + save (r_argl); + save (r_varl); + r_exp = caddar (r_unev); + CALL_EVAL (ev_step_bind); + + restore (r_varl); + restore (r_argl); + + l_append (r_varl, caar (r_unev)); + l_append (r_argl, r_val); + r_unev = cdr (r_unev); + GOTO (ev_step_1); + + case ev_step_finish: + bind_arguments (r_env, Cell::car (&r_varl), Cell::car (&r_argl)); + restore (r_unev); + GOTO (ev_do_test); + + case ev_cond: + if (r_unev == nil) + RETURN_VALUE (unspecified); + + r_exp = caar (r_unev); // t1 + if (r_exp->is_symbol (s_else)) + r_val = &Cell::Bool_T; + else + { + r_cont = ev_cond_test; + CALL_EVAL (ev_cond_test); + } + + if (r_val->istrue ()) + { + r_unev = cdar (r_unev); + r_tmp = car (r_unev); + + // Check for "=> r_proc" syntax + if (r_tmp->is_symbol (s_passto)) + { + // We already have the argument. Now, evaluate + // r_proc, so we can apply it. + + save (r_val); + r_unev = cdr (r_unev); + r_exp = car (r_unev); + + CALL_EVAL (ev_cond_passto); + + r_proc = r_val; + restore (r_val); + Cell::setcar (&r_argl, cons (r_val, nil)); + GOTO (apply_dispatch2); + } + + GOTO (ev_sequence); + } + + r_unev = cdr (r_unev); + GOTO (ev_cond); + + case ev_apply: + // we have, e.g., (apply + 1 2 '(3 4)) + // and we want (+ 1 2 3 4). + + r_proc = Cell::caar(&r_argl); // peel off r_proc + r_tmp = Cell::cdar(&r_argl); + clear (r_argl); + + for (; r_tmp != nil; r_tmp = cdr (r_tmp)) + if (cdr (r_tmp) == nil) // fold the list + l_appendtail (r_argl, car (r_tmp)); + else + l_append (r_argl, car (r_tmp)); + + GOTO (apply_dispatch2); + + case ev_quasiquote: + // If it's a vector, convert it to a list and + // save a flag. + + ++r_qq; + t = r_unev->type (); + + if (t == Cell::Vec) + { + save (1); + r_unev = vector_to_list (this, cons (r_unev, nil)); // yyy + } + else + save (0); + + save (ev_qq_finish); + r_val = nil; + + case ev_qq0: + + t = r_unev->type (); + if (t == Cell::Cons) + { + r_exp = car (r_unev); + + if (r_exp->type () == Cell::Symbol) + { + p = r_exp->SymbolValue (); + + if (p == s_unquote) // unquote: evaluate sequel. + { + if (r_qq == 1) + { + r_exp = cadr (r_unev); + --r_qq; + CALL_EVAL (ev_unquote); + ++r_qq; + } + else + { + r_tmp = make_symbol (s_unquote); + save (r_tmp); + GOTO (ev_qq_decrease); + } + } + else if (p == s_quasiquote) // increase QQ level. + { + r_unev = cdr (r_unev); + save (ev_qq1); + GOTO (ev_quasiquote); + case ev_qq1: + r_tmp = make_symbol (s_quasiquote); + r_val = cons (r_tmp, r_val); + } + else + goto QQCONS; + } + + else if (r_exp->type () == Cell::Cons && + car (r_exp)->is_symbol (s_unquote_splicing)) + { + if (r_qq == 1) + { + // unquote_splicing: generate list, and splice it + // in. First evaluate to get the list. + + r_exp = cadr (r_exp); + r_unev = cdr (r_unev); + CALL_EVAL (ev_unq_spl); + + // r_val holds the list. Install it into r_argl + // (tracking head and tail). Then evaluate + // what follows. + + r_tmp = r_val; + while (cdr (r_tmp) != nil) + r_tmp = cdr (r_tmp); + + Cell::setcar(&r_argl, r_val); + Cell::setcdr(&r_argl, r_tmp); + + save (r_argl); + r_exp = r_unev; + save (ev_unq_spl2); + GOTO (ev_qq0); + } + else + { + r_tmp = make_symbol (s_unquote_splicing); + save (r_tmp); + GOTO (ev_qq_decrease); + } + + case ev_unq_spl2: + restore (r_argl); + l_appendtail (r_argl, r_val); + r_val = Cell::car(&r_argl); + } + else if (r_unev == nil) + r_val = nil; + else + { + QQCONS: // "move quasiquotation inward" + save (cdr (r_unev)); // cons (qq (car), qq (cdr)) + save (ev_qq2); // new continuation + r_unev = r_exp; + GOTO (ev_qq0); + case ev_qq2: + restore (r_unev); + save (r_val); + save (ev_qq3); + GOTO (ev_qq0); + case ev_qq3: + restore (r_exp); + r_val = cons (r_exp, r_val); + } + } + else + r_val = r_unev; // atoms are self-evaluating + + restore (r_cont); + GOTO (r_cont); + + case ev_qq_finish: // finished. reconvert to + restore (flag); // vector form if necessary. + if (flag) + r_val = vector_from_list (this, r_val); + --r_qq; + restore (r_cont); + GOTO (r_cont); + + case ev_qq_decrease: + // we get here because we saw unquote or unquote_splicing, + // and we want to proceed with a decreased qq level instead + // of evaluating it (because the qq level was too high + // when we encountered the form). + + --r_qq; + r_unev = cdr (r_unev); + save (ev_qqd_1); + GOTO (ev_qq0); + case ev_qqd_1: + restore (r_exp); // recover head symbol + ++r_qq; + RETURN_VALUE (cons (r_exp, r_val)); + + case ev_case: + // (key ((d1 d2...) x1 x2...) ((d3 d4...) x3 x4...)) + // evaluate key, and shift it away. + + r_exp = car (r_unev); + r_unev = cdr (r_unev); + CALL_EVAL (ev_case2); + + for (; r_unev != nil; r_unev = cdr (r_unev)) + { + r_exp = car (r_unev); + r_tmp = car (r_exp); + + if (r_tmp->is_symbol (s_else)) + { + r_unev = cdr (r_exp); + GOTO (ev_sequence); + } + for (; r_tmp != nil; r_tmp = cdr (r_tmp)) + { + if (r_val->eq (car (r_tmp))) + { + r_unev = cdr (r_exp); + GOTO (ev_sequence); + } + } + } + + RETURN_VALUE (unspecified); + + case ev_foreach: + r_proc = Cell::caar(&r_argl); // (r_proc list...) + r_unev = Cell::cdar(&r_argl); + + case ev_foreach1: + if (car (r_unev) == nil) + RETURN_VALUE (unspecified); + + clear (r_argl); + for (r_tmp = r_unev; r_tmp != nil; r_tmp = cdr (r_tmp)) + { + l_append (r_argl, caar (r_tmp)); + Cell::setcar (r_tmp, cdar (r_tmp)); + } + + save (r_unev); + save (r_proc); + save (ev_foreach2); + GOTO (apply_dispatch2); + case ev_foreach2: + restore (r_proc); + restore (r_unev); + GOTO (ev_foreach1); + + case ev_map: + r_proc = Cell::caar (&r_argl); + // copy r_argl to r_unev (less the first elt., which was the r_proc) + r_unev = Cell::cdar (&r_argl); + clear (r_varl); + + case ev_map1: + if (car (r_unev) == nil) // no more arguments + GOTO (ev_map3); + + clear (r_argl); + for (r_tmp = r_unev; r_tmp != nil; r_tmp = cdr (r_tmp)) + { + l_append (r_argl, caar (r_tmp)); + Cell::setcar (r_tmp, cdar (r_tmp)); + } + + save (r_varl); + save (r_unev); + save (r_proc); + save (ev_map2); + GOTO (apply_dispatch2); + case ev_map2: + restore (r_proc); + restore (r_unev); + restore (r_varl); + l_append (r_varl, r_val); + GOTO (ev_map1); + + case ev_map3: + RETURN_VALUE (Cell::car (&r_varl)); + + case ev_force: + r_exp = Cell::caar (&r_argl); + if (r_exp->flag (Cell::FORCED)) + r_val = r_exp->cd.cv->get (0); // return memoized value + else + { + // If we haven't forced the promise yet, then the cdr + // is pointing to a unit vector containing the + // procedure we must evaluate to get the value, which + // we then memoize. + + clear (r_argl); + r_proc = r_exp->cd.cv->get (0); + save (r_exp); + save (ev_force2); + GOTO (apply_dispatch2); + case ev_force2: + // Now, it can happen that the procedure we're + // invoking can force its own value. If we find that + // the FORCED flag has magically become set as a + // result of forcing, then we must accept that earlier + // computation (we are "higher" on the evaluation + // stack)... + + restore (r_exp); + if (r_exp->flag (Cell::FORCED)) + r_val = r_exp->cd.cv->get (0); + else + { + r_exp->cd.cv->set (0, r_val); + r_exp->flag (Cell::FORCED, true); + } + + } + + restore (r_cont); + GOTO (r_cont); + + case ev_withinput: + // (filename proc) + + with_input (Cell::caar (&r_argl)->StringValue ()); + r_proc = Cell::cadar (&r_argl); + clear (r_argl); + save (ev_withinput2); // continuation + GOTO (apply_dispatch2); + + case ev_withinput2: + without_input (); + restore (r_cont); + GOTO (r_cont); + + case ev_withoutput: + with_output (Cell::caar (&r_argl)->StringValue ()); + r_proc = Cell::cadar (&r_argl); + clear (r_argl); + save (ev_withoutput2); // continuation + GOTO (apply_dispatch2); + + case ev_withoutput2: + without_output (); + restore (r_cont); + GOTO (r_cont); + + case ev_load: + r_unev = make_iport (Cell::caar (&r_argl)->StringValue ()); + save (r_unev); // let r_unev hold input stream + save (r_env); + + case ev_load2: + restore (r_env); + restore (r_unev); + r_exp = read (r_unev->IportValue ()); + if (r_exp) + { + save (r_unev); + save (r_env); + r_env = root_envt; // read files into global scope + r_cont = ev_load2; // loop + EVAL_DISPATCH (); + } + r_exp = nil; + RETURN_VALUE (r_val); + + case ev_callwof: + r_proc = Cell::cadar (&r_argl); + r_unev = make_oport (Cell::caar (&r_argl)->StringValue ()); + Cell::setcar (&r_argl, cons (r_unev, nil)); + save (r_unev); + save (ev_callwof2); // cont + GOTO (apply_dispatch2); + + case ev_callwof2: + restore (r_unev); + fflush (r_unev->OportValue ()); + RETURN_VALUE (r_val); + + default: + printf ("IC = %x\n", state); + error ("internal: invalid continuation"); + } + + return unimplemented; + } + +void Context::print_vm_state () + { + printf ("%d %s exp=", m_stack.size (), state_name [state]); + r_exp->write (stdout); + printf (" unev="); + r_unev->write (stdout); + printf (" proc="); + r_proc->write (stdout); + printf (" val="); + r_val->write (stdout); + printf (" argl="); + Cell::car (&r_argl)->write (stdout); + printf (" varl="); + Cell::car (&r_varl)->write (stdout); + printf (" env="); + if (r_env == root_envt) + printf ("#"); + else + Cell::car (r_env)->write (stdout); + + printf (" cont=%s q%d\n", state_name [r_cont], r_qq); + } + +void Context::bind_arguments (Cell * env, Cell * variables, Cell * values) + { + Cell * var; + Cell * val; + + if (variables->type () == Cell::Cons) + { + for (var = variables, val = values; + var != nil; + var = cdr (var), val = cdr (val)) + { + bind (env, car (var), car (val)); + + if (cdr (var)->type () == Cell::Symbol) + { + // Implement "dotted tail" procedure call. If + // the cdr of var is another symbol, then this + // was to the right of the "dot"; put all the rest + // of the arguments in there. [SICP 2ed. p. 104, 183n; + // R5RS 4.1.4] + + bind (env, cdr (var), cdr (val)); + break; + } + } + } + else + { + // "varargs" version: (lambda args body...) + + bind (env, variables, values); + } + } + +Cell * Context::get (Cell * env, Cell * c) + { + c->typecheck (Cell::Symbol); + Cell * pResult = find (env, c); + + if (! pResult || ! CDR (pResult)) + error ("unbound variable ", c->SymbolValue ()->key); + + Cell * res = CDR (pResult); + + if (res->type () == Cell::Magic) + return res->cd.m->get_f (this, res->cd.vp); + else + return res; + } + +void Context::set (Cell * env, Cell * var, Cell * value) + { + Cell * target = find (env, var); + Cell * d; + psymbol s = var->SymbolValue (); + + if (! target) + error ("unbound variable ", s->key); + + if ((d = cdr (target)) && d->type () == Cell::Magic) + d->cd.m->set_f (this, d->cd.vp, value); + else + Cell::setcdr (target, value); + } + +Cell * Context::find (Cell * env, Cell * c) + { + int e_count = 0; + int b_count = 0; + psymbol s = c->SymbolValue (); + Cell * e = env; + Cell * val; + + if (c->flag (Cell::QUICK)) + { + int e_skip = c->e_skip (); + int b_skip = c->b_skip (); + + if (e_skip == Cell::GLOBAL_ENV) + { + // Target environment is root envt. + e = root_envt; + e_count = e_skip; + } + else + { + // Skip the indicated number of environments. + for (e_count = 0; (e != nil) && (e_count < e_skip); ++e_count) + e = CDR (e); + } + + cellvector * v = CAR (e)->VectorValue (); + + if ( b_skip < 0 + || b_skip >= v->size () + || e_skip != e_count + ) + { + printf ("b=%d, e=%d, ec=%d, vs=%d\n", b_skip, e_skip, e_count, + v->size ()); + error ("internal error: invalid lexical address: ", s->key); + } + // Go directly to the binding. + return v->get (b_skip); + } + + // Consider each environment in the enclosure chain + // in turn, counting them as we go. + + for (e_count = 0; e != nil; ++e_count, e = CDR (e)) + { + cellvector * v = CAR (e)->VectorValue (); + // Check the current environment. + + for (b_count = 0; b_count < v->size (); ++b_count) + if (CAR (v->get (b_count))->SymbolValue () == s) + { + if (e == root_envt) + { + // Top-level environment. Due to nested defines, + // this turns out to be a special case. + e_count = -1; + } + + quicken (c, e_count, b_count); + return v->get (b_count); + } + } + + // Can the OS magically supply a value?? + + if ((val = OS::undef (this, s->truename))) + { + // Yes! The OS has produced a value. We cache + // it in the outermost environment, as if it + // had been established there with (define). + + Cell * os_binding = cons (c, val); + car (root_envt)->VectorValue ()->push (os_binding); + return os_binding; + } + + // Failure. + return 0; + } + +void Context::quicken (Cell * c, int e_count, int b_count) + { + // For global symbols, we have 16 bits of b_skip to work with; + // only 8 if the symbol is not in the global environment. + // XXX: these are magic numbers and should be coordinated with + // the .h file. + + if (e_count >= 0) + { + if (e_count > 254 || b_count > 254) + return; + } + else if (b_count > 65534) + return; + + c->set_lexaddr (e_count, b_count); + } + +Cell * Context::make_procedure (Cell * e, Cell * body, Cell * arglist) + { + Cell * c = alloc (Cell::Lambda); + // XXX cellvector * cv = new cellvector (3); + cellvector* cv = cellvector::alloc(3); + + c->cd.cv = cv; + c->flag (Cell::VREF, true); + cv->set (0, e); + cv->set (1, body); + cv->set (2, arglist); + + return c; + } + +Cell * Context::make_macro (Cell * e, Cell * body, Cell * arglist) + { + Cell * c = make_procedure (e, body, arglist); + c->flag (Cell::MACRO, true); + return c; + } + +Cell * Context::make_promise (Cell * e, Cell * body) + { + Cell * c = alloc (Cell::Promise); + cellvector *cv = cellvector::alloc(1); + + // Now it may seem odd to allocate a vector of one element to + // store the content of the promise. But, our garbage collector + // only knows how to traverse two kinds of entities: (1) conses, + // consisting of a car and cdr and (2) vectors. Since we're not a + // cons, but contain a reference to either the procedure that will + // compute the promise or that procedure's memoized value, we must + // store that thing in a unit vector. + + c->cd.cv = cv; + c->flag (Cell::VREF, true); + gc_protect (c); + cv->set (0, make_procedure (e, body, nil)); + gc_unprotect (); + return c; + } + +Cell * Context::make_list1 (Cell * e1) + { + return cons (e1, nil); + } + +Cell * Context::make_list2 (Cell * e1, Cell * e2) + { + return cons (e1, make_list1 (e2)); + } + +Cell * Context::make_list3 (Cell * e1, Cell * e2, Cell * e3) + { + return cons (e1, make_list2 (e2, e3)); + } + +Cell * Context::make_continuation () + { + Cell * c = alloc (Cell::Cont); + + // Allocate a cellvector to hold the continutation (saved + // machine stack). + + int msize = m_stack.size (); + cellvector* cv = cellvector::alloc(msize); + c->flag (Cell::VREF, true); + c->cd.cv = cv; + + for (int ix = 0; ix < msize; ++ix) + cv->set (ix, m_stack [ix]); + + return c; + } + +void Context::load_continuation (Cell * cont) + { + cont->typecheck (Cell::Cont); + + cellvector * cv = cont->cd.cv; + int msize = cv->size (); + + m_stack.clear(); + for (int ix = 0; ix < msize; ++ix) + save (cv->get (ix)); + } + +class InterpreterExt : SchemeExtension +{ +public: + InterpreterExt () { + Register (this); + } + virtual void Install (Context * ctx, Cell * envt) { + // Hook in the function pointer to the interpreter's evaluation loop. + ctx->interp_eval = &Context::interp_evaluator; + + // Builtin Procedures (treated directly by `eval') + + static struct + { + const char * name; // name of procedure or form. + bool macro; // macro arguments are left unevaluated. + } builtin [] = { + { "and", true }, + { "apply", false }, + { "begin", true }, + { "call-with-current-continuation", false }, + { "call-with-input-file", false }, + { "call-with-output-file", false }, + { "case", true }, + { "cond", true }, + { "define", true }, + { "defmacro", true }, + { "delay", true }, + { "do", true }, + { "eval", false }, + { "for-each", false }, + { "force", false }, + { "if", true }, + { "lambda", true }, + { "let", true }, + { "let*", true }, + { "letrec", true }, + { "load", false }, + { "map", false }, + { "or", true }, + { "quasiquote", true }, + { "quote", true }, + { "set!", true }, + { "time", false }, + { "with-input-from-file", false }, + { "with-output-to-file", false }, + }; + + for (unsigned int ix = 0; ix < sizeof (builtin) / sizeof (*builtin); ++ix) + { + psymbol ps = intern (builtin [ix].name); + Cell * b = ctx->make_builtin (ps); + ctx->set_var (envt, ps, b); + if (builtin [ix].macro) + b->flag (Cell::MACRO, true); + } + } +}; + +static InterpreterExt interpreter_ext; diff --git a/vx-scheme/src/io.cpp b/vx-scheme/src/io.cpp new file mode 100644 index 0000000..ae01042 --- /dev/null +++ b/vx-scheme/src/io.cpp @@ -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 + +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("#key); + ss.append(">"); + break; + case Char: + ss.append("#\\"); + // XXX escaping? + ss.append(CharValue()); + break; + case Iport: + ss.append("#"); + break; + case Oport: + ss.append("#"); + break; + case Subr: + ss.append("#name); + ss.append('>'); + break; + case Cont: + ss.append("#"); + 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) ? "#write(ss); + ss.append(' '); + proc.body->write(ss); + ss.append('>'); + } else { + proc.arglist->write(ss); + ss.append(" ...>"); + } + break; + } + case Promise: + ss.append("#write(ss); + ss.append('>'); + break; + case Cproc: + ss.append("#"); + break; + case Cpromise: + ss.append(flag(FORCED) + ? "#" + : "#"); + break; + case Insn: + ss.append("#"); + 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; + } + diff --git a/vx-scheme/src/lib.cpp b/vx-scheme/src/lib.cpp new file mode 100644 index 0000000..2232a67 --- /dev/null +++ b/vx-scheme/src/lib.cpp @@ -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; + diff --git a/vx-scheme/src/library.scm b/vx-scheme/src/library.scm new file mode 100644 index 0000000..866c8b1 --- /dev/null +++ b/vx-scheme/src/library.scm @@ -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)))) + + + diff --git a/vx-scheme/src/simulator.scm b/vx-scheme/src/simulator.scm new file mode 100644 index 0000000..6b33d1c --- /dev/null +++ b/vx-scheme/src/simulator.scm @@ -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 "#" stream)) + ((tagged-list? '*cont* thing) + (display "#" 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 " ")) + ((compiled-procedure? item) + (display " ")) + ((and (list? item) + (not (null? item)) + (list? (car item)) + (not (null? (car item))) + (eq? (caar item) 'e:)) + (display " ")) + (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)))) + ;; 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.")))) + + diff --git a/vx-scheme/src/subr.cpp b/vx-scheme/src/subr.cpp new file mode 100644 index 0000000..f1d0081 --- /dev/null +++ b/vx-scheme/src/subr.cpp @@ -0,0 +1,1895 @@ +//---------------------------------------------------------------------- +// 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. +// +// subr.cpp : C implementations of Scheme primitives. + + +#include "vx-scheme.h" +#include +#include +#include +#include +#ifdef WIN32 +#include +#endif + +//--------------------------------------------------------------------- +// Utilities +// + +static FILE * oport (Context * ctx, Cell * arglist) + { + if (arglist != nil) + return car (arglist)->OportValue (); + else + return ctx->current_output ()->OportValue (); + } + +static FILE * iport (Context * ctx, Cell * arglist) + { + if (arglist != nil) + return car (arglist)->IportValue (); + else + return ctx->current_input ()->IportValue (); + } + +// exact_list canvasses the given arglist. If all the arguments +// are integer type, exact_p returns true (indicating that integer +// math is appropriate to combine them with.) If at least one +// real is found, it returns false (suggesting that the args +// should be promoted to real type before combination. If any +// other type is encountered, an error is thrown. + +static bool exact_list (Cell * arglist) + { + FOR_EACH (a, arglist) + switch (car (a)->type ()) + { + case Cell::Int: continue; + case Cell::Real: return false; + default: error ("non-numeric type encountered"); + } + + return true; + } + +inline static double asReal (Cell * c) + { + if (c->type () == Cell::Int) + return (double) c->IntValue (); + else + return c->RealValue (); + } + +//--------------------------------------------------------------------- +// THE PRIMITIVE PROCEDURES +// + +Cell * skcons (Context * ctx, Cell * arglist) + { + return ctx->cons (car (arglist), cadr (arglist)); + } + +Cell * skplus (Context * ctx, Cell * arglist) + { + if (exact_list (arglist)) + { + int result = 0; + + FOR_EACH (p, arglist) + result += car (p)->IntValue (); + + return ctx->make_int (result); + } + else + { + double result = 0; + + FOR_EACH (p, arglist) + result += asReal (car (p)); + + return ctx->make_real (result); + } + } + +Cell * skminus (Context * ctx, Cell * arglist) + { + if (exact_list (arglist)) + { + int result = car (arglist)->IntValue (); + arglist = cdr (arglist); + + if (arglist == nil) + return ctx->make_int (- result); + + FOR_EACH (a, arglist) + result -= car (a)->IntValue (); + + return ctx->make_int (result); + } + else + { + double result = asReal (car (arglist)); + arglist = cdr (arglist); + + if (arglist == nil) + return ctx->make_real (- result); + + FOR_EACH (a, arglist) + result -= asReal (car (a)); + + return ctx->make_real (result); + } + } + +Cell * divide (Context * ctx, Cell * arglist) + { + double result; + + if (cdr (arglist) != nil) + { + // The usual case: there are at least 2 arguments. + // (/ a b c ...) ==> ((a / b) / c ...) + + result = asReal (car (arglist)); + + FOR_EACH (a, cdr (arglist)) + result = result / asReal (car (a)); + } + else + { + // A single argument means take its reciprocal. + + result = 1.0 / asReal (car (arglist)); + } + + return ctx->make_real (result); + } + +Cell * times (Context * ctx, Cell * arglist) + { + if (exact_list (arglist)) + { + int result = 1; + + FOR_EACH (p, arglist) + result *= Cell::car (p)->IntValue (); + + return ctx->make_int (result); + } + else + { + double result = 1.0; + + FOR_EACH (p, arglist) + result *= asReal (car (p)); + + return ctx->make_real (result); + } + } + +Cell * skmax (Context * ctx, Cell * arglist) + { + if (exact_list (arglist)) + { + int m = INT_MIN; + int z; + + FOR_EACH (a, arglist) + if ((z = Cell::car (a)->IntValue ()) > m) + m = z; + + return ctx->make_int (m); + } + else + { + double m = DBL_MIN; + double z; + + FOR_EACH (a, arglist) + if ((z = asReal (car (a))) > m) + m = z; + + return ctx->make_real (m); + } + } + +Cell * skmin (Context * ctx, Cell * arglist) + { + if (exact_list (arglist)) + { + int m = INT_MAX; + int z; + + FOR_EACH (a, arglist) + if ((z = car (a)->IntValue ()) < m) + m = z; + + return ctx->make_int (m); + } + else + { + double m = DBL_MAX; + double z; + + FOR_EACH (a, arglist) + if ((z = asReal (car (a))) < m) + m = z; + + return ctx->make_real (m); + } + } + +Cell * skabs (Context * ctx, Cell * arglist) + { + Cell * c = car (arglist); + if (c->type () == Cell::Int) + return ctx->make_int (abs (c->IntValue ())); + else if (c->type () == Cell::Real) + return ctx->make_real (fabs (c->RealValue ())); + else + error ("numeric type expected"); + return nil; // for compiler + } + +// BINOP is a macro which constructs a binary operator +// out of a fragment of C code (OP). This works on +// non numeric types (i.e., those that do not participate +// in coercion). + +#define BINOP(name, OP, ctype, stype) \ + Cell * name (Context * ctx, Cell * args) \ + { \ + FOR_EACH (a, args) \ + if (Cell::cdr (a) != nil) \ + { \ + ctype ia = Cell::car (a)->stype##Value (); \ + ctype ib = Cell::cadr (a)->stype##Value (); \ + if (! OP (ia, ib)) \ + return &Cell::Bool_F; \ + } \ + return &Cell::Bool_T; \ + } + +static int strcmp_ci (char * s, char * t) + { + /* Derived from BSD version. */ + + unsigned char u1; + unsigned char u2; + + while (1) + { + u1 = (unsigned char) tolower (*s++); + u2 = (unsigned char) tolower (*t++); + if (u1 != u2) + return u1 - u2; + if (u1 == '\0') + return 0; + } + } + +#define EQ(a,b) ((a) == (b)) +#define LE(a,b) ((a) <= (b)) +#define LT(a,b) ((a) < (b)) +#define GE(a,b) ((a) >= (b)) +#define GT(a,b) ((a) > (b)) +#define strEQ(a,b) (strcmp (a,b) == 0) +#define strLE(a,b) (strcmp (a,b) <= 0) +#define strLT(a,b) (strcmp (a,b) < 0) +#define strGE(a,b) (strcmp (a,b) >= 0) +#define strGT(a,b) (strcmp (a,b) > 0) +#define strEQci(a,b) (strcmp_ci (a,b) == 0) +#define strLEci(a,b) (strcmp_ci (a,b) <= 0) +#define strLTci(a,b) (strcmp_ci (a,b) < 0) +#define strGEci(a,b) (strcmp_ci (a,b) >= 0) +#define strGTci(a,b) (strcmp_ci (a,b) > 0) +#define chrEQci(a,b) (tolower(a) == tolower (b)) +#define chrLEci(a,b) (tolower(a) <= tolower (b)) +#define chrLTci(a,b) (tolower(a) < tolower (b)) +#define chrGEci(a,b) (tolower(a) >= tolower (b)) +#define chrGTci(a,b) (tolower(a) > tolower (b)) + +BINOP (char_eq, EQ, char, Char) +BINOP (char_le, LE, char, Char) +BINOP (char_lt, LT, char, Char) +BINOP (char_ge, GE, char, Char) +BINOP (char_gt, GT, char, Char) +BINOP (string_eq, strEQ, char *, String) +BINOP (string_le, strLE, char *, String) +BINOP (string_lt, strLT, char *, String) +BINOP (string_ge, strGE, char *, String) +BINOP (string_gt, strGT, char *, String) +BINOP (string_eq_ci, strEQci, char *, String) +BINOP (string_le_ci, strLEci, char *, String) +BINOP (string_lt_ci, strLTci, char *, String) +BINOP (string_ge_ci, strGEci, char *, String) +BINOP (string_gt_ci, strGTci, char *, String) +BINOP (char_eq_ci, chrEQci, char, Char) +BINOP (char_le_ci, chrLEci, char, Char) +BINOP (char_lt_ci, chrLTci, char, Char) +BINOP (char_ge_ci, chrGEci, char, Char) +BINOP (char_gt_ci, chrGTci, char, Char) + +#define NBINOP(name, OP) \ + Cell * name (Context * ctx, Cell * args) \ + { \ + bool exact = exact_list (args); \ + FOR_EACH (a, args) \ + if (cdr (a) != nil) \ + if (exact) \ + { \ + int ia = car (a)->IntValue (); \ + int ib = cadr (a)->IntValue (); \ + if (! OP (ia, ib)) \ + return &Cell::Bool_F; \ + } \ + else \ + { \ + double da = asReal (car (a)); \ + double db = asReal (cadr (a)); \ + if (! OP (da, db)) \ + return &Cell::Bool_F; \ + } \ + return &Cell::Bool_T; \ + } + +NBINOP (number_equal, EQ) +NBINOP (le, LE) +NBINOP (lt, LT) +NBINOP (ge, GE) +NBINOP (gt, GT) + +#define CHAR_CLASS(sname, cname) \ + Cell * sname (Context * ctx, Cell * args) \ + { \ + Cell * charptr = Cell::car (args); \ + return ctx->make_boolean (cname (charptr->CharValue ()) != 0); \ + } + +CHAR_CLASS (alphabetic_p, isalpha) +CHAR_CLASS (lower_case_p, islower) +CHAR_CLASS (upper_case_p, isupper) +CHAR_CLASS (numeric_p, isdigit) +CHAR_CLASS (whitespace_p, isspace) + +Cell * negative_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist)->IntValue () < 0); + } + +Cell * positive_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist)->IntValue () > 0); + } + +Cell * even_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean ((car (arglist)->IntValue () & 1) == 0); + } + +Cell * odd_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean ((car (arglist)->IntValue () & 1) == 1); + } + +Cell * eq (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist)->eq (cadr (arglist))); + } + +Cell * eqv (Context * ctx, Cell * arglist) + { + // If they're both real, compare them as numbers; else use eq + if (car (arglist)->type () == Cell::Real && + cadr (arglist)->type () == Cell::Real) + return ctx->make_boolean ( + car (arglist)->RealValue () == cadr (arglist)->RealValue ()); + return eq (ctx, arglist); + } + +Cell * equal_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist)->equal (cadr (arglist))); + } + +Cell * length (Context * ctx, Cell * arglist) + { + return ctx->make_int (car (arglist)->length ()); + } + +Cell * sknot (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (! car (arglist)->istrue ()); + } + +Cell * display (Context * ctx, Cell * arglist) + { + car (arglist)->display (oport (ctx, cdr (arglist))); + return unspecified; + } + +Cell * display_star (Context * ctx, Cell * arglist) + { + FOR_EACH (a, arglist) + car(a)->display(oport (ctx, nil)); + return unspecified; + } + + +Cell * write (Context * ctx, Cell * arglist) + { + car (arglist)->write (oport (ctx, cdr (arglist))); + return unspecified; + } + +Cell * write_char (Context * ctx, Cell * arglist) + { + fputc (car (arglist)->CharValue (), oport (ctx, cdr (arglist))); + return unspecified; + } + +Cell * skmake_vector (Context * ctx, Cell * arglist) + { + int n = car (arglist)->IntValue (); + + if (cdr (arglist) != nil) + return ctx->make_vector (n, cadr (arglist)); + + return ctx->make_vector (n); + } + +Cell * vector_ref (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + int n = cadr (arglist)->IntValue (); + + return v->get (n); + } + +Cell * vector_set (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + int n = cadr (arglist)->IntValue (); + + v->set (n, caddr (arglist)); + return unspecified; + } + +Cell * vector_fill (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + Cell * filler = cadr (arglist); + int sz = v->size (); + + for (int ix = 0; ix < sz; ++ix) + v->set (ix, filler); + + return unspecified; + } + +Cell * vector_length (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + + return ctx->make_int (v->size ()); + } + +// Flexible vector functions. These are outside the Scheme standard, +// but very useful in practice. Essentially the following four functions +// allow the resizing of vectors via the standard deque operations. +// We borrow the nomenclature from Perl: "vector-push!" adds a new +// element to the right end of a vector; "vector-pop!" detaches the +// right-most element of a vector and returns it. "vector-unshift!" +// and "vector-shift!" do the same thing at the left side of the vector. + +Cell * vector_push (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + v->push (cadr (arglist)); + return unspecified; + } + +Cell * vector_pop (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + return (v->pop ()); + } + +Cell * vector_shift (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + return v->shift (); + } + +Cell * vector_unshift (Context * ctx, Cell * arglist) + { + cellvector * v = car (arglist)->VectorValue (); + v->unshift (cadr (arglist)); + return unspecified; + } + +Cell * vector_from_list (Context * ctx, Cell * arglist) + { + int n = arglist->length (); + Cell * v = ctx->make_vector (n); + cellvector * vec = v->VectorValue (); + int ix = 0; + + ctx->gc_protect (v); + FOR_EACH (elt, arglist) + vec->set (ix++, car (elt)); + ctx->gc_unprotect (); + return v; + } + +Cell * vector_to_list (Context * ctx, Cell * arglist) + { + Cell::List list; + Cell * elt; + cellvector * vec = car (arglist)->VectorValue (); + int n = vec->size (); + + ctx->gc_protect (list.head ()); + for (int ix = 0; ix < n; ++ix) + { + elt = ctx->make (vec->get (ix)); + ctx->gc_protect (elt); + list.append (elt); + ctx->gc_unprotect (2); + ctx->gc_protect (list.head ()); + } + ctx->gc_unprotect (); + return list.head (); + } + +Cell * list_ref (Context * ctx, Cell * arglist) + { + Cell * list = car (arglist); + int n = cadr (arglist)->IntValue (); + int ix = 0; + + FOR_EACH (a, list) + if (ix++ == n) + return car (a); + + error ("index out of bounds"); + return unimplemented; + } + +Cell * quotient (Context * ctx, Cell * arglist) + { + int d = cadr (arglist)->IntValue (); + if (d == 0) + error ("quotient /0"); + + return ctx->make_int (car (arglist)->IntValue () / d); + } + +Cell * remainder (Context * ctx, Cell * arglist) + { + int n = car (arglist)->IntValue (); + int d = cadr (arglist)->IntValue (); + if (d == 0) + error ("remainder /0"); + + return ctx->make_int (n % d); + } + +Cell * modulo (Context * ctx, Cell * arglist) + { + int n = car (arglist)->IntValue (); + int d = cadr (arglist)->IntValue (); + int m = n % d; + if (m < 0 && d > 0) return ctx->make_int (m + d); + if (m > 0 && d < 0) return ctx->make_int (m + d); + return ctx->make_int (m); + } + +//--------------------------------------------------------------------- +// gcd2 (u,v) +// +// Computes the greates common divisor of the given two integers. +// This implementation is Knuth's Algorithm 4.5.2B (TAoCP 3ed. vol II +// p. 338). The variables and label names are as in Knuth's +// presentation and we refer the reader there for further +// documentation. +// + +static int gcd2 (int u, int v) + { + if (u == 0) + return abs (v); + if (v == 0) + return abs (u); + u = abs (u); + v = abs (v); + +//B1: + int k = 0, t; + while ((u & 1) + (v & 1) == 0) + { + k++; + u >>= 1; + v >>= 1; + } +//B2 + if (u & 1) + { + t = -v; + goto B4; + } + t = u; +B3: t >>= 1; +B4: if ((t & 1) == 0) + goto B3; +//B5: + if (t > 0) + u = t; + else + v = -t; +//B6: + t = u - v; + if (t) + goto B3; + return u << k; + } + +Cell * gcd (Context * ctx, Cell * arglist) + { + int g = 0; + + FOR_EACH (i, arglist) + g = gcd2 (g, car (i)->IntValue ()); + + return ctx->make_int (g); + } + +Cell * lcm (Context * ctx, Cell * arglist) + { + int product = 1; + int g = 0; + + FOR_EACH (ip, arglist) + { + int i = car (ip)->IntValue (); + product *= i; + g = gcd2 (g, i); + } + + return ctx->make_int (g == 0 ? 1 : abs (product / g)); + } + +Cell * null_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist) == nil); + } + +Cell * zero_p (Context * ctx, Cell * arglist) + { + Cell * a = car (arglist); + if (a->type () == Cell::Int) + return ctx->make_boolean (a->IntValue () == 0); + else + return ctx->make_boolean (a->RealValue () == 0.0); + } + +Cell * skfalse (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (false); + } + +#define ACCESSOR(ac) \ + Cell * ac (Context * ctx, Cell * a) {return Cell::ac (Cell::car (a)); } + +ACCESSOR (car) +ACCESSOR (cdr) +ACCESSOR (caar) +ACCESSOR (cadr) +ACCESSOR (cdar) +ACCESSOR (cddr) +ACCESSOR (caaar) +ACCESSOR (caadr) +ACCESSOR (cadar) +ACCESSOR (caddr) +ACCESSOR (cdaar) +ACCESSOR (cdadr) +ACCESSOR (cddar) +ACCESSOR (cdddr) +ACCESSOR (caaaar) +ACCESSOR (caaadr) +ACCESSOR (caadar) +ACCESSOR (caaddr) +ACCESSOR (cadaar) +ACCESSOR (cadadr) +ACCESSOR (caddar) +ACCESSOR (cadddr) +ACCESSOR (cdaaar) +ACCESSOR (cdaadr) +ACCESSOR (cdadar) +ACCESSOR (cdaddr) +ACCESSOR (cddaar) +ACCESSOR (cddadr) +ACCESSOR (cdddar) +ACCESSOR (cddddr) + +#define TYPE_PREDICATE(n,t) \ + Cell * n (Context * ctx, Cell * a) \ + { return ctx->make_boolean (Cell::car (a)->type () == Cell::t);} + +TYPE_PREDICATE (string_p, String); +TYPE_PREDICATE (symbol_p, Symbol); +TYPE_PREDICATE (vector_p, Vec); +TYPE_PREDICATE (char_p, Char); +TYPE_PREDICATE (input_p, Iport); +TYPE_PREDICATE (output_p, Oport); +TYPE_PREDICATE (integer_p, Int); +TYPE_PREDICATE (exact_p, Int); +TYPE_PREDICATE (inexact_p, Real); + +#define IS_NUMERIC(n) \ + Cell * n (Context * ctx, Cell * a) \ + { \ + Cell::Type t = car (a)->type (); \ + return ctx->make_boolean (t == Cell::Int || t == Cell::Real); \ + } + +IS_NUMERIC (number_p); +IS_NUMERIC (rational_p); +IS_NUMERIC (real_p); +IS_NUMERIC (complex_p); + +Cell * pair_p (Context * ctx, Cell * arglist) + { + Cell * a = car (arglist); + + return ctx->make_boolean (a->ispair()); + } + +Cell * boolean_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist)->isBoolean ()); + } + +Cell * procedure_p (Context * ctx, Cell * arglist) + { + Cell * a = car (arglist); + Cell::Type t = a->type (); + + return ctx->make_boolean (t == Cell::Subr + || t == Cell::Lambda + || t == Cell::Cont + || t == Cell::Cproc + || (t == Cell::Builtin && !a->macro ())); + } + +Cell* primitive_procedure_p (Context * ctx, Cell * arglist) { + return ctx->make_boolean (car(arglist)->type() == Cell::Subr); +} + +Cell * list_p (Context * ctx, Cell * arglist) + { + Cell * p0 = car (arglist); + Cell * p = p0; + + + while (true) + { + if (p == nil) + return ctx->make_boolean (true); + + if (p->type () != Cell::Cons) + return ctx->make_boolean (false); + + p = Cell::cdr (p); + + if (p == p0) + return ctx->make_boolean (false); + } + } + +Cell * number_to_string (Context * ctx, Cell * arglist) + { + Cell * a = car (arglist); + switch (a->type ()) + { + case Cell::Int : + { + char * fmt = "%d"; + + if (cdr (arglist) != nil) + { + int base = cadr (arglist)->IntValue (); + + if (base == 16) + fmt = "%x"; + else if (base == 8) + fmt = "%o"; + else if (base == 10) + fmt = "%d"; + else + error ("unsupported output base"); // XXX + + } + + char buf [80]; + sprintf (buf, fmt, car (arglist)->IntValue ()); + return ctx->make_string (buf); + } + case Cell::Real : + { + char buf [80]; + Cell::real_to_string (a->RealValue (), buf, sizeof (buf)); + return ctx->make_string (buf); + } + + default: + return ctx->make_boolean (false); + } + } + +Cell * string_length (Context * ctx, Cell * arglist) + { + return ctx->make_int (static_cast(car (arglist)->StringLength ())); + } + +Cell * newline (Context * ctx, Cell * arglist) + { + fputc ('\n', oport (ctx, arglist)); + return unspecified; + } + +Cell * string_to_list (Context * ctx, Cell * arglist) + { + Cell::List l; + Cell * elt; + const char * s = car (arglist)->StringValue (); + char c; + + ctx->gc_protect (l.head ()); + while ((c = *s++)) + { + elt = ctx->make (ctx->make_char (c)); + ctx->gc_protect (elt); + l.append (elt); + ctx->gc_unprotect (2); + ctx->gc_protect (l.head ()); + } + + ctx->gc_unprotect (); + return l.head (); + } + +Cell * sklist (Context * ctx, Cell * arglist) + { + return arglist; + } + +Cell * skmake_string (Context * ctx, Cell * arglist) + { + int n = car (arglist)->IntValue (); + char ch = ' '; + + if (cdr (arglist) != nil) + ch = cadr (arglist)->CharValue (); + + return ctx->make_string (n, ch); + } + +Cell * string_ref (Context * ctx, Cell * arglist) + { + Cell * pstr = car (arglist); + int ix = cadr (arglist)->IntValue (); + int n = static_cast(pstr->StringLength ()); + + if (ix < 0 || ix >= n) + error ("string index out of bounds"); + + return ctx->make_char (pstr->StringValue () [ix]); + } + +Cell * append (Context * ctx, Cell * arglist) + { + Cell::List alist; + Cell * elt; + + if (arglist == nil) + return nil; + + ctx->gc_protect (alist.head ()); + while (cdr (arglist) != nil) + { + FOR_EACH (a, car (arglist)) + { + elt = ctx->make (car (a)); + alist.append (elt); + ctx->gc_unprotect (); + ctx->gc_protect (alist.head ()); + } + arglist = cdr (arglist); + } + + alist.append (car (arglist)); + ctx->gc_unprotect (); + + return alist.head (); + } + +// Destructive concatenation. Lists are spliced together and +// will arguments will share structure. When it is usable, it +// is faster than append, which must clone all its arguments. + +Cell* nconc(Context* ctx, Cell* arglist) { + Cell::List alist; + + // For each argument list: If this is the first + // list, install it in alist. Otherwise, splice + // it to the tail of alist, by updating pointers. + // Do not cons anything. + + if (arglist == nil) return nil; + + while(cdr(arglist) != nil) { + Cell* list_head = car(arglist); + if (list_head != nil) { + Cell* list_tail = list_head; + while(cdr(list_tail) != nil) list_tail = cdr(list_tail); + + alist.append_list(list_head, list_tail); + } + arglist = cdr(arglist); + } + + alist.append(car(arglist)); + + return alist.head(); +} + +static Cell * member_helper + ( + Context * ctx, + Cell * arglist, + bool (Cell::* equality) (Cell *) + ) + { + Cell * target = car (arglist); + Cell * list = cadr (arglist); + + FOR_EACH (l, list) + if ((target->*equality) (Cell::car (l))) + return l; + + return ctx->make_boolean (false); + } + +Cell * memq (Context * ctx, Cell * arglist) + { + return member_helper (ctx, arglist, &Cell::eq); + } + +Cell * memv (Context * ctx, Cell * arglist) + { + return member_helper (ctx, arglist, &Cell::eqv); + } + +Cell * member (Context * ctx, Cell * arglist) + { + return member_helper (ctx, arglist, &Cell::equal); + } + +static Cell * assoc_helper + ( + Context * ctx, + Cell * arglist, + bool (Cell::* equality) (Cell *) + ) + { + Cell * target = car (arglist); + Cell * list = cadr (arglist); + + FOR_EACH (l, list) + if ((target->*equality) (Cell::caar (l))) + return Cell::car (l); + + return ctx->make_boolean (false); + } + +Cell * assq (Context * ctx, Cell * arglist) + { + return assoc_helper (ctx, arglist, &Cell::eq); + } + +Cell * assv (Context * ctx, Cell * arglist) + { + return assoc_helper (ctx, arglist, &Cell::eqv); + } + +Cell * assoc (Context * ctx, Cell * arglist) + { + return assoc_helper (ctx, arglist, &Cell::equal); + } + +Cell * symbol_to_string (Context * ctx, Cell * arglist) + { + return ctx->make_string (car (arglist)->SymbolValue ()->key); + } + +Cell * string_to_symbol (Context * ctx, Cell * arglist) + { + return ctx->make_symbol + (intern_stet (car (arglist)->StringValue ())); + } + +Cell * string_to_number (Context * ctx, Cell * arglist) + { + char * s = car (arglist)->StringValue (); + char * t; + int base = 0; + + if (s[0] == '\0') + return ctx->make_boolean (false); + + // The standard requires that "." produce #f. On VxWorks, + // strtod would give "0.0", so we must treat "." as a special + // case. + + if (!strcmp (s, ".")) + return ctx->make_boolean (false); + + if (cdr (arglist) != nil) + base = cadr (arglist)->IntValue (); + + errno = 0; + int i = strtol (s, &t, base); + + if (*t != '\0' || errno == ERANGE) + { + // It didn't work as an integer, but it might + // be floating point. + + if (base == 0) + { + double d = strtod (s, &t); + if (*t == '\0') + return ctx->make_real (d); + } + + // Scheme considers it an error if we don't consume + // the whole string in the conversion. + + return ctx->make_boolean (false); + } + + return ctx->make_int (i); + } + +Cell * string_chars (Context * ctx, Cell * arglist) + { + int len = 0; + + FOR_EACH (chptr, arglist) + ++len; + + Cell * s = ctx->make_string (len); + char * p = s->StringValue(); + + FOR_EACH (chptr, arglist) + *p++ = car (chptr)->CharValue (); + + *p = '\0'; + return s; + } + +Cell * list_to_string (Context * ctx, Cell * arglist) + { + return string_chars (ctx, car (arglist)); + } + +Cell * list_to_vector (Context * ctx, Cell * arglist) + { + return vector_from_list (ctx, car (arglist)); + } + + +Cell * string_set (Context * ctx, Cell * arglist) + { + // XXX mutability? + Cell * pstr = car (arglist); + size_t n = pstr->StringLength(); + size_t ix = cadr (arglist)->IntValue (); + + if (ix < 0 || ix >= n) + error ("string index out of bounds"); + + char * s = pstr->StringValue (); + char ch = caddr (arglist)->CharValue (); + + s [ix] = ch; + return unspecified; + } + +Cell * string_copy (Context * ctx, Cell * arglist) + { + return ctx->make_string (car (arglist)->StringValue ()); + } + +Cell * string_fill (Context * ctx, Cell * arglist) + { + Cell * pstr = car (arglist); + size_t n = pstr->StringLength (); + char * p = pstr->StringValue (); + char ch = cadr (arglist)->CharValue(); + + for (size_t ix = 0; ix < n; ++ix) + p[ix] = ch; + + return unspecified; + } + +Cell * string_append (Context * ctx, Cell * arglist) + { + sstring ss; + size_t len = 0; + + FOR_EACH (pstr, arglist) + len += car (pstr)->StringLength (); + + Cell * s = ctx->make_string (len); + char * p = s->StringValue (); + + FOR_EACH (pstr, arglist) + { + strcpy (p, car (pstr)->StringValue ()); + p += car (pstr)->StringLength (); + } + + *p = '\0'; + return s; + } + +Cell * substring (Context * ctx, Cell * arglist) + { + Cell * pstr = car (arglist); + int n = static_cast(pstr->StringLength()); + int ix = cadr (arglist)->IntValue (); + int iy = caddr (arglist)->IntValue (); + + if (ix < 0 || iy < ix || n < iy) + error ("string index out of bounds"); + + int l = iy - ix; + + return ctx->make_string (pstr->StringValue () + ix, l); + } + + +Cell * char_upcase (Context * ctx, Cell * arglist) + { + return ctx->make_char (toupper (car (arglist)->CharValue ())); + } + +Cell * char_downcase (Context * ctx, Cell * arglist) + { + return ctx->make_char (tolower (car (arglist)->CharValue ())); + } + +Cell * set_cdr (Context * ctx, Cell * arglist) + { + Cell::setcdr (car (arglist), cadr (arglist)); + return unspecified; + } + +Cell * set_car (Context * ctx, Cell * arglist) + { + Cell::setcar (car (arglist), cadr (arglist)); + return unspecified; + } + +Cell * current_input_port (Context * ctx, Cell * arglist) + { + return ctx->current_input (); + } + +Cell * current_output_port (Context * ctx, Cell * arglist) + { + return ctx->current_output (); + } + +Cell * close_input_port (Context * ctx, Cell * arglist) + { + //car (arglist)->IportValue ().close (); + return unspecified; + } + +Cell * close_output_port (Context * ctx, Cell * arglist) + { + fflush (car (arglist)->OportValue ()); + return unspecified; + } + +Cell * integer_to_char (Context * ctx, Cell * arglist) + { + return ctx->make_char (car (arglist)->IntValue () & 255); + } + +Cell * char_to_integer (Context * ctx, Cell * arglist) + { + return ctx->make_int ((int) car (arglist)->CharValue ()); + } + +Cell * open_input_file (Context * ctx, Cell * arglist) + { + return ctx->make_iport (car (arglist)->StringValue ()); + } + +Cell * open_output_file (Context * ctx, Cell * arglist) + { + return ctx->make_oport (car (arglist)->StringValue ()); + } + +Cell * skread (Context * ctx, Cell * arglist) + { + Cell * r_nu = ctx->read (iport (ctx, arglist)); + return r_nu == 0 ? &Cell::Eof_Object : r_nu; + } + +Cell * read_char (Context * ctx, Cell * arglist) + { + char ch; + FILE * in = iport (ctx, arglist); + + ch = fgetc (in); + + if (feof (in)) + return &Cell::Eof_Object; + + return ctx->make_char (ch); + } + +Cell * peek_char (Context * ctx, Cell * arglist) + { + FILE * in = iport (ctx, arglist); + int ch = fgetc (in); + ungetc (ch, in); + return (ch == -1 ? &Cell::Eof_Object : ctx->make_char (ch)); + } + +Cell * eof_object_p (Context * ctx, Cell * arglist) + { + return ctx->make_boolean (car (arglist) == &Cell::Eof_Object); + } + +Cell * reverse (Context * ctx, Cell * arglist) + { + Cell * rlist = nil; + + ctx->gc_protect (rlist); + FOR_EACH (elt, car (arglist)) + { + rlist = ctx->cons (car (elt), rlist); + ctx->gc_unprotect (); + ctx->gc_protect (rlist); + } + ctx->gc_unprotect (); + + return rlist; + } + +Cell * exact_to_inexact (Context * ctx, Cell * arglist) + { + return ctx->make_real (asReal (car (arglist))); + } + +Cell * inexact_to_exact (Context * ctx, Cell * arglist) + { + Cell * a = car (arglist); + if (a->type () == Cell::Int) + return ctx->make_int (a->IntValue ()); + else + return ctx->make_int ((int) a->RealValue ()); + } + +// Round to nearest int... which would be easy except that the Scheme +// standard insists that we "round toward even" when the fractional +// part is 0.5! If it weren't for that, we could get away with +// floor(d+0.5). As it is we're left with lots of cases. This horrible +// if/else nest tries to get the job done quickly. + +double _round (double d) + { + double frac_part, int_part; + frac_part = modf (d, &int_part); + if (frac_part == 0.0) + return d; + if (frac_part > 0.0) + if (frac_part > 0.5) + return int_part + 1.0; + else if (frac_part == 0.5) + if (fmod (int_part, 2.0) != 0) + return int_part + 1.0; + else + return int_part; + else + return int_part; + else // frac_part < 0.0 + if (frac_part < -0.5) + return int_part - 1.0; + else if (frac_part == -0.5) + if (fmod (int_part, 2.0) != 0) + return int_part - 1.0; + else + return int_part; + else + return int_part; + } + +// Trunc: not ANSI, so rather than #ifdef it we just provide a +// version here that works. + +double sktrunc (double d) + { + double int_part; + modf (d, &int_part); + return int_part; + } + +// REAL_F1 and REAL_F2 are `impedance matching' macros that expose +// a C-library transcendental math function (like sin, cos) to +// scheme. F1 is for one-argument functions, F2 for two arguments. +// The subr-function name chosen is made different from the C +// library function to avoid name collisions. + +#define REAL_F1(sname,cname) \ + Cell * sname (Context * ctx, Cell * arglist) \ + { \ + return ctx->make_real (cname (asReal (car (arglist)))); \ + } + +#define REAL_F2(sname,cname) \ + Cell * sname (Context * ctx, Cell * arglist) \ + { \ + return ctx->make_real (cname (asReal (car (arglist)), \ + asReal (cadr (arglist)))); \ + } + +REAL_F1 (round, _round) +REAL_F1 (sklog, log) +REAL_F1 (sksqrt, sqrt) +REAL_F1 (skexp, exp) +REAL_F1 (sksin, sin) +REAL_F1 (skcos, cos) +REAL_F1 (sktan, tan) +REAL_F1 (skasin, asin) +REAL_F1 (skacos, acos) +REAL_F2 (inexact_expt, pow) +REAL_F1 (skfloor, floor) +REAL_F1 (skceiling, ceil) +REAL_F1 (sktruncate, sktrunc) + +static Cell * expt (Context * ctx, Cell * arglist) + { + // Scheme requires expt to return an exact result, if + // representible, when given exact arguments. XXX: + // we should detect overflow, and delegate to the + // inexact version in that event. + + if (exact_list (arglist)) + { + // This is Knuth's Algorithm 4.6.3A (TAoCP 3ed. vol II p. 462). + // The variable names and labels are as in Knuth's presentation; + // the interested reader is referred there. + + // A1: + + int Z = car (arglist)->IntValue (); + int N = cadr (arglist)->IntValue (); + int Y = 1; + int even; + + // handle Scheme's requirement that (expt 0 N) = 1 + // if N = 0 and 0 otherwise. Also, handle the + // trivial Z = 1 case. If N < 0, that's inexact. + + if (Z == 0) + return ctx->make_int (N == 0 ? 1 : 0); + if (Z == 1) + return ctx->make_int (1); + if (N == 0) + return ctx->make_int (0); + if (N < 0) + return inexact_expt (ctx, arglist); + + A2: even = !(N&1); + N >>= 1; + if (even) + goto A5; + // A3: + Y = Z * Y; + // A4: + if (N == 0) + return ctx->make_int (Y); + A5: Z = Z * Z; + goto A2; + } + else + return inexact_expt (ctx, arglist); + } + +static Cell* skatan (Context* ctx, Cell* arglist) + { + // If one arg, then compute atan(x), else compute atan2(y,x). + + double x = asReal (car (arglist)); + + if (cdr (arglist) != nil) + { + double y = asReal (cadr (arglist)); + return ctx->make_real (atan2 (y, x)); + } + + return ctx->make_real (atan (x)); + } + +static Cell* logand (Context* ctx, Cell* arglist) + { + int value = ~0; + + FOR_EACH (a, arglist) + value &= car (a)->IntValue (); + + return ctx->make_int (value); + } + +static Cell* logbit_p(Context* ctx, Cell* arglist) + { + return ctx->make_boolean ((cadr (arglist)->IntValue () + & (1 << car (arglist)->IntValue ())) != 0); + } + +static Cell* logior (Context * ctx, Cell * arglist) + { + int value = 0; + + FOR_EACH (a, arglist) + value |= car (a)->IntValue (); + + return ctx->make_int (value); + } + +static Cell* logxor (Context * ctx, Cell * arglist) + { + int value = 0; + + FOR_EACH (a, arglist) + value ^= car (a)->IntValue (); + + return ctx->make_int (value); + } + +static Cell* lognot (Context * ctx, Cell * arglist) + { + return ctx->make_int (~ car (arglist)->IntValue ()); + } + +static Cell* skerror (Context * ctx, Cell * arglist) + { + // Accumulate the arguments as though they were being + // displayed + + error (car (arglist)->StringValue ()); + return unimplemented; // satisfy compiler + } + +static Cell* skgc (Context * ctx, Cell * arglist) + { + ctx->gc (); + return unspecified; + } + +static Cell* sk_impl_type (Context * ctx, Cell * arglist) + { + return ctx->make_symbol (intern ("vx-scheme")); + } + +static Cell* vxs_impl_type(Context* ctx, Cell* arglist) { + static psymbol const i_interp = intern("interp"); + static psymbol const i_vm = intern("vm"); + return ctx->make_symbol(ctx->using_vm() ? i_vm : i_interp); +} + +#define __string(x) #x +#define __vstring(v) ("vx-scheme " __string(v)) +#define VERSION_STRING __vstring(VERSION) + +static Cell* sk_impl_ver (Context * ctx, Cell * arglist) + { + return ctx->make_string (VERSION_STRING); + } + +static Cell* sk_impl_page (Context * ctx, Cell * arglist) + { + return ctx->make_string ("http://colin-smith.net/vx-scheme/"); + } + +static Cell* sk_impl_platform (Context * ctx, Cell * arglist) + { + psymbol s; +#if defined(__CYGWIN__) + s = intern ("cygwin"); +#elif defined (VXWORKS) + s = intern ("VxWorks"); +#elif defined (__unix__) + s = intern ("unix"); +#elif defined (WIN32) + s = intern ("win32"); +#else + s = intern ("unknown"); +#endif + return ctx->make_symbol (s); + } + +static Cell* file_exists_p (Context * ctx, Cell * arglist) + { + FILE * ip = fopen (car (arglist)->StringValue (), "r"); + if (ip != NULL) fclose (ip); + return ctx->make_boolean (ip != NULL); + } + +// +// PROPERTY LIST SUPPORT +// + +static Cell* put_property (Context * ctx, Cell * arglist) + { + psymbol p = car (arglist)->SymbolValue (); + psymbol q = cadr (arglist)->SymbolValue (); + Cell * value = caddr (arglist); + + if (p->plist) + for (int ix = 0; ix < p->plist->size (); ++ix) + { + Cell * prop = p->plist->get (ix); + if (car (prop)->SymbolValue () == q) + { + Cell::setcdr (prop, value); // hit: plist already contains q. + return unspecified; + } + } + else + // time to add the plist. + p->plist = cellvector::alloc(0); + + // miss: add a new property. Create the plist if necessary. + + Cell * assoc = ctx->cons (cadr (arglist), value); + p->plist->push (assoc); + return unspecified; + } + +static Cell* get_property (Context * ctx, Cell * arglist) + { + psymbol p = car (arglist)->SymbolValue (); + psymbol q = cadr (arglist)->SymbolValue (); + + if (p->plist) + for (int ix = 0; ix < p->plist->size (); ++ix) + { + Cell * elt = p->plist->get (ix); + if (car (elt)->SymbolValue () == q) + return cdr (elt); + } + + return ctx->make_boolean (false); + } + +// Imported from Common Lisp. Returns #t if the given symbol is +// bound in the global environment (lexical bindings are not consulted), +// #f otherwise. + +Cell* bound_p(Context* ctx, Cell* arglist) { + psymbol s = car(arglist)->SymbolValue(); + return ctx->make_boolean(ctx->find_var(ctx->root(), s, 0) != NULL); +} + +// Imported from Common Lisp. Retrieves the value of a symbol in the +// global environment (not in any lexical binding). Errors if the +// symbol is unbound there. + +Cell* symbol_value(Context* ctx, Cell* arglist) { + psymbol s = car(arglist)->SymbolValue(); + Cell* value = ctx->find_var(ctx->root(), s, 0); + if (!value) { + error("unbound symbol"); + return unspecified; + } + return cdr(value); +} + +// Get/Set current working directory + +static Cell* sk_getcwd(Context* ctx, Cell* arglist) { +#ifdef WIN32 + char buf[MAX_PATH]; + GetCurrentDirectory(sizeof(buf), buf); +#else + char buf[PATH_MAX]; + getcwd(buf, sizeof(buf)); +#endif + return ctx->make_string(buf); +} + +static Cell* sk_chdir(Context* ctx, Cell* arglist) { + const char* dir = car(arglist)->StringValue(); +#ifdef WIN32 + bool ok = SetCurrentDirectory(dir) == TRUE; +#else + bool ok = chdir(dir) == 0; +#endif + return ctx->make_boolean(ok); +} + +// +// INITIALIZATION +// + +void Context::provision () + { + struct + { + const char * n; + subr_f i; + } subr [] = + { + { "*", times }, + { "+", skplus }, + { "-", skminus }, + { "/", divide }, + { "<", lt }, + { "<=", le }, + { "=", number_equal }, + { ">", gt }, + { ">=", ge }, + { "abs", skabs }, + { "append", append }, + { "acos", skacos }, + { "asin", skasin }, + { "assoc", assoc }, + { "assq", assq }, + { "assv", assv }, + { "atan", skatan }, + { "boolean?", boolean_p }, + { "caaaar", caaaar }, + { "caaadr", caaadr }, + { "caaar", caaar }, + { "caadar", caadar }, + { "caaddr", caaddr }, + { "caadr", caadr }, + { "caar", caar }, + { "cadaar", cadaar }, + { "cadadr", cadadr }, + { "cadar", cadar }, + { "caddar", caddar }, + { "cadddr", cadddr }, + { "caddr", caddr }, + { "cadr", cadr }, + { "car", car }, + { "cdaaar", cdaaar }, + { "cdaadr", cdaadr }, + { "cdaar", cdaar }, + { "cdadar", cdadar }, + { "cdaddr", cdaddr }, + { "cdadr", cdadr }, + { "cdar", cdar }, + { "cddaar", cddaar }, + { "cddadr", cddadr }, + { "cddar", cddar }, + { "cdddar", cdddar }, + { "cddddr", cddddr }, + { "cdddr", cdddr }, + { "cddr", cddr }, + { "cdr", cdr }, + { "ceiling", skceiling }, + { "char->integer", char_to_integer }, + { "char-alphabetic?", alphabetic_p }, + { "char-ci<=?", char_le_ci }, + { "char-ci=?", char_ge_ci }, + { "char-ci>?", char_gt_ci }, + { "char-downcase", char_downcase }, + { "char-lower-case?", lower_case_p }, + { "char-numeric?", numeric_p }, + { "char-upcase", char_upcase }, + { "char-upper-case?", upper_case_p }, + { "char-whitespace?", whitespace_p }, + { "char<=?", char_le }, + { "char=?", char_ge }, + { "char>?", char_gt }, + { "char?", char_p }, + { "close-input-port", close_input_port }, + { "close-output-port", close_output_port }, + { "complex?", complex_p }, + { "cons", skcons }, + { "cos", skcos }, + { "current-input-port", current_input_port }, + { "current-output-port", current_output_port }, + { "display", display }, + { "eof-object?", eof_object_p }, + { "error", skerror }, + { "eq?", eq }, + { "equal?", equal_p }, + { "eqv?", eqv }, + { "even?", even_p }, + { "exact?", exact_p }, + { "exact->inexact", exact_to_inexact }, + { "exp", skexp }, + { "expt", expt }, + { "floor", skfloor }, + { "inexact->exact", inexact_to_exact }, + { "gcd", gcd }, + { "inexact?", inexact_p }, + { "input-port?", input_p }, + { "integer->char", integer_to_char }, + { "integer?", integer_p }, + { "lcm", lcm }, + { "length", length }, + { "list", sklist }, + { "list->string", list_to_string }, + { "list->vector", list_to_vector }, + { "list-ref", list_ref }, + { "list?", list_p }, + { "log", sklog }, + { "logand", logand }, + { "logbit?", logbit_p }, + { "logior", logior }, + { "lognot", lognot }, + { "logxor", logxor }, + { "make-string", skmake_string }, + { "make-vector", skmake_vector }, + { "max", skmax }, + { "member", member }, + { "memq", memq }, + { "memv", memv }, + { "min", skmin }, + { "modulo", modulo }, + { "negative?", negative_p }, + { "newline", newline }, + { "not", sknot }, + { "null?", null_p }, + { "number->string", number_to_string }, + { "number?", number_p }, + { "odd?", odd_p }, + { "open-input-file", open_input_file }, + { "open-output-file", open_output_file }, + { "output-port?", output_p }, + { "pair?", pair_p }, + { "peek-char", peek_char }, + { "positive?", positive_p }, + { "procedure?", procedure_p }, + { "quotient", quotient }, + { "rational?", rational_p }, + { "read", skread }, + { "read-char", read_char }, + { "real?", real_p }, + { "remainder", remainder }, + { "reverse", reverse }, + { "round", round }, + { "set-car!", set_car }, + { "set-cdr!", set_cdr }, + { "sin", sksin }, + { "sqrt", sksqrt }, + { "string", string_chars }, + { "string-copy", string_copy }, // R5 + { "string-fill!", string_fill }, // R5 + { "string->list", string_to_list }, + { "string->number", string_to_number }, + { "string->symbol", string_to_symbol }, + { "string-append", string_append }, + { "string-ci<=?", string_le_ci }, + { "string-ci=?", string_ge_ci }, + { "string-ci>?", string_gt_ci }, + { "string-length", string_length }, + { "string-ref", string_ref }, + { "string-set!", string_set }, + { "string<=?", string_le }, + { "string=?", string_ge }, + { "string>?", string_gt }, + { "string?", string_p }, + { "substring", substring }, + { "symbol->string", symbol_to_string }, + { "symbol?", symbol_p }, + { "tan", sktan }, + { "truncate", sktruncate }, + { "vector", vector_from_list }, + { "vector->list", vector_to_list }, + { "vector-fill!", vector_fill }, // R5 + { "vector-length", vector_length }, + { "vector-ref", vector_ref }, + { "vector-set!", vector_set }, + { "vector?", vector_p }, + { "write", write }, + { "write-char", write_char }, + { "zero?", zero_p }, + //---------------------------------------------------------------- + // + // The following functions are not part of the spec, but + // are peculiar to this implementation. + // + { "bound?", bound_p }, + { "chdir", sk_chdir }, + { "display*", display_star }, + { "put", put_property }, + { "get", get_property }, + { "file-exists?", file_exists_p }, + { "gc", skgc }, + { "getcwd", sk_getcwd }, + { "nconc", nconc }, + { "primitive-procedure?", primitive_procedure_p }, + { "scheme-implementation-type", sk_impl_type }, + { "vx-scheme-implementation-type", vxs_impl_type }, + { "scheme-implementation-version", sk_impl_ver }, + { "scheme-implementation-home-page", sk_impl_page }, + { "scheme-implementation-platform", sk_impl_platform }, + { "symbol-value", symbol_value }, + { "vector-push!", vector_push }, + { "vector-pop!", vector_pop }, + { "vector-unshift!", vector_unshift }, + { "vector-shift!", vector_shift }, + // + //---------------------------------------------------------------- + }; + + for (unsigned int ix = 0; ix < sizeof (subr) / sizeof (*subr); ++ix) + bind_subr (subr[ix].n, subr[ix].i); + + // Source code in SICP uses the symbols `true' and `false' for + // boolean values instead of #t and #f as suggested by RxRS. + // We add these symbol-bindings here. + +#define BIND_VARIABLE(var,val) \ + set_var (envt, intern (var), val) + + BIND_VARIABLE ("true", make_boolean (true)); + BIND_VARIABLE ("false", make_boolean (false)); + BIND_VARIABLE ("*version*", make_string (VERSION_STRING)); + + // Load extension bindings. + + SchemeExtension::RunInstall (this, envt); + } + +void Context::bind_subr (const char * name, subr_f subr) + { + psymbol s = intern (name); + set_var (envt, s, make_subr (subr, name)); + } + +cellvector* SchemeExtension::extensions = 0; +SchemeExtension* SchemeExtension::main = 0; + +void SchemeExtension::Register (SchemeExtension * ext) { + if (!extensions) + extensions = new cellvector (); + + extensions->push (reinterpret_cast (ext)); +} + +void SchemeExtension::RunInstall (Context * ctx, Cell * envt) { + if (!extensions) + return; + for (int ix = 0; ix < extensions->size(); ++ix) { + SchemeExtension * extension = + reinterpret_cast (extensions->get (ix)); + extension->Install (ctx, envt); + } +} diff --git a/vx-scheme/src/symtab.cpp b/vx-scheme/src/symtab.cpp new file mode 100644 index 0000000..c35fe94 --- /dev/null +++ b/vx-scheme/src/symtab.cpp @@ -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 +#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 diff --git a/vx-scheme/src/u-main.cpp b/vx-scheme/src/u-main.cpp new file mode 100644 index 0000000..fb8ae38 --- /dev/null +++ b/vx-scheme/src/u-main.cpp @@ -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 +#include +#include "vx-scheme.h" +#ifndef WIN32 +#include +#include +#else +#include +#endif +#include + +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 (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 (setjmp (jb))) == 0) { + jmpbuf_set = true; + interact (&ctx); + } else { + fprintf (stderr, "caught: %s\n", jv); + } + } + } +} + diff --git a/vx-scheme/src/vm.cpp b/vx-scheme/src/vm.cpp new file mode 100644 index 0000000..67a2e09 --- /dev/null +++ b/vx-scheme/src/vm.cpp @@ -0,0 +1,1028 @@ +//---------------------------------------------------------------------- +// 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. +// +// vm.cpp : PAIP-style virtual machine for compiled Scheme code +// + +#include "vx-scheme.h" + +enum operand_type { + OP_NONE, + OP_INT, + OP_SYMBOL, + OP_SUBR, + OP_LEXADDR +}; + +// Extract information from a VM instruction. + +#define INSN_OPCODE(_insn) ((_insn)->ca.i >> 24) // ca.i unsigned +#define SET_OPCODE(_insn, value) \ + (((_insn)->ca.i = (_insn)->ca.i & 0xffffff | value<<24)) +#define INSN_COUNT(_insn) (((_insn)->ca.i >> 16) & 0xff) +#define LEXA_ESKIP(_insn) ((_insn)->cd.i >> 16) +#define LEXA_BSKIP(_insn) ((_insn)->cd.i & 0xffff) + +#define OPCODE(name,operand) {intern(name),operand} + +typedef struct { + psymbol opcode; + enum operand_type opnd_type; +} vm_op; + +// XXX issues: +// 1) the order of opcodes is willy-nilly. +// 2) there are magic number references to opcode numbers in this file. +// Be careful. +// 3) I forget what (3) is. + +static vm_op optab [] = { // opcode number + OPCODE ("consti", OP_INT), // 0 + OPCODE ("nil", OP_NONE), + OPCODE ("subr", OP_SUBR), + OPCODE ("gref", OP_SYMBOL), + OPCODE ("gset", OP_SYMBOL), + OPCODE ("lref", OP_LEXADDR), // 5 + OPCODE ("lset", OP_LEXADDR), + OPCODE ("goto", OP_INT), + OPCODE ("false?p", OP_INT), + OPCODE ("false?", OP_INT), + OPCODE ("true?p", OP_INT), // 10 + OPCODE ("true?", OP_INT), + OPCODE ("proc", OP_NONE), + OPCODE ("extend", OP_INT), + OPCODE ("extend!", OP_NONE), + OPCODE ("extend.", OP_INT), // 15 + OPCODE ("save", OP_INT), + OPCODE ("return", OP_NONE), + OPCODE ("pop", OP_NONE), + OPCODE ("dup", OP_NONE), + OPCODE ("take", OP_INT), // 20 + OPCODE ("cc", OP_NONE), + OPCODE ("resume", OP_NONE), + OPCODE ("apply.", OP_NONE), + OPCODE ("apply", OP_INT), + OPCODE ("unspc", OP_NONE), // 25 + OPCODE ("unassn", OP_NONE), + OPCODE ("lit", OP_INT), + OPCODE ("vector-set!", OP_INT), // starting here: + OPCODE ("vector-ref", OP_INT), // scheme primitives allocated to opcode + OPCODE ("car", OP_INT), // 30 + OPCODE ("cdr", OP_INT), + OPCODE ("zero?", OP_INT), + OPCODE ("+", OP_INT), + OPCODE ("*", OP_INT), + OPCODE ("quotient", OP_INT), // 35 + OPCODE ("remainder", OP_INT), + OPCODE ("-", OP_INT), + OPCODE ("not", OP_INT), + OPCODE ("null?", OP_INT), + OPCODE ("eq?", OP_INT), // 40 + OPCODE ("pair?", OP_INT), + OPCODE ("cons", OP_INT), + OPCODE ("gref.", OP_INT), + OPCODE ("false", OP_NONE), + OPCODE ("true", OP_NONE), // 45 + OPCODE ("int", OP_INT), + OPCODE ("promise", OP_NONE), + OPCODE ("gset.", OP_INT), +}; + +static const int n_vmops = sizeof(optab) / sizeof(*optab); + + +// exact_top_n: return true if the top n elements of the stack contained +// in cv are of exact type (in this implementation, exact is synonymous +// with integer). + +static bool exact_top_n (cellvector * cv, int n) { + int sz = cv->size(); + for (int ix = sz - n; ix < sz; ++ix) + switch (cv->get_unchecked(ix)->type()) { + case Cell::Int: continue; + case Cell::Real: return false; + default: error ("non-numeric type encountered"); + } + return true; +} + +// Context::extend +// Extend an environment with the list of bindings in blist. + +Cell* Context::extend(Cell* envt, Cell* blist) { + Cell * xe = gc_protect(make_vector(0)); + cellvector * cv = xe->unsafe_vector_value(); + FOR_EACH(b, blist) + cv->push (car (b)); + envt = cons(xe, envt); + gc_unprotect(); + return envt; +} + +// Context::extend_from_vector +// Extend environment envt with elements from the vector v, in +// reverse order. (The compiler arranges to compile function +// arguments from left to right. This means that the "rightmost" +// argument to a function will be at the top of the stack. +// References to parameters are by integer index, with the leftmost +// argument numbered zero.) + +Cell* Context::extend_from_vector (Cell* envt, cellvector* v, int n) { + int size = v->size(); + r_nu = make_vector(n); + cellvector* new_vec = r_nu->unsafe_vector_value(); + for (int ix = 0, iy = size - n; ix < n; ++ix, ++iy) + new_vec->set_unchecked(ix, v->get_unchecked(iy)); + v->discard(n); + envt = cons(r_nu, envt); + return envt; +} + +void Context::adjoin (Cell* envt, Cell* val) { + car(envt)->unsafe_vector_value()->push(val); +} + +// Context::pop_list +// Context::push_list +// 'pop' pops the specified number of elements off the machine stack and +// returns a list of the elements. The last element popped will be first +// in the list. 'Push' pushes the supplied list onto the stack. Elements +// are pushed in the order given. + +Cell* Context::pop_list (int n) { + r_tmp = nil; + for (int ix = 0; ix < n; ++ix) { + r_tmp = cons (gc_protect (m_stack.pop ()), r_tmp); + gc_unprotect (); + } + return r_tmp; +} + +int Context::push_list(Cell* list) { + int count = 0; + FOR_EACH(a, list) { + m_stack.push(car(a)); + ++count; + } + return count; +} + +void Context::print_insn(int addr, Cell* insn) { + vm_op * op = optab + INSN_OPCODE(insn); + printf ("%4d:\t%s\t", addr, op->opcode->key); + switch (op->opnd_type) { + case OP_INT: + printf ("%d", insn->cd.i); + break; + case OP_SYMBOL: + printf ("%s", insn->cd.y->key); + break; + case OP_SUBR: printf ("%d,%s", INSN_COUNT (insn), + insn->flag(Cell::QUICK) + ? insn->cd.f->name + : insn->cd.y->key); + // XXX comment + break; + case OP_LEXADDR: + printf ("%d,%d", LEXA_ESKIP(insn), LEXA_BSKIP(insn)); + break; + case OP_NONE: + ; + } + printf("\n"); +} + +// Context::vm_evaluator +// Run the expression through the virtual machine's evaluator, if it's +// present. (The evaluator is compiled code produced by the bootstrapper.) +// + +Cell* Context::vm_evaluator(Cell* form) { + if (!eval_cproc) { + Cell* binding; + if ((binding = find_var(root_envt, intern("eval"), 0))) + eval_cproc = cdr(binding); + } + if (eval_cproc) { + r_tmp = form; + r_exp = cons(form, nil); + // save(r_envt); + // r_envt = root_envt; + return execute(eval_cproc, r_exp); + // restore(r_envt); + } + error("can't find eval"); + return make_boolean(false); +} + +Cell* Context::execute (Cell* proc, Cell* args) { + cellvector *insns, *literals; + int pc; + int type; + int start; + unsigned int count; + unsigned int n_args = 0; + unsigned int b_skip = 0; + unsigned int e_skip = 0; + + // Note the initial stack size. + int initial_stackdepth = m_stack.size(); + + save (-1); + + // Push any arguments we received onto the stack. + + FOR_EACH(a, args) { + ++n_args; + save(car(a)); + } + + r_cproc = proc; + bool trace = OS::flag (TRACE_VM); + bool trace_stack = OS::flag (TRACE_VMSTACK); + bool count_insns = OS::flag (COUNT_INSNS); + + int xcount [n_vmops]; + if (count_insns) + for (int ix = 0; ix < n_vmops; ++ix) + xcount [ix] = 0; + + cellvector* root_bindings = car(root_envt)->unsafe_vector_value(); + + PROC: + r_cproc->typecheck (Cell::Cproc); + insns = r_cproc->cd.cv->get (0)->unsafe_vector_value(); + literals = r_cproc->cd.cv->get (1)->unsafe_vector_value(); + r_envt = r_cproc->cd.cv->get (2); + pc = r_cproc->cd.cv->get (3)->IntValue (); + + XEQ: + Cell * insn = insns->get_unchecked (pc); // trust compiler! + unsigned int opcode = INSN_OPCODE (insn); + if (count_insns) + ++xcount [opcode]; + if (trace) { + if (trace_stack) { + printf ("\t"); + for (int ix = m_stack.size() - 1; ix >= 0; --ix) { + Cell * c = m_stack.get_unchecked(ix); + if (!(((int)c)&1)) { + if (c == root_envt) printf("# "); + else c->write (stdout); + } else printf ("%d", ((int)c)>>1); + fputc (' ', stdout); + } + printf("\n"); + } + print_insn(pc, insn); + } + switch (opcode) + { + case 0: // consti + save (insn->cd.i); + break; + case 1: // nil + m_stack.push (nil); + break; + case 2: // subr + if (!insn->flag(Cell::QUICK)) { + Cell* subr = find_var(root_envt, insn->cd.y, 0); + if (!subr) error("missing primitive procedure"); + insn->cd.f = cdr(subr)->SubrValue(); + insn->flag(Cell::QUICK, true); + } + r_val = pop_list (INSN_COUNT (insn)); + // Subr's can change anything (in particular they can reenter execute). + save(r_envt); + save(r_cproc); + r_val = insn->cd.f->subr(this, r_val); + restore(r_cproc); + restore(r_envt); + m_stack.push(r_val); + break; + case 3: { // gref + unsigned int index; + r_val = find_var (root_envt, insn->cd.y, &index); + if (!r_val) { + error ("reference to undefined global variable: ", insn->cd.y->key); + } else { + if (cdr(r_val) == NULL) error("yikes"); // XXX + // Quicken the instruction. + SET_OPCODE(insn, 43); // gref. XXX: magic number (among others) + insn->cd.i = index; + m_stack.push (cdr (r_val)); + } + break; + } + case 4: { // gset + unsigned int index; + set_var (root_envt, insn->cd.y, m_stack.pop (), &index); + // Quicken the instruction. + SET_OPCODE(insn, 48); // gset. XXX: magic number + insn->cd.i = index; + break; + } + case 5: // lref + e_skip = LEXA_ESKIP (insn); + b_skip = LEXA_BSKIP (insn); + r_tmp = r_envt; + for (unsigned int ix = 0; ix < e_skip; ++ix) + r_tmp = cdr (r_tmp); + m_stack.push (car (r_tmp)->cd.cv->get (b_skip)); + break; + case 6: // lset + e_skip = LEXA_ESKIP (insn); + b_skip = LEXA_BSKIP (insn); + r_tmp = r_envt; + for (unsigned int ix = 0; ix < e_skip; ++ix) + r_tmp = cdr (r_tmp); + car (r_tmp)->cd.cv->set (b_skip, m_stack.pop ()); + break; + case 7: // goto + pc = insn->cd.i; + goto XEQ; + case 8: // false?p + if (!m_stack.pop ()->istrue ()) { + pc = insn->cd.i; + goto XEQ; + } + break; + case 9: // false? + if (!m_stack.top ()->istrue ()) { + pc = insn->cd.i; + goto XEQ; + } + break; + case 10: // true?p + if (m_stack.pop ()->istrue ()) { + pc = insn->cd.i; + goto XEQ; + } + break; + case 11: // true? + if (m_stack.top ()->istrue ()) { + pc = insn->cd.i; + goto XEQ; + } + break; + case 12: // proc + // pop the starting instruction from the stack and compose it + // with the current environment. + restore (start); + m_stack.push (make_compiled_procedure (r_cproc->cd.cv->get_unchecked (0), + r_cproc->cd.cv->get_unchecked (1), + r_envt, + start)); + break; + case 13: // extend + if (n_args < insn->cd.i) + error ("vm: not enough arguments to procedure"); + r_envt = extend_from_vector (r_envt, &m_stack, insn->cd.i); + //r_envt = extend (r_envt, gc_protect (pop_list (insn->cd.i))); + //gc_unprotect (); + break; + case 14: // extend! + r_envt = extend (r_envt, gc_protect (pop_list (1))); + gc_unprotect (); + break; + case 15: // extend. + if (n_args < insn->cd.i) + error ("vm: not enough arguments to procedure"); + r_val = pop_list (n_args - insn->cd.i); + r_envt = extend (r_envt, gc_protect (pop_list (insn->cd.i))); + gc_unprotect (); + adjoin (r_envt, r_val); + break; + case 16: // save + // make a continuation that will invoke the indicated + // instruction slot in this segment. + save (r_envt); + save (r_cproc); + save (insn->cd.i); + break; + case 17: // return + r_val = m_stack.pop (); // value + RETURN: + restore (pc); + if (pc < 0) + goto FINISH; + restore (r_cproc); + insns = r_cproc->cd.cv->get (0)->VectorValue (); + literals = r_cproc->cd.cv->get (1)->VectorValue (); + restore (r_envt); + save (r_val); + goto XEQ; + case 18: // pop + m_stack.pop (); + break; + case 19: // dup + m_stack.push (m_stack.top ()); + break; + case 20: { // take + // Remove the n'th item from the stack and push it onto the top. + // (We count from zero). 'take 0' would be a no-op; 'take 1' + // would swap the top two elements. We use an unchecked get + // because we "trust the compiler." + int target = insn->cd.i; + int last = m_stack.size() - 1; + r_tmp = m_stack.get_unchecked(last-target); + for (int ix = last-target; ix < last; ++ix) + m_stack.set(ix, m_stack.get_unchecked(ix+1)); + m_stack.set(last, r_tmp); + break; + } + case 21: { // cc + r_tmp = make_vector(m_stack.size()); + cellvector* saved_stack = r_tmp->VectorValue(); + for (int ix = 0; ix < m_stack.size(); ++ix) + saved_stack->set(ix, m_stack.get(ix)); + r_nu = cons(r_tmp, nil); + r_envt = extend(r_envt, r_nu); + m_stack.push(make_compiled_procedure(cc_procedure, empty_vector, + r_envt, 0)); + r_envt = cdr(r_envt); + // YYY + break; + } + case 22: { // resume + r_val = m_stack.pop(); + r_tmp = m_stack.pop(); + cellvector* new_stack = r_tmp->VectorValue(); + m_stack.clear(); // ! + for (int ix = 0; ix < new_stack->size(); ++ix) + m_stack.push(new_stack->get(ix)); + goto RETURN; + } + case 23: // apply. + // Covert stack from: rest ... a2 a1 proc + // to: proc a1 a2 ... rest + // with 'rest' spliced in in the correct order. + // Then do as in an ordinary apply. This exists + // only to support the 'apply' special procedure. + r_tmp = m_stack.pop(); + for (count = 0; count < n_args-2; ++count) + r_tmp = cons(m_stack.pop(), r_tmp); + r_proc = m_stack.pop(); + count = push_list(r_tmp); + m_stack.push(r_proc); + // dummy up the 'real' arument count that the + // microcode for 'apply' will see below. + insn->cd.i = count; + /* FALL THROUGH */ + case 24: // apply + r_exp = m_stack.pop (); + type = r_exp->type (); + if (type == Cell::Cproc) { + n_args = insn->cd.i; + r_cproc = r_exp; + goto PROC; + } else if (type == Cell::Subr) { + r_val = pop_list(insn->cd.i); + save(r_envt); + save(r_cproc); + r_val = r_exp->SubrValue()->subr(this, r_val); + restore(r_cproc); + restore(r_envt); + goto RETURN; + } else { + r_exp->write(stderr); + error ("vm: inapplicable"); + } + break; + case 25: // unspc + m_stack.push (unspecified); + break; + case 26: // unassn + m_stack.push (unassigned); + break; + case 27: // lit + m_stack.push (literals->get (insn->cd.i)); + break; + case 28: { // vector-set! + n_args = insn->cd.i; + if (n_args != 3) + error ("bad arguments to vector-set!"); + int ix = m_stack.size() - 1; + cellvector * cv = m_stack.get(ix-2)->VectorValue(); + cv->set(m_stack.get(ix-1)->IntValue(), m_stack.get(ix)); + m_stack.discard(3); + m_stack.push(unspecified); + break; + } + case 29: { // vector-ref + n_args = insn->cd.i; + if (n_args != 2) + error ("bad arguments to vector-ref!"); + int ix = m_stack.pop()->IntValue(); + cellvector * cv = m_stack.pop()->VectorValue(); + m_stack.push(cv->get(ix)); + break; + } + case 30: // car + m_stack.push(car(m_stack.pop())); + break; + case 31: // cdr + m_stack.push(cdr(m_stack.pop())); + break; + case 32: { // zero? + Cell * c = m_stack.pop(); + Cell::Type t = c->type(); + if (t == Cell::Int) + m_stack.push(make_boolean(c->IntValue() == 0)); + else if (t == Cell::Real) + m_stack.push(make_boolean(c->RealValue() == 0.0)); + else + error ("non-numeric type"); + break; + } + case 33: { // + + // get n; see if top n elements are all exact or not; add them + // accumulating in situ (to avoid consing an argument list), + // discard those elements and push the result. + n_args = insn->cd.i; + int sz = m_stack.size (); + if (exact_top_n (&m_stack, n_args)) { + int sum = 0; + for (int ix = sz - n_args; ix < sz; ++ix) + sum += m_stack.get (ix)->IntValue(); // exact_top_n guarantees this is OK + m_stack.discard (n_args); + m_stack.push(make_int(sum)); + } else { + double sum = 0.0; + for (int ix = sz - n_args; ix < sz; ++ix) + sum += m_stack.get (ix)->asReal (); + m_stack.discard(n_args); + m_stack.push(make_real(sum)); + } + break; + } + case 34: { // * + // much like +, above. + n_args = insn->cd.i; + int sz = m_stack.size (); + if (exact_top_n (&m_stack, n_args)) { + int product = 1; + for (int ix = sz - n_args; ix < sz; ++ix) + product *= m_stack.get (ix)->IntValue(); // exact_top_n says this is OK + m_stack.discard (n_args); + m_stack.push(make_int(product)); + } else { + double product = 1.0; + for (int ix = sz - n_args; ix < sz; ++ix) + product *= m_stack.get (ix)->asReal (); + m_stack.discard(n_args); + m_stack.push(make_real(product)); + } + break; + } + case 35: { // quotient + if (insn->cd.i != 2) + error ("wrong # args"); + int d = m_stack.pop()->IntValue(); + int n = m_stack.pop()->IntValue(); + if (d == 0) + error ("/0"); + m_stack.push (make_int (n/d)); + break; + } + case 36: { // remainder + if (insn->cd.i != 2) + error ("wrong # args"); + int d = m_stack.pop()->IntValue(); + int n = m_stack.pop()->IntValue(); + if (d == 0) + error ("/0"); + m_stack.push (make_int (n%d)); + break; + } + case 37: { // - + // get n; see if top n elements are all exact or not; add them + // accumulating in situ (to avoid consing an argument list), + // discard those elements and push the result. + n_args = insn->cd.i; + int sz = m_stack.size (); + if (exact_top_n (&m_stack, n_args)) { + if (n_args == 1) { + m_stack.push(make_int(-m_stack.pop()->IntValue())); + } else { + int difference = m_stack.get(sz-n_args)->IntValue(); + for (int ix = sz - n_args + 1; ix < sz; ++ix) + difference -= m_stack.get (ix)->IntValue(); + m_stack.discard (n_args); + m_stack.push(make_int(difference)); + } + } else { + if (n_args == 1) { + m_stack.push(make_real(-m_stack.pop()->asReal())); + } else { + double difference = m_stack.get(sz-n_args)->asReal(); + for (int ix = sz - n_args + 1; ix < sz; ++ix) + difference -= m_stack.get (ix)->asReal(); + m_stack.discard(n_args); + m_stack.push(make_real(difference)); + } + } + break; + } + case 38: // not + m_stack.push(m_stack.pop()->istrue() + ? &Cell::Bool_F : &Cell::Bool_T); + break; + case 39: // null? + m_stack.push(m_stack.pop() == &Cell::Nil + ? &Cell::Bool_T : &Cell::Bool_F); + break; + case 40: // eq? + m_stack.push(m_stack.pop()->eq(m_stack.pop()) + ? &Cell::Bool_T : &Cell::Bool_F); + break; + case 41: // pair? + m_stack.push(m_stack.pop()->ispair() + ? &Cell::Bool_T : &Cell::Bool_F); + break; + case 42: // cons (watch out: order matters, and cons can provoke GC.) + r_tmp = m_stack.pop(); + r_elt = m_stack.pop(); + m_stack.push(cons(r_elt, r_tmp)); + break; + case 43: { // gref. (quickened global ref; contains index of target binding) + m_stack.push(cdr(root_bindings->get(insn->cd.i))); + break; + } + case 44: // false + m_stack.push(&Cell::Bool_F); + break; + case 45: // true + m_stack.push(&Cell::Bool_T); + break; + case 46: // int + m_stack.push(make_int(insn->cd.i)); + break; + case 47: // promise + restore(start); + r_tmp = make_compiled_procedure(r_cproc->cd.cv->get(0), + r_cproc->cd.cv->get(1), + r_envt, + start); + m_stack.push(make_compiled_promise(r_tmp)); + break; + case 48: // gset. + Cell::setcdr(root_bindings->get(insn->cd.i), m_stack.pop()); + break; + default: + error ("unimplemented opcode_"); + } + ++pc; + goto XEQ; + FINISH: + if (count_insns) { + for (int ix = 0; ix < n_vmops; ++ix) + printf ("%s:%d ", optab[ix].opcode->key, xcount [ix]); + printf ("\n"); + } + if (m_stack.size() != initial_stackdepth) { + fprintf(stderr,"stack imbalance: %d (%d expected)\n", m_stack.size(), + initial_stackdepth); + } + return r_val; +} + +// find_op: match the supplied opcode symbol in the vm_op table; +// return the index (or -1 if the opcode is not in the table). + +int find_op (psymbol opsym) +{ + for (int ix = 0; ix < n_vmops; ++ix) + if (optab[ix].opcode == opsym) + return ix; + return -1; +} + +// Make compiled procedure (method and subr): store the +// current code segment, the environment, and program counter +// in an object. + +static Cell* make_compiled_procedure (Context * ctx, Cell * arglist) +{ + return ctx->make_compiled_procedure (car (arglist), + cadr (arglist), + nil, + 0); +} + +Cell * Context::make_compiled_procedure (Cell * insns, + Cell * literals, + Cell * envt, + int start) +{ + Cell * c = gc_protect (alloc (Cell::Cproc)); + cellvector * cv = cellvector::alloc(4); + + c->cd.cv = cv; + c->flag (Cell::VREF, true); + cv->set (0, insns); + cv->set (1, literals); + cv->set (2, envt); + cv->set (3, make_int (start)); + gc_unprotect (); + + return c; +} + +Cell* Context::make_compiled_promise(Cell* procedure) { + Cell * c = gc_protect(alloc(Cell::Cpromise)); + cellvector* cv = cellvector::alloc(1); + c->cd.cv = cv; + c->flag(Cell::VREF, true); + cv->set(0, procedure); + gc_unprotect(); + return c; +} + +Cell* Context::force_compiled_promise(Cell* promise) { + promise->typecheck(Cell::Cpromise); + if (promise->flag(Cell::FORCED)) return promise->cd.cv->get(0); + Cell* val = execute(promise->cd.cv->get(0), nil); + // Did the promise become forced as a result of our evaluation? + // then that value is correct. + if (promise->flag(Cell::FORCED)) return promise->cd.cv->get(0); + promise->cd.cv->set(0, val); + promise->flag(Cell::FORCED, true); + return val; +} + +// make_instruction: produce a packed machine instruction given +// an instruction in list form (e.g., '(consti 99) ). + + +static Cell* make_instruction (Context * ctx, Cell * arglist) +{ + //return ctx->make_instruction (car (arglist)); + return ctx->make_instruction (arglist); +} + + +Cell* Context::make_instruction (Cell * insn) { + psymbol op = car(insn)->SymbolValue(); + int opcode = find_op(op); + if (opcode < 0) + error ("unknown opcode: ", op->key); + return make_instruction(opcode, cdr(insn)); +} + +Cell* Context::make_instruction(int opcode, Cell* operands) +{ + unsigned int u1, u2; + psymbol y; + Cell * opnd = operands == nil ? nil : car(operands); + + Cell * c = alloc (Cell::Insn); + c->ca.i |= (opcode & 0xff) << 24; + + switch (optab[opcode].opnd_type) + { + case OP_INT: + c->cd.i = opnd->IntValue (); + break; + case OP_SYMBOL: + c->cd.y = opnd->SymbolValue (); + break; + case OP_SUBR: { + int count = cadr(operands)->IntValue (); + if (count < 0 || count > 255) + error ("count too large to store in instruction field"); + c->ca.i |= count << 16; + y = opnd->SymbolValue(); + // Store the symbol in the operand field. The evaluator + // will "quicken" the reference when the code is run. + c->cd.y = y; + break; + } + case OP_LEXADDR: + u1 = opnd->IntValue (); + u2 = cadr(operands)->IntValue (); + if (u1 > 65535 || u2 > 65535) + error ("lexical address too large"); + c->cd.i = (u1 << 16) | u2; + break; + case OP_NONE: + break; + default: + error ("unhandled operand type"); + } + return c; +} + +static Cell* execute(Context* ctx, Cell* arglist) { + return ctx->execute (car (arglist), cdr(arglist)); +} + +static Cell* disassemble(Context* ctx, Cell* arglist) { + cellvector* cproc = car(arglist)->CProcValue(); + cellvector* insns = cproc->get (0)->VectorValue (); + for (int ix = 0; ix < insns->size(); ++ix) { + ctx->print_insn(ix, insns->get(ix)); + } + return unspecified; +} + +static Cell* write_compiled_procedure(Context* ctx, Cell* arglist) { + return ctx->write_compiled_procedure(arglist); +} + +// Context::load_compiled_procedure +// Turn a serialized compiled procedure into a "live" procedure, by +// reading the saved instructions and literals back into the Scheme +// heap. +// WARNING: This is expected to be called by the startup code with +// GC disabled. + +Cell* Context::load_compiled_procedure(vm_cproc *cp) { + // We create a static argument list of two elements, which we reuse. + Cell* insns = load_instructions(cp); + Cell* literals = make_vector(cp->n_literals); + cellvector* litv = literals->VectorValue(); + for (unsigned int ix = 0; ix < cp->n_literals; ++ix) { + sstring litstr; + litstr.append(cp->literals[ix]); + Cell* lit = read(litstr); + if (lit == NULL) error("undecipherable literal", cp->literals[ix]); + litv->set(ix, lit); + } + return make_compiled_procedure(insns, literals, nil, cp->entry); +} + +Cell* Context::load_instructions(vm_cproc* cp) { + Cell* zero = make_int(0); + Cell* a1 = cons(zero, nil); + Cell* a0 = cons(zero, a1); // now a0 == '(0 0) + + Cell* insns = make_vector(cp->n_insns); + cellvector* insv = insns->VectorValue(); + for (unsigned int ix = 0; ix < cp->n_insns; ++ix) { + vm_insn* insn = cp->insns + ix; + int opcode = insn->opcode; + if (opcode > n_vmops) error("bad opcode in stored proc"); + Cell::setcar(a0, zero); + Cell::setcar(a1, zero); + switch(optab[opcode].opnd_type) { + case OP_INT: + Cell::setcar(a0, make_int(reinterpret_cast(insn->operand))); + break; + case OP_SYMBOL: + Cell::setcar(a0, + make_symbol( + intern(static_cast(insn->operand)))); + break; + case OP_LEXADDR: { + int la = reinterpret_cast(insn->operand); + Cell::setcar(a0, make_int(la >> 16)); + Cell::setcar(a1, make_int(la & 0xffff)); + break; + } + case OP_SUBR: + Cell::setcar(a0, + make_symbol( + intern(static_cast(insn->operand)))); + Cell::setcar(a1, make_int(insn->count)); + break; + case OP_NONE: + break; + } + insv->set(ix, make_instruction(opcode, a0)); + } + return insns; +} + +static void write_escaped_string(FILE* output, const char* str) { + char c; + fputc('"', output); + while ((c = *str++)) { + switch (c) { + case '\n': + fputc('\\', output); + fputc('n', output); + break; + case '"': + case '\\': + fputc('\\', output); + /* fall through */ + default: + fputc(c, output); + } + } + fputc('"', output); +} + +Cell* Context::write_compiled_procedure(Cell* arglist) { + cellvector* cproc = car(arglist)->CProcValue(); + const char* name = cadr(arglist)->StringValue(); + cellvector* insns = cproc->get(0)->VectorValue(); + cellvector* literals = cproc->get(1)->VectorValue(); + cellvector* root_bindings = car(root_envt)->VectorValue(); + int entry = cproc->get(3)->IntValue(); + FILE* output = current_output()->OportValue(); + fprintf(output, "static vm_insn %s_insns[] = {\n", name); + for (int ix = 0; ix < insns->size(); ++ix) { + Cell* insn = insns->get(ix); + int opcode = INSN_OPCODE(insn); + // Horrible special cases: 'gref./gset.'. A "quickened global + // reference" is an index into a slot in the global environment. + // We can't write it out as is, since it's not likely that all + // global variables will have the same slot in the context into + // which this procedure will be loaded. Instead we write it out as + // an ordinary 'gref', so that it can be quickened in the + // environment in which it actually runs. + if (opcode == 43) { // XXX magic number + fprintf(output, " { %2d,0,", 3); // XXX magic number + write_escaped_string(output, + car(root_bindings->get(insn->cd.i))->SymbolValue()->key); + } else if (opcode == 48) { + fprintf(output, " { %2d,0,", 4); // XXX magic number + write_escaped_string(output, + car(root_bindings->get(insn->cd.i))->SymbolValue()->key); + } else { // not 'gref.' + vm_op* op = optab + opcode; + fprintf(output, " { %2d,", opcode); // XXX magic number + switch(op->opnd_type) { + case OP_NONE: fprintf(output, "0,0"); break; + case OP_INT: fprintf(output, "0,(void*)%d", insn->cd.i); break; + case OP_SYMBOL: fprintf(output, "0,"); + write_escaped_string(output, insn->cd.y->key); break; + case OP_SUBR: + // XXX write a comment + fprintf(output, "%d,", INSN_COUNT(insn)); + if (insn->flag(Cell::QUICK)) + write_escaped_string(output, insn->cd.f->name); + else + write_escaped_string(output, insn->cd.y->key); + break; + case OP_LEXADDR: fprintf(output, "0,(void*)%#x", insn->cd.i); break; + } + } + fprintf(output, " },\n"); + } + + fprintf(output, "};\n\n"); + if (literals->size() > 0) { + fprintf(output, "const char* %s_lit[] = {\n", name); + for (int ix = 0; ix < literals->size(); ++ix) { + sstring litstr; + fputs(" ", output); + literals->get(ix)->write(litstr); + write_escaped_string(output, litstr.str()); + fputs(",\n", output); + } + fprintf(output, "};\n\n"); + } + fprintf(output, "static vm_cproc %s = {\n %s_insns,\n %d,\n", + name, name, insns->size()); + if (literals->size() > 0) { + fprintf(output, " %s_lit,\n %d,\n", name, literals->size()); + } else { + fprintf(output, " 0,\n 0,\n"); + } + fprintf(output, " %d,\n", entry); + fprintf(output, "};\n\n"); + + return unspecified; +} + +// ================================ +// PROVISIONING THE VIRTUAL MACHINE +// + +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); + } + // Initialize the macro table. + ctx->set_var(envt, intern("__macro_table"), nil); + // Attach VM execution function to context, so the interpreter may + // invoke compiled procedures. + ctx->vm_execute = &Context::execute; + ctx->vm_eval = &Context::vm_evaluator; + } +}; + +static VmExtension vm_extension; diff --git a/vx-scheme/src/vx-main.cpp b/vx-scheme/src/vx-main.cpp new file mode 100644 index 0000000..a593f7e --- /dev/null +++ b/vx-scheme/src/vx-main.cpp @@ -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 (rhs->StringValue ()); + else if (t == Cell::Char) + value = rhs->CharValue (); + else + error ("cannot convert rvalue to compatible type"); + + int * pi = static_cast (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 (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 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 (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 (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 (ar->StringValue ()); + else if (t == Cell::Symbol) + { + const char * name = ar->SymbolValue ()->truename; + char * value; + SYM_TYPE type; + + if (symFindByCName (sysSymTbl, + const_cast (name), + &value, + &type) == OK) + a [ix++] = reinterpret_cast (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 (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 (setjmp (jb))) == 0) + interact (&ctx); + else + fprintf (stderr, "caught: %s\n", jv); + } + } + + + diff --git a/vx-scheme/src/vx-scheme.h b/vx-scheme/src/vx-scheme.h new file mode 100644 index 0000000..5cf577a --- /dev/null +++ b/vx-scheme/src/vx-scheme.h @@ -0,0 +1,1223 @@ +//---------------------------------------------------------------------- +// 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-scheme.h : class definitions + +#include +#include +#include +#include +#include +#ifndef WIN32 +#include +#else +#include +// We need to do bit manipulations on pointers in order to +// implement our storage model (garbage collection bits, etc.) +// MSVC quite properly complains about this, but since it's +// necessary in this case we squelch the warnings. +#pragma warning (disable : 4311) +#pragma warning (disable : 4312) +#endif +#if __GNUG__ >= 3 +using namespace std; // so sue me +#endif +#if defined (__GNUC__) +// Statically allocated cells must lie upon an 8-byte +// boundary, so that the lower three bits of pointers +// to such objects are free for our use. +#define ALIGN8 __attribute__ ((aligned (8))) +#define PACKED __attribute__ ((packed)) +#elif defined (WIN32) +#define PACKED +#define ALIGN8 __declspec(align(8)) +#else +#error "must have a way of aligning Cells to 8-byte boundary" +#endif + + +class OS; +class Cell; +class Slab; +class Context; + +// OS abstraction layer + +class OS + { + public: + + static double get_time(); // get timestamp + static bool interactive (int fd); // terminal input? + // supply value for undef symbol + static Cell * undef (Context *, const char *); + // report exception and restart + static void exception (const char *); + // manage debug flags + static unsigned int flags (); + static bool flag (int bit) + { return (flags () & bit) != 0; } + }; + +typedef Cell * (* subr_f) (Context * ctx, Cell * arglist); +typedef void (* magic_set_f) (Context *, void * key, Cell * rhs); +typedef Cell * (* magic_get_f) (Context *, void * key); +extern Cell * nil; +extern Cell * unspecified; +extern Cell * unassigned; +extern Cell * unimplemented; + +void error (const char *, const char * = 0); + +// FOR_EACH is a macro that can be used to traverse a standard Scheme +// list. The variable `var' is bound for the duration of the traversal +// to each node in the list. + +#define FOR_EACH(var,list) \ + for (Cell * var = list; var != nil; var = Cell::cdr (var)) + +#define INTERN_SYM(sym, symname) \ + psymbol sym = intern (symname); + +class cellvector + { + public: + + // Acquire from Freelist + static cellvector* alloc(int size); + static cellvector* alloc(int size, int allocate); + // Return to freelist + void free(); + + cellvector (int size = 0); + cellvector (int size, int alloc); + ~cellvector (); + + Cell * get(int ix) + { if (ix < 0 || ix >= sz) vref_error (); return v [ix]; } + void set (int, Cell *); + + // used when you know the reference is in bounds. + Cell *get_unchecked(int ix) { return v[ix]; } + void set_unchecked(int ix, Cell* c) { v[ix] = c; } + + Cell *& operator [] (int); + Cell * top () + { if (sz <= 0) vref_error (); return v [sz-1]; } + void push (Cell * c) + { if (sz == allocated) expand (); v [sz++] = c; } + Cell * pop () + { if (sz <= 0) vref_error (); return v [--sz]; } + Cell * shift (); + void unshift (Cell *); + + int size () {return sz;} + void discard (int n = 1) + { if (n < 0 || n > sz) vref_error (); sz -= n; } + + void clear(); + + private: + + void make_cv (int size, int alloc); + void expand (); + void vref_error (); + int sz; + int allocated; + friend class Context; // Context::gc needs to see our gc_* members + int gc_index; + union { + Cell * gc_uplink; + cellvector* next_free; + }; + Cell ** v; + + // Freelist. We keep allocated storage for "short" cellvectors. + + static const int keep_size = 4; + static const int keep_count = 100; + static cellvector* freelist_head[keep_size+1]; + static int freelist_count[keep_size+1]; + }; + +// The symbol table is implemented as an AVL tree of these nodes. +// There's no repetition, so the address of one of these nodes can +// serve as a unique hashcode for a symbol for equality-testing +// purposes. There's one call, intern(), for introducing a new +// string to the collection. +// +// The Scheme standard, however, introduces one complication: the +// requirement that symbols be stored in a "standard case." This +// is in conflict with our desire to have case-sensitive symbol +// matching (for integration with underlying symbol tables). (Scheme +// also provides the primitive string->symbol, which can be used to +// create symbols outside of standard case, but the REPL is not +// expected to use this.) +// +// In the end I decided to spend some extra memory to achieve standard +// compliance and VxWorks symbol table integration at the same time. +// We choose to consider lower-case symbols as "canonical". (The standard +// says we must choose upper or lower case, but not which one). In the event +// that a symbol arrives in mixed case, we store it both ways: canonically +// (that is, with lowered case) for Scheme symbol lookup, and unmolested +// so that, when we try the VxWorks symbol table after all else has failed, +// we can respect the case of the sybmol as written. + +typedef struct _symbol + { + struct _symbol * llink; // Left binary tree link */ + struct _symbol * rlink; // Right binary tree link */ + const char * key; // Search key (symbol name) */ + const char * truename; // case-sensitive name, if diff. */ + cellvector * plist; // property list */ + short b; // Balance factor */ + } symbol, *psymbol; + +psymbol intern (const char * name); +psymbol intern_stet (const char * name); +Cell * vector_from_list (Context * ctx, Cell *); +Cell * vector_to_list (Context * ctx, Cell *); + +// ------------------------------------------------------------------------ +// class sio: input/output behavior we expect from strings or streams. +// interface class. + +class sio + { + public: + virtual ~sio() {} + virtual int get() = 0; + virtual int peek() = 0; + virtual void unget() = 0; + virtual void ignore() = 0; + }; + +// ------------------------------------------------------------------------ +// class file_sio: This wraps a FILE* into an object that answers to +// the above interface. + +class file_sio : public sio + { + public: + + file_sio (FILE * _fp) : fp (_fp), lastch (-1) {}; + + virtual int get () { return lastch = fgetc (fp); } + virtual int peek () { int c = get (); ungetc (c, fp); return c; } + virtual void unget () { ungetc (lastch, fp); } + virtual void ignore () { get (); } + + private: + + FILE * fp; + int lastch; + }; + +// ------------------------------------------------------------------------ +// An "sstring" is a simple extensible string. It reallocates storage +// as necessary to support arbitrary growth. It is a poor cousin to +// STL's string, but with considerably less code-bloat since there's no +// template expansion or nontrivial inlining. +// +// In order to avoid involving the strstream class, we also extend +// our sstream with a small amount of I/O semantics. This allows +// sstrings to be passed to the lexical analyzer. + + +class sstring : public sio + { + public: + + sstring (); + virtual ~sstring (); + + char * str () + { return base; } + char & operator [] (size_t ix) + { return base [ix]; } + + void append (const char *); + void append (const char *, size_t len); + void append (const char); + size_t length () + { return sz; } + void claim (); // claim dynamic storage + bool operator == (const char * s) + { return !strcmp (base, s); } + + // I/O behavior + + int get (); + int peek (); + bool eof (); + void unget (); + void ignore (); + + private: + + static const int stat_size = 32; + char c [stat_size]; + + size_t sz; + size_t alloc; + char * base; + char * end; + char * pos; // I/O read position + bool claimed; + }; + +//---------------------------------------------------------------------- +// class Cell +// +// The Cell is the heart of the Scheme implementation. It is the +// universal container for all Scheme data types and also the central +// structure supporting Scheme's garbage-collected memory model. +// The economy of a Cell's realization is the single most significant +// factor influencing the speed and space efficiency of a Scheme +// system (with the possible exception of compilation, beyind the +// scope of this header file). +// +// We consider it imperative that an ordinary cell be no larger than +// two machine pointers (car and cdr); if a data object requires +// more storage than this, we allocate extension words. +// +// For our implementation, we expect that a machine pointer is at +// least four bytes, so that two of these (car,cdr) will occupy +// eight bytes. In consequence, we may therefore insist that the +// storage for cells be 8-byte aligned, which gives us three bits at +// the least-significant end of a cell pointer to use as type-tagging +// information. + +class Cell + { + friend class Context; + friend class Slab; + friend class InterpreterExt; + +public: + + typedef Cell * ptr; + + void display (FILE *); + void write(FILE *) const; + void write(sstring&) const; + + bool eq (Cell * c); + bool eqv (Cell * c) + { + return eq (c); + } + + bool equal (Cell * c); + bool is_symbol (psymbol s) + { + return type () == Cell::Symbol && SymbolValue () == s; + } + + struct Procedure + { + Procedure (Cell * _envt, Cell * _body, Cell * _arglist) + : body (_body), + arglist (_arglist), + envt (_envt) + {} + + Procedure () + : body (nil), + arglist (nil), + envt (nil) + {} + + Cell * body; + Cell * arglist; + Cell * envt; + }; + + // Certain cells we have heard of + + ALIGN8 static Cell Nil; + ALIGN8 static Cell Unspecified; + ALIGN8 static Cell Unassigned; + ALIGN8 static Cell Eof_Object; + ALIGN8 static Cell Bool_T; + ALIGN8 static Cell Bool_F; + ALIGN8 static Cell Apply; + ALIGN8 static Cell Error; + ALIGN8 static Cell Halt; + ALIGN8 static Cell Unimplemented; + + // Access/Mutate Cons Cells. These are checked calls, in + // that they will verify that they are traversing a set of + // cons cells at each step, using "assert_cons", which + // throws a C++ exception if this is not found to be true. + + static void setcar (Cell * c, Cell * car) + { atomic (c) ? notcons() : (c->ca.p = car); } + static void setcdr (Cell * c, Cell * cdr) + { atomic (c) ? notcons() : (c->cd.p = cdr); } + static Cell * car (const Cell * c) + { return atomic (c) ? notcons() : c->ca.p; } + static Cell * cdr (const Cell * c) + { return atomic (c) ? notcons() : c->cd.p; } + static Cell * caar (Cell * c); + static Cell * cadr (Cell * c); + static Cell * cdar (Cell * c); + static Cell * cddr (Cell * c); + static Cell * caaar (Cell * c); + static Cell * caadr (Cell * c); + static Cell * cadar (Cell * c); + static Cell * caddr (Cell * c); + static Cell * cdaar (Cell * c); + static Cell * cdadr (Cell * c); + static Cell * cddar (Cell * c); + static Cell * cdddr (Cell * c); + static Cell * caaaar (Cell * c); + static Cell * caaadr (Cell * c); + static Cell * caadar (Cell * c); + static Cell * caaddr (Cell * c); + static Cell * cadaar (Cell * c); + static Cell * cadadr (Cell * c); + static Cell * caddar (Cell * c); + static Cell * cadddr (Cell * c); + static Cell * cdaaar (Cell * c); + static Cell * cdaadr (Cell * c); + static Cell * cdadar (Cell * c); + static Cell * cdaddr (Cell * c); + static Cell * cddaar (Cell * c); + static Cell * cddadr (Cell * c); + static Cell * cdddar (Cell * c); + static Cell * cddddr (Cell * c); + + + // "Boxes" to hold things related to atoms that won't fit in a cell. + // We need one of these whenever the atom has two words or more of + // data. They are allocated from the heap and are freed when a gc'd + // atom is finalized. + + struct SubrBox + { + subr_f subr; + const char * name; + }; + + struct MagicBox + { + void* key; + magic_set_f set_f; + magic_get_f get_f; + }; + + // We store length with strings. When these are allocated we + // preallocate the string space; freeing this object discards + // both box and string. + + struct StringBox + { + size_t length; + char s[1]; + }; + + // Value extractors + + int IntValue () const; + char CharValue () const; + SubrBox * SubrValue () const; + char * StringValue () const; + size_t StringLength () const; + FILE * IportValue () const; + FILE * OportValue () const; + void * ContValue () const; + cellvector * VectorValue () const; + cellvector * CProcValue () const; + Cell * PromiseValue () const; + psymbol SymbolValue () const; + psymbol BuiltinValue () const; + Procedure LambdaValue () const; + double RealValue () const; + const char * name () const; + + // unsafe accessors: use when you have prior knowledge that the + // cell contains an atom of the proper type. + + cellvector * unsafe_vector_value() const { + return cd.cv; + } + + static void real_to_string (double, char *, int); + + double asReal () const { + if (type () == Cell::Int) + return (double) IntValue(); + else + return RealValue(); + } + + + + // In scheme, the only two values of type `boolean' are #t and + // #f. However, from the point of view of truth valuation, + // anything other than #f is considered `true'. We follow the + // Scheme standard strictly, and so do not consider nil to have + // a false connotation as it would in other dialects of Lisp. + + bool isBoolean () {return this == &Bool_T || this == &Bool_F;} + bool istrue () {return this != &Bool_F; } + bool ispair(); + + static Cell * untagged (Cell *); + + // Utilities + int length () + { + int i = 0; + + FOR_EACH (p, this) + ++i; + + return i; + } + + class List + { + public: + + List () : h (&Nil), t (&Nil) + {} + + void append (Cell * c) + { + if (t == &Nil) + h = t = c; + else + { + Cell::setcdr (t, c); + t = c; + } + } + + void append_list(Cell* list_head, Cell* list_tail) { + if (h == &Nil) { + h = list_head; + t = list_tail; + } else { + Cell::setcdr(t, list_head); + t = list_tail; + } + } + + Cell * head () { return h; } + Cell * tail () { return t; } + + private: + + Cell * h; // head + Cell * t; // tail + }; + + void list_append (Cell *& head, Cell *& tail) + { + if (tail == &Nil) + { + head = tail = this; + } + else + { + setcdr (tail, this); + tail = this; + } + } + + static void stats (); + static void sanity_check (); + + enum Type + { + //------------ + Int = 0, // The Atoms... + Symbol = 1, + Unique = 2, + String = 3, + Real = 4, + Subr = 5, + Lambda = 6, + Vec = 7, + Char = 8, + Iport = 9, + Oport = 10, + Promise = 11, + Cont = 12, + Builtin = 13, + Magic = 14, + Insn = 15, + Cproc = 16, + Cpromise = 17, + + NUM_ATOMS = 18, + //------------ + Cons = NUM_ATOMS, // A cell. + NUM_TYPES = Cons + 1 + //------------ + }; + + // If the ATOM bit is clear, it's a cons. Otherwise, the type + // is stored in the TYPEBITS field, unless it's a short integer. + + Type type () const + { + if (short_atom (this)) + return Int; + return (Type) (((ca.i & (ATOM|SHORT)) == ATOM) + ? ((ca.i >> TAGBITS) & TYPEMASK) + : Cons); + } + + void typecheck (Type t) const + { + if (type () != t) + typefail (type (), t); + } + + bool macro () const + { + return flag (MACRO); + } + + private: + + static inline bool short_atom (const Cell * c) + { return (reinterpret_cast (c) & (ATOM|SHORT)) + == (ATOM|SHORT); } + static inline bool long_atom (const Cell* c) + { return (reinterpret_cast (c) & (ATOM|SHORT)) == ATOM; } + static inline bool atomic (const Cell * c) + { return short_atom (c) || ((c->ca.i & (ATOM|SHORT)) == ATOM); } + + void gc_set_car (Cell *); + void gc_set_cdr (Cell *); + static Cell * notcons (); + + Cell () + { + ca.p = cd.p = &Nil; + } + + Cell (const char * unique_name) + { + ca.i = 0; + set_type (Unique); + cd.u = unique_name; + } + + void typefail (Type t1, Type t2) const; + + // The lowest order three bits of a pointer are called the + // tagbits. They are always free for our use, since a cell + // consists of two words, each at least 32 bits, with the + // natural alignment (8 bytes for a 32-bit machine). + + static const unsigned int TAGBITS = 3; + static const unsigned int ATOM = 0x1; + static const unsigned int MARK = 0x2; + static const unsigned int SHORT = 0x4; + + static const unsigned int TYPEBITS = 5; + static const unsigned int TYPEMASK = (1 << TYPEBITS) - 1; + static const unsigned int TAGMASK = (1 << TAGBITS) - 1; + // Make sure flag bits are disjoint from TYPE and TAG bits. + static const unsigned int FLAGBASE = 1 << (TYPEBITS + TAGBITS); + static const unsigned int FORCED = FLAGBASE; + static const unsigned int QUICK = FLAGBASE << 1; + static const unsigned int GLOBAL = FLAGBASE << 2; + static const unsigned int MACRO = FLAGBASE << 3; + static const unsigned int VREF = FLAGBASE << 4; + static const unsigned int FREE = FLAGBASE << 5; + static const unsigned int FLAGBITS = 6; + + static const int GLOBAL_ENV = -1; + + // Warning! The virtual machine instructions use the upper + // 16 bits of the car for the opcode, and count field, + // so space for types, tags, and flags is limited to 16 bits. + +#if TAGBITS + TYPEBITS + FLAGBITS > 16 +#error too many atom bits used +#endif + + inline int e_skip () { + // If global symbol, return -1. Else number of environments + // to skip is in highest-order byte + return (ca.i & GLOBAL) ? GLOBAL_ENV + : (int)((ca.i >> (8*(sizeof(ca.i)-1))) & 0xff); + } + + inline int b_skip () { + // If global symbol, number of bindings to skip is in upper 16 + // bits; else, it's in 2nd-highest-order byte + return (ca.i & GLOBAL) ? (ca.i >> (8*(sizeof(ca.i)-2)) & 0xffff) + : ((ca.i >> (8*(sizeof(ca.i)-2))) & 0xff); + } + + void set_lexaddr (int e_skip, int b_skip) { + // If global, set flag and store b_skip in upper 16 bits. + // Else set e_skip in upper 8 bits, and set b_skip in + // next 8 bits. + const int start_bit = 8*(sizeof(ca.i)-2); + const int two_bytes = (1 << 16) - 1; + ca.i &= ~(two_bytes << start_bit); + if (e_skip == -1) + ca.i |= (b_skip << start_bit) | GLOBAL | QUICK; + else + ca.i |= ((e_skip << 8 | b_skip) << start_bit) | QUICK; + } + + // The set of bits which should be ignored when + // comparing two cells in the sense of "eq?". We ignore the + // pieces having to do with lexical addresses. + + static const unsigned int IGNORE = QUICK | GLOBAL | (~0 << 16); + static const unsigned int IGN_MASK = ~IGNORE; + + static const char * typeName [NUM_TYPES]; + static int typeCount [NUM_TYPES]; + + void flag (unsigned int f, bool b) + { + if (b) + ca.i |= f; + else + ca.i &= ~f; + } + + void dump (FILE *); + bool flag (unsigned int f) const + { + // only non-short atoms can have flags. All requested bits must be set + return (ca.i & (f | SHORT | ATOM)) == (f | ATOM); + } + + void set_type (Type t) + { + if (t != Cons) + ca.i |= (t << TAGBITS) | ATOM; + ++typeCount [t]; + } + + // The actual data for an Atom/Cell is here. + + union _car + { + unsigned int i; + Cell * p; + } ca; + union _cdr + { + unsigned int i; + double * d; + Cell * p; + const char * u; + SubrBox * f; + MagicBox * m; + StringBox * s; + psymbol y; + Cell * e; + cellvector * cv; + FILE * ip; + FILE * op; + char c; + void * vp; + void * j; + } cd; + }; + +//---------------------------------------------------------------------- +// class Environment +// +// At the simplest level, an Environment is a mapping from symbols +// to values. Symbols are the hash codes maintained by the SymbolTable +// class, and the value of any symbol is simply a pointer to a Scheme +// cell. To implement this simple data structure, we use an STL vector +// of pairs. This choice of data structure is guided +// by some particularities of evaluation in Scheme (discussed below). +// +// Environments are created by binding constructs (like let and lambda), +// and a new environment is always linked to the environment in force +// when it was created (this is called the "enclosing environment"). +// The enclosure chain always terminates at the global environment, which +// is where the symbols representing the language's standard features +// are bound. +// +// In Scheme, all variables are "lexically bound." This means that +// when a variable is mentioned in source code, one can determine the +// binding for that variable at "compile time" by looking through the +// stack of bindings crated by special forms capable of creating such +// bindings (e.g., lambda, let, et al.). The innermost matching binding +// found represents the storage for the value of the variable, and +// this can never change. +// +// This binding model creates the possibility of lexcial addressing, a +// system in which a variable reference can be replaced by the "index" +// of the storage in terms of the number of enclosing environments +// that must be traversed together with the index of the target +// variable within that environment. This represents an extremely +// efficient shortcut for variable value lookup. This is why we +// choose the vector data structure rather than an STL map: while a +// vector is slower to search the first time a variable is referenced, +// that initial search will reveal the "lexical address" of the +// variable, which we can then store in place of the referring symbol. +// It is therefore necessary that variable storage in an environment +// never move, once allocated. The simplest way to guarantee this is +// to manage the bindings ourselves in a vector; the lexical address +// can then be stored in the simple form of two integers and does not +// depend on peculiarities of the data-structure implementation. +// +// We overload the concept of Environment with other data needed to +// evaluate Scheme expressions. For example, Scheme I/O primitives +// like `with-input-from-file' provide for the presence of a stack +// of open files which we maintain in this structure. + +class Context + { + + public: + friend class Cell; + friend class Slab; + friend class VmLibExtension; + + Context (); + + // Argument and environment manipulation for the VM. + + Cell * extend (Cell * env); + Cell * extend (Cell * env, Cell * blist); + Cell * extend_from_vector (Cell * env, cellvector * cv, int n); + void adjoin (Cell * env, Cell * val); + Cell * pop_list (int n); + int push_list (Cell*); + + // "Binding" is the process of asserting a value for a + // variable in the given environment. That is, we do + // not search upward in the enclosure chain for an + // existing binding; we create one in the current environement. + // (The contrast is with `set', which does perform such + // a search. + + void bind (Cell * env, Cell * c, Cell * value); + void bind_arguments (Cell * env, Cell * vars, Cell * values); + void bind_subr (const char * name, subr_f subr); + Cell * find_var (Cell * env, psymbol var, unsigned int* index); + void set_var (Cell * env, psymbol var, Cell * value) { + set_var(env, var, value, 0); + } + void set_var (Cell * env, psymbol var, Cell * value, unsigned int* index); + void set_var (psymbol var, Cell * value, unsigned int* index) { + set_var(root_envt, var, value, index); + } + + // When new bindings are created, the existing environment + // is _extended_ with a vector of new {variable,value} bindings + // provided in parallel-list form. + + // Getting and Setting values in an environment is slightly + // different from binding: `get' will search the enclosure + // chain if necessary, returning the innermost matching binding. + // Set does the same. Both of these will signal an error if + // a binding cannot be found (they will not establish one: only + // bind can do that). + + Cell * get (Cell * env, Cell * c); + void set (Cell * env, Cell * var, Cell * value); + + // root : find the "root" (i.e., parentless) environment + // which contains this one. + + bool read_eval_print (FILE * in, FILE * out, bool); + Cell * root () { return root_envt; } + void gc (); + void gc_if_needed (); + void print_mem_stats (FILE *); + + // "Switching" evaluator: calls the interpreter to evaluate if + // present; else the compiler. + + Cell * eval (Cell* form); + + // Returns true if we are using the bytecode VM. + bool using_vm() const; + + // Interpreting evaluator + + Cell* interp_evaluator(Cell* form); + Cell* (Context::*interp_eval)(Cell* form); + + // VM for compiled code. + // It might not be linked in, in an interpreter-only + // build. The function pointer is used to connect it + // if it is present. + + Cell * execute (Cell* form, Cell* args); + Cell * (Context::*vm_execute)(Cell* form, Cell* args); + Cell * vm_evaluator(Cell* form); + Cell * (Context::*vm_eval)(Cell* form); + + // Convert text to live cells + + Cell * read (sio &); + Cell * read (FILE *); + + // Manufacture Cells and Atoms + + Cell * make (); + Cell * make_int (int i); + Cell * make_char (char ch); + Cell * make_real (double d); + Cell * make_string (size_t len); + Cell * make_string (int len, char ch); + Cell * make_string (const char * s); + Cell * make_string (const char * s, size_t len); + Cell * make_subr (subr_f s, const char * name); + Cell * make_builtin (psymbol y); + Cell * make_symbol (psymbol y); + Cell * make_boolean (bool b); + Cell * make_vector (int n, Cell * init = &Cell::Unspecified); + Cell * make_iport (const char * fname); + Cell * make_iport (FILE *); + Cell * make_oport (const char * fname); + Cell * make_oport (FILE * op); + Cell * make_procedure (Cell * env, Cell * body, Cell * arglist); + Cell * make_promise (Cell * env, Cell * body); + Cell * make_macro (Cell * env, Cell * body, Cell * arglist); + Cell * make_magic (void *, magic_set_f, magic_get_f); + Cell * make (Cell * ca, Cell * cd = &Cell::Nil); + Cell * make_list1 (Cell *); + Cell * make_list2 (Cell *, Cell *); + Cell * make_list3 (Cell *, Cell *, Cell *); + Cell * make_instruction (Cell *insn); + Cell * make_instruction (int opcode, Cell *operands); + Cell * make_compiled_procedure (Cell * insns, Cell * literals, + Cell * envt, int start); + Cell * make_compiled_promise(Cell* procedure); + Cell * force_compiled_promise(Cell* promise); + Cell * make_continuation (); + void load_continuation (Cell * cont); + void print_insn(int pc, Cell* insn); + Cell* write_compiled_procedure (Cell * arglist); + Cell* load_compiled_procedure(struct vm_cproc*); + Cell* load_instructions(vm_cproc*); + + Cell * cons (Cell * _car, Cell * _cdr) { return make (_car, _cdr); } + + // ------------------------------------------------------------ + + void with_input (const char * fname) + { + istack.push (make_iport (fname)); + } + + void with_output (const char * fname) + { + ostack.push (make_oport (fname)); + } + + void without_output () + { + fflush (ostack.pop ()->OportValue ()); + } + + void without_input () + { + istack.pop (); + } + + Cell * current_output () {return ostack.top ();} + Cell * current_input () {return istack.top ();} + + // Protection from garbage collection (cell pointers not contained + // in "register machine" variables need to be treated this way. + // The variables are protected/unprotected in strict LIFO order. + + Cell * gc_protect (Cell * c) + { r_gcp.push (c); return c; } + void gc_unprotect (int ncells = 1) + { r_gcp.discard (ncells); } + + // If the VM has a main procedure linked in, run it and return + // the result; otherwise return NULL (a signal that the driver + // program should enter interactive mode). In the event that + // a value is returned, the caller will probably want to print + // it. + + Cell* RunMain(); + + + private: + + Cell * alloc (Cell::Type t); + void mark (Cell *); + Cell * find (Cell * env, Cell * s); + void quicken (Cell *, int, int); + Cell * eval_list (Cell * list); + void provision (); + void init_machine (); + void print_vm_state (); + void * xmalloc (size_t); + + // =========================== + // Machine Stack Operations + + // The machine stack is just a cellvector, with one difference: + // it can hold integers (marked with the ATOM flag) as well as + // cell pointers. (There are thus only 31 bits in these integers, + // but that's way more than enough to hold the virtual machine + // state. + + void save (Cell * c) { m_stack.push (c); } + void save (Cell & rc) { m_stack.push (rc.ca.p); + m_stack.push (rc.cd.p); } + void save (int i) + { m_stack.push (reinterpret_cast ((i << 1) | Cell::ATOM)); } + void restore (Cell *& c) { c = m_stack.pop (); } + void restore (Cell & rc) { rc.cd.p = m_stack.pop (); + rc.ca.p = m_stack.pop (); } + void restore (int & i) + { i = (reinterpret_cast (m_stack.pop ()) & + static_cast(~Cell::ATOM)) >> 1; } + + // =========================== + // REGISTER MACHINE + // =========================== + + Cell * r_exp; // expression to evaluate + Cell * r_env; // evaluation environment + Cell * r_unev; // args awaiting evaluation + Cell r_argl; // (head,tail) of argument list + Cell r_varl; // (head,tail) of binding list + Cell * r_proc; // procedure to apply + Cell * r_val; // value resulting from evaluation + Cell * r_tmp; // temporary values + Cell * r_elt; // elements assembled into lists + Cell * r_nu; // reference to objects being created + int r_qq; // quasiquotation depth + cellvector r_gcp; // extra cells protected from GC + int r_cont; // current continuation + cellvector m_stack; // recursion/evaluation stack + int state; // current machine state + + // We added a different set of registers for the compiler VM. + // this avoids GC collisions when the interpreter is invoking + // compiled procedures. In the event vx-scheme is configured + // to use only one of the interpreter or compiler, there are + // some slots here that will be unused, but only one per execution + // context. + + Cell * r_envt; // environment + Cell * r_cproc; // current compiled procedure. + + // The assembled instructions to resume a saved continuation + Cell* cc_procedure; + Cell* empty_vector; + + // =========================== + + // routines to append elements to lists (used with r_argl and r_varl). + // Note: r_argl and r_varl MUST be maintained as correctly-formed + // lists, since we use unsafe car/cdr to traverse them. + + void l_appendtail (Cell & l, Cell * t) + { + if (l.ca.p == nil) + l.ca.p = l.cd.p = t; + else + { + l.cd.p->cd.p = t; // l.cd.p->setcdr (t); + l.cd.p = t; + } + } + + void l_append (Cell & l, Cell * t) + { + r_elt = make (t); + l_appendtail (l, r_elt); + } + + void clear (Cell & c) + { + c.ca.p = c.cd.p = nil; + } + + Cell * envt; + Cell * root_envt; + Cell * eval_cproc; + + cellvector istack; // stack of input ports (with-input...) + cellvector ostack; // stack of output ports (with-output...) + + struct Memory + { + cellvector active; // list of allocated Slabs + Cell * free; // freelist of cells + int c_free; // count of free cells + Slab * current () { return (Slab *) active.top (); } + bool low_water; // true if next exhaustion should alloc + bool last_alloc_gc; // true if last allocation provoked gc + bool no_inline_gc; // don't try gc on allocation failure + + Memory () + : active () + { + free = 0; + c_free = 0; + low_water = last_alloc_gc = no_inline_gc = false; + } + }; + + bool ok_to_gc; + Memory mem; + + int cellsAlloc; + int cellsTotal; + }; + +class VxSchemeInit + { + public: + + VxSchemeInit () + { + // Do sanity checks before scheme runs + Cell::sanity_check (); + } + + ~VxSchemeInit () + { + // Print statistics when scheme exits. + Cell::stats (); + } + }; + +class SchemeExtension +{ + public: + virtual ~SchemeExtension() {} + static void Register(SchemeExtension* ext); + static void RunInstall(Context*, Cell*); + static void MainProcedure(SchemeExtension* m) { main = m; } + static bool HaveMain() { return main != NULL; } + static Cell* RunMain(Context* ctx) { return main->Run(ctx); } + + virtual void Install(Context*, Cell*) = 0; + + private: + virtual Cell* Run(Context*) { return &Cell::Bool_F; } + static cellvector* extensions; + static SchemeExtension* main; +}; + +// Simple accessors to avoid the Cell:: scope, which we don't +// really need for simple things like 'car'. + +inline Cell * car (Cell * c) {return Cell::car (c);} +inline Cell * caar (Cell * c) {return Cell::caar (c);} +inline Cell * cdr (Cell * c) {return Cell::cdr (c);} +inline Cell * cdar (Cell * c) {return Cell::cdar (c);} +inline Cell * cadr (Cell * c) {return Cell::cadr (c);} +inline Cell * cddr (Cell * c) {return Cell::cddr (c);} +inline Cell * cadar (Cell * c) {return Cell::cadar (c);} +inline Cell * caddr (Cell * c) {return Cell::caddr (c);} +inline Cell * caadr (Cell * c) {return Cell::caadr (c);} +inline Cell * cdadr (Cell * c) {return Cell::cdadr (c);} +inline Cell * cddar (Cell * c) {return Cell::cddar (c);} +inline Cell * caddar (Cell * c) {return Cell::caddar (c);} +inline Cell * cadaar (Cell * c) {return Cell::cadaar (c);} + + +// Certain syntactic features of Scheme (so-called "syntactic sugar" +// like the `else' clause in a cond statement, the use of `.' to +// construct improper lists and "varargs lambdas", and some of the +// mechanics of quasiquotation) are most easily implemented if we have +// predefined symbols for these tokens. They are not part of the +// global environment, however, and have no definitions themselves. +// We create them with global scope (in the `C' sense) as they can +// serve as invariant hashcodes throughout any universe of Scheme +// execution: there is never any need to compute their values more +// than once, even for multiple threads. + +extern psymbol s_dot; +extern psymbol s_quote; +extern psymbol s_quasiquote; +extern psymbol s_unquote; +extern psymbol s_unquote_splicing; +extern psymbol s_passto; +extern psymbol s_else; +extern psymbol s_time; +extern psymbol s_eval; +extern psymbol s_foreach; +extern psymbol s_load; +extern psymbol s_map; +extern psymbol s_apply; +extern psymbol s_force; +extern psymbol s_delay; +extern psymbol s_defmacro; +extern psymbol s_withinput; +extern psymbol s_withoutput; +extern psymbol s_callwof; +extern psymbol s_callwif; + +// We treat special forms similarly. + +extern psymbol s_if; +extern psymbol s_define; +extern psymbol s_quote; +extern psymbol s_begin; +extern psymbol s_set; +extern psymbol s_or; +extern psymbol s_and; +extern psymbol s_lambda; +extern psymbol s_let; +extern psymbol s_letstar; +extern psymbol s_letrec; +extern psymbol s_do; +extern psymbol s_cond; +extern psymbol s_case; +extern psymbol s_callcc; + +// Execution flags + +#define TRACE_EVAL 0x01 +#define TRACE_GC 0x02 +#define DEBUG_NO_INLINE_GC 0x04 +#define DEBUG_MEMSTATS_AT_EXIT 0x08 +#define DEBUG_PRINT_PROCEDURES 0x10 +#define TRACE_GC_ALL 0x20 +#define TRACE_VM 0x40 +#define TRACE_VMSTACK 0x80 +#define COUNT_INSNS 0x100 + +// Typedefs for compiled procedures in C form. It's possible to serialize +// a compiled procedure into a C data structure that can be used to load +// the bytecode. + +typedef unsigned char byte; + +#if defined(WIN32) +#pragma pack(push, 1) +#endif +struct vm_insn { + byte opcode; + byte count; + const void* operand; +} PACKED; +#if defined(WIN32) +#pragma pack(pop) +#endif + +struct vm_cproc { + vm_insn* insns; + unsigned int n_insns; + const char** literals; + unsigned int n_literals; + int entry; +}; diff --git a/vx-scheme/src/win32/vx-scheme/.cvsignore b/vx-scheme/src/win32/vx-scheme/.cvsignore new file mode 100644 index 0000000..0f3a6b1 --- /dev/null +++ b/vx-scheme/src/win32/vx-scheme/.cvsignore @@ -0,0 +1,2 @@ +Debug +Release diff --git a/vx-scheme/src/win32/vx-scheme/vx-scheme.vcproj b/vx-scheme/src/win32/vx-scheme/vx-scheme.vcproj new file mode 100755 index 0000000..f77618a --- /dev/null +++ b/vx-scheme/src/win32/vx-scheme/vx-scheme.vcproj @@ -0,0 +1,185 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/vx-scheme/src/win32/vxs-bootstrap/.cvsignore b/vx-scheme/src/win32/vxs-bootstrap/.cvsignore new file mode 100644 index 0000000..0f3a6b1 --- /dev/null +++ b/vx-scheme/src/win32/vxs-bootstrap/.cvsignore @@ -0,0 +1,2 @@ +Debug +Release diff --git a/vx-scheme/src/win32/vxs-bootstrap/vxs-bootstrap.vcproj b/vx-scheme/src/win32/vxs-bootstrap/vxs-bootstrap.vcproj new file mode 100755 index 0000000..7af6ee8 --- /dev/null +++ b/vx-scheme/src/win32/vxs-bootstrap/vxs-bootstrap.vcproj @@ -0,0 +1,159 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/vx-scheme/src/win32/vxs-interp/.cvsignore b/vx-scheme/src/win32/vxs-interp/.cvsignore new file mode 100644 index 0000000..0f3a6b1 --- /dev/null +++ b/vx-scheme/src/win32/vxs-interp/.cvsignore @@ -0,0 +1,2 @@ +Debug +Release diff --git a/vx-scheme/src/win32/vxs-interp/vxs-interp.vcproj b/vx-scheme/src/win32/vxs-interp/vxs-interp.vcproj new file mode 100755 index 0000000..72afba9 --- /dev/null +++ b/vx-scheme/src/win32/vxs-interp/vxs-interp.vcproj @@ -0,0 +1,154 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/vx-scheme/testcases/.cvsignore b/vx-scheme/testcases/.cvsignore new file mode 100644 index 0000000..bfca292 --- /dev/null +++ b/vx-scheme/testcases/.cvsignore @@ -0,0 +1,2 @@ +*.out +tmp? diff --git a/vx-scheme/testcases/ack.scm b/vx-scheme/testcases/ack.scm new file mode 100644 index 0000000..8aec687 --- /dev/null +++ b/vx-scheme/testcases/ack.scm @@ -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) diff --git a/vx-scheme/testcases/boyer.scm b/vx-scheme/testcases/boyer.scm new file mode 100644 index 0000000..099e1cc --- /dev/null +++ b/vx-scheme/testcases/boyer.scm @@ -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) diff --git a/vx-scheme/testcases/c-good/ack.good b/vx-scheme/testcases/c-good/ack.good new file mode 100755 index 0000000..ce579ec --- /dev/null +++ b/vx-scheme/testcases/c-good/ack.good @@ -0,0 +1,3 @@ +253 +509 +1021 diff --git a/vx-scheme/testcases/c-good/boyer.good b/vx-scheme/testcases/c-good/boyer.good new file mode 100644 index 0000000..56ed4c7 --- /dev/null +++ b/vx-scheme/testcases/c-good/boyer.good @@ -0,0 +1 @@ +#t diff --git a/vx-scheme/testcases/c-good/cf.good b/vx-scheme/testcases/c-good/cf.good new file mode 100644 index 0000000..9ae7610 --- /dev/null +++ b/vx-scheme/testcases/c-good/cf.good @@ -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) diff --git a/vx-scheme/testcases/c-good/dderiv.good b/vx-scheme/testcases/c-good/dderiv.good new file mode 100644 index 0000000..4acc996 --- /dev/null +++ b/vx-scheme/testcases/c-good/dderiv.good @@ -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) diff --git a/vx-scheme/testcases/c-good/dynamic.good b/vx-scheme/testcases/c-good/dynamic.good new file mode 100644 index 0000000..c460021 --- /dev/null +++ b/vx-scheme/testcases/c-good/dynamic.good @@ -0,0 +1 @@ +((218 . 437) (6 . 1892) (2204 . 441)) diff --git a/vx-scheme/testcases/c-good/earley.good b/vx-scheme/testcases/c-good/earley.good new file mode 100644 index 0000000..4efaa29 --- /dev/null +++ b/vx-scheme/testcases/c-good/earley.good @@ -0,0 +1 @@ +1430 diff --git a/vx-scheme/testcases/c-good/maze.good b/vx-scheme/testcases/c-good/maze.good new file mode 100644 index 0000000..ff530a6 --- /dev/null +++ b/vx-scheme/testcases/c-good/maze.good @@ -0,0 +1,42 @@ + _ _ _ + _/ \_/ \_/.\ +/ \ \_ . /.\ +\ \ /. _/.\ / +/ \_/. _/ \_ .\ +\ / \ / _/ \_/ +/ _/.\ / \ / \ +\ / \ / _/ / +/ \ /.\ /.\_/ \ +\_/ \ /. _ .\ / +/ \_ . _/ \ \ +\_ \_/ _/.\ / +/ _/ / \ / \ +\_ \ / \_ .\_/ +/ \_ \_ \_ .\ +\_ \_/ _/.\ / +/ \_ \ /.\ .\ +\ /.\_ . /.\ / +/ . _/.\ / \ +\ /.\_/.\_ .\ / +/ \_ . / _/ \ +\_ \_/.\_ \_/ +/ _/ \ / \_ \ +\_/ _/.\_ \_/ +/ \ / _ . _ \ +\ / \_/. _ \_/ +/ _ \ \_/ \ +\_/.\_ .\_/ _/ +/ \ . _/ / \ +\ /.\_/ \_/.\ / +/ \_ . _/. \ +\ . /.\_/ +/ \_/ \_/ \_ .\ +\_/ / \_/. / +/ / _ \ / \ +\_/ \_/ \_/.\_/ +/ \_/ _/ \_ .\ +\ _/. /. _/ +/ \ /. / \_ .\ +\_/. _/.\_/.\ / +/ _ .\_ . _ .\ +\_/ \ / \_/ \_/ diff --git a/vx-scheme/testcases/c-good/pi.good b/vx-scheme/testcases/c-good/pi.good new file mode 100755 index 0000000..fe40b33 --- /dev/null +++ b/vx-scheme/testcases/c-good/pi.good @@ -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 diff --git a/vx-scheme/testcases/c-good/puzzle.good b/vx-scheme/testcases/c-good/puzzle.good new file mode 100644 index 0000000..9284822 --- /dev/null +++ b/vx-scheme/testcases/c-good/puzzle.good @@ -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. diff --git a/vx-scheme/testcases/c-good/r4rstest.good b/vx-scheme/testcases/c-good/r4rstest.good new file mode 100644 index 0000000..e85ba9e --- /dev/null +++ b/vx-scheme/testcases/c-good/r4rstest.good @@ -0,0 +1,772 @@ +SECTION(2 1) +SECTION(3 4) + # + # + # + # + # + # + # + # + # +(#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)# +(#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) +(# 3 4) ==> 12 +SECTION(4 1 4) +(# 4) ==> 8 +(# 7 10) ==> 3 +(# 6) ==> 10 +(# 3 4 5 6) ==> (3 4 5 6) +(# 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 +(# 6) ==> 9 +SECTION(5 2 2) +(define 45) ==> 45 +(#) ==> 5 +(define 34) ==> 34 +(#) ==> 5 +(define 34) ==> 34 +(# 88) ==> 88 +(# 4) ==> 4 +(define 34) ==> 34 +(internal-define 99) ==> 99 +(internal-define 77) ==> 77 +SECTION(6 1) +(# #t) ==> #f +(# 3) ==> #f +(# (3)) ==> #f +(# #f) ==> #t +(# ()) ==> #f +(# ()) ==> #f +(# nil) ==> #f +SECTION(6 2) +(# a a) ==> #t +(# a b) ==> #f +(# 2 2) ==> #t +(# () ()) ==> #t +(# 10000 10000) ==> #t +(# (1 . 2) (1 . 2)) ==> #f +(# # #) ==> #f +(# #f nil) ==> #f +(# # #) ==> #t +(# # #) ==> #t +(# # #) ==> #f +(# # #) ==> #f +(# a a) ==> #t +(# (a) (a)) ==> #f +(# () ()) ==> #t +(# # #) ==> #t +(# (a) (a)) ==> #t +(# #() #()) ==> #t +(# # #) ==> #t +(# a a) ==> #t +(# (a) (a)) ==> #t +(# (a (b) c) (a (b) c)) ==> #t +(# "abc" "abc") ==> #t +(# 2 2) ==> #t +(# #(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) +(# (a b c)) ==> #t +(set-cdr! (a . 4)) ==> (a . 4) +(# (a . 4) (a . 4)) ==> #t +(dot (a b c . d)) ==> (a b c . d) +(# (a . 4)) ==> #f +(list? #f) ==> #f +(# a ()) ==> (a) +(# (a) (b c d)) ==> ((a) b c d) +(# "a" (b c)) ==> ("a" b c) +(# a 3) ==> (a . 3) +(# (a b) c) ==> ((a b) . c) +(# (a b c)) ==> a +(# ((a) b c d)) ==> (a) +(# (1 . 2)) ==> 1 +(# ((a) b c d)) ==> (b c d) +(# (1 . 2)) ==> 2 +(# a 7 c) ==> (a 7 c) +(#) ==> () +(# (a b c)) ==> 3 +(# (a (b) (c d e))) ==> 3 +(# ()) ==> 0 +(# (x) (y)) ==> (x y) +(# (a) (b c d)) ==> (a b c d) +(# (a (b)) ((c))) ==> (a (b) (c)) +(#) ==> () +(# (a b) (c . d)) ==> (a b c . d) +(# () a) ==> a +(# (a b c)) ==> (c b a) +(# (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) +(# (a b c d) 2) ==> c +(# a (a b c)) ==> (a b c) +(# b (a b c)) ==> (b c) +(# a (b c d)) ==> #f +(# (a) (b (a) c)) ==> #f +(# (a) (b (a) c)) ==> ((a) c) +(# 101 (100 101 102)) ==> (101 102) +(# a ((a 1) (b 2) (c 3))) ==> (a 1) +(# b ((a 1) (b 2) (c 3))) ==> (b 2) +(# d ((a 1) (b 2) (c 3))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> ((a)) +(# 5 ((2 3) (5 7) (11 13))) ==> (5 7) +SECTION(6 4) +(# a) ==> #t +(standard-case #t) ==> #t +(standard-case #t) ==> #t +(#string> flying-fish) ==> "flying-fish" +(#string> martin) ==> "martin" +(#string> Malvina) ==> "Malvina" +(standard-case #t) ==> #t +(string-set! "cb") ==> "cb" +(#string> ab) ==> "ab" +(#symbol> "ab") ==> ab +(# mississippi mississippi) ==> #t +(string->symbol #f) ==> #f +(#symbol> "jollywog") ==> jollywog +SECTION(6 5 5) +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #f +(# 22 22 22) ==> #t +(# 22 22) ==> #t +(# 34 34 35) ==> #f +(# 34 35) ==> #f +(#> 3 -6246) ==> #t +(#> 9 9 -2424) ==> #f +(#=> 3 -4 -6246) ==> #t +(#=> 9 9) ==> #t +(#=> 8 9) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #t +(# 1 3 2) ==> #f +(#=> 1 3 2) ==> #f +(# 0) ==> #t +(# 1) ==> #f +(# -1) ==> #f +(# -100) ==> #f +(# 4) ==> #t +(# -4) ==> #f +(# 0) ==> #f +(# 4) ==> #f +(# -4) ==> #t +(# 0) ==> #f +(# 3) ==> #t +(# 2) ==> #f +(# -4) ==> #f +(# -1) ==> #t +(# 3) ==> #f +(# 2) ==> #t +(# -4) ==> #t +(# -1) ==> #f +(# 34 5 7 38 6) ==> 38 +(# 3 5 5 330 4 -24) ==> -24 +(# 3 4) ==> 7 +(# 3) ==> 3 +(#) ==> 0 +(# 4) ==> 4 +(#) ==> 1 +(# 3 4) ==> -1 +(# 3) ==> -3 +(# -7) ==> 7 +(# 7) ==> 7 +(# 0) ==> 0 +(# 35 7) ==> 5 +(# -35 7) ==> -5 +(# 35 -7) ==> -5 +(# -35 -7) ==> 5 +(# 13 4) ==> 1 +(# 13 4) ==> 1 +(# -13 4) ==> 3 +(# -13 4) ==> -1 +(# 13 -4) ==> -3 +(# 13 -4) ==> 1 +(# -13 -4) ==> -1 +(# -13 -4) ==> -1 +(# 0 86400) ==> 0 +(# 0 -86400) ==> 0 +(# 238 9) ==> #t +(# -238 9) ==> #t +(# 238 -9) ==> #t +(# -238 -9) ==> #t +(# 0 4) ==> 4 +(# -4 0) ==> 4 +(# 32 -36) ==> 4 +(#) ==> 0 +(# 32 -36) ==> 288 +(#) ==> 1 +SECTION(6 5 9) +(#string> 0) ==> "0" +(#string> 100) ==> "100" +(#string> 256 16) ==> "100" +(#number> "100") ==> 100 +(#number> "100" 16) ==> 256 +(#number> "") ==> #f +(#number> ".") ==> #f +(#number> "d") ==> #f +(#number> "D") ==> #f +(#number> "i") ==> #f +(#number> "I") ==> #f +(#number> "3i") ==> #f +(#number> "3I") ==> #f +(#number> "33i") ==> #f +(#number> "33I") ==> #f +(#number> "3.3i") ==> #f +(#number> "3.3I") ==> #f +(#number> "-") ==> #f +(#number> "+") ==> #f +SECTION(6 6) +(# #\ #\ ) ==> #t +(# #\ #\ ) ==> #t +(# #\a) ==> #t +(# #\() ==> #t +(# #\ ) ==> #t +(# #\ +) ==> #t +(# #\A #\B) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(# #\A #\B) ==> #f +(# #\a #\B) ==> #f +(# #\A #\b) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(# #\A #\a) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\B) ==> #f +(#?> #\A #\b) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(#?> #\A #\a) ==> #f +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\B) ==> #f +(#=?> #\A #\b) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(#=?> #\A #\a) ==> #t +(# #\a) ==> #t +(# #\A) ==> #t +(# #\z) ==> #t +(# #\Z) ==> #t +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #t +(# #\9) ==> #t +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #t +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(#char> 46) ==> #\. +(#char> 65) ==> #\A +(#char> 97) ==> #\a +(# #\A) ==> #\A +(# #\a) ==> #\A +(# #\A) ==> #\a +(# #\a) ==> #\a +SECTION(6 7) +(# "The word \"recursion\\\" has many meanings.") ==> #t +(string-set! "?**") ==> "?**" +(# #\a #\b #\c) ==> "abc" +(#) ==> "" +(# "abc") ==> 3 +(# "abc" 0) ==> #\a +(# "abc" 2) ==> #\c +(# "") ==> 0 +(# "ab" 0 0) ==> "" +(# "ab" 1 1) ==> "" +(# "ab" 2 2) ==> "" +(# "ab" 0 1) ==> "a" +(# "ab" 1 2) ==> "b" +(# "ab" 0 2) ==> "ab" +(# "foo" "bar") ==> "foobar" +(# "foo") ==> "foo" +(# "foo" "") ==> "foo" +(# "" "foo") ==> "foo" +(#) ==> "" +(# 0) ==> "" +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "A" "B") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(# "A" "B") ==> #f +(# "a" "B") ==> #f +(# "A" "b") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(# "A" "a") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "B") ==> #f +(#?> "A" "b") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(#?> "A" "a") ==> #f +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "B") ==> #f +(#=?> "A" "b") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(#=?> "A" "a") ==> #t +SECTION(6 8) +(# #(0 (2 2 2 2) "Anna")) ==> #t +(# a b c) ==> #(a b c) +(#) ==> #() +(# #(0 (2 2 2 2) "Anna")) ==> 3 +(# #()) ==> 0 +(# #(1 1 2 3 5 8 13 21) 5) ==> 8 +(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna") +(# 2 hi) ==> #(hi hi) +(# 0) ==> #() +(# 0 a) ==> #() +SECTION(6 9) +(# #) ==> #t +(# #) ==> #t +(# (lambda (x) (* x x))) ==> #f +(# #) ==> #t +(# # (3 4)) ==> 7 +(# # (3 4)) ==> 7 +(# # 10 (3 4)) ==> 17 +(# # ()) ==> () +(# 12 75) ==> 30 +(# # ((a b) (d e) (g h))) ==> (b e h) +(# # (1 2 3) (4 5 6)) ==> (5 7 9) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (-1 -2 -3) +(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16) +(# #) ==> -3 +(# (1 2 3 4)) ==> 4 +(# (a b . c)) ==> #f +(# # ()) ==> () +SECTION(6 10 1) +(# #) ==> #t +(# #) ==> #t +(# "r4rstest.scm" #) ==> #t +(# #) ==> #t +SECTION(6 10 2) +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (define cur-section (quote ())) +(# #) ==> #\( +(# #) ==> (define errs (quote ())) +SECTION(6 10 3) +(# "tmp1" #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) + + +Passed all tests + +;testing inexact numbers; +SECTION(6 5 5) +(# 3.9) ==> #t +(inexact? #t) ==> #t +(max 4.) ==> 4. +(exact->inexact 4.) ==> 4. +(# -4.5) ==> -4. +(# -3.5) ==> -4. +(# -3.9) ==> -4. +(# 0.) ==> 0. +(# 0.25) ==> 0. +(# 0.8) ==> 1. +(# 3.5) ==> 4. +(# 4.5) ==> 4. +(# 0 0) ==> 1 +(# 0 1) ==> 0 +(# "tmp3" #) ==> #t +(# #) ==> (define foo (quote (0.25 -3.25))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (0.25 -3.25) +(# #) ==> (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) +(#list> "P l") ==> (#\P #\ #\l) +(#list> "") ==> () +(#string> (#\1 #\\ #\")) ==> "1\\\"" +(#string> ()) ==> "" +SECTION(6 8) +(#list> #(dah dah didah)) ==> (dah dah didah) +(#list> #()) ==> () +(#vector> (dididit dah)) ==> #(dididit dah) +(#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 +(# #) ==> 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) +(# (a (b (c))) ((a) b c)) ==> #t +(# (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))) + diff --git a/vx-scheme/testcases/c-good/scheme.good b/vx-scheme/testcases/c-good/scheme.good new file mode 100644 index 0000000..b8a4c53 --- /dev/null +++ b/vx-scheme/testcases/c-good/scheme.good @@ -0,0 +1 @@ +("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") \ No newline at end of file diff --git a/vx-scheme/testcases/c-good/series.good b/vx-scheme/testcases/c-good/series.good new file mode 100644 index 0000000..323ea67 --- /dev/null +++ b/vx-scheme/testcases/c-good/series.good @@ -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 diff --git a/vx-scheme/testcases/c-good/sieve.good b/vx-scheme/testcases/c-good/sieve.good new file mode 100755 index 0000000..b6bb9c8 --- /dev/null +++ b/vx-scheme/testcases/c-good/sieve.good @@ -0,0 +1 @@ +1993 diff --git a/vx-scheme/testcases/cf.scm b/vx-scheme/testcases/cf.scm new file mode 100644 index 0000000..b2fa439 --- /dev/null +++ b/vx-scheme/testcases/cf.scm @@ -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) diff --git a/vx-scheme/testcases/cyclic.scm b/vx-scheme/testcases/cyclic.scm new file mode 100644 index 0000000..52d7366 --- /dev/null +++ b/vx-scheme/testcases/cyclic.scm @@ -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))))) diff --git a/vx-scheme/testcases/dderiv.scm b/vx-scheme/testcases/dderiv.scm new file mode 100644 index 0000000..9ed09a5 --- /dev/null +++ b/vx-scheme/testcases/dderiv.scm @@ -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 (+ . ), the code +;;; stored under the atom '+ with indicator DERIV will take 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) diff --git a/vx-scheme/testcases/dynamic.scm b/vx-scheme/testcases/dynamic.scm new file mode 100644 index 0000000..2f9dcf5 --- /dev/null +++ b/vx-scheme/testcases/dynamic.scm @@ -0,0 +1,2319 @@ +;;; DYNAMIC -- Obtained from Andrew Wright. +; +; 08/06/01 (felix): renamed "null" to "null2" because stupid MZC can't +; handle redefinitions of primitives. +; +; +;; Fritz's dynamic type inferencer, set up to run on itself +;; (see the end of this file). + +;---------------------------------------------------------------------------- +; Environment management +;---------------------------------------------------------------------------- + +;; environments are lists of pairs, the first component being the key + +;; general environment operations +;; +;; empty-env: Env +;; gen-binding: Key x Value -> Binding +;; binding-key: Binding -> Key +;; binding-value: Binding -> Value +;; binding-show: Binding -> Symbol* +;; extend-env-with-binding: Env x Binding -> Env +;; extend-env-with-env: Env x Env -> Env +;; lookup: Key x Env -> (Binding + False) +;; env->list: Env -> Binding* +;; env-show: Env -> Symbol* + + +; bindings + +(define gen-binding cons) +; generates a type binding, binding a symbol to a type variable + +(define binding-key car) +; returns the key of a type binding + +(define binding-value cdr) +; returns the tvariable of a type binding + +(define (key-show key) + ; default show procedure for keys + key) + +(define (value-show value) + ; default show procedure for values + value) + +(define (binding-show binding) + ; returns a printable representation of a type binding + (cons (key-show (binding-key binding)) + (cons ': (value-show (binding-value binding))))) + + +; environments + +(define dynamic-empty-env '()) +; returns the empty environment + +(define (extend-env-with-binding env binding) + ; extends env with a binding, which hides any other binding in env + ; for the same key (see dynamic-lookup) + ; returns the extended environment + (cons binding env)) + +(define (extend-env-with-env env ext-env) + ; extends environment env with environment ext-env + ; a binding for a key in ext-env hides any binding in env for + ; the same key (see dynamic-lookup) + ; returns the extended environment + (append ext-env env)) + +(define dynamic-lookup (lambda (x l) (assv x l))) +; returns the first pair in env that matches the key; returns #f +; if no such pair exists + +(define (env->list e) + ; converts an environment to a list of bindings + e) + +(define (env-show env) + ; returns a printable list representation of a type environment + (map binding-show env)) +;---------------------------------------------------------------------------- +; Parsing for Scheme +;---------------------------------------------------------------------------- + + +;; Needed packages: environment management + +;(load "env-mgmt.ss") +;(load "pars-act.ss") + +;; Lexical notions + +(define syntactic-keywords + ;; source: IEEE Scheme, 7.1, , + '(lambda if set! begin cond and or case let let* letrec do + quasiquote else => define unquote unquote-splicing)) + + +;; Parse routines + +; Datum + +; dynamic-parse-datum: parses nonterminal + +(define (dynamic-parse-datum e) + ;; Source: IEEE Scheme, sect. 7.2, + ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as + ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18) + ;; ***Note***: quasi-quotations are not permitted! (It would be + ;; necessary to pass the environment to dynamic-parse-datum.) + (cond + ((null? e) + (dynamic-parse-action-null-const)) + ((boolean? e) + (dynamic-parse-action-boolean-const e)) + ((char? e) + (dynamic-parse-action-char-const e)) + ((number? e) + (dynamic-parse-action-number-const e)) + ((string? e) + (dynamic-parse-action-string-const e)) + ((symbol? e) + (dynamic-parse-action-symbol-const e)) + ((vector? e) + (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e)))) + ((pair? e) + (dynamic-parse-action-pair-const (dynamic-parse-datum (car e)) + (dynamic-parse-datum (cdr e)))) + (else (error 'dynamic-parse-datum "Unknown datum: ~s" e)))) + + +; VarDef + +; dynamic-parse-formal: parses nonterminal in defining occurrence position + +(define (dynamic-parse-formal f-env e) + ; e is an arbitrary object, f-env is a forbidden environment; + ; returns: a variable definition (a binding for the symbol), plus + ; the value of the binding as a result + (if (symbol? e) + (cond + ((memq e syntactic-keywords) + (error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e)) + ((dynamic-lookup e f-env) + (error 'dynamic-parse-formal "Duplicate variable definition: ~s" e)) + (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e))) + (cons (gen-binding e dynamic-parse-action-result) + dynamic-parse-action-result)))) + (error 'dynamic-parse-formal "Not an identifier: ~s" e))) + +; dynamic-parse-formal* + +(define (dynamic-parse-formal* formals) + ;; parses a list of formals and returns a pair consisting of generated + ;; environment and list of parsing action results + (letrec + ((pf* + (lambda (f-env results formals) + ;; f-env: "forbidden" environment (to avoid duplicate defs) + ;; results: the results of the parsing actions + ;; formals: the unprocessed formals + ;; Note: generates the results of formals in reverse order! + (cond + ((null? formals) + (cons f-env results)) + ((pair? formals) + (let* ((fst-formal (car formals)) + (binding-result (dynamic-parse-formal f-env fst-formal)) + (binding (car binding-result)) + (var-result (cdr binding-result))) + (pf* + (extend-env-with-binding f-env binding) + (cons var-result results) + (cdr formals)))) + (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals)))))) + (let ((renv-rres (pf* dynamic-empty-env '() formals))) + (cons (car renv-rres) (reverse (cdr renv-rres)))))) + + +; dynamic-parse-formals: parses + +(define (dynamic-parse-formals formals) + ;; parses ; see IEEE Scheme, sect. 7.3 + ;; returns a pair: env and result + (letrec ((pfs (lambda (f-env formals) + (cond + ((null? formals) + (cons dynamic-empty-env (dynamic-parse-action-null-formal))) + ((pair? formals) + (let* ((fst-formal (car formals)) + (rem-formals (cdr formals)) + (bind-res (dynamic-parse-formal f-env fst-formal)) + (bind (car bind-res)) + (res (cdr bind-res)) + (nf-env (extend-env-with-binding f-env bind)) + (renv-res* (pfs nf-env rem-formals)) + (renv (car renv-res*)) + (res* (cdr renv-res*))) + (cons + (extend-env-with-binding renv bind) + (dynamic-parse-action-pair-formal res res*)))) + (else + (let* ((bind-res (dynamic-parse-formal f-env formals)) + (bind (car bind-res)) + (res (cdr bind-res))) + (cons + (extend-env-with-binding dynamic-empty-env bind) + res))))))) + (pfs dynamic-empty-env formals))) + + +; Expr + +; dynamic-parse-expression: parses nonterminal + +(define (dynamic-parse-expression env e) + (cond + ((symbol? e) + (dynamic-parse-variable env e)) + ((pair? e) + (let ((op (car e)) (args (cdr e))) + (case op + ((quote) (dynamic-parse-quote env args)) + ((lambda) (dynamic-parse-lambda env args)) + ((if) (dynamic-parse-if env args)) + ((set!) (dynamic-parse-set env args)) + ((begin) (dynamic-parse-begin env args)) + ((cond) (dynamic-parse-cond env args)) + ((case) (dynamic-parse-case env args)) + ((and) (dynamic-parse-and env args)) + ((or) (dynamic-parse-or env args)) + ((let) (dynamic-parse-let env args)) + ((let*) (dynamic-parse-let* env args)) + ((letrec) (dynamic-parse-letrec env args)) + ((do) (dynamic-parse-do env args)) + ((quasiquote) (dynamic-parse-quasiquote env args)) + (else (dynamic-parse-procedure-call env op args))))) + (else (dynamic-parse-datum e)))) + +; dynamic-parse-expression* + +(define (dynamic-parse-expression* env exprs) + ;; Parses lists of expressions (returns them in the right order!) + (letrec ((pe* + (lambda (results es) + (cond + ((null? es) results) + ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es))) + (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es)))))) + (reverse (pe* '() exprs)))) + + +; dynamic-parse-expressions + +(define (dynamic-parse-expressions env exprs) + ;; parses lists of arguments of a procedure call + (cond + ((null? exprs) (dynamic-parse-action-null-arg)) + ((pair? exprs) (let* ((fst-expr (car exprs)) + (rem-exprs (cdr exprs)) + (fst-res (dynamic-parse-expression env fst-expr)) + (rem-res (dynamic-parse-expressions env rem-exprs))) + (dynamic-parse-action-pair-arg fst-res rem-res))) + (else (error 'dynamic-parse-expressions "Illegal expression list: ~s" + exprs)))) + + +; dynamic-parse-variable: parses variables (applied occurrences) + +(define (dynamic-parse-variable env e) + (if (symbol? e) + (if (memq e syntactic-keywords) + (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e) + (let ((assoc-var-def (dynamic-lookup e env))) + (if assoc-var-def + (dynamic-parse-action-variable (binding-value assoc-var-def)) + (dynamic-parse-action-identifier e)))) + (error 'dynamic-parse-variable "Not an identifier: ~s" e))) + + +; dynamic-parse-procedure-call + +(define (dynamic-parse-procedure-call env op args) + (dynamic-parse-action-procedure-call + (dynamic-parse-expression env op) + (dynamic-parse-expressions env args))) + + +; dynamic-parse-quote + +(define (dynamic-parse-quote env args) + (if (list-of-1? args) + (dynamic-parse-datum (car args)) + (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args))) + + +; dynamic-parse-lambda + +(define (dynamic-parse-lambda env args) + (if (pair? args) + (let* ((formals (car args)) + (body (cdr args)) + (nenv-fresults (dynamic-parse-formals formals)) + (nenv (car nenv-fresults)) + (fresults (cdr nenv-fresults))) + (dynamic-parse-action-lambda-expression + fresults + (dynamic-parse-body (extend-env-with-env env nenv) body))) + (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args))) + + +; dynamic-parse-body + +(define (dynamic-parse-body env body) + ; = * + + (define (def-var* f-env body) + ; finds the defined variables in a body and returns an + ; environment containing them + (if (pair? body) + (let ((n-env (def-var f-env (car body)))) + (if n-env + (def-var* n-env (cdr body)) + f-env)) + f-env)) + (define (def-var f-env clause) + ; finds the defined variables in a single clause and extends + ; f-env accordingly; returns false if it's not a definition + (if (pair? clause) + (case (car clause) + ((define) (if (pair? (cdr clause)) + (let ((pattern (cadr clause))) + (cond + ((symbol? pattern) + (extend-env-with-binding + f-env + (gen-binding pattern + (dynamic-parse-action-var-def pattern)))) + ((and (pair? pattern) (symbol? (car pattern))) + (extend-env-with-binding + f-env + (gen-binding (car pattern) + (dynamic-parse-action-var-def + (car pattern))))) + (else f-env))) + f-env)) + ((begin) (def-var* f-env (cdr clause))) + (else #f)) + #f)) + (if (pair? body) + (dynamic-parse-command* (def-var* env body) body) + (error 'dynamic-parse-body "Illegal body: ~s" body))) + +; dynamic-parse-if + +(define (dynamic-parse-if env args) + (cond + ((list-of-3? args) + (dynamic-parse-action-conditional + (dynamic-parse-expression env (car args)) + (dynamic-parse-expression env (cadr args)) + (dynamic-parse-expression env (caddr args)))) + ((list-of-2? args) + (dynamic-parse-action-conditional + (dynamic-parse-expression env (car args)) + (dynamic-parse-expression env (cadr args)) + (dynamic-parse-action-empty))) + (else (error 'dynamic-parse-if "Not an if-expression: ~s" args)))) + + +; dynamic-parse-set + +(define (dynamic-parse-set env args) + (if (list-of-2? args) + (dynamic-parse-action-assignment + (dynamic-parse-variable env (car args)) + (dynamic-parse-expression env (cadr args))) + (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args))) + + +; dynamic-parse-begin + +(define (dynamic-parse-begin env args) + (dynamic-parse-action-begin-expression + (dynamic-parse-body env args))) + + +; dynamic-parse-cond + +(define (dynamic-parse-cond env args) + (if (and (pair? args) (list? args)) + (dynamic-parse-action-cond-expression + (map (lambda (e) + (dynamic-parse-cond-clause env e)) + args)) + (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args))) + +; dynamic-parse-cond-clause + +(define (dynamic-parse-cond-clause env e) + ;; ***Note***: Only ( ) is permitted! + (if (pair? e) + (cons + (if (eqv? (car e) 'else) + (dynamic-parse-action-empty) + (dynamic-parse-expression env (car e))) + (dynamic-parse-body env (cdr e))) + (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e))) + + +; dynamic-parse-and + +(define (dynamic-parse-and env args) + (if (list? args) + (dynamic-parse-action-and-expression + (dynamic-parse-expression* env args)) + (error 'dynamic-parse-and "Not a list of arguments: ~s" args))) + + +; dynamic-parse-or + +(define (dynamic-parse-or env args) + (if (list? args) + (dynamic-parse-action-or-expression + (dynamic-parse-expression* env args)) + (error 'dynamic-parse-or "Not a list of arguments: ~s" args))) + + +; dynamic-parse-case + +(define (dynamic-parse-case env args) + (if (and (list? args) (> (length args) 1)) + (dynamic-parse-action-case-expression + (dynamic-parse-expression env (car args)) + (map (lambda (e) + (dynamic-parse-case-clause env e)) + (cdr args))) + (error 'dynamic-parse-case "Not a list of clauses: ~s" args))) + +; dynamic-parse-case-clause + +(define (dynamic-parse-case-clause env e) + (if (pair? e) + (cons + (cond + ((eqv? (car e) 'else) + (list (dynamic-parse-action-empty))) + ((list? (car e)) + (map dynamic-parse-datum (car e))) + (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e)))) + (dynamic-parse-body env (cdr e))) + (error 'dynamic-parse-case-clause "Not case clause: ~s" e))) + + +; dynamic-parse-let + +(define (dynamic-parse-let env args) + (if (pair? args) + (if (symbol? (car args)) + (dynamic-parse-named-let env args) + (dynamic-parse-normal-let env args)) + (error 'dynamic-parse-let "Illegal bindings/body: ~s" args))) + + +; dynamic-parse-normal-let + +(define (dynamic-parse-normal-let env args) + ;; parses "normal" let-expressions + (let* ((bindings (car args)) + (body (cdr args)) + (env-ast (dynamic-parse-parallel-bindings env bindings)) + (nenv (car env-ast)) + (bresults (cdr env-ast))) + (dynamic-parse-action-let-expression + bresults + (dynamic-parse-body (extend-env-with-env env nenv) body)))) + +; dynamic-parse-named-let + +(define (dynamic-parse-named-let env args) + ;; parses a named let-expression + (if (pair? (cdr args)) + (let* ((variable (car args)) + (bindings (cadr args)) + (body (cddr args)) + (vbind-vres (dynamic-parse-formal dynamic-empty-env variable)) + (vbind (car vbind-vres)) + (vres (cdr vbind-vres)) + (env-ast (dynamic-parse-parallel-bindings env bindings)) + (nenv (car env-ast)) + (bresults (cdr env-ast))) + (dynamic-parse-action-named-let-expression + vres bresults + (dynamic-parse-body (extend-env-with-env + (extend-env-with-binding env vbind) + nenv) body))) + (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args))) + + +; dynamic-parse-parallel-bindings + +(define (dynamic-parse-parallel-bindings env bindings) + ; returns a pair consisting of an environment + ; and a list of pairs (variable . asg) + ; ***Note***: the list of pairs is returned in reverse unzipped form! + (if (list-of-list-of-2s? bindings) + (let* ((env-formals-asg + (dynamic-parse-formal* (map car bindings))) + (nenv (car env-formals-asg)) + (bresults (cdr env-formals-asg)) + (exprs-asg + (dynamic-parse-expression* env (map cadr bindings)))) + (cons nenv (cons bresults exprs-asg))) + (error 'dynamic-parse-parallel-bindings + "Not a list of bindings: ~s" bindings))) + + +; dynamic-parse-let* + +(define (dynamic-parse-let* env args) + (if (pair? args) + (let* ((bindings (car args)) + (body (cdr args)) + (env-ast (dynamic-parse-sequential-bindings env bindings)) + (nenv (car env-ast)) + (bresults (cdr env-ast))) + (dynamic-parse-action-let*-expression + bresults + (dynamic-parse-body (extend-env-with-env env nenv) body))) + (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args))) + +; dynamic-parse-sequential-bindings + +(define (dynamic-parse-sequential-bindings env bindings) + ; returns a pair consisting of an environment + ; and a list of pairs (variable . asg) + ;; ***Note***: the list of pairs is returned in reverse unzipped form! + (letrec + ((psb + (lambda (f-env c-env var-defs expr-asgs binds) + ;; f-env: forbidden environment + ;; c-env: constructed environment + ;; var-defs: results of formals + ;; expr-asgs: results of corresponding expressions + ;; binds: reminding bindings to process + (cond + ((null? binds) + (cons f-env (cons var-defs expr-asgs))) + ((pair? binds) + (let ((fst-bind (car binds))) + (if (list-of-2? fst-bind) + (let* ((fbinding-bres + (dynamic-parse-formal f-env (car fst-bind))) + (fbind (car fbinding-bres)) + (bres (cdr fbinding-bres)) + (new-expr-asg + (dynamic-parse-expression c-env (cadr fst-bind)))) + (psb + (extend-env-with-binding f-env fbind) + (extend-env-with-binding c-env fbind) + (cons bres var-defs) + (cons new-expr-asg expr-asgs) + (cdr binds))) + (error 'dynamic-parse-sequential-bindings + "Illegal binding: ~s" fst-bind)))) + (else (error 'dynamic-parse-sequential-bindings + "Illegal bindings: ~s" binds)))))) + (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings))) + (cons (car env-vdefs-easgs) + (cons (reverse (cadr env-vdefs-easgs)) + (reverse (cddr env-vdefs-easgs))))))) + + +; dynamic-parse-letrec + +(define (dynamic-parse-letrec env args) + (if (pair? args) + (let* ((bindings (car args)) + (body (cdr args)) + (env-ast (dynamic-parse-recursive-bindings env bindings)) + (nenv (car env-ast)) + (bresults (cdr env-ast))) + (dynamic-parse-action-letrec-expression + bresults + (dynamic-parse-body (extend-env-with-env env nenv) body))) + (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args))) + +; dynamic-parse-recursive-bindings + +(define (dynamic-parse-recursive-bindings env bindings) + ;; ***Note***: the list of pairs is returned in reverse unzipped form! + (if (list-of-list-of-2s? bindings) + (let* ((env-formals-asg + (dynamic-parse-formal* (map car bindings))) + (formals-env + (car env-formals-asg)) + (formals-res + (cdr env-formals-asg)) + (exprs-asg + (dynamic-parse-expression* + (extend-env-with-env env formals-env) + (map cadr bindings)))) + (cons + formals-env + (cons formals-res exprs-asg))) + (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings))) + + +; dynamic-parse-do + +(define (dynamic-parse-do env args) + ;; parses do-expressions + ;; ***Note***: Not implemented! + (error 'dynamic-parse-do "Nothing yet...")) + +; dynamic-parse-quasiquote + +(define (dynamic-parse-quasiquote env args) + ;; ***Note***: Not implemented! + (error 'dynamic-parse-quasiquote "Nothing yet...")) + + +;; Command + +; dynamic-parse-command + +(define (dynamic-parse-command env c) + (if (pair? c) + (let ((op (car c)) + (args (cdr c))) + (case op + ((define) (dynamic-parse-define env args)) +; ((begin) (dynamic-parse-command* env args)) ;; AKW + ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args))) + (else (dynamic-parse-expression env c)))) + (dynamic-parse-expression env c))) + + +; dynamic-parse-command* + +(define (dynamic-parse-command* env commands) + ;; parses a sequence of commands + (if (list? commands) + (map (lambda (command) (dynamic-parse-command env command)) commands) + (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands))) + + +; dynamic-parse-define + +(define (dynamic-parse-define env args) + ;; three cases -- see IEEE Scheme, sect. 5.2 + ;; ***Note***: the parser admits forms (define (x . y) ...) + ;; ***Note***: Variables are treated as applied occurrences! + (if (pair? args) + (let ((pattern (car args)) + (exp-or-body (cdr args))) + (cond + ((symbol? pattern) + (if (list-of-1? exp-or-body) + (dynamic-parse-action-definition + (dynamic-parse-variable env pattern) + (dynamic-parse-expression env (car exp-or-body))) + (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body))) + ((pair? pattern) + (let* ((function-name (car pattern)) + (function-arg-names (cdr pattern)) + (env-ast (dynamic-parse-formals function-arg-names)) + (formals-env (car env-ast)) + (formals-ast (cdr env-ast))) + (dynamic-parse-action-function-definition + (dynamic-parse-variable env function-name) + formals-ast + (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body)))) + (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern)))) + (error 'dynamic-parse-define "Not a valid definition: ~s" args))) + +;; Auxiliary routines + +; forall? + +(define (forall? pred list) + (if (null? list) + #t + (and (pred (car list)) (forall? pred (cdr list))))) + +; list-of-1? + +(define (list-of-1? l) + (and (pair? l) (null? (cdr l)))) + +; list-of-2? + +(define (list-of-2? l) + (and (pair? l) (pair? (cdr l)) (null? (cddr l)))) + +; list-of-3? + +(define (list-of-3? l) + (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l)))) + +; list-of-list-of-2s? + +(define (list-of-list-of-2s? e) + (cond + ((null? e) + #t) + ((pair? e) + (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e)))) + (else #f))) + + +;; File processing + +; dynamic-parse-from-port + +(define (dynamic-parse-from-port port) + (let ((next-input (read port))) + (if (eof-object? next-input) + '() + (dynamic-parse-action-commands + (dynamic-parse-command dynamic-empty-env next-input) + (dynamic-parse-from-port port))))) + +; dynamic-parse-file + +(define (dynamic-parse-file file-name) + (let ((input-port (open-input-file file-name))) + (dynamic-parse-from-port input-port))) +;---------------------------------------------------------------------------- +; Implementation of Union/find data structure in Scheme +;---------------------------------------------------------------------------- + +;; for union/find the following attributes are necessary: rank, parent +;; (see Tarjan, "Data structures and network algorithms", 1983) +;; In the Scheme realization an element is represented as a single +;; cons cell; its address is the element itself; the car field contains +;; the parent, the cdr field is an address for a cons +;; cell containing the rank (car field) and the information (cdr field) + + +;; general union/find data structure +;; +;; gen-element: Info -> Elem +;; find: Elem -> Elem +;; link: Elem! x Elem! -> Elem +;; asymm-link: Elem! x Elem! -> Elem +;; info: Elem -> Info +;; set-info!: Elem! x Info -> Void + + +(define (gen-element info) + ; generates a new element: the parent field is initialized to '(), + ; the rank field to 0 + (cons '() (cons 0 info))) + +(define info (lambda (l) (cddr l))) + ; returns the information stored in an element + +(define (set-info! elem info) + ; sets the info-field of elem to info + (set-cdr! (cdr elem) info)) + +; (define (find! x) +; ; finds the class representative of x and sets the parent field +; ; directly to the class representative (a class representative has +; ; '() as its parent) (uses path halving) +; ;(display "Find!: ") +; ;(display (pretty-print (info x))) +; ;(newline) +; (let ((px (car x))) +; (if (null? px) +; x +; (let ((ppx (car px))) +; (if (null? ppx) +; px +; (begin +; (set-car! x ppx) +; (find! ppx))))))) + +(define (find! elem) + ; finds the class representative of elem and sets the parent field + ; directly to the class representative (a class representative has + ; '() as its parent) + ;(display "Find!: ") + ;(display (pretty-print (info elem))) + ;(newline) + (let ((p-elem (car elem))) + (if (null? p-elem) + elem + (let ((rep-elem (find! p-elem))) + (set-car! elem rep-elem) + rep-elem)))) + +(define (link! elem-1 elem-2) + ; links class elements by rank + ; they must be distinct class representatives + ; returns the class representative of the merged equivalence classes + ;(display "Link!: ") + ;(display (pretty-print (list (info elem-1) (info elem-2)))) + ;(newline) + (let ((rank-1 (cadr elem-1)) + (rank-2 (cadr elem-2))) + (cond + ((= rank-1 rank-2) + (set-car! (cdr elem-2) (+ rank-2 1)) + (set-car! elem-1 elem-2) + elem-2) + ((> rank-1 rank-2) + (set-car! elem-2 elem-1) + elem-1) + (else + (set-car! elem-1 elem-2) + elem-2)))) + +(define asymm-link! (lambda (l x) (set-car! l x))) + +;(define (asymm-link! elem-1 elem-2) + ; links elem-1 onto elem-2 no matter what rank; + ; does not update the rank of elem-2 and does not return a value + ; the two arguments must be distinct + ;(display "AsymmLink: ") + ;(display (pretty-print (list (info elem-1) (info elem-2)))) + ;(newline) + ;(set-car! elem-1 elem-2)) + +;---------------------------------------------------------------------------- +; Type management +;---------------------------------------------------------------------------- + +; introduces type variables and types for Scheme, + + +;; type TVar (type variables) +;; +;; gen-tvar: () -> TVar +;; gen-type: TCon x TVar* -> TVar +;; dynamic: TVar +;; tvar-id: TVar -> Symbol +;; tvar-def: TVar -> Type + Null +;; tvar-show: TVar -> Symbol* +;; +;; set-def!: !TVar x TCon x TVar* -> Null +;; equiv!: !TVar x !TVar -> Null +;; +;; +;; type TCon (type constructors) +;; +;; ... +;; +;; type Type (types) +;; +;; gen-type: TCon x TVar* -> Type +;; type-con: Type -> TCon +;; type-args: Type -> TVar* +;; +;; boolean: TVar +;; character: TVar +;; null: TVar +;; pair: TVar x TVar -> TVar +;; procedure: TVar x TVar* -> TVar +;; charseq: TVar +;; symbol: TVar +;; array: TVar -> TVar + + +; Needed packages: union/find + +;(load "union-fi.so") + +; TVar + +(define counter 0) +; counter for generating tvar id's + +(define (gen-id) + ; generates a new id (for printing purposes) + (set! counter (+ counter 1)) + counter) + +(define (gen-tvar) + ; generates a new type variable from a new symbol + ; uses union/find elements with two info fields + ; a type variable has exactly four fields: + ; car: TVar (the parent field; initially null) + ; cadr: Number (the rank field; is always nonnegative) + ; caddr: Symbol (the type variable identifier; used only for printing) + ; cdddr: Type (the leq field; initially null) + (gen-element (cons (gen-id) '()))) + +(define (gen-type tcon targs) + ; generates a new type variable with an associated type definition + (gen-element (cons (gen-id) (cons tcon targs)))) + +(define dynamic (gen-element (cons 0 '()))) +; the special type variable dynamic +; Generic operations + +(define (tvar-id tvar) + ; returns the (printable) symbol representing the type variable + (car (info tvar))) + +(define (tvar-def tvar) + ; returns the type definition (if any) of the type variable + (cdr (info tvar))) + +(define (set-def! tvar tcon targs) + ; sets the type definition part of tvar to type + (set-cdr! (info tvar) (cons tcon targs)) + '()) + +(define (reset-def! tvar) + ; resets the type definition part of tvar to nil + (set-cdr! (info tvar) '())) + +(define type-con (lambda (l) (car l))) +; returns the type constructor of a type definition + +(define type-args (lambda (l) (cdr l))) +; returns the type variables of a type definition + +(define (tvar->string tvar) + ; converts a tvar's id to a string + (if (eqv? (tvar-id tvar) 0) + "Dynamic" + (string-append "t#" (number->string (tvar-id tvar) 10)))) + +(define (tvar-show tv) + ; returns a printable list representation of type variable tv + (let* ((tv-rep (find! tv)) + (tv-def (tvar-def tv-rep))) + (cons (tvar->string tv-rep) + (if (null? tv-def) + '() + (cons 'is (type-show tv-def)))))) + +(define (type-show type) + ; returns a printable list representation of type definition type + (cond + ((eqv? (type-con type) ptype-con) + (let ((new-tvar (gen-tvar))) + (cons ptype-con + (cons (tvar-show new-tvar) + (tvar-show ((type-args type) new-tvar)))))) + (else + (cons (type-con type) + (map (lambda (tv) + (tvar->string (find! tv))) + (type-args type)))))) + + + +; Special type operations + +; type constructor literals + +(define boolean-con 'boolean) +(define char-con 'char) +(define null-con 'null) +(define number-con 'number) +(define pair-con 'pair) +(define procedure-con 'procedure) +(define string-con 'string) +(define symbol-con 'symbol) +(define vector-con 'vector) + +; type constants and type constructors + +(define (null2) + ; ***Note***: Temporarily changed to be a pair! + ; (gen-type null-con '()) + (pair (gen-tvar) (gen-tvar))) +(define (boolean) + (gen-type boolean-con '())) +(define (character) + (gen-type char-con '())) +(define (number) + (gen-type number-con '())) +(define (charseq) + (gen-type string-con '())) +(define (symbol) + (gen-type symbol-con '())) +(define (pair tvar-1 tvar-2) + (gen-type pair-con (list tvar-1 tvar-2))) +(define (array tvar) + (gen-type vector-con (list tvar))) +(define (procedure arg-tvar res-tvar) + (gen-type procedure-con (list arg-tvar res-tvar))) + + +; equivalencing of type variables + +(define (equiv! tv1 tv2) + (let* ((tv1-rep (find! tv1)) + (tv2-rep (find! tv2)) + (tv1-def (tvar-def tv1-rep)) + (tv2-def (tvar-def tv2-rep))) + (cond + ((eqv? tv1-rep tv2-rep) + '()) + ((eqv? tv2-rep dynamic) + (equiv-with-dynamic! tv1-rep)) + ((eqv? tv1-rep dynamic) + (equiv-with-dynamic! tv2-rep)) + ((null? tv1-def) + (if (null? tv2-def) + ; both tv1 and tv2 are distinct type variables + (link! tv1-rep tv2-rep) + ; tv1 is a type variable, tv2 is a (nondynamic) type + (asymm-link! tv1-rep tv2-rep))) + ((null? tv2-def) + ; tv1 is a (nondynamic) type, tv2 is a type variable + (asymm-link! tv2-rep tv1-rep)) + ((eqv? (type-con tv1-def) (type-con tv2-def)) + ; both tv1 and tv2 are (nondynamic) types with equal numbers of + ; arguments + (link! tv1-rep tv2-rep) + (map equiv! (type-args tv1-def) (type-args tv2-def))) + (else + ; tv1 and tv2 are types with distinct type constructors or different + ; numbers of arguments + (equiv-with-dynamic! tv1-rep) + (equiv-with-dynamic! tv2-rep)))) + '()) + +(define (equiv-with-dynamic! tv) + (let ((tv-rep (find! tv))) + (if (not (eqv? tv-rep dynamic)) + (let ((tv-def (tvar-def tv-rep))) + (asymm-link! tv-rep dynamic) + (if (not (null? tv-def)) + (map equiv-with-dynamic! (type-args tv-def)))))) + '()) +;---------------------------------------------------------------------------- +; Polymorphic type management +;---------------------------------------------------------------------------- + +; introduces parametric polymorphic types + + +;; forall: (Tvar -> Tvar) -> TVar +;; fix: (Tvar -> Tvar) -> Tvar +;; +;; instantiate-type: TVar -> TVar + +; type constructor literal for polymorphic types + +(define ptype-con 'forall) + +(define (forall tv-func) + (gen-type ptype-con tv-func)) + +(define (forall2 tv-func2) + (forall (lambda (tv1) + (forall (lambda (tv2) + (tv-func2 tv1 tv2)))))) + +(define (forall3 tv-func3) + (forall (lambda (tv1) + (forall2 (lambda (tv2 tv3) + (tv-func3 tv1 tv2 tv3)))))) + +(define (forall4 tv-func4) + (forall (lambda (tv1) + (forall3 (lambda (tv2 tv3 tv4) + (tv-func4 tv1 tv2 tv3 tv4)))))) + +(define (forall5 tv-func5) + (forall (lambda (tv1) + (forall4 (lambda (tv2 tv3 tv4 tv5) + (tv-func5 tv1 tv2 tv3 tv4 tv5)))))) + + +; (polymorphic) instantiation + +(define (instantiate-type tv) + ; instantiates type tv and returns a generic instance + (let* ((tv-rep (find! tv)) + (tv-def (tvar-def tv-rep))) + (cond + ((null? tv-def) + tv-rep) + ((eqv? (type-con tv-def) ptype-con) + (instantiate-type ((type-args tv-def) (gen-tvar)))) + (else + tv-rep)))) + +(define (fix tv-func) + ; forms a recursive type: the fixed point of type mapping tv-func + (let* ((new-tvar (gen-tvar)) + (inst-tvar (tv-func new-tvar)) + (inst-def (tvar-def inst-tvar))) + (if (null? inst-def) + (error 'fix "Illegal recursive type: ~s" + (list (tvar-show new-tvar) '= (tvar-show inst-tvar))) + (begin + (set-def! new-tvar + (type-con inst-def) + (type-args inst-def)) + new-tvar)))) + + +;---------------------------------------------------------------------------- +; Constraint management +;---------------------------------------------------------------------------- + + +; constraints + +(define gen-constr (lambda (a b) (cons a b))) +; generates an equality between tvar1 and tvar2 + +(define constr-lhs (lambda (c) (car c))) +; returns the left-hand side of a constraint + +(define constr-rhs (lambda (c) (cdr c))) +; returns the right-hand side of a constraint + +(define (constr-show c) + (cons (tvar-show (car c)) + (cons '= + (cons (tvar-show (cdr c)) '())))) + + +; constraint set management + +(define global-constraints '()) + +(define (init-global-constraints!) + (set! global-constraints '())) + +(define (add-constr! lhs rhs) + (set! global-constraints + (cons (gen-constr lhs rhs) global-constraints)) + '()) + +(define (glob-constr-show) + ; returns printable version of global constraints + (map constr-show global-constraints)) + + +; constraint normalization + +; Needed packages: type management + +;(load "typ-mgmt.so") + +(define (normalize-global-constraints!) + (normalize! global-constraints) + (init-global-constraints!)) + +(define (normalize! constraints) + (map (lambda (c) + (equiv! (constr-lhs c) (constr-rhs c))) constraints)) +; ---------------------------------------------------------------------------- +; Abstract syntax definition and parse actions +; ---------------------------------------------------------------------------- + +; Needed packages: ast-gen.ss +;(load "ast-gen.ss") + +;; Abstract syntax +;; +;; VarDef +;; +;; Identifier = Symbol - SyntacticKeywords +;; SyntacticKeywords = { ... } (see Section 7.1, IEEE Scheme Standard) +;; +;; Datum +;; +;; null-const: Null -> Datum +;; boolean-const: Bool -> Datum +;; char-const: Char -> Datum +;; number-const: Number -> Datum +;; string-const: String -> Datum +;; vector-const: Datum* -> Datum +;; pair-const: Datum x Datum -> Datum +;; +;; Expr +;; +;; Datum < Expr +;; +;; var-def: Identifier -> VarDef +;; variable: VarDef -> Expr +;; identifier: Identifier -> Expr +;; procedure-call: Expr x Expr* -> Expr +;; lambda-expression: Formals x Body -> Expr +;; conditional: Expr x Expr x Expr -> Expr +;; assignment: Variable x Expr -> Expr +;; cond-expression: CondClause+ -> Expr +;; case-expression: Expr x CaseClause* -> Expr +;; and-expression: Expr* -> Expr +;; or-expression: Expr* -> Expr +;; let-expression: (VarDef* x Expr*) x Body -> Expr +;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr +;; let*-expression: (VarDef* x Expr*) x Body -> Expr +;; letrec-expression: (VarDef* x Expr*) x Body -> Expr +;; begin-expression: Expr+ -> Expr +;; do-expression: IterDef* x CondClause x Expr* -> Expr +;; empty: -> Expr +;; +;; VarDef* < Formals +;; +;; simple-formal: VarDef -> Formals +;; dotted-formals: VarDef* x VarDef -> Formals +;; +;; Body = Definition* x Expr+ (reversed) +;; CondClause = Expr x Expr+ +;; CaseClause = Datum* x Expr+ +;; IterDef = VarDef x Expr x Expr +;; +;; Definition +;; +;; definition: Identifier x Expr -> Definition +;; function-definition: Identifier x Formals x Body -> Definition +;; begin-command: Definition* -> Definition +;; +;; Expr < Command +;; Definition < Command +;; +;; Program = Command* + + +;; Abstract syntax operators + +; Datum + +(define null-const 0) +(define boolean-const 1) +(define char-const 2) +(define number-const 3) +(define string-const 4) +(define symbol-const 5) +(define vector-const 6) +(define pair-const 7) + +; Bindings + +(define var-def 8) +(define null-def 29) +(define pair-def 30) + +; Expr + +(define variable 9) +(define identifier 10) +(define procedure-call 11) +(define lambda-expression 12) +(define conditional 13) +(define assignment 14) +(define cond-expression 15) +(define case-expression 16) +(define and-expression 17) +(define or-expression 18) +(define let-expression 19) +(define named-let-expression 20) +(define let*-expression 21) +(define letrec-expression 22) +(define begin-expression 23) +(define do-expression 24) +(define empty 25) +(define null-arg 31) +(define pair-arg 32) + +; Command + +(define definition 26) +(define function-definition 27) +(define begin-command 28) + + +;; Parse actions for abstract syntax construction + +(define (dynamic-parse-action-null-const) + ;; dynamic-parse-action for '() + (ast-gen null-const '())) + +(define (dynamic-parse-action-boolean-const e) + ;; dynamic-parse-action for #f and #t + (ast-gen boolean-const e)) + +(define (dynamic-parse-action-char-const e) + ;; dynamic-parse-action for character constants + (ast-gen char-const e)) + +(define (dynamic-parse-action-number-const e) + ;; dynamic-parse-action for number constants + (ast-gen number-const e)) + +(define (dynamic-parse-action-string-const e) + ;; dynamic-parse-action for string literals + (ast-gen string-const e)) + +(define (dynamic-parse-action-symbol-const e) + ;; dynamic-parse-action for symbol constants + (ast-gen symbol-const e)) + +(define (dynamic-parse-action-vector-const e) + ;; dynamic-parse-action for vector literals + (ast-gen vector-const e)) + +(define (dynamic-parse-action-pair-const e1 e2) + ;; dynamic-parse-action for pairs + (ast-gen pair-const (cons e1 e2))) + +(define (dynamic-parse-action-var-def e) + ;; dynamic-parse-action for defining occurrences of variables; + ;; e is a symbol + (ast-gen var-def e)) + +(define (dynamic-parse-action-null-formal) + ;; dynamic-parse-action for null-list of formals + (ast-gen null-def '())) + +(define (dynamic-parse-action-pair-formal d1 d2) + ;; dynamic-parse-action for non-null list of formals; + ;; d1 is the result of parsing the first formal, + ;; d2 the result of parsing the remaining formals + (ast-gen pair-def (cons d1 d2))) + +(define (dynamic-parse-action-variable e) + ;; dynamic-parse-action for applied occurrences of variables + ;; ***Note***: e is the result of a dynamic-parse-action on the + ;; corresponding variable definition! + (ast-gen variable e)) + +(define (dynamic-parse-action-identifier e) + ;; dynamic-parse-action for undeclared identifiers (free variable + ;; occurrences) + ;; ***Note***: e is a symbol (legal identifier) + (ast-gen identifier e)) + +(define (dynamic-parse-action-null-arg) + ;; dynamic-parse-action for a null list of arguments in a procedure call + (ast-gen null-arg '())) + +(define (dynamic-parse-action-pair-arg a1 a2) + ;; dynamic-parse-action for a non-null list of arguments in a procedure call + ;; a1 is the result of parsing the first argument, + ;; a2 the result of parsing the remaining arguments + (ast-gen pair-arg (cons a1 a2))) + +(define (dynamic-parse-action-procedure-call op args) + ;; dynamic-parse-action for procedure calls: op function, args list of arguments + (ast-gen procedure-call (cons op args))) + +(define (dynamic-parse-action-lambda-expression formals body) + ;; dynamic-parse-action for lambda-abstractions + (ast-gen lambda-expression (cons formals body))) + +(define (dynamic-parse-action-conditional test then-branch else-branch) + ;; dynamic-parse-action for conditionals (if-then-else expressions) + (ast-gen conditional (cons test (cons then-branch else-branch)))) + +(define (dynamic-parse-action-empty) + ;; dynamic-parse-action for missing or empty field + (ast-gen empty '())) + +(define (dynamic-parse-action-assignment lhs rhs) + ;; dynamic-parse-action for assignment + (ast-gen assignment (cons lhs rhs))) + +(define (dynamic-parse-action-begin-expression body) + ;; dynamic-parse-action for begin-expression + (ast-gen begin-expression body)) + +(define (dynamic-parse-action-cond-expression clauses) + ;; dynamic-parse-action for cond-expressions + (ast-gen cond-expression clauses)) + +(define (dynamic-parse-action-and-expression args) + ;; dynamic-parse-action for and-expressions + (ast-gen and-expression args)) + +(define (dynamic-parse-action-or-expression args) + ;; dynamic-parse-action for or-expressions + (ast-gen or-expression args)) + +(define (dynamic-parse-action-case-expression key clauses) + ;; dynamic-parse-action for case-expressions + (ast-gen case-expression (cons key clauses))) + +(define (dynamic-parse-action-let-expression bindings body) + ;; dynamic-parse-action for let-expressions + (ast-gen let-expression (cons bindings body))) + +(define (dynamic-parse-action-named-let-expression variable bindings body) + ;; dynamic-parse-action for named-let expressions + (ast-gen named-let-expression (cons variable (cons bindings body)))) + +(define (dynamic-parse-action-let*-expression bindings body) + ;; dynamic-parse-action for let-expressions + (ast-gen let*-expression (cons bindings body))) + +(define (dynamic-parse-action-letrec-expression bindings body) + ;; dynamic-parse-action for let-expressions + (ast-gen letrec-expression (cons bindings body))) + +(define (dynamic-parse-action-definition variable expr) + ;; dynamic-parse-action for simple definitions + (ast-gen definition (cons variable expr))) + +(define (dynamic-parse-action-function-definition variable formals body) + ;; dynamic-parse-action for function definitions + (ast-gen function-definition (cons variable (cons formals body)))) + + +(define dynamic-parse-action-commands (lambda (a b) (cons a b))) +;; dynamic-parse-action for processing a command result followed by a the +;; result of processing the remaining commands + + +;; Pretty-printing abstract syntax trees + +(define (ast-show ast) + ;; converts abstract syntax tree to list representation (Scheme program) + ;; ***Note***: check translation of constructors to numbers at the top of the file + (let ((syntax-op (ast-con ast)) + (syntax-arg (ast-arg ast))) + (case syntax-op + ((0 1 2 3 4 8 10) syntax-arg) + ((29 31) '()) + ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg)))) + ((5) (list 'quote syntax-arg)) + ((6) (list->vector (map ast-show syntax-arg))) + ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg)))) + ((9) (ast-arg syntax-arg)) + ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg)))) + ((12) (cons 'lambda (cons (ast-show (car syntax-arg)) + (map ast-show (cdr syntax-arg))))) + ((13) (cons 'if (cons (ast-show (car syntax-arg)) + (cons (ast-show (cadr syntax-arg)) + (let ((alt (cddr syntax-arg))) + (if (eqv? (ast-con alt) empty) + '() + (list (ast-show alt)))))))) + ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg)))) + ((15) (cons 'cond + (map (lambda (cc) + (let ((guard (car cc)) + (body (cdr cc))) + (cons + (if (eqv? (ast-con guard) empty) + 'else + (ast-show guard)) + (map ast-show body)))) + syntax-arg))) + ((16) (cons 'case + (cons (ast-show (car syntax-arg)) + (map (lambda (cc) + (let ((data (car cc))) + (if (and (pair? data) + (eqv? (ast-con (car data)) empty)) + (cons 'else + (map ast-show (cdr cc))) + (cons (map datum-show data) + (map ast-show (cdr cc)))))) + (cdr syntax-arg))))) + ((17) (cons 'and (map ast-show syntax-arg))) + ((18) (cons 'or (map ast-show syntax-arg))) + ((19) (cons 'let + (cons (map + (lambda (vd e) + (list (ast-show vd) (ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map ast-show (cdr syntax-arg))))) + ((20) (cons 'let + (cons (ast-show (car syntax-arg)) + (cons (map + (lambda (vd e) + (list (ast-show vd) (ast-show e))) + (caadr syntax-arg) + (cdadr syntax-arg)) + (map ast-show (cddr syntax-arg)))))) + ((21) (cons 'let* + (cons (map + (lambda (vd e) + (list (ast-show vd) (ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map ast-show (cdr syntax-arg))))) + ((22) (cons 'letrec + (cons (map + (lambda (vd e) + (list (ast-show vd) (ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map ast-show (cdr syntax-arg))))) + ((23) (cons 'begin + (map ast-show syntax-arg))) + ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg)) + ((25) (error 'ast-show "This can't happen: empty encountered!")) + ((26) (list 'define + (ast-show (car syntax-arg)) + (ast-show (cdr syntax-arg)))) + ((27) (cons 'define + (cons + (cons (ast-show (car syntax-arg)) + (ast-show (cadr syntax-arg))) + (map ast-show (cddr syntax-arg))))) + ((28) (cons 'begin + (map ast-show syntax-arg))) + (else (error 'ast-show "Unknown abstract syntax operator: ~s" + syntax-op))))) + + +;; ast*-show + +(define (ast*-show p) + ;; shows a list of abstract syntax trees + (map ast-show p)) + + +;; datum-show + +(define (datum-show ast) + ;; prints an abstract syntax tree as a datum + (case (ast-con ast) + ((0 1 2 3 4 5) (ast-arg ast)) + ((6) (list->vector (map datum-show (ast-arg ast)))) + ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast))))) + (else (error 'datum-show "This should not happen!")))) + +; write-to-port + +(define (write-to-port prog port) + ; writes a program to a port + (for-each + (lambda (command) + (pretty-print command port) + (newline port)) + prog) + '()) + +; write-file + +(define (write-to-file prog filename) + ; write a program to a file + (let ((port (open-output-file filename))) + (write-to-port prog port) + (close-output-port port) + '())) + +; ---------------------------------------------------------------------------- +; Typed abstract syntax tree management: constraint generation, display, etc. +; ---------------------------------------------------------------------------- + + +;; Abstract syntax operations, incl. constraint generation + +(define (ast-gen syntax-op arg) + ; generates all attributes and performs semantic side effects + (let ((ntvar + (case syntax-op + ((0 29 31) (null2)) + ((1) (boolean)) + ((2) (character)) + ((3) (number)) + ((4) (charseq)) + ((5) (symbol)) + ((6) (let ((aux-tvar (gen-tvar))) + (for-each (lambda (t) + (add-constr! t aux-tvar)) + (map ast-tvar arg)) + (array aux-tvar))) + ((7 30 32) (let ((t1 (ast-tvar (car arg))) + (t2 (ast-tvar (cdr arg)))) + (pair t1 t2))) + ((8) (gen-tvar)) + ((9) (ast-tvar arg)) + ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env))) + (if in-env + (instantiate-type (binding-value in-env)) + (let ((new-tvar (gen-tvar))) + (set! dynamic-top-level-env (extend-env-with-binding + dynamic-top-level-env + (gen-binding arg new-tvar))) + new-tvar)))) + ((11) (let ((new-tvar (gen-tvar))) + (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar) + (ast-tvar (car arg))) + new-tvar)) + ((12) (procedure (ast-tvar (car arg)) + (ast-tvar (tail (cdr arg))))) + ((13) (let ((t-test (ast-tvar (car arg))) + (t-consequent (ast-tvar (cadr arg))) + (t-alternate (ast-tvar (cddr arg)))) + (add-constr! (boolean) t-test) + (add-constr! t-consequent t-alternate) + t-consequent)) + ((14) (let ((var-tvar (ast-tvar (car arg))) + (exp-tvar (ast-tvar (cdr arg)))) + (add-constr! var-tvar exp-tvar) + var-tvar)) + ((15) (let ((new-tvar (gen-tvar))) + (for-each (lambda (body) + (add-constr! (ast-tvar (tail body)) new-tvar)) + (map cdr arg)) + (for-each (lambda (e) + (add-constr! (boolean) (ast-tvar e))) + (map car arg)) + new-tvar)) + ((16) (let* ((new-tvar (gen-tvar)) + (t-key (ast-tvar (car arg))) + (case-clauses (cdr arg))) + (for-each (lambda (exprs) + (for-each (lambda (e) + (add-constr! (ast-tvar e) t-key)) + exprs)) + (map car case-clauses)) + (for-each (lambda (body) + (add-constr! (ast-tvar (tail body)) new-tvar)) + (map cdr case-clauses)) + new-tvar)) + ((17 18) (for-each (lambda (e) + (add-constr! (boolean) (ast-tvar e))) + arg) + (boolean)) + ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg))) + (def-expr-types (map ast-tvar (cdar arg))) + (body-type (ast-tvar (tail (cdr arg))))) + (for-each add-constr! var-def-tvars def-expr-types) + body-type)) + ((20) (let ((var-def-tvars (map ast-tvar (caadr arg))) + (def-expr-types (map ast-tvar (cdadr arg))) + (body-type (ast-tvar (tail (cddr arg)))) + (named-var-type (ast-tvar (car arg)))) + (for-each add-constr! var-def-tvars def-expr-types) + (add-constr! (procedure (convert-tvars var-def-tvars) body-type) + named-var-type) + body-type)) + ((23) (ast-tvar (tail arg))) + ((24) (error 'ast-gen + "Do-expressions not handled! (Argument: ~s) arg")) + ((25) (gen-tvar)) + ((26) (let ((t-var (ast-tvar (car arg))) + (t-exp (ast-tvar (cdr arg)))) + (add-constr! t-var t-exp) + t-var)) + ((27) (let ((t-var (ast-tvar (car arg))) + (t-formals (ast-tvar (cadr arg))) + (t-body (ast-tvar (tail (cddr arg))))) + (add-constr! (procedure t-formals t-body) t-var) + t-var)) + ((28) (gen-tvar)) + (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op))))) + (cons syntax-op (cons ntvar arg)))) + +(define ast-con car) +;; extracts the ast-constructor from an abstract syntax tree + +(define ast-arg cddr) +;; extracts the ast-argument from an abstract syntax tree + +(define ast-tvar cadr) +;; extracts the tvar from an abstract syntax tree + + +;; tail + +(define (tail l) + ;; returns the tail of a nonempty list + (if (null? (cdr l)) + (car l) + (tail (cdr l)))) + +; convert-tvars + +(define (convert-tvars tvar-list) + ;; converts a list of tvars to a single tvar + (cond + ((null? tvar-list) (null2)) + ((pair? tvar-list) (pair (car tvar-list) + (convert-tvars (cdr tvar-list)))) + (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list)))) + + +;; Pretty-printing abstract syntax trees + +(define (tast-show ast) + ;; converts abstract syntax tree to list representation (Scheme program) + (let ((syntax-op (ast-con ast)) + (syntax-tvar (tvar-show (ast-tvar ast))) + (syntax-arg (ast-arg ast))) + (cons + (case syntax-op + ((0 1 2 3 4 8 10) syntax-arg) + ((29 31) '()) + ((30 32) (cons (tast-show (car syntax-arg)) + (tast-show (cdr syntax-arg)))) + ((5) (list 'quote syntax-arg)) + ((6) (list->vector (map tast-show syntax-arg))) + ((7) (list 'cons (tast-show (car syntax-arg)) + (tast-show (cdr syntax-arg)))) + ((9) (ast-arg syntax-arg)) + ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg)))) + ((12) (cons 'lambda (cons (tast-show (car syntax-arg)) + (map tast-show (cdr syntax-arg))))) + ((13) (cons 'if (cons (tast-show (car syntax-arg)) + (cons (tast-show (cadr syntax-arg)) + (let ((alt (cddr syntax-arg))) + (if (eqv? (ast-con alt) empty) + '() + (list (tast-show alt)))))))) + ((14) (list 'set! (tast-show (car syntax-arg)) + (tast-show (cdr syntax-arg)))) + ((15) (cons 'cond + (map (lambda (cc) + (let ((guard (car cc)) + (body (cdr cc))) + (cons + (if (eqv? (ast-con guard) empty) + 'else + (tast-show guard)) + (map tast-show body)))) + syntax-arg))) + ((16) (cons 'case + (cons (tast-show (car syntax-arg)) + (map (lambda (cc) + (let ((data (car cc))) + (if (and (pair? data) + (eqv? (ast-con (car data)) empty)) + (cons 'else + (map tast-show (cdr cc))) + (cons (map datum-show data) + (map tast-show (cdr cc)))))) + (cdr syntax-arg))))) + ((17) (cons 'and (map tast-show syntax-arg))) + ((18) (cons 'or (map tast-show syntax-arg))) + ((19) (cons 'let + (cons (map + (lambda (vd e) + (list (tast-show vd) (tast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tast-show (cdr syntax-arg))))) + ((20) (cons 'let + (cons (tast-show (car syntax-arg)) + (cons (map + (lambda (vd e) + (list (tast-show vd) (tast-show e))) + (caadr syntax-arg) + (cdadr syntax-arg)) + (map tast-show (cddr syntax-arg)))))) + ((21) (cons 'let* + (cons (map + (lambda (vd e) + (list (tast-show vd) (tast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tast-show (cdr syntax-arg))))) + ((22) (cons 'letrec + (cons (map + (lambda (vd e) + (list (tast-show vd) (tast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tast-show (cdr syntax-arg))))) + ((23) (cons 'begin + (map tast-show syntax-arg))) + ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg)) + ((25) (error 'tast-show "This can't happen: empty encountered!")) + ((26) (list 'define + (tast-show (car syntax-arg)) + (tast-show (cdr syntax-arg)))) + ((27) (cons 'define + (cons + (cons (tast-show (car syntax-arg)) + (tast-show (cadr syntax-arg))) + (map tast-show (cddr syntax-arg))))) + ((28) (cons 'begin + (map tast-show syntax-arg))) + (else (error 'tast-show "Unknown abstract syntax operator: ~s" + syntax-op))) + syntax-tvar))) + +;; tast*-show + +(define (tast*-show p) + ;; shows a list of abstract syntax trees + (map tast-show p)) + + +;; counters for tagging/untagging + +(define untag-counter 0) +(define no-untag-counter 0) +(define tag-counter 0) +(define no-tag-counter 0) +(define may-untag-counter 0) +(define no-may-untag-counter 0) + +(define (reset-counters!) + (set! untag-counter 0) + (set! no-untag-counter 0) + (set! tag-counter 0) + (set! no-tag-counter 0) + (set! may-untag-counter 0) + (set! no-may-untag-counter 0)) + +(define (counters-show) + (list + (cons tag-counter no-tag-counter) + (cons untag-counter no-untag-counter) + (cons may-untag-counter no-may-untag-counter))) + + +;; tag-show + +(define (tag-show tvar-rep prog) + ; display prog with tagging operation + (if (eqv? tvar-rep dynamic) + (begin + (set! tag-counter (+ tag-counter 1)) + (list 'tag prog)) + (begin + (set! no-tag-counter (+ no-tag-counter 1)) + (list 'no-tag prog)))) + + +;; untag-show + +(define (untag-show tvar-rep prog) + ; display prog with untagging operation + (if (eqv? tvar-rep dynamic) + (begin + (set! untag-counter (+ untag-counter 1)) + (list 'untag prog)) + (begin + (set! no-untag-counter (+ no-untag-counter 1)) + (list 'no-untag prog)))) + +(define (may-untag-show tvar-rep prog) + ; display possible untagging in actual arguments + (if (eqv? tvar-rep dynamic) + (begin + (set! may-untag-counter (+ may-untag-counter 1)) + (list 'may-untag prog)) + (begin + (set! no-may-untag-counter (+ no-may-untag-counter 1)) + (list 'no-may-untag prog)))) + + +;; tag-ast-show + +(define (tag-ast-show ast) + ;; converts typed and normalized abstract syntax tree to + ;; a Scheme program with explicit tagging and untagging operations + (let ((syntax-op (ast-con ast)) + (syntax-tvar (find! (ast-tvar ast))) + (syntax-arg (ast-arg ast))) + (case syntax-op + ((0 1 2 3 4) + (tag-show syntax-tvar syntax-arg)) + ((8 10) syntax-arg) + ((29 31) '()) + ((30) (cons (tag-ast-show (car syntax-arg)) + (tag-ast-show (cdr syntax-arg)))) + ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg))) + (tag-ast-show (car syntax-arg))) + (tag-ast-show (cdr syntax-arg)))) + ((5) (tag-show syntax-tvar (list 'quote syntax-arg))) + ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg)))) + ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg)) + (tag-ast-show (cdr syntax-arg))))) + ((9) (ast-arg syntax-arg)) + ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg))))) + (cons (untag-show proc-tvar + (tag-ast-show (car syntax-arg))) + (tag-ast-show (cdr syntax-arg))))) + ((12) (tag-show syntax-tvar + (cons 'lambda (cons (tag-ast-show (car syntax-arg)) + (map tag-ast-show (cdr syntax-arg)))))) + ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg))))) + (cons 'if (cons (untag-show test-tvar + (tag-ast-show (car syntax-arg))) + (cons (tag-ast-show (cadr syntax-arg)) + (let ((alt (cddr syntax-arg))) + (if (eqv? (ast-con alt) empty) + '() + (list (tag-ast-show alt))))))))) + ((14) (list 'set! (tag-ast-show (car syntax-arg)) + (tag-ast-show (cdr syntax-arg)))) + ((15) (cons 'cond + (map (lambda (cc) + (let ((guard (car cc)) + (body (cdr cc))) + (cons + (if (eqv? (ast-con guard) empty) + 'else + (untag-show (find! (ast-tvar guard)) + (tag-ast-show guard))) + (map tag-ast-show body)))) + syntax-arg))) + ((16) (cons 'case + (cons (tag-ast-show (car syntax-arg)) + (map (lambda (cc) + (let ((data (car cc))) + (if (and (pair? data) + (eqv? (ast-con (car data)) empty)) + (cons 'else + (map tag-ast-show (cdr cc))) + (cons (map datum-show data) + (map tag-ast-show (cdr cc)))))) + (cdr syntax-arg))))) + ((17) (cons 'and (map + (lambda (ast) + (let ((bool-tvar (find! (ast-tvar ast)))) + (untag-show bool-tvar (tag-ast-show ast)))) + syntax-arg))) + ((18) (cons 'or (map + (lambda (ast) + (let ((bool-tvar (find! (ast-tvar ast)))) + (untag-show bool-tvar (tag-ast-show ast)))) + syntax-arg))) + ((19) (cons 'let + (cons (map + (lambda (vd e) + (list (tag-ast-show vd) (tag-ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tag-ast-show (cdr syntax-arg))))) + ((20) (cons 'let + (cons (tag-ast-show (car syntax-arg)) + (cons (map + (lambda (vd e) + (list (tag-ast-show vd) (tag-ast-show e))) + (caadr syntax-arg) + (cdadr syntax-arg)) + (map tag-ast-show (cddr syntax-arg)))))) + ((21) (cons 'let* + (cons (map + (lambda (vd e) + (list (tag-ast-show vd) (tag-ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tag-ast-show (cdr syntax-arg))))) + ((22) (cons 'letrec + (cons (map + (lambda (vd e) + (list (tag-ast-show vd) (tag-ast-show e))) + (caar syntax-arg) + (cdar syntax-arg)) + (map tag-ast-show (cdr syntax-arg))))) + ((23) (cons 'begin + (map tag-ast-show syntax-arg))) + ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg)) + ((25) (error 'tag-ast-show "This can't happen: empty encountered!")) + ((26) (list 'define + (tag-ast-show (car syntax-arg)) + (tag-ast-show (cdr syntax-arg)))) + ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg))))) + (list 'define + (tag-ast-show (car syntax-arg)) + (tag-show func-tvar + (cons 'lambda + (cons (tag-ast-show (cadr syntax-arg)) + (map tag-ast-show (cddr syntax-arg)))))))) + ((28) (cons 'begin + (map tag-ast-show syntax-arg))) + (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s" + syntax-op))))) + + +; tag-ast*-show + +(define (tag-ast*-show p) + ; display list of commands/expressions with tagging/untagging + ; operations + (map tag-ast-show p)) +; ---------------------------------------------------------------------------- +; Top level type environment +; ---------------------------------------------------------------------------- + + +; Needed packages: type management (monomorphic and polymorphic) + +;(load "typ-mgmt.ss") +;(load "ptyp-mgm.ss") + + +; type environment for miscellaneous + +(define misc-env + (list + (cons 'quote (forall (lambda (tv) tv))) + (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv)) + (boolean))))) + (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv)) + (boolean))))) + (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv)) + (boolean))))) + )) + +; type environment for input/output + +(define io-env + (list + (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic)) + (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean))) + (cons 'read (forall (lambda (tv) + (procedure (convert-tvars (list tv)) dynamic)))) + (cons 'write (forall (lambda (tv) + (procedure (convert-tvars (list tv)) dynamic)))) + (cons 'display (forall (lambda (tv) + (procedure (convert-tvars (list tv)) dynamic)))) + (cons 'newline (procedure (null2) dynamic)) + (cons 'pretty-print (forall (lambda (tv) + (procedure (convert-tvars (list tv)) dynamic)))))) + + +; type environment for Booleans + +(define boolean-env + (list + (cons 'boolean? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + ;(cons #f (boolean)) + ; #f doesn't exist in Chez Scheme, but gets mapped to null! + (cons #t (boolean)) + (cons 'not (procedure (convert-tvars (list (boolean))) (boolean))) + )) + + +; type environment for pairs and lists + +(define (list-type tv) + (fix (lambda (tv2) (pair tv tv2)))) + +(define list-env + (list + (cons 'pair? (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2))) + (boolean))))) + (cons 'null? (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2))) + (boolean))))) + (cons 'list? (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2))) + (boolean))))) + (cons 'cons (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list tv1 tv2)) + (pair tv1 tv2))))) + (cons 'car (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2))) + tv1)))) + (cons 'cdr (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2))) + tv2)))) + (cons 'set-car! (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2) + tv1)) + dynamic)))) + (cons 'set-cdr! (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars (list (pair tv1 tv2) + tv2)) + dynamic)))) + (cons 'caar (forall3 (lambda (tv1 tv2 tv3) + (procedure (convert-tvars + (list (pair (pair tv1 tv2) tv3))) + tv1)))) + (cons 'cdar (forall3 (lambda (tv1 tv2 tv3) + (procedure (convert-tvars + (list (pair (pair tv1 tv2) tv3))) + tv2)))) + + (cons 'cadr (forall3 (lambda (tv1 tv2 tv3) + (procedure (convert-tvars + (list (pair tv1 (pair tv2 tv3)))) + tv2)))) + (cons 'cddr (forall3 (lambda (tv1 tv2 tv3) + (procedure (convert-tvars + (list (pair tv1 (pair tv2 tv3)))) + tv3)))) + (cons 'caaar (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair (pair (pair tv1 tv2) tv3) tv4))) + tv1)))) + (cons 'cdaar (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair (pair (pair tv1 tv2) tv3) tv4))) + tv2)))) + (cons 'cadar (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair (pair tv1 (pair tv2 tv3)) tv4))) + tv2)))) + (cons 'cddar (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair (pair tv1 (pair tv2 tv3)) tv4))) + tv3)))) + (cons 'caadr (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair tv1 (pair (pair tv2 tv3) tv4)))) + tv2)))) + (cons 'cdadr (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair tv1 (pair (pair tv2 tv3) tv4)))) + tv3)))) + (cons 'caddr (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair tv1 (pair tv2 (pair tv3 tv4))))) + tv3)))) + (cons 'cdddr (forall4 + (lambda (tv1 tv2 tv3 tv4) + (procedure (convert-tvars + (list (pair tv1 (pair tv2 (pair tv3 tv4))))) + tv4)))) + (cons 'cadddr + (forall5 (lambda (tv1 tv2 tv3 tv4 tv5) + (procedure (convert-tvars + (list (pair tv1 + (pair tv2 + (pair tv3 + (pair tv4 tv5)))))) + tv4)))) + (cons 'cddddr + (forall5 (lambda (tv1 tv2 tv3 tv4 tv5) + (procedure (convert-tvars + (list (pair tv1 + (pair tv2 + (pair tv3 + (pair tv4 tv5)))))) + tv5)))) + (cons 'list (forall (lambda (tv) + (procedure tv tv)))) + (cons 'length (forall (lambda (tv) + (procedure (convert-tvars (list (list-type tv))) + (number))))) + (cons 'append (forall (lambda (tv) + (procedure (convert-tvars (list (list-type tv) + (list-type tv))) + (list-type tv))))) + (cons 'reverse (forall (lambda (tv) + (procedure (convert-tvars (list (list-type tv))) + (list-type tv))))) + (cons 'list-ref (forall (lambda (tv) + (procedure (convert-tvars (list (list-type tv) + (number))) + tv)))) + (cons 'memq (forall (lambda (tv) + (procedure (convert-tvars (list tv + (list-type tv))) + (boolean))))) + (cons 'memv (forall (lambda (tv) + (procedure (convert-tvars (list tv + (list-type tv))) + (boolean))))) + (cons 'member (forall (lambda (tv) + (procedure (convert-tvars (list tv + (list-type tv))) + (boolean))))) + (cons 'assq (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list tv1 + (list-type (pair tv1 tv2)))) + (pair tv1 tv2))))) + (cons 'assv (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list tv1 + (list-type (pair tv1 tv2)))) + (pair tv1 tv2))))) + (cons 'assoc (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list tv1 + (list-type (pair tv1 tv2)))) + (pair tv1 tv2))))) + )) + + +(define symbol-env + (list + (cons 'symbol? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq))) + (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol))) + )) + +(define number-env + (list + (cons 'number? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + (cons '+ (procedure (convert-tvars (list (number) (number))) (number))) + (cons '- (procedure (convert-tvars (list (number) (number))) (number))) + (cons '* (procedure (convert-tvars (list (number) (number))) (number))) + (cons '/ (procedure (convert-tvars (list (number) (number))) (number))) + (cons 'number->string (procedure (convert-tvars (list (number))) (charseq))) + (cons 'string->number (procedure (convert-tvars (list (charseq))) (number))) + )) + +(define char-env + (list + (cons 'char? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + (cons 'char->integer (procedure (convert-tvars (list (character))) + (number))) + (cons 'integer->char (procedure (convert-tvars (list (number))) + (character))) + )) + +(define string-env + (list + (cons 'string? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + )) + +(define vector-env + (list + (cons 'vector? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + (cons 'make-vector (forall (lambda (tv) + (procedure (convert-tvars (list (number))) + (array tv))))) + (cons 'vector-length (forall (lambda (tv) + (procedure (convert-tvars (list (array tv))) + (number))))) + (cons 'vector-ref (forall (lambda (tv) + (procedure (convert-tvars (list (array tv) + (number))) + tv)))) + (cons 'vector-set! (forall (lambda (tv) + (procedure (convert-tvars (list (array tv) + (number) + tv)) + dynamic)))) + )) + +(define procedure-env + (list + (cons 'procedure? (forall (lambda (tv) + (procedure (convert-tvars (list tv)) (boolean))))) + (cons 'map (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list (procedure (convert-tvars + (list tv1)) tv2) + (list-type tv1))) + (list-type tv2))))) + (cons 'foreach (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list (procedure (convert-tvars + (list tv1)) tv2) + (list-type tv1))) + (list-type tv2))))) + (cons 'call-with-current-continuation + (forall2 (lambda (tv1 tv2) + (procedure (convert-tvars + (list (procedure + (convert-tvars + (list (procedure (convert-tvars + (list tv1)) tv2))) + tv2))) + tv2)))) + )) + + +; global top level environment + +(define (global-env) + (append misc-env + io-env + boolean-env + symbol-env + number-env + char-env + string-env + vector-env + procedure-env + list-env)) + +(define dynamic-top-level-env (global-env)) + +(define (init-dynamic-top-level-env!) + (set! dynamic-top-level-env (global-env)) + '()) + +(define (dynamic-top-level-env-show) + ; displays the top level environment + (map (lambda (binding) + (cons (key-show (binding-key binding)) + (cons ': (tvar-show (binding-value binding))))) + (env->list dynamic-top-level-env))) +; ---------------------------------------------------------------------------- +; Dynamic type inference for Scheme +; ---------------------------------------------------------------------------- + +; Needed packages: + +(define (ic!) (init-global-constraints!)) +(define (pc) (glob-constr-show)) +(define (lc) (length global-constraints)) +(define (n!) (normalize-global-constraints!)) +(define (pt) (dynamic-top-level-env-show)) +(define (it!) (init-dynamic-top-level-env!)) +(define (io!) (set! tag-ops 0) (set! no-ops 0)) +(define (i!) (ic!) (it!) (io!) '()) + +(define tag-ops 0) +(define no-ops 0) + + +(define doit + (lambda () + (i!) + (let ((foo (dynamic-parse-file "dynamic.scm"))) + (normalize-global-constraints!) + (reset-counters!) + (tag-ast*-show foo) + (counters-show)))) + +(display (doit)) +(newline) diff --git a/vx-scheme/testcases/earley.scm b/vx-scheme/testcases/earley.scm new file mode 100644 index 0000000..c733c7c --- /dev/null +++ b/vx-scheme/testcases/earley.scm @@ -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) diff --git a/vx-scheme/testcases/good/ack.good b/vx-scheme/testcases/good/ack.good new file mode 100755 index 0000000..ce579ec --- /dev/null +++ b/vx-scheme/testcases/good/ack.good @@ -0,0 +1,3 @@ +253 +509 +1021 diff --git a/vx-scheme/testcases/good/boyer.good b/vx-scheme/testcases/good/boyer.good new file mode 100644 index 0000000..56ed4c7 --- /dev/null +++ b/vx-scheme/testcases/good/boyer.good @@ -0,0 +1 @@ +#t diff --git a/vx-scheme/testcases/good/cf.good b/vx-scheme/testcases/good/cf.good new file mode 100644 index 0000000..9ae7610 --- /dev/null +++ b/vx-scheme/testcases/good/cf.good @@ -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) diff --git a/vx-scheme/testcases/good/dderiv.good b/vx-scheme/testcases/good/dderiv.good new file mode 100644 index 0000000..4acc996 --- /dev/null +++ b/vx-scheme/testcases/good/dderiv.good @@ -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) diff --git a/vx-scheme/testcases/good/dynamic.good b/vx-scheme/testcases/good/dynamic.good new file mode 100644 index 0000000..c460021 --- /dev/null +++ b/vx-scheme/testcases/good/dynamic.good @@ -0,0 +1 @@ +((218 . 437) (6 . 1892) (2204 . 441)) diff --git a/vx-scheme/testcases/good/earley.good b/vx-scheme/testcases/good/earley.good new file mode 100644 index 0000000..4efaa29 --- /dev/null +++ b/vx-scheme/testcases/good/earley.good @@ -0,0 +1 @@ +1430 diff --git a/vx-scheme/testcases/good/maze.good b/vx-scheme/testcases/good/maze.good new file mode 100644 index 0000000..ff530a6 --- /dev/null +++ b/vx-scheme/testcases/good/maze.good @@ -0,0 +1,42 @@ + _ _ _ + _/ \_/ \_/.\ +/ \ \_ . /.\ +\ \ /. _/.\ / +/ \_/. _/ \_ .\ +\ / \ / _/ \_/ +/ _/.\ / \ / \ +\ / \ / _/ / +/ \ /.\ /.\_/ \ +\_/ \ /. _ .\ / +/ \_ . _/ \ \ +\_ \_/ _/.\ / +/ _/ / \ / \ +\_ \ / \_ .\_/ +/ \_ \_ \_ .\ +\_ \_/ _/.\ / +/ \_ \ /.\ .\ +\ /.\_ . /.\ / +/ . _/.\ / \ +\ /.\_/.\_ .\ / +/ \_ . / _/ \ +\_ \_/.\_ \_/ +/ _/ \ / \_ \ +\_/ _/.\_ \_/ +/ \ / _ . _ \ +\ / \_/. _ \_/ +/ _ \ \_/ \ +\_/.\_ .\_/ _/ +/ \ . _/ / \ +\ /.\_/ \_/.\ / +/ \_ . _/. \ +\ . /.\_/ +/ \_/ \_/ \_ .\ +\_/ / \_/. / +/ / _ \ / \ +\_/ \_/ \_/.\_/ +/ \_/ _/ \_ .\ +\ _/. /. _/ +/ \ /. / \_ .\ +\_/. _/.\_/.\ / +/ _ .\_ . _ .\ +\_/ \ / \_/ \_/ diff --git a/vx-scheme/testcases/good/pi.good b/vx-scheme/testcases/good/pi.good new file mode 100755 index 0000000..fe40b33 --- /dev/null +++ b/vx-scheme/testcases/good/pi.good @@ -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 diff --git a/vx-scheme/testcases/good/puzzle.good b/vx-scheme/testcases/good/puzzle.good new file mode 100644 index 0000000..9284822 --- /dev/null +++ b/vx-scheme/testcases/good/puzzle.good @@ -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. diff --git a/vx-scheme/testcases/good/r4rstest.good b/vx-scheme/testcases/good/r4rstest.good new file mode 100644 index 0000000..c23d478 --- /dev/null +++ b/vx-scheme/testcases/good/r4rstest.good @@ -0,0 +1,772 @@ +SECTION(2 1) +SECTION(3 4) + # + # + # + # + # + # + # + # + # +(#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)# +(#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) +(# 3 4) ==> 12 +SECTION(4 1 4) +(# 4) ==> 8 +(# 7 10) ==> 3 +(# 6) ==> 10 +(# 3 4 5 6) ==> (3 4 5 6) +(# 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 +(# 6) ==> 9 +SECTION(5 2 2) +(define 45) ==> 45 +(#) ==> 5 +(define 34) ==> 34 +(#) ==> 5 +(define 34) ==> 34 +(# 88) ==> 88 +(# 4) ==> 4 +(define 34) ==> 34 +(internal-define 99) ==> 99 +(internal-define 77) ==> 77 +SECTION(6 1) +(# #t) ==> #f +(# 3) ==> #f +(# (3)) ==> #f +(# #f) ==> #t +(# ()) ==> #f +(# ()) ==> #f +(# nil) ==> #f +SECTION(6 2) +(# a a) ==> #t +(# a b) ==> #f +(# 2 2) ==> #t +(# () ()) ==> #t +(# 10000 10000) ==> #t +(# (1 . 2) (1 . 2)) ==> #f +(# # #) ==> #f +(# #f nil) ==> #f +(# # #) ==> #t +(# # #) ==> #t +(# # #) ==> #f +(# # #) ==> #f +(# a a) ==> #t +(# (a) (a)) ==> #f +(# () ()) ==> #t +(# # #) ==> #t +(# (a) (a)) ==> #t +(# #() #()) ==> #t +(# # #) ==> #t +(# a a) ==> #t +(# (a) (a)) ==> #t +(# (a (b) c) (a (b) c)) ==> #t +(# "abc" "abc") ==> #t +(# 2 2) ==> #t +(# #(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) +(# (a b c)) ==> #t +(set-cdr! (a . 4)) ==> (a . 4) +(# (a . 4) (a . 4)) ==> #t +(dot (a b c . d)) ==> (a b c . d) +(# (a . 4)) ==> #f +(list? #f) ==> #f +(# a ()) ==> (a) +(# (a) (b c d)) ==> ((a) b c d) +(# "a" (b c)) ==> ("a" b c) +(# a 3) ==> (a . 3) +(# (a b) c) ==> ((a b) . c) +(# (a b c)) ==> a +(# ((a) b c d)) ==> (a) +(# (1 . 2)) ==> 1 +(# ((a) b c d)) ==> (b c d) +(# (1 . 2)) ==> 2 +(# a 7 c) ==> (a 7 c) +(#) ==> () +(# (a b c)) ==> 3 +(# (a (b) (c d e))) ==> 3 +(# ()) ==> 0 +(# (x) (y)) ==> (x y) +(# (a) (b c d)) ==> (a b c d) +(# (a (b)) ((c))) ==> (a (b) (c)) +(#) ==> () +(# (a b) (c . d)) ==> (a b c . d) +(# () a) ==> a +(# (a b c)) ==> (c b a) +(# (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) +(# (a b c d) 2) ==> c +(# a (a b c)) ==> (a b c) +(# b (a b c)) ==> (b c) +(# a (b c d)) ==> #f +(# (a) (b (a) c)) ==> #f +(# (a) (b (a) c)) ==> ((a) c) +(# 101 (100 101 102)) ==> (101 102) +(# a ((a 1) (b 2) (c 3))) ==> (a 1) +(# b ((a 1) (b 2) (c 3))) ==> (b 2) +(# d ((a 1) (b 2) (c 3))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> ((a)) +(# 5 ((2 3) (5 7) (11 13))) ==> (5 7) +SECTION(6 4) +(# a) ==> #t +(standard-case #t) ==> #t +(standard-case #t) ==> #t +(#string> flying-fish) ==> "flying-fish" +(#string> martin) ==> "martin" +(#string> Malvina) ==> "Malvina" +(standard-case #t) ==> #t +(string-set! "cb") ==> "cb" +(#string> ab) ==> "ab" +(#symbol> "ab") ==> ab +(# mississippi mississippi) ==> #t +(string->symbol #f) ==> #f +(#symbol> "jollywog") ==> jollywog +SECTION(6 5 5) +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #f +(# 22 22 22) ==> #t +(# 22 22) ==> #t +(# 34 34 35) ==> #f +(# 34 35) ==> #f +(#> 3 -6246) ==> #t +(#> 9 9 -2424) ==> #f +(#=> 3 -4 -6246) ==> #t +(#=> 9 9) ==> #t +(#=> 8 9) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #t +(# 1 3 2) ==> #f +(#=> 1 3 2) ==> #f +(# 0) ==> #t +(# 1) ==> #f +(# -1) ==> #f +(# -100) ==> #f +(# 4) ==> #t +(# -4) ==> #f +(# 0) ==> #f +(# 4) ==> #f +(# -4) ==> #t +(# 0) ==> #f +(# 3) ==> #t +(# 2) ==> #f +(# -4) ==> #f +(# -1) ==> #t +(# 3) ==> #f +(# 2) ==> #t +(# -4) ==> #t +(# -1) ==> #f +(# 34 5 7 38 6) ==> 38 +(# 3 5 5 330 4 -24) ==> -24 +(# 3 4) ==> 7 +(# 3) ==> 3 +(#) ==> 0 +(# 4) ==> 4 +(#) ==> 1 +(# 3 4) ==> -1 +(# 3) ==> -3 +(# -7) ==> 7 +(# 7) ==> 7 +(# 0) ==> 0 +(# 35 7) ==> 5 +(# -35 7) ==> -5 +(# 35 -7) ==> -5 +(# -35 -7) ==> 5 +(# 13 4) ==> 1 +(# 13 4) ==> 1 +(# -13 4) ==> 3 +(# -13 4) ==> -1 +(# 13 -4) ==> -3 +(# 13 -4) ==> 1 +(# -13 -4) ==> -1 +(# -13 -4) ==> -1 +(# 0 86400) ==> 0 +(# 0 -86400) ==> 0 +(# 238 9) ==> #t +(# -238 9) ==> #t +(# 238 -9) ==> #t +(# -238 -9) ==> #t +(# 0 4) ==> 4 +(# -4 0) ==> 4 +(# 32 -36) ==> 4 +(#) ==> 0 +(# 32 -36) ==> 288 +(#) ==> 1 +SECTION(6 5 9) +(#string> 0) ==> "0" +(#string> 100) ==> "100" +(#string> 256 16) ==> "100" +(#number> "100") ==> 100 +(#number> "100" 16) ==> 256 +(#number> "") ==> #f +(#number> ".") ==> #f +(#number> "d") ==> #f +(#number> "D") ==> #f +(#number> "i") ==> #f +(#number> "I") ==> #f +(#number> "3i") ==> #f +(#number> "3I") ==> #f +(#number> "33i") ==> #f +(#number> "33I") ==> #f +(#number> "3.3i") ==> #f +(#number> "3.3I") ==> #f +(#number> "-") ==> #f +(#number> "+") ==> #f +SECTION(6 6) +(# #\ #\ ) ==> #t +(# #\ #\ ) ==> #t +(# #\a) ==> #t +(# #\() ==> #t +(# #\ ) ==> #t +(# #\ +) ==> #t +(# #\A #\B) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(# #\A #\B) ==> #f +(# #\a #\B) ==> #f +(# #\A #\b) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(# #\A #\a) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\B) ==> #f +(#?> #\A #\b) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(#?> #\A #\a) ==> #f +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\B) ==> #f +(#=?> #\A #\b) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(#=?> #\A #\a) ==> #t +(# #\a) ==> #t +(# #\A) ==> #t +(# #\z) ==> #t +(# #\Z) ==> #t +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #t +(# #\9) ==> #t +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #t +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(#char> 46) ==> #\. +(#char> 65) ==> #\A +(#char> 97) ==> #\a +(# #\A) ==> #\A +(# #\a) ==> #\A +(# #\A) ==> #\a +(# #\a) ==> #\a +SECTION(6 7) +(# "The word \"recursion\\\" has many meanings.") ==> #t +(string-set! "?**") ==> "?**" +(# #\a #\b #\c) ==> "abc" +(#) ==> "" +(# "abc") ==> 3 +(# "abc" 0) ==> #\a +(# "abc" 2) ==> #\c +(# "") ==> 0 +(# "ab" 0 0) ==> "" +(# "ab" 1 1) ==> "" +(# "ab" 2 2) ==> "" +(# "ab" 0 1) ==> "a" +(# "ab" 1 2) ==> "b" +(# "ab" 0 2) ==> "ab" +(# "foo" "bar") ==> "foobar" +(# "foo") ==> "foo" +(# "foo" "") ==> "foo" +(# "" "foo") ==> "foo" +(#) ==> "" +(# 0) ==> "" +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "A" "B") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(# "A" "B") ==> #f +(# "a" "B") ==> #f +(# "A" "b") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(# "A" "a") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "B") ==> #f +(#?> "A" "b") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(#?> "A" "a") ==> #f +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "B") ==> #f +(#=?> "A" "b") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(#=?> "A" "a") ==> #t +SECTION(6 8) +(# #(0 (2 2 2 2) "Anna")) ==> #t +(# a b c) ==> #(a b c) +(#) ==> #() +(# #(0 (2 2 2 2) "Anna")) ==> 3 +(# #()) ==> 0 +(# #(1 1 2 3 5 8 13 21) 5) ==> 8 +(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna") +(# 2 hi) ==> #(hi hi) +(# 0) ==> #() +(# 0 a) ==> #() +SECTION(6 9) +(# #) ==> #t +(# #) ==> #t +(# (lambda (x) (* x x))) ==> #f +(# #) ==> #t +(# # (3 4)) ==> 7 +(# # (3 4)) ==> 7 +(# # 10 (3 4)) ==> 17 +(# # ()) ==> () +(# 12 75) ==> 30 +(# # ((a b) (d e) (g h))) ==> (b e h) +(# # (1 2 3) (4 5 6)) ==> (5 7 9) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (-1 -2 -3) +(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16) +(# #) ==> -3 +(# (1 2 3 4)) ==> 4 +(# (a b . c)) ==> #f +(# # ()) ==> () +SECTION(6 10 1) +(# #) ==> #t +(# #) ==> #t +(# "r4rstest.scm" #) ==> #t +(# #) ==> #t +SECTION(6 10 2) +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (define cur-section (quote ())) +(# #) ==> #\( +(# #) ==> (define errs (quote ())) +SECTION(6 10 3) +(# "tmp1" #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) + + +Passed all tests + +;testing inexact numbers; +SECTION(6 5 5) +(# 3.9) ==> #t +(inexact? #t) ==> #t +(max 4.) ==> 4. +(exact->inexact 4.) ==> 4. +(# -4.5) ==> -4. +(# -3.5) ==> -4. +(# -3.9) ==> -4. +(# 0.) ==> 0. +(# 0.25) ==> 0. +(# 0.8) ==> 1. +(# 3.5) ==> 4. +(# 4.5) ==> 4. +(# 0 0) ==> 1 +(# 0 1) ==> 0 +(# "tmp3" #) ==> #t +(# #) ==> (define foo (quote (0.25 -3.25))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (0.25 -3.25) +(# #) ==> (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) +(#list> "P l") ==> (#\P #\ #\l) +(#list> "") ==> () +(#string> (#\1 #\\ #\")) ==> "1\\\"" +(#string> ()) ==> "" +SECTION(6 8) +(#list> #(dah dah didah)) ==> (dah dah didah) +(#list> #()) ==> () +(#vector> (dididit dah)) ==> #(dididit dah) +(#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 +(# #>) ==> 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) +(# (a (b (c))) ((a) b c)) ==> #t +(# (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))) + diff --git a/vx-scheme/testcases/good/scheme.good b/vx-scheme/testcases/good/scheme.good new file mode 100644 index 0000000..b8a4c53 --- /dev/null +++ b/vx-scheme/testcases/good/scheme.good @@ -0,0 +1 @@ +("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") \ No newline at end of file diff --git a/vx-scheme/testcases/good/series.good b/vx-scheme/testcases/good/series.good new file mode 100644 index 0000000..323ea67 --- /dev/null +++ b/vx-scheme/testcases/good/series.good @@ -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 diff --git a/vx-scheme/testcases/good/sieve.good b/vx-scheme/testcases/good/sieve.good new file mode 100755 index 0000000..b6bb9c8 --- /dev/null +++ b/vx-scheme/testcases/good/sieve.good @@ -0,0 +1 @@ +1993 diff --git a/vx-scheme/testcases/maze.scm b/vx-scheme/testcases/maze.scm new file mode 100644 index 0000000..a8f4626 --- /dev/null +++ b/vx-scheme/testcases/maze.scm @@ -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))) diff --git a/vx-scheme/testcases/pi.scm b/vx-scheme/testcases/pi.scm new file mode 100644 index 0000000..2671493 --- /dev/null +++ b/vx-scheme/testcases/pi.scm @@ -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) diff --git a/vx-scheme/testcases/puzzle.scm b/vx-scheme/testcases/puzzle.scm new file mode 100644 index 0000000..ba5dba7 --- /dev/null +++ b/vx-scheme/testcases/puzzle.scm @@ -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) + diff --git a/vx-scheme/testcases/q.scm b/vx-scheme/testcases/q.scm new file mode 100644 index 0000000..b117bb6 --- /dev/null +++ b/vx-scheme/testcases/q.scm @@ -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) + + diff --git a/vx-scheme/testcases/r4rstest.scm b/vx-scheme/testcases/r4rstest.scm new file mode 100644 index 0000000..e594eea --- /dev/null +++ b/vx-scheme/testcases/r4rstest.scm @@ -0,0 +1,1197 @@ +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation; either version 2, or (at your option) any +;; later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; To receive a copy of the GNU General Public License, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA; or view +;; http://swissnet.ai.mit.edu/~jaffer/GPL.html + +;;;; "r4rstest.scm" Test correctness of scheme implementations. +;;; Author: Aubrey Jaffer + +;;; This includes examples from +;;; William Clinger and Jonathan Rees, editors. +;;; Revised^4 Report on the Algorithmic Language Scheme +;;; and the IEEE specification. + +;;; The input tests read this file expecting it to be named "r4rstest.scm". +;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running +;;; these tests. You may need to delete them in order to run +;;; "r4rstest.scm" more than once. + +;;; There are three optional tests: +;;; (TEST-CONT) tests multiple returns from call-with-current-continuation +;;; +;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE +;;; +;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by +;;; either standard. + +;;; If you are testing a R3RS version which does not have `list?' do: +;;; (define list? #f) + +;;; send corrections or additions to jaffer @ai.mit.edu + +(define cur-section '())(define errs '()) +(define SECTION (lambda args + (display "SECTION") (write args) (newline) + (set! cur-section args) #t)) +(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) + +(define test + (lambda (expect fun . args) + (write (cons fun args)) + (display " ==> ") + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (record-error (list res expect (cons fun args))) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) +(define (report-errs) + (newline) + (if (null? errs) (display "Passed all tests") + (begin + (display "errors were:") + (newline) + (display "(SECTION (got expected (call)))") + (newline) + (for-each (lambda (l) (write l) (newline)) + errs))) + (newline)) + +(SECTION 2 1);; test that all symbol characters are supported. +'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) + +(SECTION 3 4) +(define disjoint-type-functions + (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) +(define type-examples + (list + #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) +(define i 1) +(for-each (lambda (x) (display (make-string i #\ )) + (set! i (+ 3 i)) + (write x) + (newline)) + disjoint-type-functions) +(define type-matrix + (map (lambda (x) + (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) + (write t) + (write x) + (newline) + t)) + type-examples)) +(set! i 0) +(define j 0) +(for-each (lambda (x y) + (set! j (+ 1 j)) + (set! i 0) + (for-each (lambda (f) + (set! i (+ 1 i)) + (cond ((and (= i j)) + (cond ((not (f x)) (test #t f x)))) + ((f x) (test #f f x))) + (cond ((and (= i j)) + (cond ((not (f y)) (test #t f y)))) + ((f y) (test #f f y)))) + disjoint-type-functions)) + (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c)) + (list #f #\newline '() -3252 '(t . t) car "" 'nil '#())) +(SECTION 4 1 2) +(test '(quote a) 'quote (quote 'a)) +(test '(quote a) 'quote ''a) +(SECTION 4 1 3) +(test 12 (if #f + *) 3 4) +(SECTION 4 1 4) +(test 8 (lambda (x) (+ x x)) 4) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 reverse-subtract 7 10) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 add4 6) +(test '(3 4 5 6) (lambda x x) 3 4 5 6) +(test '(5 6) (lambda (x y . z) z) 3 4 5 6) +(SECTION 4 1 5) +(test 'yes 'if (if (> 3 2) 'yes 'no)) +(test 'no 'if (if (> 2 3) 'yes 'no)) +(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) +(SECTION 4 1 6) +(define x 2) +(test 3 'define (+ x 1)) +(set! x 4) +(test 5 'set! (+ x 1)) +(SECTION 4 2 1) +(test 'greater 'cond (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) +(test 'equal 'cond (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) +(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) +(test 'composite 'case (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) +(test 'consonant 'case (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) +(test #t 'and (and (= 2 2) (> 2 1))) +(test #f 'and (and (= 2 2) (< 2 1))) +(test '(f g) 'and (and 1 2 'c '(f g))) +(test #t 'and (and)) +(test #t 'or (or (= 2 2) (> 2 1))) +(test #t 'or (or (= 2 2) (< 2 1))) +(test #f 'or (or #f #f #f)) +(test #f 'or (or)) +(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) +(SECTION 4 2 2) +(test 6 'let (let ((x 2) (y 3)) (* x y))) +(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) +(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) +(test #t 'letrec (letrec ((even? + (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? + (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (even? 88))) +(define x 34) +(test 5 'let (let ((x 3)) (define x 5) x)) +(test 34 'let x) +(test 6 'let (let () (define x 6) x)) +(test 34 'let x) +(test 7 'let* (let* ((x 3)) (define x 7) x)) +(test 34 'let* x) +(test 8 'let* (let* () (define x 8) x)) +(test 34 'let* x) +(test 9 'letrec (letrec () (define x 9) x)) +(test 34 'letrec x) +(test 10 'letrec (letrec ((x 3)) (define x 10) x)) +(test 34 'letrec x) +(SECTION 4 2 3) +(define x 0) +(test 6 'begin (begin (set! x (begin (begin 5))) + (begin ((begin +) (begin x) (begin (begin 1)))))) +(SECTION 4 2 4) +(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) +(test 25 'do (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) +(test 1 'let (let foo () 1)) +(test '((6 1 3) (-5 -2)) 'let + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((negative? (car numbers)) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg))) + (else + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg))))) +;;From: Allegro Petrofsky +(test -1 'let (let ((f -)) (let f ((n (f 1))) n))) + +(SECTION 4 2 6) +(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) +(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test '((foo 7) . cons) + 'quasiquote + `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) + +;;; sqt is defined here because not all implementations are required to +;;; support it. +(define (sqt x) + (do ((i 0 (+ i 1))) + ((> (* i i) x) (- i 1)))) + +(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) +(test 5 'quasiquote `,(+ 2 3)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) +(test '(a `(b ,x ,'y d) e) 'quasiquote + (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) +(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) + +(SECTION 5 2 1) +(define add3 (lambda (x) (+ x 3))) +(test 6 'define (add3 3)) +(define first car) +(test 1 'define (first '(1 2))) +;; We now use this test with our compiler, which elects to open-code +;; +; consequently, this test wouldn't pass, since you can't really +;; give + a new definition that will stick. I don't see in the spec +;; where this behavior is required so I've commented out this test +;; for now. +;(define old-+ +) +;(begin (begin (begin) +; (begin (begin (begin) (define + (lambda (x y) (list y x))) +; (begin))) +; (begin)) +; (begin) +; (begin (begin (begin) (test '(3 6) add3 6) +; (begin)))) +;(set! + old-+) +(test 9 add3 6) +(begin) +(begin (begin)) +(begin (begin (begin (begin)))) +(SECTION 5 2 2) +(test 45 'define + (let ((x 5)) + (begin (begin (begin) + (begin (begin (begin) (define foo (lambda (y) (bar x y))) + (begin))) + (begin)) + (begin) + (begin) + (begin (define bar (lambda (a b) (+ (* a b) a)))) + (begin)) + (begin) + (begin (foo (+ x 3))))) +(define x 34) +(define (foo) (define x 5) x) +(test 5 foo) +(test 34 'define x) +(define foo (lambda () (define x 5) x)) +(test 5 foo) +(test 34 'define x) +(define (foo x) ((lambda () (define x 5) x)) x) +(test 88 foo 88) +(test 4 foo 4) +(test 34 'define x) +(test 99 'internal-define (letrec ((foo (lambda (arg) + (or arg (and (procedure? foo) + (foo 99)))))) + (define bar (foo #f)) + (foo #f))) +(test 77 'internal-define (letrec ((foo 77) + (bar #f) + (retfoo (lambda () foo))) + (define baz (retfoo)) + (retfoo))) +(SECTION 6 1) +(test #f not #t) +(test #f not 3) +(test #f not (list 3)) +(test #t not #f) +(test #f not '()) +(test #f not (list)) +(test #f not 'nil) + +;(test #t boolean? #f) +;(test #f boolean? 0) +;(test #f boolean? '()) +(SECTION 6 2) +(test #t eqv? 'a 'a) +(test #f eqv? 'a 'b) +(test #t eqv? 2 2) +(test #t eqv? '() '()) +(test #t eqv? '10000 '10000) +(test #f eqv? (cons 1 2)(cons 1 2)) +(test #f eqv? (lambda () 1) (lambda () 2)) +(test #f eqv? #f 'nil) +(let ((p (lambda (x) x))) + (test #t eqv? p p)) +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(let ((g (gen-counter))) (test #t eqv? g g)) +(test #f eqv? (gen-counter) (gen-counter)) +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (test #f eqv? f g)) + +(test #t eq? 'a 'a) +(test #f eq? (list 'a) (list 'a)) +(test #t eq? '() '()) +(test #t eq? car car) +(let ((x '(a))) (test #t eq? x x)) +(let ((x '#())) (test #t eq? x x)) +(let ((x (lambda (x) x))) (test #t eq? x x)) + +(define test-eq?-eqv?-agreement + (lambda (obj1 obj2) + (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2))) + (else + (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2))) + (display "eqv? and eq? disagree about ") + (write obj1) + (display #\ ) + (write obj2) + (newline))))) + +(test-eq?-eqv?-agreement '#f '#f) +(test-eq?-eqv?-agreement '#t '#t) +(test-eq?-eqv?-agreement '#t '#f) +(test-eq?-eqv?-agreement '(a) '(a)) +(test-eq?-eqv?-agreement '(a) '(b)) +(test-eq?-eqv?-agreement car car) +(test-eq?-eqv?-agreement car cdr) +(test-eq?-eqv?-agreement (list 'a) (list 'a)) +(test-eq?-eqv?-agreement (list 'a) (list 'b)) +(test-eq?-eqv?-agreement '#(a) '#(a)) +(test-eq?-eqv?-agreement '#(a) '#(b)) +(test-eq?-eqv?-agreement "abc" "abc") +(test-eq?-eqv?-agreement "abc" "abz") + +(test #t equal? 'a 'a) +(test #t equal? '(a) '(a)) +(test #t equal? '(a (b) c) '(a (b) c)) +(test #t equal? "abc" "abc") +(test #t equal? 2 2) +(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) +(SECTION 6 3) +(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) +(define x (list 'a 'b 'c)) +(define y x) +(and list? (test #t list? y)) +(set-cdr! x 4) +(test '(a . 4) 'set-cdr! x) +(test #t eqv? x y) +(test '(a b c . d) 'dot '(a . (b . (c . d)))) +(and list? (test #f list? y)) +(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) + +;(test #t pair? '(a . b)) +;(test #t pair? '(a . 1)) +;(test #t pair? '(a b c)) +;(test #f pair? '()) +;(test #f pair? '#(a b)) + +(test '(a) cons 'a '()) +(test '((a) b c d) cons '(a) '(b c d)) +(test '("a" b c) cons "a" '(b c)) +(test '(a . 3) cons 'a 3) +(test '((a b) . c) cons '(a b) 'c) + +(test 'a car '(a b c)) +(test '(a) car '((a) b c d)) +(test 1 car '(1 . 2)) + +(test '(b c d) cdr '((a) b c d)) +(test 2 cdr '(1 . 2)) + +(test '(a 7 c) list 'a (+ 3 4) 'c) +(test '() list) + +(test 3 length '(a b c)) +(test 3 length '(a (b) (c d e))) +(test 0 length '()) + +(test '(x y) append '(x) '(y)) +(test '(a b c d) append '(a) '(b c d)) +(test '(a (b) (c)) append '(a (b)) '((c))) +(test '() append) +(test '(a b c . d) append '(a b) '(c . d)) +(test 'a append '() 'a) + +(test '(c b a) reverse '(a b c)) +(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) + +(test 'c list-ref '(a b c d) 2) + +(test '(a b c) memq 'a '(a b c)) +(test '(b c) memq 'b '(a b c)) +(test '#f memq 'a '(b c d)) +(test '#f memq (list 'a) '(b (a) c)) +(test '((a) c) member (list 'a) '(b (a) c)) +(test '(101 102) memv 101 '(100 101 102)) + +(define e '((a 1) (b 2) (c 3))) +(test '(a 1) assq 'a e) +(test '(b 2) assq 'b e) +(test #f assq 'd e) +(test #f assq (list 'a) '(((a)) ((b)) ((c)))) +(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) +(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) +(SECTION 6 4) +;(test #t symbol? 'foo) +(test #t symbol? (car '(a b))) +;(test #f symbol? "bar") +;(test #t symbol? 'nil) +;(test #f symbol? '()) +;(test #f symbol? #f) +;;; But first, what case are symbols in? Determine the standard case: +(define char-standard-case char-upcase) +(if (string=? (symbol->string 'A) "a") + (set! char-standard-case char-downcase)) +(test #t 'standard-case + (string=? (symbol->string 'a) (symbol->string 'A))) +(test #t 'standard-case + (or (string=? (symbol->string 'a) "A") + (string=? (symbol->string 'A) "a"))) +(define (str-copy s) + (let ((v (make-string (string-length s)))) + (do ((i (- (string-length v) 1) (- i 1))) + ((< i 0) v) + (string-set! v i (string-ref s i))))) +(define (string-standard-case s) + (set! s (str-copy s)) + (do ((i 0 (+ 1 i)) + (sl (string-length s))) + ((>= i sl) s) + (string-set! s i (char-standard-case (string-ref s i))))) +(test (string-standard-case "flying-fish") symbol->string 'flying-fish) +(test (string-standard-case "martin") symbol->string 'Martin) +(test "Malvina" symbol->string (string->symbol "Malvina")) +(test #t 'standard-case (eq? 'a 'A)) + +(define x (string #\a #\b)) +(define y (string->symbol x)) +(string-set! x 0 #\c) +(test "cb" 'string-set! x) +(test "ab" symbol->string y) +(test y string->symbol "ab") + +(test #t eq? 'mISSISSIppi 'mississippi) +(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) +(test 'JollyWog string->symbol (symbol->string 'JollyWog)) + +(SECTION 6 5 5) +(test #t number? 3) +(test #t complex? 3) +(test #t real? 3) +(test #t rational? 3) +(test #t integer? 3) + +(test #t exact? 3) +(test #f inexact? 3) + +(test #t = 22 22 22) +(test #t = 22 22) +(test #f = 34 34 35) +(test #f = 34 35) +(test #t > 3 -6246) +(test #f > 9 9 -2424) +(test #t >= 3 -4 -6246) +(test #t >= 9 9) +(test #f >= 8 9) +(test #t < -1 2 3 4 5 6 7 8) +(test #f < -1 2 3 4 4 5 6 7) +(test #t <= -1 2 3 4 5 6 7 8) +(test #t <= -1 2 3 4 4 5 6 7) +(test #f < 1 3 2) +(test #f >= 1 3 2) + +(test #t zero? 0) +(test #f zero? 1) +(test #f zero? -1) +(test #f zero? -100) +(test #t positive? 4) +(test #f positive? -4) +(test #f positive? 0) +(test #f negative? 4) +(test #t negative? -4) +(test #f negative? 0) +(test #t odd? 3) +(test #f odd? 2) +(test #f odd? -4) +(test #t odd? -1) +(test #f even? 3) +(test #t even? 2) +(test #t even? -4) +(test #f even? -1) + +(test 38 max 34 5 7 38 6) +(test -24 min 3 5 5 330 4 -24) + +(test 7 + 3 4) +(test '3 + 3) +(test 0 +) +(test 4 * 4) +(test 1 *) + +(test -1 - 3 4) +(test -3 - 3) +(test 7 abs -7) +(test 7 abs 7) +(test 0 abs 0) + +(test 5 quotient 35 7) +(test -5 quotient -35 7) +(test -5 quotient 35 -7) +(test 5 quotient -35 -7) +(test 1 modulo 13 4) +(test 1 remainder 13 4) +(test 3 modulo -13 4) +(test -1 remainder -13 4) +(test -3 modulo 13 -4) +(test 1 remainder 13 -4) +(test -1 modulo -13 -4) +(test -1 remainder -13 -4) +(test 0 modulo 0 86400) +(test 0 modulo 0 -86400) +(define (divtest n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2)))) +(test #t divtest 238 9) +(test #t divtest -238 9) +(test #t divtest 238 -9) +(test #t divtest -238 -9) + +(test 4 gcd 0 4) +(test 4 gcd -4 0) +(test 4 gcd 32 -36) +(test 0 gcd) +(test 288 lcm 32 -36) +(test 1 lcm) + +;;;;From: fred@sce.carleton.ca (Fred J Kaudel) +;;; Modified by jaffer. +(define (test-inexact) + (define f3.9 (string->number "3.9")) + (define f4.0 (string->number "4.0")) + (define f-3.25 (string->number "-3.25")) + (define f.25 (string->number ".25")) + (define f4.5 (string->number "4.5")) + (define f3.5 (string->number "3.5")) + (define f0.0 (string->number "0.0")) + (define f0.8 (string->number "0.8")) + (define f1.0 (string->number "1.0")) + (define wto write-test-obj) + (define lto load-test-obj) + (newline) + (display ";testing inexact numbers; ") + (newline) + (SECTION 6 5 5) + (test #t inexact? f3.9) + (test #t 'inexact? (inexact? (max f3.9 4))) + (test f4.0 'max (max f3.9 4)) + (test f4.0 'exact->inexact (exact->inexact 4)) + (test (- f4.0) round (- f4.5)) + (test (- f4.0) round (- f3.5)) + (test (- f4.0) round (- f3.9)) + (test f0.0 round f0.0) + (test f0.0 round f.25) + (test f1.0 round f0.8) + (test f4.0 round f3.5) + (test f4.0 round f4.5) + (test 1 expt 0 0) + (test 0 expt 0 1) + (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. + (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) + (test #t call-with-output-file + "tmp3" + (lambda (test-file) + (write-char #\; test-file) + (display #\; test-file) + (display ";" test-file) + (write write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) + (check-test-file "tmp3") + (set! write-test-obj wto) + (set! load-test-obj lto) + (let ((x (string->number "4195835.0")) + (y (string->number "3145727.0"))) + (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) + (report-errs)) + +(define (test-inexact-printing) + (let ((f0.0 (string->number "0.0")) + (f0.5 (string->number "0.5")) + (f1.0 (string->number "1.0")) + (f2.0 (string->number "2.0"))) + (define log2 + (let ((l2 (log 2))) + (lambda (x) (/ (log x) l2)))) + + (define (slow-frexp x) + (if (zero? x) + (list f0.0 0) + (let* ((l2 (log2 x)) + (e (floor (log2 x))) + (e (if (= l2 e) + (inexact->exact e) + (+ (inexact->exact e) 1))) + (f (/ x (expt 2 e)))) + (list f e)))) + + (define float-precision + (let ((mantissa-bits + (do ((i 0 (+ i 1)) + (eps f1.0 (* f0.5 eps))) + ((= f1.0 (+ f1.0 eps)) + i))) + (minval + (do ((x f1.0 (* f0.5 x))) + ((zero? (* f0.5 x)) x)))) + (lambda (x) + (apply (lambda (f e) + (let ((eps + (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits)))) + ((zero? f) minval) + (else (expt f2.0 (- e mantissa-bits)))))) + (if (zero? eps) ;Happens if gradual underflow. + minval + eps))) + (slow-frexp x))))) + + (define (float-print-test x) + (define (testit number) + (eqv? number (string->number (number->string number)))) + (let ((eps (float-precision x)) + (all-ok? #t)) + (do ((j -100 (+ j 1))) + ((or (not all-ok?) (> j 100)) all-ok?) + (let* ((xx (+ x (* j eps))) + (ok? (testit xx))) + (cond ((not ok?) + (display "Number readback failure for ") + (display `(+ ,x (* ,j ,eps))) + (newline) + (display xx) + (newline) + (set! all-ok? #f)) + ;; (else (display xx) (newline)) + ))))) + + (define (mult-float-print-test x) + (let ((res #t)) + (for-each + (lambda (mult) + (or (float-print-test (* mult x)) (set! res #f))) + (map string->number + '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100" + "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100"))) + res)) + + (SECTION 6 5 6) + (test #t 'float-print-test (float-print-test f0.0)) + (test #t 'mult-float-print-test (mult-float-print-test f1.0)) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "3.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "7.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "3.1415926535897931"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "2.7182818284590451"))))) + + +(define (test-bignum) + (define tb + (lambda (n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2))))) + (newline) + (display ";testing bignums; ") + (newline) + (SECTION 6 5 7) + (test 0 modulo 33333333333333333333 3) + (test 0 modulo 33333333333333333333 -3) + (test 0 remainder 33333333333333333333 3) + (test 0 remainder 33333333333333333333 -3) + (test 2 modulo 33333333333333333332 3) + (test -1 modulo 33333333333333333332 -3) + (test 2 remainder 33333333333333333332 3) + (test 2 remainder 33333333333333333332 -3) + (test 1 modulo -33333333333333333332 3) + (test -2 modulo -33333333333333333332 -3) + (test -2 remainder -33333333333333333332 3) + (test -2 remainder -33333333333333333332 -3) + + (test 3 modulo 3 33333333333333333333) + (test 33333333333333333330 modulo -3 33333333333333333333) + (test 3 remainder 3 33333333333333333333) + (test -3 remainder -3 33333333333333333333) + (test -33333333333333333330 modulo 3 -33333333333333333333) + (test -3 modulo -3 -33333333333333333333) + (test 3 remainder 3 -33333333333333333333) + (test -3 remainder -3 -33333333333333333333) + + (test 0 modulo -2177452800 86400) + (test 0 modulo 2177452800 -86400) + (test 0 modulo 2177452800 86400) + (test 0 modulo -2177452800 -86400) + (test 0 modulo 0 -2177452800) + (test #t 'remainder (tb 281474976710655325431 65535)) + (test #t 'remainder (tb 281474976710655325430 65535)) + (SECTION 6 5 8) + (test 281474976710655325431 string->number "281474976710655325431") + (test "281474976710655325431" number->string 281474976710655325431) + (report-errs)) + +(SECTION 6 5 9) +(test "0" number->string 0) +(test "100" number->string 100) +(test "100" number->string 256 16) +(test 100 string->number "100") +(test 256 string->number "100" 16) +(test #f string->number "") +(test #f string->number ".") +(test #f string->number "d") +(test #f string->number "D") +(test #f string->number "i") +(test #f string->number "I") +(test #f string->number "3i") +(test #f string->number "3I") +(test #f string->number "33i") +(test #f string->number "33I") +(test #f string->number "3.3i") +(test #f string->number "3.3I") +(test #f string->number "-") +(test #f string->number "+") + +(SECTION 6 6) +(test #t eqv? '#\ #\Space) +(test #t eqv? #\space '#\Space) +(test #t char? #\a) +(test #t char? #\() +(test #t char? #\ ) +(test #t char? '#\newline) + +(test #f char=? #\A #\B) +(test #f char=? #\a #\b) +(test #f char=? #\9 #\0) +(test #t char=? #\A #\A) + +(test #t char? #\A #\B) +(test #f char>? #\a #\b) +(test #t char>? #\9 #\0) +(test #f char>? #\A #\A) + +(test #t char<=? #\A #\B) +(test #t char<=? #\a #\b) +(test #f char<=? #\9 #\0) +(test #t char<=? #\A #\A) + +(test #f char>=? #\A #\B) +(test #f char>=? #\a #\b) +(test #t char>=? #\9 #\0) +(test #t char>=? #\A #\A) + +(test #f char-ci=? #\A #\B) +(test #f char-ci=? #\a #\B) +(test #f char-ci=? #\A #\b) +(test #f char-ci=? #\a #\b) +(test #f char-ci=? #\9 #\0) +(test #t char-ci=? #\A #\A) +(test #t char-ci=? #\A #\a) + +(test #t char-ci? #\A #\B) +(test #f char-ci>? #\a #\B) +(test #f char-ci>? #\A #\b) +(test #f char-ci>? #\a #\b) +(test #t char-ci>? #\9 #\0) +(test #f char-ci>? #\A #\A) +(test #f char-ci>? #\A #\a) + +(test #t char-ci<=? #\A #\B) +(test #t char-ci<=? #\a #\B) +(test #t char-ci<=? #\A #\b) +(test #t char-ci<=? #\a #\b) +(test #f char-ci<=? #\9 #\0) +(test #t char-ci<=? #\A #\A) +(test #t char-ci<=? #\A #\a) + +(test #f char-ci>=? #\A #\B) +(test #f char-ci>=? #\a #\B) +(test #f char-ci>=? #\A #\b) +(test #f char-ci>=? #\a #\b) +(test #t char-ci>=? #\9 #\0) +(test #t char-ci>=? #\A #\A) +(test #t char-ci>=? #\A #\a) + +(test #t char-alphabetic? #\a) +(test #t char-alphabetic? #\A) +(test #t char-alphabetic? #\z) +(test #t char-alphabetic? #\Z) +(test #f char-alphabetic? #\0) +(test #f char-alphabetic? #\9) +(test #f char-alphabetic? #\space) +(test #f char-alphabetic? #\;) + +(test #f char-numeric? #\a) +(test #f char-numeric? #\A) +(test #f char-numeric? #\z) +(test #f char-numeric? #\Z) +(test #t char-numeric? #\0) +(test #t char-numeric? #\9) +(test #f char-numeric? #\space) +(test #f char-numeric? #\;) + +(test #f char-whitespace? #\a) +(test #f char-whitespace? #\A) +(test #f char-whitespace? #\z) +(test #f char-whitespace? #\Z) +(test #f char-whitespace? #\0) +(test #f char-whitespace? #\9) +(test #t char-whitespace? #\space) +(test #f char-whitespace? #\;) + +(test #f char-upper-case? #\0) +(test #f char-upper-case? #\9) +(test #f char-upper-case? #\space) +(test #f char-upper-case? #\;) + +(test #f char-lower-case? #\0) +(test #f char-lower-case? #\9) +(test #f char-lower-case? #\space) +(test #f char-lower-case? #\;) + +(test #\. integer->char (char->integer #\.)) +(test #\A integer->char (char->integer #\A)) +(test #\a integer->char (char->integer #\a)) +(test #\A char-upcase #\A) +(test #\A char-upcase #\a) +(test #\a char-downcase #\A) +(test #\a char-downcase #\a) +(SECTION 6 7) +(test #t string? "The word \"recursion\\\" has many meanings.") +;(test #t string? "") +(define f (make-string 3 #\*)) +(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) +(test "abc" string #\a #\b #\c) +(test "" string) +(test 3 string-length "abc") +(test #\a string-ref "abc" 0) +(test #\c string-ref "abc" 2) +(test 0 string-length "") +(test "" substring "ab" 0 0) +(test "" substring "ab" 1 1) +(test "" substring "ab" 2 2) +(test "a" substring "ab" 0 1) +(test "b" substring "ab" 1 2) +(test "ab" substring "ab" 0 2) +(test "foobar" string-append "foo" "bar") +(test "foo" string-append "foo") +(test "foo" string-append "foo" "") +(test "foo" string-append "" "foo") +(test "" string-append) +(test "" make-string 0) +(test #t string=? "" "") +(test #f string? "" "") +(test #t string<=? "" "") +(test #t string>=? "" "") +(test #t string-ci=? "" "") +(test #f string-ci? "" "") +(test #t string-ci<=? "" "") +(test #t string-ci>=? "" "") + +(test #f string=? "A" "B") +(test #f string=? "a" "b") +(test #f string=? "9" "0") +(test #t string=? "A" "A") + +(test #t string? "A" "B") +(test #f string>? "a" "b") +(test #t string>? "9" "0") +(test #f string>? "A" "A") + +(test #t string<=? "A" "B") +(test #t string<=? "a" "b") +(test #f string<=? "9" "0") +(test #t string<=? "A" "A") + +(test #f string>=? "A" "B") +(test #f string>=? "a" "b") +(test #t string>=? "9" "0") +(test #t string>=? "A" "A") + +(test #f string-ci=? "A" "B") +(test #f string-ci=? "a" "B") +(test #f string-ci=? "A" "b") +(test #f string-ci=? "a" "b") +(test #f string-ci=? "9" "0") +(test #t string-ci=? "A" "A") +(test #t string-ci=? "A" "a") + +(test #t string-ci? "A" "B") +(test #f string-ci>? "a" "B") +(test #f string-ci>? "A" "b") +(test #f string-ci>? "a" "b") +(test #t string-ci>? "9" "0") +(test #f string-ci>? "A" "A") +(test #f string-ci>? "A" "a") + +(test #t string-ci<=? "A" "B") +(test #t string-ci<=? "a" "B") +(test #t string-ci<=? "A" "b") +(test #t string-ci<=? "a" "b") +(test #f string-ci<=? "9" "0") +(test #t string-ci<=? "A" "A") +(test #t string-ci<=? "A" "a") + +(test #f string-ci>=? "A" "B") +(test #f string-ci>=? "a" "B") +(test #f string-ci>=? "A" "b") +(test #f string-ci>=? "a" "b") +(test #t string-ci>=? "9" "0") +(test #t string-ci>=? "A" "A") +(test #t string-ci>=? "A" "a") +(SECTION 6 8) +(test #t vector? '#(0 (2 2 2 2) "Anna")) +;(test #t vector? '#()) +(test '#(a b c) vector 'a 'b 'c) +(test '#() vector) +(test 3 vector-length '#(0 (2 2 2 2) "Anna")) +(test 0 vector-length '#()) +(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) +(test '#(0 ("Sue" "Sue") "Anna") 'vector-set + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) +(test '#(hi hi) make-vector 2 'hi) +(test '#() make-vector 0) +(test '#() make-vector 0 'a) +(SECTION 6 9) +(test #t procedure? car) +;(test #f procedure? 'car) +(test #t procedure? (lambda (x) (* x x))) +(test #f procedure? '(lambda (x) (* x x))) +(test #t call-with-current-continuation procedure?) +(test 7 apply + (list 3 4)) +(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) +(test 17 apply + 10 (list 3 4)) +(test '() apply list '()) +(define compose (lambda (f g) (lambda args (f (apply g args))))) +(test 30 (compose sqt *) 12 75) + +(test '(b e h) map cadr '((a b) (d e) (g h))) +(test '(5 7 9) map + '(1 2 3) '(4 5 6)) +(test '(1 2 3) map + '(1 2 3)) +(test '(1 2 3) map * '(1 2 3)) +(test '(-1 -2 -3) map - '(1 2 3)) +(test '#(0 1 4 9 16) 'for-each + (let ((v (make-vector 5))) + (for-each (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) +(test -3 call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x))) + '(54 0 37 -3 245 19)) + #t)) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r (lambda (obj) (cond ((null? obj) 0) + ((pair? obj) (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) +(test 4 list-length '(1 2 3 4)) +(test #f list-length '(a b . c)) +(test '() map cadr '()) + +;;; This tests full conformance of call-with-current-continuation. It +;;; is a separate test because some schemes do not support call/cc +;;; other than escape procedures. I am indebted to +;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this +;;; code. The function leaf-eq? compares the leaves of 2 arbitrary +;;; trees constructed of conses. +(define (next-leaf-generator obj eot) + (letrec ((return #f) + (cont (lambda (x) + (recur obj) + (set! cont (lambda (x) (return eot))) + (cont #f))) + (recur (lambda (obj) + (if (pair? obj) + (for-each recur obj) + (call-with-current-continuation + (lambda (c) + (set! cont c) + (return obj))))))) + (lambda () (call-with-current-continuation + (lambda (ret) (set! return ret) (cont #f)))))) +(define (leaf-eq? x y) + (let* ((eot (list 'eot)) + (xf (next-leaf-generator x eot)) + (yf (next-leaf-generator y eot))) + (letrec ((loop (lambda (x y) + (cond ((not (eq? x y)) #f) + ((eq? eot x) #t) + (else (loop (xf) (yf))))))) + (loop (xf) (yf))))) +(define (test-cont) + (newline) + (display ";testing continuations; ") + (newline) + (SECTION 6 9) + (test #t leaf-eq? '(a (b (c))) '((a) b c)) + (test #f leaf-eq? '(a (b (c))) '((a) b c d)) + (report-errs)) + +;;; Test Optional R4RS DELAY syntax and FORCE procedure +(define (test-delay) + (newline) + (display ";testing DELAY and FORCE; ") + (newline) + (SECTION 6 9) + (test 3 'delay (force (delay (+ 1 2)))) + (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + (test 2 'delay (letrec ((a-stream + (letrec ((next (lambda (n) + (cons n (delay (next (+ n 1))))))) + (next 0))) + (head car) + (tail (lambda (stream) (force (cdr stream))))) + (head (tail (tail a-stream))))) + (letrec ((count 0) + (p (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (x 5)) + (test 6 force p) + (set! x 10) + (test 6 force p)) + (test 3 'force + (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) + (c #f)) + (force p))) + (report-errs)) + +(SECTION 6 10 1) +(test #t input-port? (current-input-port)) +(test #t output-port? (current-output-port)) +(test #t call-with-input-file "r4rstest.scm" input-port?) +(define this-file (open-input-file "r4rstest.scm")) +(test #t input-port? this-file) +(SECTION 6 10 2) +(test #\; peek-char this-file) +(test #\; read-char this-file) +(test '(define cur-section '()) read this-file) +(test #\( peek-char this-file) +(test '(define errs '()) read this-file) +(close-input-port this-file) +(close-input-port this-file) +(define (check-test-file name) + (define test-file (open-input-file name)) + (test #t 'input-port? + (call-with-input-file + name + (lambda (test-file) + (test load-test-obj read test-file) + (test #t eof-object? (peek-char test-file)) + (test #t eof-object? (read-char test-file)) + (input-port? test-file)))) + (test #\; read-char test-file) + (test #\; read-char test-file) + (test #\; read-char test-file) + (test write-test-obj read test-file) + (test load-test-obj read test-file) + (close-input-port test-file)) +(SECTION 6 10 3) +(define write-test-obj + '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) +(define load-test-obj + (list 'define 'foo (list 'quote write-test-obj))) +(test #t call-with-output-file + "tmp1" + (lambda (test-file) + (write-char #\; test-file) + (display #\; test-file) + (display ";" test-file) + (write write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) +(check-test-file "tmp1") + +(define test-file (open-output-file "tmp2")) +(write-char #\; test-file) +(display #\; test-file) +(display ";" test-file) +(write write-test-obj test-file) +(newline test-file) +(write load-test-obj test-file) +(test #t output-port? test-file) +(close-output-port test-file) +(check-test-file "tmp2") +(define (test-sc4) + (newline) + (display ";testing scheme 4 functions; ") + (newline) + (SECTION 6 7) + (test '(#\P #\space #\l) string->list "P l") + (test '() string->list "") + (test "1\\\"" list->string '(#\1 #\\ #\")) + (test "" list->string '()) + (SECTION 6 8) + (test '(dah dah didah) vector->list '#(dah dah didah)) + (test '() vector->list '#()) + (test '#(dididit dah) list->vector '(dididit dah)) + (test '#() list->vector '()) + (SECTION 6 10 4) + (load "tmp1") + (test write-test-obj 'load foo) + (report-errs)) +(newline) +(report-errs) +(cond ((and (string->number "0.0") (inexact? (string->number "0.0"))) + (test-inexact) + (test-inexact-printing))) + +(let ((n (string->number "281474976710655325431"))) + (if (and n (exact? n)) + (test-bignum))) +(newline) +(display "To fully test continuations do:") +(newline) +(display "(test-cont)") +(newline) +(test-sc4) +(newline) +(test-delay) +(newline) +(test-cont) +"last item in file" diff --git a/vx-scheme/testcases/scheme.scm b/vx-scheme/testcases/scheme.scm new file mode 100644 index 0000000..aec6690 --- /dev/null +++ b/vx-scheme/testcases/scheme.scm @@ -0,0 +1,1083 @@ +;;; SCHEME -- A Scheme interpreter evaluating a sorting routine, written by Marc Feeley. +; +; 08/06/01 (felix): renamed "macro?" to "macro?2" because MZC can't +; handle redefinitions of primitives. +; 18/07/01 (felix): 100 iterations +; + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-eval expr) + (let ((code (scheme-comp expr scheme-global-environment))) + (code #f))) + +(define scheme-global-environment + (cons '() ; environment chain + '())) ; macros + +(define (scheme-add-macro name proc) + (set-cdr! scheme-global-environment + (cons (cons name proc) (cdr scheme-global-environment))) + name) + +(define (scheme-error msg . args) + (fatal-error msg args)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (lst->vector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro?2 name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro?2 (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro?2 (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + x + (let ((y (cons name '()))) + (set! scheme-global-variables (cons y scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (cdr i)) + +(define (scheme-global-var-set! i val) + (set-cdr! i val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? pair?) +(def-proc 'cons cons) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +(def-proc 'set-car! set-car!) +(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (run) + (let ((result #f)) + (do ((i 100 (- i 1))) + ((zero? i) result) + (set! result + (scheme-eval + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + string + # + # + # + # + # + # + # + # +(#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)# +(#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) +(# 3 4) ==> 12 +SECTION(4 1 4) +(# 4) ==> 8 +(# 7 10) ==> 3 +(# 6) ==> 10 +(# 3 4 5 6) ==> (3 4 5 6) +(# 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 +(# 6) ==> 9 +SECTION(5 2 2) +(define 45) ==> 45 +(#) ==> 5 +(define 34) ==> 34 +(#) ==> 5 +(define 34) ==> 34 +(# 88) ==> 88 +(# 4) ==> 4 +(define 34) ==> 34 +(internal-define 99) ==> 99 +(internal-define 77) ==> 77 +SECTION(6 1) +(# #t) ==> #f +(# 3) ==> #f +(# (3)) ==> #f +(# #f) ==> #t +(# ()) ==> #f +(# ()) ==> #f +(# nil) ==> #f +SECTION(6 2) +(# a a) ==> #t +(# a b) ==> #f +(# 2 2) ==> #t +(# () ()) ==> #t +(# 10000 10000) ==> #t +(# (1 . 2) (1 . 2)) ==> #f +(# # #) ==> #f +(# #f nil) ==> #f +(# # #) ==> #t +(# # #) ==> #t +(# # #) ==> #f +(# # #) ==> #f +(# a a) ==> #t +(# (a) (a)) ==> #f +(# () ()) ==> #t +(# # #) ==> #t +(# (a) (a)) ==> #t +(# #() #()) ==> #t +(# # #) ==> #t +(# a a) ==> #t +(# (a) (a)) ==> #t +(# (a (b) c) (a (b) c)) ==> #t +(# "abc" "abc") ==> #t +(# 2 2) ==> #t +(# #(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) +(# (a b c)) ==> #t +(set-cdr! (a . 4)) ==> (a . 4) +(# (a . 4) (a . 4)) ==> #t +(dot (a b c . d)) ==> (a b c . d) +(# (a . 4)) ==> #f +(list? #f) ==> #f +(# a ()) ==> (a) +(# (a) (b c d)) ==> ((a) b c d) +(# "a" (b c)) ==> ("a" b c) +(# a 3) ==> (a . 3) +(# (a b) c) ==> ((a b) . c) +(# (a b c)) ==> a +(# ((a) b c d)) ==> (a) +(# (1 . 2)) ==> 1 +(# ((a) b c d)) ==> (b c d) +(# (1 . 2)) ==> 2 +(# a 7 c) ==> (a 7 c) +(#) ==> () +(# (a b c)) ==> 3 +(# (a (b) (c d e))) ==> 3 +(# ()) ==> 0 +(# (x) (y)) ==> (x y) +(# (a) (b c d)) ==> (a b c d) +(# (a (b)) ((c))) ==> (a (b) (c)) +(#) ==> () +(# (a b) (c . d)) ==> (a b c . d) +(# () a) ==> a +(# (a b c)) ==> (c b a) +(# (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) +(# (a b c d) 2) ==> c +(# a (a b c)) ==> (a b c) +(# b (a b c)) ==> (b c) +(# a (b c d)) ==> #f +(# (a) (b (a) c)) ==> #f +(# (a) (b (a) c)) ==> ((a) c) +(# 101 (100 101 102)) ==> (101 102) +(# a ((a 1) (b 2) (c 3))) ==> (a 1) +(# b ((a 1) (b 2) (c 3))) ==> (b 2) +(# d ((a 1) (b 2) (c 3))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> ((a)) +(# 5 ((2 3) (5 7) (11 13))) ==> (5 7) +SECTION(6 4) +(# a) ==> #t +(standard-case #t) ==> #t +(standard-case #t) ==> #t +(#string> flying-fish) ==> "flying-fish" +(#string> martin) ==> "martin" +(#string> Malvina) ==> "Malvina" +(standard-case #t) ==> #t +(string-set! "cb") ==> "cb" +(#string> ab) ==> "ab" +(#symbol> "ab") ==> ab +(# mississippi mississippi) ==> #t +(string->symbol #f) ==> #f +(#symbol> "jollywog") ==> jollywog +SECTION(6 5 5) +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #f +(# 22 22 22) ==> #t +(# 22 22) ==> #t +(# 34 34 35) ==> #f +(# 34 35) ==> #f +(#> 3 -6246) ==> #t +(#> 9 9 -2424) ==> #f +(#=> 3 -4 -6246) ==> #t +(#=> 9 9) ==> #t +(#=> 8 9) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #t +(# 1 3 2) ==> #f +(#=> 1 3 2) ==> #f +(# 0) ==> #t +(# 1) ==> #f +(# -1) ==> #f +(# -100) ==> #f +(# 4) ==> #t +(# -4) ==> #f +(# 0) ==> #f +(# 4) ==> #f +(# -4) ==> #t +(# 0) ==> #f +(# 3) ==> #t +(# 2) ==> #f +(# -4) ==> #f +(# -1) ==> #t +(# 3) ==> #f +(# 2) ==> #t +(# -4) ==> #t +(# -1) ==> #f +(# 34 5 7 38 6) ==> 38 +(# 3 5 5 330 4 -24) ==> -24 +(# 3 4) ==> 7 +(# 3) ==> 3 +(#) ==> 0 +(# 4) ==> 4 +(#) ==> 1 +(# 3 4) ==> -1 +(# 3) ==> -3 +(# -7) ==> 7 +(# 7) ==> 7 +(# 0) ==> 0 +(# 35 7) ==> 5 +(# -35 7) ==> -5 +(# 35 -7) ==> -5 +(# -35 -7) ==> 5 +(# 13 4) ==> 1 +(# 13 4) ==> 1 +(# -13 4) ==> 3 +(# -13 4) ==> -1 +(# 13 -4) ==> -3 +(# 13 -4) ==> 1 +(# -13 -4) ==> -1 +(# -13 -4) ==> -1 +(# 0 86400) ==> 0 +(# 0 -86400) ==> 0 +(# 238 9) ==> #t +(# -238 9) ==> #t +(# 238 -9) ==> #t +(# -238 -9) ==> #t +(# 0 4) ==> 4 +(# -4 0) ==> 4 +(# 32 -36) ==> 4 +(#) ==> 0 +(# 32 -36) ==> 288 +(#) ==> 1 +SECTION(6 5 9) +(#string> 0) ==> "0" +(#string> 100) ==> "100" +(#string> 256 16) ==> "100" +(#number> "100") ==> 100 +(#number> "100" 16) ==> 256 +(#number> "") ==> #f +(#number> ".") ==> #f +(#number> "d") ==> #f +(#number> "D") ==> #f +(#number> "i") ==> #f +(#number> "I") ==> #f +(#number> "3i") ==> #f +(#number> "3I") ==> #f +(#number> "33i") ==> #f +(#number> "33I") ==> #f +(#number> "3.3i") ==> #f +(#number> "3.3I") ==> #f +(#number> "-") ==> #f +(#number> "+") ==> #f +SECTION(6 6) +(# #\ #\ ) ==> #t +(# #\ #\ ) ==> #t +(# #\a) ==> #t +(# #\() ==> #t +(# #\ ) ==> #t +(# #\ +) ==> #t +(# #\A #\B) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(# #\A #\B) ==> #f +(# #\a #\B) ==> #f +(# #\A #\b) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(# #\A #\a) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\B) ==> #f +(#?> #\A #\b) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(#?> #\A #\a) ==> #f +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\B) ==> #f +(#=?> #\A #\b) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(#=?> #\A #\a) ==> #t +(# #\a) ==> #t +(# #\A) ==> #t +(# #\z) ==> #t +(# #\Z) ==> #t +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #t +(# #\9) ==> #t +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #t +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(#char> 46) ==> #\. +(#char> 65) ==> #\A +(#char> 97) ==> #\a +(# #\A) ==> #\A +(# #\a) ==> #\A +(# #\A) ==> #\a +(# #\a) ==> #\a +SECTION(6 7) +(# "The word \"recursion\\\" has many meanings.") ==> #t +(string-set! "?**") ==> "?**" +(# #\a #\b #\c) ==> "abc" +(#) ==> "" +(# "abc") ==> 3 +(# "abc" 0) ==> #\a +(# "abc" 2) ==> #\c +(# "") ==> 0 +(# "ab" 0 0) ==> "" +(# "ab" 1 1) ==> "" +(# "ab" 2 2) ==> "" +(# "ab" 0 1) ==> "a" +(# "ab" 1 2) ==> "b" +(# "ab" 0 2) ==> "ab" +(# "foo" "bar") ==> "foobar" +(# "foo") ==> "foo" +(# "foo" "") ==> "foo" +(# "" "foo") ==> "foo" +(#) ==> "" +(# 0) ==> "" +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "A" "B") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(# "A" "B") ==> #f +(# "a" "B") ==> #f +(# "A" "b") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(# "A" "a") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "B") ==> #f +(#?> "A" "b") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(#?> "A" "a") ==> #f +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "B") ==> #f +(#=?> "A" "b") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(#=?> "A" "a") ==> #t +SECTION(6 8) +(# #(0 (2 2 2 2) "Anna")) ==> #t +(# a b c) ==> #(a b c) +(#) ==> #() +(# #(0 (2 2 2 2) "Anna")) ==> 3 +(# #()) ==> 0 +(# #(1 1 2 3 5 8 13 21) 5) ==> 8 +(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna") +(# 2 hi) ==> #(hi hi) +(# 0) ==> #() +(# 0 a) ==> #() +SECTION(6 9) +(# #) ==> #t +(# #) ==> #t +(# (lambda (x) (* x x))) ==> #f +(# #) ==> #t +(# # (3 4)) ==> 7 +(# # (3 4)) ==> 7 +(# # 10 (3 4)) ==> 17 +(# # ()) ==> () +(# 12 75) ==> 30 +(# # ((a b) (d e) (g h))) ==> (b e h) +(# # (1 2 3) (4 5 6)) ==> (5 7 9) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (-1 -2 -3) +(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16) +(# #) ==> -3 +(# (1 2 3 4)) ==> 4 +(# (a b . c)) ==> #f +(# # ()) ==> () +SECTION(6 10 1) +(# #) ==> #t +(# #) ==> #t +(# "r4rstest.scm" #) ==> #t +(# #) ==> #t +SECTION(6 10 2) +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (define cur-section (quote ())) +(# #) ==> #\( +(# #) ==> (define errs (quote ())) +SECTION(6 10 3) +(# "tmp1" #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) + + +Passed all tests + +;testing inexact numbers; +SECTION(6 5 5) +(# 3.9) ==> #t +(inexact? #t) ==> #t +(max 4.) ==> 4. +(exact->inexact 4.) ==> 4. +(# -4.5) ==> -4. +(# -3.5) ==> -4. +(# -3.9) ==> -4. +(# 0.) ==> 0. +(# 0.25) ==> 0. +(# 0.8) ==> 1. +(# 3.5) ==> 4. +(# 4.5) ==> 4. +(# 0 0) ==> 1 +(# 0 1) ==> 0 +(# "tmp3" #) ==> #t +(# #) ==> (define foo (quote (0.25 -3.25))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (0.25 -3.25) +(# #) ==> (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) +(#list> "P l") ==> (#\P #\ #\l) +(#list> "") ==> () +(#string> (#\1 #\\ #\")) ==> "1\\\"" +(#string> ()) ==> "" +SECTION(6 8) +(#list> #(dah dah didah)) ==> (dah dah didah) +(#list> #()) ==> () +(#vector> (dididit dah)) ==> #(dididit dah) +(#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 +(# #>) ==> 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) +(# (a (b (c))) ((a) b c)) ==> #t +(# (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))) + diff --git a/vx-scheme/testcases/vx-good/scheme.good b/vx-scheme/testcases/vx-good/scheme.good new file mode 100755 index 0000000..b8a4c53 --- /dev/null +++ b/vx-scheme/testcases/vx-good/scheme.good @@ -0,0 +1 @@ +("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") \ No newline at end of file diff --git a/vx-scheme/testcases/vx-good/series.good b/vx-scheme/testcases/vx-good/series.good new file mode 100755 index 0000000..323ea67 --- /dev/null +++ b/vx-scheme/testcases/vx-good/series.good @@ -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 diff --git a/vx-scheme/testcases/vx-good/sieve.good b/vx-scheme/testcases/vx-good/sieve.good new file mode 100755 index 0000000..b6bb9c8 --- /dev/null +++ b/vx-scheme/testcases/vx-good/sieve.good @@ -0,0 +1 @@ +1993 diff --git a/vx-scheme/testcases/vx-test.scm b/vx-scheme/testcases/vx-test.scm new file mode 100644 index 0000000..ceb51fd --- /dev/null +++ b/vx-scheme/testcases/vx-test.scm @@ -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)) + + + diff --git a/vx-scheme/testcases/w32-good/ack.good b/vx-scheme/testcases/w32-good/ack.good new file mode 100755 index 0000000..ce579ec --- /dev/null +++ b/vx-scheme/testcases/w32-good/ack.good @@ -0,0 +1,3 @@ +253 +509 +1021 diff --git a/vx-scheme/testcases/w32-good/boyer.good b/vx-scheme/testcases/w32-good/boyer.good new file mode 100644 index 0000000..56ed4c7 --- /dev/null +++ b/vx-scheme/testcases/w32-good/boyer.good @@ -0,0 +1 @@ +#t diff --git a/vx-scheme/testcases/w32-good/cf.good b/vx-scheme/testcases/w32-good/cf.good new file mode 100644 index 0000000..9baaef2 --- /dev/null +++ b/vx-scheme/testcases/w32-good/cf.good @@ -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) diff --git a/vx-scheme/testcases/w32-good/dderiv.good b/vx-scheme/testcases/w32-good/dderiv.good new file mode 100644 index 0000000..4acc996 --- /dev/null +++ b/vx-scheme/testcases/w32-good/dderiv.good @@ -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) diff --git a/vx-scheme/testcases/w32-good/dynamic.good b/vx-scheme/testcases/w32-good/dynamic.good new file mode 100644 index 0000000..c460021 --- /dev/null +++ b/vx-scheme/testcases/w32-good/dynamic.good @@ -0,0 +1 @@ +((218 . 437) (6 . 1892) (2204 . 441)) diff --git a/vx-scheme/testcases/w32-good/earley.good b/vx-scheme/testcases/w32-good/earley.good new file mode 100644 index 0000000..4efaa29 --- /dev/null +++ b/vx-scheme/testcases/w32-good/earley.good @@ -0,0 +1 @@ +1430 diff --git a/vx-scheme/testcases/w32-good/maze.good b/vx-scheme/testcases/w32-good/maze.good new file mode 100644 index 0000000..ff530a6 --- /dev/null +++ b/vx-scheme/testcases/w32-good/maze.good @@ -0,0 +1,42 @@ + _ _ _ + _/ \_/ \_/.\ +/ \ \_ . /.\ +\ \ /. _/.\ / +/ \_/. _/ \_ .\ +\ / \ / _/ \_/ +/ _/.\ / \ / \ +\ / \ / _/ / +/ \ /.\ /.\_/ \ +\_/ \ /. _ .\ / +/ \_ . _/ \ \ +\_ \_/ _/.\ / +/ _/ / \ / \ +\_ \ / \_ .\_/ +/ \_ \_ \_ .\ +\_ \_/ _/.\ / +/ \_ \ /.\ .\ +\ /.\_ . /.\ / +/ . _/.\ / \ +\ /.\_/.\_ .\ / +/ \_ . / _/ \ +\_ \_/.\_ \_/ +/ _/ \ / \_ \ +\_/ _/.\_ \_/ +/ \ / _ . _ \ +\ / \_/. _ \_/ +/ _ \ \_/ \ +\_/.\_ .\_/ _/ +/ \ . _/ / \ +\ /.\_/ \_/.\ / +/ \_ . _/. \ +\ . /.\_/ +/ \_/ \_/ \_ .\ +\_/ / \_/. / +/ / _ \ / \ +\_/ \_/ \_/.\_/ +/ \_/ _/ \_ .\ +\ _/. /. _/ +/ \ /. / \_ .\ +\_/. _/.\_/.\ / +/ _ .\_ . _ .\ +\_/ \ / \_/ \_/ diff --git a/vx-scheme/testcases/w32-good/pi.good b/vx-scheme/testcases/w32-good/pi.good new file mode 100755 index 0000000..fe40b33 --- /dev/null +++ b/vx-scheme/testcases/w32-good/pi.good @@ -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 diff --git a/vx-scheme/testcases/w32-good/puzzle.good b/vx-scheme/testcases/w32-good/puzzle.good new file mode 100644 index 0000000..9284822 --- /dev/null +++ b/vx-scheme/testcases/w32-good/puzzle.good @@ -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. diff --git a/vx-scheme/testcases/w32-good/r4rstest.good b/vx-scheme/testcases/w32-good/r4rstest.good new file mode 100644 index 0000000..5632fb8 --- /dev/null +++ b/vx-scheme/testcases/w32-good/r4rstest.good @@ -0,0 +1,778 @@ +SECTION(2 1) +SECTION(3 4) + # + # + # + # + # + # + # + # + # +(#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)# +(#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) +(# 3 4) ==> 12 +SECTION(4 1 4) +(# 4) ==> 8 +(# 7 10) ==> 3 +(# 6) ==> 10 +(# 3 4 5 6) ==> (3 4 5 6) +(# 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 +(# 6) ==> 9 +SECTION(5 2 2) +(define 45) ==> 45 +(#) ==> 5 +(define 34) ==> 34 +(#) ==> 5 +(define 34) ==> 34 +(# 88) ==> 88 +(# 4) ==> 4 +(define 34) ==> 34 +(internal-define 99) ==> 99 +(internal-define 77) ==> 77 +SECTION(6 1) +(# #t) ==> #f +(# 3) ==> #f +(# (3)) ==> #f +(# #f) ==> #t +(# ()) ==> #f +(# ()) ==> #f +(# nil) ==> #f +SECTION(6 2) +(# a a) ==> #t +(# a b) ==> #f +(# 2 2) ==> #t +(# () ()) ==> #t +(# 10000 10000) ==> #t +(# (1 . 2) (1 . 2)) ==> #f +(# # #) ==> #f +(# #f nil) ==> #f +(# # #) ==> #t +(# # #) ==> #t +(# # #) ==> #f +(# # #) ==> #f +(# a a) ==> #t +(# (a) (a)) ==> #f +(# () ()) ==> #t +(# # #) ==> #t +(# (a) (a)) ==> #t +(# #() #()) ==> #t +(# # #) ==> #t +(# a a) ==> #t +(# (a) (a)) ==> #t +(# (a (b) c) (a (b) c)) ==> #t +(# "abc" "abc") ==> #t +(# 2 2) ==> #t +(# #(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) +(# (a b c)) ==> #t +(set-cdr! (a . 4)) ==> (a . 4) +(# (a . 4) (a . 4)) ==> #t +(dot (a b c . d)) ==> (a b c . d) +(# (a . 4)) ==> #f +(list? #f) ==> #f +(# a ()) ==> (a) +(# (a) (b c d)) ==> ((a) b c d) +(# "a" (b c)) ==> ("a" b c) +(# a 3) ==> (a . 3) +(# (a b) c) ==> ((a b) . c) +(# (a b c)) ==> a +(# ((a) b c d)) ==> (a) +(# (1 . 2)) ==> 1 +(# ((a) b c d)) ==> (b c d) +(# (1 . 2)) ==> 2 +(# a 7 c) ==> (a 7 c) +(#) ==> () +(# (a b c)) ==> 3 +(# (a (b) (c d e))) ==> 3 +(# ()) ==> 0 +(# (x) (y)) ==> (x y) +(# (a) (b c d)) ==> (a b c d) +(# (a (b)) ((c))) ==> (a (b) (c)) +(#) ==> () +(# (a b) (c . d)) ==> (a b c . d) +(# () a) ==> a +(# (a b c)) ==> (c b a) +(# (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) +(# (a b c d) 2) ==> c +(# a (a b c)) ==> (a b c) +(# b (a b c)) ==> (b c) +(# a (b c d)) ==> #f +(# (a) (b (a) c)) ==> #f +(# (a) (b (a) c)) ==> ((a) c) +(# 101 (100 101 102)) ==> (101 102) +(# a ((a 1) (b 2) (c 3))) ==> (a 1) +(# b ((a 1) (b 2) (c 3))) ==> (b 2) +(# d ((a 1) (b 2) (c 3))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> #f +(# (a) (((a)) ((b)) ((c)))) ==> ((a)) +(# 5 ((2 3) (5 7) (11 13))) ==> (5 7) +SECTION(6 4) +(# a) ==> #t +(standard-case #t) ==> #t +(standard-case #t) ==> #t +(#string> flying-fish) ==> "flying-fish" +(#string> martin) ==> "martin" +(#string> Malvina) ==> "Malvina" +(standard-case #t) ==> #t +(string-set! "cb") ==> "cb" +(#string> ab) ==> "ab" +(#symbol> "ab") ==> ab +(# mississippi mississippi) ==> #t +(string->symbol #f) ==> #f +(#symbol> "jollywog") ==> jollywog +SECTION(6 5 5) +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #t +(# 3) ==> #f +(# 22 22 22) ==> #t +(# 22 22) ==> #t +(# 34 34 35) ==> #f +(# 34 35) ==> #f +(#> 3 -6246) ==> #t +(#> 9 9 -2424) ==> #f +(#=> 3 -4 -6246) ==> #t +(#=> 9 9) ==> #t +(#=> 8 9) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #f +(# -1 2 3 4 5 6 7 8) ==> #t +(# -1 2 3 4 4 5 6 7) ==> #t +(# 1 3 2) ==> #f +(#=> 1 3 2) ==> #f +(# 0) ==> #t +(# 1) ==> #f +(# -1) ==> #f +(# -100) ==> #f +(# 4) ==> #t +(# -4) ==> #f +(# 0) ==> #f +(# 4) ==> #f +(# -4) ==> #t +(# 0) ==> #f +(# 3) ==> #t +(# 2) ==> #f +(# -4) ==> #f +(# -1) ==> #t +(# 3) ==> #f +(# 2) ==> #t +(# -4) ==> #t +(# -1) ==> #f +(# 34 5 7 38 6) ==> 38 +(# 3 5 5 330 4 -24) ==> -24 +(# 3 4) ==> 7 +(# 3) ==> 3 +(#) ==> 0 +(# 4) ==> 4 +(#) ==> 1 +(# 3 4) ==> -1 +(# 3) ==> -3 +(# -7) ==> 7 +(# 7) ==> 7 +(# 0) ==> 0 +(# 35 7) ==> 5 +(# -35 7) ==> -5 +(# 35 -7) ==> -5 +(# -35 -7) ==> 5 +(# 13 4) ==> 1 +(# 13 4) ==> 1 +(# -13 4) ==> 3 +(# -13 4) ==> -1 +(# 13 -4) ==> -3 +(# 13 -4) ==> 1 +(# -13 -4) ==> -1 +(# -13 -4) ==> -1 +(# 0 86400) ==> 0 +(# 0 -86400) ==> 0 +(# 238 9) ==> #t +(# -238 9) ==> #t +(# 238 -9) ==> #t +(# -238 -9) ==> #t +(# 0 4) ==> 4 +(# -4 0) ==> 4 +(# 32 -36) ==> 4 +(#) ==> 0 +(# 32 -36) ==> 288 +(#) ==> 1 +SECTION(6 5 9) +(#string> 0) ==> "0" +(#string> 100) ==> "100" +(#string> 256 16) ==> "100" +(#number> "100") ==> 100 +(#number> "100" 16) ==> 256 +(#number> "") ==> #f +(#number> ".") ==> #f +(#number> "d") ==> #f +(#number> "D") ==> #f +(#number> "i") ==> #f +(#number> "I") ==> #f +(#number> "3i") ==> #f +(#number> "3I") ==> #f +(#number> "33i") ==> #f +(#number> "33I") ==> #f +(#number> "3.3i") ==> #f +(#number> "3.3I") ==> #f +(#number> "-") ==> #f +(#number> "+") ==> #f +SECTION(6 6) +(# #\ #\ ) ==> #t +(# #\ #\ ) ==> #t +(# #\a) ==> #t +(# #\() ==> #t +(# #\ ) ==> #t +(# #\ +) ==> #t +(# #\A #\B) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(# #\A #\B) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(# #\A #\B) ==> #f +(# #\a #\B) ==> #f +(# #\A #\b) ==> #f +(# #\a #\b) ==> #f +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #f +(# #\A #\a) ==> #f +(#?> #\A #\B) ==> #f +(#?> #\a #\B) ==> #f +(#?> #\A #\b) ==> #f +(#?> #\a #\b) ==> #f +(#?> #\9 #\0) ==> #t +(#?> #\A #\A) ==> #f +(#?> #\A #\a) ==> #f +(# #\A #\B) ==> #t +(# #\a #\B) ==> #t +(# #\A #\b) ==> #t +(# #\a #\b) ==> #t +(# #\9 #\0) ==> #f +(# #\A #\A) ==> #t +(# #\A #\a) ==> #t +(#=?> #\A #\B) ==> #f +(#=?> #\a #\B) ==> #f +(#=?> #\A #\b) ==> #f +(#=?> #\a #\b) ==> #f +(#=?> #\9 #\0) ==> #t +(#=?> #\A #\A) ==> #t +(#=?> #\A #\a) ==> #t +(# #\a) ==> #t +(# #\A) ==> #t +(# #\z) ==> #t +(# #\Z) ==> #t +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #t +(# #\9) ==> #t +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\a) ==> #f +(# #\A) ==> #f +(# #\z) ==> #f +(# #\Z) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #t +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(# #\0) ==> #f +(# #\9) ==> #f +(# #\ ) ==> #f +(# #\;) ==> #f +(#char> 46) ==> #\. +(#char> 65) ==> #\A +(#char> 97) ==> #\a +(# #\A) ==> #\A +(# #\a) ==> #\A +(# #\A) ==> #\a +(# #\a) ==> #\a +SECTION(6 7) +(# "The word \"recursion\\\" has many meanings.") ==> #t +(string-set! "?**") ==> "?**" +(# #\a #\b #\c) ==> "abc" +(#) ==> "" +(# "abc") ==> 3 +(# "abc" 0) ==> #\a +(# "abc" 2) ==> #\c +(# "") ==> 0 +(# "ab" 0 0) ==> "" +(# "ab" 1 1) ==> "" +(# "ab" 2 2) ==> "" +(# "ab" 0 1) ==> "a" +(# "ab" 1 2) ==> "b" +(# "ab" 0 2) ==> "ab" +(# "foo" "bar") ==> "foobar" +(# "foo") ==> "foo" +(# "foo" "") ==> "foo" +(# "" "foo") ==> "foo" +(#) ==> "" +(# 0) ==> "" +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "" "") ==> #t +(# "" "") ==> #f +(#?> "" "") ==> #f +(# "" "") ==> #t +(#=?> "" "") ==> #t +(# "A" "B") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(# "A" "B") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(# "A" "B") ==> #f +(# "a" "B") ==> #f +(# "A" "b") ==> #f +(# "a" "b") ==> #f +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #f +(# "A" "a") ==> #f +(#?> "A" "B") ==> #f +(#?> "a" "B") ==> #f +(#?> "A" "b") ==> #f +(#?> "a" "b") ==> #f +(#?> "9" "0") ==> #t +(#?> "A" "A") ==> #f +(#?> "A" "a") ==> #f +(# "A" "B") ==> #t +(# "a" "B") ==> #t +(# "A" "b") ==> #t +(# "a" "b") ==> #t +(# "9" "0") ==> #f +(# "A" "A") ==> #t +(# "A" "a") ==> #t +(#=?> "A" "B") ==> #f +(#=?> "a" "B") ==> #f +(#=?> "A" "b") ==> #f +(#=?> "a" "b") ==> #f +(#=?> "9" "0") ==> #t +(#=?> "A" "A") ==> #t +(#=?> "A" "a") ==> #t +SECTION(6 8) +(# #(0 (2 2 2 2) "Anna")) ==> #t +(# a b c) ==> #(a b c) +(#) ==> #() +(# #(0 (2 2 2 2) "Anna")) ==> 3 +(# #()) ==> 0 +(# #(1 1 2 3 5 8 13 21) 5) ==> 8 +(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna") +(# 2 hi) ==> #(hi hi) +(# 0) ==> #() +(# 0 a) ==> #() +SECTION(6 9) +(# #) ==> #t +(# #) ==> #t +(# (lambda (x) (* x x))) ==> #f +(# #) ==> #t +(# # (3 4)) ==> 7 +(# # (3 4)) ==> 7 +(# # 10 (3 4)) ==> 17 +(# # ()) ==> () +(# 12 75) ==> 30 +(# # ((a b) (d e) (g h))) ==> (b e h) +(# # (1 2 3) (4 5 6)) ==> (5 7 9) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (1 2 3) +(# # (1 2 3)) ==> (-1 -2 -3) +(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16) +(# #) ==> -3 +(# (1 2 3 4)) ==> 4 +(# (a b . c)) ==> #f +(# # ()) ==> () +SECTION(6 10 1) +(# #) ==> #t +(# #) ==> #t +(# "r4rstest.scm" #) ==> #t +(# #) ==> #t +SECTION(6 10 2) +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (define cur-section (quote ())) +(# #) ==> #\( +(# #) ==> (define errs (quote ())) +SECTION(6 10 3) +(# "tmp1" #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)) +(# #) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))) + + +Passed all tests + +;testing inexact numbers; +SECTION(6 5 5) +(# 3.9) ==> #t +(inexact? #t) ==> #t +(max 4.) ==> 4. +(exact->inexact 4.) ==> 4. +(# -4.5) ==> -4. +(# -3.5) ==> -4. +(# -3.9) ==> -4. +(# 0.) ==> 0. +(# 0.25) ==> 0. +(# 0.8) ==> 1. +(# 3.5) ==> 4. +(# 4.5) ==> 4. +(# 0 0) ==> 1 +(# 0 1) ==> 0 +(# "tmp3" #) ==> #t +(# #) ==> (define foo (quote (0.25 -3.25))) +(# #) ==> #t +(# #) ==> #t +(input-port? #t) ==> #t +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> #\; +(# #) ==> (0.25 -3.25) +(# #) ==> (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) +(#list> "P l") ==> (#\P #\ #\l) +(#list> "") ==> () +(#string> (#\1 #\\ #\")) ==> "1\\\"" +(#string> ()) ==> "" +SECTION(6 8) +(#list> #(dah dah didah)) ==> (dah dah didah) +(#list> #()) ==> () +(#vector> (dididit dah)) ==> #(dididit dah) +(#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 +(# #>) ==> 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) +(# (a (b (c))) ((a) b c)) ==> #t +(# (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))) + diff --git a/vx-scheme/testcases/w32-good/scheme.good b/vx-scheme/testcases/w32-good/scheme.good new file mode 100644 index 0000000..b8a4c53 --- /dev/null +++ b/vx-scheme/testcases/w32-good/scheme.good @@ -0,0 +1 @@ +("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") \ No newline at end of file diff --git a/vx-scheme/testcases/w32-good/series.good b/vx-scheme/testcases/w32-good/series.good new file mode 100644 index 0000000..117c916 --- /dev/null +++ b/vx-scheme/testcases/w32-good/series.good @@ -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.1421052631579 +3.141599357319 +3.14159271403378 +3.14159265397529 +3.14159265359118 +3.14159265358978 +3.1415926535898 +3.14159265358979 diff --git a/vx-scheme/testcases/w32-good/sieve.good b/vx-scheme/testcases/w32-good/sieve.good new file mode 100755 index 0000000..b6bb9c8 --- /dev/null +++ b/vx-scheme/testcases/w32-good/sieve.good @@ -0,0 +1 @@ +1993 diff --git a/vx-scheme/tornado/target-shell/linkSyms.c b/vx-scheme/tornado/target-shell/linkSyms.c new file mode 100755 index 0000000..12651f2 --- /dev/null +++ b/vx-scheme/tornado/target-shell/linkSyms.c @@ -0,0 +1,299 @@ +/* linkSyms.c - dynamically generated configuration file */ + + +/* +GENERATED: Sun Dec 15 00:17:51 Pacific Daylight Time 2002 +DO NOT EDIT - file is regenerated whenever the project changes +*/ + +typedef int (*FUNC) (); +extern int __assert (); +extern int abort (); +extern int abs (); +extern int acos (); +extern int asctime (); +extern int asin (); +extern int atan (); +extern int atan2 (); +extern int atexit (); +extern int atof (); +extern int atoi (); +extern int atol (); +extern int bsearch (); +extern int bufPoolInit (); +extern int calloc (); +extern int ceil (); +extern int clearerr (); +extern int clock (); +extern int clockLibInit (); +extern int cos (); +extern int cosh (); +extern int ctime (); +extern int difftime (); +extern int div (); +extern int dllInit (); +extern int exit (); +extern int exp (); +extern int fabs (); +extern int fclose (); +extern int fdopen (); +extern int feof (); +extern int ferror (); +extern int fflush (); +extern int fgetc (); +extern int fgetpos (); +extern int fgets (); +extern int fileno (); +extern int floor (); +extern int fmod (); +extern int fopen (); +extern int fprintf (); +extern int fputc (); +extern int fputs (); +extern int fread (); +extern int free (); +extern int freopen (); +extern int frexp (); +extern int fscanf (); +extern int fseek (); +extern int fsetpos (); +extern int ftell (); +extern int fwrite (); +extern int getc (); +extern int getchar (); +extern int getenv (); +extern int gets (); +extern int getw (); +extern int gmtime (); +extern int ioHelp (); +extern int isalnum (); +extern int isalpha (); +extern int iscntrl (); +extern int isdigit (); +extern int isgraph (); +extern int islower (); +extern int isprint (); +extern int ispunct (); +extern int isspace (); +extern int isupper (); +extern int isxdigit (); +extern int labs (); +extern int ldexp (); +extern int ldiv (); +extern int localeconv (); +extern int localtime (); +extern int log (); +extern int log10 (); +extern int lstInit (); +extern int malloc (); +extern int mblen (); +extern int memchr (); +extern int memcmp (); +extern int memcpy (); +extern int memmove (); +extern int memset (); +extern int mktime (); +extern int modf (); +extern int perror (); +extern int pow (); +extern int printf (); +extern int putc (); +extern int putchar (); +extern int puts (); +extern int putw (); +extern int qsort (); +extern int rand (); +extern int realloc (); +extern int rewind (); +extern int rngCreate (); +extern int scanf (); +extern int setbuf (); +extern int setbuffer (); +extern int setlocale (); +extern int setvbuf (); +extern int sin (); +extern int sinh (); +extern int sqrt (); +extern int strcat (); +extern int strchr (); +extern int strcmp (); +extern int strcoll (); +extern int strcpy (); +extern int strcspn (); +extern int strerror (); +extern int strftime (); +extern int strlen (); +extern int strncat (); +extern int strncmp (); +extern int strncpy (); +extern int strpbrk (); +extern int strrchr (); +extern int strspn (); +extern int strstr (); +extern int strtod (); +extern int strtok (); +extern int strtok_r (); +extern int strtol (); +extern int strtoul (); +extern int strxfrm (); +extern int system (); +extern int tan (); +extern int tanh (); +extern int taskVarInit (); +extern int time (); +extern int tmpfile (); +extern int tmpnam (); +extern int tolower (); +extern int toupper (); +extern int ungetc (); +extern int vfprintf (); + +FUNC linkSyms [] = { + __assert, + abort, + abs, + acos, + asctime, + asin, + atan, + atan2, + atexit, + atof, + atoi, + atol, + bsearch, + bufPoolInit, + calloc, + ceil, + clearerr, + clock, + clockLibInit, + cos, + cosh, + ctime, + difftime, + div, + dllInit, + exit, + exp, + fabs, + fclose, + fdopen, + feof, + ferror, + fflush, + fgetc, + fgetpos, + fgets, + fileno, + floor, + fmod, + fopen, + fprintf, + fputc, + fputs, + fread, + free, + freopen, + frexp, + fscanf, + fseek, + fsetpos, + ftell, + fwrite, + getc, + getchar, + getenv, + gets, + getw, + gmtime, + ioHelp, + isalnum, + isalpha, + iscntrl, + isdigit, + isgraph, + islower, + isprint, + ispunct, + isspace, + isupper, + isxdigit, + labs, + ldexp, + ldiv, + localeconv, + localtime, + log, + log10, + lstInit, + malloc, + mblen, + memchr, + memcmp, + memcpy, + memmove, + memset, + mktime, + modf, + perror, + pow, + printf, + putc, + putchar, + puts, + putw, + qsort, + rand, + realloc, + rewind, + rngCreate, + scanf, + setbuf, + setbuffer, + setlocale, + setvbuf, + sin, + sinh, + sqrt, + strcat, + strchr, + strcmp, + strcoll, + strcpy, + strcspn, + strerror, + strftime, + strlen, + strncat, + strncmp, + strncpy, + strpbrk, + strrchr, + strspn, + strstr, + strtod, + strtok, + strtok_r, + strtol, + strtoul, + strxfrm, + system, + tan, + tanh, + taskVarInit, + time, + tmpfile, + tmpnam, + tolower, + toupper, + ungetc, + vfprintf, + 0 +}; + + +int * linkDataSyms [] = { + 0 +}; + diff --git a/vx-scheme/tornado/target-shell/prjComps.h b/vx-scheme/tornado/target-shell/prjComps.h new file mode 100755 index 0000000..d9cd324 --- /dev/null +++ b/vx-scheme/tornado/target-shell/prjComps.h @@ -0,0 +1,123 @@ +/* prjComps.h - dynamically generated configuration header */ + + +/* +GENERATED: Sun Dec 15 00:17:51 Pacific Daylight Time 2002 +DO NOT EDIT - file is regenerated whenever the project changes +*/ + +#ifndef INCprjCompsh +#define INCprjCompsh + +/*** INCLUDED COMPONENTS ***/ + +#define INCLUDE_ANSI_ASSERT +#define INCLUDE_ANSI_CTYPE +#define INCLUDE_ANSI_LOCALE +#define INCLUDE_ANSI_MATH +#define INCLUDE_ANSI_STDIO +#define INCLUDE_ANSI_STDIO_EXTRA +#define INCLUDE_ANSI_STDLIB +#define INCLUDE_ANSI_STRING +#define INCLUDE_ANSI_TIME +#define INCLUDE_BUF_MGR +#define INCLUDE_CACHE_ENABLE +#define INCLUDE_CACHE_SUPPORT +#define INCLUDE_CPLUS +#define INCLUDE_CPLUS_DEMANGLER +#define INCLUDE_CPLUS_IOSTREAMS +#define INCLUDE_CPLUS_IOSTREAMS_FULL +#define INCLUDE_CPLUS_LANG +#define INCLUDE_CPLUS_STL +#define INCLUDE_CPLUS_STRING +#define INCLUDE_CPLUS_STRING_IO +#define INCLUDE_CTORS_DTORS +#define INCLUDE_DEBUG +#define INCLUDE_DISK_UTIL +#define INCLUDE_DLL +#define INCLUDE_ENV_VARS +#define INCLUDE_EXC_HANDLING +#define INCLUDE_EXC_SHOW +#define INCLUDE_EXC_TASK +#define INCLUDE_FLOATING_POINT +#define INCLUDE_FORMATTED_IO +#define INCLUDE_GNU_INTRINSICS +#define INCLUDE_HASH +#define INCLUDE_HW_FP +#define INCLUDE_HW_FP_SHOW +#define INCLUDE_IO_SYSTEM +#define INCLUDE_KERNEL +#define INCLUDE_LOADER +#define INCLUDE_LOGGING +#define INCLUDE_LSTLIB +#define INCLUDE_MEMORY_CONFIG +#define INCLUDE_MEM_MGR_BASIC +#define INCLUDE_MEM_MGR_FULL +#define INCLUDE_MEM_SHOW +#define INCLUDE_MODULE_MANAGER +#define INCLUDE_MSG_Q +#define INCLUDE_MSG_Q_SHOW +#define INCLUDE_NTPASSFS +#define INCLUDE_PIPES +#define INCLUDE_POSIX_CLOCKS +#define INCLUDE_RBUFF +#define INCLUDE_RNG_BUF +#define INCLUDE_SELECT +#define INCLUDE_SELECT_SUPPORT +#define INCLUDE_SEM_BINARY +#define INCLUDE_SEM_COUNTING +#define INCLUDE_SEM_MUTEX +#define INCLUDE_SEQ_TIMESTAMP +#define INCLUDE_SHELL +#define INCLUDE_SHELL_BANNER +#define INCLUDE_SIGNALS +#define INCLUDE_SIO +#define INCLUDE_STANDALONE_SYM_TBL +#define INCLUDE_STARTUP_SCRIPT +#define INCLUDE_STDIO +#define INCLUDE_SYM_TBL +#define INCLUDE_SYM_TBL_INIT +#define INCLUDE_SYM_TBL_SHOW +#define INCLUDE_SYSCLK_INIT +#define INCLUDE_SYSHW_INIT +#define INCLUDE_SYS_START +#define INCLUDE_TASK_HOOKS +#define INCLUDE_TASK_SHOW +#define INCLUDE_TASK_VARS +#define INCLUDE_TIMEX +#define INCLUDE_TRIGGERING +#define INCLUDE_TTY_DEV +#define INCLUDE_USER_APPL +#define INCLUDE_VXEVENTS +#define INCLUDE_WATCHDOGS +#define INCLUDE_WDB +#define INCLUDE_WDB_BANNER +#define INCLUDE_WDB_BP +#define INCLUDE_WDB_COMM_PIPE +#define INCLUDE_WDB_CTXT +#define INCLUDE_WDB_DIRECT_CALL +#define INCLUDE_WDB_EVENTPOINTS +#define INCLUDE_WDB_EVENTS +#define INCLUDE_WDB_EXC_NOTIFY +#define INCLUDE_WDB_EXIT_NOTIFY +#define INCLUDE_WDB_FUNC_CALL +#define INCLUDE_WDB_GOPHER +#define INCLUDE_WDB_HW_FP +#define INCLUDE_WDB_MEM +#define INCLUDE_WDB_REG +#define INCLUDE_WDB_START_NOTIFY +#define INCLUDE_WDB_SYS +#define INCLUDE_WDB_SYS_HW_FP +#define INCLUDE_WDB_TASK +#define INCLUDE_WDB_TASK_BP +#define INCLUDE_WDB_TASK_HW_FP +#define INCLUDE_WDB_TSFS +#define INCLUDE_WDB_USER_EVENT +#define INCLUDE_WDB_VIO +#define INCLUDE_WDB_VIO_LIB +#define INCLUDE_WINDVIEW +#define INCLUDE_WINDVIEW_CLASS +#define INCLUDE_WVUPLOAD_FILE +#define INCLUDE_WVUPLOAD_TSFSSOCK + +#endif /* INCprjCompsh */ diff --git a/vx-scheme/tornado/target-shell/prjConfig.c b/vx-scheme/tornado/target-shell/prjConfig.c new file mode 100755 index 0000000..d852573 --- /dev/null +++ b/vx-scheme/tornado/target-shell/prjConfig.c @@ -0,0 +1,345 @@ +/* prjConfig.c - dynamicaly generated configuration file */ + + +/* +GENERATED: Sun Dec 15 00:17:51 Pacific Daylight Time 2002 +DO NOT EDIT - file is regenerated whenever the project changes. +This file contains the non-BSP system initialization code +for Create a bootable VxWorks image (custom configured). +*/ + + +/* includes */ + +#include "vxWorks.h" +#include "config.h" +#include "bufLib.h" +#include "cacheLib.h" +#include "cplusLib.h" +#include "dbgLib.h" +#include "drv/wdb/wdbPipePktDrv.h" +#include "drv/wdb/wdbVioDrv.h" +#include "envLib.h" +#include "eventLib.h" +#include "excLib.h" +#include "fioLib.h" +#include "fppLib.h" +#include "hashLib.h" +#include "intLib.h" +#include "ioLib.h" +#include "iosLib.h" +#include "loadPecoffLib.h" +#include "logLib.h" +#include "lstLib.h" +#include "math.h" +#include "memLib.h" +#include "moduleLib.h" +#include "msgQLib.h" +#include "pipeDrv.h" +#include "private/cplusLibP.h" +#include "private/funcBindP.h" +#include "private/kernelLibP.h" +#include "private/seqDrvP.h" +#include "private/taskLibP.h" +#include "private/trgLibP.h" +#include "private/vmLibP.h" +#include "private/workQLibP.h" +#include "private/wvFileUploadPathLibP.h" +#include "private/wvTsfsUploadPathLibP.h" +#include "private/wvUploadPathP.h" +#include "qPriBMapLib.h" +#include "rBuffLib.h" +#include "rebootLib.h" +#include "selectLib.h" +#include "semLib.h" +#include "shellLib.h" +#include "sigLib.h" +#include "sioLib.h" +#include "stdio.h" +#include "string.h" +#include "symLib.h" +#include "sysLib.h" +#include "sysSymTbl.h" +#include "taskHookLib.h" +#include "taskLib.h" +#include "taskVarLib.h" +#include "tickLib.h" +#include "timexLib.h" +#include "trgLib.h" +#include "ttyLib.h" +#include "usrConfig.h" +#include "usrLib.h" +#include "version.h" +#include "vxLib.h" +#include "wdLib.h" +#include "wdb/wdb.h" +#include "wdb/wdbBpLib.h" +#include "wdb/wdbCommIfLib.h" +#include "wdb/wdbLib.h" +#include "wdb/wdbLibP.h" +#include "wdb/wdbMbufLib.h" +#include "wdb/wdbRegs.h" +#include "wdb/wdbRpcLib.h" +#include "wdb/wdbRtIfLib.h" +#include "wdb/wdbSvcLib.h" +#include "wdb/wdbUdpLib.h" +#include "wdb/wdbVioLib.h" +#include "wvLib.h" +#include "wvTmrLib.h" + + +/* imports */ + +IMPORT char etext []; /* defined by loader */ +IMPORT char end []; /* defined by loader */ +IMPORT char edata []; /* defined by loader */ + + +/* BSP_STUBS */ + + + +/* configlettes */ + +#include "sysComms.c" +#include "cplusgnuIos.c" +#include "cplusgnuLang.c" +#include "cplusgnuStl.c" +#include "cplusgnuString.c" +#include "cplusgnuStringIo.c" +#include "intrinsics.c" +#include "sysClkInit.c" +#include "usrBanner.c" +#include "usrBreakpoint.c" +#include "usrCache.c" +#include "usrCplus.c" +#include "usrKernel.c" +#include "usrNtPassFs.c" +#include "usrScript.c" +#include "usrSerial.c" +#include "usrStandalone.c" +#include "usrStartup.c" +#include "usrWdbBanner.c" +#include "usrWdbBp.c" +#include "usrWdbCore.c" +#include "usrWdbFpp.c" +#include "usrWdbSys.c" +#include "usrWdbSysFpp.c" +#include "usrWdbTask.c" +#include "usrWdbTaskFpp.c" +#include "usrWindview.c" +#include "usrWvFileUploadPath.c" +#include "usrWvTsfsUploadPath.c" +#include "wdbPipe.c" + + +/****************************************************************************** +* +* usrInit - pre-kernel initialization +*/ + +void usrInit (int startType) + { + sysStart (startType); /* clear BSS and set up the vector table base address. */ + cacheLibInit (USER_I_CACHE_MODE, USER_D_CACHE_MODE); /* include cache support */ + excVecInit (); /* exception handling */ + sysHwInit (); /* call the BSPs sysHwInit routine during system startup */ + usrCacheEnable (); /* optionally enable caches */ + wvLibInit (); /* low-level kernel instrumentation needed by windview */ + usrKernelInit (); /* context switch and interrupt handling. DO NOT REMOVE. */ + } + + + +/****************************************************************************** +* +* usrWdbInit - the WDB target agent +*/ + +void usrWdbInit (void) + { + wdbConfig (); /* software agent to support the tornado tools */ + wdbMemLibInit (); /* read/write target memory */ + wdbSysModeInit (); /* A breakpoint stops the entire operating system. */ + wdbTaskModeInit (); /* A breakpoint stops one task, while others keep running. */ + wdbEventLibInit (); /* asynchronous event handling needed for breakpoints etc. */ + wdbEvtptLibInit (); /* support library for breakpoints and other asynchonous events. */ + wdbDirectCallLibInit (); /* call arbitrary functions directly from WDB */ + wdbCtxLibInit (); /* create/delete/manipulate tasks */ + wdbRegsLibInit (); /* get/set registers */ + wdbGopherLibInit (); /* information gathering language used by many tools */ + wdbCtxExitLibInit (); /* ability to notify the host when a task exits */ + wdbExcLibInit (); /* notify the host when an exception occurs */ + wdbFuncCallLibInit (); /* asynchronous function calls */ + wdbVioLibInit (); /* low-level virtual I/O handling */ + wdbVioDrv ("/vio"); /* vxWorks driver for accessing virtual I/O */ + usrWdbBp (); /* core breakpoint library */ + wdbTaskBpLibInit (); /* task-mode breakpoint library */ + wdbCtxStartLibInit (); /* ability to notify the host when a task starts */ + wdbUserEvtLibInit (); /* ability to send user events to the host */ + wdbFppInit (); /* WDB hardware fpp support */ + wdbTaskFppInit (); /* task mode fpp debug support */ + wdbSysFppInit (); /* system mode mode fpp debug support */ + usrWdbBanner (); /* print banner to console after the agent is initialized */ + } + + + +/****************************************************************************** +* +* usrShellInit - the target shell +*/ + +void usrShellInit (void) + { + dbgInit (); /* breakpoints and stack tracer on target. Not needed for remote debugging with tornado. */ + usrBanner (); /* display the WRS banner on startup */ + usrStartupScript (sysBootParams.startupScript); /* shell startup script */ + shellInit (SHELL_STACK_SIZE, TRUE); /* target shell */ + } + + + +/****************************************************************************** +* +* usrWindviewInit - +*/ + +void usrWindviewInit (void) + { + windviewConfig (); /* initialize and control event logging */ + wvTmrRegister ((UINTFUNCPTR) seqStamp, (UINTFUNCPTR) seqStampLock, (FUNCPTR) seqEnable, (FUNCPTR) seqDisable, (FUNCPTR) seqConnect, (UINTFUNCPTR) seqPeriod, (UINTFUNCPTR) seqFreq); /* no timestamping */ + rBuffLibInit (); /* windview 2.0 ring of buffers for event logging */ + wdbTsfsDrv ("/tgtsvr"); /* virtual file system based on the WDB agent */ + usrWvTsfsUploadPathInit (); /* initialize path for the upload through TSFS socket */ + usrWvFileUploadPathInit (); /* initialize path for the upload to file */ + } + + + +/****************************************************************************** +* +* usrShowInit - enable object show routines +*/ + +void usrShowInit (void) + { + taskShowInit (); /* task show routine */ + memShowInit (); /* memory show routine */ + msgQShowInit (); /* message queue show routine */ + symShowInit (); /* symbol table show routine */ + fppShowInit (); /* task floating point registers */ + } + + + +/****************************************************************************** +* +* usrToolsInit - software development tools +*/ + +void usrToolsInit (void) + { + timexInit (); /* utility to measure function execution time */ + moduleLibInit (); /* support library for the target-based loader. */ + loadPecoffInit (); /* PECOFF loader */ + usrStandaloneInit (); /* prefered method if not booting from the network. */ + trgInit (); /* triggering for system and user events */ + usrWdbInit (); /* the WDB target agent */ + usrShellInit (); /* the target shell */ + usrWindviewInit (); /* usrWindviewInit */ + usrShowInit (); /* enable object show routines */ + } + + + +/****************************************************************************** +* +* usrKernelCoreInit - core kernel facilities +*/ + +void usrKernelCoreInit (void) + { + eventLibInit (); /* VxWorks events */ + semBLibInit (); /* binary semaphores */ + semMLibInit (); /* mutex semaphores */ + semCLibInit (); /* counting semaphores */ + msgQLibInit (); /* message queues */ + wdLibInit (); /* watchdog timers */ + taskHookInit (); /* user callouts on task creation/deletion/context switch */ + } + + + +/****************************************************************************** +* +* usrKernelExtraInit - extended kernel facilities +*/ + +void usrKernelExtraInit (void) + { + hashLibInit (); /* hash library */ + symLibInit (); /* symbol table */ + envLibInit (ENV_VAR_USE_HOOKS); /* environment variables */ + sigInit (); /* signals */ + } + + + +/****************************************************************************** +* +* usrIosCoreInit - core I/O system +*/ + +void usrIosCoreInit (void) + { + mathHardInit (); /* hardware fpp support */ + iosInit (NUM_DRIVERS, NUM_FILES, "/null"); /* IO system */ + ttyDrv (); /* terminal driver */ + usrSerialInit (); /* SIO component */ + } + + + +/****************************************************************************** +* +* usrIosExtraInit - extended I/O system +*/ + +void usrIosExtraInit (void) + { + excShowInit (); /* exception show routines */ + excInit (); /* miscellaneous support task */ + logInit (consoleFd, MAX_LOG_MSGS); /* message logging */ + pipeDrv (); /* pipes */ + stdioInit (); /* buffered IO library */ + fioLibInit (); /* formatting for printf, scanf, etc. */ + floatInit (); /* allow printf and others to format floats correctly */ + usrNtPassFsInit (); /* direct access to host filesystem */ + } + + + +/****************************************************************************** +* +* usrRoot - entry point for post-kernel initialization +*/ + +void usrRoot (char *pMemPoolStart, unsigned memPoolSize) + { + usrKernelCoreInit (); /* core kernel facilities */ + memInit (pMemPoolStart, memPoolSize); /* full featured memory allocator */ + memPartLibInit (pMemPoolStart, memPoolSize); /* core memory partition manager */ + sysClkInit (); /* System clock component */ + selectInit (NUM_FILES); /* select */ + usrIosCoreInit (); /* core I/O system */ + usrKernelExtraInit (); /* extended kernel facilities */ + usrIosExtraInit (); /* extended I/O system */ + selTaskDeleteHookAdd (); /* install select task delete hook */ + usrToolsInit (); /* software development tools */ + cplusCtorsLink (); /* run compiler generated initialization functions at system startup */ + usrCplusLibInit (); /* Basic support for C++ applications */ + cplusDemanglerInit (); /* support library for target shell and loader: provides human readable forms of C++ identifiers */ + usrAppInit (); /* call usrAppInit() (in your usrAppInit.c project file) after startup. */ + } + diff --git a/vx-scheme/tornado/target-shell/prjObjs.lst b/vx-scheme/tornado/target-shell/prjObjs.lst new file mode 100755 index 0000000..fffabb2 --- /dev/null +++ b/vx-scheme/tornado/target-shell/prjObjs.lst @@ -0,0 +1,4 @@ +sysLib.o +usrAppInit.o +prjConfig.o +linkSyms.o diff --git a/vx-scheme/tornado/target-shell/prjParams.h b/vx-scheme/tornado/target-shell/prjParams.h new file mode 100755 index 0000000..b0ec3c6 --- /dev/null +++ b/vx-scheme/tornado/target-shell/prjParams.h @@ -0,0 +1,485 @@ +/* prjParams.h - dynamically generated configuration header */ + + +/* +GENERATED: Sun Dec 15 00:17:51 Pacific Daylight Time 2002 +DO NOT EDIT - file is regenerated whenever the project changes +*/ + +#ifndef INCprjParamsh +#define INCprjParamsh + + +/*** INCLUDED COMPONENTS ***/ + +#define INCLUDE_ANSI_ASSERT +#define INCLUDE_ANSI_CTYPE +#define INCLUDE_ANSI_LOCALE +#define INCLUDE_ANSI_MATH +#define INCLUDE_ANSI_STDIO +#define INCLUDE_ANSI_STDIO_EXTRA +#define INCLUDE_ANSI_STDLIB +#define INCLUDE_ANSI_STRING +#define INCLUDE_ANSI_TIME +#define INCLUDE_BUF_MGR +#define INCLUDE_CACHE_ENABLE +#define INCLUDE_CACHE_SUPPORT +#define INCLUDE_CPLUS +#define INCLUDE_CPLUS_DEMANGLER +#define INCLUDE_CPLUS_IOSTREAMS +#define INCLUDE_CPLUS_IOSTREAMS_FULL +#define INCLUDE_CPLUS_LANG +#define INCLUDE_CPLUS_STL +#define INCLUDE_CPLUS_STRING +#define INCLUDE_CPLUS_STRING_IO +#define INCLUDE_CTORS_DTORS +#define INCLUDE_DEBUG +#define INCLUDE_DISK_UTIL +#define INCLUDE_DLL +#define INCLUDE_ENV_VARS +#define INCLUDE_EXC_HANDLING +#define INCLUDE_EXC_SHOW +#define INCLUDE_EXC_TASK +#define INCLUDE_FLOATING_POINT +#define INCLUDE_FORMATTED_IO +#define INCLUDE_GNU_INTRINSICS +#define INCLUDE_HASH +#define INCLUDE_HW_FP +#define INCLUDE_HW_FP_SHOW +#define INCLUDE_IO_SYSTEM +#define INCLUDE_KERNEL +#define INCLUDE_LOADER +#define INCLUDE_LOGGING +#define INCLUDE_LSTLIB +#define INCLUDE_MEMORY_CONFIG +#define INCLUDE_MEM_MGR_BASIC +#define INCLUDE_MEM_MGR_FULL +#define INCLUDE_MEM_SHOW +#define INCLUDE_MODULE_MANAGER +#define INCLUDE_MSG_Q +#define INCLUDE_MSG_Q_SHOW +#define INCLUDE_NTPASSFS +#define INCLUDE_PIPES +#define INCLUDE_POSIX_CLOCKS +#define INCLUDE_RBUFF +#define INCLUDE_RNG_BUF +#define INCLUDE_SELECT +#define INCLUDE_SELECT_SUPPORT +#define INCLUDE_SEM_BINARY +#define INCLUDE_SEM_COUNTING +#define INCLUDE_SEM_MUTEX +#define INCLUDE_SEQ_TIMESTAMP +#define INCLUDE_SHELL +#define INCLUDE_SHELL_BANNER +#define INCLUDE_SIGNALS +#define INCLUDE_SIO +#define INCLUDE_STANDALONE_SYM_TBL +#define INCLUDE_STARTUP_SCRIPT +#define INCLUDE_STDIO +#define INCLUDE_SYM_TBL +#define INCLUDE_SYM_TBL_INIT +#define INCLUDE_SYM_TBL_SHOW +#define INCLUDE_SYSCLK_INIT +#define INCLUDE_SYSHW_INIT +#define INCLUDE_SYS_START +#define INCLUDE_TASK_HOOKS +#define INCLUDE_TASK_SHOW +#define INCLUDE_TASK_VARS +#define INCLUDE_TIMEX +#define INCLUDE_TRIGGERING +#define INCLUDE_TTY_DEV +#define INCLUDE_USER_APPL +#define INCLUDE_VXEVENTS +#define INCLUDE_WATCHDOGS +#define INCLUDE_WDB +#define INCLUDE_WDB_BANNER +#define INCLUDE_WDB_BP +#define INCLUDE_WDB_COMM_PIPE +#define INCLUDE_WDB_CTXT +#define INCLUDE_WDB_DIRECT_CALL +#define INCLUDE_WDB_EVENTPOINTS +#define INCLUDE_WDB_EVENTS +#define INCLUDE_WDB_EXC_NOTIFY +#define INCLUDE_WDB_EXIT_NOTIFY +#define INCLUDE_WDB_FUNC_CALL +#define INCLUDE_WDB_GOPHER +#define INCLUDE_WDB_HW_FP +#define INCLUDE_WDB_MEM +#define INCLUDE_WDB_REG +#define INCLUDE_WDB_START_NOTIFY +#define INCLUDE_WDB_SYS +#define INCLUDE_WDB_SYS_HW_FP +#define INCLUDE_WDB_TASK +#define INCLUDE_WDB_TASK_BP +#define INCLUDE_WDB_TASK_HW_FP +#define INCLUDE_WDB_TSFS +#define INCLUDE_WDB_USER_EVENT +#define INCLUDE_WDB_VIO +#define INCLUDE_WDB_VIO_LIB +#define INCLUDE_WINDVIEW +#define INCLUDE_WINDVIEW_CLASS +#define INCLUDE_WVUPLOAD_FILE +#define INCLUDE_WVUPLOAD_TSFSSOCK +#undef INCLUDE_PROTECT_TEXT +#undef INCLUDE_PROTECT_VEC_TABLE +#undef INCLUDE_PCI_PARAMS +#undef INCLUDE_VME_PARAMS +#undef INCLUDE_PCMCIA +#undef INCLUDE_SCSI +#undef INCLUDE_LPT +#undef INCLUDE_FD +#undef INCLUDE_DSP +#undef INCLUDE_IDE +#undef INCLUDE_ATA +#undef INCLUDE_AUX_CLK +#undef INCLUDE_TIMESTAMP +#undef INCLUDE_PC_CONSOLE +#undef INCLUDE_TFFS +#undef INCLUDE_TFFS_SHOW +#undef INCLUDE_MTD_AMD +#undef INCLUDE_MTD_I28F008 +#undef INCLUDE_MTD_I28F008BAJA +#undef INCLUDE_MTD_I28F016 +#undef INCLUDE_MTD_WAMDMTD +#undef INCLUDE_MTD_CFIAMD +#undef INCLUDE_MTD_CFISCS +#undef INCLUDE_TL_FTL +#undef INCLUDE_TL_SSFDC +#undef INCLUDE_MMU_FULL +#undef INCLUDE_MMU_BASIC +#undef INCLUDE_MMU_MPU +#undef INCLUDE_DOSFS +#undef INCLUDE_TYCODRV_5_2 +#undef INCLUDE_SW_FP +#undef INCLUDE_LOOPBACK +#undef INCLUDE_DC +#undef INCLUDE_EGL +#undef INCLUDE_EI +#undef INCLUDE_FEI +#undef INCLUDE_EX +#undef INCLUDE_ENP +#undef INCLUDE_IE +#undef INCLUDE_ILAC +#undef INCLUDE_LN +#undef INCLUDE_LNSGI +#undef INCLUDE_NIC +#undef INCLUDE_NIC_EVB +#undef INCLUDE_MED +#undef INCLUDE_ELC +#undef INCLUDE_ULTRA +#undef INCLUDE_EEX +#undef INCLUDE_ELT +#undef INCLUDE_QU +#undef INCLUDE_ENE +#undef INCLUDE_ESMC +#undef INCLUDE_SN +#undef INCLUDE_OLI +#undef INCLUDE_USR_ENTRIES +#undef INCLUDE_IF_USR +#undef INCLUDE_LNEBSA +#undef INCLUDE_FN +#undef INCLUDE_BSD +#undef INCLUDE_NETDEV_CONFIG +#undef INCLUDE_MUX +#undef INCLUDE_NET_SETUP +#undef INCLUDE_NETWORK +#undef INCLUDE_NETMASK_GET +#undef INCLUDE_NETDEV_NAMEGET +#undef INCLUDE_RPC +#undef INCLUDE_ZBUF_SOCK +#undef INCLUDE_BSD_BOOT +#undef INCLUDE_END +#undef INCLUDE_END_BOOT +#undef INCLUDE_PPP +#undef INCLUDE_PPP_BOOT +#undef INCLUDE_PPP_CRYPT +#undef INCLUDE_SLIP +#undef INCLUDE_SLIP_BOOT +#undef INCLUDE_RIP +#undef INCLUDE_ROUTE_SOCK +#undef INCLUDE_DNS_RESOLVER +#undef INCLUDE_DHCPC +#undef INCLUDE_DHCPR +#undef INCLUDE_DHCPS +#undef INCLUDE_SNTPC +#undef INCLUDE_SNTPS +#undef INCLUDE_PING +#undef INCLUDE_TELNET +#undef INCLUDE_RLOGIN +#undef INCLUDE_SECURITY +#undef INCLUDE_FTP_SERVER +#undef INCLUDE_FTPD_SECURITY +#undef INCLUDE_FTP +#undef INCLUDE_NFS +#undef INCLUDE_NFS_MOUNT_ALL +#undef INCLUDE_NFS_SERVER +#undef INCLUDE_TFTP_CLIENT +#undef INCLUDE_TFTP_SERVER +#undef INCLUDE_PROXY_CLIENT +#undef INCLUDE_PROXY_SERVER +#undef INCLUDE_IP +#undef INCLUDE_TCP +#undef INCLUDE_TCP_DEBUG +#undef INCLUDE_UDP +#undef INCLUDE_IP_FILTER +#undef INCLUDE_ICMP +#undef INCLUDE_IGMP +#undef INCLUDE_NET_LIB +#undef INCLUDE_BSD_SOCKET +#undef BSD43_COMPATIBLE +#undef INCLUDE_MCAST_ROUTING +#undef INCLUDE_ARP_API +#undef INCLUDE_HOST_TBL +#undef INCLUDE_SM_NET_ADDRGET +#undef INCLUDE_SECOND_SMNET +#undef INCLUDE_SM_NET +#undef INCLUDE_SM_SEQ_ADDR +#undef INCLUDE_PROXY_DEFAULT_ADDR +#undef INCLUDE_MIB2_ALL +#undef INCLUDE_MIB2_AT +#undef INCLUDE_MIB2_ICMP +#undef INCLUDE_MIB2_IF +#undef INCLUDE_MIB2_IP +#undef INCLUDE_MIB2_SYSTEM +#undef INCLUDE_MIB2_TCP +#undef INCLUDE_MIB2_UDP +#undef INCLUDE_SNMPD +#undef INCLUDE_DHCPC_SHOW +#undef INCLUDE_UDP_SHOW +#undef INCLUDE_TCP_SHOW +#undef INCLUDE_ICMP_SHOW +#undef INCLUDE_IGMP_SHOW +#undef INCLUDE_NET_SHOW +#undef INCLUDE_SM_NET_SHOW +#undef INCLUDE_DHCPC_LEASE_TEST +#undef INCLUDE_NET_INIT +#undef INCLUDE_DHCPC_LEASE_SAVE +#undef INCLUDE_DEFER_NET_INIT +#undef INCLUDE_BOOT_LINE_INIT +#undef INCLUDE_DHCPC_LEASE_GET +#undef INCLUDE_DHCPC_LEASE_CLEAN +#undef INCLUDE_SM_COMMON +#undef INCLUDE_NET_HOST_SETUP +#undef INCLUDE_NET_REM_IO +#undef INCLUDE_DIAB_INTRINSICS +#undef INCLUDE_NO_INTRINSICS +#undef INCLUDE_CPLUS_COMPLEX +#undef INCLUDE_CPLUS_COMPLEX_IO +#undef INCLUDE_POSIX_AIO +#undef INCLUDE_POSIX_AIO_SYSDRV +#undef INCLUDE_POSIX_FTRUNC +#undef INCLUDE_POSIX_MEM +#undef INCLUDE_POSIX_MQ +#undef INCLUDE_POSIX_PTHREADS +#undef INCLUDE_POSIX_SCHED +#undef INCLUDE_POSIX_SEM +#undef INCLUDE_POSIX_SIGNALS +#undef INCLUDE_POSIX_TIMERS +#undef INCLUDE_CLASS_SHOW +#undef INCLUDE_MMU_FULL_SHOW +#undef INCLUDE_POSIX_AIO_SHOW +#undef INCLUDE_POSIX_MQ_SHOW +#undef INCLUDE_POSIX_SEM_SHOW +#undef INCLUDE_SEM_SHOW +#undef INCLUDE_STDIO_SHOW +#undef INCLUDE_TASK_HOOKS_SHOW +#undef INCLUDE_WATCHDOGS_SHOW +#undef INCLUDE_TRIGGER_SHOW +#undef INCLUDE_RBUFF_SHOW +#undef INCLUDE_ATA_SHOW +#undef INCLUDE_PCI_CFGSHOW +#undef INCLUDE_DSP_SHOW +#undef INCLUDE_SPY +#undef INCLUDE_CODETEST +#undef INCLUDE_STAT_SYM_TBL +#undef INCLUDE_SYM_TBL_SYNC +#undef INCLUDE_NET_SYM_TBL +#undef INCLUDE_UNLOADER +#undef INCLUDE_WDB_DSP +#undef INCLUDE_WDB_TASK_DSP +#undef INCLUDE_WDB_SYS_DSP +#undef INCLUDE_WDB_COMM_SERIAL +#undef INCLUDE_WDB_COMM_TYCODRV_5_2 +#undef INCLUDE_WDB_COMM_NETWORK +#undef INCLUDE_WDB_COMM_NETROM +#undef INCLUDE_WDB_COMM_VTMD +#undef INCLUDE_WDB_COMM_END +#undef INCLUDE_WDB_COMM_CUSTOM +#undef INCLUDE_CDROMFS +#undef INCLUDE_RT11FS +#undef INCLUDE_RAWFS +#undef INCLUDE_RAMDRV +#undef INCLUDE_WVNET +#undef INCLUDE_WVUPLOAD_SOCK +#undef INCLUDE_SYS_TIMESTAMP +#undef INCLUDE_USER_TIMESTAMP +#undef INCLUDE_WV_BUFF_USER +#undef INCLUDE_BPF +#undef INCLUDE_SM_OBJ +#undef INCLUDE_VXFUSION_DIST_MSG_Q_SHOW +#undef INCLUDE_VXFUSION_GRP_MSG_Q_SHOW +#undef INCLUDE_VXFUSION_DIST_NAME_DB_SHOW +#undef INCLUDE_VXFUSION_IF_SHOW +#undef INCLUDE_VXFUSION +#undef INCLUDE_DOSFS_MAIN +#undef INCLUDE_DISK_CACHE +#undef INCLUDE_DISK_PART +#undef INCLUDE_DOSFS_FAT +#undef INCLUDE_DOSFS_FMT +#undef INCLUDE_DOSFS_CHKDSK +#undef INCLUDE_CBIO +#undef INCLUDE_TAR +#undef INCLUDE_DOSFS_DIR_VFAT +#undef INCLUDE_DOSFS_DIR_FIXED +#undef INCLUDE_RAM_DISK +#undef INCLUDE_USB +#undef INCLUDE_OHCI +#undef INCLUDE_UHCI +#undef INCLUDE_USB_TARG +#undef INCLUDE_KBD_EMULATOR +#undef INCLUDE_PRN_EMULATOR +#undef INCLUDE_D12_EMULATOR +#undef INCLUDE_USB_MOUSE +#undef INCLUDE_USB_KEYBOARD +#undef INCLUDE_USB_PRINTER +#undef INCLUDE_USB_SPEAKER +#undef INCLUDE_USB_PEGASUS_END +#undef INCLUDE_USB_MS_BULKONLY +#undef INCLUDE_USB_MS_CBI +#undef INCLUDE_USB_INIT +#undef INCLUDE_UHCI_INIT +#undef INCLUDE_OHCI_INIT +#undef INCLUDE_USBTOOL +#undef INCLUDE_USB_AUDIO_DEMO +#undef INCLUDE_USB_MOUSE_INIT +#undef INCLUDE_USB_KEYBOARD_INIT +#undef INCLUDE_USB_PRINTER_INIT +#undef INCLUDE_USB_SPEAKER_INIT +#undef INCLUDE_USB_MS_BULKONLY_INIT +#undef INCLUDE_USB_MS_CBI_INIT +#undef INCLUDE_USB_PEGASUS_END_INIT +#undef INCLUDE_DOS_DISK +#undef INCLUDE_COM_CORE +#undef INCLUDE_COM_SHOW +#undef INCLUDE_COM_NTP_TIME +#undef INCLUDE_COM +#undef INCLUDE_DCOM +#undef INCLUDE_DCOM_PROXY +#undef INCLUDE_DCOM_OPC +#undef INCLUDE_DCOM_SHOW + + +/*** PARAMETERS ***/ + +#undef LOCAL_MEM_LOCAL_ADRS +#define LOCAL_MEM_LOCAL_ADRS (simMemBlock) +#undef LOCAL_MEM_SIZE +#define LOCAL_MEM_SIZE (simMemSize) +#undef LOCAL_MEM_AUTOSIZE +#undef USER_RESERVED_MEM +#define USER_RESERVED_MEM 0 +#undef NV_RAM_SIZE +#define NV_RAM_SIZE NONE +#undef NV_BOOT_OFFSET +#define NV_BOOT_OFFSET 0 +#undef VEC_BASE_ADRS +#define VEC_BASE_ADRS 0 +#undef EXC_MSG_OFFSET +#define EXC_MSG_OFFSET 0x800 +#undef EXC_MSG_ADRS +#define EXC_MSG_ADRS ((char *) (LOCAL_MEM_LOCAL_ADRS+EXC_MSG_OFFSET)) +#undef BOOT_LINE_SIZE +#define BOOT_LINE_SIZE 255 +#undef BOOT_LINE_ADRS +#define BOOT_LINE_ADRS sysBootLine +#undef BOOT_LINE_OFFSET +#define BOOT_LINE_OFFSET 0x700 +#undef DEFAULT_BOOT_LINE +#define DEFAULT_BOOT_LINE sysBootLine +#undef RESERVED +#define RESERVED 0 +#undef FREE_RAM_ADRS +#define FREE_RAM_ADRS simMemBlock +#undef ROM_WARM_ADRS +#define ROM_WARM_ADRS (0x0) +#undef STACK_SAVE +#define STACK_SAVE 0x40 +#undef RAM_HIGH_ADRS +#define RAM_HIGH_ADRS 0x00008000 +#undef RAM_LOW_ADRS +#define RAM_LOW_ADRS 0x00108000 +#undef ROM_BASE_ADRS +#define ROM_BASE_ADRS 0 +#undef ROM_TEXT_ADRS +#define ROM_TEXT_ADRS (ROM_BASE_ADRS) +#undef ROM_SIZE +#define ROM_SIZE 0 +#undef USER_I_CACHE_MODE +#define USER_I_CACHE_MODE CACHE_WRITETHROUGH +#undef USER_D_CACHE_MODE +#define USER_D_CACHE_MODE CACHE_WRITETHROUGH +#undef USER_I_CACHE_ENABLE +#define USER_I_CACHE_ENABLE +#undef USER_D_CACHE_ENABLE +#define USER_D_CACHE_ENABLE +#undef SYS_CLK_RATE +#define SYS_CLK_RATE 60 +#undef SYS_CLK_RATE_MIN +#define SYS_CLK_RATE_MIN 19 +#undef SYS_CLK_RATE_MAX +#define SYS_CLK_RATE_MAX 1000 +#undef NUM_TTY +#define NUM_TTY 1 +#undef CONSOLE_TTY +#define CONSOLE_TTY 0 +#undef CONSOLE_BAUD_RATE +#define CONSOLE_BAUD_RATE 9600 +#undef NUM_FILES +#define NUM_FILES 50 +#undef CLEAR_BSS +#undef SHELL_STACK_SIZE +#define SHELL_STACK_SIZE 50000 +#undef SYM_TBL_HASH_SIZE_LOG2 +#define SYM_TBL_HASH_SIZE_LOG2 8 +#undef WDB_STACK_SIZE +#define WDB_STACK_SIZE 0x2000 +#undef WDB_BP_MAX +#define WDB_BP_MAX 50 +#undef WDB_SPAWN_PRI +#define WDB_SPAWN_PRI 100 +#undef WDB_SPAWN_OPTS +#define WDB_SPAWN_OPTS VX_FP_TASK +#undef WDB_TASK_PRIORITY +#define WDB_TASK_PRIORITY 3 +#undef WDB_TASK_OPTIONS +#define WDB_TASK_OPTIONS VX_UNBREAKABLE | VX_FP_TASK +#undef WDB_RESTART_TIME +#define WDB_RESTART_TIME 10 +#undef WDB_MAX_RESTARTS +#define WDB_MAX_RESTARTS 5 +#undef INCLUDE_CONSTANT_RDY_Q +#define INCLUDE_CONSTANT_RDY_Q +#undef ROOT_STACK_SIZE +#define ROOT_STACK_SIZE 20000 +#undef ISR_STACK_SIZE +#define ISR_STACK_SIZE 50000 +#undef INT_LOCK_LEVEL +#define INT_LOCK_LEVEL 0x1 +#undef ENV_VAR_USE_HOOKS +#define ENV_VAR_USE_HOOKS TRUE +#undef NUM_DRIVERS +#define NUM_DRIVERS 20 +#undef MAX_LOG_MSGS +#define MAX_LOG_MSGS 50 +#undef WV_DEFAULT_BUF_MIN +#define WV_DEFAULT_BUF_MIN 4 +#undef WV_DEFAULT_BUF_MAX +#define WV_DEFAULT_BUF_MAX 10 +#undef WV_DEFAULT_BUF_SIZE +#define WV_DEFAULT_BUF_SIZE 0x8000 +#undef WV_DEFAULT_BUF_THRESH +#define WV_DEFAULT_BUF_THRESH 0x4000 +#undef WV_DEFAULT_BUF_OPTIONS +#define WV_DEFAULT_BUF_OPTIONS 0x0 + +#endif /* INCprjParamsh */ diff --git a/vx-scheme/tornado/target-shell/startup b/vx-scheme/tornado/target-shell/startup new file mode 100644 index 0000000..23d5029 --- /dev/null +++ b/vx-scheme/tornado/target-shell/startup @@ -0,0 +1,3 @@ +cd "../../vx-scheme/SIMNTgnu" +ld < vx-scheme.out +cd "../../../testcases" diff --git a/vx-scheme/tornado/target-shell/target-shell.wpj b/vx-scheme/tornado/target-shell/target-shell.wpj new file mode 100755 index 0000000..4593e0f --- /dev/null +++ b/vx-scheme/tornado/target-shell/target-shell.wpj @@ -0,0 +1,843 @@ +Document file - DO NOT EDIT + + BSP_DIR +$(WIND_BASE)/target/config/simpc + + + BUILD_RULE_$(TGT_DIR)/config/simpc/simpcDrv.a +{$(TGT_DIR)/config/simpc/simpcDrv.a \ + : \ + $(TGT_DIR)/config/simpc/winSio.c \ + $(TGT_DIR)/config/simpc/winSio.h \ + $(TGT_DIR)/config/simpc/ntEnd.c} \ + {$(RM) \ + $(TGT_DIR)/config/simpc/simpcDrv.a \ + $(TGT_DIR)/config/simpc/ntEnd.o \ + $(TGT_DIR)/config/simpc/winSio.o} \ + {$(MAKE) \ + -f \ + $(WIND_PROJ_BASE)/simpc_gnu/Makefile \ + "CC_OPTIM=$(CC_OPTIM_DRIVER)" \ + $(TGT_DIR)/config/simpc/ntEnd.o} \ + {$(MAKE) \ + -f \ + $(WIND_PROJ_BASE)/simpc_gnu/Makefile \ + "CC_OPTIM=$(CC_OPTIM_DRIVER)" \ + $(TGT_DIR)/config/simpc/winSio.o} \ + {$(AR) \ + cru \ + $(TGT_DIR)/config/simpc/simpcDrv.a \ + $(TGT_DIR)/config/simpc/ntEnd.o \ + $(TGT_DIR)/config/simpc/winSio.o} \ + {$(RANLIB) \ + $(TGT_DIR)/config/simpc/simpcDrv.a} + + + BUILD_RULE_linkSyms.o +{linkSyms.o \ + : \ + } \ + {$(CC) \ + $(OPTION_OBJECT_ONLY) \ + $(CFLAGS) \ + $(PROJECT_BSP_FLAGS_EXTRA) \ + $(PRJ_DIR)/linkSyms.c \ + -o \ + $@} + + + BUILD_RULE_prjConfig.o +{prjConfig.o \ + : \ + } \ + {$(CC) \ + $(OPTION_OBJECT_ONLY) \ + $(CFLAGS) \ + $(PROJECT_BSP_FLAGS_EXTRA) \ + $(PRJ_DIR)/prjConfig.c \ + -o \ + $@} + + + BUILD_RULE_sysLib.o +{sysLib.o \ + : \ + } \ + {$(CC) \ + $(OPTION_OBJECT_ONLY) \ + $(CFLAGS) \ + $(PROJECT_BSP_FLAGS_EXTRA) \ + $(WIND_BASE)/target/config/simpc/sysLib.c \ + -o \ + $@} + + + BUILD__CURRENT +default + + + BUILD__LIST +default + + + BUILD_default_MACRO_AR +arsimpc + + + BUILD_default_MACRO_AS +ccsimpc + + + BUILD_default_MACRO_BINXSYM +echo + + + BUILD_default_MACRO_BOOT_EXTRA + + + + BUILD_default_MACRO_CC +ccsimpc + + + BUILD_default_MACRO_CC_ARCH_SPEC +-mpentium + + + BUILD_default_MACRO_CFLAGS +-g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -I$(PRJ_DIR) \ + -I$(WIND_BASE)/target/config/simpc \ + -I$(WIND_BASE)/target/h \ + -I$(WIND_BASE)/target/config/comps/src \ + -I$(WIND_BASE)/target/src/drv \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu \ + -DPRJ_BUILD \ + + + + BUILD_default_MACRO_CFLAGS_AS +-g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -P \ + -xassembler-with-cpp \ + -I$(PRJ_DIR) \ + -I$(WIND_BASE)/target/config/simpc \ + -I$(WIND_BASE)/target/h \ + -I$(WIND_BASE)/target/config/comps/src \ + -I$(WIND_BASE)/target/src/drv \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu \ + -DPRJ_BUILD \ + + + + BUILD_default_MACRO_CFLAGS_AS_PROJECT +-g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -I/h \ + -I. \ + -I$(WIND_BASE)\target\config\all \ + -I$(WIND_BASE)\target/h \ + -I$(WIND_BASE)\target/src/config \ + -I$(WIND_BASE)\target/src/drv \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu \ + -P \ + -xassembler-with-cpp + + + BUILD_default_MACRO_CFLAGS_PROJECT +-g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -I/h \ + -I. \ + -I$(WIND_BASE)\target\config\all \ + -I$(WIND_BASE)\target/h \ + -I$(WIND_BASE)\target/src/config \ + -I$(WIND_BASE)\target/src/drv \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu + + + BUILD_default_MACRO_CPP +ccsimpc -E -P + + + BUILD_default_MACRO_DOC_FILES +sysLib winSio ntEnd + + + BUILD_default_MACRO_EXTRA_MODULES + + + + BUILD_default_MACRO_HEX_FLAGS + + + + BUILD_default_MACRO_LD +ldsimpc + + + BUILD_default_MACRO_LDFLAGS +--subsystem=windows + + + BUILD_default_MACRO_LDOUT_CONV +wtxtcl $(WIND_BASE)/host/$(WIND_HOST_TYPE)/bin/simpcToExe.tcl + + + BUILD_default_MACRO_LD_LINK_PATH +-L$(WIND_BASE)/target/lib/simpc/SIMNT/gnu \ + -L$(WIND_BASE)/target/lib/simpc/SIMNT/common + + + BUILD_default_MACRO_LD_PARTIAL +ccsimpc -r -nostdlib + + + BUILD_default_MACRO_LD_PARTIAL_FLAGS +-r + + + BUILD_default_MACRO_LD_RAM_FLAGS +$(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/lib/crt1.o + + + BUILD_default_MACRO_LIBS +$(WIND_BASE)/target/config/simpc/simpcDrv.a $(VX_OS_LIBS) + + + BUILD_default_MACRO_NM +nmsimpc -g + + + BUILD_default_MACRO_OPTION_DEFINE_MACRO +-D + + + BUILD_default_MACRO_OPTION_DEPEND +-M -w + + + BUILD_default_MACRO_OPTION_GENERATE_DEPENDENCY_FILE +-MD + + + BUILD_default_MACRO_OPTION_INCLUDE_DIR +-I + + + BUILD_default_MACRO_OPTION_LANG_C +-xc + + + BUILD_default_MACRO_OPTION_UNDEFINE_MACRO +-U + + + BUILD_default_MACRO_SIZE +sizesimpc + + + BUILD_default_MACRO_TOOL_FAMILY +gnu + + + BUILD_default_MACRO_VXSIZEPROG +echo + + + BUILD_default_RO_DEPEND_PATH +{$(WIND_BASE)/target/h/} \ + {$(WIND_BASE)/target/src/} \ + {$(WIND_BASE)/target/config/} + + + BUILD_default_TC +::tc_SIMNTgnu + + + COMPONENT_ERROR_STATUS +0 + + + CORE_INFO_TYPE +::prj_vxWorks + + + CORE_INFO_VERSION +2.2 + + + FILE_$(WIND_BASE)/target/config/simpc/sysLib.c_customRule +sysLib.o + + + FILE_$(WIND_BASE)/target/config/simpc/sysLib.c_dependDone +TRUE + + + FILE_$(WIND_BASE)/target/config/simpc/sysLib.c_dependencies +$(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(PRJ_DIR)/prjComps.h \ + $(PRJ_DIR)/prjParams.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h + + + FILE_$(WIND_BASE)/target/config/simpc/sysLib.c_objects +sysLib.o + + + FILE_$(WIND_BASE)/target/config/simpc/sysLib.c_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/linkSyms.c_customRule +linkSyms.o + + + FILE_$(PRJ_DIR)/linkSyms.c_dependDone +TRUE + + + FILE_$(PRJ_DIR)/linkSyms.c_dependencies + + + + FILE_$(PRJ_DIR)/linkSyms.c_objects +linkSyms.o + + + FILE_$(PRJ_DIR)/linkSyms.c_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/prjConfig.c_customRule +prjConfig.o + + + FILE_$(PRJ_DIR)/prjConfig.c_dependDone +TRUE + + + FILE_$(PRJ_DIR)/prjConfig.c_dependencies +$(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(PRJ_DIR)/prjComps.h \ + $(PRJ_DIR)/prjParams.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h + + + FILE_$(PRJ_DIR)/prjConfig.c_objects +prjConfig.o + + + FILE_$(PRJ_DIR)/prjConfig.c_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/usrAppInit.c_dependDone +TRUE + + + FILE_$(PRJ_DIR)/usrAppInit.c_dependencies + + + + FILE_$(PRJ_DIR)/usrAppInit.c_objects +usrAppInit.o + + + FILE_$(PRJ_DIR)/usrAppInit.c_tool +C/C++ compiler + + + PROJECT_FILES +$(WIND_BASE)/target/config/simpc/sysLib.c \ + $(PRJ_DIR)/usrAppInit.c \ + $(PRJ_DIR)/prjConfig.c \ + $(PRJ_DIR)/linkSyms.c + + + WCC__CDF_PATH +$(WIND_BASE)/target/config/comps/vxWorks \ + $(WIND_BASE)/target/config/comps/vxWorks/arch/simnt \ + {$(WIND_BASE)/target/config/comps/vxWorks/tool/$(TOOL_FAMILY)} \ + $(WIND_BASE)/target/config/simpc \ + $(PRJ_DIR) + + + WCC__CURRENT +simpc + + + WCC__LIST +simpc + + + WCC__MXR_LIBS + + + + WCC_simpc_COMPONENTS +INCLUDE_MEMORY_CONFIG \ + INCLUDE_CACHE_SUPPORT \ + INCLUDE_CACHE_ENABLE \ + INCLUDE_SYSCLK_INIT \ + INCLUDE_SIO \ + INCLUDE_TTY_DEV \ + INCLUDE_HW_FP \ + INCLUDE_SYS_START \ + INCLUDE_SYSHW_INIT \ + INCLUDE_ANSI_ASSERT \ + INCLUDE_ANSI_CTYPE \ + INCLUDE_ANSI_LOCALE \ + INCLUDE_ANSI_MATH \ + INCLUDE_ANSI_STDIO \ + INCLUDE_ANSI_STDLIB \ + INCLUDE_ANSI_STRING \ + INCLUDE_ANSI_TIME \ + INCLUDE_ANSI_STDIO_EXTRA \ + INCLUDE_CTORS_DTORS \ + INCLUDE_CPLUS \ + INCLUDE_CPLUS_LANG \ + INCLUDE_GNU_INTRINSICS \ + INCLUDE_CPLUS_STRING \ + INCLUDE_CPLUS_STL \ + INCLUDE_CPLUS_IOSTREAMS \ + INCLUDE_CPLUS_IOSTREAMS_FULL \ + INCLUDE_CPLUS_STRING_IO \ + INCLUDE_POSIX_CLOCKS \ + INCLUDE_MEM_SHOW \ + INCLUDE_MSG_Q_SHOW \ + INCLUDE_SYM_TBL_SHOW \ + INCLUDE_TASK_SHOW \ + INCLUDE_HW_FP_SHOW \ + INCLUDE_EXC_SHOW \ + INCLUDE_TRIGGERING \ + INCLUDE_RBUFF \ + INCLUDE_TIMEX \ + INCLUDE_DEBUG \ + INCLUDE_SHELL_BANNER \ + INCLUDE_STARTUP_SCRIPT \ + INCLUDE_SHELL \ + INCLUDE_CPLUS_DEMANGLER \ + INCLUDE_SYM_TBL \ + INCLUDE_SYM_TBL_INIT \ + INCLUDE_STANDALONE_SYM_TBL \ + INCLUDE_LOADER \ + INCLUDE_MODULE_MANAGER \ + INCLUDE_WDB_BANNER \ + INCLUDE_WDB_BP \ + INCLUDE_WDB_CTXT \ + INCLUDE_WDB_DIRECT_CALL \ + INCLUDE_WDB_EVENTS \ + INCLUDE_WDB_EXC_NOTIFY \ + INCLUDE_WDB_EXIT_NOTIFY \ + INCLUDE_WDB_FUNC_CALL \ + INCLUDE_WDB_GOPHER \ + INCLUDE_WDB_MEM \ + INCLUDE_WDB_REG \ + INCLUDE_WDB_VIO \ + INCLUDE_WDB_VIO_LIB \ + INCLUDE_WDB_EVENTPOINTS \ + INCLUDE_WDB_START_NOTIFY \ + INCLUDE_WDB_USER_EVENT \ + INCLUDE_WDB_TASK_BP \ + INCLUDE_WDB_HW_FP \ + INCLUDE_WDB_TASK_HW_FP \ + INCLUDE_WDB_SYS_HW_FP \ + INCLUDE_WDB_TSFS \ + INCLUDE_WDB \ + INCLUDE_WDB_TASK \ + INCLUDE_WDB_SYS \ + INCLUDE_BUF_MGR \ + INCLUDE_WDB_COMM_PIPE \ + INCLUDE_USER_APPL \ + INCLUDE_KERNEL \ + INCLUDE_EXC_HANDLING \ + INCLUDE_MEM_MGR_BASIC \ + INCLUDE_MEM_MGR_FULL \ + INCLUDE_VXEVENTS \ + INCLUDE_SEM_BINARY \ + INCLUDE_SEM_MUTEX \ + INCLUDE_SEM_COUNTING \ + INCLUDE_SIGNALS \ + INCLUDE_MSG_Q \ + INCLUDE_WATCHDOGS \ + INCLUDE_TASK_HOOKS \ + INCLUDE_TASK_VARS \ + INCLUDE_ENV_VARS \ + INCLUDE_EXC_TASK \ + INCLUDE_IO_SYSTEM \ + INCLUDE_STDIO \ + INCLUDE_FLOATING_POINT \ + INCLUDE_FORMATTED_IO \ + INCLUDE_LOGGING \ + INCLUDE_PIPES \ + INCLUDE_SELECT \ + INCLUDE_SELECT_SUPPORT \ + INCLUDE_DISK_UTIL \ + INCLUDE_HASH \ + INCLUDE_DLL \ + INCLUDE_RNG_BUF \ + INCLUDE_LSTLIB \ + INCLUDE_WINDVIEW \ + INCLUDE_WINDVIEW_CLASS \ + INCLUDE_WVUPLOAD_FILE \ + INCLUDE_WVUPLOAD_TSFSSOCK \ + INCLUDE_SEQ_TIMESTAMP \ + INCLUDE_NTPASSFS + + + WCC_simpc_PARAM_AIO_TASK_PRIORITY +0 + + + WCC_simpc_PARAM_AIO_TASK_STACK_SIZE +0 + + + WCC_simpc_PARAM_AUX_CLK_RATE_MAX +1000 + + + WCC_simpc_PARAM_AUX_CLK_RATE_MIN +2 + + + WCC_simpc_PARAM_BOOT_LINE_ADRS +sysBootLine + + + WCC_simpc_PARAM_BOOT_LINE_OFFSET +0x700 + + + WCC_simpc_PARAM_BOOT_LINE_SIZE +255 + + + WCC_simpc_PARAM_CONSOLE_BAUD_RATE +9600 + + + WCC_simpc_PARAM_CONSOLE_TTY +0 + + + WCC_simpc_PARAM_DEFAULT_BOOT_LINE +sysBootLine + + + WCC_simpc_PARAM_ENV_VAR_USE_HOOKS +TRUE + + + WCC_simpc_PARAM_EXC_MSG_ADRS +((char *) (LOCAL_MEM_LOCAL_ADRS+EXC_MSG_OFFSET)) + + + WCC_simpc_PARAM_EXC_MSG_OFFSET +0x800 + + + WCC_simpc_PARAM_FREE_RAM_ADRS +simMemBlock + + + WCC_simpc_PARAM_INCLUDE_CONSTANT_RDY_Q +TRUE + + + WCC_simpc_PARAM_INCLUDE_WDB_TTY_TEST +TRUE + + + WCC_simpc_PARAM_INT_LOCK_LEVEL +0x1 + + + WCC_simpc_PARAM_ISR_STACK_SIZE +50000 + + + WCC_simpc_PARAM_LOCAL_MEM_LOCAL_ADRS +(simMemBlock) + + + WCC_simpc_PARAM_LOCAL_MEM_SIZE +(simMemSize) + + + WCC_simpc_PARAM_MAX_AIO_SYS_TASKS +0 + + + WCC_simpc_PARAM_MAX_LIO_CALLS +0 + + + WCC_simpc_PARAM_MAX_LOG_MSGS +50 + + + WCC_simpc_PARAM_MQ_HASH_SIZE +0 + + + WCC_simpc_PARAM_NUM_DOSFS_FILES +20 + + + WCC_simpc_PARAM_NUM_DRIVERS +20 + + + WCC_simpc_PARAM_NUM_FILES +50 + + + WCC_simpc_PARAM_NUM_RAWFS_FILES +5 + + + WCC_simpc_PARAM_NUM_RT11FS_FILES +5 + + + WCC_simpc_PARAM_NUM_SIGNAL_QUEUES +16 + + + WCC_simpc_PARAM_NUM_TTY +1 + + + WCC_simpc_PARAM_NV_BOOT_OFFSET +0 + + + WCC_simpc_PARAM_NV_RAM_SIZE +NONE + + + WCC_simpc_PARAM_PPP_OPTIONS_FILE +NULL + + + WCC_simpc_PARAM_RAM_HIGH_ADRS +0x00008000 + + + WCC_simpc_PARAM_RAM_LOW_ADRS +0x00108000 + + + WCC_simpc_PARAM_RESERVED +0 + + + WCC_simpc_PARAM_ROM_BASE_ADRS +0 + + + WCC_simpc_PARAM_ROM_SIZE +0 + + + WCC_simpc_PARAM_ROM_TEXT_ADRS +(ROM_BASE_ADRS) + + + WCC_simpc_PARAM_ROOT_STACK_SIZE +20000 + + + WCC_simpc_PARAM_SHELL_STACK_SIZE +50000 + + + WCC_simpc_PARAM_SM_ANCHOR_ADRS +((char *) (LOCAL_MEM_LOCAL_ADRS+SM_ANCHOR_OFFSET)) + + + WCC_simpc_PARAM_SM_ANCHOR_OFFSET +0x600 + + + WCC_simpc_PARAM_SM_CPUS_MAX +0 + + + WCC_simpc_PARAM_SM_MASTER +0 + + + WCC_simpc_PARAM_SM_MAX_WAIT +3000 + + + WCC_simpc_PARAM_SM_OBJ_MAX_MEM_PART +4 + + + WCC_simpc_PARAM_SM_OBJ_MAX_MSG_Q +10 + + + WCC_simpc_PARAM_SM_OBJ_MAX_NAME +100 + + + WCC_simpc_PARAM_SM_OBJ_MAX_SEM +60 + + + WCC_simpc_PARAM_SM_OBJ_MAX_TASK +40 + + + WCC_simpc_PARAM_SM_OBJ_MAX_TRIES +5000 + + + WCC_simpc_PARAM_SM_PKTS_SIZE +0 + + + WCC_simpc_PARAM_SM_TAS_TYPE +SM_TAS_HARD + + + WCC_simpc_PARAM_STACK_SAVE +0x40 + + + WCC_simpc_PARAM_STAT_TBL_HASH_SIZE_LOG2 +6 + + + WCC_simpc_PARAM_SYM_TBL_HASH_SIZE_LOG2 +8 + + + WCC_simpc_PARAM_SYS_CLK_RATE +60 + + + WCC_simpc_PARAM_SYS_CLK_RATE_MAX +1000 + + + WCC_simpc_PARAM_SYS_CLK_RATE_MIN +19 + + + WCC_simpc_PARAM_USER_D_CACHE_ENABLE +TRUE + + + WCC_simpc_PARAM_USER_D_CACHE_MODE +CACHE_WRITETHROUGH + + + WCC_simpc_PARAM_USER_D_MMU_ENABLE +TRUE + + + WCC_simpc_PARAM_USER_I_CACHE_ENABLE +TRUE + + + WCC_simpc_PARAM_USER_I_CACHE_MODE +CACHE_WRITETHROUGH + + + WCC_simpc_PARAM_USER_I_MMU_ENABLE +TRUE + + + WCC_simpc_PARAM_USER_RESERVED_MEM +0 + + + WCC_simpc_PARAM_VEC_BASE_ADRS +0 + + + WCC_simpc_PARAM_VM_PAGE_SIZE +4096 + + + WCC_simpc_PARAM_WDB_COMM_VTMD +8 + + + WCC_simpc_PARAM_WDB_MTU +1500 + + + WCC_simpc_PARAM_WDB_NETROM_INDEX +0 + + + WCC_simpc_PARAM_WDB_NETROM_NUM_ACCESS +1 + + + WCC_simpc_PARAM_WDB_NETROM_POLL_DELAY +2 + + + WCC_simpc_PARAM_WDB_NETROM_ROMSIZE +ROM_SIZE + + + WCC_simpc_PARAM_WDB_NETROM_TYPE +400 + + + WCC_simpc_PARAM_WDB_NETROM_WIDTH +1 + + + WCC_simpc_PARAM_WDB_STACK_SIZE +0x2000 + + + WCC_simpc_PARAM_WDB_TTY_BAUD +9600 + + + WCC_simpc_PARAM_WDB_TTY_CHANNEL +1 + + + WCC_simpc_PARAM_WDB_TTY_DEV_NAME +"/tyCo/1" + + + userComments + + + diff --git a/vx-scheme/tornado/target-shell/usrAppInit.c b/vx-scheme/tornado/target-shell/usrAppInit.c new file mode 100755 index 0000000..d326d5d --- /dev/null +++ b/vx-scheme/tornado/target-shell/usrAppInit.c @@ -0,0 +1,30 @@ +/* usrAppInit.c - stub application initialization routine */ + +/* Copyright 1984-1998 Wind River Systems, Inc. */ + +/* +modification history +-------------------- +01a,02jun98,ms written +*/ + +/* +DESCRIPTION +Initialize user application code. +*/ + +/****************************************************************************** +* +* usrAppInit - initialize the users application +*/ + +void usrAppInit (void) + { +#ifdef USER_APPL_INIT + USER_APPL_INIT; /* for backwards compatibility */ +#endif + + /* add application specific code here */ + } + + diff --git a/vx-scheme/tornado/vx-scheme.wsp b/vx-scheme/tornado/vx-scheme.wsp new file mode 100755 index 0000000..3fb3c8e --- /dev/null +++ b/vx-scheme/tornado/vx-scheme.wsp @@ -0,0 +1,15 @@ +Document file - DO NOT EDIT + + CORE_INFO_TYPE +Workspace + + + CORE_INFO_VERSION +2.2 + + + projectList +$(PRJ_DIR)/target-shell/target-shell.wpj \ + $(PRJ_DIR)/vx-scheme/vx-scheme.wpj + + diff --git a/vx-scheme/tornado/vx-scheme/prjObjs.lst b/vx-scheme/tornado/vx-scheme/prjObjs.lst new file mode 100755 index 0000000..de1a7ed --- /dev/null +++ b/vx-scheme/tornado/vx-scheme/prjObjs.lst @@ -0,0 +1,6 @@ +vx-main.o +env.o +io.o +subr.o +symtab.o +cell.o diff --git a/vx-scheme/tornado/vx-scheme/vx-scheme.wpj b/vx-scheme/tornado/vx-scheme/vx-scheme.wpj new file mode 100755 index 0000000..5b75521 --- /dev/null +++ b/vx-scheme/tornado/vx-scheme/vx-scheme.wpj @@ -0,0 +1,346 @@ +Document file - DO NOT EDIT + + BUILD_RULE_archive + + + + BUILD_RULE_objects + + + + BUILD_RULE_vx-scheme.out + + + + BUILD_RULE_vx-scheme.pl + + + + BUILD_SIMNTgnu_BUILDRULE +vx-scheme.out + + + BUILD_SIMNTgnu_MACRO_AR +arsimpc + + + BUILD_SIMNTgnu_MACRO_ARCHIVE +$(PRJ_DIR)/SIMNTgnu/vx-scheme.a + + + BUILD_SIMNTgnu_MACRO_AS +ccsimpc + + + BUILD_SIMNTgnu_MACRO_CC +ccsimpc + + + BUILD_SIMNTgnu_MACRO_CC_ARCH_SPEC +-mpentium + + + BUILD_SIMNTgnu_MACRO_CFLAGS +-O2 \ + -g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -I. \ + -I$(WIND_BASE)/target/h/ \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu \ + -fno-exceptions \ + -fno-rtti \ + -DVERSION=0.4 \ + -DVXWORKS + + + BUILD_SIMNTgnu_MACRO_CFLAGS_AS +-g \ + -mpentium \ + -ansi \ + -fno-builtin \ + -fno-defer-pop \ + -P \ + -xassembler-with-cpp \ + -I. \ + -I$(WIND_BASE)/target/h/ \ + -DCPU=SIMNT \ + -DTOOL_FAMILY=gnu \ + -DTOOL=gnu + + + BUILD_SIMNTgnu_MACRO_CPP +ccsimpc -E -P + + + BUILD_SIMNTgnu_MACRO_HEX_FLAGS + + + + BUILD_SIMNTgnu_MACRO_LD +ldsimpc + + + BUILD_SIMNTgnu_MACRO_LDFLAGS +--subsystem=windows + + + BUILD_SIMNTgnu_MACRO_LD_PARTIAL +ccsimpc -r -nostdlib + + + BUILD_SIMNTgnu_MACRO_LD_PARTIAL_FLAGS +-r + + + BUILD_SIMNTgnu_MACRO_NM +nmsimpc -g + + + BUILD_SIMNTgnu_MACRO_OPTION_DEFINE_MACRO +-D + + + BUILD_SIMNTgnu_MACRO_OPTION_DEPEND +-M -w + + + BUILD_SIMNTgnu_MACRO_OPTION_GENERATE_DEPENDENCY_FILE +-MD + + + BUILD_SIMNTgnu_MACRO_OPTION_INCLUDE_DIR +-I + + + BUILD_SIMNTgnu_MACRO_OPTION_LANG_C +-xc + + + BUILD_SIMNTgnu_MACRO_OPTION_UNDEFINE_MACRO +-U + + + BUILD_SIMNTgnu_MACRO_POST_BUILD_RULE + + + + BUILD_SIMNTgnu_MACRO_PRJ_LIBS + + + + BUILD_SIMNTgnu_MACRO_SIZE +sizesimpc + + + BUILD_SIMNTgnu_MACRO_TOOL_FAMILY +gnu + + + BUILD_SIMNTgnu_RO_DEPEND_PATH +{$(WIND_BASE)/target/h/} \ + {$(WIND_BASE)/target/src/} \ + {$(WIND_BASE)/target/config/} + + + BUILD_SIMNTgnu_TC +::tc_SIMNTgnu + + + BUILD__CURRENT +SIMNTgnu + + + BUILD__LIST +SIMNTgnu + + + CORE_INFO_TYPE +::prj_vxApp + + + CORE_INFO_VERSION +2.2 + + + FILE_$(PRJ_DIR)/../../src/cell.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/cell.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h + + + FILE_$(PRJ_DIR)/../../src/cell.cpp_objects +cell.o + + + FILE_$(PRJ_DIR)/../../src/cell.cpp_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/../../src/env.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/env.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iomanip \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iomanip.h + + + FILE_$(PRJ_DIR)/../../src/env.cpp_objects +env.o + + + FILE_$(PRJ_DIR)/../../src/env.cpp_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/../../src/io.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/io.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iomanip \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iomanip.h + + + FILE_$(PRJ_DIR)/../../src/io.cpp_objects +io.o + + + FILE_$(PRJ_DIR)/../../src/io.cpp_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/../../src/subr.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/subr.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/float.h + + + FILE_$(PRJ_DIR)/../../src/subr.cpp_objects +subr.o + + + FILE_$(PRJ_DIR)/../../src/subr.cpp_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/../../src/symtab.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/symtab.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h + + + FILE_$(PRJ_DIR)/../../src/symtab.cpp_objects +symtab.o + + + FILE_$(PRJ_DIR)/../../src/symtab.cpp_tool +C/C++ compiler + + + FILE_$(PRJ_DIR)/../../src/vx-main.cpp_dependDone +TRUE + + + FILE_$(PRJ_DIR)/../../src/vx-main.cpp_dependencies +$(PRJ_DIR)/../../src/vx-scheme.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stddef.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/lib/gcc-lib/i386-pc-mingw32/gcc-2.96/include/stdarg.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/iostream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/streambuf.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/libio.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/i386-pc-mingw32/include/_G_config.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/stdio-lock.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/fstream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/strstream \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/strstream.h \ + $(WIND_BASE)/host/$(WIND_HOST_TYPE)/include/g++-3/strfile.h + + + FILE_$(PRJ_DIR)/../../src/vx-main.cpp_objects +vx-main.o + + + FILE_$(PRJ_DIR)/../../src/vx-main.cpp_tool +C/C++ compiler + + + PROJECT_FILES +$(PRJ_DIR)/../../src/env.cpp \ + $(PRJ_DIR)/../../src/vx-main.cpp \ + $(PRJ_DIR)/../../src/io.cpp \ + $(PRJ_DIR)/../../src/subr.cpp \ + $(PRJ_DIR)/../../src/symtab.cpp \ + $(PRJ_DIR)/../../src/cell.cpp + + + userComments + + +