pax_global_header00006660000000000000000000000064127105562330014516gustar00rootroot0000000000000052 comment=1f7e80bcff16766ef419183169bbc343db07db0c nanopass-framework-scheme-1.9+git20160429.g1f7e80b/000077500000000000000000000000001271055623300212775ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/.gitignore000066400000000000000000000000141271055623300232620ustar00rootroot00000000000000.sw? .*.sw? nanopass-framework-scheme-1.9+git20160429.g1f7e80b/.travis.yml000066400000000000000000000012271271055623300234120ustar00rootroot00000000000000language: c sudo: required os: - linux - osx env: global: - PKG_CONFIG_PATH="/usr/local/opt/libffi/lib/pkgconfig:$PKG_CONFIG_PATH" matrix: - SCHEME=chez - SCHEME=ikarus - SCHEME=vicare matrix: exclude: - os: osx env: SCHEME=vicare addons: apt: packages: - libncurses5-dev - libgmp-dev - libffi-dev before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew update ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install libffi ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install bzr ; fi - ./.travis/install_scheme script: .travis/run_tests nanopass-framework-scheme-1.9+git20160429.g1f7e80b/.travis/000077500000000000000000000000001271055623300226655ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/.travis/install_scheme000077500000000000000000000047011271055623300256070ustar00rootroot00000000000000#!/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_BASE_VERSION="0.4d0" VICARE_VERSION="${VICARE_BASE_VERSION}pre4" 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_BASE_VERSION}" ./configure --enable-posix --with-libffi make sudo make install popd # vicare-scheme-${VICARE_BASE_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="http://scheme.com/download" CHEZ_VERSION="8.4" case $ARCH in i386|i686) CHEZ_ARCH="i3" ;; x86_64|amd64) CHEZ_ARCH="a6" ;; *) echo "unexpected architecture $ARCH" ; exit 1 ;; esac case $OS in Linux) CHEZ_OS="le" ; PREFIX="/usr" ;; Darwin) CHEZ_OS="osx" ; PREFIX="/usr/local" ;; *) echo "unexpected operating system $OS" ; exit 1 ;; esac CHEZ_FILE="pcsv${CHEZ_VERSION}-${CHEZ_ARCH}${CHEZ_OS}.tar.gz" retrieve_file "${BASE_URL}/${CHEZ_FILE}" ${CHEZ_FILE} tar zxf $CHEZ_FILE pushd "csv${CHEZ_VERSION}/custom" ./configure --installprefix=$PREFIX --installman=$PREFIX/man make sudo make install popd # "csv${CHEZ_VERSION}/custom" } case $SCHEME in vicare) install_vicare ;; ikarus) install_ikarus ;; chez) install_chez ;; *) echo "Please set the SCHEME environment variable to one of: vicare, ikarus, or chez before running" ; exit 1;; esac nanopass-framework-scheme-1.9+git20160429.g1f7e80b/.travis/run_tests000077500000000000000000000004201271055623300246350ustar00rootroot00000000000000#!/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) petite --program test-all.ss ;; *) echo "unexpected scheme implementation $SCHEME" ; exit 1 ;; esac nanopass-framework-scheme-1.9+git20160429.g1f7e80b/Acknowledgements000066400000000000000000000006201271055623300245120ustar00rootroot00000000000000Acknowledgements 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+git20160429.g1f7e80b/Copyright000066400000000000000000000021311271055623300231670ustar00rootroot00000000000000Copyright (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+git20160429.g1f7e80b/LOG000066400000000000000000001153541271055623300216540ustar00rootroot000000000000002008-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 nanopass-framework-scheme-1.9+git20160429.g1f7e80b/ReadMe.md000066400000000000000000000051351271055623300227620ustar00rootroot00000000000000Nanopass 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.chezscheme.sls -- the nanopass compiler library as a Chez Scheme library group 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 lib/ -- pre-compiled binaries for use with Petite Chez Scheme bin/ -- scripts for managing the pre-compiled binaries For more information on using the pre-compile binaries, see the README.md file in the `lib` directory. References =========== [1] 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] 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+git20160429.g1f7e80b/TODO000066400000000000000000000026451271055623300217760ustar00rootroot00000000000000TODO 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+git20160429.g1f7e80b/doc/000077500000000000000000000000001271055623300220445ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/doc/Makefile000066400000000000000000000010611271055623300235020ustar00rootroot00000000000000# define default document pathname here # 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+git20160429.g1f7e80b/doc/user-guide.pdf000066400000000000000000011151471271055623300246220ustar00rootroot00000000000000%PDF-1.5 % 5 0 obj << /Length 537 /Filter /FlateDecode >> stream xuRM WpҚ NU[5+m^j=$V%lǿ`H{PtDmOIJ™hw@L "DDj~4eyA9fv% WLO]v#FJy*4R2rC9(-Q.*>}kMb[&](bv9Ĕ rV0`+e,&Fu<0pDSQS\3!˹9blfZt[ m5:?tg1c#`8ij on&u(W/*?IB/O0k!Xsr~tl;$,:o/J5L200 O WJ3s.e1CtHKiRe >gAmĹWۍmg^94$d;%W֣UM}i H@y88b盘}ۀj]> stream x3PHW0Ppr wPԳ432SIS07R07PIQ0Ҍ 2*E]C/ endstream endobj 21 0 obj << /Length 2818 /Filter /FlateDecode >> stream xڝYKWHUorboqRI^>T$ɯOHB" nC+:</~>Iqy.">q&9|oΌSRd:g^EY(\NYDn` vvy]y*eU<^t5SAᦧ {Epug^ƏLO=M Mc÷ܸ #O|3S롻֌Sx<0X.; dO1r,[$&tǓ %9Q4*XǙN&j8fU鷢JU\Z٘ͩ[%*LZa07B2w I4k\"ՋTgN.STaZJFkHTXֵ;X S`GH3R$˴Ue^$HHaƖ‰΀kpbg;UX DnLc%S VR·DC})i$5h{|=>0Mܾ2A13mav|h/Ry,n&a5P8 u5nu}?Viq݀ /$yע (k @f81UNf4E`[E'D$i'qG@ r@FM=#xZ,N=dh~I*3t/W<:bEMiVdGa;a@쓥዁6K|GV4^Rwl ,E 0͐{g;1+p1QQR-8OIC/cnGSB1_ؐ(7Gh ]hLm/r5nnGQKQ7({K.hye [gO{y },8S")$wJה б\Y) _O3K)qWȷ3 k@b vڻ5䦉pt"*l-z"l@40iMV:LI[ :EZ#vDe ,ڤ'8xQgњݒ`JS2mJFk rMkr4o; ->|v>Sb&db9 )tݐ麑"\#L8|Dž (f;Z6{ IusJr97wT%&j:^-;8:7fY ^# ޱcp !v 1N/Pᴂ;7g;ZIT%X$ZlC׺1V  ",/5r+)~ UUv&Z{v?_>VaV>AY Ii\Iƥ8N?)` ڠ\gI!_RDKAk #wy/TI JKiGzz h^"@*j[Ter_; 5R_Ka} Hꗯᆟs"q{/X^P:*?*?V0D*MdN+ʩ|[[iBI-hu綀Lsnl[q+VY3\M~' xɶKt[IVh $'e `pnzȳ{),T1 endstream endobj 35 0 obj << /Length 3709 /Filter /FlateDecode >> stream xڕ˒ܶ񮯘#JC|m)Se;֦|p|]Dr +m>Ps"h4ЍFx}7CVyO">Iyoo߿yx0bL(O~;&IXe2~{̫HV\/wqOzE؁nE*;Ut%řa 9}G43N2Hm3 Hw=zr~uOO3{T*agp*."?yBgҏtޝ@w -6 󘒩Oh@E,`aa$0C/zF =^.(=.J[L g=Haa:>2lA,i_v֘%ĤBwe8k3HJgG?+~rs=_ZsM2`vv+\q׏\@I,* :"t>ϸ^> fψP\Xkݸ!U#F G#G϶v03MEp:(}wI4A6y|԰ tǡh,q_|GWrt0s߿ϗ{t%>4m/ٲ6[lCpn.r%D|kcݏsrbpwf)o.4lGzѲ !ّt܀?1WBUX ,nMcnج;;:4QHpPe(&Co+BiBI)q-Ck}"U/yIgζ`t`gZ*-=>Ѣ%tkY fReBStO,!'um.t{@{3EDPgƲ0\ e̘ Gr ˓@k_k\`Mfy| {'0i]M˓U`n--ѬBqqYr6x[8-WX~'t/0gT ܁zD㔈U4,z0[H6AF(@mxWnE)9YD9B}LJ~k'~G,dmiG~n`v2m{6XGt[iL@AK6Ru BKlc:{m Fla`vyK F''1G)"n'C 9*V+_#FVÄ2CewTbyࠍnxcʖ>r?ڻBgBA*9Xa; F;7;ێb=~)IQqQZOmc]/دn}fOh#S@'Zdq3MxmEԎ|#J=GJ2pw ^GCV39^K-҇XUa>;z0FJo(TEq g|:n7tUy4,kBh%Ơ$Uy|-eQ"SIטovzrE,$$x5\d1_ 6}yĻb(I* HFW8 JU )c*z)4EI="4G^nQ%*^m A8JJ`kK1O!*x>4O({D\=kxUa\ g]Cx*JmRH %ʇ,_(`œ \tsj_)ͣ[,&i*!Z%(\BRJ䣼-1"D/)s.Jܿ{'y'n)\Ts1'`h k^xɋvݰYrꂆp{{~->Ѡk*Ee|(TE>;,lHD0FJSy,D4Y$I(ƁE m{<4gIvB3/VVDRM*R pD"\h3\|N)bD0{plWT4k!BFZj}fÝBN6T츍zd28!<:KPh:ժ}qۜ?󝗫֯;\E {+m[jiKR,_pbF}d>2hPƒ#H)\ŹL!l孠 *FZ4yBϾt%, TS|g1 H1M$tv[\X_Y^/a4䗙K r\sq% `@Czf\˶5 k@eY@{g¢Ǿmrb({BFR,)zM ̢mHƬE>slZҿ'zʈV"k.\e[y7=RL,i-_r@k Wt%oeZOsc6~ӸLwx G 1GN '`(} "8eM,CZ1L!D.\eUMJ$h E,. ǩ\ٗ_˵uQO8d^0ؒ\"|X$"u5l_+Kf̚HC^Up}H?>Us GD巎kj:_EjdvuC,2d#pWջWBUկE.3,`=||,UE{FPR!d/6%-R*S`5R%| @{J~P 8ú-uNSWse2vF)BRzMq-*6™?8^,%Q AT3 ć3O2bZrc/#7?aMk Wv'ls~hP| άkm/X endstream endobj 48 0 obj << /Length 1407 /Filter /FlateDecode >> stream x}WKs6WNB$@R@5=qLJ.xLfeTi>[fE:+|>$RQ\<<R|Z,zů cƇ7>s),D,YzCߏ_V\'T.8)!rUÛ8L "Yiu0A\fc->jdj߂ VC;`:~}Ɯ hΆvmY#+8y ̩[v}@BaDeqb[KM4 $J'gQښ֋0'6Af6 UFpi7]yӕ0]6ߐ05^ӡ'=X5DAdk騲Rq2Jgܢ[^lϖFJ,02Lp 7T,_{g<6_JD2/A [~gnvyW\/3hHBlJ'R)ZO>7r]08p.\?|XΛ[8jB2t!YQ"ЅNdQ^&kwv@Rp]uO(Y4O3SλO0 ֔Br;= W U1pO$/)t6jc:e߼o:b=;ۯ.Tu<$jC q`XV~,a9FܸԽf}$_5 ,y.XX 9KT$UxQq*MLa]E1~ A7[/ A:}46xvO/ -iWdX!XuM래Ph/J2EV7X7XWy8%gT9DT>\^&Ej?_|8xҗpmey4/~G84]RfTgq ̱;o`TTDA+;S=B>_IQF 7> stream x3PHW0Ppr wPԳ432SIS07R07PIQ0ӌ w36D76434j+qp q 566057 4w uev D endstream endobj 58 0 obj << /Length 1489 /Filter /FlateDecode >> stream xXɒ6+ I%C@"$- h> 45'90"fc~~y/^%$M\=V[ \A6g2b YQ+b)IVPIHhv2oU?p90 4_HY:GYV]2,: IcUus{ӍݸfY%KPUzMGˣRuYVXހ>2jxpjZ{`UV9߭BJtw۱9\ۅc][3]+}nktq횾]R{UMeԈ2jw #t 1ySu(*2_/n/)[Fsui1`c)F_Kg>m__qc$;j&bP5TFKB=Oc3Z=DQf:f)G<l&q[/]a \``tТMcd'AfR (,ccY6iIau0:ŀڞ[\k}@+vw̌xCOd#LGYw]ʯ<$0: ; 3Ιf0!@T4"2E03mq " P͙q+rMk!߻.^`2jc#YsdcCpՏ]b52S}SkV.%*6M4G??$2)ju|T JN +0 T rOC_@og}͗@Yf%R_NA&ћSor+ ,8-yFo"/tO?SR1ug}L9'g l4#$}H[ۮ'>a<'T[쫌K ܭ5FG>FpMsØ'8HحZ5R]E2%Eƿ*P,P*qvbʠlO}q߃>)y/?wWqDR{'JC7S:q0/scqeqJ -6iG!/X*YP;}^.&Y}p kAkU3ƑjM4/7[+ ffc,Gzkhe\e4;km0 7EWmE^ʑ\a\2z4vKyfg$eKa6_ q''0s vG:ʊ`YZLy\s[P@x ~p[Bf8Eזs0+D"7݆˶2RBp0k?L؅1IPW6cyo endstream endobj 67 0 obj << /Length 2538 /Filter /FlateDecode >> stream xڵY[۶~_}km" \PڰY(Ȓs/z^8l2bl)KLS xIXЍ;@(==5>LcATyed vw3'q8Xg6hkf8iyz3`I,?U@NҰ$NXb`.fxb ӪG < c93 #޵LA:Eor,bPi ;|!D{S0Cg3#+ֺzsFUفaRmZ߳}Dx R!>%*[YeMe|]۬&OدLD  ʝ3!#:fmsfq'3*7tY2fޛ$q8OJ*F9 1䫤K?#?]jO9HZ8KH= !֤4ȹB0Ap' &h^$:xmpLk-I XPL/*.#t!Ǡ8ʷ7EN3}| 'l!\6kWЙ9Peu+D䙴+[wԵq=D4+*~WH^TUui*חL_}ow=D[?蠶ߡǿs]%i^qBmFPE^ :#]KXAOPlC&Ӕ8ut6 "\~D6 ws%3^C|soAAI^ad3#0O&>5}?d٩hp|txȝ*bB.if?A Ht|)D }3=ȉ4 b3B54QQ Q Xl,# D` lLKwIMX4C﬒.܇:CH6G/{ 9I<}:)ݲ&$crMQ}2)fCQidx87ރtbC2s ˾VeXfNSL-گhr>U5uyq4;o,7L" _ /]`0 0z{M(~pT[0g|.E!QI =&,ΐ&$`9Eq8X;Kb| P#tfV M|$:^L37Tǫ\U*Zwn^CBT65Vj ,]o>|kVq2 !=;Q>P\1!!rhDhWk_}LƎ &$h8@ڷߵA4J qٰp Ӱ5[ 3uNߜ`gi>悺oRzud\m>rNG*|ٷsM.|U L޳(} X ¸mPN ˉGX ^.qs fW=-u?7 endstream endobj 73 0 obj << /Length 2947 /Filter /FlateDecode >> stream xڵn_1y9.@El <:iIrH-ɱ|}nÞ6Aa_Uu&޼))"vM~VF"eYw>}j~x%\ݻ|B*EJ;^w7ոw2%f'3S|83^z} _?dh7;GERLv?ؗ4jwGzTٵRF초0{;U2*H1WkpRG1iXx8lf+ͯЭxa7pA,=sD mG[54W?'4$p@ASvZZ5)N}xh d‰c &mt',xCoV62˨Vq*ݛh)%l’ u[5 8C%,NL$8L4=bnz4X^3q Bo@Ye>=Q ~ɆgyQe{N\;hE~Ո6eΔ>~ xK I{k;"!Yz='b|kztmS&Au3|BgE$QZab^jdIf$i` gqu:#% % |*Ese%ۡY?Aڂ6`dl]bZ_ n6F(pQCVh/҆ETy^miPwQtŁϗc( ?]g(eX̮;.JG(u25BA7;XP ѣ"(\J/ȟʢBI>E %,ښa*ADt:D"º)6=vA 2G0~̿$w["c&RC EwltZyxY"pڿG9Y$R@z%b퉐zp&H*VԷݻl,|t,B^P>, L-IT. 2AXR0*O{ ۽X? eL TY{pIP?p8 L8>:ïH>Zht`"!]nK~^m_]u75zBdQBv*.Y]8υ2cƓ-Ӊc[~I+8kk9-ĕZxn(*eMS7/{,#'8A0q&[CcE 4+5p}H.o,J1UXaYU7 @ALIĬ7ukv,}C!Y7MQ}6Ec!^9?Y=wkWٱ?/ 5q8pɏf_. Sc_Cf:x$^$ v#%x(Jvz`tO1N|e DGzKJ*j> [KeM=i ovgN4$U7=dOcjڅplbA~mz"[[[ 0U-H۝f#w)FiL5r:fyuojW\@F1P{3u\C\'(\NX<9|sJŵ-"nj/8\w5aP8<]mNjpDrA']/MLjE?rW' Iڕp#Wb=]֬PFWm T1>VCA\a MFl\%> stream xڵZY~_J^)qp*Iɱ,˥R9H.C_ƵJB===}|xs7l {"R&¤a+ 5&npfkUį KiTxCBlWqǑOHxikD \H eW\ Mh)24޹s DmۜlKbyRvmn_/or mD?': u"pUG7ݡw+JГ v]Szݴx`\~)vd_[+dn`44()T2Yʻ.7[3vG '9<^$"Ҭ&C_V忽1kѳ;D_4y6 ^]Cqs~2z s%C :LmӞ@E ?_v4;hkfY^bSiUH]t?)ޏbh=gNw[n; ^Ef$^7t2e -SdAk~oyhOh?b@Nt #i*96]ѥ݉{Ǯw}s(ymq>-|Q>UwԐE'$p&֨T-NJ7@&7Z$GQل5 #QsL0j}_-,EݜTmoԄ" LF^IWoZ*t̽}y8M"[;-Ųyz6k1Hl7&9` UyІM=w͆зEʑ\㟱4:PPDžCSywDuÅ=lgXݡqXMRh,Xq"}w÷7it_f1 1ǂ}7K P/hL"g&Ce2(s\3RnLf0D v s9hT%# ՗Ut}Q[T'79ix3M5vqhz^cAs6۹;5ĶRoH766_LN8D8͇N[*t-$zwI QO~䂙4 -W y[.@q:˾9HW% 2+LȬdHkaC A{#(r*w,|'=n S,5H\.[<-P^ҽyf>W/ed@& ~& |t!qWu `s$tGUXr%}BIiryIEFeRDoar)K]$qX*CxI?%(jX}aM4=]/8BP> =L$&lBUa6]ҔKѹyX-=kɀIKCD0!f$$rPH!1^=R`vD`p E/ZcRo[~3s}s:O~01ǧYg@~R1G f3svm sve?>1Y#?{9$X cT4_8&O. Zw"ctS_hj-ړ$rK-Ӡ}IВb I/, O*?=騧4p_' R _Cp hL t̊s:ôdc6 T}|z8?p" k(IXQ: *c(мPz̰:K-l;E:5޾o ! Q7f~@%\- +۲ xSK?ί=0_M닿\}LBcVhGA>g5ƙ 1l?fK4b0 Y)b34 xT((vx~A ѥiˤ2 eu#hZ c3=Gwr:<2yv]rDLz Z0U/b`cU~w,A_ƧTX0=(1#:N :L#CKw,> stream xڥ]6=rDR&!>t8lkwV)Qlp8ƛM7?~|,~M*-L.MMt|I)o?Vͯ?PڰXQĎfw"3>]_w!NEy<]G_m~*qI yˣn9*ǣ/ljGiOe]FAgkR0(XC "=u^uEuIqGpԖ/!F/My|MB݊T7/Ox7ǯoSӺ/_a;nJRpM@K&\8`_teBx2m//gƌJ<>#.2`TϱiY$S@{ IRͲ,KQ$' YC{E2B PfH@"C?\+ƓM6\2s'ցe&ĄC!#WuDz~->$D& %$f̣ȺJfZBcȑ)dnI*aB)lYJ/4D46BJ;Q'ޛ CI]y9_~r 'Z{qB'^I`xdXV0QLy/xK,U)p6Qm#>)|yYwm\" u~洛KZ"*ђY̱;r%@3'̄iPix,IWN[EJeEL2({ZudVJ!Ba쪔KQn^"4TInBDM]E<:59fJ1G ԎWmlVm']%n zAP.Դ*hUGJ֜l3\Dr_MK*D\AAcA"Ց6.Vd GeS%4]rA9{%UPJ[.9 "[;eaustކX" K{ШLw`HD6օ+2pQ [TXșnq$j8dsqwdYa<Ԛdз$<ok>6rh:4i |~.}a3Ǧ+3"Y5_Ṭ\#99S#(|~"0 $^%rvAW>V05gpO|rbc# :`[7mi:Nļk!QA@rOjsKOPwJRsiHSV-tJ.X\&EY|p'2>GJgq8@m6"UA/PE~,!xͺ 70kZ,N73fCMG d~AA{g|lI:rvc}/e{7;lZ~p?Q:#xQB,'PW=ÙGctNޕzAH_Q/&cwB+c}Qxiy,X,eᏓ Y endstream endobj 90 0 obj << /Length 2548 /Filter /FlateDecode >> stream xYKP$U`$]嚸&pͯzb?xgBO7wZyRXany.TΖ u5FڭX$ yP._:0ZӸiu*#vE=[Np'9l ,WmW[j-K)E',:at _>w8~$,-9Ol)Q2G0RHrSҟ|L %|sh̼<`T]USZyûrP \C)wcYd$2%Ť$J3Z1D+UBt I5#VH&x|؄:!,-p Xmyw9<:Pxg'XK1F>";clFǟU@֚e]69--}wuɧ*yzxpXÃdp8f;~\>Y;'i;<<18u!soq_v0qo/ MSץ%w#G"3{Mpda)ܼ&4)4 !؃Mʣ9!0'10ґEg/@7!:rU9`|]KA*S8?4vco}sfD2Ahh"%1ckz Ǟ H_!]SmH!EIdN+{`zS w\:Noևo"1O_f(jM86DTD}L(|\fYi?!a=`J`m΃;3GVA<ܳT?@r&XK#N>rQpL߱HIoKSd=(&9,e1 v b~U¡Q+|Bn#(}b+8U+>`Bf:z9%pBC)_ Ӏ$킨P&=ӫwl*ٗfnvca3Ygy(DrBND>2ʘw 3~ȸ:Z`v^Q 9NgV!-\i9]F;c9Ug)fM:]D%Y{z(%r!{',Tkw#A,r0 h KreHBdolٞCk)zRĖxl8uS7L} kj>R[ħQ8qeCP, wu `Д,hI+ƗF s#Q) aꏂv'K,a 5(Z]Y+:RMBi _?6:_uD ~Fgm f{j"ƞsd^ES},kj *v;ǩ?Km@ȎCOq*hTki*a k̭#p6sa)Q;/ p |Z}Q $R/1J$MQH>n/'\ r 4l};rηbHTHQԜy*iVZC,G;3 Ie4 Olaaa!,( [T'ȇu.`"ܾd> stream xYKo80'Kf^lwtX`fPl&֖ I$~XDLɠ{$>z||_o>|,bU!ˆfe)`17__.2)_~Ӆ(_]vϏH%˥.qȇܯB& ̑4ﶳW?sIUJ)55h5|`]lg:N5/% &4=mƇS# zYw_ַ[m 臺]gvZj?t ~X ;ƻ}G/Æe }0,(𪙲 и9y`3LĶR)5=Z*m")cV#p2hu;@33}v4n#55b3/p9&s]5`"G&'kY^Mw99>}~8|>u*YW b٬-)J&5GzX-6`հ}ǍKox]٧Cg{P/)51Kȝ~3onմzT牐`a?XTbwbbǕy;8[ + 6tTY: A76@vnKpA =i)z b؋frRW SX]6sʔk# 87a5p h-c!ӥ9q2g*#w;p3BRY)bNQT1Q.D7|Plt!)"&]izl͸[ng/SWR}%^,f]AB*4ҳCR~| ˂uMyJxxyj^hܫpޟޚrxIxґ٬bG[zm@Wӕ)|9f1H 3YOYGgYmS>,GXb@^I?/⧷EĤxKeByFם719ʿmNL.= xqeg7 * &_48v3::9I=B'bvyu4mjΣ8 e4;3AÛx>1#ۓ4&ar hQ%S!&񗻷B-y?AfKH2AmJ"YU{BOS@Ñx\ >ݡ\ R tl=s%ϟuf04we.2+0CPDḤ?bČfCg_)Y#TRJ  qĮf|XՑԄs{/mnӺt7[:s=`ۑZ`i# di4 @x4/&}>M8wrɈ@j)Zo [xs] ~?ms yƖ5^eK~C6)<̺g|>M%*~Z=h37qt/&DJ@dCM\6fHG eJ$P!'[~9_8b=JrD G@y$@F_΅5FڒP*mD p@ G;+n18hX[s뜣*2 4*Kn:n }d'$"A2mFY=^yF6CÞ?"O4#B#6׆RGAS?5]]+Jħggw6hr7^mݻ7m4o6VMŦe |x;<vG8&0Uh\mކ,旣q!r>ovb!~,K]?*tSiՏd) +>u-X uX.o8rx^|gI endstream endobj 100 0 obj << /Length 2313 /Filter /FlateDecode >> stream xYsܸ _ډD9i:7ӸӇ^6Zr%m>brmH, H۽{W?wERd"wZwW񇷒 (`ao>^eK)#co߼#ܼ뛽ѻDzs35>s}?LjRlNu_[Bf'B{eR~㶼!sS阛aE㩦-uGSտ0ں?g׵Vnuۡ鬰ù Oё~ޡ`"dY"Ŝ%ǖQ^"ZEN dGuu"{P_AL^8xޓ:v/r]g%v' $<͡<(c$|KMɟS-Nv^A+ϢSB_ȣ֒G))UwM[cQD}*;p )}=*'H^ĩRG`S9io'ѱ;i3DMtlr.SֽظM-'ڻ.>QQU)!p0Fn8sj\&7hނ؀8X! l"Yrñ3@&blc> 6\,U!Hv57X"Z;^|zxБ \L:/:.)5˹6…9U ܹQ~_Θ13߰IX)CXAr*' UZ@ż3قOED>kEҹF"ah GjLC}O(LN6n GǠ*(ȁMds,>,f th`7v]yCs>lj9tvi'45;b&[L@#ECqڱb! 9me_{O9>S>ƀ0.}oJXQ64=!MiuӤXIQU8c[9svfi \&Besdnڪ}ItݗO c}O=3eL tegms[mimfm`s4R]$ԍ"5Mt'W\GB'%P14a5D#%طET K\ @@on+22guy b~?p:Հ1l؂QJ.0_} |&53 @˳BdJ }/`sLm (LrTc[Ez>[A3#Hr!k_`XGW-H~ ?vu$ aŋv7.[C!JS> stream xXKo6W7X)")R{(R4 R,E =%W7ο Öٽm/9<8o gY8yqu}', 'z&Ltgy<ܗ2n\~Bxo>q3wqt # 41,+Ww,0Q$03K ;dr=֔VȼFHjM}bZо}TJDZ}x&ѹYu9k QV;Zk"lU9YD=Ku]GF2oHO xր>cAڲ*1((ՖS $8+#Q|HCKWն{_WF~XFv[Y Xe'-Qdmp{;*FH`6xd‹.H4%6J,q*s.J ښ<6LZQa[ c%wZkܞ~K@46EQ^qOY0A5T鏄Z:u1{ˢ-K#eغdZ9PsRAQvֻ\_LG9 izu].8emQ-,أ92X2a jKQRo1 6RwÐX#SSt 2Z5$t=j[]niaGmz7(J3CY{ci8.ٻy*j@z7*WRM%@9+ 0ik0d%R:a9s )PPL.M,izߟ{&{gF v2-]2SҾ?zm[)'= ;d1 Ɂ@8'oEoo 'Ч~l^e857䎵K՛v 2n_j8{M% endstream endobj 109 0 obj << /Length 3170 /Filter /FlateDecode >> stream xrFޠ8<0rؔR.W=82D EA@[ޯʒlA<===W7pɏWOHV)KЫ*X&|6կO_H>Z bi /R@u'O_W/ig^مгW?QE7o`0= URTZ εC1! `b͹!WUQ8 YۚhiL^_$@LdHc jn?0bF&m쳮Gm)x49Qkk\#FHшp| =7ۢ2k8a*rЊR2hZ)@,MvKQ!ȹl: ,% ˊNH8NN"OȩTHVhhYIPp gm4&7e©s*-n7M 6dI+S(xk淶ٜC(_Dkɋ3%Y\, Eb䒥qz?`Q]h̾dDF 6~5 =L.dV"LY(T3ݐ}x~+ sieGm4-?$ ~"8W@o_ >]0O }@OL 2n>53"{ןcR.Csf-ߞv",O#kKn>cd<%Oe&#ƓZ4|$38cDŽ}vΛޜ*kBxΏX1/h((J$#Đ8WC"YD raF033_H>o!?_ W1.ѐ<;EpN%$Tf<f2I /)?:lq17U<3`EpRĽŌbgL e|iP/YExyDf%e?Cvd gXo!WlGQ1̈lD<Ďh̐= ifGZI/pSR2߯Q" #Τ%[=OM5ߜod K\UDۣiEJ:Xu*v4Pc vy>+#m5J-xe;VⶸK66Yk.*)(BJ2t(ll⦲7{J50O{E3dy/x`˃8l+ VQvXfQ{f7l|ige^`YYchF"EQ +K5Tlt;8 lT2!ka.U* nJFb8@/IlAjkW HTI  TkͦCeelܠ{"Z"pN&ef/,J%$Y~Y.3#WYNG3 Kk2_!8B?^D`7Ѹ]LPmvlIrV2+~ֺte:V0 3%UuØ>u`oZ)#!(%PNE11-$ǡ< ~*(W<˼*.̾`gg/ uF[9MDmkc:+[W7 gt/زĆQUFzZ"~:y\Z^ t)%W ^֑t%&#Djm}%!,L/&bmcΨ? me"٧:Avf֣ tXЕccql$uℏ2L GI$;>f؇ڇ7*5yWN[aQRX\SD\pwcy)3 A rjCC߻u`2r~ZWǍwgwY@KKzT1*ń o&2#!'d`@c8iARDDSm[ 6Y*"}}gzxa]7KJ4``Oo5$AX'JȘip\3:4 RNHGK98T^տ)>>| @>4?h``6MZz'lS#(1s_LƵJ".4CYo#aiR t f=Nd.]f|;=0=qXh? \P^ {9*wтN>|e>}!+uj bƣ'wdr"gD2kH+6ډh 3 ;H)F vpocܛ.[یWi!Aop}8 w[A4x>b]Sl:DG aTE$7N۹.HBݺ*?/4Z%_t%,''{C Ya唢dC'?,p1[˨]|>Á~sI-67tg> M:q33%XXNJӮR&!43 x4 ٬-ʵfȢk+Pc#s~IpB@+M+d;ji’8W{ endstream endobj 114 0 obj << /Length 2926 /Filter /FlateDecode >> stream xَ_Qe$ EO{FR3!Qyʃfuu]UVW?ݼ`,nW)_BnՇ"\oTݯ~yBZ+7׷7᭚ #t U~}S8#hެ2SAwǾۖz4OƴmQWEKju&-v& q# r}N+,ߋ%R.C.t"!!G / <\j+C#w"ˢPe![tluYHu&"IC·ۻ(9j[ELC90K_3-k'Vn[8 = l\Pq܁穾&4t_fGHp(H2shOA,`"Tjpk|Hw2 c-KɢrgU$!\GPn!n(9L㛅~?P?$E1Dfp-]h ;NZr8]}i>L[%&Fñ(MNFjwed,>bWt4="aq4_rIŒOV&ZבGC MљQNxN/-'v:MHEc Xܟ*" 6N`º)x!IJhbH!lnlxYPf[ä7oQWqG!'l?uظ=6\!*F.lj f|00d#m& "/6csa?]Xv"͗Մ.'䟭-c&al6_GV7׷ξŊ vRl\}Lv2\ֽ)hIYd$_&!P})e Vu7p{0㚹wU%jÜPϛڦ(E {C΋0?ex _ԇ\e;~86߉pAYbɜߏ߁_eZvCިb"ԙe,0Kk)巺9J>bm",[Ea̾A*d_pyY ">D|Yye:"F2f [:% VE(LF(L `酨@^ ,L.ϪsUAB^Ki.9}]wak k<1lϹ#>uxJ>O3WFl~sXrZeA&iOG#/s >oURQSrn Hi<KeL+5d2T,m,TPd(#v\X_6Q*lfWlT*C‚+*|~Se'uewe[ה`FmMP vUOű-RM hRkRS]ehGδݸHQ,Rں:!h;Z]}uʵN &Tk/VH[Iϖ\u`+ce`]dSH8q0jW~Uj1b1Z'Y.,tI |;ń%6 ,ZYbgX:'l5k]GM9;$:x&\X<rs-}Rl%l!88]b|-m aTb˒Bb;/:31֚ə!X`I *p񏾫"-.":j& Bns뻑w[pҞz^| ,wU9jBD %VUHκ  +"0^4KB;"T5yJYD]gDT骦_X޳n~YucxS{}ۓ͠첬&cy^' ȡ=Sh? M5ѷ8( jyc#4ӿLD/*[ÊXmmֺ\Tz"&3mz7h褦t饛'A6Kƞ=Чp38A!Z!Z"uތk]`*hzuxy`KS{S*dvm[34j^=;ma-;vvq> stream xXKs6W7*>WqZMj/If SĖ"Y], "%trE>>,vaOV{r՛h[qrЋ&D\yNu,I~n~ajzg kb=M]Bi_;V}L0|hiMԍ Qi&4(y]`Z=0y SY,fgu A1V)wQdzo_|HeF ZEwbҸlѪXSF=s1E|@uEÇb|D_ǶtX) oiNx2A0i!x=hȍq#kK] #աUWQGFN8Yc_y#)RN!.4I2tN,O-H( q@170T[q*KKpS*ܔ7KO N6x `&;Eʨ~7}хilv\ÂlB$kV5@OP`30E|#/ uou /Wu G@@`xgrO71.Q$ Z!^40Cٱ#JjnÔXԬ,! CAT;l׷mv).sȞbEkμF:2Y%~imJF(|Z! Tg:;zC/3̶x۶{4q~D=,'^ctzn1z;J8%LP]+V^aU`r I>{tcUF OhL1j,*iJ]__  endstream endobj 122 0 obj << /Length 2696 /Filter /FlateDecode >> stream xڭZIsܸWt*a{0KIekS.TYFUh6&ٖ_pis~o(xXϯ~yZEJ҈G"X$6D*o}xJLDϏ~\:ʄPuM\l(ͫPd1L T]Sl,+epem^B,#1X3H› 0[{6'eIFK]"u%1a\R P[AHw{US2MFL5s,g<@CBDgp9W3C2i^E5j 9 Ge咓 !y٨]]Un PRWfֻ~,#.$"A\̌@FvFcAQY%MevQvRy1cHGQ WSNp+Ԃ%fΒK:>dt`VeU4V=!lȳʬe%pgm)/#uTL'_&_1eł*d:؟gXoujf|`|Oasw%Bg$R$ć j%\,F`IBDȐac%(W&/]٨+/ohz,ar^\â KܢUeDiz&=ȐM䬓uN:"$Y'QzPb_ غ$!ABo?m#zPBj X ye&PY=(NdA νMBYwk@OC.N!d ޙExT&Ag{l5n#   ZmJt29.b6Qڥİ1Y A5a3&JPT~kȅЈ=|8$Tgu,<'%lLS Spb5OMqfDDԫyDɑ+c[do6.rsɠ/g=cS`47{lL1 Sfj}8dnk^סK٥ Zle1K#FTBc9Xlw:v8#+z˺5C}{t! r%}xJzP6,6LJv:[ f' c^^|G% 4Co 'J{+ ߶ު*X)lu6|1@[…m(W2DifAZKN5VHێLf--@x.IоZ=g) /^ 優5\17gI=wF$e(tGCݪu iWf~3>Znsw.uwLN/_q]6>Lhfx N׃nEͅHN{c(ڙЇ۬hr0W6 N=dc3˺ Cg){N>&(eCIv}l_uYs@|ubl\sEwCQd׆/_7^pmyd:X_(=nzfpKׯJD(զ;d֟\pm qLӨ pc>ߞE`^GNk}5Qrd0,}8'I,S$؞]#_dO-S𶄠< [|J^Mڨlԁ"T^<2|}=mGhrM*ա8G{]C ~K#_Ӕ(ȈEꯀ}S1M!Z8iŦ^SC;'cXsx!GGܚ@sprPBc8XԾ;cM؟6gVax~Hw%D0OVSOϝoۛW:o endstream endobj 127 0 obj << /Length 3015 /Filter /FlateDecode >> stream xڵrF`e\"yേrVʛZiOC aY=e*v.LOc=`[w/~~mȂ,zH"Qz^Ub  ^(?7X)2X%IxG_^x2Y{sE~)̮`(WoX@2Hr%ET "ҿQKo>U$qF,0"k-V@:2"nd_^L/Y]j!Id> ( JQ b8c$mΒEϢSx[oiZXIT>T8Aq4\wi /VZ&DAQ$dTE=p#| 4npv$><"0o0;ƫ 2xULu,Ⱥ-hSf*@uZhzQAVmhmOQ̋2-d'X%@]q,bƂjm@QZ#:u4r6FAشY#egyK{T*cke]4`Gfզen}݌t"A$ 2qP0t0qu!#1ۢ2}޶;ǐ2[^*ߙmA2A h=C% Y c|(L0bGB,Z+a8ŘI$ن$4GRāɲjؑV j0c~ZUsajzH"z6HXI~jSl_KZV8 _>NJI1ɲNsr36= L&>dXo}ɛNjTc]ԙXJХ 2LY! 퉐Ձ<}^v,N􌽓9R(FB1ۡBRb{w޵h5փ%Ķ?̅^J05uY})v3Iicm:]:仼/;L|X쀤I(깠R n߬fh#J : $zhL-s,HS#+BBaj3Ad3$ G߶'֥pM/Mx29i>G w|CxYkE? Jqz,q5?GG0.`p4< caNi(<ܛjaAVTR0GOj]:oQM(ҭ% 0S{.\Nug7NN$p{(UhtдF;`Ȇ9UoяG ?9hjOTY&ABAM6Ї;Z?› }S59t,H )d$"bWN>EL*qTsCb͡x2|=-IU+fn&":˜8i[:akR.!8+7Yzg>W,C)hSf&9JZ($d8UmcbK*5[銝w=eݒ SQex-"TqմИo**h1 pkwBk@) ճ"-8^fg@/}Qv׷}6D^h: Bd&y.G-{{EEh:T iޏi V.sxJSLBAKlyWV>ɝ^^#pJvC:e>Q8N-p|} R3!LCzB0}%W{cdqLm xŷ)CbHxeL)2096 s'.u_nhm|;dYcSPk|#NE:-4s$I"d9XHO4i;tls̋Np+U8k,B3 :ǀ&×c\<Ê+Yi,P*;iΧ3&EM5_3=ڿs~#_{>^'5M>og2_g/kD4+mJhfzd)͗ǵK\g~σjGmW]gD-);Uefu47Cc׎+1q鱮w.V{L=#."3I, K\ښ#}G+~AM{8bsQpc$~omwe57WZyk=\?5n endstream endobj 131 0 obj << /Length 1785 /Filter /FlateDecode >> stream xڭY[o6~ϯ0R9Tj[Zd(b 恖i[n%%';!%ђdC#;w]vŇw}wrV7[~3fy2x˧uoww7w?}{0vN#\rPf^%Wsۋ-n@7(&+%5!uZ Ip{*VNyL.W5pg1v0\g.EmZP[ۡZVI} ,%ڌn) Uq y?.N_zЭev pf g: 9;{{0|]f=98a(0+p'CIYl=ӈqSNqS-h:_d4Tmzh442zT1 )ܳ` koO1|etcSrL)A7-MjCT4%wJ$k!Gv:%3{?g3)'rsDة<"]=] k\(/ab㺾DPYc;M@_֠=jJ%Pqmv5, ƶA Ͻ(YJS"!-ĤkY" sqVn}*)VbC\'X,=kF -YN>(\l )F5^p4ueac'኉>OI7nFa@z T]zl)UٳF$SC.l\65.+r XpѺaqP8 Tu@Q%4Oq=*0 $xSȜt4Er̞`fI5S"0ţqGzvtZ |u*dӄ`"|G]<䑥uM" K䇸c]?)v )$4L4I g@Vc ><T$s"Z.܇-@ݏ#NݞeVuyf4g|'".b8.C֚Ok}hٰnS--,S}ky# C2Id/55>/CYJ_BaZ<?3kCzφ y:yap!%{μ J^v{ <qRf;*yhwy% }F~Xfַ[VB&i*7YvÔi^7vbo5 3l4?ŷiYmvܱFcFN3.\ngC_&"e MpӿhKXM+֋s{F?^/Mτֶ1:/~"{KFf-F4_xu^S, { -6U1\_1/K}8F=W+=-n|q3L+8_Etpc?dK>j_``_[ endstream endobj 135 0 obj << /Length 1217 /Filter /FlateDecode >> stream xڭXYo8~ϯ܇āŐE($EElՑ8~(v}!ko>Ό ?7bט Eyh,0> |)W"uu~Դ, yϏ_nNwpTtuJ<]&{tҥr<ͪ=/n{=5\] ^4LI:+*QFɻֵN=.ۏeZyb nL_MB3$wWa:)Ugf0bk}r4M^$c&&eAV_"γVS44qmbOҜU*3$FE4guz ZBLPrp j Ezc}|P d?aFeQ^j:nڳtY"d4 Ôkpt䆾%K$_m4+O:6ٮ5D1n5ni^,j:hGe ͇n~ W endstream endobj 140 0 obj << /Length 1592 /Filter /FlateDecode >> stream xX[o6~кفŊ+֢ÒPlHRc,&*ɞ(;ɿEwIۃ-:<<\HϹs< %! ['"NDc*uQp(r~O.t"痋կ/z?G#YPI2~/|@y(D0G^ lDž`Ck=A31p,H:.9+nR^Ю).rj}|^>K~ҊS` "=Fq0\E=PSҰVhVc>A?z{G8Xr-E燊;ܹ'+Ӭ6]pN0"ICɉ=p*f fk%${.v ?S nmq q;zX碕_3K(i$X[&LL`q ͉>ѝ?Qk@n|*uYSrK;U G}.Olァ!A7aŸ _7Õ:n*UGKf{%e(I8qx#|S=iC҄ X!,ݚ͞Y .c;jچA  7'QU/Y|:z< zsQWu *Jf$*{0Iگ1<0TlZ$}Vo/ Ds07fGV0+Ba*gЁ{8>f}'Ԣ!=IsULUY.N>Ƚp4ZS~)/D~_K6\=DRް|ݘk=XQ& `4L!FaB$Ah׵rLM=E/ǘΗv*jR=)\O҂4axmSm7sV\k^r7恹4i-f1xJ- Vhe9OBjL=˻;g]̮W, $vM9XJ\7Eiy5'Q<#-: a 1m )IyL> stream xXIs6Wpԋ qM'Ik\BR}oͤ$;9by>Ov;˱.?o/߆V"fk $͊ͯ/ߺx @0EQJ/6muW Wo.޾zwuWߟ_]q&Z/_уfװjm\$5W;~~$\5\NA㷙i0lS,6.@}c ٝYY $i^1"E+0Uoxv^$2P#Q9@ o6+<K=@i<6P|⾬`hЊ܎;.5|:^|o&+ 2nZW4dDSǯ1aXcļO|ޟִ+Δio>A>! ֪<"5a=(>6sxiXM{y#qz.Oݤ+E,==p{& > stream xYo6~_!<i6`h:`[U48qYcYv=$#wGQN9RA%XQvh)+\Xeeʇ\XIYdcC_ )gO*}I1)r]}YU02 @E3@䤼Qֹ8B V@T=@GXM0Fj=5  \*ÉqM` 84 cIE FeE@@ q,d°z #j"$Ƅara"#yH -Y44`"*`AxC@ (H42ltHIs,@\`" 1"!BId"Ƌ`i;8qn1N̘7#FNPTWn'h8iqk:LH̸c#xaK·bcA^=83<:9krjN2s'GŁ9*}j(D(8#fDZ"P\0Infx9q[[{"_0ҠYAiʦCSHS޹:iefY #O29$ےR2KLu45i]Ү.r__ֿ#5u\6Y~d: fSġ^"Z{ :Y]Pj'"ul^ ]M]WPW>gsڎ{=p7sWK.W*{kC\WcP__ǵ~Y+?[\Ǧ_ʿdz%-0pq Y4{q8UI۴N]Kv5|`!JKOO/ 8t endstream endobj 149 0 obj << /Length 1304 /Filter /FlateDecode >> stream xYo8_!LKNUa?̆aUrykd{}H xbb F{G!Iy[˯AT{d~^|({"O td$B|EFh՘ ^ktиPwN,6a ,NTnƺW+2ӉwMĢreasIQԏTyYl|T6_ڛ#\'\= hBn)UR)I&UO8biNnLiyE0.wצbAghҸ3nC7ϬkB]4GdǗԧ$0^[lGnMp2Fs7ف7eϚgԖ (ξٗ+h55\/DTw!)FYIE?FթԟqNME:.XTނ)L+(-Ek ?P4$v> stream xY[w6 ~мӝصԅZdu'˺{J ۴,eK_I-Iɖt) $@>@T4wx&1BbQL17(.#ۆ O'&Rz@@,vn|y:{qryɀXt]:0`tu/SORXac*1 ]Q4eI30ں9p אm"]j#:wg!Er:4kWB:^a)?>a! &fZK`8aS3H``J)tw1aX)h_l_D7фLfapy@?҃ oƭŏw맞C p[gE5tU~fתf?!~Ve6YN*+ K3hN8C;&ѫN5朿Oq>RVau@S"b_J_i3՝wEԽףַo4_ _)D4dWCi2mapjd[Ye G4:؈s}}*  W"*;7oZssމakfK'vڼF[gMjkvμgnĉZark:i8:.,%W*fh$ yy_7 =U݃ jU 6w#Q{0tEIFTH9ys߭uKS ]-:Br"hAc2&Z 0Ldeƶ4Q LɈ]"h&,qصv L>wg`4a^^5e Eg{^# qޥ$6B.م@t4ZX_En5 }4P§F%gCzҲ0 a+ TRaRUd!LܦL:N}T_^a,y!Cz kuɎ*NX\jq]- #? HBF[>K{ʗYrqJG2D2 Q]ϨGWL,EL*wf+vbװ.v풗VF[š>[wz f-5pG \A+`ۂ[o>[wՔWJn2V" &]5u7¼ gp2Y+j&R:2dJqUWI ںK`M^0JȚ"sۚ$ f;i&Ƿ!W_E"4LIOI^\h VH\faؐ(Sf~FSQ)%ZUr-^Q+!d'Jt\\zȦpA-֭u_$ zWpL&lIZ\TI endstream endobj 160 0 obj << /Length 2226 /Filter /FlateDecode >> stream xZYSV~W 20E0ա{XR"<[e%M9WW$ dH~g!O;o(tȓēTyCv4T{>tӾ{WW=SW[ܲr~o,gBb'.Rot>>'|o\s8`sj|x:0W(Xxsbcp)'{_M 啷 a{UBI!alIʌ\U$fs+G2E%FA^=w{e3R:`եz4}{8|0dOyu&I4dкjkJ[GxP~ơm}'qaYWRZ4Ą4Twƥ1RjqVD~G?ګAv~WL0r?sPw1_bI'_'iMb>}Ɵ/0+Y]r`F HG!; KN@d=06?mR{ 3R IvW*<<)t>L/XxMv- )!Pja4[pIp!Ug\?]NL$@L0+LE_,?eيI3q0)<*Pz\@BBzHPKJTZ3siR a![`:gXGg͔οncVB0C&5pTu6@Jh*l:ZM<}h!; %,HqC* sX(A/ ~_չEyLI)l0'"cf ^EWa8^Fh7eCb!6b#kllчqEþn5P IyԪRqG*MRhLClʩ6(O%9p,uzX. $\fleY9 a1eiI Ҥ"]y &_k|1Iq헰P5?Y$cV\JW/KV0i.t2YPt5x qai^_|"IQpaj eyy4*ca4|m)DaXrH[5xMRog8wЋ a4Pg^hW =*M0nClIQ\MFd1F8PT7 .>_:JQcmAaIQ^Ufh^Q&XSE.9].M~Kң <6AڒEW>U0j4DK_z'/AR €&s8HU@Ǔeϡt&Z(0nljH1Yo4YÊRŕV0'Ц$X3ח7.0LxZx@b$KcYS)/B6pa ?;pk(Y..C[$~)\^WÇf ہ )uM"/O_`B| %46v_g!L"F|MQ]H\yj%^"zb_dI!}8(^0U5-I qɀim' RDMD_rjt0"fNٜ԰aHx\nHP:XFNAGPVDV endstream endobj 164 0 obj << /Length 2194 /Filter /FlateDecode >> stream xZ[S8~WkuaY:lMÃ;Q5Ny߾G؉@>eI>\c{~;B*x!B&n߻kQپ# pکS;nKvR;ē2O$E)ϧ!L27,x'٠ *Zo>%Y0&`Aތ|hC`ZE6UA,T`7$VQlébGНG&e)nIЙڰ~οp4O9/D4_ХOB+RjK=qGůWn ` `'sq,%+\i ni2# tT1͚@qNh@r=M>%n` U<ÿ{{]xN^1"aNQQQ8?.Ma]$G!#[ۅ2$MJuvYVBHb'a$XXqG=MɌ"_P:ߧh8F'u3_n)#`̂UvK 8$ֹ- e61 Ⱥ PAADM|WM /CU{_^^63It_[9;ׁ? 2H 8ܭCo % lݾ5Ob箌YAXTa(aB!dM+η +>j޲tNnVwZe{hys 1)IDs"cMXa+o{@oȽգ8i!>tuJ[Ig*25-FQ &=Q}X=ݯrJLsk/֚$*ͤ3hD3sB3'F=mR?/F6H/ ֗Iu?3`x46K .8p\Όgx?DHv_H͉$3DU4(;ͦqPL6)t" >! )M`uY&=r;XV m[# ^ wJ@ŇC{tSC2Ħ'VS1\C=ǖ#]vMwN h`ŀF:7NnwyvP6/'+` endstream endobj 168 0 obj << /Length 2936 /Filter /FlateDecode >> stream xڵZK۸WٲhENURReẂJ,Iٞ~); A4_?tsI7?)"qMnaNLrsۛ?/?1yݻ7hu>IMHeWox ,Ifs4<ԥ}}~IW3$%y} =C; ޕ(d cTDzY A$ -盝RI 킼vo|ݩ-]5ExTn/t"2|ºDf6Q˞ɥOK_9;\PVT٪"qS}:y%xG|Bs凓GyY} lc,} Y7t tp,^ k,Nl85>Ѣ4[ܗp$t.6n#0?m(b/izs`'2,lcۅk{-_"f6gJ0N`JGbu<"qϧuܨSsg(P~+ l  0&6/ 6~↖&1==i=XB L, A*ϵfDMٔjen?m4~Z>2;ΌLn<|Z;n${EvMX$ɢe{ݟWO(9t/8iyCçmnE2 <+v6.nYD'7=xEK}]99WB>[M NAqYA,RD!̊<^*"}'4^WJQQ_ y$AkQ;1råAF&96|*6* Lf@FhԹr ?ljʴ }mOu}cekeTE,QߢHZQ" |1fQľl3wUǪf WRˡxS K j} F%Ė_&ɵ'1S^ Z?s&>{`*N:IGAŢ ;'S)䀅kĿzv6hG=8B>9VO0IxVlJ,EDOMYƹE9,Z@K6Qh]lXlbkXkpVa-w刞IR r)Д{/( } dGhZ&Y TQBb=AFWls91}@aGQ#-n 2PvhH>ܨAq5Y] Y,[sQCp p *fw6֦GTRvXu28,>b444abΏ'inqB ِYBWS!d="Xk,h8 ֩1!%S0`T:\:H}E)Z&!*(ƫ/i1浞 6"*8SpӀA*]k8ZZFXW|dX6- \/zY% ~ KTM%ԣzj&kmwdXd/3I}8K0u4)Bt>i?r U_/&x(ByZ>${H`^C?"J9'&FJ , P!g%}9xVDc 7])XI2WI(=Eab Ft @rltaS|V";Xq]Qa{E)ot&jV9=!G)NP9p/*ݲnYSǗ^v2zX0 C(75{㘺yؐe`=Y g1O r1t#F']T%T9KLҏ1D$e*QbZtat0*@`UٹQĬl9=##m{# %+k_sq}Q^ŅLefeFCxҴq$J5M&}?E knwW v1{YYb*ϮDصe92k[ݷ5H2횄0i G>}A1p4+Db~eQuoE~Ru6'y~aW2G̾\`@ٴ]Wk!]V ($c۷bnq-ZUb6<^N6˱O[\_Q"IĹG$Xuߜ@'Ar]6Y<<߼_Ϲ! endstream endobj 173 0 obj << /Length 3116 /Filter /FlateDecode >> stream xڽ]o6=bAW?%+r$!(..탲KiJoCJ /I 3*_{ޖ*4׫UW(W׻/k_vWo 8YUf Ϳ6B5Ϯ6EQ|^x+^߽HK?HJ}[V%%qgnxkN5W4]36}78JCV4X]׆VOr>GٕmoO͗%\ b뎆] L Sif@PBeƧA K1yv0{7j͗f[ny`TzXu7ǽ9!dؐd bonڅ[[;ncow!S􅓾 ǔY{,3)X͍9zZ t @嗭o``;rD5lOt&#b%9_Zɜg9C7!N3YT"iM߶=:{gS _dπ*5ŐʊY]WZ/'F*Ӳ@ njqx Y'Ttf8 ls =/(7v/%OoW_S&2%??6cӱ|/3]pwt9cFPy?[\ N+Q!uk.٥d%\Vd&DҌ?ZkvjEXa.93^:#j7|=X"9}3Y=CC= ܫU";EA֣"}M͊e!FM2t zZ@&sFNeMf.[0e׈pU 5̈́=v)Mr,mtEqAA[.y2cfrOa ۿ=흴Ed񕤹s`A\=`hkS 0|%|L'J&"CҲ̒aom+L+2XfAi*+ׯ1pÜD>d8*ii6Ҹ m͈^DbϠ;A*AM#L3dIj0oG0봫1`4n*aσuWS"Upqexp  e*C X,CzJ2bi `^51Ԯ{\?$.f&viiw6eС| WR*ɱˉ Hz%C*/- TȢ`qdsȲ 59֣q|'NÀ'SA@ *؃ <8 6&Cr\ӏ3<,)s./ޏ_V*>jK34YP z㖈2&!鄓 |d;8`dQj)Ȧ0_$\Oe?΀6# 2 왌00f<E#eX;I,)((9ϹƲrU v5-m1٭Y4t=wЄ? ESWhn${H jZ+0#|y{ W9xɭv!Awx!Gk$4ř5Tj{P7.ǨO D^6t^Rr"S3Ӗ e&c^S|@N7'OhFnŖl>| 2ULպ Sά3lNfZK׎^~LPZ+pH+T.Z.܋%f|}yb_-ɽhe09k2z iLy*9QD< .*-Y4EAhr~@oN\:GSw-|Cփ/uݦ^.3_Ѡv:~mSn۞v&Q5̝ф,rzKY;)"#6 ).UV@li)ԍdn \A&_'}'cS\ Aӳ+.62pŅNBySY.QdrǮ^nA\XO_i}{ ^e:S;t Z C"%*s(@yʵmuބfpjEEF O}:lK$LYQg 1Xw$E/"YЌ \d|n܋ߔ[>!]~1⪄rM;+qJdׄU1L=22v+]1ϥ?E7n!ٮ> stream xrqڡ7C6o98ZU|}P(rLrO7>+sEht7 77?7߽SJ+7N7wǛ_w2S޹bӏ?v|[xݿ{W,kSdr݃P|~70(uhX{o?@鱦͔YV-fu;֗I\9lxG8BV:jߨSPwPM~%ty4"+lͤ(nUT%Je4ajtqlzfJInBd1AfgUZ`*:6V}i=#gv/vH L-r#y!HaG5|hٟ2_GVZ&-÷tgj{d4jN_c=/,hF\ʢty:w)!0 x])nIfhD= ˟.HΙ]y`X+`^ ƘSxaHL;h=V[fRLl/K%vm0Zp 8'X)?_Tљˣy@5Uv6q e(tO8 IeVgEU1h"fCLHiIiT8H`%̴/FKeV0wY,K/dݭs;BzrfF/|@:)r9.I!^A )7$O(N֫)[F > i <#MD5fjaE].<ӕLP kE F.=ܧb,`M}5ுr긒}:8h/QX1m[n gL4pMrmj2Dx²$,и8U(=VyL-EW_qni,}2Y<5aJױ pKJYzj$!I >[+DHhhF>^ $6vr }\/x e~ejv_F>OU$ҿ*g x@ejpmj3zUPG8MMq'cŒ s+-Q*5G[t Q 0\wʻ8i[SGl O<߻d`r $u㲄`5 بꀊ@~5}YOgĻ orGR|k桫&@=u[GLUۣVmv\`ƐpA3(cZ_{ n3 hv>Cyu'wDW! jN#'VasXf&ˎS)e 1jSMBp 4tQʿ"{fR9Ř"|ٵS3U%@3)Mۍ\ lzS zsP` ,pF-ҔfsܜL\U\*_ |MǭWWGPY]l1W'D־ڙg % Addx6EH gknQsq?4j˽@dHb~@0+J]3,L-vУ ޺lf0x s*X45>VǞ]/@HáfJsdWR$ɲI*(C Dʣܬ q>Q)cku L lٌ o'TcUQ&+]h@O_\GgJEKVw hmf78V)m1]TQ v )Yׅ8G=`˞XOѿ:P$ވB'19JoU5ǫ1ү!Froؐ̿NER n7%yc_Vh)-dP!T R RqųMx+j^ =brE[z#ǨH1/Qﰆ`|ɵM<\5>}œm)$27gNA,nT6 ~ )@9c:1*M1D!?OK<| ~_9L\Yx>-!Z%::X ȩQ`'c+r}k0RKm3N'|f ';ꛫ?_z&iYزB(x^m29 n46ۘ&,̏?Q{/ʲ)ɮaU7]g ?Fnou$^p@#(ngqҔ ֲI4=B|>h` JO YvkpO_MCe˷^2ZHʅbUK/N N D$`S^;Ey3kq{rwK(M7NUw9Ղ3N]P64F[O^D[=(\HH3$|6UÃ9 |}RD'ocP j)ՂKrDr13A-p@e)KI: ʊpݯ.pY{ endstream endobj 182 0 obj << /Length 1116 /Filter /FlateDecode >> stream xڍVKs8WpQ$^omRS6 h) $}uN93M Y Ve),g ٩?Q9b)U<{1>>F fOOܥ؛GM;D12\O'ޔ' MAd%*"n^vgNzv_Ptګ¶іbAeC vF͇_s,dRuՔUܣyBQzoj"x[ ^NnʅS")t)H%I9R)jn6P^wCM"X\-$dREEB/I )8M7tm;GQ;iUKrAws/)KO%I.ęף|qӅ<$Q6PV"w- mq)wPTC d]<YJMpפu﫶q˓ao;ΡZ2j3( )w!VTs`% +EOLiJ0 /(j7(!MO L-f ,T]`v"%aC*]|\^iY` `A Qq:1{ׄZ95"VUmU,XC._ضlIS@ ݡf RZYB2 sN"(*19-^dR&70`Ndo1;2J0{3TX-:ˀlM\MrB'X ʍ#u(_pqBxi뺵;N8 ]4PC&YɌPbU'rt<SFqx,YG)OS [bJm+:}_ۄ `BXPkmi)IśED&VԌt**\ag,x,Р|=zhIXЮ*> stream xڥn_#eBKi6r 2YH IMy^qJ5rXW']/?J 2^ve`R힪/ї92O#tA\/$8MY^p}Zt[=hԘl^-^8r 3$3d|s.Kc.Ћn؝ǡzB_C<\+XC%&?X%"2UUuf2;Z-{k \]=n32 ť;᪵m9VGj2IXRʾԭ3Wt%w=<z@d&4b|8 ~"MEؽʙW,y9Eh4C#=cG&NnWR$z$cN3=J&31>X9t :zja,chbe׎m  e*e5qx8n̆5c?#V(N`>W3!ƹުٱnMh p񄃍 &Y&3->q'hJBJI{aԷLB_S:߉qV鹎:[xQ<[ơ{:Cn n%cG_z)˳t9ZˣVxJ͜;A t;2eSd&4% rKG踐lɯGL$ĞѶT?!W {/t#l(P* BWf7>9-ǯnF j?N^]Jg@_/?36ӑi[a̠':w ?] } ON՝im&5'[SO _m}Q-@<+;)=iZ{AJ@:Mj3J!'M^/D] [J;pKy@{ELj.ѐDl4$ͯ^6HfbO=h5d  (oV/PY'nOn$Xu,= ~iU<$4+ @:.ùXtر#;>k,wZ1A*.j{ Tv(yJW)ėMcSjYD"P.|.Z?Ϊ(S5T dTYslp2ZLw|m=UPGsHqB^ouU6՚7nEC}$[R>"h{4PjVz8ya&@Y'%kԢ~=8ć9uAmDa`U|#^sH;^C)t}=z>é${O ފ OʎuczZh{KEi_#\oH&xxotmEdlED&@l8=7c}johyEqWd _nW錥,u6R<ہV9"iC> stream xڽXKsGW*潳")cH@a,-]Eߧ/i4~}=Ɠ \:;{BMrK*'$l1J~#J8o/5x7Mc C4TqJU?^T e8H00{rO qw߁n}q9ngN>{WAWD nqE\BU9[ Y遡WfIwR@{xgHF#bXwޥ6H|ڵīM72Nv0Ro7\%eU6f):LLB|XBdcle'8@g@"Ik8>س1Pw&b ĉQ}Gfuʮ*G߽G4|\>"J;SA:O٢"I4mA/l' !~HHα!T+u׏Њ~˗/|؄dǍEm70#ۦ?'uUG3Jd> stream xW96W0n)R$3q J$%P!տcEMҤ!q{x>h~XD1h$Ѫ>ǿS$eJ<+p2ER!ʉWh5/buX\豮Pݏ!;MOo/u}5&6itTʢ;GtW`܌z׺./",4y-?uܕU[/q𧷴J?nW15pdd0$njrbs߅)o:|ɹ pkԡj2bhMP Gϩ(tPe1Arޔ("QC-ibB%jπ2R;v-4{sh>S:S mL7l!?vyê8+ۀ #фR7գo{Q`,q>XvvvCêY<(#vH)vR>@%">'p~I#DAc)$^CXжe݊9 es\TMz mGeL{ xj&Wʮ+>8-vգ_{8cF1Ԙ.@ބx "WU} endstream endobj 204 0 obj << /Length 1784 /Filter /FlateDecode >> stream xXY6~ϯ0ЇJIԢH -Z},PEDeɑ=}g8,ٲI 㛓'ˉ?yٓ/$GbI,dMMg?=})X"nC^6uNM8_S._~ͻWx8&߽9޿z;[(O_l"AOU{~ 7O6]z11z%Cռ4 ٩Md[{m `pcjUX[ETD)/7꥓Z{#F t\J|W֤]<3{LEoVY ^ ի4#TVMZ]"MfX-#Snm:A'mGmfشhӎ$Wk8\e|RiwBn۝>cbWc8/;Qǰ/^r&Kd5e5zr HDSz|?v@hmxzb_o endstream endobj 209 0 obj << /Length 927 /Filter /FlateDecode >> stream xY]S@}Wd̮KNڱeNZnA!TdwsϹ== Z]= \zx*o0N)l)Uw`t}n+ǽq7<`~{;&*8>9w* "*m|QTCZ1.Þ J$zH{s#?~kۛC9 '` )0$d 8I.=$Dƀ}gA8>!hIjdӀ#w{vg:7,F3PO _ Lf̦ 3Wh:.$4ɡB94܌ Y+Z~9i\/Hb[ET0vJL~˦b E] J,2 $W\*{"tEF6,Z7Oΰ_7$ Uq*2͛+C_lUZdxpr>.O> stream xYYs6~`݇Hi @N:iqzNNϔ! E*<饿DN#X`oc-Ǻ:qro(gMf'w}kY7#N~~B}v+^mrnl;hlsޏ?/o^:zfZ\|{K~u<1<EJ>6& [60jv\WfuO/QbzVȮ1 #,3i;!50.6˜|\nM|b4eM(E )f3Eq70zO!Gw8M𣰯E!og`~ 4'XfRaRDv> stream xY]OF}WXyiiॢjڅJ5$c;N;fs |8i|r:8P "C I QpeRu~q(/b瞢e0ͺ랏FQ]>ս4nǿU)DT NUħCe .T)C͟$,'w#iC9IPr\[g0HzEnd*{m&bnKhdEH` EVXT }2[,ٲ6'4gr2f0s%y"eOzs 7wp<dúбaڷYRr †0mAl /ϫbd}K-,Z %lq1?< ^uFyo)0 @"w `{:0q3=k+W()%(>AV SK7cT?5D@XQ8nZEzE%r ն;XDY%YS}mA #6#>5YzZ5pfSus'$3yl"0yVejͳaIAҮ$\yztNُĄp-_&H8X[' 26trC'Nʕ-2J!#[Ȉ2lߎA wЮ,cȾ2T2L懓!Ӧ0}\A- 95܀Y`2=@Y[ `ȕ,j =Ċ܎“Ff撗P7r[<~͒!@f6uأ ca̵ܻwq2;,汪)(V;n%%? 2ɔٛaNƒ|_?$EriY.IƑkVkȨi4-x"QXwtD_7V*tm >z#loKӀPvzw~Q6CqDaTlDUF{(!I#> stream xYY6~ϯp%rbC@ShHC@VcK$Qw.[CQ3?z^=ӗr(`b: (rt>9_^%&$<k/ߏ]ι# C|37^||sڨ}8#Ϻ# q$ ÑBfϞ-3_-\UgzGN pVKJo)Ak`I*O BIJy*?3ݓ+) ^?e"cy4r\ZA(&E}󓱩k#0O/vAEEo)&P31?."Qn)7.*qө CFDhӡp&ݓݥaAoJVۺ 0 vBv/}_{Ѡgg<|4n7I3Uzዀp)"[$2 '! Dq(#1Èl&#a;^|>WrTBCyD#nwEH|ڑE4L鉃3(":#W}l6a-s+`Mz )";yD;fj8$ϖ`ٲ=K~@T 0:]K Ӫ(baQϽ'L-դR1ƤC/-5HcO# ‘mn)^)pU@1v).Ƒpxf ީ'gVװyo0=]=DY6 C&+QcR "Dž5L 8008W @`p5$v-t6F؀}˸0钾K\ rU8^~T|5Y!VsK];{^%zU=kBgnx^RVn"ǤݤZ3)Ti6  Uf\;}e! n NK3X Uou7 LH=$܆ Ȁz"`p9t:cp-/UYĜyelvWNt%=¸t@.'uYG:2da\SM[ոY"xj8Dbگnq! fujҩ!Lf S6;4g4HB gG9?vr쵇zM:: K c+>iŧFSgwN;=-3oӹ'=Gsmt  &UYKK٣"3ʱY4SYZU9w>s[*WFu[og-wQf}f:UW?kΝz[a']65=5B'> stream xYoF篠(盡R*mJMR{`qjf#cms! y}<:ywl|È@RLfO)g2u>q4|_Uoߍ<ƘH1n1 n(oo w]ݏ>M~ߨ- \(bHph|ÉXrCqƑ= |>7+1A) FZ$5QJZ^ 9}}x CfH 2*;RWѬ~Y-ϫ>R"!dd-p.u{P33]PDlCfa *0kMDDz$&Ik1# SL~bb@ F%54n$nj4M 7K |q* }4,_8ReQ[3$]Z<ɬX/KKiuEMdtjڈV0֒2$),<1bOfKל,WJ'SvM7'SNjshZ&iPYx62\DS`E}W8K>w[[zOqPř1hlV(K-e<,X<\@rulF00@ej(!а9Ak0C6,܁n pk2Iۗ CIVE# "hDRsWAj{,QVQ՞59g!^A8GE ~'&36!Hh@=@enCqz~hoʺ )j p»%p`ц_&ĽJi#RI ٠WzX{l{ٕGVaƶAC/ 78P#CK#H`@:ɥMb5-~վQoh;4s! ? aݿTy\=zSȷ|BS endstream endobj 231 0 obj << /Length 435 /Filter /FlateDecode >> stream xڕTN0+.Aĵv,X>xuA@㘐*s؞t^PrTΑ$B ]%қ?bŒI NY1LJ\/rx|1Hc?)sE K fDrM>?ĭ'sD%ENIشYm)x'46c5o]e zy+ۆm3~3F׌Amk=s@K筯\bbC (,٦wUCSg;SC ̨شIUfv\g׽opy!mN:[*.0Lo,$yXpjb=Yh~j_BhYO٩]Tfa[Vvbf; wX endstream endobj 251 0 obj << /Length1 1667 /Length2 10913 /Length3 0 /Length 11986 /Filter /FlateDecode >> stream xڍTY- pwww  (ƒw.w'%螞[WwGZsѕC *fBڃ-GA]GXHCA@ PPrpr8888\6@2@w%@ qJC`kח{}0X08YtH:` #@jrxhЂXA^AIà Z1<6M Q2@ 46Z _ -  G7GKr;@KQ /cjpy3t;Z [96WOWC _ L_*> (ՅlGyi4G~2`(^ odv K7'vGHQ/d W/? yZذqO%| N2@`+ p|o [A`GD_{ 9^ aG{9bv}iy%J[)%xXx9|<O:Wvh05 A߈q(WoFrne^Ye7T!/z-u t`9'Rja/{ / u ?{yT\^f R}z; z9_'lKq+叉 ej#Hzq0 `|u|0?K(ߐB">n ]l^d@ <_2W-ܠЗgexÿo @X$`KcdaNaaz%2Ѕ)p)@}T:9I4Asb8AXdm2)Ďϣnݫ&v%g7 <nyڞmJ>eԇIhi\"*DWV2$&_ӗWS8cJ (G1_ ָbog/istD8]T*:׿ܝ8KLN .fPiǥȀZ)jCh䭒*L3IdZ̭G':L>qDB1Wm~| y+#Z.1uކ=Ϲl׬l| \VQ=GN W]c or=q'}̢E(q\)Я1B7qgDI:#1v\"qss ҌRA5dKw7!%p%jy/d`nZIEO!vURQGtY4Ca^1rjRI8^B: kH}D0PWWUʫ$L6wX;UN Nm>sWϣh!pMT ysp+t@NAPZ뭄]k#,vx3Ml󢶣ɡKmqhS>s1 ND 7딾yw!nQ fc`׬x8m R$WJO䲳>9m)8-\ˏ`; Lh]`h/5>219PsӃ -6 W ut'yBXurw~O|E.:ss,T@B+[XKqx{*fR.k8KlەT T\-- 2:"rb#c =.>{bGsP~/}5zGƐ9PG61Z5X úJF %Ӻ{n_\K )jdVkRpcҰ*1\ͮL~܅mT)5*J{Gǵc\@QrsMt_ ũuMV NG`a>.2] =߇7ES[%f;HUhLlt-Kʹ-sr`[ka@&'G׵ U7Cy KY&dmN;[g~1il;_06Vnmߥt|kQbMzt[JE*/<0%o>7ts\ډ3wazVE7uNT'XOu\2wkOܒ~NVDwKf5~3黿1bCQ7MfV}{e!.%ݲΝ;kr]!PFy(`9*k 4_QÿU&3&H%Zlp2* VXThtH?í|gpxs+.ui ;CҬtybj5mk"[(SW!+K蔴d:o:D|-nYbp]5e׶W[' 7ŠSh;,wUdg0V\eA8:&!_qa6g##I,XG);d瓃/xLf'70'd6;ƽ 3pJ (LX qL-ΰ2HF溢HZO9+!ߩ4w;ǽIt *QԭU-ᯝ;UMqwHN)L*e$+Yt` y%р^A}0I7BL[\5LӉ3brQݩaOo*2i,^QǣFA@Hkq~:vP]LTD!^u,A~ҿ&mh&}g!y b/SA%<Tb; \3*&Vcv݇ IbE||>Sg޳aEĐ,f r\2X"Ւ2\D(+Szr7CNQ１p(E 5 ZfǺ΢8ћA@k7؝lxc5Z_ UcEmt/Щ|1yb(Itim  TA2;qEƬ0 WDK?8Ǫ Y;u)kw}=<)(ٿ7{݃cy42_ԙ$=p)>02D#PgWq>2M8 ϴ`6`͞`A;IΖs"kDc)[$M|Vv5&ͰnJcd^VgȈb%CrTo.5WCVӞ.eOfCtM.o˨ɘeZ b(°e|0,IK3uctM`.rK¯*zye`ܱ͇qo%\<+Xs!'2~y s`؝Ԃh1S˿&æ F9vz~fF:Vͼ8uӖ`3VB$*{YiGK\ܱ͠ed \/c@5!b`[ Hׯ ⬭=yLA3Ӎ=?麼[w碻M6K;U&p9b,>/%~ʦMA،gBsBC7UVyN]U>bfu~<l#G9PX'3vW<_䞎B]|T.-L?p2K،LŶi+3m /~&]pb*?T6"k;C`9F1 F6YYV,c0-s+F#ȱNY%]QCvpGx (e hHd$hI-(m8},_:v2qu`@_<xpKPORDqo3CJw;]{P'7CErft?A-5oEeU7ON[G+*6ug((ʢ׈P2[2[sgfs_tQ킏k"̙vd͞|]_v@'[t?+E&_,牢SGv\-aϬ)Yl 0k 2RTG.tƟΏTNVLlo4羉nΆf ֯;6WwAxЩ1 ʈv.,zr΄E2,(ԬnJ3 Hxyih b&r؟+SƔE'ZF΋B Yz-/*aN-rNܠj5h-+7m06#ݕHo4_wER {(]gFrzFKKxb]JLz| 2A ٔؗSF$nz S#ug(MSiLypDЎ9ޒGyan"-Ѩ8VݳdrosgXcҫ6Y&ݷq ,ZMLs8B"+Xgn1$"Z&BeW΋c gU<"3T԰],bGYnk /g~jc?y-?7Xq[dVc>0%dyhɰ+ "3b]$t^t7EPe.k bгDStӨa\ ǘx#O@"9X0ƺg0?h0NUaRm>muiz}4ۧBHKA-^m{%_@Jc>WXJ(Og?;ٔӱYzPSP =B!;ɐbm7teXlv:0@J׀!wDV*b ɬϲv$_$gȺq btgkYWZJ*XesŴkp`̀mj E^zy$&37}tL52,Imt7˘ܪh.ݮc%h»'0ed8^Ax0}4U=IYZ9.&9hz O|׮ Q<&yU":;_zO-K0SU3j}'RO/&~7<fq*gCFG5KL}RiqttsvCmD,W.+7G?tWKE_L7Ϸ(& `6M7&<py_Z`asE![D4{).#qg~_{Z U|98^{) ˔A KHK׀$;~9ZnRƇ x)k T0 <10Ϸ4e? _0gYg|z$c8lڣ[Ge6Ɉ2uL Lܧtoa@Oa7S~Nj5O$6XxziD!4 jW6D>3CZҗ|!SfRz׺["W %^,gYq$N *ި'[j췁Q/甶i,zYࡤij(+">xZHaʐnxmf.cdT}αI YxͩDrSRlke2M|hbUn4]ƣ~~غjUq`DDC}.^%}JɉlwQ >=?O'k%e.7 =UN[38h 0Oa|YLγ5(vwU|>~n-P[H -'Y ,&?Q{-x;OfWG_5̍IG1%1geI'GQWS⃷\JXvJ戋gt%/[Ϡ&6D*Qȓ>*ٲw>qS>p R$2>=/^N m晸}茶nFa^^ew"'0'CubiC3Ͼ61H*@w|Y@JumYmbpXM_G vI=HU? GQ^_[ܺ5jv[cQttzo*s5F_9JwD__;a?/VD-n'ɼATAZxuXMpǬI9ݭβ7zm w'q-47 +*n)l >Nck&Awݱ^[m:xs{ hds^`|%q{v /NI yѐ^!ħ02L_YLsģ*Xaw!)g3ߒ4/ 4ٿLbUA74Z xӊo%La']ӮYixDTZ႟[zct_r`Bgh,]aOFqҤaڷV+f2__#C8("=VXtsd9?h șQY[Kyag@NpwZazItEt #wgtəA9na17H7sYWĻ8fXwQ1n,xkYBCPn? i)Lܮ^\{+rh2;!H2F+{7 ԝZ \edug 6 .zkU%$ gm" sJ_kF>O﫟5/7X xПZs,b*}T1&>66ܣˑ'NT`v2.ǖ.sX7O3|H4,hN})ʹ!.hh+v9~3"S=FA}rMRXANiV)WLp;ӣ+sQO\0WW$ӱ#Am"?RQ y Q7e_Gt xG螅̬6'ZD*m_ؼ醱ֹCOܱl؍+7 ECUi/:?|J l1'bT‘c͈,]0XuEXQ}`#Xң _Lc(GO:Gn_|W/'' HgKaoU7s\$:cOD drnI) >_ﶗZUl]г27PC?ɣYʛ-^5-YBΥLh1^tƣJʍ m.s]No(b!mx)ܪ<.-!fPrPxaȣi%rY?;xJS(Fy{ mQz7J|g(A]>!5ӧ5Ѩ傏fYњҙM.Zx FE%S"hw?#%JbxwPQf\ąVJŢi\ϛƒh=5RSJ'[WEB{oc|1?ݎՂll3 H/YTc;S}5X fr#>UwjǪ^GH#ypD} U6fābvFE?˜բ mGm+o0v12Hd]җN}x2H6nydSs=/[x\l@8W Uq:ORa9o٭Eb"Ľbšk+)b# \1otصw!{X_@B؈˔.6?4 2xIndhߴt'(C*_C_j|`i꥾p=N'{dZ ^P (R\Oxga7,Joh׌qEc&W {^3~`js>Dl`barh=zh0 Lm1 *:3wDW }ZЫIAEp@}r."`.2wiAu눈/{>ޓ`=nB+69fPj_X2H^=Z*wq'UJ@ޝOwA_%M{_Íi~3El-?Iڢ5 w.!"6OHϽ.63`/uP „?P`ĖJ`Op-!5x jk+D/U P7¯j8 6m*o+ζ?ijD=4oρ`E&_+=}_{(> stream xڍPր n4K=kp@p 3gfUVWuՔj S `aagbaaCTvRb r3L]QuXXXXl,,U9$Lܭ LYRlmi_4fV^^n?@gk3=@ df t4V|L&.L gK!Z@tv(hb4&Jj Wg n`tGQXXv4613;8xY;X,%)y&WOW&v.w{wk;w?S7HL+>3gkGW&k?jd{%A@W?v݋˵uy8,-(͑Y (#?g@W' 7/zY1@|A2~w o++` v@1?~֞=cQ5$*o`dd9Y~?OMʎ2 x qk2hZZFP3@p^?M^_f$fg? ?r{k;4}7@UYh1ɸomv+[Yg{  ?8FV#{93])t0{l\gg/c/9039\M,@('Y7Y0KCfɿ,?Cf ,GP#(C&YzZzGxz`7of!+/|/|Z Z _Mo/|/_-v{@#ǻп9#~oցU6{jJ=5ễ?usr}0]=@2x_ǿ/|'T9;?|ϟ h2*JsZpV:-Ϫs# l m-[є~=I5F؈*OFI?;Vf6 28jBR9(`{ J{6 UO/TٯC|cӈ*]7^%qe$CD]GF"Dw^죻JͥO}rGW,βOYIlxLRPGiϪ@ķ C Խ3]JC;n\ҹVBl/!ölCohaEJ]Z+n fc| }훴\޵Ω 8i.?ip 8Ay,dݖl7ۀbαYO =l| lԄS49ZWl1St*`Ph=wmIQjT5~ku2tl\$y'Y 5߀ٕZ {&g~2as-, )5 :U)`"톐g Z5ѧkzԾ]!<7R$Rd/ќ?W'oe *|egWrWeUcaj׍1~Vyw4񫢛Uybܨj~{BanK+ toƲio ub۽8!?U `;HPvg<+ q*i2tV292齟?Hw峀8T}[3+C.\ z^֖jwZW7 Q4,o|6EB)je *3Hini|Vu/*8$?x(8>IPZE]3sVZD ^x0>jYh4F\O3g2߼ An+/0\MXqx|&nmLdM ]Ծ5TǦZ|u%V*҇ B,*nÍ!Xv M)}!x#q(b${X||` nC-?KQź ԓtVez8Da*31olohqExR ǔ$FQpGtEUsAtރbXh(]("G)U e4(ە&aPS`q/$MZ>pUJw<(z8,lMB^aP w#~> F `,1קue#j& Y5 &^7G"vb!7L]JTWYhhϟ<.]QN)փqt{Y\+/ҋN6ZZäg¾>][WP~EH)t{M^sZ4`,xe14:Ki㩟qJ`E7w\<"AՏ<^J"S`aZB |њnj u(#UDio-#4W\<Ė)JInܝ[)-%mBFb-c#9 7 I+V[z<&l0c2Cϓ[B=]Vr3y0z|UaZQ1 Xt_-~[H-0 #M&Ц'LH6wŎ\ np6U39c+j(0Dǘ !uX+">B ԥrVT5tM)f{NA̰[(w?7P.mcZ<@k%۴Z7lMyHUĝ;&<p1)J2FֳoS:Mz{ж  fvZTfj *e`C*X3>(aU/\%$D k7ز\D)зHQ`ac5c>Yd}.oV%Xlw;=ѴMc8#r2 ܌ -"ѥŦEh~jBlb zyp#do7 Ŏ5H2mmg#ƓEg_'tYQI!{oE5Y^69# iggt!EYadiyw7v Bi"9 MV)XwaX7,݅9>&anR~)U *\6-5_j%չo=zhONm;"{ [6 2HeDPՍ:(ʣi?)M (Tw:IB2y11yI6Q݌Գ2YH蠁ETn27oK,Md|8jՕ\57JdOD3WǂR $yzda,`^3nt}|7IBqNy&FuL(-͑;M~i-Tky_Č+f2fgvB;f{vbyawy݊_0:f0âpb5)K\ U{)1x$NZgs]t|$9C$|Lm[(s$R?D2'0κd?}߇.S&}Cj/, U)!mUq"oxYL_}ǐ{[/6=p;|'f:69>>|-^u /^t5eE iIv&i~$a3.Oצ7OV%!9j-iH K}mkpWJgӒz诹͔g,F5"W~?n/hM'xKמ>+_^,V,oŸ^FRG͵0o۴%꾜;~٩cpXB>I 4$/dE=`2x3) mƲ fY}Īg_ۊFb輔v22K?]XՆ/&6bX%ȭ{hE!+Z$}#|H/NOڸ뗇 ׀(ڢw݇ÜRQܢl=QhSve`x|!39Y9 5.SUoj윏 :)|I>L@A_d$q9 r|͙ª>nC%Ƅg"όEQIpuGx^JwEcL(TZnw 缞n KH)62$}]͵jXaM+1a9夋ϸgВ8ESe`3'H-OluKf =L=wc>k1ۧ Inwcc (,^rݭ|&mT ٖWo- ~d fÀXej40qwጺmNH$h?Ts=׉^ :64c8)953 V.(SP5pS؀n(A?um1=f2?hDf5w!CMQ_&?)k j F1Λx- ^Og s5ţ#Y&v/T}Q }gI.KH0Cau)DJ%)Wt5! 6bI((Sb,3q?U5YaZEJuJnͱ]y 3MOVic7 ̢_[om9_Q+-T9t Z/eޟA2nyj殯IWE# ܚvuy4cTQb\e{qſH0Yk5PSxh!=!G-]͢).R>c5:]%Nz763d/NcFڙJ}?*-_*҂%Way3ÛD]u: ;0ߩ[9-H09QfHSyJ KFQvaFfoHT_eڱa7x҇0a7όAh45Q&~)-M4ۚ`zFyiLxfYȉ!$9v a&[PH47ԒK0Q9}ro6SvѦy&x! [y YCz>p XkOG=HjÅ&X#+?̅vH#ч=I^*U,O"F*DA;y6C7Fа/s-眆Ql$뷿i֯_b#ґ8 )J~' J:3DXyΑPWf|w?ϙ<0? jz{={6[JCTuMb[D6M<OlZ*>C/<'j.;ؽHկ*RCŢO߷u'?|Jh쫻bl%ܸ)6 ͥ8/WlM3I@ ~s7@X9\0.,㜇D}CH]yH&\d(NJa8]!EUeW-7WEa[Ad L|U`eZe>ʙ"T  <¾~pve6b1zUu ":riՀ]xe 3'oyt,4-~é~$ԩ'[})ӧ*Fr^_r;*0 oKeu_^5~~Om/M)x= Ldl'<{[n]qw0ı~ZL",z3J-fၞ(bPdu GJB sozX +qS3 `D+?U:=I򞐯?Sz7]: c& ފH1Rw(28"ۮ\zrO:tIBmRnA޲ u)JxLƼDKe}kS!W|0q:Y11#:mzWr$/6>CnELS >7W{" 9" wi+8mQ.'/dqOxt\&? MYCh_~`C[%_KVl4Vq}?YB(bB8=z: -x>W kG6Zw+p\VWmJeē>x#uM,+k =Xb;r"Vi(O(dQCaGRk]cnVH)^)] &C)Rm0z:hf+6Z'!M*Jxry'XךOO62 4SXeuls#v_Nt_Nwʂ)LpS;|.Ʉ9uXqؿܗYW8wS#>&*UŐWH@ԊWf Hر۶b- \P;V怯b~"N)͘ispBD!\Wc.#c&%=Oő4:>oEy7@I.pj9:OH8ޭzJbՃ$IlfF}㎎ocT[/&"ye*E%CPiFΈ`k+Ju.ꢼ+l:' (= w`ʳ#}u (t9lw":Ԭ/zGC[O YV9b+_fhS'xfn>e5h -+# qW]-UrgǼmD#8/J†6G}"(냘OZ['9ݫ0'A!g鎺T)v`ܥ]0H{*y_ 1@lc):7qO -zEc=r9 VμY 3 ȅ:=HrG+MAhG8NG f39fvҚ 8S 43]7iݨZ ^M;._\haTŸ9䫫IuAX$=UȦBxs,6qs%(קz بT+$^* :|~ab>F|aV^ ~,݃o[s)S̊:x3Û81קR{=zDEJgP#7J{ ~_3>Qx38hNpkC,a  ^H~R Z\{64+m7&o8*`?]ƺQ1!-NRtU9pR;0 =G`~m`\q1!_Z"8T`.7Щ%>)1:U;r)9.:̱[DgUDQVo`;'jCaw$蜆&)6o>n`\6v4| ;)fZ}|8b6Rq\`h5#k\]NUߤkzk fMlQ@SI;.D%œ9Ied'z A}rzK(k3Ve?dF!2"TOg&ocfLFVCQiWK~)Aȟ%4 qxJ^c㒿9f 'NHC iIVELY9TϏ4w r'E\?X{qپwL*Y{(z׼1ʆq bu.XAT0 Y"75O` ,Q$ܚ{Ђ^b/1  =4Pp>Vc9/Uy|>-#4.皝Dho9XEprdĿJSw𛬱a1GMV;(E)c$s~3MJa1qlX~Y/>4;L=C9EI@FuB_\X)kdž !Xz(Ris֧rYb6Iu{"I? ny9t=c;v$cʯO0_-Ǝ2o-5b'mOҠ 1|3FD4Ml*RZ`XJe>Sܚ/T2wqd%ۙoAʣ/$O j H+,}*sq#ogR\ TRHo~j~$!,^? ~C[;  .VDlyH8Gc& CtZvY};XpJVQ&>@sydRí~\:Ęd4Dg QqdB$?3q0=%Zm^ U+ A(BBŐD+0[W 57SOW0zȽ9{]1B1lRita^I8\Q,\r6in\`uJsjTAD)A<%Vn 7tݺ%<'Ntף0OiO}*aUL Cd?oVX^~ScƴcJEphyLh~*Umn3<Wz,ELC/Â:-'LPXY؛T$.=4-((-$i=̕dƭ9TH~DfQmvB7Г 9p$JnV1g .6ݳimC "<0"Vfx G bH&)04v8#2Ct81EaZ"Io&>!B'jҖ1^Zj0x"f;O] Y "f(~A܋jѩM)dg^2]~KE&J]y L8*5.qQ(w萊s.{UtFQ#BdXx%V&#~>( &bڅL?7U' ȋ7f Q=O9" [rzhd enImvq9TƼu x6_k_-1DZݜd909u F|E0!X̲躀NtUqq @ݙѱȭڣtLTyǣ 9U}Y7Ym(LLP[Rڗm] 3͗XY?z@tGR{dg_enX+AgK"iȏ2y+̈́}~HI qz 4:պ4øB%ME'FwsƮR5K5[P7@nl[8}I8֥ر;a~呴}?ǝ1,Q-µO: q}jz}S}w˔ jH UKV4ZGysrvHt΀_a=o+wE~NK&l7e\2(EX_+Bkb':)$Cg/$flwE͎ʞL\cq/eP[!gAM* }J.Io7qn4@(mX [*L7 &솙bw!-Ik+rjDIy[OlD6oqSh!NuD1!Ó"j5Y(kՁS b|o8!|yҶ"w_z(Y$#03?(hXӘjź'])ސy%;7!q9H7̸3v,]eQzivʓ/y4 8A!U]öb]&:liЬ\PƏ]#eTm 鏙ͳ,(o'z<4(A&Cb?KަgޞTmG"y/[7TB㑛ni/ q 5c'*033c3X)ԡ91uz7oq: (f~Ƞr0I74bZJ "Vl5粽)x+TE U<v=ڷI\rLkݔOЕ&;_Ev,6Pd](؁+Q LQ1"vQwA.^zs"RP1AQ\h̔S$8~m} "Sn7ˑ ]E_xr߯bӓFM[|Dz|﹉!b?ϱFuJcsBv6y^ͯ0 k$*,*:v(YtiOkO^)tsl U*]&ٍPy9_}j=E ֯V&ؙ-\_g e ;( m?ʉ^leaE`E[4R$mMܱL2NTٷdf+8p72әVp|$\H2?X!-ON1j!yQofc1}ژMb녮J逷j|GP/'wH&?N9&%} b endstream endobj 255 0 obj << /Length1 1390 /Length2 6149 /Length3 0 /Length 7095 /Filter /FlateDecode >> stream xڍw47RRDR#gmZ{S" B$$j?*UjY[mjfRVQO}yߓs纮|šg(EPH HP @d\\Fp,GMeCc(rPFXNi 7@H $.-$! A Qhi h 4PHKⅆ;`qe>x !)) _Eg#`WF Q8 <X4!vr8`0('` 7Da=h@!0$ᆄ\q@ہ7!A @P.`i#`]5-A'FB:.#8_7`?04?!uY UF9;ÐX 0^ߓuB<;8jhUTdð1$!.`F^._Fj_o  ~ȼ1`wvzoÿ%2!!lap$02nh'=!矓n($? 41W- & Ӏ.OFu yp<( wna%H } Wmf_H ee?`g8nݰ8Zhp@)7PԱ`9Ǩ=aP=8{.90_6 N 7_&M.?i',&`/2q[O(bHءd?).v8 ٿCh~MWoa0Olz v|JCн1ϦɼVSJDчoP.(̰h% k~rsa5ݬ7V}~:4kpeIR{t.8:YR\dT 82h+6c1V]c4Y/5nƈx/?9xGlmmBF93&x U\*m:yRmLKv0V9̟.V:0^dew{3- D! geIMy, "'tn¨i0MU+'Gf $J^i-7Fk?^$R:w׉imjxݞl"NJe/9F߬\#Q$PtoHEŨD/S.gF8޽;`ªKr ZbuahianQ==/Lj-wn[Dw4D6âC]b3B)r[Qkv}_/XEzeaOdždCջ=]INDSWFs\",Ǎ[5攼n= F ZX[&jEq7jIiR}#{AYuCŲNR· hm5{>2s񹋆7sZЌ^L&Vnbm7SW"v=!Ctj;zfJEћy'>cׇ {O<ٙʆ DYހꍃh}X3iVdB; 5F6Jv\ Eat')C%i? mJ'mU6!?Ug> Q똑lH<Ćm{pqJypD)mB5n`k*pҠ|c< SFHfC{߂:6Pٱ/ϯ|8&t Xfj^͔ &r,%x M,[_뾘X] YȣaTx_;Z9Ŋ:hTK)ü KD_; KqBE.$"v@7|LY#؞p?O3B= <Ə$QC+$Ya=έyi˜LNl1.ҽ0Vd{]s2^,i(O֠ܓxଔ޹:!4uSrJ$M6#2~ߏu.{݌'1Y}Ot&YttZetlbꡃoT{W"zR'LrSok1+糣~%۷%(--b~NiJވ*o]vҠgi/wb|w(έK7o=+14 nlկX5. ŖY-c*Չ'b:Lyx)&lf4oX{.J`sU#^~`d L󰦕$7BFK]U\]JȢLUIpĽ}^vx+ZFmjwi`!zI~XFQyVlz4Rq{X%fu(Jb0IG T~];W]i7@ 8D+euxg&>s(n ~HH^DQ) 6a&6vkh㹱.EBrz6o7wrsl.yg|g\>Hci p$o$r?6FIS _^/ژTPQ)2vv>}.?Z8jU*xQMb]iN㳥 .;sѶ6JH+rRVӢ7OK_c"teH:GS9Jţ L#MkVH >2vx,ch7ddX5fJksPL)g*~~vs8(vWk,(2EN%g'xӛ"  'Tl/+"o7,0?9B;p4 |[θ}Eߘ*^ :C{pz'MjYZ*Wʶ1Mw>6:/n~1 ɯ7 7M~FThO[;lCF8NY[:gV!?} rZ6j i_o}4:Pd( p|cͷS8T5H|-Yx Ս3GZ}x%zD%<<8^fndL@GTXA,p>_I1 ChJND;,.%fjؿv`$DӂF:FmV݊/3y;̮1w oS53Ө9`Em9z^ A>]c|,Cq-9ّni@`]=Bq篱{D}.kub}92a;NߙL5+#Έ itLs "9<|qK  $+utln~9px(7`FLipn.:KbA>?Mj ˈC΍*Յ` /.(Q9 ]f3{˞IC/9|?g^g+|Nj㱁Eީ: Oná_dF/)|DFgɔ!irJdX'z*3l6DF9 Ɔ~뛄.9=y5v:%VrY\" F{V7+Ji\3fB@Hrk'ծAz[,Fz:cwTj3r ~>^>L'P0E'5Udxft0ZkpyRvk}tfE^nV,lȡ}RelaFҭ}Y PW탲^ڳ#USp!!,,te樂hi78b; ^"!o<)t*ʕ!?'C*/~'٩ P|9a2A6&} (YڷSʹe;CGqĭE)늌K>B|ޒ˗yA> stream xڌP]YNww- Hpwwww$=߫:1\cڛTYQ(`SPee3!PR[#Pj0sd. ;{-`ca@ u:#P98z:YYX@cJ `f8@dejlP0vځ<L.tqqcfvwwg2sfrpe[XT@'7WEc;ߙ1!P-9; )t 9m6V&9ƦvVs+[ @IRÅ`lotdWI1(s6urtqfr"/P%.rwgmVf濒0sudְz $B-8YXXy%/zuOG_J_bPގsP@_+s  S_ 02u-~@1NV]X~/3{[Y^\[AAՉ:x9Xl,_C z/Ϳ_I F{s9< V_Yh~ ')ub_j?jc;+[ @Z r_S-߫4rZcz[[F+gI+3.mV.#aGZ8SЅ _* hRqr=@!N7+hC̀6tJ`\f_Y70F<f߈,/f0KFf߈ ,e~#oE7"bQ@(FXEP\8pEN{A@P~b:?7;.@_%@ai?ĺ6Zqw gZF%GOUAN?D> lK 'y>n oMTid:ۆ8u"XnQ]xf d x,e{W\{~)Ѱ]*.9ħihY9<2F"8: 3Y$'1:ls^l:xDSTޢɲ +_=Z HRVјҪTjF:Yw?B b$֔4a:)aWFa԰:EWh[~睮{"k[4x:+]XJpӷ_"!B wV: Kȕe4R1n- wOQfK/6*pKr橐D140;QV&j}pQ!:S5 Y鋔HD\ ]S'wRqJ%Cp%E>aMlJ4`Hh{ːM/oD sɽ6ǶIG)m+8_ mHRDGG6i'I \?%`g?Pc'fZoye?5t֫]ú-{׭ N..q?)kC*G~ 5Ǫr>)ta A F73f4<]zض5Pm\*2Di#_ :5ˤ,jR8K)U77G@ɾy9(o( dIqj>U*)SF~Ĭ,%>p_^׆-/ֲC+ӄ񍄮q Gu?u^x( p]uIΕgU*NKEԌO<?SbJz{Jniw2uUO_Lް])>(diƹys% 㿽LP֖cZ;a&m!#*ف@LL)GǦ2R%LAa𱼙1wCx86u?_nt"ɤ+Nv B9[?ךk—Y.6B^䲩Wޮu<$SZM , *؉0{fzbiߕ~Ohy'7&p8ad}+\sxJʒУ@q0y7@_55ɦPڷ4|Au=;k`E[L6+  D.Tr*a<ʔ/={;DC3.dX?｣@ )f:g mPM5Dprd/ܤ5V_abBɲ(?'q=/öRY-XSVMTyOT,S$o.Ö{u$L\goE~u\C 9DC-dW;cL8a% 0KFvOb/ۦ R:ϫv寭^ђ0ed@EM8-QB}MڏP+jCV 9kE88m1LPSPx4#qoTՕ_o݂_ vL|lNtŹmDor7P۔auW2Vbҝ8Aǀ0~Q vMMŜdJ%& +vyPzo7$7$sL~~ n2]J|P:<7`̡Š[=(zY\4ZHp69u6MG'׏E(uB,- vSR楐zJY شTj=VW6mKpPO4}r7;%Plo4 oW gKD`.J7ۣekՅUĵ4QdI#Om=R|gI(>Z8@oQ/C{K `Srl 0p%Yn0Xɶ shǕڕl{Zk~j=rs>A:.>C;T>^JUrQXLN(훵*X]J̈́y&mggfm%i`# 76 ^{'T=ӵG |-=Y ]+ ,&ayk1O8.Yѿ5OQlNwD'ƙ7hbRɐ`R0y0Rj(;F,9fj%^׼]2,ocZ}t̅F*5Iz*z $JWq.c ? ([U̟:= i`j,"D-j+? KkH\D_wϡJGS6,mP&wrSu>e[g jS.6]Rs]loh RV>&Yv?{d2A[Na}&dH*On8_#e)m\~}u/#3?'ޯW:t_ޖ}spH2G##5ci<9'cG0q pVlF8j|6J^ ɧ/i?||˳-dӰVԫ[xV l; uBx;pGZORXhژd7KO{zd3e0_NM9yKٸeD!"-hnJA zeTW%L޲Tq7OӘ-U27O CU2 *>E>=^1/iX\:<m ;c%aW|UU΄MJw~~*rWS;^iFMMB2`jT gP@7{0 Bm͚Rk ROmzLS< i#dR% S$4}~445k7 .PZ JwG)I Œ>4F׎_o6ꯐ#P,.SY r~Q{&j;NˀO5.`"ovh^@sTDl0imlc FTiJ-cQC[s;;)FqGEc%HmG W O澦9{lӬtvF0hDŽA=+6dDǝ};/VW1`w`X%i({߰ZՅ9ze#ftaC k}OqA_G=R ^K p}sE)e0mP;2NEEֵѭ\zWw:O1o|7#U-\$#3~dj5.nܚ՝-r}SKAW+1~Gn1بE~08J&ST۴ǒ"K| Sc{v }s~D@:kU`^T JA}W\g̙S?/r0 #u#ь;G%2z@ xY]bZ;w e>93=7JNuԧoQ<$STCy?!FŔFɹg]ΥBn#m_ >%`?|,V41_n\ t Y*Ҁo83މZ/=Eݣjsi$#];ĐŏWwl9SrR z&j?k^!$$Lr ~Ϳ"m1B[%$)CGʹ!WnB{|g0I |ϑ*@\?YuUey3u ys, 5(_ 2el<,׳t"'͵^|vAڭیHNN4II~4EbjLHE+ٱIn!uSEs}WDXw=,5mZ0-MqLujSġ :ؓb7Uwڈ1z.//ڛFq~i=1>QCQ5ѸdH|4 1,8WK'3ӠG潈 wήd9R~z7Zt}B|0# KڋzE/֙5-&>ɦW^ᘞ| xz@qf&]=U?* GU:IstOi*!+k=/ ܨ?Ul[U )$O8P?l_10)YDÔbGF'n`):Ui{Q:Ɉ1G"0ZFlPG#8Ѝ1/j*GUJQ=$>mV>BfhuD8m5˥Vp'C:]EQ@QU(N!YKfa7r+bM.+m{jZ=Ⱥ͘9c$qiQr?D R/P)Ӓ7;f⋞bM*[; (8bTY`VY>//zQU[1gmbDg sS?Pg$Do [73٪D+hu E7}Щh(dK>ì/ 䅚:"i{XjrG j o_Cm˵dȦZȍf!x)Yup]ܑGݏAyKecwE nZ2þ%$l,E6[Uz.g~oS`mղkbkCDmIr{}ٞ{&# f7;;+W/ޭyofя:s,ĺ4_yXP{*uU5 긅W*]W3gBw5%@Ѥo&smW8F%:!DQqc$wȫwȐT~ُRffc H|H*E"t%nOm<&}EVhqI L(j׳Opc8QA9aXMR&⠞Ybn?sC^BN 壴ᨘvp=LjBChB}A3]VuB`4m㈼'EhՕHϒq4=O#S.tͭY6NOCWs]~k5Mwoծר[]_c/wfWeB?TVK13ӱC98S}w)ջqubc޽?$gOKIЮ6C^kcDWY(o3"pH =ghn}l?rv=&ٴ׸v{#,>sZ@|'>S$>`:r 7%h#GI\h ~ᅙ?I\KL2nCqYPDM; j4\²lt$ɶBdJ}yje7앐nDZ5X#dh%DQ2X-]3bf4"7ܚSyif_U㌨}:J]Z ˨<>6pC^2}f&Z,TT|sԻcBG=2[Ptei}繬'{JSvH5edE/kfd0;Ί͋Һ d 7,' "|4`g*sh+tt߬2jB>TI*f !rim%h9[{^DPyP&;ijډP0hň5Ua/V0Mwk  4DT0ذ迅96E[fCڲE .QA hBU =Q`l?1[9L>},_v=X$@u* pе֙O++ᙱgodNm@fNMW^Ȣ^$5\=@Tt<k%_5I;"UFfk&~EX|1”T'0KtnљX x{(ˋw9rӈFc|=Tuj%PP%)!UO:6LPfbۮm="jk VZZ$uq""Mi~ ]zҁ2|7E"㞄]'#N>ɮԊ]v%<} lHIv3WLOS>`@6`w$vԾֻA|?QZX3x/hطoK8\܊}느%\G_2ɮdcwqp} zy}T5#N`[\br\s}A!Aml1UJ!ND=TUS_F @Dw)jxqy]2 ^_KueCl4IZA]!-k륱W֯4y59Ruʘ(8pH rQ\vH/irG0-ùb#U(ocAOPi&Pwp ̯mOIX5rfS_~ ( /T~:wmxNNJFf6$1G1{*V;LfKOL.@ybu.V=g)h?TG+>|_#}cd]5CpX<֎Cfq6C=\*3_y@P MsbRtE |BehJW@h<;Q}JHQ?[kO4rUe(N!z#^@*|<'I7X? IxIy,>{LgEbizn*F]oFU.f]}:>iU05 塁qC=Y~Y28]&]sM MjnrZW\:X>K&[~OX"B>>Ni8苇w]e"A,O): ٻE1WS"vxaۗ,L|O"Y M A8_exw0?"Oq;RL+7s.c֢Xs~!to57ɱg&~r LZTk0Ϡ{_Y+hBr5U!YimeS߄g%it?;Em%]}55 VnLxTsiut4+Y:9%GiO,Ts¤ek8L2*Ji),$!ܜV\H S1^ &W TgP;#s:m !b8i9c0z1X=~DMT. w #4صC.@T֭A5b x vKBtQ{a3ZN8O2!O u=/݇p{ Zͨ#fcEP{m1o[%I%vɑbR9C\Z6]B}U։X%06 wqU3%27#YtkJ>m#Y#&RIW mBX%)WG6o41E yS%3`0:ŌŽtAp&4f`+st٘:mڡ r/!sVx~ A>b9[&|*$r×Mn~8/}JK]k CKT CHՌsǮIWBF>MB;ں 3F6n(3"B'j<w xa.)XW3rΦ!k/'f.m 1YJ,9~pCmmuBZ搂]dS%a)RsJƈq:&A*gmײIݣC@s}N5s܀t?ts傒>VSҝ9f!+a1u6apf9f.ӳ <2! تypPӈ_Km|j='chU006D ^[_]f`tTPL<(zG:+=4(@8|Ȣ!--Bk[MwsvN u)o~]l^&%Ais4䇊[4_aObs/_+agF/ϱ\JH]Q p$+G' ~µ@:]OIʻߤ ^]B$`RmFSsV, ՘'Ѧ It++b 0A)/)1yLh-1xȠ/,v? yPb~Y?In֘55S11VH_1*!|fZH\^.،L[[Ae.̔J0g'/MZc8d Ks!+)K(7QgPNqqɘpvK9QTÝ@!!;T@7c%otl B=-^J*y|M] lL%SV"rϢETfQ Gq([_-H˕*f5G py`c]d1Sxpm 0p ?{1*?9oA,CoaN@Cpe{sq}h-YmÓ2;NUub srC.=iUkɍ jUWވU (: d2<6isi eli7C-RvB"w.ŊJ/l-C9 G80GFad*K@  s|wSDH!+H׀Y(V}agN鍸^4X4aJ "ڢ!3^k.Dͬ lh|#Kֹ|ܯ' -O< 6{96Vo>ۆGh]i5C#I7HDV9t"Ѝ" 3s\ubLts"y`wZsU"aʜEMOϥHnv,(,P>z!A LYX%)GY\öE@h:v[SȵZAWc]w^ AJ&/f5,MOi~|&bc+nbaMvHRZ@kuΚO\ވ=93Z]5c\gJ+Ňg^q稷(mH9c^6]_5b1fS*Z)"c)6ffi_ tpN gl"-8lķ}5,@zt]פd?G$G߫'\q[ga"uC[rh[aX<,vIOmRhgga9/{ZJ!f_b*JہNUWP6[-l64\G'2J'GM$Z7\6ڏcG\K[Q%M'Snׂ:\`Ri )os~GrkcYrǷluADB*xUV>=RA f7kia^ڜ#pVAų\'QyG@ XUM88bSKcقk-h8i=2.^vG+L_^W?֖\= 4N0 㷠 p3Bi 80=WSʗ/}imi6B8 r",itGb֗в> uF!Fa+S^K xĒni,fD39j~xEJ_ahoTpOэI%:1p7њ[xJ^ B8z!);`k,+BQ0.~){qe7nTH3PEβM.+H-!tH > X~ޤ)s7awƊNRuðBT2 JN.>*te֏P m L)&xmI^bD![bVa,dҰϖJ %47hT8:ycF^r{LtbXW DtH4EQ׭qi>^7Ve<:Kv18Fy{͠'gl8gDՕd39HSEGS42b)C@GI+0>Vp?-[Nj6b-xa=zwDao5Pf/ 6c\ SuhE7=: k#qNDKhZ/k?w1F"Ӹ Sg/Q4£'_CěyWf+?O̷wryiCEup%=/H眳N^)ι;Q@v v74v ֔ibAE8([/ԝ+ւx@lYF\X4t=΃=Q͹asXZˤ`6CnGcF\ Gxw_^d ulv;bį0˵>(z)~enL)&ʧ%߂-AQቜclj$:y9mÉl4`¤"ŻvJ*"6脀-0סL\8YՎxGs7VzYqL5<;WTx,6(߯7Mn^ Y"ux~QQ b.ي@⨔ T&Z.Yt^LC7>v\f-oJ{zZvȶoNet.SܾIYyt+4B V'. [ ;T,Ҭ 6;QBa>t`_zr`XYuS܅0+'u 2J4+T.0,E[F3>MO AJłV#!=vDY~'ދ6JVcS~;dp4bsA`DӉ󋏈B{1a~|;(Թl;:H_ a>vœHǐ&Vm:ioԞ7oKi鳪yx<BHj9|$ g&I+yF=o~#nʦI`~H+T_#c%2r7Mj=i!f9k{%YN6Pj5Wv-l}ڝQxuĒ\]N ?䯘g '*?Woєݒp"9>ש<_*Z2˩z{ 54쐤/2o GxD5 G.Dv]JBD 9#xeE> reο><$5F832 *]"tF u؈)c-ϏW_V~b$L!gfT1EzbӞ6e%LF0LRt'VHx=@}07֠7F_Ǟv1}GDV}4Bpr|^,}p62pхeџQҫEOj]R#Ԏ  qumzG^ 0'F&Բ_KpA0Q7n5Xvqo>d*DfRh-7ZWB!j~A-Pݬ/1 wI[_Sr2}f[LFb#)M?{PH;*{B0pVQ[#׼zIkN8'`D<>2],cS`y ̏&Cr٬XP!].'X&F)J1r--[98֬~K.魌Jd$ j|cS ٛUIO;v(ЙKm05L&YۖfdDN\BHYXBq({pTs¼c)>3jij6JNSب-AWpRS$PEl-KdokUۤ"AT.i4҄GFO̬iջd:JևsxQڛ)^r*;=s0f& ě' ^֖lɢ`_;f0֦XNb-Q"(OaR1Vo}*f8n4?Ր{=SЋ=ޟ#zD 5”et^]1/4v{*e2t _o+zٓ$ {Pv٘r/gb%t :H\R?bv+ 4CZ)VNypCf2v|D";_Oˁ5lpa\͠j+}j",\Wef jP !A˃zt{ jv)QOj,t0_NM;%*hWP8*.asN <&)--@GUԃos!EHk>_K)vPґ,/[RY. %$h 9|nĹ#7 R5L~ΥMOtӮuJ"DbJ݇!ѕѵ$mJj'Y*j6(5jzV  qݪ1&wG`Jx#M[oYSm.6SɰrUk4yU%z$MA`&͟z=/RN$:mp%|=wSMZ1U&PC?!uۙqyq@ FSMDJd!p3K[ּ׋w+{vƵ 4ĬϩfL54WIl Ì3FEΐ(oǓS CLL] VM;8OO 9v[77AY)FDWsq|COB1 h2`#v?p "ayܛZ$eQXH_U#F`&ӌTSA4 ǡ'uc0E>\~βY}L0/):9-Ѹӣ]k5d# JPHcȭgIJhhbߑE3EBO%GQ$㪌J{-xt+2dK.(TOm|zv&OB @o8U% SJZ_'їv7?X=CWlHr*></!ָM,ab'7Pc=u!JexmBDޭ7z~p=W[Pdͬ4<>(bkW]'*0KDWx_ 6Ę~ƝMcC[1}5;Ok4XXm딭8ԲJG' e -N` i$,vb rQ25jr5ϯs(|UcP@(x{zl)~^t s2c?忱y,BB,H,vMX\<} 83ntoxJnafpe!XT7t%(:ö:ve_{ TSdY]$'wX_X Vj'&[G9g<^[f\;=Q$g'D<_}$rHHB>B[1lTᐿ(}hLSf.yO+prS%#E-Gl ƏXq%=A0t{β,D2[OCv6dm:g{_|”<r(>~A m#9wxE^^U8X:(/{˳񎨛,FwmEdٯvi.ryYo*[KcaY=QqHokTTNjƍ*uB8̱^8g*Iҙw~ ۾?4!4ITmyCt墶<+z,[gA[2D$FdrwéV\,wQo`1;EUjҢ{ 7[qڼR1'B6dӑ,}k>+/XIUN=܁_8Ifr=\}E['QשY!A 'GAV} YA$`D@*^-n($vZ Ӭy5? Pr5>nӯ6Vjn j2J$g+R,ŨXti)4س>͐gFnpoP=1HEMթV2abI*gP3_*@qBbWʻ[΄5}H=-DFhJɇb%,Xk.4.zΡVO*<^MJ>N١B %oҗ>= wvՈ[˗:4!t͋P'VN]Q6]BcHyQ9uyݪ|~K&YAQV`m(j=|k`I[}y-Pur;;x`bVf1BQ܈f"ӎ>BT&pr|KHo|ZnEP?izW+Oʄ(M? dSĆZ{; Q9yDpn 舃{D-(hɘaO _\] ,q:uaZ]Pq6oS)lmtv7 /t`()DHuf00:". 6`!d&+gC= ZR" '>N.2F$OʶF/KN4PLۂ%ooFa)g43poP^dZwSSV4+yGꪵ[E",k<3"vvHHi]Yvxo1nCh*a?/ q8%6 FGu?lٶ'x7j^8Q5ʏX6JQ¸2Z5MmM>HvE!6IiW6H}H:R"ԘH-UAXO?G$I{~Gn? 8 Z=b3S@X.Oac*)}>v}?ynSzE}2f'>j6unH7g9IɡEyoW_C箞Cʔ֖&y[~1`h%٫~RXW !td l;L|O OS^Mjj% RY ʿݓ&Ri?W(zE endstream endobj 259 0 obj << /Length1 1682 /Length2 9608 /Length3 0 /Length 10697 /Filter /FlateDecode >> stream xڍP-&w n 4Ґ]ww'@4@Gf̽WW]EzkRME(va`eH)kppٹX9Qhh@.(4:@3,)&m(8|Nvv:Bfn K2+@ tFrt򄀬m\^'ނ! G:@Yf.6@fMG J ۸8 98:BE qZ~9dƊBв9itrq7/{ B/JU' `? re.lfadV { @UVÅ`hfof73 fY u 9[@@N.ά ~ye| =-~tub޹ y1cxw ZN?/ |V/$ +qz` pA`VC@qe"/KG?̗MSIYVGO$%=,\N??UX@`+G^?4R_*/RQ!;g'Uoɺq9= xQV(;Cun2^y[} gYR ba3 0Ppe,^Y[8Z;N^b"/N7˂Z=P6x r(/M `SF|6ݿ 2q<X~sa<\6+?p?l/ܜ6ܼ/E;jr?%do/\B_ 6/ +0"/=( B!!,EhuX!] 5YA~]kGF$_>& 3(KSO$ȑX|A(sP+uh*_[W?UD}(eՎ1 ,7BN3Bi,WgJ-N^bjb}"rkZoɣEҢMDmG^* cZ)Azb"6X<7%?6=/̝UAϪ| <} ^Gz6 prZ}둇X uV S򶮀zu-ʱ5Qs]F{W=Ζ4MMA"GɹҨL 7m$TYym\Mj#&F' 5GC(C_wʵ˟%j?"A|w=J 7-(DVp[9}ݨ]ZSM~j8Rc'vFxo(A!M_:aElٍS=NRՇC#;AhcBĞcj.p0uKkN85uj}ߏn]Z .z ; |t?M JrLF* d7uv9 ̥9CjS0@cu i记;Gsॱ[asLV`&C^sX5(VZb=P sS;iZ;{F`evzZ{ZN^oS'HŸSX Gsr)KWub:zoNqEtT~14ZLnAyԧL$tK|ftY03) [3NYI͢$Zy6(1k)7Ex-@z Jf VA+A9㩒l q<6E>Р=q?CO$d0͙seHv [–&L 2n~ߔ?H}}¾{oli'~i2O!eol0N@}f,^TITç@J.yÖT򆨃j.aa_ Ygq-8&2ʌb)(XEmڀ 7lOQ)mckh[qepTg]S1Lu~+w9.k'NT"5qGI6G$k^ޝ4hZtW1#$P `_LP?U&LCq5V(`HEORW5RY"ߚ@^B/73^y=qwza1c hj_]%r4 @WH(T@Sa#%a1eo'\_ҥLs1j5W `h,TJ(Pr9 % N?8784ZLމG]dӶxTLy0z"Jk,'?tDdLsbbσq!}YKe|ٓT6]wYV9 om vyb [L û5CyԧQ=qR9a_ֲj%B]V`z e9FN̿6& Oi<.chU7mMf^|JG~ϵ߅}~q\Xj3 1)j\#;HH':W-hB=5遙Ge%e*L&<=b!e%o=3n>qbB*I 9qS\ܶ;(Út Lɻ}05Y.[lD0>3Tn`U\0v1)_`8$c %N' FZY=H'zj ^5C}[._`GU.4<4ҔM@Ki{=X%2'͊_1-5'tEIbz]5N{cȘiR WůMp(IVLP)C7|8o%w"$dǟA} UNPW~mV|eu QJ&6o2@7/F##55G.̔__fy,~h濾+n`TzT$"S̅_Ų( dï\p5[JAܝp1gӛ|N+#(lEp&:Wb:L WS춉+OC(`gj^=Ak*TA;^H >r9.qޑgIGN]rd:>LW=(]WUԖZ_fl[@>20C^ M?`>.$ETdQPl6nMXu #CGN(_Y$wDif{.@U# NyAت}a= @R%,*+r$1$|e:OYCM`Wz:.Zي}k)5J41rNaލmV˄ZKdT U_WC.fqm"acn#aϨRDM7ä́smddXX'Ƿ_$rŮn֞px{fRsLJ3.IvZ(v!%x-g.9cbYN"dUCT}S(RIҵ=mtEN|f,ޑǰcOH%&@Q\E<-/U]0F~$o>#jf/SYH@]hliwBpUȟM55 aԱκl>J%{Vm:ǘRkanB:JbW"^J%E+]~xrygf184KKL&U+Wz~?0bJGM2#_M l<1H.dfa #_)(B `$6g9>fRSn\OD㮎nfao?>apjϤ{52 b4P^AUhq F1 "{ U# *}(t_' 7BЮI<[zL,-TԬ N^1OtYh2Q> vYLPXشC= Y;3GxCsycbmOAz`3[nH:{caؒ<SKgsrRE_G^KC gP'1STvf81G̖5$W7t ?ttc(xzlηgg]{i?]#kG =# ?J](@1n:(GҐM fIMO\9IU*)H_`_gj:< U!0<`[ѼWu ߶Kdo)a#:D,a2R _vG{XOuy16#fS>!X<$L2 )Q@LL{H#NP  린S>Y,(P8TI{x+:;oWb9VryyU?9[12P'PN%V@h`1%U.ڮzEe`z 8?EyfYyDÂ;'5!$fxļՍ4nM4a>AZz_k1-l6gi~eS 4iaSݶ ^|V-kĕyZғ$R ԅ3SMQlԴ $TTڟ0gF%J)s_hcqI!Srۯl;rT~t聝pUp{26PM/UgۚDî[A'2wKJssftZe$E+p\#*jMVLخ۰{[xq[+&Pג{LC%FBoɥ +xi_mr8iZB+nߏ.<% 1GzYSNQOGiA'v$К5wBuDr;י*uFW5HFHD[0i, `xhR_,xb.e Nݦ'N4!E%$w9@ !FPeJm/U'=iY*Ul/JŃ O޷A6A @Y-ȸ2wbÒ=bոB@e CB1M+{?y2YC%uKߕ+7?]3= RL1mUe>s4h|sdPj_h+y Ɋ~Vx꼻ENR@b*Nz. :',?ṥfeJi d&Sd5JLc-sH@D~23vcQ=KѨMB/䃳Y2eEiid*md1.Lm;]/r Nt岻43Gc:׵aq9{gl?VO؊#j1vR=\lD0e]LAfNvTL㯅UnGb9IBVJb[C*ZM*J\SG7{DUmƻ^%8ZX68 ڝk5~.#Q+IC&+gXioosgʶ2{ ;Y&4JͰ1ܷW*x&ᥘ[ \8:㐨G3~۫N{ .H:%S.> ̟kMmEZ;!](<8-L dAZO`wSf:r8CǶksߴ+zzz _/M3ԥPב.q{>eG +?rP^w#yV~rs,'AzJPÏ%a=E{YW!dC: m<9n#疧)#5Ym M.2+_-iڪaUouTwh6˔:kzRHmV:[5` SVVg 120T'nbTߠI]v+ŕR|Hջr,Zz8E ܅th@F9Sg/ߏUqyA~pB>u7x [9q qslr)D"ue+e d%|笠lQ+⧼ㅟ< ?]+JnK TS]'ffcKOc]c;|wc(Tcmn1QvIYm8a lIKl'eH")R:]W=tEUi/. iN;ƫ@nJj.A$OÌo󮟑kEyZuj6پ4/^ۮ˂KY>4YOTd\͆QjZ3Qcb&[)_l5iC\sh^Eju6OGU%e1FSj25nJ-Utf뙢CwC:T#t|s >""|S5T@3YHc Rrsi3ᧂ@mJO4#%HGq]H3%2HR+b}Et| bR~c +{ n{ 'eZH2LκSK 9g,?Yջe8ԃV%r5SwkV;i#[ZԇUo+B[H8g^)ޠk7%Hee+ȍ+)W3" !zz~iAw/`Ɍ&g endstream endobj 261 0 obj << /Length1 1620 /Length2 9190 /Length3 0 /Length 10238 /Filter /FlateDecode >> stream xڍP-JpHp ݵ<@4@pINpdf{Utg)ި3CMARP33+@\QʎJEveF9:;6 s"sqqYYyuH]EfrB{8-'֌G:@6B@g+sG3-@j9{W Z+gg{>777f3Rv@ so%Of̨T +ӟvux6؂@ 9.PA V3lll+w!0dC,`[@YJݙ:A@-9R399흝). #y,ެ  X!IسhB. YBM,A.VVVn^.r7b]^=`L=z9]AgG׿P`3g) Ad'~|G;@Y{lߟ> 'eQVc>11; ps| X)( xˋ ? `a@S|PG7 `mXA<Eo `~__9/k/ `= > X9,ύ >7r\?D692h ^U,^Bסj!7=[s{Vmka nh#<'ZSdɘC_V5?*J62ޯ hwD2j͑"2hX Ţ5%U+/zd &RNgȳN,M8ϡ#٨x]c, ^- &5`<5]#k$B?emu[ђz\FyO!eg%z&!3nO6;&ͨ{Rvӧv(_# n!lwd*Pɨf߀_eUp+sg /'%xEJ]D`.2 bc4#Eafʽ^#mDD?]p|%A+dW^H[EE:I"`N2yy&oّ`KKkA~ew!i,?`/r}߯J -NZ0TfTԄۛdBlez^ő鷰b87,JR!>SqbKu ۼo5qlgj~J1+OX"Q˿Уտ$OXmj:[%)ICJhݏ.|G+N\l/qQE/s]>LAfMJ~|Ժ{ބEȳє{1,"c%xy743^L']UDYB?y*(IWNO_d)h[O?sv3֖h=Adز|MN ڡV+-v#Rs*&J5X lE|E\`X'ӚF,`E'g%dͥ9v6v '̼fţ0]Be+p,RౡF$E7.cݩ@v3(jgiTI~Z CxrH.uEvcܓQ}%6k_%Tr⳽+d}";n3vJ9iHpK*p٦YkML1t+q~JwҜ20丢Qk  oli O ܨpgUo|wqLiohnK Wv JYZ6 yy͏>i:;;cvEAmjy?J/_iZˏ`j4mC)gOV|iwb|\ɵ-zQ/5 ekWtޒVAe Y.̨ ˹M%wu9YX^c!9uDZ]DJ2M(hBUT $;=q:n!ﻈ>: |DlFe#{cn3WFq_j>A8BbUAAnk(V5hX=%z lcM Iu5QZl_< /Ghi_e{D͜?~rQWr(Szwpmzݻ%I*!D [n%aLg}#oM1[-YhD?l:Z8Rvpu%WQ R m/5\F,LK#ͶJ"KE43'^UH%s~feU GP%#¤~tfūͮ U1•*ˉ`q580`riZoQe_1RE*|( CN`^i8iߛ羶^c1a}XE8iMh7Ի)`1c6 UA]臿W yǫ6|]46IdRp/U7Mi<9Vݓe`ҭ?M2<WwVf`0#w*mԏOZ45/Uޱl}.$r>ęDaE b¼1-49.;$_u'M5~yVES?q 'XԌ"[[;UMXmS)(:#龼Li')^w!DT4PKV(ݤ |rX$V֫%6hKLl)zDAV:G0$j`1Δ8CsAD2jD?sknb*>F}9kSE0XlJ.],Do ߸'yNJɎ-oY"[WPUǠdHThwCZ 8KȨ8ZN 1>Bq"6i!,y_ g WWOܭBe_R#sz8vWe&B5X%"Ή 2}֫3~ LJw%LT,JSۥʿ5ߔSň|<#{crJwXaqaQ 3QU#1GLDxVN0:T._t/xXzR+ӯB[0r-q&|~ݜAXKOYM&v@ɗuZ~%|1Jèx= TES`ѣ()Bhj63P,7b_Fy ɛE8峪r4f^Z[Zե(ia;R6e&b͙A^pG 0v/O_U;@SԮx>+ho?rFg|ţy*vZۋ7wmWv\dR8RC:.[ L9ތvRߴ[NS2t" %Cj7x<*].//V<ӁeG``ohd,CN\GGS JmV-.EIGKYĠBL[0Ex϶5[/rőpAYmލHH7}Ek@Uk`JƔsZYL?`ؚ1m;(zN B\A<| k)6{S+U;O~N:}8u9_v5"S z!*y;f:'OGL ͒Wv_bPçC K,Ȉ:Mv]vwsRp#9r!;E0G.zz8X24̅x0mEK.6SwvRMN^C?V7 n(Gt!ezWS)C'%r=դV|9I+vR/E(H|O=W>[ TtTaS+ibv+f[Ɍ-EP`4d< {ZxĊzX,m:FV1˓Tfnls]̏Ȗ5=̭;vzb4\cK :sLcmfG=—{਎<|1"hT1P E<$x}cCnOnwVnpQ954&8J@<Fy8G$9e,eɽm CdXy,:4~&ZOVDSgߓYhLq+1k-_a~ u"%h6?]I2; -i΢ e˽q1}|AL"ɸ?{NWd"Zd*1=~>kwNv>*VFio*+3}5 bύA+kjGX9)s 64šdJy$ħ1I..?I٧bؽrz$ )WOoŐz@n`m,6@7j6M]Ӳ%Yr}Wk K"?!d!ף0L'J ?_P41.B r>c RVDxٛkN*uAokVԭe}K۴@RN$ک%O#J`ҐrRlڛ:`PukhӘ? Na|\ m0vTj*&as&x2Z*2âqdc?P1γ.oΕz`^?lukd$A]MY>.aG85ә t=E0/0SiJ!vH/ \BmѢt tOșEئkژNGQi`Ί8.ClZ/"lMsak@46JhϢ^1 o1a{-#Ky%,^SmTt|"hԬk }|_4o?/zNTĔP/ /:ΠeF 6ؐh_aԜ\jW~[hQ@~a}A$xY#~'i2XKO^FHkd6Z߸ fE3vꐹrtCmUt{/ZCH/?4MNǪR@h~4^sY朹bb3 ,7q%}jI>'wrݤfX# UI VB櫃+MMvZ&)$s'XʑLEOWc]Ί!iFU/ "RLceH mga|jf3nG?֍RZ\!߽ڃB|pLY.S +wg"5Gd9/v=Att~)~MISWOpNGJbm$TEb{AD i}oZ>k>% Nσ;^y5jsCᅥ# T :gN4|S UoX2"IkFVCC_JQA+lAZeUBvil4!K- d$MͳZ]ׇVcHu#l[z W:5l"YL9QNlOGckbJF!!9WWI <'HnhĬ x+~FtCRǏr?ʬ8i$;պ-Xyҝ3~Uvۮ.ܣYK |Lޑr,>Vtsipe?~j{ dR4IܾJ?-p.Dm2V!k;ӥsp?MERkOp_L Y1e2*\"Vpv=ꡐSH;VAܯkt>v@6j܏oGp -JflrxOJ+I9f$}[GVrpRG+Z!:~DEmX_/U3"\M!jE>;+́7+7[oв&Uܭk=WW8*0K*$ݶhC!Y>EI4Qvt\ųQYYӅY: ot*zx?^EmcZQy72D4`_ycl]D:_bvu]2^KT"o endstream endobj 263 0 obj << /Length1 1413 /Length2 6286 /Length3 0 /Length 7242 /Filter /FlateDecode >> stream xڍwT6"!膍n0 ƀii )I FB@w}9s}=u?猓TP@Q ! @UD "df0-CeîQXuG:n($!"@_ @ s tp*9U:x p; }0ꎭLW 9CFXW%@:+ |a( :~ݡ q\`^MN(_0 *`(  w"Sm=?_``c`pg 0BQ0# an` ecOt^$%sPW%UP8ʋWj0$uﱺp?N0/p7T[O3R'Jn6~{ <NX@CPHoh-@Gp:ddǪN#ah5K<-G 32563 o  EāHZ =;[kp'@ػ ϟs]x` 6@q ?w/~4~[y~+ӎe7 ^CamF wva^04AfMC^_ @ kWS⅝oJ. 휈D1dc%q?Po^6pB ~SL }~)\_o_!H$vS_݇BP "1^e<8.7l]9}y޳\o5G?2~3.db8}Xɶ7wHo )\xXvpzzKQӜD?{S6jfxNBrR0<&gC4J ߍ}4ջS7 ƮXtRwEKVDNDz9x;寲ssi2m4}G4ߪ r}.1Fa|ZvTrT":hom^+C7F25ۻ&F(EQ rn2HOJ Mӯ43T|%Q8ڝJVrUPn0M=F3X/"-'*ـI1Q櫒kgWMo~Lq6u}OH" zQB>i qΉUwz挮 ZU4<̜86k&?E5Ew:knp9tՍ0KbW*<0_E¯Χ K}q{9jTJi U3L_F9YC2dz+ aOc 3=a7x,>oV]vj\|#^҆q"k^H*t^v隹]{*+2^9}dz\X4~iR /4\ oKil@](o /H|-;" s{yp!;vQaM2c[&)}D{?ݔ_{f"əc}oREcv0[h<7E*vI>GݗzX+>4ȸr!83'Y}mRA2F)F5Ԥsy+ߜʰ^U8r}FKkTcA/#oM#i|y+x˰E ԂdL搵Xx+1ޅRpz\%qz"]'"pt7Ck7 /)j1Q^=s:~qoEK8@ι/G悹u,T6/xnʫY;*/qB3xٟΧg*˟p09}L>[n;'B: VQ1SFLTzwΜqzZԤ[c\}-z?OKoNo&K跽}UDoIZ[pT~wa(.h1!) vD)d\j2;aj9l~ tЇ[@GdR1xz ^j"o>ז9̫l[n'3MkI)-_O1rU|3yl#?)ؿѪ8@t8 2 S Xu4<4%g,[\/GU\+ ՝a릭 &;; 9c:ͻU'&)撍p#{"קfW^~x Q{?9W`fѥշp׾۪N깡gq K$7ƅy.{KU^CNHr2|! ]@K=fH3U!mZ-ZɤȣMixlj}H=9[be~5:ϥWwE~Rڥ\)|1Q!y^yTr`Yş4y&y6!xS{EY^Y<߯&R6Tڵ b#}#*8GSNJa vΝK(4R$$/2Lf5"fPޖ'ʖ}r? 79\D,v?r6Xa/r=S='U`QdMEsXwQeډgl. NRdB[~:O˜ e^;N7peo[wa5R ^AG>73m-.F٘i'Pxz%3@ @6UtQb?ʶ6^eS~z~UtOLpgj[iuڳx0] >4-uBk5|zwtk4xW=x4镪FZ;6^剝KJ=b d} 2{:r&8 wjBnIef'<|Hb8P JhŕǝR hi;r$А :/7˿I .V2nݛua4r$KumZ=}q[B (|UKIoJ3L1y *LH͗s;[VA3ai_"=OZ$CU~h<`L 7!66K>zKm>G B3í.d421+6|^yϢS{kNym _1SqvOPJhNqy$\X^`CO a2P_M9" 8ĺwbk[sf=ҵY 2T˃61>B0!tik}/8*>C?,</wɋωH\V߭3A³X7Dy?p$,/6ޠbla!dLy@• DV(;v8c<B2aL7BeD=_x׭K*Wm0BokQ §>jG=LU3I ɿq.GshqiP%tBp-Ἰw:@Gm/p3*E527c/q҈u!#R1'?B Zk74=PifuT&&خt~]*hp$RЏmo x`Z);k..t%EdT~6PxX6g݄Q`q~kc' @S/g~͏OO KKhjr~z\cT1m77}bOI%rJY6  _Q {\ғqm mA~`FztȉaSpu=#x}VX70}i?JW\7{x q?rQ!N?^ a$5b/ONz&F#tZ\S܇\%uTD':vYbʄDxR>˻zւz@T_r疸edyglX%nz!z Gz8l,? ɗFXw@RhS_ѱa>T^^`v\8AI2_3Z˳kNLR'-]r[bme b Q m(٭bETr (操5y` "e>5X"e`Jq !;c*!xu-5GP{Α_]FugӼ骯O@NW^ h#sCːs1*Ñ8v-pC\vQ%2ךE:CF&~OdmWV[ ?qYh-lm DO4e %T\ @[|a-xU"O 81[CZX_67ϫ]nHMlq'>XP{GX"^oN'1J6;<<נ+| #*d Q'c۷jkT"%ڇE{u~x)A%O2oth{JcqȔ@uA?嚍%Jˇȷ_8g=x _ sW?֧H2kX* u+G=eԾ`@Н(a E V[ЪG֢rcb*f%tAu 0r0Ffo.JsF5çx8y okdvBW;닽e;|I)siNjcm1@'jQnZ)kLS-.N.r5mE*eQ@n&c -_e!Ae=7>$v ϸ,!jGμ$D"3. B[luy^0?ؕTfzK^ݗCxLI[!K6E9^ ^'1cN-O"Ů;% vuHi]9 Eyq)nРۡ701 )P< X:}XNh|2*3޲piZV;LpuVTs2t9 P^v}_R~9;C|l{VcO!72> jy .!$Ixi< 屳ƸV}hc \Vd>xWۧ$̊(P,~&P}$`CfXmqD2}HIgQ?o.y6ۼV (>$Q`/w !!") endstream endobj 265 0 obj << /Length1 1446 /Length2 6613 /Length3 0 /Length 7585 /Filter /FlateDecode >> stream xڍvT6%1:I(n1 c A@ IiDAi) TIyw=ws_swLD D"QPTb>>s g "(aP,^ ("HA`,##T#\@]4 SC{anX|@~"++-;c0( hźÑ0 CAJ/zˁ@P(( @`݁p_8hEЮ(+08rc@3}7?_P 􆢂(7+ 4bP/G/"xߍC*&@(ߟ|a7W !W%k\H$O=VO:@ @!|:zUtnp,P K˂p <<F{]W8ÁX<K肀ap7 Ov<}s pA:ږBmRUEq"b@1I0J7C' ''\+<X A, M?/V_ E"Yovp:X(~3TPn^_"Ww1F`a{!Ppc/3e'ǯҿKj`h_;'&)b0 ~xI@( ŇBh <%d cK[|d[AXw ?BagbpꪣR?{caWSQJ%cVc8K(=;WӜmz O2cLWJ# ![~bnII9c{_¹!=j1Em,H9foxnLeRve";Ԗ]׮Qi!&RgGjz}!ʸpلz\ϋs&(6Uj}?*9_~zdL1pJuSr$Tc%E"_ߌ4+L㖶2};'Vr׊䗑jly>g&^I.GYΌ EO»cco(G=덊PO4Φ<7$Fm ߋ D4*$ܿd}'e~ l}KKYA4ұ~;9b'jÐRz^\IA?pkjv-}E5֣fM|YS-E֩P}./)-2@ֆPZ. mާMUOgB Aؕ9?)YO (ߢњ,ꑔ}U.qoN1tQ;piӮl{)%R۬Ev1KqҎ+i$ku)aBh :JXR>wf aFUakӹk/8?V}!d8q+UgYl zQqIf J~ SoΉ2ljb)Kc&36Squ֑vi~^Z=\ʧɾԁ$M'RS'98܍ qEIԊ&U%5.'p#H,.[0vKt4i(9DKlpLWAܚ7`AZ\#t}ݏ`Co*q?^Wn?Mgh4QG$vY~K:B{۾pxGWKE"N.82o}~lTŚhJcۋnyu>=FiunP^jQCƀ|2* vj;׍?]Ռf,HTkܘW 7dv%vVnq i6 ޼kdP* l!j*,2jZ͋ 9%F>s7XHjaei&Zm~%3V&,%T]垨`h-yQ}^6uXca&vH 8 9ӱuZա[V],uyCv]maNR֒w圎J/vڷ1p?If#Jzf=I+ "+`4U>5QE ܹް\dE56eǍ=e'tp:'?]Z|R{9ť"ЦzS4+VGT#B0Pw 5mIB4:uJy=UŶ?t_,{6D(ѝ&~!+}!Jwܷ>V7^yS0ϐ~yI-Ob;.V`3{H&3REv % X .!$~4X*lGt2 x=-±*\rOAHjIF0Æ@[ԍ lCLuZƷ~Y7BK31ĭ u׽WϚ<;nCkG娊4"NV MpJwl2Ae6zV}%slٙbŵ[d緗Oֻ{U@iWfW$kҌr'v-)PY| WOPd9XI_}l^tfR%\&u$^H|'|ztEKkJ ޘ0fydRyuAB:$iW(;и{m_TKg,֣V[i7aaWy thųºuM;] _RAh6ll*2 x1wxmĬn)Q\ir%CWYݝ^"|4uV~k3ca֞q W`9qПUO+NWy\)d~t;qSJWly4?oQ Uߠ@*vZh8i`nsj2i-<{& .ɢ6)Flyo®g{"& +2kwSoH ; {zgcqD%;h<]~1 :yPWrׄڣvQK I𤜁SZ+qb6tx7u'f) EPsiN]xjfjcUÄt>SIHn.f=0;};>Uү7[8^t\޺b}w(!{(1uNJӛRw\{3 sҳ!ҾWGvܐiN{M+DȾU U9'%1l "-U aN\KYJTf5Bz? Dvp3 h1c6Ϣ鶐uZԷNv^ut^ >m7sey0&Ym=K-)Uzn}8 Ifv۴߀to5kE6U{i&ʾ CaӥAdǪ <gWEO'%W)?` S[^}k~e0,S|OUҗC\8}lbu{5\Re#)EFhq'C<\w"Aj8|DDXI},YhE)/d#Knݥ hnuүPW1&oG"^!uc?6r4zQ^<%bJ=(x" ǣ MRUeUߎTs;&l$j ,{c^N;RQ82\4pgYV54&IQdw5ŰE6a:&g ʦ,U)R%KԂNFro( rBSBVl ,߼3GmV&=W:lKȫaDu4n>Y '9_bc#IYIJgeHd`:7/tkZ.4¹Tt.IPOy3:m?hr10lZ&_1F;;( ﮽!wV6&mQD/Y܋A6#OzψM D6G3&T 2U:5$B…e0.λoZmQ^[+-**B%x˥^/z% J 39x +K~"]xjSx $q/i(Yu,5?Nx#;%Nm,EMAZ(sϣ\HD5=VA ]IUxV(\ sms݃!v|bj[20o 7\qTytҚ[ڌ7$N&z2Ϲv]ρ2LAQ}vo玷c^;ܱ%Qkte`B(طX3F՟Rdr`o*(bD v Pn`һEU<&ZK5AR'hfbߨjx+RۊDᭉ*i#֭I  %@>A1;5=DPG<~CKt—O; SpMʮn4N.]uQ ,eU 6_L$kHS/c`MdAlE/ ^t SMW0(p%9 R"w*G#&^~ _GQ .3my{iOʽEo-X<UۏI|iJXڊ|E2aR7dTp𻬍#1]\T<$:0$>28gKʏ,qYOJ}ɻDUefZ'?jxm qiZtݯ3b1AzyTrқe->mz窫} @FG=$UǯWiᛓ|KD\ KpPf;bw|w :Jߞ]HQa۶97~ t BL^0DPv}_aonW:ӛQ:Xk']8Qml!͹*XmUd.!݉ 'SQ\ljQ!~e>+Mˏ/+.:JE6ʇn_^k e`z-uk4x[{ 닫+'W(^D(׌Vn@FPWEG9f^TpL4KĜX& I^@TgiSΡf98bA٦;HoEVit!^uP>4h\O☌88W?5=]%(+e&vۈpM "½KY{1cA~V:0ITErXj>`-)$F#sv^K8cWشTXt-o,6j BW/M]vߝ%Z'4?r ٕ endstream endobj 267 0 obj << /Length1 1861 /Length2 11835 /Length3 0 /Length 12983 /Filter /FlateDecode >> stream xڍt6f3m۶il7jvcFc169Z߷f\scfȉTM퍁v. L<Qy.+ 9 o)ގ]&fn&ooq09x9y,LL6wY2v@g8rQ{O'Ks S20sssv,MF.@Ml&@ Ag`d`d.@MptNn@S_lc#YX:-V7sq7r6&@;wW;Sl@ht] ?W KF&&Fvv3K @QBÅ`dgoF ae{~ř  ~v@;gY:MoݓwY~635+SWFu;KGWؿ,Eṕ.v&&&Nnf0`+= pqrxo 04q-.+dezoF=Z/xq =! ڥZL<-i k_ +Xqpupog(DeJ 7S:&m0R}WPyp:i@A>C!*`[LŖu&!ؙN1Mцɰ|>Ù W)?+ͣ[M&_$t\'ڙoY#Q,'^)Xq*x%F/ori?&bT)7|R𡼕L1*'ookEj4wH,⋦ DQ=qTv=躝i6xwmAziHev+ĴrQ_HB%u'n!XU6_Y86olIP|xfӂD$w{/!T\-`8qOq .ʵg ח 40ܛ/ɲ4@z1X't K၉AYeenN)?N r#cbS{]+1%58g|TX<@q'?k>Z;$:tv"wGrJE#,u61;GHy) M>?tQ1 -e&Ѵ"t: N6.8A|[puAJWΊ CzflX'NK)aNw씠kLѪ,I8d{aHMyx9aA3vϢcF6K+SF!N[yۅD6+$;nc,U{UV uOc͇t]2{k p/GGfX"Ǯ8"H=A:l[?w~*4n siR)XފҶu%}q@6u5 ~YX_[g|>\5U'\#rv\?UIyړQXdhƮgz`$32O0W0yx/%ܴtƬ-ܚq`>YKǫ$ԳO -ͅsx/j.KO͟# XJ~q:$"W[.Emm _;8Ź)Cs ׶cv-p0=;$Q9sm~h JC *QJ%^Ik{+a]|+8H!F|phYG*9jSW@N28$P?_KS3DT*;O1H9?u!It"'xLlDrΨY_בAm33+?A1Fʄ>G 1?fKiIFvH/#P>Vaw6 ~*M ֺЈr'*!g%a[lA5`a:,1h0j(k1*$fd (b9bQ}?*T?CG`u"lSk=,ӪiF{k)Rm^Q4 !~9 Ymզ|p9FI.FJtqX<{/_CrGJJRO{z zLx;Go1Z1Ȕ/_bW6I[=FI@dg>iYqfi@QAY F_\%0lzQ/l;X`вUƺԕm<&;pieL:PYa6)39ňaCE"x~;5HzSͿˬ!( ɤ?"Z1F~˂9j*VaH) btz8y-DiBdž5,jF{HeK *Oe ?Y.Eh>SWS,i ~tplM9kx栗8x'yIN0u: 4};Ƚ}HA0k,tM;956*m][%9~Q9EWa[+^|-4\)'ڝʍԘSȧsPSKܰ́73~I#I[[C;_`3)Z>G GQ8i,{|dny.Y $=7cdUa)FBj@O4nM}_h# %TYk|KA FH& Vt.hEt|縚XU?LNڄ')u+.3?O ̆l}E+߲A cf%K(Vlptxۗ_O: E7y<ۿ}%L!˘a$'[@&J|;]X bܩ؇*p<;(wdQ6ehJK8mAO5NhN N1]B\K`&)b||FeR} e e"6(k((\ i1T͋A܌yi:כ95C4u <2Ì ~洧O蓒KC`$uE%|t41Ix6(Dq ]pne;>Ռ~\3e>dHm}_[@CfcSU,c>X`X@~0Ex"Ɖto0캓-L h+@#-*R ,nol4QHyZRJUlN[FvozH/^!3i!eeϗ!::El#`V ڟ+u/[dp.9iH(A''*b(Ȯ$ ~@+v Gi~ֻFRUG>dx QƏ2} mH JiL2[ȆC8'!}-A@=T< l*Y@42Ft$dS-+) $Eӱ_PWڒt{._%a y0Vl/OѬu l4s3-xe03m|o >}y8נJ",X%.d}ڲ`O~ 83<X] AcKFSQXGf.n$XJ\ |:WiE"Pn؟_â97Wҥe(cm,x/lI+?2ṲҖ-!D{3w 7n"iZh?i$V4a?B-N[ubiV ]6NNͷiE!x6Or s$weu"7=c]SKAn%OTsg~ZFmv0xTyǩΑNF/+T \evE5s^~2}D׋'n쪹oiUzU7.VF^n fij@b\ &HJ\S[ɫ"Q=3`us%+1܇,Y_ Z>5K@wA{dLؘy#mePCfAvUWv ֆDl\HlfVʽӈٖ筛ЍX𑚵y~ؔcgM|:R!r9vƪcpx{iq?G&++.'`iw^4*w-&1ݢ?,wD5l_"潑v>grN>ZYmSRC՛J4lsʞ ZРQ[މI=TYqQrley轍3r ҈ϭ-gLXVJ~q׭<a⍍Mf폺 u1( є\FnjW"V\j6C׆ i68a ebr?iCX4w.Y%i++?Hy^ ?Wa \Osoyl8Le=9pyئse /.D oPt?d eʭIO6mjF@lD߀Kȧ~ƦO*~?eqR4|F(Ljy|hЃFuz*.]t sg@B尯^|K}T1^Dl$\W2S߃h" :']g ۔4ʈ5[>@4f~Th/n.xxZOf^(!Dݯׯ1JLlv$zS,Α4I랙hPHp1)wԭ&-=|jA4e^j% őyWGlFVoɡc i5/\߽9 ѓA}cq:snn~2 ߮rFTYH.QӠ?iGm=fڮdjFwi6e:D4ԶFMG/KqV8Mvv]=a֗U"omQJE)ktp(T{g|L >Va?q@xkJ}]7,m>1TZg}QiM4=)_3=4@S.R|O;\^ђwL٠g&*}Ӎ"PQ&HKYn%+JNԻtVarp_LR5R۴n{ )vЗRa)=(֮Q@Qՠ)$/F{kɳ ]jMݍ>/^] < 'lc6`? +Eٺٗ[v4Uh yqwo~ɇV\cܭlq3Y2L'适Jvd`a`Tv01B~+70'gc{>K3fpSY=rAZa m"bjqu%^ؠdeƿe=Ɨ ~4ګZ5xx'Wuv Nܟh%Q:}|tYo<{EmZa~9V|Ѵp1<e)\4D՜ j3B3 QaɁ \GRp!p~6܋9L$gXBp1,Xkѣs4TC 98o};!? si0 oF܎8ѳQYp5ʿ"'(~ƧD[hf^ mvi Mʣ@6߷v4ВT&1[h溨`3Q! S[6[kǣc,Mޱ{6h64\U0nj!>r~BߌxvdJL¹oPU 3ʪnk?T\yit#BgA"5h-o۸ż4Z}%O;f$wVv=nK"%@*mw  FZu\f;Z]ʸoӉdA6Q ’Kԡ;Q1m4K&-s(x~@PE0ŀpH˩p}vƧnj: 2E#tB<6gT(A ]Q-V3lMl&DCB5?mxE*xC1AqI@6lWzqY+b{Yk`ipӤ I^W0 '!<\Fz$:OPjsXGiOd:\di2f(QS6LDAj%cZRcY61y hs>u \ "_pMoWrb{J>.!< w0@Oܷ=.hqPQZB`*zju:w^o2]4:2d%"(Dӊ'<0sgh-pY~ƻMZ ߇ʖd@L9E6=~ ~St;QNd<̝t)2\m1͏jA Zu-#in&y\|*&Y] n|US 4 dTi ,t[/)!_&}A>fFt0a;ٷw+Cn)%ŬFb{\6!U 2 nTY>GPy{N+Af&KJL_C= -Xv 62 lxs~9'5b@3lq dv`/׷WΠKޅ2uB zniptWl y?+Txȧcg5m 1Dk쬣%ێd7|k+;9.)kӫ`/n !Y6ZNL$h r S$U(Ȍ(٪Ux"բ-, ]@Yƶ;>Gj+iTGSY֢Q3ZAjzpA|mb}-bhYhN<)Rb2+I~d2\1&ҰGԺ!UY?Y> r^|d{dɋqw*[)_N^_ZD;YXkE}d{n"f Jazt5 >vyſ MkX:Z4 ,=O΋1E 8p{Co돿 Rv H0uf}¸q#';5vg ͋9F7k0e {>[~=O:q)S}En9Aw#hD:&RY]3͋qG&;3s0TwTyɌAUjȢ|h Ia δ%M}ϛ,0/MOK$@$UX((‚"m'e-J NDrÎ5}c00|l5-Y{iɬM<\XҰ?7Z樠-fTD/뷴6X8ӟ+"8fcLsHS2ѣV&Y06pi(Yue߿yBW Kx FsٚNV5zKlWDvKʭk ]vFR NkrOFB-dUl*~BZiVůGvGW>ʨE̦F (;VoF i9~-`\L) { &R$y Gr&3^l%p*K +42d}zI|" Jp4؞b<#_T;el!6UG2Th~em.Ǝn7+J/gK1GM؀J41~R6*7H_R|7Њ!'v5doe5$$x3xQpyʅ+w"\1~5vX|L KnD&ˏMy eqEu/ٔMC3a8ӖFn2cF*y.2Oy&dh¨施w%Dt#;q :Ht⛘|C!]7(,7*_fVvy:~s] ~괖zY X fP +8b?3! qRdس"_܆d{n#q2lulSswF$LX"p%Ck>IPskk"[7|O)x5=¸I#p?@g+a7'm%M!된Buz|W|vy(E2MnkHw&'Q,nvg>`Hxx3Z3qM۩3L[n\=Ix2֔d;ȇu!|I ;3F¹HrA[] :G70pp6"1˟/SQkڛ"jiq:v|V3BP$jiŇFݻy@yΚ*s˳e-9@Yurg)W]2Ӯu~Yh5hPJЯT=s`}$[r8_^qMyK IidUu Zx5H8~_^Sv$Ui+UZes\<7]Jm_2Cd tΌE[ /B?˓U `JU%˅'PW61;~_jNJ}ٓ+ΗaPqml :n& +oV^SV#R[X^ tk4BDZ4^βbHTo(fN(bSv,œX9i&a*FA3Fcm~"1c̪XN3p|6HÆ' )88RA-m[(|Nylzŋ06gwA5Ska&\1 I^G26XC7({bř1 '|+7l@%Pr(cĂ'Ӹr\} \US9Vqk0m`vv..qTn9wH?V@ԗ*^{,=1 ?bͷg!sIIc#ZP70F+'^ӫbM:E-ק&E_S؎^1xRP "L$rQO5vV0A+B--RW]-Eߨht''UW ޣVL+~"E#x]AC9:)Qo!9_ƚZbAb=MB=Y`”Eu[bU}dI#i7t|kDMA6GݠՇGxmB='@Y{eR8~5~Ogqy"%7~6)Vǘk,¯> 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(Ƅ@ аvˬh0q vf@7s l@ W_ ] ?G!k?ML,v@0q0#==O&)QUɻs5sv2Z2,`.hot"Oh~^o ks?$91k:X;e%nBf 8YXXy@g̊^N?89:,%-|\M܁矎Fsk3hiww3/ykOGc/2wt;2j))?.11GO#;/~*oZULō޿$ݿek&h.>A}^yL?_H[y>nPt| Ċ@sk7ʂL7C?h*e 4WY5@{y;k |ffwO}HI3G?v `bw a}_Nss `frp,]'7Yӟ70kGx̦#wbbf |R-@ck 0qz]`6|?`ba;|n `|e럥y YY9r|g(w>ގN?{Wqf?˿3u|goO_co zVCmBD <&(3h}V\:Q`Siks\nESGzH܈6F|OVm{}6JTkCX08U|,8@OȨ!d %GYƃޣ_ڳqrm<|qOuKr1N3V?l4w HGq:s;?F"Hw^⣷QڍGKy1>C#+Mgɧd}pٳU$!}[vZCK_J'ςT@(5 ,#2e6LP=-WFVM:*l`49/cbC0XDib' ;cړT<> CIw]"y߳~<[闛^p.e{ Qck ׉0/Ohxa&mp㕊/+TnZEt\ Cja,2 zGq=Ԝn.hl #4QL-u |;INے+X,5f:U Fͧg/rLvqq~g^d_IWҩyP26t3EG0},W3̑?T,#bGurJM5ӊZ Eu[~.:}i.0D)Yv=!͑5CםʇkLLMHi!waЏʢ#%#_6Ѕ^y2yٟxDc;7_1ם'zi+sC&mvVU32YP wV~Vpe{5Vhr)Oq)"mvVw\d-?1G@мp0w?`]7KJiVSx+&~>E*9Lg& "Ə]M1IRc QGaNo"-f-,@huĆI5 #_fjɺ.9鶃RUPRE=kS2^ڐ2ݡ+%A Vvc7hvֱնZe> @M/8.3΍^oL =LG%ls a+vW{+,e2eM,Bwf)kS__?nl,͞AUw8sSΟ]qaQhe۬ r94#$}LimKP{忞􆡗(H1@j}&6[iA0Ȥ➨H>65guTAfnܤiI`"jJUdM]E_&hMFn \kުj+Ǫ,)y=0>8*v&yz}#0V_0׆5&͡nkl˄4עW%~ȪcqC andFFeXC|`CGɖԧ U4UOaPl>Xb/+y/v}]C$Z?^w&~sZaAP袭oI/A\՟%0K0˵*xPVk2&Z{#mx L"zsf: +RiU0&:n 8iJx(b1[&‚AM7P2* 5vmz`z@p)Axo.\㇇Om6QX JjTzuq`{%x^!Y6XȶHc"9)w,݄P'P!?OFJn^_eEwȂ:3(<ǎ =L{:Ҽz̘L%W j:k/i$&%PL|*9CGP`rw\H+HTg^C~,WsF{uaOђ׮iJ 1Ѯ%i2@WqRM$hh9&np&Owkuh/;- mB/fgڅ59@ H=(I8p lhnGk&Yl|^jDA|/i _7 .(V39&\r뙤[حuJb{I:}S:"8o&8'3Z|/@-è؋=vTZ% Bs678~t铋Y~| _$S+uӕKvEg A >dH>C 5='tӐf1T'O ~nMG$Tpf̛X vo&00Z,,14mPp!MlHZCYY@9hW^vcv@'Q/ t#Wdl4sFO];_x!] moQ{B+(ڇNLiM̲ATWu5' O8G z8V"cOI,7-KF1BӃCw)"frg'q\@ʺ:hT=^nr}~-YZNb}IEo#`hW̾)JtuWWNI@KOoqY,6@fxv JA"J=?Z1=r;3(9c#׀Wem |ɏ$jD88R[A!=,n 8 c'wD}v\NS48f&#%hx7S%)`N[iLexO1d&؜G">8l5b['*,y ڄx,ٰT#Ɛqsu6CcLg&*GkK'V/nxJ*ہQAU+)<3z/V,mu&Zx$XlzBmj"uNtY$(QaM"]opv#a- Tۉk0&"8kQwt_4gk% 9JGן>bκ6x_-^uV]OCo.;qǮ8caz !yy=f0js>߅/2ok?5ӕQvXCdelh6A#1meP RIpҠ1 zG +oK){TmRoϧXZ?,J'a0'&k*$~x*2]f@LT:H@.C;kX&1ǖM4[h0İazaF2g@x9RԾB=eD9z:/ ý~:DwEB̏v%o>fB-SR {@b[Kq. 9I#='DB R ?-pQ[{ |53zljTJD"iIoō 9M] ~SJ&cKdPw21p@dޯۦ=+P-w;'֦rJ8G=-YtnV|oL3OH:˥!LAY08"Tщ3ݹ[6KVMX,6$%␚`]]͟A K;qr *G/z[6YM$z3ǟ{ABq'WZ"P=(j\w6ֱ%XKqL~8[j`A,Ob,ʏ[^ X{N?m!Q]4Qz/_v CG!\~Ic=N]IvuP8͇Կdf8o(*JNZUJ_)Rk_ֻ:;'sur;;'?}♥*'߰UPwrзwA>]]y;]ʎ vOmycȊ:Xq6<43J, _䔍G9a#1^xCʵÝ]Î>:쒫x{)sKmOZAя:u(mDPe>-nQ9ioTl U5+DᒓLu+R_5Xs$ں\)Û` c܂>g=,hZ&Zj%SC]D  {]`ٰxPRwKnS; ntb|ժ.q2˧bcw*c%N3HwLJ~jb_~u zp?l#!Ҧ+Sv*FMqVηYEAlMa>v+@?0& _Й# GHLfTv|,ve ),QƧ/~@,͹*q+p@s4 l̗ӑOdH[3kj]ъ1@<G(d8znZ悞Gfi3pdgXK_Cؼ(xYJ9U>%HFX)sbD[ee&~ z[z> RBԾ\euMZ2^ _'aӽ$չFWZژ睰Ċe[锍zԂQ;ym\[ΉhXr!T (I>n9f3Q8XN~ W! 2_L>j2EDӰo nQW+75vc_}i ?\?N^s3\V1-j R6I'О*-r.!1ߎIZqu JP+O:eUL0ӲNzQ_zBI禀2)s!2B o'cw3}FOz%kfj~*\圎A;#?oa[]e ~PY1g׏W`Nt*Np>l8E6wk+>|b=tTѹԛ[uu1 "!lc흲~)خkq v0t?yE WUh-NɦDB{PLp㶊#FIbt,jVN=C!+̙I|c;˽,{JVKZ3ocz$g)ۗmkL.7vy$ ߚ yoSAc+<'F6cR=QԠGb(Y{hK:]\f´ˌf@Z=(ө:iq&a b AU-}Үgip wz~q }k&GKv7Uq$8C݅N)A|0veC#~`+$b5]H*+o \~2J)[cdtkqh @ȇ GCPol/20X^wr1_!cR{XZc۟gJK=kY Ky<_4Q=Θi 3/P N{s{N]dmw trKw<}{s׃NjzJ<,}/{ỹ'u l2ɵy O-ʵDB$xke)s8c8k{t9t^,HazRVQ#KaڛtFl73\55QY.aHvfrW98nH(>Q[y,wS.\OvWh5RxV}&gc\k"jx3#oIWܴ^ΒJd@y'm6+erʹCe;~LU{kИqj ~z׆icLSq2=/DGlm̦#q-x cs:2x3~eIOoIo 6zPp褱9z:{B8,K2~67?As~CK=hb].ۖC'z,asin}iA u_p H<\XTg/Y2O-?,Lc!:O@9I?YQdٴ58:j=\Xsu< l)y?a3w0{5Fb!8MTK8B5u>WÙjKIh(80-rDC%Q!ШK2D$:RL+Jm0SQIA*)%nK0٬ J{ п $PZ,4,켣kԋ#lDE  GKHwroR ?ڧWkWm B1hl)%ƒ=m9` 6tǝ *>EeݣE?Hēp^\fx^/lE~)KDjM c@=qJ;ӌ} S ^A}e lꩯ )sXeZFU/$dS% +(AUfӕ= L Ƈx|7@zČ˚~L3ꪽݶfU^%ynfbg!F $Ai|a$v luᔲ/L &o6ذ Nդcł6of캬"# 3xyA7ō*zV=[$oeнsg|S5`l1ex3Mc9,ݜ>J9枝؏M,M#”%>M{>p)̲gThƋѰy7Ws;p}zMt<֝k2$d4M0'wͥ|1%N(Cb< H6 k\6TDC*;EB1ŷ"(oPxZ\!fz0BNL-{g:d|=g00,4gA.ʆͫVEh_ pU׎LOP6E^}cexf\&KD+.47y`QEtycǴd%$ܝrHi3e Ǡ5J+yw;p&#[ v[j@d5fwB[hN\Ls^‘ܧV?W& GHVnWwY*ۧĮ)L%X?c(H QGw7D6s_s ׽?4S~"R Q\\`SA*m)iõ+Di)]&Տ6pUgCAm/|l[tßɆ'<k`ƗQa}M 2gx|K s3#=O,1pL.[bDM-!_~D@ UC+Fj{tIKH(c!%N$>xKя8@:Gkh =57>ˌGu>LT;jq̅,@7Sp3ӭۆN5I.T#|[1z6U'ReaΩfofJBZQLq1FVW>I"'|mS9;Qr'dY cy8r1NՓᄀ(EjMkֹx>u\7nyՖajS דK淭Vzy0 !l]ʞr)|B]͹{iP=4sTɚhyTKdtK*^4S`|>pNo-RXIi@z1:8Vi+ͳ- ,^ C!&aWQ_4cBRlj߂l6:dIrTˍ`'1j}/ &Oy(PYu?=״nG+U.d񸖖VWeosS swW_mS)850 o. ZM0& MσJ 2bX2iBmDHk82ռ 9` 7<{ߌ\GJ퀄˟Er+tbZ4Y\(&5sFQި*Q/;ؘؙ\?]Uߘ lACN~jǁVf R^+:fcWkjn2TљVvMJ iD]#ҍ.W:̇mhwb;UHm꿖)l:w|TJ{I?a.R|L#ԻA ]&\˞3M' ?Eܟҷ;1PF{Bg{?VVdI4RXyrTEt'3|`ޤv{HP͖\F&0ZpF8$x KfȃF&SKi Prsv:?uLx@zֹA3{"N( +n sWۜ{cqG "Omo )pyy\Փg)Ha{dSet]}1z"/W}- %=d0H/ptpjZ6s&7]TV i Ou;_]Z NިnenV7t}sS njQW9@Bh?EӢ 0+C~tCUkv^ͲFXtԘ va/N0ʼneP[wT+"=3dcX$l"X̜|' J$3vXrMA][;VU Kv¢ivyNYhymUݓߒު"ȲGٷfy3e84dqe5eYJ7 aQ3v Ls ^\z~%wbg5Mɖ,M$ˌ_L8k q(\ a v}m> stream xڍP[-܃kl aac!CpC܂>ݹ}꽢 1m昫 r%Uza3 PdBWcf01201 YmG$:9[yG&f(ȸY<̜lB3m(쾜f<|N3g$wePB6uiihCyA$YOk$"p%~ ̏n \2|N$X?|%z6vxsL 7\_Ţnݏ`SUG#3&D=Xw*tBM Qn15Z&F}6I Q,0kAmKܨ]bl^;0`ev|vU^ezH`! 5, u+ o<ujsd) !pt?";i'YD%.$n5 kMA~ۊ]q}A!BX?/BO,/HK-g݂m"p߰_)_(/o?P=gzO Qc0 (x'QݚL[r8yT:L KތZ#3x8{(w(iyJ{Dq´ I@R)[򭑦biTǚ onKbP~CG,;F|#xQg\S[yݙC֭>68B \^2BL=mKQ_ ?}c&ÀW༑Jd]xHe'qm9(c~CİJWKftyK-dy$qhDao[P=JI-}⩛(8Fnbvlz(FcF7Ҩ_mJ)zTMvfD'+ay/8/.$:;7H-d#:Z*EȪ7h Nx+n/tQD-hVЇ(X":x::òm?aC@`}XkSlpQDO 5.H (}n6^,Ʈ7aM?as@_62Q9`<"}w:* + ګ |D4ZoA5ĈȧV╫ʐ]lܥfR-X/xB .12 %廵䰃>aVZ9I{~,7SzTbSbE(q'_$R !|4HǩwJ,'$ n)Crux5W vg{_N`lY~bL=5 f!IE?0P?AӴ_˕Vh۷؞ᧁ'iEjԥjvΏo iMgM;Xf V_|TmB^ ?RB7e~iuq,`Uv hoLv$F^o%oHsP &X1ֺndQt9iK(A]\=X1EmGG֥Fɷ4^J}WȽݵ0Z6na3!M,r3˔^3.AU\K*ӄy?OIu௴o?LFLpY>w| xWZ|U_GSW\(8Lc?ȥD4Wȱ~Y@lX|q|a\J|UgbR ;O< [qEBvt qІ;\kK SX8[ED9''xdy9J#㤓"ߵ5QXx +X+Ypy G&A_8!:6~;EUj17c2e{V΄t_0FCk)p={xsP{/;xb@Qm & WWjS{YcL< d`͇cx8su TKI\vBz,J?(U !.i9 s.< T ˄[5jJ]ښvg0[ZNBn[X~}/aW$?0=qEKRfiޅyA1>#B)YO{^) u9kb6\K\?EdrZe2gMqfO?,cy΃$=a*P%g 5##LrdU%f鿄0+xT*5{AiÖOO0NjX, 9[Ɏ֛*4*c!νJL$Mꃍ"Gz37Ns˜_uq"|pܣ6 NxG$ncwqŸn3Sӑ0Pd5YUA*͜L&N}uy@t/cP4CM/L-aB.i!(r<-SP?VtY3x_UylV6y?]|AO-čyNpi(d9)ZP?1^RJf& Y ܧ )F^*m-p?ɔe_YCs5 MmDߙ-"4<!Dž=&O}[~`V"9jl0 Ȕ;}xп\Ηi>9&?sY l`*H#b_WG=_vчt<5R}( 9ik 3JH3͛SfK N{MN`%;csl^W;{ȟ/co#Oe\۳ϔ6yF H.c%V PϘYXЭ}q"ҧ[S%6 du8W"&ZwƘK؏*gV1)`|rFZ ~1?Sқ?Za,RA a9t(BɎ2߫\Dnm􀚶\鹍63\\?+[tb+E'qWqzPNow4 x)12GBKyCsr{kВF;ۘ}BsN84<8':GI '%1ʥs1ϊݵhDo7vcA%,^{ # בBg!f>}3w/9 _=b?FwV 'w>(0/;Tx~9F-a f3ә@tڕMR%?RQ:7hC,֎1Jx?/$v uG_$rInr`Lms-o/_γK朼CA\r풷{ ٥ڒ//Y18$m&|U,P'M9BoJuEQCT|\gqO֧^}c_2<W.e 8ڳ2bX#'VW(HWfVnl~.3MP'0xc6(N☾͸9' d>T'g>tP  m#ȎB|Z${pFUn}wv@ž>) г ѐe`r,ohǫD TE$G/Ÿa @Px} H\}XOޢE/Ft}*ңWzib.\0RĆk|.W#[\c0C0NUbǡzغ9 n>dWGRq %dYyrQCϖ?B'&v i9{]c-)l rw2oW٣F-~1 ns9tIv;3V__QցϤB7jc$s5o XK2zdl PU<0ĘtPjbʮ~{BQUA+6.^T*D 2!IHC/gH׺ž2U0yͮzص7W&=y3y0X|l!ίGM D"$+Fhwߙ6(}a{x~30UVs~s@k*6 ڧX]`BÔ6N&7Ï_}w)ٯ[8~ɘn`dEF !в$1OpP3|_AQZo#|sfY]Ƭ׊! kUvQt?HBQ5_M∟Ԯ ls&h2D8yUK, Ԃ@׻o_m2)w :x!2E)1,^;+ѵM<4Ct{b)_U -P,0vF#lx\& -8:_j:Y%H> XD>clLUsYЁ} |k)ڵaV3e_1P[`.\։.՘hO'zw҂ʦWcVu| |J5W7Sɕ[YQޚnGm(D|&}N4͇ƩO1|#ZVҜ-k*WiGaءѯ,p ß;w3N>V;$iC&edMl=N/,̭z_Go" MЭ54G>XOjbPg3Py QJ JMj8xP${ȭFږ٦̩2SuP Q%W~`IOPqh)(1qM5Lj4SoH> YM|DAi)W+䔇@\i8|oKȊUkm.9+WΣrs`L&;wӈ*"sB woW2 ##~z*՟lǼtH8$XG9xةI._٠WFkMD~2?tx1I25 Oa f/,BW BWPG\Qanm,IS00V|𞧲 Ef5B\Gݛ& !̷AJ6+I\0YtavGtⳖ)̼>U +ѻMUX9<z-5zJBidCqnEk[Q\`~ʅ Ye[E&zlf](u2{'Mӯ=4SmLٍN $oo53V5~H-^nogWISk3P# RޡJպ X5F`9?Xl}hgͤP`;6*|t8&J)o兢>ʓW؛}?eٷ!V%Bg^gdruP=on״F Yͧux\vhzб9*&zNN/?Xƹ1㊐ wg[rL4b_COIdrUu?ꗑ ipΦnyrql %k]76'X*lsOg-&, uQl~%)!R_I r"չ OCPNߘD>^sŻ}Wi2Ugj*;2d#%]LBW/n'dA[)GS7KѴ0u4 ?2GtWN7@dV3(ꏈ U, ߫9:5{NϦjf >4 LfyY*o^Ɛ|c|п.3LӼR_R i"az8!`=+k <pL?YK 1 N4͜;0gzU빿BK\uǺ~͌\j*'˃&Cpk')G&2%!&'Q?p^@QܴE)yu4b5;I(Д7KsU#`mUQ˥نw߱X3+oQϼ[B@]NB"d>Ԃ-Ow@ IϜ kҺU}:7_Yr+~V*ðpLɈ0LQ|aiOU =._4enfGt'5 d%G~zeW G;Eʥu+*b[\gHO:ӱz Yƻ j*I9sUwFFJPF,{I۾dbw^3$n)qLƍ.Nn᱒ U[ꪨZ8T1ʮk оybn`l#B㿀i 3`@n1["_ pqՊ1#G)4md5"&Rv2vN)F[C-g ㊙܆f̰^웾&#Ph%bHt&]Es{>&[~7,F!v-,H|3yM#&#bnRG~JḋMIќVwƼn˗zV%@5f56g!?!Y2,W$;ٛ^ɜi:.> |9 )"paRō Itv1\Sfr@V`ma}t@x2"]۞VSF!=I)vfwoC27sHz, G4+话LV x ?Li|MhIAjX7 j? ]^Ď!"dPJ݅@5` `=N1S0g:*G4<]b6ŔQܮ2 &mEbȸcDQh4 /Ązx̧Xwv/&_%j,nq T^?=pSn*G +tJ0 s§Df2) ˣc :H6˞YOnͩ,*ܴ3 [ O(eYɛ)\?6ZDȄr% ޟ-#;\.2""~\`- jx?W ZuU<"#/=gщ jew AεϢ&`PA_6aOED{ιHsC[:ϩόG/[t;£tWH _zWA[;D^ nUUePPJ &BQHE6saGUQx|$0wDZCP-5M^ku\M>{J<9gFr%2`|PH{xgNd6f) e49ttcS>/tf [7KgXB-BI! !-¾P$  EkO| Z>>F8$W mgi%fvGtpưn#0}@{czJQYX,7ݫ /" 8lwod%m_JǃCsD|͉K91A|[ُ*u*8dž ) ~d3њ\<-qmg I!@<#,)AW?ôe) YQET*^B>nMDA<0\ |-@ .NO95n%Uw:^!(i !M*~:$NF~dqDZ)Wgu"srqGZ~F)3ŧHjn3ef$xs <+w] OmAuSsfw謫b :@BR=`t.Su^KƯ2 (]|êEH1CJƠz! /R.k5cndVȋIyR a~aK?>0Z_d_Cetn@Fu@|. =_L;끀@ePuЮG6pt/& CRzR 5U+!jDtB̮eYKR |d-ze\H+H?`zܔ*ۍwRGيk^3(Y%e*^*Ϯ;!9Ӓ]3Q_L2vҵh,sO/s("dUeɿJLN[]aNy`IG`0 H)T'7&:gDÂ%}nC\c1LI.bSmϓK8}:DC<2$LT dP4̑mLn$6CS2w ~Cv&?K^ endstream endobj 273 0 obj << /Length1 1446 /Length2 6185 /Length3 0 /Length 7173 /Filter /FlateDecode >> stream xڍx4־-jDoC:C1 ft轅QK-z-D A!I޼k}ߚf~gg}}}fְ# *8$(j PX"dg7`&$)٢@m  QI$%"<$J^P{@ nPG'ߏ.07$!!; mm[]l "P)8PnH 7r@/=e+5Bv #!p{]`uki$W?ѿAῃm`- w8@at-fk޺-@E^`fuC!P/Ҡ۬ WDB($)A= `t}  {;a&h {Bԕ`&!(PBTT >`'_| hn7$A#m '$?\@{(8BΎ6CZdV=7 +//$@ (@LL<[lv_$epn?+ z-@ ?e_;R~?~[W(gOz6 7@kC졞UG٢gD9?_v(R׃Ni@׀A=AGC} GAO?*_#($" %D+гj-qB_ ڡ{=BDnEփ'{zx'^а׿&\E__{o⮮u$E8;iN+<A37_99@bۼ r߆&{Xfa>##KKT٫n헟;{W@K=*^>s9 j!Y,O#uk'Єs8 C24{jD_DR`NLxP9SHOb-qX~$c-y@سQG1&zȬt~1fwAb'L6{aXAsF{QV~n8LţdU4L|sQ=۰Ճt;:=>oUf̩ӝwCQG/S!If9{ɯEޓ(4]6܉A8zmRr&¤FsFZY:d$._*_.V<mN>^8TO$۸uǑfAӣ2N $h^ՎTȑJO  $|>m<,0ŤuMm<aO`z3xysDa7*9^jJiU\1j?mqh:N<fӨs]A ps>BBxv0?QI7;ĶBp '&M"Uў%ۓXKUe:A?9vI/=tE#<۶2uW n6ZvL^d83Rd|u-a#rEKB-ݟD3E{wpݓ6 A|qvihv\zݒ8u#m# ƬrC0H I%k@(d ?a0Nw\xeD~yadPɪ5r=,\Rwp*EvܫW?iAMJew|W)m,?`7@[-rvz牸N5=^*ETźT=ˢOb֡a&%4f:2|eUY7PO2PL/Wr"%#pCoۖWгƪ^ȡ(WTs Hb 72SwEE}5i/<z8nYcY]Pn/[-,2΃=KA^3|l Neڲ{knY%7k H)[C(?Y>D rwCD[kc+rqXzkd Gx[uk`[/ kT!R;W1"٢ KE^l ىuVAѓrOr$`17FJbPC'vG5bͭjͱ.ۊ>"c;T!,5ˉL4F7ګۦ HD![Emyy[zMy& "_F_7): @3(oB ܪz9OUQ=4\ͲS1*?\buM{{;%=[]-MD0_?PGX\i9]4#.`UjopzҔϝ =wn l7VRIHa=w_x4oneX>XLj/\gFCf{ch@eB`}gUřqkyv2 kxFgXkb~}ZVᅾO)R>N*.`MSn'ݿ7'⌑j5}ɉ\SleUU4t ^AU#P:M\ov-fXjX]#ʹ\]4=u~z,Zb0~_*5Y^6EUG׿[oLkyہu֍]Zb Ǵ#bxA .Q4Lj n1D(kDa(qgHCU,Νmg_FׁOke#C'ɇoZs0%nmE+ &eE*C0dJ{Ϩ?)D8hQ8 ^ځjg_}%Qυ)i[` 7&;Vq! 8e{Q_ V2l?UY&y#Z1o9Ǿr0Z2q,ا ~:ֽWGeՅ+]}GIm6/_C6ޜ%0 !SD|F_rPdTxQzf,(ru^*§+U_21ǼNܳ0>Meެ[ |.3}/2^1c=)nn5*  2PykX "':.gYW/Qں] u}] L&َ$Z Xv{ߪ!>/Q8UBf|y՝WGä̫oV&72E'M|syOP}7kW z~Gqe[G~SvЇ I{]NaSe4; \[*M 5&3pG7nox+“?bps\kfs3w鐯Crc0*)E]go=$M-)(?B4FÄ^5ȫ[EqSk_5}1X7҅f'pX'0$s^0Hi8^A 7N2o: kdHG8[5܁h.(K\D`vݩ̹dXyvt _ c/0>Ob6[.:(+P<Y]&`4YvCY߫9;4^֐)f~z ӯy);nRQ{ʤ8y.{"W?3]!Pq_9y͂0Ǩ3q.ǂB-5kE6j/Wғ3 9>- U3OW-Q .^Iߥ:'k/' & ٝa`Tc\/h|-֠[m-u 9YW48ɈJ?P<_W|ƍ g syw WenImmVpb~/s-a&- d2uB/ /O2T_豶iEFVOwB(dU\gP{z)Ggl*3ԔMdݎ|'3[ꭰHv+D-j9?ilQٍV?2[r &x0w>[Y4~(Ѐ4o1ay0C SCLinñni撩\b|wISZ^IdY֥n+0ĔQ$ 譩KGnFRc[m K4y:EMlG6JW&g#N5q^ޣtW~u|`A+k/P/C ":Ttx2$ړsnᣫoe4STXEj2۸X4ÁCU{!_W|Vks,#WOQ{A"GE&%_b7F漜M3*SRp\7%aKʌMlZ9/K\XL* X/=ȵ1НOv%{z" '۽$oI"j=rICd""7(,3iF;FTwWlRUf8mX5k~,zqCx|+.!p=[ֶmG R%)ILO U%eQiIƺc~g!EW˒Ub2!..%EXf5a0RRv?0.{5$w^BΑEeߣ14KU;϶:smy*E{+Y~\e=sH\󌳟7,ʽzOTd4z/Xs:*>*`[*Gp}' z?M..YloVKP liCe N6b2;mb[Ŗu\nۭz0y1ϋCb讬ϫ(Y+W̮U89EncXDr(r3뢾%d*!X@6qt*ji-t, `-kt%i``ВrZ+֩+e=cAZMͨ[Ne[,D'h"0\V& M-$`ip=.୳V)v+c3 e\fޚSX%*s<'뢊 g{iRQ$'˛cg)cJJ-Ǭʩ2MRpH~_0/YgqC!XtUᾱG(/IO{d*O _YS+nՍ|>5{H֥ɤG6!Qʡ${r7^Hg&kRyaju\&!L/"B-a]{g~)3l8PˌH#9$[2]Gћ25۾rnZ.У&58z`'VcIl=%W0߾gss!F('֬sN/C,2K? =ϭg^pdMl՝"3(n y߇8~mxݖ:W ˵;:jRyߏVp38ʜj8E؝4s솳wG|"!Ut<٫5b+[@ y^z|2Lq/`CEO)cA󄱳[?3vޤi*ȻSy MR 9您ݶQ˓A~BKЃCfͫH5I ̓u Rb. !/ܸ{⥕~*n xÑ$|.{< yś, ۉ ^h| }=E_^ 4W !aSlɫ} wcMNBkßdjɈj`sbGjIwMJbK }6J29K7YNYRR߈C%'x/hzSox`9.:{>Lj[hd&;z~i`*J5ڪE{1<2[1P); +ㄲ֙=}rvol"T郛 endstream endobj 275 0 obj << /Length1 1449 /Length2 6394 /Length3 0 /Length 7370 /Filter /FlateDecode >> stream xڍtTj.-R5(zCDN%$T$D@ZA|?߽kݻfy~v<~cd* A:A50Poj- Ņ@1 ~~3cව0$BQPoa8}$DRrr@ @ D4@0@_D@HO /@| *++-+E @qz+Ap) bpJ!xʉ 7a`(" P_`0"~~ *,t&!~`'!\08`'@O FA T5CQ0O Z (3 o# H(ٟ '{8$z#`^XDHe$ v i3Dz$0g( 0(,4;}@`` CPo:>㇏lx??g_ǧ d%eRiii@&jiOFm3 GV& x-CH( DWM? ib_n_ qx)c1GPKUևB`Xjc@PE%.$*! m5aP v-G!FH4狃ˇ:;UA _׽#!?OLR B@8 ^dbQB F 1c 9V Q> q# 8@`(Bp}8@P0ŧH-'5>BKd3sz2F!,iF#o}={8d:NvڎP^k(2$@`IhKb{#ytJrE+zFv(:IeĪfnE[ahQX3m hXܱZK )n6.˗t= g`ÓݟʘX Mp]MH4%kGibGocO߼L6Pkã*,Mc7Rú75ˡi-Yw2rbo Ot G:ψN*}Z\N $v_U뒻%W81Smx7Ϋ#X46veS( ՈR3=7kč9VGwt1|jZT1/?{mNv醙GzJ__^8=qIh %٫К)NgΒ*8:) ޡ:-o1vyʻPDML*g],\GK?oŒ zF>ݹ]}lH.Gv *{xI. ]h r_E+W4֯Wǻ|׫~jU3>vx} Wح18|tseu8Y'ټ4SRKPd2-@ @~Grz,8b_8'̒gsl Zj~Ieɉ|챔/{>أVqx;fU'.s)IQco 5RP; WnPz`Ja%<GV F.u: ] /igm>R"SdTۡ6{H}ySj1JitlV)8Hu 4vb3H&ՍIsVxsw]䚹YJ#ӏj,PVэ8|9𦸩'Nǧ˷ɣZbu;eqI:1, Wa\k6y$ԬYC7JI$xR|p\9q Lԣ|mE.k`b0f;f6GfY&#AM^bJ1Q*E\v9s@AAI]ʠf-Ȇ֫GQ"[Ø `^@oOփ+R^5}HfjɯCb=K\{ӑwVAk1e0 $7ӈOK^˵хv;y lMUm2b sU~9pɁ8-hf7b/6O/.)ҝ\.we6Xg}`2wޛxfզg+ >ōؕlv $<>3)BmZ_'n0d\oƚY_#'6Oi*w{uVVUlYYSq?x^jdyDQ2#LKmϵ,O?`}f'菱zCOJ5e+FO8۽i9Q imJۘI 5׭<7MZEF[k88 |pr"U~{`#E;0J瓶!5nV):ADPz{qڱ* F'쯓Lt\ u{u6̂23~>saQEgH4Igr%[&8He|jmZN-wV4UWt$)*-gB0>Nȹ3 Aͱ~Th~a|R*uޫElj8]BE\- DqǗ62Hdf%ߌ"mBϫPUQZ|ՌC&_m"B줐k8O~[k`n 3z+ԘV8wiJ~ ̷nrJ3Ӵ=Q'e8p eHN';Dx`fN|"7|6}D3 -dwJnBxF]lrJB)Xm.-wPuom8JwRxWɃRҿKHt,1I0ypp8]o}3M1~ r V5[>}bap4XRH#j~-^rןNZܿ6ʲ!!d ~~7r=RC1=l<ǓZk=nPNZZRLg{*s6sx̵(;e r*eJ/v{jwrﾰ-iΝCVVϓ&1$!<fݗo?xJIS\+^t8zg!bZPEP,"̳a00[4Y30LqvIsP+pٗj$ݳP1S'CFĢ}r}pe\4Elj <>SV=*܁D'RnmQ\)VM#QR97O7ӛg{V <=s93Zh ((W>px­A\K% aC|_ ZX T7/Uq&Y |\{)xWyLMPôtȬO|#sw>Xr bJMdruibcTn7>DG!E_,/|!75raڋG'"D8f[e7 TAr0*ը:qnkcyʇ ,R7u(.yg?3 s[^n":dcirpTÕ8T/%7h/Ucs/p^.(2 ^^/?tsy!':v>cƩ#4.~!N6Aθ_5t(3n!_Nt'@e"g llҼ41xݨ_-oPo,:jL٣8fx_Ox'|sw5x('԰ktSj[I~ˇL)&muvPR >/u^-Pz³eDbFlkv2+u.azs1/<)Yx)/7>{7=>D~4vrLIyb-Ӥ #ۤKg/C_vǚlO2?ur+-Qk >=wԓdRZB Z ,[ԟJم8lF0|%QB60d,,7VlRe efݏyb_ V-YrG&tDG,6+>Wn .3UE.TrD %B!jZ!XtTN2uO3!#-"n8O$_hw؟;LoF٥-O3cú/50ɑ丌 * _|w)梼=>)DQ$/)tAko5'+^z`Y] ܌qfO1/0=&/.D_dC 3֫wF.R1^qy1J+D"8\ {eO<.Lx?<3K+51A=cgO~{>Y2W$Eʳv)qCaVI@yӠ"ZqQff+=PQ_9#F{4@ƋPnQWMdoC^GS>1Z{ܸ{©{ v㇭{Ѱ͈Pĝ .=-|~90ZhbM(8ډxwGyFQ1f%La-[AvR%&ʾh8׉oQ']p9)RQZhEJ I;H$9@P4Iu_1U;WoN:F ,Kag} y>b 5VBi7܁)55tTʴ|8^,d'_>[ (ܶKպ(b3 _I+J-O^/>d`_F̍?J9-=hnQ94,d1tF"b*: Z-εnzoWRGmlFqW.Rnw1Oedf; m>n;ڻhBAqa9tZITqQ~71rlܥ) ̉уe<΁9o+`z%hB|V w!sdIfy%yC韪0~(,%+c<סi'wLN<\?/-An18 _3S$S>7kݍ] $uA*D rm% d BR'[O^S.t3 )71?Xj*:EN$6eX,L eϾ _^mdNkiqK!Щ )OW na vhyH+ʭyZt>:a86.]4ʺVK=lJ&dxA%HxJT]͊p=BTu YsF7TzpEں=Z$o$T < 5#Kлz[ C]SИf\zLёpA/Αm#ȔЗkҸe6)gz)Y #`k]C:^05FY[ǃϕ2 Z {{(#W?Rb'Vΰyul#`1]hÌ?|!3e&k6T-1#X4nXؘY],rchۛa)91_j\םʷ".l&Vi<>u_h"hmR‡pjTzI<4!h DuYUA⠰jHkF `~k$N7wRck+-7\5'͌L潻V@='CIicbtW:3Tҟ}|ܗ`\ D?hol|@X&zMLaw? #Ѥy<^±2y[L8M0E[cF^^5 .:a?.Lշ! r |u߷W֙WU2,bҋ2nϥҍSHF|]bԏȌlԼsdIa*rlqT jlǩ4a i*^/?i@H endstream endobj 277 0 obj << /Length1 1809 /Length2 12567 /Length3 0 /Length 13702 /Filter /FlateDecode >> stream xڍP #-`AC4 ஏ#szjfսwPi2[9Yefv6<;Z qGLtu9e! 4ʤ!N`#+`c@dPf(8nԒNޮ tv~~^?@W9l:f4wh:Y A'd 8 zzz;8ڈ37KW3č Gym4J!O |7ߗkvYVa̪ y!#Blll|| eiG-ogJ?į5:;9_?Ⱦn@o"dvvڀD¯ ;OƯfv+fUҔa*%$̜fn6;;qہTT7E[;*{)ɠ{mAu߈o:ßz  -^NZhrwZy뎈m^眙/9MRA,m\kybc?ճ}[^Ou74{#N+ .N\,U_ _ `5/xEnc`X-(_ |g  +v}}x+OW]bWeu|/J_5ۿ /J_ǿ+ ׿+ ?ܸj/0Dd)jy[/Nc m<QwWcO=XR(fEwgGKɦ_VN8k&Y,#7%w==f`+6QKyz|&9B4m75'-XPab8QaBsj%Ŧe MppV ">CzXՃ8Oub~R0Rq/jǛVzͬ(ѴP#2/\R<}@I.R>KϏBuŊ58b0(czT!z3kh#@TG))KΨF*;s{{UzS$檋{^͕򉘖2>(j |Jzxa{h:1vheYGUv`+.{O]neG!v)Y&ʖ0ٺ˪o@kCύ3^y `TlQ?U<߰:` mlƧvӉp&J,Ҙ^em T[\զJ~?sJjj9i/<¸G3=. =z NPyMMLhdF|]J}33ux&zC:KRtgI"sQ_} T#Qѿ\0MPqR(S@FMA=nծ"?!7 ℴ:$ڔ[b‹TP'`a N1{+r#HF4VEZh~g5ܺ;]B5+\2l[ .\>&)Fq=}.ǒ,͏8})UMJӛKK~y:߇+yk^M֔Ѩ-vgω+Y/m2~jy ? *\o{M" ɚbA3gWz2 2ېz>c6&G^GJi xf˻K8۠sgW&%4^S-|PK8#!H$'a=v]׏ZZuA6CXi|3߰p`4(%PC< ܙ*K%b>HGL5r~@/)-$Id+N}I` C?:0rL:qTl01 -0moʨK "@dӻ9y2M\r ?]"#nv6F5zp|>37}%e'pZϸ=j]T(mRT cBf =nJsMsQv$Ka7yM3Z KgGd9G`rsE7$D D]?'n'f'gi5;yZ1H~K}S.# \Õ|s[L2$ ҲaV3:]hzX,9%IP_Fx-E+|eCRvj_H}r4*@s\uUCT4cf=IMbco̯qt˔Ky <nU=N=H[jT?Jq?(l1 `M6&D캵`M#k$Sѭ@'l吋 ;ꇀ88^ukKXzVjr72`ӐoRӆ}&@TP[j-g%$f?޼^{*1yQv9(M\o[*ۋ$`HLLOXqNfRLP)¶g`qh "Ll>Wm7 oZĮE;es'!t*ġ5l۽X1 =~]*udQ5bv`Kn ܙ5uT[N"^Ex.2yupTWW=:q.p^*0-HJ^꾕 N} e'']+ka>z8Hi?]\ݣ[Gsư(2Z{}. co2o; ~Vǽ{;;ʴNvfM]nPDix@+ 8"こS?/Y&Sp6T"koŏn%|4[AkaW!pڪHsJ#/{gjuA-'b`&~%)2q!/O!zȈO@ovcdwtoطL2 ock9'Ato9d8uJ w/6^lgW^*!o!:_l7A ֎,4^l#M]sO>뺽nE3VRpzrX9FVv^k'ZT7nj}Ѻ<3W=Ȭ*n#\?7|bQucaL.c)k0RGQ\*;YcѲTt乺55Cu="( E7`a>FynO}c9.AmLːXB58Suu+a__< NJSO<&Lw*r&2uݲ9p=k-yިޏG!^J 7bk<Ճ քǭ*Jۗ;OsJg7 )$jаPTBz#H4ቃ zx'i6`wGpUȶ<'M&vHbE,D嫓UøP7.*_7=Źf,KF o zst^$p$!}Mi`7^9,Er2RVHpDḟ !FÂl%LW_AIZ#)g%p){cM˔x82jd#KYQ0bP&@~[?<%~ Xw2nÉ]ʱFOo]t]Î1r!J!IHj'"kr`Ӏe-F. 613egX`P .1Xh˰I`0k}\MD-Q D ;WZ 4D" 0ׇˇ@ѹ^Hdi ~ 5t+R}W$^D_?Q}Jf?ώH+`շupy P-5a9PܵM&-j).O$[>qJuT;=-H~k "0 A?"+y";pK; mI#h3IMU4P%Nwu[ȿ7 u'gt6gtd<[Wz[<|qۓi3)䜰H,p?diBEs ꕙwgҗ7v!g?{5<\>K[Yu|ҲƅZsx7 =m:"TPhqHUnU 5+hܖ&nl&an;fܣIGO4Jo~Bx埁_ܥx2=?Η? m(u=Cq^aYlZS'Z]=s<D 4KYBLodtL0za4Fb~j7Dˮ4x͞Ϫ 4(鍸_.y "|KR_Ki%¼bg$zv?re(HF&'2[InU!-5qe`&eD2r*3vY_p!uD_=@=*frF&5>@,IxJQ#sW[,Nyz?O}nў!S?E0 [C 1le.>G/vUjxq zq%I6YؤR.d)+ӅPYAЇ| \b%e$M}6QKLA.񟂬=JZ{usք1'$xUSe.ON-2XWoL`Չ--Ex߳Z$Y75cbR|RZ5@,;F?>a98qVNX:# r6|:%<; )Z;.y(q/qn6fuq ^GM-n4nX1}7C2|6\DVNkk͞4ƫ91A~K&]1g}GXFcħs)z@`=!&vIMfkLJ/WHJ~Y=+=SX­Ǣk(MM&>ݞ+ Mf:h/X&pO^Jbqt2C!'8wmۑ] Hås>{/0W\}""f4c sB mӕA!r]I& nYKoFTX8qmak`4[fzǥbywSn5^sYFH \n.z_AQ ^zQax30C,G2J F〬Kr&F7‡~:!*9UEę%o&5ղpKqF9dstE.JWL2<>2'x.tݙbm[h4Q9zв؊ׇw':]] ܐ8! iR/iI_E* 7ʭҾ np:1+AN(̉Scgj,a_Alv2k2f|k 5`2HloHPY`|- ߈O)ר瘏g9q(qS:}þ\>H'[> bEUiTw781sΡŸ=nߛ6P/1**,(%:Z1%c*SXWn`OxX9ja m#A!_Ϝ E/7% Ʌ(A556iʐgnPK\XgZE-qCM+7pݢ9 Y:]A;QD\p/o#Pw9k|'%G6:#"C3=`C mA `*{uuA%C&Nk50,f!.xj^R*- G>n܅-H3KQCa 7I^zaxa}S4Q}\ؕ,˛V4 [$1Vdz9yf{br$6)~.?ApH1S9Sڊ0#yd2j{}D7Hjqo~@>Sto(gxWP#RT)ieɖn+KqBA5秄(ffSIYQi Dj( Z/B&\]EW^j%q8珂.F^ˀ7EOV4g x# շc*e+_X-"wĘ Msk ?w݅ >'jIu v q_Y `QԒ E,/P؎jrhy>tmjlX;W )WNEAd`φoy-cK/v$&`]A|ԍڳ鱣AQ Z K&'jY">:_)) lb#nҺʼn݀ƂqTӞ & K,IN4+iBFԃS2%9Uʁrl77~@T͸7楯e_Ezb Gwƈf܅gXgkwItXv1:c+-R Q'kgTg?Cߧ6caЗS^6[;8͎g ׺Oѯ/*{3 Π[zU2*wG,cȧܽv9Pz܃9Osr(O׶.YyxuQZ~Ls)i4o^gR#U׽5QԕiH؝<`+oNfLqkX6fzӆiqVLI<EMN{mӇMMg&∍cO>;~>DLV/rU)ٻ6f a2QJfz JnQXW9rDhܨY?<30gP[Ii\uRQ=[h~ΘAͯޅ?L0.S6& fh 6ݗ ɽia#\=>{$gYOΩ$$-F[qa∊)HO~YO>󚂜ͱ} :pnW꯰wrg۬ŬjU#(kny` {6 wZmeo&]۠l;XqihtC{~"jJ9_3) x1߂~\:xEd{iצM_DYͺkQ/fZf~h}[l0{Bjj%J;fΝB(&4M9tz|ߏؕHfˇ%8+htVZտr^8AHwR[K:ޓ0o>Z=:K{rx H\̫CH,@ˁ +!E>myw1^m<?Ua"Ǣb8nZUDsTeMpJ=;j` V~:փ4t^.2YH5iFh陬F8*u:ĉߢdlTG^s<[ǂu!\FVMr:A4mk"ݒo;ghF!UzytVXOK&i_7MZϵYդ]U=?{dn ^~BҦ]v#]y񜕽jXPf޽L*G撏Qji8՝*Qz~-O%WX}/lӭX^V?Kfbi#:7~72m| G34/grt:֒nxG(NrU"=_uJE?Jϯq 4)M pwj\76]GG碅Vn-򩝣L?m 累Ip"4n%=;7\&]ުQ,sϲu;C\t~eo\59^/;~m.jo%^7M4}J`ۅ)"Jb{@][R4x/f/1Bnn&nj$,[@ZJ>1}Q !9ȰB/{GOf+Cy>/,n PHU]|'@wRaz%q; <<^'fޭAx}jGg]F+DL+@6-Vc<[egrؕ|4vAػDB#Y]ls>`>`9,dQ',Dd*o7TŐCc) ';SBc _xx+Y!Hz+_Lp R{l'6e}`tU aݳh=aS7,eJϸqn$/3?S*á+|@+D> stream xڍP\ cA{4 . 4и ,XpwwwwwG=ޫckε)H @V ,̼Q9f33#33+" _9"g=ڊ_v ë#P h`app23Xykhm tV {D QkW;k> i,<<\-Av`C@` |h([Aٙhihmg"@Cp;@ ;'7e<75FD )? ekcg*_]@ve)Y ?Ʋ1 #?l3h 2-@qYFz![ ^ *2l#0m2Y9##dwWled $oW  @.LڀRrtyA?@'o"D`2[!*:~,ߟt^'_G$.,D7"".wv+ (/@ߵ+5?^{_NKC ֯ P~mff/+uoEcZ-\xfG͐~k:ˁW+|a+ M5 hm}Xu _Kzݨ(fehm{X98@;;+"|rpY^wh^]<v$[ `xLb W?W .bE`!9;okL+^pc?rS~3 &_xC_16h(LDy0;+oݿ^ML$y՛~mZ&gfjczax_n/H+O(HV_^2&?5x}KZkH;='X8+ثOK~#G_[rZ;' k8W2o.9 v_J_ n _w\@ ֆ|fͷ ;(vԒhZQi쮅:іĨI܏c?5=xd k&q<9;ָZčIq`ԑFhbC$reT޾^2*h? ڻ+z0BoBWyn_(fZ[л.Q0D +DCiq_7g?'+'@l$Wkh23\ }9l6ܸ.X^$Gq`LSD)YGב(~)EWZÄ] :ｒ5:4]]**|(?jEO@Rb46(zyFuMfF3$IjVvuo{#h],gpv5Jv0lݙ?{p e|9d*k5gWY(L]T[ ]s'>{~rZD:`q&y-J\K '0KGKxYAA%/b%*Lr^Ysk֣~%6XDf)JD9o#+D#SK8;!d 1FKWBJ7f-Ɂai!iϴ DP>F!ŀ_y}2DP8qf {W&m(3?Cqjȯfo:ڜf\G`DM~t|ȉ!&qw7Q ,qbc~u+B>,]+u̳M#}e1qcmbg̨gk*.r[N|c\O>*A_xs,nʬuevk?ʙm>ANPZHk}%o6l֏؝cc6~915ș!g]eP*Ǘ *ֱ]OL]/?52`^JQ 'ēv7R}n8Vr-2? ~I5! gUAAPtB|W^qXsZ(+ [RdNO|oP(7Zj:YG->]̰JV` _t%hYyӂS ]}bj)*X{"$*T)d* 4uEyz^}e6 V%!NuA]p*+oqF[Ӥ77~RU|9 m=,iIgķݾ*q%ۡ xlIuYM/9?`¨v:Mua;ߪDJYI~Ylf\Dtec\n&\ϭ mP?i4^}Tm(.`:VHOyLO'(z nsat{fw މ\h| I馿L7ڴ22XOf(Ėsl [hvK\u!뫘j0y86bb>nIhlEla F8N8u~7n/E/@^3䉏qQ;O!8/lEsY`_CxDBAn[0_6Hۋz1pNsЧK>\8/-A↥K]-1SEat"4{&eδXS&/ݧK΅ãP~a wan-^-lOKs~%Vlsǜ?S]ھ$U&y^Mx~52YU4l_UsE<4_ݛp;T5_x 3f%J7ym[Gr6P\6"<ҌyHE\% psEdejxML!-<( |&Pߧɯ9_8R=6<骅+ GOe KS[-z+XxG#,"*;z*Dr/rg{Y&B^G3H:Maֻu!wK`Ԟ(v<F{ϴYܯ*y&"0 񯱘78[+@U;NY*xW.>{ՈUPo)03ƶE =~ykP vGQeG 9q?Q >_0[HhXʩ6_[D XC2QXLRAu 4]8 7&!m - D'`p͔&[h3xcN+7ǜ(!/=`j}% J=BdCXH=tx_dCe7x;?ir:K&x߄lGAU*U1w9K531H5gE<-J#d Jȱm+.=ps_t׍1ԱK. i_-vUY}+npߑc׉[!0n-&x^} E/w0Iw3mJOYC1 Ct ݨywƀjՅxtOPykU.Kb%! 46p1+|Qo^&=]6qW^ Hj/):#:gIjC.2K̋+\*%+][ܥS!7916)W:\Tv'XҲ,8rd=ß:PO[ Ƨ2[ʐM,O94d>*! qHگ=\-c2]l6&\q5{ In?#tW֦ : `d7lL2Lr%61{~?7~SU;7w#)CsEx^_yD權ήۼ7-Rd/JS~L"9ǛbIU}rΪ7ii Zм]\tm7FvFUW_]qDu,r>x*1h4x뱅|ή [Mt@IS9^sx:P:1B CMp\Ra@h7hHZh 0l7ΉL8`nӌG^JMR/G *vlݶ,4v}7caI));@*>@V`ڠ7/f/b`,kGeR(AͨY*v쌩:MUj<[T1_H n4(.Q"E ;1\Nv ŒǑc q'.y7Ĩm[=Qmҩ<2\ny[cfacXçIq-xSDyt|&Gȶ3Gmr~ bp $ Czk/;6h7 k5yeB$,|6t> %砵>dj;>|3R?áԡBe.=Y? 8>tS_9)aArDx{>s{f$˕UV{`B%>on. n>6 $w8K1Y~+!kC[d%rq-N͌cL&!Qni2z$շ^C@Һo)j#_MFrw]-}l> "R63tگ"APj2w (3ڜ ~rޒ\v p_7 ap(X rMvc/ +TnGT2ki$] }ꨲh.ԇIZӺ y,qrR 83qR?!XާaHLx_1X5mA+(^W2 SpL6P+qJ333д^&,Ȩ2i텻v")08_s4LYeb>%ƍY'1 gҷG<`eC; !P3iu myA8fԯ顚ECC p~:_/'RNl?m{~obMVt/ՠ-.ON?n`-*k5o]Ok 1f;\E2zMuNg $JiHa7b&m7'Z( 7WshS翓iV@: -_Zo|/6d=yiNcƞlם?dS( הj>f. r^ )$#LF,^=#<ٮ/3~m@4ٽ,*KХ|1QSbDq9/}nO5*],^RA*. MsuG {gJf! jd8 RzƄht4p,u0эXri)cUk3X4rƻE䯶>w2(1&.s:HnԆ; RG.+O,) }d&qLڴM ֆjb/-nTn [ $9JTn}:\51rLkٱ1ngY3UMJ‰6R9;;c}r~uF?&kը{.d+D`pމJi^[gb^bv@eo n3 5>9hL\A'JfXkMN8GĐ"0w@\.w楪..\1%fظh*^iѲ6k" W&J5$$wC޷[aQ88l7]Q&ꭷ!!\n )TyqzD%Nhj)*BV!8Y~jXc"] S9##2T19;t&Ojc :-LZ4ԟ8Ywm8I x\:9EĤ|2YFҪ|d.Fb->-Y!f.:ia>=iDoGA&YA#^xU*NRѱ.u@V0}i\?D~:ZR,RRGnb Jlگvf,vA˥9$/ʊֻ[͜njKDO*v]#ԙa .9+Z86_xzZزd8K++`4&ɍSr~|*ۣ P`%?#EGZPe^U<ZO:*R4iۼkyTo}8L=ri 7a3 n_7JFX{AmH.a ieIfU κ dp#."< |ջS_[[wD"dxڙԞuOEqq]n\?$Лng UkXG1Ƒ]y^~$QC4* ņ %MBw?7ڱ u]Uk>F7&Tܩ1ԨѨu*eqFf»%l LZ:w ʼn}OlSYs1V/y$qQW&0u>qr>;AogLNi,/ =_~v?Gߗ,u$ZId]̧]UiGI3eHL Ut"r))Ka=}t`VN z6vAJ ݶn 򙎃sXlG-aCMoN +E`}yV;=|Pڒ՛Fck1ر\-qb;*:%ĻC$չ)NS$odf22RM AKxa<óޣ3[,uuDc EMӼq妶D;tјo DdD7w ;Iwa %f &BIo :A^!,UyuH9F,Iv$HDD P]>@rXN%']ò| z"EʕHC]̓^*b- #h>;([ky_TC[mV0i-Mz':$6~ڴC+{z 0gL}Kx/>V3 "d| Hۓ !UghPGuqc>rQ&1oc0Q`c&R/cUډY*K{h3"r 61u9bD}}Ms"q\ٰA9 /U;lF,e 35$x-4n)k͹QSC trSL˰q"I$Qul OP:*y[Psr` }hذpT_=jM uz H=zK|gϰ23Qu.nB)p"TCmwT\죐5iȗMk*d ui&Iusn\ 7bvI:~13/"†*obQwKiq&UElGơÍ;eo|x/hpyv|Hlx6&;g'2ٌu@mLoiwbo6d{>EKU(.bQdozJ(6N ? !`(9>%N^z ]dBe0BLѠ49m8)Bc*wfc "gj}ieesRN<6Moc^S.kѸ G=o |ź:/t`Ü,r?U 3cJu|7"/O5%㦕 NŭF|2~NjG^LHS +6^t*)^7һ?UYFR3fbi6T.GK`"tVݏNj*8w{=s7@qVU)7!h%e;o}xtv?[1CvOu#{/E_DQ*S: vBY@eq 7"Į,T1T*(]MLHJfw@$ڝou8n},?q>KQI >{cDAjBNtsJ\qM hz;΂Յdj0FQGjllTT) `f͑wjh~@eqG*7lx?cA0^rQuP*Bl-mzCȐO T4\} Ce7LsuSG`{lX`f-jOO6o uk2V@q7M_t,.<rM;fCцX/'IhdP벜D,hKy(=٢KSB~/_$Xpie՝QݬdQmۑA:'ihڴ_۴6Wl1T@OXE?ukzd iTQCʗ ɏu+)sjm4Ku7|}[v[h)oRKՍTϺGKЂ[ӗd/bT G*zSI#p͖Tmh! ~(J68<9J zͳSGYo|xIt $]IX?bJڐr"XL,f $ ŋg``CbʱRQO>$H{:޷'i\nAoaU Bx^Vo{V|?'чr@H2ŕӺn_bSCyw䩈va5eEpՍAcK w/C-1U ?n{}1^l}o:#.շDh)7ۙu&YG:p3]d$nA{zEω N6HQϊ/, hȓSh.OZGE|iGva=Uz>?K5;֏:.&_̬r, !Ϫ( ǁu88ɾf jY]ZxgBMQrd`cͻ X4ubOpfQ5iؽnM4&Z}]DfF0,FZQJ/0a,.)\\à /t:qf3·;lju&ZD:g\m򕂋Gǐ(фu@ύ=825x :@ 7E į½P˟㿏qe$~[/kvB_f2F+Z?H6h^|м=y]9NL*=[mRP2 ?e@H`4򋮵h\g!߅=5Jh+gϣB Xƞj.*SS NUpK:Q".dJ?.7qp`t\¬߶ZoJ!gˏuwJSR6fz%?4ٟsgVUe )-sԦ_ tL*~-╱RsnRY .-53ol THᤩaK2r+[Wc`dzï7BS)xҕ RK4Rl׮;K_]nE]q~Y@-OHJ^WZ.s:x,BuK+[ue;ON$i|Odvolξ\18r߇rji:{p".v{PV3*.fesZ& KƪfbcLhT'/"a ~R۞!+3X3 歗ʝ3m!cĖ,inz)r|?.dsMy|[ q}$IPY~Gz@[%rMeUv=pӠwltUZ2x >x9l 8C){x-|9Ґ3y+]BM=vCc6vXїBDm=7hHw)Cn_BtT4fBS^L;ď~ʃg4t0ۢ*Ǽw'4Sb𱠂ua%.u9,hKKNVTj]anճR tgVI?s-Hػ+?@(32gUЭjb(O)$\Q˿mLIٯRQ r0dVG(GȞ[jqle>1G<n

