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