tmtt/chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull requests Releases 1 Activity

fix: README -> README.md

Browse source
This commit is contained in:
tmtt 2022-08-09 23:28:25 +02:00
parent 43e68af625
commit 99b0a6292c
756 changed files with 323753 additions and 71 deletions
Download patch file Download diff file Expand all files Collapse all files

2
ta6ob/nanopass/.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
.sw?
.*.sw?

53
ta6ob/nanopass/.travis.yml Normal file
View file

@ -0,0 +1,53 @@
language: c
sudo: required
env:
global:
- PKG_CONFIG_PATH="/usr/local/opt/libffi/lib/pkgconfig:$PKG_CONFIG_PATH"
matrix:
include:
- os: osx
env: SCHEME=chez
- os: osx
env: SCHEME=ikarus
before_script:
- brew update
- brew install libffi
- brew install bzr
- os: osx
env: SCHEME=ironscheme
- os: linux
env: SCHEME=chez
addons:
apt:
packages:
- libncurses5-dev
- libgmp-dev
- libffi-dev
- os: linux
env: SCHEME=ikarus
addons:
apt:
packages:
- libncurses5-dev
- libgmp-dev
- libffi-dev
- os: linux
env: SCHEME=vicare
addons:
apt:
packages:
- libncurses5-dev
- libgmp-dev
- libffi-dev
- os: linux
env: SCHEME=ironscheme
# - os: windows
# env: SCHEME=chez
# before_script:
# - rm .git/index; git reset --hard
# - choco install make -y
# - choco install sudo -y
dist: bionic
script:
- .travis/install_scheme
- .travis/run_tests

135
ta6ob/nanopass/.travis/install_scheme Executable file
View file

@ -0,0 +1,135 @@
#!/bin/bash -e
OS=$(uname)
ARCH=$(uname -m)
function retrieve_file {
URL=$1
FN=$2
GET=`which wget`
if test $? -eq 0 ; then
echo wget -O $FN $URL
wget -O $FN $URL
else
GET=`which curl`
if test $? -eq 0 ; then
echo curl -o $FN $URL
curl -o $FN $URL
echo "install requires curl or wget to pull tools"
fi
fi
}
function install_vicare {
VICARE_BASE="https://bitbucket.org/marcomaggi/vicare-scheme/downloads"
VICARE_VERSION="0.4.1-devel.3"
VICARE_FILE="vicare-scheme-${VICARE_VERSION}.tar.xz"
VICARE_URL="${VICARE_BASE}/${VICARE_FILE}"
case $OS in
Linux) ;;
*) echo "unexpected operating system $OS" ; exit 1 ;;
esac
retrieve_file ${VICARE_URL} ${VICARE_FILE}
xzcat ${VICARE_FILE} | tar xf -
pushd "vicare-scheme-${VICARE_VERSION}"
./configure --enable-posix --with-libffi
make
sudo make install
popd # vicare-scheme-${VICARE_VERSION}
}
function install_ikarus {
case $ARCH in
i386|i686) BITS=32 ;;
x86_64|amd64) BITS=64 ;;
*) echo "unexpected architecture $ARCH" ; exit 1 ;;
esac
case $OS in
Linux) PREFIX="/usr" ;;
Darwin) PREFIX="/usr/local" ;;
*) echo "unexpected operating system $OS" ; exit 1 ;;
esac
bzr branch lp:ikarus
pushd ikarus
./configure --prefix=$PREFIX \
CFLAGS="-m${BITS} `pkg-config --cflags libffi` -I/usr/local/opt/gmp/include" \
LDFLAGS="-m${BITS} `pkg-config --libs libffi` -L/usr/local/opt/gmp/lib"
make
sudo make install
popd # ikarus
}
function install_chez {
BASE_URL="https://github.com/cisco/ChezScheme/releases"
CHEZ_VERSION="9.5.2"
CHEZ_TGZ="csv${CHEZ_VERSION}.tar.gz"
CHEZ_EXE="ChezScheme${CHEZ_VERSION}.exe"
case $ARCH in
i386|i686) ARCH_MT="i3" ;;
x86_64|amd64) ARCH_MT="a6" ;;
*) echo "unexpected architecture $ARCH" ; exit 1 ;;
esac
case $OS in
Linux) OS_MT="le" ;;
Darwin) OS_MT="osx" ;;
Windows*|MSYS_NT*) OS_MT="nt" ;;
*) echo "unexpected operating system $OS" ; exit 1 ;;
esac
MT="${ARCH_MT}${OS_MT}"
case $OS_MT in
le|osx)
retrieve_file "${BASE_URL}/download/v${CHEZ_VERSION}/${CHEZ_TGZ}" ${CHEZ_TGZ}
tar zxf $CHEZ_TGZ
pushd "csv${CHEZ_VERSION}"
./configure -m="${ARCH_MT}${OS_MT}"
make
sudo make install
popd # "csv${CHEZ_VERSION}"
;;
nt)
retrieve_file "${BASE_URL}/download/v${CHEZ_VERSION}/${CHEZ_EXE}" ${CHEZ_EXE}
./${CHEZ_EXE} /install /quiet
export PATH=/c/Program\ Files/Chez\ Scheme\ ${CHEZ_VERSION}/bin/${MT}:$PATH
echo "(scheme-version)" | scheme -q
;;
*) echo "unrecognized OS_MT: ${OS_MT}" ; exit 1 ;;
esac
}
function install_ironscheme {
DOTNET_FILE="dotnet-install.sh"
DOTNET_URL="https://dot.net/v1/$DOTNET_FILE"
retrieve_file $DOTNET_URL $DOTNET_FILE
chmod +x $DOTNET_FILE
# install .NET
"./$DOTNET_FILE" --channel Current --runtime dotnet
export -p PATH="$HOME/.dotnet:$PATH"
BASE_URL="https://github.com/IronScheme/IronScheme/releases/download"
IRONSCHEME_VERSION=1.0.239
IRONSCHEME_GIT_VERSION=671ea21
IRONSCHEME_URL="${BASE_URL}/${IRONSCHEME_VERSION}/IronScheme-${IRONSCHEME_VERSION}-${IRONSCHEME_GIT_VERSION}.zip"
IRONSCHEME_FILE="IronScheme.zip"
retrieve_file $IRONSCHEME_URL $IRONSCHEME_FILE
unzip $IRONSCHEME_FILE
alias ironscheme="dotnet IronScheme.ConsoleCore.dll"
}
case $SCHEME in
vicare) install_vicare ;;
ikarus) install_ikarus ;;
chez) install_chez ;;
ironscheme) install_ironscheme ;;
*) echo "Please set the SCHEME environment variable to one of: vicare, ikarus, or chez before running" ; exit 1;;
esac

12
ta6ob/nanopass/.travis/run_tests Executable file
View file

@ -0,0 +1,12 @@
#!/bin/bash
case $SCHEME in
vicare) vicare --more-file-extensions --source-path "." --r6rs-script test-all.ss ;;
ikarus) ikarus --r6rs-script test-all.ss ;;
chez) scheme --program test-all.ss ;;
ironscheme)
export -p PATH="$HOME/.dotnet:$PATH"
dotnet ./IronScheme/IronScheme.ConsoleCore.dll -- test-all.ss
;;
*) echo "unexpected scheme implementation $SCHEME" ; exit 1 ;;
esac

7
ta6ob/nanopass/Acknowledgements Normal file
View file

@ -0,0 +1,7 @@
Acknowledgements
The development of this software has been supported by Indiana University,
Cadence Research Systems, Cisco Systems, and a gift from Microsoft Research.
Jordon Johnson implemented an early version of the infrastructure. The "cata"
syntax and quasiquote extension to handle ellipses is patterned after Erik
Hilsdale's match.ss, an early version of which was written by Dan Friedman.

19
ta6ob/nanopass/Copyright Normal file
View file

@ -0,0 +1,19 @@
Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.

832
ta6ob/nanopass/LOG Normal file
View file