o>߂|r;h a(qhRQcSc%WP>ʳ$Wwv~t /䁮FLs֞nI=6`V/:'0qa=K=ƌ^M\MٍkJ߂3;P+\`}'|w[y)c׍O[O#Wx猬@f8O:K.`9pTpӋ jzT-9;Vc&)nT1ZsJ8у?[ԗ2GxtRg/\*j5/$4ut-4NЩEn#M&ud2wl|WT='"$5e;X24 ,(ºJJl2Ic?UD:r&݀C_ >S$*Ghޕ ):ZF8гhMp}se90ƨr+}aq$N! 0:pUbƥWJi@l;Skh)-}Uۓʿx5MoÍx7}hT5|U,ClTP\DVnWrġ|$cAMK܉$ a<)fs5v'4oS) n;2|)="\몲?0CF`s'^#8`gb 5d?N5F3lOS4qPW-s'h~)W" (΃O-4ev\f6/%Uk= c> &á[tz$Bǰq/q{#tQ s|Dl&vt_}B1BLTZ:w얉 2f3P߬ YF!vejHy']ZMD,3}NaKQN endstream endobj 281 0 obj << /Length1 1559 /Length2 2945 /Length3 0 /Length 3924 /Filter /FlateDecode >> stream xڍT 8kO)LScA2fa9vD(;f2f,,٢%J(kB{8E"*RIŖ5 }\w/CtV@z涶h B)*PnKaSovdQ4zLφlx6D4@+heu: `P(oD:S{S`B,\eRlη,VSS_ t sE^Υ}C$ HZA0v44_@&;(JUQЇ@F.e+NǠ3$ @{~v`h4@؀N~d +IPcЄ4#q8[냫;uu> 0J(a_|M OY #1DԾJ չ]],4wFaQ ?J7Y#CJ?~'ʀÆ6ÜT{:D ^c6;ARXhEa+T ( @PA+GtY+.ڨ_+taP|aX (Ym@RL򕪩Hi-w$ b$' ݿC%,$23(?AUIP$#?A(_8L&4(t8;> A'h( T#E?(mj:3`9?x5NwF0׿p؉8Rβ$^y-8ӚGWE}x9vwy!#M¹Qᵏ#DUU׆UTi{^m,Ś~-Hnd+gTR<٥3n֛ =EOD_ yE$Oz9Iw.l"oot~B>i69sNرԪU_GmaN#]p&uYkm[ o }63LW?GC,]) /+$üdv.W}Vy`0lk[2_-E D2_ix5&,\j`\;F}nj(?cod4d;Kixj833nK~n^gc# e PcH-m~V*Y82s#M7 _."e״5HնJ6L5F _>9vJj;L+4A4 7x]jRLJLKx]v'+d‹7 2#s_L_֮.Zw&RiiRMS·Rn8^b}+kk 'Ǩ9lblRԢߪN DN%!!;gYy/)v˾ݐ>M%9>ڼ+'|Є:*/ݱܬsRo7 0)9},BhRygZW< ݶ;sԑ""ьk.L6ܣkϢs#L-K!ObBsZNMِveszIq`h ;dF7>%Jy㋳3|.$٧ 'm 2kS\Gz6.*&4aut9WCĶE#'Kbl{^yIfQFKsr`+>+9dY>pj-RKs&[iNLi1R{ CAif|^(}-a$쒌Lt^Anߋ=[b9&8dUgS"7nKREķuM1xfdLo-A[Ȟ3$?x"s*mi\<\d&Ў\+_m7vċ7KN~ x8uec$D1[㷉Ŋ[Se}e°fˉ"^uT5:{,z)Deh 8:O[oE} [ >rrIc?6#8/+ٜ6SK$٥,l4)ŷ=9 j0&NN~%+k𨪘jFdIKO<4'"ci*so^.q"K{UqPCQpΝ)՘j d5j7tcOA57's!O/$j؏> stream xڍT 8mF!h,3Ch1dK!30fž-E"%"T(-d^}s3s^y]}yݨsy<i,yhYXȃBY,*=̃:10ŀ@YψNV p 8@ɀpN<(-7vtb! Hd>r 1`H@䊬H9C,?ZHwbphT30 0"˂cLX8oqs: 2 PaDc"lb‹!`Ѿ g`?}^nVAҼa#@`kb LL:Rz0t@+;])"cmS֡议Yޟ6̀Hȱ{ݬ I(0LYAf`w6x~!`T0@^$'r{ o7h%]# }neb!", $94_ݑ0Dg^5,~EEӨ޿+37֗gNS+J^e@EM O?D }k_i:Mrt?Tx|7\8!!_+%뗻7{Cl*u%-?iz' Ff0#A76Ff;?f^HN+vq Hw*Lt&X _9dH.kDj%!:4R9jj#'[);_t8˫My_]~q}7n8 o:0?4d+W'*{Ni<"mW{* g &w(6[DUU+^SYNgGcￜklQTlzvM~}N>7SիطOPouDNK,l%$p}[y2l2v IvspQgJTZN4єy1:Pll^:.KJrYAkIf\\=?MZEձ}[jn`~d$w"'WɦFZC0= 6 i/^K)B:n#/>p9$ [Z͎69M__D a'Ϣ5*;{/8I`GEZ1TQQm}Mv7eՖSItMtЮ&TMϡpar.4}rX+lP8X{v*7rmUa[Na釙j f3?tL7ʝW>kgjc Qtl4R@M}hDaqa\L[~#Zй`棆ҧ1VC3|b[ q*< gW$7iC]ݥ":8e6UN&ϻ>]] Јv龱mrnGKְAu\x@v`w> hk: 1ܵO}r>8's>*#h|UvjOݙjVp}Fm}s{G1ؓ'f "k΍{ bV' KnSWa)и_'%hn]Wgzq ;cgbҺF'$/(4|;7_hRӂ@?Uy^/aS/ڝ7@8gHqPIϬAq}T 5u WwÈ*kZA?+boLXEu:AW> mSKMCI X瞲b+𮹷N}' gkҋnTjڃ Gۈign7{n(-?ᶡmn?rwV nL W[$R>xOjd񺭛m8>]/:&ع WȬR۸cjۤ!R7Cc$>Z*7 ݊ߑp5!S]8sCQV:6xlM= UO%O.KHR؀}ø *xd %fΥ4}ӗ,AOu9h-1twV]XKΩm k5w<;~Lf60ܥ sv-_ V5Rμ#LXiU6fgH^nRtq?s9lԁoiy(*|I>|cǀ2} J --bŊ|an}Ue /.(- `&mf8{/~u(p}o$T2_d`Rfx8UxZ3a!Õe c[ SPDŽM 1L j>a3||zq -3=<ŨD@5ϩޒFNGM&R֒[Y]"RԻZ;_?%S :V8w@ΦrwFd+R#b)ε㋷쮨O:Ӕy<&ʺn6g5PXO"iЯ!HYӿ`Ҥ?͝|ٟ]Ȏ3[BY<"}ޘTЮR|.pU} <1>׬כ+t(ߠ];o9J*sgGPjZq#յLέ[rL7 yCoNޑC~ 3[rƶ'ԁi.mD)se \JWt璯! [<8{âXo5kRX9/]t,ӣUCѳ\ׇ<,T6._ݨt֢kg9PsɷsW gOD4m㩿j8& X+,0I? >td"/OÒ=Eڛ>9:l>{u-S3{FL|fϜW%Fw#̀>ƅ=l}kh;Ţ#V`w3ݙO;dg3˲&9WoqƣKO1\(RrOJR;EQJm.  Ts(fw]=y|Pd^֒OkHUüv5}EPȢQՓj9\R7KIlbϺ7ՙsd[֔?n@^6½8Zq?uDh=񎏥HM_0~f80ёhoo%IU$V3b d7L)_|ɠ:h:qdlȐS2C> stream xڌPX `&wwHpww݂݃wwɝ~_uoQt圁"-Pڑ ( ```c``B %U2s#F U;Xsa hwɄAv6 'K#3?C{.@ ac t@ u731uG!%~+5@Zhho P14:-=  % t;d3C (9-W1vtѷ@K3C脓 P6ۀOmt/Gf74շv36Y"Rt4}k_6f 2A`hof@`f"/7* [ XY~'df4ݍZX۸X{ͬ0rW6s c! ̌jhJ˽-/_b/[[1 8;h9M,-+Hq_@-ͬr6fn-#сt8Z ZF61uLl}{{}7p1<Aitkt6#;/=¯Flz߈@/q~#N𿈝@/1E#&o @~#P<O7œqF (oW@l#PtO_ E_ [قm?)h@b` 7Z8X;+edb%m=z˙F*@0bXfX~I~S5\F@PHoR  h,g 6Nқz@r]+PLlMXdf@P@P,&寅F ߡXAANV.@?R]6##o5(-%OY̠@zq0Uo&vYBN@8 ~׃RaGTA.#s`rZwYh+ȉ FPVÂ zGS{s*@>;A}Ӯ@{? Uyr?7=W=k/?@+aqƐ;:߅v;4j%Ǣ}# lq 0i٤I+8!עii)f9EִR, vf** - 8ID: oOZWﻵ}bn wĵHygsj}ƃr".` v>LUҕ6lB#']k7ޔaA{٣urRyc Tg \ᨁat+ \Eda&a̻.VLwPai>(!\ޑv"(~!N<:8`¼Tte.ASP̾sUsthM-wztf܈YZ#Qv?>"]~鼪[s]_M>s t}=v4]%tXʍ/Q^:\Nn~q5RGpA$JLT=qZ9@k[*͜Ÿ4;"L*RJ{+7o%wvO8 @ު&xY':2{NWxi.zǓͬ|ykpFH 'WjQCPV70 tH .o>g#A{f>B.w,&Ì/c=,qy<`d6h)VۚLy)[ncfMZC4,ff0F"ꁗJ0PjN=x]qc}z-[ H  :&v$+ً'Yo7 i{F ONDw `Րxo~gI:=t.}ml }-n͊ 4C$aȐ4D iyM2v[ϡ+fE% Eo 3l½: c>MoŽPEc*%5]=d芠xb:mk5|CPpT;2Fw|t٤͓r+>YU6V0TiU!#ɑ_^i<©t<,nexNE#WI* T OB?л E{' H.6ri~!7otX}K'Zb?5.hJ'h4~G/) s3`ؚw6MBsֻ %v_7`&N _^GgzE3҆NLTlUW kӐN).'x f$k!Jyb%ks ǔ9x~]?;JB%,0GDVj{0M%ĜszOb ·r2N6a+?/Mf1B2o=:{pѪ1V4?cD7B@XB)IVt_()q| YY8o9VkCh,E9jH [2F!HWp7{Eoe]Efɛ/?6=!:5)<.w}bHHkV]9 6M+Q&PLJ2iGcVB13HVvM4Ѧ0WхubLyoq`zDx:b<$_# Iqizbbi5{ۨjo'dyrˉɲ#" (gxmZߌXjPSU4E@rlFFx$to͹퓫mkPi|/4Z ?Ie?^#+|Y$)OvSE==>$eC'qKc[3w/=G_4{I{[8],zhk»L)z"&;]Zn0 |)Q@nTl;Jmx &<|gy9LgQ nMΞ>޲6;~Uc|$3S l e2AHޤ6]»rt97q<3U[BOBЍBRDP;Ƀ9(7]h7eyzsC"&?@[?U47R$,KY6;6w<Ac)tgɣ gc83Bur)rEȌာE>pJNQY:>4C賜x]WKUTq>~>ynj_Y 䎊irgz5F$m;WS2v(k}8~ݙ.^: _! Dxf㽦pMzn?2 .NUE_G۰Q{ ĕi~Xg6^@f6+S}ُ&FzoWk4˃JC.#hk@-Ƭ m8vV 9-nFOkS%#H)X9])Qfٻfs2sbrD;a WjD2@Ax+^]9羋D̒vJ?V1F{J["b,}MjebB. ORsC%dR&}{@VK^ 2^hɳ+T`,ƢD>U\@|Fk ݅{RQliqAgl`&o"Sondkr1Kv/,ݐ{u<2+ƃ ;p'Ĭc(WNj=M8=8ȝ^(p9TԴG4Fk܌gR_}mjpBUJ1*O6!WdߒФOKl_5>Z0X'X&#+Z;Kok0frHЛke-?n5Ҍ0Rsvjnl=#ڤ@׻v鼼2$gNDFNGw1a߹U)LPYԆR2Ɏq(@:~؏([,بs NV\n*=On]1,+s6s.qtJ]>21I)ŖDY˜[S9mzd&<˃ݯ{-}/ vf9BKP<.Z7D,:G!ȥ@T2-6}_F7pFCCԉGv{$S\ņ =Gb$*ܷd0N3 )hlfk$s"j&&ɜtK (kVp6"M*RTh&bFDI}#fq^i^,viy3;z^*4zs4/2TocG̴Nu(CkC bxHaF 'Wx{9zLY/}$TmGSݖ}>1zf.Ud%#4&XQ -ҸWn*~zB!~Dolt[|wҐ\Bd&[SQ\ǹU/#uʷHMl*Ur; ?expu?68ky žSZs_g[MC6"1MJhg_XU4HmgʑQLxd^Z[gSLhkIܫ3>:OfyphbsR~j` F;n/E1x֝#nYW ~qo{; Q\OPsPs\dzM sܒJw EM3GIVrVdS&Hn6Ļ%dGiwyaj4 _ITRx}BW/b>yU N~@h+i۷t8M.)uZE7.%$4b k{e)3L~an}7Z:%0p䣃ئW'-~ILz<-нW@F@Q-b#?£׋OqV6}iy~fhTC=!L1:Q,ȧ~>|<-&s>w5g@#.P SS'$ކ?5t@EjqZ譗m9os(m>Q/WQ4?Jޮ-xŶ 綮ܽdrA*p4ϸX&"OLWzbvgttd# u=ocllG]5CFnJE\[3&#R-Hr"CI"8Թh멗Xs2G۾'D[ꍾJQtYsgbb:닪 Rd6v:'xzLD:q"ս?Yz#6'BW}B.x>K;p\𛔌.8z "oN|I;e#9=j^p+2z{-\0is[faP;Xm(#]4X#;N @*b *nه_s%X=C3=e6Y[p0&hނcӷ-U0AX*[yTkR[ܵ!(lⶎjjh59 sqx!g8&ˬ@V?cbBq f1fB+RSc*+!갫ִ^R2qF/_lܶ"nx7|*R?ѮIe8 3gGX԰զ<`QiM*)ٰ^w;䥵K&AOpXcZ[Kv,uݛUgL8+ZdFt>=%!>KF0Vbv)%"W;F2\[g@p*C޵h] l#Gg%c##:'( Zy ?GأŬu'ߨ<79NUӯOO6 ♑]|:69eh&"H~%1vyzh\ޗ`-9x&J`ѨFA?gΩ<~@~6]o\F'so/O: >26eJM |U-Ud\!Ȯ5KhdX8e32pS3n7 QI|\lvrkJJL9 f4 'KJKwK9!Y4Y>4DoOKK6DuWVB@"aR]`88cIl3$ (vꔜr`)D+ UI7~-0Q5p;D4=- ,1u}t^pb YXCї/DO*̓Mk2űΝ_7tb U>2IFrAt4`JzO|2v1kP7c|NgCH)OyF7'MR„،[(_2Evh3GvS&4׋akzU*D f1O&;vEhXrȶmۣZ(ڥR ܿ'3CBVmY:)jƪ"l+k,H/tOӰs*(hw;=js 'Hvw5f̔0^hu]h?ׂm&x{7xJLlE~7fBWfkLh~v"1)w]wv/JR _0*tE|Xge|$8*<,Q5K S#J}ܘO3^U;B#&nj~~^C:sByi< ƹm~UV%"'#qj^e'-ݤ hYQat!e2(D\G'~LMI4[޸>acYkVcMcD^<gJ&nΧ F`F1Dو7('`{%n.J8lnD(Ge3<;(w+g&HUĀ"kn6| Vbᇎ1I'% <8C".*l?b M\ૠ0==Cnz~sk 'o1R#vrz˕ ]mȫ^#{,\6u liKb^Jz[nad݆d،&EI1Tahf{i+Aөu|`&ЦcDCwX3wi0GSdN$(ʟ Af5g2towN%eRkOyl=_KcoI_PV<)iYLZeoW(-qfk:%*!_Kγ䍦 )=N*J `i0x?UlkˡS?E"2RE| Ǝ8x.y8ڑ\3bb?q&LQ;K溜HtEzOo$_+VmOE|lFJHsi]?%6i^/ҁCp' jځ7씙<禭T\}X7{alkDNJ0b^N̈u譿 h$w4!B1eϦ q٠l~`8u;.g)7p5s:|'ǴbɋwGs \ P*;}Zp[3K%¡3W@käl.r8[вD0`OjSWDJ aNnYg 5ڷ;\5 ބ@y'mG_5@]|e-37ÍI3Ty3s HK:څr"ȟL& r"_Q&ӗк$pp_ą[䲸!\ X?A^_~ď@\ilEC14$5פ/NQa,1\Pzyg2Jd8>e,KAJnw*Ӭ >|E' hK5[u/GXna_ǚPHgx w|B.TW2{:|*76-oޞK ۍZbpWǍ!FnGy ?(!tCCy3Uclkw7ʫo9% 07KeOXFRF=i#C]f9pgp^5 LlԭdLu xWD;w)Oφm+H]`jnP(+R1j+!mZњ n3מw8 C/T9ԵGUbzBWJ7j6ԐuIe Ko?`yLv~ti=aِt;8"RLv@LWHpAg~^?c 0CWb{lj*8G/cBگThk$a| O;ﲅb>x C*F_DEkS965)o⯞ܬ~(֎e\◈RDjCٜVV>,fE7Ca`Šg Nmt* ]ld*9V0޶!L,Nk%P\uCXQ9Q#ƈwaAӟA_kК=!ٱi®F4ꈊ%2fX8w,(kH*Caf eF\r.4 6ȃΟԵzخzGL[w -pdW(Aq8ٞ](ibX҇BL@ї[HLuL7Z" Ho7CSnkySQx}!SwL&Xu[S [TJIZpfUBم킿`鸓^*B'\ FYqo4C3TC3)Q[ѕ7[bOln[~4 3ܕZ{,ʷRLO总ޕr3>eՊJ篰GhDM}l#}Q71?Q`[7/z\sJ)CPl!0meұ݋gWY{=QTaЍ|,7p !>c!㞋$V@{DsmANaW9q![>3]-|7)gx \%ڢ7jN0Qp YTb2k(ZAؿrr r/YD*۞v1/`7r-?ɬ)1M&hzL{2Gs(B3(r4+Al}٧ŜcAY,Z03iqf/˖|!3\ym.L#/W~o_|9KrY+n%b lSgQ3;d>$VF׏hZ sen_6$jCv34R(,Zj4-IՏ1v8 :']?)p&ϱ瀷m&e :APkD3^0YɎ9zԳ(GKTѬi8.zӐ?aIeuDJ&0WGjF4߬lJ. pfSz)z p7Ae\9M[Hsg^Ώ_ ӕuBD$#a;ArH2XGX?ֶgAsr+DSQ0P]$ײHޚ^ƫ~`xB)*:KfIRGi2C lQ Um1zǟ+]>q@$ S@7{Rd^ďeh _ٟS{"Jb&y)_'J.OgیWBV˘6OXAKVӅ=<#kJ91$mOKcY\.^=!XX|X˧sm)p?63mhrޫGg4\AOJ L#q{M̪tY¨^02%X^1}7T7OΟVrq=C(?JؑDmTKmXlv 5Yٯtgo~3Sc8以ͿXc k&wC6ɷ<1=֌B۱61Pk<)>1t;fhek<x7pR*DE3nrDgw%5wrw b7n}2moa&e_15"RvYehl; 4"~ I$:D=Qh\b*D)L"'{yθ>'?LiUͿJ-r6{b!Gu~&5Uz=v}w<}.7}='7:.BYCM yȃ'Ʉws|e}?BѡYJ8"^~;I[yźm;aS -?}5͈vj)t9mȑg(FwV8Q 1? \Ae%ET\:TM6ޯGcFWPH"$z={yêy~`J/c9'a(pB:]`@c]󟬴 @mxk:B?'yy=*#J.Dz0-ܮoJ|i61sJ~R#kɲ-* {[ ͖\`9Z{yz]lC." M &S3xF~E|~Mղ6a,h(ˁ3Dak!$ε,Y#3SZpۍiiP[G$PhoJG:uk26:(_tsf+z $cV‰;+rL!O*tz|M1^^JUM 9Sڃ 8dʄ8ޭT: d}Mo!> stream x\s9b>UVa!@I[' _?&$~UZ-APBZQD[H BAF÷)tX daP8 Nޘt:³*o'<`X@D`L Oi>b\Gb3~iE rH 0yR/M!BA"P`tJJQʨS&JE/4+GsMT$':J]a tЅ [hI  (LBk`,18qn5,;O%@mPOGQ0B``ҢP@{B)WU(hPG8hIiYJ 3Gc7 NS!cXQF"HFdhD0pl `='/@LĒVeѫ 8 ` HcHc(99?3B vRt NVo%tUAu7#E, dqd40><|)O_WEwQuդaAz)ftV)T:vߊ*# j'W|Ey}1fFpo.>,}*>L4l8.TD@M*Hb|U5)>z{EyR}ۚuW;5ELuvb^ﰶͣ[wza6~ l`XGf84U׾iYōpz7/ͫ-NkG'*6c`9 ֍~ l6^/;ur o>c0km[+| x ⁠w2Z|568;qm߉r9 |F;X_RKJtKw[< ]l]ƮbWO\]hE],hnP1Q8,8h+S;$MTC/( m:H<Ѐw]ĉ8"8}ӊka,l\Z.n@'JM="e+\i*YB,7ɘgNR]Ȫu qB !`\#8e:$?>ͣ'v/]+qz$yT7I!iB5)$i 9HV֘@R 5AQē$T{x4.Q)lT8k%rKJdܰ>7 \6R<vK4`͘B\&^"^U~Tk{7k4Ev(vޡAq  ZץTG}t_e|K PPKL-~G .D z#S .Rqb< D)0"fx3B IaM_rr 4AxRr 3wYV$rre@ zppu .JzڳfCGcI}Xq(,O@!>a:*E@c8&d# "!@)))ڒE:p'#P,1o24(p:3s'p5OC!d 1I(O#(P9 :qFpQu٭~Jxuye˱d<%k% A<~Q,]93-j dQJ 7#o(NOۥtʦ!4"ssyedt Ib63 ˢu+0Ugm q4 -^:3c0X] -Ƒn[,Fb/ E*2uaf+'G#ZۉyM싵 װU_<!.Ÿ8n~x|R'Ժ dg:aÂr<+BfVʹ4mLmv@mWs3Lۥ 3QmæjCS 9`d]y0Xl*X_T. ܓ+*kb26jzaL™2 sN eh$o' ƔmV'IuLiH^{\ MO4csDLXn=c7,JQ9 H~z9%\3{{]s5v# @VDq'.QtǗZv (J~3q4S\㵡st7|k^/qĥ-]f FKOq$[ :ײ >RW? 7K'c49K|iN= |2MN˳6.x,#٨Dќ@GJ hc `%ڱ1ifse*/ZeV/k4X܂r^Ò<`ef/^5>'{ֻ׻OkhT h.ƅaz'(Mۻ_|:%m$6Lz٣AUW 4ud|?geUAyY^o7x^r\Nʛ[<>l}~]Qw`ElQ[AyXMP9\>_<UU^Oc&_FUUN~bcW˝ YK[r #U4:{wttI#!sF.->S{//2T~~&dZ\pBlxy#࿯M#}~wQW}pڭ4xk׃qXd8? kEtqu90z/\+;mGG56-Wã7;dp==C; -D“|WAۣoAAG?AK`[P:GA(?wfqK >yPԭ{+T-Sz[1wЭFNTjӟߠR-S~R[Q;¨Eoo{|څל"‹hZ;[\h8zY*uRg)_nO!.-.d' iePwe)3|o1öܩ:>6 qytk/oOy qYV{o!P7p{8r*h`Jp ǧH &e RP: z+ǧHxwm(پFu΃aQOSٕHvAٓ6j[;gںЪ Z zcLƿ:xcѯ08}3n'';E^3CCXZ/w B?n.sZ59Y~ ٠wIbŨE_\~F=4cOjω閁uZʹwp|ԒyK)+2t1n]c1<9> endobj 287 0 obj << /Type /ObjStm /N 44 /First 365 /Length 1469 /Filter /FlateDecode >> stream xڝXn8}W1bkrH (Ľ8sq[jk [3"PH93(R(B(' '0R %E)ЋhA8Rɍn4 `2P4,$ FpVX (t!P _@0=Z6Ȕ膣Z`E[WА2{Io@xbVkcx#2o:>i-Z)J )f>(Жk@ڃ!ebg#},P( a@^Ǫ׿|ZՏlTtY_ݜ?htxWbTŖbLbY.tt3V\-'g5Ϡ6v{h4$pJꐠ/OFkVѵno>r{3:ы : +nwKFNik%8Rl;~vy~.m8شpĿ92bR+:pB/?xr;_[i8mxjp=.bm?nS CtW1F"!vGe VDŊmz _հvv1VN47}YMվL>}ϫyUQieۈu<>5]XO{?OU?U-cjX K*&1|\w{O$cQR&qrMKPnja\bF&50'p1liвdQ2l[c6r<'K(CPdZHZxRԻWpt jIV4:yucSh#{+ Sz!Rn"Oxiaύo: Bb!uMlYb#L%˕ռݤTSES&Fg) (em N鮊,7&6Ktm#Q,3nu R^ޠTH\Ǔ[I\+VnDߑAὑE-2@mNX5I;}nJf՝͢ JN֠^cG(G^?;*z<-c0%l^گ%P?QehZM?zr C-xt4Vs0{,Y_8_K:"ݗ˃`|z&^YPj\`||Wj͎ endstream endobj 309 0 obj << /Type /XRef /Index [0 310] /Size 310 /W [1 3 1] /Root 307 0 R /Info 308 0 R /ID [ ] /Length 786 /Filter /FlateDecode >> stream x%Kh]u=Ih0i$;ͣ˘IM6ﴵcJAvTĎv (HDʼnHtL>9ܻ(B $(/ %xluP(N&{C"PGM;xYuy`#4VhņywLL@#/ׁ-(ڻ|@+A'+zvݰ;^x?o9;_1/$c0mp CG1} UdBA=L(VZ)4ӊs(~pDbwG 8:x ㊷I{{w׸W,2,)>zɻp(>ڻpVⳟ\K\V| Zgnl[Uj?jZKw;VGw|Ir;|=I7r#I߭Q'IOYjvh^&MT4;=3hl}~Ai_/Is9Yd&fiwT9˜tt@sƥ:IYsRZXn b&LN&=#@:&=YI;8P¤yRZZ=NI7>9?=Kmb¿\TqYOK*i;ΨvYUFtNk=W.rkEUNz+O+*nzrl7]mۡ:zWa4;aX囟wBo endstream endobj startxref 300629 %%EOF nanopass-framework-scheme-1.9+git20160429.g1f7e80b/doc/user-guide.stex000066400000000000000000003243631271055623300250350ustar00rootroot00000000000000\documentclass[letterpaper,10pt]{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:csug8} 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+git20160429.g1f7e80b/nanopass.ss000066400000000000000000000013161271055623300234710ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell ;;; See the accompanying file Copyright for details (library (nanopass) (export define-language define-parser 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) (import (nanopass language) (nanopass parser) (nanopass language-node-counter) (nanopass pass) (nanopass helpers) (nanopass records))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/000077500000000000000000000000001271055623300231215ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/helpers.ss000066400000000000000000000400651271055623300251370ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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 ;; 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 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 ;; failure token so that we can know when parsing fails with a gensym np-parse-fail-token ;; 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) (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) (with-implicit (k quasiquote) #'(let-syntax ([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) (values body (cons #'x t*) (cons #'x e*))] [(unquote-splicing x) (identifier? #'x) (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 ...))]))) ;;; 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+git20160429.g1f7e80b/nanopass/implementation-helpers.chezscheme.sls000066400000000000000000000214771271055623300324610ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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 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 ;; failure token so that we can know when parsing fails with a gensym np-parse-fail-token ;; 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))))]))) ;; another gensym listed into this library (define np-parse-fail-token '#{np-parse-fail-token dlkcd4b37swscag1dvmuiz-13}) ;; 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 #f (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+git20160429.g1f7e80b/nanopass/implementation-helpers.ikarus.ss000066400000000000000000000145451271055623300314630ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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 ;; failure token so that we can know when parsing fails with a gensym np-parse-fail-token ;; 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)) (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))))]))) ;; another gensym listed into this library (define np-parse-fail-token '#{np-parse-fail-token dlkcd4b37swscag1dvmuiz-13}) (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 #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)]) (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 with-compile-time-environment (syntax-rules () [(_ (arg) body* ... body) (lambda (arg) body* ... body)]))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/implementation-helpers.vicare.sls000066400000000000000000000131531271055623300316040ustar00rootroot00000000000000(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 ;; failure token so that we can know when parsing fails with a gensym np-parse-fail-token ;; 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) (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))))]))) ;; another gensym listed into this library (define np-parse-fail-token '#{np-parse-fail-token dlkcd4b37swscag1dvmuiz-13}) (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 #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 ([sp (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 (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 with-compile-time-environment (syntax-rules () [(_ (arg) body* ... body) (let ([arg retrieve-expand-time-value]) body* ... body)]))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/language-helpers.ss000066400000000000000000000060011271055623300267100ustar00rootroot00000000000000(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+git20160429.g1f7e80b/nanopass/language-node-counter.ss000066400000000000000000000153671271055623300276670ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/nanopass/language.ss000066400000000000000000000650451271055623300252650ustar00rootroot00000000000000;;; 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] [(terminal-alt? alt) make-terminal-alt] [(nonterminal-alt? alt) make-nonterminal-alt] [else (error who "unexpected alt" alt)]) (alt-syn alt) (alt-pretty alt) (alt-pretty-procedure? 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+git20160429.g1f7e80b/nanopass/meta-parser.ss000066400000000000000000000530671271055623300257230ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/nanopass/meta-syntax-dispatch.ss000066400000000000000000000124321271055623300275410ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/nanopass/nano-syntax-dispatch.ss000066400000000000000000000057561271055623300275610ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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 match-each (lambda (e p) (cond [(pair? e) (let ((first (match (car e) p '()))) (and first (let ((rest (match-each (cdr e) p))) (and rest (cons first rest)))))] [(null? e) '()] [else #f]))) (define match-each+ (lambda (e x-pat y-pat z-pat r) (let f ([e e]) (cond [(pair? e) (let-values ([(xr* y-pat r) (f (cdr e))]) (if r (if (null? y-pat) (let ([xr (match (car e) x-pat '())]) (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) (values '() (cdr y-pat) (match (car e) (car y-pat) r))) (values #f #f #f)))] [else (values '() y-pat (match e z-pat r))])))) (define match-each-any (lambda (e) (cond [(pair? e) (let ([l (match-each-any (cdr e))]) (and l (cons (car e) l)))] [(null? e) '()] [else #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) (and (null? e) r)] [(pair? p) (and (pair? e) (match (car e) (car p) (match (cdr e) (cdr p) r)))] [(eq? p 'each-any) (let ([l (match-each-any e)]) (and l (cons l r)))] [else (case (vector-ref p 0) [(each) (if (null? 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) (cons e r)] [else (match* e p r)]))) (define nano-syntax-dispatch (lambda (e p) (cond [(eq? p 'any) (list e)] [else (match* e p '())])))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/parser.ss000066400000000000000000000212321271055623300247640ustar00rootroot00000000000000;;; 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 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+git20160429.g1f7e80b/nanopass/pass.ss000066400000000000000000003031011271055623300244340ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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) (import (rnrs) (nanopass helpers) (nanopass records) (nanopass syntaxconvert) (nanopass meta-parser) (rnrs mutable-pairs)) ;; 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 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 "quoted terminals currently unsupported in match patterns" (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 (proc level maybe? arg args) (define add-maybe (lambda (e-arg e) (if maybe? #`(let ([t #,e-arg]) (and t #,e)) e))) (cond [(fx=? level 0) (add-maybe arg #`(#,proc #,arg #,@args))] [(fx=? level 1) #`(map (lambda (m) #,(add-maybe #'m #`(#,proc m #,@args))) #,arg)] [else (genmap #`(lambda (x) (map (lambda (m) #,(add-maybe #'m #`(#,proc m #,@args))) x)) (fx- level 1) #f ; once we've applied the maybe turn it off, since we can have a ; list of maybes but not maybe of a list. arg '())]))) (define-who process-alt (lambda (in-altsyn in-altrec out-altrec) (define process-alt-field (lambda (level maybe? fname aname ofname) (if (and (nonterminal-meta? fname intspec*) (nonterminal-meta? ofname maybe-ontspec*)) (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))) #t (lambda (id* dflt*) (for-all (lambda (req) (memp (lambda (x) (bound-identifier=? req x)) fml*)) (list-head id* (fx- (length id*) (length dflt*))))) (lambda (dflt*) ; punting when there are return values for now (null? dflt*)))]) (genmap (pdesc-name callee-pdesc) level maybe? #`(#,aname #,fml) (let ([id* (cdr (pdesc-fml* callee-pdesc))] [dflt* (pdesc-dflt* callee-pdesc)]) (let ([n (fx- (length id*) (length dflt*))]) #`(#,@(list-head id* n) #,@(map (lambda (id dflt) (if (memp (lambda (x) (bound-identifier=? id x)) (cdr fml*)) id dflt)) (list-tail id* n) dflt*)))))) (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))) #f (lambda (id* dflt*) (for-all (lambda (req) (memp (lambda (x) (bound-identifier=? req x)) fml*)) (list-head id* (fx- (length id*) (length dflt*))))) (lambda (dflt*) ; punting when there are return values for now (null? dflt*)))]) (if callee-pdesc (genmap (pdesc-name callee-pdesc) level maybe? #`(#,aname #,fml) (let ([id* (cdr (pdesc-fml* callee-pdesc))] [dflt* (pdesc-dflt* callee-pdesc)]) (let ([n (fx- (length id*) (length dflt*))]) #`(#,@(list-head id* n) #,@(map (lambda (id dflt) (if (memp (lambda (x) (bound-identifier=? id x)) (cdr fml*)) id dflt)) (list-tail id* n) dflt*))))) (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)]))) (cond [(nonterminal-alt? alt) (build-subtype-call (syntax->datum (ntspec-name (nonterminal-alt-ntspec alt))))] [(terminal-alt? alt) (let ([proc (find-proc pass-desc pass-options (pdesc-name pdesc) (syntax->datum (tspec-type (terminal-alt-tspec alt))) maybe-otype #f (lambda (id* dflt*) (fxntspec who maybe-otype maybe-ontspec*))]) (if oalt (let ([alt-code (process-alt alt-syntax 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-syntax '#,(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 inid* (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) (let ([id* (cdr (pdesc-fml* callee-pdesc))] [dflt* (pdesc-dflt* callee-pdesc)]) (with-syntax ([(earg* ...) (let* ([n (fx- (length id*) (length dflt*))]) #`(#,@(list-head id* n) #,@(map (lambda (id dflt) (if (memp (lambda (x) (bound-identifier=? id x)) fml*) id dflt)) (list-tail id* n) dflt*)))]) (if maybe? (with-syntax ([(t* ...) (generate-temporaries #'(earg* ...))]) #`((lambda (#,t t* ...) (and #,t (#,(pdesc-name callee-pdesc) #,t t* ...))) #,t earg* ...)) #`(#,(pdesc-name callee-pdesc) #,t earg* ...)))))) (define build-cata-call-3 (lambda (itype maybe-otype t outid*) (let ([callee-pdesc (find-proc pass-desc pass-options (nano-cata-syntax elt) itype maybe-otype #t (lambda (id* dflt*) (for-all (lambda (req) (memp (lambda (x) (bound-identifier=? req x)) fml*)) (list-head id* (fx- (length id*) (length dflt*))))) (lambda (dflt*) (fx=? (length dflt*) (let ([len (length outid*)]) (if maybe-otype (fx- len 1) len)))))]) (let ([id* (cdr (pdesc-fml* callee-pdesc))] [dflt* (pdesc-dflt* callee-pdesc)]) (with-syntax ([(earg* ...) (let ([n (fx- (length id*) (length dflt*))]) #`(#,@(list-head id* n) #,@(map (lambda (id dflt) (if (memp (lambda (x) (bound-identifier=? id x)) fml*) id dflt)) (list-tail id* n) dflt*)))]) (if maybe? (with-syntax ([(t* ...) (generate-temporaries #'(earg* ...))]) #`((lambda (#,t t* ...) (and #,t (#,(pdesc-name callee-pdesc) #,t t* ...))) #,t earg* ...)) #`(#,(pdesc-name callee-pdesc) #,t earg* ...))))))) ; 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 fml* (find-proc pass-desc pass-options (pdesc-name pdesc) itype maybe-otype #t (lambda (id* dflt*) (fxdatum (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 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. (define build-call (case-lambda [(caller-fml* callee-pdesc) (build-call caller-fml* callee-pdesc #f)] [(caller-fml* callee-pdesc maybe?) (define build-args (lambda (callee-fml* callee-init* caller-fml*) (let f ([required-cnt (fx- (length callee-fml*) (length callee-init*))] [callee-fml* callee-fml*] [callee-init* callee-init*] [caller-fml* caller-fml*]) (cond [(null? callee-fml*) '()] [(and (fxzero? required-cnt) (null? caller-fml*)) (cons (car callee-init*) (f required-cnt (cdr callee-fml*) (cdr callee-init*) caller-fml*))] [(fxzero? required-cnt) (cons (car caller-fml*) (f required-cnt (cdr callee-fml*) (cdr callee-init*) (cdr caller-fml*)))] [else (cons (car caller-fml*) (f (fx- required-cnt 1) (cdr callee-fml*) callee-init* (cdr caller-fml*)))])))) (with-syntax ([pname (pdesc-name callee-pdesc)] [(arg* ...) (build-args (pdesc-fml* callee-pdesc) (pdesc-dflt* callee-pdesc) caller-fml*)]) (if maybe? (with-syntax ([(t t* ...) (generate-temporaries #'(arg* ...))]) #'((lambda (t t* ...) (and t (pname t t* ...))) arg* ...)) #'(pname arg* ...)))])) (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 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 (lambda (id* dflt*) (fx=? (length dflt*) (length id*))) (lambda (dflt*) (fxzero? (length dflt*))))]) (let ([init* (pdesc-dflt* pdesc)] [rv* (pdesc-xval* pdesc)]) (if (null? rv*) #`(#,(pdesc-name pdesc) #,maybe-fml #,@init*) #`(let-values ([(result #,@(map (lambda (x) (gensym "rv")) rv*)) (#,(pdesc-name pdesc) #,maybe-fml #,@init*)]) 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*)) xval* (syntax->datum maybe-itype) (syntax->datum maybe-otype) maybe-ometa-parser maybe-body)]) (echo-pass (with-syntax ([who (datum->syntax pass-name 'who)]) #`(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))))))))) (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+git20160429.g1f7e80b/nanopass/records.ss000066400000000000000000001135321271055623300251360ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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? nano-alt->ntspec 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?) (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)))))))) (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))))) ;;; TODO, figure out if this can ever be called, if not remove the ;;; reference to it, if so, figure out what should be implemented. (define nano-alt->ntspec (lambda (alt ntspecs) (error 'nano-alt->ntspec "Not implemented"))) (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 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))]))))))))) (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)))]))))])))) (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) (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) (for-each #,(f (fx- level 1)) x)))) #,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*))))))))) (let ([syn (alt-syn ialt)]) (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 ([asyn (alt-syn alt)]) (let ([apattern (pair-alt-pattern alt)]) (and (eq? (syntax->datum (car asyn)) (syntax->datum (car syn))) (equal? apattern pattern)))))))))] [else (error who "unexpected alt" ialt)]))))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/nanopass/syntaxconvert.ss000066400000000000000000000043041271055623300264200ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/nanopass/unparser.ss000066400000000000000000000177441271055623300253440ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/test-all.ss000077500000000000000000000012701271055623300233760ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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") (run-unit-tests) (run-ensure-correct-identifiers) (run-maybe-tests) (run-maybe-dots-tests) (run-maybe-unparse-tests) (run-language-dot-support) (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) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/000077500000000000000000000000001271055623300224415ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/alltests.ss000066400000000000000000001213571271055623300246540ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/compiler-test.ss000066400000000000000000000032551271055623300256040ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/compiler.ss000066400000000000000000001636571271055623300246440ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/helpers.ss000066400000000000000000000202451271055623300244550ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/implementation-helpers.chezscheme.sls000066400000000000000000000005061271055623300317670ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/implementation-helpers.ikarus.ss000066400000000000000000000014211271055623300307700ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/implementation-helpers.ss000066400000000000000000000005021271055623300274720ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/implementation-helpers.vicare.sls000066400000000000000000000016031271055623300311210ustar00rootroot00000000000000;;; 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 (rnrs) (rnrs mutable-pairs) (only (vicare) void sub1 add1 remainder quotient))) (define interpret (lambda (src) (eval src (environment '(nanopass testing-environment))))) (define system (lambda (arg) (foreign-call "system" arg)))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/new-compiler.ss000066400000000000000000000062671271055623300254240ustar00rootroot00000000000000;;; 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+git20160429.g1f7e80b/tests/test-driver.ss000066400000000000000000000172701271055623300252670ustar00rootroot00000000000000;;; 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))))])) (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))))) unit-test-helpers-implementation.chezscheme.sls000066400000000000000000000004351271055623300336430ustar00rootroot00000000000000nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests;;; 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) (import (only (chezscheme) with-output-to-string display-condition))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/unit-test-helpers-implementation.ikarus.sls000066400000000000000000000017201271055623300331000ustar00rootroot00000000000000;;; 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) (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 (irritants-condition? 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)]))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/unit-test-helpers-implementation.vicare.sls000066400000000000000000000020671271055623300330600ustar00rootroot00000000000000;;; 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) (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 (irritants-condition? 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)])) ;; needed to get an r6rs script to print with vicare (current-output-port (current-error-port))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/unit-test-helpers.ss000066400000000000000000000077121271055623300264130ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig ;;; See the accompanying file Copyright for details (library (tests unit-test-helpers) (export test-suite test assert-equal? with-output-to-string) (import (rnrs) (tests unit-test-helpers-implementation)) (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")) (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* ...))])) (define-syntax assert-equal? (syntax-rules () [(_ expected actual) (or (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 (or (and (format-condition? e) (apply format (condition-message e) (condition-irritants e))) (and (message-condition? e) (string=? msg (condition-message e))))]) (or (string=? msg e-msg) #t (raise (condition (make-format-condition) (make-message-condition "expected error message of ~s but got ~s") (make-irritants (list msg e-mesg)) e))))]) (let ([t ?expr]) (raise (condition (make-format-condition) (make-message-condition "exptected error with message of ~s but instead got result ~s") (make-irritants (list msg t)))))))]))) nanopass-framework-scheme-1.9+git20160429.g1f7e80b/tests/unit-tests.ss000066400000000000000000000745371271055623300251470ustar00rootroot00000000000000;;; Copyright (c) 2000-2015 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) (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))) #;(test-suite error-messages ( )) )