pax_global_header00006660000000000000000000000064137430673030014520gustar00rootroot0000000000000052 comment=68990d02573faa555ee42919d5809de03f1268a0 nanopass-framework-scheme-1.9.2/000077500000000000000000000000001374306730300166105ustar00rootroot00000000000000nanopass-framework-scheme-1.9.2/.gitignore000066400000000000000000000000141374306730300205730ustar00rootroot00000000000000.sw? .*.sw? nanopass-framework-scheme-1.9.2/.travis.yml000066400000000000000000000021741374306730300207250ustar00rootroot00000000000000language: 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 nanopass-framework-scheme-1.9.2/.travis/000077500000000000000000000000001374306730300201765ustar00rootroot00000000000000nanopass-framework-scheme-1.9.2/.travis/install_scheme000077500000000000000000000070311374306730300231170ustar00rootroot00000000000000#!/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 nanopass-framework-scheme-1.9.2/.travis/run_tests000077500000000000000000000006201374306730300221500ustar00rootroot00000000000000#!/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 nanopass-framework-scheme-1.9.2/Acknowledgements000066400000000000000000000006201374306730300220230ustar00rootroot00000000000000Acknowledgements 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. nanopass-framework-scheme-1.9.2/Copyright000066400000000000000000000021311374306730300205000ustar00rootroot00000000000000Copyright (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. nanopass-framework-scheme-1.9.2/LOG000066400000000000000000001307221374306730300171610ustar00rootroot000000000000002008-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 nanopass-framework-scheme-1.9.2/ReadMe.md000066400000000000000000000045271374306730300202770ustar00rootroot00000000000000Nanopass 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. nanopass-framework-scheme-1.9.2/TODO000066400000000000000000000026451374306730300173070ustar00rootroot00000000000000TODO 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. nanopass-framework-scheme-1.9.2/doc/000077500000000000000000000000001374306730300173555ustar00rootroot00000000000000nanopass-framework-scheme-1.9.2/doc/Makefile000066400000000000000000000011251374306730300210140ustar00rootroot00000000000000# 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: nanopass-framework-scheme-1.9.2/doc/language-api.ss000066400000000000000000000035371374306730300222660ustar00rootroot00000000000000(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))) nanopass-framework-scheme-1.9.2/doc/user-guide.bib000066400000000000000000000046301374306730300221070ustar00rootroot00000000000000@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.} } nanopass-framework-scheme-1.9.2/doc/user-guide.pdf000066400000000000000000011010101374306730300221130ustar00rootroot00000000000000%PDF-1.5 % 90 0 obj << /Length 521 /Filter /FlateDecode >> stream xuRMo  ǶFj^ꪇ4fwKޤa7I^<y E;D$I#bZI% Jj#fqx{ۻ+<ߐ1;*ֶqS%+1R ET"\bʙ4aDT*> S"I-W&h ZDtB%~\qY}\D&#ILY3g%' T*D} d$A4Msn0]z,viAM;OIx[/Og;-p0liph9\G'Dx9His6>lKōRHI ^`~Q&]\:*78f,Tt1=/Wௌ3%yA{%~ŵCNgjOFP@IݜȿQI5}]a?"Gq?zWwCv%dRcvХƛWvΓw_!& endstream endobj 102 0 obj << /Length 2782 /Filter /FlateDecode >> stream xڝ˒БZ1͉Ie'DB#xPg'_~4\ED7hECt|'Gar(CWax<%EO iX eaQ)mLTkg*8 𮧫9Ҹ z7=Meԝy9h?2NP 4<ՇxpF^2ZggCwx*`r9ߟXg#y#IȚRaeJA5\*N{fJU\٘ͩ[!*LuTUEIr .KA2idRPE}tcߑJQu <2:=20\H$´֐8,k3vŎ*WgRIi$=Kx[Ö#wi{pcg;VH XnñTU)(%ѐpJ:&I`1ɞWF5FbFӣ;Y8̎/cp *I 6-nB,#wֹzҀ9#݀FYT&$yע 0K @f+'n3ZچE`@[G/DË#d$'œ%Kd&z4Eur'#h4jYtfZ |۷'(ogfrhFU) 3(TwIyNm4 A07 ҠӮFauf+1{&ĸn%_d"A)A22i<۶Y&$=iLkPyNne悈1Z; jnbɏrUjhCF]۾ =} 鎵|IJFSȱ9I$nNĹd cݤ"R/We2LHSI~la@I6+\]USޱnR %[Ef17[Iv0͈,nx$?͓c˜u?a) ȐV6j8r6`<|~7PHQ7hxϰB`Cb^@h ӞG9=Ӕht<b"ćȀ]Ynw2R EvdhX3|M?2e wȷ3 i.9 Dl=Zr 0zff3 nQ+ۀv(arZc>+lxI R,hbX6<5gY,ZrlIFRIHpI4r:"l϶e803E,fc2 @\f[A/$uCv#u#npCNO@ r#BY-8e\f$suGھr9U-pħ  D@2ǃvcO༻s eT[JvRrY m0Vy'7g;Ij@kݘA鄗$}}j!.nJ(K IXen fG\JBO8\qɪ[s ٰ5g4xYU/)K ~VR,usH).Uz'@%YLAjUvKi9|BG*09p_ ~ΧRnXcu 4L`RJo[WQ**V4~f zFC~WS{f?H0X$qgz  ~k[˸Kao~|px/= C8VQ/RTnG<#&b_ܦ7'fSa-M1{y,TIXDK;j#wKUQu/j#<8QynaerlJ (/RmAjHDCNOwsȐxr #뭭cvD氨eSvp!QBr}*0S/]㰬Ԏ\!\K).( 8 - &2ڔ_=8Au =nz׎,w(%I]??ďzI')~78BUUPr~'ut+J@ҭr!;aU )uVrR+NM7vC;/Y\v9J'ۿqr<0T!؜䦌nUDW!N `O")[-j endstream endobj 116 0 obj << /Length 3659 /Filter /FlateDecode >> stream xڕɖܶ>_G{rm)X烢Dw#bmS58'B.ǻ7|WE.v'ݯ8пgY}(~_?~Ϗ?y?',@T"ĸ d ČԟUdg:^Z>J\Z0aNZq^:ʐؗy 䙧=F[= Zв%p%ݾutm;&C8vf_L{><4'^ A8t15,agkD|P>O"h@"-+^0Edş#,#G;CղEӋh8'cRx2 YdQ\}ӶŶ bs!SbiêjPםMm0lPFƢS8cŊAL kχC,0T\LGM"x-1E5vD}cHKHI4 W B3 shİ^^T'kۉJA^FHMYk;k fW{mdCqp堑<~0{ +}-85qa"0܌f0ЋJkĸW CCt_!vN(%anb`G!"Er߁G,vK8(,^LF 8.Lb{~)I,s9-G Y ZvǚVܰ[UMz6$LbqNxEYԆ||eI8儤n?z\ѽdr=p)ŸKMa9dԒ fÁl_'7t `$LqY"jPKtyvrBL܉1jv.B+$zXl1W(4}yĹn\wnJ?AOtG`Ot35't%^,6l+tpXxtAC!]MjK/H'n[җ*PNw\” HHI"ޖc^0mhuWCyi#.sNJ"DPFȪHP8TY}ǂ `*4j'* b"= u6ĕt3$͚!#ͥFb'×J A #Lrƒ,! LSyjő bpW;Zg\p+ \E{#Qm[ܖ$XICj|u }2h=j#Ss/:[A``2&bmx|o"hk̉=⁷]kfq KlƖ,9ۥ~AoZYb? h,t}*I>%PZcB?Hǝᡊ'vXzyLERփKɦKb{gI40`b:= f!>PRĚ3iz@$3lT.ȗEfqDi eƂA2†V#.DF2qt\jÈa!tٶFt4̕wI1şřގ@)AZ:nxSXw_&fW3=!GRi\ڔblϱejyW7=0Cu=a1þIÎ憣<"=~ F98cT.̫KF #3Gn؞1>_A,zSY:CШ081B7~$uQ6kN8գT5̯0o&_>e:GV /7j42k`"}[;V\L}*S m3Rgb;u ?-2\ ;^kw$*r?v`W؅;߽eXw?ZEhywP };hKZT~xjy"4 ,~UaY)3Rǡ) ov!$7 ܤ>: n^p#),h?U0V>HJ_i2ȢD.(^A/LRh8F`5=>BA#`F^J _>j endstream endobj 129 0 obj << /Length 1357 /Filter /FlateDecode >> stream x}WK8ϯQTs1ٙT%e F$~!;qVw_-~/^y#2*4_w"]Xo_֯?R$QRޯ?R VL}=X#X*y MLW7y=;>3 D!0I28%y5M~ɥD, 齈?/h`*sp1h7Cyӵk~0ݐ1OH+ZƉ4bnL5BRq;@eϸEN- +ܗ3=r!K{+H%2mtsl4N5y oj?sλbIEh.ͦtb*:qӛ5쎿'5׷^6#ܝ*+4Hj-(р\lFo_-\ 8mFޛ9 db2M Kdv qS\ <>O>7r2H<*|p5nɱS&$IE%RM]h_Uw$2T5IEM=P}B̢e2弻k3=~2+FS&X"t+> ݲaR*&v/F-v̞B1=Cg웷bMGqdz1uh :r; %J=%9,ȁ~?UkIkTEe^G@c#Y$**Oc<ĨLI"77I3M"b.lA^ӽ A:}46xv-iWɴ0DCAG;EyZyƊh2ӫѕ9Lƭu]O柶 y6p%„KEl`b5E#g/d6@YUgVq%a(T0lp!w㕝iՑ^j\oޤ(wqӅ֋> stream xڵWKs6W=Q&"{kӴNfzsHH☯#.DJtڃ `oX"oEޯ"yw =iJoKIRmJQU@׉OV_6 :V$IcY )LD e|W૬c+nL2{17RL4a?T $E"UQ i vR4\P$hǃ$ĵzR7h@P< Zlvd:@Qdzj(-Zi+4hFDkT5kQR:ԗb&S@H)`@D[S;խɕejΌ'SnZ :vt{m&$+*F$jpU ,;.1Fii /dvwxnabj̱u-MmSglcDU.J Y!N/B~9&vߪ+|s!W(F2V"E3Pox)I㱹/xˋʳ\%b⿎h̕yVIDf۬,u&=afDoo;JVq 5o%*k4/)lՊ_;R xȾC"):G)0#9t X%lSt }yl3ydwf#e8n=6j> stream xڵY_۶OLB% @v޸q&O8HlX"%O X,]|qgx4N˴ԋȅux'/\qI\F\=}gDɋgy&zvHO^BZ^AǛ?/t̸@R#.j +i`JL緖筝LzTBL)`KbdNdn-/Rq{TNJ>'|Ӵ$e\e~Szģ$\)Ŵ֋X][n˾|oϥL835+e4nٞ͆WL;cHro>Ӛ mb&ĺ>CK)DwK mP}CSDŃL@ ow'3chCp)U,6w>(RT5wxYi-{h컞zP#DڵAky?o[y뢬o7Tݖu^Q*u^ޗ] E_upeIrP\FN?PAX8p tTCnvy'l|k?,z 0uD]['cf K>>y47ޤGpb)LS$Aı2yx[:t=VN${ k뾛> n?X3-_{4I3!3paHs٬pRqO8aLvbf /?V= =a#ϙY\*Ə{׮g N1 ɹ۲v BUN ͌ [*wqUeMm}r۴}Dx R!>%*[\njtimVsX} &^~Ι,Ɇ pٌxw2r3Ių`֑IrȜCJ3ppԟET[)nq`Ii·sdF)ܗV%Y$"}K&Y}0)-Kk~`:qcs.Ax*j0Șk), KWTRRIN1((a*;A,ʑdrTjP uUP iD!C&{X8+1 r\hp +"P<pT[J̑A`ԙ0-c| IL!6MU5eط`Fg'!(7gڌ4C -1^o;(Z9S ]ƜtgpI > stream xڕko6{~޷/"*pWW'ME}hs,ѶJľ_ )i]_3y~n޽woeɃ<&6)LT߷ͯ7W]줔(إi?o>(ݾ7_/2]_§_{;G""S;^* )d7Qw'Sf0'a6zQLi3'`R|Dq>+jQa4˱w':)S9uG[k'(b3;m@2Зkp B 5of+VPV0>ho"ʶu[4D@Ep{&M{@̶v`X##ZPi~kEtnq̧͙ T Dgcr!f$0"Eg@UH}={`)PQʱ. z}Pe1eȰVּy^ #r+2 {/N~qiz="4z6nmW=%J0`ap]^ʫ+`u rsPϤ$| [y< uStOʊò)$E)v{qD-`>Ur +;cͨxP*G[Xm>I x к4Ķ rͷߓiDj~e2 X+x8}{I Gw 2m0`ɡƣAŠLN+ 7 x 8V)R% `_J fNEkl+ۍ3Nl܅#5 !ktG,!({[E7f/*NaTbiPFbvM`Tm tٸ5>kR0 S0C<* R0Qlbx1x;ħ5,X3Pki 2|r«IkXB /Ɏgyc$Szˑ GDhu[e1jAծh_YqRt}xvGE  '!c2eJ΄z_NBn83z-|$1͞}ry%7FgIz*Nr)ztmS"'AǮu3\B' EAf/7:K^FH7D[2Dĭ,faނ` kiš+ Qo]&H~Kz60b`E؛>P,Y?Wy5 \ <) Roo-9BS: Z<-`d (_Xk (12d.ϐX ΓզJm+[ܑGWBy@vP[O rȂ;dEխ?ĆfA*y40P>hSLl\0PqG1+"-"yj\Ӡ/axNMS 3,E Cc+ %Lr i:Wmpm@2. K1XaYU7 HǼ{cqS {V&0|nOm3otX<st'˗|S>oݜt;|ss(s8 :Þ{5yAk)@.R7_a~sn=4m_LyA[<ݽ|tz?9&1FX0ǎ ^78 WJtƎshn͎t)شw7)^N[qmU,/Щ_g,ȢkRpOvW(j`@~1]K|ݟ>`ѷ=^\t,tz>ǷTRAqILD3F90sřP8*gc̓ A7% 9֔<$2`Gǁ )қnt9#c1mHj<6ɚ՘hڤMKYB0KQiOۂ4:~aA9={̋׆{ ="ٺ{Hpj,?/j_oǴMG"> stream xڝے۶}BӾp3B3mi'7Oi( bM2/~} $%Q'rspp`zX7|VW^0p[Ǘ?߽vm ]i|7޼{ͣo_{[_硗Ϸ޿~9F9AR Ou K jt'AQ;ݘ mwtl/IСʵ0x( Ԃc+_@ڠ߻,U&6Y$CTE0Q ;=PWLM}w/|,66k [&R&ʦa+@jl#zuԻr[HJE4(%~E*_a+&NoCѐ4i0(&Q)mWF48 %D*3@Xc̶$>O3\W4? m 5eA gѷn{XwsnPcljTo$7_/WV_uGZ逝b7q<Ƃ)2bAGJ')|npEׅ;As+v'RK]{ĕ$*Ҭ/d"CZt3O&/Na$6ef<"q[[V0'2=Ԡ3h*D7TԂgۓY%c < MbaY8^ `1͡聴z)6 1)<~ڭG+,et@mPr-1sǧ,)P2_;lȈ0'Nt`#T`M[t{wr?S򜼎I(;4T=NJaMd% GjA!:eW> drC%r|Q@.@oW8ݕ# ;4jXn/O_sh-c[|K-o_Ԃ*.tr5:*q[V'd+"@bMQI$z0_l%rDac 7EF]N88x~!T>OpeQ@:O'=-i YG} vh-ٶ,Jy^SIhbidLr8G6ej24*)GbpuՎ|&B DžCCGʦu#{lV07Np"|"o<L̾Mf S%tPVoX*Ce(s!I[>Xfb&Dvq>-~%hy;=!;%gUq_} 닺lbHU~rӚc WCϸP@0\XtC nP}_ |.`Z͒yA&n^_nWm]M&y#&g3n9CEa˓HI9gLkx>zϦra(@}Ok$r]6r%8@TKwd2k_db8viTE~!6**% R8|!Ku;]i#PEiG2mjLX09މy$ǐ5 Yc Y).`:WNFk"X խ8Ȩ|S:˂m D"߂?ǽ"  P]ג2k#j* 8 v'/Qza!!8ϙfT6$H<Қ\ٙH֋72~ђJȾfel)@0=k ᐽDazc]KCgTڔLzK)7v"c1[ w)\۠ƘXms8%VՖ#~0:RF=ŧ G*kj:Vf*,バ +`if7+uGŐS[c/>PwCԨ<_8U6O.RU;>GJ¢=8Dydv/ ZcUl=L’0\2)QLJHSڍ` :Uqe,\\㌔Nӣp wjM0/ P@H_ol+~<9X7Ѓ r΄| ?ecKbE* 0YNv%f菃yhsqg\n)$TYq2ap hB-S ӈh1G h}AK#b4{b,7Y,m0O,P|` ]}Unc]ɳPRp :cQC#?2ߜx]<{O tr1dac[-6@=rcf *t5/<\K,F;:TTj3 d[> nNB) xT((qxy5$`eB"C9d2Edf4zﾕ~iuld3i5Cu)nF zmfr3T4Ң霭*~1F:R׹$> 6؀LKBc|)Pb<&NWQBKFrE~sxuwp(7Ɓa@HPRZ7*Wri +[褪y<(\ GTk )hv>,4|6>^)XB|򼗓?`k3E3OkL ߆ޡb2mb) o'}'fC}80$4<쓣dHC\sV`On/i[aw;/@F endstream endobj 158 0 obj << /Length 2215 /Filter /FlateDecode >> stream xڕr_1G*/>\eWɱvԖ* %!e}rYw7x7r2,ODؤbo\v﫭2jYۻۻO|}?W">|!ݯU/_`1dbSb+f붷"#n~(TG5E>}O8/W"x|5E..Sh|ʦl#@{Dz= ϧp틆UY31WM\kҮjm]hЗG7X!Qh88%.=|rBGa350QE=(";VMQ#EuNqK󹫎P}-C2pF׶:.vEtvxT]/0 -X&0~J] r P9|J1.#ûY@6vW'(,‘=͜e*qDh;@/D2p%G3/Ij\FD'fKA 󔁇yEʬ2YPDCRW|I`i?@-AuC7Fe%C/@jmӡji lA- ř+Xuqd]%sPPM[1H*`$B6 K, 1` j55MĠPVԉ6xp+ XQc׬/o-B1ɭ^r_+ KJ&i9o%r*YԘ4PTMO%RgsO+ e %otr5 Bá"eRN8RnA()bR2P^Ș1|M E1LE7U)[QnN"[%M Mi?:ѱ,x\ͺgď@h,o+MlV]G[m'to A.Ҵ*hUEJ֜)q˅~,t* JCA. ZB^W@T]"` -,QN r^svIYK&Plq@D29e`M{tхX]V I4R-¿^i0EWh$xxU"…X]صSبi* DpD}l"^L3c/X.cHI=sKAȁ(iѴvmL!ޓ3hxF5;7 g#\d kf Om_fƏxf}nw~>N18ٺG]{VGPx+ PJ/zٛ|bLۊS'#ړQzL& NVl=pZ,a: njStNc*~"==,;A} :YCv!1jNZ?L˥sryXD[ ;"s䞠xT#udus.aE66# WdfKq_U0&K-L^㔩Z8N^xuM_ ix)ٞd*Z%;TR5!_& yur2ٹʺY`Rz$K{e^%I6kx]}X,q $u,6~] CԖ {2}{u꣎ 9Cs?O`i/=V  {SI^~ckM fo5elf# }?rAt}}Vc|$&7`2)f,[0)PM%jOy(OXߜL@!K"Ig|dN ^#] o3/sЄ%p!qHԥS-~ar,h\4y>O iuKQ,vy8}dS)5{dt@7:W׍&D\]$@pakaANXP8ӂO[oFw9vpW-H\n > {`l]՞v}> stream xYIorp gg;![%f$ v-UEHA$X˫Wox]ċt/ Q*]?,2`~?\rU^*,_~o?׷vRO]~σ_V9|?za|IeLMx[[TG4ozUmŤt:rǞz_jz*UwcXzLPOBL U{r} ЧުrO'׫H.J.;V0jtGB\Du%i#baU+@V4fS˾xߕMMă}lO喦S2-k뮯'e:RIʬ-/FKx_$Ge;g%{YWÜ9㍅IqS=MOKSzl򳩺u[|Yuo%)Ԭmh̙m4+ OG/FTU`:WB$< PYIxӮfa{{[/l Ԗ'#LOϻȵ#T>ȒlHRl2̅J *6<-Fqi9ExL /ͫ9+Y o8ulۊ4l(l+6g=6VR  H0KG1˿4wq!P 0| k3aGs86c+MW!BCy!2J?b"%1\A gҵ;Hd*5eڙI}O!9#\~dol573dsD1fN?wz&M3 tHb+f߱Ll;p ďՆz'R24F"7=2!3vϳy0o;[=NMR9luv{~C妣P?װjI_'yU\a79+/A o*9ve)hy8_T6ɗ-Ty! $pTGdJOpdU;^]X3ohGm@ɩ-zP"U&}?VڗK8L/מ02yc yɔoŞv9\r-H֞b3SFER?$*JpMpw&8&dcڬ')%%|{7 Xr J|`q+ H)vɨt!tyR.]j(D24سn5 EN rM]s߆HP0|oc{ȧ;.\"-DE z~:xBdhM/ocgy6iܿ7vZ endstream endobj 2 0 obj << /Type /ObjStm /N 100 /First 799 /Length 2018 /Filter /FlateDecode >> stream xڵYnH}Wcf/1' LF-Ŷ(&=EI%˚fuuUS"I$OQHIRʑ2,~YR!4#;ZG(p ,*B6E`8L@ LXfNuEe<'@pxF x21eV^W~>jJ/WMUfP_EB9}4}Ar5]TCnq=r_[_q=RV6=v_XY547kԔ?֩p˻f0d3>q~ eG7g}Z?[mE)]xdnakLc۰o I,Ѧxoj~69La>?/޴ [{-bT|𛬦rԃ^[")ot[b}JA=Lctv77EU {/Acv􋟣MHvt l*Ls$jʩWU;vkT.5k8;dWf$6J8;ٗ.UqI3 S,qх;P4D|8,+ټugau'kûNzE*VC?kWp NH).4)"sZIAS=D'Z ,Sb?"0HMbp؂BؚpN4Ygf} u{YMg%@,!4 R:*T +Lx)JT թJI^|~sꭳZ 3n 4f|[X#cP3 g*lla2_NÀc˦0mG%:&V*!2 $u̫:R?="8<8s-d,88h:m ‚y ׵)Ӌ(֋ܾ<eEɿ`&$BeΠzn2^?غ;d핓]f|M3OY5Ny͌fϪr{UE9=p8lw~kBeõЧmŝ5`RpGxnmlEUCÁUCi8-dto{q(+y8iʓ|=  iޗUq-EYݾ>VQڢ8(*u8vg{[Q=~[o j1V$jCrfa\>;y|F{@>#?MyANHrVhi^vm1_Ij~C {bH# ;)9H #-Mz2QhE>F!&ǹ"'L@OmqOswp" endstream endobj 171 0 obj << /Length 2364 /Filter /FlateDecode >> stream xڽY[o6~?8A#Rԭ}(ۜI.@L,,$~g8ELx -})+R.Xd0p]?rx)*7~4/- ]?_л?~?F&9 0'|,[0iW?qQR¦MGzZUO՞r,J尡 ?A"r$KՖ|֕v53]JUMi6+/M_65 7-5`bZp0C3DţeEJ) d:&l*5.'Ⴒޖn:2zUU zKkyv<2IBlw)ADg&%8eV]3Ζ޵e,-]J4 !&#Q—Si:"A7][MHZF {H F44azS{,;ʜuٷ}M5ifO{nsOrOB|($!?#-Qf.K( ^ [Z &̓{<[3 P*8q/r;<)H<,Mg0b]#.xe @6JF_d!0Y\5p=BBޗ^\zT{]@am4ʥovC LzeO8RekkOc|C]s|@35~lZ#Y`ׅvtU`2yAő-> D-"$aÚi g[M{TYM1.M'8nM^|@8nUn>`ɂ(- V V6:Km4gxX Ў$ (S[ao7!f-NNHT@tjZ\^0QS@*Xj 4׈D;F9 0U =d+N<anhQj8cӂ˞-2qO0 \#ב `Gm9Hqޛ?#$2wZuymZml3J/!\\ZVjcy{lՇn{> stream xڵYKs6W̑Si7R\=RF"YG?]p=݋,z^Df>w (a$q$UkcITǺ3'"+S~9_-od S鈛aE㱦#u7R{zIUʸj늦N&H/~nOk-XCYfSyO"+~١AI ,ŅNs"6?BVf yC xGue"{P_L^P~xޓv/rڎSg%hvG ģ<͡<,+c$|KMɟW>8e{\GW ׺ ZKf |vT6mynF&zs9؍SHpc٘rdh^x/HMC<“Y,YX2Lۙ-aS|5ngGAPb=gG H;%FoJ۔%\(G# ˁ4{+qm\4~OUMY+Ui5AށU&69ܢpbyLBɘGӠ ӣx5GKsɌRh/Y\ ]LLߏCE|>6;3̓Hr!2DcW`?ߜ%zP*ɹ@g_U&au9|̛YLe1;طġy pM_n7͢+KU Z<*DX8"ek+K$"p*p̒J@lExƃc8TMֱO,A!tdga3Y96sâk!fhS1#t e%`΄C<[l)չ\w('t+ٝMn=ͦ::E)T #'OE2] ߟ<3 |۶Н. 3Ϧ N *KlŒU%R]_X}I<]}:B(Mwl3Oq 9~\rmf侗ׯ> endstream endobj 179 0 obj << /Length 1701 /Filter /FlateDecode >> stream xXKs6W72@d{踍dḇD$Xv:Ӌ ,ەzn.~^\, 'j&La~Bx@g{)375#ynqzՊZR}썥*0yiۛQ\膶Xju)KA&FZ[UM#[vpz`$v`G` x^3dqL-+0)5Rm(*E߈@"0"|Y(7A-]U"]]~> \UMrMg33(s8n~8 ( l-nso[T ̆Lxԅ^"#_DbhdA2׫ԠiN>aäߪ%z0FZq踆Ȫ6x˘Lh40PeU5foYEUvil=,]p`cW+'єcNʜC4(3zۼ(g=cS/OEqZߡ!E{P8G7" V& L7Qדv Sk#5p7 5=5Nj/!c@fGXGdf5ڟ~GD.'QA$5CSa寮 Ћ?Mr2N9_vW5^OwÈNCq??jdt%&̃$͎PM8?50`/ @pڐWk BSgZ <VvQ>kt.1 k55?6&ÔύoψK캬,yƥq9o ʦ endstream endobj 185 0 obj << /Length 2952 /Filter /FlateDecode >> stream xڵr6_}R<얳>T労 19د>A5`3^.r'29ڜ,Uq/?^|'*M3w~{>%^xÃ|]^ė~|7&ř JAK^-)8 "F+|%S@&)U{?AT PNcoNwT}BF2x)0{0w`x Owsuy`Hߪ4NeSwAm"j2RAX2s k\` wQ<*=4Dv9X.Bg j1@~"(;U6іFPr[&#Y+WeGgK\G&;`5O-_U8yW+wJx"\7$1Eo0[ymnZ#SMlf:C±i@]>6@vQnw(U%|Er'I2/b<͟G##j[vZkvS4h4Ñ.VJed0#׈mP_sF3̵;T=ѵ.]0#][*eD/(׬5XAJFUd D 4LpS#_z/aVUaA:?Y\qWw\-J4zݐKV^`L6WpLb.o5?Ljx~A5-ԡont[ hZr<\a{Ni1M: UH2 AgviْY*E\5wKBW宬JA v~jJz>o"= U4Pn\,iEQr18#oLا &#?gpeBv H?a{puYB|Փ=S?lOqmS/Δc.}{b=ߟ66X/O# :[ 8w͒@5ͧ*MkYBOn ~~Fa}' kź-afee#n#AN~H/k,lvׅ/kpO|Rݧ au?0qF?AQ{xqk 3Ⱥ_svKu$AidN3HO%/>ȸu5 q2 }Hh}3li2Ftj{3i,BʸPC#h:}K(!}I"L]jBt[Ԕ]bFnJtN[a06Z&T["1Pwأ@(sF,IK,qG UÌE2 {MQ[m@J#nwm$e($0? ]HĹ3B%lv+,6K*YNB#Us Pncxʮ!^aOGT׌ vVu 7czGve!S82 Ϗ|%3#jesUUSOvq l`=o6cBpaT"KPOr!mnLoK?.u}[ƌt0R Bn )~=#8Fui]@PDLX(B$LKm(B2.x3eT=^YU-\V륌z+ * .gcӨ>=焻F&.rM+jDiQ- MGdOQ]ub%k)K.ubL-#VD b4)"YWɒغ FT{ڒ2'_F B ! "J-{%hfkq2|ڈ1 Ǟܤ&2S)Ӆ _UFq4;M?1Z0; s 2!Ǖ S- L E3k trkIišamDW(:[0:ƁI-# |ʇ1ZX L _+pW=P1fK-p~GHbA$HEý@4 CAiv`!*WY"sAH1|Zm8m[֟䴱O.pXoUʛ֝!KB(>Pk& cP(v.S:Ay{4|nAbrTו3 4m7:ߘ,p$2Dv9iɲ^[t-VI0zB%=;>뉎9 u?1ܶƬ-ŝjfL ܦQ_\LcbX-:09}aX#4oفy3+6ؒho\FG f)O؄% aM/6{X@LS r=}>"e12*Z[UpoU{a jafX?~P{6Y d8r]*E*G*|n[Z;nS*?kVo$:̈́4eTfܖ7C&=8$| EN'oPuM ZeMR20hlSb?Sի4. endstream endobj 189 0 obj << /Length 2747 /Filter /FlateDecode >> stream xn8轩F$,`2Bh#~X$h`XdꄛMyꧫW?M O6WoR\?~ym(<l4ͼ߾{|m3} Wݔ R`BSb [߮<3:/k4~%Az8ʦyMUA+;QExF/qةo[?Co`~ Di`߹,̂;|ٕ߆1ԫ㩒 Ə8' c:jnkHCY#XdNs`d 97QqQyقAuA/$}nH {eM{ڷo},7S ?aeFEE i]eYF9WPk00eVݺnR9r@H+ӂʓV&X-ϼqb|9#\/X9,K8rfv++4g@;4 3T=[#ЪvwaeU,<Ah8"[N'h0^EKڇ'9fi" QCCб5U ڙD1Lpnhm}+yP-!6g ̻W<Ңxj`|]vԖxxݚfx]mc\?4]]tdTRHGsXOAP F hG)Nf-b4o#$t5|X̚FIWd T_؜[McuH7ʰh "حqĭ.FKAP?]+}j`mY&x zF㩬TA)Ͼ .BmRW <"aD对$YEA'quR8ii-{Z>j"BiO;RX|0[0dK.J@a.܄ ]+܁6;};W4kvS;|$Uwȁ9^Pe|<^LUJpc ?҇>8d=n6qzl.C UM, fg`}V6DMY =)e^@Jl"ɋ4słu*O) uSibMо6 Xwٖh1|ňwjHns.2r<r4>4 3v20'hKEWHv ] wfPKedeRS.,(dz9_xSX#x J Ǩ'1!y6ń`ܻimixn2S41,Meyfn\9rRY$>S$P( UAc@D OzI\3 0 ؕ@֪\N5/V,}5ڄژ|U1ڮKRi&Rm 楏K|UynVI2w G2jRZrS3 lޫ+ӕ5\kQ;ӦёW]OK:k-LgrScҦ{pNJ; A :d0 c;iԫNP)GǟsŹvF}`H?mAӧNժu-]Y3*$@UP|{> stream xڽXKs6W79til7$)LA[` J}wHI3X oX-FM2'x4t6b򝱝$[ڽj'#m]8G |L$`:ɋflCdTYڌ,&aᴨX@=͚dbl XB'B1͊K]yњF%+=KJ>TS7`ѡ^:~Ei.; &N@zEQٺ+9+Ѳ xZ.3$p_dk%XšuUK^,]6\n0-(8R+B|Q{5$d+eHk}ub`f: /)cW\ߊ>#JVE[E> Xa*HE?[FiwL}.%3m VقO@n6+U0 [:qL+`b܂PhVI7T cPΌץzȩ ̍rU4=1DŘ7J!@ZX!(5_Ðhie@Us!1ϖZ_F by8 -76ٲ*EYeQ XWXF]R>lI1FU)bUj@hJtiqd) Ck4F74gDLSTb?lnn\0_lõ QQKK4$QPО&06 #͉ЭBs-)nPzF)h?D=}+u#WGwJG֝gNalm^`wFexTT-_ƎCҫP)|>y#6p]7 Նw:xݜpްr͇lk'Qv"/,zCVlϭϟ Um'}ty:"T'|)/QZ8fc~ Ei-/Q>ZM6K Z>9Tz{A?=BcK?_`AF~<%iLȞ|WUZJԧ s 2n7L9fO3 ƶnl'p} ۳X "?@w`o)R ˁh K;zYP0F/uR&߇"jH6Z#Ì(BOYd3#dxeЉAN?A!G5Ǟf[ugN۬4&8|O/<ϚzS5WŠXn BDnx?Vi37OWqST;gLzh{Lv^xXϥY*l)ږklplu0kr0y^2TfwWnݻQԧg}Ê> s߹1)ɝYN5/WDߥMV5yBX_Eog莨vbxzL̽HR ^O/@\ endstream endobj 197 0 obj << /Length 2565 /Filter /FlateDecode >> stream xڭZYsܸ~P*q4\ x!)uڊhU#1!$ǒӍxbʃjpv7>*z >EriģU̯b\y?ۛBu'O7?~~zÿޭx}BC>D_V ||~&МXKF,)J`qu(R՚0(hݯ M˳\%}cZwz{Oma)oUݟ̺=I HM(= ®Y2,i/UnɈǏ>@dBħp 7.Y2`zEgƅA*cX,  6ԍABVɄy]kAL[eY)% r)eNt4e p '#`D &ȟuSAxN) va<H鷪BwCG@h VlhNCu8nn_:f¦TOA /~g H@HGY\L\\{u7e6IB?t79DxF qg(nRnfrHzjP@) $nj@OELN!Dcci{i=zQ끸ϺV&>R0CިmQF E je9RWPc7 ^Ӓ`X:R34#BkDA.|v4$%9bxD *'TCUPo^hFc[#c&kcYZ6)rKɠ g=cDBF^Rh2N"ǶHG)IȀ/FS= sY B\cKۗ`Ȫ V+-5~r;xnT@>`/3^$w6I̥iMBy^ 8R_jꃔf\A#`5f<at4a[gL) Y_%W7V DGУR?\4Lֶw'ޤvfyH?]ԵnVM.;8y^-T׭)Ot^irzz"/ `&] l u`j$H|.YZn] 8 (7՚K*K@ܤHe[0J!`{FYKsm(5%B`Kr P ܒYG%w!-#~*#C1GVhL3W𼨆G"29}y}1a@]75ϟwd2_ 3%7&(0P ˌhOrPW2xPNiVuH5VS9?Gb):Gsl=JY3#3{˞>؏Ko_5O?ҾkENopn]bOP7pz}r8ҥ۷JD(ն;k 2c pι?o9ϝp5o"07V-er !^ Ed]v@ ̠Żۄ5.wB@8gS&Úrs2&w\:UkKڒه;E᜻\4!]rK7p}{Ts9DSoZ.3)UP# tߖ{,!~Fk/'\tV)8^0.^Iȼ7_Fb?؁y䱢xw7O}>8_xжLO081\}Ҹҏ^x6Om w\7o+ endstream endobj 201 0 obj << /Length 2816 /Filter /FlateDecode >> stream xڵr}<R07]oʵqEZUȡ208Vߧ%㼈3====}L7VÛ|>HW~ޯz_b$I߽ ~{'·wW zGr n1a^tJ'lO*8DMn6~Ev{<6ȏ盿#,x U(͢LhӰa%\B}|[x, npe1t/~zHڨM nw3P u}bIl.?hIR}WJ7yW#mQ][i rBOc=/u59us͌8pM9N WHǰj7OTK)vǛȼP7E8 4; ̛+tN*!^Uw Sd-~Thpʜ"hS*@u yX8JyHmH*E9yQ淥 R" H ~Vlh;`kQ@yb~zafpFH&*qL5CN^<ߩGP$5vEu'({A0u{SFKn[ MKɯNiȠ昷)sPCmV*?3A2 A h=ం=U?U= FbHb[ g5tc3ӡK%K¦e;UYGD+Q ju~ZUlsg'kg/"siv`LXH)bө͍@{ɨ=xo7빞o>]z-o 05a!2)/u؆t _VSKrC`ٍ,M*OPr<` d (,d+Ff_& KOfG}pZgRH#o0X5M! Pdij=/3drD8fMM\opy>G }8vCxYhx`? qF,==Ybr~`$L.s<$aeaN_v4 Nxp*9Zs*BH!|,JT 6o驦T^:Ϗ(Fue7NΩSnU%ѲJb ~14m,pNHb8N)덑F`O4*m]`rS[&Aʏ]/*l8P$;ě cS59>BuYl,^D8{Ct* +Ś֑QVN-cwt5م f̥CШ}=!6d:Es[ض]!s%<æ}a t̒$n ~: pO. >yxi AɴdG`5>O[ݰmZ?k77}t=¹YlD ZK{'cX6w~~yYEG,TiUWo 5xf)rPXQ$>Ğg~`hϞk]kkkԃg"{c\d^`DG[sl|S9_!%v'Ggz"Яm}3='O:gv/W˴X)Ϻ˗N/ 9*#ռ*ܼOcX6=giRxQ1 z S=GF䫾,~nZ?@AAo0b,HѯJ#_CFY $ l ǖ5OCQѧ]\A;^'4tn+P9;33k ~E }}oFM gD-)-{ ( u?ϡkTW.׆+>bb?϶>e!L/ !]g>W~D,%V\?+xP\ X b)!)9øtAT5Zb)l {e#;!H}B*wo o endstream endobj 205 0 obj << /Length 1777 /Filter /FlateDecode >> stream xڭYKs6Whr 1>Lqu'j/I b (h3rGo>.޼Fsg>'z4GS ,V֧?.Wvtf}rs{s{ԯ]u}u8`v ? S!%y3UF^) c۟Y4N~^HW(&-$5&UR-obZg)$rI8Xh' ϙ{SÍ]'9Ŏh;L2S?_']\8`ЋF:hނA!?g"!w wDjx(5.rSgN;I6MB؃:M fvdeJJfd]ߔ8j &,*x/X"?P"IIF,%,fʪ;g@8JqG ^UB>'B"NB ԵvbݫKLb* ?qIO *J3~6\G}" *8M҇ kv.`8 "raQ :%<680$(47}XrZL3Lx] SH=,3@[ gs0;H޳@aIf^{ڶN{/H Wy;:%rEZ(ۢ@Y=&4b^(c7B&cѬo)e(;4IO:J1F|0d=`W7w2z,۾Zͻﳮ:mZL,sJ2;n_xK&N8pqΓ_5xMH{Uh0" cauc'<FN!{SDWCD:,0h*V\ﵑU_LOֶ6Z4/~ ;KFkg Z4x^Sl9s WU1__1/K}8FϚz^[7VR k WX4v[ HH2X'|}IA#[^hjǔy endstream endobj 210 0 obj << /Length 1066 /Filter /FlateDecode >> stream xڭXn8}Wއ؁R[ТnlEPlOn )WC,q.g #cmaջ;<͹j9V\;-h;;|ۉۇO可=>?{"l9Dr+\3s6gy3=maǪs`[Y۸ڨ.r-[P2S\5aZ?y, ovhb|ˬR`SnO yؔ0Cj0?`;j%S2;nh,I[X`̌BO<[7J2~TsvfO=;"mPP_e!K]Fv%7m΂qRٍ$'NeFTRWfEFRDRj+)ѸBqTA{ 95V,ADKzE},)KJ8(N?< *Wz ?MAٮǜ\%si[#z5牤"Tmd5< 3 9 #U؝ ;݋۳a{2`fHX'> stream xX[o6~кÄ+ [Ct#1VYREIEfNҭ Q~"[Ɲa瓓  \[#X;8?}:Mgo/_Tή.8ϼȵ 爆5ԂEV "*N,#&Ӓ=:X. PlO A̸C&6Vyˊ$\)M=dNH`oklI4ˋxV[K5 ~xk3X$'sV,(y!+cHL/SxIڳؐWG#)Ň5VfN4HuІ2tVqc*oԳ')1TĜn}gy_-à]iV =|6yع-IN"PmryXwjMuqe&yFZZ."ү.TݯCy8BrE;ž— K &LF1WG+2vf7LgM+BJ;BY! )[!_-^0M1(U=]S&,^Ej_VȊ$_$Xs'\a4 r?Oo{y f%T\Q3\GAm9M]e&YR9B9%Bdә\j / Pmūj6QNS pZ+Vӕފ|S]k$R䚧M$A?aY cESX ͩ9Gbİc5j>"؈ؤIXzaw\q-4R \&O/KQ krpPI+5anTK8r>|`XZaCرp=Y,-#}poWTkh@,Io%(=y dN%/@&=,tQP 1me7IJ09΃AAe> stream xXKs6Wpԋ Ow\vx2z3$#$ؗ\%ܙz , mSjv{<ͷ4_֑n2V뛻[~re]ŧqy~ņiDBRT49-_ؠu "QX,aU+ /9yy'֩v/,2-^| y挄*d t2HVS QNƐp5 csNDe*I2 #p]E%mi$*"{M/y1&r I)F2ϙL5ұ/&U^dEBG]&-י@>:) %J#26.ਸL^Eh%H˦Y)Cd7Ce _ `bFT \)%\ٓ=-c.T9fW2ʤ\L f)qPҶ R$-|{emȁ>lYR$VI4YhE8G$<P[#^b4ݐ[*}nGsf]z}/I endstream endobj 224 0 obj << /Length 1208 /Filter /FlateDecode >> stream xX[oF~ϯ*92=l:V(x cjf i`2;g>Π+kEWnF2)W߯aS5qf7>2/ș?wy4͍ƴ\YPre5yKmPL3 9Dh0Gf5 Y~ $rXx'Mh*ԁgy`nO uוc:x}OϴxƼpM+e/>c :|jb+Kwа`f<E2z])>J!S"I" D:j!p\(5)z?ye9Oq.KJ~{l 6(Ե}Z}ذ0.ꓷWSSBYsZBW\Ij@HՏ'dh k-qrpl$!x Ү |sf^ Z׉Z3Ȫan#1 N3ADAErC.#JbTk\DI8@BY< G wP#J8gM>T-kQ'>SwQjw~|Jeeol~D* endstream endobj 228 0 obj << /Length 1300 /Filter /FlateDecode >> stream xYmo6_y&CR/.E:^,+SZ Md˰!ŰQ"%Q,KNvKxyɏ.tAAhj<]tv4xi׃7wornUг^]ݽoLߋF?f,AdRDj Rn \ aJeZFASyl5*Q X6FеBlS狸 lbcOǨ'^p1< WQ6 7K/|6rn + (>{FPN_uR [R{H-##G~|V-H ?SNf'rAfV?Ya$Jz:dQK߃p5-E@B't.1U8X"JZɖCئڤiWb}-k %/ dp/_审tR޴0_nn⟞KDͱ[^ܧ|8ͯZv}ւïCI*GZV1߀KU|O}ɂӠmǞ4A(q5ȸr‚1. jZ+_kw|>*ŸzliHgecQz87Xq;E#KLjYg"z!_{894 "f+E% WB\QT)̄6ۗшP)3hFm5~6)4hk[S 9a-*ZڋD'"?7DK#?h:Xdq(7%Ot/r@Jj~eSGv4s= c@@Y0Υ:mܿS/b"Bm69;Nj/o51&o6"-O#-. TezSgul袪Љv%\ޥ;" xMkxr%r@o9B]E?u"KӝĐc(f,}aWUV9-I,|1g&b {:S;Wwvŵ5)ޢ:應U+R`~"rմ}iP{Q.ߝ'RB%!{PeFQK1 z?9D1-Rhq|bШoU5p1`ŲHM{=_no9`%N+.148ā:b'8fWюd~_d endstream endobj 232 0 obj << /Length 1483 /Filter /FlateDecode >> stream xYmo6_!!&N!u) Aش<ɆDٖ- E>wGeU*rapzn+ÉC:cvcj0vu=非g?Yuu'q璷k2p7iP5BŔ"<%m L͂)@wHd:[c%hZ>)Q4Cj*@GQ aN hkǸ1Y4LB_SgyA3z%lU\펁:XQ)bףQh AS3\Yʚ>{,kyR beAEd_٣G]Z~5ZjD[JsXBXrKPe scp4b:ھПq,Uf-I!>GT cJɀ$(ln>J(sJNzU3̨Ä_)'VjmBv8ϲhAC?2Ώ(O;"k 3B1J[nk=p߿gͅi4;. k.Oc |\sD"s7FY*P؟W#FHDO ~I/ ʓ\?Z^/F&f*kʪA(ѪfN6m$GJNCvFoqH(lG]bXiTVkJr6eCu#~RQad<ȂV$y!G{z%~$–R1_?U=8}=zD/`Qk y/1|\`Ry=Oxc[Hhѽ6kMGZLJJǫV9E8=ҿ$$xT wiSm|=ؙ$(}]鮆pE >O`ϽeI;eLwlwr3 <\gÏ/@h 9Ֆ2:)6ުkw\;9[(N N50?ðmmeg'Zom > stream xڽnF_!(@"!q@%Dž+\p V2jwaɇ>H;;3;RoLzxh}t浍vc4i8FhܸR;ްZSuW9O'c= /;MQ{qף?j,t#&æ,{0 l.0-ʬZn Mn$$٤چku(+2w m$'BT)(TyX('( ]9.*yFq8޹/˿V[ɓ_1kvydC38)sw><bql{4,6qDp& Q)gSWqyjn=BF|>^\VdpyzZ&@ZM+malRO3=M6+o-r'է/;<)t?nRB.Æ'3s7ilm&Y(9 Gow(YU`wNUUq,phwkuto[ Ϻao<<`E?U L$˜c֒3YIL|94Cj\"dxp狝P7I&$ i@Wݿ`i4J_ʜ(Ȳ5oOt$8"ˌʹ~VM xÈ,.3B6MOW|4n!˔oE놤)Hr<%OBq' K"Ls*cf)D|u# 0q.^;]] ]^s($^`*c̿Q0(@&臌 4.X`J3D C3q%e%Mi/)<0@"XzVIϤROS56AT&10Z0QS,]CE#TSP!qVYWL4 !Ň2m&q$ xY=H3]WldHZ%\q[DsQGLے*yN~,*rFG- .g#$?z@B? GC _!J@ ˓Ob*TȑmIƕ|> stream xڽZݏܶ_q{A)R8N+A ٕ./JV{ADCr8͇6In޾ݫoOBMfn2g^t柷4M7Fn,|-z}k7mo6*I3`v2I^%T@-o͕7fk2LyωKxrum*wݶPV;oT-ꪯS7CStlVsLdo=y[7dCF칗凣yY} ͩlC,}Y7t tql^ k,Nl8 >Ѧ5hԄ#JBO2 7.G`XHv?,zx@.ڴLõ30 ~v6WM rfDvƧD ٠T Ti86 +gU/ݨSsUcV@X  _D٬x)75YLPȪ]Op 9?V@ | t>K91MyV6ʧ~ xDz߂V:D>aGfǕݕŭʒ NǕu40`"Kw%Ly_F[z~,[ ˣ\nJ  A @gx KMXu傛+Sܬq"D>-?];ʚl3tN#O2\2nRy|R#fy Fd uV -ǎrWϝA53}M,=}.ƣ2.m#^NU4BQPt?zS&s$jP C]AKnZnlT7`yW6)t#^SF: X(=(2&9U$creJ1(B^Hg๫U' NW\\˥a+n\)pG^H RB, OUf@q_ 1.,EP I')(cXvadp:HMܖWsnfjq[e?$yX)#˔k Er#j7-EBle1is\.ڔ.6,GNfXOINKvky$4ڷLƇޅD{EkU8R/raÎ8BFS[<2QNH>\SГѰSC׈;EW$ lC|O0JEy7uS )MnIBt")I"%1}6Ӆm=/+7rX`.蚁B 4u e3(Q"B+e@!ODb444abNGinqB@Tx F $6=ttjLH Xxa=jr.H}E Z&!*(&Ϛi 浕R6*8SpՀAZ]/q 4%FϱS5;٤`*ssC:(ILkNn*UA֪eRnOD=JYfx/p`pnvS ,J1 <.MkPGBTxɍhO`ky<~`ESyv%vǮ'@ׯn!xvGGi$}HuL}5 G/}EBžU&/,  @=欘 +PcЏ /ӷQ7|4!(3> stream xڽr>_#=*IJMmav YHH|} J"n/n/zX0s?/WRL˕1e>~@xo.>7RzWW0߿QEri w0UkWaJ痼7隱黁ΐ::Dsƫ"1֮6+gc LP⊖ٽM "Jf*$"{Žf@.E={AP4iv{; ǻz}fFpuNׯFk\x")sV6m %P2hx>ݕa_<5z[}huZe'h߸o~Wp qVlmM{vm7`mz@^}鹯:1>-Y>KϳV xؽ?H`p88zyvMd ./ 9xpPgq+J5OET_zտNș2S%o=&%bIU1Ő`F,&] ZfMwm%iFdM`'[OV!Wnv@O y=mBPcs*D+ E,*}xwYBY~iik`k 4`raq G%- eZ`,xLXnbfk TTһIZT\c9h],O>RDX­ ީ: /NgAYgja"Xh4#x*v0#h;*4D*8ӧv, 2D2epgV(4DI ] v}7@{җ/ôYdQ"cELV":a@zc|}d79]kv!"Կ"kưpah')Htw q!I]sE5R}E8ֵ,5H)<Ҙ('ι`18;uІ>m騮vzNz$&{&*?NacIq(uy$!J)"Ɉ⹓Ž@b]= J;CۡzP,IÔ `go]P7 J$na]Kh$ jKНbɋoeQdu_Z4bA Dv]bA IxɀO2>3ys_0MRq .nYn.xۑ:=mش} {g7,e|2c|2Cqw{-uw kn{H+3ț Ǔ/ψ7r aM}hom%辘xk"ҩhUH(x <^B6 ts,[AC8P.H͜a_oi\fc6`;p&[q.jrOnKݿ=l=hƁ/y#X2Je-^CÄ4HXK})0|J&J.H5%:Rz$.0`2KEQ,ޠ2c4!M ȜQH)MpmnFr!NSYq4k&ڧߎLӍFV2Ĉeh-s<8s&]4 >`y@GPFkce55av'H40DT`f;Oq@>FfGre%ۡs N2c {0WvÂN@Hӗ䙓4ei4n pR8 U O`ws.r=,MS!퇵/* oFK4CHe`; bG=T9A҆US! -!{9uIm:V!P?&:( (vT ADHl1~j,BW`^HLWŁƎ'!>xz[cr'Δ%7GXV^rBEX4LaִYP?h^E]ϗ$wJ\ϗ.-q#L#L,i-ԹDrǼMH;{l8DL-Tã:1">.. 6f¡XO鵾fi '/Ryq0:xFR1Ԓ֗$́3ʡq@S, AadԹ"MHә]Y6 8[UiCB'5)Q ɘ뢡xZ)-wU5S:2/,6g$`U{ɣ&kV(Bgz,#`xugF%ᬛnor9UsS)Xzsh҃z3L8en‹mKlzuzك؈XAeNiu{#7=,}/މ&`u kgMA?#[rY1y2?dgM'0 ge%u R9T.\BL/}5YGXCXOkɊ-R8W/N5@Rĵ@jSe H6ޘLX#SR%ݓ/Fˊ(% 5R|N#Qn6c> stream xrq<0RbIQ*"&>> *XXIkY>K.]f3 ~ͷ16b Ie8U,h]lV9Xy֮.}_n76f)wͽ]ɛi=-ˢ47+brk)R 4~2M -";/ˑ#}E^ F gQmzϟ͠rADlL4,H/ZaV,xɍY(|=!JWi$$r$r 5^ݚ/Y4+E.E{zWv~}*ܴC_$8y*iʯ.Zؙ_<3NLefӆiBmʰY΁nArL(6&8cg7uu_ )iPi*Js6N=6I8hcNbVwٱEz5=J e~o[n+E㯅KpLZUrctRT% `,~THB tcc'~Z)l qܜHgN㍾#p %9 Y\`5bE8Ha^Q/v"Z[SdJ2ެmN 5x#aTǏVMT~7)O9Hs`RVa  S=oʮ.[fs 1/YH]]o<+PcH\k~}R(4X%Q. "eSqs/HєY4jX+J $^`KWdAL~WjTcEQ6HЀDVSDzVv5u]?8G V`4rw+ٔ֘.*8REi8ú).oї=Gjw|t%38Of~ȼpt$]ѯ0;S m1bz+/6!{ j3JQᛚ@43ݲdq\`YM5YQ6_#u~e X=YgLg٤_),@F:Sj4rFi>,4J{VHFA+/r?^ú40+"T~Qc鵎<݁˿5ap,v_(T>xr`5WͰFIurWEZ:qG,* Q2-@Gt|)eDZ3O@kfj.lʕ˪TB#ԍՋԿV}@!(R$yLdgo$f3CyAK7'1m#}ۏ*yeҝh^^͛bc|dKKg3þݵGWm+)P:Q҉j XƋΙM{> 3Wr[r'H1'ꀨWXӤrMx@2mQ|ht泅e'x^J]4pc&8GxpT=qa/1RjG.hGWiȋApoct ]-MbdSz,N"+\ yhV)4O8l~WR_Iǟכfx2&:B'. Rg8-{/ yd8tIƗXųL!3H8Y7ƴM 3+-)k "y('P+æAk,YF4Jqڞ!JvIo1VVhXu"=ǷvyW3;Vre]h:%>|e}-=P!Ԧ?P|+(#~D%]lɀ.$g6gIZ1j+vp(#$>Y\7]W|+gᾩ^7 z w6qLBٛZF'uU4e]W ߌ&ckhyB( (6g-n;/4nog̞pztmu]$ʙk$Z'>4/ut 3&j P^,Ih ND$Тk0MDoʝfJ㼉r5ɸwIZ| ;=釢Q4g<M0_QCђ_`_s'?S7CߕBeJ3HIBIa1,ʓoax}׏n3Bl^& endstream endobj 254 0 obj << /Length 1087 /Filter /FlateDecode >> stream xڍVKs6WzLx{su)"!PH*}Ғ̸Hb_)JWn \4VHHbUE^Z'1Dq!Ǜ; twU)z|/>)D krdO3[ufZßD/^Rj$cS٩aMZ}W plQqBA7*s2vT.L뮪a/MvM=uCSzp>_N(.蜅/D6z \+\d,Msb:퓵!NiV.tIFK"<\ fi^q[yUz/Lm]5Ղ[-V?%xR*mp_[ x;<0l~dTsbƐ~e=6/PCyx(8ˑkn&޴lz= \ݏ~v%4kFOj 9x4NKy]Ö`~ck|D _lf6-HN, $2y%;AuiJ]~$LYN۲).R@$v K2caָH93"wcʫu`~9fl\H] O%f8gWL'F8W&8xo o9/˞P kè7X-&KbNr!.pNЌNߊC=nk'iY@q^V 'ahcXZ-" 9ܑ1$ "_)oV? e endstream endobj 259 0 obj << /Length 2224 /Filter /FlateDecode >> stream xڥn6vK9X(j6E;`v E0k,ܛei.y?^vӧ~HN$L)\(X*wOќG4Ϣtӿd9^Hvqt}!R/tk=iԘb^,]JUrLǜ,ܵ_q~;vq+ks6w+Pȁ MPlLDdhh!,pu<qv#2*VXEIWI’0tUP6Б $r:x aЈnrfE3{E3-n0 9YWGxU"G`ii`Q=APĄf9Ġ) Rg"rlgGOA Ly&o*gkX@sV ä)źˮ@d>jM; g8n̆5c?#V(N@g }Z0ޫHƹު٩nMh p񄃍 &9Mf>{|R2COo3Կ]ܥLAaR_W0 Ys~ɞ _#VW_=X[ZOh:oFE$2ݛ -t(}AK0.ϮM[`X_zVN+33|T y +Ǹ~Qr~sϊ*f+Za2Υ@9 {[{po2M]uf&s] H9;pPä xhoNT #!+*G@K|OerUpd.' 39x}U;ٸ.1x웟u߃qcZʙJ9Bƾ4|ٗ>ù_-auoFՁSݘփRP Jt& t)U!͋;7V Y4QI N/X`^Q\ykt]І/aCc+t҂IwyNncܜn@GCooJR,^I%U+z~S!%Dͺ4fإu kG;S_{ğzp`+^ˡa!sIFږvRޒC.uqF;oq_M:b }-iU;EH}/HeϺe^ OaYq0H}&C?}?q{ endstream endobj 264 0 obj << /Length 1604 /Filter /FlateDecode >> stream xڽXKoFWȅ M"-l'mV"BHο/iEۃ} 8]ϒ/g4e(D$3 |)?14hKF$xWE_-^:/^}xa.ݥ#~~e۳˱ SP jXY+6H:uҖkJNjq2j+wݮkh7)HHCQN\J;4ƈ'[f2A YL8Cx4EFQD1ƄGoTSm4<*Uu}P -C?Wu2'U58ʋA[_qSRfY<)ɔryP4N"Y7M,^\nܱrW`,q:CcgFN#=^jcBR>#fID$q>9fDdħ[i6F[l'Yjf>T+tjٴ{epMLv^nbZF͍&8*G)]I\brUӪj>@k!L6}NV#q]\(/ "z'E8<@Y:=9M;CTaF,kcMKfP `]5sb\ւ2 s`l w$.rN?Xmeaw.џBo Bhqu}?i!8N'/ d(Ia`!<,© &fĈ ދ{_tL1uB:ΰ{ ,^<< 1֎vrqFU]z-S0Wσg'B֞FC0&SL0"^ЄDJx=>o8^LO{OѠL)tB]i}J}KFg8*N(MS@iݜHWe"&{swVXHq4%a(dbpɎ,#2(?S>ɠB%LĄ&t6_RXN=JL@CpԸNP '( &z{U,'y“K$Wͦ+ ~m{e5kҶߺ}WnGfc#&$hjz/Ͷz7t5@9#C'(IJۢ434}ٻ)M }pb$ !l9MLF-i`0m ? -nsU@OLj[Aihf#/eS_Շ2W:*_NSdƗۨ5ENnז?ߧ$ ω`Js` ]3# ~vCk}pdǂP3<=j;-}&Wgow 0 endstream endobj 268 0 obj << /Length 989 /Filter /FlateDecode >> stream xڵVK6_AwUA]M:3Y$Y`mMpyk:i;]9@h h_WO?OX)2M y$"X]yTʼnLC}Y\2@8M,:| Wmlr 8(&K< ,iM%,<͘WHyP"䈳)Zrf LxT"3O^\Ui QPثW6 8v 7cR>S&nݠMӉt x84>A`?Y2R)2w"?C3S\ⱋ3{U(I= xTspSƏ, n5uWA^b)XYla, 6`FH8꾦؝S"W~EeZĂH\&3M+X~/;=$""faQg{|g/LjFKKXAg2CwBw}b{e ^g͞玾$rbvՏ"4RG^J/!yidoZ_j~cSuy1W"]^^47_ ~qߩ=WhyLe=3u<y ZI qꔩx&TNbL\G-n. ˵Q:/]{$0Y=B cQ9ҵꈂlZo6$Ȍ@BN}ۧOgQq)]z!& [3@ ƶZvU V6gLzLe&-Nг]u%<)y2io[ Ӭx(نg,)i%7{ 8@x8ɝ_АxJЧ9Iu$oiT. endstream endobj 272 0 obj << /Length 1633 /Filter /FlateDecode >> stream xڭXnF}WCd(R "UG@JZ*Xwfgyh9H`hw9sm9;^YꤑYb8Xd緯_\}۾[38>ͽ>\nD޿pk|~}|!t&`X>yNYܴA'{?IۆMa{XR:u0Yt}bqX7e[{%y~/sq+: muT˳$vXM9n^3ذQU[WjU/H/j{5j{UW HrP-2>(;tY2'b+y5IxXKjI[Yt!PzaTv _lmRZMc{4,ubƾ.̉=rS0r`F1 bUYDnjX)G#z)vN rh̖S(ZYP4[nDݛԋs5ׁ.6S$4>8Or)x14nd.,XPw3.nl=kG ƣi;-#7 5LIp8I6LFĝ,ju9O>';`6i83;m+p|oS/F.J?}ʱZ雍Ԥa9Ycmz(j~?J~iTm8?}V"kJsRm^U?%u+60> stream xWMo0W .# {)ME1@E+Ya PcQ_~χ A@tQn(p&7ޟ?{!Z rzHT=`w /_tex}89+B3CDd25d^ZIO;L 8Pj&7iV (&%'߭BN*)cEp ۬n/2]ݴC>}mdCPZ! vy7 g ~XTgO]rYWKB0ĶțYĄ,*ȠTuV՘s,Rm GһD>fA4:;:!GCa'Ƚwȗ KB׭\_/j)G]3Q[Iu5G)h7L:hEe}Zt)@ Lٙ>kK.tHR1U٤oLSͥq vlQ/ڽm;mJ_Egyۏ{oQx/mκk2b)K%IB!w:/2_#Qa]LKoRKm!]}x߇7 endstream endobj 281 0 obj << /Length 1589 /Filter /FlateDecode >> stream xڭXIoFW!RN8f)qi1PJIl(RH7 [Ȟ'7N0 I1o2_M|6aaOn}rg`qƂ~{ 7[Er_qחoAHrfkSpǑb>,:ڗ]1\ʯX^*w"d% OrPlQnğ XW(q췒ˢP4w?)*ZƤ^ķFdFuM/JQ}|vb +τ[[J PDㄞ1diP \(V#Xb%4P6F\OGpFVVmq~o[=!h״'lƤ@8L\?"-)EQC~^gbJĊ-_ƹe짽u-ТhtJ:KEYc7B\J`($f5a u!4  <+( #iY<} }?dTɽrH/2`[ */Qeפ2ƛ 6L::fZY"'I͙tg??-9< )Wr 6b0RIfu+(m(J;3d^j1)՚J"!*:ڐծ6qX&EV( . AO[7^yg|wL77 ǖ7tc$l=K2|BxQ\/MX'":#N=\9gım*q[!έ殎+mRIJcvJa=*I2 k%P&KF. N(.6%̏`rKoξ'Oy^T endstream endobj 285 0 obj << /Length 753 /Filter /FlateDecode >> stream xڽWn@7qeͦJ+BFiʂ0bJcؙX :sP[hP bkXa צ?B߯n&]-7dk0s]ԡi08G'VwTGffq$ٞ&\`.7/(DYA tjK0VokQ^vW  _W> stream xXo6_rH}XHnA7bѶV[8($C#ywGۓĞ\8;zȊ|ן01K&Wƫ7/1[S3B _.pb|⷗~qaz=k]5Bfl,Yle MB`920Hm15=ד˲EuVMsb6>hxwr(mE^D (~-yM[( +4EyTז;B0/tsEL}VM~+<f\lDb ,54;9ƐdͶ :$q7t1aպXDHdT}s3% afx;k>־T;ch@8*ÑlO=ТF(yX۸,EIt%DTE\+֖wg)x3r;Q|jRK" +sH!h->F?3ҽmcfEA"'3o %"K`|"*U̫xވ %A45ZHG6HA7 4hXq $V,&'L\+/SiIDtL  #o(t-l.#dFN :bRҲ.zǕL;6MM\Χ4n4 #7R %>0r|2H%e%dIeIq}\U@X@.4J{M>!bA `) :*!wծãGh:EVv(%* Cn 璆ekSB=WV@Ѡp-ԁq(#jw rQֱEu0`/x4YJSx97^ToaSbK4}7m*':&P*pNySS+E ^T/4.yTJ%^࿣5ВwϕjK׎z~ߑ'H:-/lh{R#zNz"ߌ3w.TEGu"]233@'{bUFR 6]e+Ã,}z.B1hx,]|j3 r_O}ݒdB6Ot NhnO:ڼU ֮ɳBYj<ҍqlW^;I=i!(.0z*MOϞT0T"ރo{ha/~4\s`u$>Vv\W{>;&n endstream endobj 168 0 obj << /Type /ObjStm /N 100 /First 875 /Length 1446 /Filter /FlateDecode >> stream xYMo7ﯘc{rï'pS$ne }؈VZ.xq8W܅D2J2q4F5L+(J QB#b4 IZ:3CYO"0f[*o APj$ApC6I9vuȞ&p"h, 涽LL%*;$~ h#h01Z# Ѝ@Yr0hM]dSذZs2 lµ;9|I''ԟ!V =EeZF4ZApj Jx@aUyoWfKg_tfxY׿?y׿.nfٿzf ]x<@x@\b7hw.sr~"Wϗ;l:anek7[gi@&6iiLfla2:LYdJn߀ٝdB%3#pCf>{+nME_Z)|@W.W_wf5_Ks (rP];f#Ip՛'/V4!?\]/g3$d~vv~,)w)"/Cg$.]jVead|h54+OX81c147v1PD?J͇U`ԣȾX&c8V:/trMrbq!=ClgnakN|bp3cdg{9a|0 g؁ΰEϱ=eyTxU-OV-c""`efJiaɰ ~ ŠaRFXbqC;do|>ս[K(2)'p'qdۻh|;;̷@;$QdE?Ez<6WF 8'] O\[ l~ctI[7y|8{vOo3ns2:r&Jq'ljdȮNay;d*)~pRvhEdJI#IW؆VmcN<UlSy<ׁ82=.<OR(q2KX]:Vy#ıDFp"ي=8vWdXYj endstream endobj 295 0 obj << /Length 1061 /Filter /FlateDecode >> stream xXKF PN+y^zbI[E"$ؒ1R1?Hlɖ aaΈH~bo XzԳK˧z~yf!Llл o|^}ݫKo?f/8DgR&#PR9㎋eS.]<.u7P-1%՟̳l 2^B5pMq8NM#Nqv-AE9)\m۶_$neyLJMU+2ZHLRE.*Vƃ4!w|U-bwBo4Sε[[|JIjve&7:lيQ%zBFJ=(&I)ʝIF6LBy@JWG[d LY<# Zdm zIeZ[JZ@gkM&ͥd sC04+ 6EzBѺJsEhl^73YGhgxLUbdo ,c LTQP4WIXhO_2((L7p6bpB*ʃ= ep̄^J <2cW`Dq|x 'Py@Enjh)ꠀp쫰T0!@[6 : %ܶFg (w({((~Zfի5ڋ8D̰ .tgZ&rt,3%d\+;$ѻl9uel}qӈ͋O/^ܿw;m.n2jJz4DyjT0P946kzkzc/?- ?U#w 3905+seDGz2;2k]αjEG#O"O3 Aƾ|skꍚY aG=a6sj?;wKn~I endstream endobj 299 0 obj << /Length 354 /Filter /FlateDecode >> stream xu_O0)[gl韍m>5hp䁰$Ltνȼ y Yk1F^9 t#9 (3qz?df8Y` > stream x}UMs8W6rUX_u$$XjB&5MRV vVu&KI\d{6>:,e,)xP:O'rV=/zޘ"?:9\͒Ҕo>SOeFӞ\$)/k50KFBr-U®, =-rbj?ҢrSM-rNˌo}JR 2Iݿ]иK{hzE·TT!^!c^[rŶIs;u1m Ӣ M0[ݼy2R7ԫ .,6;vYWu⥢L=<#9-l[W*Ӟiem'U`kaT+zC:X !3.>\G'q ?YInQrs]Ϸ34M34D7ny>jiV+ުnGg_X…^*=X[@6 UcAU qDRZQ^ 9 .MJUWdpAf&Ny %ecȌ? 7ߘmP/| !MdQu6<`8Qnw=72nZy>>Z(ucwЏmfQyc<-1M w> stream xڍP[- $Ci58o!X;ww \!k23wޫ{&XHHq@ ȉBGebN uvB ȤA./* +'8@:@ 7k @vFrpZ[wy#! ;@ 6A* ` ;5B0wqqdgwwwg;9@DY.`g0 le*wkl(t)4,]AP0E`gm8B,PKv2#_,`wd dn`xZCv`[Ye6b!Y: +twPkGg6gk?zd#˘e R`3I[C/sdrm!!KkmX:kC\ ۼP#x@ /?{g##O%|/m}-/( 70  `'l~B?߿OF/ py+fPf+%%<ެ<VN r8j  W/sWnsaw,U !!h.,#[ݟz ?z/uuy].Օt_ e$ VvB_tKǢYCj<-V t/en|8pOey; -|a DyxYG ǟ,A\^\/,((]џo `7^8^[||!+;%ÿ!7/&x l@Ηd/<5UsW(m/#!=( sB65m7c"tۺ錬 v; ƪ+MK񟔏އua-I>& ۭ(?& %jȑXw||tm_5v*9c޸y.mT*>NhGQ##1z`\^M|TL`F=쭿{;\ELKODgd[r/Up޻K|._DY%bj?5"hp HVr'.mGw,* e-w]eR%PI# fs{7Eѱv'Ob G=ŕFG-{hRN>f[Q|_!瘺Bo|/׬6l|zݛ%z~Ƞ?hˤC |s…+,EPWYb*pޙLNwBBlO c1Wآ1/F| t$[(Xvqþ`6kt}1 ~zi; {0q`EY؏R73]$`~]= s,ƭr1D@C<1^__M4*%|-XPs)D6ɦwX3]턤l2d3]Mil芔|+ 1Brp+jC4YyC +( GV6rȥMǫS:K(W+[%Jv;bSIy|sber]R܅&xP;Qee%u8B4) 9HfFMI[i 6+\l#O|XFs~I{C伳>5e!0# Z+ v@jU`hGE7f|P&NeJ ]zd4]Wd|&Pv)y`T~nf%[Z^di#k!FoG{TFc}{tr+xES} Kk}9bHizTprs1h&jovzr;Z^@mHhG 5lUDL7^\oO~ >L[B줃gfHȴ 0!^}bKeJMrp12ޗvF1P>Uĺ'|{\s.L?<(nNs;kޛy8ccI*7?쾉PnNu_m%IQ)j⡮QI~@:z,E:6U҆99h;ǡj`{We?}P,dY6;F;}nl.H%'2 ZQwk.SP(mK@=Hі|nÿ]ڊY,azTG5~ 8`8ivJyؖ0GoEF+6+?oҔoxU9uNK_!ܒф^ޠ̫vDws oNZDW?浚"m`Ćl4L~\J/Kj7 %J5LT:Gx߹`Hjoц nB9mԃȨG%GʉF˺ Fwz)HLPn~/#ﾕXgB fyxa{|U@yIɢ=D`#5z;+W7]>T$>e /;,b;wxj֢[Oudg %~uHo_M g$9X53XE|>fھqPh3-hˌ HKڻ D$>8̠k'9Kz 'h,RO`|\UB1RIDZ]'3q9\"I6F5a1fϜFWQ@h%T:5+Po.c*t-nDN3T|3,o ߕj`y`6r[0`m5ySFl+uP2n`ON%NDDo-c+m{Ku9ojۧo f͓zs*%u8?6pQcң'%hy~[癨=qB,UӼ-sXԺNJ}N+m4[/(DQƝ9SdqrL $e:VXfɲp$mLՔu.%eϹmAAwcH1STLM.:My]pmB$UkUڪ:6 ^W%K 39˽_ Xuko &L bu]  5ǠShU/T~b*˒5ruOO&:$ܜX`<5i=(fqrZH6윔@zC,l*)ӧ31e[c:iuEE#2 L9N)$ykc+TUCVs;RCw>^?ue?bu8!wSԦPD çO5DC>x~v#'3rt4ck&mccQinaC6I*sxr^ǣE~ 7ɑ{EuEw6&?sgIC:跡џhBhCļ0XdC=TjA&L 3:&V}v݇ I|Yl&|άo#!QmM_֍tJYj5e|./3Cjj#NCmp(e0)ZN׺΢I0 !7 v7[9O)]{7i%>f\FOYiz#>&OlCyn54!>m[Wh.2=ۘԲ|:ξ{`P5wMڨ{ $_6"FT iC$m|G(z MAݴȽQwCʕxg\w#ޖ2P\u~d_htvE(sX~7Dd V9 XC vL}b~0-D)Fd=LOE6{yhROaaԝ{k>˂Xπъ(kqYQ53|A%i6M6q]%xy' YIڦ fpT'/9GR>fPײT1g!9\/c@WҚ 0`[J<Ӿ ܭ=9eLa|eO6"t n7,v_Vq;iΌDYe/%f~MF؂gBsLM?Y^ < .K׬0l깏8\|- jN,od"?Bjd._BS@a>D]"Q~IIYSCSqZi݊ v5Z.&V~R#J}+)Z;32)gNz>bHccy;)+hwK4=-e͍ z9j?"9@?l~%Nf!' B7v|1+]MD(+v(K{d#^Cf{EI(ٗI/6EF~]\ l9s>Х 𩎝ztG‰+SV8&=B)F`r,58KOb'GБi(0M4HG\׼wWH\75Vvװ=zzՍgzG,',D{ʥ;fI̻ r('ѹ `BJ.{^$|`n2^/#ZeelxQ2XŦWއ)}VG].NĤj~Ǐ';)^'NCP%ΣBpqc/J**ߞ"_-u9:/&!Q"lS:g ! 1z:BnR=4j_[9V{%,?Nׄ { +xƏ˙<=ٟ&_}m=Rb^I=Ѹm5b R;d|s9^-?f iY. yO-d'~9ɪJDFLhԑc_"4R(ҕoݷE+9:+\.'(SFY(8|j/S`S;soAQVNw'^"I|H~å9\ .,qꌏk̯đ~dŞ|[@&lg`3lxpCON!/ 5j {vX|CpY3*Z}M}4lDVam{GNh{|&H,0 {ɓ|sE ~|<:GLBzr >Izʵ_򘿈VpvH]I};k J׵\^QČܳ]:Nޠj\Vjފal‡+%Hk2[w>%~=T3h:>Π'T[*z%*Pr=1 ZZR ~w_`PlNK)!gYVMp =H{ SÏy g8]Cy\ixTЖ9ޒ&RppA@Sn,*ْG\" ` ֈCwImJ9S+$<`HdܰWO"RI"HF.aq䴘k_dgDOyM!Ăas13w㕃VTs0/ 4Cdal)֧$1aX#x@N_"9Dàƪo(?h0I]alcuaiz}pS)(؈/[ chI$W%-QEJ MXUHj.۩Ħ_& b&2 aoD0di*{ەݾ{:1NC )yϐ?CH+jdZza~GyZQ2a]q bd{kYGJR2Dyc٤sxSCmz ENzy4L]ɵ-ĒAiv2ǎ;^ݤ&{x߀)%l$- mP@+iZ>SmLr&8خms5*: ٯ{92 ]tJjw|EOKS0sՇ'@fYeU @Pb_3?c}zI53󣪅pMlھv :EL<6 [%.\7mRb'?,"MJ)BjTI"Ǒ!N/XAȖzC0)8ޝ{ ?Cpd r9]{o?}UEl2m %Zk+(hᩣOK1rLRև33yu 3,Tjn3 L|mQ׋2Bt^_1SZV ^=3Yo"~ߣէ>|K:]Ɂh?yo$qg-&Ƚ1InH؄H݂sJ?J"UDž0TV)6A? tDK“ff?NPRG-B1/Kֹ!wU ߭EH_b xgbmgl{I{/DGqATd>pӊfa|G8GLaE3jJ-nQZfXE~ L.>plfZT Lٙi$9YK`u>ޟ&y\L`;TO6p׷x9 `Jӓt+j6]N~f݃8bEhxaӗ,:5bWaؘ#&NMQÓYD7\g T#B EJϱzqf j1[i;G~_itlv/ͶB<[|P3ʓ擲&ψaʼ_Uu%)q\RA|(}Bjw~充&E>עoȳ!ZW! *3>5yGTFSy˲ 3(S,frq2kPeSO)~eBRIRn\+5A@ !׮2|Vsi<}ssJۻ3_2K!)+PT[w@SKuo̅aSZet —E&[f5k]}dxh$]r)<9%N} #0k`m8[!%j;D*GK}sjs)miT; ddk;,f<[|ꩰ*_ޠW)ڱ=O ^ οb!lǎhiI6 SͶD}PHcF8;`BL*X#Nim'vΓ BsZ:vF<`M61/U۽opCH( ū/`-]}im!:0Eb/Q}R:0*C|:.qc1!M 2&2,$I> nԨ{,Z>˾wlЬ '\5`7$ԡy g{ oUxpv<$  FھdZu$q)O3I L7)Z&r.5fVw;*&[FŇ M[;܉ZC9smq;{w#,E. SWM{zJXedO#ݛK1 n<{:'K|¼?!% lKɞyj%՝c}4"V{1&礓Wj*W;pɿeDc`oh,1 9!gZ6Qn;cǁuP촇@_8ƮQsnw@3rM&٨@qZ)y «Tdo0mׁg'#fT7pxafdꈍ?8%ֈd<~Y'mt4k.r+z3~r]f ܛ[溞 MYkOJj 4qwȿZ}[׎L̒Ysg^sovKǑ9쌾'ԏ '"*i8h21q| hEt^O_HFg*ْN p[_.`47HaT|=?7z+5AhJ g8[V{I }[8xQoM'ВXEΘxn@%֟ -vf{  O7š=eNǚHA0ZA63JFu"< 'k&r1[-OdkQU'҆4 n $M7tU;IuݎٛHD? Qlj]6tE3bVGK-j[i|6 au0ڹ_PA.IT)UF(Z@cF/XC"'xZFS=r*SCjO1D2yd*m󱈒}R;Z,Tfou/Ưtf>WOrmRRmxܠ){":ȩҰdS51 ̿u?쬄mk. ;K(%dp=wzUwc2"9M5o ͔%mveԳC>^\PAiO ȺUUza/d#QX!wIE|EMrMS$JvB޷/LѳmJ(礜R Vo4q'ׁ;8$8r |LjX1Y} endstream endobj 325 0 obj << /Length1 2036 /Length2 14358 /Length3 0 /Length 15584 /Filter /FlateDecode >> stream xڍP\ր!44n]@ x ,8wwd{>c-*2e5&S{c +3 @LA#+ J9&ގbN`˛Lf`ouXXXXl,,1w,M Y{;3[КXyyv؂,M@v- fob v..|@;3֙\nbP;Z(ln na/; xX\\LN5y_2`p̬ oY 21uyZڙ,m%IyfF/C? di2~3t@RDz98Y:83;[#0o,ag*fok sqF>qK'۹{}vv!3K;S0uujY:em&B#38YXXx`GWuOJֿo=z;;Z~An`+%VV lni'l/~'K.Xۄx1j"" b nJQQ{7'; doe`+cgfWo=^:R\0Ϡp}]M_Q_V$jc_?z-&m vj6W'z;sT_/_fciVw`bea?2~{|8*oJ ;{ӿ rry"''mMO1lgxk`f׍rq"E\(x@7 (@? -zˠ2(x2(!P2h Z%7|-鯻Y@?E?4/rN~;[7v,o5[ߊUmBުf_x}{CV9m?f}+|p[2 'oC tq[/qloxLsg:~ɀ`Y{!V?BZ3m LQmk1y/8>KZsI%A{-H}X.)Q0^uba~wۡHM{"&ugG@kFvYGW<;n)ҥm*.9ħIhzETƙ3xp.Lg7Sc G:l13^+l:xޢ{ɲsŅaQf Gjҡ!}@RԭXM*с}6<gV|gg `^kceԮkZ!9y^IڄWy6\Noqݹؘ|8hՂ,qVo%ƫ $aIplkb֡IТν0kȼi.x"&͊OfH1M-ÞLQc r U з<WE|%MDM|&dJOB ?)V)OY3ص;"/eq*SCh6)t:o,R4^ܫ^Ϸj)~womh)2jN*Ɏ;-"tacYp[iY1n>eJ{]iN^բ$f&h_|t!Sy:ʠ')lG4oQ/ %]-w`m>wͤ(#_&Mnh6#evڇWن)B٥~9>Fg6GJwIj T~_\9I@B;HCӬ: X`5X<2xAV8i3{a= 3lx*@[·$c9N N7u=mSV:G!MqiEd*~ꮷgJ5dD~tjno'{1 41 jJA82=i[m5(v!ORd[`ϦZ==*6t]amo$cN}z&A/䷒ A̤w-<^`( xYc{|kt|$~AFiJ~H *?tU?:^dl&,plw-qi;NI%GW=:e'ëBc1#<:{qp`q嫉O\M_y ,$: ?zƅ)ޥ%(5[Q ̉I{Q,MLY[\,dÄ|DuLD7I?kujl#1MSYdX}˾ѹ(* gx5mI*6RudH =6vΑ'ekEaZg3u82(9|4L֍Uա[uOi%=Pna/}n)TZ`{u}GI<+ ԺGazX 2ݩKH,]д uLo(gΜcq%Ȼ%>j.^bxDQCZ 8-E,,G"Qc8$јx4?*S\O]WzL%e&JI3' 椉ѿP!q臌/tW '0A `F-߲KCҤ-uPBN0 X XksWPRwMR!l} ~1U}ክR?Rym2տJ4x%ƥ`N8Eṟ*i2QQbnjf Ve[fiHI*bZ֓f/cjU[>3Fe _~wՇǛd< wg=Ӯ*U@κ]2h=+/,UIHqy)gkq|CWױ V $p5C^?Im5 ɂT{P7y > k[9ǚZoۘ 9|h Ï `X#&~B( ERv'-TlY{.~Dn3DUQC:HD ;Fǖw9a+2RE?3@ҀknqO`T{2@ZVDxckInD(XHpßn)vp]ɜY'Z*H)ianQ{;X' $}f谶EWHVA7 O[׻NzR9g#f{ZBVO ;4R^H?dFQ)/g[[Ee; l!4l;F4H5VL#3{pÞcKKZJMMIqu?r TYY'vqE`s@k^;vjW!8L``m#i腔nʮ^kF2C Y?5wz\Hj)HY-6N\ڣXLwEj ¡ 1o9PyBga҈pA%ћk]#4 $'*^)B{=^ ['t dx-!وea߯8Q'Tf*bes7~[N5dUq͔͟ hSPN KZ#a5ɗcp/ șߑVWkE T'-(dW< %AM@`?(* nRwunöѵ%V )(fݜuc]6w 9${SzT .nZh3^y +yyS}}N}}鮢ˠ)qCt֎qJNLXUJVWڝb(nqkZ$~7Q\EY]9o~__)y[T&av-d0[iXX<ˊiH'oE2>! ,%u|qj*~qUj_+K=] HvN蒇z`Ao=#^x{Ew]2! 뼯1Q"5oiMjx]@E *f0'wlv+6L:`69~X^L;9mZؘZ&Ni2@Q~(,w!RWR?9.!^Kx, *ѳ@iWf:M32"'L㐸"Y6CDžd5EAy|IH,s rpS7Xd#h*ܡE0n|>ho#VtHzϗ2bd"`0 8: 7‰~ˆ…sCa Qpdv^,KoePʑ1ӕġ]L_r'Lإ)o@@nyF<34µ;!}`O&B"j<ͭ"ʘnGiPF?vpCʺI~3Ufr%Nۺ)?ck|-fCň'RfN}<~zl a@O4vrRZW/JWt\Ԝ̸g:wer\5=߱H BjFmŬS8nZ}S -fYGkY)"q YoV\ HM~['r|/pJ*_ge w8;ni5{حEVOY̺Bܠ6 & xwU50+ݜ>npF\Uo6y6+ΨkEk?dveP"fC,:wEwጜřJ'ol`k3`$!  .݀\4KNEmhTI_1k>YKV>`"( [&S,!\*Ÿ`hcZCy+i#V; JI/|'qCWM(娂\Rʏ9T Qfaz4 P"W@h(kN)DyN r>0;fYГV+*= )^Ak{=J9~f'h̳8V rgMI )%|U/›p8_]x7|M)60Q;;s*3>('S2o+cyU6TJmB6y3\h" !'Z> .gÐ6"uC(vHt7sm;EfV" ~0Q&Eތ XqzmAYvW8Yib59J?- x<\pN4wv<]f3wE;XzcY\i}/49e"uC#d@'qi^9 [ $ $Gs*-z4|\Τ|lv~B,EsgI؉*Cy}.1u^dJ%d\H7N)w8zwwq*Ė/5na7ے{eQ+>2}/9ިMh;)CEidD#JQCLcy `7fQ. ~Vv><1ױY:Y.{ DM4*YD)Ǻ .Kq(!q0W8ea'P5U?5 /sJ'sY5]_u90/n͚aG*>3h\w|b*fnFiO/m^~͸H]ևbXfEoir[|߼pU*Vd&8[F7=ld ^W?༕7|Eu>JЖWdDYԱ KՅ"k~%lag%wH)Tr6DT\AIV:@#(a[O>b"cLZ ێny!i/QUk UVZ7WP7I0U6y1@>SuSMQ:kĢ~q69m4 f &ji7UE|N; Fwz,JpU|"GFOvoAX?aNNޕoJtkpt)O54L@gF=Ak;XSbAPSz!-ɣ屿ec>J.fu{36M X/Na9a+mM}jvث7SLTf?SGfC7ރmI:܎?Ͳ]xw^~͟l" [QO`W%ȧU2\m|mzgnE5z'4zum;.֯CIcd5 ~J%T`/ YIa-ab%{X>2ЊÂczXfDsZ]?Po--pBN'>݀OetʆÌu?j!2{ս8sӅf ꯓPd` pĉ~2x WԌ쑌'jDo,wJ.rP29Hdl]JQŢ6q^! h!nR,<\9P<2K$<> i'Re/i դ涃Ug(Q5uIa;x!{,O3r>8[жN89/QUӿmlrը#7/SeyacMZVN DՏHdg&\dbyEʍ}}M&ޑ^y|9Ch=nX*HCo]$Yci?J`DZyLt*4^{NB j!1$U`#V9:  HoTQ!ʶxW*QxIZ UU^Ol/Y}Rh5 ơT$V̇osVJ~Rh `θ˞آUQP48nL7w]Bkv謿~ځt(Ŀv#yGf5][cbz %_TP ~"RL߅`~:J]gxY,z'F5]2tpJ[Yڳ|<$EAkHX C^~C[!}3X"BX[LJg?z=.ھDm`AeI|Mh??}(Bdg<xO@T<MԦ0ކђ`,u#:Y\ynmuuZEݹX=`u͊ ò4I[wXiU$%"u4Ö+[;8(RǷ'n3Uz{9u1lWMa[eВG?>Ãe,e`*x;NÛҀ5]N k0yj0]< H}Q^34 AgŌ' [u8`{Nx%3s_d֞ݷ5 govH|'"5.E1~c;z!$g/&Sfc?׋qkB.%(__B[u;Oxm)Io~M PulifF)yג̹?Ǡ;:!a>ʕ.*5S{TTC:-K YGOxٶ T! KM&L&+L<,h%{#֦e Euař$A 94 pYZw f~7R ( XB #4e };}%͢DٚΦȽm_W$0dhbKCxW!QL1BT04X;z'=!DxQQQy subҵ<=)M|&'ةX5XWpwΪUyPQq.%<"@9ąߚ26,9FI$t,FP8~x,I͈XBbOlݢzU LU"tcFTm?B@}ulj 2{㼪5'^-%d6P>e`}?c.-3"b\u(m*_oVY~a?8sI{uw4nRmuad \tI^3/lӎ1 6>Lu /~޾CvI)^KI9eX.A?|@#8 R!| ]{${Ovok4nf(>LǛ臡d/!PjdQ\(q-nMϬn;;eU4pl\gAіcv-L驒ߛ"҉'tmnF]:5{QS-! ݬOwD+p]ׂ%Xz,b%@U׍,R΀FΰLa PIkPg}ԕnc0W0N3e>\0wk[@(0VX;Iv wʄ uc/PU #ԉzha~fQJl}lw@/;dW /#!~6[f5x%+'H<')Oʷ@-$gbmyAǏgNcq)lqQm"8ŏySV<4X> E~I@wNZ@+pY%ڎ%f@8} rf56iFx ۭ(\Vyq[ Tycp!n ڒ\Z??bH-iǝ̏(s8z7F쇽jt\R7Ⱦs19}i'~WLd]~)}צ>X~vIyq>J%!* /KlnIkGVEa[$z۬ÆI0~5棜_K>FVqK?w$c b"hLYjq3j0;E cRw,RqtCbd:B&偢! zVS*г6z/^,͐ڸu) 4ƜӦ5VI,S芃[ %Ȁ[kA'E5o ӱ`vONϬpUIuyX0 FGq܍~(w#NJ ?.ؗZ^i(fϚ;*25ZNȑEIUh\ĤGNVH3ZUlT.jd ƆrYJxh5޴-P3md{J"$a͚'|q~mM(_)\_cw/ʔ:3pY?QS49(yi-(?qv+;\fT}S)gep̬J)V)-L4,RvstU?\[)O]i5TxQzW)h+E8m8S9gҧ$>35c7ctKbuIuSCs7#J%.>IrL`1OOmĽP='4')s4ј- $C>Д=c}{xCȨB5=u;~6R@mL*{|6c{qr t ,Q;}.<٦ E=yWQVzNF=_kٳV+ Vx;F?}# k7~uSJrзS:O p7hĞ^ lhZ| Rf+}V|Z"өl#vZLD"G^dae|ѬQa0W )4;mgJNC#5((G QMh'% ?/?T]* -~$8_r]@P$<EYF}т-~yq|i}\4_CI|ѫ8"c*Qnmy?h=zgSӅ@:u?0<榇>S$DX:?Q$XIyAMd 2 FJ6-(V ਩_]p=> stream xڌP\- !'qwwwXpw;A\_=ɾWWT5=k5)2!Pڑ ,```c``'%U1wG Ow0@h8dmRNFf##; m"Y:5TD?_FFNNvV@{s#k hd` P12:+-= )% t; 3S<)@=X@N@{,)Zc, ?017 dn)stuXeh``7p6040@LP`*?9ٛ::9[U"_a@]6Z;:=v7&?"lU휀"1LVvNft52+-o%_bP^6P@/s 3hSo067rMͭG&`]Z c0o:2tm|%dD:!!W- גx;WO6OY%߱l@[ P^rmV#E-NHo5?ur :🣕;YoM-Fs1sW?\+4*8XЂFt2zt8Vot961ĘXn!+t@׿@Ogmr5Q6V_^7b Fz߈@/_h3#fo@HF\d~#P.((Įؕ#obW@j]7iqt(3 C{/@л Ph"VP0#Kn/o¿*/F&7h pu70¿!+_7'_m`A ~PQ@AM:jGin rzP69K *pY#hY@Yۂx6jAbsqZ,̜[#iYAN@+_6@? z-7P,I*ӂf?2G?@19Ay o? (.Ɂ"34ǿjKo h8gchQv_%B;;McѾLee`pʶ(ōqsLHKb^n+$Dޱ`m?.狝fN),;' 9h.}⮵%ˣs{l%?i#U# gH gi`P/\fnnQ3'bN"=47fWTI5 nPG<>{ ,6d"$"0V+[7V;.v0d%qv⪋1*[:LVnպM,p8־f5̎}=VGhZG qM]DʹVRJu%ёi8 xغ--8Q{(w Taڡ ,.n{ΐTEșЪ1I]q{مDR<Q_'sQgA$WM/SM=4(ҴebFOB8*9`?Ƕ LmxXk5Y#!,c}S~RD5-V OF!aڙO$yik2osq[M5k7Vke\oPF}5:@ %GNTBS`& F!Gx TIW#,5&XFOmwxvNb'W8}yS"1hKP7?E$)}t|FbO7CƇaC_Tal}_ǘzYPZ 8\xXg~:NK-!!r%77yK;12? A`I8LM{ݺaϽzj۝jȳ8jITV>c bX+z`(v`[NJӾϴN!b潃OW!M"u4LMQ|D TXSH<mC4yp/<ôZR cYm .p'Xly2&RxJ;Qd'o2>,5䬐6Vҩ7u\xL#JwdQ}O*.q{m$YrMyKsLv2?+qlw#xO b5mHN&}I;1\66tlJzz/f?Ġ?r3~]H4-rcZZ!bX*_OWUfqaPI>=yȣ>|gq6€2/""=9hT .+Z1$eXEr ӗGorӛnN ʔͅ&H,$CSyƊV"!~n] e3t,l8w@X>;z _}=md榓Q_qcvd|Ku 3`. de'5_V Z'"|P-KJz* jBB^j Wͱi ϕP10["!Je |]! ?|uUv}]`cy-0BPnG6O SتczUcT%;Ѳԃ%p~̘jj mcQ+36i88JNzL3yy76U tEYRXVt/,\%l:(M`jPʹeT8ur`j=JPk98ge~|8nYW4#|aƧax>wALfpx7+,UGFAtZ, L.F39',3\њU~dB|Rnjv[<WlT-qxUVъ8 TLD͋C_ |hSg+Nt϶q_M۴VgB 1|wGFUgs89HZZDֻ/L{c%:_u#$. q~%n.f|s,1 +"2.]5͝u4g'H!+{c3<y-g ;a-¡^<QXT?H0l}C1n\,Fok %[;3s۝\|ɐ`|#I4]< 2&bKw=&sՠyN÷]"L1^*1TU}jxmń1s]9^~@^2J\4{t%,R܉}~M?کЫz}~݂F5hɯ׈i逮Y$z>pMEq$ GܝĴ."J>,q؇3= *}f֓ d1`)k~LyHկ/_~I5\><՗Ձ]6SoxEu:Y_iafNfo%v搀3Zs*n&P#mPX ,f9Gk C S$Sڷ3d2&vV_ga Ů4*8H8uB*(Ü-znՋet ,;]k5ҹjXe +!Ζ`ТZˑq|-6 ώEq}Jv?7@K#:J敷 -j^ ,Xc'"]X"v?o; A Z''Ca-{g`DsGWMI ]W*c,;mc?LSv7?_Gr(cmq8Bw- `oXV{U<E";Ž0c>ا$x>~;] wLc̥RK# $-a]z+[9Vivp`'ešADbft%SWg~u4*`GF $nt&4Qhe S*⨤24t هQ-` ]oeW7Vx$7>'d$dG 0 V)Oi1|"!9+{t=|Ks_*,+yR(MvSs%%yޠb `h~bj%  ڶ.3s]/ 'd_nқx1'(&/ND)'7u!|[ؤW;3Oj16H(q./;<E}R3~%Ogdi\،ߏ5'PGU@\9V:\AY/-zQX𡥍:x,U4=Xc!Ų>;g rIˬjݺih~ f_ Rmߗs8_%Jp72fv&|YՙMĹ:JSEg%q!ԷLQ;Sx+s: ݼsJ&V=u^Gt!F+̋Ux ]*v9|{^B`囟D˗&%ԛgrA+:T1EKg,8̜7sµV Nz0OH3[,_˭CDlLJL9Huet6KrB BH۝ 1k;^ODհG>劎\2ƇQʇX :?-FNbP7b55S)ҧ"]ldt8A>@kk8`@$E[2LadQ~ID7VH2M4ΫzKE` ӽOe's+u)Kl8gnSO٨CaZa?;FE3r{\>uCv31e1R?,㊴wkLJJK~b_ #|M2SdCO|"Ĝa_b1^G6 M:3l" Uܧ~D}s˚JETR6ݐ g&o,E)c9W)ݓv2@盛NPJ񮥨\C$XEa X)'jłϢ'CtG]DTR4+aq-~. H. lnE]BI%asQxB&el?lG죱 >Fkކ.}S]]/-YD?RÃ&~{H{; jJj%l[(|&pTMDj33T}!wscˆۤocT?=jzӝ yGpa{SN'q K ӇyZܵX^!I|Ş_UWU,'[yX;sTiaRBc%Ǝ0m0l̼Nʐ׭LT0K&R-=3Mѓ*AA[@<0G#XN1Uk^l:xO1֫Ul唴 m^J6? '~/P"M2:JLݤލՄ @<~e\Bp[A;(R.XFYȂp.3-La2DL0L_:,[%sBzgiRq~x$9gSHKЉ8*My xЂiR0%UU k9!p5[_I\P("bږ>H5޸uHXtgG[2n"vVl/"u9ELPHMv>7>eԇk%0q1%F*ȝvPiY؅gAhCY^{,t_ &+WY;7NϼxGVps_ѷjR04ޅo;q?~ٞ"kGͭX_<Y?oxײH˷.clN.ʘ~Bm#NsiyWŚxycqxjψdeߘЧg"M >W^ډCSמk?J q$V&Q-JtZG[CM vCP/ͩ"b͸ j"9NJFKj>f䉚;SVʬDz–uDDnJB!/TEc"(ˎ lxb!m8iTR ^] y."hˡdƸlTԓID[}1ZG.&%3ۦj[Աk[ѝqU*Ӑbj1lmFF5 soN!j7VX`̣KV Vnԧ-Sf૏GMJ u B')@1+=@R%sb%3SͭDggF찰.lTݮNvDWS(3wVTIבnl3e5\1Q̣)/D:rnVi#pS q}-G8u,< 2҄]P? CH̪YxBTSƾk.LT`)> &!Wp&؅@)CAv_ʹ*X'\*eLVD)B]m*W+*`C)ZܳıEMg>·'fJ;gM[8P^Mӑ,]:!Ǐɨ2lv±ʦŝ۲6)f͎7Rh3wvx`V:9Wu\İe\ul/W*oW|/F߅Ъ/4 *R8OSl|!{hSr9dYR!2y9KWX/Tg@\HF<3ǣȚќ(`]q @`>{de^W_؀Ԙ釶i]ԁ*_y4/Fd;a>]wsq{-cz1[\ gD㤔qR+'뻩Ox|iLXꕭx"]_F?ϳ<>{k(;UutEA)'˥^ӪbȭAi+-OA\3p W#/J5}oiEHf3$'*h3jƳ"sW~p.| 39䀋|F !ݕ~2]H64F/?,Ubwӑq1ѹnւI /rvagҢOUw[#AuϩGPKݰ$ysO x5Sy>7|sЊ@2fj%4,zbm~ER5Xe|сߠShgf m-Ǫ#O_?\IWrwxJE33XMw]pcZ=l@Tp$}%O)^#"EZr}:nE@d6ԈP/ F/A"'j2II+gFFk}0 ׯ)[<_L{=nQ DREnK(F5D5UKMSXFEjPц)>je;BmO Gxsf0cTW_iw](HNq{%CgyޭTB`Ņϕɭ ,PP_Sm.>BGs}vȦ`s/f'<Π'k設R.$<_(*J < ~ּ?Bb,l-\S{@iPW&x@fzl`O󒨬'MQDQ'āT8s#rwt=QZLU[9~͏"e0B9gF]am0V{>KEC #jɷKz1u8 l}D^mѬ'bGy"OBD|Q'K*dloOQhr_7+y߅gy"*gߥ,S|d;,\7XðLŹypQ'vB! DmvZsZ/~uѯƩf<7G]gZJG _yc%wNǝZtBj*QjsLpJT_xl}]#"3־A2O $UC!og?[۞5DmTz%dy+3 u- .#yv:K:VÜBr&0.9Y=Ʌ:%^ބ >:EPڭb\haWoܫV8黏cR<6dpaȿr4L:^n< LXæˉseN> Po|q3q.v>ڙe2(Ih-#[8O^e2/3 Xn4甽6g<ک#qvEijdg7Uxbź_Tq$[p1:t?M8Gb3}϶QۓLCwWW{7O.mel=dg oy߷|.hP>[bw[3eEp<+[Q!Qu6,X dъc{+nC¸XܡtW2w;[nrX6"dW`x>e) ²ox1Ú[*״_B帞3h*cI0m8wg)F僛9[k`Y@*^\ Mb'6>R̕"/*UZi>O H , VZQzT7!21 sr3hmגּD1"Pc_PZbč%)3B1bhQ1|DBTԉ~޾o7O+FΚ!C(wQ,Aߘ"E3"㻀Sq5CO:}>*eCVcK~͸GH6w p#mWf3ݐ^9,b lšCd1)bH*CkԚsp;XT,!Pw$DGGp|}dhHSdFϧӣiІ+{g^E\8웱#*a0va#2KQX\;JqT @+)FrΞ ^"ƮO2m}T 2XRZYC{+ f u5fx(P#עKpVq4\X'^f2*ıEx1CBR`DHw?dR'rGݑrm\qw8Am4/c=`ݟ$#VfQ ZOH][ u<?XhN=>6<՘VT(w* uEl4'E^;?X`&q- ~zbHUvU`s ^U#tU$;<薬+Aw k~q0NQhUkk#rTs-*ڤEF<\PyD ԯ‘1.|scgk90>#`_-f BpশY~A@}M^>E{6rpw>A;iOf? Ƥ!%}X$ ZT#O"zN&KQ22^kI+tDv-~"ZFN-c+XYoX,SaAtdWKǷ33(8/yyvA;Z-<7y.(5Ꮎ!8M=qY=,UV i;*↻Ԋ%ۓalz*Ď~1.L'OڢXF2v@ڑlB.Qny魯lӤřiJ;闾6kZHW;_J|r<U4X,"QePʓo Zr Hz^=;3MLJqw6>sխT5:X4;2MΚaS|Ɉew` h؈!FB' N0lWf udypE~\u,LX]a5gǦ%%~6]1ᒋs07g#d1d-Stb^bõ*T󵈖t&udY*zL1n k΃A6f&ZD}/>ߋ_y1,:% U%E1lbOj ƫU=. 8B1%ʂ)#)z&Ъ{B-/?P ۿ#C|-Lj|A$ F lݵa+-mDʞG.9ҹYT/ f]&R A3`u0^){,^"Ad}Rτ%2c+/!Tnnޯ&`d ¾;Īs /H7RFGl^XGi3u *$WQ5Xe"oSit>渟;}X酳uK>%ru3ɔwn~VjN#o"W~V" rfO9,-c?#3gAVWlt1ѵOɯ͸mW{UIF5h8u< N}IDk$S$2nXS+E>u jbܳN}@̙,zXWm0 )>Eϴq-~阣DUf_=2yWM}Uq/=a'Y ?(,y(,#KN`$uQAI9.>G6[g>QBv)u06G %g[85̓L} \<rN͌6p OHcnAYw;y;mZ~d0ٱ \(/%іΛ Fsx0 5 &1pɲOdc }{OM^ѤI€8XqjDEtDϚR͟W'2%ac(!oL9YD'EC2~ Y I]T;X}ep Oa҈|]O|jH^X!ƥuO۫/!JxܖMN̸ ELͅ~}v`Da@CdLIZcPC=14PT>X[n~y4YiWژ9 ENk"cݸŕٸQφS;S6qە!*^~^!me, l| YNrDY2>Pn}(#g[s2||m&" aPzܲU`+S͟~.p~I_7] *R4AGP68 ΁ T9⹆рg&w'$+"9%YU87'3&-v};x0΂F]fczuW~ BOm7?%t|/DQ8i2"۶E}^x3}*?҃gbԭ BU PŐjy@! xR ]n)t:~aQsAvl8s Ve`7Qei-S ;'>*-lbK6Dh4!/_6U*, Jb.i_ kU_5]>7|?7k=g4}J'QO3-_͕YbI9C%9ГR,ٝgڗG{Q,)UG\'ʔeBCv-QmF}4i-j |`ڧ'5KL#< 8>k [:b_9TBSFd4L0!jo6&֯Fu?/um-^+؞,g)->}y(! ^bop.x1rkV~`@7m[eM%(O^OδYJqQR1`O#Pt/wfz_{6R0u[Bl+{;-D[h+ iv}@,PE+ˑ0+cMg]٩%|2gJWM:4hNXNߐgH{#"u\xPIaW*Ĵ 7Ͳ&z_%U6[M/f%F.V:ؾB6=0.p,JOY|pR~9 H?ZNK':ͿҐ- ~KKr1#Bkk;R)pœX$y!:#ô=}718_Ed!}q[۲fܔmntQ ]Bim#g0J}Y#@q値"dLD,/GCáӰFTnѭhQH@Nki$}i:8G <,%A։][ݚoEG ׁ(9*8-d>ݛIcE;l7_l4 x+x\a)o86cY뜻~DlT~ V*@~;\ 2Cx"7V%_c3h;On^#*BpZ %&MpRڬ߽͛L $ҨvQgOl٩r%r}CGQNpM:ef-;YsaH]\o@31/Fօ1>/ }h6j2XbWv6s)My3<0S[˛#݆F[0WW >8ߖ9V7tPFhd;bmH&fg1D]"n]W[C 5m&,K]k?Ezy& p46 4@Uh1hhfu*SěNֱPW+&% ,lWDQ*g{o 4v#:i8a mhyTo*wZ$v͢H̔ʢso1濅dD*XhF/z3C7q[n̄?*o+Bby)T~tN*+LM,1U0SVʅIj! KTf U;V.$&KQ\B;:#{ gA77|l`7VC@ZN? 9u=ufI D=?ōT^ 28߭uڰOQ}?i K'OylX:ŇW$l(u ӈL0ʍk~(*%ic??76ۢw3큇,>3?@ j2! {3 (yϛC 0jlU6i8g &P 44C`d6c61%|B"|pJ-)a(eڋE ˳I{KʼJ3)Zkhm \Af&9[׏n~s5Xp6]kB) .0}Քj^vRXGQ t7ЧW+=Rr EYҖ/o?v+:uO`-+G7)Nv/'$(J~dV&4ގ{~9p N#ܳ=hhL\hE[bBu\8H$f?$H%xj0vnSW:-7b` ;t gG9&zz`:hGok3#Nu=i"oSHǜ;+*R].(*ࣜR/6R'AO.BN\ lԑ-F5{|G@~.e<*5ƕcUi/VPٽ |/XZ *L*55@OiaD҇ub ljS ;"Q0Ib9P, q;&Nzڪ6:N3 g+u7(tͿwr >16ؽ<_hMTV*2A7?5m|9TB}å7.RwDaWsbqPTf{[J:TYy%H̑&X73CP7Pj={%Ο?Oa j1lIȇr 5xْo06s&DʈD%c->i:pS9Ei~!.V=b}oq+9MfԴee!(F\=(9}@m ~o0?g?+ ԕۨ'Jx N@eZ~s3hP I:>7.sUǜr~|Qޜ$Ӽm=`ce{z@V'ĉ8=zh D !RX+rr~2p__:vkpTXnSGyC(nX;)J|Dp\44@f3OW tWD{I+z;𰌠|]C("z{X!~1'q> ͧ%[_,}O%+m6PGH)u0UX{\=b-H531˱C.0N;D6dzޖQoW&͑2mB*0#x@䅜CF}kO&wzSMtsOwHk> دJWɖEҕφ B9IMA-0@Hl?AUD" NœeIlVW:spI6@n$@l@Bэ=4)=K!/JϕK#}%BN'HB_s:WۈXw|a 1JиD*qcs-K9WLzquӼX&;C٫X&;Aj/|W@*ѐHYm#Ż0#8#Ƿ=VybN8IcU`xچ;4iW5Oƪr 9ΘBck+=hnXdϳdwʜV&VeZP^yOi-pW.i>+2vya[?*c\=Z˂(<~!A{5LPmYȁO._dv2^\ɥ-ҧK@"fyxT` hqT*rxvJn_;T(U4iM>h<褙C:Zlsu,w`{ ]N B}0sUEgQ\^ʼ=\iVh?xgb,hwDE }yK S d8bm%Fv%g)Gnz# WEҊ).~yHektCBo缭_Pk\wxcwpǛH,sǗFLmSeNp~KD9IfqOUmytjB ep1 bBNJ!9Ks: Cߏ"aR%чpQFyVL|y?4Eݽ"WnSOFC@( /̕cAXQ[{ N'1"_c@ əfm8򡰧c9ы ;U`B7b˼̈́aʙACKTtMGSdVViGYӰd]D0*p4ϤO}~se~2/+!|v̪ѓ,(B.w5A@f@.{c,?D00<7'm}ѫ1 xFu`z|Vwy ^|65LnBr;UX4CUi03֪ D!k2 vwyET11$t#8a2oEqKodpoEO\HE4oxB4GRUU DLr(l4E6:b&ՆPF:7qsk?Ǐk|z Ͽr |;:i qFTw!:i[ܡn<@Yx" ) FN|#gz+G>dV3S+֯z($_hx~-DЉd`ư"*=nHvح4OJd 3oYcI݃~4dlP!sT iU"idI6 líޗO | q=edMޮf|t-K)|׻A6fWK|-JRo;=V;W{!Š.Yr5eX)3վ}Ԃ#8) tIm!X_NCohr G(U%'_yuz(j 4 ʡ(}Ae,6$֬HMY 6=hL^>͕rq!Ntќ헓~zP[qPMTcSW\ϑndg320)JXh)).sʮ"qP!8XKF^U{XO2'+0|l2]U&5͵{+2 pd`h'HLN\fz"2qv6z/LПL5`\w[fm8gEtKLF&d,wsІ\'ER!z톣{0Jud @i+;G'p'.<5g}ek~R}UoCť _IFݘɼT@:0|9f@r8HAllK@$Qǒtz)yKIǐ/Y8j>_ S^j8ᯩ%$Ӣ q@洓&ce(̾UԟAT.BR2ʜ k/ݽϰn78 ^AX ,]j=`&MUȆ12@{l_+. +$ ϸD5=]nmD<*}@K_d2J [^+$T&-<y UO+Eb=@}/_q_JЬmp#OF4F4ȸJQIH p=yR݄e1|{n] 9&9K"t·fP08zH-YK9p#%N,t{eRm2qPѬR4O%ܳ9y[zpr%G 7]`=Tl5wzޓ\͞r W[ҥ[p;XS'qIYj#Qͱ*sZ)c4ȁ8pH6QUSK 8Uhef%6õv0qBtu5Gp5} *e;xXCD˛ͽjdw!)n #@vs_IbX^'5 fKe=٘+,}5l]4&WNOC9DϑQ%:#,C6-y=pٔtCE g 0cTr?WT6|mנF}},sh^ȍؕ$5O{UC9` cydi\ *+R-0LVwcF/=Wz処6JIvͪ6?{7*).:=}> AXג.%͚G&-2>p'b>0•[DH^¸U#'R/eյ#]{Yqk8XlDy=[#E-UzRI0lQw$(N.mW[o XR&;N(k:~ന@lCNAETe#yxڳ@>p,Rx Wfj )fC݊)mt0 ΔH8y`1'xi<7>yW$$G0YwdpMrvn CX%%5=lnbBά+|tC/ð:"P6?[Fn7e72@ae-e (H ѥ*sTe4gŗSY8߭+vcWmR=ez8RiS##0\uDt/e"ς/NF=<&B)B.-zb |b,Fb պS|=> stream xڍT6L#-2 % J C 0 !% %݈t‡{ι5k엁VKChVp9x8E<nܼ =/5&>q@ur@#jyrs &A@uN# X/ْ#,,;@ Xu hqYwrww:p:¬%X @A 4?;d@\8Z݁00QaC]=\ 0 tC4VӀl<<w g Z `'BA .@7 hhG@KsA..-r8ey(H `O[>ݓAݡ V(w W'.=(,ɣ 5`Ku=<Տz;9:B?.@70szo X`kj՟a+GgH/#?˥lgc22o|^~@QUj)`m;#i8w W{?`? t{eYW#?oV :/ >ށ41B\ `ni'Y>2{8x{,KǗ呑@PKG a0'&#x<{a'xl`Q~oࣤ$[p- ?bK||cw _" X*ן@17q9`^?c:G9 ǒa$xLww؟ۿ{?k0hCmIxYv+>jR;>}쐛;T]prn{=jJGBf_T b,ҋ|P8͐c Aoj0kF% {ԋo5ۯ^e.ȗ#2{Uf Va#_IGy5o`g "\"W[ i2NTV=-\5!X]wY^{$56$I4PjĬZFܰm끟Qd+,뛄q婛7?Ը/-y *OxMo\X;w쌺(LZبޑfP^ 7SRF=O^ k̤f%r&&q^Ƀtey| %FQWR/"r+*a!磟ΏM88Kud535cՎrLzE U[XQ}0{ %3?ې$mM=׼g2?|4Һ7l"J ѯBعR<qzy#p$]I5rc۷Om#ϧY^L:JTzfԞ9` sgv 87Րsk[m0>>ʏ'J.A%dQl1֔s1f. ֮U=klp8YZ,Lw1NV36xd?ѣ (OK_j>O+$L7YR9A>bw' .uKLa$MC5fIg wxD$,>, f4AGcȝw:ܔvml"xGr ޺p,ft-R4s6 G%HW_}m S(L$O׫ \ Ů)Vl]p!/OJgeS%3V:%s,4U/Zkq^x/T(rKē&,3""@k5BDIpi֑Jiygaz{CEo&mP_aίɊ}Fcwaߦ?Єp2[AMH(-#PqI 2OE~3O%[9,#h|M@?›LH!EJKs6Nq#(y S&GۨoHřr"Ɂ 19SY|Ns `g16xvR:f#4h# R- ٍ>KbU-L1;VJѤ%Fd%VOSh3z$ O}FYF!Eiqj`yEXJtk$ q'0*#)uhD똁9$%K! wmX%aGQf_ z痮)3(t//"(m'gxKj1l' "\#RowIHJU0qdߍ җV)`Hǽ&U~Hq."GP}Zq~K l)>LVP-ixGЗNѾTRuF& ]liwkqf$L)X2cn`(6מx,_]Z*U:R6}ɠKDC嗒SN[ /;BxTl4{ASp;Bd 8~pwDgMqb㼲7Ά=SŌI-ϟ{2R)Һ]9V*pOzIsC,+$z4T7+鿧$ z J¶Sw+ 2| Th{:˫/C1LsdΔ_?#ǘִ04,lJ)aSt:Й 7u7&f|ԟ|Ur*A3+ 샿(X W7M,~(G* =NP]KփDK6XriteT"Ark|]˩ga4:>z֌6 xao'LJ5ĵG.y5_B QUtF>egOES4< n|$)}mk&/I)<#uꛕVyA$# bG8+Xbn~ĆJnXgSdPkDBxo)=bF̦k1=-}X{:RhXʫ͏r̽"?y`c~&; kw++Qg/dF6FPȮ󨌕FVuJmrasr+Z u21%x;ҏ\ tj,mH |VZ+XԉH e6z\x$G^27;WYz W %<'d}%$4s7.7i̋<ܝ[.)ah׮;dU.y8adTYW;P6G:^Hwt}9t-S+$,Pi澼"Lsx}]ᦵBXss[ʄ!F&y{ުM}#Pbh&+xƷA*lf܀qجUZ2XYjLʱSK=Ȗ:Tַ÷Tm!9GiϣZ1 t_` ٲ9fLXοfX f鳱ySsD6MʄS"C(Ss1#>ΛԜS=-߸}&յ9#*Ev|z%ϘЦ)S'46uGq-f*b5?UGlggoV!ڋB{P¤$9hٞSxȩol k%*/Lt}z'\S #tvūbϡT˔o'o{zH(dqYܫqS^BjByIBx(W=ݍ\4,`TV-VEHf}Z$RjFV+bƮKg҈!Q w–V6Jn]ևG"NG FyFODDC)"5r>Gq!Z#bm_ftt%I'K&Y3YXlf=%["٢3ùö9 .t6ӷ5{^VYnmjoVS+=2#q2t[Bntյtj<\gH|1y*2fC@ Ǭ} =~lZ! Q$#k%AGzPk":C,9$ Xvw_R/}!ujNeV⧾bf$#)JF_H+t?K~)ЁT'Qi}sR 񢥍2j<4f*ҩ*ke}$P>UHiuXӹ溹Z9:r%\xJ}E&/Y=14Y~r_ u6TO݇(%FS{29QwvP j{k#Iew[#~OOkohǞM{N;;p 1iLD:𰥭X:Rǿ5>Ǽ?Zp=F5gt((58i l>v{P{kds46Xu'Esc|.jhǶW (Qy+mn@ىD0*k0| hpFM:`B5WTjs^kS3mJ}]ՍTd~kF4ɚ*VLf$!CʤtֹZmw'nTGiegfoDDA-_>|']x2͎IqQPIFe+N~ŕT*\K bwKpSvHU$o{!@h T$8%N9NtHpt~6CC źB?WҜfޘ`#aF@&s`AHu71}N(F/^,[(jxMxhi K_Ey ?=SM+Ds&K)1"qۛ+&$n95ڀf܇Jg _L}S&}~7+@(YʹW$p C; |OCS[ζ|LqbpַQ˔.fzޚw&!xts{<( WnTT(-Aj@k`AV-m3PF,r0Xi"4˧2VN+lLm}CÆ.rZQ-CKDb6٪ ݲkK$&Y2-H g4{dHpMwve c2zE]wJOR? oPi(`rFԆ}luXC %XĶ: 6mD|\δuh>pPS9ʌ_"P `*/I^Ô}%30Wexߠr\\a:_:."bH#u*gJ ߲yM7Qr솢8^x~5$KlK*La⢤]}EXH}9issBӇ[Kj T@bO:IZ[^$q&f$i.X) G)#7J`DyY3yڠ{ .,$כHU}Qn-_'RwtR٬54_3r?7%D&Y|H@@2;yhjD-paukU!6ҡIDr\ds q}"7f4`My +;:K7x puE>tvhn/AԪGr?Q 3-iT85hK.{b8bm.+vAy)EJ^eXDh!:}]w7x2=]~:*װnA(,ɐU9dU|NOt/FUWe:/[j&FN~-P=rnCnLy2lyLw#A76'[6N%AmxHv`gTJ~z1es[;cEXK~3|JBMؙώmQiV??s}rӚ<^󛩭ӻ|>, Ǧ4Yr(@әZ`7gt8=3گp]rM4jn Uܯ_Lhk.ڗlG6f0Erg/4CA WZ 6q\8mhW' Z48̞/V =w~QآWxjpSTJ݂oYfBxAݭޅ340~Zv\Bx-١wD#s$m[\D;5,gQᇅ3xާ][/UQO8\= Sv/6A b|? yml!C72 Қ(4e[?L 'y~e Zi[ 3TBIٻvv`z}:*9r|E.J5sjopGĹsT488;𖤌4#nډKU@VJ?>R܅[Ynn lڪ:btY}^)so򟵾7laQn §YzP(<3HwsIAwoF@/y+ݢǗ͙SOXK,~R֘Yr5E^P lW0zE5)aƱzDYSKgj3#rzF&yAq$d&I# qBS{Au$V%O*vDiBXUJk8Q~;fkφyQlO&DH%2nf/ VGTo( ѲJ7{>\Vr/J Ϲ9x|U(g.,t:{e|_A ;:Qfw+N^Y"-kC8KҕU*Ġ(7ǩч@{NMRq+7+wao9#3TQ61*vl7hWd@)lE؊\iP-#v̶`[!`Xb\Q\ l38Zۭo3Dr. Q Ll"!R.fYM^+ xAƐxG :JBTB3TŠ/H.#vwaPf,O2gI&K@!Eyt\)}G{S,'rM[Ʀu}:NϾ?B{bsp QU6;ah=vcw 3~$ l` ˼] c4HT3VQGY/'($[khMt/;D6c|} d^,]k##:ޫS0wNBϚS7\KMiW{e|hȂrQϳc9V[Uli;?.JWnYp'[ %[ 7oiZ?zgYnov< J~̡1<-N |ݬQ"j=J0kXKSP[o9BV:aL_RxS{˛ ž$o.HQ2;rJaKu>t2.6H%VD ʣ]CvqSq⇞7~Cst޾&{a&m:St`3.L1UyS ^kNuVL7$T4tvj-̓2Kv=fw*kIy&22;Ȃ >_r>7_o:nxE;'Xi endstream endobj 331 0 obj << /Length1 1598 /Length2 9190 /Length3 0 /Length 10232 /Filter /FlateDecode >> stream xڍP\.LpHp ݵ<@4@pINpdfUթskoj7*LPSWTcr0RQimAQ@N`(_ Ll\llw|l|vVVB@W9@ Pġ`K+4Кxypځf@@l{hC g A+`l sb:Z 1V5d0@ h3fT*O: < lf ӳ xNPU(ۃ +ik66f;3 jgx! -,Bm@W hlG@*_99흝[dyʒsq> #y,  X!0wgф\@^P{s t]@>^V7Bec͜ K0bş}gX?> eQVcubbPww *XqX@<t}&-@ XX͞Gq rCMځm=2x欋3[_SmП;2VKۿvUfVO%C@*P'[?2y9 8Rb5a\@GG*3ع^lϫhrfܞDY,RE"6?7hx,Y]Ͼ6 s(ȿs( ;_/_9˿s"?AfP3`Om5nL;3T;tL^.H)tفk)=["K^ZT[ԦvZQL0i|~p S*]ڭOڽXw/˧b4 Jf Ls":3"cc^\`M>%0p[g\`w"$#$M#U! yA. uA ю|7z$;(}"Tx=rw]in;Uh0,eˡTI&>mcsd,c.*-^nyBqwljedc/O..ޚʌpRa>&7 iB&QȿZc47&ޗ*nPlГnO6;~Qvci#MppU"~-trxC=w{Ii5ݶ@*j6(+3ˡE98A>e%\󓡢To#`vGt)F *"[,Z[Y5^G`.+z3dCk`ڌ'(e7}j5?¶]A֮r@ uj )YfH^2g{`0}RWH "0/.=H3Rfḡ5zAN7W2Lv|0qXTdaΜ*2$Qj n [4+T|]FxRƲn# "w⴫ Cek&oaMEM8L!VU~ [[*}C΢$bc>!THǑOvv!U V++$4*~ъœ41^E"Ignjy @W\<= -oěbWh:v Ax=Mצ[S$7ۂ@Q}R\&Ion_\MXJY3 ڦiѥ^yW_E/1hjm9=;a5ĀD8cUgA*xۚQ}&b9]%yCWU5ŇLGV=L/A)|Jwt ~yXq/5R<0wf_4]DƩrQ~%X2΄l֤jGM(qX<Msh!2FPwwS[=K3ct"UE4J[!T#gK! tt*iE+0g7nmٺڳ :@ ;-KTAΠ+n-ouђ=nG`?"5rn4X# _p/ZWt5R1AhhM^tb}V M\Z 3>(n!mgcnwoykV< Qz%TR"jDRt2֝ t(Nn'1vXMNU1$'J t/RYd;=JYbqnFZ>xXJ5q,W+>ۻKG+.B]J>sm7V(y** '-7kmdx'H_7t+!C+JPxƖ i wL_z7PI_ʙǔF4re ݠŪeS3߿3fW&򕆩u|H&[̃r~cm "PZuu<\MW WgM+h}ПILF ?ڒ ,U+N=0 P_ wXvR}I6`Uķ*O ;cIĝ4~To'e"cLc\!txe^2^t;'2|kIn:{$5²qo,Mw"q5=b(ی/~N<0D)ғ<ȧ '2"Boa*؁i7/=wa1g-^kͽFl^g+A ,\ NbG5|G߯STӭJl^or!^:ءX~KʴdT- z?DД&,\*ƶBZmθ8?e_A)b3m{liU.ɛL10^Vx1+}+klea7YP.x/Ǖ\ۢ_\[xPvZOG-za^PkŒ 2dO{:Y~W}Q 5rњcH]G[91ݥkL$⊖*D;YKU@ܽӣ9%ϴdnSxy99T&$78Lc&Lj ר?vc?i='? kڅD [Nm4Eɘ--MM ˕&Y dUS[bgUD^žGQvujJ=xo(_LE *1Uш-bAsbR](湝{nRsE#1kS҇lI|+[N. K6XՈx,Z/7W;*ުUr7x }AN7 whJ൴&yU[9ϰɎc/M1mH; ݲJWC`ٯ^ Gdva( !_\>76sgD擿>H@:jxq.$Vy.( iU[6ڤ]]uœVIv[L49 p/^B!zCk0:fc+q Qڅ~{UW~ iEcDF/\/]uӔsc=Y)$c#qu7ma 3|7bFHԩQ>HNS\H"#MHo]i V^ ̋LSBCB[yB9[g\4'zLLeHM)ɹSф61s<2ozxuKDNdE"*MQȰ'Ebez[b3ϻ_Ė.[ܑAddkqCsL34Dџx: vQQ-MO?(PV.L3:m=eaXS[&d+%Bďֺ{H1?%E~UU~ KJ:=|:tPjϫ(:{#Tz'bc)2 Up~U}Am4݊+T߮%52?YQ@?hw_f/T(Qьu;!_o b휨 o:@x|x]¤A͢>][M9\ ϗ#17&tEO,Pg |_@?s-U5sDgUO{D SO5Ee'b h?- #gѲglNe4tmbQ*H ؾ,|YWo9C@U4Q="a^f3"x,&X{8hH5oAr[/ᐼxXS>z g9H#kUů/U]ʋv# !LaSmh'˙ܜw2z#iUdK;EYw&O a.ot&*Χ\<'bglys~vnn'EV/y./5ıCKx2D뾧rzpt] %Y:-ilh'M ?u*cH) Z<ͭvxwrBnc|:qq0\vtψFFϢ1@xT_|PA=ŠFxi2RDqԜL *ĴU] 3\l; Qr W xQy|1AGzPDf TViL>7쭕Oh^&C "l7%/: NX˿R$礓ٟ'*=|Sq e]-B1⩂+Z 3`Xj;;}Ĥ@,xe,un<|>T@Ͱ⍌ȡdxe'y)+ݾJ=)ȗ&J0qO]˗z(B)F(}H ʥJ_I{T\1Jfo) !Yأjvdz$V `RTgi1ᨄ^t :?E6sCf3͆#Og~DGtyanI?Ks]љ댌dz\k3;i6\A.ڏO !:DgVYȝ;*NZ iJ|)6I e2 ~, ˹3pyq%/<GuhξXu拡AZq)ѥ8l%Rv~r tCʩy1m Q"䙮0ʣȗ9P )c)Kmpf"sf)ԡa3Qz":=LBc\qYn1cȭ)$Ge׶1"Lz/v0ƈ٩-PhIw5H([Տ eIs"""+V) k=YÿsP9T9 0:N{SY)sIrw)H>U#YE0-LzZg~K,rkke2Qh!ַ'n-]K@X q% a8QRxr¥p'U]HȐ"޴_sX$U{&z~[#ˤnuH,[ڦ}0 } p"AN}-yPKTb ެ[@1\p eHh.nRV6\F6ĻUתuU G['CqtypUacF}[k'+Oƞ& JlL\qi >©]8c')byàJS CD|DO?gl_ju4\e{FD- 6]ܭw:؎JxpV$ܿqQTJeCzQǵ`k꿴 _YQR}{1S!ىqע 5#{4ꍍ)Ay iBNwH$~'ssp#MUx1WWTnŶe"@:Q?yo+  @wC{|{_|06C4<0u~ X?3 *IK) )|P&iha[o 0| -{hE#-n"d1$tb_c΀ʚ,,b56M^_<齙JPEF gN'uS R5߽^ɯ20F_J>$LoLbw6,]6Q*TRſgWY=xrN:2RK ]*uPJThM^QP:z&/ 1Ւ~ UqpܗMc_(,CK>S o'Ua^WwI $Fu>;C*? Q?Lx~pܭoss}bӇO X8f'*6mF#RNz k"ħ֒O_T~7.W-k0Tv%ro1(k1aSF,eu[ލ*'1Ѹ,Ey/t[S#0M&{ZLCuGV}1̺[q)l_W: Rg[cO Y4+7xWD\{Trq.fI#~ۉj 5պݽ Tp )^']umKҜ+ YJߦ(O7K0 6qqů`t!y+Iv\u nr PЗB+}524̝W`+{WM9C&5zaȬJJ^ȵ7_|\Vmjjt%7IO';Td/Z}# pV I7ǤXz)W/_bh^(kD.x>FVЭl;ۧ U0>0Ԙݘq;Bn(技Xd}@ˆg>rՕU Xѭt翳=?" ix 3{5?NlJZ}JsJ߮>J,WY`uJ is$y*k "bH3{rY@ad.Mxt}|el.8^c}Q /,_NYw=w")}mh}ê,IZOo72UڎjZa d,8Kg< ,Xo^o)] ;'ir}tm5P>4gFgkc%<ҩyg#bڵar`k'o>\{W2 '7͹M9GXu{E&fE]K^K/6Xnk=?~a PfřH#Aе]oa|\6͓,èvuJ_AcocݷdYL#.WS N'h'GWi|dt!js'@ G^Q.Im/Z{4涇 *fZy7(!TiB뉰WEry)*pf˗)uD|6#"<542"ٱj~]{ʴQ~~p=K^0 m 7U2c[V{BWXI1#9O|ޘP$Gg>:Ć2<_Q &z/j+*.xqT/h Q#,YtьRF`~Ɯ;N"6h9*+Ta`^غ|]5n_8IƁUaD_R!F )-JҰ*'ʚ.IGPH|۸SIm*ZoBʻ!b̠;sf;T/'ySE6Ƕ8OڎI2_1}#wPg endstream endobj 333 0 obj << /Length1 1391 /Length2 6286 /Length3 0 /Length 7237 /Filter /FlateDecode >> stream xڍwTl?JH0atww0ƀ l8lt7HtAJKI4 H|S}s]q_slh¯waH~!4@EX$PJnAxB0Ы $S!1fzp@ $@Կ i*haOvuvAbnIIIv(CP0!]  7  %DzH =gyn>0xBGr wH.P? B@ <1^0G` 01п+=@04 pAH92y1 o 18da:O0PWL`*pww I+?U(t-{0 stU "s b@ PBR y.= B`L~pH !yCH$?HP0qH!NdP!-[po44125]Up_DC?eW HIӥ%Z n?c1& P | i_Qw>^nn\uC 6YW=#ZHf`nn"S8B`?TZ07( bzPB@0[v<>VA0K+``3b$¬#Aq` 8$)*H? q5 ,oj`{!L2?˄?l 8Wÿ6*7žf7:'#L ]A|WJ|EYDӥN[aT{˟vk/IiJvG|Tqy+nv6{#/I2bS7o+Eά׉^TN'ۄg/rțc!@#u"}V5v2/InHժpٴRg==ܓ[&873o=+]A˜&廦o|}LNZ+.~]3Ž9@4`Q{M zm&шW=UƼ@}wD(,M{Ph}}&z}^Q$+!tI`b>ްT` zz$%, { Z*lb5__i}}Y&_H$#aJ9ЪrgdVSe` (h Qz` CNk5%;>|:5idpy=&zD V>5fƤ(sJWj9~mcIyC,1z"F;Z(ИaăTvөݠ{Rl=VߨѶnHDE!\]Nΐ|<N0IP3c hP=wyfdfU@~ʗ9]N$ $Cj{PJ 6agྎŬ⼼-ӧyɍ ;iհ9[-$xHu@ M|Bs?|[pc/,`Cv(nšr2#[x}z'lI?7D:'oSYy L42 m~RzG% bd3]/ř s4b%oLtID w9ըA4B^ aEc82lw6>d9\/zoSݪ#wi-j,g)v$1)T+s k6OfZP) :ƽu1Arvl ]v$UG \]`X$ dԵpKZU7tqNve.l)g\^|]I7ϭcZ!ysuWNڑ[b|l>%Fo>SILLQk K[w:4qrIc=ppB;k`F x2͘O"e%$}cEͬ*&N|>äKCW#hшv*YK)T43Z{[$CWb}kb2.l(7 {vgpؾmk@ )\tsL}>eR]plf\aO'̛F1uP/;2ېƳ8rf\*^ s{<⤖"vn;΀}Ht`\;jǰTY5*8^ly1;|RؔcD:S_uRkSO&FoJaUk=B*k~!НG$,pW_zͱSoS/Jj댁msw .#L3,ʻ:ɵ5 ƙ/G|5Xbn'{9 n*2hw!dU~>JØ,yYT֖{|\pS#--Y^Wr>9e+լ] B IVC^[0iBv =hIu1IB 2}rFn3LflG3 a@RНQ0~wՊE/ޜ.~o tO^vj;1<~b[cMbkKtf;p _9_1Dtxx3~x7kjVkq9i:9Ycy+ϰ'NXʿفef>OZN`R[{_$*1rZY+1I1.vsaxLכ%+"%iKxzic>yYWRp%Ch}jLe; =}1P Ekex.&Ffګ>\Σl<,,9Dcs(XQV CLPءOw7?-j "YR>Ɉϕ5FF?,7Bj3U֮Nw,Cu jA  |*oS,cEӆ&e_o#mFԍU<*Mw  óɈ#4Rzk5kGk"I9{z K5k Qw^]s pMy֟ˬLߙgqfh1_;\sRc_b@Z~;_1cMd㋙R|ߞ(4^<+a^;aĬEyk٧֜6۲S٧R)gtb8f!dpќI^_Is 7\|9e!>[E0pRq;4o_n5oKf-H Z؜E{' Pࠃh^9rUx(}݇zR^`,V7%-Aɾ5fWkJykn02AHh^(u~ىfB~ɘҀMW^WcY"#d [cpU\I e fPsB?(#yo8G0ګnUBŬ5wsͬjG&^_0f$x}*j~l39S8󚑎oȀ(J>&J[MWqx7/{"sT+ssd<ǏqS=~pQpzɡr3!Nsxʹ[rAs#޵^poA{dӊ&jCЫhs r%KL~\xz;8]J\[9ʹೳ]'.bvoeS{2rY3jf?<^Hoh:Js/W6M^gN 5U:"'iez >$۽ SkA@;=̲=C7' 4eIEx7z<%W#ՇQIΥ]VBя#ס\)n\Ղzȿ-sJp,ۊ2B7t@a+uɰcRX h|" +S I^b/>:;753IbvMÔ^*U)]͹&}fPyp=7B^uA~]sBh./q5 2CL#P(5&t([*WHe\U^:ϕ-oVy7LH*B盔t dž+ۃGÓ[cOkxq9Ǿ/vu N&k>g]y!7* QTpW|@#d->`&şZ(F5Ju_-9K4I߇ VHۮ ?VRߺ,e44?$r+mw}XGa-xU2O*(℀k흁WDT /[[U߮6%'u9.|_(޻{"_arDaΚ%-d?Fb1weUĞ!>`=9T7\,nql\mMr|xpׇ<K Sn?$V)x$4RH.P-U\&xx~Fsêܠ_<@+gs/=DӆoY:ivUO "p ٍTWj7=RUh)5ZDvLTOٴԲﴮF\S,lE*Z}Q&} +r@>e-c- ա (tSZ~<<ؓUdll؞BRms8lgX4Q贇K=KwL_db~tzuSa+S ($=R}w3먥k*,ӍG=븺`TM mpq8g*T}0rM##*qeXwNgt_0":uoijCn 4) 9>3Xˮ=C4 匈7y]~Jcג&-)v_j `~3],e,GL_XfFpi{.$z^F9e9_? OY7r> stream xڍv4lۿFlڕĦ{׊$D̠F)JQ5UQvUFڻf[Ԭ/mys]Oxn)9hV" K`Qa0Xczs8F^b*7C>@("!"` *jQpo 3pqo B%p EXW8# 4Apl?Bʺb2 0-Ƹ XW1; ԇ" M]`3Gy|PNp 7DKh G1c 5@0py @v`h'@p0+~B=x/uN TW2BU7 z {#<~Ud5 ހ_"0pcuGP?ggW N> 3sc`0XR {0WЯJ/0 tƗF8?7b|TS@ @' t PGp?2~?O<-'4#濇 24]*ee?'$" !$(P_YrF$ҿk-x& X A4c( ;uZ_G E"<s_Z o%MDx#N,Uf /~`G*8~iy v]"@( Gā8~   X _^04~eq1 OeuGbR@P Gn0 O_gh{n/9RbZYHMb}NIS^daRz;h?/(Nq6_גoL6j: :O2^iL ]{7lSMTq5+<̝Vm\/)j|#5]eWV_HP}7 +s|:Ib'=8NoŋETx1s3[3S^Of+)-)F`2H.)HV!c%]9l\n' .n%g3I'W%bBnẕy0!?šϜZy# DaDNW B^gC<漁(m脊3Sv;% jەE2 چY>vw-!t3[oEH~S0y^!ɇѰ(â1dԱ m,DE)_='SQ+ԑ܅.?^rA$$|؎r{T N6%36?54Y)6pOjpp[vhˬkW+7C|أpSw~>ak7AXjϽAGJԄC#4efk1ƅacٟ9q ֏y )#ZyXփG&nM>+ ʭ3p5PFH>yp}ÿkKqtk)9W$2\hq+`x9>M.vpr @\K3Q$ˌF-\'SӀjH%%E:DWx0f2/]I3Hļ闏]˼s{FfFflEL1LuKF ug ԙcGVsVfM m4*ռ~jsmm[W"nQdLJuS|8 d+o '| ;i* S,m);Y"'y+C$v:D ?*qJhv-}E9ڭzMlIC EƩ@m67򖡊) R%@ڊPJ.5MΧM6UOg4retaؕYɢ?)Oȿߡ֘/~Q,poN18ufSp)l,{IE7,Xv1K1)G4b7406A%Ozt~ELI;ӕ0ʉ\v_@f 0·Yp3H:[0KNs&BWxzɂ1[s­4.DvidsTnw:f2:&<,<ՇNUcDts--ћʟDj$[5[_ouI(,lZr_㲲p6=D2Ǎb̍sW2_{iˈZsWlbk0u9'r961'>+ö2'©;a-t&K}1a]'k_*ǒg$͡޶B8mbVC56G;_v4!U$RlzK{W1.sgr{~F:Wq[ܗ[dQ 42Or(ycGv=Z'ge/q-8?'f(Ukm]q;2*2/8iC#,w7[#Ӕ&A[9i2 $C߂N s=OM-fNkZ{[fa_o ƌ -erkqq7o2*аoWuЃ`y_Գꝧ!%s=l[Rɜ p<;7vF\FlKh9eKhUkPއU!zCҍK{8.݀ۡf"i?5#O2AAgZNkY:t˪6beQq_JXZ2Q ?F \="%NVgTJS>| n`GHg!?:"hJ\\|׫* 3X{tv2J丱DtN<Çk/C*3[J"rm ;o9.!?Ղ(4SXb3춟DLSt!!7uE,g o?i/b֧:kP}OC ޥTK>7y@/ٿ^QeQ0Ħ$ނb'8%6w? vq\AI)oXc !ZSTD\vϨ 2-[p7Kz}|HGˆD?' Xp#..(v4 X*dGx<x5%̾:\bOAHjI?͊@S؅ dCDyFڷ~Y7K3QT) U׽TϚ+s8nCGlNV LKh2Aa6j V~%&qjޙb[wxg/nmW{++LԮ5WdO 횽Q@?X"FF9Xك:}_H>Qs$Zm"r ߙyFdkm yJ-G+s Р5HC%5oLwB!/@jCʪb}%>Ϗ?f/4 U?=%?MXZPr8*1Chǟbg.aiZnj$4_23Qn}4ZC ,>+1z5gB ^m$ԇv'FUR ڗ} R 4CtH{ #V;imcvf_Z&-'{фEQ%??P{:\ ⢏D!s7wU|nT㹪-A}׵Om,2e Xخ"FA'ﾜu@{T#pq$/-<+'P|6@Be{o_|ژLc3?3~x(q$pF~qw[}x[-2/J n]? zs`_RZc?kFs;z~|%kxM*T;c‹!⾼އwݒjLy N)I#Q:'&5h ".Ua_KZ相Ny:vfcȵ4h*rrib_?AQkB{ r]~Cq] Bg>>1bvuɴ;{-y1߶-V'~&MwrU*#ik܌ț֮aIkj4$9ApWn ؗn QO*5_j,j1K HV[xcJ'pʓz+ 6]@:(u"o pv]t_|v!?ѷcV^u){S Tk&VGYo:טŕ jW){!=D *J{uW-oA$ CGt.{@ TFg_]"A3}j~~rΦ;7}ezb2|vcK81*(o1{{Y.#GejS/ʡ'/ пǹ|:: RKN\߉{-Q.`vly>9jlY#V%7Ifŵ?# >v 4D$ ;K2*Q Z e%kD͆ 5/-Mxn4~ʷ~W`dR<[dD`PL&#"Fo+;c)8)hZɬ\sTFiTRZCVѬ?(Aı:TwtVco8abeFF3rIp,YJ5ar!B.ᔿN EI{*PH8Hc:&'=Vei$ybP.yL:9ݹ1(JJ=݈D-6Pĵb3tkۤ@[mN֜tnX;C\%rFxe@5Q]JӚ߾[`m~ѦҲ}ɵO)kba`N&%JO9%=t4pgEm&FrH&d=I{iL`#Uas3 v=ȭV^H]ɋ xyc8wy7DwM$7mJw=K}y{Z/})˅& y FM3jN[1 yjz_"=[EJz"ϡޔ39u&FVʆw5-8ZBXJn0M"& \$"(3Ot yڽmQ|7$+H+x\#R? 伟謟;B'UATRX\`43Ǚu]e pE=Қ H5-1+BWtO;TTBU-E.{>^Q>7aOH9vhZ&zOl ջH uos=)cVE!>շ81x oYr%TyoI)G8(ù˴av" Bwsؘz+s ~xT>6is[| vӫK!эW D?șHaZ& o'ɵeCZ{֗nP {Fk3~TG}|1id{D`N,&6'BD:`j4Yܔu(YU#W/t~-X2I+.;=ȰlJ'1er}eS=s?@}u" ͐bM"08)BKċ73jgytAŶ~S"l "Rik|le=c?vx}MKOEhx+SI4C?V;VMv=TM!9a ={R5t.7a(q\ '&fJ%0G@10@080KxʻLSAjՒ{ '=@kWsH㻧\ňIbq6<y$ɸfh7gX {SRq d|:`&A(WԚGO-5u}whJdn1?2 endstream endobj 337 0 obj << /Length1 1839 /Length2 11835 /Length3 0 /Length 12978 /Filter /FlateDecode >> stream xڍP[-4Np`5{pww Awfnfom;knrb%UzaS{c =3@T^ GNfb Gtr/4ryd\m̬ffN&& xbFny\}?LܜtmN&Fvy# &F6U{Kpqqadtwwg0ufw2[XT@'7)w#[_1,,6ڛ9K{) 6@UZ;X:r]d#{[#;OK;s (!B03hdlofdicdq#2轿uldliCe7YTh }=:Vk;{w;,L~`ng WĻ 9 :&y:re~`0{oci|r6r\\>^:13L-M\@sK;fw2 'wmx2*jʊ\""/zV= ; U,ł\i;3{dw߄uT jRW,@ؙLߘeWWHxl-m<׫˻'C5<.F3 lgnMt*YX-dlB331}L/ w=/)ngbo{X9FNNFpG^ch KF;{{{>3{' `m q1A>Q`T0 n{+]3? Y}h|nZ-<,"msmmD(>Ìwj^]t%|'|g|/|a?;Q?;Q?6靨_c~q57=&pˋ&Vu5s^NHIՙNwI#(kTB+D/^'- amOφ*3mpߧ Na Մ_5[@ds]%=VC9dfcԣɿg-@Р]z ͡Lưzl|iBŹ Wm|K0Y{ɫpij}BװXh\p^F rC -7r8&J;nܵc1QP/)sAոaߟ5`dw ZC+CCw`l7!bJx$$ W(2Nb`d6V3JM#T4rh2]gl3#q;yt瀘3ګORFQL`bM+Mn=t˷P't%i^=DgVu4nxg~N 2C6Ԕ?D={ao,^?flđ9*h LpU]H}kTZD}`E\6¶6 -[a:,W[Z+ ^->L2JvNT??F5jI1|*8=N3|L:N9ֲ&짪/GjJp-S;f~<зtE6U5Xdl7-6 2M!TNBaVitR=6B^9("{r= Y>NOX{i4*H<#.>8(/W; yitrb7zr#Q$p⟗NSשϐߏow/)Fڟ{(Zb* #-Vye)ʁ֎33HA\BԩLV9PZM/֮"ue5RrF'ƣr_#үn5jcPc,P]*x'֢x_eŃXt5Z8{)e7HoRxfho!%0l_Y%ԤbB>&ܥev&1xʆFTzʋ#Put#a]XOɆ7r9 HX:=ԪcjM1׾,f;x[7q{R0}os[q8S%n=C8w.ve&H;IDih}hq_5H~YoMlHH?j0'<0eY# 4!ԅ58<}2f*,VCH vB`ޭIAHB U*`6;ndpbk:q +aUp)v0ݷ r9&?VG#6 :m k/lz{x 'gϩ'm(([$xʷ,FЇX qR<#e2דB g^>-lqDbu_ S2f;/NW6V=w71;Dm *j%zr!ڢ.z3~S 4DBL׿7R!|5@T_vلh` 5 n ;FCZ izC47cb=ǸfNcC k0+9!#XI]cQ=dI=M|L5;e%+%M#8+uB3[َe5c!WfwF.1RbraXŔ4@}z%1P+Lc<.-q"1)7$}Gv~ _aHK}- %H0ۛ<[̪GsnjBgRL23-;n"A;A;;Iin_K?aP)PeO=}">T6֑˫ׅ7F-'_UZ~y,{w{װhr?ti(X/za:2 [JDLxeD&e:sH3Q]"ȍ۹jjZg|:ڏhnr F؏y96l=VGcguX@#`bESi-2hGWP]}r.ϭl1|?b ܲF*]:>{YȧMX}DRsP[&YQL7UqjwsëʣՂW]џEcbj_oa0qm* ѧש[9l.P8 2הzl*oHT Xbd Jo.7%K|WaOf咧(]^2*S=6fވg;i"dY h]{zà"yo,l#$ro4"Gky&t#5t9|fm䯴6rEo!O4-U=ru^(im=S>8db\8cقK!4Ѡ>YrkӥM[&;)7򩟱铊/Ot6}ܬ 1b<)+྆5ijC5ڋ[b7y8l~=Joy凵96;Qco<#?]6Ʌs/MҮg3j)\jLuI jdZs :m} rqCU[;brhXBZ͋1woΣ>cC$~PCXΜ[ ۟ ÷\5n*+`KT4FFx[ƽY5>z;%YZ]MN!Mz>-} @R>U61rEhs{`WO57eiw[R`J݁e'% +(tUzޚERx_WM( zO YF_ԼqZS5MOwL5TS;W~}]$w6Y쿉Ca6rt/T R!gb[ɊӨ$.UvW)STTG69,B{Xw wO=JkT&@>PaoT5h$b0ɋn.ZlBlWZ2x~`|SwOKW"OC=2OnJQnŖ _B}^dya8k0Ww+#[L  if: RE5XX)UE)d6L8؞O}Ҍ.17\TV\вp7HۆO3yB#+&Gl>:!=n#ԃLw鷢<;EH/,z7 F^5y׮i85_ i+QZ\]i6(mY&hn{O~ĭe_8͆V % '*U]`pǵ~N_,_m#DV<nQۮBq|F_EU{]=*d6״YNVr2mtx.YƆ}M-A8uw8L[n.҅I=l  (-l|qL1`sE5!rj /\ƿ[Z,NCL>M)aw8JPa)FAL*}>[ dO;O\RMڰ"|,HIQ2:|cG[.E }$p^T/f,%uM-)O2Hi533r7;4_]efc`ZVG*վ\1q BɹX!E[j5 )_vKgCM@>N{^ȧ1/46k>Za=sMn{۳GO2gw-ӵyXrJ\z[R]v@!_rMKHD*9Tyr}K8'1yS>1Ҥ -ī? = ]$9(Ur97^ѮJ$+EPxLq\ ^zJz%p4hfXe6}Z94)HҴ ,vItw9^68S:Ts\+Ł,Ǒ!mړ6q(afY,JT&/-h+v4BɭX|ǵM빾8tL"=O*qC.Cȗ;{|죒τz,Om<"=0 +m8 Za)hʺjZ][Ą f&*pyW YCf Ѵ  ƙ(v dz!D%ħ9=fmNM孟.b6N 3??84*?%s']i W$mfb -b!pZЂV]HǠf @5{; IoVWB_U.&(sx`; KJȗr_wqX"Nmk]hЄlJɴG1^!(6MjH% H-UOT3<}ޞӊ~Ą8R_dj9n2>`BskK64VmL{5tvf4!U! )R?BjrTvxe ;DǘK'Gjd` -=3dxz 3o$v(ky44qF_ Rx5J#G-cshޜ_aN-o8 G@ !L<a|C70Ghƕ3RwLGgzvcF=fk[zC U#G<ؙod[C~g!;hɶ# %ڊ6%1NK:Z*؋[V~EZ3\r1~_E˻XA0Z2frtJ'%&7{9XJҮL7l̾ɪ4!nȾsU|>2lOkO\C!.yubm+'EWNZ_ٞȶYdC3R^&]B20O]^B:V}403@ϓ"G }uƛ#F>ݾ¦s9 EY0n`wNi:Hbڼ@{)2R4U>XtEK 47]{|Xu-Is;sx0K#-rBd";Thfit2oV?>y9[tefb&\ݮTo^RLjMOm8t0ݝyQ|t{Y?r8DXd{A:}Z)%۵4(N~kO1&/, O3mI"F0=93~U9yPEc0ա[1ܚ| .X&gmܐRx<[NΪtlY=B*:/0P.c_gN\JE_[au7TVẂvbܑaL\'$Uf^2cP#by%(ZBsd~a3`Ie& f@Ab&%P'IծD: HۼI~YxyRQ0}|h|䰣iM_X{- 2=ltMd DZ2k@V4ύ9*hKb ,10}- *N?';ƿJ(|)SÜ?ҔL tF֥- ha8~V]YoD|"hG`)F\uSx^69=]zr"A-t+jQħ#&,aӚk䦩y{ >Y=[;~pGUѠeeՆO2e&?y6H"a.(N6QBůAN_o˟S ^IxI^_sá1[ ҧ>fbÊ:%; aa_!b_g>M><N[=yխf h._Y " ꊒiRf .Q%?76 #,ͭDMAJ {8F) "z~CH=0ɠF [Y<o)9^ Ac\.r H*W_*gM]c>-S’cxHY\Q~hw{Nj|6|$PhX6Ǵ3Jxu@mIE*4+0eow~>Eɀ?N\"$;2<&*ߐd|Her &pתv62]_@)r\`8jE:%^Vp>Vüh-@J0 barvCs2H6jr,OѤ %f'/jJ2^yMC0qҠH>\!J6Isz~I}S:$gr|/ZZ b< kkaoQ8}enc@hޯ3Pn-慊lYw z7P}c`DYUb7s̴k6x]l-sZ y"dchsAVYj)4OMmoGۗâ23cxVË'v%'G~RUrI0U fzhzrߗ=-uyed>%DT\{NJ%,]Z%MoP#>mM1;9]6Kd=@pI|"<$بw|_(|* ߵM B N#!(~0AKGE u5_S~$ ^d"*?tPMTuؿ=WL@.BRMq3A"" ʞ9BDXq|n $Dt8ʹ,Mf>[?w 4nyWTcv#b\L ǹ AF [Nln{:4+/W=0v,BLOE⧴X-5Ĩݵv&F\ h% :w]E3asst99KT$8?QC  *A''\{h_}2"th_㽫^9I +l'+7 8O%+z)˄' -r ~< ˰(:AZT'&(D9G I J)+{k)ߴ)n+'Ž$B9bpBu qNd%@0ƗuQ 2c (ᫎ;ArEѰ[7x N 3`kYD珷WeՆ0sνB_ I Vn2|%EAW_Y @־0 '20ZZ4Dٹ*,3YH=|x~}iԍ;(ɻW2flءt;Ʒ~{9vxl xIW i8W T,Fhx* \nݷL =eP!dK˩gaK7%]sIgǫ!q¡ӊH^rP$ rwJ[h#hߗ֟XmutPOV#0cQևX9;$As {6Z}S uu7hs(Q$'lP`I'еy"}b&_g>Y\^Hv|% Mʅd1k*:ST|DDy\Urۋ DO; endstream endobj 339 0 obj << /Length1 1842 /Length2 12717 /Length3 0 /Length 13863 /Filter /FlateDecode >> stream xڍPY-Kp;ww܂Bpww3=UUom;k$UQg5w4J9:YXjv&6JJ k/+с~q &azSttȹX\||,,6:$LܭL9G+hh D.f&ED3;5_%h@ '>ff&{W&GK!Z5 t P2%@/x7Y\́. e'_ 0u5V&WL613sw2qvXXR L O@;W|wk;?DU&;W3k'+2Q% W?IXo݋ϱ:8z8ma`nG nN̚n@YEYANn^64bO'w~>NN~>&@ O#VV` v@h~'#˻X,][v^9\f=Qm9=E?KL `dds?X+`-OŠw-%w4 \Y*/)7;?4?^{k;z׾8o6uU[WdvDkW)kO5/ec*<(FVo?]#%.6N.'} ́*zOptAc\f?L"v߈i70Xߑ-mg/ `6x?Wl~ l7|?wl^lޖ?{_,o?;+zGvGT\ߩg}Egy;SwL=lٞL37~ֿ5 4CXYt4im%`ܛΠeYqp{DM rME[!Is#Js=Y(Qmf ayThցI#1p~/u&:-Eڽmc2?r t;&oN6gA;&t<4Tr6~a؋ݾuNP= ck/Z{Ks lz&㠜A)GY rOJ@u]rV*r>!kESe~ VnE|7e>sqUߢ6׷pq*h\Jdmn JEg:"ts k9tdi݈- V~ 7J@|yg{lR5uÂs*c_3M"n`i:spnQQZ+BC7׺B+hfd `EzL$bfwE=W:Wic]0mr`asy !#8o_R 0\+Q*oa>ʬd#L{UO&fP.5]p bHP"q%Ufl5rv H62քZZ7-7Zͅ >?Qjc樎9~!H ^곅N.J情i]IUg|P $\PT?d?~N5niOSe|TB0j2%u}ln l_nzz¹ jNEV_Fmͮ 4_'?AnKW*S:YjmoC s7|>#xLk/QsRsأ C,D=25mN$:mKПb׀뼂Ve+`Z_7-1z&5"_-4sTJ嚞Bqg|((_2Gr#CSA >:mE*-6L+k3hmMp,?;9dAq|4GJk B^wJ*e2Y27!M;RlyC?*`܎~@{e$ ܔŰ2jӞ_wޟ]Ѯ8ϑ`ٙ[EV|4bcfC%̏_Yy{ZEv_xZml<ť4Y sғpDxR>@ZYZ>mu]ߐ''J@x3Dʤ'n!VM2~y->E,A3cn;@(?1(ܥ4ĚH@/[(*ZuwL(O<'!jʗ2Mh..(?WtR"7!g'!tKm.V؎0D%>:+zȾo|cVceeV$ռ/~E$XnPt> _h HJVݛBIH JiNt"{)kCRt%Zٍp`ZǞWnj͖8G4A gT44L87z]Z11ܢ3~́O[Hu^kT?8ɔ5|G  N|~Yɳ7{vUuW\M5:6vŅFa=QnFX$t2y^ck[ _CVO1ٶi,BƗz^&{<#<8oQfA~CP #bÊ{\."pԸ)‡Rʛqꎧ%]T+U7 w}vg,7 ߺ-Jp9^yu:8TXWt~LXF<Åؙ M{dj!PX}1z\X4F6vU:/"l\^r_q!V 1&olb s %[zP*T W=o؃; BE۳`MG؅_uhEFDLxi*AN>i57U@z|$pUǗ,B.ײ8C?@CXiTh;o[썏J_0 ϙԶ+JU"J,~TZ8먺=+(Y+ilt v5C*^˨PB+#ڵ}ƒålὩ^sVʾ?ADaY|3(~ReŅ'_:h$-ctyU`d`? :#ɮvB1kX{{@Kj;1c2善^ R,^@Q3 76uJwY"~L(FېMr4_:e$ %@*ΖW Aq#*t"KR{ \)Y侀օ>GK6_[)m0~*@DT*Gv\;n]I6%Ǔk 8fz~)JO.bRf s 6d>Pӳ7s`ONWj,U1.s@!x6]8RNCқeKRlScKs>yb)C7PÙ1oZjc+l ۽hLAm^ׇ7!i ui@|rv/vE- 鯠F;;[k:a372S]au(@?u5`#u[=9$D,Ǩ Nޥ4ɝZs(&'Cpg'cRxjfj9I%]$ nԂ]2+љy{_ٟ^9%-Y"8?Re8"% P+Qb+hŬȽ̠䨎mw\^-7%?x@bŧMӭm\f~1FUC?Z{+6̦Cͬ.I$9yЗ';=S|ڮ#e8-w]ps{2{NU]m#NŒCbJ.| I$J! 1>F2$VX*8,Ⱌ1Ydų9ܘ92|u!v{j_¹ ;7(w/{!xJQaJٶ3鹭}|:!'9e.4m5pL7# 3/N2D:O'C6,y.2EoP|BrK@,CZm*lFUXg hՅOh pb](RR <8P:_eD7t١Lig;{+P n'^:5˜yD]W |_k˯(,+\9~x[u9> lpRol(pCxCF|RȴOAn,GLWEeb]LJǴ-c@Y^H% kHV$XMM/ipb)k%kXH(DңnZY|te0Qp ĉ--WDmUb f5Br `p=J ŝ^i@U`qEܕnXǖ(v`.1l-<Ӌp(?:o{5cI9|Dwт\D뽔J|):cXO@mpu$)c8uZL7'}fCY .f6RUa0n(IL;iUV)}H}Y̍q݃vR`賈WrX=g(âWA]FrA:@vmwtI+;(=Kkʶ^!S +`-' Ȳ:Ӡ@*,|IS6"焹(z 껚)wv;/K-X>зU>yt?ZjE?f kKtqB9hGNs=Sq% :VV}׬JKN~.2m׭H}`izhsCfoS o"vpFB3q 6z#JZsGikk9LqYv^V'N4uJTKffAIh['Aje.ˉ!IOU+dCkJA?{b*Wvل*_t_]v詁<韃QG=x]ru7qKTF.<^M5(Y4҉Ya~HT-,J>qr JN|X8;{`"9ޅ2)-!~=5Ha۲HN=NNW۱jL*<0^6Y9~fm9>l:guB6O ruح:. xx4|Ag3=]AU``+B/#;s4Nᅺ`$f \@ۯX=0i Oo}JX mۈ2_ƱgA? 6ىqMϻᓠ*ڑ4hucaO[T#1#ƆR;Ֆ1܂Df4 |y4Bĭ9w(1_NG>F"AoUF\u6G+RHi9@\֜6-[go L%)dw}hYuk!R&Pr7՗ڲE. _Z®b_ |e(y )ףjŚ z-DMԬ#M̥<ѝntQÊbK1+qEXy4@\1^]^V$ٖ&YC9 d םШ~SΤڕƶ^=cJX?TY֍R¦"ṪXYN P tce)e1KW>5a1yG!U+{"nvjOߦQVaƷ2XAƎ=x!K[J‘aV'/q| a>mg/+T4#a Cn_230EoNc,WXb/&K -RrmЖeԁ7ix&4~?pWo;O,~T D>]iicw®+v|n1nlS6n4sR F e~sLo8'ΟaɅP5${?|Gb9)\(2|u0SlAuԯL'l㋄WwbcIe+99m\}VգJ8;'6 9B3*'UұY90g'T&LF.h)Y /iT"䟥Jl_e1<`F-Sݟ0|kr&cMq5ʮFfFGۈ}?μX;Mlx{ )Qev`+ a/yxWƏGo2ț-_َ!jXQ44yD_g`l(LԯG̼_홁b&2=g_{sH% "DRqd RI-RP& weNs 2Z/3viKxK݆Uh憳Q`,eRe6[z}C󍒇Eп η1 %PX׉ ;V .OɿQUs{DgږdN>|ř-‹Q3t V9XoHQjRte3غOjNC--9KTőIw:I4۵ [ͯPv!15pL|vs*qp o#ѽš 7!.. )By"`)C{)ɡL\~ua>LvK%Qdcimw֞U+f/Af]2,eG|M@GXB`;c)FRW`WO:7̼@)8k3~85vS5%-Y3ߑIp"]:)+<0CAoy92 -1IF38$37%WWN%q~킊ʸˇWҵb^u*+~J8+"%gesF7AXs$Io>y&')7Sl <+%g O[΍x#A(?i[_Xxyo4CSQ^AH-[k>sc͌%]qӪx%:KƒC+坴Zۘ* 5bHlrH1I |VQ Bc6%s}F38U_*1O{ p·V)Oz0ŽĵX-7}Xh YڗQ'=%׿>_, B!@G =$t,FS0uUg{ǧ -ul[*5olۻXг)]iEtk}q. Spa;PuFd˄?ybH0?cb2~^?)v& gFufHqSsam:TyVs07hQ \f>7Qc,$ ڻRc!ԍ,e%P-4T?`Л.mrZLf$щM^ab:vxDu^wއmc/WL' ~!uO7*cI)Xˠ$:7JEPu9Xr\ g&-%L<:?\K O1k D@>/Ɍ'^HH1]*LF%n~U.f20F+,h(B*C!jҰn,Q/^ثb~C1[2Yj/!-mQn@S K5h^]5Ƅ;Y֧|h $I(0o@wr3u>f OF22 yr}HY{ߣ,9.nQ7s.sy*)N3K2,N%x=G %2d̹bi&2{jW8M54W) 'OW&&[(+h23YSWcY3fԦ/ks3͸v҃USxW\ -Xϓm[eՅSʾZ2ebz,ǚbÂ<:L~3W 벊_3sܠ7Z?bl]65\wXlT+Jҵ;ɱ&A՞,Mg>oBzë}u``2NYkb18YJ+̢?9+ۆnGi;=V11!Gͧ:TKt=t '>(<2*߫ Q1,.dw)Ua%_vxb9LԞ&me)Jk}%$A(J9'ƒ3&0Gw-;E051T lWxRjU " ] Nxj><7W;Ȩa=$* (&Wv v ئo-wE%&dFCfeqCNMw>BĂŔ5ʪ4@"wsfXR@*9@\R{vb?6'vj?7S:H4=,ŧ0˞Qm/JDݼ^͉E6/Zw¯ʐm4,F5RŔ<;J; $Ll"(\seP շGl_Yn ߖ(St@jqkH92PF.{_ZX °\S(R7CGX]!i܏>$U_;և3=]NC9ldx[cq,1PC{䯻p|8wpަKP&umDzZ](ӒIJppw~! p)+3֬+DZ9צÙoE+ MoHi mQ;ErV2{X{EW GnsZ\ߛ.ОX"Y]hglsgS{:0:`p% R;|N7_nV@XD}A2؞^L:QXFdJ2Dqi$sAN!$1 <JyNvT?HU9 s,9oe~Bv&V`G3_vGU5e$q8Bz,3cl͌(4 5,3)o?y0Qw^1Q^rWHO"JZY8Ln*fR:$`P H^2jêe lIT pOK_9ٿ8ȋ2](1 !j:DdG1EZ_Y$,Nz.Dɝes px0sht;G`TO>h1b7KKY'V@ pݸ}"x'W[:UsM-\O.߶[@X6,3jt){d v5A $[;PQ%k2kDJ} Jج_fL[d%Q,7hXǨn3x?Y@]fm0_ӺmsWںZZZa_yqhTM-ϭK]/#|CzNQ<2"VPD꿽+h5'71[>**%\ oaɘ #~T !4|g'/W+䔂*_X3r)S+*ɷ:0/mȩgНKrhdqޢ0o9 EyDbRn:O'/9BuqM6:HӃ[TM0B[Zj@(:A"ӆ@)Q^+os"FI6<]s)|Mo 5'rmVOa' 2+cI@X왒Mu]V/\A0܃ /I/i̵&' tQY)&4N?vS|iwmj0:ziSC1&ZeH mM)E]  O2 p* .S(} Ue{5˲ `AZPcr6x}8ah'Cm!QW ϐT,bO9t$W`Qv3s!ccrt4+aFM^49wmhv[}T)|.# vz9ZsdWAUuON|KzX Zeߚm͔!А*הqde?+EZ6> stream xڍPڲ.,Kww lp$[pwww  .9'zjf}m_U5j"f`$Ι &`aagbaaCT9-G::v|Bh&7v~3Td]lV.>Vn> |qcW@ :!R=Ao<>hLi Dl Sc;%6=+=3Br@3_%m* n rG6wv3v6 SӛP(1ǀ2'ܿ lkoll%Iy&gwg_6N7cWcɛߩ$ETo>'SG vvfb`[[_oZہAvfabϬarpʈMGftpp%_je 2 z9Ύ.^S`2u-@v;XƏ?' 3x1 JRr"*?JQQ; `eecp>wecп2v`?ӿSv kAhK6@͟Acd1}b](AI7xmr]߶@ vT *@.[+l "vo$ r)M-  vYYXmL[|[3kl\cGGcķV!NRe3Vg9rqEbY0Kq% V`2`7v?]?]zS ƮiqE18GFoڿ-[Ζ?Fo}bvvQ.o _H h46j!BƸ;Ɓ֎J{^HM#kmk p>VXsmI #'y_rFvf8gn3 sRTgLPx<GxqN=sl.q U2TQhʩ]}xldA;u  ۳uf堂%rpLiXگX(%Ht =6_jDMSJ.𛢸ffm0mj?mDX+bESQ= A+SOȷe [Nwʊm6$>(AGe<|0xE qnۣof8Is6 չ]~Wpmt*<ٙ A BN{ b+z~GfQvNlW$h sV.<0`:y FqvO6V$, :qNI)$,gg=0#WV{K\:shݓ5)#iS ˋ FƩSOÊOX#$ >U8P# 73X/TQ',h0\y -LM?tet +)B'AiBiy1p&lk(YqlB.LPT YB~A]o%1j tsȈ؄j%';(WƁ*pQY~"F#e.-die%=QF}xmw<ª~˜Wx)}d(Jtw-Q)Xa0,GGktcM4}@<:le~j ]AKs?]v/Q[Չ"aжwnܕ"d]K jTb^Gwk#X=CkWDIy85Z#IuK\</vy{AJ l,K Yi'-d#'jibxmzZr~*^de-jQj9i˝i g*;}pXfɬ`&{ aoބPuDNTv0 <~o!ji %?Q3B1@K_ޅ)L9^6:V.@jf1^0)`XKYU&Ggf(>RQr/:G ?ɺH>`ﱓ8aq,Ar$Vz{/źŵ^j/1v]{rщUx PTC- jE@E7Hq I0Bcru` b Ϧ^ɷx$ 1ta)"&.XJ UjP+2$GNMjvf'UѳTjTUhL4Wa} .ͯqp<5O%9vmhM@&.+bz(Qi^=G͍Ss]zf3DZܯ J>8RR?85 nݒ Nx C#f?l+i9kdEIx&s"<;  ˣIl`r uQ)Ti(ezJX~#|W=?/؊iUz91k~j]@9nspsm>tߏwyc77;:W쟜c)ƥ=ix'Sl1#۱M|Ԫ_2v`-:a涀\<`$pl_WꌰgVXFi,U5ǻ+I$,(S1Ar&O6fDNp:bU2r "w`&^Nlٮ wҳhur8 "NDr w^w?Ć1 sku{*>ٱz=rmD|{yb'ڎ}d3Zfr;^b2Y%Êm=ևL-}zw~ =M/z}lV o>2KNUcxiݣ{srQ20jp]Ɩtߙg>sy=9[ܘ)MU\zqA4PHV!( CΉȥbi7ۇ6g z@-B{oy [7l1E7*gŖMumh~+ Q-7S}ػ':ƍ&AY/wXyk\Ӷ ">kq)X(4>1>,xkEؠJ83K|y# ׁBG۫di}R;ZxvAthAXeE%GM痣k"VQcxݙ D{m7ZXsim6wz 5ȥQaW\Iot*A 2x5Yx/|$MxYNSB̩jJWxsd'Pw1G_Cv*J󽆇'0h)/rմjO@~Cf4䪲\ b'&"ʬ˄9;]3Z]NPըZMe=SM-7S Jlcc-<=vA`nsD\@@CZ'zts+h;\JoI] {YW P@LN`v9#j 6z.Ըy-7 N#6Law'<}E?@Mcc{MEy",Dž3z|+>_4Hie{jU$+cwj@7n+S6 _9իٟc`!:!BMMv^͉"=?麠:a1B ~3jc} ֓/jQQ{rShQnr Te̔Z?9?dRF)9b/uS?fG+wnawI &Efk1XY"FkGyGt.]8J4qˁ!b4}`ʊUR9/ǚN%i~ɡy<^0v;Vȉ-p2%[(CA9S <f0"IP.lGSM_rE|B~׃ 5wa_}r#տC hj98&!] _ulF=_%SK/kBquY9f8 {ϻkrfy][ όOCv4(cP]Pf1bP[dqvA$<$RGPb硺5+tOZ. ViD},E3f Jh})+JNtR Uoh'1= zN*)YOOǒ1"?'rZ46F)ܦcl&{)GeǾI7Lr#ΗhTjP1̦JFbkp'gJ#T zlwwNiS]F##vz!鲔j,;v%|F{hUBN^l/VTXajxzSAW{+˻z{͜5rsF#_afA⟘𢥃P |D [361I2:SX8ybzC񒕬mpѓǮ2rse%; %zT@t-$@lww<IJ~<@g7Ky%GBu}Q@Wdr<ʕp5T1L2IQU}碽H㗌 ZMH&Mp~mPm;\Z/y&EVVVz/em;ul?aUV,>/y1RYIlrzP7 ?kG'd渄v]Z]P)ia{N .$2k:N(reᔦe&Ra)pMT0v9w ֱN ⩰ߎc29- =y!U#| 7)=VH W$a#m$#Nۖ1J|MC:~}{gNӏmA6q:B?9g:>1zw/6@rW(U_{ ?FtdƊPf0\oZEb R2krvŇ?&wGP^Y ibQ_uc*ɥɱ[șORJ^cc6 BE ՞`"x:sՃD({(q\TG**ߑ}b޳-}sj,#1?&Fڇ˵L;m S2"kL⩄@,E4`) ; B@vlGGK5/TX&Y$cGaU2?Mf+~`KΕ胚 _*KJ,%YxH̟]ķ$~ "yHW&ɋN RR(DT~# cNGC 7D;Kxz:@N(F-sݤel> 1/-+AUgyl 5x@:6rL4SM{iB:c8+rB*w "SfX ~1Y{5/!#Y/U-Dj3 llla.ؔ /@0otGWd)z vA{zsOaOT"VWיS3Wa۞*KkQZ8$ǓTX΂3ۀfl1lCj +4[RHi2p7WB{kP;ixV/c |!oNkKH %U%2=Dǟd2[M61Q,Zsi>O:>q(0Ǎ#SCQȃ)(e^3B-@I8r&Yd>d(:qش7q58E4 b?K{h'H{h<NFˇΡ(㕗C+Gx2jNshk7BaIf0з_6;^wBdf(ƶ*+{좇Uो;|#1B/sCyEnH+5CUd[y3PF9%-Tl膍fv|-U]eo';d㺖(Ɠ|넠N$࣢ Y.J?vY9"QY%ؗm{Q߂:<:: V+N 3b3|1QD=Ïy7bZI/01* tyWS6 f`ͦ33X@@Lt0۸Fc@D(ʏWc(u袨Z*y>1 ./sj9dw_dmGw<_,qr6y^l^`C3 ȡ^([/ӦEȳXkn{gem9eJ^0Wʽ``f{wU~{_&X&t6"ɒ![5WD!u|ƜҠx3VSH[\`2;l%u }/EQ$ e|' J]CTk 2QKiqa51HG8p$ANO(Fev]9R#$4FN_[ٕ4eycƿ[\Pn Ik+D%rZsgXL M GJDK Kg rQki1 9dER\6Ybj3;/CcJV_ \UH:6T4ǎ'nd\A-~e~ [LĮJ@p62~K-RwŎLë_RO&F[ 9jô4dm=rAB%ewc|PYm 0z%H25-U}9-+bǖ8! lUK7 >Aq So:l J0JO_#d ύ"s=acCO͐uyu oRP0&Ʀ[:  ɋ0bt-G'-z!ttRLz{Rv\?2z?ՎtҬê=dY8V#cYwJ"ĕ7}ЗwOQKOd%T#Lr *q<lhNo vYgv8?>͑(՞Jz+2tCS>"+'B+=kA0OIiX:4;#d7YE -^YMƂL-e%`iSC{l]JG =Ζ5 URN(}[Y4Оg,,\-Z5>b@)P-I9Z%tW򒚗]ٞioQBT{(GFuF Ji#s8Q,n!%x6{%D W{KAkpCZ\vEbיl :2  khL5'LrO2Px!voTZQ|ߦ =@L苦Y-H8A.FZPaK0Q;NiO0쨮)eg6 (*Ƕ)u>`Y+qBjpυjǭ?^4TOމtn)M 7H>iT Oј 5@?y K5D1j,=OޮK .}*UlE}D!"g> stream xڍxT6ҤJׄ^{B@HR "қHQA"={3g~f'+lz|{ %چ  ،(o≄"PءИ MF^0HIA Po"Sd uh4pM urF $$x PmrW0G ($ $2@ 5~63 /^`u"kEt%ہ7w;p ]-~/`wE!x;o;(M]@E^`OH'GBazpEBO O>-G(W^pD] s"@ QQ~-` { pGm@A@yzAO8@(= 'wv4 qF'` Dz0o#06V2Q _@OB@11@?ApG@rw4g@̥@+Э"@0 e_x`V =,j kt!P/ wB+$ "U=( j !_7 : /z[o=C\WF86AQі Jo1:1$u =zG! @ B C&%&w+g|P%:\:I:M<-%;o${hwX8?,@ 'B6̧B>,+4%/{dGI~|],&s*xcEi%Tu?8aLR 1>*S'鋀;?yDgޣ kSz0fhs&B󄙑B3=kU[;/ji j)Z-6/V٥=Flԣݬi̓쩫{*7TVZdΠWL*y%/ǃx`Dրݜx ގ3pq\{uA0Y0b4K`u 5 xf;q_ؠ95 i69_)%c<7 pT?NJ +Xh f*_rEydq'bE .wKNlw]=ZO2V,Ӳ' vo{(c+9O P 璴ޥzjېWг&/qPTw Hd 12Ss +E=&5n+J,h1ԤŦ[ rGƋI3,ƥڲ'u۲)"ļg?ꁐA$)rE:"6Bi1F_["t~%Qͺ\DU@)6E/ȏDMؐ)9:yV6!m|RБCoqv+9k0xJ-Ñ#vf4JƀO0z'뮘ﳸ<,qv/ߌmN[!ZlfY߰}=>&%A6GDt $pe3} #:\ڛ[ m7d)JL0!9U&X e2+vy9(_pP@d\t:l(rݘ;|j "0}g6oye"U& kcv'3GXJ3hҍnwm):DC .9~W"yy[TqEfg+Yd)xaA1YVEqcW)GG_Zhkq~-r[푸|ru&8'g(ò"ϵf{]uL=TKZw`safFp)uъ7F ~S.LeD3{wy%3*7߿JߞxyH{uɎS歳*DXCg*N|Qùl2sZV t7_̷ݕQ!<i (IܧT8?ct_2Py׽1X~`9 /2\ZjsW; Q;v]`a.d|])O(q,q]aPq%@YN쇱~WB;ލ? ,qq3~`6LQ:8Dt?%֯FъG-I}Kܻq3O .ƻg.-8< {s`JZXBz|pIQ;ǃ %H8._,4[Y~Ca">=ZB' D4 D m|:?BwGG_"4}>?uِ~6ֽ]KeՅnȚbabk+7P`5g}LCdL?~,W\ F%g BʑXxp?u+{1oMGLhn3++B{;^cOߏL_t_}X{ weib\ ~l Q"~LcCf-[{tQs)eD2]ce+0 kbA>٩F{+LI#<>|lN݌Q[*YOVG%bo6Jвk˒Ig).s0|1v4 : F DfK2}M&`qrt!S 9!LOnȘc &RFO?< ,LG.b0@h;BC>iD!jjWCol䧂JW)u*0 =Weɧ(*h3xhV*6;)Le#3{8>81-rOMr=:ny_Ș1sKɍMoXL6/wI"WNj.wS_ |M*nE}AhX~c>o {0^m8q Yb3`i(㼃in|O*eHヂG~n;YB%ܙm;0KN8JtrTogcu ?2(W ֹx|N4ޜSe^{Ikb% 8Fm(Agº(>ryr2Pqy,2~VJ g:T++v5%رಚU4]hг {0)Y1eǷ3xtLc'Koǽ)tӌ`z0әvj }qMuabt ~z@?z$'[.F˕7S|⸡PS5d_yi5फT%ki /a[rB`.Rk t 6n 5oyR/3ozր(\UH;]UEw.\g8?smerp6_7n!h fo:W\*Ѩe1 HB\={IFʩKXd$Oe۔yD\Xəvu֪rrŕiΗ{tO ƺdjV&lZb^*eՔLdݏp&3)T[úp T5[6anE(Q/N9o?NO P va>IBUYيc1KCLY0VVIGӀ\E!لG%Mi(ȼ%>&ͼm"u;B^2~Ly޲l>QQ4$֙ګdI؟wEƆxhd#WC:=k `}%iWǷNB1 RP(3/U)M'ɧLRoXI]~2LKn>:U|T'۩*"j_V͉elTh{]tF. ᇻ9c}#4u݈^Ŀ<7젞D0KsQ=Yr>sk~&E{4u6؁Λ9f$y{>woYYʽzTd4.z$+G/YrRbōşH)'薧}V#Tob}Ouo=LַKÂ$(zjABdjn18aYǖt_kݪ|0y1σMb讨ϭ(Y+WĦU09cE,`:smB9qU*h*!T@:qx"ji)p, d)_?K@?0hI9뜏o~k!"J3>[0ZoX [@Elu-jsf nΆ|w4h8ԜI}V!z+c; e\f:QSʝE#x?U;8p!R̀2uQjtkE,gn ߳4uRxDJbmvG,k)2RI][6`Ʋfӹ<]ĉ=@yHz9'QyYR6r`Ixaϳѥi=!s*jZSII+1Iڱ$kr+vH7&y!*jF[ބ_/)ܲOaņ>Έd8<{,(}T zM2zOnx_ =jR~ b0fv߄rQ ?{mYatbdsx R2|JfU* L_݄e$6E(8M$]^Vrk3fgow oŸ{jÑ놰}. A1rm  \,ο`l"T$\ K-8(jKO3lG뿦;91w;$zb.͍'lIoM5ɪ?xw+/R_RMȕZ&Cܐ%t.WUęUo3vg[ɝt;^N֝cXhԗw?Z6Jy$ [Z4>f:vKt c{w=3/澹)!C@H» JpYHEw##e gKS[_[&[YZh/GRPKr,1N(;=s_{c k `9JDoU{ endstream endobj 345 0 obj << /Length1 1380 /Length2 6018 /Length3 0 /Length 6960 /Filter /FlateDecode >> stream xڍTTT]&DJE?bnSZr``fAiT;$DJR@ZEDi{׺w9}~eh, A:@Ց Pgl) E@r^^c&510$BTPgSaq8=$%d%e@(/ -Py =A6Ő"Q>h3W_>m$p =ꆫH0 G >9g,%#$%r"N ^03E{B!Anߓ Lavc# p8 E`p k PPoo?OD0į`tC>0 uX~ 1H\<p_Fn?ah ?GwUŐO q#d]H/ߟ# q9%d{@@p&mNP,@(-!!@Po&>(/O3n?p  9Bqr?  =~0cP'83wh7 0 ^$7 ij**{TT?i@XXL )) gCOcHnq=8nKc-7ɭ@0%?_$φ=_n_>8z`qCdO9hz N82  ~au7bÂS0[pQ@p \P|Y.ԙF|ȁ8:q@1 $@bq!܌G$籊 pQH/y(@qR\ ɧ#\(z |2g.9K1bdJ5P6ޟ鈷)XK*{g__9A9 HQԈ%x#v*{+"[/B%DWV .17ncjVlrV&A%vҚ:mae:zI=Qif>YMӾTуL}baJ'6s#>4Q]4sMJeCu/9 (S숉%e3 lM!55s41q;3 cͫgesC9zlH~NEՅzõ8:,%򽗥w+H&З9*+5MXqqEç =x9'=9̝]o̕9[b_w3=J@ki{aNG>[V2kTI>tq(K`eeKkj 7\?]Pp=l7gخxlds._Dz٧*0"Z$CbkhD uĦR=)핊L8r&O4c)ʟ_֚-W%Q@ >q+}6ЭVh(,\ꚃR 喉Ļ)=wjv4tP{!!oSyH؝Ix ImGlnNbjen5vt@^2uA4!b\wAgZƜ=b/:LtbeC #s1KgM{&:.ZFN=> GZ+O>|YגaDx/>m;ٚ^w޹ɐ_wB{jK' ??]Z{M>E`6R^tڽ_^"]E`^@{?OߧH{y.>L=S&mƳ]-Ex@d+`$0畼/_Wjs N^p5XUQRfqw 1nY U|N 'He}4R מ%Q 1{xSj%9.6xH2[oc \GShQ.yZ^[ou!SE]:9L==RW2^io{3D07wH9yX%KoZWnU5;Yɐ*7W^Vl[XRp>zQnhNvӨ]b*}%T#%U!KhWf1ӦI!iPU揆(X݁TЂtȡJ؏*T*JڹVn]}rjÖז>g7oÍΊn -/5aft]P]IwA6Sob OY_%+vuԑ4 Odd>tr^;8?/IjmP&ElJ]jv=; Um[qr{hWڮr\5bDH}r8w>X*O"`HБrJG+ܾ=7Ễ΢?#P(]3,狋htUed 8;m-=a[3WrJ:@LֻQuiq,@:[ӹiD)vFŚm%A 7 ?|tH#RuSGnIkљ>NE: ȴ wx",0:K==8 hZ@yT(o(#t$%z:?;Rlp{T>Igj:Q ?Wd.uO4WAI#f5~)ǣp6p30SFm%\{6ki;c^b]> K AXˬD\7I68VPuzǪ et$=jɟ`K̖w.iy #ak Z*5Mxm "oATz8"Qb=oKYp0[yu %qDu,N|`.G\=˒c5NGjzV3?NgE. ♱S5_o)Sv#g2pH4ѺC#/bgO͌Oig+?EmsS>~xeۋiSL<2FD#@ĒOG6HQ3,ƴеljn?S@̜ۼM>Qku[B#j>56\wz";Ahg'57~ZvQW~f`6$K33VE磉 ]OM-.7:~}(;4^lkv6h& bبAR)Y/@5fFW4*9 \P4wxrNE}$!Mw*"\if W,f8 .ڪ(m+dZ؜o?X:ʊ*TN" 2+q1OAC]y44%CتN]vu3Yp.(NԢ `/-0Iwwۛ͵̗r 5bU {L94<)i߰]fėwBu<+}pAH(nnQOLJxcUSw.*FSF|HM_*`9E[ qhaQףeEs~=Zpƚ}Iݗ!G/]i恇oyv{RUYk0+w|ll V?@΃I\M7#{%ֻOtcmԾOӌi~9?z]Hdj>2$#-C)sf E_0!!Y,d<:HحJDĨW2^H{ bolI5[f.w+X f,-RNXyEت [(yd.;E8/aU &~ȏڂmIΈ1#- _b֊"|DkryUIYn8 bSTX!ƲTikL!9&2+tGo=31!"pEyw"~- G֩bFzfӘԚOoI(>E$mQ6Ĺ55 T e>-7-:ZYYʲ?(sM$ ~p!0q*HR S:NL]e- 4PE,)95IU0ă)?6YA%-[?8]2k+KoI葴g,U$w]%g48w<=νt ~ L 7Sfz_4S.j: mU$|#ǂZȒ$Q,jVe|Tgΰ29jABS~XI~6L\i<p$;Ԡf'*敌_f*&6"t N<Ɣ~Vi޽p}(-\X9q $|zJMLB[0׾yU˜Lي[ar._њO|(PV[ N=GKë'x}I8s-/H%>Z%'t{{gM) ws*,Qj =8cTWqy/[[imͦZU_AvHA>Z*tf*[,{>_BD(:LhI69ffD;3ADGYIp'j2ڲNhܦz`sxB$U&RRE,ҕwqP qb4rPT}3["]ђBayN>0#׬3a{>~3 T*mc<` %l'Lkkg!vQdq-⤸тޝ폐 $rYS08=:-u7 Zw}K8~hk^1cL cŚ ePnsl/76ʩ0zgWILj_?[5;D,dR'pCe/W L'ER9/cʞ3Q/"dk]|SUyܕd&AQ(Q1.+#xGekxDd &]B T̻3C:t̜{uy_N*F0Fzot[€ӿvU P{L!m$ọ$7()6܀aeV8t+<-2*a$y9'Q́ MY}k/~41NxIfU=|Y~&eÕsMQHYՒZd vj3A@vW6oiRl_+8*PщC½yxVt#%-eWEi#|@wSU'E*׬e {Xۛ/z}7eUY-,Vt&ԨҜl\Z3ÄVHbkjfᮅl_ʖES^]}#bye׏7?1/`2FPLfI6FW, 6+YBF'zC{QHJ†vWGG [MJRmYuvઝ ^$nAStNA`iL__`OIN=(U*y!'L b"sNaLOzlʐ¸Hy.m$@jO[9 y>>lhzk%$7rpm'\$pe[W: k3^T\?㵐6ݥҡFZXiY֕|]dx,+WS8ӓx~&6&v#:9u^σ\" Ώ9QmĚ *.o@ ;2 5I^. <ڽCYVcRiJw' `Ք:'1Bk%aVxGB)x:& 7u>\|w1rjDomͦ R>Wxb|Ԇ(5burdj x=^ס6ramaTgO >ˢT0c endstream endobj 347 0 obj << /Length1 2046 /Length2 16249 /Length3 0 /Length 17493 /Filter /FlateDecode >> stream xڌp[ Ƕm;Ķm{L<ĶmOdb9/﫺-^kCFL'dlgh"fgLD Udb02322ÐX8[GCfdag aGO󧡬-@`bffd032rΑ bja Hٚ8 {8Z;Gow-@sE#k5wvf`pss7qs4㧢Y8LL]M 31wi0ds )L Mk #[O[cGeIee@  `jamwvweh`doj`am`iw1!Egى ͢v66&N0'bhb >\+[;7[_e3Z8HSGff `cddd8L܍Z@o%_|eX|x9]L|_ab[9 M,laD?~Lƿ>}0c;[k?1 ͿK;w  |8 vOI=@o,95PitmF6F/.+kߌ\SGo`caouqYY&]Yc t6![ώcbgdIX_]/_fmak`d tCfdy8}*uEm6f6vYs*Mnf F#_`K/0!N   23)_>(!VS}_\INhdsY?`0/ LL_d_dc ]i)1~Va'*=?/?2g1Vĭqgk,d>7s8~VLƟi?+p~.?3aϿs"ݘ,/[?V M0^GBb( >ݰE- uG=m04Yi`0ZnxFqc,׷zO=8ɸ0Kwu}g56øhVv¤uڛ8%o|0h<d R#4;)It-8q/v:0̶=b+^6a/;`lW;em{pӘ OԵnY&@ wMh,wCm].$O6޲2qT>1h%hZ,diox]tFEi#Ѩ  /;~JA@?!-'kT%`Ɉ#^NH'Ĺ,rS^)ZQNjαnG`z#~*?'a48_m za'LieGHy:!O[ξ|cy֜Z|'[g^|֌E–L8Dц'y׍^lDJ)wՖ׹ޑ&Z^M#R[V8Z;b.+ga/u.Auͫm&K!+47D.k'k:)9 ș#&EU 0LՖ* 0/WRHvd$.D\Cv78Bm먳^Eii75@ ?uo\2SXYI]-u"d\ W,-Yn3yXt=eC;P%/A=SQj"v!5-;F@ɑ89Fs+Fyhw5>8ULN߱ݭh4#k1? FW ҎT;R]&QAiG<./*qǜq3e>3%)8TGc]n^q]bBʗRҪg2P'`,JV6C +J櫭C/xmDy>m]߬$(#Aj OZ'3I!pGӜ r᠁Z_D_ v'R}:duL 4M&}X!kP$jwN2Q^[1nʬ8(-|)ϺfDX]t)o fTlhJ4;Z<\5}F fvؓ?Hu8as˳Eon;LJ5*ZQP0LtIQ ;1\3Y'Ҹz")qMǾ@҅}E֍n#Zg9%tȞ^YU/72r\ICjE*%/l#v&w^ַ oY@6`QDBшZ)xIlI%DxWFf1͋.*)M)z' o@(xfb46ǎ, %hҸ.J2 H'_Xbl2#Lw߻* ~5?)8A1Jl^ ǜr {E*qt3/"J"Kxg->m:`uQY32,ՈExu Ha #"vqTeqinb5ސF2᭭LO{̀`7|t̪VaP oo=&5}..&ldceQMEog@fh$&xB7LQ10Ѕ ]\ՠnpz e1O6:ec[xL)5T~;W6r櫫\ꓤ] cnm 7|z2In}r3>b;j)L"3sο8?ܑOdQmk45 _XED4X]Nl2 H5Prd*q|}FlwnPe, vFB4RBpww&|2ވ3M;L]QҦUIx]s Sd:lfcV#Έ=n~![?gfrZA29R٢McO(5x#>ϡ;' y}R{~gDɨMeq  g(_.xlԆX\r#sU>H2Va8C 43F1܄RNqG(Tdy+;8MZo*B{*@ []]Ѥ)s#Kg52rlb|TD$&#K sf5Izr ͨw89řE +ڪB]1Ƽz*/aԂyd'C(*p\.]دL /t>J 6:c5B ܪv;M͞>Q; |zDxb}Q2+fr@ ! 5V{7=/ `wpNOCicRշN\bXdUEb0WBfp7@#ΤϮƯU]/'i︨4Qu9Tapp3RUGH@/!Mǫ)!wA_2m@e? l!.VJmi=zX0Ɲq˥7dbIk0<@ŀ8Q6.R9Pkw >ҊxJ!xHƃ3S87C\ЗtM[EL;]6ĪEjjKI@IH>Qf+e๦78i,R !񌒡moGJfFa D/zQB^d@e2\aMzn^lJ`Dx EpHMX9h9bRuݽ8c_2\H\L/;?]5ǰjeFq(6VgFMSGuGxm79lUpK55;>v42dk|oՏmu#A.>eNՁŴbUJ6]8{?<<^O ܧLU1eǪ#+> "ұW-Hb &9_b 7ɍl}לY**WLVe"j7'F8'Ղ\[%:aӵl9mP V<^>nv[^! 1enV4;tY K%YPZ(T'cWCh_ʃaдr̦c~rS)y0UŎU`QAJs_Hb76$| LRωxҝ̏ 1{,i[N]r}Ă)ar'1 6d+ {bWYsdq{s;z8h{5;}KL8FFIEKդ-7 O6-$Xdlw"QCYKv{{QKq4E#yJI^(U8%UWRDՃL[^eLFV!b\bwJ.wL3S_DS's[L͂?$pr0J\ 8TÅbHA IG<L5iː;I:t΀Ģjvx߂Qp7Q6SW#Z8#t+¯f:vS$ xE~GH}ORiSehD/61Ժ=v KCV%K;r Sb(yV_Iа;u -iy_߸3uM̀H K\P^۱#I*ĀcS%#cԴn uHI͌e}z;8)?ȓ(0+Id'И|ncLk}Yn {KW5l7e~"|AYI#*(7Y+=I)TV L f^^'7Ŋ׭/tXz9H v^d;f(-f ,7/&$_丗MRG)V̆gPϙZ C$_'/89t:8Xup\x` ?[xk %#!QSޢ/PBsrwH&;\/A-ҧF~hj e+vBm 7uƞA*Cu8WG,E!/NB6K~KH3*&?*'kiCVN0)Kr_Vo˫N965*^WΖtRA Ptj}FIF|kS,7=+UOa u/bG4)E V&ȱ['hwhNeJ~o@ydƽ%uI۸񁣽tjuo>P iC%ӐWoS#CB謅wHjW5>q\s_$=,tX S).V,h:5\ }/MB7Ʀv@Ԅ 6cf NPST0W=RXZ~0|*z]7lS\J1+[`ޮl7Grl5k" D2=9oB!d轝j.x %u<w"UI#'oi}}$7~M ߘ{fw)T{Vm\Mhb_JbFo~Bko+}wԔ,߰/{צ1|AؓI9Wn"B5[kS 4L=Ll"z!VEPcF /r'濃 4r۬~H`l\W "CвyjlK">-ʓؿaI*k/cnm\tnҲdP;X $ѰG6VnRu  im-T:ё@"KXbik7Y'I1RgfJ eEWǻHX Lbd J, Ǘвm؜U?vgD3j)۟ ]ϨD D lߌBՠܿ"Whoz [끕QPe!هQK8˰ܮT͟@ %@y.8?x7K>Gp{ڙACG-3yY>j4"h@Bd3 S X=ER ofЌ|+ECBzm+*pwmՑ,\ݵ⛘]j"$Wye_c,*rz˿0L+T\٘EQ1oo {V"ϖ8hAMpŤ`I@ `]ќt}-20tHϏĪ)( pxɻ8Pb'3zekTpq'NC\OzP)WeEٮrG 6]}O֡/vCa"aK,W,s\k9NzP+BsNo;W? )~U ͅmf8Vx1^t3iﭯ)wX(9Eu!ytFl7֘P %{xLv0kSJ>XgONU>z0r;w~);gZ|Cq3J}Op?aV;( 6|#P7z3u3]wCOqo-@1\ h<%b4ކGQR% ,`#V9KF־ |(gXhM{vx~twlhY$b2g霟HFգȗ @TLVME6e# Q_P0KxtUQ$<ߣ_lj`wFƷiSfSb_^&2O<5l~6zEdqw[G`T\(k^ Q?F_Dm;VC{(at<5W4sCy1T~KoaFM[ 3js@܉5ѱP1C-X=Y9% W6w8@-8 FX=~7E5PҊN5]%݈X ;2 W&^̠p˯~'rz$fmzr7Qvµn5Lm5|pfd>4 6a}D<#6T6V8xH,:;,r ?vb[QPV']-a-Ԃ'8[;L6Go]6'̏R y<2&jMsUb41)8ui:Ø/$p^^&;PaEM[fmDW'rcBs7hok$b2䃃$S MV 2zy1=%a%wb PcZ';ϣC=je PdU[GҠeSm c2礯EE$[Z1xwfzR( M䠇~ IB/oQ@pek saLxU$;흥 2҆u*" 36Ѣ <+*yn< D;= Isgޞd~dy Ø_y@0e)?u̖&?~dX-p/_+e蘤b [o`3T7B< :ќt\py%7k@Q]#-B8tD9"cq[m$DAc&Oz\s,U0Rp[SOKz h+6wd4 |c6ވJ{-z2Wa_^1͌dXŰ뎞@&Zw|rjӇeUV[L5hL}v c!&R.cL [Fdd?L ;ɣU ĨlZ_Cԅ4>(=؋JubAں ]l<;8[80+ =qJIKZf.>#1J1kQ_۪0ttyD-KN,DIW`7]:~4;P"A&sQ+˫]dWDzۑWp֪wBdh[&}+ M8)0Gz'IVu(k/C}EU+mAGvq㹊}PjxV:ݢ<!:.sP//h!m본>xd$W -΢Q>XU?#&׼mvFa>W(a;K =0WVP^gͫ5]-C\Dut= W1i} \37r2Ħ̉Z?A9zeA_Eu$@1Ů xBq7d.E J)14&uŠԻkv\'9;ڕ8"ȏL0kbu~;@%0 Nb4ϛ4Yz~la8>оʳ4<͵?5vqE.ZN2C ѱ{悦G-FQR8lomn衯ia[2-TM RDl;zKse?)~sҎ3Gjv5/#ѧ@^]OlAR7˩nD[&(wNMRJvwZOܫa8ް͌OLY_zpWgy\AcQG LsD=ĐsG@X~Pf_$a{+1DDd2v.xb8OoR.QBE2@aY v> >8" R Q㩫u6"4ĒRR+-Љ# m\*/GlBaWkNi||(prNX@ڳ[m"PЕ&FC++tPqZZmNHfN#[ fCZooǨkfvZ@i\Q6o*c@Bg3ڌQ%Ey\]L‹~:vbV}0%7N?{ ;Ǭ! >z"D4 tI\XWt]|7$[@C&O)uKC: n\^Win4O@}OC%Z5cҁnM/pC4䠅uV#.{c95h"|̫674 *uRzyCTVh[83Xp=2OY~Sm}`GE8;K@Nk~4>UBz650ܽm4 0Xa:|}1of]tbwWjKfsˏϱDՠQڔpގx2SBHR7޺.þUȆ;v6t;.Z?>7-xu&\< *.TԪgTƤ3pL#.gH GZ/ /༧fOo|j3bU5yv+3 ~lM@i6=~98Xtݲگs) sUjx9_;˃qM+i+ɚa3-o[B2?>t1<}Hk(*ֺUozK Z@fd|qpv4G6P"fO̍,4D[9ċa+h!v]BWX55w>{ٺaDbO}9*t@WH 7 A_]兆]>Sg}Cz与c>7N kLf 0]pF\jYfZ/9G|q:EpOӪ&py!VU+/dME7RuDQ(kf;f{0A,0414GCp*H`%8=Qu.pGyGoC@ B~`|"w$yr!S0c< 3\iFk΢Q |Me5V%˯aL0|q_%",M*yMnaM;T8Ex/UxbH+zJ2&p髝 w3F,"/*,GWYz/`SFv>~]q5x|w:k2`4zD9U&q(em9aPtMb=8vՂ qtҜa@U@S%"5 m$`ZOc+n,jeόp(F.B.`̢FT~xm~IM U$ z`:t,{[z F) _ }Lw:K; '4ҧdsM1ͺ@q Hgtá;7WL 1$cwGֻlz ?YۺiD-ns%r/^+v%^ HVKG}X1ضFꮌV=hz殷1uGpz`dv$F$RpF,O (TE(Y_]WSY்!FJ od{@i^Sê*Q&b.Wy0dXkt3J~K45:d20o]Zh NF(r9Y e9*wb;7ʒ;O+ONVڶFOR0@e3;z&x)}(? 'o.j;'2@V4̸!7zm{H#71[&/By "a$gQv41 3BP/]azh3C5#_+E5!uDt,LD* $F]ּ6apkyg{櫛ǻ\Z=uq""#obn~yq\ŤE.%{ͅ1Ȓ+qXw(N%*:F -E*I\Z;NuL7Ty[#MWH 17g؏R,O]ɞ"EEA 51XUkֻ5FҨZ Xkp ؏<-!OreYVEymA4* uH9PU|i\+=R_Ȉ.~cKفK;]b~H9M>Nʏ3XKoy=@Dv_~|O:lA"U?-RYEB;\e7&PTp3S.NIibV3Aޒ@ߘO0ҹ[F83qF״]U'%XRkáe?v F.[fR' -X똯;]LqH&h\uV; =9 ~h'Þ霒 ika@ˆ8ŗ D2OSkqr%a0#)E96t!n# %8r_} \x7Nެ1/)(mgqǽG+C&Cs ?4~1ta\AB+}exz9cr*R~Ur>Ô%"I.x B-\]9IndXaF{A=Fݟ4(ϡ˯LqF&&>~֜7ZkKԴ~h86FrYg=` ƣ2pGk]USpcK4ʘ#p 7a\/1bWʼnmG{)>E$bޘ+Jd\=jJmp _Sw8bLcQ5 2! :QK m?41xlxځLn#07dեh$źrW45ʆ@PDHj^Unoэ1T oJB :I%)vj᧼y39Fӎ #K7t]URT( ֹRZ;Aó,RX͝}qp.ߒž99uH6,$z>շ {(9;Uje\zPΊ=Vh뿓.m/, @flDerUecc!=-`٢_C7 'ѸM f v0 Cv}\uyRUhl\ei8ezno.%{XR6ݒ3딡.FBeZ.껖,AmD'scJ5"d? z͔`BJÜ k5qGl4jX&p:S|%ִ mn弣_0c!d,3:bQhN%$A7֢n,,ޥHUҾ|8иzp:[ xN\cn`:3;z=hHΌVh^L]0ʡbBMtWE?U[)}+͒kFM hǖ #Os 5< n~ C4^D>ũ[)V\zRGUT+XCG endstream endobj 349 0 obj << /Length1 2229 /Length2 14886 /Length3 0 /Length 16230 /Filter /FlateDecode >> stream xڍP\ . 4wwww'8 4ָ \  G=ޫckε)TE@) #+ @\QC†DIrWDtre!4qyI*rVv++7 `'>(N K+<}ИXyyr@f&E+kF3[: t4V..|L&vL`'K!Z; t:[(n arBln lAf@{WW{s5;@]V `eb'޿r6139{- [ @YJÅ`boof51}5t*ÿs6s9839l;+͒`;;3$@N@W=>\{w̚ GW6"?2K t=̬'td-~xm y;.N@_+!Af.S%OW1?@}cd:a`{[?1-{9lNvn/_`}e=4-c)_3Y8Y^X?_.fw1Idܺ"u6?4_.[C$Y 4WY5k3[=P }YYXul^oבK|ݝ(io6dl\''O$Ibxn9!03ك]^],NH,[:E/YSU vj0A 29#`-lǘl"'3emG?~?^3Ivj7k?Nfwt}J^\[EyOW ۿV]jb'ɫ;oڭtzfVVWW_tW"m_WůP쯑]L/2Z?5x}KZkHW='W^O,8^9quuWW~#W_ys]q߿:8W_v^|mO ^@P?;kʁ_B=fHK `3뺐QBwƝIY4ZF%N{4dꬠu_#}oV%iEIZU|fvڑq D#1j<9h@BvQ:c޺H{)_[QݭG~,>d2<9 #1ƹYRxz$"o ػyl=zx3Tb)r߼Ke2A!&;WeuZmgGAQ7vs8BGo.%R<`;xDo^{ws ZZnJkTb i {YlM)Kjǧ:ֻzacCsB 09 faF7Hu-&{jvS#R+L'yzi<^DISŲͤf'z؟#s Fkn߉ȭW̴KCN(=}gI_w$ؼ/t 3)Ŀ9U(R+RSyy[@np0/K"$D$Un,r/p)xV6JY8b#R}–je&gUZz^?~..'O\2y67۫91\]^;M%?{IѸ6OK{?cr`d4<&Cڸfcxx;qdVyîegW*k\xis7DH^'~C.+i5Q#5svY WWpֆIϟ*?5v.ϧIqhp*>(E2ǮEˌ҃tj}nv\K~s (jwX(̋TXdIP E <(6Gsl(S͜yj_I,ΉMܽG T-ᷴ3cӎR7qI.SA_EPgpY ՄS?%+v 7"{ctc`.iaz_bu8Jt@i#g`G.up!guV<܂~;+J>{iAxVdgK_TèĝËR cn2 w14g]u`&5 V=dϮ/ɍTe|)x6-&7T8h:92 R{F*Cfp?ZV0}ַQтL3pAQ񟬐$th_ݸ/3>z;chL@\9K g~O,O.5J-6KrCEOq;R]M M}Ά0!N uUZ?.amIyRDqeV"o-#,9˯d[(_ *%zMF Ay/e0;}Vp}(e+e>m4H5X!bFBuWŇ\ϥHTD!4x_ďA2_1ݶ$8<8I"v>.=Ff 0\eorR92b('|DTRwt i]PL|83gb t`luvnXO|4)gޢΊ€(ٍco|0.0 0J .<,v(B<.ZǑi <;, -&^ږs`,%LS57_ DS bL: >\:LBD 2%y40Der%rABxVP-=}t7@K>O9 VEd4"G /ޫ'uXI>BP^e(B>,A/*Nn~{3 Y ]m-%&*{pqQޗCYiƻ WSW*D>>Or\')b1taAoR—Qaf[}tl):;-NT𻟣p*#8jɏm I™mLM?~Y]vM~pΌ-bڃTg+Lo{mkw$8”37ɖ!@}D/`t݊6^ښ>!dX9˵0N41 "ȣlpiʩgM#V#Wx;ƴ}3x`#qN ߪaLKVixgZ[f$#0!nUd1EOCR:8v_ 2<`X6L03pW55^ "*4 ?hsG,VpB iLA KwLyGq_~b)eԞQ)7ג EϙWa@Fn:{QwLh6 q#=As ʑh\W&D`Cn6ط`NOy?2w#d|UypqmAS6u7~icѬ)` "K^m_ml%YFpKZ9,CIP1sDV dOo}У"M1GC8\xhKx_HɯkMgHXnAaAغ맰I_|I& F~o#Ns9?M7oRc{[}hBeGDv'͕ vGCL/W+qq)HH<mY*ɾM䌱_Cg|yCtRٞ{q @r.95ODo`GT:yޤiWrU$wILy+֛z~ibGt)=!@7Fq&ȄF$ #7'-08 ruKtYM6KKS, wHAw_"foDTIUl@7;qG. *ixӽg@ [UEeIJu9yV8oHiE]~'d#d-q^μ<7iϭ-= aFl&zqXщ!~Θ XᗬV80ȒTO쫩 o.9#n(٫iD/C#K ߔ^sE O{!t5,ߤ-hiMFETLAY`gY=ѻ$ъ.yޞmɍ(RS+KUcNGgtz$ ʽK 4:{Q] 4UV>,L~uE:-hQl}vS( SV{t8O?SO;JK9&4҆} ~*p[q{7tuC%o[(-IR3}߶&G?fQok}rMX3$o`7u]>^RՉdF6Kh^(JL* _|Qs_o,& :Jҁ~o/w*JN w bwV`t7!;O8`{7 I'(RЙS{`~C eG:5w _J}c- Iq-͐2h+}X;*Lk gJ <2hg-* d q5 I9D]xEOR0, p*anG5hG$Cnud*i 'a=(>y_ ,ۄvDLV9z~c ߘGnfKS 9fqt8DRqoܫFԧy]e~ >F,]p|4.ޤ WhQWxcmN AE)_JfJA9.^ %sAaPS!۷B8I0xOe?BL}]o2k{ I_Z*mo;nT閱g&ldhéa *ͩj퇻~"'4x4&sڶ͈$f0tZ΢I\ e Y@dۇ_xĉk{^5DC<*Bƥ{rFb$V%s<(d#LSCt 72MSMM򙲻3!ByKKx.Gbe軐 `+ }uFc0$Rj%wtJxzI>hQ2Db)]Xz;A`YQa@~4}/8=NSTk9~(R54>~Ρޒ3.g/`CRJhcW~3F.3\/*+=n07u8WaS?^J=SQa)˯8C&ߑ^jn7-8^ W)kNpɳL\G(<)x} _ ֶY^%4k뉏 fF*g ̛|m \iQLa07؛I"+^ћu5L42m]K*|'xid4 mRmuӷOJ7u$ }; unnwDT a2Uaof:,BOTz%)|6vݎ*JA{\uu[;W@s`طML=/7Ot[H5 2ӠQa[=?*`N?ǭ;*zJ&~iƚ!YvX~wTȞ&p`JIiƃ"km{jqQX=bvtvrȱظ ,*4\B4~b5-rFȣB enc,ZwL8r4KH0`X1/3fޞ%Ӭ\vfF^lZB۳I]u&`=lV(H#ͥ~ t"B;@VENU!qfS\~Q1889;,*(t&G̫ĂrZ9#קʍ ߊň~'w-:6 FV NjJH8SRS6yLʔ~{Pdgn7naרzeI.Ӌian 臓`\aXg="EƘ4F\1^攙%T6lc*iRExδԘ.5\ދP$KT"yU(&=NB\P|0/cFZU T&^MJ"QȢr1O+ -UD#/PwiRF6R پӺx 7,%9LWV?!CKc+#)y ԣ`Wxw?bJ˵ŎaCV ݭ)G snUr}!洈пlsK]6 nsO9o tyMuuS!'Ș5 aijqgb t}$#/ݸ{jKݽݽ|J({cB%*N汩8 $!n_u- '~z?"lj.b=XWCDc9-/Z^:a~2܌ݤIӊg<%hR;R c+_[/xR\F:qZQP?Ho; ]9lny[O`(i#1XzC6鑻pcD$7MUZ̼f%޷Z{u"?g0L>F&|udw"7v糥Yx< h2z 4,<JSȲZ>519;ӲijpWY˳.kRP `ÜΫC$=iK\is' 1J,yZoDɻ}}hܔ$AM6zpΨ0ɾQ[!vJ,1F]B3|\XGMݸlXuwxޕ!|W2HjzcvǟɤrDk[OyKqԵ3#MD!r<#zۿy>~0ؒyb(cfbu<ًV).Fb[Z/˾|9g5*'"^iBMWpT]M9viRu+t1Zf xû QFp@tk7s HdEEG?J"p~-%+wx #`Sox$Q:+pN#׶sĸ9 4JM4޸(ͤRn "PB!ud0o8E=s -N ݡ4(?\Ga2,+>CSXmK).R&$vzL?<de ۅrF_Wf T>5?&fzlIi[=aX4wf% AW_3 C )/w)t&pl㫴b}V%'=虋y~#jQpf I_t/ЛHgty d66G,\RsK E[|aأ3ȹ2bG%(k@;Hi NőG([Kr}E C3E<| +׌ÈTlRusQώȪ AfOå7-GK:f7F?=$o7ﰓ)CYM^K~ n]nK3 M|8rtn|yʈ"cCQ܊$ ;|Y QT6QR22ھ0:3i qgrˑ!kKF8 )KM7BL=۽ dJoY(2}-&LNC5.S2ծ$.,eF sI1hꪬ<=Nn8^^8ςOMU݃,s,.VvYKwvM@"wHׯϝDj%.>^L_)amYe4A|*'~mTV0ZC`]\ ۩D+?n]>y fwa%`V:$D]WCgPyaml5[gՉa?Ɩc|8<*_v&4}.<$ >dRR).1?2>s͡&*syFJTDl5Ԇ7Pl5٨ڟst_&ِ"􈧃ۚjW%mw*J[ li=W)V4cӟoͬ{dݪY?CIEMCoj\#̱ehƂ֜go<+&Ꝟ>>Ä4Q0z O7(h؋HUWg%œPw])M/`Q"C.!mH !kMӉ7CBrIwRrC xoܻaﾼE$ K#q~&IDkU} O؅ q!k}[R}sLD4izq7&Nu<[D'?,Rcr?pY$jm @ FFoT kYH/ECuٽ^2Qd )6܌ ђ\R EF0zײ $KDH񊻶ɽV:gi022" &}OU_.`[s:ΨУbAo&0Ih*XGlۃBX{#QQ"_1+cPD;]b3+y'è ĴL(^wOe̎;$_GHJ_ż0Rj[5(i(څmW&(y]Nwr*anaoIh޸X]r Vι|9 Y{)M]iZ{ co^\&(PZT!{` GBj.CB裬J6FKOQtz&q([c."%46wUg 3m5wܑL5oS)eIE7]b1<5Yo~o<0aп) ˜J25s$x2XCvp ! 짖\8-Z.*Ki 8޲OB,aBJLtNKƊVh) SyKC*dUjmp$0rڕF}{WSmAUYZ·r*%EqL J#dЃnn32}yD H*i5) 2;>z䁑c|&2|,fR=;i a\uNtG=FQ0_mo3֙mx+I ,1bo=֦LӤ2w"eRI\0u!J2XrA|ssn]PN/wj]n] b~:\LHsJh;6k} Һ?pQ&rW[[{5CNAY5C;1k)";ncBJr,憐K=!]#ENofK+INTlE.bAi]p5]9SfiLLFga'vGOT~1"<,0^~V9FB&kchH:)R-s9,^/cQ x͉tjÛu٪hV8}I?%#d s)Ic_G+5yL,}u!P0 0/d>Vk;o$42 4XQ8 υWfS}_85wZfR@biESs#d Å)]2tjU_=Z}_Af܆ ٙJd! ֊5$B9գ]2JƁJK0F"T׷n- +,rZ|3Z+knM8_kC."u׫Q]33[dEtn ]@5HkIGREyHhWNxM*nT{|9jh@6, ̐5*;J/(EO 1S'OAWs.$+f07]yyŚM'js0 3ظ뙿][KyO?Ҏ) .D3~S*.(!g@lӕhטW#X@oz^bId(tz,dd7#x:> 9]OR>)P^>bBgw& VRv[KKPM+jP0*-f> 4@$8܇o(| w-oG]2 .r=~gG-$QѳQ96;)*FҞ̯NWR{s1 #\X vk̊d?5^*Y&#h\KV@hSٗIϖ}"1S]SAx|"*3wH렦,Fo4CxKĹz>JApxeA4IhTo ;Ppp #xG~KGH(QZJK&j%yە+ӹRA0_gW@ɪBAf2G>˓ 2`kz/9:ą 9zL!{xH0h<\T=iw-rO^E`YTgZ$JB+rofwdK>\%{țRv&!ψ(KdgpzgRJՒf&K8ju&֯2nu.S}TeUlMPȑ{mȘi;j*2FuVW9xM_Xaj0PԼC4}emϝ QRlr+ϋ:{XL^kl%.y >#93D ;kus,'F Y7"Ȧ:N;3b̘Rf bN5 \fR1G1qn5e⣕c&IjjKsGGu!ǭ<*.Y,L7?k 1--+rCa_PK'EmBCiu7[?(-<-رbkhg /3'pfƧ5ऎ|of1wWt+^ E(%((-ѲP9!fjjQZ&DW9` *UD֘z 1zv(Oh ,Iꖻi E9&PG;G 0JzTWf8F m >6 pPa`0#evB I4#Lf\}5 Nal YУ _?V;k2.!H~}C'-c\ǷG%\a_k ŌǬ*CML/27=Dfc\~(5b?hr/CJw'PF {i1vvGn3g xzIRlnLD,—hQ7LΔR'^,@n>z^X'oX=;#b1ܪ59\ϑ!.g%iGWrr2M-[ꈃh=t6#GjײcSi?p+f:40}Z[&Ud;cU[\RQ T.$ wPԚM{\י \_z}p]Gڃ% )hge)aH@SCbC4]#ktQ?膮FgR:ԯp$9+۽eٺ#T^48=^De(ioeoJ&SətCO|H%SԒ'<n1: 'K /T.ŸHbT\6\=Ҡ8|OPC'7h4gl;S>;H`В0-B3Nw 5xM,uASկsy}ʓ$+ EA8Kԇi\'+rV6,De j"Z,mȲQό LCJ쑉Ae9/w= P;ǦJtr0\df1滰r`Xͮ t"0 u'rk7|aϨ)q~K-dU~@&}j, 4XGQPol՝/fYϫ%.|K]-@/rg!Z76Ǯ(Pq:0LBϡRvKL>3:^c~PpYpCz0SW yrg 3I]Ȩ ]p-ԑ ~c!ݶ+m k%mDU"b{$^\SO>(9ꥰ==la2|  7|L:ٞ*)l440\:?-1WCT'}~!6e-CL?l&0rLV)m3rv0>[*GrRgccYQNO@^02vNkݛ8NhF&{[ endstream endobj 351 0 obj << /Length1 1537 /Length2 2945 /Length3 0 /Length 3917 /Filter /FlateDecode >> stream xڍT 8kO)LScA2fa.;ŘyL̘Ő%[tD eMc([DE*Rزft_]s]3߽=~{l:DhHh:gnk( 6nLNSlȦgCDs: 0P"VVGPRN3}7+&tȂ _&ŝ̆| h55p@dRx`gAO"Ol %&f#\.WR3ݵ\ @Ȁ\Ml7 HcA!dPu dodoy`ptˉ(`<@di;@PALÖ42Oeѡx7BŻA񀡎5&\E`RlB]:fQ ,r&Hz4:(4"iy "Q8*2~A6EP>2r/\q ~ : AcXxo`39`ώ_ p)4؏$}3)> @-wRN\1o>:?N]]@(jX ,Vxj4P,tJ^Uz~eAt ?d¢J,UȐCeI2 rӡMj~[\sHxkCCss!$ZQ6JVteeh_>h$@'./ L/ ) ~hhϊΆBhDg–TM@M+h$'O I?AETH/ =?T  i B (g2?dBDW^ :A#dIXb . FiS9}G=iktj_ Dο6Nljw#wvU'?vhae 8*҈;q<{M iJdn*}) (6J'PNۋjc)֔ /74c=s(.K obRM]m:X^eXUl8vH6r_X0|Ӽ|L<[ܨJS\–fwz[VgfaP3)IKg"X1\;A,څIާg>L-_N51*۴eZ©M2>Yv, E<0u(Wݶ(W+\7yF1%l[-ꎳ26mXm>5̙~`YS0'@"_VH:y;|0[ˇ`7&dڛ#K4(3[2$'e)jLY0w"Q829hv|ЯpxԻ$wfج cUIq_BjLLGv#hIm50yӠ#%.=޸;`&x}%E][buYN»Ȧ"q8]&{ܚ{j _f%5}Hإ҈ Z [r=)Zw^833nK~n^g# e PcH-m~V*Y8*s-ŷ {P."eV◤goxbGdQ`7ɣｮsC>״5Hնj6L5G >;vJj;L+4A4 7Kly)4)γ^-۫n~AsPf k|~[9' h3[ xrnX9QʐEgl9m&lH;J{ʲ9e=q/JǤ8t0zL#}IDN< hzŏYr(#E=Z0:k!b"%]Q'<"j(99V{0ҕk\`2S:X%׹ml4'!|젴 3/>0vI}sA]w m-1I{2rx*QT+)z%z|H ۺ&KWk<7H&M Ʒ Kޑ yha-dЎPVV`fhG.{pexΣ%^>Kv|@:1d-DTbLIǩ:anjd5SJsdt=bbGs Yg"eO-zL9U1tg7lΘ)wwnҊwP6۞ǜJ5Pa'?q5xLUL5J#A⡥҉'xvnƽuϬ I x'Yz~m_~a"cH=54rBJ4?/WظB=\Nn(uE{TΖjL5{2 )U? ɚ[œ9gN5G7G.*?.գO*t/*LPu\5qX{&AR+?߷ endstream endobj 353 0 obj << /Length1 1567 /Length2 3145 /Length3 0 /Length 4139 /Filter /FlateDecode >> stream xڍT 8m,) X}y1-ER[ْJ I(^޷zkkf~ι9&8"ҤR4P35Uh94ZD 2Ì@htJBPA iSLv#9Ţр,7J;LdT DG ը.^4ށ<￀8A()p &@d8@ 0`[ c 2T )f8CD`a@tw&@0݄Jbx4`0Йn"D&ں DNN~`I#z=L  H) &C Ó!:$өxɠQ9h az4)kPjTgg #Si9v/uP=(>? IM\Pf VAa?mGъrhr Oj= ĬP] &At ;B`0&0; ~fg!w̼| X?"R)dEjjkK~*ed#򀂒{CQg6D~!K,ZM`~ago^$4 Ag)=*s (CWV"nj3@(5aOh3n6[_12L txM1h|̽"81 :S.6A!P%+4@3e$+/`H<7 d(T3`v4*PiW"1 (/P@B9x80ߊ *(Oa,Rܜ֥eK檠# TP_  ۔n4ؐ1s' Suۜ_XVm!KWs,UV-]vOJKX*%="^6ZPD{toU\"_]Liɑ զ6MOJyG!G%qkU%*B~ᕽ*KfVկ>Ge3k]s}(S:{*Tjf@eIp8Xªj9srTOyIU4´o/g"^u~`r8S0&qJ%Cu901w.ac2l|O(=t߻ko˃OW+*l2 ^c{=9Ȋ|ˌ}Fr#CPA5^Gy+7KÍQ*uѶ-&OS+CȰ4mQMquFΙ".ED's~HHQ(W<bDĢR="eZωC{x=n5q9,[>pUd9v\wgsH.!;J޴w| hRU }+힟t3(@\>)*H`ю?9f/V#0-ӡ8|󏹨fp=( #uAZv-cX}_<_^ M-XPr-OSJҌ\7汯?*sн(Gˎ^9"vӫԥmGy^ʃʔ*L z~{]cg a Ý) ._9qCtH'۬ a6,=_ u3qrz2Z9~oY^O C^~MW&Wim[?zR`OQ^܁;q|,6ۏ#oTO^ШJG±.c^.~)r~Y ˁ=_-lBx'65\VhSK^hV'(GRw=&NE Z^F&Ƙ.}m]xLy,6ľʒ ziLc&pVϚ !$#+]b-Aߦ-.O1>iqr)H/bx=2w5?} {ZSqPz 6sI`z_+8muW÷goKN7ďnh~ֽ[K Tn7'^M>Tt4ZvSSʒ"2np@x!/I#]JRڳ{6l+1;!J:Gm ϹNGNJH iΘW69%*V,m4Yo\ɔ|/Yb "\IG6ft6RR֦~ zz"Zz~EV|x{oL{[+6"p[oRmxFsi􃒵[:5G)"$F#/sNTo{뼥vM,&n}W Քo-z>M֫Qtߘ8Y>,+܉T{D?Rm sW,pgx ]*eEk5p!W[1_#z_.n[љ`>k/' 6"bi8,RNCVs"DW]1-z3sɦZ 6߾mnDʾ)dWIEn,~`. endstream endobj 355 0 obj << /Length1 2788 /Length2 17759 /Length3 0 /Length 19348 /Filter /FlateDecode >> stream xڌT[ S ұiCRkҰFJ@:n91<Ϝk\GE ljg 102DTUyl̬TT k?4":ΖQG̉zrvigk v1#KS#@H%jghinoLXxx::Z@@G#k%o-@ {^&&WWWF#'F;GsWK@tt~% 7#"@o^ j kK)vP(mV[Om,,/C6217u5YZ  7=1XȍJ#pdhirbt"/3*ۚmANtwgl\m=ff0ugRtpJs@tL,~Wu%giog0'4 z: Gg矂"D ` 4EmL;Zt`z2vWDdU_`gppkD 5+H?jזxf7G\u|6_7F6(G9;Z:T d^a[sh$a4UX5jVhdN003 W&V{ <Gq[;_ 0rt4rGd+@&hk9"j('I7o`LbI_ `XL#Vo`d#?O7Sq)F`ʿ؃o`R٪F`؟濈ѿ ,3O{XV#'KpMtml7X9Y9YaNh 4AsC\Ze/?U5qC4⿙bll~W׌2Q;s2 x l.o+` 3K?9Qfo'` 8ߥeWhO\Ip`k/##oW`[}]k[g_!&Amqo1؇=OYaj6p?rYn(;$ar/ t6/45]"DXX&h >crXw89~](؈7pa,~?GL G)`οƀuuM3ؒs՛8; -݀&sv&|AjZo ]5R2x.:9ߣ%x#8؅)w'æZG8ą C᯽D v ۥrQn]{޻}-] V)X:_f+^gx7RԁOG }92I)$;YR&0b3LTT|3:7,,>e 3Lf-}~ mOֽ4~N~0)K})꜊c÷̃"U 7$N[h1)cyZ4Bn2do&})vnqu~Ty i6aB+JicٔIKxAn%rG3lP)KS-v\4aʹA0ڐ/&-祣ю[Lՙ7Wǭ+]z~ "חR>3qy~a ySpo2ɶj::jUha dܷ4i(D$LyP\$ݺ5pwLetU@ \>GYS`И2;Ws0bl;Fx3aNb웦7VRKfuζsj㣽HTԈ+p^r pg}<3)qqI mא)69n#9F2N|Mg=-)ϸ*û}\@Fw9S2@/tQ=m\7ف8xnRЌO}ߎacRվwuFiChs).qhEjP;V\kL2Ͷj\xKԄcәQuj̓w,M\~ytћdĤH32`m5rn5{׊'+H"w-}(EKփ] H{bK7>VQ'8C8p~HACw߅#P!W7..1.Ɣi`N/[MK%ngY}Qݦ\L|()yN W?^:E)#wb꺄N*+Q*ic!/݅FcE1/P)c%k倦 Pupe3>P=gA}rBх!15"o.2'i0\{׈-ý\!)O`ǗzzaFnmM}{PiVgiK$ex-E1 yaPO5X͓ ܌H[j71B{H0Io }D<>~2iO ;I4WHz^DWhd^WOn HG4 ^=-\un=]>+4s I4T&%ui517{r߈e&7$ZYv)EcXpocn1MM!w/ $t`(I1t|=axqI?3FjW3:C hj*b"0k|$[D.`m':J?ߪR IrY*ϑd,c^|%>}bR>\qF1uEXܮ1g@AWlD+ zԁ [iyKk^èxǾjtmàvS#bSW o ߐVK^4i*xZx'b '^6 :[,=߁d" XX)}b9^yD5P+Axgh{m+0lĶ_\*.YnalĊ/ X;_:X"wEHAz>MVX_ {rC,%!}z`J>EoM)doU ~Ϙx t+ɠR} \}м =T{ѫ+8%gqa HCF 8t9,s\jam^[8M3tlp +%VɲY@[;` )Ez2VZXSbThc# ~]Ƌb_3R\ b1YSR`ϻ1j zcT=Hxr}8 p% /<(xޤ%)af;٧LT{q-DJgh<9V%4hv0^cM.Ϸezξ:?_+by <'*AbSԪ蛜&Q+iiQ z[ٮ|_Ly' ϨW%ك9LXy֜/γڪdbg!vX?.jKMlJ7~RjM .2 S#' vW>s#r=֌{;#Rqbg\U>i4> G8Q|8~ e,TԎz[ "&rd|[h]{8fPK"T1 ƺd8bg_aޘA"iwR1R9SQ'MuWzb]]H`S:P;eN+ %͕ ~eM{BjfPGcdҼ!{{C4<թ)Sbkvv<7t-ʾnjr=aٸ5Ȼ坮ZJ/g]F4 3_|d?Ln$x2i n94>[Ps9_R/ك6d{ӥځbzO?03=wvkZu4X`8Uu(QgvSISŪhۇge|tv&]!>Ĝa^y+tE݇u-af#/OȒVM HBHql]LFop@m8?X\zbO au2q quϼJ cgϓnGE4H_rU\$uf$ LU۸w̱{Ϗs~X'3& 8 [Ƭ-n8oMTGe\cdLmGκz|g~Дݨb(ÈGP40ƒdAGv@ !ʕ:-r85%iWj,kĸʣz.0[ _k9? &-%;/7R $wz}/*0vj I%Cw^@nstf+D3Z4:5zRwt=3 1w |OUZ+޸4*"f8Ӳ73[ h6_mgSTlArÁD7b͘lx{ bvll% 71lҚ+O N>َ-,Fuf7w{v .\׾+:S+,T7fC۽JP\Y0E_Hq5*M;68ऌ~Ne3nSɴ̸LƚM}5KW4B5 eȇQA*c'Ғ,?Kch%v^9.[PeNdnEl  iYi28RP˸<.Qt+p\h'c#k3ܾu7\^J>D`qA1Yr.eˁ hRɻ,OvSr?<[=EoQ3Zj8+!\+?)T@(Y}MI(s[u/ Ern?OLxf\?Mʾ=6LGVÓr[rֳGKd52O$o)EA9xU+K-5߷ƺЧeH?D~;5z (!)QuoGȊ#CljXK^:*.@^=* édN;_!DMwEWLâ~;RfE~ 2۹B,D] ["G#;A驧X|{ (s! M{κ])\pZ^\?'Y/L3N1#!{?%kڙU`8lC@KM<{CBm^,*S~fTU ʂٲj5~u5d.8U9zF>L |׮9C#Ռ[҇%Qϧ={3F3y~.o$* $/©}51Tw˯%k%{Ied_<60ݤ5fkO{&{ +2LHƭ)(h$#;!3orZgj.Fp -;سRb&3NW֢V9/^g=UW*`4` 93ml, QfcOaB/k.{.>]ȏg l;YƧ=>YgY0V3~KF7">Æ[˥:Dk.TDHmRR̫@n#]aX+썈fE7Zc P`⨿4S~)gЦ9aװhm2@rD/nGH?Y@̼#s>H ը<|#?^3p΁X{+J,[*;i0]muٔ^ʗG_~>@e^8vgW̯Fgf{EtkכT38A([,p35˅@Ԩf{5-xʍOcoHg}:3] ʤ/lܬcmyw@M3k0+}Cs6BNj/y0BMXa7mnc2+Z2#lH1`zX2Kn%,e`9Ȭ&XY-q.J2~8Ke ϑOf3F7nhxCZ:= iat?Ztj@[⢛~ijt#ġy*CFF:dj?W E3EL:"il,vKg*n>w9ͤ.I?GۛXO6giRs-:Q}e3 f22IEWyfV8(%fR29s~Ezތ>oȅyAϙM/R-Hi AIKnK&G"i+ova%#>&E HEc82DW#KH N!+fgtɣ=MTwO%Kv\/"|F|Fs]Hl3{w(S2~htHU>h=ZanNnwJ[ؒH4f뢵9Q7YBZla;u߼J^b'RDa9!|ƳԞ6Bri* wQ3еڀR-t6/"$8Lva `n%X Bgٞ |lZQ!S9oرX{HWMñEy)cy. }V8zH)[f=F K~5MҭjVޏ4/zr?07J@AJ3zvh(bby0l0ͲBiRwdi I˨",Q %ҝwE-6 a9~^p|q~##Y!ǐ"f83MS 9f$6TL5;.5 k_{a8j[Hٿ~!ُ F#`> cx~'h?=DĨ- qgpzs y5BG`m};4@ܸv-2H߂>yIC^︀3͸4irrԹ0D\ z^H݅-Q|q-a]==UFxy'@ AP|L4Nf@0SveܽoC@ uaZ7K6$%"y1h/Os})} ُ0O+c,]VS3P;e: b!Ұc4BW&ew%mVze Yg")infȘx+ Z2͐_c/PR lPމ\fhFdZ1j#ⲁ2Ic#1XPkdƽAMTfj!vql@,D`dLWMOR[jsFsRt7?PI{Фpm&6f=-snǝPuiG~ NPNX,S569X"Gf:!qobBt@-P0zv8{l wy4UXi0"z*t}nFI?@L{&‹qɆJ wߖЗ5q\ YWk|e)*UКz"ʴ+#w(^23RFE:"eNޕ,[O20}"xAj_55qvi4u(Evz~ԠnT7%C߶H ^y^˕p[?B`פȘ/ޣr"+eL2kȨ 9jx*Ogخ%7aT޴e-UDk6d}~bHMV FT˷ Ml= urW]D=3D>y?4#fz 6. Aee=<[)+oCi rVÂ~ ~vL=N8[L) $d%m,dNc%ū+鑿j2/#l.+,z)*sH:DR\n#G@_K =ٜsB m^_9զҠg&4)ؤܞ6v{M$o׿籠{ t1툤ǁbBv-g56&4ENuX!}ybQ(5uևkff{/N%oLٴB԰H7"B3~ͥٺ q0E3 wu, 1* yU5y\J9}„6v[rݚS45EHvNG X5>=^׆j6laFc(/ #_q%;KDže3T7O+N(أܴ[kЁ<_iCf2lqw0DNj&e8ݨMm~567Ȑ]/GGlh~CI8>-ώn*hȂr?n#q?tYC(k?>U}icP G`5A2#Ygcdt Jl؝ 4(qzuۈehpW mYRB7繫̌"nS3wmg+)ZIѠa2Y[J~k0EBbW60~MNaA4_sPx~2t O;1v[쭏&)W#PsҮèaKh{;ZvˉGMbdI%e3p Nr1Iཱུ<.x9Lby)>ڮ! "-ۭRaBH;*W( ?:~*Tmw@Bo^p[U7=(Q1<'k6@} O+fˠŬaCՅ0vY^Τ&-,+g>XQt7d>@fqC|{C_Od:4l$ . #0Jae$ƿ sM+8r `f40G 8P"=?ӚWL~"XvKwf-D[Lɹ6EѸR=9y2~R/opÜtYлNiǎ# VcY'i4&fӭ w!~?8#tm+N?趃|(>W̅SW_b+'kP,?kt~z$ RC`!"]NƦ~NhXz%tR?V`34Gm1#/,ɍ|HR޹Pla:n6e)Gqvì2iu! A)DZa)<G?x5I;-aRsЇW)Pjf l9%`(68V襏GHѪU8Շv8g.W^au*khp{ #:l3DJNs&=ɫrt뭷Q.r)i(ճ5>HBV3ަ슏%vdҍ?%Rh|'i=#629Nk0ꥮSL)cvˬfݤrگ3wm#K[q"M.EnE_pRۮT$* I22Zy7qE[Y/:b_$]7뇫tɲtOV2d5 ,7\;cihjS( d1hu 4NؑW}Wyl= VVϗwϞ [Mm#%]SN#$ZE:~Y{p`TPtEw`+b10"ڣABM%IWJsK?T/5& ];浠n #܈;n/N: 걐"OJNK֢1*fIй :ɳ c6AUspG,2z:kj=MȌ$x"ϗ?zC9!5|84C9ּ̙`(&*J8*rZ("m!ՁdH+޳wO*)w+Kυ5՛0b.2J77tp0ߵvPxDSֹSĺ0mNd=JaYG":αjV$\ a|>,x8X0)`|LY\/!ct毘myD `^~~ɶlt[',8+Vf+SAVQdtܤbGQ >,qCɟ)ыydHjv2`ag< Q(v4>A?ܖ6υyŰe6 ktGBE$GƫVf5{ΓjǪw)I{-3+.Ea]T a,i9%¬3ĕ"2je nS*M\E2gW+"=6 }B,::`/#4=6.JU tgw;-q1TaJPX @qE׹~gz2)'1gtxY$bhsۂf Cœ9 i7sTi`{_u_+؏nM .ωО7*2n5/-35Lyד"(li%R}pUFs`&%Sc bѳW^ ٭S@*"b?JSX[5x=vozb4ㅾz/M?8)D^:h#gu!DP公9 OIGRvp -BMRnWCTnV?O&3")Ȱԩ m5 Pf\0uAsrx8#涻MJk1|N-Z3IpBvHQPN]C rǣX=VGuܧ-h0WA~a,9z3>&'tkZ Pdya8>mɕL_-~ VuF=/)§`dR((Ŏ0XD"v&`5EN/yA7c"xQ@44t^\ ?tkॻErPFU:?H03,=j(SJ "۷G;"O>$u h'ECYbA$S  @7<zB*Ix$JbtͳD ‰UMцV_b20LjؒM9{햦T9حO(=ÔXN>p#= XߠxJd/ȢaX p}nf^À tKY;V?`2SSb7CA W`b3@IČ3-?tk6rjV P&5x,%5bKCB;r=Lǥ{$!SHz.&іH,vRF=znk? ng#6~ſ@׿6 |agv D&-ܝal kF9XZ}Nk*wM$X56hW^bS@#-;Q9QuB9&WEv00k8,l5p$6Cxb>d +p5^#^kl}c*L?cC:=FrWUBw tLjH7R$!5x*ܟv[3TgM+޺yܔo1!m#Hz|/tt_#?kuOntWpHfVp{Aޡ/|*j(;ɢmFp>cDL endstream endobj 292 0 obj << /Type /ObjStm /N 100 /First 909 /Length 4335 /Filter /FlateDecode >> stream x\oF;D( 8q8vA>(6*[$iǒZRmwW Z-,e&B*W44c$|kߡZ׾J*oSZk_H- uӂԅ.BDrYDI$t(`4tb!C-A-= k t-I  fhW4`b'Ny7JҨ=v́נVQ{xEY`@ЦtuCؤAp Qhi <;=ZLAA)J0Cff(H@\F@zD`-AO%H0Y[bzȁDRLy Q0M-q>g#r ˆ&IC@-Q {jK0YYs0ҨQ@& 8\ ( \@;u눻:FCD!$! 4;PB#Hea`8 =b R Z aQ{+joFrQ|}Q>C[:7KEvlzzT-Ey(otU7F_AV9>(zvZ)]~u6=~+>p`#`.9{48`H z@~kCYZY3 7[ZZn[lzoS~K62 |U<=v>? `k3R 6DCle-A#B+0 43 9]1qz@BOu>R,bY jPÐ4wYk,L ,1d5pH̆)Gۍx@ XqZY0w_Ղ< ܷ]Z)ܦݧ݁)5GkyˑxyxPT`J`rx}RR^)TnJ⚀k EGWԆ`qOJrn7s@ '~+98|Fp=; ,[&by?4RnMvCv6׍d6[4lJ E*j)uqk, GMLR ,R\jj 8#rVKF> vRF4vMt`lܘeO-F%unoV5]?*۽=6IP{_کrwZNTZ5I ӆ1td_Mjt,"NyCTynmVӽL,\AhihA@̒7~=mT-y$W65Shzny`dwsDBh?[-񉋆<)s6|Q+oh?Q_ǟ&KkT$25TMFqhz7kx6q4# V#:c'# :e$ Cby e&"H[MqSEwx؆!H:ܺ-2)}ޓG[^Z5 kh1_R=FbN`:DM 4i ܕ,҈!#4?0* 3snRCߧ6 RXq˲pթ6݃qP9<Vd i?3X1a><9s˘utJ7Uk~ $`F=\#cШFv \aO-tD )<{ȥxg3HSjykC:OxCsX&*mH$4T589,]㙉tlx#)k.l -۽1ڢ MOQ,- 6I Ӕt@uGꢓmGR;%Fvzzy]cQ}A'095h &l:<+CnqX#:g}yGF8U"<⽢Z<Y;YR]cSL[Ogt?]Óýot;)de^xB=x&ʝ)"P>]=_2Abc7tˤ*ѢA.MxfweUIyQ^򪚍g嬜VU|6|sMV=&k4Yd{M)O]0Y+_›x[R3sY<~kP^VUS@U&=j5v)FH6`s9jZ|awX5'?FUIyQg=N^\fXVgyA_ %^W5o/$z,0jr=//.O/WcVu^}r>A۞ʾ.*fӶ&.{{x\ G^X!nN_͡ lA&ۃ9"5D6# %IX-CG?n^2qxнG_6a6jw/hT`Q$z|(\zh] z^,SX_;ח%~ kҖvW{ƞP&P :mFɛWǻdoOzvik68c;_Õy?]]'gUkªьi,ה6?o|>e:`]#7o 9Ϊg_^Z%+sV{FƳ0 ^҅Td|8;R>sw]+x<17z|?n#B wtwo/ҷ^O3dFAP<9P2]tͿg·^?/N2mwŧdXFc(d$;܊dMMun@̙? |'H1ool13q·Ơ3byZEJ*rHc8O! SY3e=Ӈ>%*i0loؘبmn؈lhw3]g:ך/5heF8~A565GbmX;lrk@ `S}c>yP"mkmMX4h6ڵ.XQ"";M#7k6 :9f A^lxtȨ<[u[d.mYZbժX"+g^9eQ%fI O8D6Ku,:> endobj 363 0 obj << /Type /ObjStm /N 16 /First 136 /Length 813 /Filter /FlateDecode >> stream xڍVn0+xH._2 mEBجq In$,= wgKJ`$ bR)gôg,hs2!e`9"ELXH&#I" gf"E"X$'I$NN fQrݿ[>e1f⾰c&{1 u7P^ɥb*TL?|=ƂBmVKUǟz,d={;='_ O]ekOS>saeBLzt# @Qhj!/aqy$b0.E ,lp%%e:OBa]a%25!*4C=*OH*U#ac pۀ1B {L"d غA]>",rDž^;r'8S/Jz R…=MM U .KE7Ò(t$*N]mݺG7%b F2"IŒ^x:탘@ `iuD6=%OJVd;?u_.= KߐCN\8^1lGՎM;~ʊj8Dw4;h6k '?+bt/ ޽ <3849A2F48AF5380C653BE06F755FB329>] /Length 947 /Filter /FlateDecode >> stream x%]LeƟ( ( ȇ(ȫ( b$ޭ,*fuIk:rNyԑ6:Z˓߮~ySJ,,)KJ xϠr NୡJ0wIUT(n poU eQU`XŻ;79e]o+5ZPWw;D4M-RxxW(>Y2+&+P v]Ԃ:Pv= 89A4gHXjUVaIcuV~۪]ٽqeYu*{UrV+|nխ'a|ouDo>Q'OU`է|oVÜ\LʿBT-2b `E],̴L@A7}}1ϱ endstream endobj startxref 294229 %%EOF nanopass-framework-scheme-1.9.2/doc/user-guide.stex000066400000000000000000003243731374306730300223470ustar00rootroot00000000000000\documentclass[letterpaper,10pt,oneside]{book} \usepackage{fullpage} \usepackage{scheme} \usepackage[pdftitle="Nanopass Framework Users Guide", pdfauthor="Andrew W. Keep", pdfdisplaydoctitle]{hyperref} \title{Nanopass Framework Users Guide\thanks{This documentation is largely extracted from Chapter 2 of my dissertation~\cite{keep-phdthesis-2013}. The user guide has been updated to reflect recent updates the nanopass framework. Several example passes and languages have also been replaced with a more recent, publicly available example compiler.}} \author{Andrew W. Keep} \def\TODO#1{{\textcolor{red}{#1}}} \newcommand{\dash}[1][1em]{\raise.5ex\hbox to #1{\leaders\hrule\hfil}} \mathchardef\mhyphen="2D \parskip 6pt \parindent 0pt \begin{document} \maketitle \chapter{Introduction} % 2.1 The nanopass framework is an embedded DSL for writing compilers. The framework provides two main syntactic forms: \scheme{define-language} and \scheme{define-pass}. The \scheme{define-language} form specifies the grammar of an intermediate language. The \scheme{define-pass} form specifies a pass that operates over an input language and produces another, possibly different, output language. \section{A Little Nanopass Framework History} The idea of writing a compiler as a series of small, single-purpose passes grew out of a course on compiler construction taught by Dan Friedman in 1999 at Indiana University. The following year, R. Kent Dybvig and Oscar Waddell joined Friedman to refine the idea of the {\it micropass compiler} into a set of assignments that could be used in a single semester to construct a compiler for a subset of Scheme. The micropass compiler uses an S-expression pattern matcher developed by Friedman to simplify the matching and rebuilding of language terms. Erik Hilsdale added a support for catamorphisms~\cite{Meijer:1991:FPB:645420.652535} that provides a more succinct syntax for recurring into sub-terms of the language, which further simplified pass development. Passes in a micropass compiler are easy to understand, as each pass is responsible for just one transformation. The compiler is easier to debug when compared with a traditional compiler composed of a few, multi-task passes. The output from each pass can be inspected to ensure that it meets grammatical and extra-grammatical constraints. The output from each pass can also be tested in the host Scheme system to ensure that the output of each pass evaluates to the value of the initial expression. This makes it easier to isolate broken passes and identify bugs. The compiler is more flexible than a compiler composed of a few, multi-task passes. New passes can easily be added between existing passes, which allows experimentation with new optimizations. In an academic setting, writing compilers composed of many, single-task passes is useful for assigning extra compiler passes to advanced students who take the course. Micropass compilers are not without drawbacks. First, efficiency can be a problem due to pattern-matching overhead and the need to rebuild large S-expressions. Second, passes often contain boilerplate code to recur through otherwise unchanging language forms. For instance, in a pass to remove one-armed \scheme{if} expressions, where only the \scheme{if} form changes, other forms in the language must be handled explicitly to locate embedded \scheme{if} expressions. Third, the representation lacks formal structure. The grammar of each intermediate language can be documented in comments, but the structure is not enforced. The \scheme{define-language} and \scheme{define-pass} syntactic forms are used by the nanopass framework to address these problems. A \scheme{define-language} form formally specifies the grammar of an intermediate language. A \scheme{define-pass} form defines a pass that operates on one language and produces output in a possibly different language. Formally specifying the grammar of an intermediate language and writing passes based on these intermediate languages allows the nanopass framework to use a record-based representation of language terms that is more efficient than the S-expression representation, autogenerate boilerplate code to recur through otherwise unchanging language forms, and generate checks to verify that the output of each pass adheres to the output-language grammar. The summer after Dybvig, Waddell, and Friedman taught their course, Jordan Johnson implemented an initial prototype of the nanopass framework to support the construction of micropass compilers. In 2004, Dipanwita Sarkar, Oscar Waddell, and R. Kent Dybvig developed a more complete prototype nanopass framework for compiler construction and submitted a paper on it to ICFP~\cite{Sarkar:2004:NIC:1016850.1016878}. The initial paper focused on the nanopass framework as a tool capable of developing both academic and commercial quality compilers. The paper was accepted but on the condition that it be refocused only on academic uses. The reviewers were not convinced that the framework or nanopass construction method was capable of supporting a commercial compiler. In retrospect, the reviewers were right. Sarkar implemented only a few of the passes from the compiler used in the course on compilers. This implementation showed that the nanopass framework was viable, but it did not support the claim that the nanopass framework could be used for a commercial compiler. In fact, because the class compiler was started but never completed, it is unclear whether the prototype was even up to the task of writing the full class compiler. The nanopass framework described in this guide improves on the prototype developed by Sarkar. In this framework, language definitions are no longer restricted to top-level definitions. Additionally, passes can accept more than one argument and return zero or more values. Passes can be defined that operate on a subset of a language instead of being restricted to starting from the entry-point nonterminal of the language. Passes can also autogenerate nonterminal transformers not supplied by the compiler writer. The new nanopass framework also defines two new syntactic forms, \scheme{nanopass-case} and \scheme{with-output-language}, that allow language terms to be matched and constructed outside the context of a pass. \section{The Nanopass Framework Today} % TODO: Update this line count to reflect the current size of % the nanopass framework Although the nanopass framework defines just two primary syntactic forms, the macros that implement them are complex, with approximately 4600 lines of code. In both the prototype and the new version of the nanopass framework, the \scheme{define-language} macro parses a language definition and stores a representation of it in the compile-time environment. This representation can be used to guide the definition of derived languages and the construction of passes. Both also create a set of record types used to represent language terms at run time, along with an unparser for translating the record representation to an S-expression representation. Finally, both create meta-parsers to parse S-expression patterns and templates. An S-expression to record-form parser can also be created from the language using \scheme{define-parser}.\footnote{In the prototype, this was part of the functionality of \scheme{define-language}, but in a commercial compiler we do not frequently need an S-expression parser, so we no longer autogenerate one.} The \scheme{define-pass} form, in both versions of the framework, operates over an input-language term and produces an output-language term. The input-language meta-parser generates code to match the specified pattern as records, as well as a set of bindings for the variables named in the pattern. The output-language meta-parser generates record constructors and grammar-checking code. Within a pass definition, a transformer is used to define a translation from an input nonterminal to an output nonterminal. Each transformer has a set of clauses that match an input-language term and construct an output-language term. The pattern matching also supports catamorphisms~\cite{Meijer:1991:FPB:645420.652535} for recurring into language sub-terms. \section{Examples using the Nanopass Framework} There are two, publicly available examples of the nanopass framework. The first is in the {\tt tests} sub-directory of the nanopass framework git repository at \href{https://github.com/akeep/nanopass-framework/}{github.com/akeep/nanopass-framework}. This is part of a student compiler, originally included with the prototype nanopass framework developed by Sarkar et al.\ and updated to conform with the changes that have been made in the updated nanopass framework. The second example is available in the \href{https://github.com/akeep/scheme-to-c/}{github.com/akeep/scheme-to-c} repository. This compiler is better documented and provides a complete compiler example targeting fairly low-level C from a simplified Scheme dialect. It was developed to be presented at \href{https://clojure-conj.org}{Clojure Conj 2013}, just days before the Conj started, and compiles a small subset of Scheme to C. It is similar to the included example, but has the advantage of being a complete end-to-end compiler that can be run from a Scheme REPL. It uses {\tt gcc}, targeting a 64-bit platform as the back-end, but I hope can be modified to target other platforms without too much trouble, or even moved off of C to target JavaScript, LLVM, or other back ends. \section{Other Uses of the Nanopass Frameowrk} The nanopass framework was used to replace the original Chez Scheme compiler~\cite{dybvig:csug9} with a nanopass version of the compiler. The nanopass version has officially been released as Chez Scheme version 9.0. Chez Scheme is a closed-source commercial compiler. The nanopass framework is also being used as part of the \href{https://github.com/eholk/harlan}{Harlan} compiler. Harlan is a general purpose language for developing programs for running on the GPU. Harlan uses an S-expression format that is compiled into C++ using OpenCL to run computational kernels on the GPU. The source code for Harlan is publicly available at \href{https://github.com/eholk/harlan}{github.com/eholk/harlan}. \chapter{Defining Languages and Passes} % old 2.4, new 2.3 The nanopass framework builds on the prototype, originally developed by Sarkar et al. The examples in this section are pulled from the Scheme to C compiler available at \href{https://github.com/akeep/scheme-to-c}{github.com/akeep/scheme-to-c}. \section{Defining languages} The nanopass framework operates over a set of compiler-writer-defined languages. Languages defined in this way are similar to context-free grammars, in that they are composed of a set of terminals, a set of nonterminal symbols, a set of productions for each nonterminal, and a start symbol from the set of nonterminal symbols. We refer to the start symbol as the entry nonterminal of the language. An intermediate language definition for a simple variant of the Scheme programming language, post macro expansion, might look like: {\small \schemedisplay (define-language Lsrc (terminals (symbol (x)) (primitive (pr)) (constant (c)) (datum (d))) (Expr (e body) pr x c (quote d) (if e0 e1) (if e0 e1 e2) (or e* ...) (and e* ...) (not e) (begin e* ... e) (lambda (x* ...) body* ... body) (let ([x* e*] ...) body* ... body) (letrec ([x* e*] ...) body* ... body) (set! x e) (e e* ...))) \endschemedisplay } \noindent The \scheme{Lsrc} language defines a subset of Scheme suitable for our example compiler. It is the output language of a more general ``parser'' that parses S-expressions into \scheme{Lsrc} language forms. The \scheme{Lsrc} language consists of a set of terminals (listed in the \scheme{terminals} form) and a single nonterminal \scheme{Expr}. The terminals of the language are \begin{itemize} \item \scheme{symbol} (for variables), \item \scheme{primitive} (for the subset of Scheme primitives support by this language), \item \scheme{constant} (for the subset of Scheme constants, and \item \scheme{datum} (for the subset of Scheme datum supported by this language). \end{itemize} The compiler writer must supply a predicate corresponding to each terminal, lexically visible where the language is defined. The nanopass framework derives the predicate name from the terminal name by adding a \scheme{?} to the terminal name. In this case, the nanopass framework expects \scheme{symbol?}, \scheme{primitive?}, \scheme{constant?}, and \scheme{datum?} to be lexically visible where \scheme{Lsrc} is defined. Each terminal clause lists one or more meta-variables, used to refer to the terminal in nonterminal productions. Here, \scheme{x} refers to a \scheme{symbol}, \scheme{pr} refers to a \scheme{primitive}, \scheme{c} refers to a \scheme{constant}, and \scheme{d} refers to a \scheme{datum}. For our example compiler, the host Scheme system's \scheme{symbol?} is used to determine when an item is a variable. The example compiler also selects a subset of primitives from Scheme and represents these primitives as symbols. A \scheme{primitive?} predicate like the following can be used to specify this terminal.\footnote{In the example compiler, the primitives are specified in separate association lists to capture the arity of each primitive and the place in the compiler is handled as it goes through the compiler process. This complexity has been eliminated for the dicussion here. Please reference the source code for a more complete discussion of primitive handling in the example compiler.} {\small \schemedisplay (define primitive? (lambda (x) (memq x '(cons make-vector box car cdr vector-ref vector-length unbox + - * / pair? null? boolean? vector? box? = < <= > >= eq? vector-set! set-box!)))) \endschemedisplay } \noindent Our example compiler also limits the constants that can be expressed to a subset of those allowed by Scheme. The \scheme{constant?} predicate limits these to booleans (\scheme{#t} and \scheme{#f}), null (\scheme{()}), and appropriately sized integers (between $-2^{60}$ and $2^{60} - 1$). {\small \schemedisplay (define target-fixnum? (lambda (x) (and (and (integer? x) (exact? x)) (<= (- (expt 2 60)) x (- (expt 2 60) 1))))) (define constant? (lambda (x) (or (target-fixnum? x) (boolean? x) (null? x)))) \endschemedisplay } \noindent The example compiler limits the Scheme datum that can be represented to constants, pairs, vectors, and boxes. The \scheme{datum?} predicate can be defined as follows: {\small \schemedisplay (define datum? (lambda (x) (or (constant? x) (and (box? x) (datum? (unbox x))) (and (pair? x) (datum? (car x)) (datum? (cdr x))) (and (vector? x) (let loop ([i (vector-length x)]) (or (fx=? i 0) (let ([i (fx- i 1)]) (and (datum? (vector-ref x i)) (loop i))))))))) \endschemedisplay } \noindent The \scheme{Lsrc} language also defines the nonterminal \scheme{Expr}. Nonterminals start with a name, followed by a list of meta-variables and a set of grammar productions. In this case, the name is \scheme{Expr}, and two meta-variables, \scheme{e} and \scheme{body}, are specified. Just like the meta-variables named in the terminals clause, nonterminal meta-variables are used to represent the nonterminal in nonterminal productions. Each production follows one of three forms. It is a single meta-variable, an S-expression that starts with a keyword, or an S-expression that does not start with a keyword (referred to as an \emph{implicit} production). The S-expression forms cannot include keywords past the initial starting keyword. In \scheme{Lsrc}, the \scheme{x}, \scheme{c}, and \scheme{pr} productions are the single meta-variable productions and indicate that a stand-alone \scheme{symbol}, \scheme{constant}, or \scheme{primitive} are valid \scheme{Expr}s. The only implicit S-expression production is the \scheme{(e e* ...)} production, and it indicates a call that takes zero or more \scheme{Expr}s as arguments. (The \scheme{*} suffix on \scheme{e} is used by convention to indicate plurality and does not have any semantic meaning: It is the \scheme{...} that indicates that the field can take zero or more \scheme{Expr}s.) The rest of the productions are S-expression productions with keywords that correspond to the Scheme syntax that they represent. In addition to the star, \scheme{*}, suffix mentioned earlier in the call productions, meta-variable references can also use a numeric suffix (as in the productions for \scheme{if}), a question mark (\scheme{?}), or a caret (\scheme{^}). The \scheme{?} suffix is intended for use with \scheme{maybe} meta-variables, and the \scheme{^} is used when expressing meta-variables with a more mathematical syntax than the numeric suffixes provide. Suffixes can also be used in combination. References to meta-variables in a production must be unique, and the suffixes allow the same root name to be used more than once. Language definitions can also include more than one nonterminal, as the following language illustrates: {\small \schemedisplay (define-language L8 (terminals (symbol (x a)) (constant (c)) (void+primitive (pr))) (entry Expr) (Expr (e body) x le (quote c) (if e0 e1 e2) (begin e* ... e) (set! x e) (let ([x* e*] ...) abody) (letrec ([x* le*] ...) body) (primcall pr e* ...) (e e* ...)) (AssignedBody (abody) (assigned (a* ...) body) => body) (LambdaExpr (le) (lambda (x* ...) abody))) \endschemedisplay } \noindent This language has three nonterminals, \scheme{Expr}, \scheme{AssignedBody}, and \scheme{LambdaExpr}. When more than one nonterminal is specified, one must be selected as the entry point. In language \scheme{L8}, the \scheme{Expr} nonterminal is selected as the entry nonterminal by the \scheme{(entry Expr)} clause. When the entry clause is not specified, the first nonterminal listed is implicitly selected as the entry point. The \scheme{L8} language uses a single terminal meta-variable production, \scheme{x}, to indicate that a stand-alone \scheme{symbol} is a valid \scheme{Expr}. In addition, the \scheme{L8} language uses a single nonterminal meta-variable production, \scheme{le}, to indicate that any \scheme{LambdaExpr} production is also a valid \scheme{Expr}. The \scheme{LambdaExpr} is separated from \scheme{Expr} because the \scheme{letrec} production is now limited to binding \scheme{symbol}s to \scheme{LambdaExpr}s. The \scheme{assigned} production of the \scheme{AssignedBody} nonterminal utilizes a the \scheme{=>} syntax to indicate a pretty unparsing form. This allows the unparser that is automatically produced by \scheme{define-language} to generate an S-expression that can be evaluated in the host Scheme system. In this case, the \scheme{assigned} from is not a valid Scheme form, so we simply eliminated the \scheme{assigned} wrapper and list of assigned variables when unparsing.\footnote{Unparsers can also produce the non-pretty from by passing both the language form to be unparsed and a \scheme{#f} to indicate the pretty form should not be used.} In addition to the nanopass framework providing a syntax for specifying list structures in a language production, it is also possible to indicate that a field of a language production might not contain a (useful) value. The following language has an example of this: {\small \schemedisplay (define-language Lopt (terminals (uvar (x)) (label (l)) (constant (c)) (primitive (pr))) (Expr (e body) x (quote c) (begin e* ... e) (lambda (x* ...) body) (let ([x* e*] ...) body) (letrec ([x* le*] ...) body) (pr e* ...) (call (maybe l) (maybe e) e* ...)) (LambdaExpr (le) (lambda (x* ...) body))) \endschemedisplay } \noindent The \scheme{(maybe l)} field indicates that either a label, \scheme{l}, or \scheme{#f} will be provided. Here, \scheme{#f} is a stand-in for bottom, indicating that the value is not specified. The \scheme{(maybe e)} field indicates that either an \scheme{Expr} or \scheme{#f} will be provided. Instead of using \scheme{(maybe l)} to indicate a label that might be provided, a \scheme{maybe-label} terminal that serves the same purpose could be added. It is also possible to eliminate the \scheme{(maybe e)} form, although it requires the creation of a separate nonterminal that has both an \scheme{e} production and a production to represent $\bot$, when no \scheme{Expr} is available. \section{Extending languages\label{subsec:extended-define-language}} The first ``pass'' of the example compiler is a simple expander that produces \scheme{Lsrc} language forms from S-expressions. The next pass takes the \scheme{Lsrc} language and removes the one-armed-if expressions, replacing them with a two-armed-if that results in the void value being produced by the expression when the test clause is false. code appropriate to construct these constants. The output grammar of this pass changes just one production of the language, exchanging potentially complex quoted datum with quoted constants and making explicit the code to build the constant pairs and vectors when the program begins execution. The compiler writer could specify the new language by rewriting the \scheme{Lsrc} language and replacing the appropriate terminal forms. Rewriting each language in its full form, however, can result in verbose source code, particularly in a compiler like the class compiler, which has nearly 30 different intermediate languages. Instead, the nanopass framework supports a language extension form. The output language can be specified as follows: {\small \schemedisplay (define-language L1 (extends Lsrc) (terminals (- (primitive (pr))) (+ (void+primitive (pr)))) (Expr (e body) (- (if e0 e1)))) \endschemedisplay } \noindent The \scheme{L1} language removes the \scheme{primitive} terminal and replaces it with the \scheme{void+primitive} terminal. It also removes the \scheme{(if e0 e1)} production. A language extension form is indicated by including the \scheme{extends} clause, in this case \scheme{(extends Lsrc)}, that indicates that this is an extension of the given base language. In a language extension, the \scheme{terminals} form now contains subtraction clauses, in this case \scheme{(- (primitive (pr)))}, and addition clauses, in this case \scheme{(+ (void+primitive (pr)))}. These addition and subtraction clauses can contain one or more terminal specifiers. The nonterminal syntax is similarly modified, with the subtraction clause, in this case \scheme{(- (if e0 e1))}, that indicates productions to be removed and an addition clause that indicates productions to be added, in this case no productions are added. The list of meta-variables indicated for the nonterminal form is also updated to use the set in the extension language. It is important to include not only the meta-variables named in the language extension but also those for terminal and nonterminal forms that will be maintained from the base language. Otherwise, these meta-variables will be unbound in the extension language, leading to errors. Nonterminals can be removed in an extended language by removing all of the productions of the nonterminal. New nonterminals can be added in an extended language by adding the productions of the new nonterminal. For instance, language \scheme{L15} removes the \scheme{x}, \scheme{(qoute c)}, and \scheme{(label l)} productions from the \scheme{Expr} nonterminal and adds the \scheme{SimpleExpr} nonterminal. {\small \schemedisplay (define-language L15 (extends L14) (Expr (e body) (- x (quote c) (label l) (primcall pr e* ...) (e e* ...)) (+ se (primcall pr se* ...) => (pr se* ...) (se se* ...))) (SimpleExpr (se) (+ x (label l) (quote c)))) \endschemedisplay } \subsection{The {\tt define-language} form} The \scheme{define-language} syntax has two related forms. The first form fully specifies a new language. The second form uses the \scheme{extends} clause to indicate that the language is an extension of an existing base language. Both forms of \scheme{define-language} start with the same basic syntax: {\small \schemedisplay (define-language \var{language-name} \var{clause} ...) \endschemedisplay } \noindent where \var{clause} is an \scheme{extension} clause, an \scheme{entry} clause, a \scheme{terminals} clause, or a nonterminal clause. \noindent \textbf{Extension clause.} The extension clause indicates that the new language is an extension of an existing language. This clause slightly changes the syntax of the \scheme{define-language} form and is described in Section~\ref{subsec:extended-define-language}. \noindent \textbf{Entry clause.} The entry clause specifies which nonterminal is the starting point for this language. This information is used when generating passes to determine which nonterminal should be expected first by the pass. This default can be overridden in a pass definition, as described in Section~\ref{sec:pass-syntax}. The entry clause has the following form: {\small \schemedisplay (entry \var{nonterminal-name}) \endschemedisplay } \noindent where \var{nonterminal-name} corresponds to one of the nonterminals specified in this language. Only one entry clause can be specified in a language definition. \noindent \textbf{Terminals clause.} The terminals clause specifies one or more terminals used by the language. For instance, in the \scheme{Lsrc} example language, the terminals clause specifies three terminal types: \scheme{uvar}, \scheme{primitive}, and \scheme{datum}. The terminals clause has the following form: {\small \schemedisplay (terminals \var{terminal-clause} ...) \endschemedisplay } \noindent where \var{terminal-clause} has one of the following forms: {\small \schemedisplay (\var{terminal-name} (\var{meta-var} ...)) (=> (\var{terminal-name} (\var{meta-var} ...)) \var{prettifier}) (\var{terminal-name} (\var{meta-var} ...)) => \var{prettifier} \endschemedisplay } Here, \partopsep=-\parskip \begin{itemize} \item \var{terminal-name} is the name of the terminal, and a corresponding \scheme{\var{terminal-name}?} predicate function exists to determine whether a Scheme object is of this type when checking the output of a pass, \item \var{meta-var} is the name of a meta-variable used for referring to this terminal type in language and pass definitions, and \item \var{prettifier} is a procedure expression of one argument used when the language unparser is called in ``pretty'' mode to produce a pretty, S-expression representation. \end{itemize} The final form is syntactic sugar for the form above it. When the \var{prettifier} is omitted, no processing is done on the terminal when the unparser runs. \noindent \textbf{Nonterminal clause.} A nonterminal clause specifies the valid productions in a language. Each nonterminal clause has a name, a set of meta-variables, and a set of productions. A nonterminal clause has the following form: {\small \schemedisplay (\var{nonterminal-name} (\var{meta-var} ...) \var{production-clause} ...) \endschemedisplay } \noindent where \var{nonterminal-name} is an identifier that names the nonterminal, \var{meta-var} is the name of a meta-variable used when referring to this nonterminal in language and pass definitions, and \var{production-clause} has one of the following forms: {\small \schemedisplay \var{terminal-meta-var} \var{nonterminal-meta-var} \var{production-s-expression} (\var{keyword} . \var{production-s-expression}) \endschemedisplay } \noindent Here, \begin{itemize} \item \var{terminal-meta-var} is a terminal meta-variable that is a stand-alone production for this nonterminal, \item \var{nonterminal-meta-var} is a nonterminal meta-variable that indicates that any form allowed by the specified nonterminal is also allowed by this nonterminal, \item \var{keyword} is an identifier that must be matched exactly when parsing an S-expression representation, language input pattern, or language output template, and \item \var{production-s-expression} is an S-expression that represents a pattern for production and has the following form: \end{itemize} {\small \schemedisplay \var{meta-variable} (maybe \var{meta-variable}) (\var{production-s-expression} \var{ellipsis}) (\var{production-s-expression} \var{ellipsis} \var{production-s-expression} ... . \var{production-s-expression}) (\var{production-s-expression} . \var{production-s-expression}) () \endschemedisplay } \noindent Here, \begin{itemize} \item \var{meta-variable} is any terminal or nonterminal meta-variable extended with an arbitrary number of digits, followed by an arbitrary combination of \scheme{*}, \scheme{?}, or \scheme{^} characters; for example, if the meta-variable is \scheme{e}, then \scheme{e1}, \scheme{e*}, \scheme{e?}, and \scheme{e4*?} are all valid meta-variable expressions; \item \scheme{(maybe \var{meta-variable})} indicates that an element in the production is either of the type of the meta-variable or bottom (represented by \scheme{#f}); and \item \var{ellipsis} is the literal \scheme{...} and indicates that a list of the \var{production-s-expression} that proceeds it is expected. \end{itemize} Thus, a Scheme language form such as \scheme{let} can be represented as a language production as: {\small \schemedisplay (let ([x* e*] ...) body* ... body) \endschemedisplay } \noindent where \scheme{let} is the \var{keyword}, \scheme{x*} is a meta-variable that indicates a list of variables, \scheme{e*} and \scheme{body*} are meta-variables that each indicate a list of expressions, and \scheme{body} is a meta-variable that indicates a single expression. Using the \scheme{maybe} form, something similar to the named-let form could be represented as follows: {\small \schemedisplay (let (maybe x) ([x* e*] ...) body* ... body) \endschemedisplay } \noindent although this would be slightly different from the normal named-let form, in that the non-named form would then need an explicit \scheme{#f} to indicate that no name was specified. \subsection{Extensions with the {\tt define-language} form\label{subsubsec:extended-define-language}} A language defined as an extension of an existing language has a slightly modified syntax to indicate what should be added to or removed from the base language to create the new language. A compiler writer indicates that a language is an extension by using an extension clause. \noindent \textbf{Extension clause.} The extension clause has the following form: {\small \schemedisplay (extends \var{language-name}) \endschemedisplay } \noindent where \var{language-name} is the name of an already defined language. Only one extension clause can be specified in a language definition. \noindent \textbf{Entry clause.} The entry clause does not change syntactically in an extended language. It can, however, name a nonterminal from the base language that is retained in the extended language. \noindent \textbf{Terminals clause.} When a language derives from a base language, the \scheme{terminals} clause has the following form: {\small \schemedisplay (terminals \var{extended-terminal-clause} ...) \endschemedisplay } \noindent where \var{extended-terminal-clause} has one of the following forms: {\small \schemedisplay (+ \var{terminal-clause} ...) (- \var{terminal-clause} ...) \endschemedisplay } \noindent where the \var{terminal-clause} uses the syntax for terminals specified in the non-extended \scheme{terminals} form. The \scheme{+} form indicates terminals that should be added to the new language. The \scheme{-} form indicates terminals that should be removed from the list in the old language when producing the new language. Terminals not mentioned in a terminals clause will be copied unchanged into the new language. Note that adding and removing \var{meta-var}s from a terminal currently requires removing the terminal type and re-adding it. This can be done in the same step with a \scheme{terminals} clause, similar to the following: {\small \schemedisplay (terminals (- (variable (x))) (+ (variable (x y)))) \endschemedisplay } \noindent \textbf{Nonterminal clause.} When a language extends from a base language, a nonterminal clause has the following form: {\small \schemedisplay (\var{nonterminal-name} (\var{meta-var} ...) \var{extended-production-clause} ...) \endschemedisplay } \noindent where \var{extended-production-clause} has one of the following forms: {\small \schemedisplay (+ \var{production-clause} ...) (- \var{production-clause} ...) \endschemedisplay } \noindent The \scheme{+} form indicates nonterminal productions that should be added to the nonterminal in the new language. The \scheme{-} form indicates nonterminal productions that should not be copied from the list of productions for this nonterminal in the base language when producing the new language. Productions not mentioned in a nonterminal clause will be copied unchanged into the nonterminal in the new language. If a nonterminal has all of its productions removed in a new language, the nonterminal will be dropped in the new language. Conversely, new nonterminals can be added by naming the new nonterminal and using the \scheme{+} form to specify the productions of the new nonterminal. \subsection{Products of {\tt define-language}} The \scheme{define-language} form produces the following user-visible bindings: \begin{itemize} \item a language definition, bound to the specified \var{language-name}; \item an unparser (named \scheme{unparse-\var{language-name}}) that can be used to unparse a record-based representation back into an S-expression representation; and \item a set of predicates that can be used to identify a term of the language or a term from a specified nonterminal in the language. \end{itemize} It also produces the following internal bindings: \begin{itemize} \item a meta-parser that can be used by the \scheme{define-pass} macro to parse the patterns and templates used in passes and \item a set of record definitions that will be used to represent the language forms. \end{itemize} The \scheme{Lsrc} language, for example, will bind the identifier \scheme{Lsrc} to the language definition, produce an unparser named \scheme{unparse-Lsrc}, and create two predicates, \scheme{Lsrc?} and \scheme{Lsrc-Expr?}. The language definition is used when the \var{language-name} is specified as the base of a new language definition and in the definition of a pass. The \scheme{define-parser} form can also be used to create a simple parser for parsing S-expressions into language forms as follows: {\small \schemedisplay (define-parser \var{parser-name} \var{language-name}) \endschemedisplay } \noindent The parser does not support backtracking; thus, grammars must be specified, either by specifying a keyword or by having different length S-expressions so that the productions are unique. For instance, the following language definition cannot be parsed because all four of the \scheme{set!} forms have the same keyword and are S-expressions of the same length: {\small \schemedisplay (define-language Lunparsable (terminals (variable (x)) (binop (binop)) (integer-32 (int32)) (integer-64 (int64))) (Program (prog) (begin stmt* ... stmt)) (Statement (stmt) (set! x0 int64) (set! x0 x1) (set! x0 (binop x1 int32)) (set! x0 (binop x1 x2)))) \endschemedisplay } \noindent Instead, the \scheme{Statement} nonterminal must be broken into multiple nonterminals, as in the following language: {\small \schemedisplay (define-language Lparsable (terminals (variable (x)) (binop (binop)) (integer-32 (int32)) (integer-64 (int64))) (Program (prog) (begin stmt* ... stmt)) (Statement (stmt) (set! x rhs)) (Rhs (rhs) x int64 (binop x arg)) (Argument (arg) x int32)) \endschemedisplay } \section{Defining passes\label{sec:define-pass}} Passes are used to specify transformations over languages defined by using \scheme{define-language}. Before going into the formal details of defining passes, we need to take a look at a simple pass to convert an input program from the \scheme{Lsrc} intermediate language to the \scheme{L1} intermediate language. This pass removes the one-armed-if by making the result of the \scheme{if} expression explicit when the predicate is false. We define a pass called \scheme{remove-one-armed-if} to accomplish this task, without using any of the catamorphism~\cite{Meijer:1991:FPB:645420.652535} or autogeneration features of the nanopass framework. Below, we can see how this feature helps eliminate boilerplate code. {\small \schemedisplay (define-pass remove-one-armed-if : Lsrc (e) -> L1 () (Expr : Expr (e) -> Expr () [(if ,e0 ,e1) `(if ,(Expr e0) ,(Expr e1) (void))] [,pr pr] [,x x] [,c c] [(quote ,d) `(quote ,d)] [(if ,e0 ,e1 ,e2) `(if ,(Expr e0) ,(Expr e1) ,(Expr e2))] [(or ,e* ...) `(or ,(map Expr e*) ...)] [(and ,e* ...) `(and ,(map Expr e*) ...)] [(not ,e) `(not ,(Expr e))] [(begin ,e* ... ,e) `(begin ,(map Expr e*) ... ,(Expr e))] [(lambda (,x* ...) ,body* ... ,body) `(lambda (,x* ...) ,(map Expr body*) ... ,(Expr body))] [(let ([,x* ,e*] ...) ,body* ... ,body) `(let ([,x* ,(map Expr e*)] ...) ,(map Expr body*) ... ,(Expr body))] [(letrec ([,x* ,e*] ...) ,body* ... body) `(letrec ([,x* ,(map Expr e*)] ...) ,(map Expr body*) ... ,(Expr body))] [(set! ,x ,e) `(set! ,x ,(Expr e))] [(,e ,e* ...) `(,(Expr e) ,(map Expr e*) ...)]) (Expr e)) \endschemedisplay } \noindent The pass definition starts with a name (in this case, \scheme{remove-one-armed-if}) and a signature. The signature starts with an input-language specifier (e.g. \scheme{Lsrc}), along with a list of formals. Here, there is just one formal, \scheme{e}, for the input-language term. The second part of the signature has an output-language specifier (in this case, \scheme{L1}), as well as a list of extra return values (in this case, empty). Following the name and signature, is an optional definitions clause, not used in this pass. The \scheme{definitions} clause can contain any Scheme expression valid in a definition context. Next, a transformer from the input nonterminal \scheme{Expr} to the output nonterminal \scheme{Expr} is defined. The transformer is named \scheme{Expr} and has a signature similar to that of the pass, with an input-language nonterminal and list of formals followed by the output-language nonterminal and list of extra-return-value expressions. The transformer has a clause that processes each production of the \scheme{Expr} nonterminal. Each clause consists of an input pattern, an optional \scheme{guard} clause, and one or more expressions that specify zero or more return values based on the signature. The input pattern is derived from the S-expression productions specified in the input language. Each variable in the pattern is denoted by unquote (\scheme{,}). For instance, the clause for the \scheme{set!} production matches the pattern \scheme{(set! ,x ,e)}, binds \scheme{x} to the \scheme{symbol} specified by the \scheme{set!} and \scheme{e} to the \scheme{Expr} specified by the \scheme{set!}. % I might do this as an asside, if I could figure out how to bend LaTeX to my % will enough to do that. The variable names used in pattern bindings are based on the meta-variables listed in the language definition. This allows the pattern to be further restricted. For instance, if we wanted to match only \scheme{set!} forms that had a variable reference as the RHS, we could specify our pattern as \scheme{(set! ,x0 ,x1)}, which would be equivalent of using our original pattern with the \scheme{guard} clause: \scheme{(guard (symbol? e))}. The output-language expression is constructed using the \scheme{`(set! ,x ,(Expr e))} quasiquoted template. Here, quasiquote, (\scheme{`}), is rebound to a form that can construct language forms based on the template, and unquote (\scheme{,}), is used to escape back into Scheme. The \scheme{,(Expr e)} thus puts the result of the recursive call of \scheme{Expr} into the output-language \scheme{(set! x e)} form. Following the \scheme{Expr} transformer is the body of the pass, which calls \scheme{Expr} to transform the \scheme{Lsrc} \scheme{Expr} term into an \scheme{L1} \scheme{Expr} term and wraps the result in a \scheme{let} expression if any structured quoted datum are found in the program that is being compiled. In place of the explicit recursive calls to \scheme{Expr}, the compiler writer can use the catamorphism syntax to indicate the recurrence, as in the following version of the pass. {\small \schemedisplay (define-pass remove-one-armed-if : Lsrc (e) -> L1 () (Expr : Expr (e) -> Expr () [(if ,[e0] ,[e1]) `(if ,e0 ,e1 (void))] [,pr pr] [,x x] [,c c] [(quote ,d) `(quote ,d)] [(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)] [(or ,[e*] ...) `(or ,e* ...)] [(and ,[e*] ...) `(and ,e* ...)] [(not ,[e]) `(not ,e)] [(begin ,[e*] ... ,[e]) `(begin ,e* ... ,e)] [(lambda (,x* ...) ,[body*] ... ,[body]) `(lambda (,x* ...) ,body* ... ,body)] [(let ([,x* ,[e*]] ...) ,[body*] ... ,[body]) `(let ([,x* ,e*] ...) ,body* ... ,body)] [(letrec ([,x* ,[e*]] ...) ,[body*] ... ,[body]) `(letrec ([,x* ,e*] ...) ,body* ... ,body)] [(set! ,x ,[e]) `(set! ,x ,e)] [(,[e] ,[e*] ...) `(,e ,e* ...)]) (Expr e)) \endschemedisplay } \noindent Here, the square brackets that wrap the unquoted variable expression in a pattern indicate that a catamorphism should be applied. For instance, in the \scheme{set!} clause, the \scheme{,e} from the previous pass becomes \scheme{,[e]}. When the catamorphism is included on an element that is followed by an ellipsis, \scheme{map} is used to process the elements of the list and to construct the output list. % another place for this to be an aside with a link down to the % catamorphism section Using a catamorphism changes, slightly, the meaning of the meta-variables used in the pattern matcher. Instead of indicatinng a input language restriction that must be met, it indicates an output type that is expected. In the \scheme{set!} clause example, we use \scheme{e} for both, because our input language and output language both use \scheme{e} to refer to their \scheme{Expr} nonterminal. The nanopass framwork uses the input type and the output type, along with any additional input values and extra expected return values to determine which transformer should be called. In some cases, specifically where a single input nonterminal form is transformed into an equivalent output nonterminal form, these transformers can be autogenerated by the framework. Using catamorphisms helps to make the pass more succinct, but there is still boilerplate code in the pass that the framework can fill in for the compiler writer. Several clauses simply match the input-language production and generate a matching output-language production (modulo the catamorphisms for nested \scheme{Expr} forms). Because the input and output languages are defined, the \scheme{define-pass} macro can automatically generate these clauses. Thus, the same functionality can be expressed as follows: {\small \schemedisplay (define-pass remove-one-armed-if : Lsrc (e) -> L1 () (Expr : Expr (e) -> Expr () [(if ,[e0] ,[e1]) `(if ,e0 ,e1 (void))])) \endschemedisplay } \noindent In this version of the pass, only the one-armed-\scheme{if} form is explicitly processed. The \scheme{define-pass} form automatically generates the other clauses. Although all three versions of this pass perform the same task, the final form is the closest to the initial intention of replacing just the one-armed-if form with a two-armed-if. In addition to \scheme{define-pass} autogenerating the clauses of a transformer, \scheme{define-pass} can also autogenerate the transformers for nonterminals that must be traversed but are otherwise unchanged in a pass. For instance, one of the passes in the class compiler removes complex expressions from the right-hand side of the \scheme{set!} form. At this point in the compiler, the language has several nonterminals: {\small \schemedisplay (define-language L18 (entry Program) (terminals (integer-64 (i)) (effect+internal-primitive (epr)) (non-alloc-value-primitive (vpr)) (symbol (x l)) (predicate-primitive (ppr)) (constant (c))) (Program (prog) (labels ([l* le*] ...) l)) (SimpleExpr (se) x (label l) (quote c)) (Value (v body) (alloc i se) se (if p0 v1 v2) (begin e* ... v) (primcall vpr se* ...) (se se* ...)) (Effect (e) (set! x v) (nop) (if p0 e1 e2) (begin e* ... e) (primcall epr se* ...) (se se* ...)) (Predicate (p) (true) (false) (if p0 p1 p2) (begin e* ... p) (primcall ppr se* ...)) (LocalsBody (lbody) (locals (x* ...) body)) (LambdaExpr (le) (lambda (x* ...) lbody))) \endschemedisplay } \noindent The pass, however, is only interested in the \scheme{set!} form and the \scheme{Value} form in the right-hand-side position of the \scheme{set!} form. Relying on the autogeneration of transformers, this pass can be written as: {\small \schemedisplay (define-pass flatten-set! : L18 (e) -> L19 () (SimpleExpr : SimpleExpr (se) -> SimpleExpr ()) (Effect : Effect (e) -> Effect () [(set! ,x ,v) (flatten v x)]) (flatten : Value (v x) -> Effect () [,se `(set! ,x ,(SimpleExpr se))] [(primcall ,vpr ,[se*] ...) `(set! ,x (primcall ,vpr ,se* ...))] [(alloc ,i ,[se]) `(set! ,x (alloc ,i ,se))] [(,[se] ,[se*] ...) `(set! ,x (,se ,se* ...))])) \endschemedisplay } \noindent Here, the \scheme{Effect} transformer has just one clause for matching the \scheme{set!} form. The \scheme{flatten} transformer is called to produce the final \scheme{Effect} form. The \scheme{flatten} transformer, in turn, pushes the \scheme{set!} form into the \scheme{if} and \scheme{begin} forms and processes the contents of these forms, which produces a final \scheme{Effect} form. Note that the \scheme{if} and \scheme{begin} forms do not need to be provided by the compiler writer. This is because the input and output language provide enough structure that the nanopass framework can automatically generate the appropriate clauses. In the case of \scheme{begin} it will push the \scheme{set!} form into the final, value producing, expression of the \scheme{begin} form. In the case of the \scheme{if} it will push the \scheme{set!} form into both the consquent and alternative of the if form, setting the variable at the final, value producing expression on both possible execution paths. The \scheme{define-pass} macro autogenerates transformers for \scheme{Program}, \scheme{LambdaExpr}, \scheme{LocalsBody}, \scheme{Value}, and \scheme{Predicate} that recur through the input-language forms and produce the output-language forms. The \scheme{SimpleExpr} transformer only needs to be written to give a name to the transformer so that it can be called by \scheme{flatten}. It is sometimes necessary to pass more information than just the language term to a transformer. The transformer syntax allows extra formals to be named to support passing this information. For example, in the pass from the scheme to C compiler that converts the \scheme{closures} form into explicit calls to procedure primitives, the closure pointer, \scheme{cp}, and the list of free variables, \scheme{free*}, are passed to the \scheme{Expr} transformer. {\small \schemedisplay (define-pass expose-closure-prims : L12 (e) -> L13 () (Expr : Expr (e [cp #f] [free* '()]) -> Expr () (definitions (define handle-closure-ref (lambda (x cp free*) (let loop ([free* free*] [i 0]) (cond [(null? free*) x] [(eq? x (car free*)) `(primcall closure-ref ,cp (quote ,i))] [else (loop (cdr free*) (fx+ i 1))])))) (define build-closure-set* (lambda (x* l* f** cp free*) (fold-left (lambda (e* x l f*) (let loop ([f* f*] [i 0] [e* e*]) (if (null? f*) (cons `(primcall closure-code-set! ,x (label ,l)) e*) (loop (cdr f*) (fx+ i 1) (cons `(primcall closure-data-set! ,x (quote ,i) ,(handle-closure-ref (car f*) cp free*)) e*))))) '() x* l* f**)))) [(closures ([,x* ,l* ,f** ...] ...) (labels ([,l2* ,[le*]] ...) ,[body])) (let ([size* (map length f**)]) `(let ([,x* (primcall make-closure (quote ,size*))] ...) (labels ([,l2* ,le*] ...) (begin ,(build-closure-set* x* l* f** cp free*) ... ,body))))] [,x (handle-closure-ref x cp free*)] [((label ,l) ,[e*] ...) `((label ,l) ,e* ...)] [(,[e] ,[e*] ...) `((primcall closure-code ,e) ,e* ...)]) (LabelsBody : LabelsBody (lbody) -> Expr ()) (LambdaExpr : LambdaExpr (le) -> LambdaExpr () [(lambda (,x ,x* ...) (free (,f* ...) ,[body x f* -> body])) `(lambda (,x ,x* ...) ,body)])) \endschemedisplay } \noindent The catamorphism and clause autogeneration facilities are also aware of the extra formals expected by transformers. In a catamorphism, this means that extra arguments need not be specified in the catamorphism, if the formals are available in the transformer. For instance, in the \scheme{Expr} transformer, the catamorphism specifies only the binding of the output \scheme{Expr} form, and \scheme{define-pass} matches the name of the formal to the transformer with the expected argument. In the \scheme{LambdaExpr} transformer, the extra arguments need to be specified, both because they are not available as a formal of the transformer and because the values change at the \scheme{LambdaExpr} boundary. Autogenerated clauses in \scheme{Expr} also call the \scheme{Expr} transformer with the extra arguments from the formals. The \scheme{expose-closure-prims} pass also specifies default values for the extra arguments passed to the \scheme{Expr} transformer. It defaults the \scheme{cp} variable to \scheme{#f} and the \scheme{free*} variable to the empty list. The default values will only be used in calls to the \scheme{Expr} transformer when the no other value is available. In this case, this happen only when the \scheme{Expr} transformer is first called in the body of the pass. This is consistent with the body of the program, which cannot contain any free variables and hence does not need a closure pointer. Once we begin processing within the body of a \scheme{lambda} we then have a closure pointer, with the list of free variables, if any. Sometimes it is also necessary for a pass to return more than one value. The nanopass framework relies upon Scheme's built-in functionality for dealing with returning of multiple return values. To inform the nanopass framework that a given transformer is returning more than one value, we use the signature to tell the framework both how many values we are expecting to return, and what the default values should be when a clause is autogenerated. For instance, the \scheme{uncover-free} pass returns two values, the language form and the list of free variables. {\small \schemedisplay (define-pass uncover-free : L10 (e) -> L11 () (Expr : Expr (e) -> Expr (free*) [(quote ,c) (values `(quote ,c) '())] [,x (values x (list x))] [(let ([,x* ,[e* free**]] ...) ,[e free*]) (values `(let ([,x* ,e*] ...) ,e) (apply union (difference free* x*) free**))] [(letrec ([,x* ,[le* free**]] ...) ,[body free*]) (values `(letrec ([,x* ,le*] ...) ,body) (difference (apply union free* free**) x*))] [(if ,[e0 free0*] ,[e1 free1*] ,[e2 free2*]) (values `(if ,e0 ,e1 ,e2) (union free0* free1* free2*))] [(begin ,[e* free**] ... ,[e free*]) (values `(begin ,e* ... ,e) (apply union free* free**))] [(primcall ,pr ,[e* free**]...) (values `(primcall ,pr ,e* ...) (apply union free**))] [(,[e free*] ,[e* free**] ...) (values `(,e ,e* ...) (apply union free* free**))]) (LambdaExpr : LambdaExpr (le) -> LambdaExpr (free*) [(lambda (,x* ...) ,[body free*]) (let ([free* (difference free* x*)]) (values `(lambda (,x* ...) (free (,free* ...) ,body)) free*))]) (let-values ([(e free*) (Expr e)]) (unless (null? free*) (error who "found unbound variables" free*)) e)) \endschemedisplay } Transformers can also be written that handle terminals instead of nonterminals. Because terminals have no structure, the body of such transformers is simply a Scheme expression. The Scheme to C compiler does not make use of this feature, but we could imagine a pass where references to variables are replaced with already specified locations, such as the following pass: {\small \schemedisplay (define-pass replace-variable-refereces : L23 (x) -> L24 () (uvar-reg-fv : symbol (x env) -> location () (cond [(and (uvar? x) (assq x env)) => cdr] [else x])) (SimpleExpr : SimpleExpr (x env) -> Triv ()) (Rhs : Rhs (x env) -> Rhs ()) (Pred : Pred (x env) -> Pred ()) (Effect : Effect (x env) -> Effect ()) (Value : Value (x env) -> Value ()) (LocalsBody : LocalsBody (x) -> Value () [(finished ([,x* ,loc*] ...) ,vbody) (Value vbody (map cons x* loc*))])) \endschemedisplay } \noindent The two interesting parts of this pass are the \scheme{LocalsBody} transformer that creates the environment that maps variables to locations and the \scheme{uvar-reg-fv} transformer that replaces variables with the appropriate location. In this pass, transformers cannot be autogenerated because extra arguments are needed, and the nanopass framework only autogenerates transformers without extra arguments or return values. The autogeneration is limited to help reign in some of the unpredictable behavior that can result from autogenerated transformers. Passes can also be written that do not take a language form but that produce a language form. The initial parser for the Scheme to C compiler is a good example of this. It expects an S-expression that conforms to an input grammar for the subset of Scheme supported by the compiler. {\small \schemedisplay (define-pass parse-and-rename : * (e) -> Lsrc () (definitions (define process-body (lambda (who env body* f) (when (null? body*) (error who "invalid empty body")) (let loop ([body (car body*)] [body* (cdr body*)] [rbody* '()]) (if (null? body*) (f (reverse rbody*) (Expr body env)) (loop (car body*) (cdr body*) (cons (Expr body env) rbody*)))))) (define vars-unique? (lambda (fmls) (let loop ([fmls fmls]) (or (null? fmls) (and (not (memq (car fmls) (cdr fmls))) (loop (cdr fmls))))))) (define unique-vars (lambda (env fmls f) (unless (vars-unique? fmls) (error 'unique-vars "invalid formals" fmls)) (let loop ([fmls fmls] [env env] [rufmls '()]) (if (null? fmls) (f env (reverse rufmls)) (let* ([fml (car fmls)] [ufml (unique-var fml)]) (loop (cdr fmls) (cons (cons fml ufml) env) (cons ufml rufmls))))))) (define process-bindings (lambda (rec? env bindings f) (let loop ([bindings bindings] [rfml* '()] [re* '()]) (if (null? bindings) (unique-vars env rfml* (lambda (new-env rufml*) (let ([env (if rec? new-env env)]) (let loop ([rufml* rufml*] [re* re*] [ufml* '()] [e* '()]) (if (null? rufml*) (f new-env ufml* e*) (loop (cdr rufml*) (cdr re*) (cons (car rufml*) ufml*) (cons (Expr (car re*) env) e*))))))) (let ([binding (car bindings)]) (loop (cdr bindings) (cons (car binding) rfml*) (cons (cadr binding) re*))))))) (define Expr* (lambda (e* env) (map (lambda (e) (Expr e env)) e*))) (with-output-language (Lsrc Expr) (define build-primitive (lambda (as) (let ([name (car as)] [argc (cdr as)]) (cons name (if (< argc 0) (error who "primitives with arbitrary counts are not currently supported" name) (lambda (env . e*) (if (= (length e*) argc) `(,name ,(Expr* e* env) ...) (error name "invalid argument count" (cons name e*))))))))) (define initial-env (cons* (cons 'quote (lambda (env d) (unless (datum? d) (error 'quote "invalid datum" d)) `(quote ,d))) (cons 'if (case-lambda [(env e0 e1) `(if ,(Expr e0 env) ,(Expr e1 env))] [(env e0 e1 e2) `(if ,(Expr e0 env) ,(Expr e1 env) ,(Expr e2 env))] [x (error 'if (if (< (length x) 3) "too few arguments" "too many arguments") x)])) (cons 'or (lambda (env . e*) `(or ,(Expr* e* env) ...))) (cons 'and (lambda (env . e*) `(and ,(Expr* e* env) ...))) (cons 'not (lambda (env e) `(not ,(Expr e env)))) (cons 'begin (lambda (env . e*) (process-body env e* (lambda (e* e) `(begin ,e* ... ,e))))) (cons 'lambda (lambda (env fmls . body*) (unique-vars env fmls (lambda (env fmls) (process-body 'lambda env body* (lambda (body* body) `(lambda (,fmls ...) ,body* ... ,body))))))) (cons 'let (lambda (env bindings . body*) (process-bindings #f env bindings (lambda (env x* e*) (process-body 'let env body* (lambda (body* body) `(let ([,x* ,e*] ...) ,body* ... ,body))))))) (cons 'letrec (lambda (env bindings . body*) (process-bindings #t env bindings (lambda (env x* e*) (process-body 'letrec env body* (lambda (body* body) `(letrec ([,x* ,e*] ...) ,body* ... ,body))))))) (cons 'set! (lambda (env x e) (cond [(assq x env) => (lambda (as) (let ([v (cdr as)]) (if (symbol? v) `(set! ,v ,(Expr e env)) (error 'set! "invalid syntax" (list 'set! x e)))))] [else (error 'set! "set to unbound variable" (list 'set! x e))]))) (map build-primitive user-prims))) ;;; App - helper for handling applications. (define App (lambda (e env) (let ([e (car e)] [e* (cdr e)]) `(,(Expr e env) ,(Expr* e* env) ...)))))) (Expr : * (e env) -> Expr () (cond [(pair? e) (cond [(assq (car e) env) => (lambda (as) (let ([v (cdr as)]) (if (procedure? v) (apply v env (cdr e)) (App e env))))] [else (App e env)])] [(symbol? e) (cond [(assq e env) => (lambda (as) (let ([v (cdr as)]) (cond [(symbol? v) v] [(primitive? e) e] [else (error who "invalid syntax" e)])))] [else (error who "unbound variable" e)])] [(constant? e) e] [else (error who "invalid expression" e)])) (Expr e initial-env)) \endschemedisplay } \noindent The \scheme{parse-and-rename} pass is structured similarly to a simple expander with keywords and primitives.\footnote{It could easily be extended to handle simple macros, in this case, just the fixed \scheme{and} macro, \scheme{or} macro, and \scheme{not} macro would be available.} It also performs syntax checking to ensure that the input grammar conforms to the expected input grammar. Finally, it produces an \scheme{Lsrc} language term that represents the Scheme program to be compiled. In the pass syntax, the \scheme{*} in place of the input-language name indicates that no input-language term should be expected. The \scheme{Expr} and \scheme{Application} transformers do not have pattern matching clauses, as the input could be of any form. The quasiquote is, however, rebound because an output language is specified. It can also be useful to create passes without an output language. The final pass of the Scheme to C compiler is the code generator that emits C code. {\small \schemedisplay (define-pass generate-c : L22 (e) -> * () (definitions (define string-join (lambda (str* jstr) (cond [(null? str*) ""] [(null? (cdr str*)) (car str*)] [else (string-append (car str*) jstr (string-join (cdr str*) jstr))]))) (define symbol->c-id (lambda (sym) (let ([ls (string->list (symbol->string sym))]) (if (null? ls) "_" (let ([fst (car ls)]) (list->string (cons (if (char-alphabetic? fst) fst #\_) (map (lambda (c) (if (or (char-alphabetic? c) (char-numeric? c)) c #\_)) (cdr ls))))))))) (define format-function-header (lambda (l x*) (format "ptr ~a(~a)" l (string-join (map (lambda (x) (format "ptr ~a" (symbol->c-id x))) x*) ", ")))) (define format-label-call (lambda (l se*) (format " ~a(~a)" (symbol->c-id l) (string-join (map (lambda (se) (format "(ptr)~a" (format-simple-expr se))) se*) ", ")))) (define format-general-call (lambda (se se*) (format "((ptr (*)(~a))~a)(~a)" (string-join (make-list (length se*) "ptr") ", ") (format-simple-expr se) (string-join (map (lambda (se) (format "(ptr)~a" (format-simple-expr se))) se*) ", ")))) (define format-binop (lambda (op se0 se1) (format "((long)~a ~a (long)~a)" (format-simple-expr se0) op (format-simple-expr se1)))) (define format-set! (lambda (x rhs) (format "~a = (ptr)~a" (symbol->c-id x) (format-rhs rhs))))) (emit-function-decl : LambdaExpr (le l) -> * () [(lambda (,x* ...) ,lbody) (printf "~a;~%" (format-function-header l x*))]) (emit-function-def : LambdaExpr (le l) -> * () [(lambda (,x* ...) ,lbody) (printf "~a {~%" (format-function-header l x*)) (emit-function-body lbody) (printf "}~%~%")]) (emit-function-body : LocalsBody (lbody) -> * () [(locals (,x* ...) ,body) (for-each (lambda (x) (printf " ptr ~a;~%" (symbol->c-id x))) x*) (emit-value body x*)]) (emit-value : Value (v locals*) -> * () [(if ,p0 ,v1 ,v2) (printf " if (~a) {~%" (format-predicate p0)) (emit-value v1 locals*) (printf " } else {~%") (emit-value v2 locals*) (printf " }~%")] [(begin ,e* ... ,v) (for-each emit-effect e*) (emit-value v locals*)] [,rhs (printf " return (ptr)~a;\n" (format-rhs rhs))]) (format-predicate : Predicate (p) -> * (str) [(if ,p0 ,p1 ,p2) (format "((~a) ? (~a) : (~a))" (format-predicate p0) (format-predicate p1) (format-predicate p2))] [(<= ,se0 ,se1) (format-binop "<=" se0 se1)] [(< ,se0 ,se1) (format-binop "<" se0 se1)] [(= ,se0 ,se1) (format-binop "==" se0 se1)] [(true) "1"] [(false) "0"] [(begin ,e* ... ,p) (string-join (fold-right (lambda (e s*) (cons (format-effect e) s*)) (list (format-predicate p)) e*) ", ")]) (format-effect : Effect (e) -> * (str) [(if ,p0 ,e1 ,e2) (format "((~a) ? (~a) : (~a))" (format-predicate p0) (format-effect e1) (format-effect e2))] [((label ,l) ,se* ...) (format-label-call l se*)] [(,se ,se* ...) (format-general-call se se*)] [(set! ,x ,rhs) (format-set! x rhs)] [(nop) "0"] [(begin ,e* ... ,e) (string-join (fold-right (lambda (e s*) (cons (format-effect e) s*)) (list (format-effect e)) e*) ", ")] [(mset! ,se0 ,se1? ,i ,se2) (if se1? (format "((*((ptr*)((long)~a + (long)~a + ~d))) = (ptr)~a)" (format-simple-expr se0) (format-simple-expr se1?) i (format-simple-expr se2)) (format "((*((ptr*)((long)~a + ~d))) = (ptr)~a)" (format-simple-expr se0) i (format-simple-expr se2)))]) (format-simple-expr : SimpleExpr (se) -> * (str) [,x (symbol->c-id x)] [,i (number->string i)] [(label ,l) (format "(*~a)" (symbol->c-id l))] [(logand ,se0 ,se1) (format-binop "&" se0 se1)] [(shift-right ,se0 ,se1) (format-binop ">>" se0 se1)] [(shift-left ,se0 ,se1) (format-binop "<<" se0 se1)] [(divide ,se0 ,se1) (format-binop "/" se0 se1)] [(multiply ,se0 ,se1) (format-binop "*" se0 se1)] [(subtract ,se0 ,se1) (format-binop "-" se0 se1)] [(add ,se0 ,se1) (format-binop "+" se0 se1)] [(mref ,se0 ,se1? ,i) (if se1? (format "(*((ptr)((long)~a + (long)~a + ~d)))" (format-simple-expr se0) (format-simple-expr se1?) i) (format "(*((ptr)((long)~a + ~d)))" (format-simple-expr se0) i))]) ;; prints expressions in effect position into C statements (emit-effect : Effect (e) -> * () [(if ,p0 ,e1 ,e2) (printf " if (~a) {~%" (format-predicate p0)) (emit-effect e1) (printf " } else {~%") (emit-effect e2) (printf " }~%")] [((label ,l) ,se* ...) (printf " ~a;\n" (format-label-call l se*))] [(,se ,se* ...) (printf " ~a;\n" (format-general-call se se*))] [(set! ,x ,rhs) (printf " ~a;\n" (format-set! x rhs))] [(nop) (if #f #f)] [(begin ,e* ... ,e) (for-each emit-effect e*) (emit-effect e)] [(mset! ,se0 ,se1? ,i ,se2) (if se1? (printf "(*((ptr*)((long)~a + (long)~a + ~d))) = (ptr)~a;\n" (format-simple-expr se0) (format-simple-expr se1?) i (format-simple-expr se2)) (printf "(*((ptr*)((long)~a + ~d))) = (ptr)~a;\n" (format-simple-expr se0) i (format-simple-expr se2)))]) ;; formats the right-hand side of a set! into a C expression (format-rhs : Rhs (rhs) -> * (str) [((label ,l) ,se* ...) (format-label-call l se*)] [(,se ,se* ...) (format-general-call se se*)] [(alloc ,i ,se) (if (use-boehm?) (format "(ptr)((long)GC_MALLOC(~a) + ~dl)" (format-simple-expr se) i) (format "(ptr)((long)malloc(~a) + ~dl)" (format-simple-expr se) i))] [,se (format-simple-expr se)]) ;; emits a C program for our progam expression (Program : Program (p) -> * () [(labels ([,l* ,le*] ...) ,l) (let ([l (symbol->c-id l)] [l* (map symbol->c-id l*)]) (define-syntax emit-include (syntax-rules () [(_ name) (printf "#include <~s>\n" 'name)])) (define-syntax emit-predicate (syntax-rules () [(_ PRED_P mask tag) (emit-c-macro PRED_P (x) "(((long)x & ~d) == ~d)" mask tag)])) (define-syntax emit-eq-predicate (syntax-rules () [(_ PRED_P rep) (emit-c-macro PRED_P (x) "((long)x == ~d)" rep)])) (define-syntax emit-c-macro (lambda (x) (syntax-case x() [(_ NAME (x* ...) fmt args ...) #'(printf "#define ~s(~a) ~a\n" 'NAME (string-join (map symbol->string '(x* ...)) ", ") (format fmt args ...))]))) ;; the following printfs output the tiny C runtime we are using ;; to wrap the result of our compiled Scheme program. (emit-include stdio.h) (if (use-boehm?) (emit-include gc.h) (emit-include stdlib.h)) (emit-predicate FIXNUM_P fixnum-mask fixnum-tag) (emit-predicate PAIR_P pair-mask pair-tag) (emit-predicate BOX_P box-mask box-tag) (emit-predicate VECTOR_P vector-mask vector-tag) (emit-predicate PROCEDURE_P closure-mask closure-tag) (emit-eq-predicate TRUE_P true-rep) (emit-eq-predicate FALSE_P false-rep) (emit-eq-predicate NULL_P null-rep) (emit-eq-predicate VOID_P void-rep) (printf "typedef long* ptr;\n") (emit-c-macro FIX (x) "((long)x << ~d)" fixnum-shift) (emit-c-macro UNFIX (x) "((long)x >> ~d)" fixnum-shift) (emit-c-macro UNBOX (x) "((ptr)*((ptr)((long)x - ~d)))" box-tag) (emit-c-macro VECTOR_LENGTH_S (x) "((ptr)*((ptr)((long)x - ~d)))" vector-tag) (emit-c-macro VECTOR_LENGTH_C (x) "UNFIX(VECTOR_LENGTH_S(x))") (emit-c-macro VECTOR_REF (x i) "((ptr)*((ptr)((long)x - ~d + ((i+1) * ~d))))" vector-tag word-size) (emit-c-macro CAR (x) "((ptr)*((ptr)((long)x - ~d)))" pair-tag) (emit-c-macro CDR (x) "((ptr)*((ptr)((long)x - ~d + ~d)))" pair-tag word-size) (printf "void print_scheme_value(ptr x) {\n") (printf " long i, veclen;\n") (printf " ptr p;\n") (printf " if (TRUE_P(x)) {\n") (printf " printf(\"#t\");\n") (printf " } else if (FALSE_P(x)) {\n") (printf " printf(\"#f\");\n") (printf " } else if (NULL_P(x)) {\n") (printf " printf(\"()\");\n") (printf " } else if (VOID_P(x)) {\n") (printf " printf(\"(void)\");\n") (printf " } else if (FIXNUM_P(x)) {\n") (printf " printf(\"%ld\", UNFIX(x));\n") (printf " } else if (PAIR_P(x)) {\n") (printf " printf(\"(\");\n") (printf " for (p = x; PAIR_P(p); p = CDR(p)) {\n") (printf " print_scheme_value(CAR(p));\n") (printf " if (PAIR_P(CDR(p))) { printf(\" \"); }\n") (printf " }\n") (printf " if (NULL_P(p)) {\n") (printf " printf(\")\");\n") (printf " } else {\n") (printf " printf(\" . \");\n") (printf " print_scheme_value(p);\n") (printf " printf(\")\");\n") (printf " }\n") (printf " } else if (BOX_P(x)) {\n") (printf " printf(\"#(box \");\n") (printf " print_scheme_value(UNBOX(x));\n") (printf " printf(\")\");\n") (printf " } else if (VECTOR_P(x)) {\n") (printf " veclen = VECTOR_LENGTH_C(x);\n") (printf " printf(\"#(\");\n") (printf " for (i = 0; i < veclen; i += 1) {\n") (printf " print_scheme_value(VECTOR_REF(x,i));\n") (printf " if (i < veclen) { printf(\" \"); } \n") (printf " }\n") (printf " printf(\")\");\n") (printf " } else if (PROCEDURE_P(x)) {\n") (printf " printf(\"#(procedure)\");\n") (printf " }\n") (printf "}\n") (map emit-function-decl le* l*) (map emit-function-def le* l*) (printf "int main(int argc, char * argv[]) {\n") (printf " print_scheme_value(~a());\n" l) (printf " printf(\"\\n\");\n") (printf " return 0;\n") (printf "}\n"))])) \endschemedisplay } \noindent Again, a \scheme{*} is used to indicate that there is no language form in this case for the output language. The C code is printed to the standard output port. Thus, there is no need for any return value from this pass. Passes can also return a value that is not a language form. For instance, we could write the \scheme{simple?} predicate from \scheme{purify-letrec} pass as its own pass, rather than using the \scheme{nanopass-case} form. It would look something like the following: {\small \schemedisplay (define-pass simple? : (L8 Expr) (e bound* assigned*) -> * (bool) (simple? : Expr (e) -> * (bool) [(quote ,c) #t] [,x (not (or (memq x bound*) (memq x assigned*)))] [(primcall ,pr ,e* ...) (and (effect-free-prim? pr) (for-all simple? e*))] [(begin ,e* ... ,e) (and (for-all simple? e*) (simple? e))] [(if ,e0 ,e1 ,e2) (and (simple? e0) (simple? e1) (simple? e2))] [else #f]) (simple? e)) \endschemedisplay } \noindent Here, the extra return value is indicated as \scheme{bool}. The \scheme{bool} here is used to indicate to \scheme{define-pass} that an extra value is being returned. Any expression can be used in this position. In this case, the \scheme{bool} identifier will simply be an unbound variable if it is ever manifested. It is not manifested in this case, however, because the body is explicitly specified; thus, no code will be autogenerated for the body of the pass. \subsection{The {\tt define-pass} syntactic form\label{sec:pass-syntax}} The \scheme{define-pass} form has the following syntax. {\small \schemedisplay (define-pass \var{name} : \var{lang-specifier} (\var{fml} ...) -> \var{lang-specifier} (\var{extra-return-val-expr} ...) \var{definitions-clause} \var{transformer-clause} ... \var{body-expr} ...) \endschemedisplay } \noindent where \var{name} is an identifier to use as the name for the procedure definition. The \var{lang-specifier} has one of the following forms: {\small \schemedisplay * \var{lang-name} (\var{lang-name} \var{nonterminal-name}) \endschemedisplay } \noindent where \begin{itemize} \item \var{lang-name} refers to a language defined with the \scheme{define-language} form, and \item \var{nonterminal-name} refers to a nonterminal named within the language definition. \end{itemize} When the \scheme{*} form is used as the input \var{lang-specifier}, it indicates that the pass does not expect an input-language term. When there is no input language, the transformers within the pass do not have clauses with pattern matches because, without an input language, the \scheme{define-pass} macro does not know what the structure of the input term will be. When the \scheme{*} form is used as the output \var{lang-specifier}, it indicates that the pass does not produce an output-language term and should not be checked. When there is no output language, the transformers within the pass do not bind \scheme{quasiquote}, and there are no templates on the right-hand side of the transformer matches. It is possible to use the \scheme{*} specifier for both the input and output \var{lang-specifier}. This effectively turns the pass, and the transformers contained within it, into an ordinary Scheme function. When the \var{lang-name} form is used as the input \var{lang-specifier}, it indicates that the pass expects an input-language term that is one of the productions from the entry nonterminal. When the \var{lang-name} form is used as the output \var{lang-specifier}, it indicates that the pass expects that an output-language term will be produced and checked to be one of the records that represents a production of the entry nonterminal. When the (\var{lang-name} \var{nonterminal-name}) form is used as the input-language specifier, it indicates that the input-language term will be a production from the specified nonterminal in the specified input language. When the (\var{lang-name} \var{nonterminal-name}) form is used as the output-language specifier, it indicates that the pass will produce an output production from the specified nonterminal of the specified output language. The \var{fml} is a Scheme identifier, and if the input \var{lang-specifier} is not \scheme{*}, the first \var{fml} refers to the input-language term. The \var{extra-return-val-expr} is any valid Scheme expression that is valid in value context. These expressions are scoped within the binding of the identifiers named as \var{fml}s. The optional \var{definitions-clause} has the following form: {\small \schemedisplay (definitions \var{scheme-definition} ...) \endschemedisplay } \noindent where \var{scheme-definition} is any Scheme expression that can be used in definition context. Definitions in the \var{definitions-clause} are in the same lexical scope as the transformers, which means that procedures and macros defined in the \var{definitions-clause} can refer to any transformer named in a \var{transformer-clause}. The \var{definitions-clause} is followed by zero or more \var{transformer-clauses}s of the following form: {\small \schemedisplay (\var{name} : \var{nt-specifier} (\var{fml-expr} ...) -> \var{nt-specifier} (\var{extra-return-val-expr} ...) \var{definitions-clause}? \var{transformer-body}) \endschemedisplay } \noindent where \var{name} is a Scheme identifier that can be used to refer to the transformer within the pass. The input \var{nt-specifier} is one of the following two forms: {\small \schemedisplay * \var{nonterminal-name} \endschemedisplay } \noindent When the \scheme{*} form is used as the input nonterminal, it indicates that no input nonterminal form is expected and that the body of the \var{transformer-body} will not contain pattern matching clauses. When the \scheme{*} form is used as the output nonterminal, \scheme{quasiquote} will not be rebound, and no output-language templates are available. When both the input and output \var{nt-specifier} are \scheme{*}, the transformer is effectively an ordinary Scheme procedure. The \var{fml-expr} has one of the following two forms: {\small \schemedisplay \var{fml} [\var{fml} \var{default-val-expr}] \endschemedisplay } \noindent where \var{fml} is a Scheme identifier and \var{default-val-expr} is a Scheme expression. The \var{default-val-expr} is used when an argument is not specified in a catamorphism or when a matching \scheme{fml} is not available in the calling transformer. All arguments must be explicitly provided when the transformer is called as an ordinary Scheme procedure. Using the catamorphism syntax, the arguments can be explicitly supplied, using the syntax discussed on page~\pageref{cata:syntax}. It can also be specified implicitly. Arguments are filled in implicitly in catamorphisms that do not explicitly provide the arguments and in autogenerated clauses when the nonterminal elements of a production are processed. These implicitly supplied formals are handled by looking for a formal in the calling transformer that has the same name as the formal expected by the target transformer. If no matching formal is found, and the target transformer specifies a default value, the default value will be used in the call; otherwise, another target transformer must be found, a new transformer must be autogenerated, or an exception must be raised to indicate that no transformer was found and none can be autogenerated. The \var{extra-return-val-expr} can be any Scheme expression. These expressions are scoped within the \var{fml}s bound by the transformer. This allows an input formal to be returned as an extra return value, implicitly in the autogenerated clauses. This can be useful for threading values through a transformer. The optional \var{definitions-clause} can include any Scheme expression that can be placed in a definition context. These definitions are scoped within the transformer. When an output nonterminal is specified, the \scheme{quasiquote} is also bound within the body of the \scheme{definitions} clause to allow language term templates to be included in the body of the definitions. When the input \var{nt-specifier} is not \scheme{*}, the \var{transformer-body} has one of the following forms: {\small \schemedisplay [\var{pattern} \var{guard-clause} \var{body*} ... \var{body}] [\var{pattern} \var{body*} ... \var{body}] [else \var{body*} ... \var{body}] \endschemedisplay } \noindent where the \scheme{else} clause must be the last one listed in a transformer and prevents autogeneration of missing clauses (because the \scheme{else} clause is used in place of the autogenerated clauses). The \var{pattern} is an S-expression pattern, based on the S-expression productions used in the language definition. Patterns can be arbitrarily nested. Variables bound by the pattern are preceded by an \scheme{unquote} and are named based on the meta-variables named in the language definition. The variable name can be used to restrict the pattern by using a meta-variable that is more specific than the one specified in the language definition. The \var{pattern} can also contain catamorphisms that have one of the following forms: {\small \label{cata:syntax} \schemedisplay [\var{Proc-expr} : \var{input-fml} \var{arg} ... -> \var{output-fml} \var{extra-rv-fml} ...] [\var{Transformer-name} : \var{output-fml} \var{extra-rv-fml} ...] [\var{input-fml} \var{arg} ... -> \var{output-fml} \var{extra-rv-fml} ...] [\var{output-fml} \var{extra-rv-fml} ...] \endschemedisplay } \noindent In the first form, the \var{Proc-expr} is an explicitly specified procedure expression, the \var{input-fml} and all arguments to the procedure are explicitly specified, and the results of calling the \var{Proc-expr} are bound by the \var{output-fml} and \var{extra-rv-fml}s. Note that the \var{Proc-expr} may be a \var{Transformer-name}. In the second form, the \var{Transformer-name} is an identifier that refers to a transformer named in this pass. The \scheme{define-pass} macro determines, based on the signature of the transformer referred to by the \var{Transformer-name}, what arguments should be supplied to the transformer. In the last two forms, the transformer is determined automatically. In the third form, the nonterminal type associated with the \var{input-fml}, the \var{arg}s, the output nonterminal type based on the \var{output-fml}, and the \var{extra-rv-fml}s are used to determine the transformer to call. In the final form, the nonterminal type for the field within the production, along with the formals to the calling transformer, the output nonterminal type based on the \var{output-fml}, and the \var{extra-rv-fml}s are used to determine the transformer to call. In the two forms where the transformer is not explicitly named, a new transformer can be autogenerated when no \var{arg}s and no \var{extra-rv-fml}s are specified. This limitation is in place to avoid creating a transformer with extra formals whose use is unspecified and extra return values with potentially dubious return-value expressions. The \var{input-fml} is a Scheme identifier with a name based on the meta-variables named in the input-language definition. The specification of a more restrictive meta-variable name can be used to further restrict the pattern. The \var{output-fml} is a Scheme identifier with a name based on the meta-variables named in the output-language definition. The \var{extra-rv-fml} is a Scheme identifier. The \var{input-fml}s named in the fields of a pattern must be unique. The \var{output-fml}s and \var{extra-rv-fml}s must also be unique, although they can overlap with the \var{input-fml}s that are shadowed in the body by the \var{output-fml} or \var{extra-rv-fml} with the same name. Only the \var{input-fml}s are visible within the optional \var{guard-clause}. This is because the \var{guard-clause} is evaluated before the catamorphisms recur on the fields of a production. The \var{guard-clause} has the following form: {\small \schemedisplay (guard \var{guard-expr} ...) \endschemedisplay } \noindent where \var{guard-expr} is a Scheme expression. The \var{guard-clause} has the same semantics as \scheme{and}. The \var{body*} and \var{body} are any Scheme expression. When the output \var{nt-specifier} is not \scheme{*}, \scheme{quasiquote} is rebound to a macro that interprets \scheme{quasiquote} expressions as templates for productions in the output nonterminal. Additionally, \scheme{in-context} is a macro that can be used to rebind \scheme{quasiquote} to a different nonterminal. Templates are specified as S-expressions based on the productions specified by the output language. In templates, \scheme{unquote} is used to indicate that the expression in the \scheme{unquote} should be used to fill in the given field of the production. Within an \scheme{unquote} expression, \scheme{quasiquote} is rebound to the appropriate nonterminal based on the expected type of the field in the production. If the template includes items that are not \scheme{unquote}d where a field value is expected, the expression found there is automatically quoted. This allows self-evaluating items such as symbols, booleans, and numbers to be more easily specified in templates. A list of items can be specified in a field that expects a list, using an ellipsis. %More than one ellipsis can be specified to flatten out a list of lists. Although the syntax of a language production is specified as an S-expression, the record representation used for the language term separates each variable specified into a separate field. This means that the template syntax expects a separate value or list of values for each field in the record. For instance, in the \scheme{(letrec ([x* e*] ...) body)} production, a template of the form \scheme{(letrec (,bindings ...) ,body)} cannot be used because the nanopass framework will not attempt to break up the \scheme{bindings} list into its \scheme{x*} and \scheme{e*} component parts. The template \scheme{(letrec ([,(map car bindings) ,(map cadr bindings)] ...) ,body)} accomplishes the same goal, explicitly separating the variables from the expressions. It is possible that the nanopass framework could be extended to perform the task of splitting up the \scheme{binding*} list automatically, but it is not done currently, partially to avoid hiding the cost of deconstructing the \scheme{binding*} list and constructing the \scheme{x*} and \scheme{e*} lists. The \scheme{in-context} expression within the body has the following form: {\small \schemedisplay (in-context \var{nonterminal-name} \var{body*} ... \var{body}) \endschemedisplay } The \scheme{in-context} form rebinds the \scheme{quasiquote} to allow productions from the named nonterminal to be constructed in a context where they are not otherwise expected. \chapter{Working with language forms} \section{Constructing language forms outside of a pass} In addition to creating language forms using a parser defined with \scheme{define-parser} or through a pass defined with \scheme{define-pass}, language forms can also be created using the \scheme{with-output-language} form. The \scheme{with-output-language} form binds the \scheme{in-context} transformer for the language specified and, if a nonterminal is also specified, binds the \scheme{quasiquote} form. This allows the same template syntax used in the body of a transformer to be used outside of the context of a pass. In a commercial compiler, such as Chez Scheme, it is often convenient to use functional abstraction to centralize the creation of a language term. For instance, in the \scheme{convert-assignments} pass, the \scheme{with-output-languge} form is wrapped around the \scheme{make-boxes} and \scheme{build-let} procedures. This is done so that primitive calls to \scheme{box} along with the \scheme{let} form of the \scheme{L10} language can be constructed with quasiquoted expressions. {\small \schemedisplay (with-output-language (L10 Expr) (define make-boxes (lambda (t*) (map (lambda (t) `(primcall box ,t)) t*))) (define build-let (lambda (x* e* body) (if (null? x*) body `(let ([,x* ,e*] ...) ,body))))) \endschemedisplay } \noindent This rebinds both the \scheme{quasiquote} keyword and the \scheme{in-context} keyword. The \scheme{with-output-language} form has one of the following forms: {\small \schemedisplay (with-output-language \var{lang-name} \var{expr*} ... \var{expr}) (with-output-language (\var{lang-name} \var{nonterminal-name}) \var{expr*} ... \var{expr}) \endschemedisplay } \noindent In the first form, the \scheme{in-context} form is bound and can be used to specify a \var{nonterminal-name}, as described at the end of Section~\ref{sec:define-pass}. In the second form, both \scheme{in-context} and \scheme{quasiquote} are bound. The \scheme{quasiquote} form is bound in the context of the specified \var{nonterminal-name}, and templates can be defined just as they are on the right-hand side of a transformer clause. The \scheme{with-output-language} form is a splicing form, similar to \scheme{begin} or \scheme{let-syntax}, allowing multiple definitions or expressions that are all at the same scoping level as the \scheme{with-output-language} form to be contained within the form. This is convenient when writing a set of definitions that all construct some piece of a language term from the same nonterminal. This flexibility means that the \scheme{with-output-language} form cannot be defined as syntactic sugar for the \scheme{define-pass} form. \section{Matching language forms outside of a pass} In addition to the \scheme{define-pass} form, it is possible to match a language term using the \scheme{nanopass-case} form. This can be useful when creating functional abstractions, such as predicates that ask a question based on matching a language form. For instance, suppose we write a \scheme{lambda?} predicate for the \scheme{L8} language as follows: {\small \schemedisplay (define lambda? (lambda (e) (nanopass-case (L8 Expr) e [(lambda (,x* ...) ,abody) #t] [else #f]))) \endschemedisplay } \noindent The \scheme{nanopass-case} form has the following syntax: {\small \schemedisplay (nanopass-case (\var{lang-name} \var{nonterminal-name}) \var{expr} \var{matching-clause} ...) \endschemedisplay } \noindent where \var{matching-clause} has one of the following forms: {\small \schemedisplay [\var{pattern} \var{guard-clause} \var{expr*} ... \var{expr}] [\var{pattern} \var{expr*} ... \var{expr}] [else \var{expr*} ... \var{expr}] \endschemedisplay } \noindent where the \var{pattern} and \var{guard-clause} forms have the same syntax as in the \var{transformer-body} of a pass. Similar to \scheme{with-output-language}, \scheme{nanopass-case} provides a more succinct syntax for matching a language form than does the general \scheme{define-pass} form. Unlike the \scheme{with-output-language} form, however, the \scheme{nanopass-case} form can be implemented in terms of the \scheme{define-pass} form. For example, the \scheme{lambda?} predicate also could have been written as: {\small \schemedisplay (define-pass lambda? : (L8 Expr) (e) -> * (bool) (Expr : Expr (e) -> * (bool) [(lambda (,x* ...) ,abody) #t] [else #f]) (Expr e)) \endschemedisplay } \noindent This is, in fact, how the \scheme{nanopass-case} macro is implemented. \chapter{Working with languages} \section{Displaying languages} The \scheme{language->s-expression} form can be used to print the full definition of a language by supplying it the language name to be printed. This can be helpful when working with extended languages, such as in the case of \scheme{L1}: {\small \schemedisplay (language->s-expression L1) \endschemedisplay } \noindent which returns: {\small \schemedisplay (define-language L1 (entry Expr) (terminals (void+primitive (pr)) (symbol (x)) (constant (c)) (datum (d))) (Expr (e body) pr x c (quote d) (if e0 e1 e2) (or e* ...) (and e* ...) (not e) (begin e* ... e) (lambda (x* ...) body* ... body) (let ([x* e*] ...) body* ... body) (letrec ([x* e*] ...) body* ... body) (set! x e) (e e* ...))) \endschemedisplay } \section{Differencing languages} The extension form can also be derived between any two languages by using the \scheme{diff-languages} form. For instance, we can get the differences between the \scheme{Lsrc} and \scheme{L1} language (giving us back the extension) with: {\small \schemedisplay (diff-languages Lsrc L1) \endschemedisplay } \noindent which returns: {\small \schemedisplay (define-language L1 (extends Lsrc) (entry Expr) (terminals (- (primitive (pr))) (+ (void+primitive (pr)))) (Expr (e body) (- (if e0 e1)))) \endschemedisplay } \section{Viewing the expansion of passes and transformers} The \scheme{define-pass} form autogenerates both transformers and clauses within transformers. In simple passes, these are generally straightforward to reason about, but in more complex passes, particularly those that make use of different arguments for different transformers or include extra return values, it can become more difficult to determine what code will be generated. In particular, the experience of developing a full commercial compiler has shown that the \scheme{define-pass} form can autogenerate transformers that shadow those defined by the compiler writer. To help the compiler writer determine what code is being generated, there is a variation of the \scheme{define-pass} form, called \scheme{echo-define-pass}, that will echo the expansion of \scheme{define-pass}. For instance, we can echo the \scheme{remove-one-armed-if} pass to get the following: {\small \schemedisplay (echo-define-pass remove-one-armed-if : Lsrc (e) -> L1 () (Expr : Expr (e) -> Expr () [(if ,[e0] ,[e1]) `(if ,e0 ,e1 (void))])) ;=> pass remove-one-armed-if expanded into: (define remove-one-armed-if (lambda (e) (define who 'remove-one-armed-if) (define-nanopass-record) (define Expr (lambda (e) (let ([g221.159 e]) (let-syntax ([quasiquote '#] [in-context '#]) (begin (let ([rhs.160 (lambda (e0 e1) `(if ,e0 ,e1 (void)))]) (cond [(primitive? g221.159) g221.159] [(symbol? g221.159) g221.159] [(constant? g221.159) g221.159] [else (let ([tag (nanopass-record-tag g221.159)]) (cond [(eqv? tag 4) (let* ([g222.161 (Lsrc:if:Expr.387-e0 g221.159)] [g223.162 (Lsrc:if:Expr.387-e1 g221.159)]) (let-values ([(e0) (Expr g222.161)] [(e1) (Expr g223.162)]) (rhs.160 e0 e1)))] [(eqv? tag 2) (make-L1:quote:Expr.400 'remove-one-armed-if (Lsrc:quote:Expr.386-d g221.159) "d")] [(eqv? tag 6) (make-L1:if:Expr.401 'remove-one-armed-if (Expr (Lsrc:if:Expr.388-e0 g221.159)) (Expr (Lsrc:if:Expr.388-e1 g221.159)) (Expr (Lsrc:if:Expr.388-e2 g221.159)) "e0" "e1" "e2")] [(eqv? tag 8) (make-L1:or:Expr.402 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:or:Expr.389-e* g221.159)) "e*")] [(eqv? tag 10) (make-L1:and:Expr.403 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:and:Expr.390-e* g221.159)) "e*")] [(eqv? tag 12) (make-L1:not:Expr.404 'remove-one-armed-if (Expr (Lsrc:not:Expr.391-e g221.159)) "e")] [(eqv? tag 14) (make-L1:begin:Expr.405 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:begin:Expr.392-e* g221.159)) (Expr (Lsrc:begin:Expr.392-e g221.159)) "e*" "e")] [(eqv? tag 16) (make-L1:lambda:Expr.406 'remove-one-armed-if (Lsrc:lambda:Expr.393-x* g221.159) (map (lambda (m) (Expr m)) (Lsrc:lambda:Expr.393-body* g221.159)) (Expr (Lsrc:lambda:Expr.393-body g221.159)) "x*" "body*" "body")] [(eqv? tag 18) (make-L1:let:Expr.407 'remove-one-armed-if (Lsrc:let:Expr.394-x* g221.159) (map (lambda (m) (Expr m)) (Lsrc:let:Expr.394-e* g221.159)) (map (lambda (m) (Expr m)) (Lsrc:let:Expr.394-body* g221.159)) (Expr (Lsrc:let:Expr.394-body g221.159)) "x*" "e*" "body*" "body")] [(eqv? tag 20) (make-L1:letrec:Expr.408 'remove-one-armed-if (Lsrc:letrec:Expr.395-x* g221.159) (map (lambda (m) (Expr m)) (Lsrc:letrec:Expr.395-e* g221.159)) (map (lambda (m) (Expr m)) (Lsrc:letrec:Expr.395-body* g221.159)) (Expr (Lsrc:letrec:Expr.395-body g221.159)) "x*" "e*" "body*" "body")] [(eqv? tag 22) (make-L1:set!:Expr.409 'remove-one-armed-if (Lsrc:set!:Expr.396-x g221.159) (Expr (Lsrc:set!:Expr.396-e g221.159)) "x" "e")] [(eqv? tag 24) (make-L1:e:Expr.410 'remove-one-armed-if (Expr (Lsrc:e:Expr.397-e g221.159)) (map (lambda (m) (Expr m)) (Lsrc:e:Expr.397-e* g221.159)) "e" "e*")] [else (error 'remove-one-armed-if "unexpected Expr" g221.159)]))]))))))) (let ([x (Expr e)]) (unless ((lambda (x) (or (L1:Expr.399? x) (constant? x) (symbol? x) (void+primitive? x))) x) (error 'remove-one-armed-if (format "expected ~s but got ~s" 'Expr x))) x))) \endschemedisplay } \noindent This exposes the code generated by \scheme{define-pass} but does not expand the language form construction templates. The autogenerated clauses, such as the one that handles \scheme{set!}, have a form like the following: {\small \schemedisplay [(eqv? tag 7) (make-L1:set!:Expr.18 (Lsrc:set!:Expr.8-x g0.14) (Expr (Lsrc:set!:Expr.8-e g0.14)))] \endschemedisplay } \noindent Here, the tag of the record is checked and a new output-language record constructed, after recurring to the \scheme{Expr} transformer on the \scheme{e} field. The body code also changes slightly, so that the output of the pass can be checked to make sure that it is a valid \scheme{L1} \scheme{Expr}. In addition to echoing the output of the entire pass, it is also possible to echo just the expansion of a single transformer by prefixing the transformer with the \scheme{echo} keyword. {\small \schemedisplay (define-pass remove-one-armed-if : Lsrc (e) -> L1 () (echo Expr : Expr (e) -> Expr () [(if ,[e0] ,[e1]) `(if ,e0 ,e1 (void))])) ;=> Expr in pass remove-one-armed-if expanded into: (define Expr (lambda (e) (let ([g442.303 e]) (let-syntax ([quasiquote '#] [in-context '#]) (begin (let ([rhs.304 (lambda (e0 e1) `(if ,e0 ,e1 (void)))]) (cond [(primitive? g442.303) g442.303] [(symbol? g442.303) g442.303] [(constant? g442.303) g442.303] [else (let ([tag (nanopass-record-tag g442.303)]) (cond [(eqv? tag 4) (let* ([g443.305 (Lsrc:if:Expr.770-e0 g442.303)] [g444.306 (Lsrc:if:Expr.770-e1 g442.303)]) (let-values ([(e0) (Expr g443.305)] [(e1) (Expr g444.306)]) (rhs.304 e0 e1)))] [(eqv? tag 2) (make-L1:quote:Expr.783 'remove-one-armed-if (Lsrc:quote:Expr.769-d g442.303) "d")] [(eqv? tag 6) (make-L1:if:Expr.784 'remove-one-armed-if (Expr (Lsrc:if:Expr.771-e0 g442.303)) (Expr (Lsrc:if:Expr.771-e1 g442.303)) (Expr (Lsrc:if:Expr.771-e2 g442.303)) "e0" "e1" "e2")] [(eqv? tag 8) (make-L1:or:Expr.785 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:or:Expr.772-e* g442.303)) "e*")] [(eqv? tag 10) (make-L1:and:Expr.786 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:and:Expr.773-e* g442.303)) "e*")] [(eqv? tag 12) (make-L1:not:Expr.787 'remove-one-armed-if (Expr (Lsrc:not:Expr.774-e g442.303)) "e")] [(eqv? tag 14) (make-L1:begin:Expr.788 'remove-one-armed-if (map (lambda (m) (Expr m)) (Lsrc:begin:Expr.775-e* g442.303)) (Expr (Lsrc:begin:Expr.775-e g442.303)) "e*" "e")] [(eqv? tag 16) (make-L1:lambda:Expr.789 'remove-one-armed-if (Lsrc:lambda:Expr.776-x* g442.303) (map (lambda (m) (Expr m)) (Lsrc:lambda:Expr.776-body* g442.303)) (Expr (Lsrc:lambda:Expr.776-body g442.303)) "x*" "body*" "body")] [(eqv? tag 18) (make-L1:let:Expr.790 'remove-one-armed-if (Lsrc:let:Expr.777-x* g442.303) (map (lambda (m) (Expr m)) (Lsrc:let:Expr.777-e* g442.303)) (map (lambda (m) (Expr m)) (Lsrc:let:Expr.777-body* g442.303)) (Expr (Lsrc:let:Expr.777-body g442.303)) "x*" "e*" "body*" "body")] [(eqv? tag 20) (make-L1:letrec:Expr.791 'remove-one-armed-if (Lsrc:letrec:Expr.778-x* g442.303) (map (lambda (m) (Expr m)) (Lsrc:letrec:Expr.778-e* g442.303)) (map (lambda (m) (Expr m)) (Lsrc:letrec:Expr.778-body* g442.303)) (Expr (Lsrc:letrec:Expr.778-body g442.303)) "x*" "e*" "body*" "body")] [(eqv? tag 22) (make-L1:set!:Expr.792 'remove-one-armed-if (Lsrc:set!:Expr.779-x g442.303) (Expr (Lsrc:set!:Expr.779-e g442.303)) "x" "e")] [(eqv? tag 24) (make-L1:e:Expr.793 'remove-one-armed-if (Expr (Lsrc:e:Expr.780-e g442.303)) (map (lambda (m) (Expr m)) (Lsrc:e:Expr.780-e* g442.303)) "e" "e*")] [else (error 'remove-one-armed-if "unexpected Expr" g442.303)]))]))))))) \endschemedisplay } \section{Tracing passes and transformers} Echoing the code generated by \scheme{define-pass} can help compiler writers to understand what is happening at expansion time, but it does not help in determining what is happening at run time. To facilitate this type of debugging, passes and transformers can be traced at run time. The tracing system, similar to Chez Scheme's \scheme{trace-define-syntax}, unparses the input-language term and output-language term of the pass using the language unparsers to provide the S-expression representation of the language term that is being transformed. The \scheme{trace-define-pass} form works just like the \scheme{define-pass} form but adds tracing for the input-language term and output-language term of the pass. For instance, if we want to trace the processing of the input: {\small \schemedisplay (let ([x 10]) (if (= (* (/ x 2) 2) x) (set! x (/ x 2))) (* x 3)) \endschemedisplay } \noindent the pass can be defined as a tracing pass, as follows: {\small \schemedisplay (trace-define-pass remove-one-armed-if : Lsrc (e) -> L1 () (Expr : Expr (e) -> Expr () [(if ,[e0] ,[e1]) `(if ,e0 ,e1 (void))])) \endschemedisplay } \noindent Running the class compiler with \scheme{remove-one-armed-if} traced produces the following: {\small \schemedisplay > (my-tiny-compile '(let ([x 10]) (if (= (* (/ x 2) 2) x) (set! x (/ x 2))) (* x 3))) |(remove-one-armed-if (let ([x.12 10]) (if (= (* (/ x.12 2) 2) x.12) (set! x.12 (/ x.12 2))) (* x.12 3))) |(let ([x.12 10]) (if (= (* (/ x.12 2) 2) x.12) (set! x.12 (/ x.12 2)) (void)) (* x.12 3)) 15 \endschemedisplay } \noindent The tracer prints the \emph{pretty} (i.e., S-expression) form of the language, rather than the record representation, to allow the compiler writer to read the terms more easily. This does not trace the internal transformations that happen within the transformers of the pass. Transformers can be traced by adding the \scheme{trace} keyword in front of the transformer definition. We can run the same test with a \scheme{remove-one-armed-if} that traces the \scheme{Expr} transformer, as follows: {\small \schemedisplay > (my-tiny-compile '(let ([x 10]) (if (= (* (/ x 2) 2) x) (set! x (/ x 2))) (* x 3))) |(Expr (let ([x.0 10]) (if (= (* (/ x.0 2) 2) x.0) (set! x.0 (/ x.0 2))) (* x.0 3))) | (Expr (* x.0 3)) | |(Expr x.0) | |x.0 | |(Expr 3) | |3 | |(Expr *) | |* | (* x.0 3) | (Expr (if (= (* (/ x.0 2) 2) x.0) (set! x.0 (/ x.0 2)))) | |(Expr (= (* (/ x.0 2) 2) x.0)) | | (Expr (* (/ x.0 2) 2)) | | |(Expr (/ x.0 2)) | | | (Expr x.0) | | | x.0 | | | (Expr 2) | | | 2 | | | (Expr /) | | | / | | |(/ x.0 2) | | |(Expr 2) | | |2 | | |(Expr *) | | |* | | (* (/ x.0 2) 2) | | (Expr x.0) | | x.0 | | (Expr =) | | = | |(= (* (/ x.0 2) 2) x.0) | |(Expr (set! x.0 (/ x.0 2))) | | (Expr (/ x.0 2)) | | |(Expr x.0) | | |x.0 | | |(Expr 2) | | |2 | | |(Expr /) | | |/ | | (/ x.0 2) | |(set! x.0 (/ x.0 2)) | (if (= (* (/ x.0 2) 2) x.0) (set! x.0 (/ x.0 2)) (void)) | (Expr 10) | 10 |(let ([x.0 10]) (if (= (* (/ x.0 2) 2) x.0) (set! x.0 (/ x.0 2)) (void)) (* x.0 3)) 15 \endschemedisplay } \noindent Here, too, the traced forms are the pretty representation and not the record representation. \bibliographystyle{abbrv} \bibliography{user-guide} \end{document} nanopass-framework-scheme-1.9.2/nanopass.ss000066400000000000000000000015371374306730300210070ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/nanopass/000077500000000000000000000000001374306730300204325ustar00rootroot00000000000000nanopass-framework-scheme-1.9.2/nanopass/exp-syntax.sls000066400000000000000000000307511374306730300233030ustar00rootroot00000000000000(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)))]))) ) nanopass-framework-scheme-1.9.2/nanopass/experimental.sls000066400000000000000000002164661374306730300236710ustar00rootroot00000000000000(library (nanopass experimental) (export experimental-language datum? dots? maybe? syntax? exact-integer? Lnp-source unparse-Lnp-source parse-np-source Lcomplete unparse-Lcomplete language-information make-language-information language-information-language language-information-annotated-language handle-language-extension Llanguage unparse-Llanguage meta-variable-suffix-checker check-and-finish-language Lannotated unparse-Lannotated Lannotated? Lannotated-Defn? Lannotated-Terminal? Lannotated-Nonterminal? annotate-language star? modifier? Lpass-src unparse-Lpass-src lookup-language prune-lang diff-langs build-lang-node-counter build-unparser build-parser parse-pass Lpass unparse-Lpass) (import (rnrs) (nanopass) (nanopass helpers) (nanopass prefix-matcher) (only (chezscheme) box box? set-box! unbox make-parameter record-constructor-descriptor? eq-hashtable-update!)) (define-syntax experimental-language (lambda (x) (syntax-violation 'experimental-language "misplaced aux keyword" x))) (define-nanopass-record) (define (datum? x) #t) (define (dots? x) (eq? (syntax->datum x) '...)) (define (maybe? x) (eq? (syntax->datum x) 'maybe)) (define (syntax? x) #t) ;; could be slightly more perscriptive, and check for raw symbols (define (exact-integer? x) (and (integer? x) (exact? x))) (define-language Lnp-source (terminals (syntax (stx)) => syntax->datum (identifier (id)) => syntax->datum (datum (handler)) (dots (dots)) (null (null))) (Defn (def) (define-language id cl* ...)) (Clause (cl) (extends id) (entry id) (nongenerative-id id) (terminals term* ...) (id (id* ...) prod prod* ...)) (Terminal (term) base-term (+ base-term* ...) (- base-term* ...)) (BaseTerminal (base-term) simple-term (=> (=> simple-term handler) (=> simple-term handler))) (SimpleTerminal (simple-term) (id (id* ...))) (Production (prod) stx)) (define-pass parse-np-source : * (stx who) -> Lnp-source () (definitions (define (parse-terminals stx) (let f ([stx stx]) (syntax-case stx () [() '()] [_ (let-values ([(t stx) (Terminal stx #t)]) (cons t (f stx)))]))) (define (parse-base-terminals stx) (let f ([stx stx]) (syntax-case stx () [() '()] [_ (let-values ([(t stx) (Terminal stx #f)]) (cons t (f stx)))])))) (Defn : * (stx) -> Defn () (syntax-case stx () [(_ ?id ?cl ...) (identifier? #'?id) `(define-language ,#'?id ,(map Clause #'(?cl ...)) ...)] [_ (syntax-violation who "invalid syntax" stx)])) (Clause : * (stx) -> Clause () (syntax-case stx (extends entry terminals nongenerative-id) [(extends ?id) (identifier? #'?id) `(extends ,#'?id)] [(entry ?id) (identifier? #'?id) `(entry ,#'?id)] [(nongenerative-id ?id) (identifier? #'?id) `(nongenerative-id ,#'?id)] [(terminals ?term* ...) `(terminals ,(parse-terminals #'(?term* ...)) ...)] [(?id (?id* ...) ?prod ?prod* ...) (and (identifier? #'?id) (for-all identifier? #'(?id* ...))) `(,#'?id (,#'(?id* ...) ...) ,#'?prod ,#'(?prod* ...) ...)] [x (syntax-violation who "unrecognized language clause" stx #'x)])) (Terminal : * (stx ext-okay?) -> Terminal (stx) (syntax-case stx () [((=> (?id (?id* ...)) ?handler) . ?rest) (and (double-arrow? #'=>) (identifier? #'?id) (for-all identifier? #'(?id* ...))) (values `(=> (,#'?id (,#'(?id* ...) ...)) ,#'?handler) #'?rest)] [((?id (?id* ...)) => ?handler . ?rest) (and (double-arrow? #'=>) (identifier? #'?id) (for-all identifier? #'(?id* ...))) (values `(=> (,#'?id (,#'(?id* ...) ...)) ,#'?handler) #'?rest)] [((?id (?id* ...)) . ?rest) (and (identifier? #'?id) (for-all identifier? #'(?id* ...))) (values `(,#'?id (,#'(?id* ...) ...)) #'?rest)] [((+ ?term* ...) . ?rest) (and ext-okay? (plus? #'+)) (values `(+ ,(parse-base-terminals #'(?term* ...)) ...) #'?rest)] [((- ?term* ...) . ?rest) (and ext-okay? (minus? #'-)) (values `(- ,(parse-base-terminals #'(?term* ...)) ...) #'?rest)] [x (syntax-violation who "unrecognized terminal clause" stx #'x)])) (Defn stx)) (define-language Lcomplete (extends Lnp-source) (Clause (cl) (- (extends id) (id (id* ...) prod prod* ...)) (+ (id (id* ...) prod* ...))) ;; really the requirement remains, but is enforced in pass (Terminal (term) (- base-term (+ base-term* ...) (- base-term* ...)) (+ simple-term (=> (=> simple-term handler) (=> simple-term handler)))) (BaseTerminal (base-term) (- simple-term (=> (=> simple-term handler) (=> simple-term handler)))) (Production (prod) (- stx) (+ pattern (=> (=> pattern0 pattern1) (=> pattern0 pattern1)) (=> (-> pattern handler) (-> pattern handler)))) (Pattern (pattern) (+ id (maybe id) (pattern0 dots . pattern1) (pattern0 . pattern1) null))) (define-record-type language-information (nongenerative) (fields language annotated-language)) (define-pass handle-language-extension : Lnp-source (lang who rho) -> Lcomplete () (definitions (define (language-extension? cl*) (fold-left (lambda (ext? cl) (nanopass-case (Lnp-source Clause) cl [(extends ,id) id] [else ext?])) #f cl*)) (define parse-productions (case-lambda [(stx) (parse-productions stx '())] [(stx prod*) (let f ([stx stx]) (syntax-case stx () [() prod*] [_ (let-values ([(prod stx) (FinishProd stx)]) (cons prod (f stx)))]))])) (define (extend-clauses cl* base-lang) (nanopass-case (Lannotated Defn) base-lang [(define-language ,id ,ref ,id? ,rtd ,rcd ,tag-mask (,term* ...) ,nt* ...) (let loop ([cl* cl*] [term* term*] [nt* nt*] [new-term* '()] [new-cl* '()]) (if (null? cl*) (cons (with-output-language (Lcomplete Clause) `(terminals ,(fold-left (lambda (new-term* term) (cons (rewrite-annotated-term term) new-term*)) new-term* term*) ...)) (fold-left (lambda (new-cl* nt) (cons (rewrite-annotated-nt nt) new-cl*)) new-cl* nt*)) (let-values ([(term* nt* new-cl* new-term*) (ExtendClause (car cl*) term* nt* new-cl* new-term*)]) (loop (cdr cl*) term* nt* new-term* new-cl*))))])) (define-pass rewrite-annotated-term : (Lannotated Terminal) (ir) -> (Lcomplete Terminal) () (Terminal : Terminal (ir) -> Terminal () [(,id (,id* ...) ,b ,handler? ,pred) (if handler? `(=> (,id (,id* ...)) ,handler?) `(,id (,id* ...)))])) (define-pass rewrite-production : (Lannotated Production) (ir) -> (Lcomplete Production) () (Production : Production (ir) -> Production () (definitions (define (finish-prod pattern pretty-prod?) (if pretty-prod? (nanopass-case (Lannotated PrettyProduction) pretty-prod? [(procedure ,handler) `(-> ,pattern ,handler)] [(pretty ,pattern0) `(=> ,pattern ,(Pattern pattern0))]) pattern))) [(production ,[pattern] ,pretty-prod? ,rtd ,tag ,pred ,maker ,field* ...) (finish-prod pattern pretty-prod?)] [(terminal ,[pattern] ,pretty-prod?) (finish-prod pattern pretty-prod?)] [(nonterminal ,[pattern] ,pretty-prod?) (finish-prod pattern pretty-prod?)] [else (errorf who "unexpected Production ~s" (unparse-Lannotated ir))]) (Reference : Reference (ir) -> Pattern () [(term-ref ,id0 ,id1 ,b) id0] [(nt-ref ,id0 ,id1 ,b) id0]) (Pattern : Pattern (ir) -> Pattern () [,id id] [,ref (Reference ref)] [(maybe ,[pattern]) `(maybe ,pattern)] [(,[pattern0] ,dots . ,[pattern1]) `(,pattern0 ,dots . ,pattern1)] [(,[pattern0] . ,[pattern1]) `(,pattern0 . ,pattern1)] [,null null])) (define-pass rewrite-annotated-nt : (Lannotated Nonterminal) (ir) -> (Lcomplete Clause) () (Nonterminal : Nonterminal (ir) -> Clause () [(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...) `(,id (,id* ...) ,(map rewrite-production prod*) ...)])) (define (extend-terminals term* old-term* new-term*) (let loop ([term* term*] [old-term* old-term*] [new-term* new-term*]) (if (null? term*) (values old-term* new-term*) (let-values ([(new-term* old-term*) (ExtendTerminal (car term*) new-term* old-term*)]) (loop (cdr term*) old-term* new-term*))))) (define (extend-productions stx* old-prod*) (with-values (let f ([stx* stx*]) (if (null? stx*) (values '() old-prod*) (let-values ([(new-prod* old-prod*) (f (cdr stx*))]) (ExtendProd (car stx*) new-prod* old-prod*)))) (lambda (prod* old-prod*) (fold-left (lambda (prod* old-prod) (cons (rewrite-production old-prod) prod*)) prod* old-prod*)))) (define (remove-productions stx old-prod*) (let loop ([stx stx] [old-prod* old-prod*]) (syntax-case stx () [() old-prod*] [_ (with-values (RemoveProd stx old-prod*) loop)]))) (define (remove-terminal id0 id0* old-term*) (let f ([old-term* old-term*]) (if (null? old-term*) (errorf who "could not find terminal matching (~s ~s)" (syntax->datum id0) (map syntax->datum id0*)) (let ([old-term (car old-term*)] [old-term* (cdr old-term*)]) (nanopass-case (Lannotated Terminal) old-term [(,id (,id* ...) ,b ,handler? ,pred) (if (and (eq? (syntax->datum id) (syntax->datum id0)) (equal? (syntax->datum id*) (syntax->datum id0*))) old-term* (cons old-term (f old-term*)))]))))) (define-pass syntax-matches? : (Lannotated Production) (pat stx) -> * (boolean?) (definitions (define (identifier-matches? id stx) (and (identifier? stx) (eq? (syntax->datum id) (syntax->datum stx))))) (Production : Production (ir stx) -> * (boolean?) [(production ,[b?] ,pretty-prod? ,rtd ,tag ,pred ,maker ,field* ...) b?] [(terminal ,[b?] ,pretty-prod?) b?] [(nonterminal ,[b?] ,pretty-prod?) b?]) (Reference : Reference (ir stx) -> * (boolean?) [(term-ref ,id0 ,id1 ,b) (identifier-matches? id0 stx)] [(nt-ref ,id0 ,id1 ,b) (identifier-matches? id0 stx)]) (Pattern : Pattern (pat stx) -> * (boolean?) [,id (identifier-matches? id stx)] [,ref (Reference ref stx)] [(maybe ,[b?]) b?] [(,pattern0 ,dots . ,pattern1) (syntax-case stx () [(p0 dots . p1) (dots? #'dots) (and (Pattern pattern0 #'p0) (Pattern pattern1 #'p1))] [_ #f])] [(,pattern0 . ,pattern1) (syntax-case stx () [(p0 . p1) (and (Pattern pattern0 #'p0) (Pattern pattern1 #'p1))] [_ #f])] [,null (syntax-case stx () [() #t] [_ #f])]) (Production pat stx)) (define (remove-prod stx old-prod*) (let f ([old-prod* old-prod*]) (if (null? old-prod*) (syntax-violation who "unable to find matching old production" stx) (let ([old-prod (car old-prod*)] [old-prod* (cdr old-prod*)]) (if (syntax-matches? old-prod stx) old-prod* (cons old-prod (f old-prod*))))))) (define (find-matching-nt id old-nt*) (let f ([old-nt* old-nt*]) (if (null? old-nt*) (values '() '()) (let ([old-nt (car old-nt*)] [old-nt* (cdr old-nt*)]) (nanopass-case (Lannotated Nonterminal) old-nt [(,id0 (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...) (if (eq? (syntax->datum id0) (syntax->datum id)) (values old-nt* prod*) (let-values ([(old-nt* prod*) (f old-nt*)]) (values (cons old-nt old-nt*) prod*)))]))))) ) (Defn : Defn (def) -> Defn () [(define-language ,id ,cl* ...) `(define-language ,id ,(cond [(language-extension? cl*) => (lambda (base-lang-id) (extend-clauses cl* (language-information-annotated-language (lookup-language rho base-lang-id))))] [else (map FinishClause cl*)]) ...)]) (FinishClause : Clause (cl) -> Clause () [(terminals ,[FinishTerminal : term* -> term*] ...) `(terminals ,term* ...)] [(,id (,id* ...) ,prod ,prod* ...) `(,id (,id* ...) ,(parse-productions (cons prod prod*)) ...)]) (FinishTerminal : Terminal (term) -> Terminal () [(+ ,base-term* ...) (errorf who "unexpected terminal extension clause ~s" (unparse-Lnp-source term))] [(- ,base-term* ...) (errorf who "unexpected terminal extension clause ~s" (unparse-Lnp-source term))]) (FinishProd : syntax (stx) -> Production (stx) (syntax-case stx () [(?pattern => ?pretty . ?rest) (double-arrow? #'=>) (values `(=> ,(Pattern #'?pattern) ,(Pattern #'?pretty)) #'?rest)] [((=> ?pattern ?handler) . ?rest) (double-arrow? #'=>) (values `(=> ,(Pattern #'?pattern) ,(Pattern #'?pretty)) #'?rest)] [(?pattern -> ?handler . ?rest) (arrow? #'->) (values `(-> ,(Pattern #'?pattern) ,#'?handler) #'?rest)] [((-> ?pattern ?handler) . ?rest) (arrow? #'->) (values `(-> ,(Pattern #'?pattern) ,#'?handler) #'?rest)] [(?x . ?rest) (values (Pattern #'?x) #'?rest)] [_ (syntax-violation who "unrecognized productions list" stx)])) (ExtendClause : Clause (cl old-term* old-nt* cl* new-term*) -> * (old-term* old-nt* cl* new-term*) [(terminals ,term* ...) (let-values ([(old-term* new-term*) (extend-terminals term* old-term* new-term*)]) (values old-term* old-nt* cl* new-term*))] [(,id (,id* ...) ,prod ,prod* ...) (let-values ([(old-nt* old-prod*) (find-matching-nt id old-nt*)]) (let ([prod* (extend-productions (cons prod prod*) old-prod*)]) (values old-term* old-nt* (if (null? prod*) cl* (cons (in-context Clause `(,id (,id* ...) ,prod* ...)) cl*)) new-term*)))] [(extends ,id) (values old-term* old-nt* cl* new-term*)] [(entry ,id) (values old-term* old-nt* (cons (in-context Clause `(entry ,id)) cl*) new-term*)] [(nongenerative-id ,id) (values old-term* old-nt* (cons (in-context Clause `(nongenerative-id ,id)) cl*) new-term*)]) (ExtendTerminal : Terminal (term new-term* old-term*) -> * (new-term* old-term*) [(+ ,[term*] ...) (values (append term* new-term*) old-term*)] [(- ,base-term* ...) (values new-term* (fold-left (lambda (old-term* base-term) (RemoveTerminal base-term old-term*)) old-term* base-term*))] [,base-term (errorf who "unexpected non-extension terminal in extended language ~s" (unparse-Lnp-source base-term))]) (RemoveTerminal : BaseTerminal (ir old-term*) -> * (old-term*) [(,id (,id* ...)) (remove-terminal id id* old-term*)] [(=> (,id (,id* ...)) ,handler) (remove-terminal id id* old-term*)] [else (errorf who "unexpected base terminal ~s" (unparse-Lnp-source ir))]) (BaseTerminal : BaseTerminal (ir) -> Terminal ()) (ExtendProd : syntax (stx new-prod* old-prod*) -> * (new-prod* old-prod*) (syntax-case stx () [(+ ?prod* ...) (plus? #'+) (values (parse-productions #'(?prod* ...) new-prod*) old-prod*)] [(- ?prod* ...) (minus? #'-) (values new-prod* (remove-productions #'(?prod* ...) old-prod*))] [_ (syntax-violation who "unexpected production extension syntax" stx)])) (RemoveProd : syntax (stx old-prod*) -> * (stx old-prod*) (let-values ([(pattern rest) (syntax-case stx () [(?pattern => ?handler . ?rest) (double-arrow? #'=>) (values #'?pattern #'?rest)] [((=> ?pattern ?handler) . ?rest) (double-arrow? #'=>) (values #'?pattern #'?rest)] [(?pattern -> ?pretty . ?rest) (arrow? #'->) (values #'?pattern #'?rest)] [((-> ?pattern ?pretty) . ?rest) (arrow? #'->) (values #'?pattern #'?rest)] [(?pattern . ?rest) (values #'?pattern #'?rest)] [_ (syntax-violation who "unrecognized productions list" stx)])]) (values rest (remove-prod pattern old-prod*)))) (Pattern : * (stx) -> Pattern () (syntax-case stx () [?id (identifier? #'?id) #'?id] [(maybe ?id) (and (maybe? #'maybe) (identifier? #'?id)) `(maybe ,#'?id)] [(?pattern0 dots . ?pattern1) (ellipsis? #'dots) `(,(Pattern #'?pattern0) ,#'dots . ,(Pattern #'?pattern1))] [(?pattern0 . ?pattern1) `(,(Pattern #'?pattern0) . ,(Pattern #'?pattern1))] [() '()]))) (define-language Llanguage (extends Lcomplete) (terminals (+ (box (b)))) (Clause (cl) (- (entry id) (id (id* ...) prod* ...)) (+ (entry ref) (id (id* ...) b prod* ...))) (Reference (ref) (+ (term-ref id0 id1 b) => id0 (nt-ref id0 id1 b) => id0)) (SimpleTerminal (simple-term) (- (id (id* ...))) (+ (id (id* ...) b))) (Pattern (pattern) (- (maybe id)) (+ ref (maybe ref)))) (define meta-variable-suffix-checker (make-parameter (lambda (str) (let f ([i (string-length str)]) (or (fx=? i 0) (let* ([i (fx- i 1)] [c (string-ref str i)]) (cond [(or (char=? c #\*) (char=? c #\^) (char=? c #\?)) (f i)] [(char-numeric? c) (let f ([i i]) (or (fx=? i 0) (let ([i (fx- i 1)]) (and (char-numeric? (string-ref str i)) (f i)))))] [else #f]))))) (lambda (x) (unless (procedure? x) (errorf 'meta-variable-suffix-checker "expected procedure, but got ~s" x)) x))) (define-pass check-and-finish-language : Lcomplete (ir) -> Llanguage () (definitions (define (build-and-check-maps cl*) (let ([ht (make-eq-hashtable)]) (let ([pt (fold-left (lambda (pt cl) (ExtendMapsClause cl pt ht)) (empty-prefix-tree) cl*)]) (values pt ht)))) (define (extract-all-terminals cl* pt ht) (let f ([cl* cl*]) (if (null? cl*) (values '() '()) (let ([cl (car cl*)]) (let-values ([(term-out* cl-out*) (f (cdr cl*))]) (nanopass-case (Lcomplete Clause) cl [(terminals ,term* ...) (values (fold-right (lambda (term term-out*) (cons (Terminal term ht) term-out*)) term-out* term*) cl-out*)] [else (values term-out* (cons cl cl-out*))])))))) (define (extract-all-nonterminals cl* pt ht) (let f ([cl* cl*]) (if (null? cl*) (values '() '()) (let-values ([(nt* cl-out*) (f (cdr cl*))]) (let ([cl (car cl*)]) (nanopass-case (Lcomplete Clause) cl [(,id (,id* ...) ,prod* ...) (values (cons (Clause cl pt ht) nt*) cl-out*)] [else (values nt* (cons cl cl-out*))])))))) (define (check-and-rewrite-clauses cl* pt ht) (let*-values ([(term* cl*) (extract-all-terminals cl* pt ht)] [(nt* cl*) (extract-all-nonterminals cl* pt ht)]) (fold-left (lambda (cl* cl) (cons (Clause cl pt ht) cl*)) (with-output-language (Llanguage Clause) (cons `(terminals ,term* ...) nt*)) cl*))) (define (build-ref terminal? mv id b) (with-output-language (Llanguage Reference) (if terminal? `(term-ref ,mv ,id ,b) `(nt-ref ,mv ,id ,b)))) (define ref (case-lambda [(ht id) (let ([sym (syntax->datum id)]) (or (eq-hashtable-ref ht sym #f) (let ([b (box #f)]) (eq-hashtable-set! ht sym b) b)))] [(pt ht id) (let* ([str (symbol->string (syntax->datum id))] [pr (match-prefix pt str (meta-variable-suffix-checker))] [terminal? (car pr)] [raw-id (cdr pr)]) (unless raw-id (syntax-violation who "unable to find matching metavariable" id)) (build-ref terminal? id raw-id (ref ht raw-id)))])) (define (maybe-ref pt ht id) (let* ([str (symbol->string (syntax->datum id))] [pr (match-prefix pt str (meta-variable-suffix-checker))]) (if pr (let ([terminal? (car pr)] [raw-id (cdr pr)]) (build-ref terminal? id raw-id (ref ht raw-id))) id)))) (Defn : Defn (ir) -> Defn () [(define-language ,id ,cl* ...) (let-values ([(pt ht) (build-and-check-maps cl*)]) (let ([cl* (check-and-rewrite-clauses cl* pt ht)]) `(define-language ,id ,cl* ...)))]) (ExtendMapsClause : Clause (cl pt ht) -> * (pt) [(terminals ,term* ...) (fold-left (lambda (pt term) (ExtendMapsTerminal term pt ht)) pt term*)] [(,id (,id* ...) ,prod* ...) ;; should we be using an identifier hashtable? or symbol hashtable? (eq-hashtable-set! ht (syntax->datum id) (box #f)) (let ([pr (cons #f id)]) (fold-left (lambda (pt mv-id) (insert-prefix pt (symbol->string (syntax->datum mv-id)) pr)) pt id*))] [else pt]) (ExtendMapsTerminal : Terminal (term pt ht) -> * (pt) [,simple-term (ExtendMapsSimpleTerminal simple-term pt ht)] [(=> ,simple-term ,handler) (ExtendMapsSimpleTerminal simple-term pt ht)]) (ExtendMapsSimpleTerminal : SimpleTerminal (simple-term pt ht) -> * (pt) [(,id (,id* ...)) (eq-hashtable-set! ht (syntax->datum id) (box #f)) (let ([pr (cons #t id)]) (fold-left (lambda (pt mv-id) (insert-prefix pt (symbol->string (syntax->datum mv-id)) pr)) pt id*))]) (Terminal : Terminal (term ht) -> Terminal () [(,id (,id* ...)) (let* ([b (ref ht id)] [term `(,id (,id* ...) ,b)]) (set-box! b term) term)] [(=> (,id (,id* ...)) ,handler) (let* ([b (ref ht id)] [term `(=> (,id (,id* ...) ,b) ,handler)]) (set-box! b term) term)] [,simple-term (errorf who "unreachable match ,simple-term, reached!")] [(=> ,simple-term ,handler) (errorf who "unreachable match (=> ,simple-term ,handler), reached!")]) (Clause : Clause (cl pt ht) -> Clause () [(entry ,id) `(entry (nt-ref ,id ,id ,(ref ht id)))] [(nongenerative-id ,id) `(nongenerative-id ,id)] [(terminals ,term* ...) (errorf who "unexpected terminal clause after terminals were filtered")] [(,id (,id* ...) ,prod* ...) (let* ([b (ref ht id)] [prod* (map (lambda (prod) (Production prod pt ht)) prod*)] [cl `(,id (,id* ...) ,b ,prod* ...)]) (set-box! b cl) cl)]) (Production : Production (prod pt ht) -> Production () [,pattern (Pattern pattern pt ht)] [(=> ,[pattern0] ,[pattern1 (empty-prefix-tree) ht -> pattern1]) `(=> ,pattern0 ,pattern1)] [(-> ,[pattern] ,handler) `(-> ,pattern ,handler)]) (Pattern : Pattern (pattern pt ht) -> Pattern () [,id (maybe-ref pt ht id)] [(maybe ,id) (ref pt ht id)] [(,[pattern0] ,dots . ,[pattern1]) `(,pattern0 ,dots . ,pattern1)] [(,[pattern0] . ,[pattern1]) `(,pattern0 . ,pattern1)] [,null null]) ) (define-language Lannotated (extends Llanguage) (terminals (- (datum (handler))) (+ (datum (handler record-name pred all-pred all-term-pred accessor maker)) (exact-integer (tag level tag-mask)) (record-type-descriptor (rtd)) (record-constructor-descriptor (rcd)))) (Defn (def) (- (define-language id cl* ...)) (+ (define-language id ;; language name ref ;; reference to entry ntspec (maybe id0) ;; nongenerative-id rtd rcd tag-mask (term* ...) nt* ...))) (Clause (cl) (- (entry ref) (nongenerative-id id) (terminals term* ...) (id (id* ...) b prod* ...))) (Nonterminal (nt) (+ (id (id* ...) b rtd rcd tag pred all-pred all-term-pred prod* ...) => (id (id* ...) prod* ...))) (PrettyProduction (pretty-prod) (+ (procedure handler) (pretty pattern))) (Production (prod) (- pattern (=> (=> pattern0 pattern1) (=> pattern0 pattern1)) (=> (-> pattern handler) (-> pattern handler))) (+ (production pattern (maybe pretty-prod) rtd tag pred maker field* ...) (terminal ref (maybe pretty-prod)) (nonterminal ref (maybe pretty-prod)))) (Field (field) (+ (ref level accessor) (optional ref level accessor))) (Terminal (term) (- simple-term (=> (=> simple-term handler) (=> simple-term handler))) (+ (id (id* ...) b (maybe handler) pred) => (id (id* ...) handler pred))) (SimpleTerminal (simple-term) (- (id (id* ...) b)))) ;; TODO: fix the entry for language extenions (define-pass annotate-language : Llanguage (lang) -> Lannotated () (definitions (define-pass build-ref : (Llanguage Clause) (cl) -> (Llanguage Reference) () (build-ref : Clause (cl) -> Reference () [(,id (,id* ...) ,b ,prod* ...) `(nt-ref ,id ,id ,b)] [else (errorf who "unexpected clause ~s" (unparse-Llanguage cl))])) (define (separate-clauses cl*) (let loop ([cl* cl*] [entry #f] [first-nt #f] [nongen-id #f] [rterm* '()] [rnt* '()] [rb* '()]) (if (null? cl*) (values (or entry (build-ref first-nt)) nongen-id (reverse rterm*) (reverse rnt*) rb*) (with-values (BinClause (car cl*) entry first-nt nongen-id rterm* rnt* rb*) (lambda (entry first-nt nongen-id rterm* rnt* rb*) (loop (cdr cl*) entry first-nt nongen-id rterm* rnt* rb*)))))) (define (annotate-terminals term*) (map Terminal term*)) (define (annotate-nonterminals nt* lang-name lang-rtd lang-rcd nongen-id) (let ([bits (fxlength (length nt*))]) (let f ([nt* nt*] [tag 0]) (if (null? nt*) '() (cons (Nonterminal (car nt*) lang-name lang-rtd lang-rcd bits tag nongen-id) (f (cdr nt*) (fx+ tag 1))))))) (define (build-production pattern nt-rtd lang-name nt-name tag pretty nongen-id) (define-pass find-prod-name : (Llanguage Pattern) (pattern) -> * (id) (Pattern : Pattern (pattern) -> * (id) [,id id] [,ref (Reference ref)] [(maybe ,[id]) id] [(,[id] ,dots . ,pattern1) id] [(,[id] . ,pattern1) id] [else (construct-id #'* "anonymous")]) (Reference : Reference (ref) -> * (id) [(term-ref ,id0 ,id1 ,b) id0] [(nt-ref ,id0 ,id1 ,b) id0]) (Pattern pattern)) (let* ([prod-name (find-prod-name pattern)] [base-name (unique-name lang-name nt-name prod-name)]) (let-values ([(pattern field* field-name*) (Pattern pattern base-name 0 '() '())]) (let* ([rtd (make-record-type-descriptor (string->symbol base-name) nt-rtd (if nongen-id (regensym nongen-id (format ":~s:~s" (syntax->datum nt-name) (syntax->datum prod-name)) (format "-~s" tag)) (gensym base-name)) #t #f (list->vector (map (lambda (fn) `(immutable ,(syntax->datum fn))) field-name*)))] [pred (construct-id #'* base-name "?")] [maker (construct-id #'* "make-" base-name)]) (with-output-language (Lannotated Production) `(production ,pattern ,pretty ,rtd ,tag ,pred ,maker ,field* ...)))))) (define (build-accessor record-name id) (construct-id #'* record-name id)) (with-output-language (Lannotated PrettyProduction) (define (pretty-pattern pattern) `(pretty ,(RewritePattern pattern))) (define (pretty-procedure handler) `(procedure ,handler))) ) (Defn : Defn (def) -> Defn () [(define-language ,id ,cl* ...) (let-values ([(entry nongen-id term* nt* b*) (separate-clauses cl*)]) (let* ([rtd (make-record-type-descriptor (syntax->datum id) (record-type-descriptor nanopass-record) (if nongen-id (syntax->datum nongen-id) (gensym (unique-name id))) #f #f (vector))] [rcd (make-record-constructor-descriptor rtd (record-constructor-descriptor nanopass-record) #f)] [tag-mask (fx- (fxarithmetic-shift-left 1 (fxlength (length nt*))) 1)] [term* (annotate-terminals term*)] [nt* (annotate-nonterminals nt* id rtd rcd nongen-id)]) (let-values ([(ref ref-id) (Reference entry)]) (for-each (lambda (b) (set-box! b (cdr (unbox b)))) b*) `(define-language ,id ,ref ,nongen-id ,rtd ,rcd ,tag-mask (,term* ...) ,nt* ...))))]) (BinClause : Clause (cl entry first-nt nongen-id rterm* rnt* rb*) -> * (entry first-nt nongen-id rterm* rnt* rb*) [(entry ,ref) (when entry (errorf who "found more than one entry")) (values ref first-nt nongen-id rterm* rnt* rb*)] [(nongenerative-id ,id) (when nongen-id (syntax-violation who "found more than one nongenerative-id" id)) (values entry first-nt id rterm* rnt* rb*)] [(terminals ,term* ...) (values entry first-nt nongen-id (append term* rterm*) rnt* (fold-right GrabTermBox rb* term*))] [(,id (,id* ...) ,b ,prod* ...) (let ([new-b (box #f)]) (set-box! b (cons new-b (unbox b))) (values entry (or first-nt cl) nongen-id rterm* (cons cl rnt*) (cons b rb*)))]) (GrabTermBox : Terminal (term rb*) -> * (rb*) [(,id (,id* ...) ,b) (let ([new-b (box #f)]) (set-box! b (cons new-b (unbox b))) (cons b rb*))] [(=> (,id (,id* ...) ,b) ,handler) (let ([new-b (box #f)]) (set-box! b (cons new-b (unbox b))) (cons b rb*))] ;; unreachable! [else (errorf who "unreachable")]) (Terminal : Terminal (term) -> Terminal () [(,id (,id* ...) ,b) (let* ([new-b (car (unbox b))] [term `(,id (,id* ...) ,new-b #f ,(construct-id id id "?"))]) (set-box! new-b term) term)] [(=> (,id (,id* ...) ,b) ,handler) (let* ([new-b (car (unbox b))] [term `(,id (,id* ...) ,new-b ,handler ,(construct-id id id "?"))]) (set-box! new-b term) term)] [else (errorf who "unexpected terminal ~s" (unparse-Llanguage term))]) (Nonterminal : Clause (cl lang-name lang-rtd lang-rcd bits tag nongen-id) -> Nonterminal () [(,id (,id* ...) ,b ,prod* ...) (let* ([record-name (unique-name lang-name id)] [rtd (make-record-type-descriptor (string->symbol record-name) lang-rtd (if nongen-id (regensym nongen-id (format ":~s" (syntax->datum id)) (format "-~d" tag)) (gensym record-name)) #f #f (vector))] [rcd (make-record-constructor-descriptor rtd lang-rcd #f)] [pred (construct-id #'* record-name "?")] [all-pred (construct-id lang-name lang-name "-" id "?")] [all-term-pred (construct-id #'* lang-name "-" id "-terminal?")]) (let loop ([prod* prod*] [next 1] [rprod* '()]) (if (null? prod*) (let* ([new-b (car (unbox b))] [nt `(,id (,id* ...) ,new-b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,(reverse rprod*) ...)]) (set-box! new-b nt) nt) (let ([prod-tag (fx+ (fxarithmetic-shift-left next bits) tag)]) (loop (cdr prod*) (fx+ next 1) (cons (Production (car prod*) rtd lang-name id prod-tag nongen-id) rprod*))))))] [else (errorf who "unexpected clause in Nonterminal ~s" (unparse-Llanguage cl))]) (Production : Production (prod nt-rtd lang-name nt-name prod-tag nongen-id) -> Production () [,ref (BaseReference ref #f)] [(=> ,ref ,pattern1) (BaseReference ref (pretty-pattern pattern1))] [(-> ,ref ,handler) (BaseReference ref (pretty-procedure handler))] [,pattern (build-production pattern nt-rtd lang-name nt-name prod-tag #f nongen-id)] [(=> ,pattern0 ,pattern1) (build-production pattern0 nt-rtd lang-name nt-name prod-tag (pretty-pattern pattern1) nongen-id)] [(-> ,pattern ,handler) (build-production pattern nt-rtd lang-name nt-name prod-tag (pretty-procedure handler) nongen-id)]) (BaseReference : Reference (ref maybe-pretty) -> Production () [(term-ref ,id0 ,id1 ,b) `(terminal (term-ref ,id0 ,id1 ,b) ,maybe-pretty)] [(nt-ref ,id0 ,id1 ,b) `(nonterminal (nt-ref ,id0 ,id1 ,b) ,maybe-pretty)]) (RewritePattern : Pattern (pattern) -> Pattern ()) (Pattern : Pattern (pattern record-name level flds fns) -> Pattern (flds fns) [,id (values id flds fns)] [,ref (let-values ([(ref meta-var) (Reference ref)]) (values ref (cons (in-context Field `(,ref ,level ,(build-accessor record-name meta-var))) flds) (cons meta-var fns)))] [(maybe ,ref) (let-values ([(ref meta-var) (Reference ref)]) (values `(maybe ,ref) (cons (in-context Field `(optional ,ref ,level ,(build-accessor record-name meta-var))) flds) (cons meta-var fns)))] [(,pattern0 ,dots . ,pattern1) (let*-values ([(pattern1 flds fns) (Pattern pattern1 record-name level flds fns)] [(pattern0 flds fns) (Pattern pattern0 record-name (fx+ level 1) flds fns)]) (values `(,pattern0 ,dots . ,pattern1) flds fns))] [(,pattern0 . ,pattern1) (let*-values ([(pattern1 flds fns) (Pattern pattern1 record-name level flds fns)] [(pattern0 flds fns) (Pattern pattern0 record-name level flds fns)]) (values `(,pattern0 . ,pattern1) flds fns))] [,null (values null flds fns)]) (Reference : Reference (ref) -> Reference (id) [(term-ref ,id0 ,id1 ,b) (values `(term-ref ,id0 ,id1 ,(car (unbox b))) id0)] [(nt-ref ,id0 ,id1 ,b) (values `(nt-ref ,id0 ,id1 ,(car (unbox b))) id0)]) ) (define-pass prune-lang : Lannotated (ir caller-who maybe-name) -> * (stx) (Defn : Defn (ir) -> * (stx) [(define-language ,id ,ref ,id0? ,rtd ,rcd ,tag-mask (,term* ...) ,nt* ...) (let ([ht (make-eq-hashtable)]) (let-values ([(entry-id ts nts) (FollowReference ref ht '() '())]) (with-syntax ([define-language-exp (datum->syntax id 'define-language-exp)]) (with-implicit (id entry terminals nongenerative-id) #`(define-language-exp #,(or maybe-name id) (entry #,entry-id) #,@(if id0? #`((nongenerative-id #,id0?)) #'()) (terminals #,@ts) #,@nts)))))]) (FollowReference : Reference (ir ht ts nts) -> * (id ts nts) [(term-ref ,id0 ,id1 ,b) (unless (eq-hashtable-ref ht ir #f) (eq-hashtable-set! ht ir #t) (FollowTerminal (unbox b) ts nts id0))] [(nt-ref ,id0 ,id1 ,b) (unless (eq-hashtable-ref ht ir #f) (eq-hashtable-set! ht ir #t) (FollowNonterminal (unbox b) ht ts nts id0))]) (FollowTerminal : Terminal (ir ts nts id0) -> * (id0 ts nts) [(,id (,id* ...) ,b ,handler? ,pred) (values id0 (cons (if handler? #`(=> (#,id #,id*) #,handler?) #`(#,id #,id*)) ts) nts)]) (FollowNonterminal : Nonterminal (ir ht ts nts id0) -> * (id0 ts nts) [(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...) (let loop ([prod* prod*] [ts ts] [nts nts] [rprod* '()]) (if (null? prod*) (values id0 ts (cons #`(#,id #,id* . #,rprod*) nts)) (let-values ([(prod ts nts) (Production (car prod*) ht ts nts)]) (loop (cdr prod*) ts nts (cons prod rprod*)))))]) (Production : Production (ir ht ts nts) -> * (stx ts nts) (definitions (define (maybe-wrap pp? stx) (if pp? (PrettyProduction pp? stx) stx))) [(production ,[stx] ,pretty-prod? ,rtd ,tag ,pred ,maker ,field* ...) (let loop ([field* field*] [ts ts] [nts nts]) (if (null? field*) (values (maybe-wrap pretty-prod? stx) ts nts) (let-values ([(ts nts) (FollowField (car field*) ht ts nts)]) (loop (cdr field*) ts nts))))] [(terminal ,ref ,pretty-prod?) (let-values ([(id0 ts nts) (FollowReference ref ht ts nts)]) (values (maybe-wrap pretty-prod? id0) ts nts))] [(nonterminal ,ref ,pretty-prod?) (let-values ([(id0 ts nts) (FollowReference ref ht ts nts)]) (values (maybe-wrap pretty-prod? id0) ts nts))]) (FollowField : Field (field ht ts nts) -> * (ts nts) [(,[id0 ts nts] ,level ,accessor) (values ts nts)] [(optional ,[id0 ts nts] ,level ,accessor) (values ts nts)]) (PrettyProduction : PrettyProduction (ir stx) -> * (stx) [(procedure ,handler) #`(-> #,stx #,handler)] [(pretty ,[pattern]) #`(=> #,stx #,pattern)]) (Pattern : Pattern (ir) -> * (stx) [,id id] [,ref (Reference ref)] [,null #'()] [(maybe ,[id]) #`(maybe #,id)] [(,[pattern0] ,dots . ,[pattern1]) #`(#,pattern0 (... ...) . #,pattern1)] [(,[pattern0] . ,[pattern1]) #`(#,pattern0 . #,pattern1)]) (Reference : Reference (ir) -> * (id) [(term-ref ,id0 ,id1 ,b) id0] [(nt-ref ,id0 ,id1 ,b) id0]) (Defn ir)) (define-pass diff-langs : Llanguage (ir-out ir-base) -> * (stx) (definitions (define (separate-clauses cl*) (let loop ([cl* cl*] [rcl* '()] [term* '()] [nt* '()]) (if (null? cl*) (values rcl* term* nt*) (let-values ([(rcl* term* nt*) (BinClause (car cl*) rcl* term* nt*)]) (loop (cdr cl*) rcl* term* nt*))))) (define (find-matching-terminal id term1*) (let f ([term1* term1*]) (if (null? term1*) (values #f '()) (let ([term (car term1*)]) (nanopass-case (Llanguage Terminal) term [(,id1 (,id1* ...) ,b) (if (eq? (syntax->datum id) (syntax->datum id1)) (values #t (cdr term1*)) (let-values ([(found? term1*) (f (cdr term1*))]) (values found? (cons term term1*))))] [(=> (,id1 (,id1* ...) ,b) ,handler) (if (eq? (syntax->datum id) (syntax->datum id1)) (values #t (cdr term1*)) (let-values ([(found? term1*) (f (cdr term1*))]) (values found? (cons term term1*))))]))))) (define (find-matching-nonterminal id nt1*) (let f ([nt1* nt1*]) (if (null? nt1*) (values '() '()) (let ([nt (car nt1*)]) (nanopass-case (Llanguage Clause) nt [(,id1 (,id1* ...) ,b ,prod* ...) (if (eq? (syntax->datum id) (syntax->datum id1)) (values prod* (cdr nt1*)) (let-values ([(prod* nt1*) (f (cdr nt1*))]) (values prod* (cons nt nt1*))))] [else (errorf who "unexpected clause in nonterminal ~s" (unparse-Llanguage nt))]))))) (define (add-terms-clause type term* cl*) (if (null? term*) cl* (cons #`(#,type . #,term*) cl*))) (define (Terminal* term0* term1*) (let loop ([term0* term0*] [term1* term1*] [add-term* '()]) (if (null? term0*) (add-terms-clause #'- (map RewriteTerminal term1*) (add-terms-clause #'+ add-term* '())) (let-values ([(term1* add-term*) (Terminal (car term0*) term1* add-term*)]) (loop (cdr term0*) term1* add-term*))))) (define (Nonterminal* nt0* nt1*) (let loop ([nt0* nt0*] [nt1* nt1*] [rnt* '()]) (if (null? nt0*) (reverse (fold-left (lambda (rnt* nt) (nanopass-case (Llanguage Clause) nt [(,id (,id* ...) ,b ,prod* ...) #`(#,id #,id* (- . #,(map RewriteProduction prod*)))] [else (errorf who "unexpected clause in nonterminal ~s" (unparse-Llanguage nt))])) rnt* nt1*)) (let-values ([(rnt* nt1*) (Nonterminal (car nt0*) nt1* rnt*)]) (loop (cdr nt0*) nt1* rnt*))))) (define (add-productions type prod* cl*) (if (null? prod*) cl* (cons #`(#,type . #,(fold-left (lambda (out* prod) (cons (RewriteProduction prod) out*)) '() prod*)) cl*))) (define (Production* prod0* prod1*) (let loop ([prod0* prod0*] [prod1* prod1*] [add-prod* '()]) (if (null? prod0*) (add-productions #'- prod1* (add-productions #'+ add-prod* '())) (let-values ([(prod1* add-prod*) (Production (car prod0*) prod1* add-prod*)]) (loop (cdr prod0*) prod1* add-prod*))))) (define (find-matching-pattern pattern prod1*) (let f ([prod1* prod1*]) (if (null? prod1*) (values #f '()) (let* ([prod1 (car prod1*)] [pattern1 (ProductionPattern prod1)]) (if (Pattern=? pattern pattern1) (values #t (cdr prod1*)) (let-values ([(found? prod1*) (f (cdr prod1*))]) (values found? (cons prod1 prod1*)))))))) ) (Defn : Defn (ir-out ir-base) -> * (stx) [(define-language ,id0 ,cl0* ...) (let-values ([(base-cl* term0* nt0*) (separate-clauses cl0*)]) (nanopass-case (Llanguage Defn) ir-base [(define-language ,id1 ,cl1* ...) (let-values ([(_ term1* nt1*) (separate-clauses cl1*)]) (let ([term* (Terminal* term0* term1*)] [nt* (Nonterminal* nt0* nt1*)]) (if (null? term*) #`(define-language #,id0 #,@base-cl* . #,nt*) #`(define-language #,id0 #,@base-cl* (terminals . #,term*) . #,nt*))))]))]) (BinClause : Clause (ir cl* all-term* nt*) -> * (cl* all-term* nt*) [(entry ,[id]) (values (cons #`(entry #,id) cl*) all-term* nt*)] [(nongenerative-id ,id) (values (cons #`(nongenerative-id #,id) cl*) all-term* nt*)] [(terminals ,term* ...) (values cl* (append term* all-term*) nt*)] [(,id (,id* ...) ,b ,prod* ...) (values cl* all-term* (cons ir nt*))]) (Terminal : Terminal (term0 term1* add-term*) -> * (term1* add-term*) [(=> (,id (,id* ...) ,b) ,handler) (let-values ([(found? term1*) (find-matching-terminal id term1*)]) (if found? (values term1* add-term*) (values term1* (cons #`(=> (#,id #,id*) #,handler) add-term*))))] [(,id (,id* ...) ,b) (let-values ([(found? term1*) (find-matching-terminal id term1*)]) (if found? (values term1* add-term*) (values term1* (cons #`(#,id #,id*) add-term*))))] [else (errorf who "unreachable clause in Terminal")]) (Nonterminal : Clause (nt0 nt1* rnt*) -> * (rnt* nt1*) [(,id (,id* ...) ,b ,prod* ...) (let*-values ([(prod1* nt1*) (find-matching-nonterminal id nt1*)]) (let ([prod* (Production* prod* prod1*)]) (if (null? prod*) (values rnt* nt1*) (values (cons #`(#,id #,id* . #,prod*) rnt*) nt1*))))] [else (errorf who "unexpected clause ~s" (unparse-Llanguage nt0))]) (Production : Production (prod prod1* add-prod*) -> * (prod1* add-prod*) [,pattern (let-values ([(found? prod1*) (find-matching-pattern pattern prod1*)]) (if found? (values prod1* add-prod*) (values prod1* (cons prod add-prod*))))] [(=> ,pattern0 ,pattern1) (let-values ([(found? prod1*) (find-matching-pattern pattern0 prod1*)]) (if found? (values prod1* add-prod*) (values prod1* (cons prod add-prod*))))] [(-> ,pattern ,handler) (let-values ([(found? prod1*) (find-matching-pattern pattern prod1*)]) (if found? (values prod1* add-prod*) (values prod1* (cons prod add-prod*))))]) (Pattern=? : Pattern (pattern0 pattern1) -> * (bool?) [,id0 (nanopass-case (Llanguage Pattern) pattern1 [,id1 (eq? (syntax->datum id0) (syntax->datum id1))] [else #f])] [,ref0 (nanopass-case (Llanguage Pattern) pattern1 [,ref1 (Reference=? ref0 ref1)] [else #f])] [,null0 (nanopass-case (Llanguage Pattern) pattern1 [,null1 #t] [else #f])] [(maybe ,ref0) (nanopass-case (Llanguage Pattern) pattern1 [(maybe ,ref1) (Reference=? ref0 ref1)] [else #f])] [(,pattern00 ,dots . ,pattern10) (nanopass-case (Llanguage Pattern) pattern1 [(,pattern01 ,dots . ,pattern11) (and (Pattern=? pattern00 pattern01) (Pattern=? pattern10 pattern11))] [else #f])] [(,pattern00 . ,pattern10) (nanopass-case (Llanguage Pattern) pattern1 [(,pattern01 . ,pattern11) (and (Pattern=? pattern00 pattern01) (Pattern=? pattern10 pattern11))] [else #f])]) (Reference=? : Reference (ref0 ref1) -> * (bool?) [(term-ref ,id00 ,id10 ,b0) (nanopass-case (Llanguage Pattern) ref1 [(term-ref ,id01 ,id11 ,b1) (eq? (syntax->datum id00) (syntax->datum id01))] [else #f])] [(nt-ref ,id00 ,id10 ,b0) (nanopass-case (Llanguage Pattern) ref1 [(nt-ref ,id01 ,id11 ,b1) (eq? (syntax->datum id00) (syntax->datum id01))] [else #f])]) (ProductionPattern : Production (ir) -> * (stx) [,pattern pattern] [(=> ,pattern0 ,pattern1) pattern0] [(-> ,pattern ,handler) pattern]) (RewriteTerminal : Terminal (ir) -> * (stx) [(,id (,id* ...) ,b) #`(#,id #,id*)] [(=> (,id (,id* ...) ,b) ,handler) #`(=> (#,id #,id*) ,handler)] [else (errorf who "unexpected terminal ~s" (unparse-Llanguage ir))]) (RewriteProduction : Production (ir) -> * (stx) [,pattern (RewritePattern pattern)] [(=> ,[stx0] ,[stx1]) #`(=> #,stx0 #,stx1)] [(-> ,[stx0] ,handler) #`(-> #,stx0 ,handler)]) (RewritePattern : Pattern (ir) -> * (stx) [,id id] [,ref (RewriteReference ref)] [,null #'()] [(maybe ,[id]) #`(maybe #,id)] [(,[stx0] ,dots . ,[stx1]) #`(#,stx0 (... ...) . #,stx1)] [(,[stx0] . ,[stx1]) #`(#,stx0 . #,stx1)]) (RewriteReference : Reference (ir) -> * (stx) [(term-ref ,id0 ,id1 ,b) id0] [(nt-ref ,id0 ,id1 ,b) id0]) (Defn ir-out ir-base)) (define-pass build-lang-node-counter : Lannotated (ir name) -> * (stx) (Defn : Defn (ir) -> * (stx) [(define-language ,id ,[id1] ,id0? ,rtd ,rcd ,tag-mask (,term* ...) ,[procs] ...) #`(define-pass #,name : #,id (ir) -> * (cnt) #,@procs (#,id1 ir))]) (Nonterminal : Nonterminal (ir) -> * (stx) [(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,[cl*] ...) #`(#,id : #,id (ir) -> * (cnt) . #,cl*)]) (Production : Production (ir) -> * (stx) [(production ,[pattern] ,pretty-prod? ,rtd ,tag ,pred ,maker ,[recur] ...) #`[#,pattern (+ 1 . #,recur)]] [(terminal (term-ref ,id0 ,id1 ,b) ,pretty-prod?) #`[,#,id0 0]] [(nonterminal (nt-ref ,id0 ,id1 ,b) ,pretty-prod?) #`[,#,id0 (#,id1 #,id0)]] [else (errorf who "unrecognized production ~s" (unparse-Lannotated ir))]) (Pattern : Pattern (ir) -> * (stx) [,id id] [,ref #`,#,(Reference ref)] [,null #'()] [(maybe ,[id]) #`,#,id] [(,[pattern0] ,dots . ,[pattern1]) #`(#,pattern0 (... ...) . #,pattern1)] [(,[pattern0] . ,[pattern1]) #`(#,pattern0 . #,pattern1)]) (Field : Field (ir) -> * (stx) (definitions (define (build-recur recur level) (let f ([level level]) (if (fx=? level 0) recur #`(lambda (x) (fold-left (lambda (c x) (+ c (#,(f (fx- level 1)) x))) 0 x))))) (define (Ref ref level optional?) (nanopass-case (Lannotated Reference) ref [(term-ref ,id0 ,id1 ,b) #'0] ;; possibly should be 1 at base, with recur to sum [(nt-ref ,id0 ,id1 ,b) (let ([recur-base (if optional? #`(lambda (x) (if x (#,id1 x) 0)) id1)]) #`(#,(build-recur recur-base level) #,id0))]))) [(,ref ,level ,accessor) (Ref ref level #f)] [(optional ,ref ,level ,accessor) (Ref ref level #t)] [else (errorf who "unrecognized field ~s" (unparse-Lannotated ir))]) (Reference : Reference (ir) -> * (id) [(term-ref ,id0 ,id1 ,b) id0] [(nt-ref ,id0 ,id1 ,b) id0]) (Defn ir)) (define-pass build-unparser : Lannotated (ir name) -> * (stx) (definitions (define (build-mv-refs pat flds) (if flds (map Field flds) (let-values ([(mv up) (Reference pat)]) (list mv))))) (Defn : Defn (ir) -> * (stx) [(define-language ,id ,[mv upname] ,id? ,rtd ,rcd ,tag-mask (,[tup* tpred* tn*] ...) ,[up* pred* n*] ...) (with-syntax ([(tup* ...) tup*] [(tpred* ...) tpred*] [(tn* ...) tn*] [(up* ...) up*] [(pred* ...) pred*] [(n* ...) n*] [who (datum->syntax name 'who)]) ;; NOTE: entry is #f when not specified to preserve the current ;; behavior, but could be specified to be the entry instead. #`(define #,name (let () (define-pass #,name : #,id (lf entry raw?) -> * (sexp) tup* ... up* ... (case entry [(n*) (n* lf)] ... [(tn*) (tn* lf)] ... [else (cond [(pred* lf) (n* lf)] ... [(tpred* lf) (tn* lf)] ... [else (errorf who "Unrecognized input ~s" lf)])])) (case-lambda [(lf) (#,name lf #f #f)] [(lf entry/raw?) (if (symbol? entry/raw?) (#,name lf entry/raw? #f) (#,name lf #f entry/raw?))] [(lf entry raw?) (#,name lf entry raw?)]))))]) (Terminal : Terminal (ir) -> * (tup tpred tn) [(,id (,id* ...) ,b ,handler? ,pred) (values (if handler? #`(#,id : #,id (lf) -> * (sexp) (if raw? lf (#,handler? lf))) #`(#,id : #,id (lf) -> * (sexp) lf)) pred id)]) (Nonterminal : Nonterminal (ir) -> * (up pred n) [(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,[cl*] ...) (values #`(#,id : #,id (lf) -> * (sexp) . #,cl*) all-pred id)]) (Production : Production (ir) -> * (cl) (definitions (define (build-sexp pretty-prod? raw-pattern mv*) (if pretty-prod? (PrettyProduction pretty-prod? raw-pattern mv*) #`(with-extended-quasiquote (quasiquote #,raw-pattern))))) [(production ,[pattern] ,pretty-prod? ,rtd ,tag ,pred ,maker ,[mv* up*] ...) (with-syntax ([sexp-builder (build-sexp pretty-prod? pattern mv*)] [(mv* ...) mv*] [(up* ...) up*]) #`[#,pattern (let ([mv* (up* mv*)] ...) sexp-builder)])] [(terminal ,[ref -> mv upname] ,pretty-prod?) (with-syntax ([sexp-builder (build-sexp pretty-prod? #`,#,mv (list mv))]) #`[,#,mv (let ([#,mv (#,upname #,mv)]) sexp-builder)])] [(nonterminal ,[ref -> mv upname] ,pretty-prod?) (with-syntax ([sexp-builder (build-sexp pretty-prod? #`,#,mv (list mv))]) #`[,#,mv (let ([#,mv (#,upname #,mv)]) sexp-builder)])]) (Pattern : Pattern (ir) -> * (stx) [,id id] [,ref (let-values ([(mv up) (Reference ref)]) #`,#,mv)] [,null #'()] [(maybe ,[mv up]) #`,#,mv] [(,[pattern0] ,dots . ,[pattern1]) #`(#,pattern0 (... ...) . #,pattern1)] [(,[pattern0] . ,[pattern1]) #`(#,pattern0 . #,pattern1)]) (PrettyProduction : PrettyProduction (ir raw-pattern mv*) -> * (stx) [(procedure ,handler) #`(if raw? (with-extended-quasiquote (quasiquote #,raw-pattern)) (#,handler #,name . #,mv*))] [(pretty ,pattern) (with-syntax ([pretty-builder (Pattern pattern)]) #`(if raw? (with-extended-quasiquote (quasiquote #,raw-pattern)) (with-extended-quasiquote (quasiquote pretty-builder))))]) (Field : Field (ir) -> * (mv up) (definitions (define (build-unparser-for-level up level) (let f ([level level]) (if (fx=? level 0) up #`(lambda (x) (map #,(f (fx- level 1)) x)))))) [(,[mv up] ,level ,accessor) (values mv (build-unparser-for-level up level))] [(optional ,[mv up] ,level ,accessor) (values mv (build-unparser-for-level #`(lambda (x) (and x (#,up x))) level))]) (Reference : Reference (ir) -> * (mv up) [(term-ref ,id0 ,id1 ,b) (values id0 id1)] [(nt-ref ,id0 ,id1 ,b) (values id0 id1)]) (Defn ir)) (define-pass build-parser : Lannotated (ir name) -> * (stx) (definitions (define-pass extract-bindings : (Lannotated Pattern) (ir) -> * (id*) (Pattern : Pattern (ir id*) -> * (id*) [,id id*] [,ref (Reference ref id*)] [(maybe ,[id*]) id*] [,null id*] [(,pattern0 . ,[id*]) (Pattern pattern0 id*)] [(,pattern0 ,dots . ,[id*]) (Pattern pattern0 id*)]) (Reference : Reference (ir id*) -> * (id*) [(term-ref ,id0 ,id1 ,b) (cons id0 id*)] [(nt-ref ,id0 ,id1 ,b) (cons id0 id*)]) (Pattern ir '())) (define (build-body id prod*) (let f ([prod* prod*]) (if (null? prod*) #'fk (with-syntax ([(fk) (generate-temporaries '(fk))]) (Production (car prod*) id #'fk #`(lambda () #,(f (cdr prod*))))))))) (Defn : Defn (ir) -> * (stx) [(define-language ,id ,[mv pname pred term?] ,id? ,rtd ,rcd ,tag-mask (,term* ...) ,[p* n*] ...) (with-syntax ([(p* ...) p*] [(n* ...) n*] [who (datum->syntax name 'who)]) #`(define #,name (let () (define-pass #,name : * (sexp entry) -> #,id () (definitions (define (squawk) (errorf who "unrecognized syntax ~s" sexp))) p* ... (case entry [(n*) (n* sexp squawk)] ... [else (errorf who "Unexpected entry name ~s" entry)])) (case-lambda [(sexp) (#,name sexp '#,pname)] [(sexp entry) (#,name sexp entry)]))))]) (Nonterminal : Nonterminal (ir) -> * (stx n) [(,id (,id* ...) ,b ,rtd ,rcd ,tag ,pred ,all-pred ,all-term-pred ,prod* ...) (values #`(#,id : * (sexp fk) -> #,id () #,(build-body id prod*)) id)]) (Production : Production (ir id fk-id fk) -> * (stx) [(production ,[pattern -> build-rec] ,pretty-prod? ,rtd ,tag ,pred ,maker ,field* ...) (with-syntax ([quasiquote (datum->syntax id 'quasiquote)]) #`(let ([#,fk-id #,fk]) #,(Pattern pattern #'sexp #`(quasiquote #,build-rec) fk-id)))] [(terminal ,[mv p pred term?] ,pretty-prod?) #`(let ([#,fk-id #,fk]) (if (#,pred sexp) sexp (#,fk-id)))] [(nonterminal ,[mv p pred term?] ,pretty-prod?) #`(let ([#,fk-id #,fk]) (#,p sexp #,fk-id))]) (Pattern : Pattern (ir sexp-id body fk) -> * (stx) [,id #`(if (eq? #,sexp-id '#,id) #,body (#,fk))] [,ref (let-values ([(mv p pred term?) (Reference ref)]) (if term? #`(if (#,pred #,sexp-id) (let ([#,mv #,sexp-id]) #,body) (#,fk)) #`(let ([#,mv (#,p #,sexp-id #,fk)]) #,body)))] [,null #`(if (null? #,sexp-id) #,body (#,fk))] [(maybe ,[mv p pred term?]) (if term? #`(if (or (eq? #,sexp-id #f) (#,pred #,sexp-id)) (let ([#,mv #,sexp-id]) #,body) (#,fk)) #`(let ([#,mv (and #,sexp-id (#,p #,sexp-id #,fk))]) #,body))] [(,pattern0 . ,pattern1) (with-syntax ([(a d) (generate-temporaries '(a d))]) #`(if (pair? #,sexp-id) (let ([a (car #,sexp-id)] [d (cdr #,sexp-id)]) #,(Pattern pattern0 #'a (Pattern pattern1 #'d body fk) fk)) (#,fk)))] [(,pattern0 ,dots . ,pattern1) (let ([binding* (extract-bindings pattern0)]) (with-syntax ([(binding ...) binding*] [(tbinding ...) (generate-temporaries binding*)] [(t0 t1 new-k loop) (generate-temporaries '(t0 t1 new-fk loop))]) #`(let loop ([t0 #,sexp-id] [tbinding '()] ...) (let ([new-fk (lambda () (if (pair? t0) (let ([t1 (car t0)] [t0 (cdr t0)]) #,(Pattern pattern0 #'t1 #'(loop t0 (cons binding tbinding) ...) fk)) (#,fk)))]) #,(Pattern pattern1 #'t0 #`(let ([binding (reverse tbinding)] ...) #,body) #'new-fk)))))]) (BuildPattern : Pattern (ir) -> * (stx) [,id id] [,ref (let-values ([(mv up pred term?) (Reference ref)]) #`,#,mv)] [,null #'()] [(maybe ,[mv up pred term?]) #`,#,mv] [(,[pattern0] ,dots . ,[pattern1]) #`(#,pattern0 (... ...) . #,pattern1)] [(,[pattern0] . ,[pattern1]) #`(#,pattern0 . #,pattern1)]) (Reference : Reference (ir) -> * (mv pname pred term?) [(term-ref ,id0 ,id1 ,b) (values id0 id1 (nanopass-case (Lannotated Terminal) (unbox b) [(,id (,id* ...) ,b ,handler? ,pred) pred]) #t)] [(nt-ref ,id0 ,id1 ,b) (values id0 id1 #f #f)]) (Defn ir)) (define (star? x) (or (eq? x '*) (eq? (syntax->datum x) '*))) (define (modifier? x) (memq (syntax->datum x) '(echo trace))) (define (definitions? x) (or (eq? x 'definitions) (eq? (syntax->datum x) 'defintions))) (define (options? x) (or (eq? x 'options) (eq? (syntax->datum x) 'options))) (define-language Lpass-src (terminals (identifier (id)) (colon (:)) (arrow (->)) (star (*)) (definitions (definitions)) (options (options)) (syntax (stx)) (modifier (modifier)) (null (null)) (dots (dots)) (unquote (unquote)) (boolean (b))) (Program (prog) (define-pass id : lname0 (id* ...) -> lname1 (out* ...) (options opt* ...) (definitions stx* ...) proc* ... (maybe stx))) (LanguageName (lname) * id (id0 id1)) (Processor (proc) (id : id0 (in* ...) -> id1 (out* ...) (options opt* ...) (definitions stx* ...) cl* ...)) (InputArgument (in) id [id stx]) (OutputExpression (out) id stx) (Clause (cl) [pattern stx* ... stx]) (Pattern (pattern) id (binding hole) (pattern0 dots . pattern1) (pattern0 . pattern1) null) (Hole (hole) id cata) (Catamorphism (cata) (stx : . cata-remainder) cata-remainder) (CatamorphismRemainder (cata-remainder) (stx* ... -> . cata-out) cata-out) (CatamorphismOutputVariables (cata-out) (id* ...)) (Option (opt) (trace b) (echo b) (generate-transformers b))) (define-pass parse-pass : * (stx who) -> Lpass-src () (definitions (define (has-language? lang) (nanopass-case (Lpass-src LanguageName) lang [,* #f] [else #t]))) (Program : * (stx) -> Program () (syntax-case stx () [(_ pass-name ?colon iname (fml ...) ?arrow oname (xval ...) . rest) (let ([squawk (lambda (msg what) (syntax-violation who msg stx what))]) (unless (identifier? #'pass-name) (squawk "invalid pass name" #'pass-name)) (unless (eq? (datum ?colon) ':) (squawk "expected colon" #'?colon)) (let ([ilang (LanguageName #'iname squawk)] [fml* #'(fml ...)]) (unless (for-all identifier? #'(fml ...)) (squawk "expected list of identifiers" fml*)) (when (and (has-language? ilang) (null? fml*)) (squawk "expected non-empty list of formals" fml*)) (unless (eq? (datum ?arrow) '->) (squawk "expected arrow" #'?arrow)) (let ([olang (LanguageName #'oname squawk)]) (define (looks-like-processor? x) (let loop ([x x] [mcount 0]) (syntax-case x () [(pname ?colon itype (fml ...) ?arrow otype (xval ...) . more) (and (eq? (datum ?colon) ':) (eq? (datum ?arrow) '->) (identifier? #'itype) (identifier? #'otype) (for-all (lambda (fml) (or (identifier? fml) (syntax-case fml () [[fml exp-value] (identifier? #'fml)]))) #'(fml ...))) #t] [(?modifier ?not-colon . more) (and (memq (datum ?modifier) '(trace echo)) (not (eq? (datum ?not-colon) ':)) (< mcount 2)) (loop #'(?not-colon . more) (fx+ mcount 1))] [_ #f]))) (define (s0 rest defn* pass-options) (syntax-case rest () [((definitions defn* ...) . rest) (eq? (datum definitions) 'definitions) (s0 #'rest #'(defn* ...) pass-options)] [((pass-options options ...) . rest) (eq? (datum pass-options) 'pass-options) (s0 #'rest defn* (map Option #'(options ...)))] [_ (s1 rest defn* pass-options '())])) (define (s1 rest defn* pass-options processor*) (syntax-case rest () [(a . rest) (looks-like-processor? #'a) (s1 #'rest defn* pass-options (cons (Processor #'a squawk) processor*))] [_ (s2 rest defn* pass-options processor*)])) (define (s2 rest defn* pass-options processor*) `(define-pass ,#'pass-name ,#'?colon ,ilang (,fml* ...) ,#'?arrow ,olang (,#'(xval ...) ...) (options ,(or pass-options '()) ...) (definitions ,defn* ...) ,processor* ... ,(syntax-case rest () [() #f] [oth #`(begin . oth)]))) (s0 #'rest '() #f))))])) (LanguageName : * (stx squawk) -> LanguageName () (syntax-case stx () [* (eq? (datum #'*) '*) #'*] [id (identifier? #'id) #'id] [(id0 id1) (and (identifier? #'id0) (identifier? #'id1)) `(,#'id0 ,#'id1)] [_ (squawk "invalid language specifier" stx)])) (Option : * (stx squawk) -> Option () (syntax-case stx () [trace (eq? (datum #'trace) 'trace) `(trace #t)] [echo (eq? (datum #'echo) 'echo) `(echo #t)] [generate-transformers (eq? (datum #'generate-transforms) 'generate-transforms) `(generate-transformers #t)] [_ (squawk "unexpected option" stx)])) (Processor : * (stx squawk) -> Processor () (let s0 ([stx stx] [modifier* '()]) (syntax-case stx () [(pname ?colon itype (fml ...) ?arrow otype (xval ...) . more) (and (eq? (datum ?colon) ':) (eq? (datum ?arrow) '->) (identifier? #'itype) (identifier? #'otype) (for-all (lambda (fml) (or (identifier? fml) (syntax-case fml () [[fml exp-value] (identifier? #'fml)]))) #'(fml ...))) (syntax-case #'more () [((definitions defn ...) cl ...) (eq? (datum definitions) 'definitions) (let ([cl* (map Clause #'(cl ...))] [in* (map InputArgument #'(fml ...))]) `(,#'id ,#'?colon ,#'itype (,in* ...) ,#'?arrow ,#'otype (,#'(xval ...) ...) (options ,modifier* ...) (definitions ,#'(defn ...) ...) ,cl* ...))] [(cl ...) (let ([cl* (map Clause #'(cl ...))] [in* (map InputArgument #'(fml ...))]) `(,#'id ,#'?colon ,#'itype (,in* ...) ,#'?arrow ,#'otype (,#'(xval ...) ...) (options ,modifier* ...) (definitions) ,cl* ...))])] [(?modifier ?not-colon . more) (s0 #'(?not-colon . more) (cons (Option #'?modifier squawk) modifier*))]))) (InputArgument : * (stx) -> InputArgument () (syntax-case stx () [id (identifier? #'id) #'id] [[id stx] (identifier? #'id) `(,#'id ,#'stx)])) (Clause : * (stx) -> Clause () (syntax-case stx () [(pattern stx* ... stx) (let ([pattern (Pattern #'pattern)]) `(,pattern ,#'(stx* ...) ... ,#'stx))])) (Pattern : * (stx) -> Pattern () (syntax-case stx () [id (identifier? #'id) #'id] [(unq hole) (eq? (datum unq) 'unquote) `(binding ,(Hole #'hole))] [(pattern0 dots . pattern1) (eq? (datum dots) '...) `(,(Pattern #'pattern0) ,#'dots . ,(Pattern #'pattern1))] [(pattern0 . pattern1) `(,(Pattern #'pattern0) . ,(Pattern #'pattern1))] [null '()])) (Hole : * (stx) -> Hole () (syntax-case stx () [id (identifier? #'id) #'id] [_ (Catamorphism stx)])) (Catamorphism : * (stx) -> Catamorphism () (let () (define (s0 stx) (syntax-case stx () [(: . stx) (colon? #':) (s2 #f #'stx)] [(-> . stx) (arrow? #'->) (s4 #f #f '() #'stx)] [(e . stx) (s1 #'e #'stx)] [() (in-context CatamorphismOutputVariables `(,'() ...))])) (define (s1 e stx) (syntax-case stx () [(: . stx) (colon? #':) (s2 e #'stx)] [(-> . stx) (and (arrow? #'->) (identifier? e)) (s4 #f (list e) '() #'stx)] [(expr . stx) (identifier? e) (s3 #f (list #'expr e) #'stx)] [() (identifier? e) (in-context CatamorphismOutputVariables `(,e))])) (define (s2 f stx) (syntax-case stx () [(-> . stx) (arrow? #'->) (s4 f #f '() #'stx)] [(id . stx) (identifier? #'id) (s3 f (list #'id) #'stx)])) (define (s3 f e* stx) (syntax-case stx () [(-> . stx) (arrow? #'->) (s4 f (reverse e*) '() #'stx)] [(e . stx) (s3 f (cons #'e e*) #'stx)] [() (for-all identifier? e*) `(,f : -> ,e* ...)])) (define (s4 f maybe-inid* routid* stx) (syntax-case stx () [(id . stx) (identifier? #'id) (s4 f maybe-inid* (cons #'id routid*) #'stx)] [() `(,f : ,(or maybe-inid* '()) ... -> ,(reverse routid*) ...)])) (s0 stx))) (Program stx)) (define-language Lpass (extends Lpass-src) (terminals (+ (Lannotated (np-lang)))) (Program (prog) (- (define-pass id : lname0 (id* ...) -> lname1 (out* ...) (options opt* ...) (definitions stx* ...) proc* ... (maybe stx))) (+ (define-pass id : lang0 (id* ...) -> lang1 (stx0* ...) (options opt* ...) (definitions stx1* ...) proc* ... stx))) (LanguageName (lname) (- * id (id0 id1))) (Language (lang) (+ (none) np-lang (np-lang id))) (Clause (cl) (- (pattern stx* ... stx)) (+ (pattern stx))) (Catamorphism (cata) (- (stx : . cata-remainder) cata-remainder) (+ (stx : (stx* ...) -> id* ...))) (CatamorphismRemainder (cata-remainder) (- (stx* ... -> . cata-out) cata-out)) (CatamorphismOutputVariables (cata-out) (- (id* ...)))) (define lookup-language (lambda (rho name) (let ([lang (rho name #'experimental-language)]) (unless (language-information? lang) (errorf 'with-language "unable to find language information for ~s" (syntax->datum name))) lang))) ) nanopass-framework-scheme-1.9.2/nanopass/helpers.ss000066400000000000000000000416361374306730300224550ustar00rootroot00000000000000;;; 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 .+. 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))])))))) nanopass-framework-scheme-1.9.2/nanopass/implementation-helpers.chezscheme.sls000066400000000000000000000211551374306730300277630ustar00rootroot00000000000000;;; 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))]))])) nanopass-framework-scheme-1.9.2/nanopass/implementation-helpers.ikarus.ss000066400000000000000000000153671374306730300267770ustar00rootroot00000000000000;;; 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))]))) nanopass-framework-scheme-1.9.2/nanopass/implementation-helpers.ironscheme.sls000066400000000000000000000160561374306730300300050ustar00rootroot00000000000000;;; 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))]))) nanopass-framework-scheme-1.9.2/nanopass/implementation-helpers.vicare.sls000066400000000000000000000143121374306730300271130ustar00rootroot00000000000000;;; 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)]))) nanopass-framework-scheme-1.9.2/nanopass/language-helpers.ss000066400000000000000000000060011374306730300242210ustar00rootroot00000000000000(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))]))))]))))))))))))) nanopass-framework-scheme-1.9.2/nanopass/language-node-counter.ss000066400000000000000000000153671374306730300252000ustar00rootroot00000000000000;;; 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)])))))))))])))) nanopass-framework-scheme-1.9.2/nanopass/language.ss000066400000000000000000000652171374306730300225770ustar00rootroot00000000000000;;; 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 ...)))))])))) nanopass-framework-scheme-1.9.2/nanopass/meta-parser.ss000066400000000000000000000530671374306730300232340ustar00rootroot00000000000000;;; 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 #) ; 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))))) nanopass-framework-scheme-1.9.2/nanopass/meta-syntax-dispatch.ss000066400000000000000000000124311374306730300250510ustar00rootroot00000000000000;;; 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 '())))) nanopass-framework-scheme-1.9.2/nanopass/nano-syntax-dispatch.ss000066400000000000000000000065271374306730300250670ustar00rootroot00000000000000;;; 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 '())]))) nanopass-framework-scheme-1.9.2/nanopass/parser.ss000066400000000000000000000221301374306730300222730ustar00rootroot00000000000000;;; 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)])))) nanopass-framework-scheme-1.9.2/nanopass/pass.ss000066400000000000000000002747361374306730300217720ustar00rootroot00000000000000;;; Copyright (c) 2000-2018 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell ;;; See the accompanying file Copyright for details ;;; TODO: ;;; 1. write make-processors (based on make-processor, currently in meta-parsers ;;; 2. add else clause to processors ;;; Make sure the following are obeyed: ;;; 1. allow ir to be named ;;; 2. loosen up form of pass body ;;; 3. don't require () in pass body ;;; 4. add else clause ;;; 5. support Datum output ;;; 6. don't bind quasiquote with Datum output ;;; 7. make cata work with Datum output (library (nanopass pass) (export define-pass trace-define-pass echo-define-pass with-output-language nanopass-case pass-input-parser pass-output-unparser pass-identifier? pass-input-language pass-output-language) (import (rnrs) (nanopass helpers) (nanopass records) (nanopass syntaxconvert) (nanopass meta-parser) (nanopass parser) (nanopass unparser) (rnrs mutable-pairs)) (define-syntax pass-input-parser (lambda (x) (syntax-case x () [(_ pass-name) (with-compile-time-environment (rho) (let ([pass-info (rho #'pass-name #'define-pass)]) (if pass-info (let ([Lid (pass-info-input-language pass-info)]) (if Lid (with-syntax ([Lid Lid]) #'(let () (define-parser parse-Lid Lid) parse-Lid)) #'(lambda (x . rest) x))) #'#f)))]))) (define-syntax pass-output-unparser (lambda (x) (syntax-case x () [(_ pass-name) (with-compile-time-environment (rho) (let ([pass-info (rho #'pass-name #'define-pass)]) (if pass-info (let ([Lid (pass-info-output-language pass-info)]) (if Lid (with-syntax ([Lid Lid]) #'(let () (define-unparser unparse-Lid Lid) unparse-Lid)) #'(lambda (x . rest) x))) #f)))]))) (define pass-identifier? (lambda (id rho) (and (rho id #'define-pass) #t))) (define pass-input-language (lambda (id rho) (let ([pass-info (rho id #'define-pass)]) (and pass-info (pass-info-input-language pass-info))))) (define pass-output-language (lambda (id rho) (let ([pass-info (rho id #'define-pass)]) (and pass-info (pass-info-output-language pass-info))))) ;; NOTE: the following is less general then the with-output-language because it does not ;; support multiple return values. It also generates nastier code for the expander to deal ;; with, though cp0 should clean it up. It is possible that in the long run, we'll want to ;; have a separate pass-lambda form, or that we'll loosen up the body further to return ;; multiple values even when they aren't specified. For now, this is moth-balled. #;(define-syntax with-output-language (lambda (x) (syntax-case x () [(k (lang type) b b* ...) (with-syntax ([pass (datum->syntax #'k 'pass)]) #'(let () (define-pass pass : * () -> (lang type) () (begin b b* ...)) (pass)))] [(k lang b b* ...) (with-syntax ([pass (datum->syntax #'k 'pass)]) #'(let () (define-pass pass : * () -> lang () (begin b b* ...)) (pass)))]))) (define-syntax with-output-language (lambda (x) (with-compile-time-environment (r) (syntax-case x () [(id (lang type) b b* ...) (let* ([olang-pair (r #'lang)] [olang (and olang-pair (car olang-pair))] [meta-parser (and olang-pair (cdr olang-pair))]) (unless (language? olang) (syntax-violation 'with-output-language "unrecognized language" #'lang)) (unless (procedure? meta-parser) (syntax-violation 'with-output-language "missing meta parser for language" #'lang)) (with-syntax ([in-context (datum->syntax #'id 'in-context)] [quasiquote (datum->syntax #'id 'quasiquote)]) #`(let-syntax ([quasiquote '#,(make-quasiquote-transformer #'id #'type olang meta-parser)] [in-context '#,(make-in-context-transformer #'id olang meta-parser)]) b b* ...)))] [(id lang b b* ...) (let* ([olang-pair (r #'lang)] [olang (and olang-pair (car olang-pair))] [meta-parser (and olang-pair (cdr olang-pair))]) (unless (language? olang) (syntax-violation 'with-output-language "unrecognized language" #'lang)) (unless (procedure? meta-parser) (syntax-violation 'with-output-language "missing meta parser for language" #'lang)) (with-syntax ([in-context (datum->syntax #'id 'in-context)]) #`(let-syntax ([in-context '#,(make-in-context-transformer #'id olang meta-parser)]) b b* ...)))])))) (define-syntax nanopass-case ; (nanopass-case (lang type) id ---) rebinds id so that it always holds the ; current ir even through cata recursion (lambda (x) (syntax-case x (else) [(k (lang type) x cl ... [else b0 b1 ...]) (identifier? #'x) (with-syntax ([quasiquote (datum->syntax #'k 'quasiquote)]) ; if we were in a rhs, pick-up the output quasiquote #'(let () (define-pass p : (lang type) (x) -> * (val) (proc : type (x) -> * (val) cl ... [else b0 b1 ...]) (proc x)) (p x)))] [(k (lang type) e cl ... [else b0 b1 ...]) #'(let ([ir e]) (k (lang type) ir cl ... [else b0 b1 ...]))] [(k (lang type) e cl ...) #`(k (lang type) e cl ... [else (error 'nanopass-case ; TODO: we were using $strip-wrap here, should be something like ; $make-source-oops, but at least pseudo r6rs portable if possible #,(let ([si (syntax->source-info x)]) (if si (format "empty else clause hit ~s ~a" (syntax->datum x) si) (format "empty else clause hit ~s" (syntax->datum x)))))])]))) (define-syntax trace-define-pass (lambda (x) (define unparser (lambda (lang) (cond [(eq? (syntax->datum lang) '*) #f] [(identifier? lang) (construct-id lang "unparse-" lang)] [else (syntax-case lang () [(lang type) (construct-id #'lang "unparse-" #'lang)])]))) (syntax-case x () [(_ name ?colon ilang (id ...) ?arrow olang (xtra ...) . body) (and (identifier? #'name) (eq? (datum ?arrow) '->) (eq? (datum ?colon) ':) (for-all identifier? #'(id ...))) (let ([iunparser (unparser #'ilang)] [ounparser (unparser #'olang)]) #`(define name (lambda (id ...) (define-pass name ?colon ilang (id ...) ?arrow olang (xtra ...) . body) (let ([tpass name]) #,(if iunparser (if ounparser (with-syntax ([(ot xvals ...) (generate-temporaries #'(name xtra ...))] [(tid xargs ...) (generate-temporaries #'(id ...))] [(id id* ...) #'(id ...)]) #`(let ([result #f]) (trace-let name ([tid (#,iunparser id #t)] [xargs id*] ...) (let-values ([(ot xvals ...) (tpass id id* ...)]) (set! result (list ot xvals ...)) (values (#,ounparser ot #t) xvals ...))) (apply values result))) (with-syntax ([(xvals ...) (generate-temporaries #'(xtra ...))] [(tid xargs ...) (generate-temporaries #'(id ...))] [(id id* ...) #'(id ...)]) #`(trace-let name ([tid (#,iunparser id #t)] [xargs id*] ...) (tpass id id* ...)))) (if ounparser (with-syntax ([(ot xvals ...) (generate-temporaries #'(name xtra ...))]) #`(let ([result #f]) (trace-let name ([id id] ...) (let-values ([(ot xvals ...) (tpass id ...)]) (set! result (list ot xvals ...)) (values (#,ounparser ot #t) xvals ...))) (apply values result))) #`(trace-let name ([id id] ...) (tpass id ...))))))))]))) (define-syntax define-pass (syntax-rules () [(_ . more) (x-define-pass . more)])) (define-syntax echo-define-pass (lambda (x) (define parse-options (lambda (body) (let loop ([rest body] [defn #f] [pass-options '()]) (syntax-case rest () [() (if defn #`(#,pass-options #,defn) #`(#,pass-options))] [((definitions . defn) . rest) (eq? (datum definitions) 'definitions) (loop #'rest #'(definitions . defn) pass-options)] [((?pass-options ?options ...) . rest) (eq? (datum ?pass-options) 'pass-options) (loop #'rest defn #'(?options ...))] [_ (if defn #`(#,pass-options #,defn . #,rest) #`(#,pass-options . #,rest))])))) (syntax-case x () [(_ name ?colon ilang (fml ...) ?arrow olang (xval ...) . body) (and (identifier? #'name) (eq? (datum ?colon) ':) (or (identifier? #'ilang) (syntax-case #'ilang () [(ilang itype) (and (identifier? #'ilang) (identifier? #'itype))] [_ #f])) (or (identifier? #'olang) (syntax-case #'olang () [(olang otype) (and (identifier? #'olang) (identifier? #'otype))] [_ #f])) (for-all identifier? #'(fml ...))) (with-syntax ([((options ...) . body) (parse-options #'body)]) #'(x-define-pass name ?colon ilang (fml ...) ?arrow olang (xval ...) (pass-options (echo #t) options ...) . body))]))) (define-syntax x-define-pass (lambda (x) (define who 'define-pass) (define-record-type pass-options (nongenerative) (fields echo? generate-transformers?) (protocol (lambda (new) (case-lambda [() (new #f #t)] [(options) (let loop ([options options] [echo? #f] [gt? #t]) (syntax-case options () [() (new echo? gt?)] [((?echo ?bool) . options) (and (identifier? #'?echo) (eq? (datum ?echo) 'echo) (boolean? (datum ?bool))) (loop #'options (datum ?bool) gt?)] [((?generate-transformers ?bool) . options) (and (identifier? #'?generate-transformers) (eq? (datum ?generate-transformers) 'generate-transformers) (boolean? (datum ?bool))) (loop #'options echo? (datum ?bool))] [(opt . options) (syntax-violation who "invalid pass option" x #'opt)]))])))) (define-record-type pass-desc (nongenerative) (fields name maybe-ilang maybe-olang (mutable pdesc*))) (define-record-type pdesc (nongenerative) (fields name maybe-itype fml* dflt* maybe-otype xval* body trace? echo?)) (define-record-type pclause (nongenerative) (fields lhs guard id rhs-arg* rhs-lambda (mutable used? pclause-used? pclause-used-set!) (mutable related-alt*)) (protocol (lambda (new) (lambda (lhs guard id rhs-arg* rhs-lambda) (new lhs guard id rhs-arg* rhs-lambda #f '()))))) (define make-processors (lambda (pass-desc pass-options maybe-imeta-parser maybe-ometa-parser) (let loop ([pdesc* (pass-desc-pdesc* pass-desc)] [processor* '()]) (if (null? pdesc*) (let ([pdesc* (let ([ls (pass-desc-pdesc* pass-desc)]) (list-head ls (fx- (length ls) (length processor*))))]) (if (null? pdesc*) processor* (loop pdesc* processor*))) (loop (cdr pdesc*) (cons (make-processor pass-desc pass-options maybe-imeta-parser maybe-ometa-parser (car pdesc*)) processor*)))))) (define make-processor (lambda (pass-desc pass-options maybe-imeta-parser maybe-ometa-parser pdesc) (define echo-processor (lambda (result) (when (pdesc-echo? pdesc) (printf "~s in pass ~s expanded into:\n" (syntax->datum (pdesc-name pdesc)) (syntax->datum (pass-desc-name pass-desc))) (pretty-print (syntax->datum result))) result)) (with-syntax ([lambda-expr (make-processor-lambda pass-desc pass-options maybe-imeta-parser maybe-ometa-parser pdesc)] [name (pdesc-name pdesc)]) (echo-processor #`(define name #,(if (pdesc-trace? pdesc) (let ([maybe-ilang (pass-desc-maybe-ilang pass-desc)] [maybe-olang (pass-desc-maybe-olang pass-desc)]) (let ([iunparser (and maybe-ilang (pdesc-maybe-itype pdesc) (let ([ilang (language-name maybe-ilang)]) (construct-id ilang "unparse-" ilang)))] [ounparser (and maybe-olang (pdesc-maybe-otype pdesc) (let ([olang (language-name maybe-olang)]) (construct-id olang "unparse-" olang)))]) (if iunparser (if ounparser (with-syntax ([(fml fml* ...) (generate-temporaries (pdesc-fml* pdesc))] [(ot xrt ...) (generate-temporaries (cons 'ot (pdesc-xval* pdesc)))] [(tot txrt ...) (generate-temporaries (cons 'tot (pdesc-xval* pdesc)))]) #`(lambda (fml fml* ...) (let ([tproc lambda-expr]) (let ([ot #f] [xrt #f] ...) (trace-let name ([t (#,iunparser fml #t)] [fml* fml*] ...) (let-values ([(tot txrt ...) (tproc fml fml* ...)]) (set! ot tot) (set! xrt txrt) ... (values (#,ounparser tot #t) txrt ...))) (values ot xrt ...))))) (with-syntax ([(fml fml* ...) (generate-temporaries (pdesc-fml* pdesc))]) #`(lambda (fml fml* ...) (let ([tproc lambda-expr]) (trace-let name ([t (#,iunparser fml #t)] [fml* fml*] ...) (tproc fml fml* ...)))))) (if ounparser (with-syntax ([(fml ...) (generate-temporaries (pdesc-fml* pdesc))] [(ot xrt ...) (generate-temporaries (cons 'ot (pdesc-xval* pdesc)))] [(tot txrt ...) (generate-temporaries (cons 'tot (pdesc-xval* pdesc)))]) #`(lambda (fml ...) (let ([tproc lambda-expr]) (let ([ot #f] [xrt #f] ...) (trace-let name ([fml fml] ...) (let-values ([(tot txrt ...) (tproc fml ...)]) (set! ot tot) (set! xrt txrt) ... (values (#,ounparser tot #t) txrt ...))) (values ot xrt ...))))) (with-syntax ([(fml ...) (generate-temporaries (pdesc-fml* pdesc))]) #'(lambda (fml ...) (let ([tproc lambda-expr]) (trace-let name ([fml fml] ...) (tproc fml ...))))))))) #'lambda-expr)))))) (define make-processor-lambda (lambda (pass-desc pass-options maybe-imeta-parser maybe-ometa-parser pdesc) (let ([maybe-olang (pass-desc-maybe-olang pass-desc)] [maybe-otype (pdesc-maybe-otype pdesc)] ; HERE [tfml (car (generate-temporaries '(x)))] [fml* (pdesc-fml* pdesc)]) #`(lambda #,fml* (let ([#,tfml #,(car fml*)]) #,@((lambda (forms) (if maybe-olang (list (rhs-in-context-quasiquote (pass-desc-name pass-desc) maybe-otype maybe-olang maybe-ometa-parser #`(begin #,@forms))) forms)) (if (let ([maybe-itype (pdesc-maybe-itype pdesc)]) (and maybe-itype (nonterm-id->ntspec? maybe-itype (language-ntspecs (pass-desc-maybe-ilang pass-desc))))) (let-values ([(body defn*) (syntax-case (pdesc-body pdesc) () [((definitions defn* ...) . body) (eq? (datum definitions) 'definitions) (values #'body #'(defn* ...))] [body (values #'body '())])]) #`(#,@defn* #,(make-processor-clauses pass-desc pass-options tfml maybe-imeta-parser maybe-ometa-parser pdesc body))) (pdesc-body pdesc)))))))) (define make-processor-clauses (lambda (pass-desc pass-options tfml imeta-parser maybe-ometa-parser pdesc cl*) (let* ([itype (pdesc-maybe-itype pdesc)] ; HERE [ilang (pass-desc-maybe-ilang pass-desc)] [intspec* (language-ntspecs ilang)] [maybe-otype (pdesc-maybe-otype pdesc)] ; HERE [maybe-olang (pass-desc-maybe-olang pass-desc)] [maybe-ontspec* (and maybe-otype (language-ntspecs maybe-olang))] [fml* (pdesc-fml* pdesc)] [fml tfml] [xfml* (cdr fml*)]) (define match-xfml* (match-extra-formals xfml*)) (define parse-clauses (lambda (cl*) (define nano-meta->fml* (lambda (cl nm) (let f ([nrec* (nano-meta-fields nm)] [fml* '()]) (fold-right (rec g (lambda (nrec fml*) (cond [(nano-dots? nrec) (g (nano-dots-x nrec) fml*)] [(nano-unquote? nrec) (cons (nano-unquote-x nrec) fml*)] [(nano-cata? nrec) (let ([fml* (append (let ([outid* (nano-cata-outid* nrec)]) (if (and maybe-olang (not (null? outid*)) (eq? (syntax->datum (car outid*)) '*)) (cdr outid*) outid*)) fml*)] [maybe-inid* (nano-cata-maybe-inid* nrec)]) (if (and maybe-inid* (let ([id (car maybe-inid*)]) (and (identifier? id) (not (memp (lambda (fml) (free-identifier=? fml id)) fml*))))) (cons (car maybe-inid*) fml*) fml*))] [(nano-meta? nrec) (f (nano-meta-fields nrec) fml*)] [(list? nrec) (f nrec fml*)] [(nano-quote? nrec) (syntax-violation who (format "quoted terminals (~s) currently unsupported in match patterns" (nano-quote-x nrec)) (nano-quote-x nrec) cl)] [else (error who "unrecognized nano-rec" nrec)]))) fml* nrec*)))) (define (helper cl lhs guard rhs rhs*) (let ([nano-meta (imeta-parser itype lhs #t)]) (let ([fml* (nano-meta->fml* cl nano-meta)]) (unless (all-unique-identifiers? fml*) (syntax-violation who "pattern binds one or more identifiers more then once" lhs)) (make-pclause nano-meta guard (datum->syntax #'* (gensym "rhs")) fml* #`(lambda #,fml* #,rhs #,@rhs*))))) (let f ([cl* cl*] [pclause* '()]) (if (null? cl*) (values (reverse pclause*) #f #f) (syntax-case (car cl*) (guard else) [[else rhs0 rhs1 ...] (null? (cdr cl*)) (values (reverse pclause*) #'else-th #'(lambda () (begin rhs0 rhs1 ...)))] [[lhs (guard g0 g1 ...) rhs0 rhs1 ...] (f (cdr cl*) (cons (helper (car cl*) #'lhs #'(and g0 g1 ...) #'rhs0 #'(rhs1 ...)) pclause*))] [[lhs rhs0 rhs1 ...] (f (cdr cl*) (cons (helper (car cl*) #'lhs #t #'rhs0 #'(rhs1 ...)) pclause*))] [_ (syntax-violation (syntax->datum (pass-desc-name pass-desc)) "invalid processor clause" (pdesc-name pdesc) (car cl*))]))))) (module (make-clause generate-system-clauses) (define make-system-clause (lambda (alt) (define genmap (lambda (callee-pdesc level maybe? arg args) (if (fx=? level 0) (build-call callee-pdesc (cons arg args) maybe?) (with-syntax ([arg arg]) (let loop ([proc (with-syntax ([(t) (generate-temporaries '(t))]) #`(lambda (t) #,(build-call callee-pdesc (cons #'t args) maybe?)))] [level level]) (with-syntax ([proc proc]) (if (fx=? level 0) #'(proc arg) (loop #'(lambda (x) (map proc x)) (fx- level 1))))))))) (define-who process-alt (lambda (in-altrec out-altrec) (define process-alt-field (lambda (level maybe? fname aname ofname) (let ([callee-pdesc (find-proc pass-desc pass-options (pdesc-name pdesc) (syntax->datum (spec-type (find-spec fname ilang))) (syntax->datum (spec-type (find-spec ofname maybe-olang))) (and (nonterminal-meta? fname intspec*) (nonterminal-meta? ofname maybe-ontspec*)) match-xfml* no-xval?)]) ; punting when there are return values for now (if callee-pdesc (genmap callee-pdesc level maybe? #`(#,aname #,fml) xfml*) (begin (when (or (nonterminal-meta? fname intspec*) (nonterminal-meta? ofname maybe-ontspec*)) (syntax-violation who (format "unable to automatically translate ~s in ~s to ~s in ~s" (syntax->datum fname) (syntax->datum (alt-syn in-altrec)) (syntax->datum ofname) (syntax->datum (alt-syn out-altrec))) (pass-desc-name pass-desc) (pdesc-name pdesc))) #`(#,aname #,fml)))))) (cond [(pair-alt? in-altrec) (let* ([in-field-level* (pair-alt-field-levels in-altrec)] [in-field-maybe* (pair-alt-field-maybes in-altrec)] [in-acc* (pair-alt-accessors in-altrec)] [in-field-name* (pair-alt-field-names in-altrec)] [out-field-name* (pair-alt-field-names out-altrec)] [out-field* (map process-alt-field in-field-level* in-field-maybe* in-field-name* in-acc* out-field-name*)]) ; always using the non-checking form here, because we are simply rebuilding; ; TODO: terminals should be checked to be matching from the input language ; to the output language, otherwise a check should be made here or the ; checking version of the maker should be used. ; AWK: this has been changed to use the checking alt, because we cannot ; assume that other transformers will always create a valid element for ; sub-parts of this particular maker. ; TODO: Need to find a way to give a better error message in the checking maker #`(#,(pair-alt-maker out-altrec) '#,(pass-desc-name pass-desc) #,@out-field* #,@(map (lambda (x) (format "~s" x)) (syntax->datum in-field-name*))))] [(terminal-alt? in-altrec) (error who "unexpected terminal alt" in-altrec)] [(nonterminal-alt? in-altrec) (error who "unexpected nonterminal alt" in-altrec)] [else (errorf who "unexpected alt: ~s" alt)]))) (cond [(nonterminal-alt? alt) (build-subtype-call (syntax->datum (ntspec-name (nonterminal-alt-ntspec alt))))] [(terminal-alt? alt) (let ([xval* (pdesc-xval* pdesc)]) (cond [(find-proc pass-desc pass-options (pdesc-name pdesc) (syntax->datum (tspec-type (terminal-alt-tspec alt))) maybe-otype #f match-xfml* (length-matches xval*)) => (lambda (callee-pdesc) (build-call callee-pdesc fml*))] [(null? xval*) fml] [else #`(values #,fml #,@xval*)]))] [else (let ([oalt (exists-alt? alt (nonterm-id->ntspec who maybe-otype maybe-ontspec*))]) (if oalt (let ([alt-code (process-alt alt oalt)] [xval* (pdesc-xval* pdesc)]) (if (null? xval*) alt-code #`(values #,alt-code #,@xval*))) ; TODO: if there were no user provided clauses for this input alt, ; we could raise a compile time error here, otherwise we have to rely ; on the runtime error #`(error '#,(pass-desc-name pass-desc) (format "no matching clause for input ~s in processor ~s" '#,(alt-syn alt) '#,(pdesc-name pdesc)) #,fml)))]))) (define gen-binding (lambda (t v) (if (eq? t v) '() (list #`(#,t #,v))))) (define gen-t (lambda (acc) (if (identifier? acc) acc (gentemp)))) (define gen-let1 (lambda (t v e) (cond [(eq? t v) e] [(eq? e #t) #t] [else #`(let ([#,t #,v]) #,e)]))) ;; Note: gen-and DOES NOT actually function like and. For instance, ;; normally (and exp #t) would return #t, but with gen-and we get exp ;; so if exp does not evaluate to #t, the result is different. ;; This is used in the generated results. (define gen-and (lambda (e1 e2) (cond [(eq? e1 #t) e2] [(eq? e2 #t) e1] [else #`(and #,e1 #,e2)]))) (define gen-for-all (lambda (t v e) (if (eq? e #t) #t #`(for-all (lambda (#,t) #,e) #,v)))) ; TODO: Right now process-nano-fields and its helpers are generating a predicate ; on incoming records, and two bindings for each user specified unquote expression. ; I think the infrastructure should be assuming that the input is well structured ; (i.e. it should rely on the builder of the structure to do the checking and not ; check on input, and hence should not generate the temporary bindings, or the ; checks.) (define process-nano-fields (lambda (elt* acc-id aname* itype*) (if (null? elt*) (values #t '() '() '()) (let-values ([(elt-ipred elt-tbinding* elt-ibinding* elt-obinding*) (process-nano-elt (car elt*) #`(#,(car aname*) #,acc-id) (car itype*))] [(rest-ipred rest-tbinding* rest-ibinding* rest-obinding*) (process-nano-fields (cdr elt*) acc-id (cdr aname*) (cdr itype*))]) (values (gen-and elt-ipred rest-ipred) (append elt-tbinding* rest-tbinding*) (append elt-ibinding* rest-ibinding*) (append elt-obinding* rest-obinding*)))))) (define gen-mvmap (lambda (who ids proc arg . args) (with-syntax ([who who] [proc proc] [arg arg]) (with-syntax ([(arg* ...) args] [(ls2 ...) (generate-temporaries args)] [(id ...) (generate-temporaries ids)] [(id* ...) (generate-temporaries ids)]) (with-syntax ([(ls ...) #'(ls1 ls2 ...)]) #'(let ([p proc] [ls1 arg] [ls2 arg*] ...) (unless (list? ls) (error 'who "not a proper list" ls)) ... (let ([n (length ls1)]) (unless (and (= (length ls2) n) ...) (error 'who "mismatched list lengths" ls1 ls2 ...))) (let f ([ls1 ls1] [ls2 ls2] ...) (if (null? ls1) (let ([id '()] ...) (values id ...)) (let-values ([(id ...) (p (car ls1) (car ls2) ...)] [(id* ...) (f (cdr ls1) (cdr ls2) ...)]) (values (cons id id*) ...)))))))))) (define process-nano-dots (lambda (elt acc itype) (let ([map-t (gentemp)]) (let-values ([(ipred tbinding* ibinding* obinding*) (process-nano-elt elt map-t itype)]) (let ([ls-t (gen-t acc)]) (values (gen-for-all map-t acc ipred) (gen-binding ls-t acc) (map (lambda (ibinding) (syntax-case ibinding () [(id expr) (if (and (identifier? #'expr) (eq? map-t #'expr)) #`(id #,ls-t) #`(id (map (lambda (#,map-t) #,(if (null? tbinding*) #'expr #`(let* #,tbinding* expr))) #,ls-t)))])) ibinding*) (map (lambda (obinding) ;; TODO: rather than tearing apart the code we've constructed ;; in the nano-cata case to support dotted cata, the nano-cata ;; should be constructed to just build the correct code in the first ;; place. (syntax-case obinding () [(ids (procexpr var args ...)) ;; contains expr itself #`(ids ((let ([p (let ([p procexpr]) (lambda (m) (p m args ...)))]) (lambda (x) #,(cond [(null? #'ids) #'(begin (for-each p x) (values))] [(null? (cdr #'ids)) #'(map p x)] [else (gen-mvmap (pass-desc-name pass-desc) #'ids #'p #'x)]))) var))])) obinding*))))))) (define process-nano-list (lambda (elt* acc itype) (define helper (lambda (elt* tail-acc) (if (null? elt*) (values #t '() '() '() 0 #f) (let ([elt (car elt*)]) (if (nano-dots? elt) (let ([t (gen-t tail-acc)] [n (length (cdr elt*))]) (let-values ([(elt-ipred elt-tbinding* elt-ibinding* elt-obinding*) (process-nano-dots (nano-dots-x elt) (if (fx=? n 0) t #`(list-head #,t (fx- (length #,t) #,n))) itype)] [(rest-ipred rest-tbinding* rest-ibinding* rest-obinding* i dots?) (helper (cdr elt*) (if (fx=? n 0) t #`(list-tail #,t (fx- (length #,t) #,n))))]) (values (gen-let1 t tail-acc (gen-and elt-ipred rest-ipred)) (append (gen-binding t tail-acc) elt-tbinding* rest-tbinding*) (append elt-ibinding* rest-ibinding*) (append elt-obinding* rest-obinding*) i #t))) (let ([t (gen-t tail-acc)]) (let-values ([(elt-ipred elt-tbinding* elt-ibinding* elt-obinding*) (process-nano-elt elt #`(car #,t) itype)] [(rest-ipred rest-tbinding* rest-ibinding* rest-obinding* i dots?) (helper (cdr elt*) #`(cdr #,t))]) (values (gen-let1 t tail-acc (gen-and elt-ipred rest-ipred)) (append (gen-binding t tail-acc) elt-tbinding* rest-tbinding*) (append elt-ibinding* rest-ibinding*) (append elt-obinding* rest-obinding*) (fx+ i 1) dots?)))))))) (let ([t (gen-t acc)]) (let-values ([(ipred tbinding* ibinding* obinding* i dots?) (helper elt* t)]) (values (gen-let1 t acc (if dots? (if (fx=? i 0) ipred (gen-and #`(fx>=? (length #,t) #,i) ipred)) (gen-and #`(fx=? (length #,t) #,i) ipred))) (append (gen-binding t acc) tbinding*) ibinding* obinding*))))) (define build-meta-variable-check (lambda (id acc itype) (let ([spec (find-spec id ilang)]) ;; SYMBOLIC (cond [(eq? (syntax->datum (spec-type spec)) (syntax->datum itype)) #t] [(nonterm-id->ntspec? itype (language-ntspecs ilang)) => (lambda (ntspec) (if (subspec? spec ntspec) #`(#,(spec-all-pred spec) #,acc) (syntax-violation (syntax->datum (pass-desc-name pass-desc)) (format "expected meta-variable for nonterminal ~s, but got" (syntax->datum itype)) id)))] [(term-id->tspec? itype (language-tspecs ilang)) => (lambda (tspec) (syntax-violation (syntax->datum (pass-desc-name pass-desc)) (format "expected meta-variable for terminal ~s, but got" (syntax->datum itype)) id))] [else (syntax-violation (syntax->datum (pass-desc-name pass-desc)) (format "NANOPASS INTERNAL ERROR: unable to find spec for type ~s" (syntax->datum itype)) id)])))) (define process-nano-elt (lambda (elt acc itype) (cond [(nano-meta? elt) (let ([t (gen-t acc)]) (let-values ([(ipred tbinding* ibinding* obinding*) (process-nano-meta elt t)]) (values (gen-let1 t acc (gen-and ;; TODO: if the nt here doesn't have any terminals, then we only ;; need to do the tag comparison. #;#`(eqv? (nanopass-record-tag #,t) #,(pair-alt-tag (nano-meta-alt elt))) #`(#,(pair-alt-pred (nano-meta-alt elt)) #,t) ipred)) (append (gen-binding t acc) tbinding*) ibinding* obinding*)))] [(nano-quote? elt) (syntax-violation (syntax->datum (pass-desc-name pass-desc)) "quoted items are currently unsupported in patterns" (nano-quote-x elt))] [(nano-unquote? elt) ; TODO: will break if two ids are same (let ([id (nano-unquote-x elt)]) (values (build-meta-variable-check id acc itype) '() (list #`(#,id #,acc)) '()))] [(nano-cata? elt) ; TODO: will break if two ids are same ; HERE: if this is a cata for a (maybe x) field, it needs to not bother ; parsing the #f (let* ([maybe-inid* (nano-cata-maybe-inid* elt)] [t (or (and maybe-inid* (car maybe-inid*)) (gentemp))] [maybe? (nano-cata-maybe? elt)] [itype (syntax->datum itype)]) (let-values ([(maybe-otype outid*) (let ([outid* (nano-cata-outid* elt)]) (if maybe-olang (if (null? outid*) (values #f outid*) (if (eq? (syntax->datum (car outid*)) '*) (values #f (cdr outid*)) (values (syntax->datum (spec-type (find-spec (car outid*) maybe-olang))) outid*))) (values #f outid*)))]) (define build-cata-call-1 (lambda (itype maybe-otype inid* outid*) (build-call-with-arguments (find-proc pass-desc pass-options (nano-cata-syntax elt) itype maybe-otype #t (lambda (id* dflt*) (fx= itype and pdesc-otype <= otype (define pdesc-ok? (lambda (pdesc outid*) (and (for-all (lambda (req) (memp (lambda (x) (bound-identifier=? req x)) fml*)) (list-head xfml* (fx- (length xfml*) (length (pdesc-dflt* pdesc))))) (fx=? (length (pdesc-xval* pdesc)) ; TODO: when we don't have an otype for a processor, we may not have an otype here ; we should check this out to be sure. (length (if itype (cdr outid*) outid*)))))) (define build-cata-call-2 (lambda (callee-pdesc t) (build-call callee-pdesc (cons t xfml*) maybe?))) (define build-cata-call-3 (lambda (itype maybe-otype t outid*) (build-call (find-proc pass-desc pass-options (nano-cata-syntax elt) itype maybe-otype #t match-xfml* (length-matches (if maybe-otype (cdr outid*) outid*))) (cons t xfml*) maybe?))) ; check number of arguments when we have a maybe (when (and maybe? (not (fx=? (length outid*) 1))) (syntax-violation who "cannot use cata-morphism that returns multiple values with a maybe field" (nano-cata-syntax elt))) (let ([procexpr (nano-cata-procexpr elt)]) (define build-procexpr-call (lambda () (let ([inid* (or maybe-inid* (list t))]) (if maybe? (with-syntax ([(t t* ...) (generate-temporaries inid*)]) #`((lambda (t t* ...) (and t (#,procexpr t t* ...))) #,@inid*)) #`(#,procexpr #,@inid*))))) #;(unless procexpr (unless (nonterm-id->ntspec? itype (language-ntspecs ilang)) (syntax-violation who "cannot use cata-morphism without specifying a procedure to call for an input terminal field" (nano-cata-syntax elt)))) #;(when maybe-otype (unless (or procexpr (nonterm-id->ntspec? maybe-otype (language-ntspecs maybe-olang))) (syntax-violation who "cannot use cata-morphism without specifying a procedure to call for an output terminal field" (nano-cata-syntax elt)))) ; when we are not given a processor, make sure our itype is valid (values ; input predicate check (if maybe-inid* (build-meta-variable-check (car maybe-inid*) acc (nano-cata-itype elt)) #t) ; binding of temporaries '() ; binding of input variable from language record (list #`(#,t #,acc)) ; binding of output variable(s) (if maybe-inid* (if procexpr (list #`[#,outid* #,(build-procexpr-call)]) (list #`[#,outid* #,(build-cata-call-1 itype maybe-otype maybe-inid* outid*)])) (cond [(and (identifier? procexpr) (find (lambda (pdesc) (bound-identifier=? procexpr (pdesc-name pdesc))) (pass-desc-pdesc* pass-desc))) => (lambda (callee-pdesc) (if (pdesc-ok? callee-pdesc outid*) (list #`[#,outid* #,(build-cata-call-2 callee-pdesc t)]) (syntax-violation (syntax->datum (pass-desc-name pass-desc)) (format "incorrect arguments for ~s in cata" (syntax->datum procexpr)) (nano-cata-syntax elt))))] [procexpr (list #`[#,outid* #,(build-procexpr-call)])] [else (list #`[#,outid* #,(build-cata-call-3 itype maybe-otype t outid*)])]))))))] [(list? elt) (process-nano-list elt acc itype)] [else (values #`(equal? #,acc #,elt) '() '() '())]))) (define-who process-nano-meta (lambda (x acc-id) (let ([prec-alt (nano-meta-alt x)]) (if (pair-alt? prec-alt) (process-nano-fields (nano-meta-fields x) acc-id (pair-alt-accessors prec-alt) (map (lambda (x) (spec-type (find-spec x ilang))) (pair-alt-field-names prec-alt))) (let ([elt (car (nano-meta-fields x))]) ; TODO: we'd like to more generally support cata for terminal and nonterminal-alt and ; this code will have to change to support that. (assert (nano-unquote? elt)) (let ([id (nano-unquote-x elt)]) (values #t '() (list #`(#,id #,acc-id)) '()))))))) (define find-eq-constraints (lambda (ibinding*) (let f ([ibinding* ibinding*] [id* '()]) (if (null? ibinding*) (values '() #t) (let* ([ibinding (car ibinding*)] [id (car ibinding)]) (if (bound-id-member? id id*) (syntax-violation who "eq constraints are not supported" id) #;(let-values ([(ibinding* ieqpred) (f (cdr ibinding*) id*)]) (let ([t (gentemp)]) (values #`((#,t #,(cadr ibinding)) #,@ibinding*) (gen-and #`(nano-equal? #,t #,id) ieqpred)))) (let-values ([(ibinding* ieqpred) (f (cdr ibinding*) (cons id id*))]) (values #`(#,ibinding #,@ibinding*) ieqpred)))))))) (define make-user-clause (lambda (pclause k) (let ([lhs-rec (pclause-lhs pclause)] [guard-code (pclause-guard pclause)] [rhs-id (pclause-id pclause)] [rhs-arg* (pclause-rhs-arg* pclause)]) (let-values ([(ipred tbinding* ibinding* obinding*) (process-nano-meta lhs-rec fml)]) (let-values ([(ibinding* ieqpred) (find-eq-constraints ibinding*)]) (let ([guard-code (gen-and guard-code ieqpred)] [body-code #`(let-values #,obinding* (#,rhs-id #,@rhs-arg*))]) (if (eq? ipred #t) #`(let* (#,@tbinding* #,@ibinding*) #,(if (eq? guard-code #t) body-code #`(if #,guard-code #,body-code #,(k)))) (if (eq? guard-code #t) #`(if #,ipred (let* (#,@tbinding* #,@ibinding*) #,body-code) #,(k)) #`(let ([next-th (lambda () #,(k))]) (if #,ipred (let* (#,@tbinding* #,@ibinding*) (if #,guard-code #,body-code (next-th))) (next-th))))))))))) (define generate-system-clauses (lambda (alt*) ; NB: don't use variants here to see how that impacts performance for testing purposes. #;(let f ([alt* alt*] [rcond-cl* '()]) (if (null? alt*) (reverse rcond-cl*) (let* ([alt (car alt*)] [alt (if (pair? alt) (car alt) alt)]) (f (cdr alt*) (cons #`[(#,(cond [(pair-alt? alt) (pair-alt-pred alt)] [(terminal-alt? alt) (tspec-pred (terminal-alt-tspec alt))] [else (ntspec-all-pred (nonterminal-alt-ntspec alt))]) #,fml) #,(make-clause alt '() #f)] rcond-cl*))))) (let f ([alt* alt*] [rcond-rec-cl* '()] [rcond-case-cl* '()]) (if (null? alt*) (values (reverse rcond-rec-cl*) (reverse rcond-case-cl*)) (let* ([alt (car alt*)] [alt (if (pair? alt) (car alt) alt)]) (with-syntax ([body (make-clause alt '() #f)]) (cond [(pair-alt? alt) (f (cdr alt*) rcond-rec-cl* (cons #`[(eqv? tag #,(pair-alt-tag alt)) body] rcond-case-cl*))] [(terminal-alt? alt) (let* ([tspec (terminal-alt-tspec alt)] [ttag (tspec-tag tspec)]) (if ttag (f (cdr alt*) rcond-rec-cl* (cons (if (tspec-parent? tspec) #`[(not (fxzero? (fxand tag #,ttag))) body] #`[(eqv? tag #,ttag) body]) rcond-case-cl*)) (f (cdr alt*) (cons #`[(#,(tspec-pred (terminal-alt-tspec alt)) #,fml) body] rcond-rec-cl*) rcond-case-cl*)))] [else (let ([ntspec (nonterminal-alt-ntspec alt)]) (let ([maybe-term-pred? (ntspec-all-term-pred ntspec)]) (f (cdr alt*) (if maybe-term-pred? (cons #`[(#,maybe-term-pred? #,fml) body] rcond-rec-cl*) rcond-rec-cl*) (with-syntax ([(all-tag ...) (ntspec-all-tag ntspec)]) (cons #`[(let ([t (fxand tag #,(language-tag-mask ilang))]) (or (fx=? t all-tag) ...)) body] rcond-case-cl*)))))]))))))) (define build-subtype-call (lambda (itype) (build-call (find-proc pass-desc pass-options (pdesc-name pdesc) itype maybe-otype #t match-xfml* (length-matches (pdesc-xval* pdesc))) fml*))) (define make-clause (lambda (alt pclause* else-id) (let f ([pclause* pclause*]) (if (null? pclause*) (cond [else-id #`(#,else-id)] ; TODO: Consider dropping the (not maybe-olang) and ; building the subtype call even if there is no otype ; for this. (Need to make sure build-subtype-call ; can handle this appropriately (possibly also need ; to decide if a user-supplied sub-type call with an ; output type is okay to call).) [(and (or (and maybe-olang maybe-otype) (not maybe-olang)) (nonterminal-alt? alt)) (build-subtype-call (syntax->datum (ntspec-name (nonterminal-alt-ntspec alt))))] [(and maybe-olang maybe-otype) (make-system-clause alt)] [else (syntax-violation (syntax->datum (pass-desc-name pass-desc)) (format "missing ~s clause cannot be generated with no output type" (syntax->datum (alt-syn alt))) (pdesc-name pdesc))]) (let ([pclause (car pclause*)] [pclause* (cdr pclause*)]) (pclause-used-set! pclause #t) (make-user-clause pclause (lambda () (f pclause*))))))))) (define maybe-add-lambdas (lambda (pclause* else-id else-body body) (with-syntax ([((id* rhs-body*) ...) (fold-left (lambda (ls pclause) (if (pclause-used? pclause) (cons (list (pclause-id pclause) (pclause-rhs-lambda pclause)) ls) ls)) (if else-id (list (list else-id else-body)) '()) pclause*)]) #`(let ([id* rhs-body*] ...) #,body)))) ; note: assumes grammar nonterminal clauses form a DAG ; TODO: reject grammars that have nonterminal clauses that don't form DAG ; TODO: should we build this structure up front? also is there a better DS for us ; to figure out how the various pclauses are interrelated while we process them (define-record-type nt-alt-info (fields alt (mutable up*) (mutable down*)) (nongenerative) (protocol (lambda (new) (lambda (alt) (new alt '() '()))))) (define build-ntspec-ht (lambda (ntspec) (let ([ht (make-eq-hashtable)]) (define set-cons (lambda (item ls) (if (memq item ls) ls (cons item ls)))) (define set-append (lambda (ls1 ls2) (cond [(null? ls1) ls2] [(null? ls2) ls1] [else (fold-left (lambda (ls item) (set-cons item ls)) ls2 ls1)]))) (define discover-nt-alt-info! (lambda (alt up*) (let ([nt-alt-info (or (eq-hashtable-ref ht alt #f) (let ([nt-alt-info (make-nt-alt-info alt)]) (eq-hashtable-set! ht alt nt-alt-info) nt-alt-info))]) (nt-alt-info-up*-set! nt-alt-info (set-append up* (nt-alt-info-up* nt-alt-info))) (let ([up* (cons alt up*)]) (let ([down* (fold-left (lambda (down* alt) (set-append (discover-nt-alt-info! alt up*) down*)) (nt-alt-info-down* nt-alt-info) (filter nonterminal-alt? (ntspec-alts (nonterminal-alt-ntspec alt))))]) (nt-alt-info-down*-set! nt-alt-info down*) (cons alt down*)))))) (for-each (lambda (alt) (discover-nt-alt-info! alt '())) (filter nonterminal-alt? (ntspec-alts ntspec))) ht))) (define build-alt-tree (lambda (ntspec) (let f ([alt* (ntspec-alts ntspec)] [ralt* '()]) (if (null? alt*) (reverse ralt*) (f (cdr alt*) (cons (let ([alt (car alt*)]) (if (nonterminal-alt? alt) (cons alt (f (ntspec-alts (nonterminal-alt-ntspec alt)) '())) alt)) ralt*)))))) (define alt-tree->s-expr (lambda (tree) (let f ([alt* tree]) (if (null? alt*) '() (let ([alt (car alt*)]) (if (pair? alt) (cons (f alt) (f (cdr alt*))) (cons (syntax->datum (alt-syn alt)) (f (cdr alt*))))))))) (define remove-alt (lambda (covered-alt alt*) (let f ([alt* alt*]) (if (null? alt*) '() (let ([alt (car alt*)] [alt* (cdr alt*)]) (if (pair? alt) (if (eq? (car alt) covered-alt) alt* (let ([calt* (f (cdr alt))]) (if (null? calt*) alt* (cons (cons (car alt) calt*) (f alt*))))) (if (eq? alt covered-alt) alt* (cons alt (f alt*))))))))) (define handle-pclause* (lambda (pclause* else-id alt-tree ht) (define partition-pclause* (lambda (alt pclause pclause*) (if (nonterminal-alt? alt) (let* ([nt-alt-info (eq-hashtable-ref ht alt #f)] [this-and-down* (cons alt (nt-alt-info-down* nt-alt-info))] [up* (nt-alt-info-up* nt-alt-info)]) (let-values ([(matching-pclause* other-pclause*) (partition (lambda (pclause) (memq (nano-meta-alt (pclause-lhs pclause)) this-and-down*)) pclause*)]) (let ([related-pclause* (filter (lambda (pclause) (memq (nano-meta-alt (pclause-lhs pclause)) up*)) other-pclause*)]) (values (cons pclause (append matching-pclause* related-pclause*)) other-pclause*)))) (let-values ([(matching-pclause* other-pclause*) (partition (lambda (pclause) (eq? (nano-meta-alt (pclause-lhs pclause)) alt)) pclause*)]) (let ([related-pclause* (filter (let ([nt-alt* (pclause-related-alt* pclause)]) (lambda (pclause) (memq (nano-meta-alt (pclause-lhs pclause)) nt-alt*))) pclause*)]) (values (cons pclause (append matching-pclause* related-pclause*)) other-pclause*)))))) #;(let f ([pclause* pclause*] [alt-tree alt-tree] [rcond-cl* '()]) (if (null? pclause*) (values (reverse rcond-cl*) alt-tree) (let* ([pclause (car pclause*)] [alt (nano-meta-alt (pclause-lhs pclause))]) (let-values ([(related-pclause* other-pclause*) (partition-pclause* alt pclause (cdr pclause*))]) (f other-pclause* (remove-alt alt alt-tree) (cons #`[(#,(cond [(pair-alt? alt) (pair-alt-pred alt)] [(terminal-alt? alt) (tspec-pred (terminal-alt-tspec alt))] [else (ntspec-all-pred (nonterminal-alt-ntspec alt))]) #,fml) #,(make-clause alt related-pclause* else-id)] rcond-cl*)))))) (let f ([pclause* pclause*] [alt-tree alt-tree] [rcond-rec-cl* '()] [rcond-case-cl* '()]) (if (null? pclause*) (values (reverse rcond-rec-cl*) (reverse rcond-case-cl*) alt-tree) (let* ([pclause (car pclause*)] [alt (nano-meta-alt (pclause-lhs pclause))]) (let-values ([(related-pclause* other-pclause*) (partition-pclause* alt pclause (cdr pclause*))]) (with-syntax ([body (make-clause alt related-pclause* else-id)]) (cond [(pair-alt? alt) (f other-pclause* (remove-alt alt alt-tree) rcond-rec-cl* (cons #`[(eqv? tag #,(pair-alt-tag alt)) body] rcond-case-cl*))] [(terminal-alt? alt) (let* ([tspec (terminal-alt-tspec alt)] [ttag (tspec-tag tspec)]) (if ttag (f other-pclause* (remove-alt alt alt-tree) rcond-rec-cl* (cons (if (tspec-parent? tspec) #`[(not (fxzero? (fxand tag #,ttag))) body] #`[(eqv? tag #,ttag) body]) rcond-case-cl*)) (f other-pclause* (remove-alt alt alt-tree) (cons #`[(#,(tspec-pred (terminal-alt-tspec alt)) #,fml) body] rcond-rec-cl*) rcond-case-cl*)))] [else (let ([ntspec (nonterminal-alt-ntspec alt)]) (let ([maybe-term-pred? (ntspec-all-term-pred ntspec)]) (f other-pclause* (remove-alt alt alt-tree) (if maybe-term-pred? (cons #`[(#,maybe-term-pred? #,fml) body] rcond-rec-cl*) rcond-rec-cl*) (with-syntax ([(all-tag ...) (ntspec-all-tag ntspec)]) (cons #`[(let ([t (fxand tag #,(language-tag-mask ilang))]) (or (fx=? t all-tag) ...)) body] rcond-case-cl*)))))])))))))) (define annotate-pclause*! (lambda (pclause* ntspec ht) (let f ([pclause* pclause*] [alt* (filter nonterminal-alt? (ntspec-alts ntspec))] [curr-alt #f]) (if (or (null? alt*) (null? pclause*)) pclause* (let ([alt (car alt*)]) (if (nonterminal-alt? alt) (f (f pclause* (ntspec-alts (nonterminal-alt-ntspec alt)) alt) (cdr alt*) curr-alt) (let-values ([(matching-pclause* other-pclause*) (partition (lambda (pclause) (eq? (nano-meta-alt (pclause-lhs pclause)) alt)) pclause*)]) (for-each (lambda (pclause) (pclause-related-alt*-set! pclause (cons curr-alt (nt-alt-info-up* (eq-hashtable-ref ht curr-alt #f))))) matching-pclause*) (f other-pclause* (cdr alt*) curr-alt)))))))) (let-values ([(pclause* else-id else-body) (parse-clauses cl*)]) (let ([ntspec (nonterm-id->ntspec who itype intspec*)]) (maybe-add-lambdas pclause* else-id else-body (let ([ht (build-ntspec-ht ntspec)]) (annotate-pclause*! pclause* ntspec ht) #;(let-values ([(user-clause* alt*) (handle-pclause* pclause* else-id (if else-id '() (build-alt-tree ntspec)) ht)]) (let ([system-clause* (if else-id '() (generate-system-clauses alt*))]) #`(cond #,@user-clause* #,@system-clause* [else #,(if else-id #`(#,else-id) #`(error '#,(pass-desc-name pass-desc) #,(format "unexpected ~s" (syntax->datum itype)) #,fml))]))) (let-values ([(user-rec-clause* user-case-clause* alt*) (handle-pclause* pclause* else-id (if else-id '() (build-alt-tree ntspec)) ht)]) (let-values ([(system-rec-clause* system-case-clause*) (if else-id (values (if (ntspec-all-term-pred ntspec) #`([(not (nanopass-record? #,fml)) (#,else-id)]) '()) '()) (generate-system-clauses alt*))]) #`(cond #,@user-rec-clause* #,@system-rec-clause* [else (let ([tag (nanopass-record-tag #,fml)]) (cond #,@user-case-clause* #,@system-case-clause* [else #,(if else-id #`(#,else-id) #`(error '#,(pass-desc-name pass-desc) #,(format "unexpected ~s" (syntax->datum itype)) #,fml))]))])))))))))) ; build-call, build-call-with-arguments, and find-proc need to work in ; concert, so they are located near eachother to increase the chance that ; we actually remember to alter both of them when the interface is ; effected by changing one. (module (build-call build-call-with-arguments) (define $build-call (lambda (fn arg* maybe?) (with-syntax ([fn fn] [(arg* ...) arg*]) (if maybe? (with-syntax ([(t t* ...) (generate-temporaries #'(arg* ...))]) #'((lambda (t t* ...) (and t (fn t t* ...))) arg* ...)) #'(fn arg* ...))))) (define build-args-from-fmls (lambda (id* dflt* fml*) (cons (car fml*) (let ([id* (cdr id*)] [xfml* (cdr fml*)]) (let ([n (fx- (length id*) (length dflt*))]) #`(#,@(list-head id* n) #,@(map (lambda (id dflt) (if (memp (lambda (x) (bound-identifier=? id x)) xfml*) id dflt)) (list-tail id* n) dflt*))))))) (define build-call (case-lambda [(callee-pdesc fml*) (build-call callee-pdesc fml* #f)] [(callee-pdesc fml* maybe?) ($build-call (pdesc-name callee-pdesc) (build-args-from-fmls (pdesc-fml* callee-pdesc) (pdesc-dflt* callee-pdesc) fml*) maybe?)])) (define build-full-args-from-args (lambda (callee-fml* callee-init* arg*) (let f ([required-cnt (fx- (length callee-fml*) (length callee-init*))] [callee-fml* callee-fml*] [callee-init* callee-init*] [arg* arg*]) (cond [(null? callee-fml*) '()] [(and (fxzero? required-cnt) (null? arg*)) (cons (car callee-init*) (f required-cnt (cdr callee-fml*) (cdr callee-init*) arg*))] [(fxzero? required-cnt) (cons (car arg*) (f required-cnt (cdr callee-fml*) (cdr callee-init*) (cdr arg*)))] [else (cons (car arg*) (f (fx- required-cnt 1) (cdr callee-fml*) callee-init* (cdr arg*)))])))) (define build-call-with-arguments (lambda (callee-pdesc arg* maybe?) ($build-call (pdesc-name callee-pdesc) (build-full-args-from-args (pdesc-fml* callee-pdesc) (pdesc-dflt* callee-pdesc) arg*) maybe?)))) ;; matcher helpers for use with find-proc. (define match-extra-formals (lambda (xfml*) (lambda (id* dflt*) (for-all (lambda (req) (memp (lambda (x) (bound-identifier=? req x)) xfml*)) (list-head id* (fx- (length id*) (length dflt*))))))) (define no-xval? null?) (define length-matches (lambda (expected-xval*) (lambda (xval*) (fx=? (length xval*) (length expected-xval*))))) (define find-proc ; will never be asked to find a proc without an itype, so itype is never #f (lambda (pass-desc pass-options src-stx itype maybe-otype try-to-generate? xfmls-ok? xvals-ok?) (define (try-to-generate) (if (pass-options-generate-transformers? pass-options) (begin (unless (and (xfmls-ok? '() '()) (xvals-ok? '())) (syntax-violation who (format "cannot find a transformer from ~s to ~s, \ and cannot generate one with extra formals or return values" itype maybe-otype) (pass-desc-name pass-desc) src-stx)) (unless (and (nonterm-id->ntspec? itype (language-ntspecs (pass-desc-maybe-ilang pass-desc))) (nonterm-id->ntspec? maybe-otype (language-ntspecs (pass-desc-maybe-olang pass-desc)))) (syntax-violation who (format "cannot find a transformer from ~s to ~s, \ and cannot generate one when either the input or output type is a terminal" itype maybe-otype) (pass-desc-name pass-desc) src-stx)) (let ([pdesc (make-pdesc (datum->syntax #'* (gensym (format "~s->~s" itype maybe-otype))) itype (list #'ir) '() maybe-otype '() '() #f #f)]) (pass-desc-pdesc*-set! pass-desc (cons pdesc (pass-desc-pdesc* pass-desc))) pdesc)) (syntax-violation who (format "cannot find a transformer from ~s to ~s that matches the expected signature" itype maybe-otype) (pass-desc-name pass-desc) src-stx))) (define find-subspecs (lambda (ospec sub-ospec*) (if (ntspec? ospec) (let f ([alt* (ntspec-alts ospec)] [sub-ospec* sub-ospec*]) (if (null? alt*) sub-ospec* (let ([alt (car alt*)]) (cond [(nonterminal-alt? alt) (f (cdr alt*) (cons (nonterminal-alt-ntspec alt) sub-ospec*))] [(terminal-alt? alt) (f (cdr alt*) (cons (terminal-alt-tspec alt) sub-ospec*))] [else (f (cdr alt*) sub-ospec*)])))) sub-ospec*))) (define find-candidate (lambda (maybe-otype) (let loop ([pdesc* (pass-desc-pdesc* pass-desc)] [candidate #f]) (if (null? pdesc*) candidate (loop (cdr pdesc*) (let ([pdesc (car pdesc*)]) (if (and (eq? (pdesc-maybe-itype pdesc) itype) ; HERE (eq? (pdesc-maybe-otype pdesc) maybe-otype) ; HERE (xfmls-ok? (cdr (pdesc-fml* pdesc)) (pdesc-dflt* pdesc)) (xvals-ok? (pdesc-xval* pdesc))) (if candidate (syntax-violation who (format "ambiguous target for implicit processor call from ~s to ~s" itype maybe-otype) (pass-desc-name pass-desc) src-stx) pdesc) candidate))))))) (when (identifier? maybe-otype) (syntax-violation 'find-proc "expected symbol otype, got identifier" maybe-otype)) ; doing a breadth-first search of maybe-otype and its subtypes ; could go up to parent itype(s) on itype as well #;(printf "entering with itype ~s to otype ~s in ~s\n" itype maybe-otype (map (lambda (x) (list (syntax->datum (pdesc-name x)) ': (pdesc-maybe-itype x) '-> (pdesc-maybe-otype x))) (pass-desc-pdesc* pass-desc))) (if maybe-otype (let ospec-loop ([ospec* (list (id->spec maybe-otype (pass-desc-maybe-olang pass-desc)))] [sub-ospec* '()]) (if (null? ospec*) (if (null? sub-ospec*) (and try-to-generate? (try-to-generate)) (ospec-loop sub-ospec* '())) (or (find-candidate (syntax->datum (spec-type (car ospec*)))) (ospec-loop (cdr ospec*) (find-subspecs (car ospec*) sub-ospec*))))) (or (find-candidate #f) (syntax-violation who (format "cannot find a processor that accepts input type ~s and no output type" itype) (pass-desc-name pass-desc) src-stx))))) (define parse-proc (lambda (pass-name ilang olang) (lambda (x) (let loop ([x x] [trace? #f] [echo? #f]) (syntax-case x () [(?echo ?not-colon . rest) (and (eq? (datum ?echo) 'echo) (not (eq? (datum ?not-colon) ':))) (loop #'(?not-colon . rest) trace? #t)] [(?trace ?not-colon . rest) (and (eq? (datum ?trace) 'trace) (not (eq? (datum ?not-colon) ':))) (loop #'(?not-colon . rest) #t echo?)] [(proc-name ?colon itype (arg ...) ?arrow otype (rv ...) body ...) (let ([squawk (lambda (msg what) (syntax-violation (syntax->datum pass-name) msg what))]) (unless (identifier? #'proc-name) (squawk "invalid processor name" #'proc-name)) (unless (eq? (datum ?colon) ':) (squawk "expected colon" #'?colon)) (let ([maybe-itype (syntax-case #'itype () [* (eq? (datum *) '*) #f] [id (identifier? #'id) (if ilang (if (or (nonterm-id->ntspec? #'id (language-ntspecs ilang)) (term-id->tspec? #'id (language-tspecs ilang))) (syntax->datum #'id) (squawk "unrecognized input non-terminal" #'id)) (squawk "specified input non-terminal without input language" #'id))] [_ (squawk "invalid input type specifier" #'itype)])]) (let ([arg* #'(arg ...)]) (when maybe-itype (when (null? arg*) (squawk "expected non-empty argument list" arg*)) (unless (identifier? (car arg*)) (squawk "invalid first argument" (car arg*)))) (let-values ([(fml* init*) (let f ([arg* arg*] [dflt? #f]) (if (null? arg*) (values '() '()) (syntax-case (car arg*) () [id (identifier? #'id) (if dflt? (squawk "unexpected non-default formal after start of default formals" #'id) (let-values ([(fml* init*) (f (cdr arg*) #f)]) (values (cons #'id fml*) init*)))] [[id expr] (identifier? #'id) (let-values ([(fml* init*) (f (cdr arg*) #t)]) (values (cons #'id fml*) (cons #'expr init*)))] [arg (squawk "invalid argument specifier" #'arg)])))]) (unless (eq? (datum ?arrow) '->) (squawk "expected arrow" #'?arrow)) (let ([maybe-otype (syntax-case #'otype () [* (eq? (datum *) '*) #f] [id (identifier? #'id) (if olang (if (or (nonterm-id->ntspec? #'id (language-ntspecs olang)) (term-id->tspec? #'id (language-tspecs olang))) (syntax->datum #'id) (squawk "unrecognized output non-terminal" #'id)) (squawk "specified output non-terminal without output language" #'id))] [_ (squawk "invalid output-type specifier" #'otype)])]) (make-pdesc #'proc-name maybe-itype fml* init* maybe-otype #'(rv ...) #'(body ...) trace? echo?))))))]))))) (define lookup-lang (lambda (pass-name r maybe-name) (if maybe-name (let* ([olang-pair (r maybe-name)] [lang (and olang-pair (car olang-pair))] [meta-parser (and olang-pair (cdr olang-pair))]) (unless (language? lang) (syntax-violation (syntax->datum pass-name) "unrecognized language" maybe-name)) (unless (procedure? meta-parser) (syntax-violation (syntax->datum pass-name) "missing meta parser for language" maybe-name)) (values lang meta-parser)) (values #f #f)))) (define build-checked-body (lambda (pass-desc pass-options maybe-fml extra-fml* xval* maybe-itype maybe-otype maybe-ometa-parser maybe-body) (define generate-output-check (lambda (type x ntspec*) ((lambda (ls) (if (null? (cdr ls)) (car ls) #`(or #,@ls))) (let f ([ntspec (nonterm-id->ntspec who type ntspec*)] [test* '()]) (cons #`(#,(ntspec-all-pred ntspec) #,x) (fold-left (lambda (test* alt) (if (nonterminal-alt? alt) (f (nonterminal-alt-ntspec alt) test*) test*)) test* (ntspec-alts ntspec))))))) (define generate-body (lambda (maybe-olang maybe-otype) (cond [(and maybe-body maybe-otype) (rhs-in-context-quasiquote (pass-desc-name pass-desc) maybe-otype maybe-olang maybe-ometa-parser maybe-body)] [maybe-body] [else (unless (null? xval*) (syntax-violation who "cannot auto-generate body for pass with extra return values" (pass-desc-name pass-desc))) (let ([ilang (pass-desc-maybe-ilang pass-desc)]) (unless ilang (syntax-violation who "cannot auto-generate body without input language" (pass-desc-name pass-desc))) (let ([itype (or maybe-itype (syntax->datum (language-entry-ntspec ilang)))]) (let ([pdesc (find-proc pass-desc pass-options (pass-desc-name pass-desc) itype maybe-otype #t (match-extra-formals extra-fml*) ; punting when there are return values for now --- matches rejecting auto generation when xval* is not null no-xval?)]) (let ([rv* (pdesc-xval* pdesc)]) (if (null? rv*) (build-call pdesc (cons maybe-fml extra-fml*)) #`(let-values ([(result #,@(generate-temporaries rv*)) #,(build-call pdesc (cons maybe-fml extra-fml*))]) result))))))]))) (let ([olang (pass-desc-maybe-olang pass-desc)]) (if olang (let ([otype (or maybe-otype (syntax->datum (language-entry-ntspec olang)))]) (with-syntax ([checked-body #`(unless #,(generate-output-check otype #'x (language-ntspecs olang)) (error '#,(pass-desc-name pass-desc) (format "expected ~s but got ~s" '#,(datum->syntax #'* otype) x)))]) (if (null? xval*) #`(let ([x #,(generate-body olang otype)]) checked-body x) (with-syntax ([(res* ...) (generate-temporaries xval*)]) #`(let-values ([(x res* ...) #,(generate-body olang otype)]) checked-body (values x res* ...)))))) (generate-body #f #f))))) (define do-define-pass (lambda (pass-name pass-options maybe-iname maybe-itype fml* maybe-oname maybe-otype xval* defn* p* maybe-body) (define echo-pass (lambda (x) (when (pass-options-echo? pass-options) (printf "pass ~s expanded into:\n" (syntax->datum pass-name)) (pretty-print (syntax->datum x)) (newline)) x)) (with-compile-time-environment (r) #;(unless (and maybe-iname (not (null? fml*))) (syntax-violation who "can't yet handle \"*\" iname" pass-name)) (let-values ([(maybe-ilang maybe-imeta-parser) (lookup-lang pass-name r maybe-iname)] [(maybe-olang maybe-ometa-parser) (lookup-lang pass-name r maybe-oname)]) (when (and maybe-itype (not (nonterm-id->ntspec? maybe-itype (language-ntspecs maybe-ilang)))) (syntax-violation who "unrecognized pass input non-terminal" pass-name maybe-itype)) (when (and maybe-otype (not (nonterm-id->ntspec? maybe-otype (language-ntspecs maybe-olang)))) (syntax-violation who "unrecognized pass output non-terminal" pass-name maybe-otype)) (let* ([pdesc* (map (parse-proc pass-name maybe-ilang maybe-olang) p*)] [pass-desc (make-pass-desc pass-name maybe-ilang maybe-olang pdesc*)] [body (build-checked-body pass-desc pass-options (and (pair? fml*) (car fml*)) (if (pair? fml*) (cdr fml*) '()) xval* (syntax->datum maybe-itype) (syntax->datum maybe-otype) maybe-ometa-parser maybe-body)]) (echo-pass (with-syntax ([who (datum->syntax pass-name 'who)]) #`(begin (define #,pass-name (lambda #,fml* (define who '#,pass-name) (define-nanopass-record) #,@defn* #,@(make-processors pass-desc pass-options maybe-imeta-parser maybe-ometa-parser) #,body)) (define-property #,pass-name define-pass (make-pass-info #,(and maybe-iname #`#'#,maybe-iname) #,(and maybe-oname #`#'#,maybe-oname))))))))))) (syntax-case x () [(_ pass-name ?colon iname (fml ...) ?arrow oname (xval ...) stuff ...) (let ([squawk (lambda (msg what) (syntax-violation who msg x what))]) (unless (identifier? #'pass-name) (squawk "invalid pass name" #'pass-name)) (unless (eq? (datum ?colon) ':) (squawk "expected colon" #'?colon)) (let-values ([(maybe-iname maybe-itype) (syntax-case #'iname () [* (eq? (datum *) '*) (values #f #f)] [iname (identifier? #'iname) (values #'iname #f)] [(iname itype) (and (identifier? #'iname) (identifier? #'itype)) (values #'iname #'itype)] [_ (squawk "invalid input language specifier" #'iname)])]) (let ([fml* #'(fml ...)]) (unless (for-all identifier? fml*) (squawk "expected list of identifiers" fml*)) (when (and maybe-iname (null? fml*)) (squawk "expected non-empty list of formals" fml*)) (unless (eq? (datum ?arrow) '->) (squawk "expected arrow" #'?arrow)) (let-values ([(maybe-oname maybe-otype) (syntax-case #'oname () [* (eq? (datum *) '*) (values #f #f)] [id (identifier? #'id) (values #'id #f)] [(oname otype) (and (identifier? #'oname) (identifier? #'otype)) (values #'oname #'otype)] [_ (squawk "invalid output-language specifier" #'oname)])]) (define (s1 stuff* defn* processor* pass-options) (if (null? stuff*) (s2 defn* processor* #f pass-options) (let ([stuff (car stuff*)]) (if (let processor? ([stuff stuff] [mcount 0]) (syntax-case stuff () [(pname ?colon itype (fml ...) ?arrow otype (xval ...) . more) (and (eq? (datum ?colon) ':) (eq? (datum ?arrow) '->) (identifier? #'itype) (identifier? #'otype) (for-all (lambda (fml) (or (identifier? fml) (syntax-case fml () [[fml exp-val] (identifier? #'fml)]))) #'(fml ...)) #t)] [(?modifier ?not-colon . more) (and (memq (datum ?modifier) '(trace echo)) (not (eq? (datum ?not-colon) ':)) (< mcount 2)) (processor? #'(?not-colon . more) (fx+ mcount 1))] [_ #f])) (s1 (cdr stuff*) defn* (cons stuff processor*) pass-options) (s2 defn* processor* #`(begin #,@stuff*) pass-options))))) (define (s2 defn* processor* maybe-body pass-options) (do-define-pass #'pass-name pass-options maybe-iname maybe-itype fml* maybe-oname maybe-otype #'(xval ...) defn* (reverse processor*) maybe-body)) (let s0 ([stuff* #'(stuff ...)] [defn* '()] [pass-options #f]) (if (null? stuff*) (s1 stuff* defn* '() (or pass-options (make-pass-options))) (syntax-case (car stuff*) () [(definitions defn ...) (eq? (datum definitions) 'definitions) (s0 (cdr stuff*) #'(defn ...) pass-options)] [(?pass-options . ?options) (eq? (datum ?pass-options) 'pass-options) (s0 (cdr stuff*) defn* (make-pass-options #'?options))] [_ (s1 stuff* defn* '() (or pass-options (make-pass-options)))])))))))] [(_ . rest) (syntax-violation who "invalid syntax" #'(define-pass . rest))])))) nanopass-framework-scheme-1.9.2/nanopass/prefix-matcher.ss000066400000000000000000000114761374306730300237300ustar00rootroot00000000000000(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"))) ) nanopass-framework-scheme-1.9.2/nanopass/records.ss000066400000000000000000001162351374306730300224520ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/nanopass/syntactic-property.sls000066400000000000000000000044561374306730300250510ustar00rootroot00000000000000;;; 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)))))]))) nanopass-framework-scheme-1.9.2/nanopass/syntaxconvert.ss000066400000000000000000000043041374306730300237310ustar00rootroot00000000000000;;; 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 '() '() '())))) nanopass-framework-scheme-1.9.2/nanopass/unparser.ss000066400000000000000000000177441374306730300226550ustar00rootroot00000000000000;;; 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))))])))) nanopass-framework-scheme-1.9.2/test-all.ss000077500000000000000000000021631374306730300207110ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/tests/000077500000000000000000000000001374306730300177525ustar00rootroot00000000000000nanopass-framework-scheme-1.9.2/tests/alltests.ss000066400000000000000000001213571374306730300221650ustar00rootroot00000000000000;;; 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)))))))))) nanopass-framework-scheme-1.9.2/tests/compiler-test.ss000066400000000000000000000032551374306730300231150ustar00rootroot00000000000000;;; 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 ))) nanopass-framework-scheme-1.9.2/tests/compiler.ss000066400000000000000000001636571374306730300221550ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell ;;; See the accompanying file Copyright for details (library (tests compiler) (export ;; languages LP L0 L1 L2 L3 L4 L5 L6 L7 L8 L9 L10 L11 L12 L13 L14 L15 L16 L17 L18 ;; parsers parse-LP parse-L0 parse-L1 parse-L2 parse-L3 parse-L4 parse-L5 parse-L6 parse-L7 parse-L8 parse-L9 parse-L10 parse-L11 parse-L13 parse-L14 parse-L15 parse-L16 parse-L17 parse-L18 ;; unparsers unparse-LP unparse-L0 unparse-L1 unparse-L2 unparse-L3 unparse-L4 unparse-L5 unparse-L6 unparse-L7 unparse-L8 unparse-L9 unparse-L10 unparse-L11 unparse-L12 unparse-L13 unparse-L14 unparse-L15 unparse-L16 unparse-L17 unparse-L18 ;; passes verify-scheme 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 ;; preprocessor rename-vars/verify-legal) (import (rnrs) (nanopass) (tests helpers) (tests synforms) (nanopass nano-syntax-dispatch)) (define-language LP (terminals (variable (x)) (datum (d)) (user-primitive (pr))) (Expr (e body) d x pr (set! x e) (if e1 e2) (if e1 e2 e3) (begin e1 ... e2) (lambda (x ...) body1 ... body2) (let ((x e) ...) body1 ... body2) (letrec ((x e) ...) body1 ... body2) (e0 e1 ...))) (define-parser parse-LP LP) (define-language L0 (extends LP) (Expr (e body) (- d x pr (e0 e1 ...)) (+ (datum d) (var x) (primapp pr e ...) (app e0 e1 ...)))) (define-parser parse-L0 L0) (define-who rename-vars/verify-legal (lambda (expr) (define keywords '(quote set! if begin let letrec lambda)) (define extend-env* (lambda (x* env) (let f ([x* x*] [rx* '()] [env env]) (if (null? x*) (values (reverse rx*) env) (let ([x (car x*)]) (let ([rx (gen-symbol x)]) (f (cdr x*) (cons rx rx*) (cons (cons x rx) env)))))))) (let f ([expr expr] [env '()]) (define f* (lambda (e* env) (map (lambda (e) (f e env)) e*))) (with-output-language (L0 Expr) (syncase expr [,const (guard (constant? const)) `(datum ,const)] [(quote ,lit) (guard (not (assq 'quote env))) `(datum ,lit)] [,var (guard (symbol? var)) (cond [(assq var env) => (lambda (a) `(var ,(cdr a)))] [(memq var keywords) (error who "invalid reference to keyword" var)] [else (error who "reference to unbound var" var)])] [(set! ,var ,rhs) (guard (not (assq 'set! env)) (symbol? var)) (cond [(assq var env) => (lambda (a) `(set! ,(cdr a) ,(f rhs env)))] [(memq var keywords) (error who "set! of keyword" expr)] [else (error who "set! of unbound var" expr)])] [(if ,e0 ,e1) (guard (not (assq 'if env))) `(if ,(f e0 env) ,(f e1 env))] [(if ,e0 ,e1 ,e2) (guard (not (assq 'if env))) `(if ,(f e0 env) ,(f e1 env) ,(f e2 env))] [(begin ,e* ... ,e) (guard (not (assq 'begin env))) `(begin ,(f* e* env) ... ,(f e env))] [(let ([,x* ,rhs*] ...) ,e* ... ,e) (guard (for-all symbol? x*) (set? x*)) (let-values ([(x* new-env) (extend-env* x* env)]) `(let ([,x* ,(f* rhs* env)] ...) ,(f* e* new-env) ... ,(f e new-env)))] [(letrec ([,x* ,rhs*] ...) ,e* ... ,e) (guard (for-all symbol? x*) (set? x*)) (let-values ([(x* env) (extend-env* x* env)]) `(letrec ([,x* ,(f* rhs* env)] ...) ,(f* e* env) ... ,(f e env)))] [(lambda (,x* ...) ,e* ... ,e) (guard (not (assq 'lambda env)) (for-all symbol? x*) (set? x*)) (let-values ([(x* env) (extend-env* x* env)]) `(lambda (,x* ...) ,(f* e* env) ... ,(f e env)))] [(,prim ,rand* ...) (guard (not (assq prim env)) (user-primitive? prim) (= (cadr (assq prim list-of-user-primitives)) (length rand*))) `(primapp ,prim ,(f* rand* env) ...)] [(,rator ,rand* ...) `(app ,(f rator env) ,(f* rand* env) ...)] [else (error who "invalid expression" expr)]))))) (define-pass verify-scheme : LP (ir) -> L0 () (definitions (define invalid-var? (lambda (x env) (cond [(memq x env) #f] [(keyword? x) "keyword"] [(user-primitive? x) "user-primitive"] [else "unbound variable"]))) (define valid-bindings? (lambda (ls) (for-all variable? ls))) (define duplicate-names? (lambda (var*) (let f ([ls var*] [dups '()]) (cond [(null? ls) (if (null? dups) #f dups)] [(and (memq (car ls) (cdr ls)) (not (memq (car ls) dups))) (f (cdr ls) (cons (car ls) dups))] [else (f (cdr ls) dups)])))) (define format-list (lambda (ls) (case (length ls) [(0) ""] [(1) (format "~s" (car ls))] [(2) (format "~s and ~s" (car ls) (cadr ls))] [else (let f ([a (car ls)] [ls (cdr ls)]) (if (null? ls) (format "and ~s" a) (format "~s, ~a" a (f (car ls) (cdr ls)))))])))) (Expr : Expr (ir [env '()]) -> Expr () [,d `(datum ,d)] [,x (let ([invalid? (invalid-var? x env)]) (if invalid? (error 'verify-scheme (format "reference to ~a ~s" invalid? x)) `(var ,x)))] [(set! ,x ,e) (let ([invalid? (invalid-var? x env)]) (if invalid? (error 'verify-scheme (format "assignment to ~a ~s" invalid? x)) (let ([e (Expr e env)]) `(set! ,x ,e))))] [(lambda (,x ...) ,body1 ... ,body2) (cond [(not (valid-bindings? x)) (error 'verify-scheme (format "invalid binding list ~a in lambda form" x))] [(duplicate-names? x) => (lambda (x) (error 'verify-scheme (format "duplicate bindings ~a in lambda form" (format-list x))))] [else (let ([env (append env x)]) (let ([body1 (map (lambda (x) (Expr x env)) body1)] [body2 (Expr body2 env)]) `(lambda (,x ...) ,body1 ... ,body2)))])] [(let ((,x ,e) ...) ,body1 ... ,body2) ;; track variables (cond [(not (valid-bindings? x)) (error 'verify-scheme (format "invalid binding list ~a in let form" x))] [(duplicate-names? x) => (lambda (x) (error 'verify-scheme (format "duplicate bindings ~a in let form" (format-list x))))] [else (let ([e (map (lambda (x) (Expr x env)) e)]) (let ([env (append env x)]) (let ([body1 (map (lambda (x) (Expr x env)) body1)] [body2 (Expr body2 env)]) `(let ((,x ,e) ...) ,body1 ... ,body2))))])] [(letrec ((,x ,e) ...) ,body1 ... ,body2) ;; track variables (cond [(not (valid-bindings? x)) (error 'verify-scheme (format "invalid binding list ~a in letrec form" x))] [(duplicate-names? x) => (lambda (x) (error 'verify-scheme (format "duplicate bindings ~a in letrec form" (format-list x))))] [else (let ([env (append env x)]) (let ([e (map (lambda (x) (Expr x env)) e)]) (let ([body1 (map (lambda (x) (Expr x env)) body1)] [body2 (Expr body2 env)]) `(letrec ((,x ,e) ...) ,body1 ... ,body2))))])] [(,e0 ,e1 ...) (let ([e1 (map (lambda (x) (Expr x env)) e1)]) (if (and (symbol? e0) (user-primitive? e0)) `(primapp ,e0 ,e1 ...) `(app ,(Expr e0 env) ,e1 ...)))])) (define-language L1 (extends L0) (Expr (e body) (- (lambda (x ...) body1 ... body2) (let ((x e) ...) body1 ... body2) (letrec ((x e) ...) body1 ... body2)) (+ (lambda (x ...) body) (let ((x e) ...) body) (letrec ((x e) ...) body)))) (define-parser parse-L1 L1) (define-pass remove-implicit-begin : L0 (ir) -> L1 () (process-expr-expr : Expr (ir) -> Expr () [(lambda (,x ...) ,[body1] ... ,[body2]) `(lambda (,x ...) (begin ,body1 ... ,body2))] [(let ((,x ,[e]) ...) ,[body1] ... ,[body2]) `(let ((,x ,e) ...) (begin ,body1 ... ,body2))] [(letrec ((,x ,[e]) ...) ,[body1] ... ,[body2]) `(letrec ((,x ,e) ...) (begin ,body1 ... ,body2))])) (define-language L2 (extends L1) (Expr (e body) (- (datum d)) (+ (quoted-const d)))) (define-parser parse-L2 L2) (define-pass remove-unquoted-constant : L1 (ir) -> L2 () (process-expr-expr : Expr (ir) -> Expr () [(datum ,d) `(quoted-const ,d)])) (define-language L3 (extends L2) (Expr (e body) (- (if e1 e2)))) (define-parser parse-L3 L3) (define-pass remove-one-armed-if : L2 (ir) -> L3 () (process-expr-expr : Expr (ir) -> Expr () [(if ,[e1] ,[e2]) `(if ,e1 ,e2 (primapp void))])) (define-language L4 (extends L3) (Expr (e body) (- (lambda (x ...) body) (let ((x e) ...) body) (letrec ((x e) ...) body)) (+ (lambda (x ...) sbody) (let ((x e) ...) sbody) (letrec ((x e) ...) sbody))) (SetBody (sbody) (+ (settable (x ...) body) => body))) (define-parser parse-L4 L4) (define-pass uncover-settable : L3 (ir) -> L4 () (definitions (define Expr* (lambda (e* asgn-var*) (if (null? e*) (values '() asgn-var*) (let-values ([(e asgn-var*) (Expr (car e*) asgn-var*)]) (let-values ([(e* asgn-var*) (Expr* (cdr e*) asgn-var*)]) (values (cons e e*) asgn-var*))))))) (Expr : Expr (ir asgn-var*) -> Expr (asgn-var*) [(set! ,x ,[e asgn-var*]) (values `(set! ,x ,e) (set-cons x asgn-var*))] [(lambda (,x* ...) ,[body asgn-var*]) (let ([set-x* (intersection asgn-var* x*)]) (values `(lambda (,x* ...) (settable (,set-x* ...) ,body)) (difference asgn-var* set-x*)))] [(let ([,x* ,e*]...) ,[body asgn-var*]) (let ([set-x* (intersection asgn-var* x*)]) (let-values ([(e* asgn-var*) (Expr* e* (difference asgn-var* set-x*))]) (values `(let ([,x* ,e*] ...) (settable (,set-x* ...) ,body)) asgn-var*)))] [(letrec ([,x* ,e*]...) ,[body asgn-var*]) (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)]) (let ([set-x* (intersection asgn-var* x*)]) (values `(letrec ((,x* ,e*) ...) (settable (,set-x* ...) ,body)) (difference asgn-var* set-x*))))] ; TODO: this code used to be supported by the automatic combiners, we've ; abandoned this in favor of threading, but we've not added threading yet [(app ,[e asgn-var*] ,e* ...) (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)]) (values `(app ,e ,e* ...) asgn-var*))] [(primapp ,pr ,e* ...) (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)]) (values `(primapp ,pr ,e* ...) asgn-var*))] [(if ,[e0 asgn-var*] ,e1 ,e2) (let-values ([(e1 asgn-var*) (Expr e1 asgn-var*)]) (let-values ([(e2 asgn-var*) (Expr e2 asgn-var*)]) (values `(if ,e0 ,e1 ,e2) asgn-var*)))] [(begin ,e* ... ,[e asgn-var*]) (let-values ([(e* asgn-var*) (Expr* e* asgn-var*)]) (values `(begin ,e* ... ,e) asgn-var*))]) (let-values ([(e asgn-var*) (Expr ir '())]) e)) (define-language L5 (extends L4) (Expr (e body) (+ lexpr (letrec ((x lexpr) ...) body)) (- (lambda (x ...) sbody) (letrec ((x e) ...) sbody))) (LambdaExpr (lexpr) (+ (lambda (x ...) sbody)))) (define-parser parse-L5 L5) (define-pass remove-impure-letrec : L4 (ir) -> L5 () (process-expr-expr : Expr (ir) -> Expr () [(lambda (,x ...) ,[sbody]) (in-context LambdaExpr `(lambda (,x ...) ,sbody))] [(letrec ((,x1 (lambda (,x2 ...) ,[sbody1])) ...) (settable () ,[body2])) (let ([lambdabody (map (lambda (x sbody) (in-context LambdaExpr `(lambda (,x ...) ,sbody))) x2 sbody1)]) `(letrec ((,x1 ,lambdabody) ...) ,body2))] [(letrec ((,x1 ,[e]) ...) (settable (,x2 ...) ,[body])) (let () (define void-maker (lambda (ids) (letrec ((helper (lambda (ls) (if (null? (cdr ls)) (list (in-context Expr `(primapp void))) (cons (in-context Expr `(primapp void)) (helper (cdr ls))))))) (helper (iota (length ids)))))) (let* ([new-ids (map gen-symbol x1)] [voids (void-maker x1)] [bodies (map (lambda (lhs id) `(set! ,lhs (var ,id))) x1 new-ids)] [rbodies (reverse bodies)] [new-body (cdr rbodies)] [rest-bodies (car rbodies)]) `(let ([,x1 ,voids] ...) (settable (,x1 ...) (begin (primapp void) (let ([,new-ids ,e] ...) ;;**** this need not be from the output nonterminal **** (settable () (begin ,new-body ... ,rest-bodies))) ,body)))))]) (process-setbody-setbody : SetBody (ir) -> SetBody () [(settable (,x ...) ,[body]) `(settable (,x ...) ,body)]) (process-expr-lexpr : Expr (ir) -> LambdaExpr () [(lambda (,x ...) ,[sbody]) `(lambda (,x ...) ,sbody)]) (process-setbody-expr : SetBody (ir) -> Expr () [(settable (,x ...) ,[body]) `,body])) (define-language L6 (extends L5) (Expr (e body) (- (let ((x e) ...) sbody) (set! x e)) (+ (let ((x e) ...) body))) (LambdaExpr (lexpr) (- (lambda (x ...) sbody)) (+ (lambda (x ...) body))) (SetBody (sbody) (- (settable (x ...) body)))) (define-parser parse-L6 L6) (define-pass remove-set! : L5 (ir) -> L6 () (Expr : Expr (ir [set* '()]) -> Expr () [(var ,x) (if (memq x set*) `(primapp car (var ,x)) `(var ,x))] [(set! ,x ,[e set* -> e]) `(primapp set-car! (var ,x) ,e)] [(let ((,x ,[e set* -> e]) ...) ,sbody) (let ([body (SetBody sbody x e set*)]) `,body)]) (LambdaExpr : LambdaExpr (ir set*) -> LambdaExpr () [(lambda (,x ...) ,[sbody x '() set* -> body]) `,body]) (SetBody : SetBody (ir x* e* set*) -> Expr () [(settable () ,[body set* -> body]) (if (null? e*) `(lambda (,x* ...) ,body) `(let ([,x* ,e*] ...) ,body))] [(settable (,x ...) ,[body (append x set*) -> body]) (let () (define settable-bindings (lambda (var* set*) (if (null? var*) (values '() '() '()) (let ([var (car var*)]) (let-values ([(var* lhs* rhs*) (settable-bindings (cdr var*) set*)]) (if (memq var set*) (let ([tmp (gen-symbol var)]) (values (cons tmp var*) (cons var lhs*) (cons (in-context Expr `(primapp cons (var ,tmp) (primapp void))) rhs*))) ;; **** (primapp void) is still a problem here **** (values (cons var var*) lhs* rhs*))))))) (let-values ([(x* lhs* rhs*) (settable-bindings x* x)]) ;; **** cannot have (let (,(apply append bindings*)) ---) or ;; some such, due to nano-syntax-dispatch ;; the problem is not that we don't allow ,(arbitrary ;; function call) in the metaparser (if (null? e*) `(lambda (,x* ...) (let ([,lhs* ,rhs*] ...) ,body)) `(let ([,x* ,e*] ...) (let ([,lhs* ,rhs*] ...) ,body)))))])) (define-pass sanitize-binding : L6 (ir) -> L6 () (Expr : Expr (ir [rhs? #f]) -> Expr (#f) [(var ,x) (values `(var ,x) #f)] [(if ,[e1 #f -> e1 ig1] ,[e2 #f -> e2 ig2] ,[e3 #f -> e3 ig3]) (values `(if ,e1 ,e2 ,e3) #f)] [(begin ,[e1 #f -> e1 ig1] ... ,[e2 #f -> e2 ig2]) (values `(begin ,e1 ... ,e2) #f)] [(primapp ,pr ,[e #f -> e ig] ...) (values `(primapp ,pr ,e ...) #f)] [(app ,[e0 #f -> e0 ig0] ,[e1 #f -> e1 ig1] ...) (values `(app ,e0 ,e1 ...) #f)] [(quoted-const ,d) (values `(quoted-const ,d) #f)] [(let ([,x ,[e #t -> e lambda?]] ...) ,[body #f -> body ig]) (let-values ([(let-x* let-e* letrec-x* letrec-e*) (let f ([x x] [e e] [lambda? lambda?]) (if (null? x) (values '() '() '() '()) (let-values ([(let-x let-e letrec-x letrec-e) (f (cdr x) (cdr e) (cdr lambda?))]) (let ([lhs (car x)] [rhs (car e)] [rhs-lambda? (car lambda?)]) (if rhs-lambda? (values let-x let-e (cons lhs letrec-x) (cons rhs letrec-e)) (values (cons lhs let-x) (cons rhs let-e) letrec-x letrec-e))))))]) (if (null? letrec-x*) (values `(let ([,let-x* ,let-e*] ...) ,body) #f) (if (null? let-x*) (values `(letrec ([,letrec-x* ,letrec-e*] ...) ,body) #f) (values `(letrec ([,letrec-x* ,letrec-e*] ...) (let ([,let-x* ,let-e*] ...) ,body)) #f))))] [(letrec ([,x1 (lambda (,x2 ...) ,[body1 #f -> body1 ig1])] ...) ,[body2 #f -> body2 ig2]) (values `(letrec ([,x1 (lambda (,x2 ...) ,body1)] ...) ,body2) #f)]) (LambdaExpr : LambdaExpr (ir [rhs? #f]) -> LambdaExpr (dummy) [(lambda (,x ...) ,[body #f -> body ig]) (values `(lambda (,x ...) ,body) #t)])) (define-language L7 (extends L6) (Expr (e body) (- lexpr))) (define-parser parse-L7 L7) (define-pass remove-anonymous-lambda : L6 (ir) -> L7 () (Expr : Expr (ir) -> Expr () [(lambda (,x ...) ,[body]) (let ([anon (gen-symbol 'anon)]) `(letrec ([,anon (lambda (,x ...) ,body)]) (var ,anon)))])) #; (define-pass remove-anonymous-lambda : L6 (ir) -> L7 () (Expr : Expr (ir) -> Expr () [(lambda (,x ...) ,[body]) (let ([anon (gen-symbol 'anon)]) `(letrec ([,anon (lambda (,x ...) ,body)]) (var ,anon)))] [(var ,x) `(var ,x)] [(quoted-const ,d) `(quoted-const ,d)] [(if ,[e1] ,[e2] ,[e3]) `(if ,e1 ,e2 ,e3)] [(begin ,[e1] ... ,[e2]) `(begin ,e1 ... ,e2)] [(let ([,x ,[e]] ...) ,[body]) `(let ([,x ,e] ...) ,body)] [(letrec ([,x ,[lexpr]] ...) ,[body]) `(letrec ([,x ,lexpr] ...) ,body)] [(primapp ,pr ,[e] ...) `(primapp ,pr ,e ...)] [(app ,[e0] ,[e1] ...) `(app ,e0 ,e1 ...)]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x ...) ,[body]) `(lambda (,x ...) ,body)])) (define-language L8 (extends L7) (entry Expr) (LambdaExpr (lexpr) (- (lambda (x ...) body))) (FreeExp (free-body) (+ (free (x ...) body) => body)) (LambdaExpr (lexpr) (+ (lambda (x ...) free-body)))) (define-parser parse-L8 L8) (define-pass uncover-free : L7 (ir) -> L8 () (definitions (define LambdaExpr* (lambda (lexpr* free*) (if (null? lexpr*) (values '() free*) (let-values ([(lexpr free*) (LambdaExpr (car lexpr*) free*)]) (let-values ([(lexpr* free*) (LambdaExpr* (cdr lexpr*) free*)]) (values (cons lexpr lexpr*) free*)))))) (define Expr* (lambda (e* free*) (if (null? e*) (values '() free*) (let-values ([(e free*) (Expr (car e*) free*)]) (let-values ([(e* free*) (Expr* (cdr e*) free*)]) (values (cons e e*) free*))))))) (Expr : Expr (ir free*) -> Expr (free*) [(letrec ([,x* ,lexpr*] ...) ,[body free*]) (let-values ([(e* free*) (LambdaExpr* lexpr* free*)]) (values `(letrec ([,x* ,e*] ...) ,body) (difference free* x*)))] [(let ([,x* ,e*] ...) ,[body free*]) (let-values ([(e* free*) (Expr* e* (difference free* x*))]) (values `(let ([,x* ,e*] ...) ,body) free*))] [(var ,x) (values `(var ,x) (cons x free*))] ; TODO: get threaded variables working so we don't need to do this by hand [(app ,[e free*] ,e* ...) (let-values ([(e* free*) (Expr* e* free*)]) (values `(app ,e ,e* ...) free*))] [(primapp ,pr ,e* ...) (let-values ([(e* free*) (Expr* e* free*)]) (values `(primapp ,pr ,e* ...) free*))] [(if ,[e1 free*] ,e2 ,e3) (let-values ([(e2 free*) (Expr e2 free*)]) (let-values ([(e3 free*) (Expr e3 free*)]) (values `(if ,e1 ,e2 ,e3) free*)))] [(begin ,e* ... ,[e free*]) (let-values ([(e* free*) (Expr* e* free*)]) (values `(begin ,e* ... ,e) free*))]) (LambdaExpr : LambdaExpr (ir free*) -> LambdaExpr (free*) [(lambda (,x* ...) ,[body free*]) (let ([free* (difference free* x*)]) (values `(lambda (,x* ...) (free (,free* ...) ,body)) free*))]) (let-values ([(e free*) (Expr ir '())]) e)) (define-language L9 (terminals (variable (x)) (datum (d)) (user-primitive (pr))) (Expr (e body) (var x) (quoted-const d) (if e1 e2 e3) (begin e1 ... e2) (let ((x e) ...) body) (letrec ((x lexpr) ...) c-letrec) (primapp pr e ...) (app e0 e1 ...) (anonymous-call e0 e1 ...)) (LambdaExpr (lexpr) (lambda (x ...) bf-body)) (BindFree (bf-body) (bind-free (x1 x2 ...) body)) (Closure (c-exp) (closure x1 x2 ...)) (ClosureLetrec (c-letrec) (closure-letrec ((x c-exp) ...) body))) (define-parser parse-L9 L9) (define-pass convert-closure : L8 (ir) -> L9 () (Expr : Expr (ir [direct '()]) -> Expr () [(app (var ,x) ,[e1 direct -> e1] ...) (guard (assq x direct)) `(app (var ,(cdr (assq x direct))) (var ,x) ,e1 ...)] [(app ,[e0 direct -> e0] ,[e1 direct -> e1] ...) `(anonymous-call ,e0 ,e1 ...)] [(letrec ([,x1 (lambda (,x2 ...) (free (,x3 ...) ,body1))] ...) ,body2) (let ([code-name* (map gen-label x1)] [cp* (map (lambda (x) (gen-symbol 'cp)) x1)]) (let* ([direct (append (map cons x1 code-name*) direct)] [body1 (map (lambda (exp)(Expr exp direct)) body1)] [bind-free* (map (lambda (cp formal* free* lbody) (in-context LambdaExpr `(lambda (,cp ,formal* ...) (bind-free (,cp ,free* ...) ,lbody)))) cp* x2 x3 body1)] [closure* (map (lambda (code-name free*) (in-context Closure `(closure ,code-name ,free* ...))) code-name* x3)]) `(letrec ([,code-name* ,bind-free*] ...) (closure-letrec ([,x1 ,closure*] ...) ,(Expr body2 direct)))))])) (define-language L10 (extends L9) (entry LetrecExpr) (LetrecExpr (lrexpr) (+ (letrec ((x lexpr) ...) e))) (Expr (e body) (- (letrec ((x lexpr) ...) c-letrec)) (+ (closure-letrec ((x c-exp) ...) body))) (ClosureLetrec (c-letrec) (- (closure-letrec ((x c-exp) ...) body)))) (define-parser parse-L10 L10) (define-pass lift-letrec : L9 (ir) -> L10 () (definitions (define Expr* (lambda (e* binding*) (if (null? e*) (values '() binding*) (let-values ([(e binding*) (Expr (car e*) binding*)]) (let-values ([(e* binding*) (Expr* (cdr e*) binding*)]) (values (cons e e*) binding*)))))) (define LambdaExpr* (lambda (lexpr* binding*) (if (null? lexpr*) (values '() binding*) (let-values ([(lexpr binding*) (LambdaExpr (car lexpr*) binding*)]) (let-values ([(lexpr* binding*) (LambdaExpr* (cdr lexpr*) binding*)]) (values (cons lexpr lexpr*) binding*))))))) (Expr : Expr (ir binding*) -> Expr (binding*) ; TODO: we'd like to do this using variable threading! [(var ,x) (values `(var ,x) binding*)] [(quoted-const ,d) (values `(quoted-const ,d) binding*)] [(if ,e1 ,e2 ,[e3 binding*]) (let-values ([(e1 binding*) (Expr e1 binding*)]) (let-values ([(e2 binding*) (Expr e2 binding*)]) (values `(if ,e1 ,e2 ,e3) binding*)))] [(begin ,e1 ... ,[e2 binding*]) (let-values ([(e1 binding*) (Expr* e1 binding*)]) (values `(begin ,e1 ... ,e2) binding*))] [(let ([,x* ,e*] ...) ,[body binding*]) (let-values ([(e* binding*) (Expr* e* binding*)]) (values `(let ([,x* ,e*] ...) ,body) binding*))] [(primapp ,pr ,e* ...) (let-values ([(e* binding*) (Expr* e* binding*)]) (values `(primapp ,pr ,e* ...) binding*))] [(app ,[e binding*] ,e* ...) (let-values ([(e* binding*) (Expr* e* binding*)]) (values `(app ,e ,e* ...) binding*))] [(anonymous-call ,[e binding*] ,e* ...) (let-values ([(e* binding*) (Expr* e* binding*)]) (values `(anonymous-call ,e ,e* ...) binding*))] [(letrec ((,x* ,lexpr*) ...) ,[e binding*]) (let-values ([(lexpr* binding*) (LambdaExpr* lexpr* binding*)]) (values e (append (map cons x* lexpr*) binding*)))]) (LambdaExpr : LambdaExpr (ir binding*) -> LambdaExpr (binding*) [(lambda (,x* ...) ,[bf-body binding*]) (values `(lambda (,x* ...) ,bf-body) binding*)]) (BindFree : BindFree (ir binding*) -> BindFree (binding*) [(bind-free (,x ,x* ...) ,[body binding*]) (values `(bind-free (,x ,x* ...) ,body) binding*)]) (ClosureLetrec : ClosureLetrec (ir binding*) -> Expr (binding*) [(closure-letrec ([,x* ,[c-exp*]] ...) ,[body binding*]) (values `(closure-letrec ([,x* ,c-exp*] ...) ,body) binding*)]) (let-values ([(e binding*) (Expr ir '())]) (let ([x* (map car binding*)] [e* (map cdr binding*)]) `(letrec ([,x* ,e*] ...) ,e)))) (define-language L11 (extends L10) (entry LetrecExpr) (terminals (+ (system-primitive (spr)))) (Expr (e body) (- (closure-letrec ((x c-exp) ...) body)) (+ (sys-primapp spr e ...))) (BindFree (bf-body) (- (bind-free (x1 x2 ...) body))) (Closure (c-exp) (- (closure x1 x2 ...))) (LambdaExpr (lexpr) (- (lambda (x ...) bf-body)) (+ (lambda (x ...) body)))) (define-parser parse-L11 L11) (define-pass explicit-closure : L10 (ir) -> L11 () (LetrecExpr : LetrecExpr (ir) -> LetrecExpr () [(letrec ((,x ,[lexpr]) ...) ,e) (let ([e (Expr e '() '())]) `(letrec ((,x ,lexpr) ...) ,e))]) (Expr : Expr (ir [cp '()] [env '()]) -> Expr () [(var ,x) (let ([i (list-index x env)]) (if (>= i 0) `(sys-primapp closure-ref (var ,cp) (quoted-const ,i)) `(var ,x)))] [(closure-letrec ((,x ,[c-exp -> e free**]) ...) ,[body cp env -> body]) (let* ([e* (append (apply append (map (lambda (lhs free*) (map (lambda (i free) `(sys-primapp closure-set! (var ,lhs) (quoted-const ,i) ,(let ([ind (list-index free env)]) (if (>= ind 0) `(sys-primapp closure-ref (var ,cp) (quoted-const ,ind)) `(var ,free))))) (iota (length free*)) free*)) x free**)) (list body))]) (let* ([re* (reverse e*)] [e1 (cdr re*)] [e2 (car re*)]) `(let ([,x ,e] ...) (begin ,e1 ... ,e2))))]) (BindFree : BindFree (ir) -> Expr () [(bind-free (,x1 ,x2 ...) ,[body x1 x2 -> body]) `,body]) (Closure : Closure (ir) -> Expr (dummy) [(closure ,x1 ,x2 ...) (values `(sys-primapp make-closure (var ,x1) (quoted-const ,(length x2))) x2)]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x ...) ,[bf-body -> body]) `(lambda (,x ...) ,body)])) (define-language L12 (terminals (variable (x)) (datum (d)) (value-primitive (vp)) (predicate-primitive (pp)) (effect-primitive (ep)) (system-primitive (spr))) (LetrecExpr (lrexpr) (letrec ((x lexpr) ...) v)) (LambdaExpr (lexpr) (lambda (x ...) v)) (Value (v) (var x) (quoted-const d) (if p1 v2 v3) (begin f0 ... v1) (let ((x v1) ...) v2) (primapp vp v ...) (sys-primapp spr v ...) (anonymous-call v0 v1 ...) (app v0 v1 ...)) (Predicate (p) (true) (false) (if p1 p2 p3) (begin f0 ... p1) (let ((x v) ...) p) (primapp pp v ...) (sys-primapp spr v ...) (anonymous-call v0 v1 ...) (app v0 v1 ...)) (Effect (f) (nop) (if p1 f2 f3) (begin f0 ... f1) (let ((x v) ...) f) (primapp ep v ...) (sys-primapp spr v ...) (anonymous-call v0 v1 ...) (app v0 v1 ...))) (define-parser parse-L12 L12) (define-pass normalize-context : L11 (ir) -> L12 () (LetrecExpr : LetrecExpr (ir) -> LetrecExpr () [(letrec ((,x ,[lexpr]) ...) ,[v]) `(letrec ((,x ,lexpr) ...) ,v)]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x ...) ,[v]) `(lambda (,x ...) ,v)]) (Value : Expr (ir) -> Value () [(var ,x) `(var ,x)] [(quoted-const ,d) `(quoted-const ,d)] [(if ,[p0] ,[v1] ,[v2]) `(if ,p0 ,v1 ,v2)] [(begin ,[f0] ... ,[v1]) `(begin ,f0 ... ,v1)] [(let ((,x ,[v1]) ...) ,[v2]) `(let ((,x ,v1) ...) ,v2)] [(primapp ,pr ,[p]) (guard (equal? pr 'not)) `(if ,p (quoted-const #f) (quoted-const #t))] [(primapp ,pr ,[v0] ...) (guard (predicate-primitive? pr)) `(if (primapp ,pr ,v0 ...) (quoted-const #t) (quoted-const #f))] [(primapp ,pr ,[v0] ...) (guard (value-primitive? pr)) `(primapp ,pr ,v0 ...)] [(primapp ,pr ,[v0] ...) (guard (effect-primitive? pr)) `(begin (primapp ,pr ,v0 ...) (primapp void))] [(sys-primapp ,spr ,[v0] ...) (guard (predicate-primitive? spr)) `(if (sys-primapp ,spr ,v0 ...) (quoted-const #t) (quoted-const #f))] [(sys-primapp ,spr ,[v0] ...) (guard (value-primitive? spr)) `(sys-primapp ,spr ,v0 ...)] [(sys-primapp ,spr ,[v0] ...) (guard (effect-primitive? spr)) `(begin (primapp ,spr ,v0 ...) (primapp void))] [(anonymous-call ,[v0] ,[v1] ...) `(anonymous-call ,v0 ,v1 ...)] [(app ,[v0] ,[v1] ...) `(app ,v0 ,v1 ...)]) (Predicate : Expr (ir) -> Predicate () [(var ,x) `(if (primapp eq? (var ,x) (quoted-const #f)) (false) (true))] [(quoted-const ,d) (if d `(true) `(false))] [(if ,[p0] ,[p1] ,[p2]) `(if ,p0 ,p1 ,p2)] [(begin ,[f0] ... ,[p1]) `(begin ,f0 ... ,p1)] [(let ((,x ,[v]) ...) ,[p]) `(let ((,x ,v) ...) ,p)] [(primapp ,pr ,[p]) (guard (equal? pr 'not)) `(if ,p (false) (true))] [(primapp ,pr ,[v0] ...) (guard (predicate-primitive? pr)) `(primapp ,pr ,v0 ...)] [(primapp ,pr ,[v0] ...) (guard (value-primitive? pr)) `(if (primapp eq? (primapp ,pr ,v0 ...) (quoted-const #f)) (false) (true))] [(primapp ,pr ,[v0] ...) (guard (effect-primitive? pr)) `(begin (primapp ,pr ,v0 ...)(true))] [(sys-primapp ,spr ,[v0] ...) (guard (predicate-primitive? spr)) `(sys-primapp ,spr ,v0 ...)] [(sys-primapp ,spr ,[v0] ...) (guard (value-primitive? spr)) `(if (primapp eq? (sys-primapp ,spr ,v0 ...) (quoted-const #f)) (false) (true))] [(sys-primapp ,spr ,[v0] ...) (guard (effect-primitive? spr)) `(begin (sys-primapp ,spr ,v0 ...)(true))] [(anonymous-call ,[v0] ,[v1] ...) `(if (primapp eq? (anonymous-call ,v0 ,v1 ...) (quoted-const #f)) (false) (true))] [(app ,[v0] ,[v1] ...) `(if (primapp eq? (app ,v0 ,v1 ...) (quoted-const #f)) (false) (true))]) (Effect : Expr (ir) -> Effect () [(var ,x) `(nop)] [(quoted-const ,d) `(nop)] [(if ,[p0] ,[f1] ,[f2]) `(if ,p0 ,f1 ,f2)] [(begin ,[f0] ... ,[f1]) `(begin ,f0 ... ,f1)] [(let ((,x ,[v]) ...) ,[f]) `(let ((,x ,v) ...) ,f)] [(primapp ,pr ,[f]) (guard (equal? pr 'not)) f] [(primapp ,pr ,[f0] ...) (guard (or (predicate-primitive? pr) (value-primitive? pr))) (if (null? f0) `(nop) `(begin ,f0 ... (nop)))] [(primapp ,pr ,[v0] ...) (guard (effect-primitive? pr)) `(primapp ,pr ,v0 ...)] [(sys-primapp ,spr ,[f0] ...) (guard (or (predicate-primitive? spr) (value-primitive? spr))) (if (null? f0) `(nop) `(begin ,f0 ... (nop)))] [(sys-primapp ,spr ,[v0] ...) (guard (effect-primitive? spr)) `(sys-primapp ,spr ,v0 ...)] [(anonymous-call ,[v0] ,[v1] ...) `(anonymous-call ,v0 ,v1 ...)] [(app ,[v0] ,[v1] ...) `(app ,v0 ,v1 ...)])) (define-language L13 (terminals (variable (x)) (datum (d)) (value-primitive (vp)) (predicate-primitive (pp)) (effect-primitive (ep)) (system-primitive (spr))) (LetrecExpr (lrexpr) (letrec ((x lexpr) ...) v)) (LambdaExpr (lexpr) (lambda (x ...) v)) (Triv (t) (var x) (quoted-const d)) (Value (v) t (if p1 v2 v3) (begin f0 ... v1) (let ((x v1) ...) v2) (primapp vp t ...) (sys-primapp spr t ...) (anonymous-call t0 t1 ...) (app t0 t1 ...)) (Predicate (p) (true) (false) (if p1 p2 p3) (begin f0 ... p1) (let ((x v) ...) p) (primapp pp t ...) (sys-primapp spr t ...) (anonymous-call t0 t1 ...) (app t0 t1 ...)) (Effect (f) (nop) (if p1 f2 f3) (begin f0 ... f1) (let ((x v) ...) f) (primapp ep t ...) (sys-primapp spr t ...) (anonymous-call t0 t1 ...) (app t0 t1 ...))) (define-parser parse-L13 L13) (define-pass remove-complex-opera* : L12 (ir) -> L13 () (definitions (define remove-nulls (lambda (ls) (if (null? ls) '() (if (null? (car ls)) (remove-nulls (cdr ls)) (cons (car ls) (remove-nulls (cdr ls)))))))) (LetrecExpr : LetrecExpr (ir) -> LetrecExpr () [(letrec ((,x ,[lexpr]) ...) ,[v]) `(letrec ((,x ,lexpr) ...) ,v)]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x ...) ,[v]) `(lambda (,x ...) ,v)]) (Opera : Value (ir) -> Triv (dummy) [(var ,x) (values `(var ,x) '())] [(quoted-const ,d) (values `(quoted-const ,d) '())] ; [,[v] (let ([tmp (gen-symbol 'tmp)]) ; (values `(var ,tmp) ; (list tmp (in-context Value `,v))))]) [(if ,[p1] ,[v2] ,[v3]) (let ([tmp (gen-symbol 'tmp)]) (values `(var ,tmp) (list tmp (in-context Value `(if ,p1 ,v2 ,v3)))))] [(begin ,[f0] ... ,[v1]) (let ([tmp (gen-symbol 'tmp)]) (values `(var ,tmp) (list tmp (in-context Value `(begin ,f0 ... ,v1)))))] [(let ((,x ,[v1]) ...) ,[v2]) (let ([tmp (gen-symbol 'tmp)]) (values `(var ,tmp) (list tmp (in-context Value `(let ((,x ,v1) ...) ,v2)))))] [(primapp ,vp ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (let ([tmp (gen-symbol 'tmp)]) (if (null? binding*) (values `(var ,tmp) (list tmp (in-context Value `(primapp ,vp ,t* ...)))) (let ([x (map car binding*)] [v (map cadr binding*)]) (values `(var ,tmp) (list tmp (in-context Value `(let ((,x ,v) ...) (primapp ,vp ,t* ...)))))))))] [(sys-primapp ,spr ,[t* binding*]...) (let ([binding* (remove-nulls binding*)]) (let ([tmp (gen-symbol 'tmp)]) (if (null? binding*) (values `(var ,tmp) (list tmp (in-context Value `(sys-primapp ,spr ,t* ...)))) (let ([x (map car binding*)][v (map cadr binding*)]) (values `(var ,tmp) (list tmp (in-context Value `(let ((,x ,v) ...) (sys-primapp ,spr ,t* ...)))))))))] [(anonymous-call ,[v0 binding] ,[v1 binding*] ...) (let ([binding* (remove-nulls (cons binding binding*))] [tmp (gen-symbol 'tmp)]) (if (null? binding*) (values `(var ,tmp) (list tmp (in-context Value `(anonymous-call ,v0 ,v1 ...)))) (let ([x (map car binding*)] [v (map cadr binding*)]) (values `(var ,tmp) (list tmp (in-context Value `(let ((,x ,v) ...) (anonymous-call ,v0 ,v1 ...))))))))] [(app ,[v0] ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (let ([tmp (gen-symbol 'tmp)]) (if (null? binding*) (values `(var ,tmp) (list tmp (in-context Value `(app ,v0 ,t* ...)))) (let ([x (map car binding*)] [v (map cadr binding*)]) (values `(var ,tmp) (list tmp (in-context Value `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))))))]) (Value : Value (ir) -> Value () [(var ,x) (in-context Triv `(var ,x))] [(quoted-const ,d) (in-context Triv `(quoted-const ,d))] [(if ,[p1] ,[v2] ,[v3]) `(if ,p1 ,v2 ,v3)] [(begin ,[f0] ... ,[v1]) `(begin ,f0 ... ,v1)] [(let ((,x ,[v1]) ...) ,[v2]) `(let ((,x ,v1) ...) ,v2)] [(primapp ,vp ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(primapp ,vp ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (primapp ,vp ,t* ...)))))] [(sys-primapp ,spr ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(sys-primapp ,spr ,t* ...) (let ([x (map car binding*)][v (map cadr binding*)]) `(let ((,x ,v) ...) (sys-primapp ,spr ,t* ...)))))] [(anonymous-call ,[t0 binding] ,[t1 binding*] ...) (let ([binding* (remove-nulls (cons binding binding*))]) (if (null? binding*) `(anonymous-call ,t0 ,t1 ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (anonymous-call ,t0 ,t1 ...)))))] [(app ,[v0] ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(app ,v0 ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))]) (Predicate : Predicate (ir) -> Predicate () [(let ((,x ,[v]) ...) ,[p]) `(let ((,x ,v) ...) ,p)] [(primapp ,pp ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(primapp ,pp ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (primapp ,pp ,t* ...)))))] [(sys-primapp ,spr ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(sys-primapp ,spr ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (sys-primapp ,spr ,t* ...)))))] [(anonymous-call ,[t0 binding] ,[t1 binding*]...) (let ([binding* (remove-nulls (cons binding binding*))]) (if (null? binding*) `(anonymous-call ,t0 ,t1 ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (anonymous-call ,t0 ,t1 ...)))))] [(app ,[v0] ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(app ,v0 ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))]) (Effect : Effect (ir) -> Effect () [(let ((,x ,[v]) ...) ,[f]) `(let ((,x ,v) ...) ,f)] [(primapp ,ep ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(primapp ,ep ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (primapp ,ep ,t* ...)))))] [(sys-primapp ,spr ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(sys-primapp ,spr ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (sys-primapp ,spr ,t* ...)))))] [(anonymous-call ,[t0 binding] ,[t1 binding*] ...) (let ([binding* (remove-nulls (cons binding binding*))]) (if (null? binding*) `(anonymous-call ,t0 ,t1 ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (anonymous-call ,t0 ,t1 ...)))))] [(app ,[v0] ,[t* binding*] ...) (let ([binding* (remove-nulls binding*)]) (if (null? binding*) `(app ,v0 ,t* ...) (let ([x (map car binding*)] [v (map cadr binding*)]) `(let ((,x ,v) ...) (app ,v0 ,t* ...)))))])) (define-language L14 (extends L13) (entry LetrecExpr) (Value (v) (- (anonymous-call t0 t1 ...))) (Predicate (p) (- (anonymous-call t0 t1 ...))) (Effect (f) (- (anonymous-call t0 t1 ...)))) (define-pass remove-anonymous-call : L13 (ir) -> L14 () (Value : Value (ir) -> Value () [(anonymous-call ,[t0] ,[t1] ...) (let ([tmp (gen-symbol 'tmp)]) `(let ([,tmp (sys-primapp procedure-code ,t0)]) (app (var ,tmp) ,t0 ,t1 ...)))]) (Predicate : Predicate (ir) -> Predicate () [(anonymous-call ,[t0] ,[t1] ...) (let ([tmp (gen-symbol 'tmp)]) `(let ([,tmp (sys-primapp procedure-code ,t0)]) (app (var ,tmp) ,t0 ,t1 ...)))]) (Effect : Effect (ir) -> Effect () [(anonymous-call ,[t0] ,[t1] ...) (let ([tmp (gen-symbol 'tmp)]) `(let ([,tmp (sys-primapp procedure-code ,t0)]) (app (var ,tmp) ,t0 ,t1 ...)))])) (define-parser parse-L14 L14) (define-language L15 (terminals (variable (x)) (datum (d)) (value-primitive (vp)) (predicate-primitive (pp)) (effect-primitive (ep)) (system-primitive (spr))) (LetrecExpr (lrexpr) (letrec ((x1 lexpr) ...) rnexpr)) (RunExpr (rnexpr) (run (x) tl)) (LambdaExpr (lexpr) (lambda (x ...) tl)) (Triv (t) (var x) (quoted-const d)) (Application (a) (app t0 t1 ...)) (Tail (tl) (return t1 t2) (if p1 tl2 tl3) (begin f0 ... tl1) (let ((x ntl1) ...) tl2) (app t0 t1 ...)) (Nontail (ntl) t (if p1 ntl2 ntl3) (begin f0 ... ntl1) (let ((x ntl1) ...) ntl2) (primapp vp t ...) (sys-primapp spr t ...) (return-point x a)) (Predicate (p) (true) (false) (if p1 p2 p3) (begin f0 ... p1) (let ((x ntl) ...) p) (primapp pp t ...) (sys-primapp spr t ...)) (Effect (f) (nop) (if p1 f2 f3) (begin f0 ... f1) (let ((x ntl) ...) f) (primapp ep t ...) (sys-primapp spr t ...) (return-point x a))) (define-parser parse-L15 L15) ; (define process-tail ; (lambda (expr rp) ; (match expr ; [(quote ,datum) `(return ,rp (quote ,datum))] ; [,var (guard (symbol? var)) `(return ,rp ,var)] ; [(if ,test ,[conseq] ,[altern]) ; `(if ,(process-nontail test) ,conseq ,altern)] ; [(begin ,expr* ...) ; `(begin ; ,@((foldl '()) ; (lambda (expr) ; (lambda (expr*) ; (if (null? expr*) ; (cons (process-tail expr rp) expr*) ; (cons (process-nontail expr) expr*)))) ; expr*))] ; [(let ([,lhs* ,rhs*] ...) ,[body]) ; (let ([rhs* (map process-nontail rhs*)]) ; `(let ([,lhs* ,rhs*] ...) ; ,body))] ; [(,prim ,rand* ...) ; (guard (primitive? prim)) ; (let ([rand* (map process-nontail rand*)]) ; (let ([tmp (gen-symbol 'tmp)]) ; `(let ([,tmp (,prim ,rand* ...)]) ; (return ,rp ,tmp))))] ; [(,rator ,rand* ...) ; (let ([rator (process-nontail rator)] ; [rand* (map process-nontail rand*)]) ; `(,rator ,rp ,rand* ...))] ; [,expr (error 'insert-dummy-rp "Invalid expression: ~s" expr)]))) ; (define process-nontail ; (lambda (expr) ; (match expr ; [(quote ,datum) `(quote ,datum)] ; [,var (guard (symbol? var)) `,var] ; [(if ,[test] ,[conseq] ,[altern]) ; `(if ,test ,conseq ,altern)] ; [(begin ,[expr*] ...) `(begin ,expr* ...)] ; [(let ([,lhs* ,[rhs*]] ...) ,[body]) ; `(let ([,lhs* ,rhs*] ...) ,body)] ; [(,prim ,[rand*] ...) ; (guard (primitive? prim)) ; `(,prim ,rand* ...)] ; [(,[rator] ,[rand*] ...) ; (let ([label (gen-label (gen-symbol 'lab))]) ; `(return-point ,label ; (,rator ,label ,rand* ...)))] ; [,expr (error 'insert-dummy-rp "Invalid expression: ~s" expr)]))) ; (define process-lambda ; (lambda (expr) ; (match expr ; [(lambda (,formal* ...) ,body) ; (let ([rp (gen-symbol 'rp)]) ; `(lambda (,rp ,formal* ...) ; ,(process-tail body rp)))]))) ; (define process-letrec ; (lambda (expr) ; (match expr ; [(letrec ([,lhs* ,rhs*] ...) ,body) ; (let ([rhs* (map process-lambda rhs*)]) ; (let ([rp (gen-symbol 'rp)]) ; `(letrec ([,lhs* ,rhs*] ...) ; (run (,rp) ; ,(process-tail body rp)))))]))) (define-pass introduce-dummy-rp : L14 (ir) -> L15 () (LetrecExpr : LetrecExpr (ir) -> LetrecExpr () [(letrec ((,x ,[lexpr]) ...) ,[rnexpr]) `(letrec ((,x ,lexpr) ...) ,rnexpr)]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x ...) ,v) (let ([rp (gen-symbol 'rp)]) (let ([tl (ValueTail v rp)]) `(lambda (,rp ,x ...) ,tl)))]) (ValueRun : Value (ir) -> RunExpr () [(var ,x) (let ([rp (gen-symbol 'rp)]) `(run (,rp) (return (var ,rp) (var ,x))))] [(quoted-const ,d) (let ([rp (gen-symbol 'rp)]) `(run (,rp) (return (var ,rp) (quoted-const ,d))))] [(if ,[p1] ,v2 ,v3) (let ([rp (gen-symbol 'rp)]) (let ([tl2 (ValueTail v2 rp)] [tl3 (ValueTail v3 rp)]) `(run (,rp) (if ,p1 ,tl2 ,tl3))))] [(begin ,[f0] ... ,v1) (let ([rp (gen-symbol 'rp)]) (let ([tl1 (ValueTail v1 rp)]) `(run (,rp) (begin ,f0 ... ,tl1))))] [(let ((,x ,[ntl1]) ...) ,v2) (let ([rp (gen-symbol 'rp)]) (let ([tl2 (ValueTail v2 rp)]) `(run (,rp) (let ((,x ,ntl1) ...) ,tl2))))] [(primapp ,vp ,[t] ...) (let ([rp (gen-symbol 'rp)]) (let ([tmp (gen-symbol 'tmp)]) `(run (,rp) (let ([,tmp (primapp ,vp ,t ...)]) (return (var ,rp) (var ,tmp))))))] [(sys-primapp ,spr ,[t] ...) (let ([rp (gen-symbol 'rp)]) (let ([tmp (gen-symbol 'tmp)]) `(run (,rp) (let ([,tmp (primapp ,spr ,t ...)]) (return (var ,rp) (var ,tmp))))))] [(app ,[t0] ,[t1] ...) (let ([rp (gen-symbol 'rp)]) `(run (,rp)(app ,t0 (var ,rp) ,t1 ...)))]) (ValueTail : Value (ir rp) -> Tail () [(var ,x) `(return (var ,rp) (var ,x))] [(quoted-const ,d) `(return (var ,rp) (quoted-const ,d))] [(if ,[p1] ,[ValueTail : v2 rp -> tl2] ,[ValueTail : v3 rp -> tl3]) `(if ,p1 ,tl2 ,tl3)] [(begin ,[f0] ... ,[ValueTail : v1 rp -> tl1]) `(begin ,f0 ... ,tl1)] [(let ((,x ,[ntl1]) ...) ,[ValueTail : v2 rp -> tl2]) `(let ((,x ,ntl1) ...) ,tl2)] [(primapp ,vp ,[t] ...) (let ([tmp (gen-symbol 'tmp)]) `(let ([,tmp (primapp ,vp ,t ...)]) (return (var ,rp) (var ,tmp))))] [(sys-primapp ,spr ,[t] ...) (let ([tmp (gen-symbol 'tmp)]) `(let ([,tmp (primapp ,spr ,t ...)]) (return (var ,rp) (var ,tmp))))] [(app ,[t0] ,[t1] ...) `(app ,t0 (var ,rp) ,t1 ...)]) (ValueNTail : Value (ir) -> Nontail () [(if ,[p1] ,[ntl2] ,[ntl3]) `(if ,p1 ,ntl2 ,ntl3)] [(begin ,[f0] ... ,[ntl1]) `(begin ,f0 ... ,ntl1)] [(let ((,x ,[ntl1]) ...) ,[ntl2]) `(let ((,x ,ntl1) ...) ,ntl2)] [(app ,[t0] ,[t1] ...) (let ([label (gen-label (gen-symbol 'lab))]) `(return-point ,label (app ,t0 (var ,label) ,t1 ...)))]) (Predicate : Predicate (ir) -> Predicate () [(let ((,x ,[ntl1]) ...) ,[p]) `(let ((,x ,ntl1) ...) ,p)]) (Effect : Effect (ir) -> Effect () [(let ((,x ,[ntl1]) ...) ,[f]) `(let ((,x ,ntl1) ...) ,f)] [(app ,[t0] ,[t1] ...) (let ([label (gen-label (gen-symbol 'lab))]) `(return-point ,label (app ,t0 (var ,label) ,t1 ...)))])) (define-language L16 (extends L15) (entry LetrecExpr) (Tail (tl) (- (let ((x ntl1) ...) tl2)) (+ (let ((x ntl1)) tl2))) (Nontail (ntl) (- (let ((x ntl1) ...) ntl2)) (+ (let ((x ntl1)) ntl2))) (Predicate (p) (- (let ((x ntl) ...) p)) (+ (let ((x ntl)) p))) (Effect (f) (- (let ((x ntl) ...) f)) (+ (let ((x ntl)) f)))) (define-parser parse-L16 L16) (define-pass remove-nonunary-let : L15 (ir) -> L16 () (Tail : Tail (ir) -> Tail () [(let ((,x ,[ntl]) ...) ,[tl]) (let loop ([lhs* x] [rhs* ntl]) (if (null? lhs*) tl (let ([x (car lhs*)] [ntl (car rhs*)] [tl (loop (cdr lhs*) (cdr rhs*))]) `(let ((,x ,ntl)) ,tl))))]) (Nontail : Nontail (ir) -> Nontail () [(let ((,x ,[ntl1]) ...) ,[ntl2]) (let loop ([lhs* x] [rhs* ntl1]) (if (null? lhs*) ntl2 (let ([x (car lhs*)] [ntl1 (car rhs*)] [ntl2 (loop (cdr lhs*) (cdr rhs*))]) `(let ((,x ,ntl1)) ,ntl2))))]) (Predicate : Predicate (ir) -> Predicate () [(let ((,x ,[ntl]) ...) ,[p]) (let loop ([lhs* x] [rhs* ntl]) (if (null? lhs*) p (let ([x (car lhs*)] [ntl (car rhs*)] [p (loop (cdr lhs*) (cdr rhs*))]) `(let ((,x ,ntl)) ,p))))]) (Effect : Effect (ir) -> Effect () [(let ((,x ,[ntl]) ...) ,[f]) (let loop ([lhs* x] [rhs* ntl]) (if (null? lhs*) f (let ([x (car lhs*)] [ntl (car rhs*)] [f (loop (cdr lhs*) (cdr rhs*))]) `(let ((,x ,ntl)) ,f))))])) (define-language L17 (extends L16) (entry LetrecExpr) (RunExpr (rnexpr) (- (run (x) tl)) (+ (run (x) dec))) (LambdaExpr (lexpr) (- (lambda (x ...) tl)) (+ (lambda (x ...) dec))) (DeclareExpr (dec) (+ (declare (x ...) tl))) (Tail (tl) (- (let ((x ntl1)) tl2))) (Nontail (ntl) (- t (if p1 ntl2 ntl3) (begin f0 ... ntl1) (let ((x ntl1)) ntl2) (primapp vp t ...) (sys-primapp spr t ...) (return-point x a))) (RhsExpr (rhs) (+ t (if p1 rhs2 rhs3) (begin f0 ... rhs1) (primapp vp t ...) (sys-primapp spr t ...) (return-point x a))) (Predicate (p) (- (let ((x ntl)) p))) (Effect (f) (- (let ((x ntl)) f)) (+ (set! x rhs)))) (define-parser parse-L17 L17) (define-pass return-of-set! : L16 (ir) -> L17 () (definitions (define Effect* (lambda (f* var*) (if (null? f*) (values '() var*) (let-values ([(f var*) (Effect (car f*) var*)]) (let-values ([(f* var*) (Effect* (cdr f*) var*)]) (values (cons f f*) var*))))))) (RunExpr : RunExpr (ir) -> RunExpr () [(run (,x) ,[tl '() -> tl var*]) `(run (,x) (declare (,var* ...) ,tl))]) (LambdaExpr : LambdaExpr (ir) -> LambdaExpr () [(lambda (,x* ...) ,[tl '() -> tl var*]) `(lambda (,x* ...) (declare (,var* ...) ,tl))]) (Tail : Tail (ir var*) -> Tail (var*) [(let ([,x ,ntl]) ,[tl var*]) (let-values ([(rhs var*) (Nontail ntl var*)]) (values `(begin (set! ,x ,rhs) ,tl) (cons x var*)))] [(if ,[p1 var*] ,tl2 ,tl3) (let-values ([(tl2 var*) (Tail tl2 var*)]) (let-values ([(tl3 var*) (Tail tl3 var*)]) (values `(if ,p1 ,tl2 ,tl3) var*)))] [(begin ,f* ... ,[tl var*]) (let-values ([(f* var*) (Effect* f* var*)]) (values `(begin ,f* ... ,tl) var*))]) (Nontail : Nontail (ir var*) -> RhsExpr (var*) [(let ((,x ,ntl1)) ,[rhs2 var*]) (let-values ([(rhs1 var*) (Nontail ntl1 var*)]) (values `(begin (set! ,x ,rhs1) ,rhs2) (cons x var*)))] [(if ,[p1 var*] ,ntl2 ,ntl3) (let-values ([(rhs2 var*) (Nontail ntl2 var*)]) (let-values ([(rhs3 var*) (Nontail ntl3 var*)]) (values `(if ,p1 ,rhs2 ,rhs3) var*)))] [(begin ,f* ... ,[rhs var*]) (let-values ([(f* var*) (Effect* f* var*)]) (values `(begin ,f* ... ,rhs) var*))] ; TODO: something we could do better here? Triv->Rhs is effectively just this code [(quoted-const ,d) (values `(quoted-const ,d) var*)] [(var ,x) (values `(var ,x) var*)]) (Effect : Effect (ir var*) -> Effect (var*) [(let ([,x ,ntl]) ,[f var*]) (let-values ([(rhs var*) (Nontail ntl var*)]) (values `(begin (set! ,x ,rhs) ,f) var*))] [(if ,[p1 var*] ,f2 ,f3) (let-values ([(f2 var*) (Effect f2 var*)]) (let-values ([(f3 var*) (Effect f3 var*)]) (values `(if ,p1 ,f2 ,f3) var*)))] [(begin ,f* ... ,[f var*]) (let-values ([(f* var*) (Effect* f* var*)]) (values `(begin ,f* ... ,f) var*))]) (Predicate : Predicate (ir var*) -> Predicate (var*) [(let ([,x ,ntl]) ,[p var*]) (let-values ([(rhs var*) (Nontail ntl var*)]) (values `(begin (set! ,x ,rhs) ,p) (cons x var*)))] [(if ,[p1 var*] ,p2 ,p3) (let-values ([(p2 var*) (Predicate p2 var*)]) (let-values ([(p3 var*) (Predicate p3 var*)]) (values `(if ,p1 ,p2 ,p3) var*)))] [(begin ,f* ... ,[p var*]) (let-values ([(f* var*) (Effect* f* var*)]) (values `(begin ,f* ... ,p) var*))])) (define-language L18 (extends L17) (entry LetrecExpr) (Triv (t) (+ (label x)))) (define-parser parse-L18 L18) (define-pass explicit-labels : L17 (ir) -> L18 () (LetrecExpr : LetrecExpr (ir [labs '()]) -> LetrecExpr () [(letrec ((,x ,[lexpr x -> lexpr]) ...) ,[rnexpr x -> rnexpr]) `(letrec ((,x ,lexpr) ...) ,rnexpr)]) (LambdaExpr : LambdaExpr (ir labs) -> LambdaExpr ()) (Triv : Triv (ir labs) -> Triv () [(var ,x) (if (memq x labs) `(label ,x) `(var ,x))]) (Application : Application (ir labs) -> Application ()) (DeclareExpr : DeclareExpr (ir labs) -> DeclareExpr ()) (RunExpr : RunExpr (ir labs) -> RunExpr ()) (Tail : Tail (ir labs) -> Tail ()) (RhsExpr : RhsExpr (ir labs) -> RhsExpr () [(return-point ,x ,a) (let ([a (Application a (cons x labs))]) `(return-point ,x ,a))]) (Predicate : Predicate (ir labs) -> Predicate ()) (Effect : Effect (ir labs) -> Effect () [(return-point ,x ,a) (let ([a (Application a (cons x labs))]) `(return-point ,x ,a))]))) nanopass-framework-scheme-1.9.2/tests/helpers.ss000066400000000000000000000202451374306730300217660ustar00rootroot00000000000000;;; 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)]))))) nanopass-framework-scheme-1.9.2/tests/implementation-helpers.chezscheme.sls000066400000000000000000000005061374306730300273000ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/tests/implementation-helpers.ikarus.ss000066400000000000000000000014211374306730300263010ustar00rootroot00000000000000;;; 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)))))) nanopass-framework-scheme-1.9.2/tests/implementation-helpers.ironscheme.sls000066400000000000000000000016121374306730300273150ustar00rootroot00000000000000;;; 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)))))) nanopass-framework-scheme-1.9.2/tests/implementation-helpers.ss000066400000000000000000000005021374306730300250030ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/tests/implementation-helpers.vicare.sls000066400000000000000000000032511374306730300264330ustar00rootroot00000000000000;;; 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)))) nanopass-framework-scheme-1.9.2/tests/new-compiler.ss000066400000000000000000000062671374306730300227350ustar00rootroot00000000000000;;; 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 ;;; (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)))) nanopass-framework-scheme-1.9.2/tests/test-driver.ss000066400000000000000000000172771374306730300226070ustar00rootroot00000000000000;;; 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 # with "#" to make it something the reader can ; handle, then substitute void for "#" (shell "sed -e 's/#/\"#\"/g' < ~a > ~a.tmp" out-file out-file) (let ([ip (open-input-file (format "~a.tmp" out-file))]) (let ([x (subst (void) "#" (read ip))]) (close-input-port ip) x))))) nanopass-framework-scheme-1.9.2/tests/unit-test-helpers-implementation.chezscheme.sls000066400000000000000000000006311374306730300312310ustar00rootroot00000000000000;;; 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 ...))]))) nanopass-framework-scheme-1.9.2/tests/unit-test-helpers-implementation.ikarus.sls000066400000000000000000000022221374306730300304070ustar00rootroot00000000000000;;; 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 ...)]))) nanopass-framework-scheme-1.9.2/tests/unit-test-helpers-implementation.ironscheme.sls000066400000000000000000000025451374306730300312550ustar00rootroot00000000000000;;; 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 ...)]))) nanopass-framework-scheme-1.9.2/tests/unit-test-helpers-implementation.vicare.sls000066400000000000000000000023671374306730300303740ustar00rootroot00000000000000;;; 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))) nanopass-framework-scheme-1.9.2/tests/unit-test-helpers.ss000066400000000000000000000112471374306730300237220ustar00rootroot00000000000000;;; 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)))]))) nanopass-framework-scheme-1.9.2/tests/unit-tests.ss000066400000000000000000001151621374306730300224460ustar00rootroot00000000000000;;; Copyright (c) 2000-2018 Andrew W. Keep, R. Kent Dybvig ;;; See the accompanying file Copyright for details (library (tests unit-tests) (export run-unit-tests run-ensure-correct-identifiers run-maybe-tests run-maybe-dots-tests run-language-dot-support run-maybe-unparse-tests run-argument-name-matching run-error-messages run-pass-parser-unparser) (import (rnrs) (nanopass helpers) (nanopass language) (nanopass pass) (nanopass parser) (tests unit-test-helpers)) (define primitives '(car cdr cons + - =)) (define primitive? (lambda (x) (memq x primitives))) (define variable? (lambda (x) (and (symbol? x) (not (primitive? x))))) (define constant? (lambda (x) (or (number? x) (boolean? x) (string? x) (and (pair? x) (constant? (car x)) (constant? (cdr x)))))) (define-language L0 (terminals (variable (x)) (constant (c)) (primitive (pr))) (Expr (e) (var x) (quote c) (begin e0 ... e1) (if e0 e1 e2) (lambda (x ...) e0 ... e1) (let ([x e] ...) e0 ... e1) (letrec ([x e] ...) e0 ... e1) (primapp pr e1 ...) (app e0 e1 ...))) (define-record-type var (fields sym ref set mset) (protocol (lambda (new) (lambda (sym) (new sym #f #f #f))))) (define-language LUNPARSE (terminals (var (x)) => var-sym (constant (c)) (primitive (pr))) (Expr (e body) (var x) => x (quoted c) => (quote c) (seq e0 e1) => (begin e0 e1) (if e0 e1 e2) (lambda (x ...) e0 ... e1) (binding (x ...) (e ...) body0 ... body1) => (let ([x e] ...) body0 ... body1) (recbinding (x ...) (e ...) body0 ... body1) => (letrec ([x e] ...) body0 ... body1) (primapp pr e1 ...) => (pr e1 ...) (app e0 e1 ...) => (e0 e1 ...))) (define-language LBool (terminals (boolean (b))) (Expr (e) b)) (define-language LBoolLambda (terminals (boolean (b)) (symbol (x))) (Expr (e) v x (lambda (x) e) (and e0 e1) (or e0 e1) (not e) (e0 e1)) (Value (v) b)) (test-suite unit-tests (test with-output-language (assert-equal? '(var a) (unparse-L0 (with-output-language L0 (in-context Expr `(var a))))) (assert-equal? '(let ([x '1] [y '2]) (primapp + (var x) (var y))) (unparse-L0 (with-output-language L0 (in-context Expr `(let ([x (quote 1)] [y (quote 2)]) (primapp + (var x) (var y))))))) (assert-equal? '(var a) (unparse-L0 (with-output-language (L0 Expr) `(var a)))) (assert-equal? '(let ([x '1] [y '2]) (primapp + (var x) (var y))) (unparse-L0 (with-output-language (L0 Expr) `(let ([x (quote 1)] [y (quote 2)]) (primapp + (var x) (var y))))))) (test unparse-language (assert-equal? `(quoted 5) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(quoted 5)) #t)) (assert-equal? `(seq (quoted 7) (quoted 8)) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(seq (quoted 7) (quoted 8))) #t)) (let ([x.0 (make-var 'x.0)]) (assert-equal? `(var ,x.0) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(var ,x.0)) #t))) (let ([x.1 (make-var 'x.1)] [x.2 (make-var 'x.2)] [y.3 (make-var 'y.2)] [x.4 (make-var 'x.4)] [zero?.5 (make-var 'zero?.5)] [*.6 (make-var '*.6)] [f.7 (make-var 'f.7)]) (assert-equal? `(recbinding (,zero?.5 ,*.6 ,f.7) ((lambda (,x.1) (primapp = (var ,x.1) (quoted 0))) (lambda (,x.2 ,y.3) (if (app (var ,zero?.5) (var ,x.2)) (quoted 0) (if (primapp = (var ,x.2) (quoted 1)) (var ,y.3) (primapp + (var ,y.3) (app (var ,*.6) (primapp - (var ,x.2) (quoted 1)) (var ,y.3)))))) (lambda (,x.4) (if (app (var ,zero?.5) (var ,x.4)) (quoted 1) (app (var ,*.6) (var ,x.4) (app (var ,f.7) (primapp - (var ,x.4) (quoted 1))))))) (app (var ,f.7) (quoted 10))) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(recbinding (,zero?.5 ,*.6 ,f.7) ((lambda (,x.1) (primapp = (var ,x.1) (quoted 0))) (lambda (,x.2 ,y.3) (if (app (var ,zero?.5) (var ,x.2)) (quoted 0) (if (primapp = (var ,x.2) (quoted 1)) (var ,y.3) (primapp + (var ,y.3) (app (var ,*.6) (primapp - (var ,x.2) (quoted 1)) (var ,y.3)))))) (lambda (,x.4) (if (app (var ,zero?.5) (var ,x.4)) (quoted 1) (app (var ,*.6) (var ,x.4) (app (var ,f.7) (primapp - (var ,x.4) (quoted 1))))))) (app (var ,f.7) (quoted 10)))) #t))) (assert-equal? '(quote 5) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(quoted 5)) #f)) (assert-equal? '(begin (quote 7) (quote 8)) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(seq (quoted 7) (quoted 8))) #f)) (let ([x.0 (make-var 'x.0)]) (assert-equal? 'x.0 (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(var ,x.0)) #f))) (let ([x.1 (make-var 'x.1)] [x.2 (make-var 'x.2)] [y.3 (make-var 'y.3)] [x.4 (make-var 'x.4)] [zero?.5 (make-var 'zero?.5)] [*.6 (make-var '*.6)] [f.7 (make-var 'f.7)]) (assert-equal? '(letrec ([zero?.5 (lambda (x.1) (= x.1 '0))] [*.6 (lambda (x.2 y.3) (if (zero?.5 x.2) '0 (if (= x.2 '1) y.3 (+ y.3 (*.6 (- x.2 '1) y.3)))))] [f.7 (lambda (x.4) (if (zero?.5 x.4) '1 (*.6 x.4 (f.7 (- x.4 '1)))))]) (f.7 '10)) (unparse-LUNPARSE (with-output-language (LUNPARSE Expr) `(recbinding (,zero?.5 ,*.6 ,f.7) ((lambda (,x.1) (primapp = (var ,x.1) (quoted 0))) (lambda (,x.2 ,y.3) (if (app (var ,zero?.5) (var ,x.2)) (quoted 0) (if (primapp = (var ,x.2) (quoted 1)) (var ,y.3) (primapp + (var ,y.3) (app (var ,*.6) (primapp - (var ,x.2) (quoted 1)) (var ,y.3)))))) (lambda (,x.4) (if (app (var ,zero?.5) (var ,x.4)) (quoted 1) (app (var ,*.6) (var ,x.4) (app (var ,f.7) (primapp - (var ,x.4) (quoted 1))))))) (app (var ,f.7) (quoted 10)))) #f))) ) (test boolean-terminals (let () (define-parser parse-LBool LBool) (assert-equal? #t (parse-LBool #t))) (let () (define-parser parse-LBool LBool) (assert-equal? #f (parse-LBool #f))) (let () (define-parser parse-LBool LBool) (guard (c [else #t]) (assert-equal? 'a (parse-LBool 'a)))) (let () (define-parser parse-LBoolLambda LBoolLambda) (assert-equal? #t (parse-LBoolLambda #t))) (let () (define-parser parse-LBoolLambda LBoolLambda) (assert-equal? #f (parse-LBoolLambda #f))) (let () (define-parser parse-LBoolLambda LBoolLambda) (assert-equal? '(lambda (x) #f) (unparse-LBoolLambda (parse-LBoolLambda '(lambda (x) #f))))) (let () (define-parser parse-LBoolLambda LBoolLambda) (assert-equal? '(lambda (f) (f #f)) (unparse-LBoolLambda (parse-LBoolLambda '(lambda (f) (f #f)))))) (let () (define-parser parse-LBoolLambda LBoolLambda) (assert-equal? '(lambda (f) (not (f #f))) (unparse-LBoolLambda (parse-LBoolLambda '(lambda (f) (not (f #f))))))))) (define datum? (lambda (x) (or (number? x) (string? x) (symbol? x) (and (pair? x) (datum? (car x)) (datum? (cdr x))) (and (vector? x) (for-all datum? (vector->list x)))))) (define-language LVAR (terminals (var (x)) (primitive (pr)) (datum (d))) (Expr (e) (var x) (quote d) (if e0 e1 e2) (begin e0 ... e1) (let ([x e] ...) e1) (letrec ([x e] ...) e1) (app e0 e1 ...) (primapp pr e ...))) (define-pass break-variable : LVAR (ir) -> LVAR () (definitions (define var? symbol?)) (Expr : Expr (ir) -> Expr () [(var ,x) (printf "found var: ~a\n" (var-sym x)) `(var ,x)])) (test-suite ensure-correct-identifiers (test accidental-variable?-capture (assert-equal? (with-output-to-string (lambda () (break-variable (with-output-language (LVAR Expr) `(var ,(make-var 'x)))))) "found var: x\n"))) (define-language Lmaybe (terminals (boolean (b)) (integer (i))) (Exp (e) (Int i) (Bool b) (Bar (maybe i) e) (Foo i (maybe e)))) (define-parser parse-Lmaybe Lmaybe) (test-suite maybe-tests (test maybe-parse/unparse (assert-equal? '(Int 72) (unparse-Lmaybe (parse-Lmaybe '(Int 72)))) (assert-equal? '(Bool #t) (unparse-Lmaybe (parse-Lmaybe '(Bool #t)))) (assert-equal? '(Bar 5 (Bool #t)) (unparse-Lmaybe (parse-Lmaybe '(Bar 5 (Bool #t))))) (assert-equal? '(Bar #f (Bool #t)) (unparse-Lmaybe (parse-Lmaybe '(Bar #f (Bool #t))))) (assert-equal? '(Foo 5 #f) (unparse-Lmaybe (parse-Lmaybe '(Foo 5 #f)))) (assert-equal? '(Foo 5 (Foo 4 (Foo 3 #f))) (unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Foo 4 (Foo 3 #f)))))) (assert-equal? '(Foo 5 (Bar 3 (Foo 1 #f))) (unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Bar 3 (Foo 1 #f)))))) (assert-equal? '(Foo 5 (Int 3)) (unparse-Lmaybe (parse-Lmaybe '(Foo 5 (Int 3)))))) (test maybe-with-output-language/unparse (assert-equal? '(Int 72) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Int 72)))) (assert-equal? '(Bool #t) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bool #t)))) (assert-equal? '(Bar 5 (Bool #t)) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bar 5 (Bool #t))))) (assert-equal? '(Bar #f (Bool #t)) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Bar #f (Bool #t))))) (assert-equal? '(Foo 5 #f) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 #f)))) (assert-equal? '(Foo 5 (Foo 4 (Foo 3 #f))) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Foo 4 (Foo 3 #f)))))) (assert-equal? '(Foo 5 (Bar 3 (Foo 1 #f))) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Bar 3 (Foo 1 #f)))))) (assert-equal? '(Foo 5 (Int 3)) (unparse-Lmaybe (with-output-language (Lmaybe Exp) `(Foo 5 (Int 3)))))) (test maybe-pass (let () (define-pass add-one-int : Lmaybe (ir) -> Lmaybe () (Exp : Exp (ir) -> Exp () [(Int ,i) `(Int ,(fx+ i 1))])) (and (assert-equal? '(Int 4) (unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Int 3))))) (assert-equal? '(Foo 4 (Int 4)) (unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 4 (Int 3)))))) (assert-equal? '(Foo 4 (Foo 5 (Int 3))) (unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 4 (Foo 5 (Int 2))))))) (assert-equal? '(Foo 3 #f) (unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Foo 3 #f))))) (assert-equal? '(Bar #f (Int 5)) (unparse-Lmaybe (add-one-int (with-output-language (Lmaybe Exp) `(Bar #f (Int 4)))))))) (let () (define-pass add-one : Lmaybe (ir) -> Lmaybe () (Exp : Exp (ir) -> Exp () [(Foo ,i ,[e?]) `(Foo ,(fx+ i 1) ,e?)] [(Bar ,i? ,[e]) `(Bar ,(and i? (fx+ i? 1)) ,e)] [(Int ,i) `(Int ,(fx+ i 1))])) (and (assert-equal? '(Int 4) (unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Int 3))))) (assert-equal? '(Foo 5 (Int 4)) (unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 4 (Int 3)))))) (assert-equal? '(Foo 5 (Foo 6 (Int 3))) (unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 4 (Foo 5 (Int 2))))))) (assert-equal? '(Foo 4 (Bar 6 (Foo 7 #f))) (unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 3 (Bar 5 (Foo 6 #f))))))) (assert-equal? '(Foo 4 (Bar #f (Foo 7 #f))) (unparse-Lmaybe (add-one (with-output-language (Lmaybe Exp) `(Foo 3 (Bar #f (Foo 6 #f))))))))))) (define-language Lmaybe2 (terminals (boolean (b)) (integer (i))) (Exp (e) (Int i) (Bool b) (Bar (maybe i) ... e) (Foo i (maybe e) ...))) (define-parser parse-Lmaybe2 Lmaybe2) (test-suite maybe-dots-tests (test maybe-parse/unparse (assert-equal? '(Foo 3) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 3)))) (assert-equal? '(Bar (Int 72)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bar (Int 72))))) (assert-equal? '(Int 72) (unparse-Lmaybe2 (parse-Lmaybe2 '(Int 72)))) (assert-equal? '(Bool #t) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bool #t)))) (assert-equal? '(Bar 5 (Bool #t)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bar 5 (Bool #t))))) (assert-equal? '(Bar #f (Bool #t)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bar #f (Bool #t))))) (assert-equal? '(Bar #f 1 #f 2 #f 3 (Bool #t)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bar #f 1 #f 2 #f 3 (Bool #t))))) (assert-equal? '(Bar 1 #f 2 #f 3 #f (Bool #t)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Bar 1 #f 2 #f 3 #f (Bool #t))))) (assert-equal? '(Foo 5 #f) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 #f)))) (assert-equal? '(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f)))) (assert-equal? '(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3)))) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3))))))) (assert-equal? '(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f))) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f)))))) (assert-equal? '(Foo 5 (Int 3) (Bool #f)) (unparse-Lmaybe2 (parse-Lmaybe2 '(Foo 5 (Int 3) (Bool #f)))))) (test maybe-with-output-language/unparse (assert-equal? '(Foo 3) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 3)))) (assert-equal? '(Bar (Int 72)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar (Int 72))))) (assert-equal? '(Int 72) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Int 72)))) (assert-equal? '(Bool #t) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bool #t)))) (assert-equal? '(Bar 5 (Bool #t)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar 5 (Bool #t))))) (assert-equal? '(Bar #f (Bool #t)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar #f (Bool #t))))) (assert-equal? '(Bar #f 1 #f 2 #f 3 (Bool #t)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar #f 1 #f 2 #f 3 (Bool #t))))) (assert-equal? '(Bar 1 #f 2 #f 3 #f (Bool #t)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Bar 1 #f 2 #f 3 #f (Bool #t))))) (assert-equal? '(Foo 5 #f) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 #f)))) (assert-equal? '(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 #f #f (Bar 3 (Foo 2 #f)) (Bool #t) #f #f (Int 2) #f)))) (assert-equal? '(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3)))) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Foo 4 (Foo 3 #f (Bool #t) (Int 3))))))) (assert-equal? '(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f))) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Bar 3 (Foo 1 (Bar 2 (Bool #t)) #f #f)))))) (assert-equal? '(Foo 5 (Int 3) (Bool #f)) (unparse-Lmaybe2 (with-output-language (Lmaybe2 Exp) `(Foo 5 (Int 3) (Bool #f)))))) (test maybe-pass (let () (define-pass add-one-int : Lmaybe2 (ir) -> Lmaybe2 () (Exp : Exp (ir) -> Exp () [(Int ,i) `(Int ,(fx+ i 1))])) (and (assert-equal? '(Int 4) (unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Int 3))))) (assert-equal? '(Foo 4 (Int 4) (Int 5) (Int 7) #f #f (Int 8)) (unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 4 (Int 3) (Int 4) (Int 6) #f #f (Int 7)))))) (assert-equal? '(Foo 4 (Foo 5 (Int 3) #f (Int 4) (Int 5))) (unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 4 (Foo 5 (Int 2) #f (Int 3) (Int 4))))))) (assert-equal? '(Foo 3 #f (Int 4)) (unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Foo 3 #f (Int 3)))))) (assert-equal? '(Bar 3 #f 4 #f (Int 4)) (unparse-Lmaybe2 (add-one-int (with-output-language (Lmaybe2 Exp) `(Bar 3 #f 4 #f (Int 3)))))))) (let () (define-pass add-one : Lmaybe2 (ir) -> Lmaybe2 () (Exp : Exp (ir) -> Exp () [(Foo ,i ,[e?*] ...) `(Foo ,(fx+ i 1) ,e?* ...)] [(Bar ,i?* ... ,[e]) `(Bar ,(map (lambda (i?) (and i? (fx+ i? 1))) i?*) ... ,e)] [(Int ,i) `(Int ,(fx+ i 1))])) (and (assert-equal? '(Int 4) (unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Int 3))))) (assert-equal? '(Foo 5 (Int 4) (Int 5) (Int 6) #f (Int 8)) (unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 4 (Int 3) (Int 4) (Int 5) #f (Int 7)))))) (assert-equal? '(Foo 5 (Foo 6 (Int 3) (Bar 4 3 2 #f 1 (Foo 3 (Int 8) (Int 9))))) (unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 4 (Foo 5 (Int 2) (Bar 3 2 1 #f 0 (Foo 2 (Int 7) (Int 8))))))))) (assert-equal? '(Foo 4 (Bar 6 #f 8 #f 9 (Foo 7 #f)) (Bool #t) #f) (unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 3 (Bar 5 #f 7 #f 8 (Foo 6 #f)) (Bool #t) #f))))) (assert-equal? '(Foo 4 (Bar #f (Foo 7 #f)) (Bool #t) #f) (unparse-Lmaybe2 (add-one (with-output-language (Lmaybe2 Exp) `(Foo 3 (Bar #f (Foo 6 #f)) (Bool #t) #f))))))))) (define-language LMaybeNoBool (terminals (symbol (x)) (number (n))) (Expr (e) (foo x (maybe n)) (bar (maybe e) x) (num n) (ref x))) (define-language LMaybeListNoBool (terminals (symbol (x)) (number (n))) (Expr (e) (foo ([x (maybe n)] ...) e) (bar (maybe e) ... x) (num n) (ref x))) (test-suite maybe-unparse-tests (test maybe-unparse (assert-equal? '(foo x 10) (unparse-LMaybeNoBool (with-output-language (LMaybeNoBool Expr) `(foo x 10)))) (assert-equal? '(bar (foo x #f) x) (unparse-LMaybeNoBool (with-output-language (LMaybeNoBool Expr) `(bar (foo x #f) x)))) (assert-equal? '(bar (bar (foo y #f) y) z) (unparse-LMaybeNoBool (with-output-language (LMaybeNoBool Expr) `(bar (bar (foo y #f) y) z)))) (assert-equal? '(bar (bar (bar #f x) y) z) (unparse-LMaybeNoBool (with-output-language (LMaybeNoBool Expr) `(bar (bar (bar #f x) y) z))))) (test maybe-unparse-dots (assert-equal? '(foo ([x 10] [y 12]) (ref x)) (unparse-LMaybeListNoBool (with-output-language (LMaybeListNoBool Expr) `(foo ([x 10] [y 12]) (ref x))))) (assert-equal? '(foo ([x #f] [y 12] [z #f]) (ref y)) (unparse-LMaybeListNoBool (with-output-language (LMaybeListNoBool Expr) `(foo ([x #f] [y 12] [z #f]) (ref y))))) (assert-equal? '(bar #f #f (num 10) (ref x) #f (foo ([x #f] [y 10] [z 5] [w #f]) (bar #f z)) #f w) (unparse-LMaybeListNoBool (with-output-language (LMaybeListNoBool Expr) `(bar #f #f (num 10) (ref x) #f (foo ([x #f] [y 10] [z 5] [w #f]) (bar #f z)) #f w)))))) ;; tests related to issue #7 on github.com (define-language LPairs (terminals (symbol (x)) (null (n))) (Expr (e) x n (e0 . e1))) (define-parser parse-LPairs LPairs) (define-pass reverse-pairs : LPairs (p) -> LPairs () (Expr : Expr (p) -> Expr () [(,[e0] . ,[e1]) `(,e1 . ,e0)])) (define-language LList (terminals (symbol (x)) (null (n))) (Expr (e) x n (e0 ... . e1))) (define-parser parse-LList LList) (define-language LList2 (terminals (symbol (x)) (null (n))) (Expr (e) x n (e0 ... e1))) (define-pass swap-parts : LList (e) -> LList () (Expr : Expr (e) -> Expr () [(,[e*] ... . ,[e]) `(,e ,e* ... . ())])) ;; example provided by Simon Stapleton via bug #7 (define-language Lx (terminals (symbol (x))) (Expr (e) x (lambda (x* ... . x) e) (define (x x* ... . x1) e) (define x e))) (define-parser parse-Lx Lx) (define-pass Px1 : Lx (ir) -> Lx () (Expr : Expr (ir) -> Expr() [(define (,x ,x* ... . ,x1) ,[e]) `(define ,x (lambda (,x* ... . ,x1) ,e))])) (test-suite language-dot-support (test simple-dots (assert-equal? '() (unparse-LPairs (parse-LPairs '()))) (assert-equal? 'a (unparse-LPairs (parse-LPairs 'a))) (assert-equal? '(a) (unparse-LPairs (parse-LPairs '(a)))) (assert-equal? '(a . b) (unparse-LPairs (parse-LPairs '(a . b)))) (assert-equal? '(a b c . d) (unparse-LPairs (parse-LPairs '(a b c . d)))) (assert-equal? '(((a b . c) d e) f . g) (unparse-LPairs (parse-LPairs '(((a b . c) d e) f . g)))) (assert-equal? '() (unparse-LPairs (with-output-language (LPairs Expr) `()))) (assert-equal? 'a (unparse-LPairs (with-output-language (LPairs Expr) `a))) (assert-equal? '(a) (unparse-LPairs (with-output-language (LPairs Expr) `(a)))) (assert-equal? '(a . b) (unparse-LPairs (with-output-language (LPairs Expr) `(a . b)))) (assert-equal? '(a b c . d) (unparse-LPairs (with-output-language (LPairs Expr) `(a b c . d)))) (assert-equal? '(((a b . c) d e) f . g) (unparse-LPairs (with-output-language (LPairs Expr) `(((a b . c) d e) f . g)))) (assert-equal? '(() . a) (unparse-LPairs (reverse-pairs (parse-LPairs '(a))))) (assert-equal? '(b . a) (unparse-LPairs (reverse-pairs (parse-LPairs '(a . b))))) (assert-equal? '(((d . c) . b) . a) (unparse-LPairs (reverse-pairs (parse-LPairs '(a b c . d))))) (assert-equal? '((g . f) ((() . e) . d) (c . b) . a) (unparse-LPairs (reverse-pairs (parse-LPairs '(((a b . c) d e) f . g)))))) (test dot-after-ellipsis (assert-equal? '() (unparse-LList (parse-LList '()))) (assert-equal? 'x (unparse-LList (parse-LList 'x))) (assert-equal? '(a b c) (unparse-LList (parse-LList '(a b c)))) (assert-equal? '(a b c . d) (unparse-LList (parse-LList '(a b c . d)))) (assert-equal? '(((a b) (c d)) e . f) (unparse-LList (parse-LList '(((a b) (c d)) e . f)))) (assert-equal? '() (unparse-LList (with-output-language (LList Expr) `()))) (assert-equal? 'x (unparse-LList (with-output-language (LList Expr) `x))) (assert-equal? '(a b c) (unparse-LList (with-output-language (LList Expr) `(a b c)))) (assert-equal? '(a b c . d) (unparse-LList (with-output-language (LList Expr) `(a b c . d)))) (assert-equal? '(((a b) (c d)) e . f) (unparse-LList (with-output-language (LList Expr) `(((a b) (c d)) e . f)))) (assert-equal? '(() a b c) (unparse-LList (swap-parts (with-output-language (LList Expr) `(a b c))))) (assert-equal? '(d a b c) (unparse-LList (swap-parts (with-output-language (LList Expr) `(a b c . d))))) (assert-equal? '(f (() (() a b) (() c d)) e) (unparse-LList (swap-parts (with-output-language (LList Expr) `(((a b) (c d)) e . f)))))) (test github-issue-7 (assert-equal? 'x (unparse-Lx (parse-Lx 'x))) (assert-equal? '(lambda (x . z) x) (unparse-Lx (parse-Lx '(lambda (x . z) x)))) (assert-equal? '(lambda (x y . z) x) (unparse-Lx (parse-Lx '(lambda (x y . z) x)))) (assert-equal? '(lambda x x) (unparse-Lx (parse-Lx '(lambda x x)))) (assert-equal? '(define (x y . z) z) (unparse-Lx (parse-Lx '(define (x y . z) z)))) (assert-equal? '(define x x) (unparse-Lx (parse-Lx '(define x x)))) (assert-equal? '(define (l m . n) (define g (lambda (x . z) (lambda (a . b) (lambda (c . d) l))))) (unparse-Lx (parse-Lx '(define (l m . n) (define g (lambda (x . z) (lambda (a . b) (lambda (c . d) l)))))))) (assert-equal? 'x (unparse-Lx (with-output-language (Lx Expr) `x))) (assert-equal? '(lambda (x . z) x) (unparse-Lx (with-output-language (Lx Expr) `(lambda (x . z) x)))) (assert-equal? '(lambda (x y . z) x) (unparse-Lx (with-output-language (Lx Expr) `(lambda (x y . z) x)))) (assert-equal? '(define (x y . z) z) (unparse-Lx (with-output-language (Lx Expr) `(define (x y . z) z)))) (assert-equal? '(lambda x x) (unparse-Lx (with-output-language (Lx Expr) `(lambda x x)))) (assert-equal? '(define x x) (unparse-Lx (with-output-language (Lx Expr) `(define x x)))) (assert-equal? '(define (l m . n) (define g (lambda (x . z) (lambda (a . b) (lambda (c . d) l))))) (unparse-Lx (with-output-language (Lx Expr) `(define (l m . n) (define g (lambda (x . z) (lambda (a . b) (lambda (c . d) l)))))))) (assert-equal? '(define f (lambda (x . y) x)) (unparse-Lx (Px1 (parse-Lx '(define (f x . y) x))))) (assert-equal? '(define g (lambda (x y z . w) w)) (unparse-Lx (Px1 (parse-Lx '(define (g x y z . w) w))))) (assert-equal? '(define h (lambda (x y . z) (define i (lambda (a b c . d) d)))) (unparse-Lx (Px1 (parse-Lx '(define (h x y . z) (define (i a b c . d) d)))))) (assert-equal? '(define f (lambda x (define g (lambda y x)))) (unparse-Lx (Px1 (parse-Lx '(define (f . x) (define (g . y) x)))))))) (define-language LMULTI (terminals (var (x)) (primitive (pr)) (datum (d))) (Expr (e) (var x) (primref pr) (quote d) (if e0 e1 e2) (begin e0 ... e1) (let ([x e] ...) e1) (letrec ([x le] ...) e) (app e0 e1 ...)) (LambdaExpr (le) (lambda (x ...) e) (case-lambda cl ...)) (CaseLambdaClause (cl) (clause (x ...) e))) (define-language L-error (terminals (symbol (x))) (Expr (e body) x (lambda (x* ...) body* ... body) (let ([x* e*] ...) body* ... body) (let-values ([(x** ...) e*] ...) body* ... body) (e e* ...))) (define test-file (let () (define-syntax foo (lambda (x) (syntax-violation 'foo "unexpected call to foo" x))) (source-information-source-file (syntax->source-information #'foo)))) (test-suite error-messages (test run-time-error-messages (assert-error (format-error-message "Exception in with-output-language: expected list of symbol but received x in field x* of (lambda (x* ...) body* ... body) from expression ~s at line 872, char 23 of ~a" ''x test-file) (with-output-language (L-error Expr) `(lambda (,'x ...) z))) (assert-error (format-error-message "Exception in with-output-language: expected list of list of symbol but received x** in field x** of ~s from expression ~s at line 876, char 29 of ~a" '(let-values (((x** ...) e*) ...) body* ... body) ''x** test-file) (with-output-language (L-error Expr) `(let-values ([(,'x** ...) ,'(y)] ...) z))) )) ;; regression test for error reported by R. Kent Dybvig: (define-language L (terminals (symbol (x))) (A (a) b) (B (b) x)) (define-pass P1 : L (ir) -> L () (A : A (ir foo bar ignore) -> A ()) (B : B (ir foo bar) -> B () [else (printf "bar = ~s\n" bar) ir]) (A ir "I am not bar" "I am bar" "extra stuff")) (define-pass P2 : L (ir) -> L () (A : A (ir foo bar ignore) -> A ()) (B : B (ir bar) -> B () [else (printf "bar = ~s\n" bar) ir]) (A ir "I am not bar" "I am bar" "extra stuff")) (define-pass P3 : L (ir) -> L () (A : A (ir xxfoo xxbar ignore) -> A ()) (B : B (ir foo bar) -> B () [else (printf "bar = ~s\n" bar) ir]) (B2 : B (ir) -> B () [else (printf "calling B2\n") ir]) (A ir "I am not bar" "I am bar" "extra stuff")) (define-pass P4 : L (ir) -> L () (A : A (ir) -> A ()) (B : B (ir [foo "I am not bar"] [bar "I am bar"]) -> B () [else (printf "bar = ~s\n" bar) ir]) (A ir)) (define-pass P5 : L (ir) -> L () (B : B (ir foo bar ignore) -> B ()) (symbol : symbol (ir foo bar) -> symbol () (printf "bar = ~s\n" bar) ir) (B ir "I am not bar" "I am bar" "extra stuff")) (define-pass P6 : L (ir) -> L () (B : B (ir foo bar ignore) -> B ()) (symbol : symbol (ir bar) -> symbol () (printf "bar = ~s\n" bar) ir) (B ir "I am not bar" "I am bar" "extra stuff")) (define-pass P7 : L (ir) -> L () (B : B (ir foo bar ignore) -> B ()) (symbol : symbol (ir xxfoo xxbar) -> symbol () (printf "bar = ~s\n" xxbar) ir) (symbol2 : symbol (ir) -> symbol () (printf "calling symbol2\n") ir) (B ir "I am not bar" "I am bar" "extra stuff")) (define-pass P8 : L (ir) -> L () (B : B (ir) -> B ()) (symbol : symbol (ir [foo "I am not bar"] [bar "I am bar"]) -> symbol () (printf "bar = ~s\n" bar) ir) (B ir)) (define-pass P9 : L (ir foo bar ignore) -> L () (A : A (ir foo bar) -> A () [else (printf "bar = ~s\n" bar) ir])) (define-pass P10 : L (ir foo bar ignore) -> L () (A : A (ir bar) -> A () [else (printf "bar = ~s\n" bar) ir])) (define-pass P11 : L (ir foo bar ignore) -> L () (A : A (ir xxfoo xxbar) -> A ()) (A2 : A (ir) -> A () [else (printf "calling A2\n") ir])) (define-pass P12 : L (ir) -> L () (A : A (ir [foo "I am not bar"] [bar "I am bar"]) -> A () [else (printf "bar = ~s\n" bar) ir])) (test-suite argument-name-matching (test sub-nonterminal-regression (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P1 'q)))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P2 'q)))) (assert-equal? "calling B2\n" (with-output-to-string (lambda () (P3 'q)))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P4 'q))))) (test sub-terminal-regression (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P5 'q)))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P6 'q)))) (assert-equal? "calling symbol2\n" (with-output-to-string (lambda () (P7 'q)))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P8 'q))))) (test sub-terminal-regression (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P9 'q "I am not bar" "I am bar" "extra stuff")))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P10 'q "I am not bar" "I am bar" "extra stuff")))) (assert-equal? "calling A2\n" (with-output-to-string (lambda () (P11 'q "I am not bar" "I am bar" "extra stuff")))) (assert-equal? "bar = \"I am bar\"\n" (with-output-to-string (lambda () (P12 'q)))))) (define (ski-combinator? x) (memq x '(S K I))) (define-language Lski (terminals (ski-combinator (C))) (Expr (e) C (e0 e1))) (define-language Llc (terminals (symbol (x))) (Expr (e) x (lambda (x) e) (e0 e1))) (define-pass ski->lc : Lski (ir) -> Llc () (definitions (define-syntax with-variables (syntax-rules () [(_ (x* ...) body0 body1 ...) (let* ([x* (make-variable 'x*)] ...) body0 body1 ...)])) (define counter 0) (define inc-counter (lambda () (let ([count counter]) (set! counter (fx+ count 1)) count))) (define make-variable (lambda (x) (string->symbol (format "~s.~s" x (inc-counter)))))) (Expr : Expr (e) -> Expr () [,C (case C [(S) (with-variables (x y z) `(lambda (,x) (lambda (,y) (lambda (,z) ((,x ,z) (,y ,z))))))] [(K) (with-variables (x y) `(lambda (,x) (lambda (,y) ,x)))] [(I) (with-variables (x) `(lambda (,x) ,x))])] [(,e0 ,e1) (let* ([e0 (Expr e0)] [e1 (Expr e1)]) `(,e0 ,e1))])) (define-pass ski-in : * (ir) -> Lski () (Expr : * (ir) -> Expr () (cond [(memq ir '(S K I)) ir] [(and (list? ir) (= (length ir) 2)) (let ([e0 (car ir)] [e1 (cdr ir)]) `(,(Expr e0) ,(Expr e1)))] [else (errorf who "unrecognized ski input ~s" ir)])) (Expr ir)) (define-pass lc-out : Llc (ir) -> * (sexpr) (Expr : Expr (ir) -> * (sexpr) [(lambda (,x) ,[sexpr]) `(lambda (,x) ,sexpr)] [(,[sexpr0] ,[sexpr1]) `(,sexpr0 ,sexpr1)] [,x x]) (Expr ir)) (test-suite pass-parser-unparser (test pass-parsers (assert-equal? '((S K) I) ((pass-input-parser ski-in) '((S K) I))) (assert-equal? (with-output-language (Lski Expr) `((S K) I)) ((pass-input-parser ski->lc) '((S K) I))) (assert-equal? (with-output-language (Llc Expr) `(lambda (x) (x x))) ((pass-input-parser lc-out) '(lambda (x) (x x))))) (test pass-unparsers (assert-equal? '((S I) K) ((pass-output-unparser ski-in) (with-output-language (Lski Expr) `((S I) K)))) (assert-equal? '((lambda (x) (x x)) (lambda (y) (y y))) ((pass-output-unparser ski->lc) (with-output-language (Llc Expr) `((lambda (x) (x x)) (lambda (y) (y y)))))) (assert-equal? 'bob ((pass-output-unparser lc-out) 'bob))) (test pass-parser-unparser (assert-equal? '(((lambda (x.0) (lambda (y.1) x.0)) (lambda (x.2) x.2)) (lambda (x.3) x.3)) ((pass-output-unparser ski->lc) (ski->lc ((pass-input-parser ski->lc) '((K I) I))))))) )