@ -0,0 +1,832 @@
2008-09-25 18:51:12 - 4865e596edc0ea8a68be26943c1463b9a9b3b6ab
* initial import of Dipa Sarkar's code
alltests.ss, compiler.ss, define-language.ss, define-pass.ss, driver.ss,
helpers.ss, match.ss, meta-parser.ss, meta-syntax-dispatch.ss,
nano-syntax-dispatch.ss, nano.ss, nanohelpers.ss, nanotest.ss, parser.ss,
preprocess.ss, records.ss, synforms.ss, syntaxconvert.ss, term.ss,
unparser.ss
2008-10-03 19:28:03 - d0a9aa5cfe8463a0a7d52a8fc9e03283b5f86078
* added copyright notice
+ Copyright.txt
* removed match, it was used to do initial parsing of sexp
- match.ss, nanotest.ss
* added first comment in trying to decode define-language
define-language.ss
* moved back to optimize-level 2 to give debugging information
nanotest.ss
2008-10-06 09:40:52 - 1fd736e52b3ca305f56aaeac049176ddd6f5eb71
* removed execution bit from files, since they were unneeded
compiler.ss, define-language.ss, define-pass.ss, meta-parser.ss,
meta-syntax-dispatch.ss, nano-syntax-dispatch.ss, nano.ss,
nanohelpers.ss, parser.ss, records.ss, syntaxconvert.ss, term.ss,
unparser.ss
2008-10-06 09:48:17 - e06164bd5a6bf2437a833a2b8009e7dc8c7629a2
* reorganized code to move library source into src directory
moved: define-language.ss, define-pass.ss, meta-parser.ss,
meta-syntax-dispatch.ss, nano-syntax-dispatch.ss, nano.ss,
nanohelpers.ss, parser.ss, records.ss, syntaxconvert.ss, terms.ss, and
unparser.ss to src directory
2008-10-06 09:49:43 - d72c88e555b24a6bc8738162c98d194b1069503f
* reorganized code to move testing source into tests directory
moved: alltests.ss, compiler.ss, driver.ss, helpers.ss, nanotest.ss,
preprocess.ss, and synforms.ss to tests directory
2008-10-09 21:29:41 - a1b2dd8408b6f1282cfc9a962d38f0647dc32409
* accidentally changed (define-syntax define-langauge ... to
(define-language ...
* changed tests to support reorganized directories
tests/nanotest.ss
* began working to identify (and remove) unused code, along with code
reading to understand where and how functions are used. Also changed
to use consistent function definition syntax and line-wrap.
src/define-language.ss, src/define-pass.ss
* removed code after #!eof to be put in chaff file.
src/define-language.ss, src/define-pass.ss
* lifted duplicated common functions from make-processor-clause and
do-define-pass
src/define-pass.ss
2008-10-09 21:43:19 - d43213f91181deee413f86126fc3a0a56bfdf53e
* lifted make-incontext-transformer and make-quasiquote-transformer to
commonize these functions
src/define-pass.ss
* fixed (define-syntax define-language ... typo
src/define-language.ss
2008-10-09 22:23:42 - 29d2029f0213605732712c2be60f586e02c27677
* commented out some of the lifted fields
src/define-pass.ss
2008-10-09 22:23:42 - d14c0b3ed8e254991baddd15317a6a9e31dcf30c
* uncommented and generally reworked code for defining passes
src/define-pass.ss
2008-10-10 11:18:17 - 4f7840c069d47d7cd68357c67cd5b805a98886de
* cleanup of language->s-expression code
src/define-language.ss
* more code reformating and moving of common functions into the helpers.ss
src/nanohelpers.ss, src/define-pass.ss, src/meta-parser.ss,
src/meta-syntax-dispatch.ss, src/nano-syntax-dispatch.ss, src/parser.ss,
src/records.ss, src/syntaxconvert.ss, src/unparser.ss
2008-10-24 18:13:23 - d1dff8cb77922342f52a10ed36a89497f8df5f6b
* added external TODO list moved from other files
TODO.txt, src/define-language.ss
* added load-all.ss file to load the parts from the src and tests directories
load-all.ss
* moved spare code to scrap file
scraps.ss
* curried the rec-member? call to reuse the code in all of the member?
functions
src/define-language.ss
* removed alt-union, alt-difference, and tspec-union functions
src/define-language.ss
* reorganized deeply nested if statements into conds
src/define-language.ss, src/define-pass.ss
2008-10-25 14:25:18 - 21451b92b0bd1a140b35cc375eda365530edfcc0
* removed calls to eval that were used for looking up the meta-parser by
changing the meta-parser from a meta define to a procedure stored in the
compile time environment (procedure is then passed around in define-pass).
src/define-pass.ss, src/define-language.ss
2008-10-26 21:17:58 - 1284b9818ffb015f16d81e407aab94bfeaa59098
* R6RSification: changed syntax-object->datum => syntax->datum,
list* => cons*, datum->syntax-object => datum->syntax,
(sub1 ,x) => (- ,x 1), (add1 ,x) => (+ ,x 1), partition => partition-syn
src/define-language.ss, src/define-pass.ss, src/meta-parser.ss,
src/nanohelpers.ss, src/records.ss, src/syntaxconvert.ss, src/unparser.ss
* removed unused, useless, or duplicated procedure definitions: show-decls,
show-tspecs, show-productions, lookup-any, split-decls, any, every, choose,
assp, remp, memp, filter, fold, reduce, empty-set, singleton-set,
add-element, member?, empty?, union, intersection, difference
src/nanohelpers.ss
* moved lookup-alt from nanohelpers.ss to meta-parser.ss
src/nanohelpers, src/meta-parser.ss
* removed module wrappers as part of r6rsification
src/unparser.ss, src/parser.ss, src/meta-parser.ss
* changed null syntax () to #'() in generation of field patterns
src/syntaxconvert.ss,
* added more to scraps from the tail end of unparser
src/scraps.ss
2008-10-26 21:20:07 - dc1e9b02e6964ec0c36772380660a462cf8e73d6
* created R6RS libraries to wrap around existing code base
nanopass.ss, nanopass/helpers.ss, nanopass/language.ss,
nanopass/meta-parser.ss, nanopass/parser.ss, nanopass/pass.ss,
nanopass/r6rs-helpers.ss, nanopass/records.ss, nanopass/unparser.ss,
* added R6RS compatibililty wrappers for define-record, syntax-error,
literal-identifier=?, warning, and fx=
nanopass/r6rs-helpers.ss
* accidentally added swap file: nanopass/.records.ss.swp
nanopass/.records.ss.swp
2008-10-26 22:15:18 - 871b67ad1d4e2dafabe71536f15a6ec6d364c2ec
* added test-all script wrapper to ease testing
test-all.ss
2008-11-09 01:50:07 - 806ef5378ca0259b9a2a1bf3f1766e18a14ac227
* removed accidentally added swap files: nanopass/.records.ss.swp
nanopass/.records.ss.swp
* cleaned up imports as more code is changed to comply with R6RS
nanopass/helpers.ss, nanopass/language.ss, nanpoass/meta-parser.ss,
nanopass/parser.ss, nanopass/pass.ss, nanopass/r6rs-helpers.ss,
nanopass/records.ss, nanopass/syntaxconvert.ss, nanopass/unparser.ss
* continued to press an Chez -> R6RS compatibility macro for define-record
nanopass/r6rs-helpers.ss
* also introduced my-syntax-violation to push for syntax-error compatibility
nanopass/r6rs-helpers.ss
* committed some debugging source (trace-define of parse-language)
nanopass/define-language.ss,
* added R6RS version of test-all
test-all-r6rs.ss
* code reformatting (removed spaces, changed to consistent coding standard)
nanopass/r6rs-helpers.ss, tests/r6rs-compiler.ss
* added implementation-helpers to abstract away some of the implementation
specific code
nanopass/syntaxconvert.ss, nanopass/unparser.ss
* moved iota from tests/compiler.ss to tests/helpers.ss
nanopass/compiler.ss
* create r6rs copy of the test compiler
tests/r6rs-compiler.ss, tests/r6rs-helper.ss, tests/r6rs-nanotest.ss
2008-11-09 01:59:07 - 118a0a36a308f49c25c58c3b67539ce4e384d46d
* added the implementation helpers files to the repositor, one for
Chez Scheme and one for Ikarus Scheme
nanopass/implementation-helpers.ikarus.ss,
nanopass/implementation-helpers.ss
2008-11-24 20:30:17 - 6e88caf2af091aac629fddb896651fcca92512a2
* removed parse-language trace-define
src/define-language.ss
* commented out assert, since the R6RS one stands in fine
src/nanohelpers.ss
2008-11-24 20:39:20 - afe583a450a94aa25f9884902a7ce1032d5b48d7
* resolving conflicts between two wroking copies, assert => syn-assert
src/nanohelpers.ss
2008-11-24 20:50:04 - 370bd11afdfc8a0233cf82b9f3d7f3c9e2f3db80
* exported all of the internal exports from the main nanopass library
nanopass.ss
* more exports to allow this to run on Ikarus Scheme: added meta-define,
and a hack to support meta-define
nanopass/implementation-helpers.ikarus.ss, nanopass/term.ss
* exported more features of meta-parser: parse-cata, lookup-alt
nanopass/meta-parser.ss
* created library for meta-syntax-dispatch
nanopass/meta-syntax-dispatch.ss
* moved to more formal make-compile-time-value definition for
putting things into the compile-time environment to support ikarus.
src/define-language.ss
* more cleanup and R6RSification of meta-parser.ss
src/meta-parser.ss
* removed module tag from meta-syntax-dispatch
src/meta-syntax-dispatch.ss
* R6RSification of src/parser.ss: syntax-object->datum => syntax->datum,
assert => syn-assert
src/parser.ss, src/records.ss
* excluded datum from the R6RS compiler nanopss import
tests/r6rs-compiler.ss
2008-11-22 11:05:22 - 61feff78ee11abef5624b2de493e2bdb09851ffe
* same changes as previous version on a differnt machine.
nanopass.ss, nanopass/helpers.ss, nanopass/meta-parser.ss
nanopass/implementation-helpers.ikarus.ss, src/define-language.ss,
src/meta-parser.ss, src/meta-syntax-dispatch.ss, src/nanohelpers.ss,
src/records.ss, tests/r6rs-compiler.ss
2008-11-22 14:13:59 - 6b61d840e4e1b86eeacd1a489431a241023cf962
* finished copying changes from previous commit in different working copy
nanopass/meta-syntax-dispatch.ss, nanopass/term.ss
2008-11-24 20:50:28 - 31d49c16511376b46781a3e5e737cb705b8f9609
* merged two working copies
2008-11-24 22:36:14 - cbc2955a6fd540f482290fc92a39eaa4168d057b
* added trace-define-syntax and printf to the implementation-helpers to
support debugging
nanopass/implementation-helpers.ikarus.ss
* imported meta-syntax-dispatch into the meta-parser
nanopass/meta-parser.ss
* committed debugging code in the language definition
src/define-language.ss
2008-11-24 20:27:30 - f79bcb8b4aab5e804246a4030d2061edcf560e8d
* added meta-define and make-compilet-time-value macros for Chez to expand
into the appropriate meta define and cons
load-all.ss
* reformatted the exports in the nanopass top-level
nanopass.ss
* exported more helper procedures
nanopass/helpers.ss, nanopass/implementation-helpers.ss
* created auxiliaary keywords to export from the libraries to ensure they
will be free-identifier=? when used as keywords outside the library with
macros defined within the library
nanopass/language.ss, nanopas/meta-parser.ss
* created nano-syntax-dispatch library based on the syntax dispatcher from
the original code.
nanopass/nano-syntax-dispatch.ss
* added inclusing of nanopass/nano-syntax-dispatch.ss to parser.ss
nanopass/parsers.ss
* small formatting changes and removed debugging code.
nanopass/language.ss, src/define-language.ss, src/define-pass.ss,
src/parser.ss, src/unparser.ss, tests/r6rs-compiler.ss
* pulled make-double-collector-over-list and map2 into helpers
nanopass/helpers.ss
* small changes to deal with chez style records (record-type-name =>
chez-record-type-name, record-type-descriptor =>
chez-record-type-descriptor
src/unparser.ss
* added procedure definitions for compose, disjoin, any, every, choose,
reverse-filter, fold, reduce, partition, constant? keyword?,
list-of-user-primitives, list-of-system-primitives, user-primitive?,
system-primitive? primitive? predicate-primitive? value-primitive?,
effect-primitive? effect-free-primitive? gen-label, gen-symbol-seed,
reset-seed, gen-symbol, set? iota, with-values, mvlet, empty-set,
singleton-set, add-element, member?, empty?, union, intersection, and
difference to tests version of r6rs-helpers
tests/r6rs-helpers.ss
* created tiny testing library for looking at a single language definition
tests/r6rs-tiny.ss, tests/tiny.ss
2008-11-24 22:37:23 - 6f68e61e97d091ebad305b4406f7352e3cc14a6e
* no changes? looks like a merge node.
2008-12-11 09:06:34 - 65049181072cd5a748e732d454617083814b724e
* re-added auxiliary keywords for $tspec, $metas, $production, and $alt
nanopass.ss
* added code to push wraps down into syntax to support Ikarus. current
code makes extended use of car, cdr, etc. to decompose syntax rather than
syntax-case. eventually more of this needs to be dropped.
nanopass/helpers.ss
* added more implementation specific helpers to the Ikarus specific code.
some of these are to support things like format, printf, etc.
nanopass/implementation-helpers.ikarus.ss,
nanopass/implementation-helpers.ss
* moved auxiliary keywords: $tspec, $metas, $production, $alt, in, where,
over, extends, definitions, and entry into aux-keywords library
nanopass/language.ss, nanopassrecords.ss, (nanopass/aux-keywords.ss?)
* added helper syntax for map to print out what is being mapped over
for debugging purposes
nanopass/pass.ss
* fixing syntax around null (replacing #'() with '())
nanopass/r6rs-helpers.ss
* tspec?, gramelt-metas, tspec-terminal, nonterminal-name, alt=?, and
define-language now use an eq? comparison to match aux-keywords rather
then relying on the auxiliary keyword facility
nanopass/define-language.ss
* general code cleanup (reformatting, removing debugging in places, etc.)
nanopass/define-language.ss
LATEST
* reformatted a couple places where there was some odd indenting
tests/compiler-test.ss
* updated compiler passes to make use of the new pass syntax. with this
change passes that utilized the automatic combining code needed to be
rewritten to explicitly do the combining themselves (this was usually
append or union). these passes now thread a varaible through and
perform a cheaper update when possible.
tests/compiler.ss, tests/unit-tests.ss
* added set-cons for adding individual items to a set (instead of using
union everywhere
tests/helpers.ss, test/compiler.ss
* worked a little on a new test compiler, but did not make much progress
tests/new-compiler.ss
* fixed error handling in the test driver so that we are no longer getting
a non-continuable error raised when there is an exception in a pass
tests/test-driver.ss
2011-04-09 -
* added todo to investigate the handling of tspec=? down the road we may want
to investigate the syntax for extending languages again and drop the
definitions section (or at least rename it)
nanopass/language.ss
* fixed the cata syntax to support cata to a Processor that returns
zero values. as part of this fix also improved support for mapping
over processors that return multiple values. originally this was
limited to just mapping over processors with one or two values, but
now it supports zero or more. (zero return value is special-cased to
use for-each, one return value is special-cased to use map, and a loop
is built on the fly to support two or more return values.)
nanopass/meta-parser.ss, nanopass/pass.ss
* improved error message when a processor meta-variable cannot be found in
the parser and unparser.
nanopass/parser.ss, nanopass/meta-parser.ss
2011-04-25 -
* merged changes from work with some in progress changes here.
* updated tests to work with new meta-variable only nonterminal alternatives
2011-05-13 -
* added nanopass-case macro to allow for local matching of nanopass
syntax. currently this expands into a directly applied define-pass
and is restricted to returning a single, non-checked value.
nanopass/pass.ss
* extended the meta parser to allow more then statement in the body of
in-context and with-output-language transformers.
nanopass/meta-parser.ss
* fixed issue with processor internal definitions not being properly
recognized and placed definitions within a with-output-language so
that quasiquotes will be transformed into nanopass language-records
similar to the processor right-hand-sides.
nanopass/pass.ss
* fixed bug with define-pass that was causing it to return a single value
when a user provided body was checked for an appropriate language value.
the check now happens to the first return value and the extra returned
values are returned as is.
nanopass/pass.ss
* fixed bug in how extend pred-all checks were being generated so that
a call to the ntspec's pred is being generated instead of just the a
reference to the pred itself.
nanopass/records.ss
* fixed bug in the unparser that was causing non-terminal productions to
be handled through a recursively generated form rather then using the
existing pred-all for the non-terminal.
nanopass/unparser.ss
* improved error message when searching for procs fails, so that we know
the syntax we were trying to process (and hence whether it was a body,
auto-generated ntspec production, auto-generated cata, or cata call
that generated the problem).
nanopass/pass.ss
* changed a debugging pretty-print
nanopass/language.ss
2011-05-17
* improved error message when a field cannot be autogenerated in an
autogenerated clause to a processor
nanopass/pass.ss
* changed from call-with-values to let-values in code produced in
body of a processor (now that the error message doesn't hold onto
the 3D code we were generating)
nanopass/pass.ss
2011-05-22
* removed the syn-map, map2, make-double-collector, and find-matching-clause
since they were no longer being used.
nanopass/helpers.ss, tests/helpers.ss
* changed references to prod and production to ntspec
nanopass/languages.ss, nanopass/meta-parser.ss, nanopass/parser.ss,
nanopass/unparser.ss, nanopass/records.ss
* rewrote code for handling user clauses in order to support nonterminals on
the left-hand-side of a clause. clauses are now matched in the order they
appear, with additional clauses autogenerated after user clauses have been
added. the code supports the current (limited) testing but has not yet been
tested with the new compiler code. it also does not yet support terminal
or nonterminal catas.
nanopass/meta-parser.ss, nanopass/pass.ss
2011-05-22
* fixed the processor builder by adding the input identifier from a cata to
the list of formal arguments (when it would not be otherwise shadowed).
note: the order is not necessarily maintained, but since these values will
be set by the let* that binds them, there does not seem to be a need of
ordering. also fixed the else thunk to be a thunk.
nanopass/pass.ss
* incorporated changes to nanopass-case that Kent Dybvig made. when an
identifier is used in as the expression to be matched the identifier is
rebound with the new value when the cata is called.
nanopass/pass.ss
* incorporated changes to meta-language quasiquote syntax from Kent Dybvig.
this change allows things like `(locals (,(reverse xnfv*) ...) ---) which
would previously have raised an error since ellispis expected to find an
identifier in its body. to support this a quote form was also added to
make sure this feature does no cause automatically quoted items in the body
of an input, like booleans, symbols, and other constants.
nanopass/records.ss, nanopass/meta-parser.ss, nanopass/pass.ss
2011-05-25
* fixed the error message for the output processor so that it would have the
preformatted name rather then the syntax I had inadvertently dropped in
(fix thanks to Kent Dybvig).
nanopass/meta-parser.ss
2011-05-25
* setup the output process to leave quasiquote in the correct context
when an output expression is unquoted. this should allow us to avoid
many of the in-context specifiers needed in the current np-compiler.
nanopass/meta-parser.ss
2011-09-23
* removed definitions form from define-language. added a todo for a better
solution to the problem of unparsing languages into a runnable s-expression
syntax. also removed empty let wrapper from unparser output, since it is
no longer needed with the definitions support gone.
nanopass/language.ss, nanopass/record.ss, nanopass/unparser.ss
* added feature to gather up information about the syntax being passed to
a record constructor so that we can provide a slightly better error message
when the value passed for one of the fields is invalid. this is done
using the source-annotation functionality, and produces a single message
for each fld (even though multiple syntax objects might have contributed,
e.g. in the case of a list field). when the identifier is known, it will
report that the problem occurred at the given syntax item and when it is
not it will report that the problem ocurred near the given syntax item.
nanopass/records.ss, nanopass/meta-parser.ss, nanopass/parser.ss
* parser and unparser are now defined with define-who so that they can report
which parser or unparser went belly up when an error occurs.
nanopass/language.ss, nanopass/parser.ss
* added check in nano-meta->fml* to raise an error when a quoted terminal
is found in the list of formals. this is just a more specific message
than the "unrecognized nano-rec" in the else case.
nanopass/pass.ss
* at optimize-level 3, the "checking" version of the pair-alt record
constructor is now a syntax definitions that washes down to a call to
the normal record constructor, so that the output of the checked and
unchecked cases will be the same.
nanopass/records.ss
2011-09-24
* moved the preprocessor code into the tests/compiler.ss file and changed
it to use with-output-language, rather than the s-expression quasiquote.
tests/compiler.ss, tests/compiler-tests.ss, tests/preprocess.ss (removed)
* updated the synforms library to not require a quasiquoted expression.
also changed to use ... in place of dots or .. by using the Chez extended
syntax-rules (which allow for a general guard expression). also got rid of
top level quoted item, probably should have also made unquote legal as
start of pattern.
tests/synforms.ss
* now exporting define-who from tests/helpers.ss to allow for more convenient
error calls in the rename-var/verify-scheme function.
tests/helpers.ss, tests/compiler.ss
2011-09-29
* added a (maybe x) form to language definitions to allow language defintions
to contain fields that can be occupied by either a non-terminal or #f.
this means it is now possible to have a production like:
(define-language L
(terminals
(integer (int))
---)
(Exp (e)
(Foo int (maybe e))
---))
and the e field in Foo maybe either be an Exp or #f. also added ? as a valid
character to put on a meta-variable to allow e? for those fields that are
maybe fields.
nanopass/helpers.ss, nanopass/meta-parser.ss, nanopass/pass.ss,
nanopass/records.ss, nanopass/syntaxconvert.ss, nanopass/unparser.ss
test-all.ss, tests/unit-test-helpers.ss, tests/unit-tests.ss
* Fixed variable overlap bug when a pattern and the langauge formal to a processor
share the same name. For example:
(Exp : Exp (e1) -> Exp ()
[(Foo ,e1 ,e2) ---]
---)
this now produces the expected code and shadowing, instead of re-binding e1
before e2 has a chance to be extracted from e1.
nanopass/pass.ss
* Fixed bug when handling output expressions that can end in a terminal in the
meta-parser. This means if you have:
(define-language L
(terminals
(integer (int))
(boolean (bool))
---)
(Exp (e)
(Foo int e-or-bool)
---)
(Exp-or-Bool (e-or-bool)
bool
e))
then the expression:
(with-output-language (L Exp) `(Foo 4 #f))
it should now work properly.
nanopass/meta-parser.ss
* Added indirect-export of record constructors, predicates, and accessors
created when defining a language, so that if the language is exported,
these will be exported as well.
nanopass/records.ss
* convert-pattern now returns fields and levels as separate list return
values along with a list of maybes. it also parses the (maybe e) syntax
(see note above)
nanopass/syntaxconvert.ss
* Fixed some tests that were still expecting the (let () ---) wrapper
around the output of language unparsers. also cleaned up the output
to make it a little more obvious what was going on with these.
tests/unit-tests.ss, tests/unit-test-helpers.ss
2011-09-09
* The nanopass library is now built as a library group to ease testing in
Chez Scheme 8.9.1 (which includes a built in copy of the nanopass framework
that will be used in place of the library if it is not carefully loaded).
nanopass.ss
* Cleaned up unique names so that they now have a single number added to them
rather then several, and the names are divided by : in stead of being
divided by .
nanopass/helpers.ss
* Small changes to error messages that report bad meta-variables, these now
report if they are from the parser or meta-parser.
nanopass/meta-parser.ss, nanopass/parser.ss
* First step at moving to record variants with case dispatch. This version
includes the potential for some extra record checks, sometimes even when
they are not needed. However the basic dispatch is there now.
nanopass/pass.ss, nanopass/records.ss
2011-09-10
* Moved calculation of ntspec sub-terminal predicate and ntspec full tags
into the same code that calculates the all-pred for the ntspec. This
has the added benefit that when the else is used we only put in the
nanopass-record check when there is a possibility that it could be a
terminal.
nanopass/records.ss, nanopass/pass.ss
----
2011-12-26
* Small fix to echo message for echoing passes (now includes newline)
nanopass/pass.ss
* Added basic support for nanopass records as terminals. This support is
incomplete, since it doesn't have a syntax that fully supports the
define-record-type syntax, but should be able to.
nanopass/pass.ss, nanopass/records.ss, nanopass/language.ss,
nanopass/meta-parser.ss
* Fixed (slightly) handling of mapping over input terms. Now if there is
not an expression to map, it does not build a call to map.
nanopass/pass.ss
----
2012-12-17 - 949d59d57739e3a29cce020b244c81d049f73e5b
* Moved project to public github.
all files
2013-01-30 - 41f14e679b5fb9c2a8eaabe6f908905c3f329fe1
* removed list-tail definition from helpers and turned it into an import in
implementation helpers. (thanks to Kent Dybvig, who made the change and
submitted a bug report).
nanopass/helpers.ss, nanopass/implementation-helpers.ss
* there is no longer an additional (duplicate) count for traversing into a
sub-nonterminal. counts for terminal elements of a wrapping nonterminal
have also been removed (not sure if this was a good change or not).
nanopass/language-node-counter.ss
* changed how the "trace" keyword determines when it should use an input or
output unparser. this is now determined by both checking that there is an
input (or output) language and an input (or output) nonterminal in the
transformer being traced.
nanopass/pass.ss
* changed the autogenerated clauses to call the checking record maker instead
of the non-checking version, because a recursive call could potentially hit
a compiler writer supplied terminal or nonterminal transformer that builds
an invalid item.
nanopass/pass.ss
2013-01-30 - 65d35a107fcdd4e7091af6c159867215d8da0971
* Updated copyright information in all the files.
Copyright, nanopass.ss, nanopass/helpers.ss,
nanopass/implementation-helpers.chezscheme.ss,
nanopass/implementation-helpers.ikarus.ss,
nanopass/implementation-helpers.ss, nanopass/language-node-counter.ss,
nanopass/language.ss, nanopass/meta-parser.ss,
nanopass/meta-syntax-dispatch.ss, nanopass/nano-syntax-dispatch.ss,
nanopass/parser.ss, nanopass/pass.ss, nanopass/random-util.sls,
nanopass/records.ss, nanopass/syntax-handler.sls,
nanopass/syntaxconvert.ss, nanopass/unparser.ss, test-all.ss,
tests/alltests.ss, tests/compiler-test.ss, tests/compiler.ss,
tests/helpers.ss, tests/implementation-helpers.ikarus.ss,
tests/implementation-helpers.ss, tests/new-compiler.ss,
tests/synforms.ss, tests/test-driver.ss,
tests/unit-test-helpers-implementation.chezscheme.sls,
tests/unit-test-helpers.ss, tests/unit-tests.ss
2013-07-18 - 097f7c428a1573af14556e76619fab323f7d42b8
* Merged typo fix in error message (courtesy of Eric Holk)
nanopass/pass.ss
2013-07-18 - 79e0e644d5c490a2ea71418834228a429b97d581
* Merged another typo fix in another error message (courtesy of Eric Holk)
nanopass/records.ss
2013-08-03 - ce94b43cfc1a6ef1dd7de5bd65d37c165902918d
* INCOMPATIBLE CHANGE: Extended languages now use the base languages's entry
point as the entry point for the language instead of the first listed
nonterminal. In general, this seems like the behavior you want, though it
may break some existing libraries, so upgrade with caution.
nanopass/languages.ss, tests/compiler.ss
* Added a prune-language form that, when given a language, starts traversing
the language from the entry nontermainal and determines if there are any
dead nonterminals or terminals in the language, prunes them, and returns an
S-expression representing only the reachable parts of the language.
nanopass/language.ss, nanopass.ss
2013-09-03 - f8fc318d2bc644357c02cef5e897702efa2d1675
* Added binaries of the nanopass framework for OS X
ReadMe, ReadMe.md, lib/ReadMe.md, lib/csv8.4/{,t}{a6,i3}osx/nanopass.so
2013-09-03 - b13b070e578d960c895c45aafba616175d4c5782
* Added binaries ot the nanopass framework for Linux
lib/csv8.4/{,t}{a6,i3}le/nanopasss.so
2013-09-16 - ad7ff9b1eba29bffc474fc94cb4fc0ab431fa3ab
* Fixed a bug with the parser that caused bare boolean terminals to fail to
parse. Specifically, since #f was used to indicate a failed parse,
parsing the bare boolean #f was raising an error.
nanopass/parse.ss, tests/unit-tests.ss
2013-10-01 - af34af0544292872a5f1de4a8f92c1caca5e51b2
* changed unique-id to unique-symbol, since we are now building the
unique-symbol and using it directly instead of generating the id to use in
output syntax. also exporting make-list to make generating accessors
easier.
nanopass/helpers.ss, nanopass/implementation-helpers.chezscheme.ss,
nanopass/implementation-helpers.ss
* fixed language->s-expression to no longer output the nongenerative id of
an ntspec, since it is no longer necessary to specify for each ntspec
nanopass/language.ss
* small cleanup of the meta-parser. removed extra (unused) argument to a
couple of procedures.
nanopass/meta-parsers.ss, nanopass/parser.ss, nanopass/unparser.ss
* removed differentiation between checking and non-checking maker, since we
are no longer using the non-checking maker.
nanopass/meta-parsers.ss, nanopass/records.ss, nanopass/parser.ss,
nanopass/pass.ss
* improved checking of meta-variables so that if the wrong meta-variable is
used, it will report it to the user, rather than doing a check that will
always fail we now report that an invalid meta-variable was used at expand
time. also did some general cleanup and improved error messages around
using quoted items in a pattern match.
nanopass/pass.ss, nanopass/records.ss
* changed record creation code to skip the define-record-type macro and
instead we are creating the records directly using the procedural
interface. this (hopefully) helps the memory usage and speed of expanding
language definitions.
nanopass/records.ss
2013-10-02 - 3dd941537379b2a2a1a139daf8107a24ce919346
* added bin directory to automate the process of building binaries across Mac
OS X and Linux. these scripts require a setup with multiple versions of
the Chez Scheme compiler installed.
bin/build-shared-objects, bin/compile-file-to-lib-dir
2013-10-02 - 3dd941537379b2a2a1a139daf8107a24ce919346
* added a define-pruned-language form that prunes a language and then defines
it with a new name. also changed diff-languages to output code that is
appropriate for the current implemntation of language extensions in the
nanopass framework.
nanopass.ss, nanopass/languages.ss
2013-10-04 - 9cd67d5ee048370ca253b7fd3b942151921858fd
* added checking for mutually recursive nonterminals so that we now report
an error to the user. this was a simple change, and if we want to support
this in the future, there is probably a way to do so, we just need to be
careful about pass generation.
nanopass/records.ss
2013-10-04 - 1aa2c01274137066aa3de75f966ce7c11374d20f,
c38ba0f9fea350ca403f8d0892765aebbb80890b
* fixed a small bug in the error reporting code for the stricter checking of
nanopass meta-variables.
nanopass/pass.ss
2013-10-15 - 47c580d5ee361d6aa209189baa3489c067e18248,
3c7b2c6eff3e0e724291063cddce46ad9a447d47
* added support for Vicare Scheme through the implementation helper files.
removed use of define-property, since it is not supported on other
Scheme platforms.
nanopass.ss, nanopass/helpers.ss, nanopass/language-node-counter.ss,
nanopass/language.ss, nanopass/meta-parser.ss,
nanopass/meta-syntax-dispatch.ss, nanopass/parser.ss, nanopass/pass.ss,
nanopass/record.ss, nanopass/unparser.ss, nanopass/synforms.ss,
nanopass.chezscheme.sls (new),
nanopass/implementation-helpers.chezscheme.sls
(renamed, was nanopass/implementation-helpers.chezscheme.ss),
nanopass/implementation-helpers.ss (removed),
nanopass/implementation-helpers.vicare.sls (new),
tests/implementation-helpers.chezscheme.sls (new),
tests/implementation-helpers.vicare.sls (new),
tests/unit-test-helpers-implementation.vicare.sls (new)
* moved language pruning code into a separate library to remove duplicated
code for prune-language and define-pruned-language.
nanopass/language-helpers.ss (new), nanopass/language.ss
* added a gitignore file so that I won't accidentally commit vim swap files.
.gitignore
2013-10-16 - d7f3c8a71a99f2cc88a3a5f8c28b780dcf07c41d
* added support for Ikarus Scheme (which is a little easier to install on Mac
OS X). moved more Chez specific code to the implementation specific
libraries.
nanopass/helpers.ss, implementation-helpers.chezscheme.sls,
implementation-helpers.ikarus.ss, implementation-helpers.vicare.sls,
nanopass/meta-parser.ss, nanopass/parser.ss, nanopass/pass.ss,
nanopass/records.ss, nanopass/unparser.ss, tests/compiler.ss,
tests/unit-test-helpers-implementation.ikarus.sls (new)
* test-all now prints output when running under Vicare Scheme.
tests/unit-test-helpers-implementation.vicare.sls
* started cleaning up code that is no longer used.
nanopass/helpers.ss, nanopass/random-util.sls (removed),
nanopass/syntax-handler.sls (removed)
2013-10-17 - 31bdcd721d5685ca78c1f43974ffb0ea890ad8b2
* code cleanup. removed more no longer used code.
nanopass/helpers.ss, nanopass/implementation-helpers.chezscheme.sls,
test-all.ss
2013-10-17 -
* updated documentation and logs
LOG, TODO, ReadMe.md, CHANGES (removed), Notes (removed),
ReadMe (removed)
* updated binary build script and built updated binaries
bin/build-shared-objects, bin/compile-file-to-dir,
lib/csv8.4/{,t}{a6,i3}{le,osx}/nanopass.so
2013-10-24 -
* fixed support for using improper lists in language productions. this
addresses issue 7 from the github issues list. it is now possible to
use an improper list as the top-level pattern for a production and
improper lists can now be matched in a pass without raising an invalid
pattern syntax error in the pass. also added regression tests.
nanopass/language.ss, nanopass/meta-syntax-dispatch.ss,
tests/unit-tests.ss, test-all.ss,
lib/csv8.4/a6le/nanopass.so, lib/csv8.4/a6osx/nanopass.so,
lib/csv8.4/i3le/nanopass.so, lib/csv8.4/i3osx/nanopass.so,
lib/csv8.4/ta6le/nanopass.so, lib/csv8.4/ta6osx/nanopass.so,
lib/csv8.4/ti3le/nanopass.so, lib/csv8.4/ti3osx/nanopass.so
2013-12-05 -
* added a with-r6rs-quasiquote and a with-extended-quasiquote forms. the
r6rs version provides the normal quasiquote, while the extended version
includes support for ellipsis in the template (the extended quasiquote is
now needed for the pretty output forms).
nanopass.ss, nanopass/helpers.ss, nanopass/unparser.ss
* added a second pretty form (->) for writing procedural unparsing of
nonterminal productions.
nanopass/language.ss, nanopass/helpers.ss, nanopass.ss, nanopass/records.ss,
nanopass/unparser.ss
* changed how trace-define-pass and traced transformers work, so that the
tracing now outputs the raw S-expressions syntax, rather than the unparsed
S-expression syntax.
nanopass/unparser.ss
* fixed how the unparser handles terminals, so that they will be unparsed
using the pretty unparser, even when they are unparsed at the top level, if
they are not using the raw unparsing.
nanopass/unparser.ss
* fixed a bug in how the meta-parser generates catas so that it will now put
the correct type in for terminal specs.
nanopass/meta-parser.ss
* fixed a bug in how the transformer syntax is parsed when there is no input
language, or when there is no output language. (the code used to assume
that the language would be present, leading to unhelpful error messages.)
nanopass/pass.ss
2013-12-05 -
* fixed a bug with how errors are reported when a language production gets
the wrong the value. (Thanks to Eric Holk for pointing out the bug (and
the different handling of formats in Vicare).
nanopass/records.ss
* built csv8.4 binaries with the current updates.
lib/csv8.4/a6le/nanopass.so, lib/csv8.4/a6osx/nanopass.so,
lib/csv8.4/i3le/nanopass.so, lib/csv8.4/i3osx/nanopass.so,
lib/csv8.4/ta6le/nanopass.so, lib/csv8.4/ta6osx/nanopass.so,
lib/csv8.4/ti3le/nanopass.so, lib/csv8.4/ti3osx/nanopass.so
2013-12-09 -
* fixed a bug with the unparsing of maybe fields, with an added test to make
sure that we don't wreck the handling of maybe fields again.
nanopass/unparser.ss, test-all.ss, tests/unit-tests.ss
* built csv8.4 binaries with the current updates.
lib/csv8.4/a6le/nanopass.so, lib/csv8.4/a6osx/nanopass.so,
lib/csv8.4/i3le/nanopass.so, lib/csv8.4/i3osx/nanopass.so,
lib/csv8.4/ta6le/nanopass.so, lib/csv8.4/ta6osx/nanopass.so,
lib/csv8.4/ti3le/nanopass.so, lib/csv8.4/ti3osx/nanopass.so
2017-11-09 -
* fixed bug in handling of extra arguments for terminal subtypes, nonterminal
subtypes, and pass bodies. Previously all three of these cases simply
looked for a processor that did not require more extra arguments than we
had available, and supplied them in positional order, instead of using
names like the cata-morphism or normal pair-alt production processing.
nanopass/pass.ss, tests/unit-test.ss, test-all.ss
2017-11-10 -
* fixed a bug introduced by the last bug check that was leading to an
erroneous change in generation of terminal and nonterminal subtype calls
when there were additional return values. Also fixed a bug with the
handling of terminal subtype calls (these originally looked for a processor
that could return multiple values and then produced a values return that
added effectively had a multi-valued first element (which would have lead
to run time errors).
nanopass/pass.ss
2017-11-17 -
* fixed error message generated by nanopass constructors with list fields so
that it reports that it expected a list of (or list of list of ... etc.)
the type instead of failing because we are calling for-each. (bad error
message reported by Jamie Taylor---thanks!)
nanopass/records.ss, test-all.ss, tests/unit-tests.ss
* fixed assert-error so that it will work, now that there are tests that
need to make use of it.
tests/unit-test-helpers.ss
2018-09-05 -
* remove outdated information and add links to papers
ReadMe.md
* fixed Travis CI fails caused by inaccurate vicare-scheme version
.travis/install_scheme
2018-09-16 -
* fixed tests to work with recent version of vicare (0.4d1)
nanopass/implementation-helpers.vicare.sls, nanopass/language.ss,
nanopass/pass.ss, nanopass/records.ss,
tests/implementation-helpers.vicare.sls, tests/test-driver.ss
2018-09-30 -
* implemented define-property for ikarus and vicare
nanopass/syntactic-property.sls (new),
nanopass/implementation-helpers.ikarus.ss,
nanopass/implementation-helpers.vicare.sls,
nanopass/implementation-helpers.chezscheme.ss, nanopass/helpers.ss
* added pass-input-parser and pass-output-unparser to allow the class
compiler driver to determine the parser and unparser for passes used in the
compiler so that we can trace and start at intermediate points in the
compiler without having to specify it in each case.
nanopass.ss, nanopass/pass.ss, test-all.ss, tests/unit-tests.ss,
tests/unit-test-helpers.ss
* updated to the most recent vicare release
.travis/install_scheme
2018-10-04 -
* Updated the way we store the pass input and output languages, so that we
can differentiate between a pass that does not have an input language or
output language and an identifier that is not for a pass. These macros now
expand into code for the language unparser/parser (when there is an input
or output language), a procedure that takes one or more arguments and
returns the first one (when there is no input or output language), or #f
(when the identifier is not for a pass, or the pass info property has been
somehow lost). Also added procedures for looking up the input and outpuot
language with an identifier and the compile time environment, and
determining if an identifier has related pass information.
nanopass.ss, nanopass/pass.ss nanopass/records.ss
2019-11-27 -
* Small fix to correct with-r6rs-quasiquote, which was previously not
restoring the normal R6RS quasiquote within a scope where a nanopass
quasiquote handler was bound.
nanopass/helpers.ss
* Whitespace cleanup.
nanopass/pass.ss
2019-12-07 -
* Small fix to make the unit tests exit with a non-zero exit code when one of
the unit test fails. Along with this fixed formatting around the error
messages so that it should be consistent across platforms. This required a
bit of hackery to get the filename that will be used by Chez, Ikarus, and
Vicare, along with exposing a version of format that sets the print
parameters necessary to get it to match display-condition (in Chez, this is
just format in Ikarus and Vicare). Finally, exposed some of the underlying
source information extracting functions.
test-all.ss, nanopass/helpers.ss,
tests/unit-test-helpers-implementation.chezscheme.sls,
tests/unit-test-helpers-implementation.ikarus.sls,
tests/unit-test-helpers-implementation.vicare.sls,
tests/unit-test-helpers.ss, tests/unit-tests.ss
* Corrected (embarrassing) misspelling of received.
nanopass/records.ss
2020-01-31 -
* Small changes: added trace-define-who, slightly improved error message for
quoted terminals in patterns, and a little code and comment cleanup.
nanopass/helpers.ss, nanopass/meta-syntax-dispatch.ss, nanopass/pass.ss,
nanopass/records.ss
2020-10-11 -
* Changed the nano-syntax-dispatch into a macro so that compilers using
define-parser do not have a run-time dependency on the (nanopass
nano-syntax-dispatch) library. With this change the pattern no longer
needs to be quoted in the output of define-parser.
nanopass/nano-syntax-dispatch.ss, nanopass/parser.ss
2020-10-18 -
* Removed np-parse-fail-token as a run-time dependency by making it a macro.
The whole parser really needs to be revisited, but this should make it
possible to generate compilers with intermediate language parser that do
not have a run-time dependency on the nanopass framework.
nanopass/parser.ss, nanopass/helpers.ss,
nanopass/implementation-helpers.chezscheme.sls,
nanopass/implementation-helpers.ikarus.ss,
nanopass/implementation-helpers.ironscheme.sls,
nanopass/implementation-helpers.vicare.sls

46
ta6ob/nanopass/ReadMe.md Normal file
View file

@ -0,0 +1,46 @@
Nanopass Compiler Library
==========================
[![Build Status](https://travis-ci.org/nanopass/nanopass-framework-scheme.svg?branch=master)](https://travis-ci.org/nanopass/nanopass-framework-scheme)
This repositiory contains an R6RS version of the Nanopass Compiler Infrastructure
described in \[1, 2, 3, 4\], along with the beginnings of a test compiler for the
library and the rough start to a users guide. The nanopass framework currently
supports Chez Scheme, Vicare Scheme, and Ikarus Scheme.
Files
======
ReadMe.md -- this readme file
Acknowledgements -- thanks to those who have supported the work
Copyright -- copyright information
TODO -- the head of the infinite todo list
LOG -- change log for the nanopass framework
test-all.ss -- is a simple wrapper for importing the compiler and
performing a testing run of all of the tests.
nanopass.ss -- the main interface to the nanopass compiler library
nanopass/ -- contains the parts that nanopass.ss aggregates
tests/ -- contains a testing compiler along with tests for that
compiler and a driver for running the tests
doc/ -- contains a user guide and developer guide along with a
makefile for generating their pdfs with pdflatex
References
===========
[[1]](https://dl.acm.org/citation.cfm?id=2500618)
A. Keep and R. K. Dybvig. A Nanopass Compiler for Commercial Compiler
Development. In ICFP ’13: Proceedings of the 18th ACM SIGPLAN International
Conference on Functional Programming, New York, NY, USA, 2013. ACM.
[2] A. Keep. A Nanopass Framework for Commercial Compiler Development.
Doctoral dissertation, Indiana University,
Bloomington, Indiana, USA, Feb. 2013.
[3] D. Sarkar. Nanopass Compiler Infrastructure.
Doctoral dissertation, Indiana University,
Bloomington, Indiana, USA, 2008.
[[4]](https://dl.acm.org/citation.cfm?id=1016878)
D. Sarkar, O. Waddell, and R. K. Dybvig. A nanopass infrastructure for
compiler education. In ICFP ’04: Proceedings of the ninth ACM SIGPLAN
International Conference on Functional Programming, pages 201–212,
New York, NY, USA, 2004. ACM.

48
ta6ob/nanopass/TODO Normal file
View file

@ -0,0 +1,48 @@
TODO
Support:
1. Create Racket version of the nanopass framework
2. Extended to more R6RS libraries (at least if they support some form of
compile time environment).
Nanopass Annoyances:
1. Removal of patterns is too strict matching EXACTLY the variable names (see
above example) This may not be bad, but without the error is a very rough
edge.
2. Output forms need to match original language forms very closely, e.g. if we
have:
(define-language L
over
---
where
(e in Expr
(begin e0 ... e1)
---)
---)
we cannot create the constructor:
`(begin (set! ,x0 (var ,tmp*)) ...)
because it sees this as a single form instead of a list. Being able to
create a make-begin helper for this situation is helpful, but ultimately
we'd like it to match broader forms and complain at compilation time if it
cannot prove they are safe itself. The contortion we are instead forced to
perform is:
(let* ([expr* (map (lambda (x tmp) `(set! ,x (var ,tmp))) x0 tmp*)]
[rexpr* (reverse expr*)]
[last-expr (car rexpr*)]
[expr* (reverse (cdr expr*))])
`(begin ,expr* ... ,last-expr))
Features to add down the road:
1. Pass fusing with deforestation of the intermediate passes.
Error Handling/Loosening restrictions:
1. Fix parser to use positional information to report errors on the syntax
error, in addition to reporting the error.

37
ta6ob/nanopass/doc/Makefile Normal file
View file

@ -0,0 +1,37 @@
# define default document pathname here
Scheme=scheme
STEXLIB=${HOME}/stex
# override on command line with 'make x=newdoc'
x = user-guide
# define latex processor: latex or pdflatex
latex = pdflatex
# define stex macro files here
stexmacrofiles =
# list bibliography files here
bib = user-guide.bib
# define index if an index is to be generated
# index=yes
doit: $x.pdf
include ~/stex/Mf-stex
# define or override suffixes here
# define any additional targets here
# define any dependencies here
# define cleanup targets here:
$(x).clean:
$(x).reallyclean:
$(x).reallyreallyclean:

77
ta6ob/nanopass/doc/language-api.ss Normal file
View file

@ -0,0 +1,77 @@
(define-language Lannotated
(entry Defn)
(terminals
(record-constructor-descriptor (rcd))
(record-type-descriptor (rtd))
(exact-integer (tag level tag-mask))
(datum (handler record-name pred all-pred all-term-pred
accessor maker))
(box (b))
(syntax (stx))
(identifier (id))
(dots (dots))
(null (null)))
(Defn (def)
(define-language id ref (maybe id0) rtd rcd tag-mask
(term* ...) nt* ...))
(Terminal (term)
(id (id* ...) b (maybe handler) pred))
(Nonterminal (nt)
(id (id* ...) b rtd rcd tag pred all-pred all-term-pred
prod* ...))
(Production (prod)
(production pattern (maybe pretty-prod) rtd tag pred maker field* ...)
(terminal ref (maybe pretty-prod))
(nonterminal ref (maybe pretty-prod)))
(Pattern (pattern)
id
ref
null
(maybe ref)
(pattern dots)
(pattern0 dots pattern1 ... . pattern2)
(pattern0 . pattern1))
(PrettyProduction (pretty-prod)
(procedure handler)
(pretty pattern))
(Field (field)
(ref level accessor)
(optional ref level accessor))
(Reference (ref)
(reference id0 id1 b)))
(define-language Llanguage
(entry Defn)
(terminals
(box (b))
(syntax (stx))
(identifier (id))
(datum (handler))
(dots (dots))
(null (null)))
(Defn (def)
(define-language id cl* ...))
(Clause (cl)
(entry ref)
(nongenerative-id id)
(terminals term* ...)
(id (id* ...) b prod* ...))
(Terminal (term)
simple-term
(=> simple-term handler))
(SimpleTerminal (simple-term)
(id (id* ...) b))
(Production (prod)
pattern
(=> pattern0 pattern1)
(-> pattern handler))
(Pattern (pattern)
id
ref
null
(maybe ref)
(pattern dots)
(pattern0 dots pattern1 ... . pattern2)
(pattern0 . pattern1))
(Reference (ref)
(reference id0 id1 b)))

67
ta6ob/nanopass/doc/user-guide.bib Normal file
View file

@ -0,0 +1,67 @@
@phdthesis{keep-phdthesis-2013,
author = {Keep, Andrew W.},
title = {{A Nanopass Framework for Commercial Compiler Development}},
school = {Indiana University},
year = {2013},
month = feb,
url = {https://pqdtopen.proquest.com/pubnum/3560746.html}
}
@inproceedings{Meijer:1991:FPB:645420.652535,
author = {Meijer, Erik and Fokkinga, Maarten M. and Paterson, Ross},
title = {{Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire}},
booktitle = {Proc. 5th ACM Conference on Functional Programming Languages and Computer Architecture},
year = {1991},
isbn = {3-540-54396-1},
pages = {124--144},
numpages = {21},
url = {http://dl.acm.org/citation.cfm?id=645420.652535},
acmid = {652535},
publisher = {Springer-Verlag},
address = {London, UK},
}
@inproceedings{Sarkar:2004:NIC:1016850.1016878,
author = {Sarkar, Dipanwita and Waddell, Oscar and Dybvig, R. Kent},
title = {{A Nanopass Infrastructure for Compiler Education}},
booktitle = {Proc. 9th ACM SIGPLAN International Conference on Functional Programming},
series = {ICFP '04},
year = {2004},
location = {Snow Bird, UT, USA},
pages = {201--212},
numpages = {12},
url = {http://doi.acm.org/10.1145/1016850.1016878},
acmid = {1016878},
publisher = {ACM},
address = {New York},
keywords = {compiler writing tools, domain-specific languages, nanopass compilers, syntactic abstraction},
}
@book{Dybvig:csug8,
author = {R. Kent Dybvig},
title = {{Chez Scheme Version 8 User's Guide}},
publisher = {Cadence Research Systems},
year = 2009,
texturl = "http://www.scheme.com/csug8/",
biburl = "http://www.cs.indiana.edu/{\textasciitilde}dyb/pubs/csug8.bib",
annote = {User's guide and reference manual for Chez Scheme Version 8. Complements \cite{Dybvig:tspl4}.}
}
@book{Dybvig:csug9,
author = {R. Kent Dybvig},
title = {{Chez Scheme Version 9 User's Guide}},
publisher = {Cisco Systems, Inc.},
year = 2019,
url = "http://cisco.github.io/ChezScheme/csug9.5/csug.html",
annote = {User's guide and reference manual for Chez Scheme Version 9.5 Complements \cite{Dybvig:tspl4}.}
}
@book{Dybvig:tspl4,
author = {R. Kent Dybvig},
title = {The {Scheme} Programming Language},
publisher = {{MIT} Press},
edition = {Fourth},
year = 2009,
texturl = "http://www.scheme.com/tspl4/",
annote = {Introduction and reference manual for R6RS Scheme with numerous short and extended examples and exercises.}
}

BIN
ta6ob/nanopass/doc/user-guide.pdf Normal file
View file

Binary file not shown.

2752
ta6ob/nanopass/doc/user-guide.stex Normal file
View file

File diff suppressed because it is too large Load diff

20
ta6ob/nanopass/nanopass.ss Normal file
View file

@ -0,0 +1,20 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass)
(export define-language define-parser define-unparser trace-define-parser
trace-define-pass echo-define-pass define-pass with-output-language
nanopass-case language->s-expression extends entry terminals
nongenerative-id maybe #;define-nanopass-record-types diff-languages
define-language-node-counter prune-language define-pruned-language
with-extended-quasiquote with-r6rs-quasiquote pass-input-parser
pass-output-unparser pass-identifier? pass-input-language
pass-output-language)
(import
(nanopass language)
(nanopass parser)
(nanopass unparser)
(nanopass language-node-counter)
(nanopass pass)
(nanopass helpers)
(nanopass records)))

297
ta6ob/nanopass/nanopass/exp-syntax.sls Normal file
View file

@ -0,0 +1,297 @@
(library (nanopass exp-syntax)
(export
define-language-exp
inspect-language lookup-language
Llanguage unparse-Llanguage
Lannotated unparse-Lannotated
language->s-expression-exp
prune-language-exp
define-pruned-language-exp
diff-languages-exp
define-language-node-counter-exp
define-unparser-exp
define-parser-exp
)
(import (rnrs) (nanopass) (nanopass experimental) (nanopass helpers)
(only (chezscheme) make-compile-time-value trace-define-syntax unbox
optimize-level enumerate with-output-to-string errorf))
(define-syntax define-language-exp
(lambda (x)
(lambda (rho)
(syntax-case x ()
[(_ . rest)
(let* ([lang (parse-np-source x 'define-language-exp)]
[lang (handle-language-extension lang 'define-language-exp rho)]
[lang (check-and-finish-language lang)]
[lang-annotated (annotate-language lang)])
(nanopass-case (Llanguage Defn) lang
[(define-language ,id ,cl* ...)
#`(begin
(define-language . rest)
(define-property #,id experimental-language
(make-language-information '#,lang '#,lang-annotated))
(define-language-records #,id)
#;(define-language-predicates #,id))]))]))))
(define-syntax inspect-language
(lambda (x)
(lambda (rho)
(syntax-case x ()
[(_ name)
(let ([lang (rho #'name)])
(if lang
(let ([l (language-information-language lang)]
[a (language-information-annotated-language lang)])
#`(list
'#,l
'#,(datum->syntax #'* (unparse-Llanguage l))
'#,a
'#,(datum->syntax #'* (unparse-Lannotated a))))
(syntax-violation 'inspect-language "no language found" #'name)))]))))
(define (build-list-of-string level name)
(with-output-to-string
(lambda ()
(let loop! ([level level])
(if (fx=? level 0)
(write name)
(begin (display "list of ") (loop! (fx- level 1))))))))
(define-syntax define-language-records
(lambda (x)
(define-pass construct-records : Lannotated (ir) -> * (stx)
(definitions
(define (build-field-check name mv level pred)
#`(lambda (x msg)
(define (squawk level x)
(if msg
(errorf who "expected ~a but received ~s in field ~s from ~a"
(build-list-of-string level '#,name) x '#,mv msg)
(errorf who "expected ~a but received ~s in field ~s"
(build-list-of-string level '#,name) x '#,mv)))
#,(let f ([level level])
(if (fx=? level 0)
#`(lambda (x) (unless (#,pred x) (squawk #,level x)))
#`(lambda (x)
(let loop ([x x])
(cond
[(pair? x) (#,(f (fx- level 1)) (car x))]
[(null? x)]
[else (squawk #,level x)]))))))))
(Defn : Defn (ir) -> * (stx)
[(define-language ,id ,ref ,id0? ,rtd ,rcd ,tag-mask (,term* ...) ,[nt*] ...)
#`(begin #,@nt*)])
(Nonterminal : Nonterminal (ir) -> * (stx)
[(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...)
(let ([stx* (map (lambda (prod) (Production prod rcd)) prod*)])
#`(begin (define #,pred (record-predicate '#,rtd)) #,@stx*))])
(Production : Production (ir nt-rcd) -> * (stx)
[(production ,pattern ,pretty-prod? ,rtd ,tag ,pred ,maker ,[mv* acc* check*] ...)
(with-syntax ([(mv* ...) mv*]
[(msg* ...) (generate-temporaries mv*)]
[(check* ...) check*]
[(acc* ...) acc*]
[(idx ...) (enumerate acc*)])
#`(begin
(define #,maker
(let ()
(define maker
(record-constructor
(make-record-constructor-descriptor '#,rtd '#,nt-rcd
(lambda (pargs->new)
(lambda (mv* ...)
((pargs->new #,tag) mv* ...))))))
(lambda (who mv* ... msg* ...)
#,@(if (fx=? (optimize-level) 3)
'()
#`((check* mv* msg*) ...))
(maker mv* ...))))
(define #,pred (record-predicate '#,rtd))
(define acc* (record-accessor '#,rtd idx)) ...))]
[else #'(begin)])
(Field : Field (ir) -> * (mv check acc)
[(,[mv name pred] ,level ,accessor)
(values mv accessor (build-field-check name mv level pred))]
[(optional ,[mv name pred] ,level ,accessor)
(values mv accessor
(build-field-check name mv level
#`(lambda (x) (or (eq? x #f) (#,pred x)))))])
(Reference : Reference (ir) -> * (mv name pred)
[(term-ref ,id0 ,id1 ,b)
(values id0 id1 (TerminalPred (unbox b)))]
[(nt-ref ,id0 ,id1 ,b)
(values id0 id1 (NonterminalPred (unbox b)))])
(TerminalPred : Terminal (ir) -> * (name pred)
[(,id (,id* ...) ,b ,handler? ,pred) pred])
(NonterminalPred : Nonterminal (ir) -> * (name pred)
[(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...)
all-pred])
(Defn ir))
(syntax-case x ()
[(_ name)
(lambda (rho)
(let ([lang (lookup-language rho #'name)])
(construct-records (language-information-annotated-language lang))))])))
(define-syntax define-language-predicates
(lambda (x)
(define-pass language-predicates : Lannotated (ir) -> * (stx)
(definitions
(define (set-cons x ls)
(if (memq x ls)
ls
(cons x ls))))
(Defn : Defn (ir) -> * (stx)
[(define-language ,id ,ref ,id0? ,rtd ,rcd ,tag-mask (,term* ...) ,nt* ...)
(let loop ([nt* nt*] [ntpreddef* '()] [tpred* '()])
(if (null? nt*)
(with-syntax ([pred (construct-id id id "?")]
[(tpred* ...) tpred*])
#`(begin
(define pred
(lambda (x)
(or ((record-predicate '#,rtd) x) (tpred* x) ...)))
#,@ntpreddef*))
(let-values ([(ntpreddef* tpred*) (Nonterminal (car nt*) ntpreddef* tpred*)])
(loop (cdr nt*) ntpreddef* tpred*))))])
(Nonterminal : Nonterminal (nt ntpreddef* lang-tpred*) -> * (ntpreddef* lang-tpred*)
[(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...)
(let loop ([prod* prod*] [pred* '()] [lang-tpred* lang-tpred*])
(if (null? prod*)
(values
(cons
(with-syntax ([(pred* ...) pred*])
#`(define #,all-pred
(lambda (x)
(or ((record-predicate '#,rtd) x) (pred* x) ...))))
ntpreddef*)
lang-tpred*)
(let-values ([(tpred* lang-tpred*) (Production (car prod*) pred* lang-tpred*)])
(loop (cdr prod*) tpred* lang-tpred*))))])
(Production : Production (ir pred* lang-tpred*) -> * (pred* lang-tpred*)
[(terminal (term-ref ,id0 ,id1 ,b) ,pretty-prod?)
(let ([pred (TerminalPred (unbox b))])
(values (cons pred pred*) (set-cons pred lang-tpred*)))]
[(nonterminal (nt-ref ,id0 ,id1 ,b) ,pretty-prod?)
(values (cons (NonterminalPred (unbox b)) pred*) lang-tpred*)]
[else (values pred* lang-tpred*)])
(TerminalPred : Terminal (ir) -> * (pred)
[(,id (,id* ...) ,b ,handler? ,pred) pred])
(NonterminalPred : Nonterminal (ir) -> * (pred)
[(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...) all-pred])
(Defn ir))
(syntax-case x ()
[(_ name)
(lambda (rho)
(let ([lang (lookup-language rho #'name)])
(language-predicates (language-information-annotated-language lang))))])))
(define-syntax language->s-expression-exp
(lambda (x)
(define-pass lang->sexp : Llanguage (ir) -> * (sexp)
(Defn : Defn (ir) -> * (sexp)
[(define-language ,id ,[cl*] ...)
`(define-language ,(syntax->datum id) . ,cl*)])
(Clause : Clause (ir) -> * (sexp)
[(entry ,[sym]) `(entry ,sym)]
[(nongenerative-id ,id)
`(nongenerative-id ,(syntax->datum id))]
[(terminals ,[term*] ...)
`(terminals . ,term*)]
[(,id (,id* ...) ,b ,[prod*] ...)
`(,(syntax->datum id) ,(map syntax->datum id*) . ,prod*)])
(Terminal : Terminal (ir) -> * (sexp)
[,simple-term (SimpleTerminal simple-term)]
[(=> ,[simple-term] ,handler)
`(=> ,simple-term ,(syntax->datum handler))])
(SimpleTerminal : SimpleTerminal (ir) -> * (sexp)
[(,id (,id* ...) ,b)
`(,(syntax->datum id) ,(map syntax->datum id*))])
(Production : Production (ir) -> * (sexp)
[,pattern (Pattern pattern)]
[(=> ,[pattern0] ,[pattern1])
`(=> ,pattern0 ,pattern1)]
[(-> ,[pattern] ,handler)
`(-> ,pattern ,(syntax->datum handler))])
(Pattern : Pattern (ir) -> * (sexp)
[(maybe ,[sym]) `(maybe ,sym)]
[,ref (Reference ref)]
[,id (syntax->datum id)]
[(,[pattern0] ,dots . ,[pattern1])
`(,pattern0 ... . ,pattern1)]
[(,[pattern0] . ,[pattern1])
`(,pattern0 . ,pattern1)]
[,null '()])
(Reference : Reference (ir) -> * (sym)
[(term-ref ,id0 ,id1 ,b) (syntax->datum id0)]
[(nt-ref ,id0 ,id1 ,b) (syntax->datum id0)])
(Defn ir))
(syntax-case x ()
[(_ name)
(lambda (rho)
(let ([lang (lookup-language rho #'name)])
#`'#,(datum->syntax #'*
(lang->sexp
(language-information-language lang)))))])))
(define-syntax prune-language-exp
(lambda (x)
(syntax-case x ()
[(_ name)
(lambda (rho)
(let ([lang (lookup-language rho #'name)])
(with-syntax ([pl (prune-lang
(language-information-annotated-language lang)
'prune-language-exp
#f)])
#'(quote pl))))])))
(define-syntax define-pruned-language-exp
(lambda (x)
(syntax-case x ()
[(_ name new-name)
(lambda (rho)
(let ([lang (lookup-language rho #'name)])
(prune-lang
(language-information-annotated-language lang)
'define-pruned-language-exp
#'new-name)))])))
(define-syntax diff-languages-exp
(lambda (x)
(syntax-case x ()
[(_ name0 name1)
(lambda (rho)
(let ([lang0 (lookup-language rho #'name0)]
[lang1 (lookup-language rho #'name1)])
(with-syntax ([diff (diff-langs
(language-information-language lang0)
(language-information-language lang1))])
#'(quote diff))))])))
(define-syntax define-language-node-counter-exp
(lambda (x)
(syntax-case x ()
[(_ name lang)
(lambda (rho)
(let ([l (lookup-language rho #'lang)])
(build-lang-node-counter (language-information-annotated-language l) #'name)))])))
(define-syntax define-unparser-exp
(lambda (x)
(syntax-case x ()
[(_ name lang)
(lambda (rho)
(let ([l (lookup-language rho #'lang)])
(build-unparser (language-information-annotated-language l) #'name)))])))
(define-syntax define-parser-exp
(lambda (x)
(syntax-case x ()
[(_ name lang)
(lambda (rho)
(let ([l (lookup-language rho #'lang)])
(build-parser (language-information-annotated-language l) #'name)))])))
)

1636
ta6ob/nanopass/nanopass/experimental.sls Normal file
View file

File diff suppressed because it is too large Load diff

453
ta6ob/nanopass/nanopass/helpers.ss Normal file
View file

@ -0,0 +1,453 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass helpers)
(export
;; auxiliary keywords for language/pass definitions
extends definitions entry terminals nongenerative-id maybe
;; predicates for looking for identifiers independent of context
ellipsis? unquote? colon? arrow? plus? minus? double-arrow?
;; things for dealing with syntax and idetnfieris
all-unique-identifiers? construct-id construct-unique-id gentemp
bound-id-member? bound-id-union partition-syn datum
;; things for dealing with language meta-variables
meta-var->raw-meta-var combine unique-name
;; convenience syntactic forms
rec with-values define-who trace-define-who
;; source information funtions
syntax->source-info
;;; stuff imported from implementation-helpers
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
define-property make-compile-time-value
;; code organization helpers
module
;; useful for warning items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; handy syntactic stuff
with-implicit with-r6rs-quasiquote with-extended-quasiquote
extended-quasiquote with-auto-unquote
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, & Vicare
with-compile-time-environment
;; expose the source information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information)
(import (rnrs) (nanopass implementation-helpers))
(define-syntax datum
(syntax-rules ()
[(_ e) (syntax->datum #'e)]))
(define-syntax with-r6rs-quasiquote
(lambda (x)
(syntax-case x ()
[(k . body)
#`(let-syntax ([#,(datum->syntax #'k 'quasiquote) (syntax-rules () [(_ x) `x])])
. body)])))
(define-syntax extended-quasiquote
(lambda (x)
(define gather-unquoted-exprs
(lambda (body)
(let f ([body body] [t* '()] [e* '()])
(syntax-case body (unquote unquote-splicing)
[(unquote x)
(identifier? #'x)
(if (memp (lambda (t) (bound-identifier=? t #'x)) t*)
(values body t* e*)
(values body (cons #'x t*) (cons #'x e*)))]
[(unquote-splicing x)
(identifier? #'x)
(if (memp (lambda (t) (bound-identifier=? t #'x)) t*)
(values body t* e*)
(values body (cons #'x t*) (cons #'x e*)))]
[(unquote e)
(with-syntax ([(t) (generate-temporaries '(t))])
(values #'(unquote t) (cons #'t t*) (cons #'e e*)))]
[(unquote-splicing e)
(with-syntax ([(t) (generate-temporaries '(t))])
(values #'(unquote-splicing t) (cons #'t t*) (cons #'e e*)))]
[(tmpl0 . tmpl1)
(let-values ([(tmpl0 t* e*) (f #'tmpl0 t* e*)])
(let-values ([(tmpl1 t* e*) (f #'tmpl1 t* e*)])
(values #`(#,tmpl0 . #,tmpl1) t* e*)))]
[atom (values #'atom t* e*)]))))
(define build-list
(lambda (body orig-level)
(let loop ([body body] [level orig-level])
(syntax-case body (unquote unquote-splicing)
[(tmpl0 ... (unquote e))
(with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))])
(cond
[(fx=? level 0) #'(tmpl0 ... (unquote e))]
[(fx=? level 1) #'(tmpl0 ... (unquote-splicing e))]
[else (let loop ([level level] [e #'e])
(if (fx=? level 1)
#`(tmpl0 ... (unquote-splicing #,e))
(loop (fx- level 1) #`(apply append #,e))))]))]
[(tmpl0 ... (unquote-splicing e))
(with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))])
(cond
[(fx=? level 0) #'(tmpl0 ... (unquote-splicing e))]
[else (let loop ([level level] [e #'e])
(if (fx=? level 0)
#`(tmpl0 ... (unquote-splicing #,e))
(loop (fx- level 1) #`(apply append #,e))))]))]
[(tmpl0 ... tmpl1 ellipsis)
(eq? (datum ellipsis) '...)
(loop #'(tmpl0 ... tmpl1) (fx+ level 1))]
[(tmpl0 ... tmpl1)
(with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))])
(let-values ([(tmpl1 t* e*) (gather-unquoted-exprs #'tmpl1)])
(when (null? e*)
(syntax-violation 'extended-quasiquote
"no variables found in ellipsis expression" body))
(let loop ([level level]
[e #`(map (lambda #,t*
(extended-quasiquote
#,tmpl1))
. #,e*)])
(if (fx=? level 1)
#`(tmpl0 ... (unquote-splicing #,e))
(loop (fx- level 1) #`(apply append #,e))))))]))))
(define rebuild-body
(lambda (body level)
(syntax-case body (unquote unquote-splicing)
[(unquote e) #'(unquote e)]
[(unquote-splicing e) #'(unquote-splicing e)]
[(tmpl0 ... tmpl1 ellipsis)
(eq? (datum ellipsis) '...)
(with-syntax ([(tmpl0 ...) (build-list #'(tmpl0 ... tmpl1) (fx+ level 1))])
#'(tmpl0 ...))]
[(tmpl0 ... tmpl1 ellipsis . tmpl2)
(eq? (datum ellipsis) '...)
(with-syntax ([(tmpl0 ...) (build-list #'(tmpl0 ... tmpl1) (fx+ level 1))]
[tmpl2 (rebuild-body #'tmpl2 level)])
#'(tmpl0 ... . tmpl2))]
[(tmpl0 ... tmpl1)
(with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) level)]
[tmpl1 (rebuild-body #'tmpl1 level)])
#'(tmpl0 ... tmpl1))]
[(tmpl0 ... tmpl1 . tmpl2)
(with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ... tmpl1) level)]
[tmpl2 (rebuild-body #'tmpl2 level)])
#'(tmpl0 ... . tmpl2))]
[other #'other])))
(syntax-case x ()
[(k body)
(with-syntax ([body (rebuild-body #'body 0)])
#'(quasiquote body))])))
(define-syntax with-extended-quasiquote
(lambda (x)
(syntax-case x ()
[(k . body)
(with-implicit (k quasiquote)
#'(let-syntax ([quasiquote (syntax-rules ()
[(_ x) (extended-quasiquote x)])])
. body))])))
(define-syntax with-auto-unquote
(lambda (x)
(syntax-case x ()
[(k (x* ...) . body)
(with-implicit (k quasiquote)
#'(let-syntax ([quasiquote
(lambda (x)
(define replace-vars
(let ([vars (list #'x* ...)])
(lambda (b)
(let f ([b b])
(syntax-case b ()
[id (identifier? #'id)
(if (memp (lambda (var) (free-identifier=? var #'id)) vars)
#'(unquote id)
#'id)]
[(a . d) (with-syntax ([a (f #'a)] [d (f #'d)]) #'(a . d))]
[atom #'atom])))))
(syntax-case x ()
[(_ b)
(with-syntax ([b (replace-vars #'b)])
#'`b)]))])
. body))])))
(define all-unique-identifiers?
(lambda (ls)
(and (for-all identifier? ls)
(let f ([ls ls])
(if (null? ls)
#t
(let ([id (car ls)] [ls (cdr ls)])
(and (not (memp (lambda (x) (free-identifier=? x id)) ls))
(f ls))))))))
(define-syntax with-values
(syntax-rules ()
[(_ p c) (call-with-values (lambda () p) c)]))
(define-syntax rec
(syntax-rules ()
[(_ name proc) (letrec ([name proc]) name)]
[(_ (name . arg) body body* ...)
(letrec ([name (lambda arg body body* ...)]) name)]))
(define-syntax define-auxiliary-keyword
(syntax-rules ()
[(_ name)
(define-syntax name
(lambda (x)
(syntax-violation 'name "misplaced use of auxiliary keyword" x)))]))
(define-syntax define-auxiliary-keywords
(syntax-rules ()
[(_ name* ...)
(begin (define-auxiliary-keyword name*) ...)]))
(define-auxiliary-keywords extends definitions entry terminals nongenerative-id maybe)
(define-syntax define-who
(lambda (x)
(syntax-case x ()
[(k name expr)
(with-implicit (k who)
#'(define name (let () (define who 'name) expr)))]
[(k (name . fmls) expr exprs ...)
#'(define-who name (lambda (fmls) expr exprs ...))])))
(define-syntax trace-define-who
(lambda (x)
(syntax-case x ()
[(k name expr)
(with-implicit (k who)
#'(trace-define name (let () (define who 'name) expr)))]
[(k (name . fmls) expr exprs ...)
#'(trace-define-who name (lambda (fmls) expr exprs ...))])))
;;; moved from meta-syntax-dispatch.ss and nano-syntax-dispatch.ss
(define combine
(lambda (r* r)
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))
;;; moved from meta-syntax-dispatch.ss and syntaxconvert.ss
(define ellipsis?
(lambda (x)
(and (identifier? x) (free-identifier=? x (syntax (... ...))))))
(define unquote?
(lambda (x)
(and (identifier? x) (free-identifier=? x (syntax unquote)))))
(define unquote-splicing?
(lambda (x)
(and (identifier? x) (free-identifier=? x (syntax unquote-splicing)))))
(define plus?
(lambda (x)
(and (identifier? x)
(or (free-identifier=? x #'+)
(eq? (syntax->datum x) '+)))))
(define minus?
(lambda (x)
(and (identifier? x)
(or (free-identifier=? x #'-)
(eq? (syntax->datum x) '-)))))
(define double-arrow?
(lambda (x)
(and (identifier? x)
(or (free-identifier=? x #'=>)
(eq? (syntax->datum x) '=>)))))
(define colon?
(lambda (x)
(and (identifier? x)
(or (free-identifier=? x #':)
(eq? (syntax->datum x) ':)))))
(define arrow?
(lambda (x)
(and (identifier? x)
(or (free-identifier=? x #'->)
(eq? (syntax->datum x) '->)))))
;;; unique-name produces a unique name derived the input name by
;;; adding a unique suffix of the form .<digit>+. creating a unique
;;; name from a unique name has the effect of replacing the old
;;; unique suffix with a new one.
(define unique-suffix
(let ((count 0))
(lambda ()
(set! count (+ count 1))
(number->string count))))
(define unique-name
(lambda (id . id*)
(string-append
(fold-right
(lambda (id str) (string-append str ":" (symbol->string (syntax->datum id))))
(symbol->string (syntax->datum id)) id*)
"."
(unique-suffix))))
; TODO: at some point we may want this to be a little bit more
; sophisticated, or we may want to have something like a regular
; expression style engine where we bail as soon as we can identify
; what the meta-var corresponds to.
(define meta-var->raw-meta-var
(lambda (sym)
(let ([s (symbol->string sym)])
(let f ([i (fx- (string-length s) 1)])
(cond
[(fx=? i -1) sym]
[(or (char=? #\* (string-ref s i))
(char=? #\^ (string-ref s i))
(char=? #\? (string-ref s i)))
(f (fx- i 1))]
[else (let f ([i i])
(cond
[(fx=? i -1) sym]
[(char-numeric? (string-ref s i)) (f (fx- i 1))]
[else (string->symbol (substring s 0 (fx+ i 1)))]))])))))
(define build-id
(lambda (who x x*)
(define ->str
(lambda (x)
(cond
[(string? x) x]
[(identifier? x) (symbol->string (syntax->datum x))]
[(symbol? x) (symbol->string x)]
[else (error who "invalid input ~s" x)])))
(apply string-append (->str x) (map ->str x*))))
(define $construct-id
(lambda (who str->sym tid x x*)
(unless (identifier? tid)
(error who "template argument ~s is not an identifier" tid))
(datum->syntax tid (str->sym (build-id who x x*)))))
(define-who construct-id
(lambda (tid x . x*)
($construct-id who string->symbol tid x x*)))
(define-who construct-unique-id
(lambda (tid x . x*)
($construct-id who gensym tid x x*)))
(define-syntax partition-syn
(lambda (x)
(syntax-case x ()
[(_ ls-expr () e0 e1 ...) #'(begin ls-expr e0 e1 ...)]
[(_ ls-expr ([set pred] ...) e0 e1 ...)
(with-syntax ([(pred ...)
(let f ([preds #'(pred ...)])
(if (null? (cdr preds))
(if (free-identifier=? (car preds) #'otherwise)
(list #'(lambda (x) #t))
preds)
(cons (car preds) (f (cdr preds)))))])
#'(let-values ([(set ...)
(let f ([ls ls-expr])
(if (null? ls)
(let ([set '()] ...) (values set ...))
(let-values ([(set ...) (f (cdr ls))])
(cond
[(pred (car ls))
(let ([set (cons (car ls) set)])
(values set ...))]
...
[else (error 'partition-syn
"no home for ~s"
(car ls))]))))])
e0 e1 ...))])))
(define gentemp
(lambda ()
(car (generate-temporaries '(#'t)))))
(define bound-id-member?
(lambda (id id*)
(and (not (null? id*))
(or (bound-identifier=? id (car id*))
(bound-id-member? id (cdr id*))))))
(define bound-id-union ; seems to be unneeded
(lambda (ls1 ls2)
(cond
[(null? ls1) ls2]
[(bound-id-member? (car ls1) ls2) (bound-id-union (cdr ls1) ls2)]
[else (cons (car ls1) (bound-id-union (cdr ls1) ls2))])))
(define syntax->source-info
(lambda (stx)
(let ([si (syntax->source-information stx)])
(and si
(cond
[(and (source-information-position-line si)
(source-information-position-column si))
(format "~s line ~s, char ~s of ~a"
(source-information-type si)
(source-information-position-line si)
(source-information-position-column si)
(source-information-source-file si))]
[(source-information-byte-offset-start si)
(format "~s byte position ~s of ~a"
(source-information-type si)
(source-information-byte-offset-start si)
(source-information-source-file si))]
[(source-information-char-offset-start si)
(format "~s character position ~s of ~a"
(source-information-type si)
(source-information-char-offset-start si)
(source-information-source-file si))]
[else (format "in ~a" (source-information-source-file si))]))))))

203
ta6ob/nanopass/nanopass/implementation-helpers.chezscheme.sls Normal file
View file

@ -0,0 +1,203 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
#!chezscheme
(library (nanopass implementation-helpers)
(export
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; source-information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
define-property make-compile-time-value
;; code organization helpers
module
;; useful for warning items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; handy syntactic stuff
with-implicit
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, & Vicare
with-compile-time-environment
;; apparently not neeaded (or no longer needed)
; scheme-version= scheme-version< scheme-version> scheme-version>=
; scheme-version<= with-scheme-version gensym? errorf with-output-to-string
; with-input-from-string
)
(import (chezscheme))
; the base language
(define-syntax define-nanopass-record
(lambda (x)
(syntax-case x ()
[(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag)
#'(define-record-type (nanopass-record make-nanopass-record nanopass-record?)
(nongenerative #{nanopass-record d47f8omgluol6otrw1yvu5-0})
(fields (immutable tag nanopass-record-tag))))])))
;; the following should get moved into Chez Scheme proper (and generally
;; cleaned up with appropriate new Chez Scheme primitives for support)
(define regensym
(case-lambda
[(gs extra)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra) (errorf 'regensym "~s is not a string" extra))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a ~a~a}" pretty-name unique-name extra) read))]
[(gs extra0 extra1)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra0) (errorf 'regensym "~s is not a string" extra0))
(unless (string? extra1) (errorf 'regensym "~s is not a string" extra1))
(with-output-to-string (lambda () (format "~s" gs)))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a~a ~a~a}" pretty-name extra0 unique-name extra1) read))]))
(define-syntax define-scheme-version-relop
(lambda (x)
(syntax-case x ()
[(_ name relop strict-inequality?)
#`(define name
(lambda (ls)
(let-values ([(a1 b1 c1) (scheme-version-number)]
[(a2 b2 c2)
(cond
[(fx= (length ls) 1) (values (car ls) 0 0)]
[(fx= (length ls) 2) (values (car ls) (cadr ls) 0)]
[(fx= (length ls) 3) (values (car ls) (cadr ls) (caddr ls))])])
#,(if (datum strict-inequality?)
#'(or (relop a1 a2)
(and (fx= a1 a2)
(or (relop b1 b2)
(and (fx= b1 b2)
(relop c1 c2)))))
#'(and (relop a1 a2) (relop b1 b2) (relop c1 c2))))))])))
(define-scheme-version-relop scheme-version= fx= #f)
(define-scheme-version-relop scheme-version< fx< #t)
(define-scheme-version-relop scheme-version> fx> #t)
(define-scheme-version-relop scheme-version<= fx<= #f)
(define-scheme-version-relop scheme-version>= fx>= #f)
(define-syntax with-scheme-version
(lambda (x)
(define-scheme-version-relop scheme-version= fx= #f)
(define-scheme-version-relop scheme-version< fx< #t)
(define-scheme-version-relop scheme-version> fx> #t)
(define-scheme-version-relop scheme-version<= fx<= #f)
(define-scheme-version-relop scheme-version>= fx>= #f)
(define finish
(lambda (pat* e** elsee*)
(if (null? pat*)
#`(begin #,@elsee*)
(or (and (syntax-case (car pat*) (< <= = >= >)
[(< v ...) (scheme-version< (datum (v ...)))]
[(<= v ...) (scheme-version<= (datum (v ...)))]
[(= v ...) (scheme-version= (datum (v ...)))]
[(>= v ...) (scheme-version>= (datum (v ...)))]
[(> v ...) (scheme-version> (datum (v ...)))]
[else #f])
#`(begin #,@(car e**)))
(finish (cdr pat*) (cdr e**) elsee*)))))
(syntax-case x (else)
[(_ [pat e1 e2 ...] ... [else ee1 ee2 ...])
(finish #'(pat ...) #'((e1 e2 ...) ...) #'(ee1 ee2 ...))]
[(_ [pat e1 e2 ...] ...)
(finish #'(pat ...) #'((e1 e2 ...) ...) #'())])))
(define provide-full-source-information
(make-parameter #t (lambda (n) (and n #t))))
(define-record-type source-information
(nongenerative)
(sealed #t)
(fields source-file byte-offset-start char-offset-start byte-offset-end
char-offset-end position-line position-column type)
(protocol
(lambda (new)
(lambda (a type)
(let ([so (annotation-source a)])
(let ([sfd (source-object-sfd so)]
[bfp (source-object-bfp so)]
[efp (source-object-efp so)])
(if (provide-full-source-information)
(let ([ip (open-source-file sfd)])
(let loop ([n bfp] [line 1] [col 1])
(if (= n 0)
(let ([byte-offset-start (port-position ip)])
(let loop ([n (- efp bfp)])
(if (= n 0)
(let ([byte-offset-end (port-position ip)])
(close-input-port ip)
(new (source-file-descriptor-path sfd)
byte-offset-start bfp
byte-offset-end efp
line col type))
(let ([c (read-char ip)]) (loop (- n 1))))))
(let ([c (read-char ip)])
(if (char=? c #\newline)
(loop (- n 1) (fx+ line 1) 1)
(loop (- n 1) line (fx+ col 1)))))))
(new (source-file-descriptor-path sfd)
#f bfp #f efp #f #f type))))))))
(define syntax->source-information
(lambda (stx)
(let loop ([stx stx] [type 'at])
(cond
[(syntax->annotation stx) =>
(lambda (a) (make-source-information a type))]
[(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))]
[else #f]))))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(_ (arg) body* ... body) (lambda (arg) body* ... body)]))
(with-scheme-version
[(< 8 3 1)
(define syntax->annotation (lambda (x) #f))
(define annotation-source (lambda (x) (errorf 'annotation-source "unsupported before version 8.4")))
(define source-object-bfp (lambda (x) (errorf 'source-object-bfp "unsupported before version 8.4")))
(define source-object-sfd (lambda (x) (errorf 'source-object-sfd "unsupported before version 8.4")))
(define source-file-descriptor-path (lambda (x) (errorf 'source-file-descriptor-path "unsupported before version 8.4")))])
(with-scheme-version
[(< 8 1) (define-syntax indirect-export (syntax-rules () [(_ id indirect-id ...) (define t (if #f #f))]))]))

185
ta6ob/nanopass/nanopass/implementation-helpers.ikarus.ss Normal file
View file

@ -0,0 +1,185 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass implementation-helpers)
(export
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; source-information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
define-property make-compile-time-value
;; code organization helpers
module
;; useful for warning and error items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; handy syntactic stuff
with-implicit
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, & Vicare
with-compile-time-environment
;; apparently not neeaded (or no longer needed)
; scheme-version= scheme-version< scheme-version> scheme-version>=
; scheme-version<= with-scheme-version gensym? errorf with-output-to-string
; with-input-from-string
)
(import (rnrs) (rnrs eval) (ikarus) (nanopass syntactic-property))
(define-syntax with-implicit
(syntax-rules ()
[(_ (id name ...) body bodies ...)
(with-syntax ([name (datum->syntax #'id 'name)] ...) body bodies ...)]))
; the base language
(define-syntax define-nanopass-record
(lambda (x)
(syntax-case x ()
[(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag)
#'(define-record-type (nanopass-record make-nanopass-record nanopass-record?)
(nongenerative #{nanopass-record d47f8omgluol6otrw1yvu5-0})
(fields (immutable tag nanopass-record-tag))))])))
(define-syntax eq-hashtable-set! (identifier-syntax hashtable-set!))
(define-syntax eq-hashtable-ref (identifier-syntax hashtable-ref))
(define list-head
(lambda (orig-ls orig-n)
(let f ([ls orig-ls] [n orig-n])
(cond
[(fxzero? n) '()]
[(null? ls) (error 'list-head "index out of range" orig-ls orig-n)]
[else (cons (car ls) (f (cdr ls) (fx- n 1)))]))))
(define iota
(lambda (n)
(let loop ([n n] [ls '()])
(if (fxzero? n)
ls
(let ([n (- n 1)])
(loop n (cons n ls)))))))
(define regensym
(case-lambda
[(gs extra)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra) (errorf 'regensym "~s is not a string" extra))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a ~a~a}" pretty-name unique-name extra) read))]
[(gs extra0 extra1)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra0) (errorf 'regensym "~s is not a string" extra0))
(unless (string? extra1) (errorf 'regensym "~s is not a string" extra1))
(with-output-to-string (lambda () (format "~s" gs)))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a~a ~a~a}" pretty-name extra0 unique-name extra1) read))]))
(define provide-full-source-information
(make-parameter #t (lambda (x) (and x #t))))
(define-record-type source-information
(nongenerative)
(sealed #t)
(fields source-file byte-offset-start char-offset-start byte-offset-end
char-offset-end position-line position-column type)
(protocol
(lambda (new)
(lambda (a type)
(let ([as (annotation-source a)])
(let ([fn (car as)] [cp (cdr as)])
(if (provide-full-source-information)
(call-with-input-file fn
(lambda (ip)
(let loop ([n cp] [line 1] [col 0])
(if (= n 0)
(new fn (port-position ip) cp #f #f line col type)
(let ([c (read-char ip)])
(if (char=? c #\newline)
(loop (- n 1) (fx+ line 1) 0)
(loop (- n 1) line (fx+ col 1))))))))
(new fn #f cp #f #f #f #f type))))))))
(define syntax->annotation
(lambda (x)
(and (struct? x) ;; syntax objects are structs
(string=? (struct-name x) "stx") ;; with the name syntax
(let ([e (struct-ref x 0)]) ;; the 0th element is potentially an annotation
(and (annotation? e) e))))) ;; if it is an annotation return it
(define syntax->source-information
(lambda (stx)
(let loop ([stx stx] [type 'at])
(cond
[(syntax->annotation stx) =>
(lambda (a) (make-source-information a type))]
[(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))]
[else #f]))))
(define-syntax errorf
(syntax-rules ()
[(_ who fmt args ...) (error who (format fmt args ...))]))
(define-syntax warningf
(syntax-rules ()
[(_ who fmt args ...) (warning who (format fmt args ...))]))
(define-syntax indirect-export
(syntax-rules ()
[(_ id indirect-id ...) (define t (if #f #f))]))
(define-syntax define-property
(lambda (x)
(syntax-case x ()
[(_ id key value)
(with-syntax ([t (datum->syntax #'id (gensym (syntax->datum #'id)))])
(syntax-property-set! #'id #'key (syntax->datum #'t))
#'(define-syntax waste (let () (set-symbol-value! 't value) (lambda (x) (syntax-violation #f "invalid syntax" x)))))])))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(k (arg) body* ... body)
(lambda (rho)
(let ([arg (case-lambda
[(x) (rho x)]
[(x y) (let ([sym (syntax-property-get x y #f)])
(and sym (symbol-value sym)))])])
body* ... body))])))

195
ta6ob/nanopass/nanopass/implementation-helpers.ironscheme.sls Normal file
View file

@ -0,0 +1,195 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass implementation-helpers)
(export
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; source-information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
define-property make-compile-time-value
;; code organization helpers
module
;; useful for warning and error items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; handy syntactic stuff
with-implicit
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, Vicare and IronScheme
with-compile-time-environment
;; apparently not neeaded (or no longer needed)
; scheme-version= scheme-version< scheme-version> scheme-version>=
; scheme-version<= with-scheme-version gensym? errorf with-output-to-string
; with-input-from-string
)
(import
(rnrs)
(rnrs eval)
(ironscheme)
(nanopass syntactic-property)
(ironscheme core)
(ironscheme clr)
(ironscheme reader))
(define optimize-level (make-parameter 0)) ;; not sure what this is used for (yet)
(define-syntax with-implicit
(syntax-rules ()
[(_ (id name ...) body bodies ...)
(with-syntax ([name (datum->syntax #'id 'name)] ...) body bodies ...)]))
; the base language
(define-syntax define-nanopass-record
(lambda (x)
(syntax-case x ()
[(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag)
#'(define-record-type (nanopass-record make-nanopass-record nanopass-record?)
(nongenerative nanopass-record-d47f8omgluol6otrw1yvu5-0)
(fields (immutable tag nanopass-record-tag))))])))
(define-syntax eq-hashtable-set! (identifier-syntax hashtable-set!))
(define-syntax eq-hashtable-ref (identifier-syntax hashtable-ref))
(define list-head
(lambda (orig-ls orig-n)
(let f ([ls orig-ls] [n orig-n])
(cond
[(fxzero? n) '()]
[(null? ls) (error 'list-head "index out of range" orig-ls orig-n)]
[else (cons (car ls) (f (cdr ls) (fx- n 1)))]))))
(define iota
(lambda (n)
(let loop ([n n] [ls '()])
(if (fxzero? n)
ls
(let ([n (fx- n 1)])
(loop n (cons n ls)))))))
(define (gensym? s) (eq? s (ungensym s)))
;; just stuffing info for now... I guess it is needed for prettiness only?
(define regensym
(case-lambda
[(gs extra)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra) (errorf 'regensym "~s is not a string" extra))
; (let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
; [unique-name (gensym->unique-string gs)])
; (with-input-from-string (format "~a-~a~a" pretty-name unique-name extra) read))
(gensym (format "~a~a" gs extra))]
[(gs extra0 extra1)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra0) (errorf 'regensym "~s is not a string" extra0))
(unless (string? extra1) (errorf 'regensym "~s is not a string" extra1))
; (with-output-to-string (lambda () (format "~s" gs)))
; (let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
; [unique-name (gensym->unique-string gs)])
; (with-input-from-string (format "~a~a-~a~a" pretty-name extra0 unique-name extra1) read))
(gensym (format "~a~a~a" gs extra0 extra1))
]))
(define provide-full-source-information
(make-parameter #f (lambda (x) (and x #t))))
(define-record-type source-information
(nongenerative)
(sealed #t)
(fields source-file byte-offset-start char-offset-start byte-offset-end
char-offset-end position-line position-column type)
(protocol
(lambda (new)
(lambda (a type)
(let* ([as (annotation-source a)][cp (car (clr-static-call IronScheme.Runtime.Builtins SourceLocation (cdr as)))])
(let ([fn (car as)] [line (car cp)][col (cdr cp)])
;; the line/col info from the reader is pretty accurate, do I need the stuff below?
(if (provide-full-source-information)
(call-with-input-file fn
(lambda (ip)
(let loop ([n cp] [line 1] [col 0])
(if (= n 0)
(new fn (port-position ip) cp #f #f line col type)
(let ([c (read-char ip)])
(if (char=? c #\newline)
(loop (- n 1) (fx+ line 1) 0)
(loop (- n 1) line (fx+ col 1))))))))
(new fn #f #f #f #f line col type))))))))
(define syntax->source-information
(lambda (stx)
(let loop ([stx stx] [type 'at])
(cond
[(stx? stx)
(let ([e (stx-expr stx)])
(and (annotation? e) (make-source-information e type)))]
[(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))]
[else #f]))))
(define-syntax errorf
(syntax-rules ()
[(_ who fmt args ...) (error who (format fmt args ...))]))
(define-syntax warningf
(syntax-rules ()
[(_ who fmt args ...) (warning who (format fmt args ...))]))
(define-syntax indirect-export
(syntax-rules ()
[(_ id indirect-id ...) (define t (if #f #f))]))
(define-syntax define-property
(lambda (x)
(syntax-case x ()
[(_ id key value)
(with-syntax ([t (datum->syntax #'id (gensym (syntax->datum #'id)))])
(syntax-property-set! #'id #'key (syntax->datum #'t))
#'(define-syntax waste (let () (set-symbol-value! 't value) (lambda (x) (syntax-violation #f "invalid syntax" x)))))])))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(k (arg) body* ... body)
(lambda (rho)
(let ([arg (case-lambda
[(x) (rho x)]
[(x y) (let ([sym (syntax-property-get x y #f)])
(and sym (symbol-value sym)))])])
body* ... body))])))

174
ta6ob/nanopass/nanopass/implementation-helpers.vicare.sls Normal file
View file

@ -0,0 +1,174 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass implementation-helpers)
(export
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; source-information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
define-property (rename (make-expand-time-value make-compile-time-value))
;; code organization helpers
module
;; useful for warning and error items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; handy syntactic stuff
with-implicit
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, & Vicare
with-compile-time-environment
;; apparently not neeaded (or no longer needed)
; scheme-version= scheme-version< scheme-version> scheme-version>=
; scheme-version<= with-scheme-version gensym? errorf with-output-to-string
; with-input-from-string
)
(import
(vicare)
(vicare language-extensions)
(vicare language-extensions tracing-syntaxes)
(only (vicare expander) stx? stx-expr)
(only (vicare compiler) optimize-level))
(define-syntax with-implicit
(syntax-rules ()
[(_ (id name ...) body bodies ...)
(with-syntax ([name (datum->syntax #'id 'name)] ...) body bodies ...)]))
; the base language
(define-syntax define-nanopass-record
(lambda (x)
(syntax-case x ()
[(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag)
#'(define-record-type (nanopass-record make-nanopass-record nanopass-record?)
(nongenerative #{nanopass-record d47f8omgluol6otrw1yvu5-0})
(fields (immutable tag nanopass-record-tag))))])))
(define-syntax eq-hashtable-set! (identifier-syntax hashtable-set!))
(define-syntax eq-hashtable-ref (identifier-syntax hashtable-ref))
(define list-head
(lambda (orig-ls orig-n)
(let f ([ls orig-ls] [n orig-n])
(cond
[(fxzero? n) '()]
[(null? ls) (error 'list-head "index out of range" orig-ls orig-n)]
[else (cons (car ls) (f (cdr ls) (fx- n 1)))]))))
(define iota
(lambda (n)
(let loop ([n n] [ls '()])
(if (fxzero? n)
ls
(let ([n (- n 1)])
(loop n (cons n ls)))))))
(define regensym
(case-lambda
[(gs extra)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra) (errorf 'regensym "~s is not a string" extra))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a ~a~a}" pretty-name unique-name extra) read))]
[(gs extra0 extra1)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra0) (errorf 'regensym "~s is not a string" extra0))
(unless (string? extra1) (errorf 'regensym "~s is not a string" extra1))
(with-output-to-string (lambda () (format "~s" gs)))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a~a ~a~a}" pretty-name extra0 unique-name extra1) read))]))
(define provide-full-source-information
(make-parameter #t (lambda (x) (and x #t))))
(define-record-type source-information
(nongenerative)
(sealed #t)
(fields source-file byte-offset-start char-offset-start byte-offset-end
char-offset-end position-line position-column type)
(protocol
(lambda (new)
(lambda (a type)
(let ([sp (reader-annotation-textual-position a)])
(new
(source-position-port-id sp) (source-position-byte sp)
(source-position-character sp) #f #f (source-position-line sp)
(source-position-column sp) type))))))
(define syntax->source-information
(lambda (stx)
(let loop ([stx stx] [type 'at])
(cond
[(stx? stx)
(let ([e (stx-expr stx)])
(and (reader-annotation? e) (make-source-information e type)))]
[(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))]
[else #f]))))
(define-syntax warningf
(syntax-rules ()
[(_ who fmt args ...) (warning who (format fmt args ...))]))
(define-syntax errorf
(syntax-rules ()
[(_ who fmt args ...) (error who (format fmt args ...))]))
(define-syntax indirect-export
(syntax-rules ()
[(_ id indirect-id ...) (define t (if #f #f))]))
(define-syntax define-property
(lambda (x)
(syntax-case x ()
[(_ id key value)
(with-syntax ([t (datum->syntax #'id (gensym (syntax->datum #'id)))])
(syntactic-binding-putprop #'id (syntax->datum #'key) (syntax->datum #'t))
#'(define-syntax waste (let () (set-symbol-value! 't value) (lambda (x) (syntax-violation #f "invalid syntax" x)))))])))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(_ (arg) body* ... body)
(let ([arg (case-lambda
[(x) (retrieve-expand-time-value x)]
[(x y) (let ([sym (syntactic-binding-getprop x (syntax->datum y))])
(and sym (symbol-value sym)))])])
body* ... body)])))

59
ta6ob/nanopass/nanopass/language-helpers.ss Normal file
View file

@ -0,0 +1,59 @@
(library (nanopass language-helpers)
(export prune-language-helper)
(import (rnrs) (nanopass records))
(define tspec->ts-syntax
(lambda (tspec)
(with-syntax ([(meta-vars ...) (tspec-meta-vars tspec)]
[type (tspec-type tspec)])
#'(type (meta-vars ...)))))
(define ntspec->nts-syntax
(lambda (ntspec)
(with-syntax ([(meta-vars ...) (ntspec-meta-vars ntspec)]
[name (ntspec-name ntspec)]
[(prods ...) (map alt-syn (ntspec-alts ntspec))])
#'(name (meta-vars ...) prods ...))))
(define prune-language-helper
(lambda (l)
(let ([entry (language-entry-ntspec l)])
(let ([nt* (list (nonterm-id->ntspec 'prune-language entry (language-ntspecs l)))])
(let loop ([nt* nt*] [ts '()] [nts '()])
(if (null? nt*)
(with-syntax ([(ts ...) (map tspec->ts-syntax ts)]
[(nts ...) (map ntspec->nts-syntax nts)])
#'((ts ...) (nts ...)))
(let ([nt (car nt*)] [nt* (cdr nt*)])
(let ([nts (cons nt nts)])
(let inner-loop ([prod* (ntspec-alts nt)] [nt* nt*] [ts ts])
(if (null? prod*)
(loop nt* ts nts)
(let ([prod (car prod*)])
(cond
[(terminal-alt? prod)
(inner-loop (cdr prod*) nt*
(let ([tspec (terminal-alt-tspec prod)])
(if (memq tspec ts) ts (cons tspec ts))))]
[(nonterminal-alt? prod)
(inner-loop (cdr prod*)
(let ([ntspec (nonterminal-alt-ntspec prod)])
(if (or (memq ntspec nt*) (memq ntspec nts)) nt* (cons ntspec nt*)))
ts)]
[(pair-alt? prod)
(let inner-inner-loop ([flds (pair-alt-field-names prod)] [nt* nt*] [ts ts])
(if (null? flds)
(inner-loop (cdr prod*) nt* ts)
(let ([fld (car flds)])
(cond
[(meta-name->tspec fld (language-tspecs l)) =>
(lambda (tspec)
(inner-inner-loop (cdr flds) nt*
(if (memq tspec ts) ts (cons tspec ts))))]
[(meta-name->ntspec fld (language-ntspecs l)) =>
(lambda (ntspec)
(inner-inner-loop (cdr flds)
(if (or (memq ntspec nt*) (memq ntspec nts)) nt* (cons ntspec nt*))
ts))]))))])))))))))))))

101
ta6ob/nanopass/nanopass/language-node-counter.ss Normal file
View file

@ -0,0 +1,101 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep
;;; See the accompanying file Copyright for details
(library (nanopass language-node-counter)
(export define-language-node-counter)
(import (rnrs) (nanopass records) (nanopass helpers))
(define-syntax define-language-node-counter
(lambda (x)
(define make-ntspec-counter-assoc
(lambda (tid)
(lambda (ntspec)
(cons ntspec (construct-unique-id tid "count-" (ntspec-name ntspec))))))
(syntax-case x ()
[(_ name lang)
(and (identifier? #'name) (identifier? #'lang))
(lambda (r)
(let ([l-pair (r #'lang)])
(unless l-pair (syntax-violation 'define-language-node-counter (format "unknown language ~s" (datum lang)) #'name x))
(let ([l (car l-pair)])
(let ([ntspecs (language-ntspecs l)] [tspecs (language-tspecs l)])
(let ([counter-names (map (make-ntspec-counter-assoc #'name) ntspecs)])
(define lookup-counter
(lambda (ntspec)
(cond
[(assq ntspec counter-names) => cdr]
[else (syntax-violation 'define-language-node-counter
(format "unexpected nonterminal ~s in language ~s"
(syntax->datum (ntspec-name ntspec)) (datum lang))
#'name x)])))
(define build-counter-proc
(lambda (proc-name l)
(lambda (ntspec)
(let loop ([alt* (ntspec-alts ntspec)] [term* '()] [nonterm* '()] [pair* '()])
(if (null? alt*)
#`(lambda (x)
(cond
#,@term*
#,@pair*
#,@nonterm*
[else (errorf who "unrecognized term ~s" x)]))
(let ([alt (car alt*)] [alt* (cdr alt*)])
(cond
[(terminal-alt? alt)
(loop alt*
(cons #`[(#,(tspec-pred (terminal-alt-tspec alt)) x) 1] term*)
nonterm* pair*)]
[(nonterminal-alt? alt)
(let ([ntspec (nonterminal-alt-ntspec alt)])
(loop alt* term*
(cons #`[(#,(ntspec-all-pred ntspec) x)
(#,(lookup-counter ntspec) x)]
nonterm*)
pair*))]
[(pair-alt? alt)
(let inner-loop ([fld* (pair-alt-field-names alt)]
[lvl* (pair-alt-field-levels alt)]
[maybe?* (pair-alt-field-maybes alt)]
[acc* (pair-alt-accessors alt)]
[rec* '()])
(if (null? fld*)
(loop alt* term* nonterm*
(cons #`[(#,(pair-alt-pred alt) x) (+ 1 #,@rec*)] pair*))
(inner-loop (cdr fld*) (cdr lvl*) (cdr maybe?*) (cdr acc*)
(cons
(let ([fld (car fld*)] [maybe? (car maybe?*)] [acc (car acc*)])
(let ([spec (find-spec fld l)])
(if (ntspec? spec)
#`(let ([x (#,acc x)])
#,(let loop ([lvl (car lvl*)] [outer-most? #t])
(if (fx=? lvl 0)
(if maybe?
(if outer-most?
#`(if x (#,(lookup-counter spec) x) 0)
#`(+ a (if x (#,(lookup-counter spec) x) 0)))
(if outer-most?
#`(#,(lookup-counter spec) x)
#`(+ a (#,(lookup-counter spec) x))))
(if outer-most?
#`(fold-left
(lambda (a x) #,(loop (- lvl 1) #f))
0 x)
#`(fold-left
(lambda (a x) #,(loop (- lvl 1) #f))
a x)))))
0)))
rec*))))]
[else (syntax-violation 'define-language-node-counter
(format "unrecognized alt ~s building language node counter" (syntax->datum (alt-syn alt)))
proc-name x)])))))))
(with-syntax ([(ntspec? ...) (map ntspec-pred ntspecs)]
[(proc-name ...) (map cdr counter-names)]
[(tspec? ...) (map tspec-pred tspecs)]
[(proc ...) (map (build-counter-proc #'name l) ntspecs)])
#'(define-who name
(lambda (x)
(define proc-name proc) ...
(cond
[(ntspec? x) (proc-name x)] ...
[(tspec? x) 1] ...
[else (errorf who "unrecognized language record ~s" x)])))))))))]))))

536
ta6ob/nanopass/nanopass/language.ss Normal file
View file

@ -0,0 +1,536 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
;;; Producs are : record defs, parser, meta parser, lang
;;; may need to use meta define meta-parser.
;;;
;;; TODO:
;;; - add facility to allow for functional transformations while unparsing
;;; (instead of just the pattern ones available now). this should be
;;; clearer than the old definitions form.
;;; - re-investigate how language extensions work and see if there is a
;;; cleaner way to do this
;;; - better comparison of alts then simple symbolic equality
;;; - checking for language output to make sure constructed languages are
;;; internally consistent:
;;; - check to make sure metas are unique
(library (nanopass language)
(export define-language language->s-expression diff-languages prune-language define-pruned-language)
(import (rnrs)
(nanopass helpers)
(nanopass language-helpers)
(nanopass records)
(nanopass unparser)
(nanopass meta-parser))
(define-syntax define-language
(syntax-rules ()
[(_ ?L ?rest ...)
(let-syntax ([a (syntax-rules ()
[(_ ?XL)
(x-define-language ?XL ((... ...) ?rest) ...)])])
(a ?L))]))
(define-syntax x-define-language
(lambda (x)
;; This function tests equality of tspecs
;; tspecs are considered to be equal when the lists of metas are
;; identical (same order too) and when they represent the same terminal
; TODO: think about a better way of doing equality here... right now we get a weird
; error message when the original had (fixnum (x y z)) and our extension has (fixnum (x y))
(define tspec=?
(lambda (ts1 ts2)
(and (equal? (syntax->datum (tspec-meta-vars ts1))
(syntax->datum (tspec-meta-vars ts2)))
(eq? (syntax->datum (tspec-type ts1))
(syntax->datum (tspec-type ts2))))))
;; This function tests the equality of ntspecs
;; ntspecs are considered to be equal when they are ntspecs of
;; the same nonterminal and the intersection of their alternatives is
;; not null
(define ntspec=?
(lambda (p1 p2)
(eq? (syntax->datum (ntspec-name p1))
(syntax->datum (ntspec-name p2)))))
;; It is enough to check for same syntax because the record-decls of the
;; new alternative will be different because they are parsed again
(define alt=?
(lambda (a1 a2)
(equal? (syntax->datum (alt-syn a1)) (syntax->datum (alt-syn a2)))))
(define fresh-tspec
(lambda (tspec)
(make-tspec
(tspec-type tspec)
(tspec-meta-vars tspec)
(tspec-handler tspec))))
(define-who fresh-alt
(lambda (alt)
(cond
[(pair-alt? alt) (make-pair-alt (alt-syn alt) (alt-pretty alt) (alt-pretty-procedure? alt))]
[(terminal-alt? alt) (make-terminal-alt (alt-syn alt) (alt-pretty alt) (alt-pretty-procedure? alt))]
[(nonterminal-alt? alt) (make-nonterminal-alt (alt-syn alt) (alt-pretty alt) (alt-pretty-procedure? alt))]
[else (error who "unexpected alt" alt)])))
(define fresh-ntspec
(lambda (ntspec)
(make-ntspec
(ntspec-name ntspec)
(ntspec-meta-vars ntspec)
(map fresh-alt (ntspec-alts ntspec)))))
;; Doing a little extra work here to make sure that we are able to track
;; errors. The basic idea is that we want to go through the list of
;; existing tspecs, and when we keep them, make a new copy (so that
;; language specific information can be updated in them), and when they
;; are being removed, we "mark" that we found the one to remove by
;; pulling it out of our removal list. If any remain in the removal
;; list when we're done, we complain about it.
(define freshen-objects
(lambda (o=? fresh-o msg unpacker)
(rec f
(lambda (os os-)
(cond
[(and (null? os) (not (null? os-)))
(syntax-violation 'define-language msg (map unpacker os-))]
[(null? os) '()]
[else
(let g ([os- os-] [o (car os)] [checked-os- '()])
(cond
[(null? os-) (cons (fresh-o o) (f (cdr os) checked-os-))]
[(o=? o (car os-))
(f (cdr os) (append checked-os- (cdr os-)))]
[else (g (cdr os-) o (cons (car os-) checked-os-))]))])))))
(define freshen-tspecs
(freshen-objects tspec=? fresh-tspec "unrecognized tspecs" tspec-type))
(define freshen-alts
(freshen-objects alt=? fresh-alt "unrecognized alts" alt-syn))
(define add-objects
(lambda (o=? msg)
(letrec ([f (lambda (os os+)
(if (null? os+)
os
(let ([o+ (car os+)])
(when (memp (lambda (x) (o=? o+ x)) os)
(syntax-violation 'define-language msg o+))
(f (cons o+ os) (cdr os+)))))])
f)))
(define add-tspecs (add-objects tspec=? "duplicate tspec in add"))
(define add-alts (add-objects alt=? "duplicate alt in add"))
(define freshen-ntspecs
(lambda (ntspecs ntspecs-)
(cond
[(and (null? ntspecs) (not (null? ntspecs-)))
(if (fx>? (length ntspecs-) 1)
(syntax-violation 'define-language
"multiple unrecognized ntspecs, including"
(ntspec-name (car ntspecs-)))
(syntax-violation 'define-language
"unrecognized ntspec" (ntspec-name (car ntspecs-))))]
[(null? ntspecs) '()]
[else
(let g ([ntspecs- ntspecs-] [ntspec (car ntspecs)] [remaining '()])
(if (null? ntspecs-)
(cons (fresh-ntspec ntspec) (freshen-ntspecs (cdr ntspecs) remaining))
(let ([ntspec- (car ntspecs-)])
(if (ntspec=? ntspec- ntspec)
(let ([alts (freshen-alts (ntspec-alts ntspec) (ntspec-alts ntspec-))])
(if (null? alts)
(freshen-ntspecs (cdr ntspecs) (append remaining (cdr ntspecs-)))
(cons (make-ntspec
(ntspec-name ntspec-)
(ntspec-meta-vars ntspec-)
alts)
(freshen-ntspecs (cdr ntspecs) (append remaining (cdr ntspecs-))))))
(g (cdr ntspecs-) ntspec (cons (car ntspecs-) remaining))))))])))
(define add-ntspecs
(lambda (ntspecs ntspecs+)
(cond
[(null? ntspecs) ntspecs+]
[else
(let g ([ntspecs+ ntspecs+] [ntspec (car ntspecs)] [remaining '()])
(if (null? ntspecs+)
(cons ntspec (add-ntspecs (cdr ntspecs) remaining))
(let ([ntspec+ (car ntspecs+)])
(if (ntspec=? ntspec+ ntspec)
(let ([alts (add-alts (ntspec-alts ntspec) (ntspec-alts ntspec+))])
(cons (make-ntspec
(ntspec-name ntspec+)
(ntspec-meta-vars ntspec+)
alts)
(add-ntspecs (cdr ntspecs) (append remaining (cdr ntspecs+)))))
(g (cdr ntspecs+) ntspec (cons (car ntspecs+) remaining))))))])))
(define partition-terms
(lambda (terms)
(let f ([terms terms] [terms+ '()] [terms- '()])
(syntax-case terms ()
[() (values terms+ terms-)]
[((+ t* ...) terms ...) (plus? #'+)
(f #'(terms ...)
(append terms+ (parse-terms #'(t* ...))) terms-)]
[((- t* ...) terms ...) (minus? #'-)
(f #'(terms ...) terms+
(append terms- (parse-terms #'(t* ...))))]))))
(define partition-ntspecs
(lambda (ntspecs terminal-meta*)
(let f ([ntspecs ntspecs] [ntspecs+ '()] [ntspecs- '()])
(if (null? ntspecs)
(values ntspecs+ ntspecs-) ;; lists returned are reversed (okay?)
(let ([ntspec (car ntspecs)] [ntspecs (cdr ntspecs)])
(let g ([alts (cddr ntspec)] [alts+ '()] [alts- '()])
(syntax-case alts ()
[() (let ([name (car ntspec)] [metas (cadr ntspec)])
(f ntspecs
(if (null? alts+)
ntspecs+
(cons (make-ntspec name metas alts+)
ntspecs+))
(if (null? alts-)
ntspecs-
(cons (make-ntspec name metas alts-)
ntspecs-))))]
[((+ a* ...) alts ...) (plus? #'+)
(g #'(alts ...) (append alts+ (parse-alts #'(a* ...) terminal-meta*))
alts-)]
[((- a* ...) alts ...) (minus? #'-)
(g #'(alts ...) alts+
(append alts- (parse-alts #'(a* ...) terminal-meta*)))])))))))
(define parse-alts
(lambda (alt* terminal-meta*)
(define make-alt
(lambda (syn pretty pretty-procedure?)
(syntax-case syn ()
[(s s* ...) (make-pair-alt #'(s s* ...) pretty pretty-procedure?)]
[(s s* ... . sr) (make-pair-alt #'(s s* ... . sr) pretty pretty-procedure?)]
[s
(identifier? #'s)
(if (memq (meta-var->raw-meta-var (syntax->datum #'s)) terminal-meta*)
(make-terminal-alt #'s pretty pretty-procedure?)
(make-nonterminal-alt #'s pretty pretty-procedure?))])))
(let f ([alt* alt*])
(syntax-case alt* ()
[() '()]
[((=> syn pretty) . alt*) (double-arrow? #'=>)
(cons (make-alt #'syn #'pretty #f) (f #'alt*))]
[(syn => pretty . alt*) (double-arrow? #'=>)
(cons (make-alt #'syn #'pretty #f) (f #'alt*))]
[((-> syn prettyf) . alt*) (arrow? #'->)
(with-implicit (-> with-extended-quasiquote)
(cons (make-alt #'syn #'(with-extended-quasiquote prettyf) #t) (f #'alt*)))]
[(syn -> prettyf . alt*) (arrow? #'->)
(with-implicit (-> with-extended-quasiquote)
(cons (make-alt #'syn #'(with-extended-quasiquote prettyf) #t) (f #'alt*)))]
[(syn . alt*) (cons (make-alt #'syn #f #f) (f #'alt*))]
[_ (syntax-violation 'define-language "unexpected alt" alt*)]))))
(define parse-terms
(lambda (term*)
(syntax-case term* ()
[() '()]
[((=> (t (tmeta* ...)) handler) term* ...) (double-arrow? #'=>)
(cons (make-tspec #'t #'(tmeta* ...) #'handler)
(parse-terms #'(term* ...)))]
[((t (tmeta* ...)) => handler term* ...) (double-arrow? #'=>)
(cons (make-tspec #'t #'(tmeta* ...) #'handler)
(parse-terms #'(term* ...)))]
[((t (tmeta* ...)) term* ...)
(cons (make-tspec #'t #'(tmeta* ...))
(parse-terms #'(term* ...)))])))
(define parse-language-and-finish
(lambda (name ldef)
(define parse-clauses
(lambda (ldef)
(let f ([ldef ldef] [base-lang #f] [found-entry #f]
[entry-ntspec #f] [first-ntspec #f] [terms '()] [ntspecs '()] [nongen-id #f])
(syntax-case ldef (extends entry terminals nongenerative-id)
[() (values base-lang (if base-lang entry-ntspec (or entry-ntspec first-ntspec)) terms (reverse ntspecs) nongen-id)]
[((nongenerative-id ?id) . rest)
(identifier? #'?id)
(begin
(when nongen-id
(syntax-violation 'define-language
"only one nongenerative-id clause allowed in language definition"
#'(nongenerative-id ?id) name))
(f #'rest base-lang found-entry entry-ntspec first-ntspec terms ntspecs #'?id))]
[((extends ?L) . rest)
(identifier? #'?L)
(begin
(when base-lang
(syntax-violation 'define-language
"only one extends clause allowed in language definition"
#'(extends ?L) name))
(f #'rest #'?L found-entry entry-ntspec first-ntspec terms ntspecs nongen-id))]
[((entry ?P) . rest)
(identifier? #'?P)
(begin
(when found-entry
(syntax-violation 'define-language
"only one entry clause allowed in language definition"
#'(entry ?P) entry-ntspec))
(f #'rest base-lang #t #'?P first-ntspec terms ntspecs nongen-id))]
[((terminals ?t* ...) . rest)
(f #'rest base-lang found-entry entry-ntspec first-ntspec
(append terms #'(?t* ...)) ntspecs nongen-id)]
[((ntspec (meta* ...) a a* ...) . rest)
(and (identifier? #'ntspec) (map identifier? #'(meta* ...)))
(f #'rest base-lang found-entry
entry-ntspec
(if first-ntspec first-ntspec #'ntspec)
terms (cons (cons* #'ntspec #'(meta* ...) #'a #'(a* ...)) ntspecs)
nongen-id)]
[(x . rest) (syntax-violation 'define-language "unrecognized clause" #'x)]
[x (syntax-violation 'define-language
"unrecognized rest of language clauses" #'x)]))))
(let-values ([(base-lang entry-ntspec terms ntspecs nongen-id) (parse-clauses ldef)])
(with-compile-time-environment (r)
(if base-lang
(let ([base-pair (r base-lang)])
(unless (and (pair? base-pair)
(language? (car base-pair))
(procedure? (cdr base-pair)))
(syntax-violation 'define-language
"unrecognized base language" base-lang x))
(let ([base (car base-pair)])
(let ([entry-ntspec (or entry-ntspec (language-entry-ntspec base))])
(finish r nongen-id entry-ntspec name name
(let-values ([(terms+ terms-) (partition-terms terms)])
(let* ([tspecs (freshen-tspecs (language-tspecs base) terms-)]
[tspecs (add-tspecs tspecs terms+)]
[terminal-meta* (extract-terminal-metas tspecs)])
(let-values ([(ntspecs+ ntspecs-) (partition-ntspecs ntspecs terminal-meta*)])
(let* ([ntspecs (freshen-ntspecs (language-ntspecs base) ntspecs-)]
[ntspecs (add-ntspecs ntspecs ntspecs+)])
(make-language name entry-ntspec tspecs ntspecs nongen-id)))))))))
(let* ([tspecs (parse-terms terms)]
[terminal-meta* (extract-terminal-metas tspecs)])
(finish r nongen-id entry-ntspec name name
(make-language name
entry-ntspec
tspecs
(map (lambda (ntspec)
(make-ntspec (car ntspec) (cadr ntspec)
(parse-alts (cddr ntspec) terminal-meta*)))
ntspecs)
nongen-id))))))))
(define extract-terminal-metas
(lambda (tspecs)
(fold-left (lambda (metas tspec)
(append (syntax->datum (tspec-meta-vars tspec)) metas))
'() tspecs)))
(define finish
(lambda (r nongen-id ntname lang id desc) ; constructs the output
(annotate-language! r desc id)
(with-syntax ([(records ...) (language->lang-records desc)]
[(predicates ...) (language->lang-predicates desc)]
[unparser-name (construct-id id "unparse-" lang)]
[meta-parser (make-meta-parser desc)])
#;(pretty-print (list 'unparser (syntax->datum lang) (syntax->datum #'unparser)))
#;(pretty-print (list 'meta-parser (syntax->datum lang) (syntax->datum #'meta-parser)))
#`(begin
records ...
predicates ...
(define-syntax #,lang
(make-compile-time-value
(cons '#,desc meta-parser)))
#;(define-property #,lang meta-parser-property meta-parser)
(define-unparser unparser-name #,lang)))))
(syntax-case x ()
[(_ ?L ?rest ...)
(identifier? #'?L)
(parse-language-and-finish #'?L #'(?rest ...))]
[(_ (?L ?nongen-id) ?rest ...)
(and (identifier? #'?L) (identifier? #'?nongen-id))
(parse-language-and-finish #'?L #'(?rest ...))])))
(define-syntax language->s-expression
(lambda (x)
(define who 'language->s-expression)
(define doit
(lambda (lang handler?)
(define tspec->s-expression
(lambda (t)
(if (and handler? (tspec-handler t))
#`(=> (#,(tspec-type t) #,(tspec-meta-vars t))
#,(tspec-handler t))
#`(#,(tspec-type t) #,(tspec-meta-vars t)))))
(define alt->s-expression
(lambda (a)
(if (and handler? (alt-pretty a))
#`(=> #,(alt-syn a) #,(alt-pretty a))
(alt-syn a))))
(define ntspec->s-expression
(lambda (p)
#`(#,(ntspec-name p) #,(ntspec-meta-vars p)
#,@(map alt->s-expression (ntspec-alts p)))))
(lambda (env)
(let ([lang-pair (env lang)])
(unless lang-pair (syntax-violation who "language not found" lang))
(let ([lang (car lang-pair)])
(with-syntax ([(ng ...) (let ([nongen-id (language-nongenerative-id lang)])
(if nongen-id
#`((nongenerative-id #,nongen-id))
#'()))])
#`'(define-language #,(language-name lang)
ng ...
(entry #,(language-entry-ntspec lang))
(terminals #,@(map tspec->s-expression (language-tspecs lang)))
#,@(map ntspec->s-expression (language-ntspecs lang)))))))))
(syntax-case x ()
[(_ lang) (identifier? #'lang) (doit #'lang #f)]
[(_ lang handler?) (identifier? #'lang) (doit #'lang (syntax->datum #'handler?))])))
(define-syntax diff-languages
(lambda (x)
(define who 'diff-languages)
(define combine
(lambda (same removed added)
(if (null? removed)
(if (null? added)
'()
#`((+ #,@added)))
(if (null? added)
#`((- #,@removed))
#`((- #,@removed) (+ #,@added))))))
(define tspec->syntax
(lambda (tspec)
#`(#,(tspec-type tspec) #,(tspec-meta-vars tspec))))
(define ntspec->syntax
(lambda (ntspec)
#`(#,(ntspec-name ntspec) #,(ntspec-meta-vars ntspec) #,@(map alt-syn (ntspec-alts ntspec)))))
(define diff-meta-vars
(lambda (mv0* mv1*)
mv1*
#;(let f ([mv0* mv0*] [mv1* mv1*] [same '()] [removed '()] [added '()])
(cond
[(and (null? mv0*) (null? mv1*)) (combine same removed added)]
[(null? mv0*) (f mv0* (cdr mv1*) same removed (cons (car mv1*) added))]
[else
(let* ([mv0 (car mv0*)] [mv0-sym (syntax->datum mv0)])
(cond
[(find (lambda (mv1) (eq? (syntax->datum mv1) mv0-sym)) mv1*) =>
(lambda (mv1) (f (cdr mv0*) (remq mv1 mv1*) (cons mv1 same) removed added))]
[else (f (cdr mv0*) mv1* same (cons mv0 removed) added)]))]))))
(define diff-terminals
(lambda (t0* t1*)
(let f ([t0* t0*] [t1* t1*] [same '()] [removed '()] [added '()])
(cond
[(and (null? t0*) (null? t1*)) (combine same removed added)]
[(null? t0*) (f t0* (cdr t1*) same removed (cons (tspec->syntax (car t1*)) added))]
[else
(let* ([t0 (car t0*)] [t0-type (tspec-type t0)] [t0-type-sym (syntax->datum t0-type)])
(cond
[(find (lambda (t1) (eq? (syntax->datum (tspec-type t1)) t0-type-sym)) t1*) =>
(lambda (t1)
(with-syntax ([(meta-vars ...) (diff-meta-vars (tspec-meta-vars t0) (tspec-meta-vars t1))])
(f (cdr t0*) (remq t1 t1*) (cons #`(#,t0-type (meta-vars ...)) same) removed added)))]
[else (f (cdr t0*) t1* same (cons (tspec->syntax t0) removed) added)]))]))))
(define diff-alts
(lambda (a0* a1*)
(let f ([a0* a0*] [a1* a1*] [same '()] [removed '()] [added '()])
(cond
[(and (null? a0*) (null? a1*)) (combine same removed added)]
[(null? a0*) (f a0* (cdr a1*) same removed (cons (alt-syn (car a1*)) added))]
[else
(let* ([a0 (car a0*)] [a0-syn (alt-syn a0)] [a0-syn-s-expr (syntax->datum a0-syn)])
(cond
[(find (lambda (a1) (equal? (syntax->datum (alt-syn a1)) a0-syn-s-expr)) a1*) =>
(lambda (a1) (f (cdr a0*) (remq a1 a1*) (cons a0-syn same) removed added))]
[else (f (cdr a0*) a1* same (cons (alt-syn a0) removed) added)]))]))))
(define diff-nonterminals
(lambda (nt0* nt1*)
(let f ([nt0* nt0*] [nt1* nt1*] [updated '()])
(cond
[(and (null? nt0*) (null? nt1*)) updated]
[(null? nt0*)
(f nt0* (cdr nt1*)
(let ([nt1 (car nt1*)])
(cons #`(#,(ntspec-name nt1) #,(ntspec-meta-vars nt1) (+ #,@(map alt-syn (ntspec-alts nt1))))
updated)))]
[else
(let* ([nt0 (car nt0*)] [nt0-name (ntspec-name nt0)] [nt0-name-sym (syntax->datum nt0-name)])
(cond
[(find (lambda (nt1) (eq? (syntax->datum (ntspec-name nt1)) nt0-name-sym)) nt1*) =>
(lambda (nt1)
(f (cdr nt0*) (remq nt1 nt1*)
(let ([alts (diff-alts (ntspec-alts nt0) (ntspec-alts nt1))])
(syntax-case alts ()
[() updated]
[(alts ...)
(with-syntax ([(meta-vars ...) (diff-meta-vars (ntspec-meta-vars nt0) (ntspec-meta-vars nt1))])
(cons #`(#,nt0-name (meta-vars ...) alts ...) updated))]))))]
[else (f (cdr nt0*) nt1* (cons #`(#,nt0-name #,(ntspec-meta-vars nt0) (- #,@(map alt-syn (ntspec-alts nt0)))) updated))]))]))))
(syntax-case x ()
[(_ lang0 lang1)
(with-compile-time-environment (r)
(let ([l0-pair (r #'lang0)] [l1-pair (r #'lang1)])
(unless l0-pair (syntax-violation who "language not found" #'lang0))
(unless l1-pair (syntax-violation who "language not found" #'lang1))
(let ([l0 (car l0-pair)] [l1 (car l1-pair)])
(with-syntax ([l1-entry (language-entry-ntspec l1)]
[(term ...) (diff-terminals (language-tspecs l0) (language-tspecs l1))]
[(nonterm ...) (diff-nonterminals (language-ntspecs l0) (language-ntspecs l1))]
[(ng ...) (let ([nongen-id (language-nongenerative-id l1)])
(if nongen-id
#`((nongenerative-id #,nongen-id))
#'()))])
(syntax-case #'(term ...) ()
[() #''(define-language lang1 (extends lang0)
ng ...
(entry l1-entry)
nonterm ...)]
[(term ...) #''(define-language lang1 (extends lang0)
ng ...
(entry l1-entry)
(terminals term ...)
nonterm ...)])))))])))
(define-syntax prune-language
(lambda (x)
(define who 'prune-language)
(syntax-case x ()
[(_ L)
(with-compile-time-environment (r)
(let ([l-pair (r #'L)])
(unless l-pair (syntax-violation who "language not found" #'L))
(let ([l (car l-pair)])
(with-syntax ([((ts ...) (nts ...)) (prune-language-helper l)]
[entry-nt (language-entry-ntspec l)])
(syntax-case #'(ts ...) ()
[() #''(define-language L
(entry entry-nt)
nts ...)]
[(ts ...) #''(define-language L
(entry entry-nt)
(terminals ts ...)
nts ...)])))))])))
(define-syntax define-pruned-language
(lambda (x)
(define who 'define-pruned-language)
(syntax-case x ()
[(_ L new-name)
(with-compile-time-environment (r)
(let ([l-pair (r #'L)])
(unless l-pair (syntax-violation who "language not found" #'L))
(let ([l (car l-pair)])
(with-syntax ([((ts ...) (nts ...)) (prune-language-helper l)]
[entry-nt (language-entry-ntspec l)])
#'(define-language new-name
(entry entry-nt)
(terminals ts ...)
nts ...)))))]))))

410
ta6ob/nanopass/nanopass/meta-parser.ss Normal file
View file

@ -0,0 +1,410 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass meta-parser)
(export make-meta-parser rhs-in-context-quasiquote meta-parse-term
make-quasiquote-transformer make-in-context-transformer
output-records->syntax parse-cata)
(import (rnrs)
(nanopass helpers)
(nanopass records)
(nanopass syntaxconvert)
(nanopass meta-syntax-dispatch))
(define make-ntspec-meta-parser-assoc
(lambda (tid)
(lambda (ntspec)
(cons ntspec (construct-unique-id tid "meta-parse-" (ntspec-name ntspec))))))
(define make-meta-parser
(lambda (desc)
(let* ([lang-name (language-name desc)]
[ntspecs (language-ntspecs desc)]
[tspecs (language-tspecs desc)]
[ntspec-meta-parsers (map (make-ntspec-meta-parser-assoc lang-name) ntspecs)])
(define lookup-meta-parser
(lambda (ntspec)
(cond
[(assq ntspec ntspec-meta-parsers) => cdr]
[else (syntax-violation 'define-language
(format "unexpected nonterminal ~s in langauge ~s while building meta-parser, expected on of ~s"
(syntax->datum (ntspec-name ntspec)) (syntax->datum lang-name)
(map (lambda (nt) (syntax->datum (ntspec-name nt))) ntspecs))
lang-name)])))
(define make-meta-parse-proc
(lambda (ntspec cata?)
(define parse-field
(lambda (m level maybe?)
(cond
[(meta-name->tspec m tspecs) =>
(lambda (name)
(let f ([level level] [x m])
(if (= level 0)
#`(meta-parse-term '#,name #,x #,cata? #,maybe?)
#`(map (lambda (x)
(if (nano-dots? x)
(make-nano-dots #,(f (- level 1)
#'(nano-dots-x x)))
#,(f (- level 1) #'x)))
#,x))))]
[(meta-name->ntspec m ntspecs) =>
(lambda (spec)
(with-syntax ([proc-name (lookup-meta-parser spec)])
(let f ([level level] [x m])
(if (= level 0)
#`(proc-name #,x #t #t #,maybe?)
#`(map (lambda (x)
(if (nano-dots? x)
(make-nano-dots #,(f (- level 1)
#'(nano-dots-x x)))
#,(f (- level 1) #'x)))
#,x)))))]
[else (syntax-violation 'define-language
(format "unrecognized meta variable ~s in language ~s, when building meta parser" m lang-name)
lang-name)])))
(define make-term-clause
(lambda (x)
(lambda (alt)
#`[(memq (meta-var->raw-meta-var (syntax->datum #,x))
(quote #,(tspec-meta-vars (terminal-alt-tspec alt))))
(make-nano-meta '#,alt (list (make-nano-unquote #,x)))])))
(define make-nonterm-unquote
(lambda (x)
(lambda (alt)
#`[(memq (meta-var->raw-meta-var (syntax->datum #,x))
(quote #,(ntspec-meta-vars (nonterminal-alt-ntspec alt))))
(make-nano-meta '#,alt (list (make-nano-unquote #,x)))])))
(define make-nonterm-clause
(lambda (x maybe?)
(lambda (alt)
#`(#,(lookup-meta-parser (nonterminal-alt-ntspec alt)) #,x #f nested? maybe?))))
(define make-pair-clause
(lambda (stx first-stx rest-stx)
(lambda (alt)
(with-syntax ([(field-var ...) (pair-alt-field-names alt)])
(with-syntax ([(parsed-field ...)
(map parse-field #'(field-var ...)
(pair-alt-field-levels alt)
(pair-alt-field-maybes alt))]
[field-pats (datum->syntax #'* (pair-alt-pattern alt))])
#`[#,(if (pair-alt-implicit? alt)
#`(meta-syntax-dispatch #,stx 'field-pats)
#`(and (eq? (syntax->datum #,first-stx) '#,(car (alt-syn alt)))
(meta-syntax-dispatch #,rest-stx 'field-pats)))
=> (lambda (ls)
(apply
(lambda (field-var ...)
(make-nano-meta '#,alt (list parsed-field ...)))
ls))])))))
(define separate-syn
(lambda (ls)
(let loop ([ls ls] [pair* '()] [pair-imp* '()] [term* '()] [imp* '()] [nonimp* '()])
(if (null? ls)
(values (reverse pair*) (reverse pair-imp*) (reverse term*) (reverse imp*) (reverse nonimp*))
(let ([v (car ls)])
(cond
[(nonterminal-alt? v)
(if (has-implicit-alt? (nonterminal-alt-ntspec v))
(loop (cdr ls) pair* pair-imp* term* (cons v imp*) nonimp*)
(loop (cdr ls) pair* pair-imp* term* imp* (cons v nonimp*)))]
[(terminal-alt? v) (loop (cdr ls) pair* pair-imp* (cons v term*) imp* nonimp*)]
[(pair-alt-implicit? v) (loop (cdr ls) pair* (cons v pair-imp*) term* imp* nonimp*)]
[else (loop (cdr ls) (cons v pair*) pair-imp* term* imp* nonimp*)]))))))
(let-values ([(pair-alt* pair-imp-alt* term-alt* nonterm-imp-alt* nonterm-nonimp-alt*)
(separate-syn (ntspec-alts ntspec))])
#`(lambda (stx error? nested? maybe?)
(or (syntax-case stx (unquote)
[(unquote id)
(identifier? #'id)
(if nested?
(make-nano-unquote #'id)
(cond
#,@(map (make-term-clause #'#'id) term-alt*)
; TODO: right now we can match the meta for this item, but we
; cannot generate the needed nano-meta because we have no
; alt record to put into it. (perhaps the current model is
; just pushed as far as it can be right now, and we need to
; rework it.)
#,@(map (make-nonterm-unquote #'#'id) nonterm-imp-alt*)
#,@(map (make-nonterm-unquote #'#'id) nonterm-nonimp-alt*)
[else #f]))]
[(unquote x)
(if nested?
(if #,cata?
(parse-cata #'x '#,(ntspec-name ntspec) maybe?)
(make-nano-unquote #'x))
(syntax-violation #f "cata unsupported at top-level of pattern" stx))]
[_ #f])
#,@(map (make-nonterm-clause #'stx #'maybe?) nonterm-nonimp-alt*)
(syntax-case stx ()
[(a . d)
(cond
#,@(map (make-pair-clause #'stx #'#'a #'#'d) pair-alt*)
#,@(map (make-pair-clause #'stx #'#'a #'#'d) pair-imp-alt*)
[else #f])]
; if we find something here that is not a pair, assume it should
; be treated as a quoted constant, and will be checked appropriately
; by the run-time constructor check
[atom (make-nano-quote #''atom)])
#,@(map (make-nonterm-clause #'stx #'maybe?) nonterm-imp-alt*)
(and error? (syntax-violation who "unrecognized pattern or template" stx)))))))
(with-syntax ([cata? (gentemp)])
(with-syntax ([(ntspec-id ...) (map ntspec-name ntspecs)]
[(parse-name ...) (map cdr ntspec-meta-parsers)]
[(parse-proc ...)
(map (lambda (ntspec) (make-meta-parse-proc ntspec #'cata?)) ntspecs)])
#`(lambda (ntspec-name stx input?)
(let ([cata? input?])
(define-who parse-name parse-proc) ...
(case ntspec-name
[(ntspec-id) (parse-name stx #t (not input?) #f)] ...
[else (syntax-violation '#,(construct-id lang-name "meta-parse-" lang-name)
(format "unexpected nonterminal ~s passed to meta parser for language ~s while meta-parsing, expected one of ~s"
ntspec-name '#,lang-name '#,(map ntspec-name ntspecs))
stx)]))))))))
;; used to handle output of meta-parsers
(define meta-parse-term
(lambda (tname stx cata? maybe?)
(syntax-case stx (unquote)
[(unquote x)
(if (and cata? (not (identifier? #'x)))
(parse-cata #'x (tspec-type tname) maybe?)
(make-nano-unquote #'x))]
[(a . d)
(syntax-violation 'meta-parse-term "invalid pattern or template" stx)]
[stx
; treat everything else we find as ,'foo because if we don't
; `(primapp void) is interpreted as:
; `(primapp #<procedure void>)
; instead we want it to treat it as:
; `(primapp ,'void)
; which is how it would have to be written without this.
; Note that we don't care what literal expression we find here
; because at runtime it will be checked like every other element
; used to construct the output record, and anything invalid will
; be caught then. (If we check earlier, then it forces us to use
; the terminal predicates at compile-time, which means that can't
; be in the same library, and that is a bummer for other reasons,
; so better to be flexible and let something invalid go through
; here to be caught later.)
(make-nano-quote #''stx)])))
;; used in the input meta parser to parse cata syntax
;; TODO: support for multiple input terms.
(define parse-cata
; should be more picky if nonterminal is specified--see 10/08/2007 NOTES
(lambda (x itype maybe?)
(define (serror) (syntax-violation 'define-pass "invalid cata syntax" x))
(define (s0 stuff)
(syntax-case stuff ()
[(: . stuff) (colon? #':) (s2 #f #'stuff)]
[(-> . stuff) (arrow? #'->) (s4 #f #f '() #'stuff)]
[(e . stuff) (s1 #'e #'stuff)]
[() (make-nano-cata itype x #f #f '() maybe?)]
[_ (serror)]))
(define (s1 e stuff)
(syntax-case stuff ()
[(: . stuff) (colon? #':) (s2 e #'stuff)]
[(-> . stuff)
(and (arrow? #'->) (identifier? e))
(s4 #f (list e) '() #'stuff)]
[(expr . stuff)
; it is pre-mature to check for identifier here since these could be input exprs
#;(and (identifier? #'id) (identifier? e))
(identifier? e)
(s3 #f (list #'expr e) #'stuff)]
[() (identifier? e) (make-nano-cata itype x #f #f (list e) maybe?)]
[_ (serror)]))
(define (s2 f stuff)
(syntax-case stuff ()
[(-> . stuff)
(arrow? #'->)
(s4 f #f '() #'stuff)]
[(id . stuff)
(identifier? #'id)
(s3 f (list #'id) #'stuff)]
[_ (serror)]))
(define (s3 f e* stuff)
(syntax-case stuff ()
[(-> . stuff)
(arrow? #'->)
(s4 f (reverse e*) '() #'stuff)]
[(e . stuff)
; this check is premature, since these could be input expressions
#;(identifier? #'id)
(s3 f (cons #'e e*) #'stuff)]
[()
; now we want to check if these are identifiers, because they are our return ids
(for-all identifier? e*)
(make-nano-cata itype x f #f (reverse e*) maybe?)]
[_ (serror)]))
(define (s4 f maybe-inid* routid* stuff)
(syntax-case stuff ()
[(id . stuff)
(identifier? #'id)
(s4 f maybe-inid* (cons #'id routid*) #'stuff)]
[() (make-nano-cata itype x f maybe-inid* (reverse routid*) maybe?)]
[_ (serror)]))
(syntax-case x ()
[(stuff ...) (s0 #'(stuff ...))])))
;; used in the output of the input metaparser and in the output of
;; define-pass
(define rhs-in-context-quasiquote
(lambda (id type omrec ometa-parser body)
(if type
(with-syntax ([quasiquote (datum->syntax id 'quasiquote)]
[in-context (datum->syntax id 'in-context)])
#`(let-syntax ([quasiquote
'#,(make-quasiquote-transformer id type omrec ometa-parser)]
[in-context
'#,(make-in-context-transformer id omrec ometa-parser)])
#,body))
(with-syntax ([in-context (datum->syntax id 'in-context)])
#`(let-syntax ([in-context
'#,(make-in-context-transformer id omrec ometa-parser)])
#,body)))))
;; Done to do allow a programmer to specify what the context for
;; their quasiquote is, incase it is different from the current
;; expression.
;; bug fix #8 (not sure what this refers to)
(define make-in-context-transformer
(lambda (pass-name omrec ometa-parser)
(lambda (x)
(syntax-case x ()
[(_ ntname stuff ...)
(with-syntax ([quasiquote (datum->syntax pass-name 'quasiquote)])
#`(let-syntax ([quasiquote '#,(make-quasiquote-transformer
pass-name #'ntname
omrec ometa-parser)])
stuff ...))]))))
;; Used to make quasiquote transformers in the in-context transformer
;; and in the normal right hand side transformer in do-define-pass and
;; make-rhs
(define make-quasiquote-transformer
(lambda (pass-name ntname omrec ometa-parser)
(lambda (x)
(syntax-case x ()
[(_ stuff)
; TODO move error message like this into wherever the template doesn't match is
(output-records->syntax pass-name ntname omrec ometa-parser
(ometa-parser (syntax->datum ntname) #'stuff #f))
#;(let ([stx #f])
(trace-let quasiquote-transformer ([t (syntax->datum #'stuff)])
(let ([t (output-records->syntax pass-name ntname omrec ometa-parser
(ometa-parser (syntax->datum ntname) #'stuff #f))])
(set! stx t)
(syntax->datum t)))
stx)]))))
;; helper function used by the output metaparser in the meta-parsing
;; two step
;; TODO:
;; - defeated (for now) at getting rid of the unnecessary bindings. still convinced this is possible and to be fixed.
;; - we are using bound-id-union to append lists of variables that are unique by construction (unless I am misreading the code) this is pointless.
;; - we are mapping over the field-names to find the specs for the fields. this seems waistful in a small way (building an unnecessary list) and a big way (lookup something that could be cached)
;; - we are always building the checking version of the pair-alt constructor here, but could probably be avoiding that.
(define output-records->syntax
(lambda (pass-name ntname omrec ometa-parser rhs-rec)
(define id->msg
(lambda (id)
(cond
[(fx=? (optimize-level) 3) #f]
[(syntax->source-info id) =>
(lambda (si) (format "expression ~s ~a" (syntax->datum id) si))]
[else (format "expression ~s" (syntax->datum id))])))
(define process-nano-fields
(lambda (elt* spec* binding*)
(if (null? elt*)
(values '() '() '() binding*)
(let-values ([(elt elt-id elt-var* binding*) (process-nano-elt (car elt*) (car spec*) binding*)])
(let-values ([(elt* elt*-id elt*-var* binding*)
(process-nano-fields (cdr elt*) (cdr spec*) binding*)])
(values (cons elt elt*) (cons elt-id elt*-id) (bound-id-union elt-var* elt*-var*) binding*))))))
(define process-nano-dots
(lambda (orig-elt spec binding*)
; ought to check that each of var* are bound to proper lists
; and that they have the same lengths
(let-values ([(elt id var* binding*) (process-nano-elt (nano-dots-x orig-elt) spec binding*)])
(if (null? var*)
; TODO: store original syntax object in nano-dots record and use it here
(syntax-violation (syntax->datum pass-name)
"no variables within ellipsis pattern"
(let f ([elt (nano-dots-x orig-elt)])
(cond
[(nano-meta? elt) (map f (nano-meta-fields elt))]
[(nano-quote? elt) (cadr (nano-quote-x elt))]
[(nano-unquote? elt) (nano-unquote-x elt)]
[(nano-cata? elt) (nano-cata-syntax elt)]
[(list? elt) (map f elt)]
[else elt])))
(values
(if (null? (cdr var*))
(let ([t (car var*)])
(if (eq? t elt)
t
#`(map (lambda (#,t) #,elt) #,t)))
#`(map (lambda #,var* #,elt) #,@var*))
id var* binding*)))))
(define process-nano-list
(lambda (elt* spec binding*)
(let f ([elt* elt*] [binding* binding*])
(if (null? elt*)
(values #''() '() '() binding*)
(let ([elt (car elt*)] [elt* (cdr elt*)])
(if (nano-dots? elt)
(if (null? elt*)
(process-nano-dots elt spec binding*)
(let-values ([(elt elt-id elt-var* binding*)
(process-nano-dots elt spec binding*)])
(let-values ([(elt* elt*-id* elt*-var* binding*) (f elt* binding*)])
(values #`(append #,elt #,elt*)
(cons elt-id elt*-id*)
(bound-id-union elt-var* elt*-var*)
binding*))))
(let-values ([(elt elt-id elt-var* binding*) (process-nano-elt elt spec binding*)])
(let-values ([(elt* elt*-id* elt*-var* binding*) (f elt* binding*)])
(values #`(cons #,elt #,elt*)
(cons elt-id elt*-id*)
(bound-id-union elt-var* elt*-var*)
binding*)))))))))
(define process-nano-meta
(lambda (x binding*)
(let ([prec-alt (nano-meta-alt x)])
(let-values ([(field* id* var* binding*)
(process-nano-fields (nano-meta-fields x)
(map (lambda (x) (find-spec x omrec)) (pair-alt-field-names prec-alt))
binding*)])
(values
#`(#,(pair-alt-maker prec-alt) '#,pass-name #,@field* #,@(map id->msg id*))
#f var* binding*)))))
(define process-nano-elt
(lambda (elt spec binding*)
(cond
[(nano-meta? elt)
(assert (pair-alt? (nano-meta-alt elt)))
(process-nano-meta elt binding*)]
[(nano-quote? elt) (let ([x (nano-quote-x elt)]) (values x x '() binding*))]
[(nano-unquote? elt)
(let ([x (nano-unquote-x elt)])
(with-syntax ([expr (if (ntspec? spec)
; TODO: when we eventually turn these processors into named entities (either
; directly with meta define, define-syntax or some sort of property, replace
; this with the appropriate call. In the meantime this should allow us to
; remove some of our in-contexts
(with-syntax ([quasiquote (datum->syntax pass-name 'quasiquote)])
#`(let-syntax ([quasiquote '#,(make-quasiquote-transformer
pass-name (spec-type spec)
omrec ometa-parser)])
#,x))
x)]
[tmp (car (generate-temporaries '(x)))])
(values #'tmp x (list #'tmp) (cons #'(tmp expr) binding*))))]
[(list? elt) (process-nano-list elt spec binding*)]
[else (values elt elt '() binding*)])))
(let-values ([(elt id var* binding*)
(process-nano-elt rhs-rec (nonterm-id->ntspec 'define-pass ntname (language-ntspecs omrec)) '())])
#`(let #,binding* #,elt)))))

145
ta6ob/nanopass/nanopass/meta-syntax-dispatch.ss Normal file
View file

@ -0,0 +1,145 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass meta-syntax-dispatch)
(export meta-syntax-dispatch)
(import (rnrs)
(nanopass helpers)
(nanopass records))
;; (fields->patterns '(e0 e1 e2)) => (any any any)
;; (fields->patterns '(e0 ...)) => ((each+ any () ()))
;; (fields->patterns '(e0 ... e1)) => ((each+ any (any) ()))
;; (fields->patterns '(e0 ... e1 e2)) => ((each+ any (any any) ()))
;; (fields->patterns '(([x e0] ...) e1 e2 ...)) =>
;; ((each+ (any any) () ())) any (each+ (any) () ()))
;;; syntax-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned.
;;; The expression is matched with the pattern as follows:
;;; p in pattern: matches:
;;; () empty list
;;; any anything
;;; (p1 . p2) pair (list)
;;; each-any any proper list
;;; #(each p) (p*)
;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
(define match-each
(lambda (e p)
(syntax-case e ()
[(a dots . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots))
(let ([first (match #'a p '())])
(and first
(let ([rest (match-each #'d p)])
(and rest (cons (map make-nano-dots first) rest)))))]
[(a . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)))
(let ([first (match #'a p '())])
(and first
(let ([rest (match-each #'d p)])
(and rest (cons first rest)))))]
[() '()]
[else #f])))
(define match-each+
(lambda (e x-pat y-pat z-pat r)
(let f ([e e])
(syntax-case e ()
[(a dots . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots))
(let-values ([(xr* y-pat r) (f #'d)])
(if r
(if (null? y-pat)
(let ([xr (match #'a x-pat '())])
(if xr
(values (cons (map make-nano-dots xr) xr*) y-pat r)
(values #f #f #f)))
(values '() (cdr y-pat) (match #'a (car y-pat) r)))
(values #f #f #f)))]
[(a . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)))
(let-values ([(xr* y-pat r) (f #'d)])
(if r
(if (null? y-pat)
(let ([xr (match #'a x-pat '())])
(if xr
(values (cons xr xr*) y-pat r)
(values #f #f #f)))
(values '() (cdr y-pat) (match #'a (car y-pat) r)))
(values #f #f #f)))]
[_ (values '() y-pat (match e z-pat r))]))))
(define match-each-any
(lambda (e)
(syntax-case e ()
[(a dots . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)) (ellipsis? #'dots))
(let ([l (match-each-any #'d)])
(and l (cons (make-nano-dots #'a) l)))]
[(a . d)
(and (not (ellipsis? #'a)) (not (unquote? #'a)))
(let ([l (match-each-any #'d)])
(and l (cons #'a l)))]
[() '()]
[_ #f])))
(define match-empty
(lambda (p r)
(cond
[(null? p) r]
[(eq? p 'any) (cons '() r)]
[(pair? p) (match-empty (car p) (match-empty (cdr p) r))]
[(eq? p 'each-any) (cons '() r)]
[else
(case (vector-ref p 0)
[(each) (match-empty (vector-ref p 1) r)]
[(each+) (match-empty
(vector-ref p 1)
(match-empty
(reverse (vector-ref p 2))
(match-empty (vector-ref p 3) r)))])])))
(define match*
(lambda (e p r)
(cond
[(null? p) (syntax-case e () [() r] [_ #f])]
[(pair? p)
(syntax-case e ()
[(a . d) (match #'a (car p) (match #'d (cdr p) r))]
[_ #f])]
[(eq? p 'each-any)
(let ([l (match-each-any e)]) (and l (cons l r)))]
[else
(case (vector-ref p 0)
[(each)
(syntax-case e ()
[() (match-empty (vector-ref p 1) r)]
[_ (let ([r* (match-each e (vector-ref p 1))])
(and r* (combine r* r)))])]
[(each+)
(let-values ([(xr* y-pat r)
(match-each+ e (vector-ref p 1) (vector-ref p 2)
(vector-ref p 3) r)])
(and r (null? y-pat)
(if (null? xr*)
(match-empty (vector-ref p 1) r)
(combine xr* r))))])])))
(define match
(lambda (e p r)
(cond
[(not r) #f]
[(eq? p 'any)
(and (not (ellipsis? e))
(not (unquote? e)) ; avoid matching unquote
(cons e r))]
[else (match* e p r)])))
(define meta-syntax-dispatch
(lambda (e p)
(match e p '()))))

99
ta6ob/nanopass/nanopass/nano-syntax-dispatch.ss Normal file
View file

@ -0,0 +1,99 @@
;;; Copyright (c) 2000-2020 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass nano-syntax-dispatch)
(export nano-syntax-dispatch)
(import (rnrs) (nanopass helpers))
(define-syntax match-each
(syntax-rules ()
[(_ ?e p)
(let f ([e ?e])
(cond
[(pair? e) (match (car e) p (f (cdr e)))]
[(null? e) '()]
[else #f]))]))
(define-syntax match-remainder
(syntax-rules ()
[(_ ?e () z-pat ?r)
(let loop ([e ?e] [re* '()])
(if (pair? e)
(loop (cdr e) (cons (car e) re*))
(values re* (match e z-pat ?r))))]
[(_ ?e (y-pat . y-pat-rest) z-pat ?r)
(let-values ([(re* r) (match-remainder ?e y-pat-rest z-pat ?r)])
(if r
(if (null? re*)
(values #f #f)
(values (cdr re*) (match (car re*) y-pat r)))
(values #f #f)))]))
(define-syntax match-each+
(syntax-rules ()
[(_ e x-pat y-pat z-pat ?r)
(let-values ([(re* r) (match-remainder e y-pat z-pat ?r)])
(if r
(let loop ([re* re*] [xr* '()])
(if (null? re*)
(values xr* r)
(let ([xr (match (car re*) x-pat '())])
(if xr
(loop (cdr re*) (cons xr xr*))
(values #f #f)))))
(values #f #f)))]))
(define-syntax match-each-any
(syntax-rules ()
[(_ ?e)
(let f ([e ?e])
(cond
[(pair? e)
(let ([l (f (cdr e))])
(and l (cons (car e) l)))]
[(null? e) '()]
[else #f]))]))
(define-syntax match-empty
(lambda (x)
(syntax-case x (any each-any each each+)
[(_ () r) #'r]
[(_ any r) #'(cons '() r)]
[(_ (a . d) r) #'(match-empty a (match-empty d r))]
[(_ each-any r) #'(cons '() r)]
[(_ #(each p1) r) #'(match-empty p1 r)]
[(_ #(each+ p1 (p2 ...) p3) r)
(with-syntax ([(rp2 ...) (reverse #'(p2 ...))])
#'(match-empty p1 (match-empty (rp2 ...) (match-empty p3 r))))])))
(define-syntax match
(syntax-rules (any)
[(_ e any r) (and r (cons e r))]
[(_ e p r) (and r (match* e p r))]))
(define-syntax match*
(syntax-rules (any each-any each each+)
[(_ e () r) (and (null? e) r)]
[(_ e (a . d) r) (and (pair? e) (match (car e) a (match (cdr e) d r)))]
[(_ e each-any r) (let ([l (match-each-any e)]) (and l (cons l r)))]
[(_ e #(each p1) ?r)
(if (null? e)
(match-empty p1 ?r)
(let ([r* (match-each e p1)])
(and r* (let combine ([r* r*] [r ?r])
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))))]
[(_ e #(each+ p1 p2 p3) ?r)
(let-values ([(xr* r) (match-each+ e p1 p2 p3 ?r)])
(and r (if (null? xr*)
(match-empty p1 r)
(let combine ([r* xr*] [r r])
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))))]))
(define-syntax nano-syntax-dispatch
(syntax-rules (any)
[(_ e any) (list e)]
[(_ e p) (match* e p '())])))

172
ta6ob/nanopass/nanopass/parser.ss Normal file
View file

@ -0,0 +1,172 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass parser)
(export define-parser trace-define-parser)
(import (rnrs)
(nanopass helpers)
(nanopass records)
(nanopass syntaxconvert)
(nanopass nano-syntax-dispatch))
(define-syntax np-parse-fail-token
(let ([sym (datum->syntax #'* (gensym "np-parse-fail-token"))])
(make-variable-transformer
(lambda (x)
(syntax-case x ()
[id (identifier? #'id) (with-syntax ([sym sym]) #''sym)]
[(set! _ e) (syntax-violation 'np-parse-fail-token "misplaced use of keyword" x)]
[(_ e ...) (syntax-violation 'np-parse-fail-token "misplaced use of keyword" x)])))))
(define-syntax parse-or
(syntax-rules (on-error)
[(_ (on-error ?err0)) ?err0]
[(_ (on-error ?err0) ?e0 . ?e1)
(let ([t0 ?e0])
(if (eq? t0 np-parse-fail-token)
(parse-or (on-error ?err0) . ?e1)
t0))]))
(define-syntax define-parser
(syntax-rules ()
[(_ . rest) (x-define-parser . rest)]))
(define-syntax trace-define-parser
(syntax-rules ()
[(_ . rest) (x-define-parser trace . rest)]))
(define-syntax x-define-parser
(lambda (x)
(define make-parser-name-assoc
(lambda (tid)
(lambda (ntspec)
(let ([name-sym (syntax->datum (ntspec-name ntspec))])
(cons name-sym (construct-unique-id tid "parse-" name-sym))))))
(define make-parser
(lambda (parser-name lang trace?)
(with-compile-time-environment (r)
(let ([who (if trace? 'trace-define-parser 'define-parser)]
[desc-pair (guard (c [else #f]) (r lang))])
(unless desc-pair
(syntax-violation who
(format "unknown language ~s" (syntax->datum lang))
parser-name x))
(let* ([desc (car desc-pair)]
[lang-name (language-name desc)]
[ntspecs (language-ntspecs desc)]
[tspecs (language-tspecs desc)]
[parser-names (map (make-parser-name-assoc parser-name) ntspecs)])
(define lookup-parser-name
(lambda (name)
(cond
[(assq (syntax->datum name) parser-names) => cdr]
[else (syntax-violation who
(format "unexpected nonterminal ~s in language ~s, expected one of ~s"
(syntax->datum name) (syntax->datum lang-name)
(map (lambda (nt) (syntax->datum (ntspec-name nt))) ntspecs))
parser-name x)])))
(define make-parse-proc
(lambda (desc tspecs ntspecs ntspec lang-name)
(define parse-field
(lambda (m level maybe?)
(cond
[(meta-name->tspec m tspecs) m]
[(meta-name->ntspec m ntspecs) =>
(lambda (spec)
(with-syntax ([proc-name (lookup-parser-name (ntspec-name spec))])
(let f ([level level] [x m])
(if (= level 0)
(if maybe? #`(and #,x (proc-name #,x #t)) #`(proc-name #,x #t))
#`(map (lambda (x) #,(f (- level 1) #'x)) #,x)))))]
[else (syntax-violation who
(format "unrecognized meta-variable ~s in language ~s"
(syntax->datum m) (syntax->datum lang-name))
parser-name x)])))
(define make-term-clause
(lambda (alt)
(with-syntax ([term-pred?
(cond
[(meta-name->tspec (alt-syn alt) tspecs) => tspec-pred]
[else (syntax-violation who
(format "unrecognized terminal meta-variable ~s in language ~s"
(syntax->datum (alt-syn alt)) (syntax->datum lang-name))
parser-name x)])])
#'[(term-pred? s-exp) s-exp])))
(define make-nonterm-clause
(lambda (alt)
(let ([spec (meta-name->ntspec (alt-syn alt) ntspecs)])
(unless spec
(syntax-violation who
(format "unrecognized nonterminal meta-variable ~s in language ~s"
(syntax->datum (alt-syn alt)) (syntax->datum lang-name))
parser-name x))
(with-syntax ([proc-name (lookup-parser-name (ntspec-name spec))])
#`(proc-name s-exp #f)))))
(define make-pair-clause
(lambda (alt)
(with-syntax ([maker (pair-alt-maker alt)]
[(field-var ...) (pair-alt-field-names alt)])
(with-syntax ([(parsed-field ...)
(map parse-field #'(field-var ...)
(pair-alt-field-levels alt)
(pair-alt-field-maybes alt))]
[(msg ...) (map (lambda (x) #f) #'(field-var ...))]
[field-pats (datum->syntax #'* (pair-alt-pattern alt))])
#`[#,(if (pair-alt-implicit? alt)
#'(nano-syntax-dispatch s-exp field-pats)
(with-syntax ([key (car (alt-syn alt))])
#'(and (eq? 'key (car s-exp))
(nano-syntax-dispatch (cdr s-exp) field-pats))))
=>
(lambda (ls)
(apply
(lambda (field-var ...)
(let ([field-var parsed-field] ...)
(maker who field-var ... msg ...))) ls))]))))
(partition-syn (ntspec-alts ntspec)
([term-alt* terminal-alt?]
[nonterm-alt* nonterminal-alt?]
[pair-imp-alt* pair-alt-implicit?]
[pair-alt* otherwise])
(partition-syn nonterm-alt*
([nonterm-imp-alt* (lambda (alt) (has-implicit-alt? (nonterminal-alt-ntspec alt)))]
[nonterm-nonimp-alt* otherwise])
#`(lambda (s-exp at-top-parse?)
(parse-or
(on-error
(if at-top-parse?
(error who (format "invalid syntax ~s" s-exp))
np-parse-fail-token))
#,@(map make-nonterm-clause nonterm-nonimp-alt*)
(if (pair? s-exp)
(cond
#,@(map make-pair-clause pair-alt*)
#,@(map make-pair-clause pair-imp-alt*)
[else np-parse-fail-token])
(cond
#,@(map make-term-clause term-alt*)
[else np-parse-fail-token]))
#,@(map make-nonterm-clause nonterm-imp-alt*)))))))
(with-syntax ([(parse-name ...) (map cdr parser-names)]
[(parse-proc ...)
(map (lambda (ntspec)
(make-parse-proc desc tspecs ntspecs ntspec lang-name))
ntspecs)])
(with-syntax ([entry-proc-name (lookup-parser-name (language-entry-ntspec desc))]
[parser-name parser-name])
(with-syntax ([(lam-exp ...) (if trace? #'(trace-lambda parser-name) #'(lambda))]
[def (if trace? #'trace-define #'define)])
#'(define-who parser-name
(lam-exp ... (s-exp)
(def parse-name parse-proc)
...
(entry-proc-name s-exp #t)))))))))))
(syntax-case x (trace)
[(_ parser-name lang)
(and (identifier? #'parser-name) (identifier? #'lang))
(make-parser #'parser-name #'lang #f)]
[(_ trace parser-name lang)
(and (identifier? #'parser-name) (identifier? #'lang))
(make-parser #'parser-name #'lang #t)]))))

1624
ta6ob/nanopass/nanopass/pass.ss Normal file
View file

File diff suppressed because it is too large Load diff

98
ta6ob/nanopass/nanopass/prefix-matcher.ss Normal file
View file

@ -0,0 +1,98 @@
(library (nanopass prefix-matcher)
(export empty-prefix-tree insert-prefix match-prefix)
(import (chezscheme))
(define-record-type prefix-node
(nongenerative)
(sealed #t)
(fields str start end result next*))
(define substring=?
(lambda (str0 str1 s e)
(let loop ([i s])
(or (fx= i e)
(and (char=? (string-ref str0 i) (string-ref str1 i))
(loop (fx+ i 1)))))))
(define empty-prefix-tree (lambda () '()))
(define match-prefix
(case-lambda
[(pt str) (match-prefix pt str (lambda (str s e) #t))]
[(pt str ok-suffix?)
(let ([len (string-length str)])
(let loop ([pt pt] [curr-result #f] [curr-end 0])
(if (null? pt)
(and curr-result (ok-suffix? (substring str curr-end len)) curr-result)
(let ([node (car pt)] [pt (cdr pt)])
(let ([end (prefix-node-end node)])
(if (fx> end len)
(loop pt curr-result curr-end)
(let ([node-str (prefix-node-str node)])
(if (substring=? node-str str (prefix-node-start node) end)
(cond
[(fx= end len)
(or (prefix-node-result node)
(and curr-result (ok-suffix? (substring str curr-end len)) curr-result))]
[(prefix-node-result node)
(loop (prefix-node-next* node) (prefix-node-result node) end)]
[else (loop (prefix-node-next* node) curr-result curr-end)])
(loop pt curr-result curr-end)))))))))]))
;; NB: the following assumes that no one will be mutating the strings put into this tree
(define insert-prefix
(lambda (pt str result)
(let ([len (string-length str)])
(let f ([pt pt] [start 0])
(if (null? pt)
(list (make-prefix-node str start len result '()))
(let* ([node (car pt)] [pt (cdr pt)] [node-str (prefix-node-str node)])
(when (string=? node-str str) (errorf 'add-prefix "prefix already in tree"))
(let loop ([offset start])
(if (fx= offset len)
(cons
(make-prefix-node node-str start offset #f
(cons (make-prefix-node str offset len result '())
(make-prefix-node node-str offset (prefix-node-end node)
(prefix-node-result node) (prefix-node-next* node))))
pt)
(let ([end (prefix-node-end node)])
(cond
[(fx= offset end)
(cons (make-prefix-node node-str start (prefix-node-end node)
(prefix-node-result node)
(f (prefix-node-next* node) offset))
pt)]
[(char=? (string-ref str offset) (string-ref node-str offset)) (loop (fx+ offset 1))]
[(fx= offset start) (cons node (f pt start))]
[else (cons (make-prefix-node node-str start offset #f
(list (make-prefix-node node-str offset end
(prefix-node-result node) (prefix-node-next* node))
(make-prefix-node str offset len result '())))
pt)]))))))))))
(define remove-prefix
(lambda (pt str)
#|
(let ([len (string-length str)])
(let f ([pt pt])
(if (null? pt)
pt
(let ([node (car pt)] [pt (cdr pt)])
(let ([end (prefix-node-end node)])
(if (fx> end len)
pt
(let ([node-str (prefix-node-str node)])
(if (substring=? node-str str (prefix-node-str node) end)
(if (fx= end len)
(let ([next* (prefix-node-next* node)])
(cond
[(null? next*) pt]
[(fx= (length next*) 1)
(let ([next (car next*)])
(make-prefix-node (prefix-node-str next) (prefix-node-start node)
(prefix-node-end next) (prefix-node-result next) (prefix-node-next* next)))]
[else (make-prefix-node (prefix-node-str (car next*))
(prefix-node-start node) (prefix-node
|#
(errorf 'remove-prefix "not yet implemented")))
)

804
ta6ob/nanopass/nanopass/records.ss Normal file
View file

@ -0,0 +1,804 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass records)
(export find-spec nonterminal-meta?
nonterm-id->ntspec? nonterm-id->ntspec id->spec term-id->tspec?
meta-name->tspec meta-name->ntspec
make-nano-dots nano-dots? nano-dots-x
make-nano-quote nano-quote? nano-quote-x
make-nano-unquote nano-unquote? nano-unquote-x
make-nano-meta nano-meta? nano-meta-alt nano-meta-fields
make-nano-cata nano-cata? nano-cata-itype nano-cata-syntax
nano-cata-procexpr nano-cata-maybe-inid* nano-cata-outid*
nano-cata-maybe?
make-language language? language-name language-entry-ntspec
language-tspecs language-ntspecs
language-tag-mask language-nongenerative-id
make-tspec tspec-meta-vars tspec-type tspec-pred
tspec-handler tspec? tspec-tag tspec-parent?
ntspec? make-ntspec ntspec-name ntspec-meta-vars
ntspec-alts ntspec-pred ntspec-all-pred
ntspec-tag ntspec-all-tag ntspec-all-term-pred
alt? alt-syn alt-pretty alt-pretty-procedure?
make-pair-alt pair-alt? pair-alt-pattern
pair-alt-field-names pair-alt-field-levels pair-alt-field-maybes
pair-alt-accessors pair-alt-implicit? pair-alt-pred pair-alt-maker
pair-alt-tag
make-terminal-alt terminal-alt? terminal-alt-tspec
make-nonterminal-alt nonterminal-alt? nonterminal-alt-ntspec
has-implicit-alt?
spec-all-pred
spec-type
subspec?
annotate-language!
language->lang-records
language->lang-predicates
define-nanopass-record
#;define-nanopass-record-types
exists-alt?
make-pass-info pass-info? pass-info-input-language
pass-info-output-language)
(import (rnrs) (nanopass helpers) (nanopass syntaxconvert))
(define-nanopass-record)
#;(define-syntax *nanopass-record-tag* (lambda (x) (syntax-violation #f "invalid syntax" x)))
#;(define-syntax *nanopass-record-is-parent* (lambda (x) (syntax-violation #f "invalid syntax" x)))
#;(define-syntax *nanopass-record-bits* (lambda (x) (syntax-violation #f "invalid syntax" x)))
#;(define-syntax define-nanopass-record-types
(lambda (x)
(define-record-type np-rec
(fields name maker pred parent sealed? fields protocol (mutable tag) (mutable bp) (mutable c*))
(nongenerative)
(protocol
(lambda (new)
(lambda (name maker pred parent fields protocol)
(new name maker pred parent (syntax->datum parent) fields protocol #f #f '())))))
(define high-bit (fx- (fixnum-width) 2)) ; need to figure out how to use the high bit
(define figure-bits-out!
(lambda (np-rec*)
; NB. currently does not support a hierarchy, but could be extended
; NB. to support this by having the first bit in the tag indicate the
; NB. grand parent and a following specifier bit for the parent and finally
; NB. a count for the children. (partition, will become more compilcated)
(let-values ([(c* p*) (partition np-rec-sealed? np-rec*)])
(let-values ([(env bits)
(let f ([p* p*] [bp high-bit] [env '()])
(if (null? p*)
(values env (fx- high-bit bp))
(let ([p (car p*)])
(np-rec-tag-set! p (fxarithmetic-shift-left 1 bp))
(np-rec-bp-set! p bp)
(f (cdr p*) (fx- bp 1)
(cons (cons (syntax->datum (np-rec-name p)) p) env)))))])
(for-each
(lambda (c)
(cond
[(assq (syntax->datum (np-rec-parent c)) env) =>
(lambda (a) (let ([p (cdr a)]) (np-rec-c*-set! p (cons c (np-rec-c* p)))))]
[else (syntax-violation 'define-nanopass-record-types
"nanopass record parent not named in this form"
(np-rec-parent c))]))
c*)
(for-each
(lambda (p)
(let ([parent-tag (np-rec-tag p)])
(let f ([c* c*] [count 0])
(if (null? c*)
(fx- (fxfirst-bit-set (fxreverse-bit-field count 0 (fx- (fixnum-width) 1))) bits)
(let ([count (fx+ count 1)])
(let ([shift-cnt (f (cdr c*) count)] [c (car c*)])
(np-rec-tag-set! c (fxior (fxarithmetic-shift-left count shift-cnt) parent-tag))
shift-cnt))))))
p*)
bits))))
(syntax-case x ()
[(_ [name maker pred rent flds pfunc] ...)
(let ([np-rec* (map make-np-rec #'(name ...) #'(maker ...) #'(pred ...) #'(rent ...) #'(flds ...) #'(pfunc ...))])
(let ([bits (figure-bits-out! np-rec*)])
#`(begin
(define-property nanopass-record *nanopass-record-bits* #,bits)
#,@(if (null? np-rec*)
'()
(let f ([np-rec (car np-rec*)] [np-rec* (cdr np-rec*)])
(let ([e #`(begin
(define-record-type (#,(np-rec-name np-rec) #,(np-rec-maker np-rec) #,(np-rec-pred np-rec))
(nongenerative)
#,@(if (np-rec-sealed? np-rec)
#`((sealed #t) (parent #,(np-rec-parent np-rec)))
#`((parent nanopass-record)))
(fields #,@(np-rec-fields np-rec))
#,(if (np-rec-sealed? np-rec)
#`(protocol
(let ([p #,(np-rec-protocol np-rec)])
(lambda (pargs->new)
(lambda args
(apply (p pargs->new) #,(np-rec-tag np-rec) args)))))
#`(protocol #,(np-rec-protocol np-rec))))
(define-property #,(np-rec-name np-rec) *nanopass-record-tag* #,(np-rec-tag np-rec))
#,@(if (np-rec-bp np-rec)
#`((define-property #,(np-rec-name np-rec) *nanopass-record-is-parent* #,(np-rec-tag np-rec)))
#'()))])
(if (null? np-rec*)
(list e)
(cons e (f (car np-rec*) (cdr np-rec*))))))))))])))
(define-record-type language
(fields name entry-ntspec tspecs ntspecs (mutable rtd) (mutable rcd) (mutable tag-mask) nongenerative-id)
(nongenerative)
(protocol
(lambda (new)
(lambda (name entry-ntspec tspecs ntspecs nongen-id)
(define check-meta!
(let ()
(define (spec-meta-vars spec) (if (ntspec? spec) (ntspec-meta-vars spec) (tspec-meta-vars spec)))
(define (spec-name spec) (if (ntspec? spec) (ntspec-name spec) (tspec-type spec)))
(lambda (lang-name tspecs ntspecs)
(let f ([specs (append tspecs ntspecs)])
(unless (null? specs)
(let ([test-spec (car specs)])
(for-each
(lambda (mv)
(let ([mv-sym (syntax->datum mv)])
(for-each
(lambda (spec)
(when (memq mv-sym (syntax->datum (spec-meta-vars spec)))
(syntax-violation 'define-language
(format "the forms ~s and ~s in language ~s uses the same meta-variable"
(syntax->datum (spec-name test-spec))
(syntax->datum (spec-name spec)) (syntax->datum lang-name))
mv)))
(cdr specs))))
(spec-meta-vars test-spec)))
(f (cdr specs)))))))
(check-meta! name tspecs ntspecs)
(new name entry-ntspec tspecs ntspecs #f #f #f nongen-id)))))
(define-record-type tspec
(fields meta-vars type handler (mutable pred) (mutable tag) (mutable parent?))
(nongenerative)
(protocol
(lambda (new)
(case-lambda
[(type meta-vars) (new meta-vars type #f #f #f #f)]
[(type meta-vars handler) (new meta-vars type handler #f #f #f)]))))
(define-record-type ntspec
(fields name meta-vars alts
(mutable rtd)
(mutable rcd)
(mutable tag)
(mutable pred) ; this record?
(mutable all-pred) ; this record or valid sub-grammar element
; e.g., if Rhs -> Triv, Triv -> Lvalue, and Lvalue -> var,
; then all-pred returns true for any Rhs, Triv, Lvalue, or var
(mutable all-term-pred) ; this record's term sub-grammar elements
(mutable all-tag)) ; tag for this record logor all sub grammar elements
; following all-pred order
(nongenerative)
(protocol
(lambda (new)
(lambda (name meta-vars alts)
(new name meta-vars alts #f #f #f #f #f #f #f)))))
(define-record-type alt
(fields syn pretty pretty-procedure?)
(nongenerative))
(define-record-type pair-alt
(parent alt)
(fields
(mutable rtd)
(mutable pattern)
(mutable field-names)
(mutable field-levels)
(mutable field-maybes)
(mutable implicit? pair-alt-implicit? pair-alt-implicit-set!)
(mutable tag)
(mutable pred)
(mutable maker)
(mutable accessors))
(nongenerative)
(sealed #t)
(protocol
(lambda (pargs->new)
(lambda (syn pretty pretty-procedure?)
((pargs->new syn pretty pretty-procedure?)
#f #f #f #f #f #f #f #f #f #f)))))
(define-record-type terminal-alt
(parent alt)
(fields (mutable tspec))
(nongenerative)
(sealed #t)
(protocol
(lambda (pargs->new)
(lambda (syn pretty pretty-procedure?)
((pargs->new syn pretty pretty-procedure?) #f)))))
(define-record-type nonterminal-alt
(parent alt)
(fields (mutable ntspec))
(nongenerative)
(sealed #t)
(protocol
(lambda (pargs->new)
(lambda (syn pretty pretty-procedure?)
((pargs->new syn pretty pretty-procedure?) #f)))))
(define-who spec-all-pred
(lambda (x)
(cond
[(tspec? x) (tspec-pred x)]
[(ntspec? x) (ntspec-all-pred x)]
[else (error who "unrecognized type" x)])))
(define-who spec-type
(lambda (x)
(cond
[(tspec? x) (tspec-type x)]
[(ntspec? x) (ntspec-name x)]
[else (error who "unrecognized type" x)])))
;;; records produced by meta parsers
(define-record-type nano-dots (fields x) (nongenerative) (sealed #t))
(define-record-type nano-quote (fields x) (nongenerative) (sealed #t))
(define-record-type nano-unquote (fields x) (nongenerative) (sealed #t))
(define-record-type nano-meta (fields alt fields) (nongenerative) (sealed #t))
(define-record-type nano-cata
(fields itype syntax procexpr maybe-inid* outid* maybe?)
(nongenerative)
(sealed #t))
;; record helpers
(define find-spec
(lambda (m lang)
(let ([name (meta-var->raw-meta-var (syntax->datum m))])
(or (find (lambda (ntspec)
(memq name (syntax->datum (ntspec-meta-vars ntspec))))
(language-ntspecs lang))
(find (lambda (tspec)
(memq name (syntax->datum (tspec-meta-vars tspec))))
(language-tspecs lang))
(syntax-violation #f "meta not found" (language-name lang) m)))))
(define nonterminal-meta?
(lambda (m ntspec*)
(let ([m (meta-var->raw-meta-var (syntax->datum m))])
(exists (lambda (x) (memq m (syntax->datum (ntspec-meta-vars x))))
ntspec*))))
(define nonterminal-meta->ntspec
(lambda (meta ntspecs)
(let ([meta (meta-var->raw-meta-var (syntax->datum meta))])
(find (lambda (x) (memq meta (syntax->datum (ntspec-meta-vars x))))
ntspecs))))
(define terminal-meta->tspec
(lambda (meta tspecs)
(let ([meta (meta-var->raw-meta-var (syntax->datum meta))])
(find (lambda (x) (memq meta (syntax->datum (tspec-meta-vars x))))
tspecs))))
(define meta->pred
(lambda (m lang)
(let ([name (meta-var->raw-meta-var (syntax->datum m))])
(or (find (lambda (ntspec)
(and (memq name (syntax->datum (ntspec-meta-vars ntspec)))
(ntspec-all-pred ntspec)))
(language-ntspecs lang))
(find (lambda (tspec)
(and (memq name (syntax->datum (tspec-meta-vars tspec)))
(tspec-pred tspec)))
(language-tspecs lang))
(syntax-violation #f "meta not found" (language-name lang) m)))))
(define id->spec
(lambda (id lang)
(or (nonterm-id->ntspec? id (language-ntspecs lang))
(term-id->tspec? id (language-tspecs lang)))))
(define term-id->tspec?
(lambda (id tspecs)
(let ([type (syntax->datum id)])
(find (lambda (tspec) (eq? (syntax->datum (tspec-type tspec)) type))
tspecs))))
(define nonterm-id->ntspec?
(lambda (id ntspecs)
(let ([ntname (syntax->datum id)])
(find (lambda (ntspec) (eq? (syntax->datum (ntspec-name ntspec)) ntname))
ntspecs))))
(define-syntax nonterm-id->ntspec
(syntax-rules ()
[(_ ?who ?id ?ntspecs)
(let ([id ?id])
(or (nonterm-id->ntspec? id ?ntspecs)
(syntax-violation ?who "unrecognized non-terminal" id)))]))
(define-who meta-name->tspec
(lambda (m tspecs)
(let ([m (meta-var->raw-meta-var (syntax->datum m))])
(find (lambda (tspec)
(memq m (syntax->datum (tspec-meta-vars tspec))))
tspecs))))
(define-who meta-name->ntspec
(lambda (m ntspecs)
(let ([m (meta-var->raw-meta-var (syntax->datum m))])
(find (lambda (ntspec)
(memq m (syntax->datum (ntspec-meta-vars ntspec))))
ntspecs))))
(define subspec?
(lambda (maybe-subspec spec)
(let loop ([spec* (list spec)] [seen* '()])
(and (not (null? spec*))
(let ([spec (car spec*)])
(or (eq? maybe-subspec spec)
(loop
(if (tspec? spec)
(cdr spec*)
(fold-left
(lambda (spec* alt)
(cond
[(terminal-alt? alt)
(let ([spec (terminal-alt-tspec alt)])
(if (memq spec seen*)
spec*
(cons spec spec*)))]
[(nonterminal-alt? alt)
(let ([spec (nonterminal-alt-ntspec alt)])
(if (memq spec seen*)
spec*
(cons spec spec*)))]
[else spec*]))
(cdr spec*)
(ntspec-alts spec)))
(cons spec seen*))))))))
(define type->pred-prefixes
(lambda (id mrec)
(define find-related-ntspecs
(lambda (ntspec mrec)
(let ([ntspecs (language-ntspecs mrec)])
(let f ([alts (ntspec-alts ntspec)] [ls '()])
(fold-left (lambda (ls alt)
(if (nonterminal-alt? alt)
(let ([ntspec (nonterminal-alt-ntspec alt)])
(cons ntspec (f (ntspec-alts ntspec) ls)))
ls))
ls alts)))))
(define find
(lambda (specs)
(cond
[(null? specs) #f]
[(eq? (syntax->datum id)
(syntax->datum
(let ([spec (car specs)])
(cond
[(tspec? spec) (tspec-type spec)]
[(ntspec? spec) (ntspec-name spec)]
[else (error 'type->pred-prefixes
"unable to find matching spec, wrong type"
spec)]))))
(car specs)]
[else (find (cdr specs))])))
(let ([found (find (language-tspecs mrec))])
(if found
(list found)
(let ([found (find (language-ntspecs mrec))])
(if found
(let ([ntspecs (find-related-ntspecs found mrec)])
(cons found ntspecs))
(error 'type->pred-prefixes "unrecognized non-terminal"
id)))))))
(define has-implicit-alt?
(lambda (ntspec)
(exists
(lambda (alt)
(if (pair-alt? alt)
(pair-alt-implicit? alt)
(and (nonterminal-alt? alt)
(has-implicit-alt? (nonterminal-alt-ntspec alt)))))
(ntspec-alts ntspec))))
(define gather-meta
(lambda (lang)
(let ([tmeta (map tspec-meta-vars (language-tspecs lang))]
[pmeta (map ntspec-meta-vars (language-ntspecs lang))])
(apply append (append tmeta pmeta)))))
(define annotate-language!
(lambda (r lang id)
(let ([lang-name (language-name lang)] [nongen-id (language-nongenerative-id lang)])
(let ([lang-rec-id (construct-unique-id id lang-name "-record")]
[tspec* (language-tspecs lang)]
[ntspec* (language-ntspecs lang)]
[np-bits #f #;(r #'nanopass-record #'*nanopass-record-bits*)]
[nongen-sym (and nongen-id (syntax->datum nongen-id))])
;; Needs to return #t because it ends up encoded in a field this way
(define meta?
(lambda (m)
(let ([m (meta-var->raw-meta-var (syntax->datum m))])
(or (exists (lambda (tspec) (memq m (syntax->datum (tspec-meta-vars tspec)))) tspec*)
(exists (lambda (ntspec) (memq m (syntax->datum (ntspec-meta-vars ntspec)))) ntspec*)))))
(define annotate-tspec!
(lambda (tspec-tag-all tspec)
(let ([t (tspec-type tspec)])
(tspec-pred-set! tspec (construct-id t t "?"))
(let ([tag #f #;(guard (c [else #f]) (r t #'*nanopass-record-tag*))])
(if tag
(begin
(tspec-tag-set! tspec tag)
(tspec-parent?-set! tspec #f #;(r t #'*nanopass-record-is-parent*))
(fxior tag tspec-tag-all))
tspec-tag-all)))))
(define-who annotate-alt*!
(lambda (bits)
(lambda (alt-all-tag ntspec)
(let ([tag (ntspec-tag ntspec)] [nt-rtd (ntspec-rtd ntspec)] [ntname (ntspec-name ntspec)])
(let ([ntname-sym (syntax->datum ntname)])
(let f ([alt* (ntspec-alts ntspec)] [next 1] [alt-all-tag alt-all-tag])
(if (null? alt*)
alt-all-tag
(let ([a (car alt*)] [alt* (cdr alt*)])
(cond
[(pair-alt? a)
(let* ([syn (alt-syn a)]
[name (car syn)]
[rec-name (unique-name lang-name ntname name)]
[m? (meta? name)])
(let-values ([(p fields levels maybes) (convert-pattern (if m? syn (cdr syn)))])
(unless (all-unique-identifiers? fields)
(syntax-violation 'define-language "found one or more duplicate fields in production" syn))
(let ([tag (fx+ (fxarithmetic-shift-left next bits) tag)])
(pair-alt-tag-set! a tag)
(pair-alt-rtd-set! a
(make-record-type-descriptor (string->symbol rec-name) nt-rtd
(if nongen-sym
(regensym nongen-sym
(format ":~s:~s" ntname-sym (syntax->datum name))
(format "-~s" tag))
(gensym rec-name))
#t #f
(let loop ([fields fields] [count 0])
(if (null? fields)
(make-vector count)
(let ([v (loop (cdr fields) (fx+ count 1))])
(vector-set! v count `(immutable ,(syntax->datum (car fields))))
v)))))
(pair-alt-pattern-set! a p)
(pair-alt-field-names-set! a fields)
(pair-alt-field-levels-set! a levels)
(pair-alt-field-maybes-set! a maybes)
(pair-alt-implicit-set! a m?)
(pair-alt-accessors-set! a
(map (lambda (field)
(construct-unique-id id rec-name "-" field))
fields))
(pair-alt-pred-set! a (construct-unique-id id rec-name "?"))
(pair-alt-maker-set! a (construct-unique-id id "make-" rec-name))
(f alt* (fx+ next 1) (fxior alt-all-tag tag)))))]
[(nonterminal-alt? a)
(let ([a-ntspec (nonterminal-meta->ntspec (alt-syn a) ntspec*)])
(unless a-ntspec
(syntax-violation 'define-language "no nonterminal for meta-variable"
lang-name (alt-syn a)))
(nonterminal-alt-ntspec-set! a a-ntspec)
(f alt* next alt-all-tag))]
[(terminal-alt? a)
(let ([tspec (terminal-meta->tspec (alt-syn a) tspec*)])
(unless tspec
(syntax-violation 'define-language "no terminal for meta-variable"
lang-name (alt-syn a)))
(terminal-alt-tspec-set! a tspec)
(f alt* next alt-all-tag))]
[else (errorf who "unexpected terminal alt ~s" a)])))))))))
(define annotate-ntspec*!
(lambda (ntspec*)
(let f ([nt-counter 0] [ntspec* ntspec*])
(if (null? ntspec*)
nt-counter
(let ([ntspec (car ntspec*)] [ntspec* (cdr ntspec*)])
(let ([nterm (ntspec-name ntspec)])
(let ([nt-rec-name (unique-name lang-name nterm)])
(let ([nt-rtd (make-record-type-descriptor
(string->symbol nt-rec-name)
(language-rtd lang)
(if nongen-sym
(regensym nongen-sym
(format ":~s"
(syntax->datum nterm))
(format "-~d" nt-counter))
(gensym nt-rec-name))
#f #f (vector))])
(ntspec-tag-set! ntspec nt-counter)
(ntspec-rtd-set! ntspec nt-rtd)
(ntspec-rcd-set! ntspec
(make-record-constructor-descriptor nt-rtd
(language-rcd lang) #f))
(ntspec-pred-set! ntspec (construct-unique-id id nt-rec-name "?"))
(f (fx+ nt-counter 1) ntspec*)))))))))
(define-who annotate-all-pred!
(lambda (ntspec)
(let ([all-pred (ntspec-all-pred ntspec)])
(cond
[(eq? all-pred 'processing) (syntax-violation 'define-language "found mutually recursive nonterminals" (ntspec-name ntspec))]
[all-pred (values all-pred (ntspec-all-term-pred ntspec) (ntspec-all-tag ntspec))]
[else
(ntspec-all-pred-set! ntspec 'processing)
(let f ([alt* (ntspec-alts ntspec)] [pred* '()] [term-pred* '()] [tag '()])
(if (null? alt*)
(let ([all-pred (if (null? pred*)
(ntspec-pred ntspec)
#`(lambda (x)
(or (#,(ntspec-pred ntspec) x)
#,@(map (lambda (pred) #`(#,pred x)) pred*))))]
[all-term-pred (cond
[(null? term-pred*) #f]
[(null? (cdr term-pred*)) (car term-pred*)]
[else #`(lambda (x) (or #,@(map (lambda (pred) #`(#,pred x)) term-pred*)))])]
[tag (cons (ntspec-tag ntspec) tag)])
(ntspec-all-pred-set! ntspec all-pred)
(ntspec-all-term-pred-set! ntspec all-term-pred)
(ntspec-all-tag-set! ntspec tag)
(values all-pred all-term-pred tag))
(let ([alt (car alt*)])
(cond
[(pair-alt? alt) (f (cdr alt*) pred* term-pred* tag)]
[(terminal-alt? alt)
(let* ([tspec (terminal-alt-tspec alt)]
[new-tag (tspec-tag tspec)]
[pred (tspec-pred tspec)])
(f (cdr alt*) (cons pred pred*)
(if #f #;new-tag term-pred* (cons pred term-pred*))
(if #f #;new-tag (fxior new-tag tag) tag)))]
[(nonterminal-alt? alt)
(let-values ([(pred term-pred new-tag) (annotate-all-pred! (nonterminal-alt-ntspec alt))])
(f (cdr alt*) (cons pred pred*)
(if term-pred (cons term-pred term-pred*) term-pred*)
(append new-tag tag)))]
[else (errorf who "unexpected alt ~s" alt)]))))]))))
(let ([lang-rtd (make-record-type-descriptor (syntax->datum lang-name)
(record-type-descriptor nanopass-record)
(let ([nongen-id (language-nongenerative-id lang)])
(if nongen-id
(syntax->datum nongen-id)
(gensym (unique-name lang-name))))
#f #f (vector))])
(language-rtd-set! lang lang-rtd)
(language-rcd-set! lang
(make-record-constructor-descriptor lang-rtd
(record-constructor-descriptor nanopass-record) #f)))
(let ([tspec-tag-bits (fold-left annotate-tspec! 0 tspec*)])
(let ([nt-counter (annotate-ntspec*! ntspec*)])
(let ([bits (fxlength nt-counter)])
(unless (fxzero? (fxand tspec-tag-bits (fx- (fxarithmetic-shift-left 1 bits) 1)))
(syntax-violation 'define-language "nanopass-record tags interfere with language production tags"
lang-name))
(language-tag-mask-set! lang (fx- (fxarithmetic-shift-left 1 bits) 1))
(let ([ntalt-tag-bits (fold-left (annotate-alt*! bits) 0 ntspec*)])
(unless (or (not np-bits)
(fxzero? (fxand ntalt-tag-bits
(fxreverse-bit-field (fx- (fxarithmetic-shift-left 1 np-bits) 1)
0 (fx- (fixnum-width) 1)))))
(syntax-violation 'define-language "language production tags interfere with nanopass-record tags"
lang-name))
(for-each annotate-all-pred! ntspec*)))))))))
(define language->lang-records
(lambda (lang)
(let ([ntspecs (language-ntspecs lang)] [tspecs (language-tspecs lang)])
(define alt->lang-record
(lambda (ntspec alt)
; TODO: handle fld and msgs that are lists.
(define build-field-check
(lambda (fld msg level maybe?)
(with-values
(cond
[(nonterminal-meta->ntspec fld ntspecs) =>
(lambda (ntspec) (values (ntspec-all-pred ntspec) (ntspec-name ntspec)))]
[(terminal-meta->tspec fld tspecs) =>
(lambda (tspec) (values (tspec-pred tspec) (tspec-type tspec)))]
[else (syntax-violation 'define-language
(format "unrecognized meta-variable in language ~s"
(syntax->datum (language-name lang)))
fld)])
(lambda (pred? name)
(define (build-list-of-string level name)
(let loop ([level level] [str ""])
(if (fx=? level 0)
(string-append str (symbol->string (syntax->datum name)))
(loop (fx- level 1) (string-append str "list of ")))))
(with-syntax ([pred? (if maybe?
#`(lambda (x) (or (eq? x #f) (#,pred? x)))
pred?)])
#`(#,(let f ([level level])
(if (fx=? level 0)
#`(lambda (x)
(unless (pred? x)
(let ([msg #,msg])
(if msg
(errorf who
"expected ~s but received ~s in field ~s of ~s from ~a"
'#,name x '#,fld '#,(alt-syn alt) msg)
(errorf who
"expected ~s but received ~s in field ~s of ~s"
'#,name x '#,fld '#,(alt-syn alt))))))
#`(lambda (x)
(let loop ([x x])
(cond
[(pair? x)
(#,(f (fx- level 1)) (car x))
(loop (cdr x))]
[(null? x)]
[else
(let ([msg #,msg])
(if msg
(errorf who
"expected ~a but received ~s in field ~s of ~s from ~a"
#,(build-list-of-string level name) x '#,fld '#,(alt-syn alt) msg)
(errorf who
"expected ~a but received ~s in field ~s of ~s"
#,(build-list-of-string level name) x '#,fld '#,(alt-syn alt))))])))))
#,fld))))))
(with-syntax ([(fld ...) (pair-alt-field-names alt)])
(with-syntax ([(msg ...) (generate-temporaries #'(fld ...))]
[(idx ...) (iota (length #'(fld ...)))]
[(accessor ...) (pair-alt-accessors alt)]
[(rtd ...) (make-list (length #'(fld ...)) (pair-alt-rtd alt))])
#`(begin
(define #,(pair-alt-pred alt) (record-predicate '#,(pair-alt-rtd alt)))
(define #,(pair-alt-maker alt)
(let ()
(define rcd
(make-record-constructor-descriptor '#,(pair-alt-rtd alt)
'#,(ntspec-rcd ntspec)
(lambda (pargs->new)
(lambda (fld ...)
((pargs->new #,(pair-alt-tag alt)) fld ...)))))
(define maker (record-constructor rcd))
(lambda (who fld ... msg ...)
#,@(if (fx=? (optimize-level) 3)
'()
(map build-field-check #'(fld ...) #'(msg ...)
(pair-alt-field-levels alt)
(pair-alt-field-maybes alt)))
(maker fld ...))))
(define accessor (record-accessor 'rtd idx)) ...)))))
(define ntspec->lang-record
(lambda (ntspec)
#`(define #,(ntspec-pred ntspec) (record-predicate '#,(ntspec-rtd ntspec)))))
(define ntspecs->lang-records
(lambda (ntspec*)
(let f ([ntspec* ntspec*] [ntrec* '()] [altrec* '()])
(if (null? ntspec*)
#`(#,ntrec* #,altrec*)
(let ([ntspec (car ntspec*)])
(let g ([alt* (ntspec-alts ntspec)] [altrec* altrec*])
(if (null? alt*)
(f (cdr ntspec*)
(cons (ntspec->lang-record ntspec) ntrec*)
altrec*)
(let ([alt (car alt*)])
(if (pair-alt? alt)
(g (cdr alt*)
(cons (alt->lang-record ntspec alt) altrec*))
(g (cdr alt*) altrec*))))))))))
(define ntspecs->indirect-id*
(lambda (ntspec*)
(let f ([ntspec* ntspec*] [id* '()])
(if (null? ntspec*)
id*
(let ([ntspec (car ntspec*)])
(let g ([alt* (ntspec-alts ntspec)] [id* id*])
(if (null? alt*)
(f (cdr ntspec*) (cons (ntspec-pred ntspec) id*))
(g (cdr alt*)
(let ([alt (car alt*)])
(if (pair-alt? alt)
(cons* (pair-alt-pred alt)
(pair-alt-maker alt)
(append (pair-alt-accessors alt) id*))
id*))))))))))
(with-syntax ([((ntrec ...) (altrec ...))
(ntspecs->lang-records (language-ntspecs lang))]
[lang-id (language-name lang)]
[(indirect-id* ...) (ntspecs->indirect-id* (language-ntspecs lang))])
#`(ntrec ... altrec ... (indirect-export lang-id indirect-id* ...))))))
(define language->lang-predicates
(lambda (desc)
(let ([name (language-name desc)])
(let loop ([ntspecs (language-ntspecs desc)] [nt?* '()] [term?* '()])
(if (null? ntspecs)
(with-syntax ([lang? (construct-id name name "?")]
[(nt? ...) nt?*]
[(term? ...) term?*])
#`((define lang?
(lambda (x)
(or ((record-predicate '#,(language-rtd desc)) x) (term? x) ...)))
nt? ...))
(let ([ntspec (car ntspecs)])
(loop (cdr ntspecs)
(with-syntax ([nt? (construct-id name name "-" (ntspec-name ntspec) "?")]
[lambda-expr (ntspec-all-pred ntspec)])
(cons #'(define nt? lambda-expr) nt?*))
(let loop ([alts (ntspec-alts ntspec)] [term?* term?*])
(if (null? alts)
term?*
(loop (cdr alts)
(let ([alt (car alts)])
(if (terminal-alt? alt)
(cons (tspec-pred (terminal-alt-tspec alt)) term?*)
term?*))))))))))))
;; utilities moved out of pass.ss
(define-who exists-alt?
(lambda (ialt ntspec)
(define scan-alts
(lambda (pred?)
(let f ([alt* (ntspec-alts ntspec)])
(if (null? alt*)
#f
(let ([alt (car alt*)])
(if (nonterminal-alt? alt)
(or (f (ntspec-alts (nonterminal-alt-ntspec alt)))
(f (cdr alt*)))
(if (pred? alt) alt (f (cdr alt*)))))))))
(cond
[(terminal-alt? ialt)
(let ([type (syntax->datum (tspec-type (terminal-alt-tspec ialt)))])
(scan-alts
(lambda (alt)
(and (terminal-alt? alt)
(eq? (syntax->datum (tspec-type (terminal-alt-tspec alt))) type)))))]
[(pair-alt? ialt)
(if (pair-alt-implicit? ialt)
(let ([pattern (pair-alt-pattern ialt)])
(scan-alts
(lambda (alt)
(and (pair-alt? alt)
(pair-alt-implicit? alt)
(let ([apattern (pair-alt-pattern alt)])
(equal? apattern pattern))))))
(let ([pattern (pair-alt-pattern ialt)])
(scan-alts
(lambda (alt)
(and (pair-alt? alt)
(not (pair-alt-implicit? alt))
(let ([apattern (pair-alt-pattern alt)])
(and (eq? (syntax->datum (car (alt-syn alt))) (syntax->datum (car (alt-syn ialt))))
(equal? apattern pattern))))))))]
[else (error who "unexpected alt" ialt)])))
;; record type used to transport data in the compile-time environment.
(define-record-type pass-info
(nongenerative)
(fields input-language output-language)))

55
ta6ob/nanopass/nanopass/syntactic-property.sls Normal file
View file

@ -0,0 +1,55 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
;; implements a global association list from bound-identifiers to property
;; lists property lists are themselves assogiation lists from free-identifiers
;; to values.
(library (nanopass syntactic-property)
(export syntax-property-set! syntax-property-get)
(import (rnrs))
(define-record-type ($box box box?) (nongenerative) (fields (mutable v unbox box-set!)))
(define props (box '()))
(define syntax-property-set!
(lambda (id key value)
(box-set! props
(let f ([props (unbox props)])
(if (null? props)
(list (cons id (list (cons key value))))
(let ([as (car props)] [props (cdr props)])
(if (bound-identifier=? (car as) id)
(cons (cons id (cons (cons key value) (cdr as))) props)
(cons as (f props)))))))))
(define syntax-property-get
(case-lambda
[(id key)
(let loop ([props (unbox props)])
(if (null? props)
(error 'syntax-property-get "no properties for ~s found" (syntax->datum id))
(let ([as (car props)] [props (cdr props)])
(if (bound-identifier=? (car as) id)
(let loop ([ls (cdr as)])
(if (null? ls)
(error 'syntax-propert-get "no property ~s for ~s found" (syntax->datum key) (syntax->datum id))
(let ([as (car ls)] [ls (cdr ls)])
(if (free-identifier=? (car as) key)
(cdr as)
(loop ls)))))
(loop props)))))]
[(id key not-found)
(let loop ([props (unbox props)])
(if (null? props)
not-found
(let ([as (car props)] [props (cdr props)])
(if (bound-identifier=? (car as) id)
(let loop ([ls (cdr as)])
(if (null? ls)
not-found
(let ([as (car ls)] [ls (cdr ls)])
(if (free-identifier=? (car as) key)
(cdr as)
(loop ls)))))
(loop props)))))])))

45
ta6ob/nanopass/nanopass/syntaxconvert.ss Normal file
View file

@ -0,0 +1,45 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass syntaxconvert)
(export convert-pattern)
(import (rnrs) (nanopass helpers))
(define convert-pattern
; accepts pattern & keys
; returns syntax-dispatch pattern & ids
(lambda (pattern)
(define cvt*
(lambda (p* n flds lvls maybes)
(if (null? p*)
(values '() flds lvls maybes)
(let-values ([(y flds lvls maybes) (cvt* (cdr p*) n flds lvls maybes)])
(let-values ([(x flds lvls maybes) (cvt (car p*) n flds lvls maybes)])
(values (cons x y) flds lvls maybes))))))
(define cvt
(lambda (p n flds lvls maybes)
(if (identifier? p)
(values 'any (cons p flds) (cons n lvls) (cons #f maybes))
(syntax-case p ()
[(x dots)
(ellipsis? (syntax dots))
(let-values ([(p flds lvls maybes) (cvt (syntax x) (fx+ n 1) flds lvls maybes)])
(values (if (eq? p 'any) 'each-any (vector 'each p)) flds lvls maybes))]
[(x dots y ... . z)
(ellipsis? (syntax dots))
(let-values ([(z flds lvls maybes) (cvt (syntax z) n flds lvls maybes)])
(let-values ([(y flds lvls maybes) (cvt* (syntax (y ...)) n flds lvls maybes)])
(let-values ([(x flds lvls maybes) (cvt (syntax x) (fx+ n 1) flds lvls maybes)])
(values `#(each+ ,x ,(reverse y) ,z) flds lvls maybes))))]
[(maybe x)
(and (identifier? #'x) (eq? (datum maybe) 'maybe))
(values 'any (cons #'x flds) (cons n lvls) (cons #t maybes))]
[(x . y)
(let-values ([(y flds lvls maybes) (cvt (syntax y) n flds lvls maybes)])
(let-values ([(x flds lvls maybes) (cvt (syntax x) n flds lvls maybes)])
(values (cons x y) flds lvls maybes)))]
[() (values '() flds lvls maybes)]
[oth (syntax-violation 'cvt "unable to find match" #'oth)]))))
(cvt pattern 0 '() '() '()))))

150
ta6ob/nanopass/nanopass/unparser.ss Normal file
View file

@ -0,0 +1,150 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (nanopass unparser)
(export define-unparser)
(import (rnrs)
(nanopass helpers)
(nanopass records)
(nanopass syntaxconvert))
(define-syntax define-unparser
(lambda (x)
(define make-unparser-name-assoc
(lambda (tid)
(lambda (ntspec)
(cons ntspec (construct-unique-id tid "unparse-" (syntax->datum (ntspec-name ntspec)))))))
(define make-unparse-term-clause-body-assoc
(lambda (tspec)
(cons tspec
(let ([h (tspec-handler tspec)])
(if h
#`(if raw? ir (#,h ir))
#'ir)))))
(define make-unparser
(lambda (unparser-name desc)
(let* ([lang-name (language-name desc)]
[ntspecs (language-ntspecs desc)]
[tspecs (language-tspecs desc)]
[unparser-names (map (make-unparser-name-assoc unparser-name) ntspecs)]
[tspec-bodies (map make-unparse-term-clause-body-assoc tspecs)])
(define (lookup-unparser ntspec)
(cond
[(assq ntspec unparser-names) => cdr]
[else (syntax-violation 'define-unparser
(format "unexpected nonterminal ~s in language ~s, expected one of ~s"
(syntax->datum (ntspec-name ntspec)) (syntax->datum lang-name)
(map (lambda (nt) (syntax->datum (ntspec-name nt))) ntspecs))
unparser-name x)]))
(define (lookup-tspec-body tspec)
(cond
[(assq tspec tspec-bodies) => cdr]
[else (syntax-violation 'define-unparser
(format "unexpected terminal ~s in language ~s, expected one of ~s"
(syntax->datum (tspec-type tspec)) (syntax->datum lang-name)
(map (lambda (t) (syntax->datum (tspec-type t))) tspecs))
unparser-name x)]))
(with-syntax ([unparser-name unparser-name]
[(proc-name ...) (map cdr unparser-names)]
[(ntspec? ...) (map ntspec-pred ntspecs)]
[(tspec? ...) (map tspec-pred tspecs)]
[(tspec-body ...) (map cdr tspec-bodies)])
(define make-unparse-proc
(lambda (ntspec)
;; handles alts of the form: LambdaExpr where LambdaExpr is another
;; non-terminal specifier with no surrounding markers.
(define make-nonterm-clause
(lambda (alt)
(let ([ntspec (nonterminal-alt-ntspec alt)])
(list #`((#,(ntspec-all-pred ntspec) ir)
(#,(lookup-unparser ntspec) ir))))))
;; handles alts of the form: x, c where x and c are meta-variables
;; that refer to terminals, and have no surrounding marker.
(define-who make-term-clause ;; only atom alt cases
(lambda (alt)
(let ([tspec (terminal-alt-tspec alt)])
#`((#,(tspec-pred tspec) ir)
#,(lookup-tspec-body tspec)))))
(define strip-maybe
(lambda (tmpl)
(syntax-case tmpl (maybe)
[(maybe x) (and (identifier? #'x) (eq? (datum maybe) 'maybe)) #'x]
[(a . d) (with-syntax ([a (strip-maybe #'a)] [d (strip-maybe #'d)]) #'(a . d))]
[() tmpl]
[oth tmpl])))
(define build-accessor-expr
(lambda (acc level maybe?)
(let loop ([level level] [f #`(lambda (t)
#,(if maybe?
#'(and t (unparser-name t raw?))
#'(unparser-name t raw?)))])
(if (fx=? level 0)
#`(#,f (#,acc ir))
(loop (fx- level 1) #`(lambda (t) (map #,f t)))))))
(define build-template-wrapper
(lambda (tmpl alt)
(with-syntax ([(e ...) (map build-accessor-expr
(pair-alt-accessors alt)
(pair-alt-field-levels alt)
(pair-alt-field-maybes alt))]
[(fld ...) (pair-alt-field-names alt)]
[tmpl tmpl])
#'(let ([fld e] ...)
(with-extended-quasiquote
(with-auto-unquote (fld ...) `tmpl))))))
(define make-pair-clause
(lambda (alt)
(with-syntax ([pred? (pair-alt-pred alt)]
[raw-body (build-template-wrapper (strip-maybe (alt-syn alt)) alt)])
#`((pred? ir)
#,(let ([pretty (alt-pretty alt)])
(if pretty
#`(if raw?
raw-body
#,(if (alt-pretty-procedure? alt)
(with-syntax ([(acc ...) (pair-alt-accessors alt)])
#`(#,pretty unparser-name (acc ir) ...))
(build-template-wrapper pretty alt)))
#'raw-body))))))
;; When one nonterminalA alternative is another nonterminalB, we
;; expand all the alternatives of nonterminalB with the alternatives
;; of nonterminalA However, nonterminalA and nonterminalB cannot
;; (both) have an implicit case, by design.
(partition-syn (ntspec-alts ntspec)
([term-alt* terminal-alt?] [nonterm-alt* nonterminal-alt?] [pair-alt* otherwise])
(partition-syn nonterm-alt*
([nonterm-imp-alt* (lambda (alt)
(has-implicit-alt?
(nonterminal-alt-ntspec alt)))]
[nonterm-nonimp-alt* otherwise])
#`(lambda (ir)
(cond
#,@(map make-term-clause term-alt*)
#,@(map make-pair-clause pair-alt*)
;; note: the following two can potentially be combined
#,@(apply append (map make-nonterm-clause nonterm-nonimp-alt*))
#,@(apply append (map make-nonterm-clause nonterm-imp-alt*))
[else (error who "invalid record" ir)]))))))
(with-syntax ([(proc ...) (map make-unparse-proc ntspecs)])
#'(define-who unparser-name
(case-lambda
[(ir) (unparser-name ir #f)]
[(ir raw?)
(define-who proc-name proc) ...
(cond
[(ntspec? ir) (proc-name ir)] ...
[(tspec? ir) tspec-body] ...
[else (error who "unrecognized language record" ir)])])))))))
(syntax-case x ()
[(_ name lang)
(and (identifier? #'name) (identifier? #'lang))
(with-compile-time-environment (r)
(let ([l-pair (r #'lang)])
(unless (pair? l-pair)
(syntax-violation 'define-unparser "unknown language" #'lang x))
(make-unparser #'name (car l-pair))))]))))

29
ta6ob/nanopass/test-all.ss Executable file
View file

@ -0,0 +1,29 @@
;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(import (rnrs) (tests compiler-test) (tests helpers) (tests unit-tests) (nanopass helpers))
(printf "Running unit tests\n")
(let* ([succeeded? (run-unit-tests)]
[succeeded? (and (run-ensure-correct-identifiers) succeeded?)]
[succeeded? (and (run-maybe-tests) succeeded?)]
[succeeded? (and (run-maybe-dots-tests) succeeded?)]
[succeeded? (and (run-maybe-unparse-tests) succeeded?)]
[succeeded? (and (run-language-dot-support) succeeded?)]
[succeeded? (and (run-argument-name-matching) succeeded?)]
[succeeded? (and (run-error-messages) succeeded?)]
[succeeded? (and (run-pass-parser-unparser) succeeded?)])
(printf "Compiler loaded, running all tests (quietly)\n")
(time
(begin
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)
(run-all-tests)))
(exit (if succeeded? 0 1)))

926
ta6ob/nanopass/tests/alltests.ss Normal file
View file

@ -0,0 +1,926 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests alltests)
(export main-tests final-tests)
(import (rnrs))
(define main-tests
'(
'()
(- 2 4)
(* -6 7)
(cons 0 '())
(cons (cons 0 '()) (cons 1 '()))
(void)
(if #f 3)
(let ((x 0)) x)
(let ([x 0]) x x)
(let ([q (add1 (add1 2))]) q)
(+ 20 (if #t 122))
(if #t
(+ 20
(if #t 122))
10000)
(not (if #f #t (not #f)))
(let ([x 0][y 4000]) x)
(begin (if #f 7) 3)
(begin (if (zero? 4) 7) 3)
(let ([x 0]) (begin (if (zero? x) 7) x))
(let ([x 0]) (begin (if (zero? x) (begin x 7)) x))
(let ([x 0] [z 9000])
(begin (if (zero? x) (begin x 7)) z))
(let ([x 0] [z 9000])
(begin (if (zero? x) (begin (set! x x) 7))
(+ x z)))
(let ([x (cons 0 '())])
(begin (if x (set-car! x (car x))) x))
(let ([x (cons 0 '())])
(begin (if x (set-car! x (+ (car x) (car x)))) x))
(let ([x (cons 0 '())])
(if (zero? (car x)) (begin (set-car! x x) 7) x))
(let ([x (cons 0 '())])
(let ([q x]) (if (zero? (car x)) (begin (set-car! q x) 7) x)))
(let ([x 0]) (if (zero? x) (begin (set! x (+ x 5000)) x) 20))
(let ([y 0]) (begin (if #t (set! y y)) y))
(begin (if #t #t #t) #f)
(begin (if (if #t #t #f) (if #t #t #f) (if #t #t #f)) #f)
(let ([x 0] [y 4000] [z 9000])
(let ((q (+ x z)))
(begin
(if (zero? x) (begin (set! q (+ x x)) 7))
(+ y y)
(+ x z))))
(let ([x (let ([y 2]) y)] [y 5])
(add1 x))
(let ([y 4000]) (+ y y))
((lambda (y) y) 4000)
(let ([f (lambda (x) x)])
(add1 (f 0)))
(let ([f (lambda (y) y)]) (f (f 4)))
((lambda (f) (f (f 4))) (lambda (y) y))
((let ([a 4000])
(lambda (b) (+ a b)))
5000)
(((lambda (a)
(lambda (b)
(+ a b)))
4000)
5000)
(let ([f (lambda (x) (add1 x))]) (f (f 0)))
((lambda (f) (f (f 0))) (lambda (x) (add1 x)))
(let ([x 0] [f (lambda (x) x)])
(let ([a (f x)] [b (f x)] [c (f x)]) (+ (+ a b) c)))
(let ([x 0][y 1][z 2][f (lambda (x) x)])
(let ([a (f x)][b (f y)][c (f z)])
(+ (+ a b) c)))
(let ([f (lambda (x y) x)])
(f 0 1))
(let ([f (lambda (x y) x)])
(let ([a (f 0 1)]) (f a a)))
(let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
(let ([a (f x y z)]) (f a a a)))
(let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
(let ([a (f x y z)] [b y] [c z]) (f a b c)))
(let ([f (lambda (a b c d)
(+ a d))])
(f 0 1 2 3))
(let ([f (lambda (x) x)])
(+ (f 0)
(let ([a 0] [b 1] [c 2])
(+ (f a) (+ (f b) (f c))))))
(let ([f (lambda (x) x)])
(+ (f 0)
(let ([a 0] [b 1] [c 2])
(add1 (f a)))))
(let ([f (lambda (x) x)])
(+ (f 0) (let ([a 0][b 1][c 2][d 3])
(+ (f a)
(+ (f b)
(+ (f c)
(f d)))))))
(let ([a 0])(letrec ([a (lambda () 0)][b (lambda () 11)]) (set! a 11)))
(let ([a 0])(letrec ([a (lambda () (set! a 0))][b 11]) (a)))
(let ([a 0])(let ([a (set! a 0)][b 11]) a))
(let ([a 5]) (let ([a 0] [b (set! a (+ a 11))]) a))
(letrec ([a (lambda () 0)]) (a))
(letrec ([a (lambda () 0)] [b (lambda () 11)]) (a))
(let ([x 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! x 11)))
(let ([a 0]) (let ([b (set! a 0)]) a))
(let ([a 0])(let ([a (set! a 0)]) (let ([b 11]) a)))
(let ([a 0])(let ([a 0]) (let ([b (set! a 11)]) a)))
(let ([a 0])(let ([a 0]) (let ([b 11]) (set! a 11))))
(let ([f (let ([x 1]) (lambda (y) (+ x y)))])
(let ([x 0]) (f (f x))))
((let ([t (lambda (x) (+ x 50))])
(lambda (f) (t (f 1000))))
(lambda (y) (+ y 2000)))
(let ([x 0])
(let ([f (let ([x 1] [z x])
(lambda (y)
(+ x (+ z y))))])
(f (f x))))
(((lambda (t)
(lambda (f) (t (f 1000))))
(lambda (x) (+ x 50)))
(lambda (y) (+ y 2000)))
((let ([t 50])
(lambda (f)
(+ t (f))))
(lambda () 2000))
(((lambda (t)
(lambda (f)
(+ t (f))))
50)
(lambda () 2000))
((let ([x 300])
(lambda (y) (+ x y)))
400)
(let ([x 3] [f (lambda (x y) x)])
(f (f 0 0) x))
(let ([x 3] [f (lambda (x y) x)])
(if (f 0 0) (f (f 0 0) x) 0))
(let ([x02 3] [f01 (lambda (x04 y03) x04)])
(if (not x02) (f01 (f01 0 0) x02) 0))
(let ((f (lambda (x) (if (if (pair? x) (not (eq? (car x) 0)) #f) x #f))))
(f (cons 0 0)))
(let ((f (lambda (x)
(if (if x (not (if (pair? x) (not (eq? (car x) 0)) #f)) #f)
x #f))))
(f 0))
(let ((f (lambda (x) (if (if (pair? x) #t (null? x)) x '()))))
(f 0))
(let ([y 4])
(let ([f (lambda (y) y)])
(f (f y))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y y) (f y y))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y y) (f y (f y y)))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y (f y y)) (f y (f y y)))))
((lambda (y) ((lambda (f) (f (f y))) (lambda (y) y))) 4)
(let ([f (lambda (x) (+ x x))]) (f 4000))
(let ((x (if 1000 2000 3000))) x)
(let ([f (lambda (x) x)]) (add1 (if #f 1 (f 22))))
(let ([f (lambda (x) x)]) (if (f (zero? 23)) 1 22))
(let ([f (lambda (x) (if x (not x) x))]
[f2 (lambda (x) (* 10 x))]
[x 23])
(add1 (if (f (zero? x)) 1 (* x (f2 (sub1 x))))))
(let ([f (lambda () 0)])
(let ([x (f)]) 1))
(let ([f (lambda () 0)])
(begin (f) 1))
(let ([f (lambda (x) x)])
(if #t (begin (f 3) 4) 5))
(let ([f (lambda (x) x)])
(begin (if #t (f 4) 5) 6))
(let ([f (lambda (x) x)])
(begin (if (f #t)
(begin (f 3) (f 4))
(f 5))
(f 6)))
(let ([f (lambda (x) (add1 x))])
(f (let ([f 3]) (+ f 1))))
(let ((x 15)
(f (lambda (h v) (* h v)))
(k (lambda (x) (+ x 5)))
(g (lambda (x) (add1 x))))
(k (g (let ((g 3)) (f g x)))))
(let ([x 4])
(let ([f (lambda () x)])
(set! x 5)
(f)))
(let ([x (let ([y 2]) y)]) x)
(let ([x (if #t (let ([y 2]) y) 1)]) x)
(let ([x (let ([y (let ([z 3]) z)]) y)]) x)
(let ([x (if #t (let ([y (if #t (let ([z 3]) z) 2)]) y) 1)]) x)
(+ (let ([x 3]) (add1 x)) 4)
(+ (let ([x 3][y 4]) (* x y)) 4)
(let ([x (add1 (let ([y 4]) y))]) x)
(let ([x (add1 (letrec ([y (lambda () 4)]) (y)))]) x)
(let ([x (+ (let ([y 4]) y) (let ([y 4]) y))]) (add1 x))
(let ([z 0]) (let ([x z]) z x))
(let ([z 0]) (let ([x (begin (let ([y 2]) (set! z y)) z)]) x))
(let ([x (begin (let ([y 2]) (set! y y)) (let ([z 3]) z))]) x)
(letrec ([one (lambda (n) (if (zero? n) 1 (one (sub1 n))))])
(one 13))
(letrec ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
(odd 13))
(let ([t #t] [f #f])
(letrec ((even (lambda (x) (if (zero? x) t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) f (even (sub1 x))))))
(odd 13)))
(let ((even (lambda (x) x)))
(even (letrec ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
(odd 13))))
(letrec ((fact (lambda (n) (if (zero? n) 1 (* n (fact (sub1 n)))))))
(fact 5))
(let ([x 5])
(letrec ([a (lambda (u v w) (if (zero? u) (b v w) (a (- u 1) v w)))]
[b (lambda (q r)
(let ([p (* q r)])
(letrec
([e (lambda (n) (if (zero? n) (c p) (o (- n 1))))]
[o (lambda (n) (if (zero? n) (c x) (e (- n 1))))])
(e (* q r)))))]
[c (lambda (x) (* 5 x))])
(a 3 2 1)))
(let ([f (lambda () 80)]) (let ([a (f)] [b (f)]) 0))
(let ([f (lambda () 80)]) (let ([a (f)] [b (f)]) (* a b)))
(let ([f (lambda () 80)] [g (lambda () 80)])
(let ([a (f)] [b (g)])
(* a b)))
(let ((f (lambda (x) (add1 x)))
(g (lambda (x) (sub1 x)))
(t (lambda (x) (add1 x)))
(j (lambda (x) (add1 x)))
(i (lambda (x) (add1 x)))
(h (lambda (x) (add1 x)))
(x 80))
(let ((a (f x)) (b (g x)) (c (h (i (j (t x))))))
(* a (* b (+ c 0)))))
(let ((x 3000))
(if (integer? x)
(let ((y (cons x '())))
(if (if (pair? y) (null? (cdr y)) #f)
(+ x 5000)
(- x 3000)))))
(let ((x (cons 1000 2000)))
(if (pair? x)
(let ((temp (car x)))
(set-car! x (cdr x))
(set-cdr! x temp)
(+ (car x) (cdr x)))
10000000))
(let ((v (make-vector 3)))
(vector-set! v 0 10)
(vector-set! v 1 20)
(vector-set! v 2 30)
(if (vector? v)
(+ (+ (vector-length v) (vector-ref v 0))
(+ (vector-ref v 1) (vector-ref v 2)))
10000))
(let ([fact (lambda (fact n)
(if (zero? n) 1 (* (fact fact (sub1 n)) n)))])
(fact fact 5))
(let ([s (make-vector 20)])
(vector-set! s 19 #\z)
(if (vector? s)
(+ 20 (let ([c #\z]) (if (char? c) 122)))
10000))
(let ([s (make-vector 20)])
(vector-set! s 19 #\z)
(if (vector? s)
(+ (vector-length s)
(let ([c (vector-ref s 19)])
(if (char? c)
(char->integer (vector-ref s 19)))))
10000))
(let ((s (make-vector 20)) (s2 (make-vector 3)))
(vector-set! s 19 #\z)
(vector-set! s 18 #\t)
(vector-set! s2 0 #\a)
(if (vector? s)
(+ (vector-length s)
(let ((c (vector-ref s 18)))
(if (char? c)
(+ (char->integer (vector-ref s 19))
(char->integer c)))))
10000))
(let ([f (lambda (x) (+ x 1000))])
(if (zero? (f -2)) (f 6000) (f (f 8000))))
(let ([f (lambda (x) (+ x 1000))])
(if (zero? (f -1)) (f 6000) (f (f 8000))))
(let ((f (lambda (x y) (+ x 1000))))
(+ (if (f 3000 (begin 0 0 0)) (f (f 4000 0) 0) 8000) 2000))
((((lambda (x)
(lambda (y)
(lambda (z)
(+ x (+ y (+ z y))))))
5) 6) 7)
((((((lambda (x)
(lambda (y)
(lambda (z)
(lambda (w)
(lambda (u)
(+ x (+ y (+ z (+ w u)))))))))
5) 6) 7) 8) 9)
(let ((f (lambda (x) x)))
(if (procedure? f) #t #f))
(let ((sum (lambda (sum ls)
(if (null? ls) 0 (+ (car ls) (sum sum (cdr ls)))))))
(sum sum (cons 1 (cons 2 (cons 3 '())))))
(let ((v (make-vector 5))
(w (make-vector 7)))
(vector-set! v 0 #t)
(vector-set! w 3 #t)
(if (boolean? (vector-ref v 0))
(vector-ref w 3)
#f))
(let ((a 5) (b 4))
(if (< b 3)
(eq? a (+ b 1))
(if (<= b 3)
(eq? (- a 1) b)
(= a (+ b 2)))))
(let ((a 5) (b 4))
(if #f (eq? a (+ b 1)) (if #f (eq? (- a 1) b) (= a (+ b 2)))))
(((lambda (a) (lambda () (+ a (if #t 200)) 1500)) 1000))
(((lambda (b) (lambda (a) (set! a (if 1 2)) (+ a b))) 100) 200)
((((lambda (a)
(lambda (b)
(set! a (if b 200))
(lambda (c) (set! c (if 300 400))
(+ a (+ b c)))))
1000) 2000) 3000)
((((lambda (a) (lambda (b) (lambda (c) (+ a (+ b c))))) 10) 20) 30)
(+ 2 3)
((lambda (a) (+ 2 a)) 3)
(((lambda (b) (lambda (a) (+ b a))) 3) 2)
((lambda (b) ((lambda (a) (+ b a)) 2)) 3)
((lambda (f) (f (f 5))) (lambda (x) x))
((let ((f (lambda (x) (+ x 3000)))) (lambda (y) (f (f y)))) 2000)
(let ((n #\newline) (s #\space) (t #\tab))
(let ((st (make-vector 5)))
(vector-set! st 0 n)
(vector-set! st 1 s)
(vector-set! st 2 t)
(if (not (vector? st))
10000
(vector-length st))))
(let ((s (make-vector 1)))
(vector-set! s 0 #\c)
(if (eq? (vector-ref s 0) #\c) 1000 2000))
(not 17)
(not #f)
(let ([fact (lambda (fact n acc)
(if (zero? n) acc (fact fact (sub1 n) (* n acc))))])
(fact fact 5 1))
((lambda (b c a)
(let ((b (+ b a)) (a (+ a (let ((a (+ b b)) (c (+ c c))) (+ a a)))))
(* a a))) 2 3 4)
(let ((f (lambda (x) (lambda () (x))))) ((f (lambda () 3))))
(letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
(let ([q 17])
(let ((g (lambda (a) (set! q 10) (lambda () (a q)))))
((g f)))))
(letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
(let ((g (lambda (a) (lambda (b) (a b)))))
((g f) 10)))
(letrec ((f (lambda () (+ a b)))
(g (lambda (y) (set! g (lambda (y) y)) (+ y y)))
(a 17)
(b 35)
(h (cons (lambda () a) (lambda (v) (set! a v)))))
(let ((x1 (f)) (x2 (g 22)) (x3 ((car h))))
(let ((x4 (g 22)))
((cdr h) 3)
(let ((x5 (f)) (x6 ((car h))))
(cons x1 (cons x2 (cons x3 (cons x4 (cons x5 x6)))))))))
(letrec ((f (lambda () (+ a b)))
(a 17)
(b 35)
(h (cons (lambda () a) (lambda () b))))
(cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
(letrec ((f (lambda (x) (letrec ((x 3)) 3))))
(letrec ((g (lambda (x) (letrec ((y 14)) (set! y 7) y))))
(set! g (cons g 3))
(letrec ((h (lambda (x) x)) (z 42))
(cons (cdr g) (h z)))))
(let ([t #t] [f #f])
(let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
(letrec
([even (lambda (x) (if (zero? x) (id (car bools)) (odd (- x 1))))]
[odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
(odd 5))))
(letrec ([fib (lambda (x)
(let ([decrx (lambda () (set! x (- x 1)))])
(if (< x 2)
1
(+ (begin (decrx) (fib x))
(begin (decrx) (fib x))))))])
(fib 10))
(letrec ([fib (lambda (x)
(let ([decrx (lambda () (lambda (i) (set! x (- x i))))])
(if (< x 2)
1
(+ (begin ((decrx) 1) (fib x))
(begin ((decrx) 1) (fib x))))))])
(fib 10))
;; Jie Li
(let ((a 5))
(let ((b (cons a 6)))
(let ((f (lambda(x) (* x a))))
(begin (if (- (f a) (car b))
(begin (set-car! b (if (not a) (* 2 a) (+ 2 a)))
(f a))
(if (not (not (< (f a) b))) (f a)))
(not 3)
(void)
(f (car b))))))
(letrec ([f (lambda (x y)
(if (not x) (g (add1 x) (add1 y)) (h (+ x y))))]
[g (lambda (u v)
(let ([a (+ u v)] [b (* u v)])
(letrec ([e (lambda (d)
(letrec ([p (cons a b)]
[q (lambda (m)
(if (< m u)
(f m d)
(h (car p))))])
(q (f a b))))])
(e u))))]
[h (lambda (w) w)])
(f 4 5))
(letrec ((f (lambda (x)
(+ x (((lambda (y)
(lambda (z)
(+ y z)))
6) 7))))
(g (+ 5 ((lambda (w u) (+ w u)) 8 9))))
g)
;; Jordan Johnson
(let ((test (if (not (not 10)) #f 5)))
(letrec ([num 5]
[length
(lambda (ls)
(let ((len (if ((lambda (ck)
(begin ck (set! num test) ck))
(null? ls))
(begin num (set! num 0) num)
(begin (length '())
(set! num 5)
(+ 1 (length (cdr ls)))))))
(if len len)))])
(length (cons 5 (cons (if (set! num 50) (length (cons test '())) 1)
'())))))
(letrec ([quotient (lambda (x y)
(if (< x 0)
(- 0 (quotient (- 0 x) y))
(if (< y 0)
(- 0 (quotient x (- 0 y)))
(letrec ([f (lambda (x a)
(if (< x y)
a
(f (- x y) (+ a 1))))])
(f x 0)))))])
(letrec ([sub-interval 1]
[sub-and-continue
(lambda (n acc k) (k (- n sub-interval) (* n acc)))]
[strange-fact
(lambda (n acc)
(if (zero? n)
(lambda (proc) (proc acc))
(sub-and-continue n acc strange-fact)))])
(let ([x 20]
[fact (let ((seed 1)) (lambda (n) (strange-fact n seed)))])
(let ([give-fact5-answer (fact 5)]
[give-fact6-answer (fact 6)]
[answer-user (lambda (ans) (quotient ans x))])
(set! x (give-fact5-answer answer-user))
(begin (set! x (give-fact6-answer answer-user)) x)))))
(let ((y '()) (z 10))
(let ((test-ls (cons 5 y)))
(set! y (lambda (f)
((lambda (g) (f (lambda (x) ((g g) x))))
(lambda (g) (f (lambda (x) ((g g) x)))))))
(set! test-ls (cons z test-ls))
(letrec ((length (lambda (ls)
(if (null? ls) 0 (+ 1 (length (cdr ls)))))))
(let ((len (length test-ls)))
(eq? (begin
(set! length (y (lambda (len)
(lambda (ls)
(if (null? ls)
0
(+ 1 (len (cdr ls))))))))
(length test-ls))
len)))))
;; Ryan Newton
(letrec ((loop (lambda () (lambda () (loop))))) (loop) 0)
(letrec ([f (lambda ()
(letrec ([loop
(lambda (link)
(lambda ()
(link)))])
(loop (lambda () 668))))])
((f)))
;; AWK - the following test uses the syntax #36rgood and #36rbad,
;; which the ikarus reader seems to choak on, so I'm commenting out
;; this test for now.
; (if (lambda () 1)
; (let ((a 2))
; (if (if ((lambda (x)
; (let ((x (set! a (set! a 1))))
; x)) 1)
; (if (eq? a (void))
; #t
; #f)
; #f)
; #36rgood ; dyb: cannot use symbols, so use radix 36
; #36rbad))) ; syntax to make all letters digits
; contributed by Ryan Newton
(letrec ([dropsearch
(lambda (cell tree)
(letrec ([create-link
(lambda (node f)
(lambda (g)
(if (not (pair? node))
(f g)
(if (eq? node cell)
#f
(f (create-link
(car node)
(create-link
(cdr node) g)))))))]
[loop
(lambda (link)
(lambda ()
(if link
(loop (link (lambda (v) v)))
#f)))])
(loop (create-link tree (lambda (x) x)))))]
[racethunks
(lambda (thunkx thunky)
(if (if thunkx thunky #f)
(racethunks (thunkx) (thunky))
(if thunky
#t
(if thunkx
#f
'()))))]
[higher? (lambda (x y tree)
(racethunks (dropsearch x tree)
(dropsearch y tree)))]
[under?
(lambda (x y tree)
(racethunks (dropsearch x y)
(dropsearch x tree)))]
[explore
(lambda (x y tree)
(if (not (pair? y))
#t
(if (eq? x y)
#f ; takes out anything pointing to itself
(let ((result (higher? x y tree)))
(if (eq? result #t)
(if (explore y (car y) tree)
(explore y (cdr y) tree)
#f)
(if (eq? result #f)
(process-vertical-jump x y tree)
(if (eq? result '())
(process-horizontal-jump x y tree)
)))))))]
[process-vertical-jump
(lambda (jumpedfrom jumpedto tree)
(if (under? jumpedfrom jumpedto tree)
#f
(fullfinite? jumpedto)))]
[process-horizontal-jump
(lambda (jumpedfrom jumpedto tree)
(fullfinite? jumpedto))]
[fullfinite?
(lambda (pair)
(if (not (pair? pair))
#t
(if (explore pair (car pair) pair)
(explore pair (cdr pair) pair)
#f)))])
(cons (fullfinite? (cons 1 2))
(cons (fullfinite? (let ((x (cons 1 2))) (set-car! x x) x))
(cons (fullfinite?
(let ([a (cons 0 0)] [b (cons 0 0)] [c (cons 0 0)])
(set-car! a b) (set-cdr! a c) (set-cdr! b c)
(set-car! b c) (set-car! c b) (set-cdr! c b) a))
'()))))))
(define final-tests
; extracted tests from assignment writeups
'(75
(+ 16 32)
(* 16 128)
(let ((x 16) (y 128)) (* x y))
(let ([x 17]) (+ x x)) (cons 16 32) (cdr (cons 16 32))
(let ((x (cons 16 32))) (pair? x))
(let ([x 3]) (let ([y (+ x (quote 4))]) (+ x y)))
(let ([f (lambda (x) x)]) (let ([a 1]) (* (+ (f a) a) a)))
(let ([k (lambda (x y) x)])
(let ([b 17]) ((k (k k 37) 37) b (* b b))))
(let ([f (lambda ()
(let ([n 256])
(let ([v (make-vector n)])
(vector-set! v 32 n)
(vector-ref v 32))))])
(pair? (f)))
(let ((w 4) (x 8) (y 16) (z 32))
(let ((f (lambda ()
(+ w (+ x (+ y z))))))
(f)))
(let ((f (lambda (g u) (g (if u (g 37) u)))))
(f (lambda (x) x) 75))
(let ((f (lambda (h u) (h (if u (h (+ u 37)) u)))) (w 62))
(f (lambda (x) (- w x)) (* 75 w)))
(let ([t #t] [f #f])
(let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
(letrec
([even (lambda (x) (if (id (zero? x)) (car bools) (odd (- x 1))))]
[odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
(odd 5))))
((lambda (x y z)
(let ((f (lambda (u v) (begin (set! x u) (+ x v))))
(g (lambda (r s) (begin (set! y (+ z s)) y))))
(* (f '1 '2) (g '3 '4))))
'10 '11 '12)
((lambda (x y z)
(let ((f '#f)
(g (lambda (r s) (begin (set! y (+ z s)) y))))
(begin
(set! f
(lambda (u v) (begin (set! v u) (+ x v))))
(* (f '1 '2) (g '3 '4)))))
'10 '11 '12)
(letrec ((f (lambda (x) (+ x 1)))
(g (lambda (y) (f (f y)))))
(+ (f 1) (g 1)))
(let ((y 3))
(letrec
((f (lambda (x) (if (zero? x) (g (+ x 1)) (f (- x y)))))
(g (lambda (x) (h (* x x))))
(h (lambda (x) x)))
(g 39)))
(letrec ((f (lambda (x) (+ x 1))) (g (lambda (y) (f (f y)))))
(set! f (lambda (x) (- x 1)))
(+ (f 1) (g 1)))
(letrec ([f (lambda () (+ a b))]
[a 17]
[b 35]
[h (cons (lambda () a) (lambda () b))])
(cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
(let ((v (make-vector 8)))
(vector-set! v 0 '())
(vector-set! v 1 (void))
(vector-set! v 2 #f)
(vector-set! v 3 #\a)
(vector-set! v 4 #\z)
(vector-set! v 5 #t)
(vector-set! v 6 2)
(vector-set! v 7 5)
(vector-ref v (vector-ref v 6)))
(let ([x 5] [th (let ((a 1)) (lambda () a))])
(letrec ([fact (lambda (n th)
(if (zero? n) (th) (* n (fact (- n 1) th))))])
(fact x th)))
(let ([negative? (lambda (n) (< n 0))])
(letrec
([fact (lambda (n)
(if (zero? n) 1 (* n (fact (- n 1)))))]
[call-fact (lambda (n)
(if (not (negative? n))
(fact n)
(- 0 (fact (- 0 n)))))])
(cons (call-fact 5) (call-fact -5))))
(letrec ([iota-fill! (lambda (v i n)
(if (not (= i n))
(begin
(vector-set! v i i)
(iota-fill! v (+ i 1) n))))])
(let ([n 4])
(let ([v (make-vector n)]) (iota-fill! v 0 n) v)))
; make-vector with non-constant operand and improper alignment
(let ([x 6])
(let ([v (make-vector x)])
(vector-set! v 0 3)
(vector-set! v 1 (cons (vector-ref v 0) 2))
(vector-set! v 2 (cons (vector-ref v 1) 2))
(vector-set! v 3 (cons (vector-ref v 2) 2))
(vector-set! v 4 (cons (vector-ref v 3) 2))
(vector-set! v 5 (cons (vector-ref v 4) 2))
(cons (pair? (vector-ref v 5)) (car (vector-ref v 4)))))
; nest some lambdas
(((((lambda (a)
(lambda (b)
(lambda (c)
(lambda (d)
(cons (cons a b) (cons c d))))))
33) 55) 77) 99)
; stress the register allocator
(let ((a 17))
(let ((f (lambda (x)
(let ((x1 (+ x 1)) (x2 (+ x 2)))
(let ((y1 (* x1 7)) (y2 (* x2 7)))
(let ((z1 (- y1 x1)) (z2 (- y2 x2)))
(let ((w1 (* z1 a)) (w2 (* z2 a)))
(let ([g (lambda (b)
(if (= b a)
(cons x1 (cons y1 (cons z1 '())))
(cons x2 (cons y2 (cons z2 '())))))]
[h (lambda (c)
(if (= c x) w1 w2))])
(if (if (= (* x x) (+ x x))
#t
(< x 0))
(cons (g 17) (g 16))
(cons (h x) (h (- x 0))))))))))))
(cons (f 2) (cons (f -1) (cons (f 3) '())))))
; printer
(letrec
([write
(lambda (x)
(let ([digits
(let ([v (make-vector 10)])
(vector-set! v 0 #\0)
(vector-set! v 1 #\1)
(vector-set! v 2 #\2)
(vector-set! v 3 #\3)
(vector-set! v 4 #\4)
(vector-set! v 5 #\5)
(vector-set! v 6 #\6)
(vector-set! v 7 #\7)
(vector-set! v 8 #\8)
(vector-set! v 9 #\9)
v)])
(letrec
([list->vector
(lambda (ls)
(let ([v (make-vector (length ls))])
(letrec
([loop
(lambda (ls i)
(if (null? ls)
v
(begin
(vector-set! v i (car ls))
(loop (cdr ls) (+ i 1)))))])
(loop ls 0))))]
[length
(lambda (ls)
(if (null? ls)
0
(add1 (length (cdr ls)))))]
[map
(lambda (p ls)
(if (null? ls)
'()
(cons (p (car ls))
(map p (cdr ls)))))]
[wr (lambda (x p)
(if (eq? x #f)
(cons #\# (cons #\f p))
(if (eq? x #t)
(cons #\# (cons #\t p))
(if (eq? x '())
(cons #\( (cons #\) p))
(if (eq? x (void))
(cons #\# (cons #\< (cons #\v
(cons #\o (cons #\i (cons #\d
(cons #\> p)))))))
(if (char? x)
(cons #\# (cons #\\
(if (eq? x #\newline)
(cons #\n (cons #\e (cons #\w
(cons #\l (cons #\i (cons #\n
(cons #\e p)))))))
(if (eq? x #\space)
(cons #\s (cons #\p
(cons #\a (cons #\c
(cons #\e p)))))
(if (eq? x #\tab)
(cons #\t (cons #\a
(cons #\b p)))
(cons x p))))))
(if (integer? x)
(if (< x 0)
(cons #\- (wrint (- 0 x) p))
(wrint x p))
(if (pair? x)
(cons #\( ; )
(letrec
([loop
(lambda (x)
(wr (car x)
(if (pair? (cdr x))
(cons #\space
(loop
(cdr x)))
(if
(null?
(cdr x))
;(
(cons #\) p)
(cons
#\space
(cons
#\.
(cons
#\space
(wr
(cdr
x)
;(
(cons
#\)
p)
))))
))))])
(loop x)))
(if (vector? x)
(cons #\# (cons #\( ; )
(let
([n (vector-length
x)])
(if (= n 0) ;(
(cons #\) p)
(letrec
([loop
(lambda (i)
(wr
(vector-ref
x i)
(if
(=
(+
i
1)
n)
;(
(cons
#\)
p)
(cons
#\space
(loop
(+
i
1))
)))
)])
(loop 0))))))
(if (procedure? x)
(cons #\# (cons #\<
(cons #\p (cons #\r
(cons #\o
(cons #\c
(cons #\e
(cons #\d
(cons #\u
(cons
#\r
(cons
#\e
(cons
#\>
p)
)))
))))))))
(cons #\# (cons #\<
(cons #\g (cons #\a
(cons #\r
(cons #\b
(cons #\a
(cons #\g
(cons #\e
(cons
#\>
p))))
)))))))))
)))))))]
[wrint (lambda (n p)
(if (< n 10)
(cons (vector-ref digits n) p)
(wrint
(quotient n 10)
(cons (vector-ref digits
(remainder n 10)) p))))]
[remainder (lambda (x y)
(let ([q (quotient x y)]) (- x (* y q))))]
[quotient (lambda (x y)
(if (< x 0)
(- 0 (quotient (- 0 x) y))
(if (< y 0)
(- 0 (quotient x (- 0 y)))
(letrec ([f (lambda (x a)
(if (< x y)
a
(f (- x y) (+ a 1))))])
(f x 0)))))])
(list->vector (map (lambda (x)
(char->integer x))
(wr x '()))))))])
(write
(let ([v1 (make-vector 4)] [v2 (make-vector 0)])
(vector-set! v1 0 #\a)
(vector-set! v1 1 #\space)
(vector-set! v1 2 #\newline)
(vector-set! v1 3 #\tab)
(cons (cons 0 (cons 4 (cons 2334 -98765)))
(cons (cons #t (cons #f (cons (void) (cons '() '()))))
(cons v1 (cons v2 write))))))))))

63
ta6ob/nanopass/tests/compiler-test.ss Normal file
View file

@ -0,0 +1,63 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests compiler-test)
(export test-one test-all run-main-tests run-final-tests run-all-tests)
(import (rnrs)
(tests compiler)
(tests test-driver)
(tests alltests))
(define run-final-tests
(case-lambda
[() (run-final-tests #t)]
[(emit?) (run-final-tests emit? #f)]
[(emit? noisy?) (tests final-tests) (test-all emit? noisy?)]))
(define run-main-tests
(case-lambda
[() (run-main-tests #t)]
[(emit?) (run-main-tests emit? #f)]
[(emit? noisy?) (tests main-tests) (test-all emit? noisy?)]))
(define run-all-tests
(case-lambda
[() (run-all-tests #t #f)]
[(emit?) (run-all-tests emit? #f)]
[(emit? noisy?) (run-main-tests emit? noisy?)
(run-final-tests emit? noisy?)]))
(passes
(define-passes
rename-vars/verify-legal
remove-implicit-begin
remove-unquoted-constant
remove-one-armed-if
uncover-settable
remove-impure-letrec
remove-set!
sanitize-binding
remove-anonymous-lambda
uncover-free
convert-closure
lift-letrec
explicit-closure
normalize-context
remove-complex-opera*
remove-anonymous-call
introduce-dummy-rp
remove-nonunary-let
return-of-set!
explicit-labels
;unparse-l18
;introduce-registers
;uncover-live
;uncover-conflict
;uncover-move
;assign-register
;rename-register
;assign-frame
;rename-frame
;flatten-program
;generate-code
)))

1456
ta6ob/nanopass/tests/compiler.ss Normal file
View file

File diff suppressed because it is too large Load diff

325
ta6ob/nanopass/tests/helpers.ss Normal file
View file

@ -0,0 +1,325 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests helpers)
(export compose disjoin any every choose reverse-filter fold reduce
constant? keyword? list-of-user-primitives list-of-system-primitives
user-primitive? system-primitive? primitive? predicate-primitive?
value-primitive? effect-primitive? effect-free-primitive? gen-label
reset-seed gen-symbol set? iota with-values
empty-set singleton-set
add-element member? empty? union intersection difference
variable? datum? list-index primapp sys-primapp app const-datum const
var quoted-const time printf system interpret pretty-print format set-cons
define-who)
(import (rnrs)
(tests implementation-helpers)
(nanopass helpers))
(define-syntax primapp
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax sys-primapp
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax app
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax const-datum
(syntax-rules ()
[(_ expr) (quote expr)]))
(define-syntax const
(syntax-rules ()
[(_ expr) expr]))
(define-syntax var
(syntax-rules ()
[(_ expr) expr]))
(define-syntax quoted-const
(syntax-rules ()
[(_ expr) (quote expr)]))
(define compose
(case-lambda
[() (lambda (x) x)]
[(f) f]
[(f . g*) (lambda (x) (f ((apply compose g*) x)))]))
(define disjoin
(case-lambda
[() (lambda (x) #f)]
[(p?) p?]
[(p? . q?*) (lambda (x)
(or (p? x) ((apply disjoin q?*) x)))]))
(define any
(lambda (pred? ls)
(let loop ([ls ls])
(cond
[(null? ls) #f]
[(pred? (car ls)) #t]
[else (loop (cdr ls))]))))
(define every
(lambda (pred? ls)
(let loop ([ls ls])
(cond
[(null? ls) #t]
[(pred? (car ls)) (loop (cdr ls))]
[else #f]))))
(define choose
(lambda (pred? ls)
(fold (lambda (elt tail)
(if (pred? elt)
(cons elt tail)
tail))
'()
ls)))
(define reverse-filter
(lambda (pred? ls)
(fold (lambda (elt tail)
(if (pred? elt)
tail
(cons elt tail)))
'()
ls)))
;; fold op base (cons a (cons b (cons c '()))) =
;; (op a (op b (op c base)))
(define fold
(lambda (op base ls)
(let recur ([ls ls])
(if (null? ls)
base
(op (car ls) (recur (cdr ls)))))))
;; reduce op base (cons a (cons b (cons c '())))
;; (op c (op b (op a base)))
(define reduce
(lambda (op base ls)
(let loop ([ls ls] [ans base])
(if (null? ls)
ans
(loop (cdr ls) (op (car ls) ans))))))
;;; General Scheme helpers for the compiler
(define constant?
(disjoin null? number? char? boolean? string?))
(define keyword?
(lambda (x)
(and (memq x '(quote set! if begin let letrec lambda)) #t)))
(define datum?
(lambda (x)
(or (constant? x)
(null? x)
(if (pair? x)
(and (datum? (car x)) (datum? (cdr x)))
(and (vector? x) (for-all datum? (vector->list x)))))))
(define variable? symbol?)
(define list-of-user-primitives
'(; not is a special case
(not 1 not)
; predicates
(< 2 test)
(<= 2 test)
(= 2 test)
(boolean? 1 test)
(char? 1 test)
(eq? 2 test)
(integer? 1 test)
(null? 1 test)
(pair? 1 test)
(procedure? 1 test)
(vector? 1 test)
(zero? 1 test)
; value-producing
(* 2 value)
(+ 2 value)
(- 2 value)
(add1 1 value)
(car 1 value)
(cdr 1 value)
(char->integer 1 value)
(cons 2 value)
(make-vector 1 value)
(quotient 2 value)
(remainder 2 value)
(sub1 1 value)
(vector -1 value)
(vector-length 1 value)
(vector-ref 2 value)
(void 0 value)
; side-effecting
(set-car! 2 effect)
(set-cdr! 2 effect)
(vector-set! 3 effect)))
(define list-of-system-primitives ; these are introduced later by the compiler
'(; value-producing
(closure-ref 2 value)
(make-closure 2 value)
(procedure-code 1 value)
; side-effecting
(closure-set! 3 effect)
(fref 1 value)
(fset! 2 effect)
(fincr! 1 effect)
(fdecr! 1 effect)
(href 2 value)
(hset! 3 effect)
(logand 2 value)
(sll 2 value)
(sra 2 value)))
(define user-primitive?
(lambda (x)
(and (assq x list-of-user-primitives) #t)))
(define system-primitive?
(lambda (x)
(and (assq x list-of-system-primitives) #t)))
(define primitive?
(lambda (x)
(or (user-primitive? x) (system-primitive? x))))
(define predicate-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'test))]
[else #f])))
(define value-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'value))]
[else #f])))
(define effect-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'effect))]
[else #f])))
(define effect-free-primitive?
(lambda (x)
(not (effect-primitive? x))))
(define gen-label
; at some point, gen-label should be redefined to emit
; assembler-friendly labels
(lambda (sym)
(string->symbol (format "~a%" sym))))
(define gen-symbol-seed 0)
(define reset-seed
(lambda ()
(set! gen-symbol-seed 0)))
(define gen-symbol
(lambda (sym)
(set! gen-symbol-seed (+ gen-symbol-seed 1))
(string->symbol (format "~a_~s" sym gen-symbol-seed))))
(define set?
(lambda (ls)
(or (null? ls)
(and (not (memq (car ls) (cdr ls))) (set? (cdr ls))))))
;;; ====================
;;; Extra syntax and helpers for multiple values
;;; Set abstraction
(define empty-set (lambda () '()))
(define singleton-set (lambda (elt) (list elt)))
(define add-element
(lambda (elt set)
(if (member? elt set)
set
(cons elt set))))
(define member? memq)
(define empty? null?)
(define set-cons
(lambda (a set)
(if (memq a set) set (cons a set))))
(define union
(case-lambda
[() (empty-set)]
[(set1 set2)
(cond
[(empty? set1) set2]
[(empty? set2) set1]
[(eq? set1 set2) set1]
[else (reduce (lambda (elt set)
(if (member? elt set2) set (cons elt set)))
set2
set1)])]
[(set1 . sets)
(if (null? sets)
set1
(union set1 (reduce union (empty-set) sets)))]))
(define intersection
(lambda (set1 . sets)
(cond
[(null? sets) set1]
[(any empty? sets) (empty-set)]
[else (choose
(lambda (elt)
(every (lambda (set) (member? elt set)) sets)) set1)])))
(define list-index
(lambda (a ls)
(cond
[(null? ls) -1]
[(eq? (car ls) a) 0]
[else (maybe-add1 (list-index a (cdr ls)))])))
(define maybe-add1
(lambda (n)
(if (= n -1) -1 (+ n 1))))
(define difference
(lambda (set1 . sets)
(let ((sets (reverse-filter empty? sets)))
(cond
[(null? sets) set1]
[else (reverse-filter (lambda (elt)
(any (lambda (set)
(member? elt set))
sets))
set1)])))))

6
ta6ob/nanopass/tests/implementation-helpers.chezscheme.sls Normal file
View file

@ -0,0 +1,6 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (only (chezscheme) time printf system interpret pretty-print format)))

19
ta6ob/nanopass/tests/implementation-helpers.ikarus.ss Normal file
View file

@ -0,0 +1,19 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (ikarus))
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rnrs) (rnrs mutable-pairs) (ikarus)))
(define interpret
(lambda (src)
(eval src (environment '(nanopass testing-environment))))))

23
ta6ob/nanopass/tests/implementation-helpers.ironscheme.sls Normal file
View file

@ -0,0 +1,23 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (ironscheme))
;; this seems to be only used for a pass not enabled. not sure how to use...
(define (system . args) #f)
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rnrs) (rnrs mutable-pairs) (ironscheme)))
(define interpret
(lambda (src)
(eval src (environment '(nanopass testing-environment))))))

6
ta6ob/nanopass/tests/implementation-helpers.ss Normal file
View file

@ -0,0 +1,6 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (only (scheme) time printf system interpret pretty-print format)))

40
ta6ob/nanopass/tests/implementation-helpers.vicare.sls Normal file
View file

@ -0,0 +1,40 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (vicare))
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rename (rnrs) (set! vicare:set!) (if vicare:if))
(rnrs mutable-pairs)
(rename (only (vicare) void sub1 add1 remainder quotient) (void vicare:void)))
(define-syntax set!
(syntax-rules ()
[(_ x v) (call-with-values (lambda () (vicare:set! x v)) (case-lambda [() #!void] [(x) x]))]))
(define-syntax if
(syntax-rules ()
[(_ t c) (call-with-values (lambda () (vicare:if t c)) (case-lambda [() #!void] [(x) x]))]
[(_ t c a) (vicare:if t c a)]))
(define-syntax void
(syntax-rules ()
[(_) (call-with-values (lambda () (vicare:void)) (case-lambda [() #!void] [(x) x]))])))
(define interpret
(lambda (src)
;; work around for vicare's strange handling of the return value of primitives like set!,
;; which apparently returns no values.
(call-with-values (lambda () (eval src (environment '(nanopass testing-environment))))
(case-lambda
[() #!void]
[(x) x]))))
(define system
(lambda (arg)
(foreign-call "system" arg))))

102
ta6ob/nanopass/tests/new-compiler.ss Normal file
View file

@ -0,0 +1,102 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests new-compiler)
(export L0 parse-L0 unparse-L0)
(import (rnrs) (nanopass) (tests helpers))
#|
(compiler-passes '(
parse-scheme ;; conversion? simplification? verification.
convert-complex-datum ;; conversion/simplification
uncover-assigned ;; analysis
purify-letrec ;; conversion/simplification
convert-assignments ;; conversion
optimize-direct-call ;; optimization
remove-anonymous-lambda ;; conversion
sanitize-binding-forms ;; conversion/simplification
uncover-free ;; analysis
convert-closures ;; conversion
optimize-known-call ;; optimization
analyze-closure-size ;; analysis
uncover-well-known ;; analysis (for optimization)
optimize-free ;; optimization
optimize-self-reference ;; optimization
analyze-closure-size ;; analysis
introduce-procedure-primitives ;; conversion
lift-letrec ;; conversion
normalize-context ;; conversion
specify-representation ;; conversion
uncover-locals ;; analysis
remove-let ;; conversion
verify-uil ;; verification
remove-complex-opera* ;; conversion
flatten-set! ;; conversion
impose-calling-conventions ;; conversion
expose-allocation-pointer ;; conversion
uncover-frame-conflict ;; conversion
pre-assign-frame ;;
assign-new-frame
(iterate
finalize-frame-locations
select-instructions
uncover-register-conflict
assign-registers
(break when everybody-home?)
assign-frame)
discard-call-live
finalize-locations
expose-frame-var
expose-memory-operands
expose-basic-blocks
#;optimize-jumps
flatten-program
generate-x86-64
))
|#
(define vector-for-all
(lambda (p? x)
(let loop ([n (fx- (vector-length x) 1)])
(cond
[(fx<? n 0) #t]
[(not (p? (vector-ref x n))) #f]
[else (loop (fx- n 1))]))))
(define target-fixnum?
(lambda (x)
(and (integer? x) (exact? x)
(<= (- (ash 1 60)) x (- (ash 1 60) 1)))))
(define constant?
(lambda (x)
(or (eq? x #t) (eq? x #f) (eq? x '()) (target-fixnum? x))))
(define scheme-object?
(lambda (x)
(or (constant? x)
(and (pair? x) (scheme-object? (car x)) (scheme-object? (cdr x)))
(and (vector? x) (vector-for-all scheme-object? x)))))
(define-language L0
(terminals
(constant (c))
(scheme-object (d))
(variable (x))
(primitive (pr)))
(Expr (e body)
c
x
(quote d)
(if e0 e1)
(if e0 e1 e2)
(and e* ...)
(or e* ...)
(begin e* ... e)
(lambda (x* ...) body body* ...)
(let ([x* e*] ...) body body* ...)
(letrec ([x* e*] ...) body body* ...)
(set! x e)
(pr e* ...)
(e0 e* ...)))
)

281
ta6ob/nanopass/tests/synforms.ss Normal file
View file

@ -0,0 +1,281 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
;;; AWK - TODO - Once the meta-parser can handle language passes that match
;;; a single variable.
;;; FIXME - For Ikarus, I needed to use "dots" instead of the ".."
;;; because Ikarus sees .. as a syntax error, even when it is
;;; exported as an auxiliary keyword.
;;; Time-stamp: <2000-01-10 12:29:38 kemillik>
;;; (time-stamp generated by emacs: Type M-x time-stamp anywhere to update)
;;; syncase is a pattern matcher where patterns are quoted or
;;; quasiquoted expressions, or symbols. Unquoted symbols denote
;;; pattern variables. All quoted things must match precisely.
;;; Also, there is a symbol ".." that may be used to allow repetitions
;;; of the preceeding pattern. Any pattern variables within are bound
;;; to a list of matches. ".." may be nested.
;;; Below is the canonical example of "let"
;;; [`(let ([,var ,rhs] ..) ,body0 ,body1 ..)
;;; (guard (for-all symbol? var) (no-duplicates? var))
;;; `((lambda ,var ,body0 ,@body1) ,@rhs)]
;;; For the pattern to match, the optional guard requires its
;;; arguments to be true. The guard also uses the pattern
;;; variables.
;;; We have added three obvious new forms: synlambda, synlet, and
;;; synlet*. Finally, we have added a very useful operation,
;;; make-double-collector-over-list, whose description follows from the
;;; very simple code below.
;;; Here are some descriptive examples of each of the new special forms.
;;;> (define foo
;;; (synlambda `((if ,exp0 ,exp1) ,env)
;;; (guard (number? exp1))
;;; `(,env (if ,exp0 ,exp1 0))))
;;;> (foo '(if 1 2) 'anenv)
;;;(anenv (if 1 2 0))
;;;> (synlet ([`(if ,exp0 ,exp1)
;;; (guard (number? exp0))
;;; '(if 0 1)])
;;; `(if ,exp1, exp0))
;;;(if 1 0)
;;;> (synlet ([`(if ,x ,y ,z) '(if 1 2 3)]
;;; [`(if ,a then ,b else ,c) '(if 1 then 2 else 3)]
;;; [`(when ,u ,w) (guard (number? u) (number? w) (= u w))
;;; '(when 1 1)])
;;; (list x y z a b c a b))
;;; (1 2 3 1 2 3 1 2)
;;;> (synlet* ([`(if ,exp0 ,exp1) (guard (number? exp0)) '(if 0 1)]
;;; [`(if ,x ,y ,exp2) `(if ,exp0 ,exp1 5)])
;;; `(if ,exp0 ,y ,exp2))
;;;(if 0 1 5)
(library (tests synforms)
(export syncase)
(import (rnrs))
(define-syntax syncase
(syntax-rules ()
[(_ Exp (Clause ...) ...)
(let ([x Exp])
(call/cc
(lambda (succeed)
(pm:c start x succeed Clause ...)
...
(error 'syncase "No match for ~s" x))))]))
(define-syntax pm:c
(syntax-rules (guard start finish)
[(pm:c start V Succ Pattern (guard Exp ...) Body0 Body ...)
(pm:parse start Pattern
(pm:c finish V
(when (and Exp ...)
(Succ (begin Body0 Body ...)))))]
[(pm:c finish V Body Pattern UsedFormals)
(pm:find-dup UsedFormals
(cont (Dup)
(pm:error "Duplicate patvar ~s in pattern ~s" Dup Pattern))
(cont () (pm V Pattern Body)))]
[(_ start V Succ Pattern Body0 Body ...)
(pm:c start V Succ Pattern (guard) Body0 Body ...)]
[(_ start V Succ Pattern)
(pm:error "Missing body for pattern ~s" Pattern)]))
(define-syntax pm:parse ;; returns parsed thing + used formals
(syntax-rules (dots quasiquote quote unquote start)
[(pm:parse start () K) (pm:ak K (null) ())]
[(pm:parse start (unquote X) K) (pm:ak K (formal X) (X))]
[(pm:parse start (A . D) K) (pm:parseqq start (A . D) K)]
[(pm:parse start X K) (pm:ak K (keyword X) ())]))
(define-syntax pm:parseqq;; returns parsed thing + used formals
(lambda (x)
(syntax-case x (unquote start dothead dottail dottemps pairhead pairtail)
[(pm:parseqq start (unquote ()) K) #'(pm:error "Bad variable: ~s" ())]
[(pm:parseqq start (unquote (quasiquote X)) K) #'(pm:parseqq start X K)]
[(pm:parseqq start (unquote (X . Y)) K)
#'(pm:error "Bad variable: ~s" (X . Y))]
[(pm:parseqq start (unquote #(X ...)) K)
#'(pm:error "Bad variable: ~s" #(X ...))]
[(pm:parseqq start (unquote X) K) #'(pm:ak K (formal X) (X))]
[(pm:parseqq start (X dots . Y) K)
(eq? (syntax->datum #'dots) '...)
#'(pm:parseqq start X (pm:parseqq dothead Y K))]
[(pm:parseqq dothead Y K Xpat Xformals)
#'(pm:parseqq^ start Y () ()
(pm:parseqq dottail Xpat Xformals K))]
[(pm:parseqq dottail Xpat Xformals K Yrevpat Yformals)
#'(pm:gen-temps Xformals ()
(pm:parseqq dottemps Xpat Yrevpat Xformals Yformals K))]
[(pm:parseqq dottemps Xpat Yrevpat (Xformal ...) (Yformal ...) K Xtemps)
#'(pm:ak K (dots (Xformal ...) Xtemps Xpat Yrevpat)
(Xformal ... Yformal ...))]
[(pm:parseqq start (X . Y) K)
#'(pm:parseqq start X (pm:parseqq pairhead Y K))]
[(pm:parseqq pairhead Y K Xpat Xformals)
#'(pm:parseqq start Y (pm:parseqq pairtail Xpat Xformals K))]
[(pm:parseqq pairtail Xpat (Xformal ...) K Ypat (Yformal ...))
#'(pm:ak K (pair Xpat Ypat) (Xformal ... Yformal ...))]
[(pm:parseqq start X K) #'(pm:ak K (keyword X) ())])))
(define-syntax pm:parseqq^;; returns list-of parsed thing + used formals
(syntax-rules (dots start pairhead)
[(pm:parseqq^ start () Acc Used K) (pm:ak K Acc ())]
[(pm:parseqq^ start (dots . Y) Acc Used K)
(pm:error "Illegal continuation of list pattern beyond dots: ~s" Y)]
[(pm:parseqq^ start (X . Y) Acc Used K)
(pm:parseqq start X (pm:parseqq^ pairhead Y Acc Used K))]
[(pm:parseqq^ pairhead Y Acc (Used ...) K Xpat (Xformal ...))
(pm:parseqq^ start Y (Xpat . Acc) (Used ... Xformal ...) K)]
[(pm:parseqq^ start X Acc Used K) (pm:error "Bad pattern ~s" X)]))
(define-syntax pm
(syntax-rules (keyword formal dots null pair)
[(pm V (keyword K) Body) (when (eqv? V 'K) Body)]
[(pm V (formal F) Body) (let ((F V)) Body)]
[(pm V (dots Dformals DTemps DPat (PostPat ...)) Body)
(when (list? V)
(let ((rev (reverse V)))
(pm:help rev (PostPat ...) Dformals DTemps DPat Body)))]
[(pm V (null) Body) (when (null? V) Body)]
[(pm V (pair P0 P1) Body)
(when (pair? V)
(let ((X (car V)) (Y (cdr V)))
(pm X P0 (pm Y P1 Body))))]))
(define-syntax pm:help
(syntax-rules ()
[(pm:help V () (DFormal ...) (DTemp ...) DPat Body)
(let f ((ls V) (DTemp '()) ...)
(if (null? ls)
(let ((DFormal DTemp) ...) Body)
(let ((X (car ls)) (Y (cdr ls)))
(pm X DPat
(f Y (cons DFormal DTemp) ...)))))]
[(pm:help V (Post0 PostPat ...) DFormals DTemps DPat Body)
(when (pair? V)
(let ((X (car V)) (Y (cdr V)))
(pm X Post0
(pm:help Y (PostPat ...) DFormals DTemps DPat Body))))]))
(define-syntax pm:error
(syntax-rules ()
[(pm:error X ...) (error 'syncase 'X ...)]))
(define-syntax pm:eq?
(syntax-rules ()
[(_ A B SK FK) ; b should be an identifier
(let-syntax ([f (syntax-rules (B)
[(f B _SK _FK) (pm:ak _SK)]
[(f nonB _SK _FK) (pm:ak _FK)])])
(f A SK FK))]))
(define-syntax pm:member?
(syntax-rules ()
[(pm:member? A () SK FK) (pm:ak FK)]
[(pm:member? A (Id0 . Ids) SK FK)
(pm:eq? A Id0 SK (cont () (pm:member? A Ids SK FK)))]))
(define-syntax pm:find-dup
(syntax-rules ()
[(pm:find-dup () SK FK) (pm:ak FK)]
[(pm:find-dup (X . Y) SK FK)
(pm:member? X Y
(cont () (pm:ak SK X)) (cont () (pm:find-dup Y SK FK)))]))
(define-syntax pm:gen-temps
(syntax-rules ()
[(_ () Acc K) (pm:ak K Acc)]
[(_ (X . Y) Acc K) (pm:gen-temps Y (temp . Acc) K)]))
;;; ------------------------------
;;; Continuation representation and stuff
(define-syntax cont ; broken for non-nullary case
(syntax-rules ()
[(_ () Body) Body]
[(_ (Var ...) Body Exp ...)
(let-syntax ([f (syntax-rules ()
[(_ Var ...) Body])])
(f Exp ...))]))
(define-syntax pm:ak
(syntax-rules ()
[(_ (X Y ...) Z ...) (X Y ... Z ...)]))
;;; ------------------------------
;;; tests
;(define exp0
; '(syncase '((a) (b) (c d))
; ((,zz ,ww) ((,zz .. ,ww) ..)
; zz)))
;(define test
; (lambda (x)
; (pretty-print x)
; (pretty-print (eval x))
; (newline)))
;
;(define test0 (lambda () (test exp0)))
;;; There are three additional special forms, which should be obvious.
(define-syntax synlambda
(syntax-rules (guard)
[(_ pat (guard g ...) body0 body1 ...)
(lambda (x)
(syncase x
[pat (guard g ...) (begin body0 body1 ...)]))]
[(_ pat body0 body1 ...)
(lambda (x)
(syncase x
[pat (begin body0 body1 ...)]))]))
(define-syntax synlet
(syntax-rules (guard)
[(_ ([pat (guard g) rhs] ...) body0 body1 ...)
((synlambda `(,pat ...)
(guard (and g ...)) body0 body1 ...) `(,rhs ...))]
[(_ ([pat rhs] ...) body0 body1 ...)
((synlambda `(,pat ...) body0 body1 ...) `(,rhs ...))]
[(_ stuff ...) (synlet-all-guarded () stuff ...)]))
(define-syntax synlet-all-guarded
(syntax-rules (guard)
[(_ (x ...) () body0 body1 ...) (synlet (x ...) body0 body1 ...)]
[(_ (x ...) ([pat (guard g0 g1 g2 ...) rhs] decl ...) body0 body1 ...)
(synlet-all-guarded (x ... [pat (guard (and g0 g1 g2 ...)) rhs])
(decl ...) body0 body1 ...)]
[(_ (x ...) ([pat rhs] decl ...) body0 body1 ...)
(synlet-all-guarded (x ... [pat (guard #t) rhs])
(decl ...) body0 body1 ...)]
[(_ (x ...) ([pat] decl ...) body0 body1 ...)
(pm:error "synlet missing right-hand-side for pattern: ~s" pat)]
[(_ () (decl ...)) (pm:error "synlet missing body")]))
(define-syntax synlet*
(syntax-rules ()
[(_ (dec) body0 body1 ...) (synlet (dec) body0 body1 ...)]
[(_ (dec0 decl ...) body0 body1 ...)
(synlet (dec0) (synlet* (decl ...) body0 body1 ...))]))
(define make-double-collector-over-list
(lambda (constructor1 base1 constructor2 base2)
(letrec ((loop42 (lambda args
(if (not (= (length args) 2))
(error 'syncase "Invalid rhs expression"))
(let ([f (car args)] [arg (cadr args)])
(cond
[(null? arg) `(,base1 ,base2)]
[else
(synlet ([`(,x ,y) (f (car arg))]
[`(,x* ,y*) (loop42 f (cdr arg))])
`(,(constructor1 x x*)
,(constructor2 y y*)))])))))
loop42))))

200
ta6ob/nanopass/tests/test-driver.ss Normal file
View file

@ -0,0 +1,200 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests test-driver)
(export define-passes pass-names passes tracer test-one test-all tests
print-file)
(import (rnrs) (tests helpers))
(define subst
(lambda (new old tree)
(cond
[(null? tree) '()]
[(equal? tree old) new]
[(pair? tree) `(,(subst new old (car tree)) .
,(subst new old (cdr tree)))]
[else tree])))
(define void (lambda () (if #f #f)))
(define-syntax define-passes
(syntax-rules ()
[(_ p1 p2 ...) (list '(p1 p2 ...) (list p1 p2 ...))]))
(define passes
(let ([pass-list '()])
(case-lambda
[() pass-list]
[(x) (set! pass-list x)])))
(define-syntax pass-names
(identifier-syntax (let ([passes (passes)])
(if (null? passes) '() (car passes)))))
(define tests
(let ([test-list '()])
(case-lambda
[() test-list]
[(x) (set! test-list x)])))
(define tracer
(let ([trace-list '()])
(case-lambda
[() trace-list]
[(x)
(set! trace-list
(cond
[(eq? x #t) pass-names]
[(eq? x #f) '()]
[(and (symbol? x) (memq x pass-names)) (list x)]
[(and (list? x) (for-all (lambda (x) (memq x pass-names)) x)) x]
[else (error 'tracer (format "invalid argument ~s" x))]))])))
(define test-all
(case-lambda
[() (test-all #t #f #f)]
[(emit?) (test-all emit? #f #f)]
[(emit? print-expr?) (test-all emit? print-expr? #f)]
[(emit? print-expr? check-eval?)
(for-each
(lambda (x)
(when print-expr? (pretty-print x))
(unless (test-one x emit?)
(error 'test-all "test failed")))
(tests))]))
(define print-file
(lambda (path)
(with-input-from-file path
(letrec ([f (lambda ()
(unless (eof-object? (peek-char))
(write-char (read-char))
(f)))])
f))))
(define test-one
(case-lambda
[(original-input-expr) (test-one original-input-expr #t)]
[(original-input-expr emit?)
(let ([answer (interpret original-input-expr)])
(define-syntax on-error
(syntax-rules ()
[(_ e0 e1 e2 ...)
(guard (e [else e0 (raise e)])
e1 e2 ...)]))
#;
(define check-eval
(lambda (pass-name input-expr output-expr)
(on-error
(begin
(printf "~s input:~%" pass-name)
(pretty-print input-expr)
(printf "========~%~s output:~%" pass-name)
(pretty-print output-expr))
(let ([t (interpret output-exr)])
(unless (equal? t answer)
(error pass-name
(format "answer is ~s, should have been ~s" t answer)))
(let ([t (parameterize ([run-cp0 (lambda (cp0 x) x)])
(interpret output-expr))])
(unless (equal? t answer)
(error pass-name "answer is ~s, should have been ~s"
t answer)))))))
(define check-eval
(lambda (pass-name input-expr output-expr)
(void)))
(define run
(lambda (input-expr pass-names pass-procs)
(if (null? pass-names)
input-expr
(let ([pass-name (car pass-names)])
(when (memq pass-name (tracer)) (printf "~%~s:~%" pass-name))
(let ([pass (car pass-procs)])
(let ([output-expr
(on-error
(begin
(printf "~s input:~%" pass-name)
(pretty-print input-expr))
(pass input-expr))])
(check-eval pass-name input-expr output-expr)
(when (memq pass-name (tracer))
(pretty-print output-expr))
(run output-expr (cdr pass-names) (cdr pass-procs))))))))
;; AWK - TODO - need to come up with more elegant handling of this
;; since looking up generate-code for each test is
;; pretty hackish. Maybe passes could handle this as
;; well?
(define generate-code
(lambda (expr)
(let ([passes (passes)])
(if (null? passes)
(error 'generate-code "No passes defined")
(let ([proc (let l ([names (car passes)]
[procs (cadr passes)])
(cond
[(null? names)
(error 'generate-code
"No generate-code pass defined")]
[(eq? 'generate-code (car names)) (car procs)]
[else (l (cdr names) (cdr procs))]))])
(proc expr))))))
(define run-code
(lambda (input-expr)
(define asm-file "t1.s")
(define err-file "t1.err")
(define out-file "t1.out")
(when (memq 'generate-code (tracer)) (printf "~%generate-code:~%"))
(on-error
(begin
(printf "generate-code input:~%")
(pretty-print input-expr))
(when (file-exists? asm-file) (delete-file asm-file))
(with-output-to-file asm-file
(lambda ()
(printf "/* ~%")
(pretty-print original-input-expr)
(printf "*/~%~%")
(print-file "canned.s")
(newline)
(generate-code input-expr))))
(on-error
(begin
(printf "generate-code input:~%")
(pretty-print input-expr)
(printf "========~%generate-code output:~%")
(print-file asm-file)
(printf "========~%")
(print-file err-file))
(let ([t (assemble-and-run asm-file err-file out-file)])
(unless (equal? t answer)
(error 'generate-code
(format "answer is ~s, should have been ~s"
t answer)))))
(when (memq 'generate-code (tracer)) (print-file asm-file))))
(reset-seed)
(let ([expr (run original-input-expr (car (passes)) (cadr (passes)))])
(when (and emit? (memq 'generate-code pass-names))
(run-code expr))
#t))]))
(define assemble-and-run
(lambda (asm-file err-file out-file)
(define shell
(lambda (s . args)
(system (apply format s args))))
(unless
(= 0 (shell "cc -o run startup.c ~a > ~a 2>&1" asm-file err-file))
(error 'generate-program "build error(s)"))
(let ([status (shell "exec ./run > ~a 2>&1" out-file)])
(shell "cat ~a >> ~a" out-file err-file)
(unless (= status 0)
(error 'generate-program "run error(s)")))
; replace #<void> with "#<void>" to make it something the reader can
; handle, then substitute void for "#<void>"
(shell "sed -e 's/#<void>/\"#<void>\"/g' < ~a > ~a.tmp"
out-file out-file)
(let ([ip (open-input-file (format "~a.tmp" out-file))])
(let ([x (subst (void) "#<void>" (read ip))])
(close-input-port ip)
x)))))

9
ta6ob/nanopass/tests/unit-test-helpers-implementation.chezscheme.sls Normal file
View file

@ -0,0 +1,9 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (chezscheme))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (parameterize ([print-level 3] [print-length 6]) (format args ...))])))

29
ta6ob/nanopass/tests/unit-test-helpers-implementation.ikarus.sls Normal file
View file

@ -0,0 +1,29 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (ikarus))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)])))

36
ta6ob/nanopass/tests/unit-test-helpers-implementation.ironscheme.sls Normal file
View file

@ -0,0 +1,36 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (ironscheme))
;; easy enough to define ;p
(define (with-output-to-string thunk)
(let-values (((p g) (open-string-output-port)))
(parameterize ([current-output-port p])
(thunk)
(g))))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)])))

32
ta6ob/nanopass/tests/unit-test-helpers-implementation.vicare.sls Normal file
View file

@ -0,0 +1,32 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (vicare))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)]))
;; needed to get an r6rs script to print with vicare
(current-output-port (current-error-port)))

124
ta6ob/nanopass/tests/unit-test-helpers.ss Normal file
View file

@ -0,0 +1,124 @@
;;; Copyright (c) 2000-2018 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers)
(export test-suite test assert-equal? assert-error with-output-to-string format-error-message)
(import (rnrs) (tests unit-test-helpers-implementation) (only (nanopass helpers) errorf))
(define-syntax test-suite
(lambda (x)
(define name->run-name
(lambda (name)
(datum->syntax name
(string->symbol
(string-append "run-" (symbol->string (syntax->datum name)))))))
(syntax-case x ()
[(_ name test test* ...)
(with-syntax ([run (name->run-name #'name)])
#'(define run
(lambda ()
(display "Running ")
(write (quote name))
(display " test suite...\n")
(let f ([tests (list (lambda () test) (lambda () test*) ...)]
[successes 0] [failures 0] [exceptions 0])
(if (null? tests)
(begin
(display "Ran ")
(write (+ successes failures exceptions))
(display " tests with ")
(write successes)
(display " successes, ")
(write failures)
(display " failures, and ")
(write exceptions)
(display " exceptions\n")
(and (= failures 0) (= exceptions 0)))
(guard (e [else
(display " caught expection... ")
(display-condition e)
(newline)
(f (cdr tests) successes failures
(+ exceptions 1))])
(let ([result ((car tests))])
(write result)
(newline)
(if result
(f (cdr tests) (+ successes 1) failures
exceptions)
(f (cdr tests) successes (+ failures 1)
exceptions)))))))))])))
(define-syntax test
(syntax-rules ()
[(_ name assertion assertion* ...)
(begin
(display " Testing ")
(write (quote name))
(display " ...")
(and assertion assertion* ...))]))
;; extended to cover record equality, but not doing the union-find
;; equality we should be doing.
(define stupid-extended-equal?
(lambda (x y)
(or (equal? x y)
(and (record? x)
(record? y)
(record=? x y)))))
(define record-type-accessors
(lambda (rtd)
(let loop ([i (vector-length (record-type-field-names rtd))] [ls '()])
(if (fx=? i 0)
ls
(let ([i (fx- i 1)])
(loop i (cons (record-accessor rtd i) ls)))))))
(define record=?
(lambda (x y)
(let ([rtd (record-rtd x)])
(and (eq? rtd (record-rtd y))
(let loop ([rtd rtd])
(or (eq? rtd #f)
(and (for-all (lambda (ac) (stupid-extended-equal? (ac x) (ac y))) (record-type-accessors rtd))
(loop (record-type-parent rtd)))))))))
(define-syntax assert-equal?
(syntax-rules ()
[(_ expected actual)
(or (stupid-extended-equal? expected actual)
(begin
(newline)
(display "!!! ")
(write actual)
(display " does not match expected: ")
(write expected)
(newline)
#f))]))
(define-syntax assert-error
(syntax-rules ()
[(_ ?msg ?expr)
(let ([msg ?msg])
(guard (e [else
(let ([e-msg (with-output-to-string
(lambda ()
(display-condition e)))])
(or (string=? msg e-msg)
(begin
(newline)
(display "!!! expected error message ")
(write msg)
(display " does not match ")
(write e-msg)
(newline)
#f)))])
(let ([t ?expr])
(newline)
(display "!!! expected error with message ")
(write msg)
(display " but got result ")
(write t)
(newline)
#f)))])))

1105
ta6ob/nanopass/tests/unit-tests.ss Normal file
View file

File diff suppressed because it is too large Load diff