--- /dev/null
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
--- /dev/null
+Source Code for Selected GC Benchmarks
+
+These benchmarks are derived from the benchmarks that Lars Hansen used for
+his thesis on Older-first garbage collection in practice . That thesis
+contains storage profiles and detailed discussion for most of these
+benchmarks.
+
+Portability
+
+Apart from a run-benchmark procedure, most of these benchmarks are intended
+to run in any R5RS-conforming implementation of Scheme. (The softscheme
+benchmark is an exception.) Please report any portability problems that you
+encounter.
+
+To find the main entry point(s) of a benchmark, search for calls to
+run-benchmark, which calculates and reports the run time and any other
+relevant statistics. The run-benchmark procedure is
+implementation-dependent; see run-benchmark.chez for an example of how to
+write it.
+
+GC Benchmarks
+
+To obtain a gzip'ed tar file containing source code for all of the
+benchmarks described below, click here .
+
+dummy
+ Description: A null benchmark for testing the implementation-specific
+ run-benchmark procedure.
+dynamic
+ Description: Fritz Henglein's algorithm for dynamic type inference.
+ Three inputs are available for this benchmark. In increasing order of
+ size, they are:
+ 1. dynamic.sch, the code for the benchmark itself
+ 2. dynamic-input-small.sch, which is macro-expanded code for the
+ Twobit compiler
+ 3. dynamic-input-large.sch, which is macro-expanded code for the
+ Twobit compiler and SPARC assembler.
+earley
+ Description: Earley's context-free parsing algorithm, as implemented by
+ Marc Feeley, given a simple ambiguous grammar, generating all the parse
+ trees for a short input.
+gcbench
+ Description: A synthetic benchmark originally written in Java by John
+ Ellis, Pete Kovac, and Hans Boehm.
+graphs
+ Description: Enumeration of directed graphs, possibly written by Jim
+ Miller. Makes heavy use of higher-order procedures.
+lattice
+ Description: Enumeration of lattices of monotone maps between lattices,
+ obtained from Andrew Wright, possibly written by Wright or Jim Miller.
+nboyer
+ Description: Bob Boyer's theorem proving benchmark, with a scaling
+ parameter suggested by Boyer, some bug fixes noted by Henry Baker and
+ ourselves, and rewritten to use a more reasonable representation for
+ the database (with constant-time lookups) instead of property lists
+ (which gave linear-time lookups for the most widely distributed form of
+ the boyer benchmark in Scheme).
+nucleic2
+ Description: Marc Feeley et al's Pseudoknot benchmark, revised to use
+ R5RS macros instead of implementation-dependent macro systems.
+perm
+ Description: Zaks's algorithm for generating a list of permutations.
+ This is a diabolical garbage collection benchmark with four parameters
+ M, N, K, and L. The MpermNKL benchmark allocates a queue of size K and
+ then performs M iterations of the following operation: Fill the queue
+ with individually computed copies of all permutations of a list of size
+ N, and then remove the oldest L copies from the queue. At the end of
+ each iteration, the oldest L/K of the live storage becomes garbage, and
+ object lifetimes are distributed uniformly between two volumes that
+ depend upon N, K, and L.
+sboyer
+ Description: This is the nboyer benchmark with a small but effective
+ tweak: shared consing as implemented by Henry Baker.
+softscheme
+ Description: Andrew's Wright's soft type inference for Scheme. This
+ software is covered by the GNU GENERAL PUBLIC LICENSE. This benchmark
+ is nonportable because it uses a low-level syntax definition to define
+ a non-hygienic defmacro construct. Requires an input file; the inputs
+ used with the dynamic and twobit benchmarks should be suitable.
+twobit
+ Description: A portable version of the Twobit Scheme compiler and
+ Larceny's SPARC assembler, written by Will Clinger and Lars Hansen. Two
+ input files are provided:
+ 1. twobit-input-short.sch, the nucleic2 benchmark stripped of
+ implementation-specific alternatives to its R4RS macros
+ 2. twobit.sch, the twobit benchmark itself
+twobit-smaller.sch
+ Description: The twobit benchmark without the SPARC assembler.
+
+----------------------------------------------------------------------------
+
+Last updated 4 April 2001.
--- /dev/null
+; Dumb benchmark to test the reporting of words marked during gc.
+; Example: (foo 1000000)
+
+(define (ballast bytes)
+ (do ((bytes bytes (- bytes 8))
+ (x '() (cons bytes x)))
+ ((zero? bytes) x)))
+
+(define (words-benchmark bytes0 bytes1)
+ (let ((x (ballast bytes0)))
+ (do ((bytes1 bytes1 (- bytes1 8)))
+ ((not (positive? bytes1))
+ (car (last-pair x)))
+ (cons (car x) bytes1))))
+
+(define (foo n)
+ (collect)
+ (display-memstats (memstats))
+ (run-benchmark "foo" (lambda () (words-benchmark 1000000 n)) 1)
+ (display-memstats (memstats)))
+
--- /dev/null
+; Dummy benchmark (for testing)
+;
+; $Id: dummy.sch,v 1.2 1999/07/12 18:03:37 lth Exp $
+
+(define (dummy-benchmark . args)
+ (run-benchmark "dummy"
+ 1
+ (lambda ()
+ (collect)
+ (display "This is the dummy benchmark!")
+ (newline)
+ (display "My arguments are: ")
+ (display args)
+ (newline)
+ args)
+ (lambda (result)
+ (equal? result args))))
+
+; eof
--- /dev/null
+(let () (begin (set! make-relative-filename (lambda .components|1 (let ((.construct|2 (unspecified))) (begin (set! .construct|2 (lambda (.l|3) (if (null? (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) .l|3 (cons (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (cons "/" (.construct|2 (let ((.x|12|15 .l|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))))))) (if (null? (let ((.x|16|19 .components|1)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.x|20|23 .components|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (apply string-append (.construct|2 .components|1))))))) 'make-relative-filename))
+(let () (begin (set! pathname-append (lambda .components|1 (let ((.construct|4 (unspecified))) (begin (set! .construct|4 (lambda (.l|5) (if (null? (let ((.x|7|10 .l|5)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) .l|5 (if (string=? (let ((.x|12|15 .l|5)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))) "") (.construct|4 (let ((.x|16|19 .l|5)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (if (char=? #\/ (string-ref (let ((.x|21|24 .l|5)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))) (- (string-length (let ((.x|25|28 .l|5)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) 1))) (cons (let ((.x|29|32 .l|5)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32))) (.construct|4 (let ((.x|33|36 .l|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (cons (let ((.x|38|41 .l|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (cons "/" (.construct|4 (let ((.x|42|45 .l|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))))))))) (let ((.n|46 (if (null? (let ((.x|47|50 .components|1)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))) (let ((.x|51|54 .components|1)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))) (apply string-append (.construct|4 .components|1))))) (if (not (char=? #\/ (string-ref .n|46 (- (string-length .n|46) 1)))) (string-append .n|46 "/") .n|46)))))) 'pathname-append))
+(let () (begin (set! make-nbuild-parameter (lambda (.dir|1 .source?|1 .verbose?|1 .hostdir|1 .hostname|1) (let ((.make-nbuild-parameter|2 0)) (begin (set! .make-nbuild-parameter|2 (lambda (.dir|3 .source?|3 .verbose?|3 .hostdir|3 .hostname|3) (let ((.parameters|6 (.cons (.cons 'compiler (pathname-append .dir|3 "Compiler")) (.cons (.cons 'util (pathname-append .dir|3 "Util")) (.cons (.cons 'build (pathname-append .dir|3 "Rts" "Build")) (.cons (.cons 'source (pathname-append .dir|3 "Lib")) (.cons (.cons 'common-source (pathname-append .dir|3 "Lib" "Common")) (.cons (.cons 'repl-source (pathname-append .dir|3 "Repl")) (.cons (.cons 'interp-source (pathname-append .dir|3 "Eval")) (.cons (.cons 'machine-source (pathname-append .dir|3 "Lib" "Sparc")) (.cons (.cons 'common-asm (pathname-append .dir|3 "Asm" "Common")) (.cons (.cons 'sparc-asm (pathname-append .dir|3 "Asm" "Sparc")) (.cons '(target-machine . sparc) (.cons '(endianness . big) (.cons '(word-size . 32) (.cons (.cons 'always-source? .source?|3) (.cons (.cons 'verbose-load? .verbose?|3) (.cons (.cons 'compatibility (pathname-append .dir|3 "Compat" .hostdir|3)) (.cons (.cons 'host-system .hostname|3) '()))))))))))))))))))) (lambda (.key|7) (let ((.probe|10 (assq .key|7 .parameters|6))) (if .probe|10 (let ((.x|11|14 .probe|10)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))) #f)))))) (.make-nbuild-parameter|2 .dir|1 .source?|1 .verbose?|1 .hostdir|1 .hostname|1))))) 'make-nbuild-parameter))
+(let () (begin (set! nbuild-parameter (make-nbuild-parameter "" #f #f "Larceny" "Larceny")) 'nbuild-parameter))
+(let () (begin (set! aremq! (lambda (.key|1 .alist|1) (let ((.aremq!|2 0)) (begin (set! .aremq!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (eq? .key|3 (let ((.x|7|10 (let ((.x|11|14 .alist|3)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))))) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (.aremq!|2 .key|3 (let ((.x|15|18 .alist|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))) (begin (set-cdr! .alist|3 (.aremq!|2 .key|3 (let ((.x|20|23 .alist|3)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) .alist|3))))) (.aremq!|2 .key|1 .alist|1))))) 'aremq!))
+(let () (begin (set! aremv! (lambda (.key|1 .alist|1) (let ((.aremv!|2 0)) (begin (set! .aremv!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (eqv? .key|3 (let ((.x|8|11 (let ((.x|12|15 .alist|3)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) (.aremv!|2 .key|3 (let ((.x|16|19 .alist|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (begin (set-cdr! .alist|3 (.aremv!|2 .key|3 (let ((.x|21|24 .alist|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) .alist|3))))) (.aremv!|2 .key|1 .alist|1))))) 'aremv!))
+(let () (begin (set! aremove! (lambda (.key|1 .alist|1) (let ((.aremove!|2 0)) (begin (set! .aremove!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (equal? .key|3 (let ((.x|7|10 (let ((.x|11|14 .alist|3)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))))) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (.aremove!|2 .key|3 (let ((.x|15|18 .alist|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))) (begin (set-cdr! .alist|3 (.aremove!|2 .key|3 (let ((.x|20|23 .alist|3)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) .alist|3))))) (.aremove!|2 .key|1 .alist|1))))) 'aremove!))
+(let () (begin (set! filter (lambda (.select?|1 .list|1) (let ((.filter|2 0)) (begin (set! .filter|2 (lambda (.select?|3 .list|3) (if (null? .list|3) .list|3 (if (.select?|3 (let ((.x|6|9 .list|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (cons (let ((.x|10|13 .list|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.filter|2 .select?|3 (let ((.x|14|17 .list|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (.filter|2 .select?|3 (let ((.x|19|22 .list|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (.filter|2 .select?|1 .list|1))))) 'filter))
+(let () (begin (set! find (lambda (.selected?|1 .list|1) (let ((.find|2 0)) (begin (set! .find|2 (lambda (.selected?|3 .list|3) (if (null? .list|3) #f (if (.selected?|3 (let ((.x|6|9 .list|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (let ((.x|10|13 .list|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.find|2 .selected?|3 (let ((.x|15|18 .list|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))))) (.find|2 .selected?|1 .list|1))))) 'find))
+(let () (begin (set! remove-duplicates (lambda (.list|1 .same?|1) (let ((.remove-duplicates|2 0)) (begin (set! .remove-duplicates|2 (lambda (.list|3 .same?|3) (let ((.member?|5 (unspecified))) (begin (set! .member?|5 (lambda (.x|6 .list|6) (if (null? .list|6) #f (if (.same?|3 .x|6 (let ((.x|9|12 .list|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) #t (.member?|5 .x|6 (let ((.x|14|17 .list|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))))))) (if (null? .list|3) .list|3 (if (.member?|5 (let ((.x|19|22 .list|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) (let ((.x|23|26 .list|3)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))) (.remove-duplicates|2 (let ((.x|27|30 .list|3)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))) .same?|3) (cons (let ((.x|32|35 .list|3)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) (.remove-duplicates|2 (let ((.x|36|39 .list|3)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) .same?|3)))))))) (.remove-duplicates|2 .list|1 .same?|1))))) 'remove-duplicates))
+(let () (begin (set! least (lambda (.less?|1 .list|1) (let ((.least|2 0)) (begin (set! .least|2 (lambda (.less?|3 .list|3) (reduce (lambda (.a|4 .b|4) (if (.less?|3 .a|4 .b|4) .a|4 .b|4)) #f .list|3))) (.least|2 .less?|1 .list|1))))) 'least))
+(let () (begin (set! greatest (lambda (.greater?|1 .list|1) (let ((.greatest|2 0)) (begin (set! .greatest|2 (lambda (.greater?|3 .list|3) (reduce (lambda (.a|4 .b|4) (if (.greater?|3 .a|4 .b|4) .a|4 .b|4)) #f .list|3))) (.greatest|2 .greater?|1 .list|1))))) 'greatest))
+(let () (begin (set! mappend (lambda (.proc|1 .l|1) (let ((.mappend|2 0)) (begin (set! .mappend|2 (lambda (.proc|3 .l|3) (apply append (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (.proc|3 (let ((.x|24|27 .y1|4|5|16)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27)))) .results|4|8|16)))))) (.loop|9|12|15 .l|3 '()))))))) (.mappend|2 .proc|1 .l|1))))) 'mappend))
+(let () (begin (set! make-list (lambda (.nelem|1 . .rest|1) (let* ((.val|4 (if (null? .rest|1) #f (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))))) (.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.n|6 .l|6) (if (zero? .n|6) .l|6 (.loop|5 (- .n|6 1) (cons .val|4 .l|6))))) (.loop|5 .nelem|1 '()))))) 'make-list))
+(let () (begin (set! reduce (lambda (.proc|1 .initial|1 .l|1) (let ((.reduce|2 0)) (begin (set! .reduce|2 (lambda (.proc|3 .initial|3 .l|3) (let ((.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.val|6 .l|6) (if (null? .l|6) .val|6 (.loop|5 (.proc|3 .val|6 (let ((.x|7|10 .l|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (let ((.x|11|14 .l|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))))))) (if (null? .l|3) .initial|3 (if (null? (let ((.x|16|19 .l|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.x|20|23 .l|3)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (.loop|5 (let ((.x|25|28 .l|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|29|32 .l|3)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32)))))))))) (.reduce|2 .proc|1 .initial|1 .l|1))))) 'reduce))
+(let () (begin (set! reduce-right (lambda (.proc|1 .initial|1 .l|1) (let ((.reduce-right|2 0)) (begin (set! .reduce-right|2 (lambda (.proc|3 .initial|3 .l|3) (let ((.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.l|6) (if (null? (let ((.x|7|10 .l|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (let ((.x|11|14 .l|6)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (.proc|3 (let ((.x|15|18 .l|6)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.loop|5 (let ((.x|19|22 .l|6)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (if (null? .l|3) .initial|3 (if (null? (let ((.x|24|27 .l|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (let ((.x|28|31 .l|3)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) (.loop|5 .l|3))))))) (.reduce-right|2 .proc|1 .initial|1 .l|1))))) 'reduce-right))
+(let () (begin (set! fold-left (lambda (.proc|1 .initial|1 .l|1) (let ((.fold-left|2 0)) (begin (set! .fold-left|2 (lambda (.proc|3 .initial|3 .l|3) (if (null? .l|3) .initial|3 (.fold-left|2 .proc|3 (.proc|3 .initial|3 (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))))))) (.fold-left|2 .proc|1 .initial|1 .l|1))))) 'fold-left))
+(let () (begin (set! fold-right (lambda (.proc|1 .initial|1 .l|1) (let ((.fold-right|2 0)) (begin (set! .fold-right|2 (lambda (.proc|3 .initial|3 .l|3) (if (null? .l|3) .initial|3 (.proc|3 (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (.fold-right|2 .proc|3 .initial|3 (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))))))) (.fold-right|2 .proc|1 .initial|1 .l|1))))) 'fold-right))
+(let () (begin (set! iota (lambda (.n|1) (let ((.iota|2 0)) (begin (set! .iota|2 (lambda (.n|3) (let ((.n|6 (- .n|3 1)) (.r|6 '())) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.n|10 .r|10) (let ((.r|13 (cons .n|10 .r|10))) (if (= .n|10 0) .r|13 (.loop|9 (- .n|10 1) .r|13))))) (.loop|9 .n|6 .r|6))))))) (.iota|2 .n|1))))) 'iota))
+(let () (begin (set! list-head (lambda (.l|1 .n|1) (let ((.list-head|2 0)) (begin (set! .list-head|2 (lambda (.l|3 .n|3) (if (zero? .n|3) '() (cons (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (.list-head|2 (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) (- .n|3 1)))))) (.list-head|2 .l|1 .n|1))))) 'list-head))
+(let () (begin (set! $$trace (lambda (.x|1) (let ((.$$trace|2 0)) (begin (set! .$$trace|2 (lambda (.x|3) #t)) (.$$trace|2 .x|1))))) '$$trace))
+(let () (begin (set! host-system 'larceny) 'host-system))
+(let () (begin (set! .check! (lambda (.flag|1 .exn|1 . .args|1) (if (not .flag|1) (apply error "Runtime check exception: " .exn|1 .args|1) (unspecified)))) '.check!))
+(let () (begin (set! compat:initialize (lambda .rest|1 (if (null? .rest|1) (let ((.dir|4 (nbuild-parameter 'compatibility))) (begin (compat:load (string-append .dir|4 "compat2.sch")) (compat:load (string-append .dir|4 "../../Auxlib/list.sch")) (compat:load (string-append .dir|4 "../../Auxlib/pp.sch")))) (unspecified)))) 'compat:initialize))
+(let () (begin (set! with-optimization (lambda (.level|1 .thunk|1) (let ((.with-optimization|2 0)) (begin (set! .with-optimization|2 (lambda (.level|3 .thunk|3) (.thunk|3))) (.with-optimization|2 .level|1 .thunk|1))))) 'with-optimization))
+(let () (begin (set! call-with-error-control (lambda (.thunk1|1 .thunk2|1) (let ((.call-with-error-control|2 0)) (begin (set! .call-with-error-control|2 (lambda (.thunk1|3 .thunk2|3) (let ((.eh|6 (error-handler))) (begin (error-handler (lambda .args|7 (begin (error-handler .eh|6) (.thunk2|3) (apply .eh|6 .args|7)))) (.thunk1|3) (error-handler .eh|6))))) (.call-with-error-control|2 .thunk1|1 .thunk2|1))))) 'call-with-error-control))
+(let () (begin (set! larc-new-extension (lambda (.fn|1 .ext|1) (let ((.larc-new-extension|2 0)) (begin (set! .larc-new-extension|2 (lambda (.fn|3 .ext|3) (let* ((.l|6 (string-length .fn|3)) (.x|9 (let ((.i|15 (- .l|6 1))) (let () (let ((.loop|18 (unspecified))) (begin (set! .loop|18 (lambda (.i|19) (if (< .i|19 0) #f (if (char=? (string-ref .fn|3 .i|19) #\.) (+ .i|19 1) (.loop|18 (- .i|19 1)))))) (.loop|18 .i|15))))))) (let () (if (not .x|9) (string-append .fn|3 "." .ext|3) (string-append (substring .fn|3 0 .x|9) .ext|3)))))) (.larc-new-extension|2 .fn|1 .ext|1))))) 'larc-new-extension))
+(let () (begin (set! compat:load (lambda (.filename|1) (let ((.compat:load|2 0)) (begin (set! .compat:load|2 (lambda (.filename|3) (let ((.loadit|4 (unspecified))) (begin (set! .loadit|4 (lambda (.fn|5) (begin (if (nbuild-parameter 'verbose-load?) (format #t "~a~%" .fn|5) (unspecified)) (load .fn|5)))) (if (nbuild-parameter 'always-source?) (.loadit|4 .filename|3) (let ((.fn|8 (larc-new-extension .filename|3 "fasl"))) (if (if (file-exists? .fn|8) (compat:file-newer? .fn|8 .filename|3) #f) (.loadit|4 .fn|8) (.loadit|4 .filename|3)))))))) (.compat:load|2 .filename|1))))) 'compat:load))
+(let () (begin (set! compat:file-newer? (lambda (.a|1 .b|1) (let ((.compat:file-newer?|2 0)) (begin (set! .compat:file-newer?|2 (lambda (.a|3 .b|3) (let* ((.ta|6 (file-modification-time .a|3)) (.tb|9 (file-modification-time .b|3)) (.limit|12 (let ((.v|42|45 .ta|6)) (begin (.check! (vector? .v|42|45) 42 .v|42|45) (vector-length:vec .v|42|45))))) (let () (let ((.i|18 0)) (let () (let ((.loop|21 (unspecified))) (begin (set! .loop|21 (lambda (.i|22) (if (= .i|22 .limit|12) #f (if (= (let ((.v|25|28 .ta|6) (.i|25|28 .i|22)) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28))) (let ((.v|29|32 .tb|9) (.i|29|32 .i|22)) (begin (.check! (fixnum? .i|29|32) 40 .v|29|32 .i|29|32) (.check! (vector? .v|29|32) 40 .v|29|32 .i|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 40 .v|29|32 .i|29|32) (.check! (>=:fix:fix .i|29|32 0) 40 .v|29|32 .i|29|32) (vector-ref:trusted .v|29|32 .i|29|32)))) (.loop|21 (+ .i|22 1)) (> (let ((.v|34|37 .ta|6) (.i|34|37 .i|22)) (begin (.check! (fixnum? .i|34|37) 40 .v|34|37 .i|34|37) (.check! (vector? .v|34|37) 40 .v|34|37 .i|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 40 .v|34|37 .i|34|37) (.check! (>=:fix:fix .i|34|37 0) 40 .v|34|37 .i|34|37) (vector-ref:trusted .v|34|37 .i|34|37))) (let ((.v|38|41 .tb|9) (.i|38|41 .i|22)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41)))))))) (.loop|21 .i|18))))))))) (.compat:file-newer?|2 .a|1 .b|1))))) 'compat:file-newer?))
+(let () (begin (set! host-system 'larceny) 'host-system))
+(let () (begin (set! compat:sort (lambda (.list|1 .less?|1) (sort .list|1 .less?|1))) 'compat:sort))
+(let () (begin (set! compat:char->integer char->integer) 'compat:char->integer))
+(let () (begin (set! write-lop (lambda (.item|1 .port|1) (let ((.write-lop|2 0)) (begin (set! .write-lop|2 (lambda (.item|3 .port|3) (begin (lowlevel-write .item|3 .port|3) (newline .port|3) (newline .port|3)))) (.write-lop|2 .item|1 .port|1))))) 'write-lop))
+(let () (begin (set! write-fasl-datum lowlevel-write) 'write-fasl-datum))
+(let () (begin (set! misc->bytevector (lambda (.x|1) (let ((.misc->bytevector|2 0)) (begin (set! .misc->bytevector|2 (lambda (.x|3) (let ((.bv|6 (bytevector-like-copy .x|3))) (begin (typetag-set! .bv|6 $tag.bytevector-typetag) .bv|6)))) (.misc->bytevector|2 .x|1))))) 'misc->bytevector))
+(let () (begin (set! string->bytevector misc->bytevector) 'string->bytevector))
+(let () (begin (set! bignum->bytevector misc->bytevector) 'bignum->bytevector))
+(let () (begin (set! flonum->bytevector (lambda (.x|1) (let ((.flonum->bytevector|2 0)) (begin (set! .flonum->bytevector|2 (lambda (.x|3) (clear-first-word (misc->bytevector .x|3)))) (.flonum->bytevector|2 .x|1))))) 'flonum->bytevector))
+(let () (begin (set! compnum->bytevector (lambda (.x|1) (let ((.compnum->bytevector|2 0)) (begin (set! .compnum->bytevector|2 (lambda (.x|3) (clear-first-word (misc->bytevector .x|3)))) (.compnum->bytevector|2 .x|1))))) 'compnum->bytevector))
+(let () (begin (set! clear-first-word (lambda (.bv|1) (let ((.clear-first-word|2 0)) (begin (set! .clear-first-word|2 (lambda (.bv|3) (begin (bytevector-like-set! .bv|3 0 0) (bytevector-like-set! .bv|3 1 0) (bytevector-like-set! .bv|3 2 0) (bytevector-like-set! .bv|3 3 0) .bv|3))) (.clear-first-word|2 .bv|1))))) 'clear-first-word))
+(let () (begin (set! list->bytevector (lambda (.l|1) (let ((.list->bytevector|2 0)) (begin (set! .list->bytevector|2 (lambda (.l|3) (let ((.b|6 (make-bytevector (length .l|3)))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.i|14 .l|14) (if (null? .l|14) .b|6 (begin (begin #t (bytevector-set! .b|6 .i|14 (let ((.x|17|20 .l|14)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (.loop|7|10|13 (+ .i|14 1) (let ((.x|21|24 .l|14)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))))))) (.loop|7|10|13 0 .l|3))))))) (.list->bytevector|2 .l|1))))) 'list->bytevector))
+(let () (begin (set! bytevector-word-ref (let ((.two^8|3 (expt 2 8)) (.two^16|3 (expt 2 16)) (.two^24|3 (expt 2 24))) (lambda (.bv|4 .i|4) (+ (+ (+ (* (bytevector-ref .bv|4 .i|4) .two^24|3) (* (bytevector-ref .bv|4 (+ .i|4 1)) .two^16|3)) (* (bytevector-ref .bv|4 (+ .i|4 2)) .two^8|3)) (bytevector-ref .bv|4 (+ .i|4 3)))))) 'bytevector-word-ref))
+(let () (begin (set! twobit-format (lambda (.fmt|1 . .rest|1) (let ((.out|4 (open-output-string))) (begin (apply format .out|4 .fmt|1 .rest|1) (get-output-string .out|4))))) 'twobit-format))
+(let () (begin (set! an-arbitrary-number (lambda () (let ((.an-arbitrary-number|2 0)) (begin (set! .an-arbitrary-number|2 (lambda () (begin (system "echo \\\"`date`\\\" > a-random-number") (let ((.x|6 (string-hash (call-with-input-file "a-random-number" read)))) (begin (delete-file "a-random-number") .x|6))))) (.an-arbitrary-number|2))))) 'an-arbitrary-number))
+(let () (begin (set! cerror error) 'cerror))
+(let () (begin (set! empty-set (lambda () (let ((.empty-set|2 0)) (begin (set! .empty-set|2 (lambda () '())) (.empty-set|2))))) 'empty-set))
+(let () (begin (set! empty-set? (lambda (.x|1) (let ((.empty-set?|2 0)) (begin (set! .empty-set?|2 (lambda (.x|3) (null? .x|3))) (.empty-set?|2 .x|1))))) 'empty-set?))
+(let () (begin (set! make-set (lambda (.x|1) (let ((.make-set|2 0)) (begin (set! .make-set|2 (lambda (.x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.x|5 .y|5) (if (null? .x|5) .y|5 (if (member (let ((.x|8|11 .x|5)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .y|5) (.loop|4 (let ((.x|12|15 .x|5)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) .y|5) (.loop|4 (let ((.x|17|20 .x|5)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (let ((.x|21|24 .x|5)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))) .y|5)))))) (.loop|4 .x|3 '()))))) (.make-set|2 .x|1))))) 'make-set))
+(let () (begin (set! set-equal? (lambda (.x|1 .y|1) (let ((.set-equal?|2 0)) (begin (set! .set-equal?|2 (lambda (.x|3 .y|3) (if (subset? .x|3 .y|3) (subset? .y|3 .x|3) #f))) (.set-equal?|2 .x|1 .y|1))))) 'set-equal?))
+(let () (begin (set! subset? (lambda (.x|1 .y|1) (let ((.subset?|2 0)) (begin (set! .subset?|2 (lambda (.x|3 .y|3) (every? (lambda (.x|4) (member .x|4 .y|3)) .x|3))) (.subset?|2 .x|1 .y|1))))) 'subset?))
+(let () (begin (set! apply-union (undefined)) 'apply-union))
+(let () (begin (set! union (let () (let ((.union2|3 (unspecified))) (begin (set! .union2|3 (lambda (.x|4 .y|4) (if (null? .x|4) .y|4 (if (member (let ((.x|7|10 .x|4)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) .y|4) (.union2|3 (let ((.x|11|14 .x|4)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))) .y|4) (.union2|3 (let ((.x|16|19 .x|4)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (cons (let ((.x|20|23 .x|4)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) .y|4)))))) (set! apply-union (lambda (.sets|24) (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.sets|32 .result|32) (if (null? .sets|32) .result|32 (begin #t (.loop|25|28|31 (let ((.x|35|38 .sets|32)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (.union2|3 (let ((.x|39|42 .sets|32)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) .result|32)))))) (.loop|25|28|31 .sets|24 '())))))) (lambda .args|43 (if (null? .args|43) '() (if (null? (let ((.x|46|49 .args|43)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49)))) (let ((.x|50|53 .args|43)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))) (if (null? (let ((.x|56|59 (let ((.x|60|63 .args|43)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))))) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59)))) (.union2|3 (let ((.x|64|67 .args|43)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))) (let ((.x|69|72 (let ((.x|73|76 .args|43)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72)))) (.union2|3 (.union2|3 (let ((.x|78|81 .args|43)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81))) (let ((.x|83|86 (let ((.x|87|90 .args|43)) (begin (.check! (pair? .x|87|90) 1 .x|87|90) (cdr:pair .x|87|90))))) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86)))) (apply union (let ((.x|92|95 (let ((.x|96|99 .args|43)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))))))))))))) 'union))
+(let () (begin (set! intersection (let () (let ((.intersection2|3 (unspecified))) (begin (set! .intersection2|3 (lambda (.x|4 .y|4) (if (null? .x|4) '() (if (member (let ((.x|7|10 .x|4)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) .y|4) (cons (let ((.x|11|14 .x|4)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (.intersection2|3 (let ((.x|15|18 .x|4)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .y|4)) (.intersection2|3 (let ((.x|20|23 .x|4)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) .y|4))))) (lambda .args|24 (if (null? .args|24) '() (if (null? (let ((.x|27|30 .args|24)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (let ((.x|31|34 .args|24)) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))) (if (null? (let ((.x|37|40 (let ((.x|41|44 .args|24)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))) (.intersection2|3 (let ((.x|45|48 .args|24)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))) (let ((.x|50|53 (let ((.x|54|57 .args|24)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53)))) (.intersection2|3 (.intersection2|3 (let ((.x|59|62 .args|24)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|64|67 (let ((.x|68|71 .args|24)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (apply intersection (let ((.x|73|76 (let ((.x|77|80 .args|24)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))))) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))))))))))) 'intersection))
+(let () (begin (set! difference (lambda (.x|1 .y|1) (let ((.difference|2 0)) (begin (set! .difference|2 (lambda (.x|3 .y|3) (if (null? .x|3) '() (if (member (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .y|3) (.difference|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) .y|3) (cons (let ((.x|15|18 .x|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.difference|2 (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))) .y|3)))))) (.difference|2 .x|1 .y|1))))) 'difference))
+(let () (begin (set! object-hash (lambda (.x|1) 0)) 'object-hash))
+(let () (begin (set! equal-hash (lambda (.x|1) 0)) 'equal-hash))
+(let () (let ((.n|3 16777216) (.n-1|3 16777215) (.adj:fixnum|3 9000000) (.adj:negative|3 8000000) (.adj:large|3 7900000) (.adj:ratnum|3 7800000) (.adj:complex|3 7700000) (.adj:flonum|3 7000000) (.adj:compnum|3 6900000) (.adj:char|3 6111000) (.adj:string|3 5022200) (.adj:vector|3 4003330) (.adj:misc|3 3000444) (.adj:pair|3 2555000) (.adj:proc|3 2321001) (.adj:iport|3 2321002) (.adj:oport|3 2321003) (.adj:weird|3 2321004) (.budget0|3 32)) (let ((.hash-on-equal|4 (unspecified)) (.combine|4 (unspecified))) (begin (set! .hash-on-equal|4 (lambda (.x|5 .budget|5) (if (> .budget|5 0) (if (string? .x|5) (string-hash .x|5) (if (pair? .x|5) (let ((.budget|10 (quotient .budget|5 2))) (.combine|4 (.hash-on-equal|4 (let ((.x|11|14 .x|5)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) .budget|10) (.hash-on-equal|4 (let ((.x|15|18 .x|5)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .budget|10))) (if (vector? .x|5) (let ((.n|22 (let ((.v|35|38 .x|5)) (begin (.check! (vector? .v|35|38) 42 .v|35|38) (vector-length:vec .v|35|38)))) (.budget|22 (quotient .budget|5 4))) (if (> .n|22 0) (.combine|4 (.combine|4 (.hash-on-equal|4 (let ((.v|23|26 .x|5) (.i|23|26 0)) (begin (.check! (fixnum? .i|23|26) 40 .v|23|26 .i|23|26) (.check! (vector? .v|23|26) 40 .v|23|26 .i|23|26) (.check! (<:fix:fix .i|23|26 (vector-length:vec .v|23|26)) 40 .v|23|26 .i|23|26) (.check! (>=:fix:fix .i|23|26 0) 40 .v|23|26 .i|23|26) (vector-ref:trusted .v|23|26 .i|23|26))) .budget|22) (.hash-on-equal|4 (let ((.v|27|30 .x|5) (.i|27|30 (- .n|22 1))) (begin (.check! (fixnum? .i|27|30) 40 .v|27|30 .i|27|30) (.check! (vector? .v|27|30) 40 .v|27|30 .i|27|30) (.check! (<:fix:fix .i|27|30 (vector-length:vec .v|27|30)) 40 .v|27|30 .i|27|30) (.check! (>=:fix:fix .i|27|30 0) 40 .v|27|30 .i|27|30) (vector-ref:trusted .v|27|30 .i|27|30))) .budget|22)) (.hash-on-equal|4 (let ((.v|31|34 .x|5) (.i|31|34 (quotient .n|22 2))) (begin (.check! (fixnum? .i|31|34) 40 .v|31|34 .i|31|34) (.check! (vector? .v|31|34) 40 .v|31|34 .i|31|34) (.check! (<:fix:fix .i|31|34 (vector-length:vec .v|31|34)) 40 .v|31|34 .i|31|34) (.check! (>=:fix:fix .i|31|34 0) 40 .v|31|34 .i|31|34) (vector-ref:trusted .v|31|34 .i|31|34))) (+ .budget|22 .budget|22))) .adj:vector|3)) (object-hash .x|5)))) .adj:weird|3))) (set! .combine|4 (lambda (.hash|40 .adjustment|40) (modulo (+ (+ (+ .hash|40 .hash|40) .hash|40) .adjustment|40) 16777216))) (set! object-hash (lambda (.x|43) (if (symbol? .x|43) (symbol-hash .x|43) (if (number? .x|43) (if (exact? .x|43) (if (integer? .x|43) (if (< .x|43 0) (.combine|4 (object-hash (- 0 .x|43)) .adj:negative|3) (if (< .x|43 .n|3) (.combine|4 .x|43 .adj:fixnum|3) (.combine|4 (modulo .x|43 .n|3) .adj:large|3))) (if (rational? .x|43) (.combine|4 (.combine|4 (object-hash (numerator .x|43)) .adj:ratnum|3) (object-hash (denominator .x|43))) (if (real? .x|43) .adj:weird|3 (if (complex? .x|43) (.combine|4 (.combine|4 (object-hash (real-part .x|43)) .adj:complex|3) (object-hash (imag-part .x|43))) .adj:weird|3)))) (if #t .adj:flonum|3 (if (rational? .x|43) (.combine|4 (.combine|4 (object-hash (inexact->exact (numerator .x|43))) .adj:flonum|3) (object-hash (inexact->exact (denominator .x|43)))) (if (real? .x|43) .adj:weird|3 (if (complex? .x|43) (.combine|4 (.combine|4 (object-hash (real-part .x|43)) .adj:compnum|3) (object-hash (imag-part .x|43))) .adj:weird|3))))) (if (char? .x|43) (.combine|4 (char->integer .x|43) .adj:char|3) (if (string? .x|43) (.combine|4 (string-length .x|43) .adj:string|3) (if (vector? .x|43) (.combine|4 (let ((.v|64|67 .x|43)) (begin (.check! (vector? .v|64|67) 42 .v|64|67) (vector-length:vec .v|64|67))) .adj:vector|3) (if (eq? .x|43 #t) (.combine|4 1 .adj:misc|3) (if (eq? .x|43 #f) (.combine|4 2 .adj:misc|3) (if (null? .x|43) (.combine|4 3 .adj:misc|3) (if (pair? .x|43) .adj:pair|3 (if (procedure? .x|43) .adj:proc|3 (if (input-port? .x|43) .adj:iport|3 (if (output-port? .x|43) .adj:oport|3 .adj:weird|3)))))))))))))) (set! equal-hash (lambda (.x|76) (.hash-on-equal|4 .x|76 .budget0|3)))))))
+(let () (begin (set! make-hashtable (lambda .args|1 '*)) 'make-hashtable))
+(let () (begin (set! hashtable-contains? (lambda (.ht|1 .key|1) #f)) 'hashtable-contains?))
+(let () (begin (set! hashtable-fetch (lambda (.ht|1 .key|1 .flag|1) .flag|1)) 'hashtable-fetch))
+(let () (begin (set! hashtable-get (lambda (.ht|1 .key|1) (hashtable-fetch .ht|1 .key|1 #f))) 'hashtable-get))
+(let () (begin (set! hashtable-put! (lambda (.ht|1 .key|1 .val|1) '*)) 'hashtable-put!))
+(let () (begin (set! hashtable-remove! (lambda (.ht|1 .key|1) '*)) 'hashtable-remove!))
+(let () (begin (set! hashtable-clear! (lambda (.ht|1) '*)) 'hashtable-clear!))
+(let () (begin (set! hashtable-size (lambda (.ht|1) 0)) 'hashtable-size))
+(let () (begin (set! hashtable-for-each (lambda (.ht|1 .proc|1) '*)) 'hashtable-for-each))
+(let () (begin (set! hashtable-map (lambda (.ht|1 .proc|1) '())) 'hashtable-map))
+(let () (begin (set! hashtable-copy (lambda (.ht|1) .ht|1)) 'hashtable-copy))
+(let () (let ((.doc|3 (cons "HASHTABLE" '())) (.count|3 (lambda (.ht|484) (let ((.v|485|488 .ht|484) (.i|485|488 1)) (begin (.check! (fixnum? .i|485|488) 40 .v|485|488 .i|485|488) (.check! (vector? .v|485|488) 40 .v|485|488 .i|485|488) (.check! (<:fix:fix .i|485|488 (vector-length:vec .v|485|488)) 40 .v|485|488 .i|485|488) (.check! (>=:fix:fix .i|485|488 0) 40 .v|485|488 .i|485|488) (vector-ref:trusted .v|485|488 .i|485|488))))) (.count!|3 (lambda (.ht|489 .n|489) (let ((.v|490|493 .ht|489) (.i|490|493 1) (.x|490|493 .n|489)) (begin (.check! (fixnum? .i|490|493) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (vector? .v|490|493) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (<:fix:fix .i|490|493 (vector-length:vec .v|490|493)) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (>=:fix:fix .i|490|493 0) 41 .v|490|493 .i|490|493 .x|490|493) (vector-set!:trusted .v|490|493 .i|490|493 .x|490|493))))) (.hasher|3 (lambda (.ht|494) (let ((.v|495|498 .ht|494) (.i|495|498 2)) (begin (.check! (fixnum? .i|495|498) 40 .v|495|498 .i|495|498) (.check! (vector? .v|495|498) 40 .v|495|498 .i|495|498) (.check! (<:fix:fix .i|495|498 (vector-length:vec .v|495|498)) 40 .v|495|498 .i|495|498) (.check! (>=:fix:fix .i|495|498 0) 40 .v|495|498 .i|495|498) (vector-ref:trusted .v|495|498 .i|495|498))))) (.searcher|3 (lambda (.ht|499) (let ((.v|500|503 .ht|499) (.i|500|503 3)) (begin (.check! (fixnum? .i|500|503) 40 .v|500|503 .i|500|503) (.check! (vector? .v|500|503) 40 .v|500|503 .i|500|503) (.check! (<:fix:fix .i|500|503 (vector-length:vec .v|500|503)) 40 .v|500|503 .i|500|503) (.check! (>=:fix:fix .i|500|503 0) 40 .v|500|503 .i|500|503) (vector-ref:trusted .v|500|503 .i|500|503))))) (.buckets|3 (lambda (.ht|504) (let ((.v|505|508 .ht|504) (.i|505|508 4)) (begin (.check! (fixnum? .i|505|508) 40 .v|505|508 .i|505|508) (.check! (vector? .v|505|508) 40 .v|505|508 .i|505|508) (.check! (<:fix:fix .i|505|508 (vector-length:vec .v|505|508)) 40 .v|505|508 .i|505|508) (.check! (>=:fix:fix .i|505|508 0) 40 .v|505|508 .i|505|508) (vector-ref:trusted .v|505|508 .i|505|508))))) (.buckets!|3 (lambda (.ht|509 .v|509) (let ((.v|510|513 .ht|509) (.i|510|513 4) (.x|510|513 .v|509)) (begin (.check! (fixnum? .i|510|513) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (vector? .v|510|513) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (<:fix:fix .i|510|513 (vector-length:vec .v|510|513)) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (>=:fix:fix .i|510|513 0) 41 .v|510|513 .i|510|513 .x|510|513) (vector-set!:trusted .v|510|513 .i|510|513 .x|510|513))))) (.defaultn|3 10)) (let ((.hashtable?|6 (lambda (.ht|470) (if (vector? .ht|470) (if (= 5 (let ((.v|473|476 .ht|470)) (begin (.check! (vector? .v|473|476) 42 .v|473|476) (vector-length:vec .v|473|476)))) (eq? .doc|3 (let ((.v|478|481 .ht|470) (.i|478|481 0)) (begin (.check! (fixnum? .i|478|481) 40 .v|478|481 .i|478|481) (.check! (vector? .v|478|481) 40 .v|478|481 .i|478|481) (.check! (<:fix:fix .i|478|481 (vector-length:vec .v|478|481)) 40 .v|478|481 .i|478|481) (.check! (>=:fix:fix .i|478|481 0) 40 .v|478|481 .i|478|481) (vector-ref:trusted .v|478|481 .i|478|481)))) #f) #f))) (.hashtable-error|6 (lambda (.x|482) (begin (display "ERROR: Bad hash table: ") (newline) (write .x|482) (newline))))) (let ((.ht-copy|7 (unspecified)) (.ht-map|7 (unspecified)) (.ht-for-each|7 (unspecified)) (.size|7 (unspecified)) (.clear!|7 (unspecified)) (.remove!|7 (unspecified)) (.put!|7 (unspecified)) (.fetch|7 (unspecified)) (.contains?|7 (unspecified)) (.contents|7 (unspecified)) (.resize|7 (unspecified)) (.remq1|7 (unspecified)) (.substitute1|7 (unspecified)) (.make-ht|7 (unspecified))) (begin (set! .ht-copy|7 (lambda (.ht|8) (if (.hashtable?|6 .ht|8) (let* ((.newtable|11 (make-hashtable (.hasher|3 .ht|8) (.searcher|3 .ht|8) 0)) (.v|14 (.buckets|3 .ht|8)) (.n|17 (let ((.v|42|45 .v|14)) (begin (.check! (vector? .v|42|45) 42 .v|42|45) (vector-length:vec .v|42|45)))) (.newvector|20 (make-vector .n|17 '()))) (let () (begin (.count!|3 .newtable|11 (.count|3 .ht|8)) (.buckets!|3 .newtable|11 .newvector|20) (let () (let ((.loop|25|27|30 (unspecified))) (begin (set! .loop|25|27|30 (lambda (.i|31) (if (= .i|31 .n|17) (if #f #f (unspecified)) (begin (begin #t (let ((.v|34|37 .newvector|20) (.i|34|37 .i|31) (.x|34|37 (append (let ((.v|38|41 .v|14) (.i|38|41 .i|31)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))) '()))) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37)))) (.loop|25|27|30 (+ .i|31 1)))))) (.loop|25|27|30 0)))) .newtable|11))) (.hashtable-error|6 .ht|8)))) (set! .ht-map|7 (lambda (.f|46 .ht|46) (if (.hashtable?|6 .ht|46) (let* ((.v|49 (.contents|7 .ht|46)) (.n|52 (let ((.v|81|84 .v|49)) (begin (.check! (vector? .v|81|84) 42 .v|81|84) (vector-length:vec .v|81|84))))) (let () (let () (let ((.loop|56|59|62 (unspecified))) (begin (set! .loop|56|59|62 (lambda (.j|63 .results|63) (if (= .j|63 .n|52) (reverse .results|63) (begin #t (.loop|56|59|62 (+ .j|63 1) (let ((.x|68 (let ((.v|77|80 .v|49) (.i|77|80 .j|63)) (begin (.check! (fixnum? .i|77|80) 40 .v|77|80 .i|77|80) (.check! (vector? .v|77|80) 40 .v|77|80 .i|77|80) (.check! (<:fix:fix .i|77|80 (vector-length:vec .v|77|80)) 40 .v|77|80 .i|77|80) (.check! (>=:fix:fix .i|77|80 0) 40 .v|77|80 .i|77|80) (vector-ref:trusted .v|77|80 .i|77|80))))) (cons (.f|46 (let ((.x|69|72 .x|68)) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72))) (let ((.x|73|76 .x|68)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76)))) .results|63))))))) (.loop|56|59|62 0 '())))))) (.hashtable-error|6 .ht|46)))) (set! .ht-for-each|7 (lambda (.f|85 .ht|85) (if (.hashtable?|6 .ht|85) (let* ((.v|88 (.contents|7 .ht|85)) (.n|91 (let ((.v|120|123 .v|88)) (begin (.check! (vector? .v|120|123) 42 .v|120|123) (vector-length:vec .v|120|123))))) (let () (let () (let ((.loop|96|98|101 (unspecified))) (begin (set! .loop|96|98|101 (lambda (.j|102) (if (= .j|102 .n|91) (if #f #f (unspecified)) (begin (begin #t (let ((.x|107 (let ((.v|116|119 .v|88) (.i|116|119 .j|102)) (begin (.check! (fixnum? .i|116|119) 40 .v|116|119 .i|116|119) (.check! (vector? .v|116|119) 40 .v|116|119 .i|116|119) (.check! (<:fix:fix .i|116|119 (vector-length:vec .v|116|119)) 40 .v|116|119 .i|116|119) (.check! (>=:fix:fix .i|116|119 0) 40 .v|116|119 .i|116|119) (vector-ref:trusted .v|116|119 .i|116|119))))) (.f|85 (let ((.x|108|111 .x|107)) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111))) (let ((.x|112|115 .x|107)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115)))))) (.loop|96|98|101 (+ .j|102 1)))))) (.loop|96|98|101 0)))))) (.hashtable-error|6 .ht|85)))) (set! .size|7 (lambda (.ht|124) (if (.hashtable?|6 .ht|124) (.count|3 .ht|124) (.hashtable-error|6 .ht|124)))) (set! .clear!|7 (lambda (.ht|125) (if (.hashtable?|6 .ht|125) (call-without-interrupts (lambda () (begin (.count!|3 .ht|125 0) (.buckets!|3 .ht|125 (make-vector .defaultn|3 '())) #f))) (.hashtable-error|6 .ht|125)))) (set! .remove!|7 (lambda (.ht|127 .key|127) (if (.hashtable?|6 .ht|127) (call-without-interrupts (lambda () (let* ((.v|131 (.buckets|3 .ht|127)) (.n|134 (let ((.v|155|158 .v|131)) (begin (.check! (vector? .v|155|158) 42 .v|155|158) (vector-length:vec .v|155|158)))) (.h|137 (modulo ((.hasher|3 .ht|127) .key|127) .n|134)) (.b|140 (let ((.v|151|154 .v|131) (.i|151|154 .h|137)) (begin (.check! (fixnum? .i|151|154) 40 .v|151|154 .i|151|154) (.check! (vector? .v|151|154) 40 .v|151|154 .i|151|154) (.check! (<:fix:fix .i|151|154 (vector-length:vec .v|151|154)) 40 .v|151|154 .i|151|154) (.check! (>=:fix:fix .i|151|154 0) 40 .v|151|154 .i|151|154) (vector-ref:trusted .v|151|154 .i|151|154)))) (.probe|143 ((.searcher|3 .ht|127) .key|127 .b|140))) (let () (begin (if .probe|143 (begin (.count!|3 .ht|127 (- (.count|3 .ht|127) 1)) (let ((.v|147|150 .v|131) (.i|147|150 .h|137) (.x|147|150 (.remq1|7 .probe|143 .b|140))) (begin (.check! (fixnum? .i|147|150) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (vector? .v|147|150) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (<:fix:fix .i|147|150 (vector-length:vec .v|147|150)) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (>=:fix:fix .i|147|150 0) 41 .v|147|150 .i|147|150 .x|147|150) (vector-set!:trusted .v|147|150 .i|147|150 .x|147|150))) (if (< (* 2 (+ .defaultn|3 (.count|3 .ht|127))) .n|134) (.resize|7 .ht|127) (unspecified))) (unspecified)) #f))))) (.hashtable-error|6 .ht|127)))) (set! .put!|7 (lambda (.ht|159 .key|159 .val|159) (if (.hashtable?|6 .ht|159) (call-without-interrupts (lambda () (begin (let* ((.v|163 (.buckets|3 .ht|159)) (.n|166 (let ((.v|191|194 .v|163)) (begin (.check! (vector? .v|191|194) 42 .v|191|194) (vector-length:vec .v|191|194)))) (.h|169 (modulo ((.hasher|3 .ht|159) .key|159) .n|166)) (.b|172 (let ((.v|187|190 .v|163) (.i|187|190 .h|169)) (begin (.check! (fixnum? .i|187|190) 40 .v|187|190 .i|187|190) (.check! (vector? .v|187|190) 40 .v|187|190 .i|187|190) (.check! (<:fix:fix .i|187|190 (vector-length:vec .v|187|190)) 40 .v|187|190 .i|187|190) (.check! (>=:fix:fix .i|187|190 0) 40 .v|187|190 .i|187|190) (vector-ref:trusted .v|187|190 .i|187|190)))) (.probe|175 ((.searcher|3 .ht|159) .key|159 .b|172))) (let () (if .probe|175 (let ((.v|179|182 .v|163) (.i|179|182 .h|169) (.x|179|182 (.substitute1|7 (cons .key|159 .val|159) .probe|175 .b|172))) (begin (.check! (fixnum? .i|179|182) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (vector? .v|179|182) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (<:fix:fix .i|179|182 (vector-length:vec .v|179|182)) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (>=:fix:fix .i|179|182 0) 41 .v|179|182 .i|179|182 .x|179|182) (vector-set!:trusted .v|179|182 .i|179|182 .x|179|182))) (begin (.count!|3 .ht|159 (+ (.count|3 .ht|159) 1)) (let ((.v|183|186 .v|163) (.i|183|186 .h|169) (.x|183|186 (cons (cons .key|159 .val|159) .b|172))) (begin (.check! (fixnum? .i|183|186) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (vector? .v|183|186) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (<:fix:fix .i|183|186 (vector-length:vec .v|183|186)) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (>=:fix:fix .i|183|186 0) 41 .v|183|186 .i|183|186 .x|183|186) (vector-set!:trusted .v|183|186 .i|183|186 .x|183|186))) (if (> (.count|3 .ht|159) .n|166) (.resize|7 .ht|159) (unspecified)))))) #f))) (.hashtable-error|6 .ht|159)))) (set! .fetch|7 (lambda (.ht|195 .key|195 .flag|195) (if (.hashtable?|6 .ht|195) (let* ((.v|198 (.buckets|3 .ht|195)) (.n|201 (let ((.v|222|225 .v|198)) (begin (.check! (vector? .v|222|225) 42 .v|222|225) (vector-length:vec .v|222|225)))) (.h|204 (modulo ((.hasher|3 .ht|195) .key|195) .n|201)) (.b|207 (let ((.v|218|221 .v|198) (.i|218|221 .h|204)) (begin (.check! (fixnum? .i|218|221) 40 .v|218|221 .i|218|221) (.check! (vector? .v|218|221) 40 .v|218|221 .i|218|221) (.check! (<:fix:fix .i|218|221 (vector-length:vec .v|218|221)) 40 .v|218|221 .i|218|221) (.check! (>=:fix:fix .i|218|221 0) 40 .v|218|221 .i|218|221) (vector-ref:trusted .v|218|221 .i|218|221)))) (.probe|210 ((.searcher|3 .ht|195) .key|195 .b|207))) (let () (if .probe|210 (let ((.x|214|217 .probe|210)) (begin (.check! (pair? .x|214|217) 1 .x|214|217) (cdr:pair .x|214|217))) .flag|195))) (.hashtable-error|6 .ht|195)))) (set! .contains?|7 (lambda (.ht|226 .key|226) (if (.hashtable?|6 .ht|226) (let* ((.v|229 (.buckets|3 .ht|226)) (.n|232 (let ((.v|246|249 .v|229)) (begin (.check! (vector? .v|246|249) 42 .v|246|249) (vector-length:vec .v|246|249)))) (.h|235 (modulo ((.hasher|3 .ht|226) .key|226) .n|232)) (.b|238 (let ((.v|242|245 .v|229) (.i|242|245 .h|235)) (begin (.check! (fixnum? .i|242|245) 40 .v|242|245 .i|242|245) (.check! (vector? .v|242|245) 40 .v|242|245 .i|242|245) (.check! (<:fix:fix .i|242|245 (vector-length:vec .v|242|245)) 40 .v|242|245 .i|242|245) (.check! (>=:fix:fix .i|242|245 0) 40 .v|242|245 .i|242|245) (vector-ref:trusted .v|242|245 .i|242|245))))) (let () (if ((.searcher|3 .ht|226) .key|226 .b|238) #t #f))) (.hashtable-error|6 .ht|226)))) (set! .contents|7 (lambda (.ht|250) (let* ((.v|253 (.buckets|3 .ht|250)) (.n|256 (let ((.v|296|299 .v|253)) (begin (.check! (vector? .v|296|299) 42 .v|296|299) (vector-length:vec .v|296|299)))) (.z|259 (make-vector (.count|3 .ht|250) '()))) (let () (let ((.loop|263 (unspecified))) (begin (set! .loop|263 (lambda (.i|264 .bucket|264 .j|264) (if (null? .bucket|264) (if (= .i|264 .n|256) (if (= .j|264 (let ((.v|265|268 .z|259)) (begin (.check! (vector? .v|265|268) 42 .v|265|268) (vector-length:vec .v|265|268)))) .z|259 (begin (display "BUG in hashtable") (newline) '#())) (.loop|263 (+ .i|264 1) (let ((.v|269|272 .v|253) (.i|269|272 .i|264)) (begin (.check! (fixnum? .i|269|272) 40 .v|269|272 .i|269|272) (.check! (vector? .v|269|272) 40 .v|269|272 .i|269|272) (.check! (<:fix:fix .i|269|272 (vector-length:vec .v|269|272)) 40 .v|269|272 .i|269|272) (.check! (>=:fix:fix .i|269|272 0) 40 .v|269|272 .i|269|272) (vector-ref:trusted .v|269|272 .i|269|272))) .j|264)) (let ((.entry|275 (let ((.x|292|295 .bucket|264)) (begin (.check! (pair? .x|292|295) 0 .x|292|295) (car:pair .x|292|295))))) (begin (let ((.v|276|279 .z|259) (.i|276|279 .j|264) (.x|276|279 (cons (let ((.x|280|283 .entry|275)) (begin (.check! (pair? .x|280|283) 0 .x|280|283) (car:pair .x|280|283))) (let ((.x|284|287 .entry|275)) (begin (.check! (pair? .x|284|287) 1 .x|284|287) (cdr:pair .x|284|287)))))) (begin (.check! (fixnum? .i|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (vector? .v|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (<:fix:fix .i|276|279 (vector-length:vec .v|276|279)) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (>=:fix:fix .i|276|279 0) 41 .v|276|279 .i|276|279 .x|276|279) (vector-set!:trusted .v|276|279 .i|276|279 .x|276|279))) (.loop|263 .i|264 (let ((.x|288|291 .bucket|264)) (begin (.check! (pair? .x|288|291) 1 .x|288|291) (cdr:pair .x|288|291))) (+ .j|264 1))))))) (.loop|263 0 '() 0))))))) (set! .resize|7 (lambda (.ht0|300) (call-without-interrupts (lambda () (let ((.ht|304 (.make-ht|7 (.hasher|3 .ht0|300) (.searcher|3 .ht0|300) (+ 1 (* 2 (.count|3 .ht0|300)))))) (begin (.ht-for-each|7 (lambda (.key|305 .val|305) (.put!|7 .ht|304 .key|305 .val|305)) .ht0|300) (.buckets!|3 .ht0|300 (.buckets|3 .ht|304)))))))) (set! .remq1|7 (lambda (.x|306 .y|306) (if (eq? .x|306 (let ((.x|308|311 .y|306)) (begin (.check! (pair? .x|308|311) 0 .x|308|311) (car:pair .x|308|311)))) (let ((.x|312|315 .y|306)) (begin (.check! (pair? .x|312|315) 1 .x|312|315) (cdr:pair .x|312|315))) (cons (let ((.x|317|320 .y|306)) (begin (.check! (pair? .x|317|320) 0 .x|317|320) (car:pair .x|317|320))) (.remq1|7 .x|306 (let ((.x|321|324 .y|306)) (begin (.check! (pair? .x|321|324) 1 .x|321|324) (cdr:pair .x|321|324)))))))) (set! .substitute1|7 (lambda (.x|325 .y|325 .z|325) (if (eq? .y|325 (let ((.x|327|330 .z|325)) (begin (.check! (pair? .x|327|330) 0 .x|327|330) (car:pair .x|327|330)))) (cons .x|325 (let ((.x|331|334 .z|325)) (begin (.check! (pair? .x|331|334) 1 .x|331|334) (cdr:pair .x|331|334)))) (cons (let ((.x|336|339 .z|325)) (begin (.check! (pair? .x|336|339) 0 .x|336|339) (car:pair .x|336|339))) (.substitute1|7 .x|325 .y|325 (let ((.x|340|343 .z|325)) (begin (.check! (pair? .x|340|343) 1 .x|340|343) (cdr:pair .x|340|343)))))))) (set! .make-ht|7 (lambda (.hashfun|344 .searcher|344 .size|344) (let* ((.t|345|350|355 (make-vector .size|344 '())) (.t|345|349|358 .searcher|344) (.t|345|348|361 .hashfun|344) (.t|345|347|364 0) (.t|345|346|367 .doc|3) (.v|345|352|370 (make-vector 5 .t|345|350|355))) (let () (begin (let ((.v|374|377 .v|345|352|370) (.i|374|377 3) (.x|374|377 .t|345|349|358)) (begin (.check! (fixnum? .i|374|377) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (vector? .v|374|377) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (<:fix:fix .i|374|377 (vector-length:vec .v|374|377)) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (>=:fix:fix .i|374|377 0) 41 .v|374|377 .i|374|377 .x|374|377) (vector-set!:trusted .v|374|377 .i|374|377 .x|374|377))) (let ((.v|378|381 .v|345|352|370) (.i|378|381 2) (.x|378|381 .t|345|348|361)) (begin (.check! (fixnum? .i|378|381) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (vector? .v|378|381) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (<:fix:fix .i|378|381 (vector-length:vec .v|378|381)) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (>=:fix:fix .i|378|381 0) 41 .v|378|381 .i|378|381 .x|378|381) (vector-set!:trusted .v|378|381 .i|378|381 .x|378|381))) (let ((.v|382|385 .v|345|352|370) (.i|382|385 1) (.x|382|385 .t|345|347|364)) (begin (.check! (fixnum? .i|382|385) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (vector? .v|382|385) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (<:fix:fix .i|382|385 (vector-length:vec .v|382|385)) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (>=:fix:fix .i|382|385 0) 41 .v|382|385 .i|382|385 .x|382|385) (vector-set!:trusted .v|382|385 .i|382|385 .x|382|385))) (let ((.v|386|389 .v|345|352|370) (.i|386|389 0) (.x|386|389 .t|345|346|367)) (begin (.check! (fixnum? .i|386|389) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (vector? .v|386|389) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (<:fix:fix .i|386|389 (vector-length:vec .v|386|389)) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (>=:fix:fix .i|386|389 0) 41 .v|386|389 .i|386|389 .x|386|389) (vector-set!:trusted .v|386|389 .i|386|389 .x|386|389))) .v|345|352|370))))) (set! make-hashtable (lambda .args|390 (let* ((.hashfun|393 (if (null? .args|390) object-hash (let ((.x|456|459 .args|390)) (begin (.check! (pair? .x|456|459) 0 .x|456|459) (car:pair .x|456|459))))) (.searcher|396 (if (let ((.temp|438|441 (null? .args|390))) (if .temp|438|441 .temp|438|441 (null? (let ((.x|443|446 .args|390)) (begin (.check! (pair? .x|443|446) 1 .x|443|446) (cdr:pair .x|443|446)))))) assv (let ((.x|448|451 (let ((.x|452|455 .args|390)) (begin (.check! (pair? .x|452|455) 1 .x|452|455) (cdr:pair .x|452|455))))) (begin (.check! (pair? .x|448|451) 0 .x|448|451) (car:pair .x|448|451))))) (.size|399 (if (let ((.temp|403|406 (null? .args|390))) (if .temp|403|406 .temp|403|406 (let ((.temp|407|410 (null? (let ((.x|421|424 .args|390)) (begin (.check! (pair? .x|421|424) 1 .x|421|424) (cdr:pair .x|421|424)))))) (if .temp|407|410 .temp|407|410 (null? (let ((.x|413|416 (let ((.x|417|420 .args|390)) (begin (.check! (pair? .x|417|420) 1 .x|417|420) (cdr:pair .x|417|420))))) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416)))))))) .defaultn|3 (let ((.x|426|429 (let ((.x|430|433 (let ((.x|434|437 .args|390)) (begin (.check! (pair? .x|434|437) 1 .x|434|437) (cdr:pair .x|434|437))))) (begin (.check! (pair? .x|430|433) 1 .x|430|433) (cdr:pair .x|430|433))))) (begin (.check! (pair? .x|426|429) 0 .x|426|429) (car:pair .x|426|429)))))) (let () (.make-ht|7 .hashfun|393 .searcher|396 .size|399))))) (set! hashtable-contains? (lambda (.ht|460 .key|460) (.contains?|7 .ht|460 .key|460))) (set! hashtable-fetch (lambda (.ht|461 .key|461 .flag|461) (.fetch|7 .ht|461 .key|461 .flag|461))) (set! hashtable-get (lambda (.ht|462 .key|462) (.fetch|7 .ht|462 .key|462 #f))) (set! hashtable-put! (lambda (.ht|463 .key|463 .val|463) (.put!|7 .ht|463 .key|463 .val|463))) (set! hashtable-remove! (lambda (.ht|464 .key|464) (.remove!|7 .ht|464 .key|464))) (set! hashtable-clear! (lambda (.ht|465) (.clear!|7 .ht|465))) (set! hashtable-size (lambda (.ht|466) (.size|7 .ht|466))) (set! hashtable-for-each (lambda (.ht|467 .proc|467) (.ht-for-each|7 .ht|467 .proc|467))) (set! hashtable-map (lambda (.ht|468 .proc|468) (.ht-map|7 .ht|468 .proc|468))) (set! hashtable-copy (lambda (.ht|469) (.ht-copy|7 .ht|469))) #f)))))
+(let () (begin (set! make-hashtree (lambda .args|1 '*)) 'make-hashtree))
+(let () (begin (set! hashtree-contains? (lambda (.ht|1 .key|1) #f)) 'hashtree-contains?))
+(let () (begin (set! hashtree-fetch (lambda (.ht|1 .key|1 .flag|1) .flag|1)) 'hashtree-fetch))
+(let () (begin (set! hashtree-get (lambda (.ht|1 .key|1) (hashtree-fetch .ht|1 .key|1 #f))) 'hashtree-get))
+(let () (begin (set! hashtree-put (lambda (.ht|1 .key|1 .val|1) '*)) 'hashtree-put))
+(let () (begin (set! hashtree-remove (lambda (.ht|1 .key|1) '*)) 'hashtree-remove))
+(let () (begin (set! hashtree-size (lambda (.ht|1) 0)) 'hashtree-size))
+(let () (begin (set! hashtree-for-each (lambda (.ht|1 .proc|1) '*)) 'hashtree-for-each))
+(let () (begin (set! hashtree-map (lambda (.ht|1 .proc|1) '())) 'hashtree-map))
+(let () (let ((.doc|3 (cons "hashtree" '())) (.count|3 (lambda (.ht|334) (let ((.v|335|338 .ht|334) (.i|335|338 1)) (begin (.check! (fixnum? .i|335|338) 40 .v|335|338 .i|335|338) (.check! (vector? .v|335|338) 40 .v|335|338 .i|335|338) (.check! (<:fix:fix .i|335|338 (vector-length:vec .v|335|338)) 40 .v|335|338 .i|335|338) (.check! (>=:fix:fix .i|335|338 0) 40 .v|335|338 .i|335|338) (vector-ref:trusted .v|335|338 .i|335|338))))) (.hasher|3 (lambda (.ht|339) (let ((.v|340|343 .ht|339) (.i|340|343 2)) (begin (.check! (fixnum? .i|340|343) 40 .v|340|343 .i|340|343) (.check! (vector? .v|340|343) 40 .v|340|343 .i|340|343) (.check! (<:fix:fix .i|340|343 (vector-length:vec .v|340|343)) 40 .v|340|343 .i|340|343) (.check! (>=:fix:fix .i|340|343 0) 40 .v|340|343 .i|340|343) (vector-ref:trusted .v|340|343 .i|340|343))))) (.searcher|3 (lambda (.ht|344) (let ((.v|345|348 .ht|344) (.i|345|348 3)) (begin (.check! (fixnum? .i|345|348) 40 .v|345|348 .i|345|348) (.check! (vector? .v|345|348) 40 .v|345|348 .i|345|348) (.check! (<:fix:fix .i|345|348 (vector-length:vec .v|345|348)) 40 .v|345|348 .i|345|348) (.check! (>=:fix:fix .i|345|348 0) 40 .v|345|348 .i|345|348) (vector-ref:trusted .v|345|348 .i|345|348))))) (.buckets|3 (lambda (.ht|349) (let ((.v|350|353 .ht|349) (.i|350|353 4)) (begin (.check! (fixnum? .i|350|353) 40 .v|350|353 .i|350|353) (.check! (vector? .v|350|353) 40 .v|350|353 .i|350|353) (.check! (<:fix:fix .i|350|353 (vector-length:vec .v|350|353)) 40 .v|350|353 .i|350|353) (.check! (>=:fix:fix .i|350|353 0) 40 .v|350|353 .i|350|353) (vector-ref:trusted .v|350|353 .i|350|353))))) (.make-empty-buckets|3 (lambda () '())) (.make-buckets|3 (lambda (.h|355 .alist|355 .buckets1|355 .buckets2|355) (let* ((.t1|356|359 .h|355) (.t2|356|362 (let* ((.t1|366|369 .alist|355) (.t2|366|372 (let* ((.t1|376|379 .buckets1|355) (.t2|376|382 (cons .buckets2|355 '()))) (let () (cons .t1|376|379 .t2|376|382))))) (let () (cons .t1|366|369 .t2|366|372))))) (let () (cons .t1|356|359 .t2|356|362))))) (.buckets-empty?|3 (lambda (.buckets|387) (null? .buckets|387))) (.buckets-n|3 (lambda (.buckets|388) (let ((.x|389|392 .buckets|388)) (begin (.check! (pair? .x|389|392) 0 .x|389|392) (car:pair .x|389|392))))) (.buckets-alist|3 (lambda (.buckets|393) (let ((.x|395|398 (let ((.x|399|402 .buckets|393)) (begin (.check! (pair? .x|399|402) 1 .x|399|402) (cdr:pair .x|399|402))))) (begin (.check! (pair? .x|395|398) 0 .x|395|398) (car:pair .x|395|398))))) (.buckets-left|3 (lambda (.buckets|403) (let ((.x|405|408 (let ((.x|409|412 (let ((.x|413|416 .buckets|403)) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416))))) (begin (.check! (pair? .x|409|412) 1 .x|409|412) (cdr:pair .x|409|412))))) (begin (.check! (pair? .x|405|408) 0 .x|405|408) (car:pair .x|405|408))))) (.buckets-right|3 (lambda (.buckets|417) (let ((.x|419|422 (let ((.x|423|426 (let ((.x|427|430 (let ((.x|431|434 .buckets|417)) (begin (.check! (pair? .x|431|434) 1 .x|431|434) (cdr:pair .x|431|434))))) (begin (.check! (pair? .x|427|430) 1 .x|427|430) (cdr:pair .x|427|430))))) (begin (.check! (pair? .x|423|426) 1 .x|423|426) (cdr:pair .x|423|426))))) (begin (.check! (pair? .x|419|422) 0 .x|419|422) (car:pair .x|419|422)))))) (let ((.hashtree?|6 (lambda (.ht|320) (if (vector? .ht|320) (if (= 5 (let ((.v|323|326 .ht|320)) (begin (.check! (vector? .v|323|326) 42 .v|323|326) (vector-length:vec .v|323|326)))) (eq? .doc|3 (let ((.v|328|331 .ht|320) (.i|328|331 0)) (begin (.check! (fixnum? .i|328|331) 40 .v|328|331 .i|328|331) (.check! (vector? .v|328|331) 40 .v|328|331 .i|328|331) (.check! (<:fix:fix .i|328|331 (vector-length:vec .v|328|331)) 40 .v|328|331 .i|328|331) (.check! (>=:fix:fix .i|328|331 0) 40 .v|328|331 .i|328|331) (vector-ref:trusted .v|328|331 .i|328|331)))) #f) #f))) (.hashtree-error|6 (lambda (.x|332) (begin (display "ERROR: Bad hash tree: ") (newline) (write .x|332) (newline))))) (let ((.ht-map|7 (unspecified)) (.ht-for-each|7 (unspecified)) (.size|7 (unspecified)) (.remove|7 (unspecified)) (.put|7 (unspecified)) (.find-bucket|7 (unspecified)) (.fetch|7 (unspecified)) (.contains?|7 (unspecified)) (.contents|7 (unspecified)) (.remq1|7 (unspecified)) (.substitute1|7 (unspecified)) (.make-ht|7 (unspecified))) (begin (set! .ht-map|7 (lambda (.f|8 .ht|8) (if (.hashtree?|6 .ht|8) (let () (let ((.loop|14|17|20 (unspecified))) (begin (set! .loop|14|17|20 (lambda (.y1|9|10|21 .results|9|13|21) (if (null? .y1|9|10|21) (reverse .results|9|13|21) (begin #t (.loop|14|17|20 (let ((.x|25|28 .y1|9|10|21)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) (cons (let ((.association|29 (let ((.x|38|41 .y1|9|10|21)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (.f|8 (let ((.x|30|33 .association|29)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|34|37 .association|29)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) .results|9|13|21)))))) (.loop|14|17|20 (.contents|7 .ht|8) '())))) (.hashtree-error|6 .ht|8)))) (set! .ht-for-each|7 (lambda (.f|42 .ht|42) (if (.hashtree?|6 .ht|42) (let () (let ((.loop|48|50|53 (unspecified))) (begin (set! .loop|48|50|53 (lambda (.y1|43|44|54) (if (null? .y1|43|44|54) (if #f #f (unspecified)) (begin (begin #t (let ((.association|58 (let ((.x|67|70 .y1|43|44|54)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (.f|42 (let ((.x|59|62 .association|58)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|63|66 .association|58)) (begin (.check! (pair? .x|63|66) 1 .x|63|66) (cdr:pair .x|63|66)))))) (.loop|48|50|53 (let ((.x|71|74 .y1|43|44|54)) (begin (.check! (pair? .x|71|74) 1 .x|71|74) (cdr:pair .x|71|74)))))))) (.loop|48|50|53 (.contents|7 .ht|42))))) (.hashtree-error|6 .ht|42)))) (set! .size|7 (lambda (.ht|75) (if (.hashtree?|6 .ht|75) (.count|3 .ht|75) (.hashtree-error|6 .ht|75)))) (set! .remove|7 (lambda (.ht|76 .key|76) (if (.hashtree?|6 .ht|76) (let ((.t|79 (.buckets|3 .ht|76)) (.h|79 ((.hasher|3 .ht|76) .key|76)) (.c|79 (.count|3 .ht|76))) (let ((.remove|82 (unspecified))) (begin (set! .remove|82 (lambda (.t|83 .h|83) (if (.buckets-empty?|3 .t|83) .t|83 (let ((.n|86 (.buckets-n|3 .t|83)) (.alist|86 (.buckets-alist|3 .t|83)) (.left|86 (.buckets-left|3 .t|83)) (.right|86 (.buckets-right|3 .t|83))) (if (< .h|83 .n|86) (.make-buckets|3 .n|86 .alist|86 (.remove|82 .left|86 .h|83) .right|86) (if (< .n|86 .h|83) (.make-buckets|3 .n|86 .alist|86 .left|86 (.remove|82 .right|86 .h|83)) (let ((.probe|92 ((.searcher|3 .ht|76) .key|76 .alist|86))) (if .probe|92 (begin (set! .c|79 (- .c|79 1)) (.make-buckets|3 .n|86 (.remq1|7 .probe|92 .alist|86) .left|86 .right|86)) .t|83)))))))) (let ((.buckets|93 (.remove|82 .t|79 .h|79))) (.make-ht|7 .c|79 (.hasher|3 .ht|76) (.searcher|3 .ht|76) .buckets|93))))) (.hashtree-error|6 .ht|76)))) (set! .put|7 (lambda (.ht|94 .key|94 .val|94) (if (.hashtree?|6 .ht|94) (let ((.t|97 (.buckets|3 .ht|94)) (.h|97 ((.hasher|3 .ht|94) .key|94)) (.association|97 (cons .key|94 .val|94)) (.c|97 (.count|3 .ht|94))) (let ((.put|100 (unspecified))) (begin (set! .put|100 (lambda (.t|101 .h|101) (if (.buckets-empty?|3 .t|101) (begin (set! .c|97 (+ .c|97 1)) (.make-buckets|3 .h|101 (cons .association|97 '()) .t|101 .t|101)) (let ((.n|105 (.buckets-n|3 .t|101)) (.alist|105 (.buckets-alist|3 .t|101)) (.left|105 (.buckets-left|3 .t|101)) (.right|105 (.buckets-right|3 .t|101))) (if (< .h|101 .n|105) (.make-buckets|3 .n|105 .alist|105 (.put|100 (.buckets-left|3 .t|101) .h|101) .right|105) (if (< .n|105 .h|101) (.make-buckets|3 .n|105 .alist|105 .left|105 (.put|100 (.buckets-right|3 .t|101) .h|101)) (let ((.probe|111 ((.searcher|3 .ht|94) .key|94 .alist|105))) (if .probe|111 (.make-buckets|3 .n|105 (.substitute1|7 .association|97 .probe|111 .alist|105) .left|105 .right|105) (begin (set! .c|97 (+ .c|97 1)) (.make-buckets|3 .n|105 (cons .association|97 .alist|105) .left|105 .right|105)))))))))) (let ((.buckets|112 (.put|100 .t|97 .h|97))) (.make-ht|7 .c|97 (.hasher|3 .ht|94) (.searcher|3 .ht|94) .buckets|112))))) (.hashtree-error|6 .ht|94)))) (set! .find-bucket|7 (lambda (.t|113 .h|113) (if (.buckets-empty?|3 .t|113) '() (let ((.n|116 (.buckets-n|3 .t|113))) (if (< .h|113 .n|116) (.find-bucket|7 (.buckets-left|3 .t|113) .h|113) (if (< .n|116 .h|113) (.find-bucket|7 (.buckets-right|3 .t|113) .h|113) (.buckets-alist|3 .t|113))))))) (set! .fetch|7 (lambda (.ht|120 .key|120 .flag|120) (if (.hashtree?|6 .ht|120) (let* ((.t|123 (.buckets|3 .ht|120)) (.h|126 ((.hasher|3 .ht|120) .key|120)) (.probe|129 ((.searcher|3 .ht|120) .key|120 (.find-bucket|7 .t|123 .h|126)))) (let () (if .probe|129 (let ((.x|133|136 .probe|129)) (begin (.check! (pair? .x|133|136) 1 .x|133|136) (cdr:pair .x|133|136))) .flag|120))) (.hashtree-error|6 .ht|120)))) (set! .contains?|7 (lambda (.ht|137 .key|137) (if (.hashtree?|6 .ht|137) (let* ((.t|140 (.buckets|3 .ht|137)) (.h|143 ((.hasher|3 .ht|137) .key|137))) (let () (if ((.searcher|3 .ht|137) .key|137 (.find-bucket|7 .t|140 .h|143)) #t #f))) (.hashtree-error|6 .ht|137)))) (set! .contents|7 (lambda (.ht|147) (let ((.t|150 (.buckets|3 .ht|147))) (let () (let ((.randomize-combine|154 (unspecified)) (.randomize3|154 (unspecified)) (.randomize2|154 (unspecified)) (.randomize1|154 (unspecified)) (.append-reverse|154 (unspecified)) (.contents|154 (unspecified))) (begin (set! .randomize-combine|154 (lambda (.alist1|155 .alist2|155 .alist3|155) (if (null? .alist2|155) .alist1|155 (if (null? .alist3|155) (.append-reverse|154 .alist2|155 .alist1|155) (.append-reverse|154 (.randomize1|154 .alist3|155 '() '() '()) (.append-reverse|154 (.randomize1|154 .alist1|155 '() '() '()) (.randomize1|154 .alist2|155 '() '() '()))))))) (set! .randomize3|154 (lambda (.alist|159 .alist1|159 .alist2|159 .alist3|159) (if (null? .alist|159) (.randomize-combine|154 .alist1|159 .alist2|159 .alist3|159) (.randomize1|154 (let ((.x|160|163 .alist|159)) (begin (.check! (pair? .x|160|163) 1 .x|160|163) (cdr:pair .x|160|163))) .alist1|159 .alist2|159 (cons (let ((.x|164|167 .alist|159)) (begin (.check! (pair? .x|164|167) 0 .x|164|167) (car:pair .x|164|167))) .alist3|159))))) (set! .randomize2|154 (lambda (.alist|168 .alist1|168 .alist2|168 .alist3|168) (if (null? .alist|168) (.randomize-combine|154 .alist1|168 .alist2|168 .alist3|168) (.randomize3|154 (let ((.x|169|172 .alist|168)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172))) .alist1|168 (cons (let ((.x|173|176 .alist|168)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176))) .alist2|168) .alist3|168)))) (set! .randomize1|154 (lambda (.alist|177 .alist1|177 .alist2|177 .alist3|177) (if (null? .alist|177) (.randomize-combine|154 .alist1|177 .alist2|177 .alist3|177) (.randomize2|154 (let ((.x|178|181 .alist|177)) (begin (.check! (pair? .x|178|181) 1 .x|178|181) (cdr:pair .x|178|181))) (cons (let ((.x|182|185 .alist|177)) (begin (.check! (pair? .x|182|185) 0 .x|182|185) (car:pair .x|182|185))) .alist1|177) .alist2|177 .alist3|177)))) (set! .append-reverse|154 (lambda (.x|186 .y|186) (if (null? .x|186) .y|186 (.append-reverse|154 (let ((.x|187|190 .x|186)) (begin (.check! (pair? .x|187|190) 1 .x|187|190) (cdr:pair .x|187|190))) (cons (let ((.x|191|194 .x|186)) (begin (.check! (pair? .x|191|194) 0 .x|191|194) (car:pair .x|191|194))) .y|186))))) (set! .contents|154 (lambda (.t|195 .alist|195) (if (.buckets-empty?|3 .t|195) .alist|195 (.contents|154 (.buckets-left|3 .t|195) (.contents|154 (.buckets-right|3 .t|195) (.append-reverse|154 (.buckets-alist|3 .t|195) .alist|195)))))) (.randomize1|154 (.contents|154 .t|150 '()) '() '() '()))))))) (set! .remq1|7 (lambda (.x|196 .y|196) (if (eq? .x|196 (let ((.x|198|201 .y|196)) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) (let ((.x|202|205 .y|196)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))) (cons (let ((.x|207|210 .y|196)) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210))) (.remq1|7 .x|196 (let ((.x|211|214 .y|196)) (begin (.check! (pair? .x|211|214) 1 .x|211|214) (cdr:pair .x|211|214)))))))) (set! .substitute1|7 (lambda (.x|215 .y|215 .z|215) (if (eq? .y|215 (let ((.x|217|220 .z|215)) (begin (.check! (pair? .x|217|220) 0 .x|217|220) (car:pair .x|217|220)))) (cons .x|215 (let ((.x|221|224 .z|215)) (begin (.check! (pair? .x|221|224) 1 .x|221|224) (cdr:pair .x|221|224)))) (cons (let ((.x|226|229 .z|215)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229))) (.substitute1|7 .x|215 .y|215 (let ((.x|230|233 .z|215)) (begin (.check! (pair? .x|230|233) 1 .x|230|233) (cdr:pair .x|230|233)))))))) (set! .make-ht|7 (lambda (.count|234 .hashfun|234 .searcher|234 .buckets|234) (let* ((.t|235|240|245 .buckets|234) (.t|235|239|248 .searcher|234) (.t|235|238|251 .hashfun|234) (.t|235|237|254 .count|234) (.t|235|236|257 .doc|3) (.v|235|242|260 (make-vector 5 .t|235|240|245))) (let () (begin (let ((.v|264|267 .v|235|242|260) (.i|264|267 3) (.x|264|267 .t|235|239|248)) (begin (.check! (fixnum? .i|264|267) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (vector? .v|264|267) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (<:fix:fix .i|264|267 (vector-length:vec .v|264|267)) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (>=:fix:fix .i|264|267 0) 41 .v|264|267 .i|264|267 .x|264|267) (vector-set!:trusted .v|264|267 .i|264|267 .x|264|267))) (let ((.v|268|271 .v|235|242|260) (.i|268|271 2) (.x|268|271 .t|235|238|251)) (begin (.check! (fixnum? .i|268|271) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (vector? .v|268|271) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (<:fix:fix .i|268|271 (vector-length:vec .v|268|271)) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (>=:fix:fix .i|268|271 0) 41 .v|268|271 .i|268|271 .x|268|271) (vector-set!:trusted .v|268|271 .i|268|271 .x|268|271))) (let ((.v|272|275 .v|235|242|260) (.i|272|275 1) (.x|272|275 .t|235|237|254)) (begin (.check! (fixnum? .i|272|275) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (vector? .v|272|275) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (<:fix:fix .i|272|275 (vector-length:vec .v|272|275)) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (>=:fix:fix .i|272|275 0) 41 .v|272|275 .i|272|275 .x|272|275) (vector-set!:trusted .v|272|275 .i|272|275 .x|272|275))) (let ((.v|276|279 .v|235|242|260) (.i|276|279 0) (.x|276|279 .t|235|236|257)) (begin (.check! (fixnum? .i|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (vector? .v|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (<:fix:fix .i|276|279 (vector-length:vec .v|276|279)) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (>=:fix:fix .i|276|279 0) 41 .v|276|279 .i|276|279 .x|276|279) (vector-set!:trusted .v|276|279 .i|276|279 .x|276|279))) .v|235|242|260))))) (set! make-hashtree (lambda .args|280 (let* ((.hashfun|283 (if (null? .args|280) object-hash (let ((.x|308|311 .args|280)) (begin (.check! (pair? .x|308|311) 0 .x|308|311) (car:pair .x|308|311))))) (.searcher|286 (if (let ((.temp|290|293 (null? .args|280))) (if .temp|290|293 .temp|290|293 (null? (let ((.x|295|298 .args|280)) (begin (.check! (pair? .x|295|298) 1 .x|295|298) (cdr:pair .x|295|298)))))) assv (let ((.x|300|303 (let ((.x|304|307 .args|280)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))))) (begin (.check! (pair? .x|300|303) 0 .x|300|303) (car:pair .x|300|303)))))) (let () (.make-ht|7 0 .hashfun|283 .searcher|286 (.make-empty-buckets|3)))))) (set! hashtree-contains? (lambda (.ht|312 .key|312) (.contains?|7 .ht|312 .key|312))) (set! hashtree-fetch (lambda (.ht|313 .key|313 .flag|313) (.fetch|7 .ht|313 .key|313 .flag|313))) (set! hashtree-get (lambda (.ht|314 .key|314) (.fetch|7 .ht|314 .key|314 #f))) (set! hashtree-put (lambda (.ht|315 .key|315 .val|315) (.put|7 .ht|315 .key|315 .val|315))) (set! hashtree-remove (lambda (.ht|316 .key|316) (.remove|7 .ht|316 .key|316))) (set! hashtree-size (lambda (.ht|317) (.size|7 .ht|317))) (set! hashtree-for-each (lambda (.ht|318 .proc|318) (.ht-for-each|7 .ht|318 .proc|318))) (set! hashtree-map (lambda (.ht|319 .proc|319) (.ht-map|7 .ht|319 .proc|319))) #f)))))
+(let () (begin (set! make-twobit-flag (undefined)) 'make-twobit-flag))
+(let () (begin (set! display-twobit-flag (undefined)) 'display-twobit-flag))
+(let () (begin (set! make-twobit-flag (lambda (.name|1) (let ((.display-flag|4 (unspecified)) (.twobit-warning|4 (unspecified))) (begin (set! .display-flag|4 (lambda (.state|5) (begin (display (if .state|5 " + " " - ")) (display .name|1) (display " is ") (display (if .state|5 "on" "off")) (newline)))) (set! .twobit-warning|4 (lambda () (begin (display "Error: incorrect arguments to ") (write .name|1) (newline) (reset)))) (let ((.state|7 #t)) (lambda .args|8 (if (null? .args|8) .state|7 (if (if (null? (let ((.x|12|15 .args|8)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15)))) (boolean? (let ((.x|17|20 .args|8)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20)))) #f) (begin (set! .state|7 (let ((.x|21|24 .args|8)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) .state|7) (if (if (null? (let ((.x|27|30 .args|8)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (eq? (let ((.x|32|35 .args|8)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) 'display) #f) (.display-flag|4 .state|7) (.twobit-warning|4)))))))))) 'make-twobit-flag))
+(let () (begin (set! display-twobit-flag (lambda (.flag|1) (let ((.display-twobit-flag|2 0)) (begin (set! .display-twobit-flag|2 (lambda (.flag|3) (.flag|3 'display))) (.display-twobit-flag|2 .flag|1))))) 'display-twobit-flag))
+(let () (begin (set! issue-warnings (make-twobit-flag 'issue-warnings)) 'issue-warnings))
+(let () (begin (set! include-source-code (make-twobit-flag 'include-source-code)) 'include-source-code))
+(let () (begin (set! include-variable-names (make-twobit-flag 'include-variable-names)) 'include-variable-names))
+(let () (begin (set! include-procedure-names (make-twobit-flag 'include-procedure-names)) 'include-procedure-names))
+(let () (begin (set! avoid-space-leaks (make-twobit-flag 'avoid-space-leaks)) 'avoid-space-leaks))
+(let () (begin (set! integrate-usual-procedures (make-twobit-flag 'integrate-usual-procedures)) 'integrate-usual-procedures))
+(let () (begin (set! control-optimization (make-twobit-flag 'control-optimization)) 'control-optimization))
+(let () (begin (set! parallel-assignment-optimization (make-twobit-flag 'parallel-assignment-optimization)) 'parallel-assignment-optimization))
+(let () (begin (set! lambda-optimization (make-twobit-flag 'lambda-optimization)) 'lambda-optimization))
+(let () (begin (set! benchmark-mode (make-twobit-flag 'benchmark-mode)) 'benchmark-mode))
+(let () (begin (set! benchmark-block-mode (make-twobit-flag 'benchmark-block-mode)) 'benchmark-block-mode))
+(let () (begin (set! global-optimization (make-twobit-flag 'global-optimization)) 'global-optimization))
+(let () (begin (set! interprocedural-inlining (make-twobit-flag 'interprocedural-inlining)) 'interprocedural-inlining))
+(let () (begin (set! interprocedural-constant-propagation (make-twobit-flag 'interprocedural-constant-propagation)) 'interprocedural-constant-propagation))
+(let () (begin (set! common-subexpression-elimination (make-twobit-flag 'common-subexpression-elimination)) 'common-subexpression-elimination))
+(let () (begin (set! representation-inference (make-twobit-flag 'representation-inference)) 'representation-inference))
+(let () (begin (set! local-optimization (make-twobit-flag 'local-optimization)) 'local-optimization))
+(let () (begin (set! ignore-space-leaks (lambda .args|1 (if (null? .args|1) (not (avoid-space-leaks)) (avoid-space-leaks (not (let ((.x|2|5 .args|1)) (begin (.check! (pair? .x|2|5) 0 .x|2|5) (car:pair .x|2|5)))))))) 'ignore-space-leaks))
+(let () (begin (set! lambda-optimizations lambda-optimization) 'lambda-optimizations))
+(let () (begin (set! local-optimizations local-optimization) 'local-optimizations))
+(let () (begin (set! set-compiler-flags! (lambda (.how|1) (let ((.set-compiler-flags!|2 0)) (begin (set! .set-compiler-flags!|2 (lambda (.how|3) (let ((.temp|4|7 .how|3)) (if (memv .temp|4|7 '(no-optimization)) (begin (.set-compiler-flags!|2 'standard) (avoid-space-leaks #t) (integrate-usual-procedures #f) (control-optimization #f) (parallel-assignment-optimization #f) (lambda-optimization #f) (benchmark-mode #f) (benchmark-block-mode #f) (global-optimization #f) (interprocedural-inlining #f) (interprocedural-constant-propagation #f) (common-subexpression-elimination #f) (representation-inference #f) (local-optimization #f)) (if (memv .temp|4|7 '(standard)) (begin (issue-warnings #t) (include-source-code #f) (include-procedure-names #t) (include-variable-names #t) (avoid-space-leaks #f) (runtime-safety-checking #t) (integrate-usual-procedures #f) (control-optimization #t) (parallel-assignment-optimization #t) (lambda-optimization #t) (benchmark-mode #f) (benchmark-block-mode #f) (global-optimization #t) (interprocedural-inlining #t) (interprocedural-constant-propagation #t) (common-subexpression-elimination #t) (representation-inference #t) (local-optimization #t)) (if (memv .temp|4|7 '(fast-safe)) (let ((.bbmode|13 (benchmark-block-mode))) (begin (.set-compiler-flags!|2 'standard) (integrate-usual-procedures #t) (benchmark-mode #t) (benchmark-block-mode .bbmode|13))) (if (memv .temp|4|7 '(fast-unsafe)) (begin (.set-compiler-flags!|2 'fast-safe) (runtime-safety-checking #f)) (error "set-compiler-flags!: unknown mode " .how|3)))))))) (.set-compiler-flags!|2 .how|1))))) 'set-compiler-flags!))
+(let () (begin (set! display-twobit-flags (lambda (.which|1) (let ((.display-twobit-flags|2 0)) (begin (set! .display-twobit-flags|2 (lambda (.which|3) (let ((.temp|4|7 .which|3)) (if (memv .temp|4|7 '(debugging)) (begin (display-twobit-flag issue-warnings) (display-twobit-flag include-procedure-names) (display-twobit-flag include-variable-names) (display-twobit-flag include-source-code)) (if (memv .temp|4|7 '(safety)) (display-twobit-flag avoid-space-leaks) (if (memv .temp|4|7 '(optimization)) (begin (display-twobit-flag integrate-usual-procedures) (display-twobit-flag control-optimization) (display-twobit-flag parallel-assignment-optimization) (display-twobit-flag lambda-optimization) (display-twobit-flag benchmark-mode) (display-twobit-flag benchmark-block-mode) (display-twobit-flag global-optimization) (if (global-optimization) (begin (display " ") (display-twobit-flag interprocedural-inlining) (display " ") (display-twobit-flag interprocedural-constant-propagation) (display " ") (display-twobit-flag common-subexpression-elimination) (display " ") (display-twobit-flag representation-inference)) (unspecified)) (display-twobit-flag local-optimization)) #t)))))) (.display-twobit-flags|2 .which|1))))) 'display-twobit-flags))
+(let () ($$trace "pass1.aux"))
+(let () (begin (set! @maxargs-with-rest-arg@ 1000000) '@maxargs-with-rest-arg@))
+(let () (begin (set! prim-entry (lambda (.name|1) (let ((.prim-entry|2 0)) (begin (set! .prim-entry|2 (lambda (.name|3) #f)) (.prim-entry|2 .name|1))))) 'prim-entry))
+(let () (begin (set! prim-arity (lambda (.name|1) (let ((.prim-arity|2 0)) (begin (set! .prim-arity|2 (lambda (.name|3) 0)) (.prim-arity|2 .name|1))))) 'prim-arity))
+(let () (begin (set! prim-opcodename (lambda (.name|1) (let ((.prim-opcodename|2 0)) (begin (set! .prim-opcodename|2 (lambda (.name|3) .name|3)) (.prim-opcodename|2 .name|1))))) 'prim-opcodename))
+(let () (begin (set! m-warn (lambda (.msg|1 . .more|1) (if (issue-warnings) (begin (display "WARNING from macro expander:") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1)))))) (unspecified)))) 'm-warn))
+(let () (begin (set! m-error (lambda (.msg|1 . .more|1) (begin (display "ERROR detected during macro expansion:") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1))))) (m-quit (make-constant #f))))) 'm-error))
+(let () (begin (set! m-bug (lambda (.msg|1 . .more|1) (begin (display "BUG in macro expander: ") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1))))) (m-quit (make-constant #f))))) 'm-bug))
+(let () '(define (make-null-terminated x) (cond ((null? x) '()) ((pair? x) (cons (car x) (make-null-terminated (cdr x)))) (else (list x)))))
+(let () (begin (set! safe-length (lambda (.x|1) (let ((.safe-length|2 0)) (begin (set! .safe-length|2 (lambda (.x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.x|5 .n|5) (if (null? .x|5) .n|5 (if (pair? .x|5) (.loop|4 (let ((.x|8|11 .x|5)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) (+ .n|5 1)) -1)))) (.loop|4 .x|3 0))))) (.safe-length|2 .x|1))))) 'safe-length))
+(let () (begin (set! filter1 (lambda (.p|1 .x|1) (let ((.filter1|2 0)) (begin (set! .filter1|2 (lambda (.p|3 .x|3) (if (null? .x|3) '() (if (.p|3 (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (cons (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.filter1|2 .p|3 (let ((.x|14|17 .x|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (.filter1|2 .p|3 (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (.filter1|2 .p|1 .x|1))))) 'filter1))
+(let () (begin (set! every1? (lambda (.p|1 .x|1) (let ((.every1?|2 0)) (begin (set! .every1?|2 (lambda (.p|3 .x|3) (if (null? .x|3) #t (if (.p|3 (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (.every1?|2 .p|3 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) #f)))) (.every1?|2 .p|1 .x|1))))) 'every1?))
+(let () (begin (set! union2 (lambda (.x|1 .y|1) (let ((.union2|2 0)) (begin (set! .union2|2 (lambda (.x|3 .y|3) (if (null? .x|3) .y|3 (if (member (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .y|3) (.union2|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) .y|3) (.union2|2 (let ((.x|15|18 .x|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) (cons (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) .y|3)))))) (.union2|2 .x|1 .y|1))))) 'union2))
+(let () (begin (set! copy-alist (lambda (.alist|1) (let ((.copy-alist|2 0)) (begin (set! .copy-alist|2 (lambda (.alist|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.x|24 (let ((.x|33|36 .y1|4|5|16)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (cons (let ((.x|25|28 .x|24)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|29|32 .x|24)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) .results|4|8|16)))))) (.loop|9|12|15 .alist|3 '())))))) (.copy-alist|2 .alist|1))))) 'copy-alist))
+(let () '(define remq! (letrec ((loop (lambda (x y prev) (cond ((null? y) #t) ((eq? x (car y)) (set-cdr! prev (cdr y)) (loop x (cdr prev) prev)) (else (loop x (cdr y) y)))))) (lambda (x y) (cond ((null? y) '()) ((eq? x (car y)) (remq! x (cdr y))) (else (loop x (cdr y) y) y))))))
+(let () (begin (set! integrable? (lambda (.name|1) (let ((.integrable?|2 0)) (begin (set! .integrable?|2 (lambda (.name|3) (if (integrate-usual-procedures) (prim-entry .name|3) #f))) (.integrable?|2 .name|1))))) 'integrable?))
+(let () (begin (set! make-readable (lambda (.exp|1 . .rest|1) (let ((.fancy?|4 (if (not (null? .rest|1)) (let ((.x|963|966 .rest|1)) (begin (.check! (pair? .x|963|966) 0 .x|963|966) (car:pair .x|963|966))) #f))) (let ((.make-readable-let*|5 (unspecified)) (.make-readable-let|5 (unspecified)) (.make-readable-call|5 (unspecified)) (.make-readable-quote|5 (unspecified)) (.make-readable|5 (unspecified))) (begin (set! .make-readable-let*|5 (lambda (.exp|6 .vars|6 .inits|6 .defs|6) (if (if (null? .defs|6) (if (call? .exp|6) (if (lambda? (call.proc .exp|6)) (= 1 (length (lambda.args (call.proc .exp|6)))) #f) #f) #f) (let ((.proc|13 (call.proc .exp|6)) (.arg|13 (let ((.x|92|95 (call.args .exp|6))) (begin (.check! (pair? .x|92|95) 0 .x|92|95) (car:pair .x|92|95))))) (if (if (call? .arg|13) (if (lambda? (call.proc .arg|13)) (if (= 1 (length (lambda.args (call.proc .arg|13)))) (null? (lambda.defs (call.proc .arg|13))) #f) #f) #f) (.make-readable-let*|5 (make-call .proc|13 (cons (lambda.body (call.proc .arg|13)) '())) (cons (let ((.x|19|22 (lambda.args (call.proc .arg|13)))) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) .vars|6) (cons (.make-readable|5 (let ((.x|23|26 (call.args .arg|13))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) .inits|6) '()) (.make-readable-let*|5 (lambda.body .proc|13) (cons (let ((.x|27|30 (lambda.args .proc|13))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))) .vars|6) (cons (.make-readable|5 (let ((.x|31|34 (call.args .exp|6))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34)))) .inits|6) (let () (let ((.loop|40|43|46 (unspecified))) (begin (set! .loop|40|43|46 (lambda (.y1|35|36|47 .results|35|39|47) (if (null? .y1|35|36|47) (reverse .results|35|39|47) (begin #t (.loop|40|43|46 (let ((.x|51|54 .y1|35|36|47)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (cons (let ((.def|55 (let ((.x|88|91 .y1|35|36|47)) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91))))) (.cons 'define (.cons (def.lhs .def|55) (.cons (.make-readable|5 (def.rhs .def|55)) '())))) .results|35|39|47)))))) (.loop|40|43|46 (reverse (lambda.defs .proc|13)) '()))))))) (if (let ((.temp|97|100 (not (null? .vars|6)))) (if .temp|97|100 .temp|97|100 (not (null? .defs|6)))) (.cons 'let* (.cons (let () (let ((.loop|147|151|154 (unspecified))) (begin (set! .loop|147|151|154 (lambda (.y1|141|143|155 .y1|141|142|155 .results|141|146|155) (if (let ((.temp|157|160 (null? .y1|141|143|155))) (if .temp|157|160 .temp|157|160 (null? .y1|141|142|155))) (reverse .results|141|146|155) (begin #t (.loop|147|151|154 (let ((.x|163|166 .y1|141|143|155)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))) (let ((.x|167|170 .y1|141|142|155)) (begin (.check! (pair? .x|167|170) 1 .x|167|170) (cdr:pair .x|167|170))) (cons (let* ((.t1|171|174 (let ((.x|186|189 .y1|141|143|155)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) (.t2|171|177 (cons (let ((.x|182|185 .y1|141|142|155)) (begin (.check! (pair? .x|182|185) 0 .x|182|185) (car:pair .x|182|185))) '()))) (let () (cons .t1|171|174 .t2|171|177))) .results|141|146|155)))))) (.loop|147|151|154 (reverse .vars|6) (reverse .inits|6) '())))) (append .defs|6 (.cons (.make-readable|5 .exp|6) '())))) (if (if (call? .exp|6) (lambda? (call.proc .exp|6)) #f) (let ((.proc|195 (call.proc .exp|6))) (.cons 'let (.cons (let () (let ((.loop|241|245|248 (unspecified))) (begin (set! .loop|241|245|248 (lambda (.y1|235|237|249 .y1|235|236|249 .results|235|240|249) (if (let ((.temp|251|254 (null? .y1|235|237|249))) (if .temp|251|254 .temp|251|254 (null? .y1|235|236|249))) (reverse .results|235|240|249) (begin #t (.loop|241|245|248 (let ((.x|257|260 .y1|235|237|249)) (begin (.check! (pair? .x|257|260) 1 .x|257|260) (cdr:pair .x|257|260))) (let ((.x|261|264 .y1|235|236|249)) (begin (.check! (pair? .x|261|264) 1 .x|261|264) (cdr:pair .x|261|264))) (cons (let* ((.t1|265|268 (let ((.x|280|283 .y1|235|237|249)) (begin (.check! (pair? .x|280|283) 0 .x|280|283) (car:pair .x|280|283)))) (.t2|265|271 (cons (let ((.x|276|279 .y1|235|236|249)) (begin (.check! (pair? .x|276|279) 0 .x|276|279) (car:pair .x|276|279))) '()))) (let () (cons .t1|265|268 .t2|265|271))) .results|235|240|249)))))) (.loop|241|245|248 (lambda.args .proc|195) (let () (let ((.loop|289|292|295 (unspecified))) (begin (set! .loop|289|292|295 (lambda (.y1|284|285|296 .results|284|288|296) (if (null? .y1|284|285|296) (reverse .results|284|288|296) (begin #t (.loop|289|292|295 (let ((.x|300|303 .y1|284|285|296)) (begin (.check! (pair? .x|300|303) 1 .x|300|303) (cdr:pair .x|300|303))) (cons (.make-readable|5 (let ((.x|304|307 .y1|284|285|296)) (begin (.check! (pair? .x|304|307) 0 .x|304|307) (car:pair .x|304|307)))) .results|284|288|296)))))) (.loop|289|292|295 (call.args .exp|6) '())))) '())))) (append (let () (let ((.loop|313|316|319 (unspecified))) (begin (set! .loop|313|316|319 (lambda (.y1|308|309|320 .results|308|312|320) (if (null? .y1|308|309|320) (reverse .results|308|312|320) (begin #t (.loop|313|316|319 (let ((.x|324|327 .y1|308|309|320)) (begin (.check! (pair? .x|324|327) 1 .x|324|327) (cdr:pair .x|324|327))) (cons (let ((.def|328 (let ((.x|361|364 .y1|308|309|320)) (begin (.check! (pair? .x|361|364) 0 .x|361|364) (car:pair .x|361|364))))) (.cons 'define (.cons (def.lhs .def|328) (.cons (.make-readable|5 (def.rhs .def|328)) '())))) .results|308|312|320)))))) (.loop|313|316|319 (lambda.defs .proc|195) '())))) (.cons (.make-readable|5 (lambda.body .proc|195)) '()))))) (.make-readable|5 .exp|6)))))) (set! .make-readable-let|5 (lambda (.exp|366) (let* ((.l|369 (call.proc .exp|366)) (.formals|372 (lambda.args .l|369)) (.args|375 (let () (let ((.loop|646|649|652 (unspecified))) (begin (set! .loop|646|649|652 (lambda (.y1|641|642|653 .results|641|645|653) (if (null? .y1|641|642|653) (reverse .results|641|645|653) (begin #t (.loop|646|649|652 (let ((.x|657|660 .y1|641|642|653)) (begin (.check! (pair? .x|657|660) 1 .x|657|660) (cdr:pair .x|657|660))) (cons (.make-readable|5 (let ((.x|661|664 .y1|641|642|653)) (begin (.check! (pair? .x|661|664) 0 .x|661|664) (car:pair .x|661|664)))) .results|641|645|653)))))) (.loop|646|649|652 (call.args .exp|366) '()))))) (.body|378 (.make-readable|5 (lambda.body .l|369)))) (let () (if (if (null? (lambda.defs .l|369)) (if (= (length .args|375) 1) (if (pair? .body|378) (let ((.temp|386|389 (if (eq? (let ((.x|396|399 .body|378)) (begin (.check! (pair? .x|396|399) 0 .x|396|399) (car:pair .x|396|399))) 'let) (= (length (let ((.x|402|405 (let ((.x|406|409 .body|378)) (begin (.check! (pair? .x|406|409) 1 .x|406|409) (cdr:pair .x|406|409))))) (begin (.check! (pair? .x|402|405) 0 .x|402|405) (car:pair .x|402|405)))) 1) #f))) (if .temp|386|389 .temp|386|389 (eq? (let ((.x|391|394 .body|378)) (begin (.check! (pair? .x|391|394) 0 .x|391|394) (car:pair .x|391|394))) 'let*))) #f) #f) #f) (.cons 'let* (.cons (.cons (.cons (let ((.x|470|473 .formals|372)) (begin (.check! (pair? .x|470|473) 0 .x|470|473) (car:pair .x|470|473))) (.cons (let ((.x|474|477 .args|375)) (begin (.check! (pair? .x|474|477) 0 .x|474|477) (car:pair .x|474|477))) '())) (let ((.x|479|482 (let ((.x|483|486 .body|378)) (begin (.check! (pair? .x|483|486) 1 .x|483|486) (cdr:pair .x|483|486))))) (begin (.check! (pair? .x|479|482) 0 .x|479|482) (car:pair .x|479|482)))) (let ((.x|488|491 (let ((.x|492|495 .body|378)) (begin (.check! (pair? .x|492|495) 1 .x|492|495) (cdr:pair .x|492|495))))) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))))) (.cons 'let (.cons (let () (let ((.loop|541|545|548 (unspecified))) (begin (set! .loop|541|545|548 (lambda (.y1|535|537|549 .y1|535|536|549 .results|535|540|549) (if (let ((.temp|551|554 (null? .y1|535|537|549))) (if .temp|551|554 .temp|551|554 (null? .y1|535|536|549))) (reverse .results|535|540|549) (begin #t (.loop|541|545|548 (let ((.x|557|560 .y1|535|537|549)) (begin (.check! (pair? .x|557|560) 1 .x|557|560) (cdr:pair .x|557|560))) (let ((.x|561|564 .y1|535|536|549)) (begin (.check! (pair? .x|561|564) 1 .x|561|564) (cdr:pair .x|561|564))) (cons (let* ((.t1|565|568 (let ((.x|580|583 .y1|535|537|549)) (begin (.check! (pair? .x|580|583) 0 .x|580|583) (car:pair .x|580|583)))) (.t2|565|571 (cons (let ((.x|576|579 .y1|535|536|549)) (begin (.check! (pair? .x|576|579) 0 .x|576|579) (car:pair .x|576|579))) '()))) (let () (cons .t1|565|568 .t2|565|571))) .results|535|540|549)))))) (.loop|541|545|548 (lambda.args .l|369) .args|375 '())))) (append (let () (let ((.loop|589|592|595 (unspecified))) (begin (set! .loop|589|592|595 (lambda (.y1|584|585|596 .results|584|588|596) (if (null? .y1|584|585|596) (reverse .results|584|588|596) (begin #t (.loop|589|592|595 (let ((.x|600|603 .y1|584|585|596)) (begin (.check! (pair? .x|600|603) 1 .x|600|603) (cdr:pair .x|600|603))) (cons (let ((.def|604 (let ((.x|637|640 .y1|584|585|596)) (begin (.check! (pair? .x|637|640) 0 .x|637|640) (car:pair .x|637|640))))) (.cons 'define (.cons (def.lhs .def|604) (.cons (.make-readable|5 (def.rhs .def|604)) '())))) .results|584|588|596)))))) (.loop|589|592|595 (lambda.defs .l|369) '())))) (.cons .body|378 '()))))))))) (set! .make-readable-call|5 (lambda (.exp|665) (let ((.proc|668 (call.proc .exp|665))) (if (if .fancy?|4 (if (lambda? .proc|668) (list? (lambda.args .proc|668)) #f) #f) (.make-readable-let|5 .exp|665) (.cons (.make-readable|5 (call.proc .exp|665)) (let () (let ((.loop|696|699|702 (unspecified))) (begin (set! .loop|696|699|702 (lambda (.y1|691|692|703 .results|691|695|703) (if (null? .y1|691|692|703) (reverse .results|691|695|703) (begin #t (.loop|696|699|702 (let ((.x|707|710 .y1|691|692|703)) (begin (.check! (pair? .x|707|710) 1 .x|707|710) (cdr:pair .x|707|710))) (cons (.make-readable|5 (let ((.x|711|714 .y1|691|692|703)) (begin (.check! (pair? .x|711|714) 0 .x|711|714) (car:pair .x|711|714)))) .results|691|695|703)))))) (.loop|696|699|702 (call.args .exp|665) '()))))))))) (set! .make-readable-quote|5 (lambda (.exp|715) (let ((.x|718 (constant.value .exp|715))) (if (if .fancy?|4 (let ((.temp|721|724 (boolean? .x|718))) (if .temp|721|724 .temp|721|724 (let ((.temp|725|728 (number? .x|718))) (if .temp|725|728 .temp|725|728 (let ((.temp|729|732 (char? .x|718))) (if .temp|729|732 .temp|729|732 (string? .x|718))))))) #f) .x|718 .exp|715)))) (set! .make-readable|5 (lambda (.exp|734) (let ((.temp|735|738 (let ((.x|957|960 .exp|734)) (begin (.check! (pair? .x|957|960) 0 .x|957|960) (car:pair .x|957|960))))) (if (memv .temp|735|738 '(quote)) (.make-readable-quote|5 .exp|734) (if (memv .temp|735|738 '(lambda)) (.cons 'lambda (.cons (lambda.args .exp|734) (append (let () (let ((.loop|785|788|791 (unspecified))) (begin (set! .loop|785|788|791 (lambda (.y1|780|781|792 .results|780|784|792) (if (null? .y1|780|781|792) (reverse .results|780|784|792) (begin #t (.loop|785|788|791 (let ((.x|796|799 .y1|780|781|792)) (begin (.check! (pair? .x|796|799) 1 .x|796|799) (cdr:pair .x|796|799))) (cons (let ((.def|800 (let ((.x|833|836 .y1|780|781|792)) (begin (.check! (pair? .x|833|836) 0 .x|833|836) (car:pair .x|833|836))))) (.cons 'define (.cons (def.lhs .def|800) (.cons (.make-readable|5 (def.rhs .def|800)) '())))) .results|780|784|792)))))) (.loop|785|788|791 (lambda.defs .exp|734) '())))) (.cons (.make-readable|5 (lambda.body .exp|734)) '())))) (if (memv .temp|735|738 '(set!)) (.cons 'set! (.cons (assignment.lhs .exp|734) (.cons (.make-readable|5 (assignment.rhs .exp|734)) '()))) (if (memv .temp|735|738 '(if)) (.cons 'if (.cons (.make-readable|5 (if.test .exp|734)) (.cons (.make-readable|5 (if.then .exp|734)) (.cons (.make-readable|5 (if.else .exp|734)) '())))) (if (memv .temp|735|738 '(begin)) (if (variable? .exp|734) (variable.name .exp|734) (.cons 'begin (let () (let ((.loop|937|940|943 (unspecified))) (begin (set! .loop|937|940|943 (lambda (.y1|932|933|944 .results|932|936|944) (if (null? .y1|932|933|944) (reverse .results|932|936|944) (begin #t (.loop|937|940|943 (let ((.x|948|951 .y1|932|933|944)) (begin (.check! (pair? .x|948|951) 1 .x|948|951) (cdr:pair .x|948|951))) (cons (.make-readable|5 (let ((.x|952|955 .y1|932|933|944)) (begin (.check! (pair? .x|952|955) 0 .x|952|955) (car:pair .x|952|955)))) .results|932|936|944)))))) (.loop|937|940|943 (begin.exprs .exp|734) '())))))) (.make-readable-call|5 .exp|734))))))))) (.make-readable|5 .exp|1)))))) 'make-readable))
+(let () (begin (set! make-unreadable (lambda (.exp|1) (let ((.make-unreadable|2 0)) (begin (set! .make-unreadable|2 (lambda (.exp|3) (if (symbol? .exp|3) (let* ((.t1|5|8 'begin) (.t2|5|11 (cons .exp|3 '()))) (let () (cons .t1|5|8 .t2|5|11))) (if (pair? .exp|3) (let ((.temp|17|20 (let ((.x|291|294 .exp|3)) (begin (.check! (pair? .x|291|294) 0 .x|291|294) (car:pair .x|291|294))))) (if (memv .temp|17|20 '(quote)) .exp|3 (if (memv .temp|17|20 '(lambda)) (let* ((.t1|23|26 'lambda) (.t2|23|29 (let* ((.t1|33|36 (let ((.x|105|108 (let ((.x|109|112 .exp|3)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))))) (begin (.check! (pair? .x|105|108) 0 .x|105|108) (car:pair .x|105|108)))) (.t2|33|39 (let* ((.t1|43|46 '(begin)) (.t2|43|49 (let* ((.t1|53|56 (let* ((.t1|73|76 '()) (.t2|73|79 (let* ((.t1|83|86 '()) (.t2|83|89 (let* ((.t1|93|96 '()) (.t2|93|99 (cons '() '()))) (let () (cons .t1|93|96 .t2|93|99))))) (let () (cons .t1|83|86 .t2|83|89))))) (let () (cons .t1|73|76 .t2|73|79)))) (.t2|53|59 (cons (.make-unreadable|2 (cons 'begin (let ((.x|65|68 (let ((.x|69|72 .exp|3)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68))))) '()))) (let () (cons .t1|53|56 .t2|53|59))))) (let () (cons .t1|43|46 .t2|43|49))))) (let () (cons .t1|33|36 .t2|33|39))))) (let () (cons .t1|23|26 .t2|23|29))) (if (memv .temp|17|20 '(set!)) (let* ((.t1|114|117 'set!) (.t2|114|120 (let* ((.t1|124|127 (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152)))) (.t2|124|130 (cons (.make-unreadable|2 (let ((.x|136|139 (let ((.x|140|143 (let ((.x|144|147 .exp|3)) (begin (.check! (pair? .x|144|147) 1 .x|144|147) (cdr:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))))) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139)))) '()))) (let () (cons .t1|124|127 .t2|124|130))))) (let () (cons .t1|114|117 .t2|114|120))) (if (memv .temp|17|20 '(if)) (let* ((.t1|158|161 'if) (.t2|158|164 (let* ((.t1|168|171 (.make-unreadable|2 (let ((.x|220|223 (let ((.x|224|227 .exp|3)) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227))))) (begin (.check! (pair? .x|220|223) 0 .x|220|223) (car:pair .x|220|223))))) (.t2|168|174 (let* ((.t1|178|181 (.make-unreadable|2 (let ((.x|207|210 (let ((.x|211|214 (let ((.x|215|218 .exp|3)) (begin (.check! (pair? .x|215|218) 1 .x|215|218) (cdr:pair .x|215|218))))) (begin (.check! (pair? .x|211|214) 1 .x|211|214) (cdr:pair .x|211|214))))) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210))))) (.t2|178|184 (cons (if (= (length .exp|3) 3) '(unspecified) (.make-unreadable|2 (let ((.x|190|193 (let ((.x|194|197 (let ((.x|198|201 (let ((.x|202|205 .exp|3)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))))) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))))) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))))) '()))) (let () (cons .t1|178|181 .t2|178|184))))) (let () (cons .t1|168|171 .t2|168|174))))) (let () (cons .t1|158|161 .t2|158|164))) (if (memv .temp|17|20 '(begin)) (if (= (length .exp|3) 2) (.make-unreadable|2 (let ((.x|230|233 (let ((.x|234|237 .exp|3)) (begin (.check! (pair? .x|234|237) 1 .x|234|237) (cdr:pair .x|234|237))))) (begin (.check! (pair? .x|230|233) 0 .x|230|233) (car:pair .x|230|233)))) (cons 'begin (let () (let ((.loop|243|246|249 (unspecified))) (begin (set! .loop|243|246|249 (lambda (.y1|238|239|250 .results|238|242|250) (if (null? .y1|238|239|250) (reverse .results|238|242|250) (begin #t (.loop|243|246|249 (let ((.x|254|257 .y1|238|239|250)) (begin (.check! (pair? .x|254|257) 1 .x|254|257) (cdr:pair .x|254|257))) (cons (.make-unreadable|2 (let ((.x|258|261 .y1|238|239|250)) (begin (.check! (pair? .x|258|261) 0 .x|258|261) (car:pair .x|258|261)))) .results|238|242|250)))))) (.loop|243|246|249 (let ((.x|262|265 .exp|3)) (begin (.check! (pair? .x|262|265) 1 .x|262|265) (cdr:pair .x|262|265))) '())))))) (let () (let ((.loop|272|275|278 (unspecified))) (begin (set! .loop|272|275|278 (lambda (.y1|267|268|279 .results|267|271|279) (if (null? .y1|267|268|279) (reverse .results|267|271|279) (begin #t (.loop|272|275|278 (let ((.x|283|286 .y1|267|268|279)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))) (cons (.make-unreadable|2 (let ((.x|287|290 .y1|267|268|279)) (begin (.check! (pair? .x|287|290) 0 .x|287|290) (car:pair .x|287|290)))) .results|267|271|279)))))) (.loop|272|275|278 .exp|3 '())))))))))) (let* ((.t1|296|299 'quote) (.t2|296|302 (cons .exp|3 '()))) (let () (cons .t1|296|299 .t2|296|302))))))) (.make-unreadable|2 .exp|1))))) 'make-unreadable))
+(let () ($$trace "pass2.aux"))
+(let () (begin (set! constant? (lambda (.exp|1) (let ((.constant?|2 0)) (begin (set! .constant?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'quote))) (.constant?|2 .exp|1))))) 'constant?))
+(let () (begin (set! variable? (lambda (.exp|1) (let ((.variable?|2 0)) (begin (set! .variable?|2 (lambda (.exp|3) (if (eq? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) 'begin) (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) #f))) (.variable?|2 .exp|1))))) 'variable?))
+(let () (begin (set! lambda? (lambda (.exp|1) (let ((.lambda?|2 0)) (begin (set! .lambda?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'lambda))) (.lambda?|2 .exp|1))))) 'lambda?))
+(let () (begin (set! call? (lambda (.exp|1) (let ((.call?|2 0)) (begin (set! .call?|2 (lambda (.exp|3) (pair? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))))) (.call?|2 .exp|1))))) 'call?))
+(let () (begin (set! assignment? (lambda (.exp|1) (let ((.assignment?|2 0)) (begin (set! .assignment?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'set!))) (.assignment?|2 .exp|1))))) 'assignment?))
+(let () (begin (set! conditional? (lambda (.exp|1) (let ((.conditional?|2 0)) (begin (set! .conditional?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'if))) (.conditional?|2 .exp|1))))) 'conditional?))
+(let () (begin (set! begin? (lambda (.exp|1) (let ((.begin?|2 0)) (begin (set! .begin?|2 (lambda (.exp|3) (if (eq? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) 'begin) (not (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))))) #f))) (.begin?|2 .exp|1))))) 'begin?))
+(let () (begin (set! make-constant (lambda (.value|1) (let ((.make-constant|2 0)) (begin (set! .make-constant|2 (lambda (.value|3) (let* ((.t1|4|7 'quote) (.t2|4|10 (cons .value|3 '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constant|2 .value|1))))) 'make-constant))
+(let () (begin (set! make-variable (lambda (.name|1) (let ((.make-variable|2 0)) (begin (set! .make-variable|2 (lambda (.name|3) (let* ((.t1|4|7 'begin) (.t2|4|10 (cons .name|3 '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-variable|2 .name|1))))) 'make-variable))
+(let () (begin (set! make-lambda (lambda (.formals|1 .defs|1 .r|1 .f|1 .g|1 .decls|1 .doc|1 .body|1) (let ((.make-lambda|2 0)) (begin (set! .make-lambda|2 (lambda (.formals|3 .defs|3 .r|3 .f|3 .g|3 .decls|3 .doc|3 .body|3) (let* ((.t1|4|7 'lambda) (.t2|4|10 (let* ((.t1|14|17 .formals|3) (.t2|14|20 (let* ((.t1|24|27 (cons 'begin .defs|3)) (.t2|24|30 (let* ((.t1|34|37 (let* ((.t1|45|48 'quote) (.t2|45|51 (cons (let* ((.t1|56|59 .r|3) (.t2|56|62 (let* ((.t1|66|69 .f|3) (.t2|66|72 (let* ((.t1|76|79 .g|3) (.t2|76|82 (let* ((.t1|86|89 .decls|3) (.t2|86|92 (cons .doc|3 '()))) (let () (cons .t1|86|89 .t2|86|92))))) (let () (cons .t1|76|79 .t2|76|82))))) (let () (cons .t1|66|69 .t2|66|72))))) (let () (cons .t1|56|59 .t2|56|62))) '()))) (let () (cons .t1|45|48 .t2|45|51)))) (.t2|34|40 (cons .body|3 '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-lambda|2 .formals|1 .defs|1 .r|1 .f|1 .g|1 .decls|1 .doc|1 .body|1))))) 'make-lambda))
+(let () (begin (set! make-call (lambda (.proc|1 .args|1) (let ((.make-call|2 0)) (begin (set! .make-call|2 (lambda (.proc|3 .args|3) (cons .proc|3 (append .args|3 '())))) (.make-call|2 .proc|1 .args|1))))) 'make-call))
+(let () (begin (set! make-assignment (lambda (.lhs|1 .rhs|1) (let ((.make-assignment|2 0)) (begin (set! .make-assignment|2 (lambda (.lhs|3 .rhs|3) (let* ((.t1|4|7 'set!) (.t2|4|10 (let* ((.t1|14|17 .lhs|3) (.t2|14|20 (cons .rhs|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-assignment|2 .lhs|1 .rhs|1))))) 'make-assignment))
+(let () (begin (set! make-conditional (lambda (.e0|1 .e1|1 .e2|1) (let ((.make-conditional|2 0)) (begin (set! .make-conditional|2 (lambda (.e0|3 .e1|3 .e2|3) (let* ((.t1|4|7 'if) (.t2|4|10 (let* ((.t1|14|17 .e0|3) (.t2|14|20 (let* ((.t1|24|27 .e1|3) (.t2|24|30 (cons .e2|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-conditional|2 .e0|1 .e1|1 .e2|1))))) 'make-conditional))
+(let () (begin (set! make-begin (lambda (.exprs|1) (let ((.make-begin|2 0)) (begin (set! .make-begin|2 (lambda (.exprs|3) (if (null? (let ((.x|4|7 .exprs|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (let ((.x|8|11 .exprs|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (cons 'begin (append .exprs|3 '()))))) (.make-begin|2 .exprs|1))))) 'make-begin))
+(let () (begin (set! make-definition (lambda (.lhs|1 .rhs|1) (let ((.make-definition|2 0)) (begin (set! .make-definition|2 (lambda (.lhs|3 .rhs|3) (let* ((.t1|4|7 'define) (.t2|4|10 (let* ((.t1|14|17 .lhs|3) (.t2|14|20 (cons .rhs|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-definition|2 .lhs|1 .rhs|1))))) 'make-definition))
+(let () (begin (set! constant.value (lambda (.exp|1) (let ((.constant.value|2 0)) (begin (set! .constant.value|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constant.value|2 .exp|1))))) 'constant.value))
+(let () (begin (set! variable.name (lambda (.exp|1) (let ((.variable.name|2 0)) (begin (set! .variable.name|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.variable.name|2 .exp|1))))) 'variable.name))
+(let () (begin (set! lambda.args (lambda (.exp|1) (let ((.lambda.args|2 0)) (begin (set! .lambda.args|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.args|2 .exp|1))))) 'lambda.args))
+(let () (begin (set! lambda.defs (lambda (.exp|1) (let ((.lambda.defs|2 0)) (begin (set! .lambda.defs|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.lambda.defs|2 .exp|1))))) 'lambda.defs))
+(let () (begin (set! lambda.r (lambda (.exp|1) (let ((.lambda.r|2 0)) (begin (set! .lambda.r|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.r|2 .exp|1))))) 'lambda.r))
+(let () (begin (set! lambda.f (lambda (.exp|1) (let ((.lambda.f|2 0)) (begin (set! .lambda.f|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|23|26 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 .exp|3)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.f|2 .exp|1))))) 'lambda.f))
+(let () (begin (set! lambda.g (lambda (.exp|1) (let ((.lambda.g|2 0)) (begin (set! .lambda.g|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .exp|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.g|2 .exp|1))))) 'lambda.g))
+(let () (begin (set! lambda.decls (lambda (.exp|1) (let ((.lambda.decls|2 0)) (begin (set! .lambda.decls|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 .exp|3)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.decls|2 .exp|1))))) 'lambda.decls))
+(let () (begin (set! lambda.doc (lambda (.exp|1) (let ((.lambda.doc|2 0)) (begin (set! .lambda.doc|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 (let ((.x|26|29 (let ((.x|30|33 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 (let ((.x|47|50 .exp|3)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.doc|2 .exp|1))))) 'lambda.doc))
+(let () (begin (set! lambda.body (lambda (.exp|1) (let ((.lambda.body|2 0)) (begin (set! .lambda.body|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .exp|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.body|2 .exp|1))))) 'lambda.body))
+(let () (begin (set! call.proc (lambda (.exp|1) (let ((.call.proc|2 0)) (begin (set! .call.proc|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.call.proc|2 .exp|1))))) 'call.proc))
+(let () (begin (set! call.args (lambda (.exp|1) (let ((.call.args|2 0)) (begin (set! .call.args|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.call.args|2 .exp|1))))) 'call.args))
+(let () (begin (set! assignment.lhs (lambda (.exp|1) (let ((.assignment.lhs|2 0)) (begin (set! .assignment.lhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignment.lhs|2 .exp|1))))) 'assignment.lhs))
+(let () (begin (set! assignment.rhs (lambda (.exp|1) (let ((.assignment.rhs|2 0)) (begin (set! .assignment.rhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignment.rhs|2 .exp|1))))) 'assignment.rhs))
+(let () (begin (set! if.test (lambda (.exp|1) (let ((.if.test|2 0)) (begin (set! .if.test|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.test|2 .exp|1))))) 'if.test))
+(let () (begin (set! if.then (lambda (.exp|1) (let ((.if.then|2 0)) (begin (set! .if.then|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.then|2 .exp|1))))) 'if.then))
+(let () (begin (set! if.else (lambda (.exp|1) (let ((.if.else|2 0)) (begin (set! .if.else|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.else|2 .exp|1))))) 'if.else))
+(let () (begin (set! begin.exprs (lambda (.exp|1) (let ((.begin.exprs|2 0)) (begin (set! .begin.exprs|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.begin.exprs|2 .exp|1))))) 'begin.exprs))
+(let () (begin (set! def.lhs (lambda (.exp|1) (let ((.def.lhs|2 0)) (begin (set! .def.lhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.def.lhs|2 .exp|1))))) 'def.lhs))
+(let () (begin (set! def.rhs (lambda (.exp|1) (let ((.def.rhs|2 0)) (begin (set! .def.rhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.def.rhs|2 .exp|1))))) 'def.rhs))
+(let () (begin (set! variable-set! (lambda (.exp|1 .newexp|1) (let ((.variable-set!|2 0)) (begin (set! .variable-set!|2 (lambda (.exp|3 .newexp|3) (begin (set-car! .exp|3 (let ((.x|4|7 .newexp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (set-cdr! .exp|3 (append (let ((.x|8|11 .newexp|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) '()))))) (.variable-set!|2 .exp|1 .newexp|1))))) 'variable-set!))
+(let () (begin (set! lambda.args-set! (lambda (.exp|1 .args|1) (let ((.lambda.args-set!|2 0)) (begin (set! .lambda.args-set!|2 (lambda (.exp|3 .args|3) (set-car! (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .args|3))) (.lambda.args-set!|2 .exp|1 .args|1))))) 'lambda.args-set!))
+(let () (begin (set! lambda.defs-set! (lambda (.exp|1 .defs|1) (let ((.lambda.defs-set!|2 0)) (begin (set! .lambda.defs-set!|2 (lambda (.exp|3 .defs|3) (set-cdr! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) .defs|3))) (.lambda.defs-set!|2 .exp|1 .defs|1))))) 'lambda.defs-set!))
+(let () (begin (set! lambda.r-set! (lambda (.exp|1 .r|1) (let ((.lambda.r-set!|2 0)) (begin (set! .lambda.r-set!|2 (lambda (.exp|3 .r|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .exp|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) .r|3))) (.lambda.r-set!|2 .exp|1 .r|1))))) 'lambda.r-set!))
+(let () (begin (set! lambda.f-set! (lambda (.exp|1 .f|1) (let ((.lambda.f-set!|2 0)) (begin (set! .lambda.f-set!|2 (lambda (.exp|3 .f|3) (set-car! (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .f|3))) (.lambda.f-set!|2 .exp|1 .f|1))))) 'lambda.f-set!))
+(let () (begin (set! lambda.g-set! (lambda (.exp|1 .g|1) (let ((.lambda.g-set!|2 0)) (begin (set! .lambda.g-set!|2 (lambda (.exp|3 .g|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|23|26 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 .exp|3)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .g|3))) (.lambda.g-set!|2 .exp|1 .g|1))))) 'lambda.g-set!))
+(let () (begin (set! lambda.decls-set! (lambda (.exp|1 .decls|1) (let ((.lambda.decls-set!|2 0)) (begin (set! .lambda.decls-set!|2 (lambda (.exp|3 .decls|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .exp|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .decls|3))) (.lambda.decls-set!|2 .exp|1 .decls|1))))) 'lambda.decls-set!))
+(let () (begin (set! lambda.doc-set! (lambda (.exp|1 .doc|1) (let ((.lambda.doc-set!|2 0)) (begin (set! .lambda.doc-set!|2 (lambda (.exp|3 .doc|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 .exp|3)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .doc|3))) (.lambda.doc-set!|2 .exp|1 .doc|1))))) 'lambda.doc-set!))
+(let () (begin (set! lambda.body-set! (lambda (.exp|1 .exp0|1) (let ((.lambda.body-set!|2 0)) (begin (set! .lambda.body-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.lambda.body-set!|2 .exp|1 .exp0|1))))) 'lambda.body-set!))
+(let () (begin (set! call.proc-set! (lambda (.exp|1 .exp0|1) (let ((.call.proc-set!|2 0)) (begin (set! .call.proc-set!|2 (lambda (.exp|3 .exp0|3) (set-car! .exp|3 .exp0|3))) (.call.proc-set!|2 .exp|1 .exp0|1))))) 'call.proc-set!))
+(let () (begin (set! call.args-set! (lambda (.exp|1 .exprs|1) (let ((.call.args-set!|2 0)) (begin (set! .call.args-set!|2 (lambda (.exp|3 .exprs|3) (set-cdr! .exp|3 .exprs|3))) (.call.args-set!|2 .exp|1 .exprs|1))))) 'call.args-set!))
+(let () (begin (set! assignment.rhs-set! (lambda (.exp|1 .exp0|1) (let ((.assignment.rhs-set!|2 0)) (begin (set! .assignment.rhs-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.assignment.rhs-set!|2 .exp|1 .exp0|1))))) 'assignment.rhs-set!))
+(let () (begin (set! if.test-set! (lambda (.exp|1 .exp0|1) (let ((.if.test-set!|2 0)) (begin (set! .if.test-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .exp0|3))) (.if.test-set!|2 .exp|1 .exp0|1))))) 'if.test-set!))
+(let () (begin (set! if.then-set! (lambda (.exp|1 .exp0|1) (let ((.if.then-set!|2 0)) (begin (set! .if.then-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.if.then-set!|2 .exp|1 .exp0|1))))) 'if.then-set!))
+(let () (begin (set! if.else-set! (lambda (.exp|1 .exp0|1) (let ((.if.else-set!|2 0)) (begin (set! .if.else-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.if.else-set!|2 .exp|1 .exp0|1))))) 'if.else-set!))
+(let () (begin (set! begin.exprs-set! (lambda (.exp|1 .exprs|1) (let ((.begin.exprs-set!|2 0)) (begin (set! .begin.exprs-set!|2 (lambda (.exp|3 .exprs|3) (set-cdr! .exp|3 .exprs|3))) (.begin.exprs-set!|2 .exp|1 .exprs|1))))) 'begin.exprs-set!))
+(let () (begin (set! expression-set! variable-set!) 'expression-set!))
+(let () (begin (set! make-doc (lambda (.name|1 .arity|1 .formals|1 .source-code|1 .filename|1 .filepos|1) (let ((.make-doc|2 0)) (begin (set! .make-doc|2 (lambda (.name|3 .arity|3 .formals|3 .source-code|3 .filename|3 .filepos|3) (let* ((.t|4|10|15 .formals|3) (.t|4|9|18 .filepos|3) (.t|4|8|21 .filename|3) (.t|4|7|24 .arity|3) (.t|4|6|27 .source-code|3) (.t|4|5|30 .name|3) (.v|4|12|33 (make-vector 6 .t|4|10|15))) (let () (begin (let ((.v|37|40 .v|4|12|33) (.i|37|40 4) (.x|37|40 .t|4|9|18)) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) (let ((.v|41|44 .v|4|12|33) (.i|41|44 3) (.x|41|44 .t|4|8|21)) (begin (.check! (fixnum? .i|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (vector? .v|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (<:fix:fix .i|41|44 (vector-length:vec .v|41|44)) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (>=:fix:fix .i|41|44 0) 41 .v|41|44 .i|41|44 .x|41|44) (vector-set!:trusted .v|41|44 .i|41|44 .x|41|44))) (let ((.v|45|48 .v|4|12|33) (.i|45|48 2) (.x|45|48 .t|4|7|24)) (begin (.check! (fixnum? .i|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (vector? .v|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (<:fix:fix .i|45|48 (vector-length:vec .v|45|48)) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (>=:fix:fix .i|45|48 0) 41 .v|45|48 .i|45|48 .x|45|48) (vector-set!:trusted .v|45|48 .i|45|48 .x|45|48))) (let ((.v|49|52 .v|4|12|33) (.i|49|52 1) (.x|49|52 .t|4|6|27)) (begin (.check! (fixnum? .i|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (vector? .v|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (<:fix:fix .i|49|52 (vector-length:vec .v|49|52)) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (>=:fix:fix .i|49|52 0) 41 .v|49|52 .i|49|52 .x|49|52) (vector-set!:trusted .v|49|52 .i|49|52 .x|49|52))) (let ((.v|53|56 .v|4|12|33) (.i|53|56 0) (.x|53|56 .t|4|5|30)) (begin (.check! (fixnum? .i|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (vector? .v|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (<:fix:fix .i|53|56 (vector-length:vec .v|53|56)) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (>=:fix:fix .i|53|56 0) 41 .v|53|56 .i|53|56 .x|53|56) (vector-set!:trusted .v|53|56 .i|53|56 .x|53|56))) .v|4|12|33))))) (.make-doc|2 .name|1 .arity|1 .formals|1 .source-code|1 .filename|1 .filepos|1))))) 'make-doc))
+(let () (begin (set! doc.name (lambda (.d|1) (let ((.doc.name|2 0)) (begin (set! .doc.name|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.name|2 .d|1))))) 'doc.name))
+(let () (begin (set! doc.code (lambda (.d|1) (let ((.doc.code|2 0)) (begin (set! .doc.code|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.code|2 .d|1))))) 'doc.code))
+(let () (begin (set! doc.arity (lambda (.d|1) (let ((.doc.arity|2 0)) (begin (set! .doc.arity|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.arity|2 .d|1))))) 'doc.arity))
+(let () (begin (set! doc.file (lambda (.d|1) (let ((.doc.file|2 0)) (begin (set! .doc.file|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.file|2 .d|1))))) 'doc.file))
+(let () (begin (set! doc.filepos (lambda (.d|1) (let ((.doc.filepos|2 0)) (begin (set! .doc.filepos|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 4)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.filepos|2 .d|1))))) 'doc.filepos))
+(let () (begin (set! doc.formals (lambda (.d|1) (let ((.doc.formals|2 0)) (begin (set! .doc.formals|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 5)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.formals|2 .d|1))))) 'doc.formals))
+(let () (begin (set! doc.name-set! (lambda (.d|1 .x|1) (let ((.doc.name-set!|2 0)) (begin (set! .doc.name-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 0) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.name-set!|2 .d|1 .x|1))))) 'doc.name-set!))
+(let () (begin (set! doc.code-set! (lambda (.d|1 .x|1) (let ((.doc.code-set!|2 0)) (begin (set! .doc.code-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.code-set!|2 .d|1 .x|1))))) 'doc.code-set!))
+(let () (begin (set! doc.arity-set! (lambda (.d|1 .x|1) (let ((.doc.arity-set!|2 0)) (begin (set! .doc.arity-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.arity-set!|2 .d|1 .x|1))))) 'doc.arity-set!))
+(let () (begin (set! doc.file-set! (lambda (.d|1 .x|1) (let ((.doc.file-set!|2 0)) (begin (set! .doc.file-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.file-set!|2 .d|1 .x|1))))) 'doc.file-set!))
+(let () (begin (set! doc.filepos-set! (lambda (.d|1 .x|1) (let ((.doc.filepos-set!|2 0)) (begin (set! .doc.filepos-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 4) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.filepos-set!|2 .d|1 .x|1))))) 'doc.filepos-set!))
+(let () (begin (set! doc.formals-set! (lambda (.d|1 .x|1) (let ((.doc.formals-set!|2 0)) (begin (set! .doc.formals-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 5) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.formals-set!|2 .d|1 .x|1))))) 'doc.formals-set!))
+(let () (begin (set! doc-copy (lambda (.d|1) (let ((.doc-copy|2 0)) (begin (set! .doc-copy|2 (lambda (.d|3) (list->vector (vector->list .d|3)))) (.doc-copy|2 .d|1))))) 'doc-copy))
+(let () (begin (set! ignored? (lambda (.name|1) (let ((.ignored?|2 0)) (begin (set! .ignored?|2 (lambda (.name|3) (eq? .name|3 name:ignored))) (.ignored?|2 .name|1))))) 'ignored?))
+(let () (begin (set! flag-as-ignored (lambda (.name|1 .l|1) (let ((.flag-as-ignored|2 0)) (begin (set! .flag-as-ignored|2 (lambda (.name|3 .l|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.name|5 .formals|5) (if (null? .formals|5) #t (if (symbol? .formals|5) #t (if (eq? .name|5 (let ((.x|9|12 .formals|5)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (begin (set-car! .formals|5 name:ignored) (if (not (local? (lambda.r .l|3) name:ignored)) (lambda.r-set! .l|3 (cons (make-r-entry name:ignored '() '() '()) (lambda.r .l|3))) (unspecified))) (.loop|4 .name|5 (let ((.x|14|17 .formals|5)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))))))) (.loop|4 .name|3 (lambda.args .l|3)))))) (.flag-as-ignored|2 .name|1 .l|1))))) 'flag-as-ignored))
+(let () (begin (set! make-null-terminated (lambda (.formals|1) (let ((.make-null-terminated|2 0)) (begin (set! .make-null-terminated|2 (lambda (.formals|3) (if (null? .formals|3) '() (if (symbol? .formals|3) (cons .formals|3 '()) (cons (let ((.x|8|11 .formals|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (.make-null-terminated|2 (let ((.x|12|15 .formals|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))))))) (.make-null-terminated|2 .formals|1))))) 'make-null-terminated))
+(let () (begin (set! list-head (lambda (.x|1 .n|1) (let ((.list-head|2 0)) (begin (set! .list-head|2 (lambda (.x|3 .n|3) (if (zero? .n|3) '() (cons (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) (.list-head|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) (- .n|3 1)))))) (.list-head|2 .x|1 .n|1))))) 'list-head))
+(let () (begin (set! remq (lambda (.x|1 .y|1) (let ((.remq|2 0)) (begin (set! .remq|2 (lambda (.x|3 .y|3) (if (null? .y|3) '() (if (eq? .x|3 (let ((.x|6|9 .y|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (.remq|2 .x|3 (let ((.x|10|13 .y|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) (cons (let ((.x|15|18 .y|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.remq|2 .x|3 (let ((.x|19|22 .y|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))))) (.remq|2 .x|1 .y|1))))) 'remq))
+(let () (begin (set! make-call-to-list (lambda (.args|1) (let ((.make-call-to-list|2 0)) (begin (set! .make-call-to-list|2 (lambda (.args|3) (if (null? .args|3) (make-constant '()) (if (null? (let ((.x|6|9 .args|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (make-call (make-variable name:cons) (let* ((.t1|10|13 (let ((.x|21|24 .args|3)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) (.t2|10|16 (cons (make-constant '()) '()))) (let () (cons .t1|10|13 .t2|10|16)))) (make-call (make-variable name:list) .args|3))))) (.make-call-to-list|2 .args|1))))) 'make-call-to-list))
+(let () (begin (set! pass2-error (lambda (.i|1 . .etc|1) (apply cerror (cons (let ((.v|2|5 pass2-error-messages) (.i|2|5 .i|1)) (begin (.check! (fixnum? .i|2|5) 40 .v|2|5 .i|2|5) (.check! (vector? .v|2|5) 40 .v|2|5 .i|2|5) (.check! (<:fix:fix .i|2|5 (vector-length:vec .v|2|5)) 40 .v|2|5 .i|2|5) (.check! (>=:fix:fix .i|2|5 0) 40 .v|2|5 .i|2|5) (vector-ref:trusted .v|2|5 .i|2|5))) .etc|1)))) 'pass2-error))
+(let () (begin (set! pass2-error-messages '#("System error: violation of an invariant in pass 2" "Wrong number of arguments to known procedure")) 'pass2-error-messages))
+(let () (begin (set! p2error:violation-of-invariant 0) 'p2error:violation-of-invariant))
+(let () (begin (set! p2error:wna 1) 'p2error:wna))
+(let () (begin (set! make-r-entry (lambda (.name|1 .refs|1 .assigns|1 .calls|1) (let ((.make-r-entry|2 0)) (begin (set! .make-r-entry|2 (lambda (.name|3 .refs|3 .assigns|3 .calls|3) (let* ((.t1|4|7 .name|3) (.t2|4|10 (let* ((.t1|14|17 .refs|3) (.t2|14|20 (let* ((.t1|24|27 .assigns|3) (.t2|24|30 (cons .calls|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-r-entry|2 .name|1 .refs|1 .assigns|1 .calls|1))))) 'make-r-entry))
+(let () (begin (set! r-entry.name (lambda (.x|1) (let ((.r-entry.name|2 0)) (begin (set! .r-entry.name|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.r-entry.name|2 .x|1))))) 'r-entry.name))
+(let () (begin (set! r-entry.references (lambda (.x|1) (let ((.r-entry.references|2 0)) (begin (set! .r-entry.references|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.references|2 .x|1))))) 'r-entry.references))
+(let () (begin (set! r-entry.assignments (lambda (.x|1) (let ((.r-entry.assignments|2 0)) (begin (set! .r-entry.assignments|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.assignments|2 .x|1))))) 'r-entry.assignments))
+(let () (begin (set! r-entry.calls (lambda (.x|1) (let ((.r-entry.calls|2 0)) (begin (set! .r-entry.calls|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .x|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.calls|2 .x|1))))) 'r-entry.calls))
+(let () (begin (set! r-entry.references-set! (lambda (.x|1 .refs|1) (let ((.r-entry.references-set!|2 0)) (begin (set! .r-entry.references-set!|2 (lambda (.x|3 .refs|3) (set-car! (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .refs|3))) (.r-entry.references-set!|2 .x|1 .refs|1))))) 'r-entry.references-set!))
+(let () (begin (set! r-entry.assignments-set! (lambda (.x|1 .assignments|1) (let ((.r-entry.assignments-set!|2 0)) (begin (set! .r-entry.assignments-set!|2 (lambda (.x|3 .assignments|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .assignments|3))) (.r-entry.assignments-set!|2 .x|1 .assignments|1))))) 'r-entry.assignments-set!))
+(let () (begin (set! r-entry.calls-set! (lambda (.x|1 .calls|1) (let ((.r-entry.calls-set!|2 0)) (begin (set! .r-entry.calls-set!|2 (lambda (.x|3 .calls|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .calls|3))) (.r-entry.calls-set!|2 .x|1 .calls|1))))) 'r-entry.calls-set!))
+(let () (begin (set! local? (lambda (.r|1 .i|1) (let ((.local?|2 0)) (begin (set! .local?|2 (lambda (.r|3 .i|3) (assq .i|3 .r|3))) (.local?|2 .r|1 .i|1))))) 'local?))
+(let () (begin (set! r-entry (lambda (.r|1 .i|1) (let ((.r-entry|2 0)) (begin (set! .r-entry|2 (lambda (.r|3 .i|3) (assq .i|3 .r|3))) (.r-entry|2 .r|1 .i|1))))) 'r-entry))
+(let () (begin (set! r-lookup (lambda (.r|1 .i|1) (let ((.r-lookup|2 0)) (begin (set! .r-lookup|2 (lambda (.r|3 .i|3) (let ((.temp|4|7 (assq .i|3 .r|3))) (if .temp|4|7 .temp|4|7 (pass2-error p2error:violation-of-invariant .r|3 .i|3))))) (.r-lookup|2 .r|1 .i|1))))) 'r-lookup))
+(let () (begin (set! references (lambda (.r|1 .i|1) (let ((.references|2 0)) (begin (set! .references|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.references|2 .r|1 .i|1))))) 'references))
+(let () (begin (set! assignments (lambda (.r|1 .i|1) (let ((.assignments|2 0)) (begin (set! .assignments|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignments|2 .r|1 .i|1))))) 'assignments))
+(let () (begin (set! calls (lambda (.r|1 .i|1) (let ((.calls|2 0)) (begin (set! .calls|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.calls|2 .r|1 .i|1))))) 'calls))
+(let () (begin (set! references-set! (lambda (.r|1 .i|1 .x|1) (let ((.references-set!|2 0)) (begin (set! .references-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|4|7 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .x|3))) (.references-set!|2 .r|1 .i|1 .x|1))))) 'references-set!))
+(let () (begin (set! assignments-set! (lambda (.r|1 .i|1 .x|1) (let ((.assignments-set!|2 0)) (begin (set! .assignments-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .x|3))) (.assignments-set!|2 .r|1 .i|1 .x|1))))) 'assignments-set!))
+(let () (begin (set! calls-set! (lambda (.r|1 .i|1 .x|1) (let ((.calls-set!|2 0)) (begin (set! .calls-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .x|3))) (.calls-set!|2 .r|1 .i|1 .x|1))))) 'calls-set!))
+(let () (begin (set! make-notepad (lambda (.l|1) (let ((.make-notepad|2 0)) (begin (set! .make-notepad|2 (lambda (.l|3) (let* ((.t|4|8|13 '()) (.t|4|7|16 '()) (.t|4|6|19 '()) (.t|4|5|22 .l|3) (.v|4|10|25 (make-vector 4 .t|4|8|13))) (let () (begin (let ((.v|29|32 .v|4|10|25) (.i|29|32 2) (.x|29|32 .t|4|7|16)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) (let ((.v|33|36 .v|4|10|25) (.i|33|36 1) (.x|33|36 .t|4|6|19)) (begin (.check! (fixnum? .i|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (vector? .v|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (<:fix:fix .i|33|36 (vector-length:vec .v|33|36)) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (>=:fix:fix .i|33|36 0) 41 .v|33|36 .i|33|36 .x|33|36) (vector-set!:trusted .v|33|36 .i|33|36 .x|33|36))) (let ((.v|37|40 .v|4|10|25) (.i|37|40 0) (.x|37|40 .t|4|5|22)) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) .v|4|10|25))))) (.make-notepad|2 .l|1))))) 'make-notepad))
+(let () (begin (set! notepad.parent (lambda (.np|1) (let ((.notepad.parent|2 0)) (begin (set! .notepad.parent|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.parent|2 .np|1))))) 'notepad.parent))
+(let () (begin (set! notepad.lambdas (lambda (.np|1) (let ((.notepad.lambdas|2 0)) (begin (set! .notepad.lambdas|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.lambdas|2 .np|1))))) 'notepad.lambdas))
+(let () (begin (set! notepad.nonescaping (lambda (.np|1) (let ((.notepad.nonescaping|2 0)) (begin (set! .notepad.nonescaping|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.nonescaping|2 .np|1))))) 'notepad.nonescaping))
+(let () (begin (set! notepad.vars (lambda (.np|1) (let ((.notepad.vars|2 0)) (begin (set! .notepad.vars|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.vars|2 .np|1))))) 'notepad.vars))
+(let () (begin (set! notepad.lambdas-set! (lambda (.np|1 .x|1) (let ((.notepad.lambdas-set!|2 0)) (begin (set! .notepad.lambdas-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.lambdas-set!|2 .np|1 .x|1))))) 'notepad.lambdas-set!))
+(let () (begin (set! notepad.nonescaping-set! (lambda (.np|1 .x|1) (let ((.notepad.nonescaping-set!|2 0)) (begin (set! .notepad.nonescaping-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.nonescaping-set!|2 .np|1 .x|1))))) 'notepad.nonescaping-set!))
+(let () (begin (set! notepad.vars-set! (lambda (.np|1 .x|1) (let ((.notepad.vars-set!|2 0)) (begin (set! .notepad.vars-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.vars-set!|2 .np|1 .x|1))))) 'notepad.vars-set!))
+(let () (begin (set! notepad-lambda-add! (lambda (.np|1 .l|1) (let ((.notepad-lambda-add!|2 0)) (begin (set! .notepad-lambda-add!|2 (lambda (.np|3 .l|3) (notepad.lambdas-set! .np|3 (cons .l|3 (notepad.lambdas .np|3))))) (.notepad-lambda-add!|2 .np|1 .l|1))))) 'notepad-lambda-add!))
+(let () (begin (set! notepad-nonescaping-add! (lambda (.np|1 .l|1) (let ((.notepad-nonescaping-add!|2 0)) (begin (set! .notepad-nonescaping-add!|2 (lambda (.np|3 .l|3) (notepad.nonescaping-set! .np|3 (cons .l|3 (notepad.nonescaping .np|3))))) (.notepad-nonescaping-add!|2 .np|1 .l|1))))) 'notepad-nonescaping-add!))
+(let () (begin (set! notepad-var-add! (lambda (.np|1 .i|1) (let ((.notepad-var-add!|2 0)) (begin (set! .notepad-var-add!|2 (lambda (.np|3 .i|3) (let ((.vars|6 (notepad.vars .np|3))) (if (not (memq .i|3 .vars|6)) (notepad.vars-set! .np|3 (cons .i|3 .vars|6)) (unspecified))))) (.notepad-var-add!|2 .np|1 .i|1))))) 'notepad-var-add!))
+(let () (begin (set! notepad-captured-variables (lambda (.np|1) (let ((.notepad-captured-variables|2 0)) (begin (set! .notepad-captured-variables|2 (lambda (.np|3) (let ((.nonescaping|6 (notepad.nonescaping .np|3))) (apply-union (let () (let ((.loop|12|15|18 (unspecified))) (begin (set! .loop|12|15|18 (lambda (.y1|7|8|19 .results|7|11|19) (if (null? .y1|7|8|19) (reverse .results|7|11|19) (begin #t (.loop|12|15|18 (let ((.x|23|26 .y1|7|8|19)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))) (cons (let ((.l|27 (let ((.x|28|31 .y1|7|8|19)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (if (memq .l|27 .nonescaping|6) (lambda.g .l|27) (lambda.f .l|27))) .results|7|11|19)))))) (.loop|12|15|18 (notepad.lambdas .np|3) '())))))))) (.notepad-captured-variables|2 .np|1))))) 'notepad-captured-variables))
+(let () (begin (set! notepad-free-variables (lambda (.np|1) (let ((.notepad-free-variables|2 0)) (begin (set! .notepad-free-variables|2 (lambda (.np|3) (let () (let ((.loop|4|7|10 (unspecified))) (begin (set! .loop|4|7|10 (lambda (.lambdas|11 .fv|11) (if (null? .lambdas|11) .fv|11 (begin #t (.loop|4|7|10 (let ((.x|14|17 .lambdas|11)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (let ((.l|20 (let ((.x|21|24 .lambdas|11)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (union (difference (lambda.f .l|20) (make-null-terminated (lambda.args .l|20))) .fv|11))))))) (.loop|4|7|10 (notepad.lambdas .np|3) (notepad.vars .np|3))))))) (.notepad-free-variables|2 .np|1))))) 'notepad-free-variables))
+(let () ($$trace "prefs"))
+(let () (begin (set! begin1 (string->symbol "Begin")) 'begin1))
+(let () (begin (set! define1 (string->symbol "Define")) 'define1))
+(let () (begin (set! quote1 (string->symbol "Quote")) 'quote1))
+(let () (begin (set! lambda1 (string->symbol "Lambda")) 'lambda1))
+(let () (begin (set! if1 (string->symbol "If")) 'if1))
+(let () (begin (set! set!1 (string->symbol "Set!")) 'set!1))
+(let () (begin (set! undefined1 (cons (string->symbol "Undefined") '())) 'undefined1))
+(let () (begin (set! renaming-prefix-character #\.) 'renaming-prefix-character))
+(let () (begin (set! renaming-suffix-character #\|) 'renaming-suffix-character))
+(let () (begin (set! renaming-prefix (string renaming-prefix-character)) 'renaming-prefix))
+(let () (begin (set! renaming-suffix (string renaming-suffix-character)) 'renaming-suffix))
+(let () (begin (set! make-toplevel-definition (lambda (.id|1 .exp|1) (let ((.make-toplevel-definition|2 0)) (begin (set! .make-toplevel-definition|2 (lambda (.id|3 .exp|3) (begin (if (lambda? .exp|3) (doc.name-set! (lambda.doc .exp|3) .id|3) (unspecified)) (make-begin (let* ((.t1|4|7 (make-assignment .id|3 .exp|3)) (.t2|4|10 (cons (make-constant .id|3) '()))) (let () (cons .t1|4|7 .t2|4|10))))))) (.make-toplevel-definition|2 .id|1 .exp|1))))) 'make-toplevel-definition))
+(let () (begin (set! make-undefined (lambda () (let ((.make-undefined|2 0)) (begin (set! .make-undefined|2 (lambda () (make-call (make-variable 'undefined) '()))) (.make-undefined|2))))) 'make-undefined))
+(let () (begin (set! make-unspecified (lambda () (let ((.make-unspecified|2 0)) (begin (set! .make-unspecified|2 (lambda () (make-call (make-variable 'unspecified) '()))) (.make-unspecified|2))))) 'make-unspecified))
+(let () ($$trace "syntaxenv"))
+(let () (begin (set! standard-syntactic-environment '((quote special quote) (lambda special lambda) (if special if) (set! special set!) (begin special begin) (define special define) (define-inline special define-inline) (define-syntax special define-syntax) (let-syntax special let-syntax) (letrec-syntax special letrec-syntax) (syntax-rules special syntax-rules))) 'standard-syntactic-environment))
+(let () (begin (set! lambda0 (string->symbol " lambda ")) 'lambda0))
+(let () (begin (set! set!0 (string->symbol " set! ")) 'set!0))
+(let () (begin (set! syntactic-copy (lambda (.env|1) (let ((.syntactic-copy|2 0)) (begin (set! .syntactic-copy|2 (lambda (.env|3) (copy-alist .env|3))) (.syntactic-copy|2 .env|1))))) 'syntactic-copy))
+(let () (begin (set! make-basic-syntactic-environment (lambda () (let ((.make-basic-syntactic-environment|2 0)) (begin (set! .make-basic-syntactic-environment|2 (lambda () (cons (cons lambda0 (let ((.x|4|7 (assq 'lambda standard-syntactic-environment))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (cons (cons set!0 (let ((.x|8|11 (assq 'set! standard-syntactic-environment))) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))) (syntactic-copy standard-syntactic-environment))))) (.make-basic-syntactic-environment|2))))) 'make-basic-syntactic-environment))
+(let () (begin (set! global-syntactic-environment (make-basic-syntactic-environment)) 'global-syntactic-environment))
+(let () (begin (set! global-syntactic-environment-set! (lambda (.env|1) (let ((.global-syntactic-environment-set!|2 0)) (begin (set! .global-syntactic-environment-set!|2 (lambda (.env|3) (begin (set-cdr! global-syntactic-environment .env|3) #t))) (.global-syntactic-environment-set!|2 .env|1))))) 'global-syntactic-environment-set!))
+(let () (begin (set! syntactic-bind-globally! (lambda (.id|1 .denotation|1) (let ((.syntactic-bind-globally!|2 0)) (begin (set! .syntactic-bind-globally!|2 (lambda (.id|3 .denotation|3) (if (if (identifier-denotation? .denotation|3) (eq? .id|3 (identifier-name .denotation|3)) #f) (let () (let ((.remove-bindings-for-id|8 (unspecified))) (begin (set! .remove-bindings-for-id|8 (lambda (.bindings|9) (if (null? .bindings|9) '() (if (eq? (let ((.x|13|16 (let ((.x|17|20 .bindings|9)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) .id|3) (.remove-bindings-for-id|8 (let ((.x|21|24 .bindings|9)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) (cons (let ((.x|26|29 .bindings|9)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) (.remove-bindings-for-id|8 (let ((.x|30|33 .bindings|9)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))))))) (global-syntactic-environment-set! (.remove-bindings-for-id|8 (let ((.x|34|37 global-syntactic-environment)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37)))))))) (let ((.x|40 (assq .id|3 global-syntactic-environment))) (if .x|40 (begin (set-cdr! .x|40 .denotation|3) #t) (global-syntactic-environment-set! (cons (cons .id|3 .denotation|3) (let ((.x|41|44 global-syntactic-environment)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44)))))))))) (.syntactic-bind-globally!|2 .id|1 .denotation|1))))) 'syntactic-bind-globally!))
+(let () (begin (set! syntactic-divert (lambda (.env1|1 .env2|1) (let ((.syntactic-divert|2 0)) (begin (set! .syntactic-divert|2 (lambda (.env1|3 .env2|3) (append .env2|3 .env1|3))) (.syntactic-divert|2 .env1|1 .env2|1))))) 'syntactic-divert))
+(let () (begin (set! syntactic-extend (lambda (.env|1 .ids|1 .denotations|1) (let ((.syntactic-extend|2 0)) (begin (set! .syntactic-extend|2 (lambda (.env|3 .ids|3 .denotations|3) (syntactic-divert .env|3 (let () (let ((.loop|10|14|17 (unspecified))) (begin (set! .loop|10|14|17 (lambda (.y1|4|6|18 .y1|4|5|18 .results|4|9|18) (if (let ((.temp|20|23 (null? .y1|4|6|18))) (if .temp|20|23 .temp|20|23 (null? .y1|4|5|18))) (reverse .results|4|9|18) (begin #t (.loop|10|14|17 (let ((.x|26|29 .y1|4|6|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (let ((.x|30|33 .y1|4|5|18)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) (cons (cons (let ((.x|34|37 .y1|4|6|18)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) (let ((.x|38|41 .y1|4|5|18)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41)))) .results|4|9|18)))))) (.loop|10|14|17 .ids|3 .denotations|3 '()))))))) (.syntactic-extend|2 .env|1 .ids|1 .denotations|1))))) 'syntactic-extend))
+(let () (begin (set! syntactic-lookup (lambda (.env|1 .id|1) (let ((.syntactic-lookup|2 0)) (begin (set! .syntactic-lookup|2 (lambda (.env|3 .id|3) (let ((.entry|6 (assq .id|3 .env|3))) (if .entry|6 (let ((.x|7|10 .entry|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) (make-identifier-denotation .id|3))))) (.syntactic-lookup|2 .env|1 .id|1))))) 'syntactic-lookup))
+(let () (begin (set! syntactic-assign! (lambda (.env|1 .id|1 .denotation|1) (let ((.syntactic-assign!|2 0)) (begin (set! .syntactic-assign!|2 (lambda (.env|3 .id|3 .denotation|3) (let ((.entry|6 (assq .id|3 .env|3))) (if .entry|6 (set-cdr! .entry|6 .denotation|3) (m-bug "Bug detected in syntactic-assign!" .env|3 .id|3 .denotation|3))))) (.syntactic-assign!|2 .env|1 .id|1 .denotation|1))))) 'syntactic-assign!))
+(let () (begin (set! denotation-class car) 'denotation-class))
+(let () (begin (set! special-denotation? (lambda (.denotation|1) (let ((.special-denotation?|2 0)) (begin (set! .special-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'special))) (.special-denotation?|2 .denotation|1))))) 'special-denotation?))
+(let () (begin (set! macro-denotation? (lambda (.denotation|1) (let ((.macro-denotation?|2 0)) (begin (set! .macro-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'macro))) (.macro-denotation?|2 .denotation|1))))) 'macro-denotation?))
+(let () (begin (set! inline-denotation? (lambda (.denotation|1) (let ((.inline-denotation?|2 0)) (begin (set! .inline-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'inline))) (.inline-denotation?|2 .denotation|1))))) 'inline-denotation?))
+(let () (begin (set! identifier-denotation? (lambda (.denotation|1) (let ((.identifier-denotation?|2 0)) (begin (set! .identifier-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'identifier))) (.identifier-denotation?|2 .denotation|1))))) 'identifier-denotation?))
+(let () (begin (set! make-macro-denotation (lambda (.rules|1 .env|1) (let ((.make-macro-denotation|2 0)) (begin (set! .make-macro-denotation|2 (lambda (.rules|3 .env|3) (let* ((.t1|4|7 'macro) (.t2|4|10 (let* ((.t1|14|17 .rules|3) (.t2|14|20 (cons .env|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-macro-denotation|2 .rules|1 .env|1))))) 'make-macro-denotation))
+(let () (begin (set! make-inline-denotation (lambda (.id|1 .rules|1 .env|1) (let ((.make-inline-denotation|2 0)) (begin (set! .make-inline-denotation|2 (lambda (.id|3 .rules|3 .env|3) (let* ((.t1|4|7 'inline) (.t2|4|10 (let* ((.t1|14|17 .rules|3) (.t2|14|20 (let* ((.t1|24|27 .env|3) (.t2|24|30 (cons .id|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-inline-denotation|2 .id|1 .rules|1 .env|1))))) 'make-inline-denotation))
+(let () (begin (set! make-identifier-denotation (lambda (.id|1) (let ((.make-identifier-denotation|2 0)) (begin (set! .make-identifier-denotation|2 (lambda (.id|3) (let* ((.t1|4|7 'identifier) (.t2|4|10 (let* ((.t1|14|17 .id|3) (.t2|14|20 (let* ((.t1|24|27 '()) (.t2|24|30 (let* ((.t1|34|37 '()) (.t2|34|40 (cons '() '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-identifier-denotation|2 .id|1))))) 'make-identifier-denotation))
+(let () (begin (set! macro-rules cadr) 'macro-rules))
+(let () (begin (set! macro-env caddr) 'macro-env))
+(let () (begin (set! inline-rules macro-rules) 'inline-rules))
+(let () (begin (set! inline-env macro-env) 'inline-env))
+(let () (begin (set! inline-name cadddr) 'inline-name))
+(let () (begin (set! identifier-name cadr) 'identifier-name))
+(let () (begin (set! identifier-r-entry cdr) 'identifier-r-entry))
+(let () (begin (set! same-denotation? (lambda (.d1|1 .d2|1) (let ((.same-denotation?|2 0)) (begin (set! .same-denotation?|2 (lambda (.d1|3 .d2|3) (let ((.temp|4|7 (eq? .d1|3 .d2|3))) (if .temp|4|7 .temp|4|7 (if (identifier-denotation? .d1|3) (if (identifier-denotation? .d2|3) (eq? (identifier-name .d1|3) (identifier-name .d2|3)) #f) #f))))) (.same-denotation?|2 .d1|1 .d2|1))))) 'same-denotation?))
+(let () (begin (set! denotation-of-quote (syntactic-lookup standard-syntactic-environment 'quote)) 'denotation-of-quote))
+(let () (begin (set! denotation-of-lambda (syntactic-lookup standard-syntactic-environment 'lambda)) 'denotation-of-lambda))
+(let () (begin (set! denotation-of-if (syntactic-lookup standard-syntactic-environment 'if)) 'denotation-of-if))
+(let () (begin (set! denotation-of-set! (syntactic-lookup standard-syntactic-environment 'set!)) 'denotation-of-set!))
+(let () (begin (set! denotation-of-begin (syntactic-lookup standard-syntactic-environment 'begin)) 'denotation-of-begin))
+(let () (begin (set! denotation-of-define (syntactic-lookup standard-syntactic-environment 'define)) 'denotation-of-define))
+(let () (begin (set! denotation-of-define-inline (syntactic-lookup standard-syntactic-environment 'define-inline)) 'denotation-of-define-inline))
+(let () (begin (set! denotation-of-define-syntax (syntactic-lookup standard-syntactic-environment 'define-syntax)) 'denotation-of-define-syntax))
+(let () (begin (set! denotation-of-let-syntax (syntactic-lookup standard-syntactic-environment 'let-syntax)) 'denotation-of-let-syntax))
+(let () (begin (set! denotation-of-letrec-syntax (syntactic-lookup standard-syntactic-environment 'letrec-syntax)) 'denotation-of-letrec-syntax))
+(let () (begin (set! denotation-of-syntax-rules (syntactic-lookup standard-syntactic-environment 'syntax-rules)) 'denotation-of-syntax-rules))
+(let () (begin (set! denotation-of-... (syntactic-lookup standard-syntactic-environment '...)) 'denotation-of-...))
+(let () (begin (set! denotation-of-transformer (syntactic-lookup standard-syntactic-environment 'transformer)) 'denotation-of-transformer))
+(let () (begin (set! syntactic-alias (lambda (.env|1 .alist|1 .env2|1) (let ((.syntactic-alias|2 0)) (begin (set! .syntactic-alias|2 (lambda (.env|3 .alist|3 .env2|3) (syntactic-divert .env|3 (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.name-pair|24 (let ((.x|36|39 .y1|4|5|16)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (let ((.old-name|27 (let ((.x|28|31 .name-pair|24)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.new-name|27 (let ((.x|32|35 .name-pair|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))))) (cons .new-name|27 (syntactic-lookup .env2|3 .old-name|27)))) .results|4|8|16)))))) (.loop|9|12|15 .alist|3 '()))))))) (.syntactic-alias|2 .env|1 .alist|1 .env2|1))))) 'syntactic-alias))
+(let () (begin (set! syntactic-rename (lambda (.env|1 .alist|1) (let ((.syntactic-rename|2 0)) (begin (set! .syntactic-rename|2 (lambda (.env|3 .alist|3) (if (null? .alist|3) .env|3 (let* ((.old|6 (let ((.x|30|33 (let ((.x|34|37 .alist|3)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (.new|9 (let ((.x|21|24 (let ((.x|25|28 .alist|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) (.denotation|12 (make-identifier-denotation .new|9))) (let () (.syntactic-rename|2 (cons (cons .old|6 .denotation|12) (cons (cons .new|9 .denotation|12) .env|3)) (let ((.x|16|19 .alist|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))))))) (.syntactic-rename|2 .env|1 .alist|1))))) 'syntactic-rename))
+(let () (begin (set! renaming-counter 0) 'renaming-counter))
+(let () (begin (set! make-rename-procedure (lambda () (let ((.make-rename-procedure|2 0)) (begin (set! .make-rename-procedure|2 (lambda () (begin (set! renaming-counter (+ renaming-counter 1)) (let ((.suffix|6 (string-append renaming-suffix (number->string renaming-counter)))) (lambda (.sym|7) (if (symbol? .sym|7) (let ((.s|10 (symbol->string .sym|7))) (if (if (> (string-length .s|10) 0) (char=? (string-ref .s|10 0) renaming-prefix-character) #f) (string->symbol (string-append .s|10 .suffix|6)) (string->symbol (string-append renaming-prefix .s|10 .suffix|6)))) (m-warn "Illegal use of rename procedure" 'ok:fixme .sym|7))))))) (.make-rename-procedure|2))))) 'make-rename-procedure))
+(let () (begin (set! m-strip (lambda (.x|1) (let ((.m-strip|2 0)) (begin (set! .m-strip|2 (lambda (.x|3) (let ((.original-symbol|5 (unspecified))) (begin (set! .original-symbol|5 (lambda (.x|6) (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.sym|10 .s|10 .i|10 .n|10) (if (= .i|10 .n|10) .sym|10 (if (char=? (string-ref .s|10 .i|10) renaming-suffix-character) (string->symbol (substring .s|10 1 .i|10)) (.loop|9 .sym|10 .s|10 (+ .i|10 1) .n|10))))) (let ((.s|14 (symbol->string .x|6))) (if (if (> (string-length .s|14) 0) (char=? (string-ref .s|14 0) renaming-prefix-character) #f) (.loop|9 .x|6 .s|14 0 (string-length .s|14)) .x|6)))))) (if (symbol? .x|3) (.original-symbol|5 .x|3) (if (pair? .x|3) (let ((.a|21 (.m-strip|2 (let ((.x|32|35 .x|3)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))))) (.b|21 (.m-strip|2 (let ((.x|36|39 .x|3)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39)))))) (if (if (eq? .a|21 (let ((.x|23|26 .x|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) (eq? .b|21 (let ((.x|28|31 .x|3)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31)))) #f) .x|3 (cons .a|21 .b|21))) (if (vector? .x|3) (let* ((.v|43 (vector->list .x|3)) (.v2|46 (let () (let ((.loop|55|58|61 (unspecified))) (begin (set! .loop|55|58|61 (lambda (.y1|50|51|62 .results|50|54|62) (if (null? .y1|50|51|62) (reverse .results|50|54|62) (begin #t (.loop|55|58|61 (let ((.x|66|69 .y1|50|51|62)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (cons (.m-strip|2 (let ((.x|70|73 .y1|50|51|62)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) .results|50|54|62)))))) (.loop|55|58|61 .v|43 '())))))) (let () (if (equal? .v|43 .v2|46) .x|3 (list->vector .v2|46)))) .x|3))))))) (.m-strip|2 .x|1))))) 'm-strip))
+(let () (begin (set! rename-vars (lambda (.original-vars|1) (let ((.rename-vars|2 0)) (begin (set! .rename-vars|2 (lambda (.original-vars|3) (let* ((.rename|6 (make-rename-procedure)) (.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.vars|8 .newvars|8) (if (null? .vars|8) (reverse .newvars|8) (if (pair? .vars|8) (let ((.var|13 (let ((.x|18|21 .vars|8)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if (symbol? .var|13) (.loop|7 (let ((.x|14|17 .vars|8)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (cons (cons .var|13 (.rename|6 .var|13)) .newvars|8)) (m-error "Illegal variable" .var|13))) (if (symbol? .vars|8) (.loop|7 (cons .vars|8 '()) .newvars|8) (m-error "Malformed parameter list" .original-vars|3)))))) (.loop|7 .original-vars|3 '()))))) (.rename-vars|2 .original-vars|1))))) 'rename-vars))
+(let () (begin (set! rename-formals (lambda (.formals|1 .alist|1) (let ((.rename-formals|2 0)) (begin (set! .rename-formals|2 (lambda (.formals|3 .alist|3) (if (null? .formals|3) '() (if (pair? .formals|3) (cons (let ((.x|6|9 (assq (let ((.x|10|13 .formals|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) .alist|3))) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9))) (.rename-formals|2 (let ((.x|14|17 .formals|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) .alist|3)) (let ((.x|19|22 (assq .formals|3 .alist|3))) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))) (.rename-formals|2 .formals|1 .alist|1))))) 'rename-formals))
+(let () ($$trace "syntaxrules"))
+(let () (begin (set! pattern-variable-flag (cons 'v '())) 'pattern-variable-flag))
+(let () (begin (set! ellipsis-pattern-flag (cons 'e '())) 'ellipsis-pattern-flag))
+(let () (begin (set! ellipsis-template-flag ellipsis-pattern-flag) 'ellipsis-template-flag))
+(let () (begin (set! make-patternvar (lambda (.v|1 .rank|1) (let ((.make-patternvar|2 0)) (begin (set! .make-patternvar|2 (lambda (.v|3 .rank|3) (let* ((.t|4|7|12 .rank|3) (.t|4|6|15 .v|3) (.t|4|5|18 pattern-variable-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-patternvar|2 .v|1 .rank|1))))) 'make-patternvar))
+(let () (begin (set! make-ellipsis-pattern (lambda (.p|1 .vars|1) (let ((.make-ellipsis-pattern|2 0)) (begin (set! .make-ellipsis-pattern|2 (lambda (.p|3 .vars|3) (let* ((.t|4|7|12 .vars|3) (.t|4|6|15 .p|3) (.t|4|5|18 ellipsis-pattern-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-ellipsis-pattern|2 .p|1 .vars|1))))) 'make-ellipsis-pattern))
+(let () (begin (set! make-ellipsis-template (lambda (.t|1 .vars|1) (let ((.make-ellipsis-template|2 0)) (begin (set! .make-ellipsis-template|2 (lambda (.t|3 .vars|3) (let* ((.t|4|7|12 .vars|3) (.t|4|6|15 .t|3) (.t|4|5|18 ellipsis-template-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-ellipsis-template|2 .t|1 .vars|1))))) 'make-ellipsis-template))
+(let () (begin (set! patternvar? (lambda (.x|1) (let ((.patternvar?|2 0)) (begin (set! .patternvar?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) pattern-variable-flag) #f) #f))) (.patternvar?|2 .x|1))))) 'patternvar?))
+(let () (begin (set! ellipsis-pattern? (lambda (.x|1) (let ((.ellipsis-pattern?|2 0)) (begin (set! .ellipsis-pattern?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) ellipsis-pattern-flag) #f) #f))) (.ellipsis-pattern?|2 .x|1))))) 'ellipsis-pattern?))
+(let () (begin (set! ellipsis-template? (lambda (.x|1) (let ((.ellipsis-template?|2 0)) (begin (set! .ellipsis-template?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) ellipsis-template-flag) #f) #f))) (.ellipsis-template?|2 .x|1))))) 'ellipsis-template?))
+(let () (begin (set! patternvar-name (lambda (.v|1) (let ((.patternvar-name|2 0)) (begin (set! .patternvar-name|2 (lambda (.v|3) (let ((.v|4|7 .v|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.patternvar-name|2 .v|1))))) 'patternvar-name))
+(let () (begin (set! patternvar-rank (lambda (.v|1) (let ((.patternvar-rank|2 0)) (begin (set! .patternvar-rank|2 (lambda (.v|3) (let ((.v|4|7 .v|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.patternvar-rank|2 .v|1))))) 'patternvar-rank))
+(let () (begin (set! ellipsis-pattern (lambda (.p|1) (let ((.ellipsis-pattern|2 0)) (begin (set! .ellipsis-pattern|2 (lambda (.p|3) (let ((.v|4|7 .p|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-pattern|2 .p|1))))) 'ellipsis-pattern))
+(let () (begin (set! ellipsis-pattern-vars (lambda (.p|1) (let ((.ellipsis-pattern-vars|2 0)) (begin (set! .ellipsis-pattern-vars|2 (lambda (.p|3) (let ((.v|4|7 .p|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-pattern-vars|2 .p|1))))) 'ellipsis-pattern-vars))
+(let () (begin (set! ellipsis-template (lambda (.t|1) (let ((.ellipsis-template|2 0)) (begin (set! .ellipsis-template|2 (lambda (.t|3) (let ((.v|4|7 .t|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-template|2 .t|1))))) 'ellipsis-template))
+(let () (begin (set! ellipsis-template-vars (lambda (.t|1) (let ((.ellipsis-template-vars|2 0)) (begin (set! .ellipsis-template-vars|2 (lambda (.t|3) (let ((.v|4|7 .t|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-template-vars|2 .t|1))))) 'ellipsis-template-vars))
+(let () (begin (set! pattern-variable (lambda (.v|1 .vars|1) (let ((.pattern-variable|2 0)) (begin (set! .pattern-variable|2 (lambda (.v|3 .vars|3) (if (null? .vars|3) #f (if (eq? .v|3 (patternvar-name (let ((.x|6|9 .vars|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))))) (let ((.x|10|13 .vars|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.pattern-variable|2 .v|3 (let ((.x|15|18 .vars|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))))) (.pattern-variable|2 .v|1 .vars|1))))) 'pattern-variable))
+(let () (begin (set! m-compile-transformer-spec (lambda (.spec|1 .env|1) (let ((.m-compile-transformer-spec|2 0)) (begin (set! .m-compile-transformer-spec|2 (lambda (.spec|3 .env|3) (if (if (> (safe-length .spec|3) 1) (eq? (syntactic-lookup .env|3 (let ((.x|6|9 .spec|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) denotation-of-syntax-rules) #f) (let ((.literals|12 (let ((.x|72|75 (let ((.x|76|79 .spec|3)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))))) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.rules|12 (let ((.x|81|84 (let ((.x|85|88 .spec|3)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88))))) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84))))) (begin (if (let ((.temp|13|16 (not (list? .literals|12)))) (if .temp|13|16 .temp|13|16 (not (every1? (lambda (.rule|18) (if (= (safe-length .rule|18) 2) (pair? (let ((.x|21|24 .rule|18)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) #f)) .rules|12)))) (m-error "Malformed syntax-rules" .spec|3) (unspecified)) (let* ((.t1|25|28 'macro) (.t2|25|31 (let* ((.t1|35|38 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (let ((.rule|66 (let ((.x|67|70 .y1|46|47|58)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (m-compile-rule .rule|66 .literals|12 .env|3)) .results|46|50|58)))))) (.loop|51|54|57 .rules|12 '()))))) (.t2|35|41 (cons .env|3 '()))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))))) (m-error "Malformed syntax-rules" .spec|3)))) (.m-compile-transformer-spec|2 .spec|1 .env|1))))) 'm-compile-transformer-spec))
+(let () (begin (set! m-compile-rule (lambda (.rule|1 .literals|1 .env|1) (let ((.m-compile-rule|2 0)) (begin (set! .m-compile-rule|2 (lambda (.rule|3 .literals|3 .env|3) (m-compile-pattern (let ((.x|4|7 (let ((.x|8|11 .rule|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .literals|3 .env|3 (lambda (.compiled-rule|12 .patternvars|12) (cons .compiled-rule|12 (m-compile-template (let ((.x|14|17 (let ((.x|18|21 .rule|3)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))) .patternvars|12 .env|3)))))) (.m-compile-rule|2 .rule|1 .literals|1 .env|1))))) 'm-compile-rule))
+(let () (begin (set! m-compile-pattern (lambda (.p|1 .literals|1 .env|1 .k|1) (let ((.m-compile-pattern|2 0)) (begin (set! .m-compile-pattern|2 (lambda (.p|3 .literals|3 .env|3 .k|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.p|5 .vars|5 .rank|5 .k|5) (if (symbol? .p|5) (if (memq .p|5 .literals|3) (.k|5 .p|5 .vars|5) (let ((.var|9 (make-patternvar .p|5 .rank|5))) (.k|5 .var|9 (cons .var|9 .vars|5)))) (if (null? .p|5) (.k|5 '() .vars|5) (if (pair? .p|5) (if (if (pair? (let ((.x|13|16 .p|5)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16)))) (if (symbol? (let ((.x|19|22 (let ((.x|23|26 .p|5)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))))) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (same-denotation? (syntactic-lookup .env|3 (let ((.x|29|32 (let ((.x|33|36 .p|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) denotation-of-...) #f) #f) (if (null? (let ((.x|38|41 (let ((.x|42|45 .p|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))) (.loop|4 (let ((.x|46|49 .p|5)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) '() (+ .rank|5 1) (lambda (.p|50 .vars1|50) (.k|5 (make-ellipsis-pattern .p|50 .vars1|50) (union2 .vars1|50 .vars|5)))) (m-error "Malformed pattern" .p|5)) (.loop|4 (let ((.x|51|54 .p|5)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))) .vars|5 .rank|5 (lambda (.p1|55 .vars|55) (.loop|4 (let ((.x|56|59 .p|5)) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) .vars|55 .rank|5 (lambda (.p2|60 .vars|60) (.k|5 (cons .p1|55 .p2|60) .vars|60)))))) (if (vector? .p|5) (.loop|4 (vector->list .p|5) .vars|5 .rank|5 (lambda (.p|62 .vars|62) (.k|5 (make-vector 1 .p|62) .vars|62))) (.k|5 .p|5 .vars|5))))))) (.loop|4 .p|3 '() 0 .k|3))))) (.m-compile-pattern|2 .p|1 .literals|1 .env|1 .k|1))))) 'm-compile-pattern))
+(let () (begin (set! m-compile-template (lambda (.t|1 .vars|1 .env|1) (let ((.m-compile-template|2 0)) (begin (set! .m-compile-template|2 (lambda (.t|3 .vars|3 .env|3) (let ((.loop1|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .loop1|4 (lambda (.t|5 .inserted|5 .referenced|5 .rank|5 .escaped?|5 .k|5) (.loop|4 (let ((.x|6|9 .t|5)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .inserted|5 '() (+ .rank|5 1) .escaped?|5 (lambda (.t1|10 .inserted|10 .referenced1|10) (.loop|4 (let ((.x|12|15 (let ((.x|16|19 .t|5)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) .inserted|10 (append .referenced1|10 .referenced|5) .rank|5 .escaped?|5 (lambda (.t2|20 .inserted|20 .referenced|20) (.k|5 (cons (make-ellipsis-template .t1|10 (filter1 (lambda (.var|21) (> (patternvar-rank .var|21) .rank|5)) .referenced1|10)) .t2|20) .inserted|20 .referenced|20))))))) (set! .loop|4 (lambda (.t|22 .inserted|22 .referenced|22 .rank|22 .escaped?|22 .k|22) (if (symbol? .t|22) (let ((.x|26 (pattern-variable .t|22 .vars|3))) (if .x|26 (if (>= .rank|22 (patternvar-rank .x|26)) (.k|22 .x|26 .inserted|22 (cons .x|26 .referenced|22)) (m-error "Too few ellipses follow pattern variable in template" (patternvar-name .x|26))) (.k|22 .t|22 (cons .t|22 .inserted|22) .referenced|22))) (if (null? .t|22) (.k|22 '() .inserted|22 .referenced|22) (if (pair? .t|22) (if (if (not .escaped?|22) (if (symbol? (let ((.x|32|35 .t|22)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35)))) (if (same-denotation? (syntactic-lookup .env|3 (let ((.x|37|40 .t|22)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) denotation-of-...) (if (pair? (let ((.x|42|45 .t|22)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))) (null? (let ((.x|48|51 (let ((.x|52|55 .t|22)) (begin (.check! (pair? .x|52|55) 1 .x|52|55) (cdr:pair .x|52|55))))) (begin (.check! (pair? .x|48|51) 1 .x|48|51) (cdr:pair .x|48|51)))) #f) #f) #f) #f) (.loop|4 (let ((.x|57|60 (let ((.x|61|64 .t|22)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))))) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))) .inserted|22 .referenced|22 .rank|22 #t .k|22) (if (if (not .escaped?|22) (if (pair? (let ((.x|68|71 .t|22)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71)))) (if (symbol? (let ((.x|74|77 (let ((.x|78|81 .t|22)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))))) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) (same-denotation? (syntactic-lookup .env|3 (let ((.x|84|87 (let ((.x|88|91 .t|22)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))))) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87)))) denotation-of-...) #f) #f) #f) (.loop1|4 .t|22 .inserted|22 .referenced|22 .rank|22 .escaped?|22 .k|22) (.loop|4 (let ((.x|93|96 .t|22)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))) .inserted|22 .referenced|22 .rank|22 .escaped?|22 (lambda (.t1|97 .inserted|97 .referenced|97) (.loop|4 (let ((.x|98|101 .t|22)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) .inserted|97 .referenced|97 .rank|22 .escaped?|22 (lambda (.t2|102 .inserted|102 .referenced|102) (.k|22 (cons .t1|97 .t2|102) .inserted|102 .referenced|102))))))) (if (vector? .t|22) (.loop|4 (vector->list .t|22) .inserted|22 .referenced|22 .rank|22 .escaped?|22 (lambda (.t|104 .inserted|104 .referenced|104) (.k|22 (make-vector 1 .t|104) .inserted|104 .referenced|104))) (.k|22 .t|22 .inserted|22 .referenced|22))))))) (.loop|4 .t|3 '() '() 0 #f (lambda (.t|107 .inserted|107 .referenced|107) (let* ((.t1|108|111 .t|107) (.t2|108|114 (cons .inserted|107 '()))) (let () (cons .t1|108|111 .t2|108|114))))))))) (.m-compile-template|2 .t|1 .vars|1 .env|1))))) 'm-compile-template))
+(let () (begin (set! empty-pattern-variable-environment (cons (make-patternvar (string->symbol "") 0) '())) 'empty-pattern-variable-environment))
+(let () (begin (set! m-match (lambda (.f|1 .p|1 .env-def|1 .env-use|1) (let ((.m-match|2 0)) (begin (set! .m-match|2 (lambda (.f|3 .p|3 .env-def|3 .env-use|3) (let ((.match1|4 (unspecified)) (.match|4 (unspecified))) (begin (set! .match1|4 (lambda (.f|5 .p|5 .answer|5 .rank|5) (if (not (list? .f|5)) #f (if (null? .f|5) (append (let () (let ((.loop|13|16|19 (unspecified))) (begin (set! .loop|13|16|19 (lambda (.y1|8|9|20 .results|8|12|20) (if (null? .y1|8|9|20) (reverse .results|8|12|20) (begin #t (.loop|13|16|19 (let ((.x|24|27 .y1|8|9|20)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))) (cons (let ((.var|28 (let ((.x|29|32 .y1|8|9|20)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32))))) (cons .var|28 '())) .results|8|12|20)))))) (.loop|13|16|19 (ellipsis-pattern-vars .p|5) '())))) .answer|5) (let* ((.p1|36 (ellipsis-pattern .p|5)) (.answers|39 (let () (let ((.loop|103|106|109 (unspecified))) (begin (set! .loop|103|106|109 (lambda (.y1|98|99|110 .results|98|102|110) (if (null? .y1|98|99|110) (reverse .results|98|102|110) (begin #t (.loop|103|106|109 (let ((.x|114|117 .y1|98|99|110)) (begin (.check! (pair? .x|114|117) 1 .x|114|117) (cdr:pair .x|114|117))) (cons (let ((.f|118 (let ((.x|119|122 .y1|98|99|110)) (begin (.check! (pair? .x|119|122) 0 .x|119|122) (car:pair .x|119|122))))) (.match|4 .f|118 .p1|36 .answer|5 .rank|5)) .results|98|102|110)))))) (.loop|103|106|109 .f|5 '())))))) (let () (if (every1? (lambda (.answer|43) .answer|43) .answers|39) (append (let () (let ((.loop|49|52|55 (unspecified))) (begin (set! .loop|49|52|55 (lambda (.y1|44|45|56 .results|44|48|56) (if (null? .y1|44|45|56) (reverse .results|44|48|56) (begin #t (.loop|49|52|55 (let ((.x|60|63 .y1|44|45|56)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))) (cons (let ((.var|64 (let ((.x|94|97 .y1|44|45|56)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) (cons .var|64 (let () (let ((.loop|70|73|76 (unspecified))) (begin (set! .loop|70|73|76 (lambda (.y1|65|66|77 .results|65|69|77) (if (null? .y1|65|66|77) (reverse .results|65|69|77) (begin #t (.loop|70|73|76 (let ((.x|81|84 .y1|65|66|77)) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84))) (cons (let* ((.answer|85 (let ((.x|90|93 .y1|65|66|77)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (.x|86|89 (assq .var|64 .answer|85))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))) .results|65|69|77)))))) (.loop|70|73|76 .answers|39 '())))))) .results|44|48|56)))))) (.loop|49|52|55 (ellipsis-pattern-vars .p|5) '())))) .answer|5) #f))))))) (set! .match|4 (lambda (.f|123 .p|123 .answer|123 .rank|123) (if (null? .p|123) (if (null? .f|123) .answer|123 #f) (if (pair? .p|123) (if (pair? .f|123) (let ((.answer|132 (.match|4 (let ((.x|143|146 .f|123)) (begin (.check! (pair? .x|143|146) 0 .x|143|146) (car:pair .x|143|146))) (let ((.x|147|150 .p|123)) (begin (.check! (pair? .x|147|150) 0 .x|147|150) (car:pair .x|147|150))) .answer|123 .rank|123))) (if .answer|132 (.match|4 (let ((.x|135|138 .f|123)) (begin (.check! (pair? .x|135|138) 1 .x|135|138) (cdr:pair .x|135|138))) (let ((.x|139|142 .p|123)) (begin (.check! (pair? .x|139|142) 1 .x|139|142) (cdr:pair .x|139|142))) .answer|132 .rank|123) #f)) #f) (if (symbol? .p|123) (if (symbol? .f|123) (if (same-denotation? (syntactic-lookup .env-def|3 .p|123) (syntactic-lookup .env-use|3 .f|123)) .answer|123 #f) #f) (if (patternvar? .p|123) (cons (cons .p|123 .f|123) .answer|123) (if (ellipsis-pattern? .p|123) (.match1|4 .f|123 .p|123 .answer|123 (+ .rank|123 1)) (if (vector? .p|123) (if (vector? .f|123) (.match|4 (vector->list .f|123) (let ((.v|160|163 .p|123) (.i|160|163 0)) (begin (.check! (fixnum? .i|160|163) 40 .v|160|163 .i|160|163) (.check! (vector? .v|160|163) 40 .v|160|163 .i|160|163) (.check! (<:fix:fix .i|160|163 (vector-length:vec .v|160|163)) 40 .v|160|163 .i|160|163) (.check! (>=:fix:fix .i|160|163 0) 40 .v|160|163 .i|160|163) (vector-ref:trusted .v|160|163 .i|160|163))) .answer|123 .rank|123) #f) (if (equal? .f|123 .p|123) .answer|123 #f))))))))) (.match|4 .f|3 .p|3 empty-pattern-variable-environment 0))))) (.m-match|2 .f|1 .p|1 .env-def|1 .env-use|1))))) 'm-match))
+(let () (begin (set! m-rewrite (lambda (.t|1 .alist|1) (let ((.m-rewrite|2 0)) (begin (set! .m-rewrite|2 (lambda (.t|3 .alist|3) (let ((.make-columns|4 (unspecified)) (.rewrite1|4 (unspecified)) (.rewrite|4 (unspecified))) (begin (set! .make-columns|4 (lambda (.vars|5 .rows|5 .alist|5) (let ((.loop|6 (unspecified))) (begin (set! .loop|6 (lambda (.rows|7) (if (null? (let ((.x|8|11 .rows|7)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) '() (cons (append (let () (let ((.loop|18|22|25 (unspecified))) (begin (set! .loop|18|22|25 (lambda (.y1|12|14|26 .y1|12|13|26 .results|12|17|26) (if (let ((.temp|28|31 (null? .y1|12|14|26))) (if .temp|28|31 .temp|28|31 (null? .y1|12|13|26))) (reverse .results|12|17|26) (begin #t (.loop|18|22|25 (let ((.x|34|37 .y1|12|14|26)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) (let ((.x|38|41 .y1|12|13|26)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (cons (let ((.var|42 (let ((.x|47|50 .y1|12|14|26)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) (.row|42 (let ((.x|51|54 .y1|12|13|26)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))))) (cons .var|42 (let ((.x|43|46 .row|42)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) .results|12|17|26)))))) (.loop|18|22|25 .vars|5 .rows|7 '())))) .alist|5) (.loop|6 (let () (let ((.loop|60|63|66 (unspecified))) (begin (set! .loop|60|63|66 (lambda (.y1|55|56|67 .results|55|59|67) (if (null? .y1|55|56|67) (reverse .results|55|59|67) (begin #t (.loop|60|63|66 (let ((.x|71|74 .y1|55|56|67)) (begin (.check! (pair? .x|71|74) 1 .x|71|74) (cdr:pair .x|71|74))) (cons (let ((.x|75|78 (let ((.x|79|82 .y1|55|56|67)) (begin (.check! (pair? .x|79|82) 0 .x|79|82) (car:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 1 .x|75|78) (cdr:pair .x|75|78))) .results|55|59|67)))))) (.loop|60|63|66 .rows|7 '()))))))))) (if (let ((.temp|83|86 (null? (let ((.x|112|115 .rows|5)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115)))))) (if .temp|83|86 .temp|83|86 (apply = (let () (let ((.loop|93|96|99 (unspecified))) (begin (set! .loop|93|96|99 (lambda (.y1|88|89|100 .results|88|92|100) (if (null? .y1|88|89|100) (reverse .results|88|92|100) (begin #t (.loop|93|96|99 (let ((.x|104|107 .y1|88|89|100)) (begin (.check! (pair? .x|104|107) 1 .x|104|107) (cdr:pair .x|104|107))) (cons (length (let ((.x|108|111 .y1|88|89|100)) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111)))) .results|88|92|100)))))) (.loop|93|96|99 .rows|5 '()))))))) (.loop|6 .rows|5) (m-error "Use of macro is not consistent with definition" .vars|5 .rows|5)))))) (set! .rewrite1|4 (lambda (.t|116 .alist|116 .rank|116) (let* ((.t1|119 (ellipsis-template .t|116)) (.vars|122 (ellipsis-template-vars .t|116)) (.rows|125 (let () (let ((.loop|159|162|165 (unspecified))) (begin (set! .loop|159|162|165 (lambda (.y1|154|155|166 .results|154|158|166) (if (null? .y1|154|155|166) (reverse .results|154|158|166) (begin #t (.loop|159|162|165 (let ((.x|170|173 .y1|154|155|166)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))) (cons (let* ((.var|174 (let ((.x|179|182 .y1|154|155|166)) (begin (.check! (pair? .x|179|182) 0 .x|179|182) (car:pair .x|179|182)))) (.x|175|178 (assq .var|174 .alist|116))) (begin (.check! (pair? .x|175|178) 1 .x|175|178) (cdr:pair .x|175|178))) .results|154|158|166)))))) (.loop|159|162|165 .vars|122 '())))))) (let () (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (let ((.alist|149 (let ((.x|150|153 .y1|129|130|141)) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))))) (.rewrite|4 .t1|119 .alist|149 .rank|116)) .results|129|133|141)))))) (.loop|134|137|140 (.make-columns|4 .vars|122 .rows|125 .alist|116) '())))))))) (set! .rewrite|4 (lambda (.t|183 .alist|183 .rank|183) (if (null? .t|183) '() (if (pair? .t|183) ((if (ellipsis-pattern? (let ((.x|186|189 .t|183)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) append cons) (.rewrite|4 (let ((.x|190|193 .t|183)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))) .alist|183 .rank|183) (.rewrite|4 (let ((.x|194|197 .t|183)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) .alist|183 .rank|183)) (if (symbol? .t|183) (let ((.x|199|202 (assq .t|183 .alist|183))) (begin (.check! (pair? .x|199|202) 1 .x|199|202) (cdr:pair .x|199|202))) (if (patternvar? .t|183) (let ((.x|204|207 (assq .t|183 .alist|183))) (begin (.check! (pair? .x|204|207) 1 .x|204|207) (cdr:pair .x|204|207))) (if (ellipsis-template? .t|183) (.rewrite1|4 .t|183 .alist|183 (+ .rank|183 1)) (if (vector? .t|183) (list->vector (.rewrite|4 (let ((.v|210|213 .t|183) (.i|210|213 0)) (begin (.check! (fixnum? .i|210|213) 40 .v|210|213 .i|210|213) (.check! (vector? .v|210|213) 40 .v|210|213 .i|210|213) (.check! (<:fix:fix .i|210|213 (vector-length:vec .v|210|213)) 40 .v|210|213 .i|210|213) (.check! (>=:fix:fix .i|210|213 0) 40 .v|210|213 .i|210|213) (vector-ref:trusted .v|210|213 .i|210|213))) .alist|183 .rank|183)) .t|183)))))))) (.rewrite|4 .t|3 .alist|3 0))))) (.m-rewrite|2 .t|1 .alist|1))))) 'm-rewrite))
+(let () (begin (set! m-transcribe0 (lambda (.exp|1 .env-use|1 .k|1 .inline?|1) (let ((.m-transcribe0|2 0)) (begin (set! .m-transcribe0|2 (lambda (.exp|3 .env-use|3 .k|3 .inline?|3) (let* ((.m|6 (syntactic-lookup .env-use|3 (let ((.x|86|89 .exp|3)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89))))) (.rules|9 (macro-rules .m|6)) (.env-def|12 (macro-env .m|6)) (.f|15 (let ((.x|82|85 .exp|3)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (let () (let ((.loop|19 (unspecified))) (begin (set! .loop|19 (lambda (.rules|20) (if (null? .rules|20) (if .inline?|3 (.k|3 .exp|3 .env-use|3) (m-error "Use of macro does not match definition" .exp|3)) (let* ((.rule|23 (let ((.x|78|81 .rules|20)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.pattern|26 (let ((.x|74|77 .rule|23)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) (.alist|29 (m-match .f|15 .pattern|26 .env-def|12 .env-use|3))) (let () (if .alist|29 (let* ((.template|35 (let ((.x|62|65 (let ((.x|66|69 .rule|23)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (.inserted|38 (let ((.x|49|52 (let ((.x|53|56 (let ((.x|57|60 .rule|23)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60))))) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))))) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52)))) (.alist2|41 (rename-vars .inserted|38)) (.newexp|44 (m-rewrite .template|35 (append .alist2|41 .alist|29)))) (let () (.k|3 .newexp|44 (syntactic-alias .env-use|3 .alist2|41 .env-def|12)))) (.loop|19 (let ((.x|70|73 .rules|20)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73)))))))))) (if (procedure? .rules|9) (m-transcribe-low-level .exp|3 .env-use|3 .k|3 .rules|9 .env-def|12) (.loop|19 .rules|9)))))))) (.m-transcribe0|2 .exp|1 .env-use|1 .k|1 .inline?|1))))) 'm-transcribe0))
+(let () (begin (set! m-transcribe (lambda (.exp|1 .env-use|1 .k|1) (let ((.m-transcribe|2 0)) (begin (set! .m-transcribe|2 (lambda (.exp|3 .env-use|3 .k|3) (m-transcribe0 .exp|3 .env-use|3 .k|3 #f))) (.m-transcribe|2 .exp|1 .env-use|1 .k|1))))) 'm-transcribe))
+(let () (begin (set! m-transcribe-inline (lambda (.exp|1 .env-use|1 .k|1) (let ((.m-transcribe-inline|2 0)) (begin (set! .m-transcribe-inline|2 (lambda (.exp|3 .env-use|3 .k|3) (m-transcribe0 .exp|3 .env-use|3 .k|3 #t))) (.m-transcribe-inline|2 .exp|1 .env-use|1 .k|1))))) 'm-transcribe-inline))
+(let () ($$trace "lowlevel"))
+(let () (begin (set! m-transcribe-low-level (lambda (.exp|1 .env-use|1 .k|1 .transformer|1 .env-def|1) (let ((.m-transcribe-low-level|2 0)) (begin (set! .m-transcribe-low-level|2 (lambda (.exp|3 .env-use|3 .k|3 .transformer|3 .env-def|3) (let ((.rename0|6 (make-rename-procedure)) (.renamed|6 '()) (.ok|6 #t)) (let ((.lookup|9 (unspecified))) (begin (set! .lookup|9 (lambda (.sym|10) (let ((.alist|13 .renamed|6)) (let () (let ((.loop|16 (unspecified))) (begin (set! .loop|16 (lambda (.alist|17) (if (null? .alist|17) (syntactic-lookup .env-use|3 .sym|10) (if (eq? .sym|10 (let ((.x|20|23 (let ((.x|24|27 .alist|17)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) (syntactic-lookup .env-def|3 (let ((.x|28|31 (let ((.x|32|35 .alist|17)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))))) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.loop|16 (let ((.x|37|40 .alist|17)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))))))) (.loop|16 .alist|13))))))) (let ((.rename|41 (lambda (.sym|45) (if .ok|6 (let ((.probe|48 (assq .sym|45 .renamed|6))) (if .probe|48 (let ((.x|49|52 .probe|48)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.sym2|55 (.rename0|6 .sym|45))) (begin (set! .renamed|6 (cons (cons .sym|45 .sym2|55) .renamed|6)) .sym2|55)))) (m-error "Illegal use of a rename procedure" .sym|45)))) (.compare|41 (lambda (.sym1|56 .sym2|56) (same-denotation? (.lookup|9 .sym1|56) (.lookup|9 .sym2|56))))) (let ((.exp2|44 (.transformer|3 .exp|3 .rename|41 .compare|41))) (begin (set! .ok|6 #f) (.k|3 .exp2|44 (syntactic-alias .env-use|3 .renamed|6 .env-def|3)))))))))) (.m-transcribe-low-level|2 .exp|1 .env-use|1 .k|1 .transformer|1 .env-def|1))))) 'm-transcribe-low-level))
+(let () (begin (set! identifier? symbol?) 'identifier?))
+(let () (begin (set! identifier->symbol (lambda (.id|1) (let ((.identifier->symbol|2 0)) (begin (set! .identifier->symbol|2 (lambda (.id|3) (m-strip .id|3))) (.identifier->symbol|2 .id|1))))) 'identifier->symbol))
+(let () ($$trace "expand"))
+(let () (begin (set! define-syntax-scope (let ((.flag|3 'letrec)) (lambda .args|4 (if (null? .args|4) .flag|3 (if (not (null? (let ((.x|7|10 .args|4)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))))) (apply m-warn "Too many arguments passed to define-syntax-scope" .args|4) (if (let ((.t0|12|13|16 (let ((.x|42|45 .args|4)) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45)))) (.t1|12|13|16 '(letrec letrec* let*))) (if (eq? .t0|12|13|16 'letrec) .t1|12|13|16 (let ((.t1|12|13|20 (let ((.x|38|41 .t1|12|13|16)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))))) (if (eq? .t0|12|13|16 'letrec*) .t1|12|13|20 (let ((.t1|12|13|24 (let ((.x|34|37 .t1|12|13|20)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (if (eq? .t0|12|13|16 'let*) .t1|12|13|24 (let ((.t1|12|13|28 (let ((.x|30|33 .t1|12|13|24)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) #f))))))) (set! .flag|3 (let ((.x|46|49 .args|4)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))) (m-warn "Unrecognized argument to define-syntax-scope" (let ((.x|51|54 .args|4)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))))))))) 'define-syntax-scope))
+(let () (begin (set! macro-expand (lambda (.def-or-exp|1) (let ((.macro-expand|2 0)) (begin (set! .macro-expand|2 (lambda (.def-or-exp|3) (call-with-current-continuation (lambda (.k|4) (begin (set! m-quit .k|4) (set! renaming-counter 0) (make-call (make-lambda '() '() '() '() '() '() #f (desugar-definitions .def-or-exp|3 global-syntactic-environment make-toplevel-definition)) '())))))) (.macro-expand|2 .def-or-exp|1))))) 'macro-expand))
+(let () (begin (set! desugar-definitions (lambda (.exp|1 .env|1 .make-toplevel-definition|1) (let ((.desugar-definitions|2 0)) (begin (set! .desugar-definitions|2 (lambda (.exp|3 .env|3 .make-toplevel-definition|3) (let () (let ((.redefinition|6 (unspecified)) (.desugar-define|6 (unspecified)) (.define-syntax-loop|6 (unspecified)) (.define-loop|6 (unspecified))) (begin (set! .redefinition|6 (lambda (.id|7) (if (symbol? .id|7) (if (not (identifier-denotation? (syntactic-lookup global-syntactic-environment .id|7))) (if (issue-warnings) (m-warn "Redefining " .id|7) (unspecified)) (unspecified)) (m-error "Malformed variable or keyword" .id|7)))) (set! .desugar-define|6 (lambda (.exp|8 .env|8) (if (null? (let ((.x|10|13 .exp|8)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) (m-error "Malformed definition" .exp|8) (if (null? (let ((.x|16|19 (let ((.x|20|23 .exp|8)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.id|26 (let ((.x|33|36 (let ((.x|37|40 .exp|8)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (if (let ((.temp|27|30 (null? pass1-block-inlines))) (if .temp|27|30 .temp|27|30 (not (memq .id|26 pass1-block-inlines)))) (begin (.redefinition|6 .id|26) (syntactic-bind-globally! .id|26 (make-identifier-denotation .id|26))) (unspecified)) (.make-toplevel-definition|3 .id|26 (make-undefined)))) (if (pair? (let ((.x|43|46 (let ((.x|47|50 .exp|8)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) (.desugar-define|6 (let* ((.def|53 (let ((.x|343|346 .exp|8)) (begin (.check! (pair? .x|343|346) 0 .x|343|346) (car:pair .x|343|346)))) (.pattern|56 (let ((.x|335|338 (let ((.x|339|342 .exp|8)) (begin (.check! (pair? .x|339|342) 1 .x|339|342) (cdr:pair .x|339|342))))) (begin (.check! (pair? .x|335|338) 0 .x|335|338) (car:pair .x|335|338)))) (.f|59 (let ((.x|330|333 .pattern|56)) (begin (.check! (pair? .x|330|333) 0 .x|330|333) (car:pair .x|330|333)))) (.args|62 (let ((.x|326|329 .pattern|56)) (begin (.check! (pair? .x|326|329) 1 .x|326|329) (cdr:pair .x|326|329)))) (.body|65 (let ((.x|318|321 (let ((.x|322|325 .exp|8)) (begin (.check! (pair? .x|322|325) 1 .x|322|325) (cdr:pair .x|322|325))))) (begin (.check! (pair? .x|318|321) 1 .x|318|321) (cdr:pair .x|318|321))))) (let () (if (if (symbol? (let ((.x|70|73 (let ((.x|75|78 (let ((.x|79|82 .exp|8)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))))) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) (if (benchmark-mode) (list? (let ((.x|86|89 (let ((.x|90|93 .exp|8)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89)))) #f) #f) (.cons .def|53 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 (.cons (.cons (.cons lambda0 (.cons (.cons .f|59 '()) (.cons (.cons set!0 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 .body|65)) '()))) (.cons .pattern|56 '())))) '(0)) '()))) '()))) (.cons .def|53 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 .body|65)) '())))))) .env|8) (if (> (length .exp|8) 3) (m-error "Malformed definition" .exp|8) (let ((.id|351 (let ((.x|371|374 (let ((.x|375|378 .exp|8)) (begin (.check! (pair? .x|375|378) 1 .x|375|378) (cdr:pair .x|375|378))))) (begin (.check! (pair? .x|371|374) 0 .x|371|374) (car:pair .x|371|374))))) (begin (if (let ((.temp|352|355 (null? pass1-block-inlines))) (if .temp|352|355 .temp|352|355 (not (memq .id|351 pass1-block-inlines)))) (begin (.redefinition|6 .id|351) (syntactic-bind-globally! .id|351 (make-identifier-denotation .id|351))) (unspecified)) (.make-toplevel-definition|3 .id|351 (m-expand (let ((.x|358|361 (let ((.x|362|365 (let ((.x|366|369 .exp|8)) (begin (.check! (pair? .x|366|369) 1 .x|366|369) (cdr:pair .x|366|369))))) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))))) (begin (.check! (pair? .x|358|361) 0 .x|358|361) (car:pair .x|358|361))) .env|8)))))))))) (set! .define-syntax-loop|6 (lambda (.exp|379 .rest|379 .env|379) (if (if (pair? .exp|379) (if (symbol? (let ((.x|383|386 .exp|379)) (begin (.check! (pair? .x|383|386) 0 .x|383|386) (car:pair .x|383|386)))) (if (eq? (syntactic-lookup .env|379 (let ((.x|388|391 .exp|379)) (begin (.check! (pair? .x|388|391) 0 .x|388|391) (car:pair .x|388|391)))) denotation-of-begin) (pair? (let ((.x|393|396 .exp|379)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396)))) #f) #f) #f) (.define-syntax-loop|6 (let ((.x|398|401 (let ((.x|402|405 .exp|379)) (begin (.check! (pair? .x|402|405) 1 .x|402|405) (cdr:pair .x|402|405))))) (begin (.check! (pair? .x|398|401) 0 .x|398|401) (car:pair .x|398|401))) (append (let ((.x|407|410 (let ((.x|411|414 .exp|379)) (begin (.check! (pair? .x|411|414) 1 .x|411|414) (cdr:pair .x|411|414))))) (begin (.check! (pair? .x|407|410) 1 .x|407|410) (cdr:pair .x|407|410))) .rest|379) .env|379) (if (if (pair? .exp|379) (if (symbol? (let ((.x|418|421 .exp|379)) (begin (.check! (pair? .x|418|421) 0 .x|418|421) (car:pair .x|418|421)))) (eq? (syntactic-lookup .env|379 (let ((.x|423|426 .exp|379)) (begin (.check! (pair? .x|423|426) 0 .x|423|426) (car:pair .x|423|426)))) denotation-of-define-syntax) #f) #f) (begin (if (pair? (let ((.x|427|430 .exp|379)) (begin (.check! (pair? .x|427|430) 1 .x|427|430) (cdr:pair .x|427|430)))) (.redefinition|6 (let ((.x|432|435 (let ((.x|436|439 .exp|379)) (begin (.check! (pair? .x|436|439) 1 .x|436|439) (cdr:pair .x|436|439))))) (begin (.check! (pair? .x|432|435) 0 .x|432|435) (car:pair .x|432|435)))) (unspecified)) (if (null? .rest|379) (m-define-syntax .exp|379 .env|379) (begin (m-define-syntax .exp|379 .env|379) (.define-syntax-loop|6 (let ((.x|440|443 .rest|379)) (begin (.check! (pair? .x|440|443) 0 .x|440|443) (car:pair .x|440|443))) (let ((.x|444|447 .rest|379)) (begin (.check! (pair? .x|444|447) 1 .x|444|447) (cdr:pair .x|444|447))) .env|379)))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|451|454 .exp|379)) (begin (.check! (pair? .x|451|454) 0 .x|451|454) (car:pair .x|451|454)))) (eq? (syntactic-lookup .env|379 (let ((.x|456|459 .exp|379)) (begin (.check! (pair? .x|456|459) 0 .x|456|459) (car:pair .x|456|459)))) denotation-of-define-inline) #f) #f) (begin (if (pair? (let ((.x|460|463 .exp|379)) (begin (.check! (pair? .x|460|463) 1 .x|460|463) (cdr:pair .x|460|463)))) (.redefinition|6 (let ((.x|465|468 (let ((.x|469|472 .exp|379)) (begin (.check! (pair? .x|469|472) 1 .x|469|472) (cdr:pair .x|469|472))))) (begin (.check! (pair? .x|465|468) 0 .x|465|468) (car:pair .x|465|468)))) (unspecified)) (if (null? .rest|379) (m-define-inline .exp|379 .env|379) (begin (m-define-inline .exp|379 .env|379) (.define-syntax-loop|6 (let ((.x|473|476 .rest|379)) (begin (.check! (pair? .x|473|476) 0 .x|473|476) (car:pair .x|473|476))) (let ((.x|477|480 .rest|379)) (begin (.check! (pair? .x|477|480) 1 .x|477|480) (cdr:pair .x|477|480))) .env|379)))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|484|487 .exp|379)) (begin (.check! (pair? .x|484|487) 0 .x|484|487) (car:pair .x|484|487)))) (macro-denotation? (syntactic-lookup .env|379 (let ((.x|489|492 .exp|379)) (begin (.check! (pair? .x|489|492) 0 .x|489|492) (car:pair .x|489|492))))) #f) #f) (m-transcribe .exp|379 .env|379 (lambda (.exp|493 .env|493) (.define-syntax-loop|6 .exp|493 .rest|379 .env|493))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|497|500 .exp|379)) (begin (.check! (pair? .x|497|500) 0 .x|497|500) (car:pair .x|497|500)))) (eq? (syntactic-lookup .env|379 (let ((.x|502|505 .exp|379)) (begin (.check! (pair? .x|502|505) 0 .x|502|505) (car:pair .x|502|505)))) denotation-of-define) #f) #f) (.define-loop|6 .exp|379 .rest|379 '() .env|379) (if (null? .rest|379) (m-expand .exp|379 .env|379) (make-begin (let () (let ((.loop|513|516|519 (unspecified))) (begin (set! .loop|513|516|519 (lambda (.y1|508|509|520 .results|508|512|520) (if (null? .y1|508|509|520) (reverse .results|508|512|520) (begin #t (.loop|513|516|519 (let ((.x|524|527 .y1|508|509|520)) (begin (.check! (pair? .x|524|527) 1 .x|524|527) (cdr:pair .x|524|527))) (cons (let ((.exp|528 (let ((.x|529|532 .y1|508|509|520)) (begin (.check! (pair? .x|529|532) 0 .x|529|532) (car:pair .x|529|532))))) (m-expand .exp|528 .env|379)) .results|508|512|520)))))) (.loop|513|516|519 (cons .exp|379 .rest|379) '()))))))))))))) (set! .define-loop|6 (lambda (.exp|533 .rest|533 .first|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|537|540 .exp|533)) (begin (.check! (pair? .x|537|540) 0 .x|537|540) (car:pair .x|537|540)))) (if (eq? (syntactic-lookup .env|533 (let ((.x|542|545 .exp|533)) (begin (.check! (pair? .x|542|545) 0 .x|542|545) (car:pair .x|542|545)))) denotation-of-begin) (pair? (let ((.x|547|550 .exp|533)) (begin (.check! (pair? .x|547|550) 1 .x|547|550) (cdr:pair .x|547|550)))) #f) #f) #f) (.define-loop|6 (let ((.x|552|555 (let ((.x|556|559 .exp|533)) (begin (.check! (pair? .x|556|559) 1 .x|556|559) (cdr:pair .x|556|559))))) (begin (.check! (pair? .x|552|555) 0 .x|552|555) (car:pair .x|552|555))) (append (let ((.x|561|564 (let ((.x|565|568 .exp|533)) (begin (.check! (pair? .x|565|568) 1 .x|565|568) (cdr:pair .x|565|568))))) (begin (.check! (pair? .x|561|564) 1 .x|561|564) (cdr:pair .x|561|564))) .rest|533) .first|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|572|575 .exp|533)) (begin (.check! (pair? .x|572|575) 0 .x|572|575) (car:pair .x|572|575)))) (eq? (syntactic-lookup .env|533 (let ((.x|577|580 .exp|533)) (begin (.check! (pair? .x|577|580) 0 .x|577|580) (car:pair .x|577|580)))) denotation-of-define) #f) #f) (let ((.exp|583 (.desugar-define|6 .exp|533 .env|533))) (if (if (null? .first|533) (null? .rest|533) #f) .exp|583 (if (null? .rest|533) (make-begin (reverse (cons .exp|583 .first|533))) (.define-loop|6 (let ((.x|589|592 .rest|533)) (begin (.check! (pair? .x|589|592) 0 .x|589|592) (car:pair .x|589|592))) (let ((.x|593|596 .rest|533)) (begin (.check! (pair? .x|593|596) 1 .x|593|596) (cdr:pair .x|593|596))) (cons .exp|583 .first|533) .env|533)))) (if (if (pair? .exp|533) (if (symbol? (let ((.x|600|603 .exp|533)) (begin (.check! (pair? .x|600|603) 0 .x|600|603) (car:pair .x|600|603)))) (if (let ((.temp|605|608 (eq? (syntactic-lookup .env|533 (let ((.x|614|617 .exp|533)) (begin (.check! (pair? .x|614|617) 0 .x|614|617) (car:pair .x|614|617)))) denotation-of-define-syntax))) (if .temp|605|608 .temp|605|608 (eq? (syntactic-lookup .env|533 (let ((.x|610|613 .exp|533)) (begin (.check! (pair? .x|610|613) 0 .x|610|613) (car:pair .x|610|613)))) denotation-of-define-inline))) (null? .first|533) #f) #f) #f) (.define-syntax-loop|6 .exp|533 .rest|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|622|625 .exp|533)) (begin (.check! (pair? .x|622|625) 0 .x|622|625) (car:pair .x|622|625)))) (macro-denotation? (syntactic-lookup .env|533 (let ((.x|627|630 .exp|533)) (begin (.check! (pair? .x|627|630) 0 .x|627|630) (car:pair .x|627|630))))) #f) #f) (m-transcribe .exp|533 .env|533 (lambda (.exp|631 .env|631) (.define-loop|6 .exp|631 .rest|533 .first|533 .env|631))) (if (if (null? .first|533) (null? .rest|533) #f) (m-expand .exp|533 .env|533) (if (null? .rest|533) (make-begin (reverse (cons (m-expand .exp|533 .env|533) .first|533))) (make-begin (append (reverse .first|533) (let () (let ((.loop|642|645|648 (unspecified))) (begin (set! .loop|642|645|648 (lambda (.y1|637|638|649 .results|637|641|649) (if (null? .y1|637|638|649) (reverse .results|637|641|649) (begin #t (.loop|642|645|648 (let ((.x|653|656 .y1|637|638|649)) (begin (.check! (pair? .x|653|656) 1 .x|653|656) (cdr:pair .x|653|656))) (cons (let ((.exp|657 (let ((.x|658|661 .y1|637|638|649)) (begin (.check! (pair? .x|658|661) 0 .x|658|661) (car:pair .x|658|661))))) (m-expand .exp|657 .env|533)) .results|637|641|649)))))) (.loop|642|645|648 (cons .exp|533 .rest|533) '())))))))))))))) (.define-loop|6 .exp|3 '() '() .env|3)))))) (.desugar-definitions|2 .exp|1 .env|1 .make-toplevel-definition|1))))) 'desugar-definitions))
+(let () (begin (set! m-expand (lambda (.exp|1 .env|1) (let ((.m-expand|2 0)) (begin (set! .m-expand|2 (lambda (.exp|3 .env|3) (if (not (pair? .exp|3)) (m-atom .exp|3 .env|3) (if (not (symbol? (let ((.x|6|9 .exp|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))))) (m-application .exp|3 .env|3) (let* ((.keyword|13 (syntactic-lookup .env|3 (let ((.x|41|44 .exp|3)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (.temp|14|17 (denotation-class .keyword|13))) (if (memv .temp|14|17 '(special)) (if (eq? .keyword|13 denotation-of-quote) (m-quote .exp|3) (if (eq? .keyword|13 denotation-of-lambda) (m-lambda .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-if) (m-if .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-set!) (m-set .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-begin) (m-begin .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-let-syntax) (m-let-syntax .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-letrec-syntax) (m-letrec-syntax .exp|3 .env|3) (if (let ((.temp|27|30 (eq? .keyword|13 denotation-of-define))) (if .temp|27|30 .temp|27|30 (let ((.temp|31|34 (eq? .keyword|13 denotation-of-define-syntax))) (if .temp|31|34 .temp|31|34 (eq? .keyword|13 denotation-of-define-inline))))) (m-error "Definition out of context" .exp|3) (m-bug "Bug detected in m-expand" .exp|3 .env|3))))))))) (if (memv .temp|14|17 '(macro)) (m-macro .exp|3 .env|3) (if (memv .temp|14|17 '(inline)) (m-inline .exp|3 .env|3) (if (memv .temp|14|17 '(identifier)) (m-application .exp|3 .env|3) (m-bug "Bug detected in m-expand" .exp|3 .env|3)))))))))) (.m-expand|2 .exp|1 .env|1))))) 'm-expand))
+(let () (begin (set! m-atom (lambda (.exp|1 .env|1) (let ((.m-atom|2 0)) (begin (set! .m-atom|2 (lambda (.exp|3 .env|3) (if (not (symbol? .exp|3)) (begin (if (if (not (boolean? .exp|3)) (if (not (number? .exp|3)) (if (not (char? .exp|3)) (if (not (string? .exp|3)) (if (not (procedure? .exp|3)) (not (eq? .exp|3 (unspecified))) #f) #f) #f) #f) #f) (m-warn "Malformed constant -- should be quoted" .exp|3) (unspecified)) (make-constant .exp|3)) (let* ((.denotation|14 (syntactic-lookup .env|3 .exp|3)) (.temp|15|18 (denotation-class .denotation|14))) (if (memv .temp|15|18 '(special macro)) (begin (m-warn "Syntactic keyword used as a variable" .exp|3) (make-constant #t)) (if (memv .temp|15|18 '(inline)) (make-variable (inline-name .denotation|14)) (if (memv .temp|15|18 '(identifier)) (let ((.var|24 (make-variable (identifier-name .denotation|14))) (.r-entry|24 (identifier-r-entry .denotation|14))) (begin (r-entry.references-set! .r-entry|24 (cons .var|24 (r-entry.references .r-entry|24))) .var|24)) (m-bug "Bug detected by m-atom" .exp|3 .env|3)))))))) (.m-atom|2 .exp|1 .env|1))))) 'm-atom))
+(let () (begin (set! m-quote (lambda (.exp|1) (let ((.m-quote|2 0)) (begin (set! .m-quote|2 (lambda (.exp|3) (if (if (pair? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8)))) (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) #f) (make-constant (m-strip (let ((.x|20|23 (let ((.x|24|27 .exp|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (m-error "Malformed quoted constant" .exp|3)))) (.m-quote|2 .exp|1))))) 'm-quote))
+(let () (begin (set! m-lambda (lambda (.exp|1 .env|1) (let ((.m-lambda|2 0)) (begin (set! .m-lambda|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 2) (let* ((.formals|6 (let ((.x|242|245 (let ((.x|246|249 .exp|3)) (begin (.check! (pair? .x|246|249) 1 .x|246|249) (cdr:pair .x|246|249))))) (begin (.check! (pair? .x|242|245) 0 .x|242|245) (car:pair .x|242|245)))) (.alist|9 (rename-vars .formals|6)) (.env|12 (syntactic-rename .env|3 .alist|9)) (.body|15 (let ((.x|233|236 (let ((.x|237|240 .exp|3)) (begin (.check! (pair? .x|237|240) 1 .x|237|240) (cdr:pair .x|237|240))))) (begin (.check! (pair? .x|233|236) 1 .x|233|236) (cdr:pair .x|233|236))))) (let () (begin (let () (let ((.loop|20|22|25 (unspecified))) (begin (set! .loop|20|22|25 (lambda (.alist|26) (if (null? .alist|26) (if #f #f (unspecified)) (begin (begin #t (if (assq (let ((.x|30|33 (let ((.x|34|37 .alist|26)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|38|41 .alist|26)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))) (m-error "Malformed parameter list" .formals|6) (unspecified))) (.loop|20|22|25 (let ((.x|42|45 .alist|26)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))))))) (.loop|20|22|25 .alist|9)))) (if (if (not (list? .formals|6)) (> (length .alist|9) @maxargs-with-rest-arg@) #f) (let ((.temp|50 (let ((.x|195|198 (rename-vars '(temp)))) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))))) (.m-lambda|2 (.cons lambda0 (.cons .temp|50 (.cons (.cons (.cons lambda0 (.cons (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.x|140|143 (let ((.x|144|147 .y1|120|121|132)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 0 .x|140|143) (car:pair .x|140|143))) .results|120|124|132)))))) (.loop|125|128|131 .alist|9 '())))) (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 1 .x|149|152) (cdr:pair .x|149|152))))) (let () (let ((.loop|157|161|164 (unspecified))) (begin (set! .loop|157|161|164 (lambda (.actuals|165 .path|165 .formals|165) (if (symbol? .formals|165) (append (reverse .actuals|165) (cons .path|165 '())) (begin #t (.loop|157|161|164 (cons (let* ((.t1|169|172 name:car) (.t2|169|175 (cons .path|165 '()))) (let () (cons .t1|169|172 .t2|169|175))) .actuals|165) (let* ((.t1|180|183 name:cdr) (.t2|180|186 (cons .path|165 '()))) (let () (cons .t1|180|183 .t2|180|186))) (let ((.x|191|194 .formals|165)) (begin (.check! (pair? .x|191|194) 1 .x|191|194) (cdr:pair .x|191|194)))))))) (.loop|157|161|164 '() .temp|50 .formals|6))))) '()))) .env|12)) (make-lambda (rename-formals .formals|6 .alist|9) '() (let () (let ((.loop|204|207|210 (unspecified))) (begin (set! .loop|204|207|210 (lambda (.y1|199|200|211 .results|199|203|211) (if (null? .y1|199|200|211) (reverse .results|199|203|211) (begin #t (.loop|204|207|210 (let ((.x|215|218 .y1|199|200|211)) (begin (.check! (pair? .x|215|218) 1 .x|215|218) (cdr:pair .x|215|218))) (cons (let* ((.entry|219 (let ((.x|228|231 .y1|199|200|211)) (begin (.check! (pair? .x|228|231) 0 .x|228|231) (car:pair .x|228|231)))) (.x|220|223 (syntactic-lookup .env|12 (let ((.x|224|227 .entry|219)) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227)))))) (begin (.check! (pair? .x|220|223) 1 .x|220|223) (cdr:pair .x|220|223))) .results|199|203|211)))))) (.loop|204|207|210 .alist|9 '())))) '() '() '() (make-doc #f (if (list? .formals|6) (length .alist|9) (exact->inexact (- (length .alist|9) 1))) (if (include-variable-names) .formals|6 #f) (if (include-source-code) .exp|3 #f) source-file-name source-file-position) (m-body .body|15 .env|12)))))) (m-error "Malformed lambda expression" .exp|3)))) (.m-lambda|2 .exp|1 .env|1))))) 'm-lambda))
+(let () (begin (set! m-body (lambda (.body|1 .env|1) (let ((.m-body|2 0)) (begin (set! .m-body|2 (lambda (.body|3 .env|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.body|5 .env|5 .defs|5) (begin (if (null? .body|5) (m-error "Empty body") (unspecified)) (let ((.exp|8 (let ((.x|50|53 .body|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (if (pair? .exp|8) (symbol? (let ((.x|11|14 .exp|8)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) #f) (let* ((.denotation|17 (syntactic-lookup .env|5 (let ((.x|46|49 .exp|8)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))))) (.temp|18|21 (denotation-class .denotation|17))) (if (memv .temp|18|21 '(special)) (if (eq? .denotation|17 denotation-of-begin) (.loop|4 (append (let ((.x|24|27 .exp|8)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))) (let ((.x|28|31 .body|5)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31)))) .env|5 .defs|5) (if (eq? .denotation|17 denotation-of-define) (.loop|4 (let ((.x|33|36 .body|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))) .env|5 (cons .exp|8 .defs|5)) (finalize-body .body|5 .env|5 .defs|5))) (if (memv .temp|18|21 '(macro)) (m-transcribe .exp|8 .env|5 (lambda (.exp|39 .env|39) (.loop|4 (cons .exp|39 (let ((.x|40|43 .body|5)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43)))) .env|39 .defs|5))) (if (memv .temp|18|21 '(inline identifier)) (finalize-body .body|5 .env|5 .defs|5) (m-bug "Bug detected in m-body" .body|5 .env|5))))) (finalize-body .body|5 .env|5 .defs|5)))))) (.loop|4 .body|3 .env|3 '()))))) (.m-body|2 .body|1 .env|1))))) 'm-body))
+(let () (begin (set! finalize-body (lambda (.body|1 .env|1 .defs|1) (let ((.finalize-body|2 0)) (begin (set! .finalize-body|2 (lambda (.body|3 .env|3 .defs|3) (if (null? .defs|3) (let ((.body|6 (let () (let ((.loop|20|23|26 (unspecified))) (begin (set! .loop|20|23|26 (lambda (.y1|15|16|27 .results|15|19|27) (if (null? .y1|15|16|27) (reverse .results|15|19|27) (begin #t (.loop|20|23|26 (let ((.x|31|34 .y1|15|16|27)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) (cons (let ((.exp|35 (let ((.x|36|39 .y1|15|16|27)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (m-expand .exp|35 .env|3)) .results|15|19|27)))))) (.loop|20|23|26 .body|3 '())))))) (if (null? (let ((.x|7|10 .body|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (let ((.x|11|14 .body|6)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (make-begin .body|6))) (let () (let ((.expand-letrec|43 (unspecified)) (.desugar-definition|43 (unspecified)) (.sort-defs|43 (unspecified))) (begin (set! .expand-letrec|43 (lambda (.bindings|44 .body|44) (make-call (m-expand (.cons lambda0 (.cons (let () (let ((.loop|85|88|91 (unspecified))) (begin (set! .loop|85|88|91 (lambda (.y1|80|81|92 .results|80|84|92) (if (null? .y1|80|81|92) (reverse .results|80|84|92) (begin #t (.loop|85|88|91 (let ((.x|96|99 .y1|80|81|92)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))) (cons (let ((.x|100|103 (let ((.x|104|107 .y1|80|81|92)) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))))) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103))) .results|80|84|92)))))) (.loop|85|88|91 .bindings|44 '())))) (append (let () (let ((.loop|113|116|119 (unspecified))) (begin (set! .loop|113|116|119 (lambda (.y1|108|109|120 .results|108|112|120) (if (null? .y1|108|109|120) (reverse .results|108|112|120) (begin #t (.loop|113|116|119 (let ((.x|124|127 .y1|108|109|120)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.binding|128 (let ((.x|174|177 .y1|108|109|120)) (begin (.check! (pair? .x|174|177) 0 .x|174|177) (car:pair .x|174|177))))) (.cons set!0 (.cons (let ((.x|161|164 .binding|128)) (begin (.check! (pair? .x|161|164) 0 .x|161|164) (car:pair .x|161|164))) (.cons (let ((.x|166|169 (let ((.x|170|173 .binding|128)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))))) (begin (.check! (pair? .x|166|169) 0 .x|166|169) (car:pair .x|166|169))) '())))) .results|108|112|120)))))) (.loop|113|116|119 .bindings|44 '())))) .body|44))) .env|3) (let () (let ((.loop|183|186|189 (unspecified))) (begin (set! .loop|183|186|189 (lambda (.y1|178|179|190 .results|178|182|190) (if (null? .y1|178|179|190) (reverse .results|178|182|190) (begin #t (.loop|183|186|189 (let ((.x|194|197 .y1|178|179|190)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) (cons (let ((.binding|198 (let ((.x|199|202 .y1|178|179|190)) (begin (.check! (pair? .x|199|202) 0 .x|199|202) (car:pair .x|199|202))))) (make-unspecified)) .results|178|182|190)))))) (.loop|183|186|189 .bindings|44 '()))))))) (set! .desugar-definition|43 (lambda (.def|203) (if (> (safe-length .def|203) 2) (if (pair? (let ((.x|206|209 (let ((.x|210|213 .def|203)) (begin (.check! (pair? .x|210|213) 1 .x|210|213) (cdr:pair .x|210|213))))) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))) (.desugar-definition|43 (.cons (let ((.x|269|272 .def|203)) (begin (.check! (pair? .x|269|272) 0 .x|269|272) (car:pair .x|269|272))) (.cons (let ((.x|273|276 (let ((.x|278|281 (let ((.x|282|285 .def|203)) (begin (.check! (pair? .x|282|285) 1 .x|282|285) (cdr:pair .x|282|285))))) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281))))) (begin (.check! (pair? .x|273|276) 0 .x|273|276) (car:pair .x|273|276))) (.cons (.cons lambda0 (.cons (let ((.x|286|289 (let ((.x|291|294 (let ((.x|295|298 .def|203)) (begin (.check! (pair? .x|295|298) 1 .x|295|298) (cdr:pair .x|295|298))))) (begin (.check! (pair? .x|291|294) 0 .x|291|294) (car:pair .x|291|294))))) (begin (.check! (pair? .x|286|289) 1 .x|286|289) (cdr:pair .x|286|289))) (let ((.x|300|303 (let ((.x|304|307 .def|203)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))))) (begin (.check! (pair? .x|300|303) 1 .x|300|303) (cdr:pair .x|300|303))))) '())))) (if (if (= (length .def|203) 3) (symbol? (let ((.x|312|315 (let ((.x|316|319 .def|203)) (begin (.check! (pair? .x|316|319) 1 .x|316|319) (cdr:pair .x|316|319))))) (begin (.check! (pair? .x|312|315) 0 .x|312|315) (car:pair .x|312|315)))) #f) (let ((.x|320|323 .def|203)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) (m-error "Malformed definition" .def|203))) (m-error "Malformed definition" .def|203)))) (set! .sort-defs|43 (lambda (.defs|325) (let* ((.augmented|328 (let () (let ((.loop|382|385|388 (unspecified))) (begin (set! .loop|382|385|388 (lambda (.y1|377|378|389 .results|377|381|389) (if (null? .y1|377|378|389) (reverse .results|377|381|389) (begin #t (.loop|382|385|388 (let ((.x|393|396 .y1|377|378|389)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396))) (cons (let* ((.def|397 (let ((.x|420|423 .y1|377|378|389)) (begin (.check! (pair? .x|420|423) 0 .x|420|423) (car:pair .x|420|423)))) (.rhs|400 (let ((.x|412|415 (let ((.x|416|419 .def|397)) (begin (.check! (pair? .x|416|419) 1 .x|416|419) (cdr:pair .x|416|419))))) (begin (.check! (pair? .x|412|415) 0 .x|412|415) (car:pair .x|412|415))))) (if (not (pair? .rhs|400)) (cons 'trivial .def|397) (let ((.denotation|403 (syntactic-lookup .env|3 (let ((.x|407|410 .rhs|400)) (begin (.check! (pair? .x|407|410) 0 .x|407|410) (car:pair .x|407|410)))))) (if (eq? .denotation|403 denotation-of-lambda) (cons 'procedure .def|397) (if (eq? .denotation|403 denotation-of-quote) (cons 'trivial .def|397) (cons 'miscellaneous .def|397)))))) .results|377|381|389)))))) (.loop|382|385|388 .defs|325 '()))))) (.sorted|331 (twobit-sort (lambda (.x|363 .y|363) (let ((.temp|364|367 (eq? (let ((.x|373|376 .x|363)) (begin (.check! (pair? .x|373|376) 0 .x|373|376) (car:pair .x|373|376))) 'procedure))) (if .temp|364|367 .temp|364|367 (eq? (let ((.x|369|372 .y|363)) (begin (.check! (pair? .x|369|372) 0 .x|369|372) (car:pair .x|369|372))) 'miscellaneous)))) .augmented|328))) (let () (let () (let ((.loop|340|343|346 (unspecified))) (begin (set! .loop|340|343|346 (lambda (.y1|335|336|347 .results|335|339|347) (if (null? .y1|335|336|347) (reverse .results|335|339|347) (begin #t (.loop|340|343|346 (let ((.x|351|354 .y1|335|336|347)) (begin (.check! (pair? .x|351|354) 1 .x|351|354) (cdr:pair .x|351|354))) (cons (let ((.x|355|358 (let ((.x|359|362 .y1|335|336|347)) (begin (.check! (pair? .x|359|362) 0 .x|359|362) (car:pair .x|359|362))))) (begin (.check! (pair? .x|355|358) 1 .x|355|358) (cdr:pair .x|355|358))) .results|335|339|347)))))) (.loop|340|343|346 .sorted|331 '())))))))) (.expand-letrec|43 (.sort-defs|43 (let () (let ((.loop|429|432|435 (unspecified))) (begin (set! .loop|429|432|435 (lambda (.y1|424|425|436 .results|424|428|436) (if (null? .y1|424|425|436) (reverse .results|424|428|436) (begin #t (.loop|429|432|435 (let ((.x|440|443 .y1|424|425|436)) (begin (.check! (pair? .x|440|443) 1 .x|440|443) (cdr:pair .x|440|443))) (cons (.desugar-definition|43 (let ((.x|444|447 .y1|424|425|436)) (begin (.check! (pair? .x|444|447) 0 .x|444|447) (car:pair .x|444|447)))) .results|424|428|436)))))) (.loop|429|432|435 (reverse .defs|3) '()))))) .body|3))))))) (.finalize-body|2 .body|1 .env|1 .defs|1))))) 'finalize-body))
+(let () (begin (set! m-if (lambda (.exp|1 .env|1) (let ((.m-if|2 0)) (begin (set! .m-if|2 (lambda (.exp|3 .env|3) (let ((.n|6 (safe-length .exp|3))) (if (let ((.temp|7|10 (= .n|6 3))) (if .temp|7|10 .temp|7|10 (= .n|6 4))) (make-conditional (m-expand (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) .env|3) (m-expand (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))) .env|3) (if (= .n|6 3) (make-unspecified) (m-expand (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 (let ((.x|47|50 .exp|3)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))) .env|3))) (m-error "Malformed if expression" .exp|3))))) (.m-if|2 .exp|1 .env|1))))) 'm-if))
+(let () (begin (set! m-set (lambda (.exp|1 .env|1) (let ((.m-set|2 0)) (begin (set! .m-set|2 (lambda (.exp|3 .env|3) (if (= (safe-length .exp|3) 3) (let ((.lhs|6 (m-expand (let ((.x|28|31 (let ((.x|32|35 .exp|3)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))))) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) .env|3)) (.rhs|6 (m-expand (let ((.x|37|40 (let ((.x|41|44 (let ((.x|45|48 .exp|3)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))))) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))) .env|3))) (if (variable? .lhs|6) (let* ((.x|9 (variable.name .lhs|6)) (.assignment|12 (make-assignment .x|9 .rhs|6)) (.denotation|15 (syntactic-lookup .env|3 .x|9))) (let () (begin (if (identifier-denotation? .denotation|15) (let ((.r-entry|21 (identifier-r-entry .denotation|15))) (begin (r-entry.references-set! .r-entry|21 (remq .lhs|6 (r-entry.references .r-entry|21))) (r-entry.assignments-set! .r-entry|21 (cons .assignment|12 (r-entry.assignments .r-entry|21))))) (unspecified)) (if (if (lambda? .rhs|6) (include-procedure-names) #f) (let ((.doc|26 (lambda.doc .rhs|6))) (doc.name-set! .doc|26 .x|9)) (unspecified)) (if pass1-block-compiling? (set! pass1-block-assignments (cons .x|9 pass1-block-assignments)) (unspecified)) .assignment|12))) (m-error "Malformed assignment" .exp|3))) (m-error "Malformed assignment" .exp|3)))) (.m-set|2 .exp|1 .env|1))))) 'm-set))
+(let () (begin (set! m-begin (lambda (.exp|1 .env|1) (let ((.m-begin|2 0)) (begin (set! .m-begin|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 1) (make-begin (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.y1|5|6|17 .results|5|9|17) (if (null? .y1|5|6|17) (reverse .results|5|9|17) (begin #t (.loop|10|13|16 (let ((.x|21|24 .y1|5|6|17)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) (cons (let ((.exp|25 (let ((.x|26|29 .y1|5|6|17)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (m-expand .exp|25 .env|3)) .results|5|9|17)))))) (.loop|10|13|16 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) '()))))) (if (= (safe-length .exp|3) 1) (begin (m-warn "Non-standard begin expression" .exp|3) (make-unspecified)) (m-error "Malformed begin expression" .exp|3))))) (.m-begin|2 .exp|1 .env|1))))) 'm-begin))
+(let () (begin (set! m-application (lambda (.exp|1 .env|1) (let ((.m-application|2 0)) (begin (set! .m-application|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 0) (let* ((.proc|6 (m-expand (let ((.x|129|132 .exp|3)) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .env|3)) (.args|9 (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.exp|120 (let ((.x|121|124 .y1|100|101|112)) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))))) (m-expand .exp|120 .env|3)) .results|100|104|112)))))) (.loop|105|108|111 (let ((.x|125|128 .exp|3)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) '()))))) (.call|12 (make-call .proc|6 .args|9))) (let () (if (variable? .proc|6) (let* ((.procname|18 (variable.name .proc|6)) (.entry|21 (if (not (null? .args|9)) (if (constant? (let ((.x|57|60 .args|9)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60)))) (if (integrate-usual-procedures) (if (every1? constant? .args|9) (let ((.entry|66 (constant-folding-entry .procname|18))) (if .entry|66 (let ((.predicates|71 (constant-folding-predicates .entry|66))) (if (= (length .args|9) (length .predicates|71)) (let ((.args|76 .args|9) (.predicates|76 .predicates|71)) (let () (let ((.loop|79 (unspecified))) (begin (set! .loop|79 (lambda (.args|80 .predicates|80) (if (null? .args|80) .entry|66 (if ((let ((.x|83|86 .predicates|80)) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86))) (constant.value (let ((.x|87|90 .args|80)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (.loop|79 (let ((.x|91|94 .args|80)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (let ((.x|95|98 .predicates|80)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98)))) #f)))) (.loop|79 .args|76 .predicates|76))))) #f)) #f)) #f) #f) #f) #f))) (let () (if .entry|21 (make-constant (apply (constant-folding-folder .entry|21) (let () (let ((.loop|30|33|36 (unspecified))) (begin (set! .loop|30|33|36 (lambda (.y1|25|26|37 .results|25|29|37) (if (null? .y1|25|26|37) (reverse .results|25|29|37) (begin #t (.loop|30|33|36 (let ((.x|41|44 .y1|25|26|37)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))) (cons (constant.value (let ((.x|45|48 .y1|25|26|37)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48)))) .results|25|29|37)))))) (.loop|30|33|36 .args|9 '())))))) (let ((.denotation|51 (syntactic-lookup .env|3 .procname|18))) (begin (if (identifier-denotation? .denotation|51) (let ((.r-entry|54 (identifier-r-entry .denotation|51))) (r-entry.calls-set! .r-entry|54 (cons .call|12 (r-entry.calls .r-entry|54)))) (unspecified)) .call|12))))) .call|12))) (m-error "Malformed application" .exp|3)))) (.m-application|2 .exp|1 .env|1))))) 'm-application))
+(let () (begin (set! m-define-inline (lambda (.exp|1 .env|1) (let ((.m-define-inline|2 0)) (begin (set! .m-define-inline|2 (lambda (.exp|3 .env|3) (if (if (= (safe-length .exp|3) 3) (symbol? (let ((.x|8|11 (let ((.x|12|15 .exp|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) #f) (let ((.name|18 (let ((.x|36|39 (let ((.x|40|43 .exp|3)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (begin (m-define-syntax1 .name|18 (let ((.x|20|23 (let ((.x|24|27 (let ((.x|28|31 .exp|3)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))))) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) .env|3 (define-syntax-scope)) (let ((.denotation|34 (syntactic-lookup global-syntactic-environment .name|18))) (syntactic-bind-globally! .name|18 (make-inline-denotation .name|18 (macro-rules .denotation|34) (macro-env .denotation|34)))) (make-constant .name|18))) (m-error "Malformed define-inline" .exp|3)))) (.m-define-inline|2 .exp|1 .env|1))))) 'm-define-inline))
+(let () (begin (set! m-define-syntax (lambda (.exp|1 .env|1) (let ((.m-define-syntax|2 0)) (begin (set! .m-define-syntax|2 (lambda (.exp|3 .env|3) (if (if (= (safe-length .exp|3) 3) (symbol? (let ((.x|8|11 (let ((.x|12|15 .exp|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) #f) (m-define-syntax1 (let ((.x|17|20 (let ((.x|21|24 .exp|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))) (let ((.x|26|29 (let ((.x|30|33 (let ((.x|34|37 .exp|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) .env|3 (define-syntax-scope)) (if (if (= (safe-length .exp|3) 4) (if (symbol? (let ((.x|42|45 (let ((.x|46|49 .exp|3)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))))) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45)))) (let ((.t0|51|52|55 (let ((.x|82|85 (let ((.x|86|89 (let ((.x|90|93 .exp|3)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) (.t1|51|52|55 '(letrec letrec* let*))) (if (eq? .t0|51|52|55 'letrec) .t1|51|52|55 (let ((.t1|51|52|59 (let ((.x|77|80 .t1|51|52|55)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))))) (if (eq? .t0|51|52|55 'letrec*) .t1|51|52|59 (let ((.t1|51|52|63 (let ((.x|73|76 .t1|51|52|59)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (if (eq? .t0|51|52|55 'let*) .t1|51|52|63 (let ((.t1|51|52|67 (let ((.x|69|72 .t1|51|52|63)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) #f))))))) #f) #f) (m-define-syntax1 (let ((.x|95|98 (let ((.x|99|102 .exp|3)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))) (let ((.x|104|107 (let ((.x|108|111 (let ((.x|112|115 (let ((.x|116|119 .exp|3)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))))) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))))) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111))))) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))) .env|3 (let ((.x|121|124 (let ((.x|125|128 (let ((.x|129|132 .exp|3)) (begin (.check! (pair? .x|129|132) 1 .x|129|132) (cdr:pair .x|129|132))))) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))))) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124)))) (m-error "Malformed define-syntax" .exp|3))))) (.m-define-syntax|2 .exp|1 .env|1))))) 'm-define-syntax))
+(let () (begin (set! m-define-syntax1 (lambda (.keyword|1 .spec|1 .env|1 .scope|1) (let ((.m-define-syntax1|2 0)) (begin (set! .m-define-syntax1|2 (lambda (.keyword|3 .spec|3 .env|3 .scope|3) (begin (if (if (pair? .spec|3) (symbol? (let ((.x|6|9 .spec|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) #f) (let* ((.transformer-keyword|12 (let ((.x|39|42 .spec|3)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42)))) (.denotation|15 (syntactic-lookup .env|3 .transformer-keyword|12))) (let () (if (eq? .denotation|15 denotation-of-syntax-rules) (let ((.temp|20|23 .scope|3)) (if (memv .temp|20|23 '(letrec)) (m-define-syntax-letrec .keyword|3 .spec|3 .env|3) (if (memv .temp|20|23 '(letrec*)) (m-define-syntax-letrec* .keyword|3 .spec|3 .env|3) (if (memv .temp|20|23 '(let*)) (m-define-syntax-let* .keyword|3 .spec|3 .env|3) (m-bug "Weird scope" .scope|3))))) (if (same-denotation? .denotation|15 denotation-of-transformer) (syntactic-bind-globally! .keyword|3 (make-macro-denotation (eval (let ((.x|30|33 (let ((.x|34|37 .spec|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) .env|3)) (m-error "Malformed syntax transformer" .spec|3))))) (m-error "Malformed syntax transformer" .spec|3)) (make-constant .keyword|3)))) (.m-define-syntax1|2 .keyword|1 .spec|1 .env|1 .scope|1))))) 'm-define-syntax1))
+(let () (begin (set! m-define-syntax-letrec (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-letrec|2 0)) (begin (set! .m-define-syntax-letrec|2 (lambda (.keyword|3 .spec|3 .env|3) (syntactic-bind-globally! .keyword|3 (m-compile-transformer-spec .spec|3 .env|3)))) (.m-define-syntax-letrec|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-letrec))
+(let () (begin (set! m-define-syntax-letrec* (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-letrec*|2 0)) (begin (set! .m-define-syntax-letrec*|2 (lambda (.keyword|3 .spec|3 .env|3) (let* ((.env|6 (syntactic-extend (syntactic-copy .env|3) (cons .keyword|3 '()) '((fake denotation)))) (.transformer|9 (m-compile-transformer-spec .spec|3 .env|6))) (let () (begin (syntactic-assign! .env|6 .keyword|3 .transformer|9) (syntactic-bind-globally! .keyword|3 .transformer|9)))))) (.m-define-syntax-letrec*|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-letrec*))
+(let () (begin (set! m-define-syntax-let* (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-let*|2 0)) (begin (set! .m-define-syntax-let*|2 (lambda (.keyword|3 .spec|3 .env|3) (syntactic-bind-globally! .keyword|3 (m-compile-transformer-spec .spec|3 (syntactic-copy .env|3))))) (.m-define-syntax-let*|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-let*))
+(let () (begin (set! m-let-syntax (lambda (.exp|1 .env|1) (let ((.m-let-syntax|2 0)) (begin (set! .m-let-syntax|2 (lambda (.exp|3 .env|3) (if (if (> (safe-length .exp|3) 2) (every1? (lambda (.binding|6) (if (pair? .binding|6) (if (symbol? (let ((.x|9|12 .binding|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (if (pair? (let ((.x|14|17 .binding|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))) (null? (let ((.x|20|23 (let ((.x|24|27 .binding|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) #f) #f) #f)) (let ((.x|29|32 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) #f) (m-body (let ((.x|38|41 (let ((.x|42|45 .exp|3)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (syntactic-extend .env|3 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (let ((.x|66|69 (let ((.x|70|73 .y1|46|47|58)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69))) .results|46|50|58)))))) (.loop|51|54|57 (let ((.x|75|78 (let ((.x|79|82 .exp|3)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))) '())))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.y1|83|84|95 .results|83|87|95) (if (null? .y1|83|84|95) (reverse .results|83|87|95) (begin #t (.loop|88|91|94 (let ((.x|99|102 .y1|83|84|95)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (cons (let ((.spec|103 (let ((.x|104|107 .y1|83|84|95)) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))))) (m-compile-transformer-spec .spec|103 .env|3)) .results|83|87|95)))))) (.loop|88|91|94 (let () (let ((.loop|113|116|119 (unspecified))) (begin (set! .loop|113|116|119 (lambda (.y1|108|109|120 .results|108|112|120) (if (null? .y1|108|109|120) (reverse .results|108|112|120) (begin #t (.loop|113|116|119 (let ((.x|124|127 .y1|108|109|120)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.x|129|132 (let ((.x|133|136 (let ((.x|137|140 .y1|108|109|120)) (begin (.check! (pair? .x|137|140) 0 .x|137|140) (car:pair .x|137|140))))) (begin (.check! (pair? .x|133|136) 1 .x|133|136) (cdr:pair .x|133|136))))) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .results|108|112|120)))))) (.loop|113|116|119 (let ((.x|142|145 (let ((.x|146|149 .exp|3)) (begin (.check! (pair? .x|146|149) 1 .x|146|149) (cdr:pair .x|146|149))))) (begin (.check! (pair? .x|142|145) 0 .x|142|145) (car:pair .x|142|145))) '())))) '())))))) (m-error "Malformed let-syntax" .exp|3)))) (.m-let-syntax|2 .exp|1 .env|1))))) 'm-let-syntax))
+(let () (begin (set! m-letrec-syntax (lambda (.exp|1 .env|1) (let ((.m-letrec-syntax|2 0)) (begin (set! .m-letrec-syntax|2 (lambda (.exp|3 .env|3) (if (if (> (safe-length .exp|3) 2) (every1? (lambda (.binding|6) (if (pair? .binding|6) (if (symbol? (let ((.x|9|12 .binding|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (if (pair? (let ((.x|14|17 .binding|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))) (null? (let ((.x|20|23 (let ((.x|24|27 .binding|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) #f) #f) #f)) (let ((.x|29|32 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) #f) (let ((.env|39 (syntactic-extend .env|3 (let () (let ((.loop|171|174|177 (unspecified))) (begin (set! .loop|171|174|177 (lambda (.y1|166|167|178 .results|166|170|178) (if (null? .y1|166|167|178) (reverse .results|166|170|178) (begin #t (.loop|171|174|177 (let ((.x|182|185 .y1|166|167|178)) (begin (.check! (pair? .x|182|185) 1 .x|182|185) (cdr:pair .x|182|185))) (cons (let ((.x|186|189 (let ((.x|190|193 .y1|166|167|178)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))))) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189))) .results|166|170|178)))))) (.loop|171|174|177 (let ((.x|195|198 (let ((.x|199|202 .exp|3)) (begin (.check! (pair? .x|199|202) 1 .x|199|202) (cdr:pair .x|199|202))))) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))) '())))) (let () (let ((.loop|208|211|214 (unspecified))) (begin (set! .loop|208|211|214 (lambda (.y1|203|204|215 .results|203|207|215) (if (null? .y1|203|204|215) (reverse .results|203|207|215) (begin #t (.loop|208|211|214 (let ((.x|219|222 .y1|203|204|215)) (begin (.check! (pair? .x|219|222) 1 .x|219|222) (cdr:pair .x|219|222))) (cons (let ((.id|223 (let ((.x|224|227 .y1|203|204|215)) (begin (.check! (pair? .x|224|227) 0 .x|224|227) (car:pair .x|224|227))))) '(fake denotation)) .results|203|207|215)))))) (.loop|208|211|214 (let ((.x|229|232 (let ((.x|233|236 .exp|3)) (begin (.check! (pair? .x|233|236) 1 .x|233|236) (cdr:pair .x|233|236))))) (begin (.check! (pair? .x|229|232) 0 .x|229|232) (car:pair .x|229|232))) '()))))))) (begin (let () (let ((.loop|46|49|52 (unspecified))) (begin (set! .loop|46|49|52 (lambda (.y1|40|42|53 .y1|40|41|53) (if (let ((.temp|55|58 (null? .y1|40|42|53))) (if .temp|55|58 .temp|55|58 (null? .y1|40|41|53))) (if #f #f (unspecified)) (begin (begin #t (let ((.id|61 (let ((.x|62|65 .y1|40|42|53)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (.spec|61 (let ((.x|66|69 .y1|40|41|53)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69))))) (syntactic-assign! .env|39 .id|61 (m-compile-transformer-spec .spec|61 .env|39)))) (.loop|46|49|52 (let ((.x|70|73 .y1|40|42|53)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (let ((.x|74|77 .y1|40|41|53)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77)))))))) (.loop|46|49|52 (let () (let ((.loop|83|86|89 (unspecified))) (begin (set! .loop|83|86|89 (lambda (.y1|78|79|90 .results|78|82|90) (if (null? .y1|78|79|90) (reverse .results|78|82|90) (begin #t (.loop|83|86|89 (let ((.x|94|97 .y1|78|79|90)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))) (cons (let ((.x|98|101 (let ((.x|102|105 .y1|78|79|90)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105))))) (begin (.check! (pair? .x|98|101) 0 .x|98|101) (car:pair .x|98|101))) .results|78|82|90)))))) (.loop|83|86|89 (let ((.x|107|110 (let ((.x|111|114 .exp|3)) (begin (.check! (pair? .x|111|114) 1 .x|111|114) (cdr:pair .x|111|114))))) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))) '())))) (let () (let ((.loop|120|123|126 (unspecified))) (begin (set! .loop|120|123|126 (lambda (.y1|115|116|127 .results|115|119|127) (if (null? .y1|115|116|127) (reverse .results|115|119|127) (begin #t (.loop|120|123|126 (let ((.x|131|134 .y1|115|116|127)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134))) (cons (let ((.x|136|139 (let ((.x|140|143 (let ((.x|144|147 .y1|115|116|127)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))))) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))) .results|115|119|127)))))) (.loop|120|123|126 (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152))) '())))))))) (m-body (let ((.x|158|161 (let ((.x|162|165 .exp|3)) (begin (.check! (pair? .x|162|165) 1 .x|162|165) (cdr:pair .x|162|165))))) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))) .env|39))) (m-error "Malformed let-syntax" .exp|3)))) (.m-letrec-syntax|2 .exp|1 .env|1))))) 'm-letrec-syntax))
+(let () (begin (set! m-macro (lambda (.exp|1 .env|1) (let ((.m-macro|2 0)) (begin (set! .m-macro|2 (lambda (.exp|3 .env|3) (m-transcribe .exp|3 .env|3 (lambda (.exp|4 .env|4) (m-expand .exp|4 .env|4))))) (.m-macro|2 .exp|1 .env|1))))) 'm-macro))
+(let () (begin (set! m-inline (lambda (.exp|1 .env|1) (let ((.m-inline|2 0)) (begin (set! .m-inline|2 (lambda (.exp|3 .env|3) (if (integrate-usual-procedures) (m-transcribe-inline .exp|3 .env|3 (lambda (.newexp|4 .env|4) (if (eq? .exp|3 .newexp|4) (m-application .exp|3 .env|4) (m-expand .newexp|4 .env|4)))) (m-application .exp|3 .env|3)))) (.m-inline|2 .exp|1 .env|1))))) 'm-inline))
+(let () (begin (set! m-quit (lambda (.v|1) .v|1)) 'm-quit))
+(let () ($$trace "usual"))
+(let () (define-syntax-scope 'letrec*))
+(let () (let () (let ((.loop|6|8|11 (unspecified))) (begin (set! .loop|6|8|11 (lambda (.y1|1|2|12) (if (null? .y1|1|2|12) (if #f #f (unspecified)) (begin (begin #t (let ((.form|16 (let ((.x|17|20 .y1|1|2|12)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (macro-expand .form|16))) (.loop|6|8|11 (let ((.x|21|24 .y1|1|2|12)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))))))) (.loop|6|8|11 '((define-syntax let (syntax-rules () ((let ((?name ?val) ...) ?body ?body1 ...) ((lambda (?name ...) ?body ?body1 ...) ?val ...)))) (define-syntax let* (syntax-rules () ((let* () ?body ?body1 ...) (let () ?body ?body1 ...)) ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...) (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...))))) (define-syntax letrec (syntax-rules (lambda quote) ((letrec ((?name ?val) ...) ?body ?body2 ...) ((lambda () (define ?name ?val) ... ?body ?body2 ...))))) (define-syntax let let* (syntax-rules () ((let (?bindings ...) . ?body) (let (?bindings ...) . ?body)) ((let ?tag ((?name ?val) ...) ?body ?body1 ...) (let ((?name ?val) ...) (letrec ((?tag (lambda (?name ...) ?body ?body1 ...))) (?tag ?name ...)))))) (define-syntax and (syntax-rules () ((and) #t) ((and ?e) ?e) ((and ?e1 ?e2 ?e3 ...) (if ?e1 (and ?e2 ?e3 ...) #f)))) (define-syntax or (syntax-rules () ((or) #f) ((or ?e) ?e) ((or ?e1 ?e2 ?e3 ...) (let ((temp ?e1)) (if temp temp (or ?e2 ?e3 ...)))))) (define-syntax cond (syntax-rules (else =>) ((cond (else ?result ?result2 ...)) (begin ?result ?result2 ...)) ((cond (?test => ?result)) (let ((temp ?test)) (if temp (?result temp)))) ((cond (?test)) ?test) ((cond (?test ?result ?result2 ...)) (if ?test (begin ?result ?result2 ...))) ((cond (?test => ?result) ?clause ?clause2 ...) (let ((temp ?test)) (if temp (?result temp) (cond ?clause ?clause2 ...)))) ((cond (?test) ?clause ?clause2 ...) (or ?test (cond ?clause ?clause2 ...))) ((cond (?test ?result ?result2 ...) ?clause ?clause2 ...) (if ?test (begin ?result ?result2 ...) (cond ?clause ?clause2 ...))))) (define-syntax do (syntax-rules () ((do (?bindings0 ...) (?test) ?body0 ...) (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...)) ((do (?bindings0 ...) ?clause0 ?body0 ...) (letrec-syntax ((do-aux (... (syntax-rules () ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...) (letrec ((loop (lambda (?name ...) (cond ?clause (else (begin #t ?body ...) (loop ?step ...)))))) (loop ?init ...))) ((do-aux ((?name ?init ?step) ?todo ...) (?bindings ...) ?clause ?body ...) (do-aux (?todo ...) (?bindings ... (?name ?init ?step)) ?clause ?body ...)) ((do-aux ((?name ?init) ?todo ...) (?bindings ...) ?clause ?body ...) (do-aux (?todo ...) (?bindings ... (?name ?init ?name)) ?clause ?body ...)))))) (do-aux (?bindings0 ...) () ?clause0 ?body0 ...))))) (define-syntax delay (syntax-rules () ((delay ?e) (.make-promise (lambda () ?e))))) (define-syntax case (syntax-rules (else) ((case ?e1 (else ?body ?body2 ...)) (begin ?e1 ?body ?body2 ...)) ((case ?e1 (?z ?body ?body2 ...)) (if (memv ?e1 '?z) (begin ?body ?body2 ...))) ((case ?e1 ?clause1 ?clause2 ?clause3 ...) (letrec-syntax ((case-aux (... (syntax-rules (else) ((case-aux ?temp (else ?body ?body2 ...)) (begin ?body ?body2 ...)) ((case-aux ?temp ((?z ...) ?body ?body2 ...)) (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...))) ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...) (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...) (case-aux ?temp ?c1 ?c2 ...))) ((case-aux ?temp (?z ?body ...) ?c1 ...) (case-aux ?temp ((?z) ?body ...) ?c1 ...)))))) (let ((temp ?e1)) (case-aux temp ?clause1 ?clause2 ?clause3 ...)))))) (begin (define-syntax .finalize-quasiquote letrec (syntax-rules (quote unquote unquote-splicing) ((.finalize-quasiquote quote ?arg ?return) (.interpret-continuation ?return '?arg)) ((.finalize-quasiquote unquote ?arg ?return) (.interpret-continuation ?return ?arg)) ((.finalize-quasiquote unquote-splicing ?arg ?return) (syntax-error ",@ in illegal context" ?arg)) ((.finalize-quasiquote ?mode ?arg ?return) (.interpret-continuation ?return (?mode . ?arg))))) (define-syntax .descend-quasiquote letrec (syntax-rules (quasiquote unquote unquote-splicing) ((.descend-quasiquote `?y ?x ?level ?return) (.descend-quasiquote-pair ?x ?x (?level) ?return)) ((.descend-quasiquote ,?y ?x () ?return) (.interpret-continuation ?return unquote ?y)) ((.descend-quasiquote ,?y ?x (?level) ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote ,@?y ?x () ?return) (.interpret-continuation ?return unquote-splicing ?y)) ((.descend-quasiquote ,@?y ?x (?level) ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote (?y . ?z) ?x ?level ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote #(?y ...) ?x ?level ?return) (.descend-quasiquote-vector ?x ?x ?level ?return)) ((.descend-quasiquote ?y ?x ?level ?return) (.interpret-continuation ?return quote ?x)))) (define-syntax .descend-quasiquote-pair letrec (syntax-rules (quote unquote unquote-splicing) ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return) (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return))))) (define-syntax .descend-quasiquote-vector letrec (syntax-rules (quote) ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return) (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return))))) (define-syntax .interpret-continuation letrec (syntax-rules (quote unquote unquote-splicing) ((.interpret-continuation (-1) ?e) ?e) ((.interpret-continuation (0) ?mode ?arg) (.finalize-quasiquote ?mode ?arg (-1))) ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg) (.descend-quasiquote ?cdrx ?cdrx ?level (2 ?car-mode ?car-arg ?x ?return))) ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg) (.interpret-continuation ?return quote ?x)) ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ()) (.interpret-continuation ?return unquote ?car-arg)) ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) ?cdr-mode ?cdr-arg) (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return))) ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return) ?cdr-mode ?cdr-arg) (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return))) ((.interpret-continuation (3 ?car-arg ?return) ?e) (.interpret-continuation ?return append (?car-arg ?e))) ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1) (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return))) ((.interpret-continuation (5 ?e1 ?return) ?e2) (.interpret-continuation ?return .cons (?e1 ?e2))) ((.interpret-continuation (6 ?x ?return) quote ?arg) (.interpret-continuation ?return quote ?x)) ((.interpret-continuation (6 ?x ?return) ?mode ?arg) (.finalize-quasiquote ?mode ?arg (7 ?return))) ((.interpret-continuation (7 ?return) ?e) (.interpret-continuation ?return .list->vector (?e))))) (define-syntax quasiquote letrec (syntax-rules () (`?x (.descend-quasiquote ?x ?x () (0)))))) (define-syntax let*-syntax (syntax-rules () ((let*-syntax () ?body) (let-syntax () ?body)) ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body) (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))))))))
+(let () (define-syntax-scope 'letrec))
+(let () (begin (set! standard-syntactic-environment (syntactic-copy global-syntactic-environment)) 'standard-syntactic-environment))
+(let () (begin (set! make-standard-syntactic-environment (lambda () (let ((.make-standard-syntactic-environment|2 0)) (begin (set! .make-standard-syntactic-environment|2 (lambda () (syntactic-copy standard-syntactic-environment))) (.make-standard-syntactic-environment|2))))) 'make-standard-syntactic-environment))
+(let () (begin (set! copy-exp (lambda (.exp|1) (let ((.copy-exp|2 0)) (begin (set! .copy-exp|2 (lambda (.exp|3) (let ((.copy|4 (unspecified)) (.lexical-lookup|4 (unspecified)) (.env-unbind-multiple!|4 (unspecified)) (.env-bind-multiple!|4 (unspecified)) (.env-lookup|4 (unspecified)) (.env-unbind!|4 (unspecified)) (.env-bind!|4 (unspecified)) (.make-env|4 (unspecified)) (.rename-formals|4 (unspecified)) (.rename-vars|4 (unspecified)) (.renaming-counter|4 (unspecified)) (.original-names|4 (unspecified)) (.special-names|4 (unspecified))) (begin (set! .copy|4 (lambda (.exp|5 .env|5 .notepad|5 .r-table|5) (if (constant? .exp|5) .exp|5 (if (lambda? .exp|5) (let* ((.bvl|10 (make-null-terminated (lambda.args .exp|5))) (.newnames|13 (.rename-vars|4 .bvl|10)) (.procnames|16 (let () (let ((.loop|172|175|178 (unspecified))) (begin (set! .loop|172|175|178 (lambda (.y1|167|168|179 .results|167|171|179) (if (null? .y1|167|168|179) (reverse .results|167|171|179) (begin #t (.loop|172|175|178 (let ((.x|183|186 .y1|167|168|179)) (begin (.check! (pair? .x|183|186) 1 .x|183|186) (cdr:pair .x|183|186))) (cons (def.lhs (let ((.x|187|190 .y1|167|168|179)) (begin (.check! (pair? .x|187|190) 0 .x|187|190) (car:pair .x|187|190)))) .results|167|171|179)))))) (.loop|172|175|178 (lambda.defs .exp|5) '()))))) (.newprocnames|19 (.rename-vars|4 .procnames|16)) (.refinfo|22 (let () (let ((.loop|147|150|153 (unspecified))) (begin (set! .loop|147|150|153 (lambda (.y1|142|143|154 .results|142|146|154) (if (null? .y1|142|143|154) (reverse .results|142|146|154) (begin #t (.loop|147|150|153 (let ((.x|158|161 .y1|142|143|154)) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))) (cons (let ((.var|162 (let ((.x|163|166 .y1|142|143|154)) (begin (.check! (pair? .x|163|166) 0 .x|163|166) (car:pair .x|163|166))))) (make-r-entry .var|162 '() '() '())) .results|142|146|154)))))) (.loop|147|150|153 (append .newnames|13 .newprocnames|19) '()))))) (.newexp|25 (make-lambda (.rename-formals|4 (lambda.args .exp|5) .newnames|13) '() .refinfo|22 '() '() (lambda.decls .exp|5) (lambda.doc .exp|5) (lambda.body .exp|5)))) (let () (begin (.env-bind-multiple!|4 .env|5 .procnames|16 .newprocnames|19) (.env-bind-multiple!|4 .env|5 .bvl|10 .newnames|13) (let () (let ((.loop|34|36|39 (unspecified))) (begin (set! .loop|34|36|39 (lambda (.y1|29|30|40) (if (null? .y1|29|30|40) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|44 (let ((.x|45|48 .y1|29|30|40)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))))) (.env-bind!|4 .r-table|5 (r-entry.name .entry|44) .entry|44))) (.loop|34|36|39 (let ((.x|49|52 .y1|29|30|40)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52)))))))) (.loop|34|36|39 .refinfo|22)))) (notepad-lambda-add! .notepad|5 .newexp|25) (let ((.newnotepad|55 (make-notepad .notepad|5))) (begin (let () (let ((.loop|62|65|68 (unspecified))) (begin (set! .loop|62|65|68 (lambda (.y1|56|58|69 .y1|56|57|69) (if (let ((.temp|71|74 (null? .y1|56|58|69))) (if .temp|71|74 .temp|71|74 (null? .y1|56|57|69))) (if #f #f (unspecified)) (begin (begin #t (let ((.name|77 (let ((.x|78|81 .y1|56|58|69)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.rhs|77 (let ((.x|82|85 .y1|56|57|69)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85))))) (lambda.defs-set! .newexp|25 (cons (make-definition .name|77 (.copy|4 .rhs|77 .env|5 .newnotepad|55 .r-table|5)) (lambda.defs .newexp|25))))) (.loop|62|65|68 (let ((.x|86|89 .y1|56|58|69)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))) (let ((.x|90|93 .y1|56|57|69)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93)))))))) (.loop|62|65|68 (reverse .newprocnames|19) (let () (let ((.loop|99|102|105 (unspecified))) (begin (set! .loop|99|102|105 (lambda (.y1|94|95|106 .results|94|98|106) (if (null? .y1|94|95|106) (reverse .results|94|98|106) (begin #t (.loop|99|102|105 (let ((.x|110|113 .y1|94|95|106)) (begin (.check! (pair? .x|110|113) 1 .x|110|113) (cdr:pair .x|110|113))) (cons (def.rhs (let ((.x|114|117 .y1|94|95|106)) (begin (.check! (pair? .x|114|117) 0 .x|114|117) (car:pair .x|114|117)))) .results|94|98|106)))))) (.loop|99|102|105 (reverse (lambda.defs .exp|5)) '())))))))) (lambda.body-set! .newexp|25 (.copy|4 (lambda.body .exp|5) .env|5 .newnotepad|55 .r-table|5)) (lambda.f-set! .newexp|25 (notepad-free-variables .newnotepad|55)) (lambda.g-set! .newexp|25 (notepad-captured-variables .newnotepad|55)))) (.env-unbind-multiple!|4 .env|5 .procnames|16) (.env-unbind-multiple!|4 .env|5 .bvl|10) (let () (let ((.loop|123|125|128 (unspecified))) (begin (set! .loop|123|125|128 (lambda (.y1|118|119|129) (if (null? .y1|118|119|129) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|133 (let ((.x|134|137 .y1|118|119|129)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137))))) (.env-unbind!|4 .r-table|5 (r-entry.name .entry|133)))) (.loop|123|125|128 (let ((.x|138|141 .y1|118|119|129)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141)))))))) (.loop|123|125|128 .refinfo|22)))) .newexp|25))) (if (assignment? .exp|5) (let* ((.oldname|194 (assignment.lhs .exp|5)) (.name|197 (.env-lookup|4 .env|5 .oldname|194 .oldname|194)) (.varinfo|200 (.env-lookup|4 .r-table|5 .name|197 #f)) (.newexp|203 (make-assignment .name|197 (.copy|4 (assignment.rhs .exp|5) .env|5 .notepad|5 .r-table|5)))) (let () (begin (notepad-var-add! .notepad|5 .name|197) (if .varinfo|200 (r-entry.assignments-set! .varinfo|200 (cons .newexp|203 (r-entry.assignments .varinfo|200))) (unspecified)) .newexp|203))) (if (conditional? .exp|5) (make-conditional (.copy|4 (if.test .exp|5) .env|5 .notepad|5 .r-table|5) (.copy|4 (if.then .exp|5) .env|5 .notepad|5 .r-table|5) (.copy|4 (if.else .exp|5) .env|5 .notepad|5 .r-table|5)) (if (begin? .exp|5) (make-begin (let () (let ((.loop|214|217|220 (unspecified))) (begin (set! .loop|214|217|220 (lambda (.y1|209|210|221 .results|209|213|221) (if (null? .y1|209|210|221) (reverse .results|209|213|221) (begin #t (.loop|214|217|220 (let ((.x|225|228 .y1|209|210|221)) (begin (.check! (pair? .x|225|228) 1 .x|225|228) (cdr:pair .x|225|228))) (cons (let ((.exp|229 (let ((.x|230|233 .y1|209|210|221)) (begin (.check! (pair? .x|230|233) 0 .x|230|233) (car:pair .x|230|233))))) (.copy|4 .exp|229 .env|5 .notepad|5 .r-table|5)) .results|209|213|221)))))) (.loop|214|217|220 (begin.exprs .exp|5) '()))))) (if (variable? .exp|5) (let* ((.oldname|237 (variable.name .exp|5)) (.name|240 (.env-lookup|4 .env|5 .oldname|237 .oldname|237)) (.varinfo|243 (.env-lookup|4 .r-table|5 .name|240 #f)) (.newexp|246 (make-variable .name|240))) (let () (begin (notepad-var-add! .notepad|5 .name|240) (if .varinfo|243 (r-entry.references-set! .varinfo|243 (cons .newexp|246 (r-entry.references .varinfo|243))) (unspecified)) .newexp|246))) (if (call? .exp|5) (let ((.newexp|253 (make-call (.copy|4 (call.proc .exp|5) .env|5 .notepad|5 .r-table|5) (let () (let ((.loop|262|265|268 (unspecified))) (begin (set! .loop|262|265|268 (lambda (.y1|257|258|269 .results|257|261|269) (if (null? .y1|257|258|269) (reverse .results|257|261|269) (begin #t (.loop|262|265|268 (let ((.x|273|276 .y1|257|258|269)) (begin (.check! (pair? .x|273|276) 1 .x|273|276) (cdr:pair .x|273|276))) (cons (let ((.exp|277 (let ((.x|278|281 .y1|257|258|269)) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281))))) (.copy|4 .exp|277 .env|5 .notepad|5 .r-table|5)) .results|257|261|269)))))) (.loop|262|265|268 (call.args .exp|5) '()))))))) (begin (if (variable? (call.proc .newexp|253)) (let ((.varinfo|256 (.env-lookup|4 .r-table|5 (variable.name (call.proc .newexp|253)) #f))) (if .varinfo|256 (r-entry.calls-set! .varinfo|256 (cons .newexp|253 (r-entry.calls .varinfo|256))) (unspecified))) (unspecified)) (if (lambda? (call.proc .newexp|253)) (notepad-nonescaping-add! .notepad|5 (call.proc .newexp|253)) (unspecified)) .newexp|253)) ???))))))))) (set! .lexical-lookup|4 (lambda (.r-table|283 .name|283) (assq .name|283 .r-table|283))) (set! .env-unbind-multiple!|4 (lambda (.env|284 .symbols|284) (let () (let ((.loop|290|292|295 (unspecified))) (begin (set! .loop|290|292|295 (lambda (.y1|285|286|296) (if (null? .y1|285|286|296) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|300 (let ((.x|301|304 .y1|285|286|296)) (begin (.check! (pair? .x|301|304) 0 .x|301|304) (car:pair .x|301|304))))) (.env-unbind!|4 .env|284 .sym|300))) (.loop|290|292|295 (let ((.x|305|308 .y1|285|286|296)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308)))))))) (.loop|290|292|295 .symbols|284)))))) (set! .env-bind-multiple!|4 (lambda (.env|309 .symbols|309 .infos|309) (let () (let ((.loop|316|319|322 (unspecified))) (begin (set! .loop|316|319|322 (lambda (.y1|310|312|323 .y1|310|311|323) (if (let ((.temp|325|328 (null? .y1|310|312|323))) (if .temp|325|328 .temp|325|328 (null? .y1|310|311|323))) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|331 (let ((.x|332|335 .y1|310|312|323)) (begin (.check! (pair? .x|332|335) 0 .x|332|335) (car:pair .x|332|335)))) (.info|331 (let ((.x|336|339 .y1|310|311|323)) (begin (.check! (pair? .x|336|339) 0 .x|336|339) (car:pair .x|336|339))))) (.env-bind!|4 .env|309 .sym|331 .info|331))) (.loop|316|319|322 (let ((.x|340|343 .y1|310|312|323)) (begin (.check! (pair? .x|340|343) 1 .x|340|343) (cdr:pair .x|340|343))) (let ((.x|344|347 .y1|310|311|323)) (begin (.check! (pair? .x|344|347) 1 .x|344|347) (cdr:pair .x|344|347)))))))) (.loop|316|319|322 .symbols|309 .infos|309)))))) (set! .env-lookup|4 (lambda (.env|348 .sym|348 .default|348) (let ((.stack|351 (hashtable-get .env|348 .sym|348))) (if .stack|351 (let ((.x|352|355 .stack|351)) (begin (.check! (pair? .x|352|355) 0 .x|352|355) (car:pair .x|352|355))) .default|348)))) (set! .env-unbind!|4 (lambda (.env|356 .sym|356) (let ((.stack|359 (hashtable-get .env|356 .sym|356))) (hashtable-put! .env|356 .sym|356 (let ((.x|360|363 .stack|359)) (begin (.check! (pair? .x|360|363) 1 .x|360|363) (cdr:pair .x|360|363))))))) (set! .env-bind!|4 (lambda (.env|364 .sym|364 .info|364) (let ((.stack|367 (hashtable-get .env|364 .sym|364))) (hashtable-put! .env|364 .sym|364 (cons .info|364 .stack|367))))) (set! .make-env|4 (lambda () (make-hashtable symbol-hash assq))) (set! .rename-formals|4 (lambda (.formals|369 .newnames|369) (if (null? .formals|369) '() (if (symbol? .formals|369) (let ((.x|372|375 .newnames|369)) (begin (.check! (pair? .x|372|375) 0 .x|372|375) (car:pair .x|372|375))) (if (memq (let ((.x|377|380 .formals|369)) (begin (.check! (pair? .x|377|380) 0 .x|377|380) (car:pair .x|377|380))) .special-names|4) (cons (let ((.x|381|384 .formals|369)) (begin (.check! (pair? .x|381|384) 0 .x|381|384) (car:pair .x|381|384))) (.rename-formals|4 (let ((.x|385|388 .formals|369)) (begin (.check! (pair? .x|385|388) 1 .x|385|388) (cdr:pair .x|385|388))) (let ((.x|389|392 .newnames|369)) (begin (.check! (pair? .x|389|392) 1 .x|389|392) (cdr:pair .x|389|392))))) (cons (let ((.x|394|397 .newnames|369)) (begin (.check! (pair? .x|394|397) 0 .x|394|397) (car:pair .x|394|397))) (.rename-formals|4 (let ((.x|398|401 .formals|369)) (begin (.check! (pair? .x|398|401) 1 .x|398|401) (cdr:pair .x|398|401))) (let ((.x|402|405 .newnames|369)) (begin (.check! (pair? .x|402|405) 1 .x|402|405) (cdr:pair .x|402|405)))))))))) (set! .rename-vars|4 (lambda (.vars|406) (let ((.rename|409 (make-rename-procedure))) (let () (let ((.loop|415|418|421 (unspecified))) (begin (set! .loop|415|418|421 (lambda (.y1|410|411|422 .results|410|414|422) (if (null? .y1|410|411|422) (reverse .results|410|414|422) (begin #t (.loop|415|418|421 (let ((.x|426|429 .y1|410|411|422)) (begin (.check! (pair? .x|426|429) 1 .x|426|429) (cdr:pair .x|426|429))) (cons (let ((.var|430 (let ((.x|434|437 .y1|410|411|422)) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437))))) (if (memq .var|430 .special-names|4) .var|430 (if (hashtable-get .original-names|4 .var|430) (.rename|409 .var|430) (begin (hashtable-put! .original-names|4 .var|430 #t) .var|430)))) .results|410|414|422)))))) (.loop|415|418|421 .vars|406 '()))))))) (set! .renaming-counter|4 0) (set! .original-names|4 (make-hashtable symbol-hash assq)) (set! .special-names|4 (cons name:ignored argument-registers)) (.copy|4 .exp|3 (.make-env|4) (make-notepad #f) (.make-env|4)))))) (.copy-exp|2 .exp|1))))) 'copy-exp))
+(let () (begin (set! check-referencing-invariants (lambda (.exp|1 . .flags|1) (let ((.check-free-variables?|4 (memq 'free .flags|1)) (.check-referencing?|4 (memq 'reference .flags|1)) (.first-violation?|4 #t)) (let ((.lookup|5 (unspecified)) (.return|5 (unspecified)) (.check|5 (unspecified))) (begin (set! .lookup|5 (lambda (.env|6 .i|6) (if (null? .env|6) #f (let* ((.rinfo|9 (r-entry (lambda.r (let ((.x|19|22 .env|6)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) .i|6)) (.temp|10|13 .rinfo|9)) (if .temp|10|13 .temp|10|13 (.lookup|5 (let ((.x|15|18 .env|6)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .i|6)))))) (set! .return|5 (lambda (.exp|23 .flag|23) (if .flag|23 #t (if .first-violation?|4 (begin (set! .first-violation?|4 #f) (display "Violation of referencing invariants") (newline) (pretty-print (make-readable .exp|23)) #f) (begin (pretty-print (make-readable .exp|23)) #f))))) (set! .check|5 (lambda (.exp|27 .env|27) (if (constant? .exp|27) (.return|5 .exp|27 #t) (if (lambda? .exp|27) (let ((.env|32 (cons .exp|27 .env|27))) (.return|5 .exp|27 (if (every? (lambda (.exp|34) (.check|5 .exp|34 .env|32)) (let () (let ((.loop|40|43|46 (unspecified))) (begin (set! .loop|40|43|46 (lambda (.y1|35|36|47 .results|35|39|47) (if (null? .y1|35|36|47) (reverse .results|35|39|47) (begin #t (.loop|40|43|46 (let ((.x|51|54 .y1|35|36|47)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (cons (def.rhs (let ((.x|55|58 .y1|35|36|47)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58)))) .results|35|39|47)))))) (.loop|40|43|46 (lambda.defs .exp|27) '()))))) (if (.check|5 (lambda.body .exp|27) .env|32) (if (if (if .check-free-variables?|4 (not (null? .env|32)) #f) (subset? (difference (lambda.f .exp|27) (make-null-terminated (lambda.args .exp|27))) (lambda.f (let ((.x|63|66 .env|32)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))))) #t) (if .check-referencing?|4 (let ((.env|70 (cons .exp|27 .env|32)) (.r|70 (lambda.r .exp|27))) (every? (lambda (.formal|71) (let ((.temp|72|75 (ignored? .formal|71))) (if .temp|72|75 .temp|72|75 (r-entry .r|70 .formal|71)))) (make-null-terminated (lambda.args .exp|27)))) #t) #f) #f) #f))) (if (variable? .exp|27) (.return|5 .exp|27 (if (if (if .check-free-variables?|4 (not (null? .env|27)) #f) (memq (variable.name .exp|27) (lambda.f (let ((.x|81|84 .env|27)) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))))) #t) (if .check-referencing?|4 (let ((.rinfo|88 (.lookup|5 .env|27 (variable.name .exp|27)))) (if .rinfo|88 (memq .exp|27 (r-entry.references .rinfo|88)) #t)) #t) #f)) (if (assignment? .exp|27) (.return|5 .exp|27 (if (.check|5 (assignment.rhs .exp|27) .env|27) (if (if (if .check-free-variables?|4 (not (null? .env|27)) #f) (memq (assignment.lhs .exp|27) (lambda.f (let ((.x|94|97 .env|27)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) #t) (if .check-referencing?|4 (let ((.rinfo|101 (.lookup|5 .env|27 (assignment.lhs .exp|27)))) (if .rinfo|101 (memq .exp|27 (r-entry.assignments .rinfo|101)) #t)) #t) #f) #f)) (if (conditional? .exp|27) (.return|5 .exp|27 (if (.check|5 (if.test .exp|27) .env|27) (if (.check|5 (if.then .exp|27) .env|27) (.check|5 (if.else .exp|27) .env|27) #f) #f)) (if (begin? .exp|27) (.return|5 .exp|27 (every? (lambda (.exp|107) (.check|5 .exp|107 .env|27)) (begin.exprs .exp|27))) (if (call? .exp|27) (.return|5 .exp|27 (if (.check|5 (call.proc .exp|27) .env|27) (if (every? (lambda (.exp|111) (.check|5 .exp|111 .env|27)) (call.args .exp|27)) (if (if .check-referencing?|4 (variable? (call.proc .exp|27)) #f) (let ((.rinfo|117 (.lookup|5 .env|27 (variable.name (call.proc .exp|27))))) (if .rinfo|117 (memq .exp|27 (r-entry.calls .rinfo|117)) #t)) #t) #f) #f)) ???))))))))) (if (null? .flags|1) (begin (set! .check-free-variables?|4 #t) (set! .check-referencing?|4 #t)) (unspecified)) (.check|5 .exp|1 '())))))) 'check-referencing-invariants))
+(let () (begin (set! compute-free-variables! (lambda (.exp|1) (let ((.compute-free-variables!|2 0)) (begin (set! .compute-free-variables!|2 (lambda (.exp|3) (let ((.free|4 (unspecified)) (.set->list|4 (unspecified)) (.union3|4 (unspecified)) (.union2|4 (unspecified)) (.singleton|4 (unspecified)) (.empty-set|4 (unspecified))) (begin (set! .free|4 (lambda (.exp|5) (if (constant? .exp|5) .empty-set|4 (if (lambda? .exp|5) (let* ((.defs|10 (lambda.defs .exp|5)) (.formals|13 (make-set (make-null-terminated (lambda.args .exp|5)))) (.defined|16 (make-set (let () (let ((.loop|59|62|65 (unspecified))) (begin (set! .loop|59|62|65 (lambda (.y1|54|55|66 .results|54|58|66) (if (null? .y1|54|55|66) (reverse .results|54|58|66) (begin #t (.loop|59|62|65 (let ((.x|70|73 .y1|54|55|66)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (cons (def.lhs (let ((.x|74|77 .y1|54|55|66)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) .results|54|58|66)))))) (.loop|59|62|65 .defs|10 '())))))) (.fdefs|19 (apply-union (let () (let ((.loop|34|37|40 (unspecified))) (begin (set! .loop|34|37|40 (lambda (.y1|29|30|41 .results|29|33|41) (if (null? .y1|29|30|41) (reverse .results|29|33|41) (begin #t (.loop|34|37|40 (let ((.x|45|48 .y1|29|30|41)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))) (cons (let ((.def|49 (let ((.x|50|53 .y1|29|30|41)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (.free|4 (def.rhs .def|49))) .results|29|33|41)))))) (.loop|34|37|40 .defs|10 '())))))) (.fbody|22 (.free|4 (lambda.body .exp|5))) (.f|25 (.union2|4 .fdefs|19 .fbody|22))) (let () (begin (lambda.f-set! .exp|5 (.set->list|4 .f|25)) (lambda.g-set! .exp|5 (.set->list|4 .f|25)) (difference .f|25 (.union2|4 .formals|13 .defined|16))))) (if (assignment? .exp|5) (.union2|4 (make-set (cons (assignment.lhs .exp|5) '())) (.free|4 (assignment.rhs .exp|5))) (if (conditional? .exp|5) (.union3|4 (.free|4 (if.test .exp|5)) (.free|4 (if.then .exp|5)) (.free|4 (if.else .exp|5))) (if (begin? .exp|5) (apply-union (let () (let ((.loop|87|90|93 (unspecified))) (begin (set! .loop|87|90|93 (lambda (.y1|82|83|94 .results|82|86|94) (if (null? .y1|82|83|94) (reverse .results|82|86|94) (begin #t (.loop|87|90|93 (let ((.x|98|101 .y1|82|83|94)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) (cons (let ((.exp|102 (let ((.x|103|106 .y1|82|83|94)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106))))) (.free|4 .exp|102)) .results|82|86|94)))))) (.loop|87|90|93 (begin.exprs .exp|5) '()))))) (if (variable? .exp|5) (.singleton|4 (variable.name .exp|5)) (if (call? .exp|5) (.union2|4 (.free|4 (call.proc .exp|5)) (apply-union (let () (let ((.loop|114|117|120 (unspecified))) (begin (set! .loop|114|117|120 (lambda (.y1|109|110|121 .results|109|113|121) (if (null? .y1|109|110|121) (reverse .results|109|113|121) (begin #t (.loop|114|117|120 (let ((.x|125|128 .y1|109|110|121)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) (cons (let ((.exp|129 (let ((.x|130|133 .y1|109|110|121)) (begin (.check! (pair? .x|130|133) 0 .x|130|133) (car:pair .x|130|133))))) (.free|4 .exp|129)) .results|109|113|121)))))) (.loop|114|117|120 (call.args .exp|5) '())))))) ???))))))))) (set! .set->list|4 (lambda (.set|135) .set|135)) (set! .union3|4 (lambda (.x|136 .y|136 .z|136) (union .x|136 .y|136 .z|136))) (set! .union2|4 (lambda (.x|137 .y|137) (union .x|137 .y|137))) (set! .singleton|4 (lambda (.x|138) (cons .x|138 '()))) (set! .empty-set|4 (make-set '())) (.free|4 .exp|3))))) (.compute-free-variables!|2 .exp|1))))) 'compute-free-variables!))
+(let () (begin '(define (compute-free-variables! exp) (define empty-set (make-hashtree symbol-hash assq)) (define (singleton x) (hashtree-put empty-set x #t)) (define (make-set values) (if (null? values) empty-set (hashtree-put (make-set (cdr values)) (car values) #t))) (define (union2 x y) (hashtree-for-each (lambda (key val) (set! x (hashtree-put x key #t))) y) x) (define (union3 x y z) (union2 (union2 x y) z)) (define (apply-union sets) (cond ((null? sets) (make-set '())) ((null? (cdr sets)) (car sets)) (else (union2 (car sets) (apply-union (cdr sets)))))) (define (difference x y) (hashtree-for-each (lambda (key val) (set! x (hashtree-remove x key))) y) x) (define (set->list set) (hashtree-map (lambda (sym val) sym) set)) (define (free exp) (cond ((constant? exp) empty-set) ((lambda? exp) (let* ((defs (lambda.defs exp)) (formals (make-set (make-null-terminated (lambda.args exp)))) (defined (make-set (map def.lhs defs))) (fdefs (apply-union (map (lambda (def) (free (def.rhs def))) defs))) (fbody (free (lambda.body exp))) (f (union2 fdefs fbody))) (lambda.f-set! exp (set->list f)) (lambda.g-set! exp (set->list f)) (difference f (union2 formals defined)))) ((assignment? exp) (union2 (make-set (list (assignment.lhs exp))) (free (assignment.rhs exp)))) ((conditional? exp) (union3 (free (if.test exp)) (free (if.then exp)) (free (if.else exp)))) ((begin? exp) (apply-union (map (lambda (exp) (free exp)) (begin.exprs exp)))) ((variable? exp) (singleton (variable.name exp))) ((call? exp) (union2 (free (call.proc exp)) (apply-union (map (lambda (exp) (free exp)) (call.args exp))))) (else ???))) (hashtree-map (lambda (sym val) sym) (free exp))) #t))
+(let () ($$trace "pass1"))
+(let () (begin (set! source-file-name #f) 'source-file-name))
+(let () (begin (set! source-file-position #f) 'source-file-position))
+(let () (begin (set! pass1-block-compiling? #f) 'pass1-block-compiling?))
+(let () (begin (set! pass1-block-assignments '()) 'pass1-block-assignments))
+(let () (begin (set! pass1-block-inlines '()) 'pass1-block-inlines))
+(let () (begin (set! pass1 (lambda (.def-or-exp|1 . .rest|1) (begin (set! source-file-name #f) (set! source-file-position #f) (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (if (not (null? .rest|1)) (begin (set! source-file-name (let ((.x|2|5 .rest|1)) (begin (.check! (pair? .x|2|5) 0 .x|2|5) (car:pair .x|2|5)))) (if (not (null? (let ((.x|6|9 .rest|1)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9))))) (set! source-file-position (let ((.x|11|14 (let ((.x|15|18 .rest|1)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) (unspecified))) (unspecified)) (set! renaming-counter 0) (macro-expand .def-or-exp|1)))) 'pass1))
+(let () (begin (set! pass1-block (lambda (.forms|1 . .rest|1) (let ((.part3|2 (unspecified)) (.part2|2 (unspecified)) (.part1|2 (unspecified))) (begin (set! .part3|2 (lambda (.alist|3 .definitions0|3 .definitions1|3 .forms|3) (begin (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (let* ((.constnames0|6 (let () (let ((.loop|211|214|217 (unspecified))) (begin (set! .loop|211|214|217 (lambda (.y1|206|207|218 .results|206|210|218) (if (null? .y1|206|207|218) (reverse .results|206|210|218) (begin #t (.loop|211|214|217 (let ((.x|222|225 .y1|206|207|218)) (begin (.check! (pair? .x|222|225) 1 .x|222|225) (cdr:pair .x|222|225))) (cons (assignment.lhs (let ((.x|226|229 .y1|206|207|218)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229)))) .results|206|210|218)))))) (.loop|211|214|217 .definitions0|3 '()))))) (.constnames1|9 (let () (let ((.loop|182|185|188 (unspecified))) (begin (set! .loop|182|185|188 (lambda (.y1|177|178|189 .results|177|181|189) (if (null? .y1|177|178|189) (reverse .results|177|181|189) (begin #t (.loop|182|185|188 (let ((.x|193|196 .y1|177|178|189)) (begin (.check! (pair? .x|193|196) 1 .x|193|196) (cdr:pair .x|193|196))) (cons (let* ((.id0|197 (let ((.x|202|205 .y1|177|178|189)) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205)))) (.x|198|201 (assq .id0|197 .alist|3))) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))) .results|177|181|189)))))) (.loop|182|185|188 .constnames0|6 '()))))) (.procnames1|12 (let () (let ((.loop|158|161|164 (unspecified))) (begin (set! .loop|158|161|164 (lambda (.y1|153|154|165 .results|153|157|165) (if (null? .y1|153|154|165) (reverse .results|153|157|165) (begin #t (.loop|158|161|164 (let ((.x|169|172 .y1|153|154|165)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172))) (cons (assignment.lhs (let ((.x|173|176 .y1|153|154|165)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176)))) .results|153|157|165)))))) (.loop|158|161|164 .definitions1|3 '())))))) (let () (copy-exp (make-call (make-lambda .constnames1|9 '() '() '() '() '() #f (make-begin (let* ((.t1|16|19 (make-begin (cons (make-constant #f) (reverse (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.id|120 (let ((.x|125|128 .y1|100|101|112)) (begin (.check! (pair? .x|125|128) 0 .x|125|128) (car:pair .x|125|128))))) (make-assignment .id|120 (make-variable (let ((.x|121|124 (assq .id|120 .alist|3))) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))) .results|100|104|112)))))) (.loop|105|108|111 .constnames0|6 '())))))))) (.t2|16|22 (cons (make-call (make-lambda .constnames0|6 '() '() '() '() '() #f (make-call (make-lambda (let () (let ((.loop|32|35|38 (unspecified))) (begin (set! .loop|32|35|38 (lambda (.y1|27|28|39 .results|27|31|39) (if (null? .y1|27|28|39) (reverse .results|27|31|39) (begin #t (.loop|32|35|38 (let ((.x|43|46 .y1|27|28|39)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))) (cons (assignment.lhs (let ((.x|47|50 .y1|27|28|39)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) .results|27|31|39)))))) (.loop|32|35|38 .definitions1|3 '())))) '() '() '() '() '() #f (make-begin (cons (make-constant #f) (append .definitions1|3 .forms|3)))) (let () (let ((.loop|56|59|62 (unspecified))) (begin (set! .loop|56|59|62 (lambda (.y1|51|52|63 .results|51|55|63) (if (null? .y1|51|52|63) (reverse .results|51|55|63) (begin #t (.loop|56|59|62 (let ((.x|67|70 .y1|51|52|63)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))) (cons (let ((.ignored|71 (let ((.x|72|75 .y1|51|52|63)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75))))) (make-unspecified)) .results|51|55|63)))))) (.loop|56|59|62 .definitions1|3 '())))))) (let () (let ((.loop|81|84|87 (unspecified))) (begin (set! .loop|81|84|87 (lambda (.y1|76|77|88 .results|76|80|88) (if (null? .y1|76|77|88) (reverse .results|76|80|88) (begin #t (.loop|81|84|87 (let ((.x|92|95 .y1|76|77|88)) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))) (cons (make-variable (let ((.x|96|99 .y1|76|77|88)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99)))) .results|76|80|88)))))) (.loop|81|84|87 .constnames1|9 '()))))) '()))) (let () (cons .t1|16|19 .t2|16|22))))) (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (assignment.rhs (let ((.x|149|152 .y1|129|130|141)) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152)))) .results|129|133|141)))))) (.loop|134|137|140 .definitions0|3 '()))))))))))) (set! .part2|2 (lambda (.defined|230) (begin (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (set! renaming-counter 0) (let* ((.rename|233 (make-rename-procedure)) (.alist|236 (let () (let ((.loop|354|357|360 (unspecified))) (begin (set! .loop|354|357|360 (lambda (.y1|349|350|361 .results|349|353|361) (if (null? .y1|349|350|361) (reverse .results|349|353|361) (begin #t (.loop|354|357|360 (let ((.x|365|368 .y1|349|350|361)) (begin (.check! (pair? .x|365|368) 1 .x|365|368) (cdr:pair .x|365|368))) (cons (let ((.id|369 (let ((.x|370|373 .y1|349|350|361)) (begin (.check! (pair? .x|370|373) 0 .x|370|373) (car:pair .x|370|373))))) (cons .id|369 (.rename|233 .id|369))) .results|349|353|361)))))) (.loop|354|357|360 .defined|230 '()))))) (.definitions0|239 '()) (.definitions1|242 '())) (let () (let ((.make-toplevel-definition|248 (unspecified))) (begin (set! .make-toplevel-definition|248 (lambda (.id|249 .exp|249) (begin (if (lambda? .exp|249) (doc.name-set! (lambda.doc .exp|249) .id|249) (unspecified)) (let ((.probe|252 (assq .id|249 .alist|236))) (if .probe|252 (let ((.id1|255 (let ((.x|283|286 .probe|252)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))))) (if (constant? .exp|249) (begin (set! .definitions0|239 (cons (make-assignment .id|249 .exp|249) .definitions0|239)) (make-constant .id|249)) (if (lambda? .exp|249) (begin (set! .definitions1|242 (cons (make-assignment .id1|255 .exp|249) .definitions1|242)) (make-assignment .id|249 (make-lambda (lambda.args .exp|249) '() '() '() '() '() (lambda.doc .exp|249) (make-call (make-variable .id1|255) (let () (let ((.loop|263|266|269 (unspecified))) (begin (set! .loop|263|266|269 (lambda (.y1|258|259|270 .results|258|262|270) (if (null? .y1|258|259|270) (reverse .results|258|262|270) (begin #t (.loop|263|266|269 (let ((.x|274|277 .y1|258|259|270)) (begin (.check! (pair? .x|274|277) 1 .x|274|277) (cdr:pair .x|274|277))) (cons (make-variable (let ((.x|278|281 .y1|258|259|270)) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281)))) .results|258|262|270)))))) (.loop|263|266|269 (lambda.args .exp|249) '())))))))) (m-error "Inconsistent macro expansion" (make-readable .exp|249))))) (make-assignment .id|249 .exp|249)))))) (let ((.env0|287 (syntactic-copy global-syntactic-environment)) (.bmode|287 (benchmark-mode)) (.wmode|287 (issue-warnings))) (begin (issue-warnings #f) (let () (let ((.loop|293|295|298 (unspecified))) (begin (set! .loop|293|295|298 (lambda (.y1|288|289|299) (if (null? .y1|288|289|299) (if #f #f (unspecified)) (begin (begin #t (let ((.pair|303 (let ((.x|320|323 .y1|288|289|299)) (begin (.check! (pair? .x|320|323) 0 .x|320|323) (car:pair .x|320|323))))) (let ((.id0|306 (let ((.x|312|315 .pair|303)) (begin (.check! (pair? .x|312|315) 0 .x|312|315) (car:pair .x|312|315)))) (.id1|306 (let ((.x|316|319 .pair|303)) (begin (.check! (pair? .x|316|319) 1 .x|316|319) (cdr:pair .x|316|319))))) (begin (syntactic-bind-globally! .id0|306 (make-inline-denotation .id0|306 (lambda (.exp|307 .rename|307 .compare|307) (cons .id1|306 (let ((.x|308|311 .exp|307)) (begin (.check! (pair? .x|308|311) 1 .x|308|311) (cdr:pair .x|308|311))))) global-syntactic-environment)) (set! pass1-block-inlines (cons .id0|306 pass1-block-inlines)))))) (.loop|293|295|298 (let ((.x|324|327 .y1|288|289|299)) (begin (.check! (pair? .x|324|327) 1 .x|324|327) (cdr:pair .x|324|327)))))))) (.loop|293|295|298 .alist|236)))) (benchmark-mode #f) (issue-warnings .wmode|287) (let ((.forms|330 (let () (let ((.loop|331|334|337 (unspecified))) (begin (set! .loop|331|334|337 (lambda (.forms|338 .newforms|338) (if (null? .forms|338) (reverse .newforms|338) (begin #t (.loop|331|334|337 (let ((.x|341|344 .forms|338)) (begin (.check! (pair? .x|341|344) 1 .x|341|344) (cdr:pair .x|341|344))) (cons (desugar-definitions (let ((.x|345|348 .forms|338)) (begin (.check! (pair? .x|345|348) 0 .x|345|348) (car:pair .x|345|348))) global-syntactic-environment .make-toplevel-definition|248) .newforms|338)))))) (.loop|331|334|337 .forms|1 '())))))) (begin (benchmark-mode .bmode|287) (set! global-syntactic-environment .env0|287) (.part3|2 .alist|236 .definitions0|239 .definitions1|242 .forms|330)))))))))))) (set! .part1|2 (lambda () (begin (set! pass1-block-compiling? #t) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (set! renaming-counter 0) (let ((.env0|377 (syntactic-copy global-syntactic-environment)) (.bmode|377 (benchmark-mode)) (.wmode|377 (issue-warnings)) (.defined|377 '())) (let ((.make-toplevel-definition|378 (unspecified))) (begin (set! .make-toplevel-definition|378 (lambda (.id|379 .exp|379) (begin (if (memq .id|379 .defined|377) (set! pass1-block-assignments (cons .id|379 pass1-block-assignments)) (if (let ((.temp|382|385 (constant? .exp|379))) (if .temp|382|385 .temp|382|385 (if (lambda? .exp|379) (list? (lambda.args .exp|379)) #f))) (set! .defined|377 (cons .id|379 .defined|377)) (unspecified))) (make-begin (let* ((.t1|389|392 (make-assignment .id|379 .exp|379)) (.t2|389|395 (cons (make-constant .id|379) '()))) (let () (cons .t1|389|392 .t2|389|395))))))) (benchmark-mode #f) (issue-warnings #f) (let () (let ((.loop|405|407|410 (unspecified))) (begin (set! .loop|405|407|410 (lambda (.y1|400|401|411) (if (null? .y1|400|401|411) (if #f #f (unspecified)) (begin (begin #t (let ((.form|415 (let ((.x|416|419 .y1|400|401|411)) (begin (.check! (pair? .x|416|419) 0 .x|416|419) (car:pair .x|416|419))))) (desugar-definitions .form|415 global-syntactic-environment .make-toplevel-definition|378))) (.loop|405|407|410 (let ((.x|420|423 .y1|400|401|411)) (begin (.check! (pair? .x|420|423) 1 .x|420|423) (cdr:pair .x|420|423)))))))) (.loop|405|407|410 .forms|1)))) (set! global-syntactic-environment .env0|377) (benchmark-mode .bmode|377) (issue-warnings .wmode|377) (.part2|2 (filter (lambda (.id|424) (not (memq .id|424 pass1-block-assignments))) (reverse .defined|377))))))))) (set! source-file-name #f) (set! source-file-position #f) (if (not (null? .rest|1)) (begin (set! source-file-name (let ((.x|425|428 .rest|1)) (begin (.check! (pair? .x|425|428) 0 .x|425|428) (car:pair .x|425|428)))) (if (not (null? (let ((.x|429|432 .rest|1)) (begin (.check! (pair? .x|429|432) 1 .x|429|432) (cdr:pair .x|429|432))))) (set! source-file-position (let ((.x|434|437 (let ((.x|438|441 .rest|1)) (begin (.check! (pair? .x|438|441) 1 .x|438|441) (cdr:pair .x|438|441))))) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437)))) (unspecified))) (unspecified)) (.part1|2))))) 'pass1-block))
+(let () (begin (set! make-available-table (lambda () (let ((.make-available-table|2 0)) (begin (set! .make-available-table|2 (lambda () (let* ((.t|4|6|11 '()) (.t|4|5|14 '()) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))))) (.make-available-table|2))))) 'make-available-table))
+(let () (begin (set! copy-available-table (lambda (.available|1) (let ((.copy-available-table|2 0)) (begin (set! .copy-available-table|2 (lambda (.available|3) (let* ((.t|4|6|11 (let ((.v|29|32 .available|3) (.i|29|32 1)) (begin (.check! (fixnum? .i|29|32) 40 .v|29|32 .i|29|32) (.check! (vector? .v|29|32) 40 .v|29|32 .i|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 40 .v|29|32 .i|29|32) (.check! (>=:fix:fix .i|29|32 0) 40 .v|29|32 .i|29|32) (vector-ref:trusted .v|29|32 .i|29|32)))) (.t|4|5|14 (let ((.v|25|28 .available|3) (.i|25|28 0)) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28)))) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))))) (.copy-available-table|2 .available|1))))) 'copy-available-table))
+(let () (begin (set! available-expression (lambda (.available|1 .e|1) (let ((.available-expression|2 0)) (begin (set! .available-expression|2 (lambda (.available|3 .e|3) (let ((.binding|6 (assoc .e|3 (let ((.v|16|19 .available|3) (.i|16|19 0)) (begin (.check! (fixnum? .i|16|19) 40 .v|16|19 .i|16|19) (.check! (vector? .v|16|19) 40 .v|16|19 .i|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 40 .v|16|19 .i|16|19) (.check! (>=:fix:fix .i|16|19 0) 40 .v|16|19 .i|16|19) (vector-ref:trusted .v|16|19 .i|16|19)))))) (if .binding|6 (let ((.x|8|11 (let ((.x|12|15 .binding|6)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) #f)))) (.available-expression|2 .available|1 .e|1))))) 'available-expression))
+(let () (begin (set! available-variable (lambda (.available|1 .t|1) (let ((.available-variable|2 0)) (begin (set! .available-variable|2 (lambda (.available|3 .t|3) (let ((.binding|6 (assq .t|3 (let ((.v|16|19 .available|3) (.i|16|19 1)) (begin (.check! (fixnum? .i|16|19) 40 .v|16|19 .i|16|19) (.check! (vector? .v|16|19) 40 .v|16|19 .i|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 40 .v|16|19 .i|16|19) (.check! (>=:fix:fix .i|16|19 0) 40 .v|16|19 .i|16|19) (vector-ref:trusted .v|16|19 .i|16|19)))))) (if .binding|6 (let ((.x|8|11 (let ((.x|12|15 .binding|6)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) #f)))) (.available-variable|2 .available|1 .t|1))))) 'available-variable))
+(let () (begin (set! available-extend! (lambda (.available|1 .t|1 .e|1 .k|1) (let ((.available-extend!|2 0)) (begin (set! .available-extend!|2 (lambda (.available|3 .t|3 .e|3 .k|3) (if (constant? .e|3) (let ((.v|5|8 .available|3) (.i|5|8 1) (.x|5|8 (cons (let* ((.t1|9|12 .t|3) (.t2|9|15 (let* ((.t1|19|22 .e|3) (.t2|19|25 (cons .k|3 '()))) (let () (cons .t1|19|22 .t2|19|25))))) (let () (cons .t1|9|12 .t2|9|15))) (let ((.v|30|33 .available|3) (.i|30|33 1)) (begin (.check! (fixnum? .i|30|33) 40 .v|30|33 .i|30|33) (.check! (vector? .v|30|33) 40 .v|30|33 .i|30|33) (.check! (<:fix:fix .i|30|33 (vector-length:vec .v|30|33)) 40 .v|30|33 .i|30|33) (.check! (>=:fix:fix .i|30|33 0) 40 .v|30|33 .i|30|33) (vector-ref:trusted .v|30|33 .i|30|33)))))) (begin (.check! (fixnum? .i|5|8) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (vector? .v|5|8) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (<:fix:fix .i|5|8 (vector-length:vec .v|5|8)) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (>=:fix:fix .i|5|8 0) 41 .v|5|8 .i|5|8 .x|5|8) (vector-set!:trusted .v|5|8 .i|5|8 .x|5|8))) (if (if (variable? .e|3) (eq? .k|3 available:killer:none) #f) (let ((.v|37|40 .available|3) (.i|37|40 1) (.x|37|40 (cons (let* ((.t1|41|44 .t|3) (.t2|41|47 (let* ((.t1|51|54 .e|3) (.t2|51|57 (cons .k|3 '()))) (let () (cons .t1|51|54 .t2|51|57))))) (let () (cons .t1|41|44 .t2|41|47))) (let ((.v|62|65 .available|3) (.i|62|65 1)) (begin (.check! (fixnum? .i|62|65) 40 .v|62|65 .i|62|65) (.check! (vector? .v|62|65) 40 .v|62|65 .i|62|65) (.check! (<:fix:fix .i|62|65 (vector-length:vec .v|62|65)) 40 .v|62|65 .i|62|65) (.check! (>=:fix:fix .i|62|65 0) 40 .v|62|65 .i|62|65) (vector-ref:trusted .v|62|65 .i|62|65)))))) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) (let ((.v|67|70 .available|3) (.i|67|70 0) (.x|67|70 (cons (let* ((.t1|71|74 .e|3) (.t2|71|77 (let* ((.t1|81|84 .t|3) (.t2|81|87 (cons .k|3 '()))) (let () (cons .t1|81|84 .t2|81|87))))) (let () (cons .t1|71|74 .t2|71|77))) (let ((.v|92|95 .available|3) (.i|92|95 0)) (begin (.check! (fixnum? .i|92|95) 40 .v|92|95 .i|92|95) (.check! (vector? .v|92|95) 40 .v|92|95 .i|92|95) (.check! (<:fix:fix .i|92|95 (vector-length:vec .v|92|95)) 40 .v|92|95 .i|92|95) (.check! (>=:fix:fix .i|92|95 0) 40 .v|92|95 .i|92|95) (vector-ref:trusted .v|92|95 .i|92|95)))))) (begin (.check! (fixnum? .i|67|70) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (vector? .v|67|70) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (<:fix:fix .i|67|70 (vector-length:vec .v|67|70)) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (>=:fix:fix .i|67|70 0) 41 .v|67|70 .i|67|70 .x|67|70) (vector-set!:trusted .v|67|70 .i|67|70 .x|67|70))))))) (.available-extend!|2 .available|1 .t|1 .e|1 .k|1))))) 'available-extend!))
+(let () (begin (set! available-kill! (lambda (.available|1 .k|1) (let ((.available-kill!|2 0)) (begin (set! .available-kill!|2 (lambda (.available|3 .k|3) (begin (let ((.v|4|7 .available|3) (.i|4|7 0) (.x|4|7 (filter (lambda (.binding|8) (zero? (logand .k|3 (let ((.x|10|13 (let ((.x|14|17 (let ((.x|18|21 .binding|8)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))))) (let ((.v|22|25 .available|3) (.i|22|25 0)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25)))))) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (let ((.v|26|29 .available|3) (.i|26|29 1) (.x|26|29 (filter (lambda (.binding|30) (zero? (logand .k|3 (let ((.x|32|35 (let ((.x|36|39 (let ((.x|40|43 .binding|30)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))))) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35)))))) (let ((.v|44|47 .available|3) (.i|44|47 1)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47)))))) (begin (.check! (fixnum? .i|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (vector? .v|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (<:fix:fix .i|26|29 (vector-length:vec .v|26|29)) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (>=:fix:fix .i|26|29 0) 41 .v|26|29 .i|26|29 .x|26|29) (vector-set!:trusted .v|26|29 .i|26|29 .x|26|29)))))) (.available-kill!|2 .available|1 .k|1))))) 'available-kill!))
+(let () (begin (set! available-intersect! (lambda (.available0|1 .available1|1 .available2|1) (let ((.available-intersect!|2 0)) (begin (set! .available-intersect!|2 (lambda (.available0|3 .available1|3 .available2|3) (begin (let ((.v|4|7 .available0|3) (.i|4|7 0) (.x|4|7 (intersection (let ((.v|8|11 .available1|3) (.i|8|11 0)) (begin (.check! (fixnum? .i|8|11) 40 .v|8|11 .i|8|11) (.check! (vector? .v|8|11) 40 .v|8|11 .i|8|11) (.check! (<:fix:fix .i|8|11 (vector-length:vec .v|8|11)) 40 .v|8|11 .i|8|11) (.check! (>=:fix:fix .i|8|11 0) 40 .v|8|11 .i|8|11) (vector-ref:trusted .v|8|11 .i|8|11))) (let ((.v|12|15 .available2|3) (.i|12|15 0)) (begin (.check! (fixnum? .i|12|15) 40 .v|12|15 .i|12|15) (.check! (vector? .v|12|15) 40 .v|12|15 .i|12|15) (.check! (<:fix:fix .i|12|15 (vector-length:vec .v|12|15)) 40 .v|12|15 .i|12|15) (.check! (>=:fix:fix .i|12|15 0) 40 .v|12|15 .i|12|15) (vector-ref:trusted .v|12|15 .i|12|15)))))) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (let ((.v|16|19 .available0|3) (.i|16|19 1) (.x|16|19 (intersection (let ((.v|20|23 .available1|3) (.i|20|23 1)) (begin (.check! (fixnum? .i|20|23) 40 .v|20|23 .i|20|23) (.check! (vector? .v|20|23) 40 .v|20|23 .i|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 40 .v|20|23 .i|20|23) (.check! (>=:fix:fix .i|20|23 0) 40 .v|20|23 .i|20|23) (vector-ref:trusted .v|20|23 .i|20|23))) (let ((.v|24|27 .available2|3) (.i|24|27 1)) (begin (.check! (fixnum? .i|24|27) 40 .v|24|27 .i|24|27) (.check! (vector? .v|24|27) 40 .v|24|27 .i|24|27) (.check! (<:fix:fix .i|24|27 (vector-length:vec .v|24|27)) 40 .v|24|27 .i|24|27) (.check! (>=:fix:fix .i|24|27 0) 40 .v|24|27 .i|24|27) (vector-ref:trusted .v|24|27 .i|24|27)))))) (begin (.check! (fixnum? .i|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (vector? .v|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (>=:fix:fix .i|16|19 0) 41 .v|16|19 .i|16|19 .x|16|19) (vector-set!:trusted .v|16|19 .i|16|19 .x|16|19)))))) (.available-intersect!|2 .available0|1 .available1|1 .available2|1))))) 'available-intersect!))
+(let () (begin (set! available:killer:globals 2) 'available:killer:globals))
+(let () (begin (set! available:killer:car 4) 'available:killer:car))
+(let () (begin (set! available:killer:cdr 8) 'available:killer:cdr))
+(let () (begin (set! available:killer:string 16) 'available:killer:string))
+(let () (begin (set! available:killer:vector 32) 'available:killer:vector))
+(let () (begin (set! available:killer:cell 64) 'available:killer:cell))
+(let () (begin (set! available:killer:io 128) 'available:killer:io))
+(let () (begin (set! available:killer:none 0) 'available:killer:none))
+(let () (begin (set! available:killer:all 1022) 'available:killer:all))
+(let () (begin (set! available:killer:immortal 0) 'available:killer:immortal))
+(let () (begin (set! available:killer:dead 1023) 'available:killer:dead))
+(let () (begin (set! available:killer-combine (lambda (.k1|1 .k2|1) (let ((.available:killer-combine|2 0)) (begin (set! .available:killer-combine|2 (lambda (.k1|3 .k2|3) (logior .k1|3 .k2|3))) (.available:killer-combine|2 .k1|1 .k2|1))))) 'available:killer-combine))
+(let () (begin (set! simple-lambda? (lambda (.l|1) (let ((.simple-lambda?|2 0)) (begin (set! .simple-lambda?|2 (lambda (.l|3) (if (null? (lambda.defs .l|3)) (every? (lambda (.decl|6) (eq? .decl|6 a-normal-form-declaration)) (lambda.decls .l|3)) #f))) (.simple-lambda?|2 .l|1))))) 'simple-lambda?))
+(let () (begin (set! real-call? (lambda (.e|1) (let ((.real-call?|2 0)) (begin (set! .real-call?|2 (lambda (.e|3) (if (call? .e|3) (let ((.proc|8 (call.proc .e|3))) (if (not (lambda? .proc|8)) (let ((.temp|11|14 (not (variable? .proc|8)))) (if .temp|11|14 .temp|11|14 (let* ((.f|18 (variable.name .proc|8)) (.temp|19|22 (not (integrate-usual-procedures)))) (if .temp|19|22 .temp|19|22 (not (prim-entry .f|18)))))) #f)) #f))) (.real-call?|2 .e|1))))) 'real-call?))
+(let () (begin (set! prim-call (lambda (.e|1) (let ((.prim-call|2 0)) (begin (set! .prim-call|2 (lambda (.e|3) (if (call? .e|3) (let ((.proc|8 (call.proc .e|3))) (if (variable? .proc|8) (if (integrate-usual-procedures) (prim-entry (variable.name .proc|8)) #f) #f)) #f))) (.prim-call|2 .e|1))))) 'prim-call))
+(let () (begin (set! no-side-effects? (lambda (.e|1) (let ((.no-side-effects?|2 0)) (begin (set! .no-side-effects?|2 (lambda (.e|3) (let ((.temp|4|7 (constant? .e|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (variable? .e|3))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (lambda? .e|3))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (if (conditional? .e|3) (if (.no-side-effects?|2 (if.test .e|3)) (if (.no-side-effects?|2 (if.then .e|3)) (.no-side-effects?|2 (if.else .e|3)) #f) #f) #f))) (if .temp|16|19 .temp|16|19 (if (call? .e|3) (let ((.proc|25 (call.proc .e|3))) (if (variable? .proc|25) (if (integrate-usual-procedures) (let ((.entry|31 (prim-entry (variable.name .proc|25)))) (if .entry|31 (not (eq? available:killer:dead (prim-lives-until .entry|31))) #f)) #f) #f)) #f))))))))))) (.no-side-effects?|2 .e|1))))) 'no-side-effects?))
+(let () (begin (set! temporary-used-once? (lambda (.t|1 .e|1 .used-once|1) (let ((.temporary-used-once?|2 0)) (begin (set! .temporary-used-once?|2 (lambda (.t|3 .e|3 .used-once|3) (if (call? .e|3) (let ((.proc|7 (call.proc .e|3)) (.args|7 (call.args .e|3))) (let ((.temp|8|11 (if (lambda? .proc|7) (if (not (memq .t|3 (lambda.f .proc|7))) (if (pair? .args|7) (if (null? (let ((.x|47|50 .args|7)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))) (.temporary-used-once?|2 .t|3 (let ((.x|52|55 .args|7)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))) .used-once|3) #f) #f) #f) #f))) (if .temp|8|11 .temp|8|11 (let () (let ((.loop|13|16|19 (unspecified))) (begin (set! .loop|13|16|19 (lambda (.exprs|20 .n|20) (if (let ((.temp|22|25 (null? .exprs|20))) (if .temp|22|25 .temp|22|25 (> .n|20 1))) (= .n|20 1) (begin #t (.loop|13|16|19 (let ((.x|28|31 .exprs|20)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))) (let ((.exp|34 (let ((.x|38|41 .exprs|20)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (if (constant? .exp|34) .n|20 (if (variable? .exp|34) (if (eq? .t|3 (variable.name .exp|34)) (+ .n|20 1) .n|20) 2)))))))) (.loop|13|16|19 (cons .proc|7 (call.args .e|3)) 0))))))) (memq .t|3 .used-once|3)))) (.temporary-used-once?|2 .t|1 .e|1 .used-once|1))))) 'temporary-used-once?))
+(let () (begin (set! make-regbinding (lambda (.lhs|1 .rhs|1 .use|1) (let ((.make-regbinding|2 0)) (begin (set! .make-regbinding|2 (lambda (.lhs|3 .rhs|3 .use|3) (let* ((.t1|4|7 .lhs|3) (.t2|4|10 (let* ((.t1|14|17 .rhs|3) (.t2|14|20 (cons .use|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-regbinding|2 .lhs|1 .rhs|1 .use|1))))) 'make-regbinding))
+(let () (begin (set! regbinding.lhs (lambda (.x|1) (let ((.regbinding.lhs|2 0)) (begin (set! .regbinding.lhs|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.regbinding.lhs|2 .x|1))))) 'regbinding.lhs))
+(let () (begin (set! regbinding.rhs (lambda (.x|1) (let ((.regbinding.rhs|2 0)) (begin (set! .regbinding.rhs|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.regbinding.rhs|2 .x|1))))) 'regbinding.rhs))
+(let () (begin (set! regbinding.use (lambda (.x|1) (let ((.regbinding.use|2 0)) (begin (set! .regbinding.use|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.regbinding.use|2 .x|1))))) 'regbinding.use))
+(let () (begin (set! wrap-with-register-bindings (lambda (.regbindings|1 .e|1 .f|1) (let ((.wrap-with-register-bindings|2 0)) (begin (set! .wrap-with-register-bindings|2 (lambda (.regbindings|3 .e|3 .f|3) (if (null? .regbindings|3) (values .e|3 .f|3) (let* ((.regbinding|6 (let ((.x|25|28 .regbindings|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) (.r|9 (regbinding.lhs .regbinding|6)) (.x|12 (regbinding.rhs .regbinding|6))) (let () (.wrap-with-register-bindings|2 (let ((.x|16|19 .regbindings|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (make-call (make-lambda (cons .r|9 '()) '() '() .f|3 .f|3 (cons a-normal-form-declaration '()) #f .e|3) (cons (make-variable .x|12) '())) (union (cons .x|12 '()) (difference .f|3 (cons .r|9 '()))))))))) (.wrap-with-register-bindings|2 .regbindings|1 .e|1 .f|1))))) 'wrap-with-register-bindings))
+(let () (begin (set! register-bindings (lambda (.regbindings|1 .x|1) (let ((.register-bindings|2 0)) (begin (set! .register-bindings|2 (lambda (.regbindings|3 .x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.regbindings|5 .to-x|5 .others|5) (if (null? .regbindings|5) (values .to-x|5 .others|5) (if (eq? .x|3 (regbinding.rhs (let ((.x|8|11 .regbindings|5)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))))) (.loop|4 (let ((.x|12|15 .regbindings|5)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) (cons (let ((.x|16|19 .regbindings|5)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))) .to-x|5) .others|5) (.loop|4 (let ((.x|21|24 .regbindings|5)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) .to-x|5 (cons (let ((.x|25|28 .regbindings|5)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) .others|5)))))) (.loop|4 .regbindings|3 '() '()))))) (.register-bindings|2 .regbindings|1 .x|1))))) 'register-bindings))
+(let () (begin (set! declaration-error (lambda (.e|1) (let ((.declaration-error|2 0)) (begin (set! .declaration-error|2 (lambda (.e|3) (if (issue-warnings) (begin (display "WARNING: Assertion is false: ") (write (make-readable .e|3 #t)) (newline)) (unspecified)))) (.declaration-error|2 .e|1))))) 'declaration-error))
+(let () (begin (set! *nreps* 0) '*nreps*))
+(let () (begin (set! *rep-encodings* '()) '*rep-encodings*))
+(let () (begin (set! *rep-decodings* '()) '*rep-decodings*))
+(let () (begin (set! *rep-subtypes* '()) '*rep-subtypes*))
+(let () (begin (set! *rep-joins* (make-bytevector 0)) '*rep-joins*))
+(let () (begin (set! *rep-meets* (make-bytevector 0)) '*rep-meets*))
+(let () (begin (set! *rep-joins-special* '#()) '*rep-joins-special*))
+(let () (begin (set! *rep-meets-special* '#()) '*rep-meets-special*))
+(let () (begin (set! representation-error (lambda (.msg|1 . .stuff|1) (apply error (if (string? .msg|1) (string-append "Bug in flow analysis: " .msg|1) .msg|1) .stuff|1))) 'representation-error))
+(let () (begin (set! symbol->rep (lambda (.sym|1) (let ((.symbol->rep|2 0)) (begin (set! .symbol->rep|2 (lambda (.sym|3) (let ((.probe|6 (assq .sym|3 *rep-encodings*))) (if .probe|6 (let ((.x|7|10 .probe|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) (let ((.rep|13 *nreps*)) (begin (set! *nreps* (+ *nreps* 1)) (if (> *nreps* 255) (representation-error "Too many representation types") (unspecified)) (set! *rep-encodings* (cons (cons .sym|3 .rep|13) *rep-encodings*)) (set! *rep-decodings* (cons (cons .rep|13 .sym|3) *rep-decodings*)) .rep|13)))))) (.symbol->rep|2 .sym|1))))) 'symbol->rep))
+(let () (begin (set! rep->symbol (lambda (.rep|1) (let ((.rep->symbol|2 0)) (begin (set! .rep->symbol|2 (lambda (.rep|3) (if (pair? .rep|3) (cons (.rep->symbol|2 (let ((.x|4|7 .rep|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (let ((.x|8|11 .rep|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))) (let ((.probe|14 (assv .rep|3 *rep-decodings*))) (if .probe|14 (let ((.x|15|18 .probe|14)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) 'unknown))))) (.rep->symbol|2 .rep|1))))) 'rep->symbol))
+(let () (begin (set! representation-table (lambda (.table|1) (let ((.representation-table|2 0)) (begin (set! .representation-table|2 (lambda (.table|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.row|24 (let ((.x|74|77 .y1|4|5|16)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77))))) (let () (let ((.loop|30|33|36 (unspecified))) (begin (set! .loop|30|33|36 (lambda (.y1|25|26|37 .results|25|29|37) (if (null? .y1|25|26|37) (reverse .results|25|29|37) (begin #t (.loop|30|33|36 (let ((.x|41|44 .y1|25|26|37)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))) (cons (let ((.x|45 (let ((.x|70|73 .y1|25|26|37)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (if (list? .x|45) (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (symbol->rep (let ((.x|66|69 .y1|46|47|58)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69)))) .results|46|50|58)))))) (.loop|51|54|57 .x|45 '())))) .x|45)) .results|25|29|37)))))) (.loop|30|33|36 .row|24 '()))))) .results|4|8|16)))))) (.loop|9|12|15 .table|3 '())))))) (.representation-table|2 .table|1))))) 'representation-table))
+(let () (begin (set! define-subtype (lambda (.sym1|1 .sym2|1) (let ((.define-subtype|2 0)) (begin (set! .define-subtype|2 (lambda (.sym1|3 .sym2|3) (let* ((.rep2|6 (symbol->rep .sym2|3)) (.rep1|9 (symbol->rep .sym1|3))) (let () (begin (set! *rep-subtypes* (cons (cons .rep1|9 .rep2|6) *rep-subtypes*)) .sym1|3))))) (.define-subtype|2 .sym1|1 .sym2|1))))) 'define-subtype))
+(let () (begin (set! define-intersection (lambda (.sym1|1 .sym2|1 .sym3|1) (let ((.define-intersection|2 0)) (begin (set! .define-intersection|2 (lambda (.sym1|3 .sym2|3 .sym3|3) (let ((.rep1|6 (symbol->rep .sym1|3)) (.rep2|6 (symbol->rep .sym2|3)) (.rep3|6 (symbol->rep .sym3|3))) (begin (representation-aset! *rep-meets* .rep1|6 .rep2|6 .rep3|6) (representation-aset! *rep-meets* .rep2|6 .rep1|6 .rep3|6))))) (.define-intersection|2 .sym1|1 .sym2|1 .sym3|1))))) 'define-intersection))
+(let () (begin (set! representation-aref (lambda (.bv|1 .i|1 .j|1) (let ((.representation-aref|2 0)) (begin (set! .representation-aref|2 (lambda (.bv|3 .i|3 .j|3) (bytevector-ref .bv|3 (+ (* *nreps* .i|3) .j|3)))) (.representation-aref|2 .bv|1 .i|1 .j|1))))) 'representation-aref))
+(let () (begin (set! representation-aset! (lambda (.bv|1 .i|1 .j|1 .x|1) (let ((.representation-aset!|2 0)) (begin (set! .representation-aset!|2 (lambda (.bv|3 .i|3 .j|3 .x|3) (bytevector-set! .bv|3 (+ (* *nreps* .i|3) .j|3) .x|3))) (.representation-aset!|2 .bv|1 .i|1 .j|1 .x|1))))) 'representation-aset!))
+(let () (begin (set! compute-unions! (lambda () (let ((.compute-unions!|2 0)) (begin (set! .compute-unions!|2 (lambda () (begin (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|19 (let ((.x|20|23 .y1|4|5|15)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (define-subtype 'bottom .sym|19))) (.loop|9|11|14 (let ((.x|24|27 .y1|4|5|15)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|9|11|14 (let () (let ((.loop|33|36|39 (unspecified))) (begin (set! .loop|33|36|39 (lambda (.y1|28|29|40 .results|28|32|40) (if (null? .y1|28|29|40) (reverse .results|28|32|40) (begin #t (.loop|33|36|39 (let ((.x|44|47 .y1|28|29|40)) (begin (.check! (pair? .x|44|47) 1 .x|44|47) (cdr:pair .x|44|47))) (cons (let ((.x|48|51 (let ((.x|52|55 .y1|28|29|40)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (begin (.check! (pair? .x|48|51) 0 .x|48|51) (car:pair .x|48|51))) .results|28|32|40)))))) (.loop|33|36|39 *rep-encodings* '())))))))) (let* ((.debugging?|58 #f) (.n|61 *nreps*) (.n^2|64 (* .n|61 .n|61)) (.matrix|67 (make-bytevector .n^2|64))) (let () (let ((.compute-joins!|73 (unspecified)) (.compute-transitive-closure!|73 (unspecified)) (.join|73 (unspecified)) (.lub|73 (unspecified))) (begin (set! .compute-joins!|73 (lambda () (begin (let ((.default|77 (lambda (.x|78 .y|78) (error "Compiler bug: special meet or join" .x|78 .y|78)))) (begin (set! *rep-joins-special* (make-vector .n|61 .default|77)) (set! *rep-meets-special* (make-vector .n|61 .default|77)))) (set! *rep-joins* (make-bytevector .n^2|64)) (set! *rep-meets* (make-bytevector .n^2|64)) (let () (let ((.loop|80|82|85 (unspecified))) (begin (set! .loop|80|82|85 (lambda (.i|86) (if (= .i|86 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|90|92|95 (unspecified))) (begin (set! .loop|90|92|95 (lambda (.j|96) (if (= .j|96 .n|61) (if #f #f (unspecified)) (begin (begin #t (representation-aset! *rep-joins* .i|86 .j|96 (.join|73 .i|86 .j|96))) (.loop|90|92|95 (+ .j|96 1)))))) (.loop|90|92|95 0))))) (.loop|80|82|85 (+ .i|86 1)))))) (.loop|80|82|85 0))))))) (set! .compute-transitive-closure!|73 (lambda () (let* ((.changed?|102 #f) (.loop|103 (unspecified))) (begin (set! .loop|103 (lambda () (begin (let () (let ((.loop|106|108|111 (unspecified))) (begin (set! .loop|106|108|111 (lambda (.i|112) (if (= .i|112 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|116|118|121 (unspecified))) (begin (set! .loop|116|118|121 (lambda (.k|122) (if (= .k|122 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.j|132 .sum|132) (if (= .j|132 .n|61) (if (> .sum|132 0) (let ((.x|136 (representation-aref .matrix|67 .i|112 .k|122))) (if (zero? .x|136) (begin (set! .changed?|102 #t) (representation-aset! .matrix|67 .i|112 .k|122 1)) (unspecified))) (unspecified)) (begin #t (.loop|125|128|131 (+ .j|132 1) (logior .sum|132 (logand (representation-aref .matrix|67 .i|112 .j|132) (representation-aref .matrix|67 .j|132 .k|122)))))))) (.loop|125|128|131 0 0))))) (.loop|116|118|121 (+ .k|122 1)))))) (.loop|116|118|121 0))))) (.loop|106|108|111 (+ .i|112 1)))))) (.loop|106|108|111 0)))) (if .changed?|102 (begin (set! .changed?|102 #f) (.loop|103)) (unspecified))))) (.loop|103))))) (set! .join|73 (lambda (.i|138 .j|138) (.lub|73 .i|138 .j|138 (lambda (.rep1|139 .rep2|139) (= 1 (representation-aref .matrix|67 .rep1|139 .rep2|139)))))) (set! .lub|73 (lambda (.rep1|140 .rep2|140 .subtype?|140) (let () (let ((.loop|141|144|147 (unspecified))) (begin (set! .loop|141|144|147 (lambda (.i|148 .bounds|148) (if (= .i|148 .n|61) (let ((.x|150|153 (twobit-sort .subtype?|140 .bounds|148))) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))) (begin #t (.loop|141|144|147 (+ .i|148 1) (if (if (.subtype?|140 .rep1|140 .i|148) (.subtype?|140 .rep2|140 .i|148) #f) (cons .i|148 .bounds|148) .bounds|148)))))) (.loop|141|144|147 0 '())))))) (let () (let ((.loop|72|158|161 (unspecified))) (begin (set! .loop|72|158|161 (lambda (.i|162) (if (= .i|162 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|166|168|171 (unspecified))) (begin (set! .loop|166|168|171 (lambda (.j|172) (if (= .j|172 .n|61) (if #f #f (unspecified)) (begin (begin #t (representation-aset! .matrix|67 .i|162 .j|172 0)) (.loop|166|168|171 (+ .j|172 1)))))) (.loop|166|168|171 0)))) (representation-aset! .matrix|67 .i|162 .i|162 1)) (.loop|72|158|161 (+ .i|162 1)))))) (.loop|72|158|161 0)))) (let () (let ((.loop|180|182|185 (unspecified))) (begin (set! .loop|180|182|185 (lambda (.y1|175|176|186) (if (null? .y1|175|176|186) (if #f #f (unspecified)) (begin (begin #t (let ((.subtype|190 (let ((.x|202|205 .y1|175|176|186)) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205))))) (let ((.rep1|193 (let ((.x|194|197 .subtype|190)) (begin (.check! (pair? .x|194|197) 0 .x|194|197) (car:pair .x|194|197)))) (.rep2|193 (let ((.x|198|201 .subtype|190)) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))))) (representation-aset! .matrix|67 .rep1|193 .rep2|193 1)))) (.loop|180|182|185 (let ((.x|206|209 .y1|175|176|186)) (begin (.check! (pair? .x|206|209) 1 .x|206|209) (cdr:pair .x|206|209)))))))) (.loop|180|182|185 *rep-subtypes*)))) (.compute-transitive-closure!|73) (if .debugging?|58 (let () (let ((.loop|211|213|216 (unspecified))) (begin (set! .loop|211|213|216 (lambda (.i|217) (if (= .i|217 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|221|223|226 (unspecified))) (begin (set! .loop|221|223|226 (lambda (.j|227) (if (= .j|227 .n|61) (if #f #f (unspecified)) (begin (begin #t (write-char #\space) (write (representation-aref .matrix|67 .i|217 .j|227))) (.loop|221|223|226 (+ .j|227 1)))))) (.loop|221|223|226 0)))) (newline)) (.loop|211|213|216 (+ .i|217 1)))))) (.loop|211|213|216 0)))) (unspecified)) (.compute-joins!|73) (set! *rep-subtypes* '())))))))) (.compute-unions!|2))))) 'compute-unions!))
+(let () (begin (set! compute-intersections! (lambda () (let ((.compute-intersections!|2 0)) (begin (set! .compute-intersections!|2 (lambda () (let* ((.n|6 *nreps*) (.meet|9 (unspecified))) (begin (set! .meet|9 (lambda (.i|10 .j|10) (let ((.k|13 (representation-union .i|10 .j|10))) (if (= .i|10 .k|13) .j|10 .i|10)))) (let () (let ((.loop|8|15|18 (unspecified))) (begin (set! .loop|8|15|18 (lambda (.i|19) (if (= .i|19 .n|6) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.j|29) (if (= .j|29 .n|6) (if #f #f (unspecified)) (begin (begin #t (representation-aset! *rep-meets* .i|19 .j|29 (.meet|9 .i|19 .j|29))) (.loop|23|25|28 (+ .j|29 1)))))) (.loop|23|25|28 0))))) (.loop|8|15|18 (+ .i|19 1)))))) (.loop|8|15|18 0)))))))) (.compute-intersections!|2))))) 'compute-intersections!))
+(let () (begin (set! compute-type-structure! (lambda () (let ((.compute-type-structure!|2 0)) (begin (set! .compute-type-structure!|2 (lambda () (begin (compute-unions!) (compute-intersections!)))) (.compute-type-structure!|2))))) 'compute-type-structure!))
+(let () (begin (set! representation-subtype? (lambda (.rep1|1 .rep2|1) (let ((.representation-subtype?|2 0)) (begin (set! .representation-subtype?|2 (lambda (.rep1|3 .rep2|3) (equal? .rep2|3 (representation-union .rep1|3 .rep2|3)))) (.representation-subtype?|2 .rep1|1 .rep2|1))))) 'representation-subtype?))
+(let () (begin (set! representation-union (lambda (.rep1|1 .rep2|1) (let ((.representation-union|2 0)) (begin (set! .representation-union|2 (lambda (.rep1|3 .rep2|3) (if (fixnum? .rep1|3) (if (fixnum? .rep2|3) (representation-aref *rep-joins* .rep1|3 .rep2|3) (.representation-union|2 .rep1|3 (let ((.x|4|7 .rep2|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (if (fixnum? .rep2|3) (.representation-union|2 (let ((.x|8|11 .rep1|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .rep2|3) (let ((.r1|14 (let ((.x|19|22 .rep1|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (.r2|14 (let ((.x|23|26 .rep2|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (= .r1|14 .r2|14) ((let ((.v|15|18 *rep-joins-special*) (.i|15|18 .r1|14)) (begin (.check! (fixnum? .i|15|18) 40 .v|15|18 .i|15|18) (.check! (vector? .v|15|18) 40 .v|15|18 .i|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 40 .v|15|18 .i|15|18) (.check! (>=:fix:fix .i|15|18 0) 40 .v|15|18 .i|15|18) (vector-ref:trusted .v|15|18 .i|15|18))) .rep1|3 .rep2|3) (.representation-union|2 .r1|14 .r2|14))))))) (.representation-union|2 .rep1|1 .rep2|1))))) 'representation-union))
+(let () (begin (set! representation-intersection (lambda (.rep1|1 .rep2|1) (let ((.representation-intersection|2 0)) (begin (set! .representation-intersection|2 (lambda (.rep1|3 .rep2|3) (if (fixnum? .rep1|3) (if (fixnum? .rep2|3) (representation-aref *rep-meets* .rep1|3 .rep2|3) (.representation-intersection|2 .rep1|3 (let ((.x|4|7 .rep2|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (if (fixnum? .rep2|3) (.representation-intersection|2 (let ((.x|8|11 .rep1|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .rep2|3) (let ((.r1|14 (let ((.x|19|22 .rep1|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (.r2|14 (let ((.x|23|26 .rep2|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (= .r1|14 .r2|14) ((let ((.v|15|18 *rep-meets-special*) (.i|15|18 .r1|14)) (begin (.check! (fixnum? .i|15|18) 40 .v|15|18 .i|15|18) (.check! (vector? .v|15|18) 40 .v|15|18 .i|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 40 .v|15|18 .i|15|18) (.check! (>=:fix:fix .i|15|18 0) 40 .v|15|18 .i|15|18) (vector-ref:trusted .v|15|18 .i|15|18))) .rep1|3 .rep2|3) (.representation-intersection|2 .r1|14 .r2|14))))))) (.representation-intersection|2 .rep1|1 .rep2|1))))) 'representation-intersection))
+(let () (begin (set! display-unions-and-intersections (lambda () (let ((.display-unions-and-intersections|2 0)) (begin (set! .display-unions-and-intersections|2 (lambda () (let* ((.column-width|6 10) (.columns/row|9 (quotient 80 .column-width|6))) (let () (let ((.display-matrix|13 (unspecified)) (.display-symbol|13 (unspecified))) (begin (set! .display-matrix|13 (lambda (.f|14 .i|14 .n|14) (begin (display (make-string .column-width|6 #\space)) (let () (let ((.loop|16|18|21 (unspecified))) (begin (set! .loop|16|18|21 (lambda (.i|22) (if (= .i|22 .n|14) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol .i|22))) (.loop|16|18|21 (+ .i|22 1)))))) (.loop|16|18|21 .i|14)))) (newline) (newline) (let () (let ((.loop|26|28|31 (unspecified))) (begin (set! .loop|26|28|31 (lambda (.k|32) (if (= .k|32 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol .k|32)) (let () (let ((.loop|36|38|41 (unspecified))) (begin (set! .loop|36|38|41 (lambda (.i|42) (if (= .i|42 .n|14) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol (.f|14 .k|32 .i|42)))) (.loop|36|38|41 (+ .i|42 1)))))) (.loop|36|38|41 .i|14)))) (newline)) (.loop|26|28|31 (+ .k|32 1)))))) (.loop|26|28|31 0)))) (newline) (newline)))) (set! .display-symbol|13 (lambda (.sym|45) (let* ((.s|48 (symbol->string .sym|45)) (.n|51 (string-length .s|48))) (let () (if (< .n|51 .column-width|6) (begin (display .s|48) (display (make-string (- .column-width|6 .n|51) #\space))) (begin (display (substring .s|48 0 (- .column-width|6 1))) (write-char #\space))))))) (display "Unions:") (newline) (newline) (let () (let ((.loop|56|58|61 (unspecified))) (begin (set! .loop|56|58|61 (lambda (.i|62) (if (>= .i|62 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-matrix|13 representation-union .i|62 (min *nreps* (+ .i|62 .columns/row|9)))) (.loop|56|58|61 (+ .i|62 .columns/row|9)))))) (.loop|56|58|61 0)))) (display "Intersections:") (newline) (newline) (let () (let ((.loop|66|68|71 (unspecified))) (begin (set! .loop|66|68|71 (lambda (.i|72) (if (>= .i|72 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-matrix|13 representation-intersection .i|72 (min *nreps* (+ .i|72 .columns/row|9)))) (.loop|66|68|71 (+ .i|72 .columns/row|9)))))) (.loop|66|68|71 0)))))))))) (.display-unions-and-intersections|2))))) 'display-unions-and-intersections))
+(let () (begin (set! rep-specific? (lambda (.f|1 .rs|1) (let ((.rep-specific?|2 0)) (begin (set! .rep-specific?|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-specific caddr))) (.rep-specific?|2 .f|1 .rs|1))))) 'rep-specific?))
+(let () (begin (set! rep-result? (lambda (.f|1 .rs|1) (let ((.rep-result?|2 0)) (begin (set! .rep-result?|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-result caaddr))) (.rep-result?|2 .f|1 .rs|1))))) 'rep-result?))
+(let () (begin (set! rep-if-true (lambda (.f|1 .rs|1) (let ((.rep-if-true|2 0)) (begin (set! .rep-if-true|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-informing caddr))) (.rep-if-true|2 .f|1 .rs|1))))) 'rep-if-true))
+(let () (begin (set! rep-if-false (lambda (.f|1 .rs|1) (let ((.rep-if-false|2 0)) (begin (set! .rep-if-false|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-informing cadddr))) (.rep-if-false|2 .f|1 .rs|1))))) 'rep-if-false))
+(let () (begin (set! rep-match (lambda (.f|1 .rs|1 .table|1 .selector|1) (let ((.rep-match|2 0)) (begin (set! .rep-match|2 (lambda (.f|3 .rs|3 .table|3 .selector|3) (let* ((.n|6 (length .rs|3)) (.entries|9 .table|3)) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.entries|13) (if (null? .entries|13) #f (if (eq? .f|3 (let ((.x|16|19 (let ((.x|20|23 .entries|13)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (let ((.rs0|26 (let ((.x|88|91 (let ((.x|92|95 (let ((.x|96|99 .entries|13)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))))) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91))))) (if (if (= .n|6 (length .rs0|26)) (every? (lambda (.r1+r2|29) (let ((.r1|32 (let ((.x|33|36 .r1+r2|29)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))) (.r2|32 (let ((.x|37|40 .r1+r2|29)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (representation-subtype? .r1|32 .r2|32))) (let () (let ((.loop|47|51|54 (unspecified))) (begin (set! .loop|47|51|54 (lambda (.y1|41|43|55 .y1|41|42|55 .results|41|46|55) (if (let ((.temp|57|60 (null? .y1|41|43|55))) (if .temp|57|60 .temp|57|60 (null? .y1|41|42|55))) (reverse .results|41|46|55) (begin #t (.loop|47|51|54 (let ((.x|63|66 .y1|41|43|55)) (begin (.check! (pair? .x|63|66) 1 .x|63|66) (cdr:pair .x|63|66))) (let ((.x|67|70 .y1|41|42|55)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))) (cons (cons (let ((.x|71|74 .y1|41|43|55)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74))) (let ((.x|75|78 .y1|41|42|55)) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78)))) .results|41|46|55)))))) (.loop|47|51|54 .rs|3 .rs0|26 '()))))) #f) (.selector|3 (let ((.x|79|82 .entries|13)) (begin (.check! (pair? .x|79|82) 0 .x|79|82) (car:pair .x|79|82)))) (.loop|12 (let ((.x|83|86 .entries|13)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86)))))) (.loop|12 (let ((.x|101|104 .entries|13)) (begin (.check! (pair? .x|101|104) 1 .x|101|104) (cdr:pair .x|101|104)))))))) (.loop|12 .entries|9))))))) (.rep-match|2 .f|1 .rs|1 .table|1 .selector|1))))) 'rep-match))
+(let () (begin (set! aeval (lambda (.e|1 .types|1 .constraints|1) (let ((.aeval|2 0)) (begin (set! .aeval|2 (lambda (.e|3 .types|3 .constraints|3) (if (call? .e|3) (let ((.proc|7 (call.proc .e|3))) (if (variable? .proc|7) (let* ((.op|10 (variable.name .proc|7)) (.argtypes|13 (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.y1|20|21|32 .results|20|24|32) (if (null? .y1|20|21|32) (reverse .results|20|24|32) (begin #t (.loop|25|28|31 (let ((.x|36|39 .y1|20|21|32)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.e|40 (let ((.x|41|44 .y1|20|21|32)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (.aeval|2 .e|40 .types|3 .constraints|3)) .results|20|24|32)))))) (.loop|25|28|31 (call.args .e|3) '()))))) (.type|16 (rep-result? .op|10 .argtypes|13))) (let () (if .type|16 .type|16 rep:object))) rep:object)) (if (variable? .e|3) (representation-typeof (variable.name .e|3) .types|3 .constraints|3) (if (constant? .e|3) (representation-of-value (constant.value .e|3)) rep:object))))) (.aeval|2 .e|1 .types|1 .constraints|1))))) 'aeval))
+(let () (begin (set! representation-typeof (lambda (.name|1 .types|1 .constraints|1) (let ((.representation-typeof|2 0)) (begin (set! .representation-typeof|2 (lambda (.name|3 .types|3 .constraints|3) (let ((.t0|6 (hashtable-fetch .types|3 .name|3 rep:object)) (.cs|6 (hashtable-fetch (constraints.table .constraints|3) .name|3 '()))) (let ((.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.type|8 .cs|8) (if (null? .cs|8) .type|8 (let* ((.c|11 (let ((.x|28|31 .cs|8)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.cs|14 (let ((.x|24|27 .cs|8)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (.e|17 (constraint.rhs .c|11))) (let () (if (constant? .e|17) (.loop|7 (representation-intersection .type|8 (constant.value .e|17)) .cs|14) (if (call? .e|17) (.loop|7 (representation-intersection .type|8 (aeval .e|17 .types|3 .constraints|3)) .cs|14) (.loop|7 .type|8 .cs|14)))))))) (.loop|7 .t0|6 .cs|6)))))) (.representation-typeof|2 .name|1 .types|1 .constraints|1))))) 'representation-typeof))
+(let () (begin (set! make-constraint (lambda (.t|1 .e|1 .k|1) (let ((.make-constraint|2 0)) (begin (set! .make-constraint|2 (lambda (.t|3 .e|3 .k|3) (let* ((.t1|4|7 .t|3) (.t2|4|10 (let* ((.t1|14|17 .e|3) (.t2|14|20 (cons .k|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constraint|2 .t|1 .e|1 .k|1))))) 'make-constraint))
+(let () (begin (set! constraint.lhs (lambda (.c|1) (let ((.constraint.lhs|2 0)) (begin (set! .constraint.lhs|2 (lambda (.c|3) (let ((.x|4|7 .c|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.constraint.lhs|2 .c|1))))) 'constraint.lhs))
+(let () (begin (set! constraint.rhs (lambda (.c|1) (let ((.constraint.rhs|2 0)) (begin (set! .constraint.rhs|2 (lambda (.c|3) (let ((.x|5|8 (let ((.x|9|12 .c|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraint.rhs|2 .c|1))))) 'constraint.rhs))
+(let () (begin (set! constraint.killer (lambda (.c|1) (let ((.constraint.killer|2 0)) (begin (set! .constraint.killer|2 (lambda (.c|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .c|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraint.killer|2 .c|1))))) 'constraint.killer))
+(let () (begin (set! make-type-constraint (lambda (.t|1 .type|1 .k|1) (let ((.make-type-constraint|2 0)) (begin (set! .make-type-constraint|2 (lambda (.t|3 .type|3 .k|3) (make-constraint .t|3 (make-constant .type|3) .k|3))) (.make-type-constraint|2 .t|1 .type|1 .k|1))))) 'make-type-constraint))
+(let () (begin (set! constraints-add! (lambda (.types|1 .constraints|1 .new|1) (let ((.constraints-add!|2 0)) (begin (set! .constraints-add!|2 (lambda (.types|3 .constraints|3 .new|3) (let* ((.debugging?|6 #f) (.t|9 (constraint.lhs .new|3)) (.e|12 (constraint.rhs .new|3)) (.k|15 (constraint.killer .new|3)) (.cs|18 (constraints-for-variable .constraints|3 .t|9))) (let () (let ((.record-new-reps!|22 (unspecified)) (.loop|22 (unspecified))) (begin (set! .record-new-reps!|22 (lambda (.args|23 .argtypes|23 .reps|23 .k2|23) (begin (if .debugging?|6 (begin (write (let* ((.t1|24|27 (let () (let ((.loop|98|101|104 (unspecified))) (begin (set! .loop|98|101|104 (lambda (.y1|93|94|105 .results|93|97|105) (if (null? .y1|93|94|105) (reverse .results|93|97|105) (begin #t (.loop|98|101|104 (let ((.x|109|112 .y1|93|94|105)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))) (cons (make-readable (let ((.x|113|116 .y1|93|94|105)) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .results|93|97|105)))))) (.loop|98|101|104 .args|23 '()))))) (.t2|24|30 (let* ((.t1|34|37 (let () (let ((.loop|74|77|80 (unspecified))) (begin (set! .loop|74|77|80 (lambda (.y1|69|70|81 .results|69|73|81) (if (null? .y1|69|70|81) (reverse .results|69|73|81) (begin #t (.loop|74|77|80 (let ((.x|85|88 .y1|69|70|81)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88))) (cons (rep->symbol (let ((.x|89|92 .y1|69|70|81)) (begin (.check! (pair? .x|89|92) 0 .x|89|92) (car:pair .x|89|92)))) .results|69|73|81)))))) (.loop|74|77|80 .argtypes|23 '()))))) (.t2|34|40 (cons (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (rep->symbol (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .reps|23 '())))) '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30)))) (newline)) (unspecified)) (let () (let ((.loop|124|128|131 (unspecified))) (begin (set! .loop|124|128|131 (lambda (.y1|117|120|132 .y1|117|119|132 .y1|117|118|132) (if (let ((.temp|134|137 (null? .y1|117|120|132))) (if .temp|134|137 .temp|134|137 (let ((.temp|138|141 (null? .y1|117|119|132))) (if .temp|138|141 .temp|138|141 (null? .y1|117|118|132))))) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|144 (let ((.x|148|151 .y1|117|120|132)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151)))) (.type0|144 (let ((.x|152|155 .y1|117|119|132)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155)))) (.type1|144 (let ((.x|156|159 .y1|117|118|132)) (begin (.check! (pair? .x|156|159) 0 .x|156|159) (car:pair .x|156|159))))) (if (not (representation-subtype? .type0|144 .type1|144)) (if (variable? .arg|144) (let ((.name|147 (variable.name .arg|144))) (if (hashtable-get .types|3 .name|147) (.constraints-add!|2 .types|3 .constraints|3 (make-type-constraint .name|147 .type1|144 (available:killer-combine .k|15 .k2|23))) (cerror "Compiler bug: unexpected global: " .name|147))) (unspecified)) (unspecified)))) (.loop|124|128|131 (let ((.x|160|163 .y1|117|120|132)) (begin (.check! (pair? .x|160|163) 1 .x|160|163) (cdr:pair .x|160|163))) (let ((.x|164|167 .y1|117|119|132)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (let ((.x|168|171 .y1|117|118|132)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171)))))))) (.loop|124|128|131 .args|23 .argtypes|23 .reps|23))))))) (set! .loop|22 (lambda (.type|172 .k|172 .cs|172 .newcs|172) (if (null? .cs|172) (cons (make-type-constraint .t|9 .type|172 .k|172) .newcs|172) (let* ((.c2|175 (let ((.x|249|252 .cs|172)) (begin (.check! (pair? .x|249|252) 0 .x|249|252) (car:pair .x|249|252)))) (.cs|178 (let ((.x|245|248 .cs|172)) (begin (.check! (pair? .x|245|248) 1 .x|245|248) (cdr:pair .x|245|248)))) (.e2|181 (constraint.rhs .c2|175)) (.k2|184 (constraint.killer .c2|175))) (let () (if (constant? .e2|181) (let* ((.type2|190 (constant.value .e2|181)) (.type3|193 (representation-intersection .type|172 .type2|190))) (let () (if (eq? .type2|190 .type3|193) (if (= .k2|184 (logand .k|172 .k2|184)) (append .newcs|172 .cs|178) (.loop|22 (representation-intersection .type|172 .type2|190) (available:killer-combine .k|172 .k2|184) .cs|178 (cons .c2|175 .newcs|172))) (if (representation-subtype? .type|172 .type3|193) (if (= .k|172 (logand .k|172 .k2|184)) (.loop|22 .type|172 .k|172 .cs|178 .newcs|172) (.loop|22 .type|172 .k|172 .cs|178 (cons .c2|175 .newcs|172))) (.loop|22 .type3|193 (available:killer-combine .k|172 .k2|184) .cs|178 (cons .c2|175 .newcs|172)))))) (let* ((.op|202 (variable.name (call.proc .e2|181))) (.args|205 (call.args .e2|181)) (.argtypes|208 (let () (let ((.loop|225|228|231 (unspecified))) (begin (set! .loop|225|228|231 (lambda (.y1|220|221|232 .results|220|224|232) (if (null? .y1|220|221|232) (reverse .results|220|224|232) (begin #t (.loop|225|228|231 (let ((.x|236|239 .y1|220|221|232)) (begin (.check! (pair? .x|236|239) 1 .x|236|239) (cdr:pair .x|236|239))) (cons (let ((.exp|240 (let ((.x|241|244 .y1|220|221|232)) (begin (.check! (pair? .x|241|244) 0 .x|241|244) (car:pair .x|241|244))))) (aeval .exp|240 .types|3 .constraints|3)) .results|220|224|232)))))) (.loop|225|228|231 .args|205 '())))))) (let () (begin (if (representation-subtype? .type|172 rep:true) (let ((.reps|215 (rep-if-true .op|202 .argtypes|208))) (if .reps|215 (.record-new-reps!|22 .args|205 .argtypes|208 .reps|215 .k2|184) (unspecified))) (if (representation-subtype? .type|172 rep:false) (let ((.reps|219 (rep-if-false .op|202 .argtypes|208))) (if .reps|219 (.record-new-reps!|22 .args|205 .argtypes|208 .reps|219 .k2|184) (unspecified))) (unspecified))) (.loop|22 .type|172 .k|172 .cs|178 (cons .c2|175 .newcs|172))))))))))) (if (not (zero? .k|15)) (constraints-add-killedby! .constraints|3 .t|9 .k|15) (unspecified)) (let* ((.table|255 (constraints.table .constraints|3)) (.cs|258 (hashtable-fetch .table|255 .t|9 '()))) (let () (if (constant? .e|12) (let ((.type|265 (constant.value .e|12))) (begin (if .debugging?|6 (begin (display .t|9) (display " : ") (display (rep->symbol .type|265)) (newline)) (unspecified)) (let ((.cs|268 (.loop|22 .type|265 .k|15 .cs|258 '()))) (begin (hashtable-put! .table|255 .t|9 .cs|268) .constraints|3)))) (begin (if .debugging?|6 (begin (display .t|9) (display " = ") (display (make-readable .e|12 #t)) (newline)) (unspecified)) (if (not (null? .cs|258)) (begin (display "Compiler bug: ") (write .t|9) (display " has unexpectedly nonempty constraints") (newline)) (unspecified)) (hashtable-put! .table|255 .t|9 (cons (let* ((.t1|271|274 .t|9) (.t2|271|277 (let* ((.t1|281|284 .e|12) (.t2|281|287 (cons .k|15 '()))) (let () (cons .t1|281|284 .t2|281|287))))) (let () (cons .t1|271|274 .t2|271|277))) '())) .constraints|3)))))))))) (.constraints-add!|2 .types|1 .constraints|1 .new|1))))) 'constraints-add!))
+(let () (begin (set! number-of-basic-killers (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.i|8 .k|8) (if (> .k|8 available:killer:dead) .i|8 (begin #t (.loop|1|4|7 (+ .i|8 1) (+ .k|8 .k|8)))))) (.loop|1|4|7 0 1))))) 'number-of-basic-killers))
+(let () (begin (set! constraints.table (lambda (.constraints|1) (let ((.constraints.table|2 0)) (begin (set! .constraints.table|2 (lambda (.constraints|3) (let ((.x|4|7 .constraints|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.constraints.table|2 .constraints|1))))) 'constraints.table))
+(let () (begin (set! constraints.killed (lambda (.constraints|1) (let ((.constraints.killed|2 0)) (begin (set! .constraints.killed|2 (lambda (.constraints|3) (let ((.x|5|8 (let ((.x|9|12 .constraints|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraints.killed|2 .constraints|1))))) 'constraints.killed))
+(let () (begin (set! make-constraints-table (lambda () (let ((.make-constraints-table|2 0)) (begin (set! .make-constraints-table|2 (lambda () (let* ((.t1|4|7 (make-hashtable symbol-hash assq)) (.t2|4|10 (cons (make-vector number-of-basic-killers '()) '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constraints-table|2))))) 'make-constraints-table))
+(let () (begin (set! copy-constraints-table (lambda (.constraints|1) (let ((.copy-constraints-table|2 0)) (begin (set! .copy-constraints-table|2 (lambda (.constraints|3) (let* ((.t1|4|7 (hashtable-copy (constraints.table .constraints|3))) (.t2|4|10 (cons (list->vector (vector->list (constraints.killed .constraints|3))) '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.copy-constraints-table|2 .constraints|1))))) 'copy-constraints-table))
+(let () (begin (set! constraints-for-variable (lambda (.constraints|1 .t|1) (let ((.constraints-for-variable|2 0)) (begin (set! .constraints-for-variable|2 (lambda (.constraints|3 .t|3) (hashtable-fetch (constraints.table .constraints|3) .t|3 '()))) (.constraints-for-variable|2 .constraints|1 .t|1))))) 'constraints-for-variable))
+(let () (begin (set! constraints-add-killedby! (lambda (.constraints|1 .t|1 .k0|1) (let ((.constraints-add-killedby!|2 0)) (begin (set! .constraints-add-killedby!|2 (lambda (.constraints|3 .t|3 .k0|3) (if (not (zero? .k0|3)) (let ((.v|6 (constraints.killed .constraints|3))) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.i|15 .k|15) (if (= .i|15 number-of-basic-killers) (if #f #f (unspecified)) (begin (begin #t (if (not (zero? (logand .k|15 .k0|3))) (let ((.v|18|21 .v|6) (.i|18|21 .i|15) (.x|18|21 (cons .t|3 (let ((.v|22|25 .v|6) (.i|22|25 .i|15)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25)))))) (begin (.check! (fixnum? .i|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (vector? .v|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (<:fix:fix .i|18|21 (vector-length:vec .v|18|21)) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (>=:fix:fix .i|18|21 0) 41 .v|18|21 .i|18|21 .x|18|21) (vector-set!:trusted .v|18|21 .i|18|21 .x|18|21))) (unspecified))) (.loop|8|11|14 (+ .i|15 1) (+ .k|15 .k|15)))))) (.loop|8|11|14 0 1))))) (unspecified)))) (.constraints-add-killedby!|2 .constraints|1 .t|1 .k0|1))))) 'constraints-add-killedby!))
+(let () (begin (set! constraints-kill! (lambda (.constraints|1 .k|1) (let ((.constraints-kill!|2 0)) (begin (set! .constraints-kill!|2 (lambda (.constraints|3 .k|3) (if (not (zero? .k|3)) (let ((.table|6 (constraints.table .constraints|3)) (.killed|6 (constraints.killed .constraints|3))) (let ((.examine!|9 (unspecified))) (begin (set! .examine!|9 (lambda (.t|10) (let ((.cs|13 (filter (lambda (.c|14) (zero? (logand (constraint.killer .c|14) .k|3))) (hashtable-fetch .table|6 .t|10 '())))) (if (null? .cs|13) (hashtable-remove! .table|6 .t|10) (hashtable-put! .table|6 .t|10 .cs|13))))) (let () (let ((.loop|8|17|20 (unspecified))) (begin (set! .loop|8|17|20 (lambda (.i|21 .j|21) (if (= .i|21 number-of-basic-killers) (if #f #f (unspecified)) (begin (begin #t (if (not (zero? (logand .j|21 .k|3))) (begin (let () (let ((.loop|29|31|34 (unspecified))) (begin (set! .loop|29|31|34 (lambda (.y1|24|25|35) (if (null? .y1|24|25|35) (if #f #f (unspecified)) (begin (begin #t (.examine!|9 (let ((.x|39|42 .y1|24|25|35)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))))) (.loop|29|31|34 (let ((.x|43|46 .y1|24|25|35)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))))) (.loop|29|31|34 (let ((.v|47|50 .killed|6) (.i|47|50 .i|21)) (begin (.check! (fixnum? .i|47|50) 40 .v|47|50 .i|47|50) (.check! (vector? .v|47|50) 40 .v|47|50 .i|47|50) (.check! (<:fix:fix .i|47|50 (vector-length:vec .v|47|50)) 40 .v|47|50 .i|47|50) (.check! (>=:fix:fix .i|47|50 0) 40 .v|47|50 .i|47|50) (vector-ref:trusted .v|47|50 .i|47|50))))))) (let ((.v|51|54 .killed|6) (.i|51|54 .i|21) (.x|51|54 '())) (begin (.check! (fixnum? .i|51|54) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (vector? .v|51|54) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (<:fix:fix .i|51|54 (vector-length:vec .v|51|54)) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (>=:fix:fix .i|51|54 0) 41 .v|51|54 .i|51|54 .x|51|54) (vector-set!:trusted .v|51|54 .i|51|54 .x|51|54)))) (unspecified))) (.loop|8|17|20 (+ .i|21 1) (+ .j|21 .j|21)))))) (.loop|8|17|20 0 1))))))) (unspecified)))) (.constraints-kill!|2 .constraints|1 .k|1))))) 'constraints-kill!))
+(let () (begin (set! constraints-intersect! (lambda (.constraints0|1 .constraints1|1 .constraints2|1) (let ((.constraints-intersect!|2 0)) (begin (set! .constraints-intersect!|2 (lambda (.constraints0|3 .constraints1|3 .constraints2|3) (let ((.table0|6 (constraints.table .constraints0|3)) (.table1|6 (constraints.table .constraints1|3)) (.table2|6 (constraints.table .constraints2|3))) (if (eq? .table0|6 .table1|6) (hashtable-for-each (lambda (.t|7 .cs|7) (if (not (null? .cs|7)) (hashtable-put! .table0|6 .t|7 (cs-intersect (hashtable-fetch .table2|6 .t|7 '()) .cs|7)) (unspecified))) .table1|6) (begin (.constraints-intersect!|2 .constraints0|3 .constraints0|3 .constraints1|3) (.constraints-intersect!|2 .constraints0|3 .constraints0|3 .constraints2|3)))))) (.constraints-intersect!|2 .constraints0|1 .constraints1|1 .constraints2|1))))) 'constraints-intersect!))
+(let () (begin (set! cs-intersect (lambda (.cs1|1 .cs2|1) (let ((.cs-intersect|2 0)) (begin (set! .cs-intersect|2 (lambda (.cs1|3 .cs2|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.cs|5 .init|5 .rep|5 .krep|5) (if (null? .cs|5) (values .init|5 .rep|5 .krep|5) (let* ((.c|8 (let ((.x|28|31 .cs|5)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.cs|11 (let ((.x|24|27 .cs|5)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (.e2|14 (constraint.rhs .c|8)) (.k2|17 (constraint.killer .c|8))) (let () (if (constant? .e2|14) (.loop|4 .cs|11 .init|5 (representation-intersection .rep|5 (constant.value .e2|14)) (available:killer-combine .krep|5 .k2|17)) (if (call? .e2|14) (if .init|5 (begin (display "Compiler bug in cs-intersect") (break)) (.loop|4 .cs|11 .c|8 .rep|5 .krep|5)) (error "Compiler bug in cs-intersect")))))))) (call-with-values (lambda () (.loop|4 .cs1|3 #f rep:object available:killer:none)) (lambda (.c1|33 .rep1|33 .krep1|33) (call-with-values (lambda () (.loop|4 .cs2|3 #f rep:object available:killer:none)) (lambda (.c2|35 .rep2|35 .krep2|35) (let ((.c|38 (if (equal? .c1|33 .c2|35) .c1|33 #f)) (.rep|38 (representation-union .rep1|33 .rep2|35)) (.krep|38 (available:killer-combine .krep1|33 .krep2|35))) (if (eq? .rep|38 rep:object) (if .c|38 (cons .c|38 '()) '()) (let ((.t|42 (constraint.lhs (let ((.x|55|58 .cs1|3)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58)))))) (if .c|38 (let* ((.t1|43|46 .c|38) (.t2|43|49 (cons (make-type-constraint .t|42 .rep|38 .krep|38) '()))) (let () (cons .t1|43|46 .t2|43|49))) (cons (make-type-constraint .t|42 .rep|38 .krep|38) '()))))))))))))) (.cs-intersect|2 .cs1|1 .cs2|1))))) 'cs-intersect))
+(let () (begin (set! $gc.ephemeral 0) '$gc.ephemeral))
+(let () (begin (set! $gc.tenuring 1) '$gc.tenuring))
+(let () (begin (set! $gc.full 2) '$gc.full))
+(let () (begin (set! $mstat.wallocated-hi 0) '$mstat.wallocated-hi))
+(let () (begin (set! $mstat.wallocated-lo 1) '$mstat.wallocated-lo))
+(let () (begin (set! $mstat.wcollected-hi 2) '$mstat.wcollected-hi))
+(let () (begin (set! $mstat.wcollected-lo 3) '$mstat.wcollected-lo))
+(let () (begin (set! $mstat.wcopied-hi 4) '$mstat.wcopied-hi))
+(let () (begin (set! $mstat.wcopied-lo 5) '$mstat.wcopied-lo))
+(let () (begin (set! $mstat.gctime 6) '$mstat.gctime))
+(let () (begin (set! $mstat.wlive 7) '$mstat.wlive))
+(let () (begin (set! $mstat.gc-last-gen 8) '$mstat.gc-last-gen))
+(let () (begin (set! $mstat.gc-last-type 9) '$mstat.gc-last-type))
+(let () (begin (set! $mstat.generations 10) '$mstat.generations))
+(let () (begin (set! $mstat.g-gc-count 0) '$mstat.g-gc-count))
+(let () (begin (set! $mstat.g-prom-count 1) '$mstat.g-prom-count))
+(let () (begin (set! $mstat.g-gctime 2) '$mstat.g-gctime))
+(let () (begin (set! $mstat.g-wlive 3) '$mstat.g-wlive))
+(let () (begin (set! $mstat.g-np-youngp 4) '$mstat.g-np-youngp))
+(let () (begin (set! $mstat.g-np-oldp 5) '$mstat.g-np-oldp))
+(let () (begin (set! $mstat.g-np-j 6) '$mstat.g-np-j))
+(let () (begin (set! $mstat.g-np-k 7) '$mstat.g-np-k))
+(let () (begin (set! $mstat.g-alloc 8) '$mstat.g-alloc))
+(let () (begin (set! $mstat.g-target 9) '$mstat.g-target))
+(let () (begin (set! $mstat.g-promtime 10) '$mstat.g-promtime))
+(let () (begin (set! $mstat.remsets 11) '$mstat.remsets))
+(let () (begin (set! $mstat.r-apool 0) '$mstat.r-apool))
+(let () (begin (set! $mstat.r-upool 1) '$mstat.r-upool))
+(let () (begin (set! $mstat.r-ahash 2) '$mstat.r-ahash))
+(let () (begin (set! $mstat.r-uhash 3) '$mstat.r-uhash))
+(let () (begin (set! $mstat.r-hrec-hi 4) '$mstat.r-hrec-hi))
+(let () (begin (set! $mstat.r-hrec-lo 5) '$mstat.r-hrec-lo))
+(let () (begin (set! $mstat.r-hrem-hi 6) '$mstat.r-hrem-hi))
+(let () (begin (set! $mstat.r-hrem-lo 7) '$mstat.r-hrem-lo))
+(let () (begin (set! $mstat.r-hscan-hi 8) '$mstat.r-hscan-hi))
+(let () (begin (set! $mstat.r-hscan-lo 9) '$mstat.r-hscan-lo))
+(let () (begin (set! $mstat.r-wscan-hi 10) '$mstat.r-wscan-hi))
+(let () (begin (set! $mstat.r-wscan-lo 11) '$mstat.r-wscan-lo))
+(let () (begin (set! $mstat.r-ssbrec-hi 12) '$mstat.r-ssbrec-hi))
+(let () (begin (set! $mstat.r-ssbrec-lo 13) '$mstat.r-ssbrec-lo))
+(let () (begin (set! $mstat.r-np-p 14) '$mstat.r-np-p))
+(let () (begin (set! $mstat.fflushed-hi 12) '$mstat.fflushed-hi))
+(let () (begin (set! $mstat.fflushed-lo 13) '$mstat.fflushed-lo))
+(let () (begin (set! $mstat.wflushed-hi 14) '$mstat.wflushed-hi))
+(let () (begin (set! $mstat.wflushed-lo 15) '$mstat.wflushed-lo))
+(let () (begin (set! $mstat.stk-created 16) '$mstat.stk-created))
+(let () (begin (set! $mstat.frestored-hi 17) '$mstat.frestored-hi))
+(let () (begin (set! $mstat.frestored-lo 18) '$mstat.frestored-lo))
+(let () (begin (set! $mstat.words-heap 19) '$mstat.words-heap))
+(let () (begin (set! $mstat.words-remset 20) '$mstat.words-remset))
+(let () (begin (set! $mstat.words-rts 21) '$mstat.words-rts))
+(let () (begin (set! $mstat.swb-assign 22) '$mstat.swb-assign))
+(let () (begin (set! $mstat.swb-lhs-ok 23) '$mstat.swb-lhs-ok))
+(let () (begin (set! $mstat.swb-rhs-const 24) '$mstat.swb-rhs-const))
+(let () (begin (set! $mstat.swb-not-xgen 25) '$mstat.swb-not-xgen))
+(let () (begin (set! $mstat.swb-trans 26) '$mstat.swb-trans))
+(let () (begin (set! $mstat.rtime 27) '$mstat.rtime))
+(let () (begin (set! $mstat.stime 28) '$mstat.stime))
+(let () (begin (set! $mstat.utime 29) '$mstat.utime))
+(let () (begin (set! $mstat.minfaults 30) '$mstat.minfaults))
+(let () (begin (set! $mstat.majfaults 31) '$mstat.majfaults))
+(let () (begin (set! $mstat.np-remsetp 32) '$mstat.np-remsetp))
+(let () (begin (set! $mstat.max-heap 33) '$mstat.max-heap))
+(let () (begin (set! $mstat.promtime 34) '$mstat.promtime))
+(let () (begin (set! $mstat.wmoved-hi 35) '$mstat.wmoved-hi))
+(let () (begin (set! $mstat.wmoved-lo 36) '$mstat.wmoved-lo))
+(let () (begin (set! $mstat.vsize 37) '$mstat.vsize))
+(let () (begin (set! $g.reg0 12) '$g.reg0))
+(let () (begin (set! $r.reg8 44) '$r.reg8))
+(let () (begin (set! $r.reg9 48) '$r.reg9))
+(let () (begin (set! $r.reg10 52) '$r.reg10))
+(let () (begin (set! $r.reg11 56) '$r.reg11))
+(let () (begin (set! $r.reg12 60) '$r.reg12))
+(let () (begin (set! $r.reg13 64) '$r.reg13))
+(let () (begin (set! $r.reg14 68) '$r.reg14))
+(let () (begin (set! $r.reg15 72) '$r.reg15))
+(let () (begin (set! $r.reg16 76) '$r.reg16))
+(let () (begin (set! $r.reg17 80) '$r.reg17))
+(let () (begin (set! $r.reg18 84) '$r.reg18))
+(let () (begin (set! $r.reg19 88) '$r.reg19))
+(let () (begin (set! $r.reg20 92) '$r.reg20))
+(let () (begin (set! $r.reg21 96) '$r.reg21))
+(let () (begin (set! $r.reg22 100) '$r.reg22))
+(let () (begin (set! $r.reg23 104) '$r.reg23))
+(let () (begin (set! $r.reg24 108) '$r.reg24))
+(let () (begin (set! $r.reg25 112) '$r.reg25))
+(let () (begin (set! $r.reg26 116) '$r.reg26))
+(let () (begin (set! $r.reg27 120) '$r.reg27))
+(let () (begin (set! $r.reg28 124) '$r.reg28))
+(let () (begin (set! $r.reg29 128) '$r.reg29))
+(let () (begin (set! $r.reg30 132) '$r.reg30))
+(let () (begin (set! $r.reg31 136) '$r.reg31))
+(let () (begin (set! $g.stkbot 180) '$g.stkbot))
+(let () (begin (set! $g.gccnt 420) '$g.gccnt))
+(let () (begin (set! $m.alloc 1024) '$m.alloc))
+(let () (begin (set! $m.alloci 1032) '$m.alloci))
+(let () (begin (set! $m.gc 1040) '$m.gc))
+(let () (begin (set! $m.addtrans 1048) '$m.addtrans))
+(let () (begin (set! $m.stkoflow 1056) '$m.stkoflow))
+(let () (begin (set! $m.stkuflow 1072) '$m.stkuflow))
+(let () (begin (set! $m.creg 1080) '$m.creg))
+(let () (begin (set! $m.creg-set! 1088) '$m.creg-set!))
+(let () (begin (set! $m.add 1096) '$m.add))
+(let () (begin (set! $m.subtract 1104) '$m.subtract))
+(let () (begin (set! $m.multiply 1112) '$m.multiply))
+(let () (begin (set! $m.quotient 1120) '$m.quotient))
+(let () (begin (set! $m.remainder 1128) '$m.remainder))
+(let () (begin (set! $m.divide 1136) '$m.divide))
+(let () (begin (set! $m.modulo 1144) '$m.modulo))
+(let () (begin (set! $m.negate 1152) '$m.negate))
+(let () (begin (set! $m.numeq 1160) '$m.numeq))
+(let () (begin (set! $m.numlt 1168) '$m.numlt))
+(let () (begin (set! $m.numle 1176) '$m.numle))
+(let () (begin (set! $m.numgt 1184) '$m.numgt))
+(let () (begin (set! $m.numge 1192) '$m.numge))
+(let () (begin (set! $m.zerop 1200) '$m.zerop))
+(let () (begin (set! $m.complexp 1208) '$m.complexp))
+(let () (begin (set! $m.realp 1216) '$m.realp))
+(let () (begin (set! $m.rationalp 1224) '$m.rationalp))
+(let () (begin (set! $m.integerp 1232) '$m.integerp))
+(let () (begin (set! $m.exactp 1240) '$m.exactp))
+(let () (begin (set! $m.inexactp 1248) '$m.inexactp))
+(let () (begin (set! $m.exact->inexact 1256) '$m.exact->inexact))
+(let () (begin (set! $m.inexact->exact 1264) '$m.inexact->exact))
+(let () (begin (set! $m.make-rectangular 1272) '$m.make-rectangular))
+(let () (begin (set! $m.real-part 1280) '$m.real-part))
+(let () (begin (set! $m.imag-part 1288) '$m.imag-part))
+(let () (begin (set! $m.sqrt 1296) '$m.sqrt))
+(let () (begin (set! $m.round 1304) '$m.round))
+(let () (begin (set! $m.truncate 1312) '$m.truncate))
+(let () (begin (set! $m.apply 1320) '$m.apply))
+(let () (begin (set! $m.varargs 1328) '$m.varargs))
+(let () (begin (set! $m.typetag 1336) '$m.typetag))
+(let () (begin (set! $m.typetag-set 1344) '$m.typetag-set))
+(let () (begin (set! $m.break 1352) '$m.break))
+(let () (begin (set! $m.eqv 1360) '$m.eqv))
+(let () (begin (set! $m.partial-list->vector 1368) '$m.partial-list->vector))
+(let () (begin (set! $m.timer-exception 1376) '$m.timer-exception))
+(let () (begin (set! $m.exception 1384) '$m.exception))
+(let () (begin (set! $m.singlestep 1392) '$m.singlestep))
+(let () (begin (set! $m.syscall 1400) '$m.syscall))
+(let () (begin (set! $m.bvlcmp 1408) '$m.bvlcmp))
+(let () (begin (set! $m.enable-interrupts 1416) '$m.enable-interrupts))
+(let () (begin (set! $m.disable-interrupts 1424) '$m.disable-interrupts))
+(let () (begin (set! $m.alloc-bv 1432) '$m.alloc-bv))
+(let () (begin (set! $m.global-ex 1440) '$m.global-ex))
+(let () (begin (set! $m.invoke-ex 1448) '$m.invoke-ex))
+(let () (begin (set! $m.global-invoke-ex 1456) '$m.global-invoke-ex))
+(let () (begin (set! $m.argc-ex 1464) '$m.argc-ex))
+(let () (begin (set! $r.g0 0) '$r.g0))
+(let () (begin (set! $r.g1 1) '$r.g1))
+(let () (begin (set! $r.g2 2) '$r.g2))
+(let () (begin (set! $r.g3 3) '$r.g3))
+(let () (begin (set! $r.g4 4) '$r.g4))
+(let () (begin (set! $r.g5 5) '$r.g5))
+(let () (begin (set! $r.g6 6) '$r.g6))
+(let () (begin (set! $r.g7 7) '$r.g7))
+(let () (begin (set! $r.o0 8) '$r.o0))
+(let () (begin (set! $r.o1 9) '$r.o1))
+(let () (begin (set! $r.o2 10) '$r.o2))
+(let () (begin (set! $r.o3 11) '$r.o3))
+(let () (begin (set! $r.o4 12) '$r.o4))
+(let () (begin (set! $r.o5 13) '$r.o5))
+(let () (begin (set! $r.o6 14) '$r.o6))
+(let () (begin (set! $r.o7 15) '$r.o7))
+(let () (begin (set! $r.l0 16) '$r.l0))
+(let () (begin (set! $r.l1 17) '$r.l1))
+(let () (begin (set! $r.l2 18) '$r.l2))
+(let () (begin (set! $r.l3 19) '$r.l3))
+(let () (begin (set! $r.l4 20) '$r.l4))
+(let () (begin (set! $r.l5 21) '$r.l5))
+(let () (begin (set! $r.l6 22) '$r.l6))
+(let () (begin (set! $r.l7 23) '$r.l7))
+(let () (begin (set! $r.i0 24) '$r.i0))
+(let () (begin (set! $r.i1 25) '$r.i1))
+(let () (begin (set! $r.i2 26) '$r.i2))
+(let () (begin (set! $r.i3 27) '$r.i3))
+(let () (begin (set! $r.i4 28) '$r.i4))
+(let () (begin (set! $r.i5 29) '$r.i5))
+(let () (begin (set! $r.i6 30) '$r.i6))
+(let () (begin (set! $r.i7 31) '$r.i7))
+(let () (begin (set! $r.result $r.o0) '$r.result))
+(let () (begin (set! $r.argreg2 $r.o1) '$r.argreg2))
+(let () (begin (set! $r.argreg3 $r.o2) '$r.argreg3))
+(let () (begin (set! $r.stkp $r.o3) '$r.stkp))
+(let () (begin (set! $r.stklim $r.i0) '$r.stklim))
+(let () (begin (set! $r.tmp1 $r.o4) '$r.tmp1))
+(let () (begin (set! $r.tmp2 $r.o5) '$r.tmp2))
+(let () (begin (set! $r.tmp0 $r.g1) '$r.tmp0))
+(let () (begin (set! $r.e-top $r.i0) '$r.e-top))
+(let () (begin (set! $r.e-limit $r.o3) '$r.e-limit))
+(let () (begin (set! $r.timer $r.i4) '$r.timer))
+(let () (begin (set! $r.millicode $r.i7) '$r.millicode))
+(let () (begin (set! $r.globals $r.i7) '$r.globals))
+(let () (begin (set! $r.reg0 $r.l0) '$r.reg0))
+(let () (begin (set! $r.reg1 $r.l1) '$r.reg1))
+(let () (begin (set! $r.reg2 $r.l2) '$r.reg2))
+(let () (begin (set! $r.reg3 $r.l3) '$r.reg3))
+(let () (begin (set! $r.reg4 $r.l4) '$r.reg4))
+(let () (begin (set! $r.reg5 $r.l5) '$r.reg5))
+(let () (begin (set! $r.reg6 $r.l6) '$r.reg6))
+(let () (begin (set! $r.reg7 $r.l7) '$r.reg7))
+(let () (begin (set! $ex.car 0) '$ex.car))
+(let () (begin (set! $ex.cdr 1) '$ex.cdr))
+(let () (begin (set! $ex.setcar 2) '$ex.setcar))
+(let () (begin (set! $ex.setcdr 3) '$ex.setcdr))
+(let () (begin (set! $ex.add 10) '$ex.add))
+(let () (begin (set! $ex.sub 11) '$ex.sub))
+(let () (begin (set! $ex.mul 12) '$ex.mul))
+(let () (begin (set! $ex.div 13) '$ex.div))
+(let () (begin (set! $ex.lessp 14) '$ex.lessp))
+(let () (begin (set! $ex.lesseqp 15) '$ex.lesseqp))
+(let () (begin (set! $ex.equalp 16) '$ex.equalp))
+(let () (begin (set! $ex.greatereqp 17) '$ex.greatereqp))
+(let () (begin (set! $ex.greaterp 18) '$ex.greaterp))
+(let () (begin (set! $ex.quotient 19) '$ex.quotient))
+(let () (begin (set! $ex.remainder 20) '$ex.remainder))
+(let () (begin (set! $ex.modulo 21) '$ex.modulo))
+(let () (begin (set! $ex.logior 22) '$ex.logior))
+(let () (begin (set! $ex.logand 23) '$ex.logand))
+(let () (begin (set! $ex.logxor 24) '$ex.logxor))
+(let () (begin (set! $ex.lognot 25) '$ex.lognot))
+(let () (begin (set! $ex.lsh 26) '$ex.lsh))
+(let () (begin (set! $ex.rsha 27) '$ex.rsha))
+(let () (begin (set! $ex.rshl 28) '$ex.rshl))
+(let () (begin (set! $ex.e2i 29) '$ex.e2i))
+(let () (begin (set! $ex.i2e 30) '$ex.i2e))
+(let () (begin (set! $ex.exactp 31) '$ex.exactp))
+(let () (begin (set! $ex.inexactp 32) '$ex.inexactp))
+(let () (begin (set! $ex.round 33) '$ex.round))
+(let () (begin (set! $ex.trunc 34) '$ex.trunc))
+(let () (begin (set! $ex.zerop 35) '$ex.zerop))
+(let () (begin (set! $ex.neg 36) '$ex.neg))
+(let () (begin (set! $ex.abs 37) '$ex.abs))
+(let () (begin (set! $ex.realpart 38) '$ex.realpart))
+(let () (begin (set! $ex.imagpart 39) '$ex.imagpart))
+(let () (begin (set! $ex.vref 40) '$ex.vref))
+(let () (begin (set! $ex.vset 41) '$ex.vset))
+(let () (begin (set! $ex.vlen 42) '$ex.vlen))
+(let () (begin (set! $ex.pref 50) '$ex.pref))
+(let () (begin (set! $ex.pset 51) '$ex.pset))
+(let () (begin (set! $ex.plen 52) '$ex.plen))
+(let () (begin (set! $ex.sref 60) '$ex.sref))
+(let () (begin (set! $ex.sset 61) '$ex.sset))
+(let () (begin (set! $ex.slen 62) '$ex.slen))
+(let () (begin (set! $ex.bvref 70) '$ex.bvref))
+(let () (begin (set! $ex.bvset 71) '$ex.bvset))
+(let () (begin (set! $ex.bvlen 72) '$ex.bvlen))
+(let () (begin (set! $ex.bvlref 80) '$ex.bvlref))
+(let () (begin (set! $ex.bvlset 81) '$ex.bvlset))
+(let () (begin (set! $ex.bvllen 82) '$ex.bvllen))
+(let () (begin (set! $ex.vlref 90) '$ex.vlref))
+(let () (begin (set! $ex.vlset 91) '$ex.vlset))
+(let () (begin (set! $ex.vllen 92) '$ex.vllen))
+(let () (begin (set! $ex.typetag 100) '$ex.typetag))
+(let () (begin (set! $ex.typetagset 101) '$ex.typetagset))
+(let () (begin (set! $ex.apply 102) '$ex.apply))
+(let () (begin (set! $ex.argc 103) '$ex.argc))
+(let () (begin (set! $ex.vargc 104) '$ex.vargc))
+(let () (begin (set! $ex.nonproc 105) '$ex.nonproc))
+(let () (begin (set! $ex.undef-global 106) '$ex.undef-global))
+(let () (begin (set! $ex.dump 107) '$ex.dump))
+(let () (begin (set! $ex.dumpfail 108) '$ex.dumpfail))
+(let () (begin (set! $ex.timer 109) '$ex.timer))
+(let () (begin (set! $ex.unsupported 110) '$ex.unsupported))
+(let () (begin (set! $ex.int2char 111) '$ex.int2char))
+(let () (begin (set! $ex.char2int 112) '$ex.char2int))
+(let () (begin (set! $ex.mkbvl 113) '$ex.mkbvl))
+(let () (begin (set! $ex.mkvl 114) '$ex.mkvl))
+(let () (begin (set! $ex.char<? 115) '$ex.char<?))
+(let () (begin (set! $ex.char<=? 116) '$ex.char<=?))
+(let () (begin (set! $ex.char=? 117) '$ex.char=?))
+(let () (begin (set! $ex.char>? 118) '$ex.char>?))
+(let () (begin (set! $ex.char>=? 119) '$ex.char>=?))
+(let () (begin (set! $ex.bvfill 120) '$ex.bvfill))
+(let () (begin (set! $ex.enable-interrupts 121) '$ex.enable-interrupts))
+(let () (begin (set! $ex.keyboard-interrupt 122) '$ex.keyboard-interrupt))
+(let () (begin (set! $ex.arithmetic-exception 123) '$ex.arithmetic-exception))
+(let () (begin (set! $ex.global-invoke 124) '$ex.global-invoke))
+(let () (begin (set! $ex.fx+ 140) '$ex.fx+))
+(let () (begin (set! $ex.fx- 141) '$ex.fx-))
+(let () (begin (set! $ex.fx-- 142) '$ex.fx--))
+(let () (begin (set! $ex.fx= 143) '$ex.fx=))
+(let () (begin (set! $ex.fx< 144) '$ex.fx<))
+(let () (begin (set! $ex.fx<= 145) '$ex.fx<=))
+(let () (begin (set! $ex.fx> 146) '$ex.fx>))
+(let () (begin (set! $ex.fx>= 147) '$ex.fx>=))
+(let () (begin (set! $ex.fxpositive? 148) '$ex.fxpositive?))
+(let () (begin (set! $ex.fxnegative? 149) '$ex.fxnegative?))
+(let () (begin (set! $ex.fxzero? 150) '$ex.fxzero?))
+(let () (begin (set! $ex.fx* 151) '$ex.fx*))
+(let () (begin (set! $tag.tagmask 7) '$tag.tagmask))
+(let () (begin (set! $tag.pair-tag 1) '$tag.pair-tag))
+(let () (begin (set! $tag.vector-tag 3) '$tag.vector-tag))
+(let () (begin (set! $tag.bytevector-tag 5) '$tag.bytevector-tag))
+(let () (begin (set! $tag.procedure-tag 7) '$tag.procedure-tag))
+(let () (begin (set! $imm.vector-header 162) '$imm.vector-header))
+(let () (begin (set! $imm.bytevector-header 194) '$imm.bytevector-header))
+(let () (begin (set! $imm.procedure-header 254) '$imm.procedure-header))
+(let () (begin (set! $imm.true 6) '$imm.true))
+(let () (begin (set! $imm.false 2) '$imm.false))
+(let () (begin (set! $imm.null 10) '$imm.null))
+(let () (begin (set! $imm.unspecified 278) '$imm.unspecified))
+(let () (begin (set! $imm.eof 534) '$imm.eof))
+(let () (begin (set! $imm.undefined 790) '$imm.undefined))
+(let () (begin (set! $imm.character 38) '$imm.character))
+(let () (begin (set! $tag.vector-typetag 0) '$tag.vector-typetag))
+(let () (begin (set! $tag.rectnum-typetag 4) '$tag.rectnum-typetag))
+(let () (begin (set! $tag.ratnum-typetag 8) '$tag.ratnum-typetag))
+(let () (begin (set! $tag.symbol-typetag 12) '$tag.symbol-typetag))
+(let () (begin (set! $tag.port-typetag 16) '$tag.port-typetag))
+(let () (begin (set! $tag.structure-typetag 20) '$tag.structure-typetag))
+(let () (begin (set! $tag.bytevector-typetag 0) '$tag.bytevector-typetag))
+(let () (begin (set! $tag.string-typetag 4) '$tag.string-typetag))
+(let () (begin (set! $tag.flonum-typetag 8) '$tag.flonum-typetag))
+(let () (begin (set! $tag.compnum-typetag 12) '$tag.compnum-typetag))
+(let () (begin (set! $tag.bignum-typetag 16) '$tag.bignum-typetag))
+(let () (begin (set! $hdr.port 178) '$hdr.port))
+(let () (begin (set! $hdr.struct 182) '$hdr.struct))
+(let () (begin (set! $p.codevector -3) '$p.codevector))
+(let () (begin (set! $p.constvector 1) '$p.constvector))
+(let () (begin (set! $p.linkoffset 5) '$p.linkoffset))
+(let () (begin (set! $p.reg0 5) '$p.reg0))
+(let () (begin (set! $p.codeoffset -1) '$p.codeoffset))
+(let () (begin (set! twobit-sort (lambda (.less?|1 .list|1) (compat:sort .list|1 .less?|1))) 'twobit-sort))
+(let () (begin (set! renaming-prefix ".") 'renaming-prefix))
+(let () (begin (set! cell-prefix (string-append renaming-prefix "CELL:")) 'cell-prefix))
+(let () (begin (set! name:check! '.check!) 'name:check!))
+(let () (begin (set! name:cons '.cons) 'name:cons))
+(let () (begin (set! name:list '.list) 'name:list))
+(let () (begin (set! name:make-cell '.make-cell) 'name:make-cell))
+(let () (begin (set! name:cell-ref '.cell-ref) 'name:cell-ref))
+(let () (begin (set! name:cell-set! '.cell-set!) 'name:cell-set!))
+(let () (begin (set! name:ignored (string->symbol "IGNORED")) 'name:ignored))
+(let () (begin (set! name:car '.car) 'name:car))
+(let () (begin (set! name:cdr '.cdr) 'name:cdr))
+(let () (begin (set! name:not 'not) 'name:not))
+(let () (begin (set! name:memq 'memq) 'name:memq))
+(let () (begin (set! name:memv 'memv) 'name:memv))
+(let () (begin (set! name:eq? 'eq?) 'name:eq?))
+(let () (begin (set! name:eqv? 'eqv?) 'name:eqv?))
+(let () (begin (set! name:fixnum? 'fixnum?) 'name:fixnum?))
+(let () (begin (set! name:char? 'char?) 'name:char?))
+(let () (begin (set! name:symbol? 'symbol?) 'name:symbol?))
+(let () (begin (set! name:fx< '<:fix:fix) 'name:fx<))
+(let () (begin (set! name:fx- 'fx-) 'name:fx-))
+(let () (begin (set! name:char->integer 'char->integer) 'name:char->integer))
+(let () (begin (set! name:vector-ref 'vector-ref:trusted) 'name:vector-ref))
+(let () (begin (set! constant-folding-entry (lambda (.name|1) (let ((.constant-folding-entry|2 0)) (begin (set! .constant-folding-entry|2 (lambda (.name|3) (assq .name|3 $usual-constant-folding-procedures$))) (.constant-folding-entry|2 .name|1))))) 'constant-folding-entry))
+(let () (begin (set! constant-folding-predicates cadr) 'constant-folding-predicates))
+(let () (begin (set! constant-folding-folder caddr) 'constant-folding-folder))
+(let () (begin (set! $usual-constant-folding-procedures$ (let ((.always?|3 (lambda (.x|1468) #t)) (.charcode?|3 (lambda (.n|1469) (if (number? .n|1469) (if (exact? .n|1469) (if (<= 0 .n|1469) (< .n|1469 128) #f) #f) #f))) (.ratnum?|3 (lambda (.n|1474) (if (number? .n|1474) (if (exact? .n|1474) (rational? .n|1474) #f) #f))) (.smallint?|3 (lambda (.n|1478) (smallint? .n|1478)))) (.cons (.cons 'integer->char (.cons (.cons .charcode?|3 '()) (.cons integer->char '()))) (.cons (.cons 'char->integer (.cons (.cons char? '()) (.cons char->integer '()))) (.cons (.cons 'zero? (.cons (.cons .ratnum?|3 '()) (.cons zero? '()))) (.cons (.cons '< (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons < '()))) (.cons (.cons '<= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons <= '()))) (.cons (.cons '= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons = '()))) (.cons (.cons '>= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons >= '()))) (.cons (.cons '> (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons > '()))) (.cons (.cons '+ (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons + '()))) (.cons (.cons '- (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons - '()))) (.cons (.cons '* (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons * '()))) (.cons (.cons '-- (.cons (.cons .ratnum?|3 '()) (.cons (lambda (.x|1467) (- 0 .x|1467)) '()))) (.cons (.cons 'eq? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons eq? '()))) (.cons (.cons 'eqv? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons eqv? '()))) (.cons (.cons 'equal? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons equal? '()))) (.cons (.cons 'memq (.cons (.cons .always?|3 (.cons list? '())) (.cons memq '()))) (.cons (.cons 'memv (.cons (.cons .always?|3 (.cons list? '())) (.cons memv '()))) (.cons (.cons 'member (.cons (.cons .always?|3 (.cons list? '())) (.cons member '()))) (.cons (.cons 'assq (.cons (.cons .always?|3 (.cons list? '())) (.cons assq '()))) (.cons (.cons 'assv (.cons (.cons .always?|3 (.cons list? '())) (.cons assv '()))) (.cons (.cons 'assoc (.cons (.cons .always?|3 (.cons list? '())) (.cons assoc '()))) (.cons (.cons 'length (.cons (.cons list? '()) (.cons length '()))) (.cons (.cons 'fixnum? (.cons (.cons .smallint?|3 '()) (.cons .smallint?|3 '()))) (.cons (.cons '=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons = '()))) (.cons (.cons '<:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons < '()))) (.cons (.cons '<=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons <= '()))) (.cons (.cons '>:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons > '()))) (.cons (.cons '>=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons >= '()))) '())))))))))))))))))))))))))))))) '$usual-constant-folding-procedures$))
+(let () (begin '(define (.check! flag exn . args) (if (not flag) (apply error "Runtime check exception: " exn args))) #t))
+(let () (let () (let ((.loop|6|8|11 (unspecified))) (begin (set! .loop|6|8|11 (lambda (.y1|1|2|12) (if (null? .y1|1|2|12) (if #f #f (unspecified)) (begin (begin #t (pass1 (let ((.x|16|19 .y1|1|2|12)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))))) (.loop|6|8|11 (let ((.x|20|23 .y1|1|2|12)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))))))) (.loop|6|8|11 (.cons (.cons 'define-inline (.cons 'car (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(car x0) (.cons (.cons 'let (.cons '((x x0)) (.cons (.cons '.check! (.cons '(pair? x) (.cons $ex.car '(x)))) '((car:pair x))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'cdr (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(car x0) (.cons (.cons 'let (.cons '((x x0)) (.cons (.cons '.check! (.cons '(pair? x) (.cons $ex.cdr '(x)))) '((cdr:pair x))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-length (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-length v0) (.cons (.cons 'let (.cons '((v v0)) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vlen '(v)))) '((vector-length:vec v))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-ref (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-ref v0 i0) (.cons (.cons 'let (.cons '((v v0) (i i0)) (.cons (.cons '.check! (.cons '(fixnum? i) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(<:fix:fix i (vector-length:vec v)) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(>=:fix:fix i 0) (.cons $ex.vref '(v i)))) '((vector-ref:trusted v i)))))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-set! (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-set! v0 i0 x0) (.cons (.cons 'let (.cons '((v v0) (i i0) (x x0)) (.cons (.cons '.check! (.cons '(fixnum? i) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(<:fix:fix i (vector-length:vec v)) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(>=:fix:fix i 0) (.cons $ex.vset '(v i x)))) '((vector-set!:trusted v i x)))))))) '())) '()))) '()))) '((define-inline list (syntax-rules () ((list) '()) ((list ?e) (cons ?e '())) ((list ?e1 ?e2 ...) (let* ((t1 ?e1) (t2 (list ?e2 ...))) (cons t1 t2))))) (define-inline vector (syntax-rules () ((vector) '#()) ((vector ?e) (make-vector 1 ?e)) ((vector ?e1 ?e2 ...) (letrec-syntax ((vector-aux1 (... (syntax-rules () ((vector-aux1 () ?n ?exps ?indexes ?temps) (vector-aux2 ?n ?exps ?indexes ?temps)) ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps) (vector-aux1 (?exp2 ...) (+ ?n 1) (?exp1 . ?exps) (?n . ?indexes) (t . ?temps)))))) (vector-aux2 (... (syntax-rules () ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...)) (let* ((?t1 ?exp1) (?t2 ?exp2) ... (v (make-vector ?n ?t1))) (vector-set! v ?n2 ?t2) ... v)))))) (vector-aux1 (?e1 ?e2 ...) 0 () () ()))))) (define-inline cadddr (syntax-rules () ((cadddr ?e) (car (cdr (cdr (cdr ?e))))))) (define-inline cddddr (syntax-rules () ((cddddr ?e) (cdr (cdr (cdr (cdr ?e))))))) (define-inline cdddr (syntax-rules () ((cdddr ?e) (cdr (cdr (cdr ?e)))))) (define-inline caddr (syntax-rules () ((caddr ?e) (car (cdr (cdr ?e)))))) (define-inline cddr (syntax-rules () ((cddr ?e) (cdr (cdr ?e))))) (define-inline cdar (syntax-rules () ((cdar ?e) (cdr (car ?e))))) (define-inline cadr (syntax-rules () ((cadr ?e) (car (cdr ?e))))) (define-inline caar (syntax-rules () ((caar ?e) (car (car ?e))))) (define-inline make-vector (syntax-rules () ((make-vector ?n) (make-vector ?n '())))) (define-inline make-string (syntax-rules () ((make-string ?n) (make-string ?n #\space)))) (define-inline = (syntax-rules () ((= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (= ?e1 t) (= t ?e3 ?e4 ...)))))) (define-inline < (syntax-rules () ((< ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (< ?e1 t) (< t ?e3 ?e4 ...)))))) (define-inline > (syntax-rules () ((> ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (> ?e1 t) (> t ?e3 ?e4 ...)))))) (define-inline <= (syntax-rules () ((<= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (<= ?e1 t) (<= t ?e3 ?e4 ...)))))) (define-inline >= (syntax-rules () ((>= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (>= ?e1 t) (>= t ?e3 ?e4 ...)))))) (define-inline + (syntax-rules () ((+) 0) ((+ ?e) ?e) ((+ ?e1 ?e2 ?e3 ?e4 ...) (+ (+ ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline * (syntax-rules () ((*) 1) ((* ?e) ?e) ((* ?e1 ?e2 ?e3 ?e4 ...) (* (* ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline - (syntax-rules () ((- ?e) (- 0 ?e)) ((- ?e1 ?e2 ?e3 ?e4 ...) (- (- ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline / (syntax-rules () ((/ ?e) (/ 1 ?e)) ((/ ?e1 ?e2 ?e3 ?e4 ...) (/ (/ ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline abs (syntax-rules () ((abs ?z) (let ((temp ?z)) (if (< temp 0) (-- temp) temp))))) (define-inline negative? (syntax-rules () ((negative? ?x) (< ?x 0)))) (define-inline positive? (syntax-rules () ((positive? ?x) (> ?x 0)))) (define-inline eqv? (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (define (constant? exp) (or (boolean? exp) (char? exp) (and (pair? exp) (= (length exp) 2) (identifier? (car exp)) (compare (car exp) (rename 'quote)) (symbol? (cadr exp))))) (if (or (constant? arg1) (constant? arg2)) (cons (rename 'eq?) (cdr exp)) exp))))) (define-inline memq (syntax-rules (quote) ((memq ?expr '(?datum ...)) (letrec-syntax ((memq0 (... (syntax-rules (quote) ((memq0 '?xx '(?d ...)) (let ((t1 '(?d ...))) (memq1 '?xx t1 (?d ...)))) ((memq0 ?e '(?d ...)) (let ((t0 ?e) (t1 '(?d ...))) (memq1 t0 t1 (?d ...))))))) (memq1 (... (syntax-rules () ((memq1 ?t0 ?t1 ()) #f) ((memq1 ?t0 ?t1 (?d1 ?d2 ...)) (if (eq? ?t0 '?d1) ?t1 (let ((?t1 (cdr ?t1))) (memq1 ?t0 ?t1 (?d2 ...))))))))) (memq0 ?expr '(?datum ...)))))) (define-inline memv (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (if (or (boolean? arg1) (fixnum? arg1) (char? arg1) (and (pair? arg1) (= (length arg1) 2) (identifier? (car arg1)) (compare (car arg1) (rename 'quote)) (symbol? (cadr arg1))) (and (pair? arg2) (= (length arg2) 2) (identifier? (car arg2)) (compare (car arg2) (rename 'quote)) (every1? (lambda (x) (or (boolean? x) (fixnum? x) (char? x) (symbol? x))) (cadr arg2)))) (cons (rename 'memq) (cdr exp)) exp))))) (define-inline assv (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (if (or (boolean? arg1) (char? arg1) (and (pair? arg1) (= (length arg1) 2) (identifier? (car arg1)) (compare (car arg1) (rename 'quote)) (symbol? (cadr arg1))) (and (pair? arg2) (= (length arg2) 2) (identifier? (car arg2)) (compare (car arg2) (rename 'quote)) (every1? (lambda (y) (and (pair? y) (let ((x (car y))) (or (boolean? x) (char? x) (symbol? x))))) (cadr arg2)))) (cons (rename 'assq) (cdr exp)) exp))))) (define-inline map (syntax-rules (lambda) ((map ?proc ?exp1 ?exp2 ...) (letrec-syntax ((loop (... (syntax-rules (lambda) ((loop 1 () (?y1 ?y2 ...) ?f ?exprs) (loop 2 (?y1 ?y2 ...) ?f ?exprs)) ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs) (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs)) ((loop 2 ?ys (lambda ?formals ?body) ?exprs) (loop 3 ?ys (lambda ?formals ?body) ?exprs)) ((loop 2 ?ys (?f1 . ?f2) ?exprs) (let ((f (?f1 . ?f2))) (loop 3 ?ys f ?exprs))) ((loop 2 ?ys ?f ?exprs) (loop 3 ?ys ?f ?exprs)) ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...)) (do ((?y1 ?e1 (cdr ?y1)) (?y2 ?e2 (cdr ?y2)) ... (results '() (cons (?f (car ?y1) (car ?y2) ...) results))) ((or (null? ?y1) (null? ?y2) ...) (reverse results)))))))) (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...)))))) (define-inline for-each (syntax-rules (lambda) ((for-each ?proc ?exp1 ?exp2 ...) (letrec-syntax ((loop (... (syntax-rules (lambda) ((loop 1 () (?y1 ?y2 ...) ?f ?exprs) (loop 2 (?y1 ?y2 ...) ?f ?exprs)) ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs) (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs)) ((loop 2 ?ys (lambda ?formals ?body) ?exprs) (loop 3 ?ys (lambda ?formals ?body) ?exprs)) ((loop 2 ?ys (?f1 . ?f2) ?exprs) (let ((f (?f1 . ?f2))) (loop 3 ?ys f ?exprs))) ((loop 2 ?ys ?f ?exprs) (loop 3 ?ys ?f ?exprs)) ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...)) (do ((?y1 ?e1 (cdr ?y1)) (?y2 ?e2 (cdr ?y2)) ...) ((or (null? ?y1) (null? ?y2) ...) (if #f #f)) (?f (car ?y1) (car ?y2) ...))))))) (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...)))))))))))))))))
+(let () (begin (set! extended-syntactic-environment (syntactic-copy global-syntactic-environment)) 'extended-syntactic-environment))
+(let () (begin (set! make-extended-syntactic-environment (lambda () (let ((.make-extended-syntactic-environment|2 0)) (begin (set! .make-extended-syntactic-environment|2 (lambda () (syntactic-copy extended-syntactic-environment))) (.make-extended-syntactic-environment|2))))) 'make-extended-syntactic-environment))
+(let () (begin (set! instruction.op car) 'instruction.op))
+(let () (begin (set! instruction.arg1 cadr) 'instruction.arg1))
+(let () (begin (set! instruction.arg2 caddr) 'instruction.arg2))
+(let () (begin (set! instruction.arg3 cadddr) 'instruction.arg3))
+(let () (begin (set! *mnemonic-names* '()) '*mnemonic-names*))
+(let () (begin '(define *last-reserved-mnemonic* 32767) '(define make-mnemonic (let ((count 0)) (lambda (name) (set! count (+ count 1)) (if (= count *last-reserved-mnemonic*) (error "Error in make-mnemonic: conflict: " name)) (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*)) count))) '(define (reserved-mnemonic name value) (if (and (> value 0) (< value *last-reserved-mnemonic*)) (set! *last-reserved-mnemonic* value)) (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*)) value) #t))
+(let () (begin (set! make-mnemonic (let ((.count|3 0)) (lambda (.name|4) (begin (set! .count|3 (+ .count|3 1)) (set! *mnemonic-names* (cons (cons .count|3 .name|4) *mnemonic-names*)) .count|3)))) 'make-mnemonic))
+(let () (begin (set! reserved-mnemonic (lambda (.name|1 .ignored|1) (let ((.reserved-mnemonic|2 0)) (begin (set! .reserved-mnemonic|2 (lambda (.name|3 .ignored|3) (make-mnemonic .name|3))) (.reserved-mnemonic|2 .name|1 .ignored|1))))) 'reserved-mnemonic))
+(let () (begin (set! $.linearize (reserved-mnemonic '.linearize -1)) '$.linearize))
+(let () (begin (set! $.label (reserved-mnemonic '.label 63)) '$.label))
+(let () (begin (set! $.proc (reserved-mnemonic '.proc 62)) '$.proc))
+(let () (begin (set! $.cont (reserved-mnemonic '.cont 61)) '$.cont))
+(let () (begin (set! $.align (reserved-mnemonic '.align 60)) '$.align))
+(let () (begin (set! $.asm (reserved-mnemonic '.asm 59)) '$.asm))
+(let () (begin (set! $.proc-doc (reserved-mnemonic '.proc-doc 58)) '$.proc-doc))
+(let () (begin (set! $.end (reserved-mnemonic '.end 57)) '$.end))
+(let () (begin (set! $.singlestep (reserved-mnemonic '.singlestep 56)) '$.singlestep))
+(let () (begin (set! $.entry (reserved-mnemonic '.entry 55)) '$.entry))
+(let () (begin (set! $op1 (make-mnemonic 'op1)) '$op1))
+(let () (begin (set! $op2 (make-mnemonic 'op2)) '$op2))
+(let () (begin (set! $op3 (make-mnemonic 'op3)) '$op3))
+(let () (begin (set! $op2imm (make-mnemonic 'op2imm)) '$op2imm))
+(let () (begin (set! $const (make-mnemonic 'const)) '$const))
+(let () (begin (set! $global (make-mnemonic 'global)) '$global))
+(let () (begin (set! $setglbl (make-mnemonic 'setglbl)) '$setglbl))
+(let () (begin (set! $lexical (make-mnemonic 'lexical)) '$lexical))
+(let () (begin (set! $setlex (make-mnemonic 'setlex)) '$setlex))
+(let () (begin (set! $stack (make-mnemonic 'stack)) '$stack))
+(let () (begin (set! $setstk (make-mnemonic 'setstk)) '$setstk))
+(let () (begin (set! $load (make-mnemonic 'load)) '$load))
+(let () (begin (set! $store (make-mnemonic 'store)) '$store))
+(let () (begin (set! $reg (make-mnemonic 'reg)) '$reg))
+(let () (begin (set! $setreg (make-mnemonic 'setreg)) '$setreg))
+(let () (begin (set! $movereg (make-mnemonic 'movereg)) '$movereg))
+(let () (begin (set! $lambda (make-mnemonic 'lambda)) '$lambda))
+(let () (begin (set! $lexes (make-mnemonic 'lexes)) '$lexes))
+(let () (begin (set! $args= (make-mnemonic 'args=)) '$args=))
+(let () (begin (set! $args>= (make-mnemonic 'args>=)) '$args>=))
+(let () (begin (set! $invoke (make-mnemonic 'invoke)) '$invoke))
+(let () (begin (set! $save (make-mnemonic 'save)) '$save))
+(let () (begin (set! $setrtn (make-mnemonic 'setrtn)) '$setrtn))
+(let () (begin (set! $restore (make-mnemonic 'restore)) '$restore))
+(let () (begin (set! $pop (make-mnemonic 'pop)) '$pop))
+(let () (begin (set! $popstk (make-mnemonic 'popstk)) '$popstk))
+(let () (begin (set! $return (make-mnemonic 'return)) '$return))
+(let () (begin (set! $mvrtn (make-mnemonic 'mvrtn)) '$mvrtn))
+(let () (begin (set! $apply (make-mnemonic 'apply)) '$apply))
+(let () (begin (set! $nop (make-mnemonic 'nop)) '$nop))
+(let () (begin (set! $jump (make-mnemonic 'jump)) '$jump))
+(let () (begin (set! $skip (make-mnemonic 'skip)) '$skip))
+(let () (begin (set! $branch (make-mnemonic 'branch)) '$branch))
+(let () (begin (set! $branchf (make-mnemonic 'branchf)) '$branchf))
+(let () (begin (set! $check (make-mnemonic 'check)) '$check))
+(let () (begin (set! $trap (make-mnemonic 'trap)) '$trap))
+(let () (begin (set! @maxargs-with-rest-arg@ 30) '@maxargs-with-rest-arg@))
+(let () (begin (set! *nregs* 32) '*nregs*))
+(let () (begin (set! *lastreg* (- *nregs* 1)) '*lastreg*))
+(let () (begin (set! *fullregs* (quotient *nregs* 2)) '*fullregs*))
+(let () (begin (set! *nhwregs* 8) '*nhwregs*))
+(let () (begin (set! *regnames* (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.alist|8 .r|8) (if (<= .r|8 0) .alist|8 (begin #t (.loop|1|4|7 (cons (cons (string->symbol (string-append ".REG" (number->string .r|8))) .r|8) .alist|8) (- .r|8 1)))))) (.loop|1|4|7 '() (- *nhwregs* 1)))))) '*regnames*))
+(let () (begin (set! *number-of-mnemonics* 72) '*number-of-mnemonics*))
+(let () (begin (set! prim-entry (lambda (.name|1) (let ((.prim-entry|2 0)) (begin (set! .prim-entry|2 (lambda (.name|3) (assq .name|3 $usual-integrable-procedures$))) (.prim-entry|2 .name|1))))) 'prim-entry))
+(let () (begin (set! prim-arity cadr) 'prim-arity))
+(let () (begin (set! prim-opcodename caddr) 'prim-opcodename))
+(let () (begin (set! prim-immediate? cadddr) 'prim-immediate?))
+(let () (begin (set! prim-primcode (lambda (.entry|1) (let ((.prim-primcode|2 0)) (begin (set! .prim-primcode|2 (lambda (.entry|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.prim-primcode|2 .entry|1))))) 'prim-primcode))
+(let () (begin (set! smallint? (let* ((.least|3 (- 0 (expt 2 29))) (.greatest|6 (- (- 0 .least|3) 1))) (let () (lambda (.x|10) (if (number? .x|10) (if (exact? .x|10) (if (integer? .x|10) (let ((.t|15|18 .x|10)) (if (<= .least|3 .t|15|18) (<= .t|15|18 .greatest|6) #f)) #f) #f) #f))))) 'smallint?))
+(let () (begin (set! sparc-imm? (lambda (.x|1) (let ((.sparc-imm?|2 0)) (begin (set! .sparc-imm?|2 (lambda (.x|3) (if (fixnum? .x|3) (let ((.t|6|9 .x|3)) (if (<= -1024 .t|6|9) (<= .t|6|9 1023) #f)) #f))) (.sparc-imm?|2 .x|1))))) 'sparc-imm?))
+(let () (begin (set! sparc-eq-imm? (lambda (.x|1) (let ((.sparc-eq-imm?|2 0)) (begin (set! .sparc-eq-imm?|2 (lambda (.x|3) (let ((.temp|4|7 (sparc-imm? .x|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (eq? .x|3 #t))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (eq? .x|3 #f))) (if .temp|12|15 .temp|12|15 (eq? .x|3 '()))))))))) (.sparc-eq-imm?|2 .x|1))))) 'sparc-eq-imm?))
+(let () (begin (set! valid-typetag? (lambda (.x|1) (let ((.valid-typetag?|2 0)) (begin (set! .valid-typetag?|2 (lambda (.x|3) (if (fixnum? .x|3) (let ((.t|6|9 .x|3)) (if (<= 0 .t|6|9) (<= .t|6|9 7) #f)) #f))) (.valid-typetag?|2 .x|1))))) 'valid-typetag?))
+(let () (begin (set! fixnum-primitives (lambda () (let ((.fixnum-primitives|2 0)) (begin (set! .fixnum-primitives|2 (lambda () #t)) (.fixnum-primitives|2))))) 'fixnum-primitives))
+(let () (begin (set! flonum-primitives (lambda () (let ((.flonum-primitives|2 0)) (begin (set! .flonum-primitives|2 (lambda () #t)) (.flonum-primitives|2))))) 'flonum-primitives))
+(let () (begin (set! prim-lives-until (lambda (.entry|1) (let ((.prim-lives-until|2 0)) (begin (set! .prim-lives-until|2 (lambda (.entry|3) (list-ref .entry|3 5))) (.prim-lives-until|2 .entry|1))))) 'prim-lives-until))
+(let () (begin (set! prim-kills (lambda (.entry|1) (let ((.prim-kills|2 0)) (begin (set! .prim-kills|2 (lambda (.entry|3) (list-ref .entry|3 6))) (.prim-kills|2 .entry|1))))) 'prim-kills))
+(let () (begin (set! $usual-integrable-procedures$ (let ((.:globals|3 available:killer:globals) (.:car|3 available:killer:car) (.:cdr|3 available:killer:cdr) (.:string|3 available:killer:string) (.:vector|3 available:killer:vector) (.:cell|3 available:killer:cell) (.:io|3 available:killer:io) (.:none|3 available:killer:none) (.:all|3 available:killer:all) (.:immortal|3 available:killer:immortal) (.:dead|3 available:killer:dead)) (.cons (.cons 'break (.cons 0 (.cons 'break (.cons #f (.cons 3 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'creg (.cons 0 (.cons 'creg (.cons #f (.cons 7 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'unspecified (.cons 0 (.cons 'unspecified (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'undefined (.cons 0 (.cons 'undefined (.cons #f (.cons 8 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eof-object (.cons 0 (.cons 'eof-object (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'enable-interrupts (.cons 1 (.cons 'enable-interrupts (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'disable-interrupts (.cons 0 (.cons 'disable-interrupts (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'typetag (.cons 1 (.cons 'typetag (.cons #f (.cons 17 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'not (.cons 1 (.cons 'not (.cons #f (.cons 24 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'null? (.cons 1 (.cons 'null? (.cons #f (.cons 25 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'pair? (.cons 1 (.cons 'pair? (.cons #f (.cons 26 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eof-object? (.cons 1 (.cons 'eof-object? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'port? (.cons 1 (.cons 'port? (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'structure? (.cons 1 (.cons 'structure? (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'car (.cons 1 (.cons 'car (.cons #f (.cons 27 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons name:car (.cons 1 (.cons 'car (.cons #f (.cons 27 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cdr (.cons 1 (.cons 'cdr (.cons #f (.cons 28 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cdr (.cons 1 (.cons 'cdr (.cons #f (.cons 28 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons 'symbol? (.cons 1 (.cons 'symbol? (.cons #f (.cons 31 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'number? (.cons 1 (.cons 'complex? (.cons #f (.cons 32 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'complex? (.cons 1 (.cons 'complex? (.cons #f (.cons 32 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'real? (.cons 1 (.cons 'rational? (.cons #f (.cons 33 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rational? (.cons 1 (.cons 'rational? (.cons #f (.cons 33 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'integer? (.cons 1 (.cons 'integer? (.cons #f (.cons 34 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fixnum? (.cons 1 (.cons 'fixnum? (.cons #f (.cons 35 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'flonum? (.cons 1 (.cons 'flonum? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'compnum? (.cons 1 (.cons 'compnum? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'exact? (.cons 1 (.cons 'exact? (.cons #f (.cons 36 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'inexact? (.cons 1 (.cons 'inexact? (.cons #f (.cons 37 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'exact->inexact (.cons 1 (.cons 'exact->inexact (.cons #f (.cons 38 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'inexact->exact (.cons 1 (.cons 'inexact->exact (.cons #f (.cons 39 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'round (.cons 1 (.cons 'round (.cons #f (.cons 40 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'truncate (.cons 1 (.cons 'truncate (.cons #f (.cons 41 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'zero? (.cons 1 (.cons 'zero? (.cons #f (.cons 44 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '-- (.cons 1 (.cons '-- (.cons #f (.cons 45 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'lognot (.cons 1 (.cons 'lognot (.cons #f (.cons 47 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'real-part (.cons 1 (.cons 'real-part (.cons #f (.cons 62 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'imag-part (.cons 1 (.cons 'imag-part (.cons #f (.cons 63 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char? (.cons 1 (.cons 'char? (.cons #f (.cons 64 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char->integer (.cons 1 (.cons 'char->integer (.cons #f (.cons 65 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'integer->char (.cons 1 (.cons 'integer->char (.cons #f (.cons 66 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string? (.cons 1 (.cons 'string? (.cons #f (.cons 80 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-length (.cons 1 (.cons 'string-length (.cons #f (.cons 81 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector? (.cons 1 (.cons 'vector? (.cons #f (.cons 82 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-length (.cons 1 (.cons 'vector-length (.cons #f (.cons 83 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector? (.cons 1 (.cons 'bytevector? (.cons #f (.cons 84 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-length (.cons 1 (.cons 'bytevector-length (.cons #f (.cons 85 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-fill! (.cons 2 (.cons 'bytevector-fill! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'make-bytevector (.cons 1 (.cons 'make-bytevector (.cons #f (.cons 86 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure? (.cons 1 (.cons 'procedure? (.cons #f (.cons 88 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure-length (.cons 1 (.cons 'procedure-length (.cons #f (.cons 89 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'make-procedure (.cons 1 (.cons 'make-procedure (.cons #f (.cons 90 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'creg-set! (.cons 1 (.cons 'creg-set! (.cons #f (.cons 113 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:make-cell (.cons 1 (.cons 'make-cell (.cons #f (.cons 126 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cell-ref (.cons 1 (.cons 'cell-ref (.cons #f (.cons 127 (.cons .:cell|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cell-set! (.cons 2 (.cons 'cell-set! (.cons #f (.cons 223 (.cons .:dead|3 (.cons .:cell|3 '()))))))) (.cons (.cons 'typetag-set! (.cons 2 (.cons 'typetag-set! (.cons valid-typetag? (.cons 160 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'eq? (.cons 2 (.cons 'eq? (.cons sparc-eq-imm? (.cons 161 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eqv? (.cons 2 (.cons 'eqv? (.cons #f (.cons 162 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cons (.cons 2 (.cons 'cons (.cons #f (.cons 168 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cons (.cons 2 (.cons 'cons (.cons #f (.cons 168 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'set-car! (.cons 2 (.cons 'set-car! (.cons #f (.cons 169 (.cons .:dead|3 (.cons .:car|3 '()))))))) (.cons (.cons 'set-cdr! (.cons 2 (.cons 'set-cdr! (.cons #f (.cons 170 (.cons .:dead|3 (.cons .:cdr|3 '()))))))) (.cons (.cons '+ (.cons 2 (.cons '+ (.cons sparc-imm? (.cons 176 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '- (.cons 2 (.cons '- (.cons sparc-imm? (.cons 177 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '* (.cons 2 (.cons '* (.cons sparc-imm? (.cons 178 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '/ (.cons 2 (.cons '/ (.cons #f (.cons 179 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'quotient (.cons 2 (.cons 'quotient (.cons #f (.cons 180 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '< (.cons 2 (.cons '< (.cons sparc-imm? (.cons 181 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<= (.cons 2 (.cons '<= (.cons sparc-imm? (.cons 182 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '= (.cons 2 (.cons '= (.cons sparc-imm? (.cons 183 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '> (.cons 2 (.cons '> (.cons sparc-imm? (.cons 184 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>= (.cons 2 (.cons '>= (.cons sparc-imm? (.cons 185 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logand (.cons 2 (.cons 'logand (.cons #f (.cons 192 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logior (.cons 2 (.cons 'logior (.cons #f (.cons 193 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logxor (.cons 2 (.cons 'logxor (.cons #f (.cons 194 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'lsh (.cons 2 (.cons 'lsh (.cons #f (.cons 195 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rsha (.cons 2 (.cons 'rsha (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rshl (.cons 2 (.cons 'rshl (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rot (.cons 2 (.cons 'rot (.cons #f (.cons 196 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'make-string (.cons 2 (.cons 'make-string (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-ref (.cons 2 (.cons 'string-ref (.cons sparc-imm? (.cons 209 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-set! (.cons 3 (.cons 'string-set! (.cons sparc-imm? (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'make-vector (.cons 2 (.cons 'make-vector (.cons #f (.cons 210 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-ref (.cons 2 (.cons 'vector-ref (.cons sparc-imm? (.cons 211 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-ref (.cons 2 (.cons 'bytevector-ref (.cons sparc-imm? (.cons 213 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure-ref (.cons 2 (.cons 'procedure-ref (.cons #f (.cons 215 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char<? (.cons 2 (.cons 'char<? (.cons char? (.cons 224 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char<=? (.cons 2 (.cons 'char<=? (.cons char? (.cons 225 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char=? (.cons 2 (.cons 'char=? (.cons char? (.cons 226 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char>? (.cons 2 (.cons 'char>? (.cons char? (.cons 227 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char>=? (.cons 2 (.cons 'char>=? (.cons char? (.cons 228 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'sys$partial-list->vector (.cons 2 (.cons 'sys$partial-list->vector (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'vector-set! (.cons 3 (.cons 'vector-set! (.cons #f (.cons 241 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'bytevector-set! (.cons 3 (.cons 'bytevector-set! (.cons #f (.cons 242 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'procedure-set! (.cons 3 (.cons 'procedure-set! (.cons #f (.cons 243 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'bytevector-like? (.cons 1 (.cons 'bytevector-like? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-like? (.cons 1 (.cons 'vector-like? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-ref (.cons 2 (.cons 'bytevector-like-ref (.cons #f (.cons -1 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-set! (.cons 3 (.cons 'bytevector-like-set! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'sys$bvlcmp (.cons 2 (.cons 'sys$bvlcmp (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'vector-like-ref (.cons 2 (.cons 'vector-like-ref (.cons #f (.cons -1 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-like-set! (.cons 3 (.cons 'vector-like-set! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'vector-like-length (.cons 1 (.cons 'vector-like-length (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-length (.cons 1 (.cons 'bytevector-like-length (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'remainder (.cons 2 (.cons 'remainder (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'sys$read-char (.cons 1 (.cons 'sys$read-char (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:io|3 '()))))))) (.cons (.cons 'gc-counter (.cons 0 (.cons 'gc-counter (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (append (if (fixnum-primitives) (.cons (.cons 'most-positive-fixnum (.cons 0 (.cons 'most-positive-fixnum (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'most-negative-fixnum (.cons 0 (.cons 'most-negative-fixnum (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx+ (.cons 2 (.cons 'fx+ (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx- (.cons 2 (.cons 'fx- (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx-- (.cons 1 (.cons 'fx-- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx* (.cons 2 (.cons 'fx* (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx= (.cons 2 (.cons 'fx= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx< (.cons 2 (.cons 'fx< (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx<= (.cons 2 (.cons 'fx<= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx> (.cons 2 (.cons 'fx> (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx>= (.cons 2 (.cons 'fx>= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxzero? (.cons 1 (.cons 'fxzero? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxpositive? (.cons 1 (.cons 'fxpositive? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxnegative? (.cons 1 (.cons 'fxnegative? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '())))))))))))))) '()) (append (if (flonum-primitives) (.cons (.cons 'fl+ (.cons 2 (.cons '+ (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl- (.cons 2 (.cons '- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl-- (.cons 1 (.cons '-- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl* (.cons 2 (.cons '* (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl= (.cons 2 (.cons '= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl< (.cons 2 (.cons '< (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl<= (.cons 2 (.cons '<= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl> (.cons 2 (.cons '> (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl>= (.cons 2 (.cons '>= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '()))))))))) '()) (.cons (.cons name:check! (.cons -1 (.cons 'check! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-length:vec (.cons 1 (.cons 'vector-length:vec (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-ref:trusted (.cons 2 (.cons 'vector-ref:trusted (.cons sparc-imm? (.cons -1 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-set!:trusted (.cons 3 (.cons 'vector-set!:trusted (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'car:pair (.cons 1 (.cons 'car:pair (.cons #f (.cons -1 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cdr:pair (.cons 1 (.cons 'cdr:pair (.cons #f (.cons -1 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:fix:fix (.cons 2 (.cons '=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<:fix:fix (.cons 2 (.cons '<:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<=:fix:fix (.cons 2 (.cons '<=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>=:fix:fix (.cons 2 (.cons '>=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>:fix:fix (.cons 2 (.cons '>:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:idx:idx (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:fix:fix (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:exi:exi (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:flo:flo (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:flo:flo (.cons 2 (.cons '=:flo:flo (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:obj:flo (.cons 2 (.cons '=:obj:flo (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:flo:obj (.cons 2 (.cons '=:flo:obj (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) '$usual-integrable-procedures$))
+(let () (begin (set! $immediate-primops$ '((typetag-set! 128) (eq? 129) (+ 130) (- 131) (< 132) (<= 133) (= 134) (> 135) (>= 136) (char<? 137) (char<=? 138) (char=? 139) (char>? 140) (char>=? 141) (string-ref 144) (vector-ref 145) (bytevector-ref 146) (bytevector-like-ref -1) (vector-like-ref -1) (fx+ -1) (fx- -1) (fx-- -1) (fx= -1) (fx< -1) (fx<= -1) (fx> -1) (fx>= -1))) '$immediate-primops$))
+(let () (begin (set! $reg/op1/branchf (make-mnemonic 'reg/op1/branchf)) '$reg/op1/branchf))
+(let () (begin (set! $reg/op2/branchf (make-mnemonic 'reg/op2/branchf)) '$reg/op2/branchf))
+(let () (begin (set! $reg/op2imm/branchf (make-mnemonic 'reg/op2imm/branchf)) '$reg/op2imm/branchf))
+(let () (begin (set! $reg/op1/check (make-mnemonic 'reg/op1/check)) '$reg/op1/check))
+(let () (begin (set! $reg/op2/check (make-mnemonic 'reg/op2/check)) '$reg/op2/check))
+(let () (begin (set! $reg/op2imm/check (make-mnemonic 'reg/op2imm/check)) '$reg/op2imm/check))
+(let () (begin (set! $reg/op1/setreg (make-mnemonic 'reg/op1/setreg)) '$reg/op1/setreg))
+(let () (begin (set! $reg/op2/setreg (make-mnemonic 'reg/op2/setreg)) '$reg/op2/setreg))
+(let () (begin (set! $reg/op2imm/setreg (make-mnemonic 'reg/op2imm/setreg)) '$reg/op2imm/setreg))
+(let () (begin (set! $reg/branchf (make-mnemonic 'reg/branchf)) '$reg/branchf))
+(let () (begin (set! $reg/return (make-mnemonic 'reg/return)) '$reg/return))
+(let () (begin (set! $reg/setglbl (make-mnemonic 'reg/setglbl)) '$reg/setglbl))
+(let () (begin (set! $reg/op3 (make-mnemonic 'reg/op3)) '$reg/op3))
+(let () (begin (set! $const/setreg (make-mnemonic 'const/setreg)) '$const/setreg))
+(let () (begin (set! $const/return (make-mnemonic 'const/return)) '$const/return))
+(let () (begin (set! $global/setreg (make-mnemonic 'global/setreg)) '$global/setreg))
+(let () (begin (set! $setrtn/branch (make-mnemonic 'setrtn/branch)) '$setrtn/branch))
+(let () (begin (set! $setrtn/invoke (make-mnemonic 'setrtn/invoke)) '$setrtn/invoke))
+(let () (begin (set! $global/invoke (make-mnemonic 'global/invoke)) '$global/invoke))
+(let () (begin (set! $cons 'cons) '$cons))
+(let () (begin (set! $car:pair 'car) '$car:pair))
+(let () (begin (set! $cdr:pair 'cdr) '$cdr:pair))
+(let () (define-subtype 'true 'object))
+(let () (define-subtype 'eqtype 'object))
+(let () (define-subtype 'nonpointer 'eqtype))
+(let () (define-subtype 'eqtype1 'eqtype))
+(let () (define-subtype 'boolean 'nonpointer))
+(let () (define-subtype 'truth 'eqtype1))
+(let () (define-subtype 'truth 'boolean))
+(let () (define-subtype 'false 'boolean))
+(let () (define-subtype 'eqtype1 'true))
+(let () (define-subtype 'procedure 'true))
+(let () (define-subtype 'vector 'true))
+(let () (define-subtype 'bytevector 'true))
+(let () (define-subtype 'string 'true))
+(let () (define-subtype 'pair 'true))
+(let () (define-subtype 'emptylist 'eqtype1))
+(let () (define-subtype 'emptylist 'nonpointer))
+(let () (define-subtype 'symbol 'eqtype1))
+(let () (define-subtype 'char 'eqtype1))
+(let () (define-subtype 'char 'nonpointer))
+(let () (define-subtype 'number 'true))
+(let () (define-subtype 'inexact 'number))
+(let () (define-subtype 'flonum 'inexact))
+(let () (define-subtype 'integer 'number))
+(let () (define-subtype 'exact 'number))
+(let () (define-subtype 'exactint 'integer))
+(let () (define-subtype 'exactint 'exact))
+(let () (define-subtype 'fixnum 'exactint))
+(let () (define-subtype '!fixnum 'fixnum))
+(let () (define-subtype 'fixnum! 'fixnum))
+(let () (define-subtype 'index '!fixnum))
+(let () (define-subtype 'index 'fixnum!))
+(let () (define-subtype 'zero 'index))
+(let () (define-subtype 'fixnum 'eqtype1))
+(let () (define-subtype 'fixnum 'nonpointer))
+(let () (compute-type-structure!))
+(let () (define-intersection 'true 'eqtype 'eqtype1))
+(let () (define-intersection 'true 'boolean 'truth))
+(let () (define-intersection 'exact 'integer 'exactint))
+(let () (define-intersection '!fixnum 'fixnum! 'index))
+(let () (begin (set! rep:min_fixnum (- 0 (expt 2 29))) 'rep:min_fixnum))
+(let () (begin (set! rep:max_fixnum (- (expt 2 29) 1)) 'rep:max_fixnum))
+(let () (begin (set! rep:max_index (- (expt 2 24) 1)) 'rep:max_index))
+(let () (begin (set! rep:object (symbol->rep 'object)) 'rep:object))
+(let () (begin (set! rep:true (symbol->rep 'true)) 'rep:true))
+(let () (begin (set! rep:truth (symbol->rep 'truth)) 'rep:truth))
+(let () (begin (set! rep:false (symbol->rep 'false)) 'rep:false))
+(let () (begin (set! rep:boolean (symbol->rep 'boolean)) 'rep:boolean))
+(let () (begin (set! rep:pair (symbol->rep 'pair)) 'rep:pair))
+(let () (begin (set! rep:symbol (symbol->rep 'symbol)) 'rep:symbol))
+(let () (begin (set! rep:number (symbol->rep 'number)) 'rep:number))
+(let () (begin (set! rep:zero (symbol->rep 'zero)) 'rep:zero))
+(let () (begin (set! rep:index (symbol->rep 'index)) 'rep:index))
+(let () (begin (set! rep:fixnum (symbol->rep 'fixnum)) 'rep:fixnum))
+(let () (begin (set! rep:exactint (symbol->rep 'exactint)) 'rep:exactint))
+(let () (begin (set! rep:flonum (symbol->rep 'flonum)) 'rep:flonum))
+(let () (begin (set! rep:exact (symbol->rep 'exact)) 'rep:exact))
+(let () (begin (set! rep:inexact (symbol->rep 'inexact)) 'rep:inexact))
+(let () (begin (set! rep:integer (symbol->rep 'integer)) 'rep:integer))
+(let () (begin (set! rep:char (symbol->rep 'char)) 'rep:char))
+(let () (begin (set! rep:string (symbol->rep 'string)) 'rep:string))
+(let () (begin (set! rep:vector (symbol->rep 'vector)) 'rep:vector))
+(let () (begin (set! rep:procedure (symbol->rep 'procedure)) 'rep:procedure))
+(let () (begin (set! rep:bottom (symbol->rep 'bottom)) 'rep:bottom))
+(let () (begin (set! representation-of-value (lambda (.x|1) (let ((.representation-of-value|2 0)) (begin (set! .representation-of-value|2 (lambda (.x|3) (if (boolean? .x|3) (if .x|3 rep:truth rep:false) (if (pair? .x|3) rep:pair (if (symbol? .x|3) rep:symbol (if (number? .x|3) (if (if (exact? .x|3) (integer? .x|3) #f) (if (zero? .x|3) rep:zero (if (let ((.t|13|16 .x|3)) (if (<= 0 .t|13|16) (<= .t|13|16 rep:max_index) #f)) rep:index (if (let ((.t|20|23 .x|3)) (if (<= rep:min_fixnum .t|20|23) (<= .t|20|23 rep:max_fixnum) #f)) rep:fixnum rep:exactint))) (if (if (inexact? .x|3) (real? .x|3) #f) rep:flonum rep:number)) (if (char? .x|3) rep:char (if (string? .x|3) rep:string (if (vector? .x|3) rep:vector rep:true))))))))) (.representation-of-value|2 .x|1))))) 'representation-of-value))
+(let () (begin (set! rep-specific (representation-table '((= (fixnum fixnum) =:fix:fix) (< (fixnum fixnum) <:fix:fix) (<= (fixnum fixnum) <=:fix:fix) (> (fixnum fixnum) >:fix:fix) (>= (fixnum fixnum) >=:fix:fix)))) 'rep-specific))
+(let () (begin (set! rep-result (representation-table '((fixnum? (fixnum) (truth)) (vector? (vector) (truth)) (<= (zero !fixnum) (truth)) (>= (!fixnum zero) (truth)) (<=:fix:fix (zero !fixnum) (truth)) (>=:fix:fix (!fixnum zero) (truth)) (+ (index index) (!fixnum)) (+ (fixnum fixnum) (exactint)) (- (index index) (fixnum!)) (- (fixnum fixnum) (exactint)) (+ (flonum flonum) (flonum)) (- (flonum flonum) (flonum)) (make-vector (object object) (vector)) (vector-length:vec (vector) (index)) (cons (object object) (pair)) (= (number number) (boolean)) (< (number number) (boolean)) (<= (number number) (boolean)) (> (number number) (boolean)) (>= (number number) (boolean)) (=:fix:fix (fixnum fixnum) (boolean)) (<:fix:fix (fixnum fixnum) (boolean)) (<=:fix:fix (fixnum fixnum) (boolean)) (>:fix:fix (fixnum fixnum) (boolean)) (>=:fix:fix (fixnum fixnum) (boolean))))) 'rep-result))
+(let () (begin (set! rep-informing (representation-table '((fixnum? (object) (fixnum) (object)) (flonum? (object) (flonum) (object)) (vector? (object) (vector) (object)) (pair? (object) (pair) (object)) (= (exactint index) (index index) (exactint index)) (= (index exactint) (index index) (index exactint)) (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum)) (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint)) (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!)) (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint)) (< (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (< (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (> (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (> (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (=:fix:fix (exactint index) (index index) (exactint index)) (=:fix:fix (index exactint) (index index) (index exactint)) (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum)) (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint)) (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!)) (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint)) (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))))) 'rep-informing))
+(let () (begin (set! pass2 (lambda (.exp|1) (let ((.pass2|2 0)) (begin (set! .pass2|2 (lambda (.exp|3) (simplify .exp|3 (make-notepad #f)))) (.pass2|2 .exp|1))))) 'pass2))
+(let () (begin (set! simplify (lambda (.exp|1 .notepad|1) (let ((.simplify|2 0)) (begin (set! .simplify|2 (lambda (.exp|3 .notepad|3) (let ((.temp|4|7 (let ((.x|14|17 .exp|3)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (if (memv .temp|4|7 '(quote)) .exp|3 (if (memv .temp|4|7 '(lambda)) (simplify-lambda .exp|3 .notepad|3) (if (memv .temp|4|7 '(set!)) (simplify-assignment .exp|3 .notepad|3) (if (memv .temp|4|7 '(if)) (simplify-conditional .exp|3 .notepad|3) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (begin (notepad-var-add! .notepad|3 (variable.name .exp|3)) .exp|3) (simplify-sequential .exp|3 .notepad|3)) (simplify-call .exp|3 .notepad|3))))))))) (.simplify|2 .exp|1 .notepad|1))))) 'simplify))
+(let () (begin (set! simplify-lambda (lambda (.exp|1 .notepad|1) (let ((.simplify-lambda|2 0)) (begin (set! .simplify-lambda|2 (lambda (.exp|3 .notepad|3) (begin (notepad-lambda-add! .notepad|3 .exp|3) (let ((.defs|6 (lambda.defs .exp|3)) (.body|6 (lambda.body .exp|3)) (.newnotepad|6 (make-notepad .exp|3))) (begin (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|7|8|18) (if (null? .y1|7|8|18) (if #f #f (unspecified)) (begin (begin #t (let ((.def|22 (let ((.x|23|26 .y1|7|8|18)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (.simplify-lambda|2 (def.rhs .def|22) .newnotepad|6))) (.loop|12|14|17 (let ((.x|27|30 .y1|7|8|18)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))))))) (.loop|12|14|17 .defs|6)))) (lambda.body-set! .exp|3 (simplify .body|6 .newnotepad|6)) (lambda.f-set! .exp|3 (notepad-free-variables .newnotepad|6)) (lambda.g-set! .exp|3 (notepad-captured-variables .newnotepad|6)) (single-assignment-analysis .exp|3 .newnotepad|6) (let ((.known-lambdas|33 (notepad.nonescaping .newnotepad|6))) (let () (let ((.loop|39|41|44 (unspecified))) (begin (set! .loop|39|41|44 (lambda (.y1|34|35|45) (if (null? .y1|34|35|45) (if #f #f (unspecified)) (begin (begin #t (let ((.l|49 (let ((.x|50|53 .y1|34|35|45)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memq .l|49 .known-lambdas|33) (lambda-lifting .l|49 .exp|3) (lambda-lifting .l|49 .l|49)))) (.loop|39|41|44 (let ((.x|54|57 .y1|34|35|45)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))))))) (.loop|39|41|44 (notepad.lambdas .newnotepad|6)))))))) (single-assignment-elimination .exp|3 .notepad|3) (assignment-elimination .exp|3) (if (not (notepad.parent .notepad|3)) (lambda-lifting .exp|3 .exp|3) (unspecified)) .exp|3))) (.simplify-lambda|2 .exp|1 .notepad|1))))) 'simplify-lambda))
+(let () (begin (set! simplify-assignment (lambda (.exp|1 .notepad|1) (let ((.simplify-assignment|2 0)) (begin (set! .simplify-assignment|2 (lambda (.exp|3 .notepad|3) (begin (notepad-var-add! .notepad|3 (assignment.lhs .exp|3)) (let ((.rhs|6 (simplify (assignment.rhs .exp|3) .notepad|3))) (if (begin? .rhs|6) (let ((.exprs|10 (reverse (begin.exprs .rhs|6)))) (begin (assignment.rhs-set! .exp|3 (let ((.x|11|14 .exprs|10)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) (post-simplify-begin (make-begin (reverse (cons .exp|3 (let ((.x|15|18 .exprs|10)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))) .notepad|3))) (begin (assignment.rhs-set! .exp|3 .rhs|6) .exp|3)))))) (.simplify-assignment|2 .exp|1 .notepad|1))))) 'simplify-assignment))
+(let () (begin (set! simplify-sequential (lambda (.exp|1 .notepad|1) (let ((.simplify-sequential|2 0)) (begin (set! .simplify-sequential|2 (lambda (.exp|3 .notepad|3) (let ((.exprs|6 (let () (let ((.loop|12|15|18 (unspecified))) (begin (set! .loop|12|15|18 (lambda (.y1|7|8|19 .results|7|11|19) (if (null? .y1|7|8|19) (reverse .results|7|11|19) (begin #t (.loop|12|15|18 (let ((.x|23|26 .y1|7|8|19)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))) (cons (let ((.exp|27 (let ((.x|28|31 .y1|7|8|19)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (simplify .exp|27 .notepad|3)) .results|7|11|19)))))) (.loop|12|15|18 (begin.exprs .exp|3) '())))))) (begin (begin.exprs-set! .exp|3 .exprs|6) (post-simplify-begin .exp|3 .notepad|3))))) (.simplify-sequential|2 .exp|1 .notepad|1))))) 'simplify-sequential))
+(let () (begin (set! post-simplify-begin (lambda (.exp|1 .notepad|1) (let ((.post-simplify-begin|2 0)) (begin (set! .post-simplify-begin|2 (lambda (.exp|3 .notepad|3) (let ((.unspecified-expression|6 (make-unspecified))) (let ((.filter|9 (unspecified)) (.flatten|9 (unspecified))) (begin (set! .filter|9 (lambda (.exprs|10 .filtered|10) (if (null? .exprs|10) .filtered|10 (let ((.exp|13 (let ((.x|39|42 .exprs|10)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))))) (if (constant? .exp|13) (.filter|9 (let ((.x|15|18 .exprs|10)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .filtered|10) (if (variable? .exp|13) (.filter|9 (let ((.x|20|23 .exprs|10)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) .filtered|10) (if (lambda? .exp|13) (begin (notepad.lambdas-set! .notepad|3 (remq .exp|13 (notepad.lambdas .notepad|3))) (.filter|9 (let ((.x|25|28 .exprs|10)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .filtered|10)) (if (equal? .exp|13 .unspecified-expression|6) (.filter|9 (let ((.x|30|33 .exprs|10)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) .filtered|10) (.filter|9 (let ((.x|35|38 .exprs|10)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (cons .exp|13 .filtered|10)))))))))) (set! .flatten|9 (lambda (.exprs|43 .flattened|43) (if (null? .exprs|43) .flattened|43 (if (begin? (let ((.x|46|49 .exprs|43)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))) (.flatten|9 (let ((.x|50|53 .exprs|43)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53))) (.flatten|9 (begin.exprs (let ((.x|54|57 .exprs|43)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) .flattened|43)) (.flatten|9 (let ((.x|59|62 .exprs|43)) (begin (.check! (pair? .x|59|62) 1 .x|59|62) (cdr:pair .x|59|62))) (cons (let ((.x|63|66 .exprs|43)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))) .flattened|43)))))) (let ((.exprs|67 (.flatten|9 (begin.exprs .exp|3) '()))) (begin (begin.exprs-set! .exp|3 (.filter|9 (let ((.x|68|71 .exprs|67)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))) (cons (let ((.x|73|76 .exprs|67)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76))) '()))) (if (null? (let ((.x|77|80 (begin.exprs .exp|3))) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80)))) (let ((.x|81|84 (begin.exprs .exp|3))) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))) .exp|3)))))))) (.post-simplify-begin|2 .exp|1 .notepad|1))))) 'post-simplify-begin))
+(let () (begin (set! simplify-call (lambda (.exp|1 .notepad|1) (let ((.simplify-call|2 0)) (begin (set! .simplify-call|2 (lambda (.exp|3 .notepad|3) (let ((.finish|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .finish|4 (lambda (.newargs|5 .exprs|5) (begin (call.args-set! .exp|3 (reverse .newargs|5)) (let* ((.newexp|8 (if (lambda? (call.proc .exp|3)) (simplify-let .exp|3 .notepad|3) (begin (call.proc-set! .exp|3 (simplify (call.proc .exp|3) .notepad|3)) .exp|3))) (.newexp|11 (if (if (call? .newexp|8) (variable? (call.proc .newexp|8)) #f) (let* ((.procname|35 (variable.name (call.proc .newexp|8))) (.args|38 (call.args .newexp|8)) (.entry|41 (if (not (null? .args|38)) (if (constant? (let ((.x|71|74 .args|38)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74)))) (if (integrate-usual-procedures) (if (every? constant? .args|38) (let ((.entry|80 (constant-folding-entry .procname|35))) (if .entry|80 (let ((.predicates|85 (constant-folding-predicates .entry|80))) (if (= (length .args|38) (length .predicates|85)) (let ((.args|90 .args|38) (.predicates|90 .predicates|85)) (let () (let ((.loop|93 (unspecified))) (begin (set! .loop|93 (lambda (.args|94 .predicates|94) (if (null? .args|94) .entry|80 (if ((let ((.x|97|100 .predicates|94)) (begin (.check! (pair? .x|97|100) 0 .x|97|100) (car:pair .x|97|100))) (constant.value (let ((.x|101|104 .args|94)) (begin (.check! (pair? .x|101|104) 0 .x|101|104) (car:pair .x|101|104))))) (.loop|93 (let ((.x|105|108 .args|94)) (begin (.check! (pair? .x|105|108) 1 .x|105|108) (cdr:pair .x|105|108))) (let ((.x|109|112 .predicates|94)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112)))) #f)))) (.loop|93 .args|90 .predicates|90))))) #f)) #f)) #f) #f) #f) #f))) (let () (if .entry|41 (make-constant (apply (constant-folding-folder .entry|41) (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (constant.value (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .args|38 '())))))) .newexp|8))) .newexp|8))) (let () (if (if (call? .newexp|11) (begin? (call.proc .newexp|11)) #f) (let ((.exprs0|20 (reverse (begin.exprs (call.proc .newexp|11))))) (begin (call.proc-set! .newexp|11 (let ((.x|21|24 .exprs0|20)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) (post-simplify-begin (make-begin (reverse (cons .newexp|11 (append (let ((.x|25|28 .exprs0|20)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .exprs|5)))) .notepad|3))) (if (null? .exprs|5) .newexp|11 (post-simplify-begin (make-begin (reverse (cons .newexp|11 .exprs|5))) .notepad|3)))))))) (set! .loop|4 (lambda (.args|114 .newargs|114 .exprs|114) (if (null? .args|114) (.finish|4 .newargs|114 .exprs|114) (if (begin? (let ((.x|117|120 .args|114)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120)))) (let ((.newexprs|123 (reverse (begin.exprs (let ((.x|136|139 .args|114)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))))))) (.loop|4 (let ((.x|124|127 .args|114)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.x|128|131 .newexprs|123)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))) .newargs|114) (append (let ((.x|132|135 .newexprs|123)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))) .exprs|114))) (.loop|4 (let ((.x|141|144 .args|114)) (begin (.check! (pair? .x|141|144) 1 .x|141|144) (cdr:pair .x|141|144))) (cons (let ((.x|145|148 .args|114)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))) .newargs|114) .exprs|114))))) (call.args-set! .exp|3 (let () (let ((.loop|154|157|160 (unspecified))) (begin (set! .loop|154|157|160 (lambda (.y1|149|150|161 .results|149|153|161) (if (null? .y1|149|150|161) (reverse .results|149|153|161) (begin #t (.loop|154|157|160 (let ((.x|165|168 .y1|149|150|161)) (begin (.check! (pair? .x|165|168) 1 .x|165|168) (cdr:pair .x|165|168))) (cons (let ((.arg|169 (let ((.x|170|173 .y1|149|150|161)) (begin (.check! (pair? .x|170|173) 0 .x|170|173) (car:pair .x|170|173))))) (simplify .arg|169 .notepad|3)) .results|149|153|161)))))) (.loop|154|157|160 (call.args .exp|3) '()))))) (.loop|4 (call.args .exp|3) '() '()))))) (.simplify-call|2 .exp|1 .notepad|1))))) 'simplify-call))
+(let () (begin (set! simplify-let (lambda (.exp|1 .notepad|1) (let ((.simplify-let|2 0)) (begin (set! .simplify-let|2 (lambda (.exp|3 .notepad|3) (let ((.return2|4 (unspecified)) (.loop2|4 (unspecified)) (.return1-finish|4 (unspecified)) (.return1|4 (unspecified)) (.loop1|4 (unspecified)) (.proc|4 (unspecified))) (begin (set! .return2|4 (lambda (.rev-formals|5 .rev-actuals|5 .rev-for-effect|5) (let ((.formals|8 (reverse .rev-formals|5)) (.actuals|8 (reverse .rev-actuals|5)) (.for-effect|8 (reverse .rev-for-effect|5))) (begin (lambda.args-set! .proc|4 .formals|8) (call.args-set! .exp|3 .actuals|8) (let ((.exp|11 (if (if (null? .actuals|8) (let ((.temp|15|18 (null? (lambda.defs .proc|4)))) (if .temp|15|18 .temp|15|18 (if (notepad.parent .notepad|3) (policy:lift? .proc|4 (notepad.parent .notepad|3) (let () (let ((.loop|27|30|33 (unspecified))) (begin (set! .loop|27|30|33 (lambda (.y1|22|23|34 .results|22|26|34) (if (null? .y1|22|23|34) (reverse .results|22|26|34) (begin #t (.loop|27|30|33 (let ((.x|38|41 .y1|22|23|34)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (cons (let ((.def|42 (let ((.x|43|46 .y1|22|23|34)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) '()) .results|22|26|34)))))) (.loop|27|30|33 (lambda.defs .proc|4) '()))))) #f))) #f) (begin (let () (let ((.loop|52|54|57 (unspecified))) (begin (set! .loop|52|54|57 (lambda (.y1|47|48|58) (if (null? .y1|47|48|58) (if #f #f (unspecified)) (begin (begin #t (let ((.i|62 (let ((.x|63|66 .y1|47|48|58)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))))) (notepad-var-add! .notepad|3 .i|62))) (.loop|52|54|57 (let ((.x|67|70 .y1|47|48|58)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70)))))))) (.loop|52|54|57 (lambda.f .proc|4))))) (if (not (null? (lambda.defs .proc|4))) (let ((.parent|73 (notepad.parent .notepad|3)) (.defs|73 (lambda.defs .proc|4)) (.r|73 (lambda.r .proc|4))) (begin (lambda.defs-set! .parent|73 (append .defs|73 (lambda.defs .parent|73))) (lambda.defs-set! .proc|4 '()) (lambda.r-set! .parent|73 (append (let () (let ((.loop|79|82|85 (unspecified))) (begin (set! .loop|79|82|85 (lambda (.y1|74|75|86 .results|74|78|86) (if (null? .y1|74|75|86) (reverse .results|74|78|86) (begin #t (.loop|79|82|85 (let ((.x|90|93 .y1|74|75|86)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))) (cons (let ((.def|94 (let ((.x|95|98 .y1|74|75|86)) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (r-lookup .r|73 (def.lhs .def|94))) .results|74|78|86)))))) (.loop|79|82|85 .defs|73 '())))) (lambda.r .parent|73))))) (unspecified)) (lambda.body .proc|4)) .exp|3))) (if (null? .for-effect|8) .exp|11 (post-simplify-begin (make-begin (append .for-effect|8 (cons .exp|11 '()))) .notepad|3))))))) (set! .loop2|4 (lambda (.formals|99 .actuals|99 .processed-formals|99 .processed-actuals|99 .for-effect|99) (if (null? .formals|99) (.return2|4 .processed-formals|99 .processed-actuals|99 .for-effect|99) (if (ignored? (let ((.x|102|105 .formals|99)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) (.loop2|4 (let ((.x|106|109 .formals|99)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109))) (let ((.x|110|113 .actuals|99)) (begin (.check! (pair? .x|110|113) 1 .x|110|113) (cdr:pair .x|110|113))) .processed-formals|99 .processed-actuals|99 (cons (let ((.x|114|117 .actuals|99)) (begin (.check! (pair? .x|114|117) 0 .x|114|117) (car:pair .x|114|117))) .for-effect|99)) (.loop2|4 (let ((.x|119|122 .formals|99)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122))) (let ((.x|123|126 .actuals|99)) (begin (.check! (pair? .x|123|126) 1 .x|123|126) (cdr:pair .x|123|126))) (cons (let ((.x|127|130 .formals|99)) (begin (.check! (pair? .x|127|130) 0 .x|127|130) (car:pair .x|127|130))) .processed-formals|99) (cons (let ((.x|131|134 .actuals|99)) (begin (.check! (pair? .x|131|134) 0 .x|131|134) (car:pair .x|131|134))) .processed-actuals|99) .for-effect|99))))) (set! .return1-finish|4 (lambda (.formals|135 .actuals|135) (begin (simplify-lambda .proc|4 .notepad|3) (.loop2|4 .formals|135 .actuals|135 '() '() '())))) (set! .return1|4 (lambda (.rev-formals|136 .rev-actuals|136) (let ((.formals|139 (reverse .rev-formals|136)) (.actuals|139 (reverse .rev-actuals|136))) (begin (lambda.args-set! .proc|4 .formals|139) (if (if (not (null? .formals|139)) (if (null? (let ((.x|142|145 .formals|139)) (begin (.check! (pair? .x|142|145) 1 .x|142|145) (cdr:pair .x|142|145)))) (let* ((.x|149 (let ((.x|161|164 .formals|139)) (begin (.check! (pair? .x|161|164) 0 .x|161|164) (car:pair .x|161|164)))) (.r|152 (lambda.r .proc|4)) (.refs|155 (references .r|152 .x|149))) (let () (if (= 1 (length .refs|155)) (null? (assignments .r|152 .x|149)) #f))) #f) #f) (let ((.x|167 (let ((.x|186|189 .formals|139)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) (.body|167 (lambda.body .proc|4))) (if (if (variable? .body|167) (eq? .x|167 (variable.name .body|167)) #f) (simplify (let ((.x|171|174 .actuals|139)) (begin (.check! (pair? .x|171|174) 0 .x|171|174) (car:pair .x|171|174))) .notepad|3) (if (if (conditional? .body|167) (let ((.b0|180 (if.test .body|167))) (begin (variable? .b0|180) (eq? .x|167 (variable.name .b0|180)))) #f) (begin (if.test-set! .body|167 (let ((.x|181|184 .actuals|139)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184)))) (simplify .body|167 .notepad|3)) (.return1-finish|4 .formals|139 .actuals|139)))) (.return1-finish|4 .formals|139 .actuals|139)))))) (set! .loop1|4 (lambda (.formals|190 .actuals|190 .processed-formals|190 .processed-actuals|190) (if (null? .formals|190) (begin (if (not (null? .actuals|190)) (pass2-error p2error:wna .exp|3) (unspecified)) (.return1|4 .processed-formals|190 .processed-actuals|190)) (if (symbol? .formals|190) (.return1|4 (cons .formals|190 .processed-formals|190) (cons (make-call-to-list .actuals|190) .processed-actuals|190)) (if (null? .actuals|190) (begin (pass2-error p2error:wna .exp|3) (.return1|4 .processed-formals|190 .processed-actuals|190)) (if (if (lambda? (let ((.x|196|199 .actuals|190)) (begin (.check! (pair? .x|196|199) 0 .x|196|199) (car:pair .x|196|199)))) (let ((.rinfo|203 (r-lookup (lambda.r .proc|4) (let ((.x|206|209 .formals|190)) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))))) (if (null? (r-entry.assignments .rinfo|203)) (= (length (r-entry.references .rinfo|203)) (length (r-entry.calls .rinfo|203))) #f)) #f) (begin (let ((.i|212 (let ((.x|213|216 .formals|190)) (begin (.check! (pair? .x|213|216) 0 .x|213|216) (car:pair .x|213|216)))) (.l|212 (let ((.x|217|220 .actuals|190)) (begin (.check! (pair? .x|217|220) 0 .x|217|220) (car:pair .x|217|220))))) (begin (notepad-nonescaping-add! .notepad|3 .l|212) (lambda.defs-set! .proc|4 (cons (make-definition .i|212 .l|212) (lambda.defs .proc|4))) (standardize-known-calls .l|212 (r-entry.calls (r-lookup (lambda.r .proc|4) .i|212))) (lambda.f-set! .proc|4 (union (lambda.f .proc|4) (free-variables .l|212))) (lambda.g-set! .proc|4 (union (lambda.g .proc|4) (lambda.g .l|212))))) (.loop1|4 (let ((.x|221|224 .formals|190)) (begin (.check! (pair? .x|221|224) 1 .x|221|224) (cdr:pair .x|221|224))) (let ((.x|225|228 .actuals|190)) (begin (.check! (pair? .x|225|228) 1 .x|225|228) (cdr:pair .x|225|228))) .processed-formals|190 .processed-actuals|190)) (if (if (constant? (let ((.x|231|234 .actuals|190)) (begin (.check! (pair? .x|231|234) 0 .x|231|234) (car:pair .x|231|234)))) (let* ((.x|238 (constant.value (let ((.x|252|255 .actuals|190)) (begin (.check! (pair? .x|252|255) 0 .x|252|255) (car:pair .x|252|255))))) (.temp|239|242 (boolean? .x|238))) (if .temp|239|242 .temp|239|242 (let ((.temp|243|246 (number? .x|238))) (if .temp|243|246 .temp|243|246 (let ((.temp|247|250 (symbol? .x|238))) (if .temp|247|250 .temp|247|250 (char? .x|238))))))) #f) (let* ((.i|258 (let ((.x|317|320 .formals|190)) (begin (.check! (pair? .x|317|320) 0 .x|317|320) (car:pair .x|317|320)))) (.rinfo|261 (r-lookup (lambda.r .proc|4) .i|258))) (let () (if (null? (r-entry.assignments .rinfo|261)) (begin (let () (let ((.loop|270|272|275 (unspecified))) (begin (set! .loop|270|272|275 (lambda (.y1|265|266|276) (if (null? .y1|265|266|276) (if #f #f (unspecified)) (begin (begin #t (let ((.ref|280 (let ((.x|285|288 .y1|265|266|276)) (begin (.check! (pair? .x|285|288) 0 .x|285|288) (car:pair .x|285|288))))) (variable-set! .ref|280 (let ((.x|281|284 .actuals|190)) (begin (.check! (pair? .x|281|284) 0 .x|281|284) (car:pair .x|281|284)))))) (.loop|270|272|275 (let ((.x|289|292 .y1|265|266|276)) (begin (.check! (pair? .x|289|292) 1 .x|289|292) (cdr:pair .x|289|292)))))))) (.loop|270|272|275 (r-entry.references .rinfo|261))))) (lambda.r-set! .proc|4 (remq .rinfo|261 (lambda.r .proc|4))) (lambda.f-set! .proc|4 (remq .i|258 (lambda.f .proc|4))) (lambda.g-set! .proc|4 (remq .i|258 (lambda.g .proc|4))) (.loop1|4 (let ((.x|293|296 .formals|190)) (begin (.check! (pair? .x|293|296) 1 .x|293|296) (cdr:pair .x|293|296))) (let ((.x|297|300 .actuals|190)) (begin (.check! (pair? .x|297|300) 1 .x|297|300) (cdr:pair .x|297|300))) .processed-formals|190 .processed-actuals|190)) (.loop1|4 (let ((.x|301|304 .formals|190)) (begin (.check! (pair? .x|301|304) 1 .x|301|304) (cdr:pair .x|301|304))) (let ((.x|305|308 .actuals|190)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308))) (cons (let ((.x|309|312 .formals|190)) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))) .processed-formals|190) (cons (let ((.x|313|316 .actuals|190)) (begin (.check! (pair? .x|313|316) 0 .x|313|316) (car:pair .x|313|316))) .processed-actuals|190))))) (begin (if (null? .actuals|190) (pass2-error p2error:wna .exp|3) (unspecified)) (.loop1|4 (let ((.x|322|325 .formals|190)) (begin (.check! (pair? .x|322|325) 1 .x|322|325) (cdr:pair .x|322|325))) (let ((.x|326|329 .actuals|190)) (begin (.check! (pair? .x|326|329) 1 .x|326|329) (cdr:pair .x|326|329))) (cons (let ((.x|330|333 .formals|190)) (begin (.check! (pair? .x|330|333) 0 .x|330|333) (car:pair .x|330|333))) .processed-formals|190) (cons (let ((.x|334|337 .actuals|190)) (begin (.check! (pair? .x|334|337) 0 .x|334|337) (car:pair .x|334|337))) .processed-actuals|190)))))))))) (set! .proc|4 (call.proc .exp|3)) (notepad-nonescaping-add! .notepad|3 .proc|4) (.loop1|4 (lambda.args .proc|4) (call.args .exp|3) '() '()))))) (.simplify-let|2 .exp|1 .notepad|1))))) 'simplify-let))
+(let () (begin (set! single-assignment-analysis (lambda (.l|1 .notepad|1) (let ((.single-assignment-analysis|2 0)) (begin (set! .single-assignment-analysis|2 (lambda (.l|3 .notepad|3) (let ((.formals|6 (lambda.args .l|3)) (.defs|6 (lambda.defs .l|3)) (.r|6 (lambda.r .l|3)) (.body|6 (lambda.body .l|3))) (let ((.finish!|7 (unspecified))) (begin (set! .finish!|7 (lambda (.exprs|8 .escapees|8) (begin (begin.exprs-set! .body|6 (append (reverse .escapees|8) .exprs|8)) (lambda.body-set! .l|3 (post-simplify-begin .body|6 '()))))) (if (begin? .body|6) (let ((.exprs|11 (begin.exprs .body|6)) (.escapees|11 '())) (let () (let ((.loop|14 (unspecified))) (begin (set! .loop|14 (lambda (.exprs|15 .escapees|15) (let ((.first|18 (let ((.x|43|46 .exprs|15)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) (if (if (assignment? .first|18) (not (null? (let ((.x|21|24 .exprs|15)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) #f) (let ((.i|27 (assignment.lhs .first|18)) (.rhs|27 (assignment.rhs .first|18))) (if (if (lambda? .rhs|27) (if (local? .r|6 .i|27) (= 1 (length (assignments .r|6 .i|27))) #f) #f) (if (= (length (calls .r|6 .i|27)) (length (references .r|6 .i|27))) (begin (notepad-nonescaping-add! .notepad|3 .rhs|27) (flag-as-ignored .i|27 .l|3) (lambda.defs-set! .l|3 (cons (make-definition .i|27 .rhs|27) (lambda.defs .l|3))) (assignments-set! .r|6 .i|27 '()) (standardize-known-calls .rhs|27 (r-entry.calls (r-lookup .r|6 .i|27))) (.loop|14 (let ((.x|31|34 .exprs|15)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) .escapees|15)) (.loop|14 (let ((.x|35|38 .exprs|15)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (cons (let ((.x|39|42 .exprs|15)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) .escapees|15))) (.finish!|7 .exprs|15 .escapees|15))) (.finish!|7 .exprs|15 .escapees|15))))) (.loop|14 .exprs|11 .escapees|11))))) (unspecified))))))) (.single-assignment-analysis|2 .l|1 .notepad|1))))) 'single-assignment-analysis))
+(let () (begin (set! standardize-known-calls (lambda (.l|1 .calls|1) (let ((.standardize-known-calls|2 0)) (begin (set! .standardize-known-calls|2 (lambda (.l|3 .calls|3) (let ((.formals|6 (lambda.args .l|3))) (if (not (list? .formals|6)) (let* ((.newformals|10 (make-null-terminated .formals|6)) (.n|13 (- (length .newformals|10) 1))) (let () (begin (lambda.args-set! .l|3 .newformals|10) (let () (let ((.loop|22|24|27 (unspecified))) (begin (set! .loop|22|24|27 (lambda (.y1|17|18|28) (if (null? .y1|17|18|28) (if #f #f (unspecified)) (begin (begin #t (let ((.call|32 (let ((.x|34|37 .y1|17|18|28)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (if (>= (length (call.args .call|32)) .n|13) (call.args-set! .call|32 (append (list-head (call.args .call|32) .n|13) (cons (make-call-to-list (list-tail (call.args .call|32) .n|13)) '()))) (pass2-error p2error:wna .call|32)))) (.loop|22|24|27 (let ((.x|38|41 .y1|17|18|28)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))))))) (.loop|22|24|27 .calls|3))))))) (let ((.n|45 (length .formals|6))) (let () (let ((.loop|51|53|56 (unspecified))) (begin (set! .loop|51|53|56 (lambda (.y1|46|47|57) (if (null? .y1|46|47|57) (if #f #f (unspecified)) (begin (begin #t (let ((.call|61 (let ((.x|62|65 .y1|46|47|57)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65))))) (if (not (= (length (call.args .call|61)) .n|45)) (pass2-error p2error:wna .call|61) (unspecified)))) (.loop|51|53|56 (let ((.x|66|69 .y1|46|47|57)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69)))))))) (.loop|51|53|56 .calls|3))))))))) (.standardize-known-calls|2 .l|1 .calls|1))))) 'standardize-known-calls))
+(let () (begin (set! single-assignment-elimination (lambda (.l|1 .notepad|1) (let ((.single-assignment-elimination|2 0)) (begin (set! .single-assignment-elimination|2 (lambda (.l|3 .notepad|3) (begin (if (begin? (lambda.body .l|3)) (let* ((.formals|6 (make-null-terminated (lambda.args .l|3))) (.defined|9 (let () (let ((.loop|190|193|196 (unspecified))) (begin (set! .loop|190|193|196 (lambda (.y1|185|186|197 .results|185|189|197) (if (null? .y1|185|186|197) (reverse .results|185|189|197) (begin #t (.loop|190|193|196 (let ((.x|201|204 .y1|185|186|197)) (begin (.check! (pair? .x|201|204) 1 .x|201|204) (cdr:pair .x|201|204))) (cons (def.lhs (let ((.x|205|208 .y1|185|186|197)) (begin (.check! (pair? .x|205|208) 0 .x|205|208) (car:pair .x|205|208)))) .results|185|189|197)))))) (.loop|190|193|196 (lambda.defs .l|3) '()))))) (.escaping|12 (intersection .formals|6 (notepad-captured-variables .notepad|3))) (.r|15 (lambda.r .l|3))) (let () (let ((.return-loop|19 (unspecified)) (.return|19 (unspecified)) (.loop|19 (unspecified))) (begin (set! .return-loop|19 (lambda (.assigns|20 .body|20) (if (null? .assigns|20) (let ((.l3|23 (call.proc .body|20))) (begin (lambda.body-set! .l|3 .body|20) (lambda-lifting .l3|23 .l|3))) (let* ((.i|26 (assignment.lhs (let ((.x|56|59 .assigns|20)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (.e|29 (assignment.rhs (let ((.x|52|55 .assigns|20)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (.l3|32 (call.proc .body|20)) (.f|35 (remq .i|26 (lambda.f .l3|32))) (.g|38 (remq .i|26 (lambda.g .l3|32)))) (let () (begin (flag-as-ignored .i|26 .l|3) (assignments-set! .r|15 .i|26 '()) (let ((.l2|44 (make-lambda (cons .i|26 '()) '() (cons (r-entry .r|15 .i|26) '()) .f|35 .g|38 (lambda.decls .l|3) (lambda.doc .l|3) .body|20))) (begin (lambda.r-set! .l|3 (remq (r-entry .r|15 .i|26) .r|15)) (lambda-lifting .l3|32 .l2|44) (.return-loop|19 (let ((.x|45|48 .assigns|20)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))) (make-call .l2|44 (cons .e|29 '()))))))))))) (set! .return|19 (lambda (.exprs|60 .assigns|60) (if (not (null? .assigns|60)) (let ((.i|63 (assignment.lhs (let ((.x|122|125 .assigns|60)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (.e|63 (assignment.rhs (let ((.x|126|129 .assigns|60)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129))))) (.defs|63 (lambda.defs .l|3)) (.f|63 (lambda.f .l|3)) (.g|63 (lambda.g .l|3))) (begin (flag-as-ignored .i|63 .l|3) (assignments-set! .r|15 .i|63 '()) (let ((.l2|66 (make-lambda (cons .i|63 '()) .defs|63 (cons (r-entry .r|15 .i|63) (let () (let ((.loop|102|105|108 (unspecified))) (begin (set! .loop|102|105|108 (lambda (.y1|97|98|109 .results|97|101|109) (if (null? .y1|97|98|109) (reverse .results|97|101|109) (begin #t (.loop|102|105|108 (let ((.x|113|116 .y1|97|98|109)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116))) (cons (let ((.def|117 (let ((.x|118|121 .y1|97|98|109)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121))))) (r-entry .r|15 (def.lhs .def|117))) .results|97|101|109)))))) (.loop|102|105|108 .defs|63 '()))))) .f|63 .g|63 (lambda.decls .l|3) (lambda.doc .l|3) (make-begin .exprs|60)))) (begin (lambda.defs-set! .l|3 '()) (let () (let ((.loop|72|74|77 (unspecified))) (begin (set! .loop|72|74|77 (lambda (.y1|67|68|78) (if (null? .y1|67|68|78) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|82 (let ((.x|83|86 .y1|67|68|78)) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86))))) (lambda.r-set! .l|3 (remq .entry|82 .r|15)))) (.loop|72|74|77 (let ((.x|87|90 .y1|67|68|78)) (begin (.check! (pair? .x|87|90) 1 .x|87|90) (cdr:pair .x|87|90)))))))) (.loop|72|74|77 (lambda.r .l2|66))))) (.return-loop|19 (let ((.x|91|94 .assigns|60)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (make-call .l2|66 (cons .e|63 '()))))))) (unspecified)))) (set! .loop|19 (lambda (.exprs|130 .assigns|130 .call-has-occurred?|130 .free|130) (if (null? (let ((.x|132|135 .exprs|130)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135)))) (.return|19 .exprs|130 .assigns|130) (if (assignment? (let ((.x|137|140 .exprs|130)) (begin (.check! (pair? .x|137|140) 0 .x|137|140) (car:pair .x|137|140)))) (let ((.i1|143 (assignment.lhs (let ((.x|176|179 .exprs|130)) (begin (.check! (pair? .x|176|179) 0 .x|176|179) (car:pair .x|176|179))))) (.e1|143 (assignment.rhs (let ((.x|180|183 .exprs|130)) (begin (.check! (pair? .x|180|183) 0 .x|180|183) (car:pair .x|180|183)))))) (if (if (memq .i1|143 .formals|6) (if (= (length (assignments .r|15 .i1|143)) 1) (not (if .call-has-occurred?|130 (memq .i1|143 .escaping|12) #f)) #f) #f) (let* ((.free-in-e1|151 (free-variables .e1|143)) (.newfree|154 (union .free-in-e1|151 .free|130))) (let () (if (let ((.temp|158|161 (memq .i1|143 .newfree|154))) (if .temp|158|161 .temp|158|161 (not (empty-set? (intersection .free-in-e1|151 .defined|9))))) (.return|19 .exprs|130 .assigns|130) (.loop|19 (let ((.x|163|166 .exprs|130)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))) (cons (let ((.x|167|170 .exprs|130)) (begin (.check! (pair? .x|167|170) 0 .x|167|170) (car:pair .x|167|170))) .assigns|130) (let ((.temp|171|174 .call-has-occurred?|130)) (if .temp|171|174 .temp|171|174 (might-return-twice? .e1|143))) .newfree|154)))) (.return|19 .exprs|130 .assigns|130))) (.return|19 .exprs|130 .assigns|130))))) (.loop|19 (begin.exprs (lambda.body .l|3)) '() #f '()))))) (unspecified)) .l|3))) (.single-assignment-elimination|2 .l|1 .notepad|1))))) 'single-assignment-elimination))
+(let () (begin (set! free-variables (lambda (.exp|1) (let ((.free-variables|2 0)) (begin (set! .free-variables|2 (lambda (.exp|3) (let ((.temp|4|7 (let ((.x|64|67 .exp|3)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))))) (if (memv .temp|4|7 '(quote)) '() (if (memv .temp|4|7 '(lambda)) (difference (lambda.f .exp|3) (make-null-terminated (lambda.args .exp|3))) (if (memv .temp|4|7 '(set!)) (union (cons (assignment.lhs .exp|3) '()) (.free-variables|2 (assignment.rhs .exp|3))) (if (memv .temp|4|7 '(if)) (union (.free-variables|2 (if.test .exp|3)) (.free-variables|2 (if.then .exp|3)) (.free-variables|2 (if.else .exp|3))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (cons (variable.name .exp|3) '()) (apply union (let () (let ((.loop|20|23|26 (unspecified))) (begin (set! .loop|20|23|26 (lambda (.y1|15|16|27 .results|15|19|27) (if (null? .y1|15|16|27) (reverse .results|15|19|27) (begin #t (.loop|20|23|26 (let ((.x|31|34 .y1|15|16|27)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) (cons (.free-variables|2 (let ((.x|35|38 .y1|15|16|27)) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38)))) .results|15|19|27)))))) (.loop|20|23|26 (begin.exprs .exp|3) '())))))) (apply union (let () (let ((.loop|45|48|51 (unspecified))) (begin (set! .loop|45|48|51 (lambda (.y1|40|41|52 .results|40|44|52) (if (null? .y1|40|41|52) (reverse .results|40|44|52) (begin #t (.loop|45|48|51 (let ((.x|56|59 .y1|40|41|52)) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) (cons (.free-variables|2 (let ((.x|60|63 .y1|40|41|52)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63)))) .results|40|44|52)))))) (.loop|45|48|51 .exp|3 '()))))))))))))) (.free-variables|2 .exp|1))))) 'free-variables))
+(let () (begin (set! might-return-twice? (lambda (.exp|1) (let ((.might-return-twice?|2 0)) (begin (set! .might-return-twice?|2 (lambda (.exp|3) (let ((.temp|4|7 (let ((.x|23|26 .exp|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (memv .temp|4|7 '(quote)) #f (if (memv .temp|4|7 '(lambda)) #f (if (memv .temp|4|7 '(set!)) (.might-return-twice?|2 (assignment.rhs .exp|3)) (if (memv .temp|4|7 '(if)) (let ((.temp|12|15 (.might-return-twice?|2 (if.test .exp|3)))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (.might-return-twice?|2 (if.then .exp|3)))) (if .temp|16|19 .temp|16|19 (.might-return-twice?|2 (if.else .exp|3)))))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) #f (some? .might-return-twice?|2 (begin.exprs .exp|3))) #t)))))))) (.might-return-twice?|2 .exp|1))))) 'might-return-twice?))
+(let () (begin (set! assignment-elimination (lambda (.l|1) (let ((.assignment-elimination|2 0)) (begin (set! .assignment-elimination|2 (lambda (.l|3) (let ((.r|6 (lambda.r .l|3))) (let ((.update-old-reference-info!|7 (unspecified)) (.new-reference-info|7 (unspecified)) (.cellify!|7 (unspecified)) (.generate-new-name|7 (unspecified)) (.eliminate|7 (unspecified)) (.loop|7 (unspecified))) (begin (set! .update-old-reference-info!|7 (lambda (.ref|8) (begin (references-set! .r|6 (variable.name .ref|8) (cons .ref|8 '())) (assignments-set! .r|6 (variable.name .ref|8) '()) (calls-set! .r|6 (variable.name .ref|8) '())))) (set! .new-reference-info|7 (lambda (.augmented-entry|10) (make-r-entry (let ((.x|11|14 .augmented-entry|10)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (r-entry.references (let ((.x|16|19 (let ((.x|20|23 .augmented-entry|10)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) '() '()))) (set! .cellify!|7 (lambda (.augmented-entry|24) (let ((.newname|27 (let ((.x|90|93 .augmented-entry|24)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (.entry|27 (let ((.x|95|98 (let ((.x|99|102 .augmented-entry|24)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (begin (let () (let ((.loop|29|31|34 (unspecified))) (begin (set! .loop|29|31|34 (lambda (.refs|35) (if (null? .refs|35) (if #f #f (unspecified)) (begin (begin #t (let* ((.reference|40 (let ((.x|51|54 .refs|35)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))) (.newref|43 (make-variable .newname|27))) (let () (begin (set-car! .reference|40 (make-variable name:cell-ref)) (set-car! (let ((.x|47|50 .reference|40)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))) .newref|43) (set-car! .refs|35 .newref|43))))) (.loop|29|31|34 (let ((.x|55|58 .refs|35)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58)))))))) (.loop|29|31|34 (r-entry.references .entry|27))))) (let () (let ((.loop|60|62|65 (unspecified))) (begin (set! .loop|60|62|65 (lambda (.assigns|66) (if (null? .assigns|66) (if #f #f (unspecified)) (begin (begin #t (let* ((.assignment|71 (let ((.x|82|85 .assigns|66)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) (.newref|74 (make-variable .newname|27))) (let () (begin (set-car! .assignment|71 (make-variable name:cell-set!)) (set-car! (let ((.x|78|81 .assignment|71)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) .newref|74) (r-entry.references-set! .entry|27 (cons .newref|74 (r-entry.references .entry|27))))))) (.loop|60|62|65 (let ((.x|86|89 .assigns|66)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89)))))))) (.loop|60|62|65 (r-entry.assignments .entry|27))))) (r-entry.assignments-set! .entry|27 '()))))) (set! .generate-new-name|7 (lambda (.name|103) (string->symbol (string-append cell-prefix (symbol->string .name|103))))) (set! .eliminate|7 (lambda (.assigned|104) (let* ((.oldnames|107 (let () (let ((.loop|554|557|560 (unspecified))) (begin (set! .loop|554|557|560 (lambda (.y1|549|550|561 .results|549|553|561) (if (null? .y1|549|550|561) (reverse .results|549|553|561) (begin #t (.loop|554|557|560 (let ((.x|565|568 .y1|549|550|561)) (begin (.check! (pair? .x|565|568) 1 .x|565|568) (cdr:pair .x|565|568))) (cons (r-entry.name (let ((.x|569|572 .y1|549|550|561)) (begin (.check! (pair? .x|569|572) 0 .x|569|572) (car:pair .x|569|572)))) .results|549|553|561)))))) (.loop|554|557|560 .assigned|104 '()))))) (.newnames|110 (let () (let ((.loop|530|533|536 (unspecified))) (begin (set! .loop|530|533|536 (lambda (.y1|525|526|537 .results|525|529|537) (if (null? .y1|525|526|537) (reverse .results|525|529|537) (begin #t (.loop|530|533|536 (let ((.x|541|544 .y1|525|526|537)) (begin (.check! (pair? .x|541|544) 1 .x|541|544) (cdr:pair .x|541|544))) (cons (.generate-new-name|7 (let ((.x|545|548 .y1|525|526|537)) (begin (.check! (pair? .x|545|548) 0 .x|545|548) (car:pair .x|545|548)))) .results|525|529|537)))))) (.loop|530|533|536 .oldnames|107 '())))))) (let () (let ((.augmented-entries|116 (let () (let ((.loop|444|448|451 (unspecified))) (begin (set! .loop|444|448|451 (lambda (.y1|438|440|452 .y1|438|439|452 .results|438|443|452) (if (let ((.temp|454|457 (null? .y1|438|440|452))) (if .temp|454|457 .temp|454|457 (null? .y1|438|439|452))) (reverse .results|438|443|452) (begin #t (.loop|444|448|451 (let ((.x|460|463 .y1|438|440|452)) (begin (.check! (pair? .x|460|463) 1 .x|460|463) (cdr:pair .x|460|463))) (let ((.x|464|467 .y1|438|439|452)) (begin (.check! (pair? .x|464|467) 1 .x|464|467) (cdr:pair .x|464|467))) (cons (let* ((.t1|468|471 (let ((.x|483|486 .y1|438|440|452)) (begin (.check! (pair? .x|483|486) 0 .x|483|486) (car:pair .x|483|486)))) (.t2|468|474 (cons (let ((.x|479|482 .y1|438|439|452)) (begin (.check! (pair? .x|479|482) 0 .x|479|482) (car:pair .x|479|482))) '()))) (let () (cons .t1|468|471 .t2|468|474))) .results|438|443|452)))))) (.loop|444|448|451 .newnames|110 .assigned|104 '()))))) (.renaming-alist|116 (let () (let ((.loop|493|497|500 (unspecified))) (begin (set! .loop|493|497|500 (lambda (.y1|487|489|501 .y1|487|488|501 .results|487|492|501) (if (let ((.temp|503|506 (null? .y1|487|489|501))) (if .temp|503|506 .temp|503|506 (null? .y1|487|488|501))) (reverse .results|487|492|501) (begin #t (.loop|493|497|500 (let ((.x|509|512 .y1|487|489|501)) (begin (.check! (pair? .x|509|512) 1 .x|509|512) (cdr:pair .x|509|512))) (let ((.x|513|516 .y1|487|488|501)) (begin (.check! (pair? .x|513|516) 1 .x|513|516) (cdr:pair .x|513|516))) (cons (cons (let ((.x|517|520 .y1|487|489|501)) (begin (.check! (pair? .x|517|520) 0 .x|517|520) (car:pair .x|517|520))) (let ((.x|521|524 .y1|487|488|501)) (begin (.check! (pair? .x|521|524) 0 .x|521|524) (car:pair .x|521|524)))) .results|487|492|501)))))) (.loop|493|497|500 .oldnames|107 .newnames|110 '()))))) (.defs|116 (lambda.defs .l|3))) (begin (let () (let ((.loop|122|124|127 (unspecified))) (begin (set! .loop|122|124|127 (lambda (.y1|117|118|128) (if (null? .y1|117|118|128) (if #f #f (unspecified)) (begin (begin #t (.cellify!|7 (let ((.x|132|135 .y1|117|118|128)) (begin (.check! (pair? .x|132|135) 0 .x|132|135) (car:pair .x|132|135))))) (.loop|122|124|127 (let ((.x|136|139 .y1|117|118|128)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139)))))))) (.loop|122|124|127 .augmented-entries|116)))) (let () (let ((.loop|145|147|150 (unspecified))) (begin (set! .loop|145|147|150 (lambda (.y1|140|141|151) (if (null? .y1|140|141|151) (if #f #f (unspecified)) (begin (begin #t (let ((.def|155 (let ((.x|181|184 .y1|140|141|151)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184))))) (let () (let ((.loop|157|159|162 (unspecified))) (begin (set! .loop|157|159|162 (lambda (.free|163) (if (null? .free|163) (if #f #f (unspecified)) (begin (begin #t (let ((.z|168 (assq (let ((.x|173|176 .free|163)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176))) .renaming-alist|116))) (if .z|168 (set-car! .free|163 (let ((.x|169|172 .z|168)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172)))) (unspecified)))) (.loop|157|159|162 (let ((.x|177|180 .free|163)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180)))))))) (.loop|157|159|162 (lambda.f (def.rhs .def|155)))))))) (.loop|145|147|150 (let ((.x|185|188 .y1|140|141|151)) (begin (.check! (pair? .x|185|188) 1 .x|185|188) (cdr:pair .x|185|188)))))))) (.loop|145|147|150 .defs|116)))) (let ((.newbody|191 (make-call (make-lambda (let () (let ((.loop|294|297|300 (unspecified))) (begin (set! .loop|294|297|300 (lambda (.y1|289|290|301 .results|289|293|301) (if (null? .y1|289|290|301) (reverse .results|289|293|301) (begin #t (.loop|294|297|300 (let ((.x|305|308 .y1|289|290|301)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308))) (cons (let ((.x|309|312 (let ((.x|313|316 .y1|289|290|301)) (begin (.check! (pair? .x|313|316) 0 .x|313|316) (car:pair .x|313|316))))) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))) .results|289|293|301)))))) (.loop|294|297|300 .augmented-entries|116 '())))) .defs|116 (union (let () (let ((.loop|322|325|328 (unspecified))) (begin (set! .loop|322|325|328 (lambda (.y1|317|318|329 .results|317|321|329) (if (null? .y1|317|318|329) (reverse .results|317|321|329) (begin #t (.loop|322|325|328 (let ((.x|333|336 .y1|317|318|329)) (begin (.check! (pair? .x|333|336) 1 .x|333|336) (cdr:pair .x|333|336))) (cons (let ((.def|337 (let ((.x|338|341 .y1|317|318|329)) (begin (.check! (pair? .x|338|341) 0 .x|338|341) (car:pair .x|338|341))))) (r-entry .r|6 (def.lhs .def|337))) .results|317|321|329)))))) (.loop|322|325|328 .defs|116 '())))) (let () (let ((.loop|347|350|353 (unspecified))) (begin (set! .loop|347|350|353 (lambda (.y1|342|343|354 .results|342|346|354) (if (null? .y1|342|343|354) (reverse .results|342|346|354) (begin #t (.loop|347|350|353 (let ((.x|358|361 .y1|342|343|354)) (begin (.check! (pair? .x|358|361) 1 .x|358|361) (cdr:pair .x|358|361))) (cons (.new-reference-info|7 (let ((.x|362|365 .y1|342|343|354)) (begin (.check! (pair? .x|362|365) 0 .x|362|365) (car:pair .x|362|365)))) .results|342|346|354)))))) (.loop|347|350|353 .augmented-entries|116 '()))))) (union (let* ((.t1|366|369 name:cell-ref) (.t2|366|372 (cons name:cell-set! '()))) (let () (cons .t1|366|369 .t2|366|372))) .newnames|110 (difference (lambda.f .l|3) .oldnames|107)) (union (let* ((.t1|377|380 name:cell-ref) (.t2|377|383 (cons name:cell-set! '()))) (let () (cons .t1|377|380 .t2|377|383))) .newnames|110 (difference (lambda.g .l|3) .oldnames|107)) (lambda.decls .l|3) (lambda.doc .l|3) (lambda.body .l|3)) (let () (let ((.loop|393|396|399 (unspecified))) (begin (set! .loop|393|396|399 (lambda (.y1|388|389|400 .results|388|392|400) (if (null? .y1|388|389|400) (reverse .results|388|392|400) (begin #t (.loop|393|396|399 (let ((.x|404|407 .y1|388|389|400)) (begin (.check! (pair? .x|404|407) 1 .x|404|407) (cdr:pair .x|404|407))) (cons (let ((.name|408 (let ((.x|410|413 .y1|388|389|400)) (begin (.check! (pair? .x|410|413) 0 .x|410|413) (car:pair .x|410|413))))) (make-call (make-variable name:make-cell) (cons (make-variable .name|408) '()))) .results|388|392|400)))))) (.loop|393|396|399 (let () (let ((.loop|419|422|425 (unspecified))) (begin (set! .loop|419|422|425 (lambda (.y1|414|415|426 .results|414|418|426) (if (null? .y1|414|415|426) (reverse .results|414|418|426) (begin #t (.loop|419|422|425 (let ((.x|430|433 .y1|414|415|426)) (begin (.check! (pair? .x|430|433) 1 .x|430|433) (cdr:pair .x|430|433))) (cons (r-entry.name (let ((.x|434|437 .y1|414|415|426)) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437)))) .results|414|418|426)))))) (.loop|419|422|425 .assigned|104 '())))) '()))))))) (begin (lambda.f-set! .l|3 (union (let* ((.t1|192|195 name:make-cell) (.t2|192|198 (let* ((.t1|202|205 name:cell-ref) (.t2|202|208 (cons name:cell-set! '()))) (let () (cons .t1|202|205 .t2|202|208))))) (let () (cons .t1|192|195 .t2|192|198))) (difference (lambda.f .l|3) (let () (let ((.loop|218|221|224 (unspecified))) (begin (set! .loop|218|221|224 (lambda (.y1|213|214|225 .results|213|217|225) (if (null? .y1|213|214|225) (reverse .results|213|217|225) (begin #t (.loop|218|221|224 (let ((.x|229|232 .y1|213|214|225)) (begin (.check! (pair? .x|229|232) 1 .x|229|232) (cdr:pair .x|229|232))) (cons (def.lhs (let ((.x|233|236 .y1|213|214|225)) (begin (.check! (pair? .x|233|236) 0 .x|233|236) (car:pair .x|233|236)))) .results|213|217|225)))))) (.loop|218|221|224 (lambda.defs .l|3) '()))))))) (lambda.defs-set! .l|3 '()) (let () (let ((.loop|242|244|247 (unspecified))) (begin (set! .loop|242|244|247 (lambda (.y1|237|238|248) (if (null? .y1|237|238|248) (if #f #f (unspecified)) (begin (begin #t (.update-old-reference-info!|7 (let ((.x|252|255 .y1|237|238|248)) (begin (.check! (pair? .x|252|255) 0 .x|252|255) (car:pair .x|252|255))))) (.loop|242|244|247 (let ((.x|256|259 .y1|237|238|248)) (begin (.check! (pair? .x|256|259) 1 .x|256|259) (cdr:pair .x|256|259)))))))) (.loop|242|244|247 (let () (let ((.loop|265|268|271 (unspecified))) (begin (set! .loop|265|268|271 (lambda (.y1|260|261|272 .results|260|264|272) (if (null? .y1|260|261|272) (reverse .results|260|264|272) (begin #t (.loop|265|268|271 (let ((.x|276|279 .y1|260|261|272)) (begin (.check! (pair? .x|276|279) 1 .x|276|279) (cdr:pair .x|276|279))) (cons (let* ((.arg|280 (let ((.x|285|288 .y1|260|261|272)) (begin (.check! (pair? .x|285|288) 0 .x|285|288) (car:pair .x|285|288)))) (.x|281|284 (call.args .arg|280))) (begin (.check! (pair? .x|281|284) 0 .x|281|284) (car:pair .x|281|284))) .results|260|264|272)))))) (.loop|265|268|271 (call.args .newbody|191) '())))))))) (lambda.body-set! .l|3 .newbody|191) (lambda-lifting (call.proc .newbody|191) .l|3))))))))) (set! .loop|7 (lambda (.entries|573 .assigned|573) (if (null? .entries|573) (if (not (null? .assigned|573)) (.eliminate|7 .assigned|573) (unspecified)) (if (not (null? (r-entry.assignments (let ((.x|576|579 .entries|573)) (begin (.check! (pair? .x|576|579) 0 .x|576|579) (car:pair .x|576|579)))))) (.loop|7 (let ((.x|580|583 .entries|573)) (begin (.check! (pair? .x|580|583) 1 .x|580|583) (cdr:pair .x|580|583))) (cons (let ((.x|584|587 .entries|573)) (begin (.check! (pair? .x|584|587) 0 .x|584|587) (car:pair .x|584|587))) .assigned|573)) (if (null? (r-entry.references (let ((.x|589|592 .entries|573)) (begin (.check! (pair? .x|589|592) 0 .x|589|592) (car:pair .x|589|592))))) (begin (flag-as-ignored (r-entry.name (let ((.x|593|596 .entries|573)) (begin (.check! (pair? .x|593|596) 0 .x|593|596) (car:pair .x|593|596)))) .l|3) (.loop|7 (let ((.x|597|600 .entries|573)) (begin (.check! (pair? .x|597|600) 1 .x|597|600) (cdr:pair .x|597|600))) .assigned|573)) (.loop|7 (let ((.x|602|605 .entries|573)) (begin (.check! (pair? .x|602|605) 1 .x|602|605) (cdr:pair .x|602|605))) .assigned|573)))))) (.loop|7 .r|6 '())))))) (.assignment-elimination|2 .l|1))))) 'assignment-elimination))
+(let () (begin (set! lambda-lifting (lambda (.l2|1 .l|1) (let ((.lambda-lifting|2 0)) (begin (set! .lambda-lifting|2 (lambda (.l2|3 .l|3) (let ((.lift|4 (unspecified))) (begin (set! .lift|4 (lambda (.l2|5 .l|5 .args-to-add|5) (let ((.formals|8 (make-null-terminated (lambda.args .l2|5)))) (begin (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.defs|17 .args-to-add|17) (if (null? .defs|17) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|22 (let ((.x|99|102 .defs|17)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.entry|25 (r-lookup (lambda.r .l2|5) (def.lhs .def|22))) (.calls|28 (r-entry.calls .entry|25)) (.added|31 (twobit-sort (lambda (.x|89 .y|89) (let ((.xx|92 (memq .x|89 .formals|8)) (.yy|92 (memq .y|89 .formals|8))) (if (if .xx|92 .yy|92 #f) (> (length .xx|92) (length .yy|92)) #t))) (let ((.x|95|98 .args-to-add|17)) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (.l3|34 (def.rhs .def|22))) (let () (begin (lambda.f-set! .l3|34 (union .added|31 (lambda.f .l3|34))) (lambda.args-set! .l3|34 (append .added|31 (lambda.args .l3|34))) (let () (let ((.loop|43|45|48 (unspecified))) (begin (set! .loop|43|45|48 (lambda (.y1|38|39|49) (if (null? .y1|38|39|49) (if #f #f (unspecified)) (begin (begin #t (let* ((.call|53 (let ((.x|81|84 .y1|38|39|49)) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84)))) (.newargs|56 (let () (let ((.loop|62|65|68 (unspecified))) (begin (set! .loop|62|65|68 (lambda (.y1|57|58|69 .results|57|61|69) (if (null? .y1|57|58|69) (reverse .results|57|61|69) (begin #t (.loop|62|65|68 (let ((.x|73|76 .y1|57|58|69)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))) (cons (make-variable (let ((.x|77|80 .y1|57|58|69)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80)))) .results|57|61|69)))))) (.loop|62|65|68 .added|31 '())))))) (call.args-set! .call|53 (append .newargs|56 (call.args .call|53))))) (.loop|43|45|48 (let ((.x|85|88 .y1|38|39|49)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88)))))))) (.loop|43|45|48 .calls|28)))) (lambda.r-set! .l2|5 (remq .entry|25 (lambda.r .l2|5))) (lambda.r-set! .l|5 (cons .entry|25 (lambda.r .l|5))))))) (.loop|10|13|16 (let ((.x|103|106 .defs|17)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))) (let ((.x|107|110 .args-to-add|17)) (begin (.check! (pair? .x|107|110) 1 .x|107|110) (cdr:pair .x|107|110)))))))) (.loop|10|13|16 (lambda.defs .l2|5) .args-to-add|5)))) (if (not (eq? .l2|5 .l|5)) (begin (lambda.defs-set! .l|5 (append (lambda.defs .l2|5) (lambda.defs .l|5))) (lambda.defs-set! .l2|5 '())) (unspecified)))))) (if .l|3 (if (not (null? (lambda.defs .l2|3))) (let ((.args-to-add|113 (compute-added-arguments (lambda.defs .l2|3) (make-null-terminated (lambda.args .l2|3))))) (if (policy:lift? .l2|3 .l|3 .args-to-add|113) (.lift|4 .l2|3 .l|3 .args-to-add|113) (unspecified))) (unspecified)) (unspecified)))))) (.lambda-lifting|2 .l2|1 .l|1))))) 'lambda-lifting))
+(let () (begin (set! compute-added-arguments (lambda (.defs|1 .formals|1) (let ((.compute-added-arguments|2 0)) (begin (set! .compute-added-arguments|2 (lambda (.defs|3 .formals|3) (let ((.procs|6 (let () (let ((.loop|159|162|165 (unspecified))) (begin (set! .loop|159|162|165 (lambda (.y1|154|155|166 .results|154|158|166) (if (null? .y1|154|155|166) (reverse .results|154|158|166) (begin #t (.loop|159|162|165 (let ((.x|170|173 .y1|154|155|166)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))) (cons (def.lhs (let ((.x|174|177 .y1|154|155|166)) (begin (.check! (pair? .x|174|177) 0 .x|174|177) (car:pair .x|174|177)))) .results|154|158|166)))))) (.loop|159|162|165 .defs|3 '()))))) (.freevars|6 (let () (let ((.loop|183|186|189 (unspecified))) (begin (set! .loop|183|186|189 (lambda (.y1|178|179|190 .results|178|182|190) (if (null? .y1|178|179|190) (reverse .results|178|182|190) (begin #t (.loop|183|186|189 (let ((.x|194|197 .y1|178|179|190)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) (cons (lambda.f (let ((.x|198|201 .y1|178|179|190)) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) .results|178|182|190)))))) (.loop|183|186|189 (let () (let ((.loop|207|210|213 (unspecified))) (begin (set! .loop|207|210|213 (lambda (.y1|202|203|214 .results|202|206|214) (if (null? .y1|202|203|214) (reverse .results|202|206|214) (begin #t (.loop|207|210|213 (let ((.x|218|221 .y1|202|203|214)) (begin (.check! (pair? .x|218|221) 1 .x|218|221) (cdr:pair .x|218|221))) (cons (def.rhs (let ((.x|222|225 .y1|202|203|214)) (begin (.check! (pair? .x|222|225) 0 .x|222|225) (car:pair .x|222|225)))) .results|202|206|214)))))) (.loop|207|210|213 .defs|3 '())))) '())))))) (let ((.callgraph|9 (let () (let ((.loop|84|87|90 (unspecified))) (begin (set! .loop|84|87|90 (lambda (.y1|79|80|91 .results|79|83|91) (if (null? .y1|79|80|91) (reverse .results|79|83|91) (begin #t (.loop|84|87|90 (let ((.x|95|98 .y1|79|80|91)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (cons (let ((.names|99 (let ((.x|125|128 .y1|79|80|91)) (begin (.check! (pair? .x|125|128) 0 .x|125|128) (car:pair .x|125|128))))) (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.name|120 (let ((.x|121|124 .y1|100|101|112)) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))))) (position .name|120 .procs|6)) .results|100|104|112)))))) (.loop|105|108|111 (intersection .names|99 .procs|6) '()))))) .results|79|83|91)))))) (.loop|84|87|90 .freevars|6 '()))))) (.added_0|9 (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (let ((.names|149 (let ((.x|150|153 .y1|129|130|141)) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))))) (intersection .names|149 .formals|3)) .results|129|133|141)))))) (.loop|134|137|140 .freevars|6 '())))))) (vector->list (compute-fixedpoint (make-vector (length .procs|6) '()) (list->vector (let () (let ((.loop|16|20|23 (unspecified))) (begin (set! .loop|16|20|23 (lambda (.y1|10|12|24 .y1|10|11|24 .results|10|15|24) (if (let ((.temp|26|29 (null? .y1|10|12|24))) (if .temp|26|29 .temp|26|29 (null? .y1|10|11|24))) (reverse .results|10|15|24) (begin #t (.loop|16|20|23 (let ((.x|32|35 .y1|10|12|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) (let ((.x|36|39 .y1|10|11|24)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.term0|40 (let ((.x|71|74 .y1|10|12|24)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74)))) (.indexes|40 (let ((.x|75|78 .y1|10|11|24)) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))))) (lambda (.approximations|41) (union .term0|40 (apply union (let () (let ((.loop|47|50|53 (unspecified))) (begin (set! .loop|47|50|53 (lambda (.y1|42|43|54 .results|42|46|54) (if (null? .y1|42|43|54) (reverse .results|42|46|54) (begin #t (.loop|47|50|53 (let ((.x|58|61 .y1|42|43|54)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) (cons (let ((.i|62 (let ((.x|67|70 .y1|42|43|54)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (let ((.v|63|66 .approximations|41) (.i|63|66 .i|62)) (begin (.check! (fixnum? .i|63|66) 40 .v|63|66 .i|63|66) (.check! (vector? .v|63|66) 40 .v|63|66 .i|63|66) (.check! (<:fix:fix .i|63|66 (vector-length:vec .v|63|66)) 40 .v|63|66 .i|63|66) (.check! (>=:fix:fix .i|63|66 0) 40 .v|63|66 .i|63|66) (vector-ref:trusted .v|63|66 .i|63|66)))) .results|42|46|54)))))) (.loop|47|50|53 .indexes|40 '())))))))) .results|10|15|24)))))) (.loop|16|20|23 .added_0|9 .callgraph|9 '()))))) set-equal?)))))) (.compute-added-arguments|2 .defs|1 .formals|1))))) 'compute-added-arguments))
+(let () (begin (set! position (lambda (.x|1 .l|1) (let ((.position|2 0)) (begin (set! .position|2 (lambda (.x|3 .l|3) (if (eq? .x|3 (let ((.x|5|8 .l|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))) 0 (+ 1 (.position|2 .x|3 (let ((.x|10|13 .l|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))))))) (.position|2 .x|1 .l|1))))) 'position))
+(let () (begin (set! compute-fixedpoint (lambda (.v|1 .functions|1 .equiv?|1) (let ((.compute-fixedpoint|2 0)) (begin (set! .compute-fixedpoint|2 (lambda (.v|3 .functions|3 .equiv?|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.i|5 .flag|5) (if (< .i|5 0) (if .flag|5 (.loop|4 (- (let ((.v|7|10 .v|3)) (begin (.check! (vector? .v|7|10) 42 .v|7|10) (vector-length:vec .v|7|10))) 1) #f) .v|3) (let ((.next_i|13 ((let ((.v|22|25 .functions|3) (.i|22|25 .i|5)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25))) .v|3))) (if (.equiv?|3 .next_i|13 (let ((.v|14|17 .v|3) (.i|14|17 .i|5)) (begin (.check! (fixnum? .i|14|17) 40 .v|14|17 .i|14|17) (.check! (vector? .v|14|17) 40 .v|14|17 .i|14|17) (.check! (<:fix:fix .i|14|17 (vector-length:vec .v|14|17)) 40 .v|14|17 .i|14|17) (.check! (>=:fix:fix .i|14|17 0) 40 .v|14|17 .i|14|17) (vector-ref:trusted .v|14|17 .i|14|17)))) (.loop|4 (- .i|5 1) .flag|5) (begin (let ((.v|18|21 .v|3) (.i|18|21 .i|5) (.x|18|21 .next_i|13)) (begin (.check! (fixnum? .i|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (vector? .v|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (<:fix:fix .i|18|21 (vector-length:vec .v|18|21)) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (>=:fix:fix .i|18|21 0) 41 .v|18|21 .i|18|21 .x|18|21) (vector-set!:trusted .v|18|21 .i|18|21 .x|18|21))) (.loop|4 (- .i|5 1) #t))))))) (.loop|4 (- (let ((.v|26|29 .v|3)) (begin (.check! (vector? .v|26|29) 42 .v|26|29) (vector-length:vec .v|26|29))) 1) #f))))) (.compute-fixedpoint|2 .v|1 .functions|1 .equiv?|1))))) 'compute-fixedpoint))
+(let () (begin (set! policy:lift? (lambda (.l2|1 .l|1 .args-to-add|1) (let ((.policy:lift?|2 0)) (begin (set! .policy:lift?|2 (lambda (.l2|3 .l|3 .args-to-add|3) (if (lambda-optimizations) (if (not (lambda? (lambda.body .l2|3))) (every? (lambda (.addlist|7) (< (length .addlist|7) 6)) .args-to-add|3) #f) #f))) (.policy:lift?|2 .l2|1 .l|1 .args-to-add|1))))) 'policy:lift?))
+(let () (begin (set! simplify-conditional (lambda (.exp|1 .notepad|1) (let ((.simplify-conditional|2 0)) (begin (set! .simplify-conditional|2 (lambda (.exp|3 .notepad|3) (let ((.coercion-to-boolean?|4 (unspecified))) (begin (set! .coercion-to-boolean?|4 (lambda (.exp|5) (if (conditional? .exp|5) (let ((.e1|10 (if.then .exp|5)) (.e2|10 (if.else .exp|5))) (if (constant? .e1|10) (if (eq? #t (constant.value .e1|10)) (if (constant? .e2|10) (eq? #f (constant.value .e2|10)) #f) #f) #f)) #f))) (if (not (control-optimization)) (begin (if.test-set! .exp|3 (simplify (if.test .exp|3) .notepad|3)) (if.then-set! .exp|3 (simplify (if.then .exp|3) .notepad|3)) (if.else-set! .exp|3 (simplify (if.else .exp|3) .notepad|3)) .exp|3) (let ((.test|17 (if.test .exp|3))) (let () (if (if (call? .test|17) (if (lambda? (call.proc .test|17)) (let* ((.l|26 (call.proc .test|17)) (.body|29 (lambda.body .l|26))) (let () (if (conditional? .body|29) (let ((.r|37 (lambda.r .l|26)) (.b0|37 (if.test .body|29)) (.b1|37 (if.then .body|29))) (if (variable? .b0|37) (if (variable? .b1|37) (let ((.x|43 (variable.name .b0|37))) (if (eq? .x|43 (variable.name .b1|37)) (if (local? .r|37 .x|43) (if (= 1 (length .r|37)) (= 1 (length (call.args .test|17))) #f) #f) #f)) #f) #f)) #f))) #f) #f) (let* ((.l|50 (call.proc .test|17)) (.r|53 (lambda.r .l|50)) (.body|56 (lambda.body .l|50)) (.ref|59 (if.then .body|56)) (.x|62 (variable.name .ref|59)) (.entry|65 (r-entry .r|53 .x|62))) (let () (begin (if.then-set! .body|56 (make-constant #t)) (if.else-set! .body|56 (make-conditional (if.else .body|56) (make-constant #t) (make-constant #f))) (r-entry.references-set! .entry|65 (remq .ref|59 (r-entry.references .entry|65))) (.simplify-conditional|2 .exp|3 .notepad|3)))) (let ((.test|71 (simplify (if.test .exp|3) .notepad|3))) (let () (let ((.loop|74 (unspecified))) (begin (set! .loop|74 (lambda (.test|75) (begin (if.test-set! .exp|3 .test|75) (if (constant? .test|75) (simplify (if (constant.value .test|75) (if.then .exp|3) (if.else .exp|3)) .notepad|3) (if (if (conditional? .test|75) (if (constant? (if.then .test|75)) (constant? (if.else .test|75)) #f) #f) (if (if (constant.value (if.then .test|75)) (constant.value (if.else .test|75)) #f) (post-simplify-begin (make-begin (let* ((.t1|84|87 (if.test .test|75)) (.t2|84|90 (cons (simplify (if.then .exp|3) .notepad|3) '()))) (let () (cons .t1|84|87 .t2|84|90)))) .notepad|3) (if (if (not (constant.value (if.then .test|75))) (not (constant.value (if.else .test|75))) #f) (post-simplify-begin (make-begin (let* ((.t1|98|101 (if.test .test|75)) (.t2|98|104 (cons (simplify (if.else .exp|3) .notepad|3) '()))) (let () (cons .t1|98|101 .t2|98|104)))) .notepad|3) (begin (if (not (constant.value (if.then .test|75))) (let ((.temp|112 (if.then .exp|3))) (begin (if.then-set! .exp|3 (if.else .exp|3)) (if.else-set! .exp|3 .temp|112))) (unspecified)) (if.test-set! .exp|3 (if.test .test|75)) (.loop|74 (if.test .exp|3))))) (if (if (conditional? .test|75) (let ((.temp|116|119 (.coercion-to-boolean?|4 (if.then .test|75)))) (if .temp|116|119 .temp|116|119 (.coercion-to-boolean?|4 (if.else .test|75)))) #f) (begin (if (.coercion-to-boolean?|4 (if.then .test|75)) (if.then-set! .test|75 (if.test (if.then .test|75))) (if.else-set! .test|75 (if.test (if.else .test|75)))) (.loop|74 .test|75)) (let ((.temp|121|124 (if (conditional? .test|75) (if (variable? (if.test .test|75)) (let* ((.x|168 (variable.name (if.test .test|75))) (.temp|169|172 (if (variable? (if.then .test|75)) (if (eq? .x|168 (variable.name (if.then .test|75))) 1 #f) #f))) (if .temp|169|172 .temp|169|172 (if (variable? (if.else .test|75)) (if (eq? .x|168 (variable.name (if.else .test|75))) 2 #f) #f))) #f) #f))) (if .temp|121|124 (let ((.n|125 .temp|121|124)) (begin (let ((.temp|126|129 .n|125)) (if (memv .temp|126|129 '(1)) (if.then-set! .test|75 (make-constant #t)) (if (memv .temp|126|129 '(2)) (if.else-set! .test|75 (make-constant #f)) (unspecified)))) (.loop|74 .test|75))) (if (begin? .test|75) (let ((.exprs|135 (reverse (begin.exprs .test|75)))) (begin (if.test-set! .exp|3 (let ((.x|136|139 .exprs|135)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139)))) (post-simplify-begin (make-begin (reverse (cons (.loop|74 (let ((.x|140|143 .exprs|135)) (begin (.check! (pair? .x|140|143) 0 .x|140|143) (car:pair .x|140|143)))) (let ((.x|144|147 .exprs|135)) (begin (.check! (pair? .x|144|147) 1 .x|144|147) (cdr:pair .x|144|147)))))) .notepad|3))) (if (if (call? .test|75) (if (variable? (call.proc .test|75)) (if (eq? (variable.name (call.proc .test|75)) name:not) (if (integrable? name:not) (if (integrate-usual-procedures) (= (length (call.args .test|75)) 1) #f) #f) #f) #f) #f) (begin (let ((.temp|157 (if.then .exp|3))) (begin (if.then-set! .exp|3 (if.else .exp|3)) (if.else-set! .exp|3 .temp|157))) (.loop|74 (let ((.x|158|161 (call.args .test|75))) (begin (.check! (pair? .x|158|161) 0 .x|158|161) (car:pair .x|158|161))))) (simplify-case .exp|3 .notepad|3))))))))))) (.loop|74 .test|71))))))))))))) (.simplify-conditional|2 .exp|1 .notepad|1))))) 'simplify-conditional))
+(let () (begin (set! simplify-case (lambda (.exp|1 .notepad|1) (let ((.simplify-case|2 0)) (begin (set! .simplify-case|2 (lambda (.exp|3 .notepad|3) (let ((.e0|6 (if.test .exp|3))) (if (if (call? .e0|6) (if (variable? (call.proc .e0|6)) (if (let* ((.name|12 (variable.name (call.proc .e0|6))) (.temp|13|16 (eq? .name|12 name:eq?))) (if .temp|13|16 .temp|13|16 (let ((.temp|17|20 (eq? .name|12 name:eqv?))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (eq? .name|12 name:memq))) (if .temp|21|24 .temp|21|24 (eq? .name|12 name:memv))))))) (if (integrate-usual-procedures) (if (= (length (call.args .e0|6)) 2) (if (variable? (let ((.x|29|32 (call.args .e0|6))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) (constant? (let ((.x|35|38 (let ((.x|39|42 (call.args .e0|6))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38)))) #f) #f) #f) #f) #f) #f) (simplify-case-clauses (variable.name (let ((.x|43|46 (call.args .e0|6))) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) .exp|3 .notepad|3) (begin (if.then-set! .exp|3 (simplify (if.then .exp|3) .notepad|3)) (if.else-set! .exp|3 (simplify (if.else .exp|3) .notepad|3)) .exp|3))))) (.simplify-case|2 .exp|1 .notepad|1))))) 'simplify-case))
+(let () (begin (set! simplify-case-clauses (lambda (.var0|1 .e|1 .notepad|1) (let ((.simplify-case-clauses|2 0)) (begin (set! .simplify-case-clauses|2 (lambda (.var0|3 .e|3 .notepad|3) (let ((.analyze|4 (unspecified)) (.finish|4 (unspecified)) (.remove-duplicates|4 (unspecified)) (.collect-clauses|4 (unspecified)) (.notepad2|4 (unspecified))) (begin (set! .analyze|4 (lambda (.default|5 .fix|5 .chr|5 .sym|5 .other|5 .constants|5) (begin (notepad-var-add! .notepad2|4 .var0|3) (let () (let ((.loop|11|13|16 (unspecified))) (begin (set! .loop|11|13|16 (lambda (.y1|6|7|17) (if (null? .y1|6|7|17) (if #f #f (unspecified)) (begin (begin #t (let ((.l|21 (let ((.x|22|25 .y1|6|7|17)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (notepad-lambda-add! .notepad|3 .l|21))) (.loop|11|13|16 (let ((.x|26|29 .y1|6|7|17)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))) (.loop|11|13|16 (notepad.lambdas .notepad2|4))))) (let () (let ((.loop|35|37|40 (unspecified))) (begin (set! .loop|35|37|40 (lambda (.y1|30|31|41) (if (null? .y1|30|31|41) (if #f #f (unspecified)) (begin (begin #t (let ((.l|45 (let ((.x|46|49 .y1|30|31|41)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))))) (notepad-nonescaping-add! .notepad|3 .l|45))) (.loop|35|37|40 (let ((.x|50|53 .y1|30|31|41)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53)))))))) (.loop|35|37|40 (notepad.nonescaping .notepad2|4))))) (let () (let ((.loop|59|61|64 (unspecified))) (begin (set! .loop|59|61|64 (lambda (.y1|54|55|65) (if (null? .y1|54|55|65) (if #f #f (unspecified)) (begin (begin #t (let ((.var|69 (let ((.x|70|73 .y1|54|55|65)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (notepad-var-add! .notepad|3 .var|69))) (.loop|59|61|64 (let ((.x|74|77 .y1|54|55|65)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77)))))))) (.loop|59|61|64 (append (let* ((.t1|78|81 name:fixnum?) (.t2|78|84 (let* ((.t1|88|91 name:char?) (.t2|88|94 (let* ((.t1|98|101 name:symbol?) (.t2|98|104 (let* ((.t1|108|111 name:fx<) (.t2|108|114 (let* ((.t1|118|121 name:fx-) (.t2|118|124 (let* ((.t1|128|131 name:char->integer) (.t2|128|134 (cons name:vector-ref '()))) (let () (cons .t1|128|131 .t2|128|134))))) (let () (cons .t1|118|121 .t2|118|124))))) (let () (cons .t1|108|111 .t2|108|114))))) (let () (cons .t1|98|101 .t2|98|104))))) (let () (cons .t1|88|91 .t2|88|94))))) (let () (cons .t1|78|81 .t2|78|84))) (notepad.vars .notepad2|4)))))) (analyze-clauses (notepad.vars .notepad2|4) .var0|3 .default|5 (reverse .fix|5) (reverse .chr|5) (reverse .sym|5) (reverse .other|5) .constants|5)))) (set! .finish|4 (lambda (.e|139 .fix|139 .chr|139 .sym|139 .other|139 .constants|139) (begin (if.else-set! .e|139 (simplify (if.else .e|139) .notepad2|4)) (.analyze|4 .e|139 .fix|139 .chr|139 .sym|139 .other|139 .constants|139)))) (set! .remove-duplicates|4 (lambda (.data|140 .set|140) (let ((.originals|143 .data|140) (.data|143 '()) (.set|143 .set|140)) (let () (let ((.loop|146 (unspecified))) (begin (set! .loop|146 (lambda (.originals|147 .data|147 .set|147) (if (null? .originals|147) (values .data|147 .set|147) (let ((.x|150 (let ((.x|152|155 .originals|147)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155)))) (.originals|150 (let ((.x|156|159 .originals|147)) (begin (.check! (pair? .x|156|159) 1 .x|156|159) (cdr:pair .x|156|159))))) (if (memv .x|150 .set|147) (.loop|146 .originals|150 .data|147 .set|147) (.loop|146 .originals|150 (cons .x|150 .data|147) (cons .x|150 .set|147))))))) (.loop|146 .originals|143 .data|143 .set|143))))))) (set! .collect-clauses|4 (lambda (.e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (if (not (conditional? .e|160)) (.analyze|4 (simplify .e|160 .notepad2|4) .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.test|163 (simplify (if.test .e|160) .notepad2|4)) (.code|163 (simplify (if.then .e|160) .notepad2|4))) (begin (if.test-set! .e|160 .test|163) (if.then-set! .e|160 .code|163) (if (not (call? .test|163)) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.proc|166 (call.proc .test|163)) (.args|166 (call.args .test|163))) (if (not (if (variable? .proc|166) (if (let* ((.name|171 (variable.name .proc|166)) (.temp|172|175 (eq? .name|171 name:eq?))) (if .temp|172|175 .temp|172|175 (let ((.temp|176|179 (eq? .name|171 name:eqv?))) (if .temp|176|179 .temp|176|179 (let ((.temp|180|183 (eq? .name|171 name:memq))) (if .temp|180|183 .temp|180|183 (eq? .name|171 name:memv))))))) (if (= (length .args|166) 2) (if (variable? (let ((.x|187|190 .args|166)) (begin (.check! (pair? .x|187|190) 0 .x|187|190) (car:pair .x|187|190)))) (if (eq? (variable.name (let ((.x|192|195 .args|166)) (begin (.check! (pair? .x|192|195) 0 .x|192|195) (car:pair .x|192|195)))) .var0|3) (constant? (let ((.x|198|201 (let ((.x|202|205 .args|166)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) #f) #f) #f) #f) #f)) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.pred|208 (variable.name .proc|166)) (.datum|208 (constant.value (let ((.x|257|260 (let ((.x|261|264 .args|166)) (begin (.check! (pair? .x|261|264) 1 .x|261|264) (cdr:pair .x|261|264))))) (begin (.check! (pair? .x|257|260) 0 .x|257|260) (car:pair .x|257|260)))))) (if (let ((.temp|209|212 (if (let ((.temp|224|227 (eq? .pred|208 name:memv))) (if .temp|224|227 .temp|224|227 (eq? .pred|208 name:memq))) (not (list? .datum|208)) #f))) (if .temp|209|212 .temp|209|212 (let ((.temp|213|216 (if (eq? .pred|208 name:eq?) (not (eqv-is-ok? .datum|208)) #f))) (if .temp|213|216 .temp|213|216 (if (eq? .pred|208 name:memq) (not (every? (lambda (.datum|220) (eqv-is-ok? .datum|220)) .datum|208)) #f))))) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (call-with-values (lambda () (.remove-duplicates|4 (if (let ((.temp|231|234 (eq? .pred|208 name:eqv?))) (if .temp|231|234 .temp|231|234 (eq? .pred|208 name:eq?))) (cons .datum|208 '()) .datum|208) .constants|160)) (lambda (.data|237 .constants|237) (let ((.clause|240 (let* ((.t1|245|248 .data|237) (.t2|245|251 (cons .code|163 '()))) (let () (cons .t1|245|248 .t2|245|251)))) (.e2|240 (if.else .e|160))) (if (every? smallint? .data|237) (.collect-clauses|4 .e2|240 (cons .clause|240 .fix|160) .chr|160 .sym|160 .other|160 .constants|237) (if (every? char? .data|237) (.collect-clauses|4 .e2|240 .fix|160 (cons .clause|240 .chr|160) .sym|160 .other|160 .constants|237) (if (every? symbol? .data|237) (.collect-clauses|4 .e2|240 .fix|160 .chr|160 (cons .clause|240 .sym|160) .other|160 .constants|237) (.collect-clauses|4 .e2|240 .fix|160 .chr|160 .sym|160 (cons .clause|240 .other|160) .constants|237))))))))))))))))) (set! .notepad2|4 (make-notepad (notepad.parent .notepad|3))) (.collect-clauses|4 .e|3 '() '() '() '() '()))))) (.simplify-case-clauses|2 .var0|1 .e|1 .notepad|1))))) 'simplify-case-clauses))
+(let () (begin (set! eqv-is-ok? (lambda (.x|1) (let ((.eqv-is-ok?|2 0)) (begin (set! .eqv-is-ok?|2 (lambda (.x|3) (let ((.temp|4|7 (smallint? .x|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (char? .x|3))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (symbol? .x|3))) (if .temp|12|15 .temp|12|15 (boolean? .x|3))))))))) (.eqv-is-ok?|2 .x|1))))) 'eqv-is-ok?))
+(let () (begin (set! eq-is-ok? (lambda (.x|1) (let ((.eq-is-ok?|2 0)) (begin (set! .eq-is-ok?|2 (lambda (.x|3) (eqv-is-ok? .x|3))) (.eq-is-ok?|2 .x|1))))) 'eq-is-ok?))
+(let () (begin (set! analyze-clauses (lambda (.f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1) (let ((.analyze-clauses|2 0)) (begin (set! .analyze-clauses|2 (lambda (.f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3) (if (let ((.temp|5|8 (if (null? .fix|3) (null? .chr|3) #f))) (if .temp|5|8 .temp|5|8 (< (length .constants|3) 12))) (implement-clauses-by-sequential-search .var0|3 .default|3 (append .fix|3 .chr|3 .sym|3 .other|3)) (implement-clauses .f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3)))) (.analyze-clauses|2 .f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1))))) 'analyze-clauses))
+(let () (begin (set! implement-clauses (lambda (.f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1) (let ((.implement-clauses|2 0)) (begin (set! .implement-clauses|2 (lambda (.f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3) (let* ((.name:n|6 ((make-rename-procedure) 'n)) (.entry|9 (make-r-entry .name:n|6 '() '() '())) (.f|12 (union (make-set (cons .name:n|6 '())) .f|3)) (.l|15 (make-lambda (cons .name:n|6 '()) '() '() .f|12 '() '() #f (implement-case-dispatch .name:n|6 (cons .default|3 (let () (let ((.loop|138|141|144 (unspecified))) (begin (set! .loop|138|141|144 (lambda (.y1|133|134|145 .results|133|137|145) (if (null? .y1|133|134|145) (reverse .results|133|137|145) (begin #t (.loop|138|141|144 (let ((.x|149|152 .y1|133|134|145)) (begin (.check! (pair? .x|149|152) 1 .x|149|152) (cdr:pair .x|149|152))) (cons (let ((.x|154|157 (let ((.x|158|161 (let ((.x|162|165 .y1|133|134|145)) (begin (.check! (pair? .x|162|165) 0 .x|162|165) (car:pair .x|162|165))))) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))))) (begin (.check! (pair? .x|154|157) 0 .x|154|157) (car:pair .x|154|157))) .results|133|137|145)))))) (.loop|138|141|144 (append .other|3 .fix|3 .chr|3 .sym|3) '()))))))))) (let () (make-call .l|15 (cons (implement-dispatch 0 .var0|3 (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.y1|20|21|32 .results|20|24|32) (if (null? .y1|20|21|32) (reverse .results|20|24|32) (begin #t (.loop|25|28|31 (let ((.x|36|39 .y1|20|21|32)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.x|40|43 (let ((.x|44|47 .y1|20|21|32)) (begin (.check! (pair? .x|44|47) 0 .x|44|47) (car:pair .x|44|47))))) (begin (.check! (pair? .x|40|43) 0 .x|40|43) (car:pair .x|40|43))) .results|20|24|32)))))) (.loop|25|28|31 .other|3 '())))) (let () (let ((.loop|53|56|59 (unspecified))) (begin (set! .loop|53|56|59 (lambda (.y1|48|49|60 .results|48|52|60) (if (null? .y1|48|49|60) (reverse .results|48|52|60) (begin #t (.loop|53|56|59 (let ((.x|64|67 .y1|48|49|60)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67))) (cons (let ((.x|68|71 (let ((.x|72|75 .y1|48|49|60)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75))))) (begin (.check! (pair? .x|68|71) 0 .x|68|71) (car:pair .x|68|71))) .results|48|52|60)))))) (.loop|53|56|59 .fix|3 '())))) (let () (let ((.loop|81|84|87 (unspecified))) (begin (set! .loop|81|84|87 (lambda (.y1|76|77|88 .results|76|80|88) (if (null? .y1|76|77|88) (reverse .results|76|80|88) (begin #t (.loop|81|84|87 (let ((.x|92|95 .y1|76|77|88)) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))) (cons (let ((.x|96|99 (let ((.x|100|103 .y1|76|77|88)) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103))))) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99))) .results|76|80|88)))))) (.loop|81|84|87 .chr|3 '())))) (let () (let ((.loop|109|112|115 (unspecified))) (begin (set! .loop|109|112|115 (lambda (.y1|104|105|116 .results|104|108|116) (if (null? .y1|104|105|116) (reverse .results|104|108|116) (begin #t (.loop|109|112|115 (let ((.x|120|123 .y1|104|105|116)) (begin (.check! (pair? .x|120|123) 1 .x|120|123) (cdr:pair .x|120|123))) (cons (let ((.x|124|127 (let ((.x|128|131 .y1|104|105|116)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))))) (begin (.check! (pair? .x|124|127) 0 .x|124|127) (car:pair .x|124|127))) .results|104|108|116)))))) (.loop|109|112|115 .sym|3 '()))))) '())))))) (.implement-clauses|2 .f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1))))) 'implement-clauses))
+(let () (begin (set! implement-case-dispatch (lambda (.var0|1 .exprs|1) (let ((.implement-case-dispatch|2 0)) (begin (set! .implement-case-dispatch|2 (lambda (.var0|3 .exprs|3) (implement-intervals .var0|3 (let () (let ((.loop|10|14|17 (unspecified))) (begin (set! .loop|10|14|17 (lambda (.y1|4|6|18 .y1|4|5|18 .results|4|9|18) (if (let ((.temp|20|23 (null? .y1|4|6|18))) (if .temp|20|23 .temp|20|23 (null? .y1|4|5|18))) (reverse .results|4|9|18) (begin #t (.loop|10|14|17 (let ((.x|26|29 .y1|4|6|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (let ((.x|30|33 .y1|4|5|18)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) (cons (let ((.n|34 (let ((.x|56|59 .y1|4|6|18)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59)))) (.code|34 (let ((.x|60|63 .y1|4|5|18)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63))))) (let* ((.t1|35|38 .n|34) (.t2|35|41 (let* ((.t1|45|48 (+ .n|34 1)) (.t2|45|51 (cons .code|34 '()))) (let () (cons .t1|45|48 .t2|45|51))))) (let () (cons .t1|35|38 .t2|35|41)))) .results|4|9|18)))))) (.loop|10|14|17 (iota (length .exprs|3)) .exprs|3 '()))))))) (.implement-case-dispatch|2 .var0|1 .exprs|1))))) 'implement-case-dispatch))
+(let () (begin (set! implement-dispatch (lambda (.prior|1 .var0|1 .other|1 .fix|1 .chr|1 .sym|1) (let ((.implement-dispatch|2 0)) (begin (set! .implement-dispatch|2 (lambda (.prior|3 .var0|3 .other|3 .fix|3 .chr|3 .sym|3) (if (not (null? .other|3)) (implement-dispatch-other (.implement-dispatch|2 (+ .prior|3 (length .other|3)) .var0|3 .fix|3 .chr|3 .sym|3 '()) .prior|3 var .other|3) (if (not (null? .fix|3)) (make-conditional (make-call (make-variable name:fixnum?) (cons (make-variable .var0|3) '())) (implement-dispatch-fixnum .prior|3 .var0|3 .fix|3) (.implement-dispatch|2 (+ .prior|3 (length .fix|3)) .var0|3 '() .chr|3 .sym|3 .other|3)) (if (not (null? .chr|3)) (make-conditional (make-call (make-variable name:char?) (cons (make-variable .var0|3) '())) (implement-dispatch-char .prior|3 .var0|3 .chr|3) (.implement-dispatch|2 (+ .prior|3 (length .chr|3)) .var0|3 .fix|3 '() .sym|3 .other|3)) (if (not (null? .sym|3)) (make-conditional (make-call (make-variable name:symbol?) (cons (make-variable .var0|3) '())) (implement-dispatch-symbol .prior|3 .var0|3 .sym|3) (.implement-dispatch|2 (+ .prior|3 (length .sym|3)) .var0|3 .fix|3 .chr|3 '() .other|3)) (make-constant 0))))))) (.implement-dispatch|2 .prior|1 .var0|1 .other|1 .fix|1 .chr|1 .sym|1))))) 'implement-dispatch))
+(let () (begin (set! implement-dispatch-fixnum (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-fixnum|2 0)) (begin (set! .implement-dispatch-fixnum|2 (lambda (.prior|3 .var0|3 .lists|3) (let ((.complete-intervals|6 (unspecified)) (.extract-intervals|6 (unspecified)) (.calculate-intervals|6 (unspecified))) (begin (set! .complete-intervals|6 (lambda (.intervals|7) (if (null? .intervals|7) .intervals|7 (if (null? (let ((.x|10|13 .intervals|7)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) .intervals|7 (let* ((.i1|17 (let ((.x|80|83 .intervals|7)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) (.i2|20 (let ((.x|72|75 (let ((.x|76|79 .intervals|7)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))))) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.end1|23 (let ((.x|63|66 (let ((.x|67|70 .i1|17)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))))) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) (.start2|26 (let ((.x|58|61 .i2|20)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61)))) (.intervals|29 (.complete-intervals|6 (let ((.x|54|57 .intervals|7)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))))) (let () (if (= .end1|23 .start2|26) (cons .i1|17 .intervals|29) (cons .i1|17 (cons (let* ((.t1|33|36 .end1|23) (.t2|33|39 (let* ((.t1|43|46 .start2|26) (.t2|43|49 (cons (make-constant 0) '()))) (let () (cons .t1|43|46 .t2|43|49))))) (let () (cons .t1|33|36 .t2|33|39))) .intervals|29))))))))) (set! .extract-intervals|6 (lambda (.n|84 .constants|84) (if (null? .constants|84) '() (let ((.k0|87 (let ((.x|136|139 .constants|84)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.constants|95 .k1|95) (if (let ((.temp|97|100 (null? .constants|95))) (if .temp|97|100 .temp|97|100 (not (= .k1|95 (let ((.x|102|105 .constants|95)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105))))))) (cons (let* ((.t1|106|109 .k0|87) (.t2|106|112 (let* ((.t1|116|119 .k1|95) (.t2|116|122 (cons (make-constant .n|84) '()))) (let () (cons .t1|116|119 .t2|116|122))))) (let () (cons .t1|106|109 .t2|106|112))) (.extract-intervals|6 .n|84 .constants|95)) (begin #t (.loop|88|91|94 (let ((.x|128|131 .constants|95)) (begin (.check! (pair? .x|128|131) 1 .x|128|131) (cdr:pair .x|128|131))) (+ .k1|95 1)))))) (.loop|88|91|94 (let ((.x|132|135 .constants|84)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))) (+ .k0|87 1))))))))) (set! .calculate-intervals|6 (lambda (.n|140 .lists|140) (let ((.loop|141 (unspecified))) (begin (set! .loop|141 (lambda (.n|142 .lists|142 .intervals|142) (if (null? .lists|142) (twobit-sort (lambda (.interval1|143 .interval2|143) (< (let ((.x|144|147 .interval1|143)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))) (let ((.x|148|151 .interval2|143)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151))))) .intervals|142) (let ((.constants|154 (twobit-sort < (let ((.x|159|162 .lists|142)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162)))))) (.loop|141 (+ .n|142 1) (let ((.x|155|158 .lists|142)) (begin (.check! (pair? .x|155|158) 1 .x|155|158) (cdr:pair .x|155|158))) (append (.extract-intervals|6 .n|142 .constants|154) .intervals|142)))))) (.loop|141 .n|140 .lists|140 '()))))) (let* ((.intervals|163 (.complete-intervals|6 (.calculate-intervals|6 (+ .prior|3 1) .lists|3))) (.lo|166 (let ((.x|206|209 (let ((.x|210|213 .intervals|163)) (begin (.check! (pair? .x|210|213) 0 .x|210|213) (car:pair .x|210|213))))) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))) (.hi|169 (let ((.x|198|201 (let ((.x|202|205 (reverse .intervals|163))) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) (.p|172 (length .intervals|163))) (let () (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|176|179 (make-variable .var0|3)) (.t2|176|182 (cons (make-constant .lo|166) '()))) (let () (cons .t1|176|179 .t2|176|182)))) (make-constant 0) (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|187|190 (make-variable .var0|3)) (.t2|187|193 (cons (make-constant (+ .hi|169 1)) '()))) (let () (cons .t1|187|190 .t2|187|193)))) (if (< (- .hi|169 .lo|166) (* 5 .p|172)) (implement-table-lookup .var0|3 (+ .prior|3 1) .lists|3 .lo|166 .hi|169) (implement-intervals .var0|3 .intervals|163)) (make-constant 0))))))))) (.implement-dispatch-fixnum|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-fixnum))
+(let () (begin (set! implement-dispatch-char (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-char|2 0)) (begin (set! .implement-dispatch-char|2 (lambda (.prior|3 .var0|3 .lists|3) (let* ((.lists|6 (let () (let ((.loop|67|70|73 (unspecified))) (begin (set! .loop|67|70|73 (lambda (.y1|62|63|74 .results|62|66|74) (if (null? .y1|62|63|74) (reverse .results|62|66|74) (begin #t (.loop|67|70|73 (let ((.x|78|81 .y1|62|63|74)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (cons (let ((.constants|82 (let ((.x|107|110 .y1|62|63|74)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.y1|83|84|95 .results|83|87|95) (if (null? .y1|83|84|95) (reverse .results|83|87|95) (begin #t (.loop|88|91|94 (let ((.x|99|102 .y1|83|84|95)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (cons (compat:char->integer (let ((.x|103|106 .y1|83|84|95)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106)))) .results|83|87|95)))))) (.loop|88|91|94 .constants|82 '()))))) .results|62|66|74)))))) (.loop|67|70|73 .lists|3 '()))))) (.name:n|9 ((make-rename-procedure) 'n)) (.f|12 (let* ((.t1|21|24 .name:n|9) (.t2|21|27 (let* ((.t1|31|34 name:eq?) (.t2|31|37 (let* ((.t1|41|44 name:fx<) (.t2|41|47 (let* ((.t1|51|54 name:fx-) (.t2|51|57 (cons name:vector-ref '()))) (let () (cons .t1|51|54 .t2|51|57))))) (let () (cons .t1|41|44 .t2|41|47))))) (let () (cons .t1|31|34 .t2|31|37))))) (let () (cons .t1|21|24 .t2|21|27)))) (.l|15 (make-lambda (cons .name:n|9 '()) '() '() .f|12 '() '() #f (implement-dispatch-fixnum .prior|3 .name:n|9 .lists|6)))) (let () (make-call .l|15 (make-call (make-variable name:char->integer) (cons (make-variable .var0|3) '()))))))) (.implement-dispatch-char|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-char))
+(let () (begin (set! implement-dispatch-symbol (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-symbol|2 0)) (begin (set! .implement-dispatch-symbol|2 (lambda (.prior|3 .var0|3 .lists|3) (implement-dispatch-other (make-constant 0) .prior|3 .var0|3 .lists|3))) (.implement-dispatch-symbol|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-symbol))
+(let () (begin (set! implement-dispatch-other (lambda (.default|1 .prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-other|2 0)) (begin (set! .implement-dispatch-other|2 (lambda (.default|3 .prior|3 .var0|3 .lists|3) (if (null? .lists|3) .default|3 (let* ((.constants|6 (let ((.x|20|23 .lists|3)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (.lists|9 (let ((.x|16|19 .lists|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (.n|12 (+ .prior|3 1))) (let () (make-conditional (make-call-to-memv .var0|3 .constants|6) (make-constant .n|12) (.implement-dispatch-other|2 .default|3 .n|12 .var0|3 .lists|9))))))) (.implement-dispatch-other|2 .default|1 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-other))
+(let () (begin (set! make-call-to-memv (lambda (.var0|1 .constants|1) (let ((.make-call-to-memv|2 0)) (begin (set! .make-call-to-memv|2 (lambda (.var0|3 .constants|3) (if (null? .constants|3) (make-constant #f) (if (null? (let ((.x|6|9 .constants|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (make-call-to-eqv .var0|3 (let ((.x|10|13 .constants|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) (make-conditional (make-call-to-eqv .var0|3 (let ((.x|15|18 .constants|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18)))) (make-constant #t) (.make-call-to-memv|2 .var0|3 (let ((.x|19|22 .constants|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))))) (.make-call-to-memv|2 .var0|1 .constants|1))))) 'make-call-to-memv))
+(let () (begin (set! make-call-to-eqv (lambda (.var0|1 .constant|1) (let ((.make-call-to-eqv|2 0)) (begin (set! .make-call-to-eqv|2 (lambda (.var0|3 .constant|3) (make-call (make-variable (if (eq-is-ok? .constant|3) name:eq? name:eqv?)) (let* ((.t1|4|7 (make-variable .var0|3)) (.t2|4|10 (cons (make-constant .constant|3) '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.make-call-to-eqv|2 .var0|1 .constant|1))))) 'make-call-to-eqv))
+(let () (begin (set! implement-table-lookup (lambda (.var0|1 .index|1 .lists|1 .lo|1 .hi|1) (let ((.implement-table-lookup|2 0)) (begin (set! .implement-table-lookup|2 (lambda (.var0|3 .index|3 .lists|3 .lo|3 .hi|3) (let ((.v|6 (make-vector (+ 1 (- .hi|3 .lo|3)) 0))) (begin (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.index|15 .lists|15) (if (null? .lists|15) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let ((.k|33 (let ((.x|38|41 .y1|18|19|29)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (let ((.v|34|37 .v|6) (.i|34|37 (- .k|33 .lo|3)) (.x|34|37 .index|15)) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37))))) (.loop|23|25|28 (let ((.x|42|45 .y1|18|19|29)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))))))) (.loop|23|25|28 (let ((.x|46|49 .lists|15)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))))))) (.loop|8|11|14 (+ .index|15 1) (let ((.x|50|53 .lists|15)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53)))))))) (.loop|8|11|14 .index|3 .lists|3)))) (make-call (make-variable name:vector-ref) (let* ((.t1|54|57 (make-constant .v|6)) (.t2|54|60 (cons (make-call (make-variable name:fx-) (let* ((.t1|65|68 (make-variable .var0|3)) (.t2|65|71 (cons (make-constant .lo|3) '()))) (let () (cons .t1|65|68 .t2|65|71)))) '()))) (let () (cons .t1|54|57 .t2|54|60)))))))) (.implement-table-lookup|2 .var0|1 .index|1 .lists|1 .lo|1 .hi|1))))) 'implement-table-lookup))
+(let () (begin (set! implement-intervals (lambda (.var0|1 .intervals|1) (let ((.implement-intervals|2 0)) (begin (set! .implement-intervals|2 (lambda (.var0|3 .intervals|3) (if (null? (let ((.x|4|7 .intervals|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .intervals|3)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) (let ((.n|27 (quotient (length .intervals|3) 2))) (let () (let ((.loop|28|32|35 (unspecified))) (begin (set! .loop|28|32|35 (lambda (.n|36 .intervals1|36 .intervals2|36) (if (zero? .n|36) (let ((.intervals1|40 (reverse .intervals1|36)) (.m|40 (let ((.x|52|55 (let ((.x|56|59 .intervals2|36)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|41|44 (make-variable .var0|3)) (.t2|41|47 (cons (make-constant .m|40) '()))) (let () (cons .t1|41|44 .t2|41|47)))) (.implement-intervals|2 .var0|3 .intervals1|40) (.implement-intervals|2 .var0|3 .intervals2|36))) (begin #t (.loop|28|32|35 (- .n|36 1) (cons (let ((.x|61|64 .intervals2|36)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))) .intervals1|36) (let ((.x|65|68 .intervals2|36)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68)))))))) (.loop|28|32|35 .n|27 '() .intervals|3)))))))) (.implement-intervals|2 .var0|1 .intervals|1))))) 'implement-intervals))
+(let () (begin (set! *memq-threshold* 20) '*memq-threshold*))
+(let () (begin (set! *memv-threshold* 4) '*memv-threshold*))
+(let () (begin (set! implement-clauses-by-sequential-search (lambda (.var0|1 .default|1 .clauses|1) (let ((.implement-clauses-by-sequential-search|2 0)) (begin (set! .implement-clauses-by-sequential-search|2 (lambda (.var0|3 .default|3 .clauses|3) (if (null? .clauses|3) .default|3 (let* ((.case1|6 (let ((.x|36|39 .clauses|3)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) (.clauses|9 (let ((.x|32|35 .clauses|3)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))) (.constants1|12 (let ((.x|28|31 .case1|6)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.code1|15 (let ((.x|20|23 (let ((.x|24|27 .case1|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (let () (make-conditional (make-call-to-memv .var0|3 .constants1|12) .code1|15 (.implement-clauses-by-sequential-search|2 .var0|3 .default|3 .clauses|9))))))) (.implement-clauses-by-sequential-search|2 .var0|1 .default|1 .clauses|1))))) 'implement-clauses-by-sequential-search))
+(let () (begin (set! callgraphnode.name (lambda (.x|1) (let ((.callgraphnode.name|2 0)) (begin (set! .callgraphnode.name|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.callgraphnode.name|2 .x|1))))) 'callgraphnode.name))
+(let () (begin (set! callgraphnode.code (lambda (.x|1) (let ((.callgraphnode.code|2 0)) (begin (set! .callgraphnode.code|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.code|2 .x|1))))) 'callgraphnode.code))
+(let () (begin (set! callgraphnode.vars (lambda (.x|1) (let ((.callgraphnode.vars|2 0)) (begin (set! .callgraphnode.vars|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.vars|2 .x|1))))) 'callgraphnode.vars))
+(let () (begin (set! callgraphnode.tailcalls (lambda (.x|1) (let ((.callgraphnode.tailcalls|2 0)) (begin (set! .callgraphnode.tailcalls|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .x|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.tailcalls|2 .x|1))))) 'callgraphnode.tailcalls))
+(let () (begin (set! callgraphnode.nontailcalls (lambda (.x|1) (let ((.callgraphnode.nontailcalls|2 0)) (begin (set! .callgraphnode.nontailcalls|2 (lambda (.x|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .x|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.callgraphnode.nontailcalls|2 .x|1))))) 'callgraphnode.nontailcalls))
+(let () (begin (set! callgraphnode.size (lambda (.x|1) (let ((.callgraphnode.size|2 0)) (begin (set! .callgraphnode.size|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .x|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.size|2 .x|1))))) 'callgraphnode.size))
+(let () (begin (set! callgraphnode.info (lambda (.x|1) (let ((.callgraphnode.info|2 0)) (begin (set! .callgraphnode.info|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .x|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.info|2 .x|1))))) 'callgraphnode.info))
+(let () (begin (set! callgraphnode.size! (lambda (.x|1 .v|1) (let ((.callgraphnode.size!|2 0)) (begin (set! .callgraphnode.size!|2 (lambda (.x|3 .v|3) (begin (set-car! (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .x|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .v|3) #f))) (.callgraphnode.size!|2 .x|1 .v|1))))) 'callgraphnode.size!))
+(let () (begin (set! callgraphnode.info! (lambda (.x|1 .v|1) (let ((.callgraphnode.info!|2 0)) (begin (set! .callgraphnode.info!|2 (lambda (.x|3 .v|3) (begin (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .x|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .v|3) #f))) (.callgraphnode.info!|2 .x|1 .v|1))))) 'callgraphnode.info!))
+(let () (begin (set! callgraph (lambda (.exp|1) (let ((.callgraph|2 0)) (begin (set! .callgraph|2 (lambda (.exp|3) (let ((.adjoin|6 (unspecified))) (begin (set! .adjoin|6 (lambda (.x|7 .z|7) (if (memq .x|7 .z|7) .z|7 (cons .x|7 .z|7)))) (let* ((.result|8 '()) (.add-vertex!|9 (unspecified))) (begin (set! .add-vertex!|9 (lambda (.name|10 .l|10 .vars|10 .known|10) (let ((.tailcalls|13 '()) (.nontailcalls|13 '()) (.size|13 0)) (let ((.graph-lambda!|14 (unspecified)) (.graph!|14 (unspecified))) (begin (set! .graph-lambda!|14 (lambda (.l|15 .vars|15 .known|15 .tail?|15) (let* ((.defs|18 (lambda.defs .l|15)) (.newknown|21 (let () (let ((.loop|67|70|73 (unspecified))) (begin (set! .loop|67|70|73 (lambda (.y1|62|63|74 .results|62|66|74) (if (null? .y1|62|63|74) (reverse .results|62|66|74) (begin #t (.loop|67|70|73 (let ((.x|78|81 .y1|62|63|74)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (cons (def.lhs (let ((.x|82|85 .y1|62|63|74)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) .results|62|66|74)))))) (.loop|67|70|73 .defs|18 '()))))) (.vars|24 (append .newknown|21 (make-null-terminated (lambda.args .l|15)) .vars|15)) (.known|27 (append .newknown|21 .known|15))) (let () (begin (let ((.f|31|34|37 (lambda (.def|57) (begin (.add-vertex!|9 (def.lhs .def|57) (def.rhs .def|57) .vars|24 .known|27) (set! .size|13 (+ .size|13 (callgraphnode.size (let ((.x|58|61 .result|8)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61)))))))))) (let () (let ((.loop|39|41|44 (unspecified))) (begin (set! .loop|39|41|44 (lambda (.y1|31|32|45) (if (null? .y1|31|32|45) (if #f #f (unspecified)) (begin (begin #t (.f|31|34|37 (let ((.x|49|52 .y1|31|32|45)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))))) (.loop|39|41|44 (let ((.x|53|56 .y1|31|32|45)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56)))))))) (.loop|39|41|44 .defs|18))))) (.graph!|14 (lambda.body .l|15) .vars|24 .known|27 .tail?|15)))))) (set! .graph!|14 (lambda (.exp|86 .vars|86 .known|86 .tail?|86) (begin (set! .size|13 (+ .size|13 1)) (let ((.temp|87|90 (let ((.x|159|162 .exp|86)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))))) (if (memv .temp|87|90 '(quote)) #f (if (memv .temp|87|90 '(lambda)) (begin (.add-vertex!|9 #f .exp|86 .vars|86 .known|86) (set! .size|13 (+ .size|13 (callgraphnode.size (let ((.x|93|96 .result|8)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))))))) (if (memv .temp|87|90 '(set!)) (.graph!|14 (assignment.rhs .exp|86) .vars|86 .known|86 #f) (if (memv .temp|87|90 '(if)) (begin (.graph!|14 (if.test .exp|86) .vars|86 .known|86 #f) (.graph!|14 (if.then .exp|86) .vars|86 .known|86 .tail?|86) (.graph!|14 (if.else .exp|86) .vars|86 .known|86 .tail?|86)) (if (memv .temp|87|90 '(begin)) (if (not (variable? .exp|86)) (let () (let ((.loop|100|102|105 (unspecified))) (begin (set! .loop|100|102|105 (lambda (.exprs|106) (if (null? (let ((.x|108|111 .exprs|106)) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111)))) (.graph!|14 (let ((.x|112|115 .exprs|106)) (begin (.check! (pair? .x|112|115) 0 .x|112|115) (car:pair .x|112|115))) .vars|86 .known|86 .tail?|86) (begin (begin #t (.graph!|14 (let ((.x|117|120 .exprs|106)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120))) .vars|86 .known|86 #f)) (.loop|100|102|105 (let ((.x|121|124 .exprs|106)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))))) (.loop|100|102|105 (begin.exprs .exp|86))))) (unspecified)) (let ((.proc|128 (call.proc .exp|86))) (begin (if (variable? .proc|128) (let ((.name|132 (variable.name .proc|128))) (if (memq .name|132 .known|86) (if .tail?|86 (set! .tailcalls|13 (.adjoin|6 .name|132 .tailcalls|13)) (set! .nontailcalls|13 (.adjoin|6 .name|132 .nontailcalls|13))) (unspecified))) (if (lambda? .proc|128) (.graph-lambda!|14 .proc|128 .vars|86 .known|86 .tail?|86) (.graph!|14 .proc|128 .vars|86 .known|86 #f))) (let () (let ((.loop|140|142|145 (unspecified))) (begin (set! .loop|140|142|145 (lambda (.y1|135|136|146) (if (null? .y1|135|136|146) (if #f #f (unspecified)) (begin (begin #t (let ((.exp|150 (let ((.x|151|154 .y1|135|136|146)) (begin (.check! (pair? .x|151|154) 0 .x|151|154) (car:pair .x|151|154))))) (.graph!|14 .exp|150 .vars|86 .known|86 #f))) (.loop|140|142|145 (let ((.x|155|158 .y1|135|136|146)) (begin (.check! (pair? .x|155|158) 1 .x|155|158) (cdr:pair .x|155|158)))))))) (.loop|140|142|145 (call.args .exp|86)))))))))))))))) (.graph-lambda!|14 .l|10 .vars|10 .known|10 #t) (set! .result|8 (cons (let* ((.t1|163|166 .name|10) (.t2|163|169 (let* ((.t1|173|176 .l|10) (.t2|173|179 (let* ((.t1|183|186 .vars|10) (.t2|183|189 (let* ((.t1|193|196 .tailcalls|13) (.t2|193|199 (let* ((.t1|203|206 .nontailcalls|13) (.t2|203|209 (let* ((.t1|213|216 .size|13) (.t2|213|219 (cons #f '()))) (let () (cons .t1|213|216 .t2|213|219))))) (let () (cons .t1|203|206 .t2|203|209))))) (let () (cons .t1|193|196 .t2|193|199))))) (let () (cons .t1|183|186 .t2|183|189))))) (let () (cons .t1|173|176 .t2|173|179))))) (let () (cons .t1|163|166 .t2|163|169))) .result|8))))))) (.add-vertex!|9 #t (make-lambda '() '() '() '() '() '() '() .exp|3) '() '()) .result|8)))))) (.callgraph|2 .exp|1))))) 'callgraph))
+(let () (begin (set! view-callgraph (lambda (.g|1) (let ((.view-callgraph|2 0)) (begin (set! .view-callgraph|2 (lambda (.g|3) (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|19 (let ((.x|26|29 .y1|4|5|15)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (let ((.name|22 (callgraphnode.name .entry|19)) (.exp|22 (callgraphnode.code .entry|19)) (.vars|22 (callgraphnode.vars .entry|19)) (.tail|22 (callgraphnode.tailcalls .entry|19)) (.nt|22 (callgraphnode.nontailcalls .entry|19)) (.size|22 (callgraphnode.size .entry|19))) (begin (if (symbol? .name|22) (write .name|22) (if .name|22 (display "TOP LEVEL EXPRESSION") (display "ESCAPING LAMBDA EXPRESSION"))) (display ":") (newline) (display "Size: ") (write .size|22) (newline) (display "Tail calls: ") (write .tail|22) (newline) (display "Non-tail calls: ") (write .nt|22) (newline) (newline))))) (.loop|9|11|14 (let ((.x|30|33 .y1|4|5|15)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33)))))))) (.loop|9|11|14 .g|3)))))) (.view-callgraph|2 .g|1))))) 'view-callgraph))
+(let () (begin (set! *tail-threshold* 10) '*tail-threshold*))
+(let () (begin (set! *nontail-threshold* 20) '*nontail-threshold*))
+(let () (begin (set! *multiplier* 300) '*multiplier*))
+(let () (begin (set! inline-using-callgraph! (lambda (.g|1) (let ((.inline-using-callgraph!|2 0)) (begin (set! .inline-using-callgraph!|2 (lambda (.g|3) (let ((.known|6 (make-hashtable)) (.category2|6 '()) (.category3|6 '())) (begin (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|7|8|18) (if (null? .y1|7|8|18) (if #f #f (unspecified)) (begin (begin #t (let ((.node|22 (let ((.x|28|31 .y1|7|8|18)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (let ((.name|25 (callgraphnode.name .node|22)) (.tcalls|25 (callgraphnode.tailcalls .node|22)) (.ncalls|25 (callgraphnode.nontailcalls .node|22))) (begin (if (symbol? .name|25) (hashtable-put! .known|6 .name|25 .node|22) (unspecified)) (if (if (null? .tcalls|25) (null? .ncalls|25) #f) (if (< (callgraphnode.size .node|22) *nontail-threshold*) (callgraphnode.info! .node|22 #t) (unspecified)) (if (symbol? .name|25) (set! .category2|6 (cons .node|22 .category2|6)) (set! .category3|6 (cons .node|22 .category3|6)))))))) (.loop|12|14|17 (let ((.x|32|35 .y1|7|8|18)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))))))) (.loop|12|14|17 .g|3)))) (set! .category2|6 (twobit-sort (lambda (.x|36 .y|36) (< (callgraphnode.size .x|36) (callgraphnode.size .y|36))) .category2|6)) (let () (let ((.loop|42|44|47 (unspecified))) (begin (set! .loop|42|44|47 (lambda (.y1|37|38|48) (if (null? .y1|37|38|48) (if #f #f (unspecified)) (begin (begin #t (let ((.node|52 (let ((.x|53|56 .y1|37|38|48)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56))))) (inline-node! .node|52 .known|6))) (.loop|42|44|47 (let ((.x|57|60 .y1|37|38|48)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60)))))))) (.loop|42|44|47 .category2|6)))) (let () (let ((.loop|66|68|71 (unspecified))) (begin (set! .loop|66|68|71 (lambda (.y1|61|62|72) (if (null? .y1|61|62|72) (if #f #f (unspecified)) (begin (begin #t (let ((.node|76 (let ((.x|77|80 .y1|61|62|72)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (inline-node! .node|76 .known|6))) (.loop|66|68|71 (let ((.x|81|84 .y1|61|62|72)) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84)))))))) (.loop|66|68|71 .category3|6)))) (hashtable-for-each (lambda (.name|85 .node|85) (callgraphnode.info! .node|85 #f)) .known|6))))) (.inline-using-callgraph!|2 .g|1))))) 'inline-using-callgraph!))
+(let () (begin (set! inline-node! (lambda (.node|1 .known|1) (let ((.inline-node!|2 0)) (begin (set! .inline-node!|2 (lambda (.node|3 .known|3) (let* ((.debugging?|6 #f) (.name|9 (callgraphnode.name .node|3)) (.exp|12 (callgraphnode.code .node|3)) (.size0|15 (callgraphnode.size .node|3)) (.budget|18 (quotient (* (- *multiplier* 100) .size0|15) 100)) (.tail-threshold|21 *tail-threshold*) (.nontail-threshold|24 *nontail-threshold*)) (let () (let ((.inline|28 (unspecified))) (begin (set! .inline|28 (lambda (.exp|29 .tail?|29 .budget|29) (if (> .budget|29 0) (let ((.temp|31|34 (let ((.x|122|125 .exp|29)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (if (memv .temp|31|34 ''lambda) .budget|29 (if (memv .temp|31|34 '(set!)) (.inline|28 (assignment.rhs .exp|29) #f .budget|29) (if (memv .temp|31|34 '(if)) (let* ((.budget|40 (.inline|28 (if.test .exp|29) #f .budget|29)) (.budget|43 (.inline|28 (if.then .exp|29) .tail?|29 .budget|40)) (.budget|46 (.inline|28 (if.else .exp|29) .tail?|29 .budget|43))) (let () .budget|46)) (if (memv .temp|31|34 '(begin)) (if (variable? .exp|29) .budget|29 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.exprs|58 .budget|58) (if (null? (let ((.x|60|63 .exprs|58)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63)))) (.inline|28 (let ((.x|64|67 .exprs|58)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))) .tail?|29 .budget|58) (begin #t (.loop|51|54|57 (let ((.x|69|72 .exprs|58)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))) (.inline|28 (let ((.x|73|76 .exprs|58)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76))) #f .budget|58)))))) (.loop|51|54|57 (begin.exprs .exp|29) .budget|29))))) (let* ((.budget|80 (let () (let ((.loop|104|107|110 (unspecified))) (begin (set! .loop|104|107|110 (lambda (.exprs|111 .budget|111) (if (null? .exprs|111) .budget|111 (begin #t (.loop|104|107|110 (let ((.x|114|117 .exprs|111)) (begin (.check! (pair? .x|114|117) 1 .x|114|117) (cdr:pair .x|114|117))) (.inline|28 (let ((.x|118|121 .exprs|111)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121))) #f .budget|111)))))) (.loop|104|107|110 (call.args .exp|29) .budget|29))))) (.proc|83 (call.proc .exp|29))) (if (variable? .proc|83) (let* ((.procname|87 (variable.name .proc|83)) (.procnode|90 (hashtable-get .known|3 .procname|87))) (let () (if .procnode|90 (let ((.size|96 (callgraphnode.size .procnode|90)) (.info|96 (callgraphnode.info .procnode|90))) (if (if .info|96 (if (<= .size|96 .budget|80) (<= .size|96 (if .tail?|29 .tail-threshold|21 .nontail-threshold|24)) #f) #f) (begin (if .debugging?|6 (begin (display " Inlining ") (write (variable.name .proc|83)) (newline)) (unspecified)) (call.proc-set! .exp|29 (copy-exp (callgraphnode.code .procnode|90))) (callgraphnode.size! .node|3 (+ (callgraphnode.size .node|3) .size|96)) (- .budget|80 .size|96)) (begin (if (if #f .debugging?|6 #f) (begin (display " Declining to inline ") (write (variable.name .proc|83)) (newline)) (unspecified)) .budget|80))) .budget|80))) (if (lambda? .proc|83) (.inline|28 (lambda.body .proc|83) .tail?|29 .budget|80) (.inline|28 .proc|83 #f .budget|80))))))))) -1))) (if (if #f .debugging?|6 #f) (begin (display "Processing ") (write .name|9) (newline)) (unspecified)) (let ((.budget|130 (.inline|28 (if (lambda? .exp|12) (lambda.body .exp|12) .exp|12) #t .budget|18))) (begin (if (if (< .budget|130 0) .debugging?|6 #f) (begin (display "Ran out of inlining budget for ") (write (callgraphnode.name .node|3)) (newline)) (unspecified)) (if (<= (callgraphnode.size .node|3) .nontail-threshold|24) (callgraphnode.info! .node|3 #t) (unspecified)) #f)))))))) (.inline-node!|2 .node|1 .known|1))))) 'inline-node!))
+(let () (begin (set! test-inlining (lambda (.test0|1) (let ((.test-inlining|2 0)) (begin (set! .test-inlining|2 (lambda (.test0|3) (let ((.g0|4 (unspecified)) (.exp0|4 (unspecified))) (begin (set! .g0|4 (begin (display "Computing call graph...") (newline) (callgraph .exp0|4))) (set! .exp0|4 (begin (display "Compiling...") (newline) (pass2 (pass1 .test0|3)))) (display "Inlining...") (newline) (inline-using-callgraph! .g0|4) (pretty-print (make-readable (copy-exp .exp0|4))))))) (.test-inlining|2 .test0|1))))) 'test-inlining))
+(let () (begin (set! *constant-propagation-limit* 5) '*constant-propagation-limit*))
+(let () (begin (set! constant-propagation (lambda (.exp|1) (let ((.constant-propagation|2 0)) (begin (set! .constant-propagation|2 (lambda (.exp|3) (let ((.constant-propagation|4 (unspecified))) (begin (set! .constant-propagation|4 (lambda (.exp|5 .i|5) (if (< .i|5 *constant-propagation-limit*) (let* ((.g|8 (callgraph .exp|5)) (.l|11 (callgraphnode.code (let ((.x|21|24 .g|8)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (.variables|14 (constant-propagation-using-callgraph .g|8)) (.changed?|17 (constant-folding! .l|11 .variables|14))) (let () (if .changed?|17 (.constant-propagation|4 (lambda.body .l|11) (+ .i|5 1)) (lambda.body .l|11)))) (unspecified)))) (.constant-propagation|4 .exp|3 0))))) (.constant-propagation|2 .exp|1))))) 'constant-propagation))
+(let () (begin (set! constant-propagation-using-callgraph (lambda (.g|1) (let ((.constant-propagation-using-callgraph|2 0)) (begin (set! .constant-propagation-using-callgraph|2 (lambda (.g|3) (let ((.debugging?|6 #f) (.folding?|6 (integrate-usual-procedures)) (.known|6 (make-hashtable)) (.variables|6 (make-hashtable)) (.counter|6 0)) (let ((.collect!|7 (unspecified)) (.combine-symbolic|7 (unspecified)) (.aeval1-error|7 (unspecified)) (.aeval1|7 (unspecified)) (.aeval|7 (unspecified)) (.join|7 (unspecified))) (begin (set! .collect!|7 (lambda (.exp|8) (let ((.temp|9|12 (let ((.x|148|151 .exp|8)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151))))) (if (memv .temp|9|12 '(quote)) (cons .exp|8 '()) (if (memv .temp|9|12 '(lambda)) #t (if (memv .temp|9|12 '(set!)) (begin (.collect!|7 (assignment.rhs .exp|8)) '()) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) (cons .exp|8 '()) (let () (let ((.loop|19|21|24 (unspecified))) (begin (set! .loop|19|21|24 (lambda (.exprs|25) (if (null? (let ((.x|27|30 .exprs|25)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (.collect!|7 (let ((.x|31|34 .exprs|25)) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34)))) (begin (begin #t (.collect!|7 (let ((.x|36|39 .exprs|25)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (.loop|19|21|24 (let ((.x|40|43 .exprs|25)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43)))))))) (.loop|19|21|24 (begin.exprs .exp|8)))))) (if (memv .temp|9|12 '(if)) (begin (.collect!|7 (if.test .exp|8)) (.collect!|7 (if.then .exp|8)) (.collect!|7 (if.else .exp|8)) #t) (let () (let ((.loop|46|49|52 (unspecified))) (begin (set! .loop|46|49|52 (lambda (.exprs|53 .reps|53) (if (null? .exprs|53) (let* ((.proc|57 (call.proc .exp|8)) (.put-args!|59 (unspecified))) (begin (set! .put-args!|59 (lambda (.args|60 .reps|60) (if (pair? .args|60) (let ((.v|64 (let ((.x|73|76 .args|60)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76)))) (.rep|64 (let ((.x|77|80 .reps|60)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (begin (hashtable-put! .variables|6 .v|64 .rep|64) (.put-args!|59 (let ((.x|65|68 .args|60)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68))) (let ((.x|69|72 .reps|60)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72)))))) (if (symbol? .args|60) (hashtable-put! .variables|6 .args|60 #t) #f)))) (if (variable? .proc|57) (let* ((.procname|85 (variable.name .proc|57)) (.procnode|88 (hashtable-get .known|6 .procname|85)) (.entry|91 (if .folding?|6 (constant-folding-entry .procname|85) #f))) (let () (if .procnode|88 (begin (let () (let ((.loop|102|105|108 (unspecified))) (begin (set! .loop|102|105|108 (lambda (.y1|96|98|109 .y1|96|97|109) (if (let ((.temp|111|114 (null? .y1|96|98|109))) (if .temp|111|114 .temp|111|114 (null? .y1|96|97|109))) (if #f #f (unspecified)) (begin (begin #t (let ((.v|117 (let ((.x|118|121 .y1|96|98|109)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121)))) (.rep|117 (let ((.x|122|125 .y1|96|97|109)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (hashtable-put! .variables|6 .v|117 (.combine-symbolic|7 .rep|117 (hashtable-get .variables|6 .v|117))))) (.loop|102|105|108 (let ((.x|126|129 .y1|96|98|109)) (begin (.check! (pair? .x|126|129) 1 .x|126|129) (cdr:pair .x|126|129))) (let ((.x|130|133 .y1|96|97|109)) (begin (.check! (pair? .x|130|133) 1 .x|130|133) (cdr:pair .x|130|133)))))))) (.loop|102|105|108 (lambda.args (callgraphnode.code .procnode|88)) .reps|53)))) (cons (make-variable .procname|85) '())) (if .entry|91 #t #t)))) (if (lambda? .proc|57) (begin (.put-args!|59 (lambda.args .proc|57) .reps|53) (.collect!|7 (lambda.body .proc|57))) (begin (.collect!|7 .proc|57) #t))))) (begin #t (.loop|46|49|52 (let ((.x|140|143 .exprs|53)) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))) (cons (.collect!|7 (let ((.x|144|147 .exprs|53)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147)))) .reps|53)))))) (.loop|46|49|52 (reverse (call.args .exp|8)) '())))))))))))) (set! .combine-symbolic|7 (lambda (.rep1|152 .rep2|152) (if (eq? .rep1|152 #t) #t (if (eq? .rep2|152 #t) #t (append .rep1|152 .rep2|152))))) (set! .aeval1-error|7 (lambda () (error "Compiler bug: constant propagation (aeval1)"))) (set! .aeval1|7 (lambda (.exp|157 .env|157) (let ((.temp|158|161 (let ((.x|238|241 .exp|157)) (begin (.check! (pair? .x|238|241) 0 .x|238|241) (car:pair .x|238|241))))) (if (memv .temp|158|161 '(quote)) .exp|157 (if (memv .temp|158|161 '(lambda)) #t (if (memv .temp|158|161 '(set!)) #f (if (memv .temp|158|161 '(begin)) (if (variable? .exp|157) (let* ((.name|168 (variable.name .exp|157)) (.i|171 (hashtable-get .variables|6 .name|168))) (let () (if .i|171 (let ((.v|175|178 .env|157) (.i|175|178 .i|171)) (begin (.check! (fixnum? .i|175|178) 40 .v|175|178 .i|175|178) (.check! (vector? .v|175|178) 40 .v|175|178 .i|175|178) (.check! (<:fix:fix .i|175|178 (vector-length:vec .v|175|178)) 40 .v|175|178 .i|175|178) (.check! (>=:fix:fix .i|175|178 0) 40 .v|175|178 .i|175|178) (vector-ref:trusted .v|175|178 .i|175|178))) #t))) (.aeval1-error|7)) (if (memv .temp|158|161 '(if)) (let* ((.val0|182 (.aeval1|7 (if.test .exp|157) .env|157)) (.val1|185 (.aeval1|7 (if.then .exp|157) .env|157)) (.val2|188 (.aeval1|7 (if.else .exp|157) .env|157))) (let () (if (eq? .val0|182 #t) (.join|7 .val1|185 .val2|188) (if (pair? .val0|182) (if (constant.value .val0|182) .val1|185 .val2|188) #f)))) (let () (let ((.loop|196|199|202 (unspecified))) (begin (set! .loop|196|199|202 (lambda (.exprs|203 .vals|203) (if (null? .exprs|203) (let ((.proc|207 (call.proc .exp|157))) (if (variable? .proc|207) (let* ((.procname|211 (variable.name .proc|207)) (.procnode|214 (hashtable-get .known|6 .procname|211)) (.entry|217 (if .folding?|6 (constant-folding-entry .procname|211) #f))) (let () (if .procnode|214 (let ((.v|222|225 .env|157) (.i|222|225 (hashtable-get .variables|6 .procname|211))) (begin (.check! (fixnum? .i|222|225) 40 .v|222|225 .i|222|225) (.check! (vector? .v|222|225) 40 .v|222|225 .i|222|225) (.check! (<:fix:fix .i|222|225 (vector-length:vec .v|222|225)) 40 .v|222|225 .i|222|225) (.check! (>=:fix:fix .i|222|225 0) 40 .v|222|225 .i|222|225) (vector-ref:trusted .v|222|225 .i|222|225))) (if .entry|217 #t (.aeval1-error|7))))) (.aeval1-error|7))) (begin #t (.loop|196|199|202 (let ((.x|230|233 .exprs|203)) (begin (.check! (pair? .x|230|233) 1 .x|230|233) (cdr:pair .x|230|233))) (cons (.aeval1|7 (let ((.x|234|237 .exprs|203)) (begin (.check! (pair? .x|234|237) 0 .x|234|237) (car:pair .x|234|237))) .env|157) .vals|203)))))) (.loop|196|199|202 (reverse (call.args .exp|157)) '())))))))))))) (set! .aeval|7 (lambda (.rep|242 .env|242) (if (eq? .rep|242 #t) #t (if (null? .rep|242) #f (if (null? (let ((.x|246|249 .rep|242)) (begin (.check! (pair? .x|246|249) 1 .x|246|249) (cdr:pair .x|246|249)))) (.aeval1|7 (let ((.x|250|253 .rep|242)) (begin (.check! (pair? .x|250|253) 0 .x|250|253) (car:pair .x|250|253))) .env|242) (.join|7 (.aeval1|7 (let ((.x|255|258 .rep|242)) (begin (.check! (pair? .x|255|258) 0 .x|255|258) (car:pair .x|255|258))) .env|242) (.aeval|7 (let ((.x|259|262 .rep|242)) (begin (.check! (pair? .x|259|262) 1 .x|259|262) (cdr:pair .x|259|262))) .env|242))))))) (set! .join|7 (lambda (.x|263 .y|263) (if (boolean? .x|263) (if .x|263 #t .y|263) (if (boolean? .y|263) (.join|7 .y|263 .x|263) (if (equal? .x|263 .y|263) .x|263 #t))))) (let () (let ((.loop|273|275|278 (unspecified))) (begin (set! .loop|273|275|278 (lambda (.y1|268|269|279) (if (null? .y1|268|269|279) (if #f #f (unspecified)) (begin (begin #t (let* ((.node|283 (let ((.x|323|326 .y1|268|269|279)) (begin (.check! (pair? .x|323|326) 0 .x|323|326) (car:pair .x|323|326)))) (.name|286 (callgraphnode.name .node|283)) (.code|289 (callgraphnode.code .node|283)) (.known?|292 (symbol? .name|286)) (.rep|295 (if .known?|292 '() #t))) (let () (begin (if .known?|292 (hashtable-put! .known|6 .name|286 .node|283) (unspecified)) (if (lambda? .code|289) (let () (let ((.loop|304|306|309 (unspecified))) (begin (set! .loop|304|306|309 (lambda (.y1|299|300|310) (if (null? .y1|299|300|310) (if #f #f (unspecified)) (begin (begin #t (let ((.var|314 (let ((.x|315|318 .y1|299|300|310)) (begin (.check! (pair? .x|315|318) 0 .x|315|318) (car:pair .x|315|318))))) (hashtable-put! .variables|6 .var|314 .rep|295))) (.loop|304|306|309 (let ((.x|319|322 .y1|299|300|310)) (begin (.check! (pair? .x|319|322) 1 .x|319|322) (cdr:pair .x|319|322)))))))) (.loop|304|306|309 (make-null-terminated (lambda.args .code|289)))))) (unspecified)))))) (.loop|273|275|278 (let ((.x|327|330 .y1|268|269|279)) (begin (.check! (pair? .x|327|330) 1 .x|327|330) (cdr:pair .x|327|330)))))))) (.loop|273|275|278 .g|3)))) (let () (let ((.loop|336|338|341 (unspecified))) (begin (set! .loop|336|338|341 (lambda (.y1|331|332|342) (if (null? .y1|331|332|342) (if #f #f (unspecified)) (begin (begin #t (let ((.node|346 (let ((.x|352|355 .y1|331|332|342)) (begin (.check! (pair? .x|352|355) 0 .x|352|355) (car:pair .x|352|355))))) (let ((.name|349 (callgraphnode.name .node|346)) (.code|349 (callgraphnode.code .node|346))) (if (symbol? .name|349) (hashtable-put! .variables|6 .name|349 (.collect!|7 (lambda.body .code|349))) (.collect!|7 (lambda.body .code|349)))))) (.loop|336|338|341 (let ((.x|356|359 .y1|331|332|342)) (begin (.check! (pair? .x|356|359) 1 .x|356|359) (cdr:pair .x|356|359)))))))) (.loop|336|338|341 .g|3)))) (if (if #f .debugging?|6 #f) (begin (hashtable-for-each (lambda (.v|362 .rep|362) (begin (write .v|362) (display ": ") (write .rep|362) (newline))) .variables|6) (display "----------------------------------------") (newline)) (unspecified)) (let* ((.n|365 (hashtable-size .variables|6)) (.vars|368 (hashtable-map (lambda (.v|482 .rep|482) .v|482) .variables|6)) (.reps|371 (let () (let ((.loop|462|465|468 (unspecified))) (begin (set! .loop|462|465|468 (lambda (.y1|457|458|469 .results|457|461|469) (if (null? .y1|457|458|469) (reverse .results|457|461|469) (begin #t (.loop|462|465|468 (let ((.x|473|476 .y1|457|458|469)) (begin (.check! (pair? .x|473|476) 1 .x|473|476) (cdr:pair .x|473|476))) (cons (let ((.v|477 (let ((.x|478|481 .y1|457|458|469)) (begin (.check! (pair? .x|478|481) 0 .x|478|481) (car:pair .x|478|481))))) (hashtable-get .variables|6 .v|477)) .results|457|461|469)))))) (.loop|462|465|468 .vars|368 '()))))) (.init|374 (make-vector .n|365 #f)) (.next|377 (make-vector .n|365 '()))) (let () (begin (let () (let ((.loop|382|386|389 (unspecified))) (begin (set! .loop|382|386|389 (lambda (.i|390 .vars|390 .reps|390) (if (= .i|390 .n|365) (if #f #f (unspecified)) (begin (begin #t (hashtable-put! .variables|6 (let ((.x|393|396 .vars|390)) (begin (.check! (pair? .x|393|396) 0 .x|393|396) (car:pair .x|393|396))) .i|390) (let ((.v|397|400 .next|377) (.i|397|400 .i|390) (.x|397|400 (let ((.rep|403 (let ((.x|405|408 .reps|390)) (begin (.check! (pair? .x|405|408) 0 .x|405|408) (car:pair .x|405|408))))) (lambda (.env|404) (.aeval|7 .rep|403 .env|404))))) (begin (.check! (fixnum? .i|397|400) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (vector? .v|397|400) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (<:fix:fix .i|397|400 (vector-length:vec .v|397|400)) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (>=:fix:fix .i|397|400 0) 41 .v|397|400 .i|397|400 .x|397|400) (vector-set!:trusted .v|397|400 .i|397|400 .x|397|400)))) (.loop|382|386|389 (+ .i|390 1) (let ((.x|409|412 .vars|390)) (begin (.check! (pair? .x|409|412) 1 .x|409|412) (cdr:pair .x|409|412))) (let ((.x|413|416 .reps|390)) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416)))))))) (.loop|382|386|389 0 .vars|368 .reps|371)))) (compute-fixedpoint .init|374 .next|377 equal?) (let () (let ((.loop|422|424|427 (unspecified))) (begin (set! .loop|422|424|427 (lambda (.y1|417|418|428) (if (null? .y1|417|418|428) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|432 (let ((.x|448|451 .y1|417|418|428)) (begin (.check! (pair? .x|448|451) 0 .x|448|451) (car:pair .x|448|451)))) (.i|435 (hashtable-get .variables|6 .v|432)) (.aval|438 (let ((.v|444|447 .init|374) (.i|444|447 .i|435)) (begin (.check! (fixnum? .i|444|447) 40 .v|444|447 .i|444|447) (.check! (vector? .v|444|447) 40 .v|444|447 .i|444|447) (.check! (<:fix:fix .i|444|447 (vector-length:vec .v|444|447)) 40 .v|444|447 .i|444|447) (.check! (>=:fix:fix .i|444|447 0) 40 .v|444|447 .i|444|447) (vector-ref:trusted .v|444|447 .i|444|447))))) (let () (begin (hashtable-put! .variables|6 .v|432 .aval|438) (if (if .debugging?|6 (not (eq? .aval|438 #t)) #f) (begin (write .v|432) (display ": ") (write .aval|438) (newline)) (unspecified)))))) (.loop|422|424|427 (let ((.x|452|455 .y1|417|418|428)) (begin (.check! (pair? .x|452|455) 1 .x|452|455) (cdr:pair .x|452|455)))))))) (.loop|422|424|427 .vars|368)))) .variables|6)))))))) (.constant-propagation-using-callgraph|2 .g|1))))) 'constant-propagation-using-callgraph))
+(let () (begin (set! constant-folding! (lambda (.l|1 .variables|1) (let ((.constant-folding!|2 0)) (begin (set! .constant-folding!|2 (lambda (.l|3 .variables|3) (let ((.debugging?|6 #f) (.msg1|6 " Propagating constant value for ") (.msg2|6 " Folding: ") (.msg3|6 " ==> ") (.folding?|6 (integrate-usual-procedures)) (.changed?|6 #f)) (let ((.fold!|7 (unspecified)) (.delete-ignored-args!|7 (unspecified))) (begin (set! .fold!|7 (lambda (.exp|8) (let ((.temp|9|12 (let ((.x|403|406 .exp|8)) (begin (.check! (pair? .x|403|406) 0 .x|403|406) (car:pair .x|403|406))))) (if (memv .temp|9|12 '(quote)) .exp|8 (if (memv .temp|9|12 '(lambda)) (let ((.rinfo|17 (lambda.r .exp|8)) (.known|17 (let () (let ((.loop|166|169|172 (unspecified))) (begin (set! .loop|166|169|172 (lambda (.y1|161|162|173 .results|161|165|173) (if (null? .y1|161|162|173) (reverse .results|161|165|173) (begin #t (.loop|166|169|172 (let ((.x|177|180 .y1|161|162|173)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180))) (cons (def.lhs (let ((.x|181|184 .y1|161|162|173)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184)))) .results|161|165|173)))))) (.loop|166|169|172 (lambda.defs .exp|8) '())))))) (begin (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let* ((.entry|33 (let ((.x|102|105 .y1|18|19|29)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) (.v|36 (r-entry.name .entry|33)) (.aval|39 (hashtable-fetch .variables|3 .v|36 #t))) (let () (if (if (pair? .aval|39) (not (memq .v|36 .known|17)) #f) (let ((.x|47 (constant.value .aval|39))) (if (let ((.temp|48|51 (boolean? .x|47))) (if .temp|48|51 .temp|48|51 (let ((.temp|52|55 (null? .x|47))) (if .temp|52|55 .temp|52|55 (let ((.temp|56|59 (symbol? .x|47))) (if .temp|56|59 .temp|56|59 (let ((.temp|60|63 (number? .x|47))) (if .temp|60|63 .temp|60|63 (let ((.temp|64|67 (char? .x|47))) (if .temp|64|67 .temp|64|67 (if (vector? .x|47) (zero? (let ((.v|71|74 .x|47)) (begin (.check! (vector? .v|71|74) 42 .v|71|74) (vector-length:vec .v|71|74)))) #f))))))))))) (let ((.refs|77 (r-entry.references .entry|33))) (begin (let () (let ((.loop|83|85|88 (unspecified))) (begin (set! .loop|83|85|88 (lambda (.y1|78|79|89) (if (null? .y1|78|79|89) (if #f #f (unspecified)) (begin (begin #t (let ((.ref|93 (let ((.x|94|97 .y1|78|79|89)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) (variable-set! .ref|93 .aval|39))) (.loop|83|85|88 (let ((.x|98|101 .y1|78|79|89)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101)))))))) (.loop|83|85|88 .refs|77)))) (lambda.r-set! .exp|8 (remq .entry|33 (lambda.r .exp|8))) (flag-as-ignored .v|36 .exp|8) (if .debugging?|6 (begin (display .msg1|6) (write .v|36) (display ": ") (write .aval|39) (newline)) (unspecified)))) (unspecified))) (unspecified))))) (.loop|23|25|28 (let ((.x|106|109 .y1|18|19|29)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109)))))))) (.loop|23|25|28 .rinfo|17)))) (let () (let ((.loop|115|117|120 (unspecified))) (begin (set! .loop|115|117|120 (lambda (.y1|110|111|121) (if (null? .y1|110|111|121) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|125 (let ((.x|153|156 .y1|110|111|121)) (begin (.check! (pair? .x|153|156) 0 .x|153|156) (car:pair .x|153|156)))) (.name|128 (def.lhs .def|125)) (.rhs|131 (def.rhs .def|125)) (.entry|134 (r-lookup .rinfo|17 .name|128)) (.calls|137 (r-entry.calls .entry|134))) (let () (if (null? .calls|137) (begin (lambda.defs-set! .exp|8 (remq .def|125 (lambda.defs .exp|8))) (lambda.r-set! .exp|8 (remq .entry|134 (lambda.r .exp|8)))) (let* ((.formals0|143 (append (lambda.args .rhs|131) '())) (.l|146 (.fold!|7 .rhs|131)) (.formals1|149 (lambda.args .l|146))) (let () (if (not (equal? .formals0|143 .formals1|149)) (.delete-ignored-args!|7 .l|146 .formals0|143 .calls|137) (unspecified)))))))) (.loop|115|117|120 (let ((.x|157|160 .y1|110|111|121)) (begin (.check! (pair? .x|157|160) 1 .x|157|160) (cdr:pair .x|157|160)))))))) (.loop|115|117|120 (lambda.defs .exp|8))))) (lambda.body-set! .exp|8 (.fold!|7 (lambda.body .exp|8))) .exp|8)) (if (memv .temp|9|12 '(set!)) (begin (assignment.rhs-set! .exp|8 (.fold!|7 (assignment.rhs .exp|8))) .exp|8) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) .exp|8 (post-simplify-begin (make-begin (let () (let ((.loop|192|195|198 (unspecified))) (begin (set! .loop|192|195|198 (lambda (.y1|187|188|199 .results|187|191|199) (if (null? .y1|187|188|199) (reverse .results|187|191|199) (begin #t (.loop|192|195|198 (let ((.x|203|206 .y1|187|188|199)) (begin (.check! (pair? .x|203|206) 1 .x|203|206) (cdr:pair .x|203|206))) (cons (.fold!|7 (let ((.x|207|210 .y1|187|188|199)) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210)))) .results|187|191|199)))))) (.loop|192|195|198 (begin.exprs .exp|8) '()))))) (make-notepad #f))) (if (memv .temp|9|12 '(if)) (let ((.exp0|214 (.fold!|7 (if.test .exp|8))) (.exp1|214 (.fold!|7 (if.then .exp|8))) (.exp2|214 (.fold!|7 (if.else .exp|8)))) (if (constant? .exp0|214) (let ((.newexp|217 (if (constant.value .exp0|214) .exp1|214 .exp2|214))) (begin (if .debugging?|6 (begin (display .msg2|6) (write (make-readable .exp|8)) (display .msg3|6) (write (make-readable .newexp|217)) (newline)) (unspecified)) (set! .changed?|6 #t) .newexp|217)) (make-conditional .exp0|214 .exp1|214 .exp2|214))) (let ((.args|221 (let () (let ((.loop|384|387|390 (unspecified))) (begin (set! .loop|384|387|390 (lambda (.y1|379|380|391 .results|379|383|391) (if (null? .y1|379|380|391) (reverse .results|379|383|391) (begin #t (.loop|384|387|390 (let ((.x|395|398 .y1|379|380|391)) (begin (.check! (pair? .x|395|398) 1 .x|395|398) (cdr:pair .x|395|398))) (cons (.fold!|7 (let ((.x|399|402 .y1|379|380|391)) (begin (.check! (pair? .x|399|402) 0 .x|399|402) (car:pair .x|399|402)))) .results|379|383|391)))))) (.loop|384|387|390 (call.args .exp|8) '()))))) (.proc|221 (.fold!|7 (call.proc .exp|8)))) (if (if .folding?|6 (if (variable? .proc|221) (if (every? constant? .args|221) (let ((.entry|229 (constant-folding-entry (variable.name .proc|221)))) (if .entry|229 (let ((.preds|234 (constant-folding-predicates .entry|229))) (if (= (length .args|221) (length .preds|234)) (every? (lambda (.x|237) .x|237) (let () (let ((.loop|244|248|251 (unspecified))) (begin (set! .loop|244|248|251 (lambda (.y1|238|240|252 .y1|238|239|252 .results|238|243|252) (if (let ((.temp|254|257 (null? .y1|238|240|252))) (if .temp|254|257 .temp|254|257 (null? .y1|238|239|252))) (reverse .results|238|243|252) (begin #t (.loop|244|248|251 (let ((.x|260|263 .y1|238|240|252)) (begin (.check! (pair? .x|260|263) 1 .x|260|263) (cdr:pair .x|260|263))) (let ((.x|264|267 .y1|238|239|252)) (begin (.check! (pair? .x|264|267) 1 .x|264|267) (cdr:pair .x|264|267))) (cons (let ((.f|268 (let ((.x|269|272 .y1|238|240|252)) (begin (.check! (pair? .x|269|272) 0 .x|269|272) (car:pair .x|269|272)))) (.v|268 (let ((.x|273|276 .y1|238|239|252)) (begin (.check! (pair? .x|273|276) 0 .x|273|276) (car:pair .x|273|276))))) (.f|268 .v|268)) .results|238|243|252)))))) (.loop|244|248|251 (constant-folding-predicates .entry|229) (let () (let ((.loop|282|285|288 (unspecified))) (begin (set! .loop|282|285|288 (lambda (.y1|277|278|289 .results|277|281|289) (if (null? .y1|277|278|289) (reverse .results|277|281|289) (begin #t (.loop|282|285|288 (let ((.x|293|296 .y1|277|278|289)) (begin (.check! (pair? .x|293|296) 1 .x|293|296) (cdr:pair .x|293|296))) (cons (constant.value (let ((.x|297|300 .y1|277|278|289)) (begin (.check! (pair? .x|297|300) 0 .x|297|300) (car:pair .x|297|300)))) .results|277|281|289)))))) (.loop|282|285|288 .args|221 '())))) '()))))) #f)) #f)) #f) #f) #f) (begin (set! .changed?|6 #t) (let ((.result|303 (make-constant (apply (constant-folding-folder (constant-folding-entry (variable.name .proc|221))) (let () (let ((.loop|309|312|315 (unspecified))) (begin (set! .loop|309|312|315 (lambda (.y1|304|305|316 .results|304|308|316) (if (null? .y1|304|305|316) (reverse .results|304|308|316) (begin #t (.loop|309|312|315 (let ((.x|320|323 .y1|304|305|316)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) (cons (constant.value (let ((.x|324|327 .y1|304|305|316)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327)))) .results|304|308|316)))))) (.loop|309|312|315 .args|221 '())))))))) (begin (if .debugging?|6 (begin (display .msg2|6) (write (make-readable (make-call .proc|221 .args|221))) (display .msg3|6) (write .result|303) (newline)) (unspecified)) .result|303))) (if (if (lambda? .proc|221) (list? (lambda.args .proc|221)) #f) (let ((.formals|333 (reverse (lambda.args .proc|221))) (.actuals|333 (reverse .args|221)) (.processed-formals|333 '()) (.processed-actuals|333 '()) (.for-effect|333 '())) (let () (let ((.loop|336 (unspecified))) (begin (set! .loop|336 (lambda (.formals|337 .actuals|337 .processed-formals|337 .processed-actuals|337 .for-effect|337) (if (null? .formals|337) (begin (lambda.args-set! .proc|221 .processed-formals|337) (call.args-set! .exp|8 .processed-actuals|337) (let ((.call|341 (if (if (null? .processed-formals|337) (null? (lambda.defs .proc|221)) #f) (lambda.body .proc|221) .exp|8))) (if (null? .for-effect|337) .call|341 (post-simplify-begin (make-begin (reverse (cons .call|341 .for-effect|337))) (make-notepad #f))))) (if (ignored? (let ((.x|345|348 .formals|337)) (begin (.check! (pair? .x|345|348) 0 .x|345|348) (car:pair .x|345|348)))) (.loop|336 (let ((.x|349|352 .formals|337)) (begin (.check! (pair? .x|349|352) 1 .x|349|352) (cdr:pair .x|349|352))) (let ((.x|353|356 .actuals|337)) (begin (.check! (pair? .x|353|356) 1 .x|353|356) (cdr:pair .x|353|356))) .processed-formals|337 .processed-actuals|337 (cons (let ((.x|357|360 .actuals|337)) (begin (.check! (pair? .x|357|360) 0 .x|357|360) (car:pair .x|357|360))) .for-effect|337)) (.loop|336 (let ((.x|362|365 .formals|337)) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))) (let ((.x|366|369 .actuals|337)) (begin (.check! (pair? .x|366|369) 1 .x|366|369) (cdr:pair .x|366|369))) (cons (let ((.x|370|373 .formals|337)) (begin (.check! (pair? .x|370|373) 0 .x|370|373) (car:pair .x|370|373))) .processed-formals|337) (cons (let ((.x|374|377 .actuals|337)) (begin (.check! (pair? .x|374|377) 0 .x|374|377) (car:pair .x|374|377))) .processed-actuals|337) .for-effect|337))))) (.loop|336 .formals|333 .actuals|333 .processed-formals|333 .processed-actuals|333 .for-effect|333))))) (begin (call.proc-set! .exp|8 .proc|221) (call.args-set! .exp|8 .args|221) .exp|8)))))))))))) (set! .delete-ignored-args!|7 (lambda (.l|407 .formals0|407 .calls|407) (let ((.formals1|410 (lambda.args .l|407))) (begin (let () (let ((.loop|416|418|421 (unspecified))) (begin (set! .loop|416|418|421 (lambda (.y1|411|412|422) (if (null? .y1|411|412|422) (if #f #f (unspecified)) (begin (begin #t (let ((.call|426 (let ((.x|465|468 .y1|411|412|422)) (begin (.check! (pair? .x|465|468) 0 .x|465|468) (car:pair .x|465|468))))) (let () (let ((.loop|427|432|435 (unspecified))) (begin (set! .loop|427|432|435 (lambda (.formals0|436 .formals1|436 .args|436 .newargs|436) (if (null? .formals0|436) (call.args-set! .call|426 (reverse .newargs|436)) (begin #t (.loop|427|432|435 (let ((.x|439|442 .formals0|436)) (begin (.check! (pair? .x|439|442) 1 .x|439|442) (cdr:pair .x|439|442))) (let ((.x|443|446 .formals1|436)) (begin (.check! (pair? .x|443|446) 1 .x|443|446) (cdr:pair .x|443|446))) (let ((.x|447|450 .args|436)) (begin (.check! (pair? .x|447|450) 1 .x|447|450) (cdr:pair .x|447|450))) (if (if (eq? (let ((.x|452|455 .formals1|436)) (begin (.check! (pair? .x|452|455) 0 .x|452|455) (car:pair .x|452|455))) name:ignored) (pair? (hashtable-get .variables|3 (let ((.x|457|460 .formals0|436)) (begin (.check! (pair? .x|457|460) 0 .x|457|460) (car:pair .x|457|460))))) #f) .newargs|436 (cons (let ((.x|461|464 .args|436)) (begin (.check! (pair? .x|461|464) 0 .x|461|464) (car:pair .x|461|464))) .newargs|436))))))) (.loop|427|432|435 .formals0|407 .formals1|410 (call.args .call|426) '())))))) (.loop|416|418|421 (let ((.x|469|472 .y1|411|412|422)) (begin (.check! (pair? .x|469|472) 1 .x|469|472) (cdr:pair .x|469|472)))))))) (.loop|416|418|421 .calls|407)))) (let () (let ((.loop|473|477|480 (unspecified))) (begin (set! .loop|473|477|480 (lambda (.formals0|481 .formals1|481 .formals2|481) (if (null? .formals0|481) (lambda.args-set! .l|407 (reverse .formals2|481)) (begin #t (.loop|473|477|480 (let ((.x|484|487 .formals0|481)) (begin (.check! (pair? .x|484|487) 1 .x|484|487) (cdr:pair .x|484|487))) (let ((.x|488|491 .formals1|481)) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))) (if (if (not (eq? (let ((.x|493|496 .formals0|481)) (begin (.check! (pair? .x|493|496) 0 .x|493|496) (car:pair .x|493|496))) (let ((.x|497|500 .formals1|481)) (begin (.check! (pair? .x|497|500) 0 .x|497|500) (car:pair .x|497|500))))) (if (eq? (let ((.x|502|505 .formals1|481)) (begin (.check! (pair? .x|502|505) 0 .x|502|505) (car:pair .x|502|505))) name:ignored) (pair? (hashtable-get .variables|3 (let ((.x|507|510 .formals0|481)) (begin (.check! (pair? .x|507|510) 0 .x|507|510) (car:pair .x|507|510))))) #f) #f) .formals2|481 (cons (let ((.x|511|514 .formals1|481)) (begin (.check! (pair? .x|511|514) 0 .x|511|514) (car:pair .x|511|514))) .formals2|481))))))) (.loop|473|477|480 .formals0|407 .formals1|410 '())))))))) (.fold!|7 .l|3) .changed?|6))))) (.constant-folding!|2 .l|1 .variables|1))))) 'constant-folding!))
+(let () (begin (set! a-normal-form-declaration (cons 'anf '())) 'a-normal-form-declaration))
+(let () (begin (set! a-normal-form (lambda (.e|1 . .rest|1) (let ((.complicated?|2 (unspecified)) (.normalize-let|2 (unspecified)) (.normalize-let-error|2 (unspecified)) (.unpermute|2 (unspecified)) (.permute|2 (unspecified)) (.anf-order-of-evaluation|2 (unspecified)) (.anf-call|2 (unspecified)) (.anf-conditional|2 (unspecified)) (.anf-assignment|2 (unspecified)) (.anf-lambda|2 (unspecified)) (.anf-sequential|2 (unspecified)) (.anf-make-let*|2 (unspecified)) (.anf-result|2 (unspecified)) (.anf-bind|2 (unspecified)) (.anf-bind-name|2 (unspecified)) (.anf-bind-dummy|2 (unspecified)) (.anf|2 (unspecified)) (.newtemp|2 (unspecified)) (.a-normal-form|2 (unspecified)) (.temp-counter|2 (unspecified)) (.anf:dummy|2 (unspecified)) (.temp-prefix|2 (unspecified))) (begin (set! .complicated?|2 (lambda (.exp|3) (let* ((.budget|6 10) (.complicated?|7 (unspecified))) (begin (set! .complicated?|7 (lambda (.exp|8) (begin (set! .budget|6 (- .budget|6 1)) (if (zero? .budget|6) #t (let ((.temp|9|12 (let ((.x|34|37 .exp|8)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (if (memv .temp|9|12 '(quote)) #f (if (memv .temp|9|12 '(lambda)) #f (if (memv .temp|9|12 '(set!)) (.complicated?|7 (assignment.rhs .exp|8)) (if (memv .temp|9|12 '(if)) (let ((.temp|17|20 (.complicated?|7 (if.test .exp|8)))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (.complicated?|7 (if.then .exp|8)))) (if .temp|21|24 .temp|21|24 (.complicated?|7 (if.else .exp|8)))))) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) #f (some? .complicated?|7 (begin.exprs .exp|8))) (let ((.proc|30 (call.proc .exp|8))) (if (if (variable? .proc|30) (if (integrate-usual-procedures) (prim-entry (variable.name .proc|30)) #f) #f) (some? .complicated?|7 (call.args .exp|8)) #t)))))))))))) (.complicated?|7 .exp|3))))) (set! .normalize-let|2 (lambda (.exp|38) (let ((.l|41 (call.proc .exp|38))) (let () (let ((.formals|47 (lambda.args .l|41)) (.args|47 (call.args .exp|38)) (.newformals|47 '()) (.newargs|47 '())) (let () (let ((.loop|50 (unspecified))) (begin (set! .loop|50 (lambda (.formals|51 .args|51 .newformals|51 .newargs|51) (if (null? .formals|51) (if (null? .args|51) (begin (lambda.args-set! .l|41 (reverse .newformals|51)) (call.args-set! .exp|38 (reverse .newargs|51))) (begin (.normalize-let-error|2 .exp|38) (.loop|50 (cons (.newtemp|2) '()) .args|51 .newformals|51 .newargs|51))) (if (pair? .formals|51) (if (pair? .args|51) (.loop|50 (let ((.x|55|58 .formals|51)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))) (let ((.x|59|62 .args|51)) (begin (.check! (pair? .x|59|62) 1 .x|59|62) (cdr:pair .x|59|62))) (cons (let ((.x|63|66 .formals|51)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))) .newformals|51) (cons (let ((.x|67|70 .args|51)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))) .newargs|51)) (begin (.normalize-let-error|2 .exp|38) (.loop|50 .formals|51 (cons (make-constant 0) .args|51) .newformals|51 .newargs|51))) (.loop|50 (cons .formals|51 '()) (cons (make-call-to-list .args|51) '()) .newformals|51 .newargs|51))))) (.loop|50 .formals|47 .args|47 .newformals|47 .newargs|47))))))))) (set! .normalize-let-error|2 (lambda (.exp|74) (if (issue-warnings) (begin (display "WARNING from compiler: ") (display "Wrong number of arguments ") (display "to lambda expression") (newline) (pretty-print (make-readable .exp|74) #t) (newline)) (unspecified)))) (set! .unpermute|2 (lambda (.things|75 .pi|75) (let* ((.v0|78 (list->vector .things|75)) (.v1|81 (make-vector (let ((.v|112|115 .v0|78)) (begin (.check! (vector? .v|112|115) 42 .v|112|115) (vector-length:vec .v|112|115))) '()))) (let () (let () (let ((.loop|85|88|91 (unspecified))) (begin (set! .loop|85|88|91 (lambda (.pi|92 .k|92) (if (null? .pi|92) (vector->list .v1|81) (begin (begin #t (let ((.v|95|98 .v1|81) (.i|95|98 (let ((.x|99|102 .pi|92)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.x|95|98 (let ((.v|103|106 .v0|78) (.i|103|106 .k|92)) (begin (.check! (fixnum? .i|103|106) 40 .v|103|106 .i|103|106) (.check! (vector? .v|103|106) 40 .v|103|106 .i|103|106) (.check! (<:fix:fix .i|103|106 (vector-length:vec .v|103|106)) 40 .v|103|106 .i|103|106) (.check! (>=:fix:fix .i|103|106 0) 40 .v|103|106 .i|103|106) (vector-ref:trusted .v|103|106 .i|103|106))))) (begin (.check! (fixnum? .i|95|98) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (vector? .v|95|98) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (<:fix:fix .i|95|98 (vector-length:vec .v|95|98)) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (>=:fix:fix .i|95|98 0) 41 .v|95|98 .i|95|98 .x|95|98) (vector-set!:trusted .v|95|98 .i|95|98 .x|95|98)))) (.loop|85|88|91 (let ((.x|107|110 .pi|92)) (begin (.check! (pair? .x|107|110) 1 .x|107|110) (cdr:pair .x|107|110))) (+ .k|92 1)))))) (.loop|85|88|91 .pi|75 0)))))))) (set! .permute|2 (lambda (.things|116 .pi|116) (let ((.v|119 (list->vector .things|116))) (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.i|140 (let ((.x|145|148 .y1|120|121|132)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))))) (let ((.v|141|144 .v|119) (.i|141|144 .i|140)) (begin (.check! (fixnum? .i|141|144) 40 .v|141|144 .i|141|144) (.check! (vector? .v|141|144) 40 .v|141|144 .i|141|144) (.check! (<:fix:fix .i|141|144 (vector-length:vec .v|141|144)) 40 .v|141|144 .i|141|144) (.check! (>=:fix:fix .i|141|144 0) 40 .v|141|144 .i|141|144) (vector-ref:trusted .v|141|144 .i|141|144)))) .results|120|124|132)))))) (.loop|125|128|131 .pi|116 '()))))))) (set! .anf-order-of-evaluation|2 (lambda (.exprs|149 .regvars|149 .for-primop?|149) (let ((.ordering|150 (unspecified))) (begin (set! .ordering|150 (lambda (.targets|151 .exprs|151 .alist|151) (let* ((.para|154 (parallel-assignment .targets|151 .alist|151 .exprs|151)) (.temp|155|158 .para|154)) (if .temp|155|158 .temp|155|158 (cons (let ((.x|160|163 .targets|151)) (begin (.check! (pair? .x|160|163) 0 .x|160|163) (car:pair .x|160|163))) (.ordering|150 (let ((.x|164|167 .targets|151)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (let ((.x|168|171 .exprs|151)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171))) .alist|151)))))) (if (parallel-assignment-optimization) (if (null? .exprs|149) '() (if (null? (let ((.x|174|177 .exprs|149)) (begin (.check! (pair? .x|174|177) 1 .x|174|177) (cdr:pair .x|174|177)))) '(0) (let* ((.contains-call?|181 #f) (.vexprs|184 (list->vector .exprs|149)) (.vindexes|187 (list->vector (iota (let ((.v|264|267 .vexprs|184)) (begin (.check! (vector? .v|264|267) 42 .v|264|267) (vector-length:vec .v|264|267)))))) (.contains-call?|190 #f) (.categories|193 (list->vector (let () (let ((.loop|240|243|246 (unspecified))) (begin (set! .loop|240|243|246 (lambda (.y1|235|236|247 .results|235|239|247) (if (null? .y1|235|236|247) (reverse .results|235|239|247) (begin #t (.loop|240|243|246 (let ((.x|251|254 .y1|235|236|247)) (begin (.check! (pair? .x|251|254) 1 .x|251|254) (cdr:pair .x|251|254))) (cons (let ((.e|255 (let ((.x|260|263 .y1|235|236|247)) (begin (.check! (pair? .x|260|263) 0 .x|260|263) (car:pair .x|260|263))))) (if (constant? .e|255) 2 (if (variable? .e|255) 2 (if (.complicated?|2 .e|255) (begin (set! .contains-call?|190 #t) 1) 0)))) .results|235|239|247)))))) (.loop|240|243|246 .exprs|149 '()))))))) (let () (if .contains-call?|190 (twobit-sort (lambda (.i|198 .j|198) (< (let ((.v|199|202 .categories|193) (.i|199|202 .i|198)) (begin (.check! (fixnum? .i|199|202) 40 .v|199|202 .i|199|202) (.check! (vector? .v|199|202) 40 .v|199|202 .i|199|202) (.check! (<:fix:fix .i|199|202 (vector-length:vec .v|199|202)) 40 .v|199|202 .i|199|202) (.check! (>=:fix:fix .i|199|202 0) 40 .v|199|202 .i|199|202) (vector-ref:trusted .v|199|202 .i|199|202))) (let ((.v|203|206 .categories|193) (.i|203|206 .j|198)) (begin (.check! (fixnum? .i|203|206) 40 .v|203|206 .i|203|206) (.check! (vector? .v|203|206) 40 .v|203|206 .i|203|206) (.check! (<:fix:fix .i|203|206 (vector-length:vec .v|203|206)) 40 .v|203|206 .i|203|206) (.check! (>=:fix:fix .i|203|206 0) 40 .v|203|206 .i|203|206) (vector-ref:trusted .v|203|206 .i|203|206))))) (iota (length .exprs|149))) (if .for-primop?|149 (reverse (iota (length .exprs|149))) (let* ((.targets|211 (iota (length .exprs|149))) (.pairup|212 (unspecified))) (begin (set! .pairup|212 (lambda (.regvars|213 .targets|213) (if (let ((.temp|214|217 (null? .targets|213))) (if .temp|214|217 .temp|214|217 (null? .regvars|213))) '() (cons (cons (let ((.x|219|222 .regvars|213)) (begin (.check! (pair? .x|219|222) 0 .x|219|222) (car:pair .x|219|222))) (let ((.x|223|226 .targets|213)) (begin (.check! (pair? .x|223|226) 0 .x|223|226) (car:pair .x|223|226)))) (.pairup|212 (let ((.x|227|230 .regvars|213)) (begin (.check! (pair? .x|227|230) 1 .x|227|230) (cdr:pair .x|227|230))) (let ((.x|231|234 .targets|213)) (begin (.check! (pair? .x|231|234) 1 .x|231|234) (cdr:pair .x|231|234)))))))) (.ordering|150 .targets|211 .exprs|149 (.pairup|212 .regvars|149 .targets|211)))))))))) (iota (length .exprs|149))))))) (set! .anf-call|2 (lambda (.e|268 .bindings|268 .regvars|268) (let* ((.proc|271 (call.proc .e|268)) (.args|274 (call.args .e|268))) (let () (let ((.let-loop|279 (unspecified)) (.loop|279 (unspecified))) (begin (set! .let-loop|279 (lambda (.exprs|280 .bindings|280 .regvars|280 .vars|280) (if (null? .exprs|280) (if (null? (lambda.defs .proc|271)) (.anf|2 (lambda.body .proc|271) .bindings|280 .regvars|280) (let ((.bindings|283 (.anf-bind|2 (make-lambda '() (lambda.defs .proc|271) '() '() '() (cons a-normal-form-declaration (lambda.decls .proc|271)) (lambda.doc .proc|271) (lambda.body .proc|271)) .bindings|280 '()))) (.anf-bind-dummy|2 (make-call (.anf-result|2 .bindings|283) '()) .bindings|283))) (.let-loop|279 (let ((.x|284|287 .exprs|280)) (begin (.check! (pair? .x|284|287) 1 .x|284|287) (cdr:pair .x|284|287))) (.anf-bind-name|2 (let ((.x|288|291 .vars|280)) (begin (.check! (pair? .x|288|291) 0 .x|288|291) (car:pair .x|288|291))) (let ((.x|292|295 .exprs|280)) (begin (.check! (pair? .x|292|295) 0 .x|292|295) (car:pair .x|292|295))) .bindings|280 .regvars|280) .regvars|280 (let ((.x|296|299 .vars|280)) (begin (.check! (pair? .x|296|299) 1 .x|296|299) (cdr:pair .x|296|299))))))) (set! .loop|279 (lambda (.exprs|300 .bindings|300 .names|300 .rename-always?|300) (if (null? .exprs|300) (values .bindings|300 (reverse .names|300)) (let ((.e|303 (let ((.x|332|335 .exprs|300)) (begin (.check! (pair? .x|332|335) 0 .x|332|335) (car:pair .x|332|335))))) (if (let ((.temp|304|307 .rename-always?|300)) (if .temp|304|307 .temp|304|307 (not (let ((.temp|309|312 (constant? .e|303))) (if .temp|309|312 .temp|309|312 (variable? .e|303)))))) (let ((.bindings|316 (.anf-bind|2 (let ((.x|324|327 .exprs|300)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327))) .bindings|300 .regvars|268))) (let () (.loop|279 (let ((.x|320|323 .exprs|300)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) .bindings|316 (cons (.anf-result|2 .bindings|316) .names|300) .rename-always?|300))) (.loop|279 (let ((.x|328|331 .exprs|300)) (begin (.check! (pair? .x|328|331) 1 .x|328|331) (cdr:pair .x|328|331))) .bindings|300 (cons .e|303 .names|300) .rename-always?|300)))))) (if (lambda? .proc|271) (let ((.formals|338 (lambda.args .proc|271))) (if (list? .formals|338) (let* ((.pi|341 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f)) (.exprs|344 (.permute|2 .args|274 .pi|341)) (.names|347 (.permute|2 (lambda.args .proc|271) .pi|341))) (let () (.let-loop|279 (reverse .exprs|344) .bindings|268 .regvars|268 (reverse .names|347)))) (.anf-call|2 (.normalize-let|2 .e|268) .bindings|268 .regvars|268))) (if (not (variable? .proc|271)) (let ((.pi|354 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|354) .bindings|268 '() #t)) (lambda (.bindings|356 .names|356) (let ((.bindings|359 (.anf-bind|2 .proc|271 .bindings|356 .regvars|268))) (.anf-bind-dummy|2 (make-call (.anf-result|2 .bindings|359) (.unpermute|2 .names|356 .pi|354)) .bindings|359))))) (if (if (integrate-usual-procedures) (prim-entry (variable.name .proc|271)) #f) (let ((.pi|365 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #t))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|365) .bindings|268 '() #t)) (lambda (.bindings|367 .names|367) (.anf-bind-dummy|2 (make-call .proc|271 (.unpermute|2 .names|367 .pi|365)) .bindings|367)))) (if (memq (variable.name .proc|271) .regvars|268) (let* ((.exprs|371 (cons .proc|271 .args|274)) (.pi|374 (.anf-order-of-evaluation|2 .exprs|371 (cons name:ignored .regvars|268) #f))) (let () (call-with-values (lambda () (.loop|279 (.permute|2 .exprs|371 .pi|374) .bindings|268 '() #t)) (lambda (.bindings|379 .names|379) (let ((.names|382 (.unpermute|2 .names|379 .pi|374))) (.anf-bind-dummy|2 (make-call (let ((.x|383|386 .names|382)) (begin (.check! (pair? .x|383|386) 0 .x|383|386) (car:pair .x|383|386))) (let ((.x|387|390 .names|382)) (begin (.check! (pair? .x|387|390) 1 .x|387|390) (cdr:pair .x|387|390)))) .bindings|379)))))) (let ((.pi|394 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|394) .bindings|268 '() #t)) (lambda (.bindings|396 .names|396) (.anf-bind-dummy|2 (make-call .proc|271 (.unpermute|2 .names|396 .pi|394)) .bindings|396)))))))))))))) (set! .anf-conditional|2 (lambda (.e|397 .bindings|397 .regvars|397) (let ((.e0|400 (if.test .e|397)) (.e1|400 (if.then .e|397)) (.e2|400 (if.else .e|397))) (if (variable? .e0|400) (let ((.e1|403 (.anf-make-let*|2 (.anf|2 .e1|400 '() .regvars|397))) (.e2|403 (.anf-make-let*|2 (.anf|2 .e2|400 '() .regvars|397)))) (.anf-bind-dummy|2 (make-conditional .e0|400 .e1|403 .e2|403) .bindings|397)) (let* ((.bindings|406 (.anf-bind|2 .e0|400 .bindings|397 .regvars|397)) (.e1|409 (.anf-make-let*|2 (.anf|2 .e1|400 '() .regvars|397))) (.e2|412 (.anf-make-let*|2 (.anf|2 .e2|400 '() .regvars|397)))) (let () (.anf-bind-dummy|2 (make-conditional (.anf-result|2 .bindings|406) .e1|409 .e2|412) .bindings|406))))))) (set! .anf-assignment|2 (lambda (.e|416 .bindings|416 .regvars|416) (let ((.i|419 (assignment.lhs .e|416)) (.e1|419 (assignment.rhs .e|416))) (if (variable? .e1|419) (.anf-bind-dummy|2 .e|416 .bindings|416) (let* ((.bindings|422 (.anf-bind|2 .e1|419 .bindings|416 .regvars|416)) (.t1|425 (.anf-result|2 .bindings|422))) (let () (.anf-bind-dummy|2 (make-assignment .i|419 .t1|425) .bindings|422))))))) (set! .anf-lambda|2 (lambda (.l|429 .bindings|429 .regvars|429) (.anf-bind-dummy|2 (make-lambda (lambda.args .l|429) (let () (let ((.loop|435|438|441 (unspecified))) (begin (set! .loop|435|438|441 (lambda (.y1|430|431|442 .results|430|434|442) (if (null? .y1|430|431|442) (reverse .results|430|434|442) (begin #t (.loop|435|438|441 (let ((.x|446|449 .y1|430|431|442)) (begin (.check! (pair? .x|446|449) 1 .x|446|449) (cdr:pair .x|446|449))) (cons (let ((.def|450 (let ((.x|451|454 .y1|430|431|442)) (begin (.check! (pair? .x|451|454) 0 .x|451|454) (car:pair .x|451|454))))) (make-definition (def.lhs .def|450) (.a-normal-form|2 (def.rhs .def|450)))) .results|430|434|442)))))) (.loop|435|438|441 (lambda.defs .l|429) '())))) '() '() '() (cons a-normal-form-declaration (lambda.decls .l|429)) (lambda.doc .l|429) (.anf-make-let*|2 (.anf|2 (lambda.body .l|429) '() (make-null-terminated (lambda.args .l|429))))) .bindings|429))) (set! .anf-sequential|2 (lambda (.e|455 .bindings|455 .regvars|455) (let () (let ((.loop|456|459|462 (unspecified))) (begin (set! .loop|456|459|462 (lambda (.bindings|463 .exprs|463) (if (null? (let ((.x|465|468 .exprs|463)) (begin (.check! (pair? .x|465|468) 1 .x|465|468) (cdr:pair .x|465|468)))) (.anf|2 (let ((.x|469|472 .exprs|463)) (begin (.check! (pair? .x|469|472) 0 .x|469|472) (car:pair .x|469|472))) .bindings|463 .regvars|455) (begin #t (.loop|456|459|462 (.anf-bind|2 (let ((.x|474|477 .exprs|463)) (begin (.check! (pair? .x|474|477) 0 .x|474|477) (car:pair .x|474|477))) .bindings|463 .regvars|455) (let ((.x|478|481 .exprs|463)) (begin (.check! (pair? .x|478|481) 1 .x|478|481) (cdr:pair .x|478|481)))))))) (.loop|456|459|462 .bindings|455 (begin.exprs .e|455))))))) (set! .anf-make-let*|2 (lambda (.bindings|482) (let ((.loop|483 (unspecified))) (begin (set! .loop|483 (lambda (.bindings|484 .body|484) (if (null? .bindings|484) .body|484 (let ((.t1|487 (let ((.x|495|498 (let ((.x|499|502 .bindings|484)) (begin (.check! (pair? .x|499|502) 0 .x|499|502) (car:pair .x|499|502))))) (begin (.check! (pair? .x|495|498) 0 .x|495|498) (car:pair .x|495|498)))) (.e1|487 (let ((.x|504|507 (let ((.x|508|511 (let ((.x|512|515 .bindings|484)) (begin (.check! (pair? .x|512|515) 0 .x|512|515) (car:pair .x|512|515))))) (begin (.check! (pair? .x|508|511) 1 .x|508|511) (cdr:pair .x|508|511))))) (begin (.check! (pair? .x|504|507) 0 .x|504|507) (car:pair .x|504|507))))) (.loop|483 (let ((.x|488|491 .bindings|484)) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))) (make-call (make-lambda (cons .t1|487 '()) '() '() '() '() (cons a-normal-form-declaration '()) '() .body|484) (cons .e1|487 '()))))))) (.loop|483 (let ((.x|516|519 .bindings|482)) (begin (.check! (pair? .x|516|519) 1 .x|516|519) (cdr:pair .x|516|519))) (let ((.x|521|524 (let ((.x|525|528 (let ((.x|529|532 .bindings|482)) (begin (.check! (pair? .x|529|532) 0 .x|529|532) (car:pair .x|529|532))))) (begin (.check! (pair? .x|525|528) 1 .x|525|528) (cdr:pair .x|525|528))))) (begin (.check! (pair? .x|521|524) 0 .x|521|524) (car:pair .x|521|524)))))))) (set! .anf-result|2 (lambda (.bindings|533) (make-variable (let ((.x|534|537 (let ((.x|538|541 .bindings|533)) (begin (.check! (pair? .x|538|541) 0 .x|538|541) (car:pair .x|538|541))))) (begin (.check! (pair? .x|534|537) 0 .x|534|537) (car:pair .x|534|537)))))) (set! .anf-bind|2 (lambda (.e|542 .bindings|542 .regvars|542) (let ((.bindings|545 (.anf|2 .e|542 .bindings|542 .regvars|542))) (cons (let* ((.t1|546|549 (.newtemp|2)) (.t2|546|552 (cons (let ((.x|558|561 (let ((.x|562|565 (let ((.x|566|569 .bindings|545)) (begin (.check! (pair? .x|566|569) 0 .x|566|569) (car:pair .x|566|569))))) (begin (.check! (pair? .x|562|565) 1 .x|562|565) (cdr:pair .x|562|565))))) (begin (.check! (pair? .x|558|561) 0 .x|558|561) (car:pair .x|558|561))) '()))) (let () (cons .t1|546|549 .t2|546|552))) (let ((.x|570|573 .bindings|545)) (begin (.check! (pair? .x|570|573) 1 .x|570|573) (cdr:pair .x|570|573))))))) (set! .anf-bind-name|2 (lambda (.name|574 .e|574 .bindings|574 .regvars|574) (let ((.bindings|577 (.anf|2 .e|574 .bindings|574 .regvars|574))) (cons (let* ((.t1|578|581 .name|574) (.t2|578|584 (cons (let ((.x|590|593 (let ((.x|594|597 (let ((.x|598|601 .bindings|577)) (begin (.check! (pair? .x|598|601) 0 .x|598|601) (car:pair .x|598|601))))) (begin (.check! (pair? .x|594|597) 1 .x|594|597) (cdr:pair .x|594|597))))) (begin (.check! (pair? .x|590|593) 0 .x|590|593) (car:pair .x|590|593))) '()))) (let () (cons .t1|578|581 .t2|578|584))) (let ((.x|602|605 .bindings|577)) (begin (.check! (pair? .x|602|605) 1 .x|602|605) (cdr:pair .x|602|605))))))) (set! .anf-bind-dummy|2 (lambda (.e|606 .bindings|606) (cons (let* ((.t1|607|610 .anf:dummy|2) (.t2|607|613 (cons .e|606 '()))) (let () (cons .t1|607|610 .t2|607|613))) .bindings|606))) (set! .anf|2 (lambda (.e|618 .bindings|618 .regvars|618) (let ((.temp|619|622 (let ((.x|629|632 .e|618)) (begin (.check! (pair? .x|629|632) 0 .x|629|632) (car:pair .x|629|632))))) (if (memv .temp|619|622 '(quote)) (.anf-bind-dummy|2 .e|618 .bindings|618) (if (memv .temp|619|622 '(begin)) (if (variable? .e|618) (.anf-bind-dummy|2 .e|618 .bindings|618) (.anf-sequential|2 .e|618 .bindings|618 .regvars|618)) (if (memv .temp|619|622 '(lambda)) (.anf-lambda|2 .e|618 .bindings|618 .regvars|618) (if (memv .temp|619|622 '(set!)) (.anf-assignment|2 .e|618 .bindings|618 .regvars|618) (if (memv .temp|619|622 '(if)) (.anf-conditional|2 .e|618 .bindings|618 .regvars|618) (.anf-call|2 .e|618 .bindings|618 .regvars|618))))))))) (set! .newtemp|2 (lambda () (begin (set! .temp-counter|2 (+ .temp-counter|2 1)) (string->symbol (string-append .temp-prefix|2 (number->string .temp-counter|2)))))) (set! .a-normal-form|2 (lambda (.e|634) (.anf-make-let*|2 (.anf|2 .e|634 '() '())))) (set! .temp-counter|2 0) (set! .anf:dummy|2 (string->symbol "RESULT")) (set! .temp-prefix|2 (if (let ((.temp|635|638 (null? .rest|1))) (if .temp|635|638 .temp|635|638 (not (string? (let ((.x|640|643 .rest|1)) (begin (.check! (pair? .x|640|643) 0 .x|640|643) (car:pair .x|640|643))))))) (string-append renaming-prefix "T") (let ((.x|644|647 .rest|1)) (begin (.check! (pair? .x|644|647) 0 .x|644|647) (car:pair .x|644|647))))) (.a-normal-form|2 .e|1))))) 'a-normal-form))
+(let () (begin (set! post-simplify-anf (lambda (.l0|1 .t1|1 .e0|1 .e1|1 .free|1 .regbindings|1 .l2|1) (let ((.post-simplify-anf|2 0)) (begin (set! .post-simplify-anf|2 (lambda (.l0|3 .t1|3 .e0|3 .e1|3 .free|3 .regbindings|3 .l2|3) (let ((.return-normally|4 (unspecified))) (begin (set! .return-normally|4 (lambda () (values (make-call .l0|3 (cons .e1|3 '())) .free|3 .regbindings|3))) (.return-normally|4))))) (.post-simplify-anf|2 .l0|1 .t1|1 .e0|1 .e1|1 .free|1 .regbindings|1 .l2|1))))) 'post-simplify-anf))
+(let () (begin (set! argument-registers (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.n|8 .regs|8) (if (zero? .n|8) .regs|8 (begin #t (.loop|1|4|7 (- .n|8 1) (cons (string->symbol (string-append ".REG" (number->string .n|8))) .regs|8)))))) (.loop|1|4|7 (- *nregs* 2) '()))))) 'argument-registers))
+(let () (begin (set! intraprocedural-commoning (lambda (.e|1 . .flags|1) (let ((.debugging?|2 (unspecified)) (.commoning?|2 (unspecified)) (.target-registers?|2 (unspecified))) (begin (set! .debugging?|2 #f) (set! .commoning?|2 (let ((.temp|3|6 (null? .flags|1))) (if .temp|3|6 .temp|3|6 (memq 'commoning .flags|1)))) (set! .target-registers?|2 (let ((.temp|8|11 (null? .flags|1))) (if .temp|8|11 .temp|8|11 (memq 'target-registers .flags|1)))) (call-with-current-continuation (lambda (.return|13) (let ((.scan-body|14 (unspecified)) (.error|14 (unspecified))) (begin (set! .scan-body|14 (lambda (.e|15 .env|15 .available|15 .regvars|15) (let ((.scan-rhs|16 (unspecified)) (.scan-defs|16 (unspecified)) (.scan-let0|16 (unspecified)) (.scan-binding-phase3|16 (unspecified)) (.scan-binding-phase2|16 (unspecified)) (.scan-binding|16 (unspecified)) (.scan|16 (unspecified)) (.available-add!|16 (unspecified)) (.global?|16 (unspecified)) (.environment-lookup|16 (unspecified)) (.environment-extend*|16 (unspecified)) (.environment-extend|16 (unspecified)) (.make-empty-environment|16 (unspecified)) (.abandon-expression!|16 (unspecified)) (.used-variable!|16 (unspecified)) (.closed-over-local-variable!|16 (unspecified)) (.adjust-local-variable!|16 (unspecified)) (.used-local-variable!|16 (unspecified)) (.record-local-variable!|16 (unspecified)) (.local-variable-used-once?|16 (unspecified)) (.local-variable-not-used?|16 (unspecified)) (.local-variable?|16 (unspecified)) (.local-variables|16 (unspecified))) (begin (set! .scan-rhs|16 (lambda (.e|17 .env|17 .available|17) (if (constant? .e|17) (values .e|17 (empty-set) '()) (if (variable? .e|17) (let* ((.name|22 (variable.name .e|17)) (.enew|25 (if .commoning?|2 (if (.global?|16 .name|22) (let ((.t|34 (available-expression .available|17 .e|17))) (if .t|34 (make-variable .t|34) #f)) (available-variable .available|17 .name|22)) #f))) (let () (if .enew|25 (.scan-rhs|16 .enew|25 .env|17 .available|17) (begin (.used-variable!|16 .name|22) (values .e|17 (cons .name|22 '()) '()))))) (if (lambda? .e|17) (let* ((.formals|38 (make-null-terminated (lambda.args .e|17))) (.env|41 (.environment-extend*|16 (.environment-extend*|16 .env|17 .formals|38) (let () (let ((.loop|87|90|93 (unspecified))) (begin (set! .loop|87|90|93 (lambda (.y1|82|83|94 .results|82|86|94) (if (null? .y1|82|83|94) (reverse .results|82|86|94) (begin #t (.loop|87|90|93 (let ((.x|98|101 .y1|82|83|94)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) (cons (def.lhs (let ((.x|102|105 .y1|82|83|94)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) .results|82|86|94)))))) (.loop|87|90|93 (lambda.defs .e|17) '())))))) (.fdefs|44 (.scan-defs|16 .e|17 .env|41 .available|17))) (let () (call-with-values (lambda () (let ((.available|51 (copy-available-table .available|17))) (begin (available-kill! .available|51 available:killer:all) (.scan-body|14 (lambda.body .e|17) .env|41 .available|51 .formals|38)))) (lambda (.e0|52 .f0|52 .regbindings0|52) (call-with-values (lambda () (wrap-with-register-bindings .regbindings0|52 .e0|52 .f0|52)) (lambda (.e0|54 .f0|54) (begin (lambda.body-set! .e|17 .e0|54) (let ((.f|57 (union .fdefs|44 .f0|54))) (begin (let () (let ((.loop|63|65|68 (unspecified))) (begin (set! .loop|63|65|68 (lambda (.y1|58|59|69) (if (null? .y1|58|59|69) (if #f #f (unspecified)) (begin (begin #t (let ((.x|73 (let ((.x|74|77 .y1|58|59|69)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77))))) (.closed-over-local-variable!|16 .x|73))) (.loop|63|65|68 (let ((.x|78|81 .y1|58|59|69)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81)))))))) (.loop|63|65|68 .f|57)))) (lambda.f-set! .e|17 .f|57) (lambda.g-set! .e|17 .f|57) (values .e|17 (difference .f|57 (make-null-terminated (lambda.args .e|17))) '())))))))))) (if (conditional? .e|17) (let ((.e0|109 (if.test .e|17)) (.e1|109 (if.then .e|17)) (.e2|109 (if.else .e|17))) (if (constant? .e0|109) (let ((.e1|112 (if (constant.value .e0|109) .e1|109 .e2|109))) (call-with-values (lambda () (.scan|16 .e1|112 .env|17 .available|17)) (lambda (.e1|114 .f1|114 .regbindings1|114) (if (let ((.temp|116|119 (not (call? .e1|114)))) (if .temp|116|119 .temp|116|119 (not (lambda? (call.proc .e1|114))))) (values .e1|114 .f1|114 .regbindings1|114) (values (make-conditional (make-constant #t) .e1|114 (make-constant 0)) .f1|114 .regbindings1|114))))) (call-with-values (lambda () (.scan|16 .e0|109 .env|17 .available|17)) (lambda (.e0|123 .f0|123 .regbindings0|123) (begin (if (not (null? .regbindings0|123)) (.error|14 'scan-rhs 'if) (unspecified)) (if (not (eq? .e0|123 (if.test .e|17))) (.scan-rhs|16 (make-conditional .e0|123 .e1|109 .e2|109) .env|17 .available|17) (let ((.available1|126 (copy-available-table .available|17)) (.available2|126 (copy-available-table .available|17))) (begin (if (variable? .e0|123) (let ((.t0|129 (variable.name .e0|123))) (.available-add!|16 .available2|126 .t0|129 (make-constant #f))) (.error|14 (make-readable .e|17 #t))) (call-with-values (lambda () (.scan|16 .e1|109 .env|17 .available1|126)) (lambda (.e1|131 .f1|131 .regbindings1|131) (call-with-values (lambda () (wrap-with-register-bindings .regbindings1|131 .e1|131 .f1|131)) (lambda (.e1|133 .f1|133) (call-with-values (lambda () (.scan|16 .e2|109 .env|17 .available2|126)) (lambda (.e2|135 .f2|135 .regbindings2|135) (call-with-values (lambda () (wrap-with-register-bindings .regbindings2|135 .e2|135 .f2|135)) (lambda (.e2|137 .f2|137) (let ((.e|140 (make-conditional .e0|123 .e1|133 .e2|137)) (.f|140 (union .f0|123 .f1|133 .f2|137))) (begin (available-intersect! .available|17 .available1|126 .available2|126) (values .e|140 .f|140 '()))))))))))))))))))) (if (assignment? .e|17) (call-with-values (lambda () (.scan-rhs|16 (assignment.rhs .e|17) .env|17 .available|17)) (lambda (.e1|143 .f1|143 .regbindings1|143) (begin (if (not (null? .regbindings1|143)) (.error|14 'scan-rhs 'set!) (unspecified)) (available-kill! .available|17 available:killer:globals) (values (make-assignment (assignment.lhs .e|17) .e1|143) (union (cons (assignment.lhs .e|17) '()) .f1|143) '())))) (if (begin? .e|17) (.error|14 'scan-rhs 'begin) (if (real-call? .e|17) (let* ((.e0|149 (call.proc .e|17)) (.args|152 (call.args .e|17)) (.regcontents|155 (append .regvars|15 (let () (let ((.loop|308|311|314 (unspecified))) (begin (set! .loop|308|311|314 (lambda (.y1|303|304|315 .results|303|307|315) (if (null? .y1|303|304|315) (reverse .results|303|307|315) (begin #t (.loop|308|311|314 (let ((.x|319|322 .y1|303|304|315)) (begin (.check! (pair? .x|319|322) 1 .x|319|322) (cdr:pair .x|319|322))) (cons (let ((.x|323 (let ((.x|324|327 .y1|303|304|315)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327))))) #f) .results|303|307|315)))))) (.loop|308|311|314 .args|152 '()))))))) (let () (let ((.args|161 .args|152) (.regs|161 argument-registers) (.regcontents|161 .regcontents|155) (.newargs|161 '()) (.regbindings|161 '()) (.f|161 (if (variable? .e0|149) (let ((.f|301 (variable.name .e0|149))) (begin (.used-variable!|16 .f|301) (cons .f|301 '()))) (empty-set)))) (let () (let ((.loop|164 (unspecified))) (begin (set! .loop|164 (lambda (.args|165 .regs|165 .regcontents|165 .newargs|165 .regbindings|165 .f|165) (if (null? .args|165) (begin (available-kill! .available|17 available:killer:all) (values (make-call .e0|149 (reverse .newargs|165)) .f|165 .regbindings|165)) (if (null? .regs|165) (let ((.arg|170 (let ((.x|183|186 .args|165)) (begin (.check! (pair? .x|183|186) 0 .x|183|186) (car:pair .x|183|186))))) (.loop|164 (let ((.x|171|174 .args|165)) (begin (.check! (pair? .x|171|174) 1 .x|171|174) (cdr:pair .x|171|174))) '() (let ((.x|175|178 .regcontents|165)) (begin (.check! (pair? .x|175|178) 1 .x|175|178) (cdr:pair .x|175|178))) (cons .arg|170 .newargs|165) .regbindings|165 (if (variable? .arg|170) (let ((.name|181 (variable.name .arg|170))) (begin (.used-variable!|16 .name|181) (union (cons .name|181 '()) .f|165))) .f|165))) (if (if .commoning?|2 (if (variable? (let ((.x|190|193 .args|165)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193)))) (available-variable .available|17 (variable.name (let ((.x|195|198 .args|165)) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))))) #f) #f) (let* ((.name|201 (variable.name (let ((.x|212|215 .args|165)) (begin (.check! (pair? .x|212|215) 0 .x|212|215) (car:pair .x|212|215))))) (.enew|204 (available-variable .available|17 .name|201))) (let () (.loop|164 (cons .enew|204 (let ((.x|208|211 .args|165)) (begin (.check! (pair? .x|208|211) 1 .x|208|211) (cdr:pair .x|208|211)))) .regs|165 .regcontents|165 .newargs|165 .regbindings|165 .f|165))) (if (if .target-registers?|2 (if (variable? (let ((.x|219|222 .args|165)) (begin (.check! (pair? .x|219|222) 0 .x|219|222) (car:pair .x|219|222)))) (let* ((.x|226 (variable.name (let ((.x|238|241 .args|165)) (begin (.check! (pair? .x|238|241) 0 .x|238|241) (car:pair .x|238|241))))) (.temp|227|230 (.local-variable-not-used?|16 .x|226))) (if .temp|227|230 .temp|227|230 (if (memq .x|226 .regvars|15) (not (eq? .x|226 (let ((.x|234|237 .regcontents|165)) (begin (.check! (pair? .x|234|237) 0 .x|234|237) (car:pair .x|234|237))))) #f))) #f) #f) (let* ((.x|244 (variable.name (let ((.x|271|274 .args|165)) (begin (.check! (pair? .x|271|274) 0 .x|271|274) (car:pair .x|271|274))))) (.r|247 (let ((.x|267|270 .regs|165)) (begin (.check! (pair? .x|267|270) 0 .x|267|270) (car:pair .x|267|270)))) (.newarg|250 (make-variable .r|247))) (let () (begin (.used-variable!|16 .x|244) (.loop|164 (let ((.x|254|257 .args|165)) (begin (.check! (pair? .x|254|257) 1 .x|254|257) (cdr:pair .x|254|257))) (let ((.x|258|261 .regs|165)) (begin (.check! (pair? .x|258|261) 1 .x|258|261) (cdr:pair .x|258|261))) (let ((.x|262|265 .regcontents|165)) (begin (.check! (pair? .x|262|265) 1 .x|262|265) (cdr:pair .x|262|265))) (cons .newarg|250 .newargs|165) (cons (make-regbinding .r|247 .x|244 .newarg|250) .regbindings|165) (union (cons .r|247 '()) .f|165))))) (let ((.e1|278 (let ((.x|295|298 .args|165)) (begin (.check! (pair? .x|295|298) 0 .x|295|298) (car:pair .x|295|298))))) (.loop|164 (let ((.x|279|282 .args|165)) (begin (.check! (pair? .x|279|282) 1 .x|279|282) (cdr:pair .x|279|282))) (let ((.x|283|286 .regs|165)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))) (let ((.x|287|290 .regcontents|165)) (begin (.check! (pair? .x|287|290) 1 .x|287|290) (cdr:pair .x|287|290))) (cons .e1|278 .newargs|165) .regbindings|165 (if (variable? .e1|278) (let ((.name|293 (variable.name .e1|278))) (begin (.used-variable!|16 .name|293) (union (cons .name|293 '()) .f|165))) .f|165))))))))) (.loop|164 .args|161 .regs|161 .regcontents|161 .newargs|161 .regbindings|161 .f|161))))))) (if (call? .e|17) (let* ((.e0|331 (call.proc .e|17)) (.f0|334 (variable.name .e0|331))) (let () (let ((.args|340 (call.args .e|17)) (.newargs|340 '()) (.f|340 (cons .f0|334 '()))) (let () (let ((.loop|343 (unspecified))) (begin (set! .loop|343 (lambda (.args|344 .newargs|344 .f|344) (if (null? .args|344) (let* ((.e|348 (make-call .e0|331 (reverse .newargs|344))) (.t|351 (if .commoning?|2 (available-expression .available|17 .e|348) #f))) (let () (if .t|351 (begin (.abandon-expression!|16 .e|348) (.scan-rhs|16 (make-variable .t|351) .env|17 .available|17)) (begin (available-kill! .available|17 (prim-kills (prim-entry .f0|334))) (if (eq? .f0|334 name:check!) (let ((.x|358 (let ((.x|363|366 (call.args .e|348))) (begin (.check! (pair? .x|363|366) 0 .x|363|366) (car:pair .x|363|366))))) (if (not (runtime-safety-checking)) (begin (.abandon-expression!|16 .e|348) (.scan-rhs|16 .x|358 .env|17 .available|17)) (if (variable? .x|358) (begin (.available-add!|16 .available|17 (variable.name .x|358) (make-constant #t)) (values .e|348 .f|344 '())) (if (constant.value .x|358) (begin (.abandon-expression!|16 .e|348) (values .x|358 '() '())) (begin (declaration-error .e|348) (values .e|348 .f|344 '())))))) (values .e|348 .f|344 '())))))) (if (variable? (let ((.x|371|374 .args|344)) (begin (.check! (pair? .x|371|374) 0 .x|371|374) (car:pair .x|371|374)))) (let* ((.e1|377 (let ((.x|402|405 .args|344)) (begin (.check! (pair? .x|402|405) 0 .x|402|405) (car:pair .x|402|405)))) (.x|380 (variable.name .e1|377)) (.enew|383 (if .commoning?|2 (available-variable .available|17 .x|380) #f))) (let () (if .enew|383 (.loop|343 (cons .enew|383 (let ((.x|387|390 .args|344)) (begin (.check! (pair? .x|387|390) 1 .x|387|390) (cdr:pair .x|387|390)))) .newargs|344 (remq .x|380 .f|344)) (begin (.used-variable!|16 .x|380) (.loop|343 (let ((.x|391|394 .args|344)) (begin (.check! (pair? .x|391|394) 1 .x|391|394) (cdr:pair .x|391|394))) (cons (let ((.x|395|398 .args|344)) (begin (.check! (pair? .x|395|398) 0 .x|395|398) (car:pair .x|395|398))) .newargs|344) (union (cons .x|380 '()) .f|344)))))) (.loop|343 (let ((.x|407|410 .args|344)) (begin (.check! (pair? .x|407|410) 1 .x|407|410) (cdr:pair .x|407|410))) (cons (let ((.x|411|414 .args|344)) (begin (.check! (pair? .x|411|414) 0 .x|411|414) (car:pair .x|411|414))) .newargs|344) .f|344))))) (.loop|343 .args|340 .newargs|340 .f|340))))))) (.error|14 'scan-rhs (make-readable .e|17)))))))))))) (set! .scan-defs|16 (lambda (.l|417 .env|417 .available|417) (let ((.defs|420 (lambda.defs .l|417)) (.newdefs|420 '()) (.fdefs|420 '())) (let () (let ((.loop|423 (unspecified))) (begin (set! .loop|423 (lambda (.defs|424 .newdefs|424 .fdefs|424) (if (null? .defs|424) (begin (lambda.defs-set! .l|417 (reverse .newdefs|424)) .fdefs|424) (let ((.def|427 (let ((.x|470|473 .defs|424)) (begin (.check! (pair? .x|470|473) 0 .x|470|473) (car:pair .x|470|473))))) (call-with-values (lambda () (let* ((.ldef|431 (def.rhs .def|427)) (.lformals|434 (make-null-terminated (lambda.args .ldef|431))) (.lenv|437 (.environment-extend*|16 (.environment-extend*|16 .env|417 .lformals|434) (let () (let ((.loop|446|449|452 (unspecified))) (begin (set! .loop|446|449|452 (lambda (.y1|441|442|453 .results|441|445|453) (if (null? .y1|441|442|453) (reverse .results|441|445|453) (begin #t (.loop|446|449|452 (let ((.x|457|460 .y1|441|442|453)) (begin (.check! (pair? .x|457|460) 1 .x|457|460) (cdr:pair .x|457|460))) (cons (def.lhs (let ((.x|461|464 .y1|441|442|453)) (begin (.check! (pair? .x|461|464) 0 .x|461|464) (car:pair .x|461|464)))) .results|441|445|453)))))) (.loop|446|449|452 (lambda.defs .ldef|431) '()))))))) (let () (.scan|16 .ldef|431 .lenv|437 .available|417)))) (lambda (.rhs|465 .frhs|465 .empty|465) (begin (if (not (null? .empty|465)) (.error|14 'scan-binding 'def) (unspecified)) (.loop|423 (let ((.x|466|469 .defs|424)) (begin (.check! (pair? .x|466|469) 1 .x|466|469) (cdr:pair .x|466|469))) (cons (make-definition (def.lhs .def|427) .rhs|465) .newdefs|424) (union .frhs|465 .fdefs|424))))))))) (.loop|423 .defs|420 .newdefs|420 .fdefs|420))))))) (set! .scan-let0|16 (lambda (.e|474 .env|474 .available|474) (let ((.l|477 (call.proc .e|474))) (if (simple-lambda? .l|477) (.scan|16 (lambda.body .l|477) .env|474 .available|474) (let ((.t1|480 (make-variable name:ignored))) (begin (lambda.args-set! .l|477 (cons .t1|480 '())) (call-with-values (lambda () (.scan|16 (make-call .l|477 (cons (make-constant 0) '())) .env|474 .available|474)) (lambda (.e|484 .f|484 .regbindings|484) (begin (lambda.args-set! .l|477 '()) (values (make-call .l|477 '()) .f|484 .regbindings|484)))))))))) (set! .scan-binding-phase3|16 (lambda (.l|485 .e0|485 .e1|485 .f|485 .f1|485 .regbindings0|485 .regbindings1|485) (let* ((.args|488 (lambda.args .l|485)) (.t1|491 (let ((.x|517|520 .args|488)) (begin (.check! (pair? .x|517|520) 0 .x|517|520) (car:pair .x|517|520)))) (.free|494 (union .f1|485 (difference .f|485 .args|488))) (.simple-let?|497 (simple-lambda? .l|485)) (.regbindings|500 (if (null? .regbindings0|485) .regbindings1|485 (if (null? .regbindings1|485) .regbindings0|485 (.error|14 'scan-binding 'regbindings))))) (let () (begin (lambda.body-set! .l|485 .e0|485) (lambda.f-set! .l|485 .f|485) (lambda.g-set! .l|485 .f|485) (if (if .simple-let?|497 (if (not (memq .t1|491 .f|485)) (no-side-effects? .e1|485) #f) #f) (begin (.abandon-expression!|16 .e1|485) (values .e0|485 .f|485 .regbindings0|485)) (if (if .target-registers?|2 (if .simple-let?|497 (.local-variable-used-once?|16 .t1|491) #f) #f) (post-simplify-anf .l|485 .t1|491 .e0|485 .e1|485 .free|494 .regbindings|500 #f) (values (make-call .l|485 (cons .e1|485 '())) .free|494 .regbindings|500)))))))) (set! .scan-binding-phase2|16 (lambda (.l|521 .t1|521 .e0|521 .e1|521 .f0|521 .f1|521 .fdefs|521 .regbindings0|521 .regbindings1|521) (let ((.phase2e|522 (unspecified)) (.phase2d|522 (unspecified)) (.phase2c|522 (unspecified)) (.phase2b|522 (unspecified)) (.phase2a|522 (unspecified))) (begin (set! .phase2e|522 (lambda (.towrap|523 .regbindings0|523) (call-with-values (lambda () (wrap-with-register-bindings .towrap|523 .e0|521 .f0|521)) (lambda (.e0|525 .f0|525) (let ((.f|528 (union .fdefs|521 .f0|525))) (.scan-binding-phase3|16 .l|521 .e0|525 .e1|521 .f|528 .f1|521 .regbindings0|523 .regbindings1|521)))))) (set! .phase2d|522 (lambda (.towrap|529 .regbindings-t1|529 .regbindings0|529) (begin (if (not (null? (let ((.x|530|533 .regbindings-t1|529)) (begin (.check! (pair? .x|530|533) 1 .x|530|533) (cdr:pair .x|530|533))))) (.error|14 "incorrect number of uses" .t1|521) (unspecified)) (let* ((.regbinding|536 (let ((.x|544|547 .regbindings-t1|529)) (begin (.check! (pair? .x|544|547) 0 .x|544|547) (car:pair .x|544|547)))) (.r|539 (regbinding.lhs .regbinding|536))) (let () (begin (lambda.args-set! .l|521 (cons .r|539 '())) (.phase2e|522 .towrap|529 .regbindings0|529))))))) (set! .phase2c|522 (lambda (.towrap|548 .rb1|548 .regbindings0|548) (if (if (not (null? .rb1|548)) (.local-variable-used-once?|16 .t1|521) #f) (.phase2d|522 .towrap|548 .rb1|548 .regbindings0|548) (.phase2e|522 (append .rb1|548 .towrap|548) .regbindings0|548)))) (set! .phase2b|522 (lambda (.rb1|553 .rb2|553 .rb3|553) (if (let ((.temp|554|557 (conditional? .e1|521))) (if .temp|554|557 .temp|554|557 (real-call? .e1|521))) (.phase2c|522 (append .rb2|553 .rb3|553) .rb1|553 '()) (.phase2c|522 .rb2|553 .rb1|553 .rb3|553)))) (set! .phase2a|522 (lambda () (let () (let ((.loop|560|564|567 (unspecified))) (begin (set! .loop|560|564|567 (lambda (.rvars|568 .regs|568 .regs1|568) (if (let ((.temp|570|573 (null? .rvars|568))) (if .temp|570|573 .temp|570|573 (null? .regs|568))) (let ((.regbindings|577 .regbindings0|521) (.rb1|577 '()) (.rb2|577 '()) (.rb3|577 '())) (let () (let ((.loop|580 (unspecified))) (begin (set! .loop|580 (lambda (.regbindings|581 .rb1|581 .rb2|581 .rb3|581) (if (null? .regbindings|581) (.phase2b|522 .rb1|581 .rb2|581 .rb3|581) (let* ((.binding|584 (let ((.x|604|607 .regbindings|581)) (begin (.check! (pair? .x|604|607) 0 .x|604|607) (car:pair .x|604|607)))) (.regbindings|587 (let ((.x|600|603 .regbindings|581)) (begin (.check! (pair? .x|600|603) 1 .x|600|603) (cdr:pair .x|600|603)))) (.lhs|590 (regbinding.lhs .binding|584)) (.rhs|593 (regbinding.rhs .binding|584))) (let () (if (eq? .rhs|593 .t1|521) (.loop|580 .regbindings|587 (cons .binding|584 .rb1|581) .rb2|581 .rb3|581) (if (memq .lhs|590 .regs1|568) (.loop|580 .regbindings|587 .rb1|581 (cons .binding|584 .rb2|581) .rb3|581) (.loop|580 .regbindings|587 .rb1|581 .rb2|581 (cons .binding|584 .rb3|581))))))))) (.loop|580 .regbindings|577 .rb1|577 .rb2|577 .rb3|577))))) (begin #t (.loop|560|564|567 (let ((.x|609|612 .rvars|568)) (begin (.check! (pair? .x|609|612) 1 .x|609|612) (cdr:pair .x|609|612))) (let ((.x|613|616 .regs|568)) (begin (.check! (pair? .x|613|616) 1 .x|613|616) (cdr:pair .x|613|616))) (if (memq (let ((.x|617|620 .rvars|568)) (begin (.check! (pair? .x|617|620) 0 .x|617|620) (car:pair .x|617|620))) .f1|521) (cons (let ((.x|621|624 .regs|568)) (begin (.check! (pair? .x|621|624) 0 .x|621|624) (car:pair .x|621|624))) .regs1|568) .regs1|568)))))) (.loop|560|564|567 .regvars|15 argument-registers '())))))) (.phase2a|522))))) (set! .scan-binding|16 (lambda (.e|625 .env|625 .available|625) (let* ((.l|628 (call.proc .e|625)) (.t1|631 (let ((.x|685|688 (lambda.args .l|628))) (begin (.check! (pair? .x|685|688) 0 .x|685|688) (car:pair .x|685|688)))) (.e1|634 (let ((.x|681|684 (call.args .e|625))) (begin (.check! (pair? .x|681|684) 0 .x|681|684) (car:pair .x|681|684)))) (.e0|637 (lambda.body .l|628))) (let () (begin (.record-local-variable!|16 .t1|631) (call-with-values (lambda () (.scan-rhs|16 .e1|634 .env|625 .available|625)) (lambda (.e1|642 .f1|642 .regbindings1|642) (begin (.available-add!|16 .available|625 .t1|631 .e1|642) (let* ((.env|645 (let ((.formals|656 (make-null-terminated (lambda.args .l|628)))) (.environment-extend*|16 (.environment-extend*|16 .env|625 .formals|656) (let () (let ((.loop|662|665|668 (unspecified))) (begin (set! .loop|662|665|668 (lambda (.y1|657|658|669 .results|657|661|669) (if (null? .y1|657|658|669) (reverse .results|657|661|669) (begin #t (.loop|662|665|668 (let ((.x|673|676 .y1|657|658|669)) (begin (.check! (pair? .x|673|676) 1 .x|673|676) (cdr:pair .x|673|676))) (cons (def.lhs (let ((.x|677|680 .y1|657|658|669)) (begin (.check! (pair? .x|677|680) 0 .x|677|680) (car:pair .x|677|680)))) .results|657|661|669)))))) (.loop|662|665|668 (lambda.defs .l|628) '()))))))) (.fdefs|648 (.scan-defs|16 .l|628 .env|645 .available|625))) (let () (call-with-values (lambda () (.scan|16 .e0|637 .env|645 .available|625)) (lambda (.e0|653 .f0|653 .regbindings0|653) (begin (lambda.body-set! .l|628 .e0|653) (if .target-registers?|2 (.scan-binding-phase2|16 .l|628 .t1|631 .e0|653 .e1|642 .f0|653 .f1|642 .fdefs|648 .regbindings0|653 .regbindings1|642) (.scan-binding-phase3|16 .l|628 .e0|653 .e1|642 (union .f0|653 .fdefs|648) .f1|642 .regbindings0|653 .regbindings1|642))))))))))))))) (set! .scan|16 (lambda (.e|689 .env|689 .available|689) (if (not (call? .e|689)) (.scan-rhs|16 .e|689 .env|689 .available|689) (let ((.proc|692 (call.proc .e|689))) (if (not (lambda? .proc|692)) (.scan-rhs|16 .e|689 .env|689 .available|689) (let ((.vars|695 (lambda.args .proc|692))) (if (null? .vars|695) (.scan-let0|16 .e|689 .env|689 .available|689) (if (null? (let ((.x|698|701 .vars|695)) (begin (.check! (pair? .x|698|701) 1 .x|698|701) (cdr:pair .x|698|701)))) (.scan-binding|16 .e|689 .env|689 .available|689) (.error|14 (make-readable .e|689)))))))))) (set! .available-add!|16 (lambda (.available|703 .t|703 .e|703) (if (constant? .e|703) (available-extend! .available|703 .t|703 .e|703 available:killer:immortal) (if (variable? .e|703) (available-extend! .available|703 .t|703 .e|703 (if (.global?|16 (variable.name .e|703)) available:killer:globals available:killer:immortal)) (let ((.entry|709 (prim-call .e|703))) (if .entry|709 (let ((.killer|712 (prim-lives-until .entry|709))) (if (not (eq? .killer|712 available:killer:dead)) (let () (let ((.loop|713|716|719 (unspecified))) (begin (set! .loop|713|716|719 (lambda (.args|720 .k|720) (if (null? .args|720) (available-extend! .available|703 .t|703 .e|703 (logior .killer|712 .k|720)) (begin #t (.loop|713|716|719 (let ((.x|723|726 .args|720)) (begin (.check! (pair? .x|723|726) 1 .x|723|726) (cdr:pair .x|723|726))) (let ((.arg|729 (let ((.x|732|735 .args|720)) (begin (.check! (pair? .x|732|735) 0 .x|732|735) (car:pair .x|732|735))))) (if (if (variable? .arg|729) (.global?|16 (variable.name .arg|729)) #f) available:killer:globals .k|720))))))) (.loop|713|716|719 (call.args .e|703) .killer|712)))) (unspecified))) (unspecified))))))) (set! .global?|16 (lambda (.x|736) (if (.local-variable?|16 .x|736) #f (if (.environment-lookup|16 .env|15 .x|736) #f #t)))) (set! .environment-lookup|16 (lambda (.env|740 .sym|740) (hashtree-get .env|740 .sym|740))) (set! .environment-extend*|16 (lambda (.env|741 .symbols|741) (if (null? .symbols|741) .env|741 (.environment-extend*|16 (hashtree-put .env|741 (let ((.x|742|745 .symbols|741)) (begin (.check! (pair? .x|742|745) 0 .x|742|745) (car:pair .x|742|745))) #t) (let ((.x|746|749 .symbols|741)) (begin (.check! (pair? .x|746|749) 1 .x|746|749) (cdr:pair .x|746|749))))))) (set! .environment-extend|16 (lambda (.env|750 .sym|750) (hashtree-put .env|750 .sym|750 #t))) (set! .make-empty-environment|16 (lambda () (make-hashtree symbol-hash assq))) (set! .abandon-expression!|16 (lambda (.e|752) (if (variable? .e|752) (.adjust-local-variable!|16 (variable.name .e|752) -1) (if (conditional? .e|752) (begin (.abandon-expression!|16 (if.test .e|752)) (.abandon-expression!|16 (if.then .e|752)) (.abandon-expression!|16 (if.else .e|752))) (if (call? .e|752) (let () (let ((.loop|761|763|766 (unspecified))) (begin (set! .loop|761|763|766 (lambda (.y1|756|757|767) (if (null? .y1|756|757|767) (if #f #f (unspecified)) (begin (begin #t (let ((.exp|771 (let ((.x|775|778 .y1|756|757|767)) (begin (.check! (pair? .x|775|778) 0 .x|775|778) (car:pair .x|775|778))))) (if (variable? .exp|771) (let ((.name|774 (variable.name .exp|771))) (if (.local-variable?|16 .name|774) (.adjust-local-variable!|16 .name|774 -1) (unspecified))) (unspecified)))) (.loop|761|763|766 (let ((.x|779|782 .y1|756|757|767)) (begin (.check! (pair? .x|779|782) 1 .x|779|782) (cdr:pair .x|779|782)))))))) (.loop|761|763|766 (cons (call.proc .e|752) (call.args .e|752)))))) (unspecified)))))) (set! .used-variable!|16 (lambda (.sym|783) (.used-local-variable!|16 .sym|783))) (set! .closed-over-local-variable!|16 (lambda (.sym|784) (hashtable-put! .local-variables|16 .sym|784 1000000))) (set! .adjust-local-variable!|16 (lambda (.sym|785 .n|785) (let ((.m|788 (hashtable-get .local-variables|16 .sym|785))) (begin (if .debugging?|2 (if (if .m|788 (> .m|788 0) #f) (begin (write (let* ((.t1|791|794 .sym|785) (.t2|791|797 (cons (+ .m|788 .n|785) '()))) (let () (cons .t1|791|794 .t2|791|797)))) (newline)) (unspecified)) (unspecified)) (if .m|788 (hashtable-put! .local-variables|16 .sym|785 (+ .m|788 .n|785)) (unspecified)))))) (set! .used-local-variable!|16 (lambda (.sym|802) (.adjust-local-variable!|16 .sym|802 1))) (set! .record-local-variable!|16 (lambda (.sym|803) (hashtable-put! .local-variables|16 .sym|803 0))) (set! .local-variable-used-once?|16 (lambda (.sym|804) (= 1 (hashtable-fetch .local-variables|16 .sym|804 0)))) (set! .local-variable-not-used?|16 (lambda (.sym|805) (= 0 (hashtable-fetch .local-variables|16 .sym|805 -1)))) (set! .local-variable?|16 (lambda (.sym|806) (hashtable-get .local-variables|16 .sym|806))) (set! .local-variables|16 (make-hashtable symbol-hash assq)) (call-with-values (lambda () (.scan|16 .e|15 .env|15 .available|15)) (lambda (.e|808 .f|808 .regbindings|808) (call-with-values (lambda () (wrap-with-register-bindings .regbindings|808 .e|808 .f|808)) (lambda (.e|810 .f|810) (values .e|810 .f|810 '()))))))))) (set! .error|14 (lambda .stuff|811 (begin (display "Bug detected during intraprocedural optimization") (newline) (let ((.f|812|815|818 (lambda (.s|838) (begin (display .s|838) (newline))))) (let () (let ((.loop|820|822|825 (unspecified))) (begin (set! .loop|820|822|825 (lambda (.y1|812|813|826) (if (null? .y1|812|813|826) (if #f #f (unspecified)) (begin (begin #t (.f|812|815|818 (let ((.x|830|833 .y1|812|813|826)) (begin (.check! (pair? .x|830|833) 0 .x|830|833) (car:pair .x|830|833))))) (.loop|820|822|825 (let ((.x|834|837 .y1|812|813|826)) (begin (.check! (pair? .x|834|837) 1 .x|834|837) (cdr:pair .x|834|837)))))))) (.loop|820|822|825 .stuff|811))))) (.return|13 (make-constant #f))))) (call-with-values (lambda () (.scan-body|14 .e|1 (make-hashtree symbol-hash assq) (make-available-table) '())) (lambda (.e|840 .f|840 .regbindings|840) (begin (if (not (null? .regbindings|840)) (.error|14 'scan-body) (unspecified)) .e|840))))))))))) 'intraprocedural-commoning))
+(let () (begin (set! representation-analysis (lambda (.exp|1) (let ((.representation-analysis|2 0)) (begin (set! .representation-analysis|2 (lambda (.exp|3) (let* ((.debugging?|6 #f) (.integrate-usual?|9 (integrate-usual-procedures)) (.known|12 (make-hashtable symbol-hash assq)) (.types|15 (make-hashtable symbol-hash assq)) (.g|18 (callgraph .exp|3)) (.schedule|21 (cons (callgraphnode.code (let ((.x|734|737 .g|18)) (begin (.check! (pair? .x|734|737) 0 .x|734|737) (car:pair .x|734|737)))) '())) (.changed?|24 #f) (.mutate?|27 #f)) (let () (let ((.display-all-types|31 (unspecified)) (.display-types|31 (unspecified)) (.analyze-unknown-lambda|31 (unspecified)) (.analyze-known-local-procedure|31 (unspecified)) (.analyze-unknown-call|31 (unspecified)) (.analyze-known-call|31 (unspecified)) (.analyze-primop-call|31 (unspecified)) (.analyze-let1|31 (unspecified)) (.analyze-let0|31 (unspecified)) (.analyze|31 (unspecified)) (.lookup-node|31 (unspecified)) (.lookup-code|31 (unspecified)) (.update-typevar!|31 (unspecified)) (.known-procedure-is-callable?|31 (unspecified)) (.schedule-local-procedures!|31 (unspecified)) (.schedule-callers!|31 (unspecified)) (.schedule-known-procedure!|31 (unspecified)) (.schedule!|31 (unspecified))) (begin (set! .display-all-types|31 (lambda () (let* ((.vars|35 (hashtable-map (lambda (.x|70 .type|70) .x|70) .types|15)) (.vars|38 (twobit-sort (lambda (.var1|69 .var2|69) (string<=? (symbol->string .var1|69) (symbol->string .var2|69))) .vars|35))) (let () (let ((.f|42|45|48 (lambda (.x|68) (begin (write .x|68) (display ": ") (write (rep->symbol (hashtable-get .types|15 .x|68))) (newline))))) (let () (let ((.loop|50|52|55 (unspecified))) (begin (set! .loop|50|52|55 (lambda (.y1|42|43|56) (if (null? .y1|42|43|56) (if #f #f (unspecified)) (begin (begin #t (.f|42|45|48 (let ((.x|60|63 .y1|42|43|56)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63))))) (.loop|50|52|55 (let ((.x|64|67 .y1|42|43|56)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67)))))))) (.loop|50|52|55 .vars|38))))))))) (set! .display-types|31 (lambda () (hashtable-for-each (lambda (.f|72 .vars|72) (begin (write .f|72) (display " : returns ") (write (rep->symbol (hashtable-get .types|15 .f|72))) (newline) (let ((.f|73|76|79 (lambda (.x|99) (begin (display " ") (write .x|99) (display ": ") (write (rep->symbol (hashtable-get .types|15 .x|99))) (newline))))) (let () (let ((.loop|81|83|86 (unspecified))) (begin (set! .loop|81|83|86 (lambda (.y1|73|74|87) (if (null? .y1|73|74|87) (if #f #f (unspecified)) (begin (begin #t (.f|73|76|79 (let ((.x|91|94 .y1|73|74|87)) (begin (.check! (pair? .x|91|94) 0 .x|91|94) (car:pair .x|91|94))))) (.loop|81|83|86 (let ((.x|95|98 .y1|73|74|87)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98)))))))) (.loop|81|83|86 .vars|72))))))) .known|12))) (set! .analyze-unknown-lambda|31 (lambda (.l|100) (begin (if .debugging?|6 (begin (display "Analyzing escaping lambda expression") (newline)) (unspecified)) (.schedule-local-procedures!|31 .l|100) (let ((.vars|103 (make-null-terminated (lambda.args .l|100)))) (begin (let () (let ((.loop|109|111|114 (unspecified))) (begin (set! .loop|109|111|114 (lambda (.y1|104|105|115) (if (null? .y1|104|105|115) (if #f #f (unspecified)) (begin (begin #t (let ((.var|119 (let ((.x|120|123 .y1|104|105|115)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123))))) (hashtable-put! .types|15 .var|119 rep:object))) (.loop|109|111|114 (let ((.x|124|127 .y1|104|105|115)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127)))))))) (.loop|109|111|114 .vars|103)))) (.analyze|31 (lambda.body .l|100) (make-constraints-table))))))) (set! .analyze-known-local-procedure|31 (lambda (.name|128) (begin (if .debugging?|6 (begin (display "Analyzing ") (display .name|128) (newline)) (unspecified)) (let ((.l|131 (.lookup-code|31 .name|128)) (.constraints|131 (make-constraints-table))) (begin (.schedule-local-procedures!|31 .l|131) (let ((.type|134 (.analyze|31 (lambda.body .l|131) .constraints|131))) (begin (if (.update-typevar!|31 .name|128 .type|134) (.schedule-callers!|31 .name|128) (unspecified)) .type|134))))))) (set! .analyze-unknown-call|31 (lambda (.exp|135 .constraints|135) (begin (.analyze|31 (call.proc .exp|135) .constraints|135) (let () (let ((.loop|141|143|146 (unspecified))) (begin (set! .loop|141|143|146 (lambda (.y1|136|137|147) (if (null? .y1|136|137|147) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|151 (let ((.x|152|155 .y1|136|137|147)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155))))) (.analyze|31 .arg|151 .constraints|135))) (.loop|141|143|146 (let ((.x|156|159 .y1|136|137|147)) (begin (.check! (pair? .x|156|159) 1 .x|156|159) (cdr:pair .x|156|159)))))))) (.loop|141|143|146 (call.args .exp|135))))) (constraints-kill! .constraints|135 available:killer:all) rep:object))) (set! .analyze-known-call|31 (lambda (.exp|160 .constraints|160 .vars|160) (let* ((.procname|163 (variable.name (call.proc .exp|160))) (.args|166 (call.args .exp|160)) (.argtypes|169 (let () (let ((.loop|216|219|222 (unspecified))) (begin (set! .loop|216|219|222 (lambda (.y1|211|212|223 .results|211|215|223) (if (null? .y1|211|212|223) (reverse .results|211|215|223) (begin #t (.loop|216|219|222 (let ((.x|227|230 .y1|211|212|223)) (begin (.check! (pair? .x|227|230) 1 .x|227|230) (cdr:pair .x|227|230))) (cons (let ((.arg|231 (let ((.x|232|235 .y1|211|212|223)) (begin (.check! (pair? .x|232|235) 0 .x|232|235) (car:pair .x|232|235))))) (.analyze|31 .arg|231 .constraints|160)) .results|211|215|223)))))) (.loop|216|219|222 .args|166 '())))))) (let () (begin (if (not (.known-procedure-is-callable?|31 .procname|163)) (.schedule-known-procedure!|31 .procname|163) (unspecified)) (let () (let ((.loop|179|182|185 (unspecified))) (begin (set! .loop|179|182|185 (lambda (.y1|173|175|186 .y1|173|174|186) (if (let ((.temp|188|191 (null? .y1|173|175|186))) (if .temp|188|191 .temp|188|191 (null? .y1|173|174|186))) (if #f #f (unspecified)) (begin (begin #t (let ((.var|194 (let ((.x|195|198 .y1|173|175|186)) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198)))) (.type|194 (let ((.x|199|202 .y1|173|174|186)) (begin (.check! (pair? .x|199|202) 0 .x|199|202) (car:pair .x|199|202))))) (if (.update-typevar!|31 .var|194 .type|194) (.schedule-known-procedure!|31 .procname|163) (unspecified)))) (.loop|179|182|185 (let ((.x|203|206 .y1|173|175|186)) (begin (.check! (pair? .x|203|206) 1 .x|203|206) (cdr:pair .x|203|206))) (let ((.x|207|210 .y1|173|174|186)) (begin (.check! (pair? .x|207|210) 1 .x|207|210) (cdr:pair .x|207|210)))))))) (.loop|179|182|185 .vars|160 .argtypes|169)))) (constraints-kill! .constraints|160 available:killer:all) (hashtable-get .types|15 .procname|163)))))) (set! .analyze-primop-call|31 (lambda (.exp|236 .constraints|236 .entry|236) (let* ((.op|239 (prim-opcodename .entry|236)) (.args|242 (call.args .exp|236)) (.argtypes|245 (let () (let ((.loop|293|296|299 (unspecified))) (begin (set! .loop|293|296|299 (lambda (.y1|288|289|300 .results|288|292|300) (if (null? .y1|288|289|300) (reverse .results|288|292|300) (begin #t (.loop|293|296|299 (let ((.x|304|307 .y1|288|289|300)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))) (cons (let ((.arg|308 (let ((.x|309|312 .y1|288|289|300)) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))))) (.analyze|31 .arg|308 .constraints|236)) .results|288|292|300)))))) (.loop|293|296|299 .args|242 '()))))) (.type|248 (rep-result? .op|239 .argtypes|245))) (let () (begin (constraints-kill! .constraints|236 (prim-kills .entry|236)) (if (if (eq? .op|239 'check!) (variable? (let ((.x|255|258 .args|242)) (begin (.check! (pair? .x|255|258) 0 .x|255|258) (car:pair .x|255|258)))) #f) (let ((.varname|261 (variable.name (let ((.x|272|275 .args|242)) (begin (.check! (pair? .x|272|275) 0 .x|272|275) (car:pair .x|272|275)))))) (begin (if (if .mutate?|27 (representation-subtype? (let ((.x|264|267 .argtypes|245)) (begin (.check! (pair? .x|264|267) 0 .x|264|267) (car:pair .x|264|267))) rep:true) #f) (call.args-set! .exp|236 (cons (make-constant #t) (let ((.x|268|271 .args|242)) (begin (.check! (pair? .x|268|271) 1 .x|268|271) (cdr:pair .x|268|271))))) (unspecified)) (constraints-add! .types|15 .constraints|236 (make-type-constraint .varname|261 rep:true available:killer:immortal)))) (let ((.temp|276|279 (if .mutate?|27 (rep-specific? .op|239 .argtypes|245) #f))) (if .temp|276|279 (let ((.newop|280 .temp|276|279)) (call.proc-set! .exp|236 (make-variable .newop|280))) (unspecified)))) (let ((.temp|283|286 .type|248)) (if .temp|283|286 .temp|283|286 rep:object))))))) (set! .analyze-let1|31 (lambda (.exp|313 .constraints|313) (let* ((.proc|316 (call.proc .exp|313)) (.vars|319 (lambda.args .proc|316))) (let () (begin (.schedule-local-procedures!|31 .proc|316) (if (if (pair? .vars|319) (null? (let ((.x|325|328 .vars|319)) (begin (.check! (pair? .x|325|328) 1 .x|325|328) (cdr:pair .x|325|328)))) #f) (let* ((.t1|331 (let ((.x|359|362 .vars|319)) (begin (.check! (pair? .x|359|362) 0 .x|359|362) (car:pair .x|359|362)))) (.e1|334 (let ((.x|355|358 (call.args .exp|313))) (begin (.check! (pair? .x|355|358) 0 .x|355|358) (car:pair .x|355|358))))) (let () (begin (if (if .integrate-usual?|9 (call? .e1|334) #f) (let ((.proc|342 (call.proc .e1|334)) (.args|342 (call.args .e1|334))) (if (variable? .proc|342) (let* ((.op|345 (variable.name .proc|342)) (.entry|348 (prim-entry .op|345)) (.k1|351 (if .entry|348 (prim-lives-until .entry|348) available:killer:dead))) (let () (if (not (= .k1|351 available:killer:dead)) (constraints-add! .types|15 .constraints|313 (make-constraint .t1|331 (make-call .proc|342 .args|342) .k1|351)) (unspecified)))) (unspecified))) (unspecified)) (.update-typevar!|31 .t1|331 (.analyze|31 .e1|334 .constraints|313)) (.analyze|31 (lambda.body .proc|316) .constraints|313)))) (.analyze-unknown-call|31 .exp|313 .constraints|313))))))) (set! .analyze-let0|31 (lambda (.exp|363 .constraints|363) (let ((.proc|366 (call.proc .exp|363))) (begin (.schedule-local-procedures!|31 .proc|366) (if (null? (lambda.args .proc|366)) (.analyze|31 (lambda.body .exp|363) .constraints|363) (.analyze-unknown-call|31 .exp|363 .constraints|363)))))) (set! .analyze|31 (lambda (.exp|367 .constraints|367) (begin (if (if #f .debugging?|6 #f) (begin (display "Analyzing: ") (newline) (pretty-print (make-readable .exp|367 #t)) (newline)) (unspecified)) (let ((.temp|370|373 (let ((.x|463|466 .exp|367)) (begin (.check! (pair? .x|463|466) 0 .x|463|466) (car:pair .x|463|466))))) (if (memv .temp|370|373 '(quote)) (representation-of-value (constant.value .exp|367)) (if (memv .temp|370|373 '(begin)) (let ((.name|378 (variable.name .exp|367))) (let () (representation-typeof .name|378 .types|15 .constraints|367))) (if (memv .temp|370|373 '(lambda)) (begin (.schedule!|31 .exp|367) rep:procedure) (if (memv .temp|370|373 '(set!)) (begin (.analyze|31 (assignment.rhs .exp|367) .constraints|367) (constraints-kill! .constraints|367 available:killer:globals) rep:object) (if (memv .temp|370|373 '(if)) (let* ((.e0|387 (if.test .exp|367)) (.e1|390 (if.then .exp|367)) (.e2|393 (if.else .exp|367)) (.type0|396 (.analyze|31 .e0|387 .constraints|367))) (let () (begin (if .mutate?|27 (if (representation-subtype? .type0|396 rep:true) (if.test-set! .exp|367 (make-constant #t)) (if (representation-subtype? .type0|396 rep:false) (if.test-set! .exp|367 (make-constant #f)) (unspecified))) (unspecified)) (if (representation-subtype? .type0|396 rep:true) (.analyze|31 .e1|390 .constraints|367) (if (representation-subtype? .type0|396 rep:false) (.analyze|31 .e2|393 .constraints|367) (if (variable? .e0|387) (let* ((.t0|407 (variable.name .e0|387)) (.ignored|410 (.analyze|31 .e0|387 .constraints|367)) (.constraints1|413 (copy-constraints-table .constraints|367)) (.constraints2|416 (copy-constraints-table .constraints|367))) (let () (begin (constraints-add! .types|15 .constraints1|413 (make-type-constraint .t0|407 rep:true available:killer:immortal)) (constraints-add! .types|15 .constraints2|416 (make-type-constraint .t0|407 rep:false available:killer:immortal)) (let* ((.type1|422 (.analyze|31 .e1|390 .constraints1|413)) (.type2|425 (.analyze|31 .e2|393 .constraints2|416)) (.type|428 (representation-union .type1|422 .type2|425))) (let () (begin (constraints-intersect! .constraints|367 .constraints1|413 .constraints2|416) .type|428)))))) (representation-error "Bad ANF" (make-readable .exp|367 #t)))))))) (let ((.proc|436 (call.proc .exp|367)) (.args|436 (call.args .exp|367))) (if (lambda? .proc|436) (if (null? .args|436) (.analyze-let0|31 .exp|367 .constraints|367) (if (null? (let ((.x|440|443 .args|436)) (begin (.check! (pair? .x|440|443) 1 .x|440|443) (cdr:pair .x|440|443)))) (.analyze-let1|31 .exp|367 .constraints|367) (error "Compiler bug: pass3rep"))) (if (variable? .proc|436) (let ((.procname|448 (variable.name .proc|436))) (let () (let ((.temp|452|455 (hashtable-get .known|12 .procname|448))) (if .temp|452|455 (let ((.vars|456 .temp|452|455)) (.analyze-known-call|31 .exp|367 .constraints|367 .vars|456)) (if .integrate-usual?|9 (let ((.entry|460 (prim-entry .procname|448))) (if .entry|460 (.analyze-primop-call|31 .exp|367 .constraints|367 .entry|460) (.analyze-unknown-call|31 .exp|367 .constraints|367))) (.analyze-unknown-call|31 .exp|367 .constraints|367)))))) (.analyze-unknown-call|31 .exp|367 .constraints|367))))))))))))) (set! .lookup-node|31 (lambda (.l|467) (let ((.g|470 .g|18)) (let () (let ((.loop|473 (unspecified))) (begin (set! .loop|473 (lambda (.g|474) (if (null? .g|474) (error "Unknown lambda expression" (make-readable .l|467 #t)) (if (eq? .l|467 (callgraphnode.code (let ((.x|477|480 .g|474)) (begin (.check! (pair? .x|477|480) 0 .x|477|480) (car:pair .x|477|480))))) (let ((.x|481|484 .g|474)) (begin (.check! (pair? .x|481|484) 0 .x|481|484) (car:pair .x|481|484))) (.loop|473 (let ((.x|486|489 .g|474)) (begin (.check! (pair? .x|486|489) 1 .x|486|489) (cdr:pair .x|486|489)))))))) (.loop|473 .g|470))))))) (set! .lookup-code|31 (lambda (.name|490) (callgraphnode.code (assq .name|490 .g|18)))) (set! .update-typevar!|31 (lambda (.tv|491 .type|491) (let* ((.type0|494 (hashtable-get .types|15 .tv|491)) (.type0|497 (let ((.temp|506|509 .type0|494)) (if .temp|506|509 .temp|506|509 (begin (hashtable-put! .types|15 .tv|491 rep:bottom) rep:bottom)))) (.type1|500 (representation-union .type0|497 .type|491))) (let () (if (eq? .type0|497 .type1|500) #f (begin (hashtable-put! .types|15 .tv|491 .type1|500) (set! .changed?|24 #t) (if (if .debugging?|6 .mutate?|27 #f) (begin (display "******** Changing type of ") (display .tv|491) (display " from ") (display (rep->symbol .type0|497)) (display " to ") (display (rep->symbol .type1|500)) (newline)) (unspecified)) #t)))))) (set! .known-procedure-is-callable?|31 (lambda (.name|511) (callgraphnode.info (assq .name|511 .g|18)))) (set! .schedule-local-procedures!|31 (lambda (.l|512) (let () (let ((.loop|518|520|523 (unspecified))) (begin (set! .loop|518|520|523 (lambda (.y1|513|514|524) (if (null? .y1|513|514|524) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|528 (let ((.x|532|535 .y1|513|514|524)) (begin (.check! (pair? .x|532|535) 0 .x|532|535) (car:pair .x|532|535)))) (.name|531 (def.lhs .def|528))) (if (.known-procedure-is-callable?|31 .name|531) (.schedule!|31 .name|531) (unspecified)))) (.loop|518|520|523 (let ((.x|536|539 .y1|513|514|524)) (begin (.check! (pair? .x|536|539) 1 .x|536|539) (cdr:pair .x|536|539)))))))) (.loop|518|520|523 (lambda.defs .l|512))))))) (set! .schedule-callers!|31 (lambda (.name|540) (let () (let ((.loop|546|548|551 (unspecified))) (begin (set! .loop|546|548|551 (lambda (.y1|541|542|552) (if (null? .y1|541|542|552) (if #f #f (unspecified)) (begin (begin #t (let ((.node|556 (let ((.x|567|570 .y1|541|542|552)) (begin (.check! (pair? .x|567|570) 0 .x|567|570) (car:pair .x|567|570))))) (if (if (callgraphnode.info .node|556) (let ((.temp|559|562 (memq .name|540 (callgraphnode.tailcalls .node|556)))) (if .temp|559|562 .temp|559|562 (memq .name|540 (callgraphnode.nontailcalls .node|556)))) #f) (let ((.caller|566 (callgraphnode.name .node|556))) (if .caller|566 (.schedule!|31 .caller|566) (.schedule!|31 (callgraphnode.code .node|556)))) (unspecified)))) (.loop|546|548|551 (let ((.x|571|574 .y1|541|542|552)) (begin (.check! (pair? .x|571|574) 1 .x|571|574) (cdr:pair .x|571|574)))))))) (.loop|546|548|551 .g|18)))))) (set! .schedule-known-procedure!|31 (lambda (.name|575) (begin (callgraphnode.info! (assq .name|575 .g|18) #t) (.schedule!|31 .name|575)))) (set! .schedule!|31 (lambda (.job|576) (if (not (memq .job|576 .schedule|21)) (begin (set! .schedule|21 (cons .job|576 .schedule|21)) (if (not (symbol? .job|576)) (callgraphnode.info! (.lookup-node|31 .job|576) #t) (unspecified))) (unspecified)))) '(if debugging? (begin (pretty-print (make-readable (car schedule) #t)) (newline))) (if .debugging?|6 (view-callgraph .g|18) (unspecified)) (let () (let ((.loop|582|584|587 (unspecified))) (begin (set! .loop|582|584|587 (lambda (.y1|577|578|588) (if (null? .y1|577|578|588) (if #f #f (unspecified)) (begin (begin #t (let* ((.node|592 (let ((.x|635|638 .y1|577|578|588)) (begin (.check! (pair? .x|635|638) 0 .x|635|638) (car:pair .x|635|638)))) (.name|595 (callgraphnode.name .node|592)) (.code|598 (callgraphnode.code .node|592)) (.vars|601 (make-null-terminated (lambda.args .code|598))) (.known?|604 (symbol? .name|595)) (.rep|607 (if .known?|604 rep:bottom rep:object))) (let () (begin (callgraphnode.info! .node|592 #f) (if .known?|604 (begin (hashtable-put! .known|12 .name|595 .vars|601) (hashtable-put! .types|15 .name|595 .rep|607)) (unspecified)) (let () (let ((.loop|616|618|621 (unspecified))) (begin (set! .loop|616|618|621 (lambda (.y1|611|612|622) (if (null? .y1|611|612|622) (if #f #f (unspecified)) (begin (begin #t (let ((.var|626 (let ((.x|627|630 .y1|611|612|622)) (begin (.check! (pair? .x|627|630) 0 .x|627|630) (car:pair .x|627|630))))) (hashtable-put! .types|15 .var|626 .rep|607))) (.loop|616|618|621 (let ((.x|631|634 .y1|611|612|622)) (begin (.check! (pair? .x|631|634) 1 .x|631|634) (cdr:pair .x|631|634)))))))) (.loop|616|618|621 .vars|601)))))))) (.loop|582|584|587 (let ((.x|639|642 .y1|577|578|588)) (begin (.check! (pair? .x|639|642) 1 .x|639|642) (cdr:pair .x|639|642)))))))) (.loop|582|584|587 .g|18)))) (let () (let () (let ((.loop|648 (unspecified))) (begin (set! .loop|648 (lambda () (if (not (null? .schedule|21)) (let ((.job|653 (let ((.x|658|661 .schedule|21)) (begin (.check! (pair? .x|658|661) 0 .x|658|661) (car:pair .x|658|661))))) (begin (set! .schedule|21 (let ((.x|654|657 .schedule|21)) (begin (.check! (pair? .x|654|657) 1 .x|654|657) (cdr:pair .x|654|657)))) (if (symbol? .job|653) (.analyze-known-local-procedure|31 .job|653) (.analyze-unknown-lambda|31 .job|653)) (.loop|648))) (if .changed?|24 (begin (set! .changed?|24 #f) (set! .schedule|21 (cons (callgraphnode.code (let ((.x|664|667 .g|18)) (begin (.check! (pair? .x|664|667) 0 .x|664|667) (car:pair .x|664|667)))) '())) (if .debugging?|6 (begin (.display-all-types|31) (newline)) (unspecified)) (.loop|648)) (unspecified))))) (.loop|648))))) (if .debugging?|6 (.display-types|31) (unspecified)) (set! .mutate?|27 #t) (set! .schedule|21 (cons (callgraphnode.code (let ((.x|668|671 .g|18)) (begin (.check! (pair? .x|668|671) 0 .x|668|671) (car:pair .x|668|671)))) (let () (let ((.loop|677|680|683 (unspecified))) (begin (set! .loop|677|680|683 (lambda (.y1|672|673|684 .results|672|676|684) (if (null? .y1|672|673|684) (reverse .results|672|676|684) (begin #t (.loop|677|680|683 (let ((.x|688|691 .y1|672|673|684)) (begin (.check! (pair? .x|688|691) 1 .x|688|691) (cdr:pair .x|688|691))) (cons (callgraphnode.name (let ((.x|692|695 .y1|672|673|684)) (begin (.check! (pair? .x|692|695) 0 .x|692|695) (car:pair .x|692|695)))) .results|672|676|684)))))) (.loop|677|680|683 (filter (lambda (.node|696) (let* ((.name|699 (callgraphnode.name .node|696)) (.known?|702 (symbol? .name|699)) (.marked?|705 (.known-procedure-is-callable?|31 .name|699))) (let () (begin (callgraphnode.info! .node|696 #f) (if .known?|702 .marked?|705 #f))))) .g|18) '())))))) (let () (let () (let ((.loop|716 (unspecified))) (begin (set! .loop|716 (lambda () (if (not (null? .schedule|21)) (let ((.job|720 (let ((.x|725|728 .schedule|21)) (begin (.check! (pair? .x|725|728) 0 .x|725|728) (car:pair .x|725|728))))) (begin (set! .schedule|21 (let ((.x|721|724 .schedule|21)) (begin (.check! (pair? .x|721|724) 1 .x|721|724) (cdr:pair .x|721|724)))) (if (symbol? .job|720) (.analyze-known-local-procedure|31 .job|720) (.analyze-unknown-lambda|31 .job|720)) (.loop|716))) (unspecified)))) (.loop|716))))) (if .changed?|24 (error "Compiler bug in representation inference") (unspecified)) (if .debugging?|6 (pretty-print (make-readable (callgraphnode.code (let ((.x|729|732 .g|18)) (begin (.check! (pair? .x|729|732) 0 .x|729|732) (car:pair .x|729|732)))) #t)) (unspecified)) .exp|3)))))) (.representation-analysis|2 .exp|1))))) 'representation-analysis))
+(let () (begin (set! pass3 (lambda (.exp|1) (let ((.pass3|2 0)) (begin (set! .pass3|2 (lambda (.exp|3) (let ((.verify|4 (unspecified)) (.finish|4 (unspecified)) (.phase4|4 (unspecified)) (.phase3|4 (unspecified)) (.phase2|4 (unspecified)) (.phase1|4 (unspecified))) (begin (set! .verify|4 (lambda (.exp|5) (begin (check-referencing-invariants .exp|5 'free) .exp|5))) (set! .finish|4 (lambda (.exp|6) (if (if (not (interprocedural-constant-propagation)) (not (common-subexpression-elimination)) #f) (begin (compute-free-variables! .exp|6) .exp|6) .exp|6))) (set! .phase4|4 (lambda (.exp|9) (if (representation-inference) (let ((.exp|12 (if (common-subexpression-elimination) .exp|9 (if (interprocedural-constant-propagation) (a-normal-form .exp|9) (a-normal-form (copy-exp .exp|9)))))) (intraprocedural-commoning (representation-analysis .exp|12))) .exp|9))) (set! .phase3|4 (lambda (.exp|16) (if (common-subexpression-elimination) (let* ((.exp|19 (if (interprocedural-constant-propagation) .exp|16 (copy-exp .exp|16))) (.exp|22 (a-normal-form .exp|19))) (let () (if (representation-inference) (intraprocedural-commoning .exp|22 'commoning) (intraprocedural-commoning .exp|22)))) .exp|16))) (set! .phase2|4 (lambda (.exp|26) (if (interprocedural-constant-propagation) (constant-propagation (copy-exp .exp|26)) .exp|26))) (set! .phase1|4 (lambda (.exp|27) (if (interprocedural-inlining) (let ((.g|30 (callgraph .exp|27))) (begin (inline-using-callgraph! .g|30) .exp|27)) .exp|27))) (if (global-optimization) (.verify|4 (.finish|4 (.phase4|4 (.phase3|4 (.phase2|4 (.phase1|4 .exp|3)))))) (begin (compute-free-variables! .exp|3) (.verify|4 .exp|3))))))) (.pass3|2 .exp|1))))) 'pass3))
+(let () (begin (set! init-labels (lambda () (let ((.init-labels|2 0)) (begin (set! .init-labels|2 (lambda () (set! cg-label-counter 1000))) (.init-labels|2))))) 'init-labels))
+(let () (begin (set! make-label (lambda () (let ((.make-label|2 0)) (begin (set! .make-label|2 (lambda () (begin (set! cg-label-counter (+ cg-label-counter 1)) cg-label-counter))) (.make-label|2))))) 'make-label))
+(let () (begin (set! cg-label-counter 1000) 'cg-label-counter))
+(let () (begin (set! make-assembly-stream (lambda () (let ((.make-assembly-stream|2 0)) (begin (set! .make-assembly-stream|2 (lambda () (let ((.code|6 (cons (cons 0 '()) '()))) (begin (set-cdr! .code|6 (let ((.x|7|10 .code|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (let* ((.t1|11|14 .code|6) (.t2|11|17 (cons #f '()))) (let () (cons .t1|11|14 .t2|11|17))))))) (.make-assembly-stream|2))))) 'make-assembly-stream))
+(let () (begin (set! assembly-stream-code (lambda (.output|1) (let ((.assembly-stream-code|2 0)) (begin (set! .assembly-stream-code|2 (lambda (.output|3) (if (local-optimizations) (filter-basic-blocks (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .output|3)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8)))) (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .output|3)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21)))))) (.assembly-stream-code|2 .output|1))))) 'assembly-stream-code))
+(let () (begin (set! assembly-stream-info (lambda (.output|1) (let ((.assembly-stream-info|2 0)) (begin (set! .assembly-stream-info|2 (lambda (.output|3) (let ((.x|5|8 (let ((.x|9|12 .output|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assembly-stream-info|2 .output|1))))) 'assembly-stream-info))
+(let () (begin (set! assembly-stream-info! (lambda (.output|1 .x|1) (let ((.assembly-stream-info!|2 0)) (begin (set! .assembly-stream-info!|2 (lambda (.output|3 .x|3) (begin (set-car! (let ((.x|4|7 .output|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .x|3) #f))) (.assembly-stream-info!|2 .output|1 .x|1))))) 'assembly-stream-info!))
+(let () (begin (set! gen-instruction! (lambda (.output|1 .instruction|1) (let ((.gen-instruction!|2 0)) (begin (set! .gen-instruction!|2 (lambda (.output|3 .instruction|3) (let ((.pair|6 (cons .instruction|3 '())) (.code|6 (let ((.x|12|15 .output|3)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))) (begin (set-cdr! (let ((.x|7|10 .code|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) .pair|6) (set-cdr! .code|6 .pair|6) .output|3)))) (.gen-instruction!|2 .output|1 .instruction|1))))) 'gen-instruction!))
+(let () (begin (set! gen! (lambda (.output|1 . .instruction|1) (gen-instruction! .output|1 .instruction|1))) 'gen!))
+(let () (begin (set! gen-save! (lambda (.output|1 .frame|1 .t0|1) (let ((.gen-save!|2 0)) (begin (set! .gen-save!|2 (lambda (.output|3 .frame|3 .t0|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (begin (gen-instruction! .output|3 (cons $save .size|6)) (gen-store! .output|3 .frame|3 0 .t0|3) (cgframe:stale-set! .frame|3 '()))))) (.gen-save!|2 .output|1 .frame|1 .t0|1))))) 'gen-save!))
+(let () (begin (set! gen-restore! (lambda (.output|1 .frame|1) (let ((.gen-restore!|2 0)) (begin (set! .gen-restore!|2 (lambda (.output|3 .frame|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (gen-instruction! .output|3 (cons $restore .size|6))))) (.gen-restore!|2 .output|1 .frame|1))))) 'gen-restore!))
+(let () (begin (set! gen-pop! (lambda (.output|1 .frame|1) (let ((.gen-pop!|2 0)) (begin (set! .gen-pop!|2 (lambda (.output|3 .frame|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (gen-instruction! .output|3 (cons $pop .size|6))))) (.gen-pop!|2 .output|1 .frame|1))))) 'gen-pop!))
+(let () (begin (set! gen-setstk! (lambda (.output|1 .frame|1 .tempname|1) (let ((.gen-setstk!|2 0)) (begin (set! .gen-setstk!|2 (lambda (.output|3 .frame|3 .tempname|3) (let ((.instruction|6 (let* ((.t1|7|10 $nop) (.t2|7|13 (let* ((.t1|17|20 $setstk) (.t2|17|23 (cons -1 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))))) (begin (cgframe-bind! .frame|3 .tempname|3 .instruction|6) (gen-instruction! .output|3 .instruction|6))))) (.gen-setstk!|2 .output|1 .frame|1 .tempname|1))))) 'gen-setstk!))
+(let () (begin (set! gen-store! (lambda (.output|1 .frame|1 .r|1 .tempname|1) (let ((.gen-store!|2 0)) (begin (set! .gen-store!|2 (lambda (.output|3 .frame|3 .r|3 .tempname|3) (let ((.instruction|6 (let* ((.t1|7|10 $nop) (.t2|7|13 (let* ((.t1|17|20 $store) (.t2|17|23 (let* ((.t1|27|30 .r|3) (.t2|27|33 (cons -1 '()))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))))) (begin (cgframe-bind! .frame|3 .tempname|3 .instruction|6) (gen-instruction! .output|3 .instruction|6))))) (.gen-store!|2 .output|1 .frame|1 .r|1 .tempname|1))))) 'gen-store!))
+(let () (begin (set! gen-load! (lambda (.output|1 .frame|1 .r|1 .tempname|1) (let ((.gen-load!|2 0)) (begin (set! .gen-load!|2 (lambda (.output|3 .frame|3 .r|3 .tempname|3) (begin (cgframe-touch! .frame|3 .tempname|3) (let ((.n|6 (entry.slotnum (cgframe-lookup .frame|3 .tempname|3)))) (gen! .output|3 $load .r|3 .n|6))))) (.gen-load!|2 .output|1 .frame|1 .r|1 .tempname|1))))) 'gen-load!))
+(let () (begin (set! gen-stack! (lambda (.output|1 .frame|1 .tempname|1) (let ((.gen-stack!|2 0)) (begin (set! .gen-stack!|2 (lambda (.output|3 .frame|3 .tempname|3) (begin (cgframe-touch! .frame|3 .tempname|3) (let ((.n|6 (entry.slotnum (cgframe-lookup .frame|3 .tempname|3)))) (gen! .output|3 $stack .n|6))))) (.gen-stack!|2 .output|1 .frame|1 .tempname|1))))) 'gen-stack!))
+(let () (begin (set! init-temps (lambda () (let ((.init-temps|2 0)) (begin (set! .init-temps|2 (lambda () (set! newtemp-counter 5000))) (.init-temps|2))))) 'init-temps))
+(let () (begin (set! newtemp (lambda () (let ((.newtemp|2 0)) (begin (set! .newtemp|2 (lambda () (begin (set! newtemp-counter (+ newtemp-counter 1)) newtemp-counter))) (.newtemp|2))))) 'newtemp))
+(let () (begin (set! newtemp-counter 5000) 'newtemp-counter))
+(let () (begin (set! newtemps (lambda (.n|1) (let ((.newtemps|2 0)) (begin (set! .newtemps|2 (lambda (.n|3) (if (zero? .n|3) '() (cons (newtemp) (.newtemps|2 (- .n|3 1)))))) (.newtemps|2 .n|1))))) 'newtemps))
+(let () (begin (set! cgreg-makeregs (lambda (.n|1 .v1|1 .v2|1) (let ((.cgreg-makeregs|2 0)) (begin (set! .cgreg-makeregs|2 (lambda (.n|3 .v1|3 .v2|3) (let* ((.t1|4|7 .n|3) (.t2|4|10 (let* ((.t1|14|17 .v1|3) (.t2|14|20 (cons .v2|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.cgreg-makeregs|2 .n|1 .v1|1 .v2|1))))) 'cgreg-makeregs))
+(let () (begin (set! cgreg-liveregs (lambda (.regs|1) (let ((.cgreg-liveregs|2 0)) (begin (set! .cgreg-liveregs|2 (lambda (.regs|3) (let ((.x|4|7 .regs|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.cgreg-liveregs|2 .regs|1))))) 'cgreg-liveregs))
+(let () (begin (set! cgreg-contents (lambda (.regs|1) (let ((.cgreg-contents|2 0)) (begin (set! .cgreg-contents|2 (lambda (.regs|3) (let ((.x|5|8 (let ((.x|9|12 .regs|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.cgreg-contents|2 .regs|1))))) 'cgreg-contents))
+(let () (begin (set! cgreg-stale (lambda (.regs|1) (let ((.cgreg-stale|2 0)) (begin (set! .cgreg-stale|2 (lambda (.regs|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .regs|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.cgreg-stale|2 .regs|1))))) 'cgreg-stale))
+(let () (begin (set! cgreg-liveregs-set! (lambda (.regs|1 .n|1) (let ((.cgreg-liveregs-set!|2 0)) (begin (set! .cgreg-liveregs-set!|2 (lambda (.regs|3 .n|3) (begin (set-car! .regs|3 .n|3) .regs|3))) (.cgreg-liveregs-set!|2 .regs|1 .n|1))))) 'cgreg-liveregs-set!))
+(let () (begin (set! cgreg-initial (lambda () (let ((.cgreg-initial|2 0)) (begin (set! .cgreg-initial|2 (lambda () (let ((.v1|6 (make-vector *nregs* #f)) (.v2|6 (make-vector *nregs* #f))) (cgreg-makeregs 0 .v1|6 .v2|6)))) (.cgreg-initial|2))))) 'cgreg-initial))
+(let () (begin (set! cgreg-copy (lambda (.regs|1) (let ((.cgreg-copy|2 0)) (begin (set! .cgreg-copy|2 (lambda (.regs|3) (let* ((.newregs|6 (cgreg-initial)) (.v1a|9 (cgreg-contents .regs|3)) (.v2a|12 (cgreg-stale .regs|3)) (.v1|15 (cgreg-contents .newregs|6)) (.v2|18 (cgreg-stale .newregs|6)) (.n|21 (let ((.v|50|53 .v1a|9)) (begin (.check! (vector? .v|50|53) 42 .v|50|53) (vector-length:vec .v|50|53))))) (let () (begin (cgreg-liveregs-set! .newregs|6 (cgreg-liveregs .regs|3)) (let () (let ((.loop|25|27|30 (unspecified))) (begin (set! .loop|25|27|30 (lambda (.i|31) (if (= .i|31 .n|21) .newregs|6 (begin (begin #t (let ((.v|34|37 .v1|15) (.i|34|37 .i|31) (.x|34|37 (let ((.v|38|41 .v1a|9) (.i|38|41 .i|31)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))))) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37))) (let ((.v|42|45 .v2|18) (.i|42|45 .i|31) (.x|42|45 (let ((.v|46|49 .v2a|12) (.i|46|49 .i|31)) (begin (.check! (fixnum? .i|46|49) 40 .v|46|49 .i|46|49) (.check! (vector? .v|46|49) 40 .v|46|49 .i|46|49) (.check! (<:fix:fix .i|46|49 (vector-length:vec .v|46|49)) 40 .v|46|49 .i|46|49) (.check! (>=:fix:fix .i|46|49 0) 40 .v|46|49 .i|46|49) (vector-ref:trusted .v|46|49 .i|46|49))))) (begin (.check! (fixnum? .i|42|45) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (vector? .v|42|45) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (<:fix:fix .i|42|45 (vector-length:vec .v|42|45)) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (>=:fix:fix .i|42|45 0) 41 .v|42|45 .i|42|45 .x|42|45) (vector-set!:trusted .v|42|45 .i|42|45 .x|42|45)))) (.loop|25|27|30 (+ .i|31 1)))))) (.loop|25|27|30 0))))))))) (.cgreg-copy|2 .regs|1))))) 'cgreg-copy))
+(let () (begin (set! cgreg-tos (lambda (.regs|1) (let ((.cgreg-tos|2 0)) (begin (set! .cgreg-tos|2 (lambda (.regs|3) (- (cgreg-liveregs .regs|3) 1))) (.cgreg-tos|2 .regs|1))))) 'cgreg-tos))
+(let () (begin (set! cgreg-live (lambda (.regs|1 .r|1) (let ((.cgreg-live|2 0)) (begin (set! .cgreg-live|2 (lambda (.regs|3 .r|3) (if (eq? .r|3 'result) (cgreg-tos .regs|3) (max .r|3 (cgreg-tos .regs|3))))) (.cgreg-live|2 .regs|1 .r|1))))) 'cgreg-live))
+(let () (begin (set! cgreg-vars (lambda (.regs|1) (let ((.cgreg-vars|2 0)) (begin (set! .cgreg-vars|2 (lambda (.regs|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.i|14 .vars|14) (if (< .i|14 0) .vars|14 (begin #t (.loop|7|10|13 (- .i|14 1) (cons (let ((.v|17|20 .v|6) (.i|17|20 .i|14)) (begin (.check! (fixnum? .i|17|20) 40 .v|17|20 .i|17|20) (.check! (vector? .v|17|20) 40 .v|17|20 .i|17|20) (.check! (<:fix:fix .i|17|20 (vector-length:vec .v|17|20)) 40 .v|17|20 .i|17|20) (.check! (>=:fix:fix .i|17|20 0) 40 .v|17|20 .i|17|20) (vector-ref:trusted .v|17|20 .i|17|20))) .vars|14)))))) (.loop|7|10|13 (- .m|6 1) '()))))))) (.cgreg-vars|2 .regs|1))))) 'cgreg-vars))
+(let () (begin (set! cgreg-bind! (lambda (.regs|1 .r|1 .t|1) (let ((.cgreg-bind!|2 0)) (begin (set! .cgreg-bind!|2 (lambda (.regs|3 .r|3 .t|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (begin (let ((.v|7|10 .v|6) (.i|7|10 .r|3) (.x|7|10 .t|3)) (begin (.check! (fixnum? .i|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (vector? .v|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (>=:fix:fix .i|7|10 0) 41 .v|7|10 .i|7|10 .x|7|10) (vector-set!:trusted .v|7|10 .i|7|10 .x|7|10))) (if (>= .r|3 .m|6) (cgreg-liveregs-set! .regs|3 (+ .r|3 1)) (unspecified)))))) (.cgreg-bind!|2 .regs|1 .r|1 .t|1))))) 'cgreg-bind!))
+(let () (begin (set! cgreg-bindregs! (lambda (.regs|1 .vars|1) (let ((.cgreg-bindregs!|2 0)) (begin (set! .cgreg-bindregs!|2 (lambda (.regs|3 .vars|3) (let () (let ((.loop|4|8|11 (unspecified))) (begin (set! .loop|4|8|11 (lambda (.m|12 .v|12 .vars|12) (if (null? .vars|12) (begin (cgreg-liveregs-set! .regs|3 .m|12) .regs|3) (begin (begin #t (let ((.v|15|18 .v|12) (.i|15|18 .m|12) (.x|15|18 (let ((.x|19|22 .vars|12)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))))) (begin (.check! (fixnum? .i|15|18) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (vector? .v|15|18) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (>=:fix:fix .i|15|18 0) 41 .v|15|18 .i|15|18 .x|15|18) (vector-set!:trusted .v|15|18 .i|15|18 .x|15|18)))) (.loop|4|8|11 (+ .m|12 1) .v|12 (let ((.x|23|26 .vars|12)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))))))) (.loop|4|8|11 (cgreg-liveregs .regs|3) (cgreg-contents .regs|3) .vars|3)))))) (.cgreg-bindregs!|2 .regs|1 .vars|1))))) 'cgreg-bindregs!))
+(let () (begin (set! cgreg-rename! (lambda (.regs|1 .alist|1) (let ((.cgreg-rename!|2 0)) (begin (set! .cgreg-rename!|2 (lambda (.regs|3 .alist|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .v|12) (if (< .i|12 0) (if #f #f (unspecified)) (begin (begin #t (let ((.var|18 (let ((.v|31|34 .v|12) (.i|31|34 .i|12)) (begin (.check! (fixnum? .i|31|34) 40 .v|31|34 .i|31|34) (.check! (vector? .v|31|34) 40 .v|31|34 .i|31|34) (.check! (<:fix:fix .i|31|34 (vector-length:vec .v|31|34)) 40 .v|31|34 .i|31|34) (.check! (>=:fix:fix .i|31|34 0) 40 .v|31|34 .i|31|34) (vector-ref:trusted .v|31|34 .i|31|34))))) (if .var|18 (let ((.probe|21 (assv .var|18 .alist|3))) (if .probe|21 (let ((.v|22|25 .v|12) (.i|22|25 .i|12) (.x|22|25 (let ((.x|26|29 .probe|21)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (fixnum? .i|22|25) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (vector? .v|22|25) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (>=:fix:fix .i|22|25 0) 41 .v|22|25 .i|22|25 .x|22|25) (vector-set!:trusted .v|22|25 .i|22|25 .x|22|25))) (unspecified))) (unspecified)))) (.loop|5|8|11 (- .i|12 1) .v|12))))) (.loop|5|8|11 (- (cgreg-liveregs .regs|3) 1) (cgreg-contents .regs|3))))))) (.cgreg-rename!|2 .regs|1 .alist|1))))) 'cgreg-rename!))
+(let () (begin (set! cgreg-release! (lambda (.regs|1 .r|1) (let ((.cgreg-release!|2 0)) (begin (set! .cgreg-release!|2 (lambda (.regs|3 .r|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (begin (let ((.v|7|10 .v|6) (.i|7|10 .r|3) (.x|7|10 #f)) (begin (.check! (fixnum? .i|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (vector? .v|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (>=:fix:fix .i|7|10 0) 41 .v|7|10 .i|7|10 .x|7|10) (vector-set!:trusted .v|7|10 .i|7|10 .x|7|10))) (let ((.v|11|14 (cgreg-stale .regs|3)) (.i|11|14 .r|3) (.x|11|14 #t)) (begin (.check! (fixnum? .i|11|14) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (vector? .v|11|14) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (>=:fix:fix .i|11|14 0) 41 .v|11|14 .i|11|14 .x|11|14) (vector-set!:trusted .v|11|14 .i|11|14 .x|11|14))) (if (= .r|3 (- .m|6 1)) (let () (let ((.loop|15|17|20 (unspecified))) (begin (set! .loop|15|17|20 (lambda (.m|21) (if (let ((.temp|23|26 (< .m|21 0))) (if .temp|23|26 .temp|23|26 (let ((.v|28|31 .v|6) (.i|28|31 .m|21)) (begin (.check! (fixnum? .i|28|31) 40 .v|28|31 .i|28|31) (.check! (vector? .v|28|31) 40 .v|28|31 .i|28|31) (.check! (<:fix:fix .i|28|31 (vector-length:vec .v|28|31)) 40 .v|28|31 .i|28|31) (.check! (>=:fix:fix .i|28|31 0) 40 .v|28|31 .i|28|31) (vector-ref:trusted .v|28|31 .i|28|31))))) (cgreg-liveregs-set! .regs|3 (+ .m|21 1)) (begin #t (.loop|15|17|20 (- .m|21 1)))))) (.loop|15|17|20 .r|3)))) (unspecified)))))) (.cgreg-release!|2 .regs|1 .r|1))))) 'cgreg-release!))
+(let () (begin (set! cgreg-release-except! (lambda (.regs|1 .vars|1) (let ((.cgreg-release-except!|2 0)) (begin (set! .cgreg-release-except!|2 (lambda (.regs|3 .vars|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .v|12) (if (< .i|12 0) (if #f #f (unspecified)) (begin (begin #t (let ((.var|18 (let ((.v|21|24 .v|12) (.i|21|24 .i|12)) (begin (.check! (fixnum? .i|21|24) 40 .v|21|24 .i|21|24) (.check! (vector? .v|21|24) 40 .v|21|24 .i|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 40 .v|21|24 .i|21|24) (.check! (>=:fix:fix .i|21|24 0) 40 .v|21|24 .i|21|24) (vector-ref:trusted .v|21|24 .i|21|24))))) (if (if .var|18 (not (memq .var|18 .vars|3)) #f) (cgreg-release! .regs|3 .i|12) (unspecified)))) (.loop|5|8|11 (- .i|12 1) .v|12))))) (.loop|5|8|11 (- (cgreg-liveregs .regs|3) 1) (cgreg-contents .regs|3))))))) (.cgreg-release-except!|2 .regs|1 .vars|1))))) 'cgreg-release-except!))
+(let () (begin (set! cgreg-clear! (lambda (.regs|1) (let ((.cgreg-clear!|2 0)) (begin (set! .cgreg-clear!|2 (lambda (.regs|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v1|6 (cgreg-contents .regs|3)) (.v2|6 (cgreg-stale .regs|3))) (let () (let ((.loop|7|9|12 (unspecified))) (begin (set! .loop|7|9|12 (lambda (.r|13) (if (= .r|13 .m|6) (cgreg-liveregs-set! .regs|3 0) (begin (begin #t (let ((.v|16|19 .v1|6) (.i|16|19 .r|13) (.x|16|19 #f)) (begin (.check! (fixnum? .i|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (vector? .v|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (>=:fix:fix .i|16|19 0) 41 .v|16|19 .i|16|19 .x|16|19) (vector-set!:trusted .v|16|19 .i|16|19 .x|16|19))) (let ((.v|20|23 .v2|6) (.i|20|23 .r|13) (.x|20|23 #t)) (begin (.check! (fixnum? .i|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (vector? .v|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (>=:fix:fix .i|20|23 0) 41 .v|20|23 .i|20|23 .x|20|23) (vector-set!:trusted .v|20|23 .i|20|23 .x|20|23)))) (.loop|7|9|12 (+ .r|13 1)))))) (.loop|7|9|12 0))))))) (.cgreg-clear!|2 .regs|1))))) 'cgreg-clear!))
+(let () (begin (set! cgreg-lookup (lambda (.regs|1 .var|1) (let ((.cgreg-lookup|2 0)) (begin (set! .cgreg-lookup|2 (lambda (.regs|3 .var|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (let ((.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.i|8) (if (< .i|8 0) #f (if (eq? .var|3 (let ((.v|11|14 .v|6) (.i|11|14 .i|8)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14)))) (let* ((.t1|15|18 .var|3) (.t2|15|21 (let* ((.t1|25|28 'register) (.t2|25|31 (let* ((.t1|35|38 .i|8) (.t2|35|41 (cons '(object) '()))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))))) (let () (cons .t1|15|18 .t2|15|21))) (.loop|7 (- .i|8 1)))))) (.loop|7 (- .m|6 1))))))) (.cgreg-lookup|2 .regs|1 .var|1))))) 'cgreg-lookup))
+(let () (begin (set! cgreg-lookup-reg (lambda (.regs|1 .r|1) (let ((.cgreg-lookup-reg|2 0)) (begin (set! .cgreg-lookup-reg|2 (lambda (.regs|3 .r|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (if (<= .m|6 .r|3) #f (let ((.v|7|10 .v|6) (.i|7|10 .r|3)) (begin (.check! (fixnum? .i|7|10) 40 .v|7|10 .i|7|10) (.check! (vector? .v|7|10) 40 .v|7|10 .i|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 40 .v|7|10 .i|7|10) (.check! (>=:fix:fix .i|7|10 0) 40 .v|7|10 .i|7|10) (vector-ref:trusted .v|7|10 .i|7|10))))))) (.cgreg-lookup-reg|2 .regs|1 .r|1))))) 'cgreg-lookup-reg))
+(let () (begin (set! cgreg-join! (lambda (.regs1|1 .regs2|1) (let ((.cgreg-join!|2 0)) (begin (set! .cgreg-join!|2 (lambda (.regs1|3 .regs2|3) (let ((.m1|6 (cgreg-liveregs .regs1|3)) (.m2|6 (cgreg-liveregs .regs2|3)) (.v1|6 (cgreg-contents .regs1|3)) (.v2|6 (cgreg-contents .regs2|3)) (.stale1|6 (cgreg-stale .regs1|3))) (let () (let ((.loop|7|9|12 (unspecified))) (begin (set! .loop|7|9|12 (lambda (.i|13) (if (< .i|13 0) (cgreg-liveregs-set! .regs1|3 (min .m1|6 .m2|6)) (begin (begin #t (let ((.x1|18 (let ((.v|34|37 .v1|6) (.i|34|37 .i|13)) (begin (.check! (fixnum? .i|34|37) 40 .v|34|37 .i|34|37) (.check! (vector? .v|34|37) 40 .v|34|37 .i|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 40 .v|34|37 .i|34|37) (.check! (>=:fix:fix .i|34|37 0) 40 .v|34|37 .i|34|37) (vector-ref:trusted .v|34|37 .i|34|37)))) (.x2|18 (let ((.v|38|41 .v2|6) (.i|38|41 .i|13)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))))) (if (eq? .x1|18 .x2|18) #t (if (not .x1|18) (if .x2|18 (let ((.v|21|24 .stale1|6) (.i|21|24 .i|13) (.x|21|24 #t)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) (unspecified)) (begin (let ((.v|26|29 .v1|6) (.i|26|29 .i|13) (.x|26|29 #f)) (begin (.check! (fixnum? .i|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (vector? .v|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (<:fix:fix .i|26|29 (vector-length:vec .v|26|29)) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (>=:fix:fix .i|26|29 0) 41 .v|26|29 .i|26|29 .x|26|29) (vector-set!:trusted .v|26|29 .i|26|29 .x|26|29))) (let ((.v|30|33 .stale1|6) (.i|30|33 .i|13) (.x|30|33 #t)) (begin (.check! (fixnum? .i|30|33) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (vector? .v|30|33) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (<:fix:fix .i|30|33 (vector-length:vec .v|30|33)) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (>=:fix:fix .i|30|33 0) 41 .v|30|33 .i|30|33 .x|30|33) (vector-set!:trusted .v|30|33 .i|30|33 .x|30|33)))))))) (.loop|7|9|12 (- .i|13 1)))))) (.loop|7|9|12 (- (max .m1|6 .m2|6) 1)))))))) (.cgreg-join!|2 .regs1|1 .regs2|1))))) 'cgreg-join!))
+(let () (begin (set! cgframe:slots car) 'cgframe:slots))
+(let () (begin (set! cgframe:stale cadr) 'cgframe:stale))
+(let () (begin (set! cgframe:livevars caddr) 'cgframe:livevars))
+(let () (begin (set! cgframe:slot.name car) 'cgframe:slot.name))
+(let () (begin (set! cgframe:slot.offset cadr) 'cgframe:slot.offset))
+(let () (begin (set! cgframe:slot.instruction caddr) 'cgframe:slot.instruction))
+(let () (begin (set! cgframe:slot.stale cadddr) 'cgframe:slot.stale))
+(let () (begin (set! cgframe:slots-set! set-car!) 'cgframe:slots-set!))
+(let () (begin (set! cgframe:stale-set! (lambda (.frame|1 .stale|1) (let ((.cgframe:stale-set!|2 0)) (begin (set! .cgframe:stale-set!|2 (lambda (.frame|3 .stale|3) (set-car! (let ((.x|4|7 .frame|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .stale|3))) (.cgframe:stale-set!|2 .frame|1 .stale|1))))) 'cgframe:stale-set!))
+(let () (begin (set! cgframe:livevars-set! (lambda (.frame|1 .vars|1) (let ((.cgframe:livevars-set!|2 0)) (begin (set! .cgframe:livevars-set!|2 (lambda (.frame|3 .vars|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .frame|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .vars|3))) (.cgframe:livevars-set!|2 .frame|1 .vars|1))))) 'cgframe:livevars-set!))
+(let () (begin (set! cgframe:slot.name-set! set-car!) 'cgframe:slot.name-set!))
+(let () (begin (set! cgframe:slot.offset-set! (lambda (.entry|1 .n|1) (let ((.cgframe:slot.offset-set!|2 0)) (begin (set! .cgframe:slot.offset-set!|2 (lambda (.entry|3 .n|3) (let ((.instruction|6 (let ((.x|65|68 (let ((.x|69|72 (let ((.x|73|76 .entry|3)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (if (let ((.temp|7|10 (not (eq? #f (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))))) (if .temp|7|10 .temp|7|10 (not (eq? $nop (let ((.x|12|15 .instruction|6)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))))) (error "Compiler bug: cgframe" .entry|3) (begin (set-car! (let ((.x|25|28 .entry|3)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .n|3) (set-car! .instruction|6 (let ((.x|30|33 (let ((.x|34|37 .instruction|6)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (set-cdr! .instruction|6 (let ((.x|39|42 (let ((.x|43|46 .instruction|6)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42)))) (if (eq? $setstk (let ((.x|47|50 .instruction|6)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) (set-car! (let ((.x|51|54 .instruction|6)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) .n|3) (set-car! (let ((.x|56|59 (let ((.x|60|63 .instruction|6)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))))) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) .n|3))))))) (.cgframe:slot.offset-set!|2 .entry|1 .n|1))))) 'cgframe:slot.offset-set!))
+(let () (begin (set! cgframe:unused-slot (lambda (.frame|1 .entry|1) (let ((.cgframe:unused-slot|2 0)) (begin (set! .cgframe:unused-slot|2 (lambda (.frame|3 .entry|3) (let* ((.stale|6 (cgframe:slot.stale .entry|3)) (.probe|9 (assq #t .stale|6))) (let () (if .probe|9 (let ((.n|15 (let ((.x|16|19 .probe|9)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))) (begin (if (zero? .n|15) (cgframe-used! .frame|3) (unspecified)) (set-car! .probe|9 #f) .n|15)) (let* ((.cell|22 (cgframe-size-cell .frame|3)) (.n|25 (+ 1 (let ((.x|29|32 .cell|22)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))))) (let () (begin (set-car! .cell|22 .n|25) (if (zero? .n|25) (.cgframe:unused-slot|2 .frame|3 .entry|3) .n|25))))))))) (.cgframe:unused-slot|2 .frame|1 .entry|1))))) 'cgframe:unused-slot))
+(let () (begin (set! cgframe-initial (lambda () (let ((.cgframe-initial|2 0)) (begin (set! .cgframe-initial|2 (lambda () (let* ((.t1|4|7 '()) (.t2|4|10 (let* ((.t1|14|17 (cons (cons #t 0) '())) (.t2|14|20 (let* ((.t1|24|27 #f) (.t2|24|30 (cons -1 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.cgframe-initial|2))))) 'cgframe-initial))
+(let () (begin (set! cgframe-livevars cgframe:livevars) 'cgframe-livevars))
+(let () (begin (set! cgframe-livevars-set! cgframe:livevars-set!) 'cgframe-livevars-set!))
+(let () (begin (set! cgframe-size-cell (lambda (.frame|1) (let ((.cgframe-size-cell|2 0)) (begin (set! .cgframe-size-cell|2 (lambda (.frame|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .frame|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))))) (.cgframe-size-cell|2 .frame|1))))) 'cgframe-size-cell))
+(let () (begin (set! cgframe-size (lambda (.frame|1) (let ((.cgframe-size|2 0)) (begin (set! .cgframe-size|2 (lambda (.frame|3) (let ((.x|4|7 (cgframe-size-cell .frame|3))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.cgframe-size|2 .frame|1))))) 'cgframe-size))
+(let () (begin (set! cgframe-used! (lambda (.frame|1) (let ((.cgframe-used!|2 0)) (begin (set! .cgframe-used!|2 (lambda (.frame|3) (if (< (cgframe-size .frame|3) 0) (set-car! (cgframe-size-cell .frame|3) 0) (unspecified)))) (.cgframe-used!|2 .frame|1))))) 'cgframe-used!))
+(let () (begin (set! cgframe-bind! (lambda (.frame|1 .var|1 .instruction|1) (let ((.cgframe-bind!|2 0)) (begin (set! .cgframe-bind!|2 (lambda (.frame|3 .var|3 .instruction|3) (cgframe:slots-set! .frame|3 (cons (let* ((.t1|4|7 .var|3) (.t2|4|10 (let* ((.t1|14|17 #f) (.t2|14|20 (let* ((.t1|24|27 .instruction|3) (.t2|24|30 (cons (cgframe:stale .frame|3) '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))) (cgframe:slots .frame|3))))) (.cgframe-bind!|2 .frame|1 .var|1 .instruction|1))))) 'cgframe-bind!))
+(let () (begin (set! cgframe-touch! (lambda (.frame|1 .var|1) (let ((.cgframe-touch!|2 0)) (begin (set! .cgframe-touch!|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (if (eq? #f .n|9) (let ((.n|12 (cgframe:unused-slot .frame|3 .entry|6))) (cgframe:slot.offset-set! .entry|6 .n|12)) (unspecified))) (error "Compiler bug: cgframe-touch!" .frame|3 .var|3))))) (.cgframe-touch!|2 .frame|1 .var|1))))) 'cgframe-touch!))
+(let () (begin (set! cgframe-rename! (lambda (.frame|1 .alist|1) (let ((.cgframe-rename!|2 0)) (begin (set! .cgframe-rename!|2 (lambda (.frame|3 .alist|3) (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let* ((.entry|19 (let ((.x|27|30 .y1|4|5|15)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30)))) (.probe|22 (assq (cgframe:slot.name .entry|19) .alist|3))) (if .probe|22 (cgframe:slot.name-set! .entry|19 (let ((.x|23|26 .probe|22)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))) (unspecified)))) (.loop|9|11|14 (let ((.x|31|34 .y1|4|5|15)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))))) (.loop|9|11|14 (cgframe:slots .frame|3))))))) (.cgframe-rename!|2 .frame|1 .alist|1))))) 'cgframe-rename!))
+(let () (begin (set! cgframe-release! (lambda (.frame|1 .var|1) (let ((.cgframe-release!|2 0)) (begin (set! .cgframe-release!|2 (lambda (.frame|3 .var|3) (let* ((.slots|6 (cgframe:slots .frame|3)) (.entry|9 (assq .var|3 .slots|6))) (let () (if .entry|9 (begin (cgframe:slots-set! .frame|3 (remq .entry|9 .slots|6)) (let ((.n|15 (cgframe:slot.offset .entry|9))) (if (if (not (eq? #f .n|15)) (not (zero? .n|15)) #f) (cgframe:stale-set! .frame|3 (cons (cons #t .n|15) (cgframe:stale .frame|3))) (unspecified)))) (unspecified)))))) (.cgframe-release!|2 .frame|1 .var|1))))) 'cgframe-release!))
+(let () (begin (set! cgframe-release-except! (lambda (.frame|1 .vars|1) (let ((.cgframe-release-except!|2 0)) (begin (set! .cgframe-release-except!|2 (lambda (.frame|3 .vars|3) (let ((.slots|6 (reverse (cgframe:slots .frame|3))) (.newslots|6 '()) (.stale|6 (cgframe:stale .frame|3))) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.slots|10 .newslots|10 .stale|10) (if (null? .slots|10) (begin (cgframe:slots-set! .frame|3 .newslots|10) (cgframe:stale-set! .frame|3 .stale|10)) (let ((.slot|13 (let ((.x|36|39 .slots|10)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (if (memq (cgframe:slot.name .slot|13) .vars|3) (.loop|9 (let ((.x|14|17 .slots|10)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (cons .slot|13 .newslots|10) .stale|10) (let ((.n|20 (cgframe:slot.offset .slot|13))) (if (eq? .n|20 #f) (.loop|9 (let ((.x|22|25 .slots|10)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) .newslots|10 .stale|10) (if (zero? .n|20) (.loop|9 (let ((.x|27|30 .slots|10)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))) (cons .slot|13 .newslots|10) .stale|10) (.loop|9 (let ((.x|32|35 .slots|10)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) .newslots|10 (cons (cons #t .n|20) .stale|10)))))))))) (.loop|9 .slots|6 .newslots|6 .stale|6))))))) (.cgframe-release-except!|2 .frame|1 .vars|1))))) 'cgframe-release-except!))
+(let () (begin (set! cgframe-lookup (lambda (.frame|1 .var|1) (let ((.cgframe-lookup|2 0)) (begin (set! .cgframe-lookup|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (begin (if (eq? #f .n|9) (cgframe-touch! .frame|3 .var|3) (unspecified)) (let* ((.t1|10|13 .var|3) (.t2|10|16 (let* ((.t1|20|23 'frame) (.t2|20|26 (let* ((.t1|30|33 (cgframe:slot.offset .entry|6)) (.t2|30|36 (cons '(object) '()))) (let () (cons .t1|30|33 .t2|30|36))))) (let () (cons .t1|20|23 .t2|20|26))))) (let () (cons .t1|10|13 .t2|10|16))))) #f)))) (.cgframe-lookup|2 .frame|1 .var|1))))) 'cgframe-lookup))
+(let () (begin (set! cgframe-spilled? (lambda (.frame|1 .var|1) (let ((.cgframe-spilled?|2 0)) (begin (set! .cgframe-spilled?|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (not (eq? #f .n|9))) #f)))) (.cgframe-spilled?|2 .frame|1 .var|1))))) 'cgframe-spilled?))
+(let () (begin (set! cgframe-copy (lambda (.frame|1) (let ((.cgframe-copy|2 0)) (begin (set! .cgframe-copy|2 (lambda (.frame|3) (cons (let ((.x|4|7 .frame|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (cons (let ((.x|9|12 (let ((.x|13|16 .frame|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) (cons (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .frame|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .frame|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))))) (.cgframe-copy|2 .frame|1))))) 'cgframe-copy))
+(let () (begin (set! cgframe-update-stale! (lambda (.frame|1) (let ((.cgframe-update-stale!|2 0)) (begin (set! .cgframe-update-stale!|2 (lambda (.frame|3) (let* ((.n|6 (cgframe-size .frame|3)) (.v|9 (make-vector (+ 1 .n|6) #t)) (.stale|12 (cgframe:stale .frame|3))) (let () (begin (let () (let ((.loop|21|23|26 (unspecified))) (begin (set! .loop|21|23|26 (lambda (.y1|16|17|27) (if (null? .y1|16|17|27) (if #f #f (unspecified)) (begin (begin #t (let ((.x|31 (let ((.x|47|50 .y1|16|17|27)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50))))) (if (let ((.x|32|35 .x|31)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) (let ((.i|38 (let ((.x|43|46 .x|31)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (if (<= .i|38 .n|6) (let ((.v|39|42 .v|9) (.i|39|42 .i|38) (.x|39|42 #f)) (begin (.check! (fixnum? .i|39|42) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (vector? .v|39|42) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (<:fix:fix .i|39|42 (vector-length:vec .v|39|42)) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (>=:fix:fix .i|39|42 0) 41 .v|39|42 .i|39|42 .x|39|42) (vector-set!:trusted .v|39|42 .i|39|42 .x|39|42))) (unspecified))) (unspecified)))) (.loop|21|23|26 (let ((.x|51|54 .y1|16|17|27)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54)))))))) (.loop|21|23|26 .stale|12)))) (let () (let ((.loop|60|62|65 (unspecified))) (begin (set! .loop|60|62|65 (lambda (.y1|55|56|66) (if (null? .y1|55|56|66) (if #f #f (unspecified)) (begin (begin #t (let* ((.slot|70 (let ((.x|117|120 .y1|55|56|66)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120)))) (.offset|73 (cgframe:slot.offset .slot|70))) (if .offset|73 (let ((.v|74|77 .v|9) (.i|74|77 .offset|73) (.x|74|77 #f)) (begin (.check! (fixnum? .i|74|77) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (vector? .v|74|77) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (<:fix:fix .i|74|77 (vector-length:vec .v|74|77)) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (>=:fix:fix .i|74|77 0) 41 .v|74|77 .i|74|77 .x|74|77) (vector-set!:trusted .v|74|77 .i|74|77 .x|74|77))) (let () (let ((.loop|83|85|88 (unspecified))) (begin (set! .loop|83|85|88 (lambda (.y1|78|79|89) (if (null? .y1|78|79|89) (if #f #f (unspecified)) (begin (begin #t (let ((.stale|93 (let ((.x|109|112 .y1|78|79|89)) (begin (.check! (pair? .x|109|112) 0 .x|109|112) (car:pair .x|109|112))))) (if (let ((.x|94|97 .stale|93)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))) (let ((.i|100 (let ((.x|105|108 .stale|93)) (begin (.check! (pair? .x|105|108) 1 .x|105|108) (cdr:pair .x|105|108))))) (if (< .i|100 .n|6) (let ((.v|101|104 .v|9) (.i|101|104 .i|100) (.x|101|104 #f)) (begin (.check! (fixnum? .i|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (vector? .v|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (<:fix:fix .i|101|104 (vector-length:vec .v|101|104)) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (>=:fix:fix .i|101|104 0) 41 .v|101|104 .i|101|104 .x|101|104) (vector-set!:trusted .v|101|104 .i|101|104 .x|101|104))) (unspecified))) (unspecified)))) (.loop|83|85|88 (let ((.x|113|116 .y1|78|79|89)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116)))))))) (.loop|83|85|88 (cgframe:slot.stale .slot|70)))))))) (.loop|60|62|65 (let ((.x|121|124 .y1|55|56|66)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))))) (.loop|60|62|65 (cgframe:slots .frame|3))))) (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.i|132 .stale|132) (if (<= .i|132 0) (cgframe:stale-set! .frame|3 .stale|132) (begin #t (.loop|125|128|131 (- .i|132 1) (if (let ((.v|135|138 .v|9) (.i|135|138 .i|132)) (begin (.check! (fixnum? .i|135|138) 40 .v|135|138 .i|135|138) (.check! (vector? .v|135|138) 40 .v|135|138 .i|135|138) (.check! (<:fix:fix .i|135|138 (vector-length:vec .v|135|138)) 40 .v|135|138 .i|135|138) (.check! (>=:fix:fix .i|135|138 0) 40 .v|135|138 .i|135|138) (vector-ref:trusted .v|135|138 .i|135|138))) (cons (cons #t .i|132) .stale|132) .stale|132)))))) (.loop|125|128|131 .n|6 (filter car .stale|12)))))))))) (.cgframe-update-stale!|2 .frame|1))))) 'cgframe-update-stale!))
+(let () (begin (set! cgframe-join! (lambda (.frame1|1 .frame2|1) (let ((.cgframe-join!|2 0)) (begin (set! .cgframe-join!|2 (lambda (.frame1|3 .frame2|3) (let* ((.slots1|6 (cgframe:slots .frame1|3)) (.slots2|9 (cgframe:slots .frame2|3)) (.slots|12 (intersection .slots1|6 .slots2|9)) (.deadslots|15 (append (difference .slots1|6 .slots|12) (difference .slots2|9 .slots|12))) (.deadoffsets|18 (make-set (filter (lambda (.x|59) (not (eq? .x|59 #f))) (let () (let ((.loop|65|68|71 (unspecified))) (begin (set! .loop|65|68|71 (lambda (.y1|60|61|72 .results|60|64|72) (if (null? .y1|60|61|72) (reverse .results|60|64|72) (begin #t (.loop|65|68|71 (let ((.x|76|79 .y1|60|61|72)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons (cgframe:slot.offset (let ((.x|80|83 .y1|60|61|72)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) .results|60|64|72)))))) (.loop|65|68|71 .deadslots|15 '()))))))) (.stale1|21 (cgframe:stale .frame1|3)) (.stale2|24 (cgframe:stale .frame2|3)) (.stale|27 (intersection .stale1|21 .stale2|24)) (.stale|30 (append (let () (let ((.loop|39|42|45 (unspecified))) (begin (set! .loop|39|42|45 (lambda (.y1|34|35|46 .results|34|38|46) (if (null? .y1|34|35|46) (reverse .results|34|38|46) (begin #t (.loop|39|42|45 (let ((.x|50|53 .y1|34|35|46)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53))) (cons (let ((.n|54 (let ((.x|55|58 .y1|34|35|46)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58))))) (cons #t .n|54)) .results|34|38|46)))))) (.loop|39|42|45 .deadoffsets|18 '())))) .stale|27))) (let () (begin (cgframe:slots-set! .frame1|3 .slots|12) (cgframe:stale-set! .frame1|3 .stale|30)))))) (.cgframe-join!|2 .frame1|1 .frame2|1))))) 'cgframe-join!))
+(let () (begin (set! entry.name car) 'entry.name))
+(let () (begin (set! entry.kind cadr) 'entry.kind))
+(let () (begin (set! entry.rib caddr) 'entry.rib))
+(let () (begin (set! entry.offset cadddr) 'entry.offset))
+(let () (begin (set! entry.label cadddr) 'entry.label))
+(let () (begin (set! entry.regnum caddr) 'entry.regnum))
+(let () (begin (set! entry.slotnum caddr) 'entry.slotnum))
+(let () (begin (set! entry.arity caddr) 'entry.arity))
+(let () (begin (set! entry.op cadddr) 'entry.op))
+(let () (begin (set! entry.imm (lambda (.entry|1) (let ((.entry.imm|2 0)) (begin (set! .entry.imm|2 (lambda (.entry|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.entry.imm|2 .entry|1))))) 'entry.imm))
+(let () (begin (set! cgenv-initial (lambda (.integrable|1) (let ((.cgenv-initial|2 0)) (begin (set! .cgenv-initial|2 (lambda (.integrable|3) (cons (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.y1|5|6|17 .results|5|9|17) (if (null? .y1|5|6|17) (reverse .results|5|9|17) (begin #t (.loop|10|13|16 (let ((.x|21|24 .y1|5|6|17)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) (cons (let* ((.x|25 (let ((.x|120|123 .y1|5|6|17)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123)))) (.t1|26|29 (let ((.x|116|119 .x|25)) (begin (.check! (pair? .x|116|119) 0 .x|116|119) (car:pair .x|116|119)))) (.t2|26|32 (let* ((.t1|36|39 'integrable) (.t2|36|42 (let* ((.t1|46|49 (let ((.x|108|111 (let ((.x|112|115 .x|25)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))))) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111)))) (.t2|46|52 (let* ((.t1|56|59 (let ((.x|95|98 (let ((.x|99|102 (let ((.x|103|106 .x|25)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))))) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98)))) (.t2|56|62 (let* ((.t1|66|69 (let ((.x|78|81 (let ((.x|82|85 (let ((.x|86|89 (let ((.x|90|93 .x|25)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.t2|66|72 (cons '(object) '()))) (let () (cons .t1|66|69 .t2|66|72))))) (let () (cons .t1|56|59 .t2|56|62))))) (let () (cons .t1|46|49 .t2|46|52))))) (let () (cons .t1|36|39 .t2|36|42))))) (let () (cons .t1|26|29 .t2|26|32))) .results|5|9|17)))))) (.loop|10|13|16 .integrable|3 '())))) '()))) (.cgenv-initial|2 .integrable|1))))) 'cgenv-initial))
+(let () (begin (set! cgenv-lookup (lambda (.env|1 .id|1) (let ((.cgenv-lookup|2 0)) (begin (set! .cgenv-lookup|2 (lambda (.env|3 .id|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.ribs|5 .m|5) (if (null? .ribs|5) (cons .id|3 '(global (object))) (let ((.x|8 (assq .id|3 (let ((.x|66|69 .ribs|5)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69)))))) (if .x|8 (let ((.temp|9|12 (let ((.x|54|57 (let ((.x|58|61 .x|8)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))))) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57))))) (if (memv .temp|9|12 '(lexical)) (cons .id|3 (cons (let ((.x|15|18 (let ((.x|19|22 .x|8)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (cons .m|5 (let ((.x|24|27 (let ((.x|28|31 .x|8)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))))) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))) (if (memv .temp|9|12 '(procedure)) (cons .id|3 (cons (let ((.x|34|37 (let ((.x|38|41 .x|8)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))))) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) (cons .m|5 (let ((.x|43|46 (let ((.x|47|50 .x|8)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))) (if (memv .temp|9|12 '(integrable)) (if (integrate-usual-procedures) .x|8 (.loop|4 '() .m|5)) ???)))) (.loop|4 (let ((.x|62|65 .ribs|5)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (+ .m|5 1))))))) (.loop|4 .env|3 0))))) (.cgenv-lookup|2 .env|1 .id|1))))) 'cgenv-lookup))
+(let () (begin (set! cgenv-extend (lambda (.env|1 .vars|1 .procs|1) (let ((.cgenv-extend|2 0)) (begin (set! .cgenv-extend|2 (lambda (.env|3 .vars|3 .procs|3) (cons (let () (let ((.loop|4|8|11 (unspecified))) (begin (set! .loop|4|8|11 (lambda (.n|12 .vars|12 .rib|12) (if (null? .vars|12) .rib|12 (begin #t (.loop|4|8|11 (+ .n|12 1) (let ((.x|15|18 .vars|12)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) (cons (let* ((.t1|19|22 (let ((.x|50|53 .vars|12)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53)))) (.t2|19|25 (let* ((.t1|29|32 'lexical) (.t2|29|35 (let* ((.t1|39|42 .n|12) (.t2|39|45 (cons '(object) '()))) (let () (cons .t1|39|42 .t2|39|45))))) (let () (cons .t1|29|32 .t2|29|35))))) (let () (cons .t1|19|22 .t2|19|25))) .rib|12)))))) (.loop|4|8|11 0 .vars|3 (let () (let ((.loop|59|62|65 (unspecified))) (begin (set! .loop|59|62|65 (lambda (.y1|54|55|66 .results|54|58|66) (if (null? .y1|54|55|66) (reverse .results|54|58|66) (begin #t (.loop|59|62|65 (let ((.x|70|73 .y1|54|55|66)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (cons (let* ((.id|74 (let ((.x|106|109 .y1|54|55|66)) (begin (.check! (pair? .x|106|109) 0 .x|106|109) (car:pair .x|106|109)))) (.t1|75|78 .id|74) (.t2|75|81 (let* ((.t1|85|88 'procedure) (.t2|85|91 (let* ((.t1|95|98 (make-label)) (.t2|95|101 (cons '(object) '()))) (let () (cons .t1|95|98 .t2|95|101))))) (let () (cons .t1|85|88 .t2|85|91))))) (let () (cons .t1|75|78 .t2|75|81))) .results|54|58|66)))))) (.loop|59|62|65 .procs|3 '())))))))) .env|3))) (.cgenv-extend|2 .env|1 .vars|1 .procs|1))))) 'cgenv-extend))
+(let () (begin (set! cgenv-bindprocs (lambda (.env|1 .procs|1) (let ((.cgenv-bindprocs|2 0)) (begin (set! .cgenv-bindprocs|2 (lambda (.env|3 .procs|3) (cons (append (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let* ((.id|24 (let ((.x|56|59 .y1|4|5|16)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59)))) (.t1|25|28 .id|24) (.t2|25|31 (let* ((.t1|35|38 'procedure) (.t2|35|41 (let* ((.t1|45|48 (make-label)) (.t2|45|51 (cons '(object) '()))) (let () (cons .t1|45|48 .t2|45|51))))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))) .results|4|8|16)))))) (.loop|9|12|15 .procs|3 '())))) (let ((.x|60|63 .env|3)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63)))) (let ((.x|64|67 .env|3)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67)))))) (.cgenv-bindprocs|2 .env|1 .procs|1))))) 'cgenv-bindprocs))
+(let () (begin (set! var-lookup (lambda (.var|1 .regs|1 .frame|1 .env|1) (let ((.var-lookup|2 0)) (begin (set! .var-lookup|2 (lambda (.var|3 .regs|3 .frame|3 .env|3) (let ((.temp|4|7 (cgreg-lookup .regs|3 .var|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (cgframe-lookup .frame|3 .var|3))) (if .temp|8|11 .temp|8|11 (cgenv-lookup .env|3 .var|3))))))) (.var-lookup|2 .var|1 .regs|1 .frame|1 .env|1))))) 'var-lookup))
+(let () (begin (set! compile (lambda (.x|1) (pass4 (pass3 (pass2 (pass1 .x|1))) $usual-integrable-procedures$))) 'compile))
+(let () (begin (set! compile-block (lambda (.x|1) (pass4 (pass3 (pass2 (pass1-block .x|1))) $usual-integrable-procedures$))) 'compile-block))
+(let () (begin (set! foo (lambda (.x|1) (pretty-print (compile .x|1)))) 'foo))
+(let () (begin (set! minregs (lambda (.x|1) (let ((.minregs|2 0)) (begin (set! .minregs|2 (lambda (.x|3) (let ((.defregs|4 (unspecified))) (begin (set! .defregs|4 (lambda (.r|5) (begin (set! *nregs* .r|5) (set! *lastreg* (- *nregs* 1)) (set! *fullregs* (quotient *nregs* 2))))) (.defregs|4 32) (let* ((.code|8 (assemble (compile .x|3))) (.binary-search|9 (unspecified))) (begin (set! .binary-search|9 (lambda (.m1|10 .m2|10) (if (= (+ .m1|10 1) .m2|10) .m2|10 (let ((.midpt|13 (quotient (+ .m1|10 .m2|10) 2))) (begin (.defregs|4 .midpt|13) (if (equal? .code|8 (assemble (compile .x|3))) (.binary-search|9 .m1|10 .midpt|13) (.binary-search|9 .midpt|13 .m2|10))))))) (.defregs|4 4) (let ((.newcode|16 (assemble (compile .x|3)))) (if (equal? .code|8 .newcode|16) 4 (.binary-search|9 4 32))))))))) (.minregs|2 .x|1))))) 'minregs))
+(let () (begin (set! pass4 (lambda (.exp|1 .integrable|1) (let ((.pass4|2 0)) (begin (set! .pass4|2 (lambda (.exp|3 .integrable|3) (begin (init-labels) (init-temps) (let ((.output|6 (make-assembly-stream)) (.frame|6 (cgframe-initial)) (.regs|6 (cgreg-initial)) (.t0|6 (newtemp))) (begin (assembly-stream-info! .output|6 (make-hashtable equal-hash assoc)) (cgreg-bind! .regs|6 0 .t0|6) (gen-save! .output|6 .frame|6 .t0|6) (cg0 .output|6 .exp|3 'result .regs|6 .frame|6 (cgenv-initial .integrable|3) #t) (pass4-code .output|6)))))) (.pass4|2 .exp|1 .integrable|1))))) 'pass4))
+(let () (begin (set! pass4-code (lambda (.output|1) (let ((.pass4-code|2 0)) (begin (set! .pass4-code|2 (lambda (.output|3) (begin (hashtable-for-each (lambda (.situation|4 .label|4) (cg-trap .output|3 .situation|4 .label|4)) (assembly-stream-info .output|3)) (assembly-stream-code .output|3)))) (.pass4-code|2 .output|1))))) 'pass4-code))
+(let () (begin (set! cg0 (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg0|2 0)) (begin (set! .cg0|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.temp|4|7 (let ((.x|14|17 .exp|3)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (if (memv .temp|4|7 '(quote)) (begin (gen! .output|3 $const (constant.value .exp|3)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (memv .temp|4|7 '(lambda)) (begin (cg-lambda .output|3 .exp|3 .regs|3 .frame|3 .env|3) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (memv .temp|4|7 '(set!)) (begin (.cg0|2 .output|3 (assignment.rhs .exp|3) 'result .regs|3 .frame|3 .env|3 #f) (cg-assignment-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|4|7 '(if)) (cg-if .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (cg-variable .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (cg-sequential .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (cg-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))) (.cg0|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg0))
+(let () (begin (set! cg-lambda (lambda (.output|1 .exp|1 .regs|1 .frame|1 .env|1) (let ((.cg-lambda|2 0)) (begin (set! .cg-lambda|2 (lambda (.output|3 .exp|3 .regs|3 .frame|3 .env|3) (let* ((.args|6 (lambda.args .exp|3)) (.vars|9 (make-null-terminated .args|6)) (.free|12 (difference (lambda.f .exp|3) .vars|9)) (.free|15 (cg-sort-vars .free|12 .regs|3 .frame|3 .env|3)) (.newenv|18 (cgenv-extend .env|3 (cons #t .free|15) '())) (.newoutput|21 (make-assembly-stream))) (let () (begin (assembly-stream-info! .newoutput|21 (make-hashtable equal-hash assoc)) (gen! .newoutput|21 $.proc) (if (list? .args|6) (gen! .newoutput|21 $args= (length .args|6)) (gen! .newoutput|21 $args>= (- (length .vars|9) 1))) (cg-known-lambda .newoutput|21 .exp|3 .newenv|18) (cg-eval-vars .output|3 .free|15 .regs|3 .frame|3 .env|3) '(if (not (ignore-space-leaks)) (begin (gen! output $const #f) (gen! output $setreg 0))) (gen! .output|3 $lambda (pass4-code .newoutput|21) (length .free|15) (lambda.doc .exp|3)) '(if (not (ignore-space-leaks)) (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))))) (.cg-lambda|2 .output|1 .exp|1 .regs|1 .frame|1 .env|1))))) 'cg-lambda))
+(let () (begin (set! cg-sort-vars (lambda (.free|1 .regs|1 .frame|1 .env|1) (let ((.cg-sort-vars|2 0)) (begin (set! .cg-sort-vars|2 (lambda (.free|3 .regs|3 .frame|3 .env|3) (let* ((.free|6 (filter (lambda (.var|74) (let ((.temp|75|78 (entry.kind (var-lookup .var|74 .regs|3 .frame|3 .env|3)))) (if (memv .temp|75|78 '(register frame)) #t (if (memv .temp|75|78 '(lexical)) (not (ignore-space-leaks)) #f)))) .free|3)) (.n|9 (length .free|6)) (.m|12 (min .n|9 (- *nregs* 1))) (.vec|15 (make-vector .m|12 #f))) (let () (let ((.loop2|19 (unspecified)) (.loop1|19 (unspecified))) (begin (set! .loop2|19 (lambda (.i|20 .free|20) (if (null? .free|20) (vector->list .vec|15) (if (= .i|20 .m|12) (append (vector->list .vec|15) .free|20) (if (let ((.v|24|27 .vec|15) (.i|24|27 .i|20)) (begin (.check! (fixnum? .i|24|27) 40 .v|24|27 .i|24|27) (.check! (vector? .v|24|27) 40 .v|24|27 .i|24|27) (.check! (<:fix:fix .i|24|27 (vector-length:vec .v|24|27)) 40 .v|24|27 .i|24|27) (.check! (>=:fix:fix .i|24|27 0) 40 .v|24|27 .i|24|27) (vector-ref:trusted .v|24|27 .i|24|27))) (.loop2|19 (+ .i|20 1) .free|20) (begin (let ((.v|29|32 .vec|15) (.i|29|32 .i|20) (.x|29|32 (let ((.x|33|36 .free|20)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) (.loop2|19 (+ .i|20 1) (let ((.x|37|40 .free|20)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))))))))) (set! .loop1|19 (lambda (.free|41 .free-notregister|41) (if (null? .free|41) (.loop2|19 0 .free-notregister|41) (let* ((.var|44 (let ((.x|70|73 .free|41)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) (.entry|47 (cgreg-lookup .regs|3 .var|44))) (let () (if .entry|47 (let ((.r|53 (entry.regnum .entry|47))) (if (<= .r|53 .n|9) (begin (let ((.v|54|57 .vec|15) (.i|54|57 (- .r|53 1)) (.x|54|57 .var|44)) (begin (.check! (fixnum? .i|54|57) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (vector? .v|54|57) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (<:fix:fix .i|54|57 (vector-length:vec .v|54|57)) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (>=:fix:fix .i|54|57 0) 41 .v|54|57 .i|54|57 .x|54|57) (vector-set!:trusted .v|54|57 .i|54|57 .x|54|57))) (.loop1|19 (let ((.x|58|61 .free|41)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) .free-notregister|41)) (.loop1|19 (let ((.x|62|65 .free|41)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons .var|44 .free-notregister|41)))) (.loop1|19 (let ((.x|66|69 .free|41)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (cons .var|44 .free-notregister|41)))))))) (.loop1|19 .free|6 '()))))))) (.cg-sort-vars|2 .free|1 .regs|1 .frame|1 .env|1))))) 'cg-sort-vars))
+(let () (begin (set! cg-eval-vars (lambda (.output|1 .free|1 .regs|1 .frame|1 .env|1) (let ((.cg-eval-vars|2 0)) (begin (set! .cg-eval-vars|2 (lambda (.output|3 .free|3 .regs|3 .frame|3 .env|3) (let ((.n|6 (length .free|3)) (.r-1|6 (- *nregs* 1))) (begin (if (>= .n|6 .r-1|6) (begin (gen! .output|3 $const '()) (gen! .output|3 $setreg .r-1|6) (cgreg-release! .regs|3 .r-1|6)) (unspecified)) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.r|15 .vars|15) (if (zero? .r|15) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|20 (let ((.x|39|42 .vars|15)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42)))) (.entry|23 (var-lookup .v|20 .regs|3 .frame|3 .env|3))) (let () (begin (let ((.temp|27|30 (entry.kind .entry|23))) (if (memv .temp|27|30 '(register)) (let ((.r1|34 (entry.regnum .entry|23))) (if (not (eqv? .r|15 .r1|34)) (if (< .r|15 .r-1|6) (begin (gen! .output|3 $movereg .r1|34 .r|15) (cgreg-bind! .regs|3 .r|15 .v|20)) (gen! .output|3 $reg .r1|34 .v|20)) (unspecified))) (if (memv .temp|27|30 '(frame)) (if (< .r|15 .r-1|6) (begin (gen-load! .output|3 .frame|3 .r|15 .v|20) (cgreg-bind! .regs|3 .r|15 .v|20)) (gen-stack! .output|3 .frame|3 .v|20)) (if (memv .temp|27|30 '(lexical)) (begin (gen! .output|3 $lexical (entry.rib .entry|23) (entry.offset .entry|23) .v|20) (if (< .r|15 .r-1|6) (begin (gen! .output|3 $setreg .r|15) (cgreg-bind! .regs|3 .r|15 .v|20) (gen-store! .output|3 .frame|3 .r|15 .v|20)) (unspecified))) (error "Bug in cg-close-lambda"))))) (if (>= .r|15 .r-1|6) (begin (gen! .output|3 $op2 $cons .r-1|6) (gen! .output|3 $setreg .r-1|6)) (unspecified)))))) (.loop|8|11|14 (- .r|15 1) (let ((.x|43|46 .vars|15)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))))) (.loop|8|11|14 .n|6 (reverse .free|3))))))))) (.cg-eval-vars|2 .output|1 .free|1 .regs|1 .frame|1 .env|1))))) 'cg-eval-vars))
+(let () (begin (set! cg-known-lambda (lambda (.output|1 .exp|1 .env|1) (let ((.cg-known-lambda|2 0)) (begin (set! .cg-known-lambda|2 (lambda (.output|3 .exp|3 .env|3) (let* ((.vars|6 (make-null-terminated (lambda.args .exp|3))) (.regs|9 (cgreg-initial)) (.frame|12 (cgframe-initial)) (.t0|15 (newtemp))) (let () (begin (if (member a-normal-form-declaration (lambda.decls .exp|3)) (cgframe-livevars-set! .frame|12 '()) (unspecified)) (cgreg-bind! .regs|9 0 .t0|15) (gen-save! .output|3 .frame|12 .t0|15) (let () (let ((.loop|19|22|25 (unspecified))) (begin (set! .loop|19|22|25 (lambda (.r|26 .vars|26) (if (let ((.temp|28|31 (null? .vars|26))) (if .temp|28|31 .temp|28|31 (= .r|26 *lastreg*))) (if (not (null? .vars|26)) (begin (gen! .output|3 $movereg *lastreg* 1) (cgreg-release! .regs|9 1) (let () (let ((.loop|34|36|39 (unspecified))) (begin (set! .loop|34|36|39 (lambda (.vars|40) (if (null? .vars|40) (if #f #f (unspecified)) (begin (begin #t (gen! .output|3 $reg 1) (gen! .output|3 $op1 $car:pair) (gen-setstk! .output|3 .frame|12 (let ((.x|43|46 .vars|40)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) (gen! .output|3 $reg 1) (gen! .output|3 $op1 $cdr:pair) (gen! .output|3 $setreg 1)) (.loop|34|36|39 (let ((.x|47|50 .vars|40)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))))))) (.loop|34|36|39 .vars|26))))) (unspecified)) (begin (begin #t (cgreg-bind! .regs|9 .r|26 (let ((.x|52|55 .vars|26)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55)))) (gen-store! .output|3 .frame|12 .r|26 (let ((.x|56|59 .vars|26)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (.loop|19|22|25 (+ .r|26 1) (let ((.x|60|63 .vars|26)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63)))))))) (.loop|19|22|25 1 .vars|6)))) (cg-body .output|3 .exp|3 'result .regs|9 .frame|12 .env|3 #t)))))) (.cg-known-lambda|2 .output|1 .exp|1 .env|1))))) 'cg-known-lambda))
+(let () (begin (set! cg-body (lambda (.output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-body|2 0)) (begin (set! .cg-body|2 (lambda (.output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.exp|6 (lambda.body .l|3)) (.defs|9 (lambda.defs .l|3)) (.free|12 (apply-union (let () (let ((.loop|153|156|159 (unspecified))) (begin (set! .loop|153|156|159 (lambda (.y1|148|149|160 .results|148|152|160) (if (null? .y1|148|149|160) (reverse .results|148|152|160) (begin #t (.loop|153|156|159 (let ((.x|164|167 .y1|148|149|160)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (cons (let* ((.def|168 (let ((.x|172|175 .y1|148|149|160)) (begin (.check! (pair? .x|172|175) 0 .x|172|175) (car:pair .x|172|175)))) (.l|171 (def.rhs .def|168))) (difference (lambda.f .l|171) (lambda.args .l|171))) .results|148|152|160)))))) (.loop|153|156|159 .defs|9 '()))))))) (let () (if (let ((.temp|17|20 (null? .defs|9))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (constant? .exp|6))) (if .temp|21|24 .temp|21|24 (variable? .exp|6))))) (cg0 .output|3 .exp|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (lambda? .exp|6) (let* ((.free|29 (cg-sort-vars (union .free|12 (difference (lambda.f .exp|6) (make-null-terminated (lambda.args .exp|6)))) .regs|3 .frame|3 .env|3)) (.newenv1|32 (cgenv-extend .env|3 (cons #t .free|29) (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (def.lhs (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .defs|9 '())))))) (.args|35 (lambda.args .exp|6)) (.vars|38 (make-null-terminated .args|35)) (.newoutput|41 (make-assembly-stream))) (let () (begin (assembly-stream-info! .newoutput|41 (make-hashtable equal-hash assoc)) (gen! .newoutput|41 $.proc) (if (list? .args|35) (gen! .newoutput|41 $args= (length .args|35)) (gen! .newoutput|41 $args>= (- (length .vars|38) 1))) (cg-known-lambda .newoutput|41 .exp|6 .newenv1|32) (cg-defs .newoutput|41 .defs|9 .newenv1|32) (cg-eval-vars .output|3 .free|29 .regs|3 .frame|3 .env|3) (gen! .output|3 $lambda (pass4-code .newoutput|41) (length .free|29) (lambda.doc .exp|6)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))))) (if (every? (lambda (.def|70) (every? (lambda (.v|71) (let ((.temp|72|75 (entry.kind (var-lookup .v|71 .regs|3 .frame|3 .env|3)))) (if (memv .temp|72|75 '(register frame)) #f #t))) (let ((.ldef|80 (def.rhs .def|70))) (difference (lambda.f .ldef|80) (lambda.args .ldef|80))))) .defs|9) (let* ((.newenv|83 (cgenv-bindprocs .env|3 (let () (let ((.loop|98|101|104 (unspecified))) (begin (set! .loop|98|101|104 (lambda (.y1|93|94|105 .results|93|97|105) (if (null? .y1|93|94|105) (reverse .results|93|97|105) (begin #t (.loop|98|101|104 (let ((.x|109|112 .y1|93|94|105)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))) (cons (def.lhs (let ((.x|113|116 .y1|93|94|105)) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .results|93|97|105)))))) (.loop|98|101|104 .defs|9 '())))))) (.l|86 (make-label)) (.r|89 (cg0 .output|3 .exp|6 .target|3 .regs|3 .frame|3 .newenv|83 .tail?|3))) (let () (begin (if (not .tail?|3) (gen! .output|3 $skip .l|86 (cgreg-live .regs|3 .r|89)) (unspecified)) (cg-defs .output|3 .defs|9 .newenv|83) (if (not .tail?|3) (gen! .output|3 $.label .l|86) (unspecified)) .r|89))) (let ((.free|120 (cg-sort-vars .free|12 .regs|3 .frame|3 .env|3))) (begin (cg-eval-vars .output|3 .free|120 .regs|3 .frame|3 .env|3) '(if (not (ignore-space-leaks)) (begin (gen! output $const #f) (gen! output $setreg 0))) (let ((.t0|123 (cgreg-lookup-reg .regs|3 0)) (.t1|123 (newtemp)) (.newenv|123 (cgenv-extend .env|3 (cons #t .free|120) (let () (let ((.loop|129|132|135 (unspecified))) (begin (set! .loop|129|132|135 (lambda (.y1|124|125|136 .results|124|128|136) (if (null? .y1|124|125|136) (reverse .results|124|128|136) (begin #t (.loop|129|132|135 (let ((.x|140|143 .y1|124|125|136)) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))) (cons (def.lhs (let ((.x|144|147 .y1|124|125|136)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147)))) .results|124|128|136)))))) (.loop|129|132|135 .defs|9 '())))))) (.l|123 (make-label))) (begin (gen! .output|3 $lexes (length .free|120) .free|120) (gen! .output|3 $setreg 0) (cgreg-bind! .regs|3 0 .t1|123) (if .tail?|3 (begin (cgframe-release! .frame|3 .t0|123) (gen-store! .output|3 .frame|3 0 .t1|123) (cg0 .output|3 .exp|6 'result .regs|3 .frame|3 .newenv|123 #t) (cg-defs .output|3 .defs|9 .newenv|123) 'result) (begin (gen-store! .output|3 .frame|3 0 .t1|123) (cg0 .output|3 .exp|6 'result .regs|3 .frame|3 .newenv|123 #f) (gen! .output|3 $skip .l|123 (cgreg-tos .regs|3)) (cg-defs .output|3 .defs|9 .newenv|123) (gen! .output|3 $.label .l|123) (gen-load! .output|3 .frame|3 0 .t0|123) (cgreg-bind! .regs|3 0 .t0|123) (cgframe-release! .frame|3 .t1|123) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))))))) (.cg-body|2 .output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-body))
+(let () (begin (set! cg-defs (lambda (.output|1 .defs|1 .env|1) (let ((.cg-defs|2 0)) (begin (set! .cg-defs|2 (lambda (.output|3 .defs|3 .env|3) (let ((.f|4|7|10 (lambda (.def|30) (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label (entry.label (cgenv-lookup .env|3 (def.lhs .def|30)))) (gen! .output|3 $.proc) (gen! .output|3 $.proc-doc (lambda.doc (def.rhs .def|30))) (cg-known-lambda .output|3 (def.rhs .def|30) .env|3))))) (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|4|5|18) (if (null? .y1|4|5|18) (if #f #f (unspecified)) (begin (begin #t (.f|4|7|10 (let ((.x|22|25 .y1|4|5|18)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (.loop|12|14|17 (let ((.x|26|29 .y1|4|5|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))) (.loop|12|14|17 .defs|3))))))) (.cg-defs|2 .output|1 .defs|1 .env|1))))) 'cg-defs))
+(let () (begin (set! cg-assignment-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-assignment-result|2 0)) (begin (set! .cg-assignment-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (gen! .output|3 $setglbl (assignment.lhs .exp|3)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))))) (.cg-assignment-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-assignment-result))
+(let () (begin (set! cg-if (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-if|2 0)) (begin (set! .cg-if|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (constant? (if.test .exp|3)) (cg0 .output|3 (if (constant.value (if.test .exp|3)) (if.then .exp|3) (if.else .exp|3)) .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (if.test .exp|3) 'result .regs|3 .frame|3 .env|3 #f) (cg-if-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))) (.cg-if|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-if))
+(let () (begin (set! cg-if-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-if-result|2 0)) (begin (set! .cg-if-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.l1|6 (make-label)) (.l2|6 (make-label))) (begin (gen! .output|3 $branchf .l1|6 (cgreg-tos .regs|3)) (let* ((.regs2|9 (cgreg-copy .regs|3)) (.frame1|12 (if (if .tail?|3 (< (cgframe-size .frame|3) 0) #f) (cgframe-initial) .frame|3)) (.frame2|15 (if (eq? .frame|3 .frame1|12) (cgframe-copy .frame1|12) (cgframe-initial))) (.t0|18 (cgreg-lookup-reg .regs|3 0))) (let () (begin (if (not (eq? .frame|3 .frame1|12)) (let ((.live|24 (cgframe-livevars .frame|3))) (begin (cgframe-livevars-set! .frame1|12 .live|24) (cgframe-livevars-set! .frame2|15 .live|24) (gen-save! .output|3 .frame1|12 .t0|18) (cg-saveregs .output|3 .regs|3 .frame1|12))) (unspecified)) (let ((.r|27 (cg0 .output|3 (if.then .exp|3) .target|3 .regs|3 .frame1|12 .env|3 .tail?|3))) (begin (if (not .tail?|3) (gen! .output|3 $skip .l2|6 (cgreg-live .regs|3 .r|27)) (unspecified)) (gen! .output|3 $.label .l1|6) (if (not (eq? .frame|3 .frame1|12)) (begin (gen-save! .output|3 .frame2|15 .t0|18) (cg-saveregs .output|3 .regs2|9 .frame2|15)) (cgframe-update-stale! .frame2|15)) (cg0 .output|3 (if.else .exp|3) .r|27 .regs2|9 .frame2|15 .env|3 .tail?|3) (if (not .tail?|3) (begin (gen! .output|3 $.label .l2|6) (cgreg-join! .regs|3 .regs2|9) (cgframe-join! .frame1|12 .frame2|15)) (unspecified)) (if (if (not .target|3) (if (not (eq? .r|27 'result)) (not (cgreg-lookup-reg .regs|3 .r|27)) #f) #f) (cg-move .output|3 .frame|3 .regs|3 .r|27 'result) .r|27)))))))))) (.cg-if-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-if-result))
+(let () (begin (set! cg-variable (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-variable|2 0)) (begin (set! .cg-variable|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.return-nostore|6 (unspecified)) (.return|6 (unspecified))) (begin (set! .return-nostore|6 (lambda (.id|7) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (if (if .target|3 (not (eq? 'result .target|3)) #f) (begin (gen! .output|3 $setreg .target|3) (cgreg-bind! .regs|3 .target|3 .id|7) .target|3) 'result)))) (set! .return|6 (lambda (.id|10) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (if (if .target|3 (not (eq? 'result .target|3)) #f) (begin (gen! .output|3 $setreg .target|3) (cgreg-bind! .regs|3 .target|3 .id|10) (gen-store! .output|3 .frame|3 .target|3 .id|10) .target|3) 'result)))) (let* ((.id|13 (variable.name .exp|3)) (.entry|16 (var-lookup .id|13 .regs|3 .frame|3 .env|3))) (let () (let ((.temp|20|23 (entry.kind .entry|16))) (if (memv .temp|20|23 '(global integrable)) (begin (gen! .output|3 $global .id|13) (.return|6 (newtemp))) (if (memv .temp|20|23 '(lexical)) (let ((.m|28 (entry.rib .entry|16)) (.n|28 (entry.offset .entry|16))) (begin (gen! .output|3 $lexical .m|28 .n|28 .id|13) (if (let ((.temp|29|32 (zero? .m|28))) (if .temp|29|32 .temp|29|32 (< (cgframe-size .frame|3) 0))) (.return-nostore|6 .id|13) (.return|6 .id|13)))) (if (memv .temp|20|23 '(procedure)) (error "Bug in cg-variable" .exp|3) (if (memv .temp|20|23 '(register)) (let ((.r|39 (entry.regnum .entry|16))) (if (let ((.temp|40|43 .tail?|3)) (if .temp|40|43 .temp|40|43 (if .target|3 (not (eqv? .target|3 .r|39)) #f))) (begin (gen! .output|3 $reg (entry.regnum .entry|16) .id|13) (.return-nostore|6 .id|13)) .r|39)) (if (memv .temp|20|23 '(frame)) (if (eq? .target|3 'result) (begin (gen-stack! .output|3 .frame|3 .id|13) (.return|6 .id|13)) (if .target|3 (begin (gen-load! .output|3 .frame|3 .target|3 .id|13) (cgreg-bind! .regs|3 .target|3 .id|13) .target|3) (let ((.r|54 (choose-register .regs|3 .frame|3))) (begin (gen-load! .output|3 .frame|3 .r|54 .id|13) (cgreg-bind! .regs|3 .r|54 .id|13) .r|54)))) (error "Bug in cg-variable" .exp|3))))))))))))) (.cg-variable|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-variable))
+(let () (begin (set! cg-sequential (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-sequential|2 0)) (begin (set! .cg-sequential|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (cg-sequential-loop .output|3 (begin.exprs .exp|3) .target|3 .regs|3 .frame|3 .env|3 .tail?|3))) (.cg-sequential|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-sequential))
+(let () (begin (set! cg-sequential-loop (lambda (.output|1 .exprs|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-sequential-loop|2 0)) (begin (set! .cg-sequential-loop|2 (lambda (.output|3 .exprs|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (null? .exprs|3) (begin (gen! .output|3 $const unspecified) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (null? (let ((.x|6|9 .exprs|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (cg0 .output|3 (let ((.x|10|13 .exprs|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (let ((.x|15|18 .exprs|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) #f .regs|3 .frame|3 .env|3 #f) (.cg-sequential-loop|2 .output|3 (let ((.x|19|22 .exprs|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))) .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))))) (.cg-sequential-loop|2 .output|1 .exprs|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-sequential-loop))
+(let () (begin (set! cg-saveregs (lambda (.output|1 .regs|1 .frame|1) (let ((.cg-saveregs|2 0)) (begin (set! .cg-saveregs|2 (lambda (.output|3 .regs|3 .frame|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .vars|12) (if (null? .vars|12) (if #f #f (unspecified)) (begin (begin #t (let ((.t|17 (let ((.x|18|21 .vars|12)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if .t|17 (gen-store! .output|3 .frame|3 .i|12 .t|17) (unspecified)))) (.loop|5|8|11 (+ .i|12 1) (let ((.x|22|25 .vars|12)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25)))))))) (.loop|5|8|11 1 (let ((.x|26|29 (cgreg-vars .regs|3))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))))))) (.cg-saveregs|2 .output|1 .regs|1 .frame|1))))) 'cg-saveregs))
+(let () (begin (set! cg-move (lambda (.output|1 .frame|1 .regs|1 .src|1 .dst|1) (let ((.cg-move|2 0)) (begin (set! .cg-move|2 (lambda (.output|3 .frame|3 .regs|3 .src|3 .dst|3) (let ((.bind|5 (unspecified))) (begin (set! .bind|5 (lambda (.dst|6) (let ((.temp|9 (newtemp))) (begin (cgreg-bind! .regs|3 .dst|6 .temp|9) (gen-store! .output|3 .frame|3 .dst|6 .temp|9) .dst|6)))) (if (not .dst|3) .src|3 (if (eqv? .src|3 .dst|3) .dst|3 (if (eq? .dst|3 'result) (begin (gen! .output|3 $reg .src|3) .dst|3) (if (eq? .src|3 'result) (begin (gen! .output|3 $setreg .dst|3) (.bind|5 .dst|3)) (if (if (not (zero? .src|3)) (not (zero? .dst|3)) #f) (begin (gen! .output|3 $movereg .src|3 .dst|3) (.bind|5 .dst|3)) (begin (gen! .output|3 $reg .src|3) (gen! .output|3 $setreg .dst|3) (.bind|5 .dst|3))))))))))) (.cg-move|2 .output|1 .frame|1 .regs|1 .src|1 .dst|1))))) 'cg-move))
+(let () (begin (set! choose-register (lambda (.regs|1 .frame|1) (let ((.choose-register|2 0)) (begin (set! .choose-register|2 (lambda (.regs|3 .frame|3) (let ((.x|4|7 (choose-registers .regs|3 .frame|3 1))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.choose-register|2 .regs|1 .frame|1))))) 'choose-register))
+(let () (begin (set! choose-registers (lambda (.regs|1 .frame|1 .n|1) (let ((.choose-registers|2 0)) (begin (set! .choose-registers|2 (lambda (.regs|3 .frame|3 .n|3) (let ((.hardcase|4 (unspecified)) (.loop2|4 (unspecified)) (.loop1|4 (unspecified))) (begin (set! .hardcase|4 (lambda () (let* ((.frame-exists?|8 (not (< (cgframe-size .frame|3) 0))) (.stufftosort|11 (let () (let ((.loop|172|175|178 (unspecified))) (begin (set! .loop|172|175|178 (lambda (.y1|167|168|179 .results|167|171|179) (if (null? .y1|167|168|179) (reverse .results|167|171|179) (begin #t (.loop|172|175|178 (let ((.x|183|186 .y1|167|168|179)) (begin (.check! (pair? .x|183|186) 1 .x|183|186) (cdr:pair .x|183|186))) (cons (let* ((.r|187 (let ((.x|220|223 .y1|167|168|179)) (begin (.check! (pair? .x|220|223) 0 .x|220|223) (car:pair .x|220|223)))) (.t|190 (cgreg-lookup-reg .regs|3 .r|187)) (.spilled?|193 (if .t|190 (cgframe-spilled? .frame|3 .t|190) #f))) (let () (let* ((.t1|197|200 .r|187) (.t2|197|203 (let* ((.t1|207|210 .t|190) (.t2|207|213 (cons .spilled?|193 '()))) (let () (cons .t1|207|210 .t2|207|213))))) (let () (cons .t1|197|200 .t2|197|203))))) .results|167|171|179)))))) (.loop|172|175|178 (let ((.x|224|227 (iota *nregs*))) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227))) '()))))) (.registers|14 (twobit-sort (lambda (.x1|65 .x2|65) (let ((.r1|68 (let ((.x|141|144 .x1|65)) (begin (.check! (pair? .x|141|144) 0 .x|141|144) (car:pair .x|141|144)))) (.r2|68 (let ((.x|145|148 .x2|65)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148)))) (.t1|68 (let ((.x|150|153 (let ((.x|154|157 .x1|65)) (begin (.check! (pair? .x|154|157) 1 .x|154|157) (cdr:pair .x|154|157))))) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153)))) (.t2|68 (let ((.x|159|162 (let ((.x|163|166 .x2|65)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))))) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))))) (if (< .r1|68 *nhwregs*) (if (not .t1|68) #t (if (< .r2|68 *nhwregs*) (if (not .t2|68) #f (if (let ((.x|75|78 (let ((.x|79|82 (let ((.x|83|86 .x1|65)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86))))) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))) #t (if (let ((.x|89|92 (let ((.x|93|96 (let ((.x|97|100 .x2|65)) (begin (.check! (pair? .x|97|100) 1 .x|97|100) (cdr:pair .x|97|100))))) (begin (.check! (pair? .x|93|96) 1 .x|93|96) (cdr:pair .x|93|96))))) (begin (.check! (pair? .x|89|92) 0 .x|89|92) (car:pair .x|89|92))) #f #t))) (if .frame-exists?|8 #t (if .t2|68 #t #f)))) (if (< .r2|68 *nhwregs*) (if .frame-exists?|8 #f (if .t1|68 #f (if .t2|68 #t #f))) (if .t1|68 (if (if (let ((.x|113|116 (let ((.x|117|120 (let ((.x|121|124 .x1|65)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124))))) (begin (.check! (pair? .x|117|120) 1 .x|117|120) (cdr:pair .x|117|120))))) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116))) (if .t2|68 (not (let ((.x|128|131 (let ((.x|132|135 (let ((.x|136|139 .x2|65)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))))) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))))) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131)))) #f) #f) #t #f) #t))))) .stufftosort|11))) (let () (begin '(for-each (lambda (register) (let ((t (cadr register)) (spilled? (caddr register))) (if (and t (not spilled?)) (cgframe-touch! frame t)))) registers) (let () (let ((.loop|18|22|25 (unspecified))) (begin (set! .loop|18|22|25 (lambda (.sorted|26 .rs|26 .n|26) (if (zero? .n|26) (reverse .rs|26) (begin #t (.loop|18|22|25 (let ((.x|29|32 .sorted|26)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))) (cons (let ((.x|33|36 .sorted|26)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))) .rs|26) (- .n|26 1)))))) (.loop|18|22|25 (let () (let ((.loop|42|45|48 (unspecified))) (begin (set! .loop|42|45|48 (lambda (.y1|37|38|49 .results|37|41|49) (if (null? .y1|37|38|49) (reverse .results|37|41|49) (begin #t (.loop|42|45|48 (let ((.x|53|56 .y1|37|38|49)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) (cons (let ((.x|57|60 (let ((.x|61|64 .y1|37|38|49)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))))) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))) .results|37|41|49)))))) (.loop|42|45|48 .registers|14 '())))) '() .n|3))))))))) (set! .loop2|4 (lambda (.i|229 .n|229 .good|229) (if (zero? .n|229) .good|229 (if (zero? .i|229) (.hardcase|4) (let ((.t|235 (cgreg-lookup-reg .regs|3 .i|229))) (if (if .t|235 (cgframe-spilled? .frame|3 .t|235) #f) (.loop2|4 (- .i|229 1) (- .n|229 1) (cons .i|229 .good|229)) (.loop2|4 (- .i|229 1) .n|229 .good|229))))))) (set! .loop1|4 (lambda (.i|238 .n|238 .good|238) (if (zero? .n|238) .good|238 (if (zero? .i|238) (if (< (cgframe-size .frame|3) 0) (.hardcase|4) (.loop2|4 (- *nhwregs* 1) .n|238 .good|238)) (if (cgreg-lookup-reg .regs|3 .i|238) (.loop1|4 (- .i|238 1) .n|238 .good|238) (.loop1|4 (- .i|238 1) (- .n|238 1) (cons .i|238 .good|238))))))) (if (< .n|3 *nregs*) (.loop1|4 (- *nhwregs* 1) .n|3 '()) (error (string-append "Compiler bug: can't allocate " (number->string .n|3) " registers on this target."))))))) (.choose-registers|2 .regs|1 .frame|1 .n|1))))) 'choose-registers))
+(let () (begin (set! cg-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-call|2 0)) (begin (set! .cg-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.proc|6 (call.proc .exp|3))) (if (if (lambda? .proc|6) (list? (lambda.args .proc|6)) #f) (cg-let .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (not (variable? .proc|6)) (cg-unknown-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.entry|14 (var-lookup (variable.name .proc|6) .regs|3 .frame|3 .env|3)) (.temp|15|18 (entry.kind .entry|14))) (if (memv .temp|15|18 '(global lexical frame register)) (cg-unknown-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|15|18 '(integrable)) (cg-integrable-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|15|18 '(procedure)) (cg-known-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Bug in cg-call" .exp|3)))))))))) (.cg-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-call))
+(let () (begin (set! cg-unknown-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-unknown-call|2 0)) (begin (set! .cg-unknown-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.args|9 (call.args .exp|3)) (.n|12 (length .args|9)) (.l|15 (make-label))) (let () (if (>= (+ .n|12 1) *lastreg*) (cg-big-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.r0|23 (cgreg-lookup-reg .regs|3 0))) (begin (if (variable? .proc|6) (let ((.entry|26 (cgreg-lookup .regs|3 (variable.name .proc|6)))) (begin (if (if .entry|26 (<= (entry.regnum .entry|26) .n|12) #f) (begin (cg-arguments .output|3 (iota1 (+ .n|12 1)) (append .args|9 (cons .proc|6 '())) .regs|3 .frame|3 .env|3) (gen! .output|3 $reg (+ .n|12 1))) (begin (cg-arguments .output|3 (iota1 .n|12) .args|9 .regs|3 .frame|3 .env|3) (cg0 .output|3 .proc|6 'result .regs|3 .frame|3 .env|3 #f))) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|15))) (gen! .output|3 $invoke .n|12))) (begin (cg-arguments .output|3 (iota1 (+ .n|12 1)) (append .args|9 (cons .proc|6 '())) .regs|3 .frame|3 .env|3) (gen! .output|3 $reg (+ .n|12 1)) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|15))) (gen! .output|3 $invoke .n|12))) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|15) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|23) (gen-load! .output|3 .frame|3 0 .r0|23) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))) (.cg-unknown-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-unknown-call))
+(let () (begin (set! cg-known-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-known-call|2 0)) (begin (set! .cg-known-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|6 (call.args .exp|3)) (.n|9 (length .args|6)) (.l|12 (make-label))) (let () (if (>= (+ .n|9 1) *lastreg*) (cg-big-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.r0|20 (cgreg-lookup-reg .regs|3 0))) (begin (cg-arguments .output|3 (iota1 .n|9) .args|6 .regs|3 .frame|3 .env|3) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|12))) (let* ((.entry|23 (cgenv-lookup .env|3 (variable.name (call.proc .exp|3)))) (.label|26 (entry.label .entry|23)) (.m|29 (entry.rib .entry|23))) (let () (if (zero? .m|29) (gen! .output|3 $branch .label|26 .n|9) (gen! .output|3 $jump .m|29 .label|26 .n|9)))) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|12) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|20) (gen-load! .output|3 .frame|3 0 .r0|20) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))) (.cg-known-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-known-call))
+(let () (begin (set! cg-big-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-big-call|2 0)) (begin (set! .cg-big-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.args|9 (call.args .exp|3)) (.n|12 (length .args|9)) (.argslots|15 (newtemps .n|12)) (.procslot|18 (newtemp)) (.r0|21 (cgreg-lookup-reg .regs|3 0)) (.r-1|24 (- *nregs* 1)) (.entry|27 (if (variable? .proc|6) (let ((.entry|103 (var-lookup (variable.name .proc|6) .regs|3 .frame|3 .env|3))) (if (eq? (entry.kind .entry|103) 'procedure) .entry|103 #f)) #f)) (.l|30 (make-label))) (let () (begin (if (not .entry|27) (begin (cg0 .output|3 .proc|6 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .procslot|18)) (unspecified)) (let ((.f|34|38|41 (lambda (.arg|74 .argslot|74) (begin (cg0 .output|3 .arg|74 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .argslot|74))))) (let () (let ((.loop|43|46|49 (unspecified))) (begin (set! .loop|43|46|49 (lambda (.y1|34|36|50 .y1|34|35|50) (if (let ((.temp|52|55 (null? .y1|34|36|50))) (if .temp|52|55 .temp|52|55 (null? .y1|34|35|50))) (if #f #f (unspecified)) (begin (begin #t (.f|34|38|41 (let ((.x|58|61 .y1|34|36|50)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) (let ((.x|62|65 .y1|34|35|50)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65))))) (.loop|43|46|49 (let ((.x|66|69 .y1|34|36|50)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (let ((.x|70|73 .y1|34|35|50)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73)))))))) (.loop|43|46|49 .args|9 .argslots|15))))) (cgreg-clear! .regs|3) (gen! .output|3 $const '()) (gen! .output|3 $setreg .r-1|24) (let () (let ((.loop|76|79|82 (unspecified))) (begin (set! .loop|76|79|82 (lambda (.i|83 .slots|83) (if (zero? .i|83) (if #f #f (unspecified)) (begin (begin #t (if (< .i|83 .r-1|24) (gen-load! .output|3 .frame|3 .i|83 (let ((.x|86|89 .slots|83)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89)))) (begin (gen-stack! .output|3 .frame|3 (let ((.x|90|93 .slots|83)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (gen! .output|3 $op2 $cons .r-1|24) (gen! .output|3 $setreg .r-1|24)))) (.loop|76|79|82 (- .i|83 1) (let ((.x|94|97 .slots|83)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97)))))))) (.loop|76|79|82 .n|12 (reverse .argslots|15))))) (if (not .entry|27) (gen-stack! .output|3 .frame|3 .procslot|18) (unspecified)) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|30))) (if .entry|27 (let ((.label|100 (entry.label .entry|27)) (.m|100 (entry.rib .entry|27))) (if (zero? .m|100) (gen! .output|3 $branch .label|100 .n|12) (gen! .output|3 $jump .m|100 .label|100 .n|12))) (gen! .output|3 $invoke .n|12)) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|30) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|21) (gen-load! .output|3 .frame|3 0 .r0|21) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))) (.cg-big-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-big-call))
+(let () (begin (set! cg-integrable-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-integrable-call|2 0)) (begin (set! .cg-integrable-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.args|6 (call.args .exp|3)) (.entry|6 (var-lookup (variable.name (call.proc .exp|3)) .regs|3 .frame|3 .env|3))) (if (= (entry.arity .entry|6) (length .args|6)) (begin (let ((.temp|7|10 (entry.arity .entry|6))) (if (memv .temp|7|10 '(0)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(1)) (begin (cg0 .output|3 (let ((.x|13|16 .args|6)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) 'result .regs|3 .frame|3 .env|3 #f) (gen! .output|3 $op1 (entry.op .entry|6))) (if (memv .temp|7|10 '(2)) (cg-integrable-call2 .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (if (memv .temp|7|10 '(3)) (cg-integrable-call3 .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (error "Bug detected by cg-integrable-call" (make-readable .exp|3))))))) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (< (entry.arity .entry|6) 0) (cg-special .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Wrong number of arguments to integrable procedure" (make-readable .exp|3))))))) (.cg-integrable-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-integrable-call))
+(let () (begin (set! cg-integrable-call2 (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-integrable-call2|2 0)) (begin (set! .cg-integrable-call2|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (begin (let ((.op|6 (entry.op .entry|3))) (if (if (entry.imm .entry|3) (if (constant? (let ((.x|10|13 (let ((.x|14|17 .args|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) ((entry.imm .entry|3) (constant.value (let ((.x|20|23 (let ((.x|24|27 .args|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) #f) #f) (begin (cg0 .output|3 (let ((.x|28|31 .args|3)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) 'result .regs|3 .frame|3 .env|3 #f) (gen! .output|3 $op2imm .op|6 (constant.value (let ((.x|33|36 (let ((.x|37|40 .args|3)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))))) (let* ((.reg2|43 (cg0 .output|3 (let ((.x|78|81 (let ((.x|82|85 .args|3)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81))) #f .regs|3 .frame|3 .env|3 #f)) (.r2|46 (choose-register .regs|3 .frame|3)) (.t2|49 (if (eq? .reg2|43 'result) (let ((.t2|76 (newtemp))) (begin (gen! .output|3 $setreg .r2|46) (cgreg-bind! .regs|3 .r2|46 .t2|76) (gen-store! .output|3 .frame|3 .r2|46 .t2|76) .t2|76)) (cgreg-lookup-reg .regs|3 .reg2|43)))) (let () (begin (cg0 .output|3 (let ((.x|53|56 .args|3)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56))) 'result .regs|3 .frame|3 .env|3 #f) (let ((.r2|59 (let ((.temp|63|66 (let ((.entry|73 (cgreg-lookup .regs|3 .t2|49))) (if .entry|73 (entry.regnum .entry|73) #f)))) (if .temp|63|66 .temp|63|66 (let ((.r2|70 (choose-register .regs|3 .frame|3))) (begin (cgreg-bind! .regs|3 .r2|70 .t2|49) (gen-load! .output|3 .frame|3 .r2|70 .t2|49) .r2|70)))))) (let () (begin (gen! .output|3 $op2 (entry.op .entry|3) .r2|59) (if (eq? .reg2|43 'result) (begin (cgreg-release! .regs|3 .r2|59) (cgframe-release! .frame|3 .t2|49)) (unspecified)))))))))) 'result))) (.cg-integrable-call2|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-integrable-call2))
+(let () (begin (set! cg-integrable-call3 (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-integrable-call3|2 0)) (begin (set! .cg-integrable-call3|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (begin (let* ((.reg2|6 (cg0 .output|3 (let ((.x|121|124 (let ((.x|125|128 .args|3)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))))) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))) #f .regs|3 .frame|3 .env|3 #f)) (.r2|9 (choose-register .regs|3 .frame|3)) (.t2|12 (if (eq? .reg2|6 'result) (let ((.t2|119 (newtemp))) (begin (gen! .output|3 $setreg .r2|9) (cgreg-bind! .regs|3 .r2|9 .t2|119) (gen-store! .output|3 .frame|3 .r2|9 .t2|119) .t2|119)) (cgreg-lookup-reg .regs|3 .reg2|6))) (.reg3|15 (cg0 .output|3 (let ((.x|105|108 (let ((.x|109|112 (let ((.x|113|116 .args|3)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116))))) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))))) (begin (.check! (pair? .x|105|108) 0 .x|105|108) (car:pair .x|105|108))) #f .regs|3 .frame|3 .env|3 #f)) (.spillregs|18 (choose-registers .regs|3 .frame|3 2)) (.t3|21 (if (eq? .reg3|15 'result) (let ((.t3|86 (newtemp)) (.r3|86 (if (eq? .t2|12 (cgreg-lookup-reg .regs|3 (let ((.x|87|90 .spillregs|18)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (let ((.x|92|95 (let ((.x|96|99 .spillregs|18)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 0 .x|92|95) (car:pair .x|92|95))) (let ((.x|100|103 .spillregs|18)) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103)))))) (begin (gen! .output|3 $setreg .r3|86) (cgreg-bind! .regs|3 .r3|86 .t3|86) (gen-store! .output|3 .frame|3 .r3|86 .t3|86) .t3|86)) (cgreg-lookup-reg .regs|3 .reg3|15)))) (let () (begin (cg0 .output|3 (let ((.x|25|28 .args|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) 'result .regs|3 .frame|3 .env|3 #f) (let* ((.spillregs|31 (choose-registers .regs|3 .frame|3 2)) (.r2|34 (let ((.temp|69|72 (let ((.entry|83 (cgreg-lookup .regs|3 .t2|12))) (if .entry|83 (entry.regnum .entry|83) #f)))) (if .temp|69|72 .temp|69|72 (let ((.r2|76 (let ((.x|77|80 .spillregs|31)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (begin (cgreg-bind! .regs|3 .r2|76 .t2|12) (gen-load! .output|3 .frame|3 .r2|76 .t2|12) .r2|76))))) (.r3|37 (let ((.temp|41|44 (let ((.entry|68 (cgreg-lookup .regs|3 .t3|21))) (if .entry|68 (entry.regnum .entry|68) #f)))) (if .temp|41|44 .temp|41|44 (let ((.r3|48 (if (eq? .r2|34 (let ((.x|49|52 .spillregs|31)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52)))) (let ((.x|54|57 (let ((.x|58|61 .spillregs|31)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))))) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57))) (let ((.x|62|65 .spillregs|31)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))))) (begin (cgreg-bind! .regs|3 .r3|48 .t3|21) (gen-load! .output|3 .frame|3 .r3|48 .t3|21) .r3|48)))))) (let () (begin (gen! .output|3 $op3 (entry.op .entry|3) .r2|34 .r3|37) (if (eq? .reg2|6 'result) (begin (cgreg-release! .regs|3 .r2|34) (cgframe-release! .frame|3 .t2|12)) (unspecified)) (if (eq? .reg3|15 'result) (begin (cgreg-release! .regs|3 .r3|37) (cgframe-release! .frame|3 .t3|21)) (unspecified)))))))) 'result))) (.cg-integrable-call3|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-integrable-call3))
+(let () (begin (set! cg-primop-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-primop-args|2 0)) (begin (set! .cg-primop-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.finish-loop|4 (unspecified)) (.eval-first-into-result|4 (unspecified)) (.eval-loop|4 (unspecified))) (begin (set! .finish-loop|4 (lambda (.disjoint|5 .temps|5 .mask|5 .registers|5) (if (null? .temps|5) .registers|5 (let* ((.t|8 (let ((.x|54|57 .temps|5)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) (.entry|11 (cgreg-lookup .regs|3 .t|8))) (let () (if .entry|11 (let ((.r|17 (entry.regnum .entry|11))) (begin (if (let ((.x|18|21 .mask|5)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (begin (cgreg-release! .regs|3 .r|17) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|22|25 .temps|5)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) (let ((.x|26|29 .mask|5)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (cons .r|17 .registers|5)))) (let ((.r|32 (let ((.x|50|53 .disjoint|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .r|32 .registers|5) (.finish-loop|4 (let ((.x|34|37 .disjoint|5)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) .temps|5 .mask|5 .registers|5) (begin (gen-load! .output|3 .frame|3 .r|32 .t|8) (cgreg-bind! .regs|3 .r|32 .t|8) (if (let ((.x|38|41 .mask|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (begin (cgreg-release! .regs|3 .r|32) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|42|45 .temps|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) (let ((.x|46|49 .mask|5)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))) (cons .r|32 .registers|5))))))))))) (set! .eval-first-into-result|4 (lambda (.temps|58 .mask|58) (begin (cg0 .output|3 (let ((.x|59|62 .args|3)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) 'result .regs|3 .frame|3 .env|3 #f) (.finish-loop|4 (choose-registers .regs|3 .frame|3 (length .temps|58)) .temps|58 .mask|58 '())))) (set! .eval-loop|4 (lambda (.args|63 .temps|63 .mask|63) (if (null? .args|63) (.eval-first-into-result|4 .temps|63 .mask|63) (let ((.reg|66 (cg0 .output|3 (let ((.x|84|87 .args|63)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) #f .regs|3 .frame|3 .env|3 #f))) (if (eq? .reg|66 'result) (let* ((.r|69 (choose-register .regs|3 .frame|3)) (.t|72 (newtemp))) (let () (begin (gen! .output|3 $setreg .r|69) (cgreg-bind! .regs|3 .r|69 .t|72) (gen-store! .output|3 .frame|3 .r|69 .t|72) (.eval-loop|4 (let ((.x|76|79 .args|63)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons .t|72 .temps|63) (cons #t .mask|63))))) (.eval-loop|4 (let ((.x|80|83 .args|63)) (begin (.check! (pair? .x|80|83) 1 .x|80|83) (cdr:pair .x|80|83))) (cons (cgreg-lookup-reg .regs|3 .reg|66) .temps|63) (cons #f .mask|63))))))) (if (< (length .args|3) *nregs*) (.eval-loop|4 (let ((.x|88|91 .args|3)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))) '() '()) (error "Bug detected by cg-primop-args" .args|3)))))) (.cg-primop-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-primop-args))
+(let () (begin (set! cg-arguments (lambda (.output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-arguments|2 0)) (begin (set! .cg-arguments|2 (lambda (.output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.evalargs0|4 (unspecified)) (.evalargs|4 (unspecified)) (.sortargs|4 (unspecified))) (begin (set! .evalargs0|4 (lambda (.targets|5 .args|5 .temps|5) (if (not (null? .targets|5)) (let ((.para|8 (let ((.regvars|92 (let () (let ((.loop|139|142|145 (unspecified))) (begin (set! .loop|139|142|145 (lambda (.y1|134|135|146 .results|134|138|146) (if (null? .y1|134|135|146) (reverse .results|134|138|146) (begin #t (.loop|139|142|145 (let ((.x|150|153 .y1|134|135|146)) (begin (.check! (pair? .x|150|153) 1 .x|150|153) (cdr:pair .x|150|153))) (cons (let ((.reg|154 (let ((.x|155|158 .y1|134|135|146)) (begin (.check! (pair? .x|155|158) 0 .x|155|158) (car:pair .x|155|158))))) (cgreg-lookup-reg .regs|3 .reg|154)) .results|134|138|146)))))) (.loop|139|142|145 .targets|5 '())))))) (let () (parallel-assignment .targets|5 (let () (let ((.loop|102|106|109 (unspecified))) (begin (set! .loop|102|106|109 (lambda (.y1|96|98|110 .y1|96|97|110 .results|96|101|110) (if (let ((.temp|112|115 (null? .y1|96|98|110))) (if .temp|112|115 .temp|112|115 (null? .y1|96|97|110))) (reverse .results|96|101|110) (begin #t (.loop|102|106|109 (let ((.x|118|121 .y1|96|98|110)) (begin (.check! (pair? .x|118|121) 1 .x|118|121) (cdr:pair .x|118|121))) (let ((.x|122|125 .y1|96|97|110)) (begin (.check! (pair? .x|122|125) 1 .x|122|125) (cdr:pair .x|122|125))) (cons (cons (let ((.x|126|129 .y1|96|98|110)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129))) (let ((.x|130|133 .y1|96|97|110)) (begin (.check! (pair? .x|130|133) 0 .x|130|133) (car:pair .x|130|133)))) .results|96|101|110)))))) (.loop|102|106|109 .regvars|92 .targets|5 '())))) .args|5))))) (if .para|8 (let ((.targets|11 .para|8) (.args|11 (cg-permute .args|5 .targets|5 .para|8)) (.temps|11 (cg-permute .temps|5 .targets|5 .para|8))) (let ((.f|12|17|20 (lambda (.arg|66 .r|66 .t|66) (begin (cg0 .output|3 .arg|66 .r|66 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|66 .t|66) (gen-store! .output|3 .frame|3 .r|66 .t|66))))) (let () (let ((.loop|22|26|29 (unspecified))) (begin (set! .loop|22|26|29 (lambda (.y1|12|15|30 .y1|12|14|30 .y1|12|13|30) (if (let ((.temp|32|35 (null? .y1|12|15|30))) (if .temp|32|35 .temp|32|35 (let ((.temp|36|39 (null? .y1|12|14|30))) (if .temp|36|39 .temp|36|39 (null? .y1|12|13|30))))) (if #f #f (unspecified)) (begin (begin #t (.f|12|17|20 (let ((.x|42|45 .y1|12|15|30)) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45))) (let ((.x|46|49 .y1|12|14|30)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) (let ((.x|50|53 .y1|12|13|30)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (.loop|22|26|29 (let ((.x|54|57 .y1|12|15|30)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))) (let ((.x|58|61 .y1|12|14|30)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) (let ((.x|62|65 .y1|12|13|30)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65)))))))) (.loop|22|26|29 .args|11 .para|8 .temps|11)))))) (let ((.r|69 (choose-register .regs|3 .frame|3)) (.t|69 (let ((.x|86|89 .temps|5)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89))))) (begin (cg0 .output|3 (let ((.x|70|73 .args|5)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))) .r|69 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|69 .t|69) (gen-store! .output|3 .frame|3 .r|69 .t|69) (.evalargs0|4 (let ((.x|74|77 .targets|5)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77))) (let ((.x|78|81 .args|5)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (let ((.x|82|85 .temps|5)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85)))))))) (unspecified)))) (set! .evalargs|4 (lambda (.targets1|159 .args1|159 .targets2|159 .args2|159) (let* ((.temps1|162 (newtemps (length .targets1|159))) (.temps2|165 (newtemps (length .targets2|159)))) (let () (begin (if (not (null? .args1|159)) (let ((.f|169|173|176 (lambda (.arg|217 .temp|217) (begin (cg0 .output|3 .arg|217 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .temp|217))))) (let () (let ((.loop|178|181|184 (unspecified))) (begin (set! .loop|178|181|184 (lambda (.y1|169|171|185 .y1|169|170|185) (if (let ((.temp|187|190 (null? .y1|169|171|185))) (if .temp|187|190 .temp|187|190 (null? .y1|169|170|185))) (if #f #f (unspecified)) (begin (begin #t (.f|169|173|176 (let ((.x|193|196 .y1|169|171|185)) (begin (.check! (pair? .x|193|196) 0 .x|193|196) (car:pair .x|193|196))) (let ((.x|197|200 .y1|169|170|185)) (begin (.check! (pair? .x|197|200) 0 .x|197|200) (car:pair .x|197|200))))) (.loop|178|181|184 (let ((.x|201|204 .y1|169|171|185)) (begin (.check! (pair? .x|201|204) 1 .x|201|204) (cdr:pair .x|201|204))) (let ((.x|205|208 .y1|169|170|185)) (begin (.check! (pair? .x|205|208) 1 .x|205|208) (cdr:pair .x|205|208)))))))) (.loop|178|181|184 (let ((.x|209|212 .args1|159)) (begin (.check! (pair? .x|209|212) 1 .x|209|212) (cdr:pair .x|209|212))) (let ((.x|213|216 .temps1|162)) (begin (.check! (pair? .x|213|216) 1 .x|213|216) (cdr:pair .x|213|216)))))))) (unspecified)) (if (not (null? .args1|159)) (.evalargs0|4 (cons (let ((.x|218|221 .targets1|159)) (begin (.check! (pair? .x|218|221) 0 .x|218|221) (car:pair .x|218|221))) .targets2|159) (cons (let ((.x|222|225 .args1|159)) (begin (.check! (pair? .x|222|225) 0 .x|222|225) (car:pair .x|222|225))) .args2|159) (cons (let ((.x|226|229 .temps1|162)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229))) .temps2|165)) (.evalargs0|4 .targets2|159 .args2|159 .temps2|165)) (let () (let ((.loop|236|239|242 (unspecified))) (begin (set! .loop|236|239|242 (lambda (.y1|230|232|243 .y1|230|231|243) (if (let ((.temp|245|248 (null? .y1|230|232|243))) (if .temp|245|248 .temp|245|248 (null? .y1|230|231|243))) (if #f #f (unspecified)) (begin (begin #t (let ((.r|251 (let ((.x|264|267 .y1|230|232|243)) (begin (.check! (pair? .x|264|267) 0 .x|264|267) (car:pair .x|264|267)))) (.t|251 (let ((.x|268|271 .y1|230|231|243)) (begin (.check! (pair? .x|268|271) 0 .x|268|271) (car:pair .x|268|271))))) (let ((.temp|254 (cgreg-lookup-reg .regs|3 .r|251))) (begin (if (not (eq? .temp|254 .t|251)) (let ((.entry|257 (var-lookup .t|251 .regs|3 .frame|3 .env|3))) (begin (let ((.temp|258|261 (entry.kind .entry|257))) (if (memv .temp|258|261 '(register)) (gen! .output|3 $movereg (entry.regnum .entry|257) .r|251) (if (memv .temp|258|261 '(frame)) (gen-load! .output|3 .frame|3 .r|251 .t|251) (unspecified)))) (cgreg-bind! .regs|3 .r|251 .t|251))) (unspecified)) (cgframe-release! .frame|3 .t|251))))) (.loop|236|239|242 (let ((.x|272|275 .y1|230|232|243)) (begin (.check! (pair? .x|272|275) 1 .x|272|275) (cdr:pair .x|272|275))) (let ((.x|276|279 .y1|230|231|243)) (begin (.check! (pair? .x|276|279) 1 .x|276|279) (cdr:pair .x|276|279)))))))) (.loop|236|239|242 (append .targets1|159 .targets2|159) (append .temps1|162 .temps2|165)))))))))) (set! .sortargs|4 (lambda (.targets|280 .args|280 .targets1|280 .args1|280 .targets2|280 .args2|280) (if (null? .args|280) (.evalargs|4 .targets1|280 .args1|280 .targets2|280 .args2|280) (let ((.target|283 (let ((.x|284|287 .targets|280)) (begin (.check! (pair? .x|284|287) 0 .x|284|287) (car:pair .x|284|287)))) (.arg|283 (let ((.x|288|291 .args|280)) (begin (.check! (pair? .x|288|291) 0 .x|288|291) (car:pair .x|288|291)))) (.targets|283 (let ((.x|292|295 .targets|280)) (begin (.check! (pair? .x|292|295) 1 .x|292|295) (cdr:pair .x|292|295)))) (.args|283 (let ((.x|296|299 .args|280)) (begin (.check! (pair? .x|296|299) 1 .x|296|299) (cdr:pair .x|296|299))))) (if (complicated? .arg|283 .env|3) (.sortargs|4 .targets|283 .args|283 (cons .target|283 .targets1|280) (cons .arg|283 .args1|280) .targets2|280 .args2|280) (.sortargs|4 .targets|283 .args|283 .targets1|280 .args1|280 (cons .target|283 .targets2|280) (cons .arg|283 .args2|280))))))) (if (parallel-assignment-optimization) (.sortargs|4 (reverse .targets|3) (reverse .args|3) '() '() '() '()) (cg-evalargs .output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3)))))) (.cg-arguments|2 .output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-arguments))
+(let () (begin (set! cg-evalargs (lambda (.output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-evalargs|2 0)) (begin (set! .cg-evalargs|2 (lambda (.output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.temps|6 (newtemps (length .targets|3)))) (begin (let ((.f|7|12|15 (lambda (.arg|61 .r|61 .t|61) (begin (cg0 .output|3 .arg|61 .r|61 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|61 .t|61) (gen-store! .output|3 .frame|3 .r|61 .t|61))))) (let () (let ((.loop|17|21|24 (unspecified))) (begin (set! .loop|17|21|24 (lambda (.y1|7|10|25 .y1|7|9|25 .y1|7|8|25) (if (let ((.temp|27|30 (null? .y1|7|10|25))) (if .temp|27|30 .temp|27|30 (let ((.temp|31|34 (null? .y1|7|9|25))) (if .temp|31|34 .temp|31|34 (null? .y1|7|8|25))))) (if #f #f (unspecified)) (begin (begin #t (.f|7|12|15 (let ((.x|37|40 .y1|7|10|25)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))) (let ((.x|41|44 .y1|7|9|25)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))) (let ((.x|45|48 .y1|7|8|25)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))))) (.loop|17|21|24 (let ((.x|49|52 .y1|7|10|25)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.x|53|56 .y1|7|9|25)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) (let ((.x|57|60 .y1|7|8|25)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60)))))))) (.loop|17|21|24 .args|3 .targets|3 .temps|6))))) (let () (let ((.loop|68|71|74 (unspecified))) (begin (set! .loop|68|71|74 (lambda (.y1|62|64|75 .y1|62|63|75) (if (let ((.temp|77|80 (null? .y1|62|64|75))) (if .temp|77|80 .temp|77|80 (null? .y1|62|63|75))) (if #f #f (unspecified)) (begin (begin #t (let ((.r|83 (let ((.x|87|90 .y1|62|64|75)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90)))) (.t|83 (let ((.x|91|94 .y1|62|63|75)) (begin (.check! (pair? .x|91|94) 0 .x|91|94) (car:pair .x|91|94))))) (let ((.temp|86 (cgreg-lookup-reg .regs|3 .r|83))) (begin (if (not (eq? .temp|86 .t|83)) (begin (gen-load! .output|3 .frame|3 .r|83 .t|83) (cgreg-bind! .regs|3 .r|83 .t|83)) (unspecified)) (cgframe-release! .frame|3 .t|83))))) (.loop|68|71|74 (let ((.x|95|98 .y1|62|64|75)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (let ((.x|99|102 .y1|62|63|75)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102)))))))) (.loop|68|71|74 .targets|3 .temps|6)))))))) (.cg-evalargs|2 .output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-evalargs))
+(let () (begin (set! complicated? (lambda (.exp|1 .env|1) (let ((.complicated?|2 0)) (begin (set! .complicated?|2 (lambda (.exp|3 .env|3) (let ((.temp|4|7 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (if (memv .temp|4|7 '(quote)) #f (if (memv .temp|4|7 '(lambda)) #t (if (memv .temp|4|7 '(set!)) (.complicated?|2 (assignment.rhs .exp|3) .env|3) (if (memv .temp|4|7 '(if)) (let ((.temp|12|15 (.complicated?|2 (if.test .exp|3) .env|3))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (.complicated?|2 (if.then .exp|3) .env|3))) (if .temp|16|19 .temp|16|19 (.complicated?|2 (if.else .exp|3) .env|3))))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) #f (some? (lambda (.exp|22) (.complicated?|2 .exp|22 .env|3)) (begin.exprs .exp|3))) (let ((.proc|26 (call.proc .exp|3))) (if (if (variable? .proc|26) (let ((.entry|31 (cgenv-lookup .env|3 (variable.name .proc|26)))) (eq? (entry.kind .entry|31) 'integrable)) #f) (some? (lambda (.exp|32) (.complicated?|2 .exp|32 .env|3)) (call.args .exp|3)) #t)))))))))) (.complicated?|2 .exp|1 .env|1))))) 'complicated?))
+(let () (begin (set! cg-permute (lambda (.src|1 .key|1 .newkey|1) (let ((.cg-permute|2 0)) (begin (set! .cg-permute|2 (lambda (.src|3 .key|3 .newkey|3) (let ((.alist|6 (let () (let ((.loop|35|39|42 (unspecified))) (begin (set! .loop|35|39|42 (lambda (.y1|29|31|43 .y1|29|30|43 .results|29|34|43) (if (let ((.temp|45|48 (null? .y1|29|31|43))) (if .temp|45|48 .temp|45|48 (null? .y1|29|30|43))) (reverse .results|29|34|43) (begin #t (.loop|35|39|42 (let ((.x|51|54 .y1|29|31|43)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (let ((.x|55|58 .y1|29|30|43)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))) (cons (cons (let ((.x|59|62 .y1|29|31|43)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|63|66 .y1|29|30|43)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) .results|29|34|43)))))) (.loop|35|39|42 .key|3 (iota (length .key|3)) '())))))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.newkey|14 .dest|14) (if (null? .newkey|14) (reverse .dest|14) (begin #t (.loop|7|10|13 (let ((.x|17|20 .newkey|14)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (list-ref .src|3 (let ((.x|21|24 (assq (let ((.x|25|28 .newkey|14)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) .alist|6))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) .dest|14)))))) (.loop|7|10|13 .newkey|3 '()))))))) (.cg-permute|2 .src|1 .key|1 .newkey|1))))) 'cg-permute))
+(let () (begin (set! parallel-assignment (lambda (.regnums|1 .alist|1 .exps|1) (if (null? .regnums|1) #t (let ((.x|4 (toposort (dependency-graph .regnums|1 .alist|1 .exps|1)))) (if .x|4 (reverse .x|4) #f))))) 'parallel-assignment))
+(let () (begin (set! dependency-graph (lambda (.regnums|1 .alist|1 .exps|1) (let ((.names|4 (let () (let ((.loop|66|69|72 (unspecified))) (begin (set! .loop|66|69|72 (lambda (.y1|61|62|73 .results|61|65|73) (if (null? .y1|61|62|73) (reverse .results|61|65|73) (begin #t (.loop|66|69|72 (let ((.x|77|80 .y1|61|62|73)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))) (cons (let ((.x|81|84 (let ((.x|85|88 .y1|61|62|73)) (begin (.check! (pair? .x|85|88) 0 .x|85|88) (car:pair .x|85|88))))) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))) .results|61|65|73)))))) (.loop|66|69|72 .alist|1 '())))))) (let () (let ((.loop|5|9|12 (unspecified))) (begin (set! .loop|5|9|12 (lambda (.regnums|13 .exps|13 .l|13) (if (null? .regnums|13) .l|13 (begin #t (.loop|5|9|12 (let ((.x|16|19 .regnums|13)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (let ((.x|20|23 .exps|13)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (cons (let ((.x|24|27 .regnums|13)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27))) (let () (let ((.loop|33|36|39 (unspecified))) (begin (set! .loop|33|36|39 (lambda (.y1|28|29|40 .results|28|32|40) (if (null? .y1|28|29|40) (reverse .results|28|32|40) (begin #t (.loop|33|36|39 (let ((.x|44|47 .y1|28|29|40)) (begin (.check! (pair? .x|44|47) 1 .x|44|47) (cdr:pair .x|44|47))) (cons (let* ((.var|48 (let ((.x|53|56 .y1|28|29|40)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56)))) (.x|49|52 (assq .var|48 .alist|1))) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) .results|28|32|40)))))) (.loop|33|36|39 (intersection (freevariables (let ((.x|57|60 .exps|13)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60)))) .names|4) '()))))) .l|13)))))) (.loop|5|9|12 .regnums|1 .exps|1 '()))))))) 'dependency-graph))
+(let () (begin (set! toposort (lambda (.graph|1) (if (null? (let ((.x|3|6 .graph|1)) (begin (.check! (pair? .x|3|6) 1 .x|3|6) (cdr:pair .x|3|6)))) (cons (let ((.x|9|12 (let ((.x|13|16 .graph|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) '()) (toposort2 .graph|1 '())))) 'toposort))
+(let () (begin (set! toposort2 (lambda (.totry|1 .tried|1) (if (null? .totry|1) #f (if (let ((.temp|4|7 (null? (let ((.x|45|48 (let ((.x|49|52 .totry|1)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))))) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48)))))) (if .temp|4|7 .temp|4|7 (if (null? (let ((.x|11|14 (let ((.x|15|18 (let ((.x|19|22 .totry|1)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))))) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (eq? (let ((.x|25|28 (let ((.x|29|32 (let ((.x|33|36 .totry|1)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|37|40 (let ((.x|41|44 .totry|1)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) #f))) (if (if (null? (let ((.x|54|57 .totry|1)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))) (null? .tried|1) #f) (cons (let ((.x|61|64 (let ((.x|65|68 .totry|1)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))) '()) (let* ((.node|71 (let ((.x|116|119 (let ((.x|120|123 .totry|1)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123))))) (begin (.check! (pair? .x|116|119) 0 .x|116|119) (car:pair .x|116|119)))) (.x|74 (toposort2 (let () (let ((.loop|83|86|89 (unspecified))) (begin (set! .loop|83|86|89 (lambda (.y1|78|79|90 .results|78|82|90) (if (null? .y1|78|79|90) (reverse .results|78|82|90) (begin #t (.loop|83|86|89 (let ((.x|94|97 .y1|78|79|90)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))) (cons (let ((.y|98 (let ((.x|107|110 .y1|78|79|90)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))))) (cons (let ((.x|99|102 .y|98)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102))) (remove .node|71 (let ((.x|103|106 .y|98)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106)))))) .results|78|82|90)))))) (.loop|83|86|89 (append (let ((.x|111|114 .totry|1)) (begin (.check! (pair? .x|111|114) 1 .x|111|114) (cdr:pair .x|111|114))) .tried|1) '())))) '()))) (let () (if .x|74 (cons .node|71 .x|74) #f)))) (toposort2 (let ((.x|125|128 .totry|1)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) (cons (let ((.x|129|132 .totry|1)) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .tried|1)))))) 'toposort2))
+(let () (begin (set! iota (lambda (.n|1) (iota2 .n|1 '()))) 'iota))
+(let () (begin (set! iota1 (lambda (.n|1) (let ((.x|2|5 (iota2 (+ .n|1 1) '()))) (begin (.check! (pair? .x|2|5) 1 .x|2|5) (cdr:pair .x|2|5))))) 'iota1))
+(let () (begin (set! iota2 (lambda (.n|1 .l|1) (if (zero? .n|1) .l|1 (let ((.n|4 (- .n|1 1))) (iota2 .n|4 (cons .n|4 .l|1)))))) 'iota2))
+(let () (begin (set! freevariables (lambda (.exp|1) (let ((.freevariables|2 0)) (begin (set! .freevariables|2 (lambda (.exp|3) (freevars2 .exp|3 '()))) (.freevariables|2 .exp|1))))) 'freevariables))
+(let () (begin (set! freevars2 (lambda (.exp|1 .env|1) (let ((.freevars2|2 0)) (begin (set! .freevars2|2 (lambda (.exp|3 .env|3) (if (symbol? .exp|3) (if (memq .exp|3 .env|3) '() (cons .exp|3 '())) (if (not (pair? .exp|3)) '() (let ((.keyword|10 (let ((.x|145|148 .exp|3)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))))) (if (eq? .keyword|10 'quote) '() (if (eq? .keyword|10 'lambda) (let ((.env|15 (append (make-null-terminated (let ((.x|51|54 (let ((.x|55|58 .exp|3)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))))) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))) .env|3))) (apply-union (let () (let ((.loop|21|24|27 (unspecified))) (begin (set! .loop|21|24|27 (lambda (.y1|16|17|28 .results|16|20|28) (if (null? .y1|16|17|28) (reverse .results|16|20|28) (begin #t (.loop|21|24|27 (let ((.x|32|35 .y1|16|17|28)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) (cons (let ((.x|36 (let ((.x|37|40 .y1|16|17|28)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))))) (.freevars2|2 .x|36 .env|15)) .results|16|20|28)))))) (.loop|21|24|27 (let ((.x|42|45 (let ((.x|46|49 .exp|3)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))))) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) '())))))) (if (let ((.t0|60|61|64 .keyword|10) (.t1|60|61|64 '(if set! begin))) (if (eq? .t0|60|61|64 'if) .t1|60|61|64 (let ((.t1|60|61|68 (let ((.x|86|89 .t1|60|61|64)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (if (eq? .t0|60|61|64 'set!) .t1|60|61|68 (let ((.t1|60|61|72 (let ((.x|82|85 .t1|60|61|68)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (if (eq? .t0|60|61|64 'begin) .t1|60|61|72 (let ((.t1|60|61|76 (let ((.x|78|81 .t1|60|61|72)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))))) #f))))))) (apply-union (let () (let ((.loop|95|98|101 (unspecified))) (begin (set! .loop|95|98|101 (lambda (.y1|90|91|102 .results|90|94|102) (if (null? .y1|90|91|102) (reverse .results|90|94|102) (begin #t (.loop|95|98|101 (let ((.x|106|109 .y1|90|91|102)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109))) (cons (let ((.x|110 (let ((.x|111|114 .y1|90|91|102)) (begin (.check! (pair? .x|111|114) 0 .x|111|114) (car:pair .x|111|114))))) (.freevars2|2 .x|110 .env|3)) .results|90|94|102)))))) (.loop|95|98|101 (let ((.x|115|118 .exp|3)) (begin (.check! (pair? .x|115|118) 1 .x|115|118) (cdr:pair .x|115|118))) '()))))) (apply-union (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.x|140 (let ((.x|141|144 .y1|120|121|132)) (begin (.check! (pair? .x|141|144) 0 .x|141|144) (car:pair .x|141|144))))) (.freevars2|2 .x|140 .env|3)) .results|120|124|132)))))) (.loop|125|128|131 .exp|3 '()))))))))))))) (.freevars2|2 .exp|1 .env|1))))) 'freevars2))
+(let () (begin (set! cg-let (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let|2 0)) (begin (set! .cg-let|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.vars|9 (lambda.args .proc|6)) (.n|12 (length .vars|9)) (.free|15 (lambda.f .proc|6)) (.live|18 (cgframe-livevars .frame|3))) (let () (if (if (null? (lambda.defs .proc|6)) (= .n|12 1) #f) (cg-let1 .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|26 (call.args .exp|3)) (.temps|29 (newtemps .n|12)) (.alist|32 (let () (let ((.loop|83|87|90 (unspecified))) (begin (set! .loop|83|87|90 (lambda (.y1|77|79|91 .y1|77|78|91 .results|77|82|91) (if (let ((.temp|93|96 (null? .y1|77|79|91))) (if .temp|93|96 .temp|93|96 (null? .y1|77|78|91))) (reverse .results|77|82|91) (begin #t (.loop|83|87|90 (let ((.x|99|102 .y1|77|79|91)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (let ((.x|103|106 .y1|77|78|91)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))) (cons (cons (let ((.x|107|110 .y1|77|79|91)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))) (let ((.x|111|114 .y1|77|78|91)) (begin (.check! (pair? .x|111|114) 0 .x|111|114) (car:pair .x|111|114)))) .results|77|82|91)))))) (.loop|83|87|90 .temps|29 .vars|9 '())))))) (let () (begin (let () (let ((.loop|42|45|48 (unspecified))) (begin (set! .loop|42|45|48 (lambda (.y1|36|38|49 .y1|36|37|49) (if (let ((.temp|51|54 (null? .y1|36|38|49))) (if .temp|51|54 .temp|51|54 (null? .y1|36|37|49))) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|57 (let ((.x|61|64 .y1|36|38|49)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64)))) (.t|57 (let ((.x|65|68 .y1|36|37|49)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (let ((.r|60 (choose-register .regs|3 .frame|3))) (begin (cg0 .output|3 .arg|57 .r|60 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|60 .t|57) (gen-store! .output|3 .frame|3 .r|60 .t|57))))) (.loop|42|45|48 (let ((.x|69|72 .y1|36|38|49)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))) (let ((.x|73|76 .y1|36|37|49)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76)))))))) (.loop|42|45|48 .args|26 .temps|29)))) (cgreg-rename! .regs|3 .alist|32) (cgframe-rename! .frame|3 .alist|32) (cg-let-release! .free|15 .live|18 .regs|3 .frame|3 .tail?|3) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))) (.cg-let|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let))
+(let () (begin (set! cg-let-release! (lambda (.free|1 .live|1 .regs|1 .frame|1 .tail?|1) (let ((.cg-let-release!|2 0)) (begin (set! .cg-let-release!|2 (lambda (.free|3 .live|3 .regs|3 .frame|3 .tail?|3) (if .tail?|3 (let ((.keepers|7 (cons (cgreg-lookup-reg .regs|3 0) .free|3))) (begin (cgreg-release-except! .regs|3 .keepers|7) (cgframe-release-except! .frame|3 .keepers|7))) (if .live|3 (let ((.keepers|11 (cons (cgreg-lookup-reg .regs|3 0) (union .live|3 .free|3)))) (begin (cgreg-release-except! .regs|3 .keepers|11) (cgframe-release-except! .frame|3 .keepers|11))) (unspecified))))) (.cg-let-release!|2 .free|1 .live|1 .regs|1 .frame|1 .tail?|1))))) 'cg-let-release!))
+(let () (begin (set! cg-let-body (lambda (.output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let-body|2 0)) (begin (set! .cg-let-body|2 (lambda (.output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.vars|6 (lambda.args .l|3)) (.free|6 (lambda.f .l|3)) (.live|6 (cgframe-livevars .frame|3))) (let ((.r|9 (cg-body .output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))) (begin (let () (let ((.loop|15|17|20 (unspecified))) (begin (set! .loop|15|17|20 (lambda (.y1|10|11|21) (if (null? .y1|10|11|21) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|25 (let ((.x|29|32 .y1|10|11|21)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) (.entry|28 (cgreg-lookup .regs|3 .v|25))) (begin (if .entry|28 (cgreg-release! .regs|3 (entry.regnum .entry|28)) (unspecified)) (cgframe-release! .frame|3 .v|25)))) (.loop|15|17|20 (let ((.x|33|36 .y1|10|11|21)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36)))))))) (.loop|15|17|20 .vars|6)))) (if (if (not .target|3) (if (not (eq? .r|9 'result)) (not (cgreg-lookup-reg .regs|3 .r|9)) #f) #f) (cg-move .output|3 .frame|3 .regs|3 .r|9 'result) .r|9)))))) (.cg-let-body|2 .output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let-body))
+(let () (begin (set! cg-let1 (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let1|2 0)) (begin (set! .cg-let1|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.v|9 (let ((.x|41|44 (lambda.args .proc|6))) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44)))) (.arg|12 (let ((.x|37|40 (call.args .exp|3))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) (.free|15 (lambda.f .proc|6)) (.live|18 (cgframe-livevars .frame|3)) (.body|21 (lambda.body .proc|6))) (let () (let ((.finish|25 (unspecified)) (.release-registers!|25 (unspecified)) (.evaluate-into-register|25 (unspecified))) (begin (set! .finish|25 (lambda () (begin (.release-registers!|25) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))) (set! .release-registers!|25 (lambda () (begin (cgframe-livevars-set! .frame|3 .live|18) (cg-let-release! .free|15 .live|18 .regs|3 .frame|3 .tail?|3)))) (set! .evaluate-into-register|25 (lambda (.r|28) (begin (cg0 .output|3 .arg|12 .r|28 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|28 .v|9) (gen-store! .output|3 .frame|3 .r|28 .v|9) .r|28))) (if .live|18 (cgframe-livevars-set! .frame|3 (union .live|18 .free|15)) (unspecified)) (if (assq .v|9 *regnames*) (begin (.evaluate-into-register|25 (let ((.x|30|33 (assq .v|9 *regnames*))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33)))) (.finish|25)) (if (not (memq .v|9 .free|15)) (begin (cg0 .output|3 .arg|12 #f .regs|3 .frame|3 .env|3 #f) (.finish|25)) (if .live|18 (begin (cg0 .output|3 .arg|12 'result .regs|3 .frame|3 .env|3 #f) (.release-registers!|25) (cg-let1-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (begin (.evaluate-into-register|25 (choose-register .regs|3 .frame|3)) (.finish|25))))))))))) (.cg-let1|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let1))
+(let () (begin (set! cg-let1-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let1-result|2 0)) (begin (set! .cg-let1-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.v|9 (let ((.x|63|66 (lambda.args .proc|6))) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) (.free|12 (lambda.f .proc|6)) (.live|15 (cgframe-livevars .frame|3)) (.body|18 (lambda.body .proc|6)) (.pattern|21 (cg-let-used-once .v|9 .body|18))) (let () (let ((.release-registers!|26 (unspecified)) (.move-to-register|26 (unspecified))) (begin (set! .release-registers!|26 (lambda () (begin (cgframe-livevars-set! .frame|3 .live|15) (cg-let-release! .free|12 .live|15 .regs|3 .frame|3 .tail?|3)))) (set! .move-to-register|26 (lambda (.r|28) (begin (gen! .output|3 $setreg .r|28) (cgreg-bind! .regs|3 .r|28 .v|9) (gen-store! .output|3 .frame|3 .r|28 .v|9) .r|28))) (let ((.temp|25|31 .pattern|21)) (if (memv .temp|25|31 '(if)) (cg-if-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-if)) (begin (if .live|15 (cgframe-livevars-set! .frame|3 (union .live|15 .free|12)) (unspecified)) (cg-if-result .output|3 (let ((.x|34|37 (call.args .body|18))) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) 'result .regs|3 .frame|3 .env|3 #f) (.release-registers!|26) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(set!)) (cg-assignment-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-set!)) (begin (cg-assignment-result .output|3 (let ((.x|40|43 (call.args .body|18))) (begin (.check! (pair? .x|40|43) 0 .x|40|43) (car:pair .x|40|43))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(primop)) (cg-primop-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-primop)) (begin (cg-primop-result .output|3 (let ((.x|46|49 (call.args .body|18))) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(_called)) (cg-call-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(_let-called)) (begin (cg-call-result .output|3 (let ((.x|52|55 (call.args .body|18))) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (begin (if (assq .v|9 *regnames*) (.move-to-register|26 (let ((.x|58|61 (assq .v|9 *regnames*))) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61)))) (if (memq .v|9 .free|12) (.move-to-register|26 (choose-register .regs|3 .frame|3)) (unspecified))) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))))))))))) (.cg-let1-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let1-result))
+(let () (begin (set! cg-primop-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-primop-result|2 0)) (begin (set! .cg-primop-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.args|6 (call.args .exp|3)) (.entry|6 (var-lookup (variable.name (call.proc .exp|3)) .regs|3 .frame|3 .env|3))) (if (= (entry.arity .entry|6) (length .args|6)) (begin (let ((.temp|7|10 (entry.arity .entry|6))) (if (memv .temp|7|10 '(0)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(1)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(2)) (cg-primop2-result! .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (if (memv .temp|7|10 '(3)) (let ((.rs|17 (cg-result-args .output|3 .args|6 .regs|3 .frame|3 .env|3))) (gen! .output|3 $op3 (entry.op .entry|6) (let ((.x|18|21 .rs|17)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (let ((.x|23|26 (let ((.x|27|30 .rs|17)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (error "Bug detected by cg-primop-result" (make-readable .exp|3))))))) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (< (entry.arity .entry|6) 0) (cg-special-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Wrong number of arguments to integrable procedure" (make-readable .exp|3))))))) (.cg-primop-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-primop-result))
+(let () (begin (set! cg-primop2-result! (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-primop2-result!|2 0)) (begin (set! .cg-primop2-result!|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.op|6 (entry.op .entry|3)) (.arg2|6 (let ((.x|18|21 (let ((.x|22|25 .args|3)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if (if (constant? .arg2|6) (if (entry.imm .entry|3) ((entry.imm .entry|3) (constant.value .arg2|6)) #f) #f) (gen! .output|3 $op2imm .op|6 (constant.value .arg2|6)) (let ((.rs|12 (cg-result-args .output|3 .args|3 .regs|3 .frame|3 .env|3))) (gen! .output|3 $op2 .op|6 (let ((.x|13|16 .rs|12)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))))))) (.cg-primop2-result!|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-primop2-result!))
+(let () (begin (set! cg-result-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-result-args|2 0)) (begin (set! .cg-result-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.save-result!|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .save-result!|4 (lambda (.args|5 .registers|5 .rr|5 .rs|5 .temps|5) (let ((.r|8 (let ((.x|13|16 .registers|5)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (gen! .output|3 $setreg .r|8) (.loop|4 .args|5 (let ((.x|9|12 .registers|5)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))) .r|8 .rs|5 .temps|5))))) (set! .loop|4 (lambda (.args|17 .registers|17 .rr|17 .rs|17 .temps|17) (if (null? .args|17) (begin (if (not (eq? .rr|17 'result)) (gen! .output|3 $reg .rr|17) (unspecified)) (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let ((.r|33 (let ((.x|34|37 .y1|18|19|29)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (cgreg-release! .regs|3 .r|33))) (.loop|23|25|28 (let ((.x|38|41 .y1|18|19|29)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))))))) (.loop|23|25|28 .temps|17)))) (reverse .rs|17)) (let ((.arg|44 (let ((.x|134|137 .args|17)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137))))) (if (constant? .arg|44) (let ((.r|48 (let ((.x|57|60 .registers|17)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))))) (begin (gen! .output|3 $const/setreg (constant.value .arg|44) .r|48) (cgreg-bind! .regs|3 .r|48 #t) (.loop|4 (let ((.x|49|52 .args|17)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.x|53|56 .registers|17)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) .rr|17 (cons .r|48 .rs|17) (cons .r|48 .temps|17)))) (if (variable? .arg|44) (let* ((.id|64 (variable.name .arg|44)) (.entry|67 (var-lookup .id|64 .regs|3 .frame|3 .env|3))) (let () (let ((.temp|71|74 (entry.kind .entry|67))) (if (memv .temp|71|74 '(global integrable)) (if (eq? .rr|17 'result) (.save-result!|4 .args|17 .registers|17 .rr|17 .rs|17 .temps|17) (let ((.r|78 (let ((.x|87|90 .registers|17)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (begin (gen! .output|3 $global .id|64) (gen! .output|3 $setreg .r|78) (cgreg-bind! .regs|3 .r|78 .id|64) (.loop|4 (let ((.x|79|82 .args|17)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))) (let ((.x|83|86 .registers|17)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86))) .rr|17 (cons .r|78 .rs|17) (cons .r|78 .temps|17))))) (if (memv .temp|71|74 '(lexical)) (if (eq? .rr|17 'result) (.save-result!|4 .args|17 .registers|17 .rr|17 .rs|17 .temps|17) (let ((.m|94 (entry.rib .entry|67)) (.n|94 (entry.offset .entry|67)) (.r|94 (let ((.x|103|106 .registers|17)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106))))) (begin (gen! .output|3 $lexical .m|94 .n|94 .id|64) (gen! .output|3 $setreg .r|94) (cgreg-bind! .regs|3 .r|94 .id|64) (.loop|4 (let ((.x|95|98 .args|17)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (let ((.x|99|102 .registers|17)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) .rr|17 (cons .r|94 .rs|17) (cons .r|94 .temps|17))))) (if (memv .temp|71|74 '(procedure)) (error "Bug in cg-variable" .arg|44) (if (memv .temp|71|74 '(register)) (let ((.r|111 (entry.regnum .entry|67))) (.loop|4 (let ((.x|112|115 .args|17)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))) .registers|17 .rr|17 (cons .r|111 .rs|17) .temps|17)) (if (memv .temp|71|74 '(frame)) (let ((.r|119 (let ((.x|128|131 .registers|17)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))))) (begin (gen-load! .output|3 .frame|3 .r|119 .id|64) (cgreg-bind! .regs|3 .r|119 .id|64) (.loop|4 (let ((.x|120|123 .args|17)) (begin (.check! (pair? .x|120|123) 1 .x|120|123) (cdr:pair .x|120|123))) (let ((.x|124|127 .registers|17)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) .rr|17 (cons .r|119 .rs|17) (cons .r|119 .temps|17)))) (error "Bug in cg-result-args" .arg|44))))))))) (error "Bug in cg-result-args"))))))) (.loop|4 (let ((.x|138|141 .args|3)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141))) (choose-registers .regs|3 .frame|3 (length .args|3)) 'result '() '()))))) (.cg-result-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-result-args))
+(let () (begin (set! cg-let-used-once (lambda (.t1|1 .exp|1) (let ((.cg-let-used-once|2 0)) (begin (set! .cg-let-used-once|2 (lambda (.t1|3 .exp|3) (let ((.cg-let-used-once|4 (unspecified)) (.budget|4 (unspecified))) (begin (set! .cg-let-used-once|4 (lambda (.t1|5 .exp|5) (let ((.used-in-args?|6 (unspecified)) (.used?|6 (unspecified))) (begin (set! .used-in-args?|6 (lambda (.t1|7 .args|7) (if (null? .args|7) #f (let ((.temp|8|11 (.used?|6 .t1|7 (let ((.x|17|20 .args|7)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20)))))) (if .temp|8|11 .temp|8|11 (.used-in-args?|6 .t1|7 (let ((.x|13|16 .args|7)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))))))) (set! .used?|6 (lambda (.t1|21 .exp|21) (begin (set! .budget|4 (- .budget|4 1)) (if (< .budget|4 0) #t (if (constant? .exp|21) #f (if (variable? .exp|21) (eq? .t1|21 (variable.name .exp|21)) (if (lambda? .exp|21) (memq .t1|21 (lambda.f .exp|21)) (if (assignment? .exp|21) (.used?|6 .t1|21 (assignment.rhs .exp|21)) (if (call? .exp|21) (let ((.temp|29|32 (.used?|6 .t1|21 (call.proc .exp|21)))) (if .temp|29|32 .temp|29|32 (.used-in-args?|6 .t1|21 (call.args .exp|21)))) (if (conditional? .exp|21) (let ((.temp|35|38 (.used?|6 .t1|21 (if.test .exp|21)))) (if .temp|35|38 .temp|35|38 (let ((.temp|39|42 (.used?|6 .t1|21 (if.then .exp|21)))) (if .temp|39|42 .temp|39|42 (.used?|6 .t1|21 (if.else .exp|21)))))) #t)))))))))) (set! .budget|4 (- .budget|4 1)) (if (< .budget|4 0) #f (if (call? .exp|5) (let ((.proc|50 (call.proc .exp|5)) (.args|50 (call.args .exp|5))) (if (variable? .proc|50) (let ((.f|54 (variable.name .proc|50))) (if (eq? .f|54 .t1|5) (if (not (.used-in-args?|6 .t1|5 .args|50)) 'called #f) (if (if (integrable? .f|54) (if (not (null? .args|50)) (if (variable? (let ((.x|62|65 .args|50)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (eq? .t1|5 (variable.name (let ((.x|67|70 .args|50)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) #f) #f) #f) (if (not (.used-in-args?|6 .t1|5 (let ((.x|72|75 .args|50)) (begin (.check! (pair? .x|72|75) 1 .x|72|75) (cdr:pair .x|72|75))))) 'primop #f) #f))) (if (lambda? .proc|50) (if (not (memq .t1|5 (lambda.f .proc|50))) (if (not (null? .args|50)) (if (null? (let ((.x|82|85 .args|50)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85)))) (let ((.temp|87|90 (.cg-let-used-once|4 .t1|5 (let ((.x|96|99 .args|50)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99)))))) (if (memv .temp|87|90 '(if)) 'let-if (if (memv .temp|87|90 '(primop)) 'let-primop (if (memv .temp|87|90 '(called)) 'let-called (if (memv .temp|87|90 '(set!)) 'let-set! #f))))) #f) #f) #f) #f))) (if (conditional? .exp|5) (let ((.e0|104 (if.test .exp|5))) (if (variable? .e0|104) (if (eq? .t1|5 (variable.name .e0|104)) (if (not (.used?|6 .t1|5 (if.then .exp|5))) (if (not (.used?|6 .t1|5 (if.else .exp|5))) 'if #f) #f) #f) #f)) (if (assignment? .exp|5) (let ((.rhs|113 (assignment.rhs .exp|5))) (if (variable? .rhs|113) (if (eq? .t1|5 (variable.name .rhs|113)) 'set! #f) #f)) #f)))))))) (set! .budget|4 20) (.cg-let-used-once|4 .t1|3 .exp|3))))) (.cg-let-used-once|2 .t1|1 .exp|1))))) 'cg-let-used-once))
+(let () (begin (set! cg-let-transform (lambda (.pattern|1 .exp|1 .e1|1) (let ((.cg-let-transform|2 0)) (begin (set! .cg-let-transform|2 (lambda (.pattern|3 .exp|3 .e1|3) (let ((.temp|4|7 .pattern|3)) (if (memv .temp|4|7 '(if)) (make-conditional .e1|3 (if.then .exp|3) (if.else .exp|3)) (if (memv .temp|4|7 '(primop)) (make-call (call.proc .exp|3) (cons .e1|3 (let ((.x|10|13 (call.args .exp|3))) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))))) (if (memv .temp|4|7 '(called)) (make-call .e1|3 (call.args .exp|3)) (if (memv .temp|4|7 '(set!)) (make-assignment (assignment.lhs .exp|3) .e1|3) (if (memv .temp|4|7 '(let-if let-primop let-called let-set!)) (make-call (call.proc .exp|3) (cons (.cg-let-transform|2 (let ((.temp|18|21 .pattern|3)) (if (memv .temp|18|21 '(let-if)) 'if (if (memv .temp|18|21 '(let-primop)) 'primop (if (memv .temp|18|21 '(let-called)) 'called (if (memv .temp|18|21 '(let-set!)) 'set! (unspecified)))))) (let ((.x|26|29 (call.args .exp|3))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) .e1|3) '())) (error "Unrecognized pattern in cg-let-transform" .pattern|3))))))))) (.cg-let-transform|2 .pattern|1 .exp|1 .e1|1))))) 'cg-let-transform))
+(let () (begin (set! cg-special (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-special|2 0)) (begin (set! .cg-special|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.name|6 (variable.name (call.proc .exp|3)))) (if (eq? .name|6 name:check!) (if (runtime-safety-checking) (cg-check .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (unspecified)) (error "Compiler bug: cg-special" (make-readable .exp|3)))))) (.cg-special|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-special))
+(let () (begin (set! cg-special-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-special-result|2 0)) (begin (set! .cg-special-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.name|6 (variable.name (call.proc .exp|3)))) (if (eq? .name|6 name:check!) (if (runtime-safety-checking) (cg-check-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (unspecified)) (error "Compiler bug: cg-special" (make-readable .exp|3)))))) (.cg-special-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-special-result))
+(let () (begin (set! cg-check (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-check|2 0)) (begin (set! .cg-check|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (let ((.x|4|7 (call.args .exp|3))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'result .regs|3 .frame|3 .env|3 #f) (cg-check-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))) (.cg-check|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-check))
+(let () (begin (set! cg-check-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-check-result|2 0)) (begin (set! .cg-check-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|6 (call.args .exp|3)) (.nargs|9 (length .args|6)) (.valexps|12 (let ((.x|173|176 (let ((.x|177|180 .args|6)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180))))) (begin (.check! (pair? .x|173|176) 1 .x|173|176) (cdr:pair .x|173|176))))) (let () (if (if (let ((.t|17|20 .nargs|9)) (if (<= 2 .t|17|20) (<= .t|17|20 5) #f)) (if (constant? (let ((.x|25|28 (let ((.x|29|32 .args|6)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) (every? (lambda (.exp|34) (let ((.temp|35|38 (constant? .exp|34))) (if .temp|35|38 .temp|35|38 (variable? .exp|34)))) .valexps|12) #f) #f) (let* ((.exn|42 (constant.value (let ((.x|164|167 (let ((.x|168|171 .args|6)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171))))) (begin (.check! (pair? .x|164|167) 0 .x|164|167) (car:pair .x|164|167))))) (.vars|45 (filter variable? .valexps|12)) (.rs|48 (cg-result-args .output|3 (cons (let ((.x|159|162 .args|6)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))) .vars|45) .regs|3 .frame|3 .env|3))) (let () (let ((.registers|54 .rs|48) (.exps|54 .valexps|12) (.operands|54 '())) (let () (let ((.loop|57 (unspecified))) (begin (set! .loop|57 (lambda (.registers|58 .exps|58 .operands|58) (if (null? .exps|58) (let* ((.situation|62 (cons .exn|42 (reverse .operands|58))) (.ht|65 (assembly-stream-info .output|3)) (.l1|68 (let ((.temp|125|128 (hashtable-get .ht|65 .situation|62))) (if .temp|125|128 .temp|125|128 (let ((.l1|132 (make-label))) (begin (hashtable-put! .ht|65 .situation|62 .l1|132) .l1|132)))))) (let () (let ((.translate|73 (unspecified))) (begin (set! .translate|73 (lambda (.r|74) (if (number? .r|74) .r|74 0))) (let ((.temp|72|77 (length .operands|58))) (if (memv .temp|72|77 '(0)) (gen! .output|3 $check 0 0 0 .l1|68) (if (memv .temp|72|77 '(1)) (gen! .output|3 $check (.translate|73 (let ((.x|80|83 .operands|58)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) 0 0 .l1|68) (if (memv .temp|72|77 '(2)) (gen! .output|3 $check (.translate|73 (let ((.x|85|88 .operands|58)) (begin (.check! (pair? .x|85|88) 0 .x|85|88) (car:pair .x|85|88)))) (.translate|73 (let ((.x|90|93 (let ((.x|94|97 .operands|58)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) 0 .l1|68) (if (memv .temp|72|77 '(3)) (gen! .output|3 $check (.translate|73 (let ((.x|99|102 .operands|58)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.translate|73 (let ((.x|104|107 (let ((.x|108|111 .operands|58)) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111))))) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107)))) (.translate|73 (let ((.x|113|116 (let ((.x|117|120 (let ((.x|121|124 .operands|58)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124))))) (begin (.check! (pair? .x|117|120) 1 .x|117|120) (cdr:pair .x|117|120))))) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .l1|68) (unspecified)))))))))) (if (constant? (let ((.x|134|137 .exps|58)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137)))) (.loop|57 .registers|58 (let ((.x|138|141 .exps|58)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141))) (cons (let ((.x|142|145 .exps|58)) (begin (.check! (pair? .x|142|145) 0 .x|142|145) (car:pair .x|142|145))) .operands|58)) (.loop|57 (let ((.x|147|150 .registers|58)) (begin (.check! (pair? .x|147|150) 1 .x|147|150) (cdr:pair .x|147|150))) (let ((.x|151|154 .exps|58)) (begin (.check! (pair? .x|151|154) 1 .x|151|154) (cdr:pair .x|151|154))) (cons (let ((.x|155|158 .registers|58)) (begin (.check! (pair? .x|155|158) 0 .x|155|158) (car:pair .x|155|158))) .operands|58)))))) (.loop|57 .registers|54 .exps|54 .operands|54))))))) (error "Compiler bug: runtime check" (make-readable .exp|3))))))) (.cg-check-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-check-result))
+(let () (begin (set! cg-trap (lambda (.output|1 .situation|1 .l1|1) (let ((.cg-trap|2 0)) (begin (set! .cg-trap|2 (lambda (.output|3 .situation|3 .l1|3) (let* ((.exn|6 (let ((.x|99|102 .situation|3)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.operands|9 (let ((.x|95|98 .situation|3)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))))) (let () (begin (gen! .output|3 $.label .l1|3) (let* ((.liveregs|15 (filter number? .operands|9)) (.loop|16 (unspecified))) (begin (set! .loop|16 (lambda (.operands|17 .registers|17 .r|17) (if (null? .operands|17) (let ((.temp|19|22 (length .registers|17))) (if (memv .temp|19|22 '(0)) (gen! .output|3 $trap 0 0 0 .exn|6) (if (memv .temp|19|22 '(1)) (gen! .output|3 $trap (let ((.x|25|28 .registers|17)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) 0 0 .exn|6) (if (memv .temp|19|22 '(2)) (gen! .output|3 $trap (let ((.x|30|33 .registers|17)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|35|38 (let ((.x|39|42 .registers|17)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))) 0 .exn|6) (if (memv .temp|19|22 '(3)) (gen! .output|3 $trap (let ((.x|44|47 .registers|17)) (begin (.check! (pair? .x|44|47) 0 .x|44|47) (car:pair .x|44|47))) (let ((.x|49|52 (let ((.x|53|56 .registers|17)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))))) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))) (let ((.x|58|61 (let ((.x|62|65 (let ((.x|66|69 .registers|17)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))))) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) .exn|6) "Compiler bug: trap"))))) (if (number? (let ((.x|72|75 .operands|17)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.loop|16 (let ((.x|76|79 .operands|17)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons (let ((.x|80|83 .operands|17)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83))) .registers|17) .r|17) (if (memv .r|17 .liveregs|15) (.loop|16 .operands|17 .registers|17 (+ .r|17 1)) (begin (gen! .output|3 $const (constant.value (let ((.x|87|90 .operands|17)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (gen! .output|3 $setreg .r|17) (.loop|16 (let ((.x|91|94 .operands|17)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (cons .r|17 .registers|17) (+ .r|17 1)))))))) (.loop|16 (reverse .operands|9) '() 1)))))))) (.cg-trap|2 .output|1 .situation|1 .l1|1))))) 'cg-trap))
+(let () (begin (set! cg-check-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-check-args|2 0)) (begin (set! .cg-check-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.finish-loop|4 (unspecified)) (.eval-first-into-result|4 (unspecified)) (.eval-loop|4 (unspecified))) (begin (set! .finish-loop|4 (lambda (.disjoint|5 .temps|5 .mask|5 .registers|5) (if (null? .temps|5) .registers|5 (let* ((.t|8 (let ((.x|54|57 .temps|5)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) (.entry|11 (cgreg-lookup .regs|3 .t|8))) (let () (if .entry|11 (let ((.r|17 (entry.regnum .entry|11))) (begin (if (let ((.x|18|21 .mask|5)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (begin (cgreg-release! .regs|3 .r|17) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|22|25 .temps|5)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) (let ((.x|26|29 .mask|5)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (cons .r|17 .registers|5)))) (let ((.r|32 (let ((.x|50|53 .disjoint|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .r|32 .registers|5) (.finish-loop|4 (let ((.x|34|37 .disjoint|5)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) .temps|5 .mask|5 .registers|5) (begin (gen-load! .output|3 .frame|3 .r|32 .t|8) (cgreg-bind! .regs|3 .r|32 .t|8) (if (let ((.x|38|41 .mask|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (begin (cgreg-release! .regs|3 .r|32) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|42|45 .temps|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) (let ((.x|46|49 .mask|5)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))) (cons .r|32 .registers|5))))))))))) (set! .eval-first-into-result|4 (lambda (.temps|58 .mask|58) (begin (cg0 .output|3 (let ((.x|59|62 .args|3)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) 'result .regs|3 .frame|3 .env|3 #f) (.finish-loop|4 (choose-registers .regs|3 .frame|3 (length .temps|58)) .temps|58 .mask|58 '())))) (set! .eval-loop|4 (lambda (.args|63 .temps|63 .mask|63) (if (null? .args|63) (.eval-first-into-result|4 .temps|63 .mask|63) (let ((.reg|66 (cg0 .output|3 (let ((.x|84|87 .args|63)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) #f .regs|3 .frame|3 .env|3 #f))) (if (eq? .reg|66 'result) (let* ((.r|69 (choose-register .regs|3 .frame|3)) (.t|72 (newtemp))) (let () (begin (gen! .output|3 $setreg .r|69) (cgreg-bind! .regs|3 .r|69 .t|72) (gen-store! .output|3 .frame|3 .r|69 .t|72) (.eval-loop|4 (let ((.x|76|79 .args|63)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons .t|72 .temps|63) (cons #t .mask|63))))) (.eval-loop|4 (let ((.x|80|83 .args|63)) (begin (.check! (pair? .x|80|83) 1 .x|80|83) (cdr:pair .x|80|83))) (cons (cgreg-lookup-reg .regs|3 .reg|66) .temps|63) (cons #f .mask|63))))))) (if (< (length .args|3) *nregs*) (.eval-loop|4 (let ((.x|88|91 .args|3)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))) '() '()) (error "Bug detected by cg-primop-args" .args|3)))))) (.cg-check-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-check-args))
+(let () (begin (set! filter-basic-blocks (let* ((.suppression-message|3 "Local optimization detected a useless instruction.") (.forward:normal|6 0) (.forward:nop|9 1) (.forward:ends-block|12 2) (.forward:interesting|15 3) (.forward:kills-all-registers|18 4) (.forward:nop-if-arg1-is-negative|21 5) (.backward:normal|24 0) (.backward:ends-block|27 1) (.backward:begins-block|30 2) (.backward:uses-arg1|33 4) (.backward:uses-arg2|36 8) (.backward:uses-arg3|39 16) (.backward:kills-arg1|42 32) (.backward:kills-arg2|45 64) (.backward:uses-many|48 128) (.dispatch-table-size|51 *number-of-mnemonics*) (.forward-table|54 (make-bytevector .dispatch-table-size|51)) (.backward-table|57 (make-bytevector .dispatch-table-size|51))) (let () (begin (let () (let ((.loop|62|64|67 (unspecified))) (begin (set! .loop|62|64|67 (lambda (.i|68) (if (= .i|68 .dispatch-table-size|51) (if #f #f (unspecified)) (begin (begin #t (bytevector-set! .forward-table|54 .i|68 .forward:normal|6) (bytevector-set! .backward-table|57 .i|68 .backward:normal|24)) (.loop|62|64|67 (+ .i|68 1)))))) (.loop|62|64|67 0)))) (bytevector-set! .forward-table|54 $nop .forward:nop|9) (bytevector-set! .forward-table|54 $invoke .forward:ends-block|12) (bytevector-set! .forward-table|54 $return .forward:ends-block|12) (bytevector-set! .forward-table|54 $skip .forward:ends-block|12) (bytevector-set! .forward-table|54 $branch .forward:ends-block|12) (bytevector-set! .forward-table|54 $branchf .forward:ends-block|12) (bytevector-set! .forward-table|54 $jump .forward:ends-block|12) (bytevector-set! .forward-table|54 $.align .forward:ends-block|12) (bytevector-set! .forward-table|54 $.proc .forward:ends-block|12) (bytevector-set! .forward-table|54 $.cont .forward:ends-block|12) (bytevector-set! .forward-table|54 $.label .forward:ends-block|12) (bytevector-set! .forward-table|54 $store .forward:interesting|15) (bytevector-set! .forward-table|54 $load .forward:interesting|15) (bytevector-set! .forward-table|54 $setstk .forward:interesting|15) (bytevector-set! .forward-table|54 $setreg .forward:interesting|15) (bytevector-set! .forward-table|54 $movereg .forward:interesting|15) (bytevector-set! .forward-table|54 $const/setreg .forward:interesting|15) (bytevector-set! .forward-table|54 $args>= .forward:kills-all-registers|18) (bytevector-set! .forward-table|54 $popstk .forward:kills-all-registers|18) (bytevector-set! .forward-table|54 $save .forward:nop-if-arg1-is-negative|21) (bytevector-set! .forward-table|54 $restore .forward:nop-if-arg1-is-negative|21) (bytevector-set! .forward-table|54 $pop .forward:nop-if-arg1-is-negative|21) (bytevector-set! .backward-table|57 $invoke .backward:ends-block|27) (bytevector-set! .backward-table|57 $return .backward:ends-block|27) (bytevector-set! .backward-table|57 $skip .backward:ends-block|27) (bytevector-set! .backward-table|57 $branch .backward:ends-block|27) (bytevector-set! .backward-table|57 $branchf .backward:ends-block|27) (bytevector-set! .backward-table|57 $jump .backward:begins-block|30) (bytevector-set! .backward-table|57 $.align .backward:begins-block|30) (bytevector-set! .backward-table|57 $.proc .backward:begins-block|30) (bytevector-set! .backward-table|57 $.cont .backward:begins-block|30) (bytevector-set! .backward-table|57 $.label .backward:begins-block|30) (bytevector-set! .backward-table|57 $op2 .backward:uses-arg2|36) (bytevector-set! .backward-table|57 $op3 (logior .backward:uses-arg2|36 .backward:uses-arg3|39)) (bytevector-set! .backward-table|57 $check (logior .backward:uses-arg1|33 (logior .backward:uses-arg2|36 .backward:uses-arg3|39))) (bytevector-set! .backward-table|57 $trap (logior .backward:uses-arg1|33 (logior .backward:uses-arg2|36 .backward:uses-arg3|39))) (bytevector-set! .backward-table|57 $store .backward:uses-arg1|33) (bytevector-set! .backward-table|57 $reg .backward:uses-arg1|33) (bytevector-set! .backward-table|57 $load .backward:kills-arg1|42) (bytevector-set! .backward-table|57 $setreg .backward:kills-arg1|42) (bytevector-set! .backward-table|57 $movereg (logior .backward:uses-arg1|33 .backward:kills-arg2|45)) (bytevector-set! .backward-table|57 $const/setreg .backward:kills-arg2|45) (bytevector-set! .backward-table|57 $lambda .backward:uses-many|48) (bytevector-set! .backward-table|57 $lexes .backward:uses-many|48) (bytevector-set! .backward-table|57 $args>= .backward:uses-many|48) (lambda (.instructions|71) (let* ((.*nregs*|74 *nregs*) (.registers|77 (make-vector .*nregs*|74 #f)) (.label-table|80 (make-hashtable (lambda (.n|532) .n|532) assv))) (let () (let ((.local-optimization-error|84 (unspecified)) (.suppress-backwards|84 (unspecified)) (.suppress-forwards|84 (unspecified)) (.backwards0|84 (unspecified)) (.backwards|84 (unspecified)) (.forwards-label|84 (unspecified)) (.forwards|84 (unspecified)) (.kill-stack!|84 (unspecified)) (.subvector-fill!|84 (unspecified)) (.vector-fill!|84 (unspecified)) (.lookup-label|84 (unspecified)) (.compute-transitive-closure!|84 (unspecified))) (begin (set! .local-optimization-error|84 (lambda (.op|85) (error "Compiler bug: local optimization" .op|85))) (set! .suppress-backwards|84 (lambda (.instruction|86 .instructions|86 .filtered|86) (begin (if (issue-warnings) '(begin (display suppression-message) (newline)) (unspecified)) (.backwards|84 .instructions|86 .filtered|86)))) (set! .suppress-forwards|84 (lambda (.instruction|87 .instructions|87 .filtered|87) (begin (if (issue-warnings) '(begin (display suppression-message) (newline)) (unspecified)) (.forwards|84 .instructions|87 .filtered|87)))) (set! .backwards0|84 (lambda (.instructions|88 .filtered|88) (if (null? .instructions|88) .filtered|88 (let* ((.instruction|91 (let ((.x|233|236 .instructions|88)) (begin (.check! (pair? .x|233|236) 0 .x|233|236) (car:pair .x|233|236)))) (.mnemonic|94 (instruction.op .instruction|91))) (let () (if (let ((.temp|99|102 (eqv? .mnemonic|94 $.label))) (if .temp|99|102 .temp|99|102 (let ((.temp|103|106 (eqv? .mnemonic|94 $.proc))) (if .temp|103|106 .temp|103|106 (let ((.temp|107|110 (eqv? .mnemonic|94 $.cont))) (if .temp|107|110 .temp|107|110 (eqv? .mnemonic|94 $.align))))))) (.backwards0|84 (let ((.x|116|119 .instructions|88)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons .instruction|91 .filtered|88)) (if (eqv? .mnemonic|94 $return) (begin (.vector-fill!|84 .registers|77 #f) (let ((.v|122|125 .registers|77) (.i|122|125 0) (.x|122|125 #t)) (begin (.check! (fixnum? .i|122|125) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (vector? .v|122|125) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (<:fix:fix .i|122|125 (vector-length:vec .v|122|125)) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (>=:fix:fix .i|122|125 0) 41 .v|122|125 .i|122|125 .x|122|125) (vector-set!:trusted .v|122|125 .i|122|125 .x|122|125))) (.backwards|84 (let ((.x|126|129 .instructions|88)) (begin (.check! (pair? .x|126|129) 1 .x|126|129) (cdr:pair .x|126|129))) (cons .instruction|91 .filtered|88))) (if (eqv? .mnemonic|94 $invoke) (let ((.n+1|134 (min .*nregs*|74 (+ (instruction.arg1 .instruction|91) 1)))) (begin (.subvector-fill!|84 .registers|77 0 .n+1|134 #t) (.subvector-fill!|84 .registers|77 .n+1|134 .*nregs*|74 #f) (.backwards|84 (let ((.x|135|138 .instructions|88)) (begin (.check! (pair? .x|135|138) 1 .x|135|138) (cdr:pair .x|135|138))) (cons .instruction|91 .filtered|88)))) (if (let ((.temp|140|143 (eqv? .mnemonic|94 $skip))) (if .temp|140|143 .temp|140|143 (eqv? .mnemonic|94 $branch))) (let* ((.live|149 (instruction.arg2 .instruction|91)) (.n+1|152 (min .*nregs*|74 (+ .live|149 1)))) (let () (begin (.subvector-fill!|84 .registers|77 0 .n+1|152 #t) (.subvector-fill!|84 .registers|77 .n+1|152 .*nregs*|74 #f) (let ((.instruction|158 (let* ((.t1|163|166 .mnemonic|94) (.t2|163|169 (let* ((.t1|173|176 (.lookup-label|84 (instruction.arg1 .instruction|91))) (.t2|173|179 (cons .live|149 '()))) (let () (cons .t1|173|176 .t2|173|179))))) (let () (cons .t1|163|166 .t2|163|169))))) (.backwards|84 (let ((.x|159|162 .instructions|88)) (begin (.check! (pair? .x|159|162) 1 .x|159|162) (cdr:pair .x|159|162))) (cons .instruction|158 .filtered|88)))))) (if (eqv? .mnemonic|94 $jump) (let ((.n+1|188 (min .*nregs*|74 (+ (instruction.arg3 .instruction|91) 1)))) (begin (.subvector-fill!|84 .registers|77 0 .n+1|188 #t) (.subvector-fill!|84 .registers|77 .n+1|188 .*nregs*|74 #f) (.backwards|84 (let ((.x|189|192 .instructions|88)) (begin (.check! (pair? .x|189|192) 1 .x|189|192) (cdr:pair .x|189|192))) (cons .instruction|91 .filtered|88)))) (if (eqv? .mnemonic|94 $branchf) (let* ((.live|197 (instruction.arg2 .instruction|91)) (.n+1|200 (min .*nregs*|74 (+ .live|197 1)))) (let () (begin (.subvector-fill!|84 .registers|77 0 .n+1|200 #t) (let ((.instruction|206 (let* ((.t1|211|214 .mnemonic|94) (.t2|211|217 (let* ((.t1|221|224 (.lookup-label|84 (instruction.arg1 .instruction|91))) (.t2|221|227 (cons .live|197 '()))) (let () (cons .t1|221|224 .t2|221|227))))) (let () (cons .t1|211|214 .t2|211|217))))) (.backwards|84 (let ((.x|207|210 .instructions|88)) (begin (.check! (pair? .x|207|210) 1 .x|207|210) (cdr:pair .x|207|210))) (cons .instruction|206 .filtered|88)))))) (.backwards|84 .instructions|88 .filtered|88)))))))))))) (set! .backwards|84 (lambda (.instructions|237 .filtered|237) (if (null? .instructions|237) .filtered|237 (let* ((.instruction|240 (let ((.x|329|332 .instructions|237)) (begin (.check! (pair? .x|329|332) 0 .x|329|332) (car:pair .x|329|332)))) (.instructions|243 (let ((.x|325|328 .instructions|237)) (begin (.check! (pair? .x|325|328) 1 .x|325|328) (cdr:pair .x|325|328)))) (.op|246 (instruction.op .instruction|240)) (.flags|249 (bytevector-ref .backward-table|57 .op|246))) (let () (if (eqv? .flags|249 .backward:normal|24) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237)) (if (eqv? .flags|249 .backward:ends-block|27) (.backwards0|84 (cons .instruction|240 .instructions|243) .filtered|237) (if (eqv? .flags|249 .backward:begins-block|30) (.backwards0|84 .instructions|243 (cons .instruction|240 .filtered|237)) (if (eqv? .flags|249 .backward:uses-many|48) (if (let ((.temp|262|265 (eqv? .op|246 $lambda))) (if .temp|262|265 .temp|262|265 (eqv? .op|246 $lexes))) (let ((.live|271 (if (eqv? .op|246 $lexes) (instruction.arg1 .instruction|240) (instruction.arg2 .instruction|240)))) (begin (.subvector-fill!|84 .registers|77 0 (min .*nregs*|74 (+ 1 .live|271)) #t) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237)))) (if (eqv? .op|246 $args>=) (begin (.vector-fill!|84 .registers|77 #t) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237))) (.local-optimization-error|84 .op|246))) (if (if (eqv? (logand .flags|249 .backward:kills-arg1|42) .backward:kills-arg1|42) (not (let ((.v|280|283 .registers|77) (.i|280|283 (instruction.arg1 .instruction|240))) (begin (.check! (fixnum? .i|280|283) 40 .v|280|283 .i|280|283) (.check! (vector? .v|280|283) 40 .v|280|283 .i|280|283) (.check! (<:fix:fix .i|280|283 (vector-length:vec .v|280|283)) 40 .v|280|283 .i|280|283) (.check! (>=:fix:fix .i|280|283 0) 40 .v|280|283 .i|280|283) (vector-ref:trusted .v|280|283 .i|280|283)))) #f) (.suppress-backwards|84 .instruction|240 .instructions|243 .filtered|237) (if (if (eqv? (logand .flags|249 .backward:kills-arg2|45) .backward:kills-arg2|45) (not (let ((.v|288|291 .registers|77) (.i|288|291 (instruction.arg2 .instruction|240))) (begin (.check! (fixnum? .i|288|291) 40 .v|288|291 .i|288|291) (.check! (vector? .v|288|291) 40 .v|288|291 .i|288|291) (.check! (<:fix:fix .i|288|291 (vector-length:vec .v|288|291)) 40 .v|288|291 .i|288|291) (.check! (>=:fix:fix .i|288|291 0) 40 .v|288|291 .i|288|291) (vector-ref:trusted .v|288|291 .i|288|291)))) #f) (.suppress-backwards|84 .instruction|240 .instructions|243 .filtered|237) (if (if (eqv? .op|246 $movereg) (= (instruction.arg1 .instruction|240) (instruction.arg2 .instruction|240)) #f) (.backwards|84 .instructions|243 .filtered|237) (let ((.filtered|299 (cons .instruction|240 .filtered|237))) (begin (if (eqv? (logand .flags|249 .backward:kills-arg1|42) .backward:kills-arg1|42) (let ((.v|301|304 .registers|77) (.i|301|304 (instruction.arg1 .instruction|240)) (.x|301|304 #f)) (begin (.check! (fixnum? .i|301|304) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (vector? .v|301|304) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (<:fix:fix .i|301|304 (vector-length:vec .v|301|304)) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (>=:fix:fix .i|301|304 0) 41 .v|301|304 .i|301|304 .x|301|304) (vector-set!:trusted .v|301|304 .i|301|304 .x|301|304))) (unspecified)) (if (eqv? (logand .flags|249 .backward:kills-arg2|45) .backward:kills-arg2|45) (let ((.v|306|309 .registers|77) (.i|306|309 (instruction.arg2 .instruction|240)) (.x|306|309 #f)) (begin (.check! (fixnum? .i|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (vector? .v|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (<:fix:fix .i|306|309 (vector-length:vec .v|306|309)) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (>=:fix:fix .i|306|309 0) 41 .v|306|309 .i|306|309 .x|306|309) (vector-set!:trusted .v|306|309 .i|306|309 .x|306|309))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg1|33) .backward:uses-arg1|33) (let ((.v|311|314 .registers|77) (.i|311|314 (instruction.arg1 .instruction|240)) (.x|311|314 #t)) (begin (.check! (fixnum? .i|311|314) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (vector? .v|311|314) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (<:fix:fix .i|311|314 (vector-length:vec .v|311|314)) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (>=:fix:fix .i|311|314 0) 41 .v|311|314 .i|311|314 .x|311|314) (vector-set!:trusted .v|311|314 .i|311|314 .x|311|314))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg2|36) .backward:uses-arg2|36) (let ((.v|316|319 .registers|77) (.i|316|319 (instruction.arg2 .instruction|240)) (.x|316|319 #t)) (begin (.check! (fixnum? .i|316|319) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (vector? .v|316|319) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (<:fix:fix .i|316|319 (vector-length:vec .v|316|319)) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (>=:fix:fix .i|316|319 0) 41 .v|316|319 .i|316|319 .x|316|319) (vector-set!:trusted .v|316|319 .i|316|319 .x|316|319))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg3|39) .backward:uses-arg3|39) (let ((.v|321|324 .registers|77) (.i|321|324 (instruction.arg3 .instruction|240)) (.x|321|324 #t)) (begin (.check! (fixnum? .i|321|324) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (vector? .v|321|324) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (<:fix:fix .i|321|324 (vector-length:vec .v|321|324)) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (>=:fix:fix .i|321|324 0) 41 .v|321|324 .i|321|324 .x|321|324) (vector-set!:trusted .v|321|324 .i|321|324 .x|321|324))) (unspecified)) (.backwards|84 .instructions|243 .filtered|299))))))))))))))) (set! .forwards-label|84 (lambda (.instruction1|333 .instructions|333 .filtered|333) (let ((.label1|336 (instruction.arg1 .instruction1|333))) (if (null? .instructions|333) (.forwards|84 .instructions|333 (let ((.x|337|340 .filtered|333)) (begin (.check! (pair? .x|337|340) 1 .x|337|340) (cdr:pair .x|337|340)))) (let ((.instructions|343 .instructions|333) (.filtered|343 (cons .instruction1|333 .filtered|333))) (let () (let ((.loop|346 (unspecified))) (begin (set! .loop|346 (lambda (.instructions|347 .filtered|347) (let* ((.instruction|350 (let ((.x|398|401 .instructions|347)) (begin (.check! (pair? .x|398|401) 0 .x|398|401) (car:pair .x|398|401)))) (.op|353 (instruction.op .instruction|350)) (.flags|356 (bytevector-ref .forward-table|54 .op|353))) (let () (if (eqv? .flags|356 .forward:nop|9) (.loop|346 (let ((.x|362|365 .instructions|347)) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))) .filtered|347) (if (if (eqv? .flags|356 .forward:nop-if-arg1-is-negative|21) (< (instruction.arg1 .instruction|350) 0) #f) (.loop|346 (let ((.x|371|374 .instructions|347)) (begin (.check! (pair? .x|371|374) 1 .x|371|374) (cdr:pair .x|371|374))) .filtered|347) (if (eqv? .op|353 $.label) (let ((.label2|379 (instruction.arg1 .instruction|350))) (begin (hashtable-put! .label-table|80 .label1|336 .label2|379) (.forwards-label|84 .instruction|350 (let ((.x|380|383 .instructions|347)) (begin (.check! (pair? .x|380|383) 1 .x|380|383) (cdr:pair .x|380|383))) (let ((.x|384|387 .filtered|347)) (begin (.check! (pair? .x|384|387) 1 .x|384|387) (cdr:pair .x|384|387)))))) (if (eqv? .op|353 $skip) (let ((.label2|392 (instruction.arg1 .instruction|350))) (begin (hashtable-put! .label-table|80 .label1|336 .label2|392) (.forwards|84 .instructions|347 (let ((.x|393|396 .filtered|347)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396)))))) (.forwards|84 .instructions|347 .filtered|347))))))))) (.loop|346 .instructions|343 .filtered|343))))))))) (set! .forwards|84 (lambda (.instructions|402 .filtered|402) (if (null? .instructions|402) (begin (.vector-fill!|84 .registers|77 #f) (let ((.v|403|406 .registers|77) (.i|403|406 0) (.x|403|406 #t)) (begin (.check! (fixnum? .i|403|406) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (vector? .v|403|406) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (<:fix:fix .i|403|406 (vector-length:vec .v|403|406)) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (>=:fix:fix .i|403|406 0) 41 .v|403|406 .i|403|406 .x|403|406) (vector-set!:trusted .v|403|406 .i|403|406 .x|403|406))) (.compute-transitive-closure!|84) (.backwards0|84 .filtered|402 '())) (let* ((.instruction|409 (let ((.x|486|489 .instructions|402)) (begin (.check! (pair? .x|486|489) 0 .x|486|489) (car:pair .x|486|489)))) (.instructions|412 (let ((.x|482|485 .instructions|402)) (begin (.check! (pair? .x|482|485) 1 .x|482|485) (cdr:pair .x|482|485)))) (.op|415 (instruction.op .instruction|409)) (.flags|418 (bytevector-ref .forward-table|54 .op|415))) (let () (if (eqv? .flags|418 .forward:normal|6) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)) (if (eqv? .flags|418 .forward:nop|9) (.forwards|84 .instructions|412 .filtered|402) (if (eqv? .flags|418 .forward:nop-if-arg1-is-negative|21) (if (< (instruction.arg1 .instruction|409) 0) (.forwards|84 .instructions|412 .filtered|402) (begin (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)))) (if (eqv? .flags|418 .forward:kills-all-registers|18) (begin (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .flags|418 .forward:ends-block|12) (begin (.vector-fill!|84 .registers|77 #f) (if (eqv? .op|415 $.label) (.forwards-label|84 .instruction|409 .instructions|412 .filtered|402) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)))) (if (eqv? .flags|418 .forward:interesting|15) (if (eqv? .op|415 $setreg) (begin (let ((.v|438|441 .registers|77) (.i|438|441 (instruction.arg1 .instruction|409)) (.x|438|441 #f)) (begin (.check! (fixnum? .i|438|441) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (vector? .v|438|441) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (<:fix:fix .i|438|441 (vector-length:vec .v|438|441)) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (>=:fix:fix .i|438|441 0) 41 .v|438|441 .i|438|441 .x|438|441) (vector-set!:trusted .v|438|441 .i|438|441 .x|438|441))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $const/setreg) (begin (let ((.v|444|447 .registers|77) (.i|444|447 (instruction.arg2 .instruction|409)) (.x|444|447 #f)) (begin (.check! (fixnum? .i|444|447) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (vector? .v|444|447) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (<:fix:fix .i|444|447 (vector-length:vec .v|444|447)) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (>=:fix:fix .i|444|447 0) 41 .v|444|447 .i|444|447 .x|444|447) (vector-set!:trusted .v|444|447 .i|444|447 .x|444|447))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $movereg) (begin (let ((.v|450|453 .registers|77) (.i|450|453 (instruction.arg2 .instruction|409)) (.x|450|453 #f)) (begin (.check! (fixnum? .i|450|453) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (vector? .v|450|453) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (<:fix:fix .i|450|453 (vector-length:vec .v|450|453)) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (>=:fix:fix .i|450|453 0) 41 .v|450|453 .i|450|453 .x|450|453) (vector-set!:trusted .v|450|453 .i|450|453 .x|450|453))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $setstk) (begin (.kill-stack!|84 (instruction.arg1 .instruction|409)) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $load) (let ((.i|460 (instruction.arg1 .instruction|409)) (.j|460 (instruction.arg2 .instruction|409))) (if (eqv? (let ((.v|462|465 .registers|77) (.i|462|465 .i|460)) (begin (.check! (fixnum? .i|462|465) 40 .v|462|465 .i|462|465) (.check! (vector? .v|462|465) 40 .v|462|465 .i|462|465) (.check! (<:fix:fix .i|462|465 (vector-length:vec .v|462|465)) 40 .v|462|465 .i|462|465) (.check! (>=:fix:fix .i|462|465 0) 40 .v|462|465 .i|462|465) (vector-ref:trusted .v|462|465 .i|462|465))) .j|460) (.suppress-forwards|84 .instruction|409 .instructions|412 .filtered|402) (begin (let ((.v|466|469 .registers|77) (.i|466|469 .i|460) (.x|466|469 .j|460)) (begin (.check! (fixnum? .i|466|469) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (vector? .v|466|469) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (<:fix:fix .i|466|469 (vector-length:vec .v|466|469)) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (>=:fix:fix .i|466|469 0) 41 .v|466|469 .i|466|469 .x|466|469) (vector-set!:trusted .v|466|469 .i|466|469 .x|466|469))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))))) (if (eqv? .op|415 $store) (let ((.i|474 (instruction.arg1 .instruction|409)) (.j|474 (instruction.arg2 .instruction|409))) (if (eqv? (let ((.v|476|479 .registers|77) (.i|476|479 .i|474)) (begin (.check! (fixnum? .i|476|479) 40 .v|476|479 .i|476|479) (.check! (vector? .v|476|479) 40 .v|476|479 .i|476|479) (.check! (<:fix:fix .i|476|479 (vector-length:vec .v|476|479)) 40 .v|476|479 .i|476|479) (.check! (>=:fix:fix .i|476|479 0) 40 .v|476|479 .i|476|479) (vector-ref:trusted .v|476|479 .i|476|479))) .j|474) (.suppress-forwards|84 .instruction|409 .instructions|412 .filtered|402) (begin (.kill-stack!|84 .j|474) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))))) (.local-optimization-error|84 .op|415))))))) (.local-optimization-error|84 .op|415)))))))))))) (set! .kill-stack!|84 (lambda (.j|490) (let () (let ((.loop|492|494|497 (unspecified))) (begin (set! .loop|492|494|497 (lambda (.i|498) (if (= .i|498 .*nregs*|74) (if #f #f (unspecified)) (begin (begin #t (let ((.x|503 (let ((.v|510|513 .registers|77) (.i|510|513 .i|498)) (begin (.check! (fixnum? .i|510|513) 40 .v|510|513 .i|510|513) (.check! (vector? .v|510|513) 40 .v|510|513 .i|510|513) (.check! (<:fix:fix .i|510|513 (vector-length:vec .v|510|513)) 40 .v|510|513 .i|510|513) (.check! (>=:fix:fix .i|510|513 0) 40 .v|510|513 .i|510|513) (vector-ref:trusted .v|510|513 .i|510|513))))) (if (if .x|503 (= .x|503 .j|490) #f) (let ((.v|506|509 .registers|77) (.i|506|509 .i|498) (.x|506|509 #f)) (begin (.check! (fixnum? .i|506|509) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (vector? .v|506|509) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (<:fix:fix .i|506|509 (vector-length:vec .v|506|509)) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (>=:fix:fix .i|506|509 0) 41 .v|506|509 .i|506|509 .x|506|509) (vector-set!:trusted .v|506|509 .i|506|509 .x|506|509))) (unspecified)))) (.loop|492|494|497 (+ .i|498 1)))))) (.loop|492|494|497 0)))))) (set! .subvector-fill!|84 (lambda (.v|514 .i|514 .j|514 .x|514) (if (< .i|514 .j|514) (begin (let ((.v|515|518 .v|514) (.i|515|518 .i|514) (.x|515|518 .x|514)) (begin (.check! (fixnum? .i|515|518) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (vector? .v|515|518) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (<:fix:fix .i|515|518 (vector-length:vec .v|515|518)) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (>=:fix:fix .i|515|518 0) 41 .v|515|518 .i|515|518 .x|515|518) (vector-set!:trusted .v|515|518 .i|515|518 .x|515|518))) (.subvector-fill!|84 .v|514 (+ .i|514 1) .j|514 .x|514)) (unspecified)))) (set! .vector-fill!|84 (lambda (.v|519 .x|519) (.subvector-fill!|84 .v|519 0 (let ((.v|520|523 .v|519)) (begin (.check! (vector? .v|520|523) 42 .v|520|523) (vector-length:vec .v|520|523))) .x|519))) (set! .lookup-label|84 (lambda (.x|524) (hashtable-fetch .label-table|80 .x|524 .x|524))) (set! .compute-transitive-closure!|84 (lambda () (let ((.lookup|526 (unspecified))) (begin (set! .lookup|526 (lambda (.x|527) (let ((.y|530 (hashtable-get .label-table|80 .x|527))) (if .y|530 (.lookup|526 .y|530) .x|527)))) (hashtable-for-each (lambda (.x|531 .y|531) (hashtable-put! .label-table|80 .x|531 (.lookup|526 .y|531))) .label-table|80))))) (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|71 '())))))))))) 'filter-basic-blocks))
+(let () (begin (set! *scheme-file-types* '(".sch" ".scm")) '*scheme-file-types*))
+(let () (begin (set! *lap-file-type* ".lap") '*lap-file-type*))
+(let () (begin (set! *mal-file-type* ".mal") '*mal-file-type*))
+(let () (begin (set! *lop-file-type* ".lop") '*lop-file-type*))
+(let () (begin (set! *fasl-file-type* ".fasl") '*fasl-file-type*))
+(let () (begin (set! compile-file (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|11|14 .rest|1)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (rewrite-file-type .infilename|1 *scheme-file-types* *fasl-file-type*))) (.user|6 (assembly-user-data))) (begin (if (if (not (integrate-usual-procedures)) (issue-warnings) #f) (begin (display "WARNING from compiler: ") (display "integrate-usual-procedures is turned off") (newline) (display "Performance is likely to be poor.") (newline)) (unspecified)) (if (benchmark-block-mode) (process-file-block .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.forms|9) (assemble (compile-block .forms|9) .user|6))) (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.expr|10) (assemble (compile .expr|10) .user|6)))) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Compile-file not supported on this target architecture.") (.doit|2)))))) 'compile-file))
+(let () (begin (set! assemble-file (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 (let* ((.t1|12|15 *lap-file-type*) (.t2|12|18 (cons *mal-file-type* '()))) (let () (cons .t1|12|15 .t2|12|18))) *fasl-file-type*))) (.malfile?|6 (file-type=? .infilename|1 *mal-file-type*)) (.user|6 (assembly-user-data))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) (assemble (if .malfile?|6 (eval .x|7) .x|7) .user|6))) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Assemble-file not supported on this target architecture.") (.doit|2)))))) 'assemble-file))
+(let () (begin (set! compile-expression (let () (let ((.compile-expression|4 (unspecified))) (begin (set! .compile-expression|4 (lambda (.expr|5 .env|5) (let* ((.syntax-env|8 (let ((.temp|15|18 (environment-tag .env|5))) (if (memv .temp|15|18 '(0 1)) (make-standard-syntactic-environment) (if (memv .temp|15|18 '(2)) global-syntactic-environment (begin (error "Invalid environment for compile-expression: " .env|5) #t))))) (.current-env|11 global-syntactic-environment)) (dynamic-wind (lambda () (set! global-syntactic-environment .syntax-env|8)) (lambda () (assemble (compile .expr|5))) (lambda () (set! global-syntactic-environment .current-env|11)))))) .compile-expression|4)))) 'compile-expression))
+(let () (begin (set! macro-expand-expression (let () (let ((.macro-expand-expression|4 (unspecified))) (begin (set! .macro-expand-expression|4 (lambda (.expr|5 .env|5) (let* ((.syntax-env|8 (let ((.temp|15|18 (environment-tag .env|5))) (if (memv .temp|15|18 '(0 1)) (make-standard-syntactic-environment) (if (memv .temp|15|18 '(2)) global-syntactic-environment (begin (error "Invalid environment for compile-expression: " .env|5) #t))))) (.current-env|11 global-syntactic-environment)) (dynamic-wind (lambda () (set! global-syntactic-environment .syntax-env|8)) (lambda () (make-readable (macro-expand .expr|5))) (lambda () (set! global-syntactic-environment .current-env|11)))))) .macro-expand-expression|4)))) 'macro-expand-expression))
+(let () (begin (set! compile313 (lambda (.infilename|1 . .rest|1) (let ((.outfilename|4 (if (not (null? .rest|1)) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) (rewrite-file-type .infilename|1 *scheme-file-types* *lap-file-type*))) (.write-lap|4 (lambda (.item|9 .port|9) (begin (write .item|9 .port|9) (newline .port|9) (newline .port|9))))) (begin (if (benchmark-block-mode) (process-file-block .infilename|1 .outfilename|4 .write-lap|4 compile-block) (process-file .infilename|1 .outfilename|4 .write-lap|4 compile)) (unspecified))))) 'compile313))
+(let () (begin (set! assemble313 (lambda (.file|1 . .rest|1) (let ((.outputfile|4 (if (not (null? .rest|1)) (let ((.x|6|9 .rest|1)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) (rewrite-file-type .file|1 (let* ((.t1|10|13 *lap-file-type*) (.t2|10|16 (cons *mal-file-type* '()))) (let () (cons .t1|10|13 .t2|10|16))) *lop-file-type*))) (.malfile?|4 (file-type=? .file|1 *mal-file-type*)) (.user|4 (assembly-user-data))) (begin (process-file .file|1 .outputfile|4 write-lop (lambda (.x|5) (assemble (if .malfile?|4 (eval .x|5) .x|5) .user|4))) (unspecified))))) 'assemble313))
+(let () (begin (set! compile-and-assemble313 (lambda (.input-file|1 . .rest|1) (let ((.output-file|4 (if (not (null? .rest|1)) (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) (rewrite-file-type .input-file|1 *scheme-file-types* *lop-file-type*))) (.user|4 (assembly-user-data))) (begin (if (benchmark-block-mode) (process-file-block .input-file|1 .output-file|4 write-lop (lambda (.x|5) (assemble (compile-block .x|5) .user|4))) (process-file .input-file|1 .output-file|4 write-lop (lambda (.x|6) (assemble (compile .x|6) .user|4)))) (unspecified))))) 'compile-and-assemble313))
+(let () (begin (set! make-fasl (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 *lop-file-type* *fasl-file-type*)))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) .x|7)) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Make-fasl not supported on this target architecture.") (.doit|2)))))) 'make-fasl))
+(let () (begin (set! disassemble (lambda (.item|1 . .rest|1) (let ((.output-port|4 (if (null? .rest|1) (current-output-port) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))))) (begin (disassemble-item .item|1 #f .output-port|4) (unspecified))))) 'disassemble))
+(let () (begin (set! disassemble-item (lambda (.item|1 .segment-no|1 .port|1) (let ((.disassemble-item|2 0)) (begin (set! .disassemble-item|2 (lambda (.item|3 .segment-no|3 .port|3) (let ((.print-segment|5 (unspecified)) (.print-constvector|5 (unspecified)) (.print|5 (unspecified))) (begin (set! .print-segment|5 (lambda (.segment|6) (begin (.print|5 "Segment # " .segment-no|3) (print-instructions (disassemble-codevector (let ((.x|7|10 .segment|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) .port|3) (.print-constvector|5 (let ((.x|11|14 .segment|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (.print|5 "========================================")))) (set! .print-constvector|5 (lambda (.cv|15) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! .loop|17|19|22 (lambda (.i|23) (if (= .i|23 (let ((.v|25|28 .cv|15)) (begin (.check! (vector? .v|25|28) 42 .v|25|28) (vector-length:vec .v|25|28)))) (if #f #f (unspecified)) (begin (begin #t (.print|5 "------------------------------------------") (.print|5 "Constant vector element # " .i|23) (let ((.temp|30|33 (let ((.x|90|93 (let ((.v|94|97 .cv|15) (.i|94|97 .i|23)) (begin (.check! (fixnum? .i|94|97) 40 .v|94|97 .i|94|97) (.check! (vector? .v|94|97) 40 .v|94|97 .i|94|97) (.check! (<:fix:fix .i|94|97 (vector-length:vec .v|94|97)) 40 .v|94|97 .i|94|97) (.check! (>=:fix:fix .i|94|97 0) 40 .v|94|97 .i|94|97) (vector-ref:trusted .v|94|97 .i|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93))))) (if (memv .temp|30|33 '(codevector)) (begin (.print|5 "Code vector") (print-instructions (disassemble-codevector (let ((.x|36|39 (let ((.x|40|43 (let ((.v|44|47 .cv|15) (.i|44|47 .i|23)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47))))) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) .port|3)) (if (memv .temp|30|33 '(constantvector)) (begin (.print|5 "Constant vector") (.print-constvector|5 (let ((.x|50|53 (let ((.x|54|57 (let ((.v|58|61 .cv|15) (.i|58|61 .i|23)) (begin (.check! (fixnum? .i|58|61) 40 .v|58|61 .i|58|61) (.check! (vector? .v|58|61) 40 .v|58|61 .i|58|61) (.check! (<:fix:fix .i|58|61 (vector-length:vec .v|58|61)) 40 .v|58|61 .i|58|61) (.check! (>=:fix:fix .i|58|61 0) 40 .v|58|61 .i|58|61) (vector-ref:trusted .v|58|61 .i|58|61))))) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .temp|30|33 '(global)) (.print|5 "Global: " (let ((.x|64|67 (let ((.x|68|71 (let ((.v|72|75 .cv|15) (.i|72|75 .i|23)) (begin (.check! (fixnum? .i|72|75) 40 .v|72|75 .i|72|75) (.check! (vector? .v|72|75) 40 .v|72|75 .i|72|75) (.check! (<:fix:fix .i|72|75 (vector-length:vec .v|72|75)) 40 .v|72|75 .i|72|75) (.check! (>=:fix:fix .i|72|75 0) 40 .v|72|75 .i|72|75) (vector-ref:trusted .v|72|75 .i|72|75))))) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (if (memv .temp|30|33 '(data)) (.print|5 "Data: " (let ((.x|78|81 (let ((.x|82|85 (let ((.v|86|89 .cv|15) (.i|86|89 .i|23)) (begin (.check! (fixnum? .i|86|89) 40 .v|86|89 .i|86|89) (.check! (vector? .v|86|89) 40 .v|86|89 .i|86|89) (.check! (<:fix:fix .i|86|89 (vector-length:vec .v|86|89)) 40 .v|86|89 .i|86|89) (.check! (>=:fix:fix .i|86|89 0) 40 .v|86|89 .i|86|89) (vector-ref:trusted .v|86|89 .i|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (unspecified))))))) (.loop|17|19|22 (+ .i|23 1)))))) (.loop|17|19|22 0)))))) (set! .print|5 (lambda .rest|98 (begin (let () (let ((.loop|104|106|109 (unspecified))) (begin (set! .loop|104|106|109 (lambda (.y1|99|100|110) (if (null? .y1|99|100|110) (if #f #f (unspecified)) (begin (begin #t (let ((.x|114 (let ((.x|115|118 .y1|99|100|110)) (begin (.check! (pair? .x|115|118) 0 .x|115|118) (car:pair .x|115|118))))) (display .x|114 .port|3))) (.loop|104|106|109 (let ((.x|119|122 .y1|99|100|110)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122)))))))) (.loop|104|106|109 .rest|98)))) (newline .port|3)))) (if (procedure? .item|3) (print-instructions (disassemble-codevector (procedure-ref .item|3 0)) .port|3) (if (if (pair? .item|3) (if (bytevector? (let ((.x|126|129 .item|3)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129)))) (vector? (let ((.x|131|134 .item|3)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134)))) #f) #f) (.print-segment|5 .item|3) (error "disassemble-item: " .item|3 " is not disassemblable."))))))) (.disassemble-item|2 .item|1 .segment-no|1 .port|1))))) 'disassemble-item))
+(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "\; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
+(let () (begin (set! compiler-switches (lambda .rest|1 (let ((.fast-unsafe-code|3 (unspecified)) (.fast-safe-code|3 (unspecified)) (.standard-code|3 (unspecified)) (.slow-code|3 (unspecified))) (begin (set! .fast-unsafe-code|3 (lambda () (begin (set-compiler-flags! 'fast-unsafe) (set-assembler-flags! 'fast-unsafe)))) (set! .fast-safe-code|3 (lambda () (begin (set-compiler-flags! 'fast-safe) (set-assembler-flags! 'fast-safe)))) (set! .standard-code|3 (lambda () (begin (set-compiler-flags! 'standard) (set-assembler-flags! 'standard)))) (set! .slow-code|3 (lambda () (begin (set-compiler-flags! 'no-optimization) (set-assembler-flags! 'no-optimization)))) (if (null? .rest|1) (begin (display "Debugging:") (newline) (display-twobit-flags 'debugging) (display-assembler-flags 'debugging) (newline) (display "Safety:") (newline) (display-twobit-flags 'safety) (display-assembler-flags 'safety) (newline) (display "Speed:") (newline) (display-twobit-flags 'optimization) (display-assembler-flags 'optimization) (if #f #f (unspecified))) (if (null? (let ((.x|9|12 .rest|1)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (begin (let ((.temp|13|16 (let ((.x|27|30 .rest|1)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (if (memv .temp|13|16 '(0 slow)) (.slow-code|3) (if (memv .temp|13|16 '(1 standard)) (.standard-code|3) (if (memv .temp|13|16 '(2 fast-safe)) (.fast-safe-code|3) (if (memv .temp|13|16 '(3 fast-unsafe)) (.fast-unsafe-code|3) (if (memv .temp|13|16 '(default factory-settings)) (begin (.fast-safe-code|3) (include-source-code #t) (benchmark-mode #f) (benchmark-block-mode #f) (common-subexpression-elimination #f) (representation-inference #f)) (error "Unrecognized flag " (let ((.x|23|26 .rest|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) " to compiler-switches."))))))) (unspecified)) (error "Too many arguments to compiler-switches."))))))) 'compiler-switches))
+(let () (begin (set! process-file (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file|2 0)) (begin (set! .process-file|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let ((.x|12 (read .inport|9))) (let () (let ((.loop|15 (unspecified))) (begin (set! .loop|15 (lambda (.x|16) (if (eof-object? .x|16) #t (begin (.writer|3 (.processer|3 .x|16) .outport|8) (.loop|15 (read .inport|9)))))) (.loop|15 .x|12)))))))))))) (let ((.current-syntactic-environment|17 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|17)))))))) (.process-file|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file))
+(let () (begin (set! process-file-block (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file-block|2 0)) (begin (set! .process-file-block|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.x|17 .forms|17) (if (eof-object? .x|17) (.writer|3 (.processer|3 (reverse .forms|17)) .outport|8) (begin #t (.loop|10|13|16 (read .inport|9) (cons .x|17 .forms|17)))))) (.loop|10|13|16 (read .inport|9) '()))))))))))) (let ((.current-syntactic-environment|20 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|20)))))))) (.process-file-block|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file-block))
+(let () (begin (set! rewrite-file-type (lambda (.filename|1 .matches|1 .new|1) (let ((.rewrite-file-type|2 0)) (begin (set! .rewrite-file-type|2 (lambda (.filename|3 .matches|3 .new|3) (if (not (pair? .matches|3)) (.rewrite-file-type|2 .filename|3 (cons .matches|3 '()) .new|3) (let* ((.j|7 (string-length .filename|3)) (.m|10 .matches|3)) (let () (let ((.loop|13 (unspecified))) (begin (set! .loop|13 (lambda (.m|14) (if (null? .m|14) (string-append .filename|3 .new|3) (let* ((.n|19 (let ((.x|30|33 .m|14)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (.l|22 (string-length .n|19))) (let () (if (file-type=? .filename|3 .n|19) (string-append (substring .filename|3 0 (- .j|7 .l|22)) .new|3) (.loop|13 (let ((.x|26|29 .m|14)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))))) (.loop|13 .m|10)))))))) (.rewrite-file-type|2 .filename|1 .matches|1 .new|1))))) 'rewrite-file-type))
+(let () (begin (set! file-type=? (lambda (.file-name|1 .type-name|1) (let ((.file-type=?|2 0)) (begin (set! .file-type=?|2 (lambda (.file-name|3 .type-name|3) (let ((.fl|6 (string-length .file-name|3)) (.tl|6 (string-length .type-name|3))) (if (>= .fl|6 .tl|6) (string-ci=? .type-name|3 (substring .file-name|3 (- .fl|6 .tl|6) .fl|6)) #f)))) (.file-type=?|2 .file-name|1 .type-name|1))))) 'file-type=?))
+(let () (begin (set! readify-lap (lambda (.code|1) (let ((.readify-lap|2 0)) (begin (set! .readify-lap|2 (lambda (.code|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let* ((.x|24 (let ((.x|88|91 .y1|4|5|16)) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91)))) (.iname|27 (let ((.x|79|82 (assv (let ((.x|84|87 .x|24)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) *mnemonic-names*))) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (if (not (= (let ((.x|28|31 .x|24)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) $lambda)) (cons .iname|27 (let ((.x|32|35 .x|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))) (let* ((.t1|36|39 .iname|27) (.t2|36|42 (let* ((.t1|46|49 (.readify-lap|2 (let ((.x|71|74 (let ((.x|75|78 .x|24)) (begin (.check! (pair? .x|75|78) 1 .x|75|78) (cdr:pair .x|75|78))))) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74))))) (.t2|46|52 (cons (let ((.x|58|61 (let ((.x|62|65 (let ((.x|66|69 .x|24)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))))) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) '()))) (let () (cons .t1|46|49 .t2|46|52))))) (let () (cons .t1|36|39 .t2|36|42))))) .results|4|8|16)))))) (.loop|9|12|15 .code|3 '())))))) (.readify-lap|2 .code|1))))) 'readify-lap))
+(let () (begin (set! readify-file (lambda (.f|1 . .o|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let* ((.i|6 (open-input-file .f|1)) (.x|9 (read .i|6))) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.x|13) (if (not (eof-object? .x|13)) (begin (pretty-print (readify-lap .x|13)) (.loop|12 (read .i|6))) (unspecified)))) (.loop|12 .x|9))))))) (if (null? .o|1) (.doit|2) (begin (delete-file (let ((.x|14|17 .o|1)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17)))) (with-output-to-file (let ((.x|18|21 .o|1)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) .doit|2))))))) 'readify-file))
+(let () (begin (set! assembly-table (lambda () (let ((.assembly-table|2 0)) (begin (set! .assembly-table|2 (lambda () (error "No assembly table defined."))) (.assembly-table|2))))) 'assembly-table))
+(let () (begin (set! assembly-start (lambda (.as|1) (let ((.assembly-start|2 0)) (begin (set! .assembly-start|2 (lambda (.as|3) #t)) (.assembly-start|2 .as|1))))) 'assembly-start))
+(let () (begin (set! assembly-end (lambda (.as|1 .segment|1) (let ((.assembly-end|2 0)) (begin (set! .assembly-end|2 (lambda (.as|3 .segment|3) .segment|3)) (.assembly-end|2 .as|1 .segment|1))))) 'assembly-end))
+(let () (begin (set! assembly-user-data (lambda () (let ((.assembly-user-data|2 0)) (begin (set! .assembly-user-data|2 (lambda () #f)) (.assembly-user-data|2))))) 'assembly-user-data))
+(let () (begin (set! assemble (lambda (.source|1 . .rest|1) (let* ((.user|4 (if (null? .rest|1) (assembly-user-data) (let ((.x|15|18 .rest|1)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))))) (.as|7 (make-assembly-structure .source|1 (assembly-table) .user|4))) (let () (begin (assembly-start .as|7) (assemble1 .as|7 (lambda (.as|11) (let ((.segment|14 (assemble-pasteup .as|11))) (begin (assemble-finalize! .as|11) (assembly-end .as|11 .segment|14)))) #f)))))) 'assemble))
+(let () (begin (set! assemble-nested-lambda (lambda (.as|1 .source|1 .doc|1 .k|1 . .rest|1) (let* ((.user|4 (if (null? .rest|1) #f (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))))) (.nested-as|7 (make-assembly-structure .source|1 (as-table .as|1) .user|4))) (let () (begin (as-parent! .nested-as|7 .as|1) (as-nested! .as|1 (cons (lambda () (assemble1 .nested-as|7 (lambda (.nested-as|12) (let ((.segment|15 (assemble-pasteup .nested-as|12))) (begin (assemble-finalize! .nested-as|12) (.k|1 .nested-as|12 .segment|15)))) .doc|1)) (as-nested .as|1)))))))) 'assemble-nested-lambda))
+(let () (begin (set! operand0 car) 'operand0))
+(let () (begin (set! operand1 cadr) 'operand1))
+(let () (begin (set! operand2 caddr) 'operand2))
+(let () (begin (set! operand3 cadddr) 'operand3))
+(let () (begin (set! operand4 (lambda (.i|1) (let ((.operand4|2 0)) (begin (set! .operand4|2 (lambda (.i|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .i|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.operand4|2 .i|1))))) 'operand4))
+(let () (begin (set! emit! (lambda (.as|1 .bv|1) (let ((.emit!|2 0)) (begin (set! .emit!|2 (lambda (.as|3 .bv|3) (begin (as-code! .as|3 (cons .bv|3 (as-code .as|3))) (as-lc! .as|3 (+ (as-lc .as|3) (bytevector-length .bv|3)))))) (.emit!|2 .as|1 .bv|1))))) 'emit!))
+(let () (begin (set! emit-string! (lambda (.as|1 .s|1) (let ((.emit-string!|2 0)) (begin (set! .emit-string!|2 (lambda (.as|3 .s|3) (begin (as-code! .as|3 (cons .s|3 (as-code .as|3))) (as-lc! .as|3 (+ (as-lc .as|3) (string-length .s|3)))))) (.emit-string!|2 .as|1 .s|1))))) 'emit-string!))
+(let () (begin (set! emit-constant (lambda (.as|1 .x|1) (let ((.emit-constant|2 0)) (begin (set! .emit-constant|2 (lambda (.as|3 .x|3) (let () (let ((.loop|4|7|10 (unspecified))) (begin (set! .loop|4|7|10 (lambda (.i|11 .y|11) (if (let ((.temp|13|16 (null? .y|11))) (if .temp|13|16 .temp|13|16 (equal? .x|3 (let ((.x|18|21 .y|11)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21)))))) (begin (if (null? .y|11) (as-constants! .as|3 (append! (as-constants .as|3) (cons .x|3 '()))) (unspecified)) .i|11) (begin #t (.loop|4|7|10 (+ .i|11 1) (let ((.x|24|27 .y|11)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|4|7|10 0 (as-constants .as|3))))))) (.emit-constant|2 .as|1 .x|1))))) 'emit-constant))
+(let () (begin (set! emit-datum (lambda (.as|1 .x|1) (let ((.emit-datum|2 0)) (begin (set! .emit-datum|2 (lambda (.as|3 .x|3) (emit-constant .as|3 (let* ((.t1|4|7 'data) (.t2|4|10 (cons .x|3 '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.emit-datum|2 .as|1 .x|1))))) 'emit-datum))
+(let () (begin (set! emit-global (lambda (.as|1 .x|1) (let ((.emit-global|2 0)) (begin (set! .emit-global|2 (lambda (.as|3 .x|3) (emit-constant .as|3 (let* ((.t1|4|7 'global) (.t2|4|10 (cons .x|3 '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.emit-global|2 .as|1 .x|1))))) 'emit-global))
+(let () (begin (set! emit-codevector (lambda (.as|1 .x|1) (let ((.emit-codevector|2 0)) (begin (set! .emit-codevector|2 (lambda (.as|3 .x|3) (emit-constants .as|3 (let* ((.t1|4|7 'codevector) (.t2|4|10 (cons .x|3 '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.emit-codevector|2 .as|1 .x|1))))) 'emit-codevector))
+(let () (begin (set! emit-constantvector (lambda (.as|1 .x|1) (let ((.emit-constantvector|2 0)) (begin (set! .emit-constantvector|2 (lambda (.as|3 .x|3) (emit-constants .as|3 (let* ((.t1|4|7 'constantvector) (.t2|4|10 (cons .x|3 '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.emit-constantvector|2 .as|1 .x|1))))) 'emit-constantvector))
+(let () (begin (set! set-constant! (lambda (.as|1 .n|1 .datum|1) (let ((.set-constant!|2 0)) (begin (set! .set-constant!|2 (lambda (.as|3 .n|3 .datum|3) (let ((.pair|6 (list-ref (as-constants .as|3) .n|3))) (set-car! (let ((.x|7|10 .pair|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) .datum|3)))) (.set-constant!|2 .as|1 .n|1 .datum|1))))) 'set-constant!))
+(let () (begin (set! emit-constants (lambda (.as|1 .x|1 . .rest|1) (let* ((.constants|4 (as-constants .as|1)) (.i|7 (length .constants|4))) (let () (begin (as-constants! .as|1 (append! .constants|4 (cons .x|1 .rest|1))) .i|7))))) 'emit-constants))
+(let () (begin (set! emit-label! (lambda (.as|1 .l|1) (let ((.emit-label!|2 0)) (begin (set! .emit-label!|2 (lambda (.as|3 .l|3) (set-cdr! .l|3 (as-lc .as|3)))) (.emit-label!|2 .as|1 .l|1))))) 'emit-label!))
+(let () (begin (set! emit-fixup! (lambda (.as|1 .offset|1 .size|1 .n|1) (let ((.emit-fixup!|2 0)) (begin (set! .emit-fixup!|2 (lambda (.as|3 .offset|3 .size|3 .n|3) (as-fixups! .as|3 (cons (let* ((.t1|4|7 (+ .offset|3 (as-lc .as|3))) (.t2|4|10 (let* ((.t1|14|17 .size|3) (.t2|14|20 (cons .n|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))) (as-fixups .as|3))))) (.emit-fixup!|2 .as|1 .offset|1 .size|1 .n|1))))) 'emit-fixup!))
+(let () (begin (set! emit-fixup-label! (lambda (.as|1 .offset|1 .size|1 .l|1) (let ((.emit-fixup-label!|2 0)) (begin (set! .emit-fixup-label!|2 (lambda (.as|3 .offset|3 .size|3 .l|3) (as-fixups! .as|3 (cons (let* ((.t1|4|7 (+ .offset|3 (as-lc .as|3))) (.t2|4|10 (let* ((.t1|14|17 .size|3) (.t2|14|20 (cons (cons .l|3 '()) '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))) (as-fixups .as|3))))) (.emit-fixup-label!|2 .as|1 .offset|1 .size|1 .l|1))))) 'emit-fixup-label!))
+(let () (begin (set! emit-fixup-proc! (lambda (.as|1 .proc|1) (let ((.emit-fixup-proc!|2 0)) (begin (set! .emit-fixup-proc!|2 (lambda (.as|3 .proc|3) (as-fixups! .as|3 (cons (let* ((.t1|4|7 (as-lc .as|3)) (.t2|4|10 (let* ((.t1|14|17 0) (.t2|14|20 (cons .proc|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))) (as-fixups .as|3))))) (.emit-fixup-proc!|2 .as|1 .proc|1))))) 'emit-fixup-proc!))
+(let () (begin (set! here (lambda (.as|1) (let ((.here|2 0)) (begin (set! .here|2 (lambda (.as|3) (as-lc .as|3))) (.here|2 .as|1))))) 'here))
+(let () (begin (set! make-asm-label (lambda (.as|1 .label|1) (let ((.make-asm-label|2 0)) (begin (set! .make-asm-label|2 (lambda (.as|3 .label|3) (let ((.probe|6 (find-label .as|3 .label|3))) (if .probe|6 .probe|6 (let ((.l|9 (cons .label|3 #f))) (begin (as-labels! .as|3 (cons .l|9 (as-labels .as|3))) .l|9)))))) (.make-asm-label|2 .as|1 .label|1))))) 'make-asm-label))
+(let () (begin (set! find-label (lambda (.as|1 .l|1) (let ((.find-label|2 0)) (begin (set! .find-label|2 (lambda (.as|3 .l|3) (let ((.lookup-label-loop|4 (unspecified))) (begin (set! .lookup-label-loop|4 (lambda (.x|5 .labels|5 .parent|5) (let* ((.entry|8 (assq .x|5 .labels|5)) (.temp|10|13 .entry|8)) (if .temp|10|13 .temp|10|13 (if (not .parent|5) #f (.lookup-label-loop|4 .x|5 (as-labels .parent|5) (as-parent .parent|5))))))) (.lookup-label-loop|4 .l|3 (as-labels .as|3) (as-parent .as|3)))))) (.find-label|2 .as|1 .l|1))))) 'find-label))
+(let () (begin (set! new-label (let ((.n|3 0)) (lambda () (begin (set! .n|3 (- .n|3 1)) (cons .n|3 #f))))) 'new-label))
+(let () (begin (set! label-value (lambda (.as|1 .l|1) (let ((.label-value|2 0)) (begin (set! .label-value|2 (lambda (.as|3 .l|3) (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.label-value|2 .as|1 .l|1))))) 'label-value))
+(let () (begin (set! next-instruction (lambda (.as|1) (let ((.next-instruction|2 0)) (begin (set! .next-instruction|2 (lambda (.as|3) (let ((.source|6 (as-source .as|3))) (if (null? .source|6) '(-1) (let ((.x|7|10 .source|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))))))) (.next-instruction|2 .as|1))))) 'next-instruction))
+(let () (begin (set! consume-next-instruction! (lambda (.as|1) (let ((.consume-next-instruction!|2 0)) (begin (set! .consume-next-instruction!|2 (lambda (.as|3) (as-source! .as|3 (let ((.x|4|7 (as-source .as|3))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))))) (.consume-next-instruction!|2 .as|1))))) 'consume-next-instruction!))
+(let () (begin (set! push-instruction (lambda (.as|1 .instruction|1) (let ((.push-instruction|2 0)) (begin (set! .push-instruction|2 (lambda (.as|3 .instruction|3) (as-source! .as|3 (cons .instruction|3 (as-source .as|3))))) (.push-instruction|2 .as|1 .instruction|1))))) 'push-instruction))
+(let () (begin (set! assembler-value (lambda (.as|1 .key|1) (let ((.assembler-value|2 0)) (begin (set! .assembler-value|2 (lambda (.as|3 .key|3) (let ((.probe|6 (assq .key|3 (as-values .as|3)))) (if .probe|6 (let ((.x|7|10 .probe|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) #f)))) (.assembler-value|2 .as|1 .key|1))))) 'assembler-value))
+(let () (begin (set! assembler-value! (lambda (.as|1 .key|1 .value|1) (let ((.assembler-value!|2 0)) (begin (set! .assembler-value!|2 (lambda (.as|3 .key|3 .value|3) (let ((.probe|6 (assq .key|3 (as-values .as|3)))) (if .probe|6 (set-cdr! .probe|6 .value|3) (as-values! .as|3 (cons (cons .key|3 .value|3) (as-values .as|3))))))) (.assembler-value!|2 .as|1 .key|1 .value|1))))) 'assembler-value!))
+(let () (begin (set! add-documentation (lambda (.as|1 .doc|1) (let ((.add-documentation|2 0)) (begin (set! .add-documentation|2 (lambda (.as|3 .doc|3) (let* ((.existing-constants|6 (let ((.x|47|50 (let ((.x|51|54 (let ((.x|55|58 (as-constants .as|3))) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58))))) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))))) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) (.new-constants|9 (twobit-sort (lambda (.a|22 .b|22) (< (let ((.x|23|26 .a|22)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) (let ((.x|27|30 .b|22)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (if (not .existing-constants|6) (cons (cons (here .as|3) .doc|3) '()) (if (pair? .existing-constants|6) (cons (cons (here .as|3) .doc|3) .existing-constants|6) (let* ((.t1|35|38 (cons (here .as|3) .doc|3)) (.t2|35|41 (cons (cons 0 .existing-constants|6) '()))) (let () (cons .t1|35|38 .t2|35|41)))))))) (let () (set-car! (let ((.x|14|17 (let ((.x|18|21 (as-constants .as|3))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) .new-constants|9))))) (.add-documentation|2 .as|1 .doc|1))))) 'add-documentation))
+(let () (begin (set! asm-value-too-large (lambda (.as|1 .info|1 .expr|1 .val|1) (let ((.asm-value-too-large|2 0)) (begin (set! .asm-value-too-large|2 (lambda (.as|3 .info|3 .expr|3 .val|3) (if (as-retry .as|3) ((as-retry .as|3)) (asm-error .info|3 ": Value too large: " .expr|3 " = " .val|3)))) (.asm-value-too-large|2 .as|1 .info|1 .expr|1 .val|1))))) 'asm-value-too-large))
+(let () (begin (set! asm-error (lambda (.msg|1 . .rest|1) (if (eq? host-system 'chez) (error 'assembler "~a" (let* ((.t1|3|6 .msg|1) (.t2|3|9 (cons .rest|1 '()))) (let () (cons .t1|3|6 .t2|3|9)))) (apply error .msg|1 .rest|1)))) 'asm-error))
+(let () (begin (set! disasm-error (lambda (.msg|1 . .rest|1) (if (eq? host-system 'chez) (error 'disassembler "~a" (let* ((.t1|3|6 .msg|1) (.t2|3|9 (cons .rest|1 '()))) (let () (cons .t1|3|6 .t2|3|9)))) (apply error .msg|1 .rest|1)))) 'disasm-error))
+(let () (begin (set! label? (lambda (.x|1) (let ((.label?|2 0)) (begin (set! .label?|2 (lambda (.x|3) (if (pair? .x|3) (fixnum? (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) #f))) (.label?|2 .x|1))))) 'label?))
+(let () (begin (set! label.ident car) 'label.ident))
+(let () (begin (set! make-assembly-structure (lambda (.source|1 .table|1 .user-data|1) (let ((.make-assembly-structure|2 0)) (begin (set! .make-assembly-structure|2 (lambda (.source|3 .table|3 .user-data|3) (let* ((.t|4|16|21 .user-data|3) (.t|4|15|24 #f) (.t|4|14|27 #f) (.t|4|13|30 '()) (.t|4|12|33 '()) (.t|4|11|36 '()) (.t|4|10|39 '()) (.t|4|9|42 '()) (.t|4|8|45 '()) (.t|4|7|48 0) (.t|4|6|51 .source|3) (.t|4|5|54 .table|3) (.v|4|18|57 (make-vector 12 .t|4|16|21))) (let () (begin (let ((.v|61|64 .v|4|18|57) (.i|61|64 10) (.x|61|64 .t|4|15|24)) (begin (.check! (fixnum? .i|61|64) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (vector? .v|61|64) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (<:fix:fix .i|61|64 (vector-length:vec .v|61|64)) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (>=:fix:fix .i|61|64 0) 41 .v|61|64 .i|61|64 .x|61|64) (vector-set!:trusted .v|61|64 .i|61|64 .x|61|64))) (let ((.v|65|68 .v|4|18|57) (.i|65|68 9) (.x|65|68 .t|4|14|27)) (begin (.check! (fixnum? .i|65|68) 41 .v|65|68 .i|65|68 .x|65|68) (.check! (vector? .v|65|68) 41 .v|65|68 .i|65|68 .x|65|68) (.check! (<:fix:fix .i|65|68 (vector-length:vec .v|65|68)) 41 .v|65|68 .i|65|68 .x|65|68) (.check! (>=:fix:fix .i|65|68 0) 41 .v|65|68 .i|65|68 .x|65|68) (vector-set!:trusted .v|65|68 .i|65|68 .x|65|68))) (let ((.v|69|72 .v|4|18|57) (.i|69|72 8) (.x|69|72 .t|4|13|30)) (begin (.check! (fixnum? .i|69|72) 41 .v|69|72 .i|69|72 .x|69|72) (.check! (vector? .v|69|72) 41 .v|69|72 .i|69|72 .x|69|72) (.check! (<:fix:fix .i|69|72 (vector-length:vec .v|69|72)) 41 .v|69|72 .i|69|72 .x|69|72) (.check! (>=:fix:fix .i|69|72 0) 41 .v|69|72 .i|69|72 .x|69|72) (vector-set!:trusted .v|69|72 .i|69|72 .x|69|72))) (let ((.v|73|76 .v|4|18|57) (.i|73|76 7) (.x|73|76 .t|4|12|33)) (begin (.check! (fixnum? .i|73|76) 41 .v|73|76 .i|73|76 .x|73|76) (.check! (vector? .v|73|76) 41 .v|73|76 .i|73|76 .x|73|76) (.check! (<:fix:fix .i|73|76 (vector-length:vec .v|73|76)) 41 .v|73|76 .i|73|76 .x|73|76) (.check! (>=:fix:fix .i|73|76 0) 41 .v|73|76 .i|73|76 .x|73|76) (vector-set!:trusted .v|73|76 .i|73|76 .x|73|76))) (let ((.v|77|80 .v|4|18|57) (.i|77|80 6) (.x|77|80 .t|4|11|36)) (begin (.check! (fixnum? .i|77|80) 41 .v|77|80 .i|77|80 .x|77|80) (.check! (vector? .v|77|80) 41 .v|77|80 .i|77|80 .x|77|80) (.check! (<:fix:fix .i|77|80 (vector-length:vec .v|77|80)) 41 .v|77|80 .i|77|80 .x|77|80) (.check! (>=:fix:fix .i|77|80 0) 41 .v|77|80 .i|77|80 .x|77|80) (vector-set!:trusted .v|77|80 .i|77|80 .x|77|80))) (let ((.v|81|84 .v|4|18|57) (.i|81|84 5) (.x|81|84 .t|4|10|39)) (begin (.check! (fixnum? .i|81|84) 41 .v|81|84 .i|81|84 .x|81|84) (.check! (vector? .v|81|84) 41 .v|81|84 .i|81|84 .x|81|84) (.check! (<:fix:fix .i|81|84 (vector-length:vec .v|81|84)) 41 .v|81|84 .i|81|84 .x|81|84) (.check! (>=:fix:fix .i|81|84 0) 41 .v|81|84 .i|81|84 .x|81|84) (vector-set!:trusted .v|81|84 .i|81|84 .x|81|84))) (let ((.v|85|88 .v|4|18|57) (.i|85|88 4) (.x|85|88 .t|4|9|42)) (begin (.check! (fixnum? .i|85|88) 41 .v|85|88 .i|85|88 .x|85|88) (.check! (vector? .v|85|88) 41 .v|85|88 .i|85|88 .x|85|88) (.check! (<:fix:fix .i|85|88 (vector-length:vec .v|85|88)) 41 .v|85|88 .i|85|88 .x|85|88) (.check! (>=:fix:fix .i|85|88 0) 41 .v|85|88 .i|85|88 .x|85|88) (vector-set!:trusted .v|85|88 .i|85|88 .x|85|88))) (let ((.v|89|92 .v|4|18|57) (.i|89|92 3) (.x|89|92 .t|4|8|45)) (begin (.check! (fixnum? .i|89|92) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (vector? .v|89|92) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (<:fix:fix .i|89|92 (vector-length:vec .v|89|92)) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (>=:fix:fix .i|89|92 0) 41 .v|89|92 .i|89|92 .x|89|92) (vector-set!:trusted .v|89|92 .i|89|92 .x|89|92))) (let ((.v|93|96 .v|4|18|57) (.i|93|96 2) (.x|93|96 .t|4|7|48)) (begin (.check! (fixnum? .i|93|96) 41 .v|93|96 .i|93|96 .x|93|96) (.check! (vector? .v|93|96) 41 .v|93|96 .i|93|96 .x|93|96) (.check! (<:fix:fix .i|93|96 (vector-length:vec .v|93|96)) 41 .v|93|96 .i|93|96 .x|93|96) (.check! (>=:fix:fix .i|93|96 0) 41 .v|93|96 .i|93|96 .x|93|96) (vector-set!:trusted .v|93|96 .i|93|96 .x|93|96))) (let ((.v|97|100 .v|4|18|57) (.i|97|100 1) (.x|97|100 .t|4|6|51)) (begin (.check! (fixnum? .i|97|100) 41 .v|97|100 .i|97|100 .x|97|100) (.check! (vector? .v|97|100) 41 .v|97|100 .i|97|100 .x|97|100) (.check! (<:fix:fix .i|97|100 (vector-length:vec .v|97|100)) 41 .v|97|100 .i|97|100 .x|97|100) (.check! (>=:fix:fix .i|97|100 0) 41 .v|97|100 .i|97|100 .x|97|100) (vector-set!:trusted .v|97|100 .i|97|100 .x|97|100))) (let ((.v|101|104 .v|4|18|57) (.i|101|104 0) (.x|101|104 .t|4|5|54)) (begin (.check! (fixnum? .i|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (vector? .v|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (<:fix:fix .i|101|104 (vector-length:vec .v|101|104)) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (>=:fix:fix .i|101|104 0) 41 .v|101|104 .i|101|104 .x|101|104) (vector-set!:trusted .v|101|104 .i|101|104 .x|101|104))) .v|4|18|57))))) (.make-assembly-structure|2 .source|1 .table|1 .user-data|1))))) 'make-assembly-structure))
+(let () (begin (set! as-reset! (lambda (.as|1 .source|1) (let ((.as-reset!|2 0)) (begin (set! .as-reset!|2 (lambda (.as|3 .source|3) (begin (as-source! .as|3 .source|3) (as-lc! .as|3 0) (as-code! .as|3 '()) (as-constants! .as|3 '()) (as-labels! .as|3 '()) (as-fixups! .as|3 '()) (as-nested! .as|3 '()) (as-values! .as|3 '()) (as-retry! .as|3 #f)))) (.as-reset!|2 .as|1 .source|1))))) 'as-reset!))
+(let () (begin (set! as-table (lambda (.as|1) (let ((.as-table|2 0)) (begin (set! .as-table|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-table|2 .as|1))))) 'as-table))
+(let () (begin (set! as-source (lambda (.as|1) (let ((.as-source|2 0)) (begin (set! .as-source|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-source|2 .as|1))))) 'as-source))
+(let () (begin (set! as-lc (lambda (.as|1) (let ((.as-lc|2 0)) (begin (set! .as-lc|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-lc|2 .as|1))))) 'as-lc))
+(let () (begin (set! as-code (lambda (.as|1) (let ((.as-code|2 0)) (begin (set! .as-code|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-code|2 .as|1))))) 'as-code))
+(let () (begin (set! as-constants (lambda (.as|1) (let ((.as-constants|2 0)) (begin (set! .as-constants|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 4)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-constants|2 .as|1))))) 'as-constants))
+(let () (begin (set! as-labels (lambda (.as|1) (let ((.as-labels|2 0)) (begin (set! .as-labels|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 5)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-labels|2 .as|1))))) 'as-labels))
+(let () (begin (set! as-fixups (lambda (.as|1) (let ((.as-fixups|2 0)) (begin (set! .as-fixups|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 6)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-fixups|2 .as|1))))) 'as-fixups))
+(let () (begin (set! as-nested (lambda (.as|1) (let ((.as-nested|2 0)) (begin (set! .as-nested|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 7)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-nested|2 .as|1))))) 'as-nested))
+(let () (begin (set! as-values (lambda (.as|1) (let ((.as-values|2 0)) (begin (set! .as-values|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 8)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-values|2 .as|1))))) 'as-values))
+(let () (begin (set! as-parent (lambda (.as|1) (let ((.as-parent|2 0)) (begin (set! .as-parent|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 9)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-parent|2 .as|1))))) 'as-parent))
+(let () (begin (set! as-retry (lambda (.as|1) (let ((.as-retry|2 0)) (begin (set! .as-retry|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 10)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-retry|2 .as|1))))) 'as-retry))
+(let () (begin (set! as-user (lambda (.as|1) (let ((.as-user|2 0)) (begin (set! .as-user|2 (lambda (.as|3) (let ((.v|4|7 .as|3) (.i|4|7 11)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.as-user|2 .as|1))))) 'as-user))
+(let () (begin (set! as-source! (lambda (.as|1 .x|1) (let ((.as-source!|2 0)) (begin (set! .as-source!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-source!|2 .as|1 .x|1))))) 'as-source!))
+(let () (begin (set! as-lc! (lambda (.as|1 .x|1) (let ((.as-lc!|2 0)) (begin (set! .as-lc!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-lc!|2 .as|1 .x|1))))) 'as-lc!))
+(let () (begin (set! as-code! (lambda (.as|1 .x|1) (let ((.as-code!|2 0)) (begin (set! .as-code!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-code!|2 .as|1 .x|1))))) 'as-code!))
+(let () (begin (set! as-constants! (lambda (.as|1 .x|1) (let ((.as-constants!|2 0)) (begin (set! .as-constants!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 4) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-constants!|2 .as|1 .x|1))))) 'as-constants!))
+(let () (begin (set! as-labels! (lambda (.as|1 .x|1) (let ((.as-labels!|2 0)) (begin (set! .as-labels!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 5) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-labels!|2 .as|1 .x|1))))) 'as-labels!))
+(let () (begin (set! as-fixups! (lambda (.as|1 .x|1) (let ((.as-fixups!|2 0)) (begin (set! .as-fixups!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 6) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-fixups!|2 .as|1 .x|1))))) 'as-fixups!))
+(let () (begin (set! as-nested! (lambda (.as|1 .x|1) (let ((.as-nested!|2 0)) (begin (set! .as-nested!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 7) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-nested!|2 .as|1 .x|1))))) 'as-nested!))
+(let () (begin (set! as-values! (lambda (.as|1 .x|1) (let ((.as-values!|2 0)) (begin (set! .as-values!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 8) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-values!|2 .as|1 .x|1))))) 'as-values!))
+(let () (begin (set! as-parent! (lambda (.as|1 .x|1) (let ((.as-parent!|2 0)) (begin (set! .as-parent!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 9) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-parent!|2 .as|1 .x|1))))) 'as-parent!))
+(let () (begin (set! as-retry! (lambda (.as|1 .x|1) (let ((.as-retry!|2 0)) (begin (set! .as-retry!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 10) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-retry!|2 .as|1 .x|1))))) 'as-retry!))
+(let () (begin (set! as-user! (lambda (.as|1 .x|1) (let ((.as-user!|2 0)) (begin (set! .as-user!|2 (lambda (.as|3 .x|3) (let ((.v|4|7 .as|3) (.i|4|7 11) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.as-user!|2 .as|1 .x|1))))) 'as-user!))
+(let () (begin (set! assemble1 (lambda (.as|1 .finalize|1 .doc|1) (let ((.assemble1|2 0)) (begin (set! .assemble1|2 (lambda (.as|3 .finalize|3 .doc|3) (let ((.assembly-table|6 (as-table .as|3)) (.peep?|6 (peephole-optimization)) (.step?|6 (single-stepping)) (.step-instr|6 (cons $.singlestep '())) (.end-instr|6 (cons $.end '()))) (let ((.doit|9 (unspecified)) (.loop|9 (unspecified))) (begin (set! .doit|9 (lambda () (begin (emit-datum .as|3 .doc|3) (.loop|9)))) (set! .loop|9 (lambda () (let ((.source|14 (as-source .as|3))) (if (null? .source|14) (begin ((let ((.v|15|18 .assembly-table|6) (.i|15|18 $.end)) (begin (.check! (fixnum? .i|15|18) 40 .v|15|18 .i|15|18) (.check! (vector? .v|15|18) 40 .v|15|18 .i|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 40 .v|15|18 .i|15|18) (.check! (>=:fix:fix .i|15|18 0) 40 .v|15|18 .i|15|18) (vector-ref:trusted .v|15|18 .i|15|18))) .end-instr|6 .as|3) (.finalize|3 .as|3)) (begin (if .step?|6 ((let ((.v|19|22 .assembly-table|6) (.i|19|22 $.singlestep)) (begin (.check! (fixnum? .i|19|22) 40 .v|19|22 .i|19|22) (.check! (vector? .v|19|22) 40 .v|19|22 .i|19|22) (.check! (<:fix:fix .i|19|22 (vector-length:vec .v|19|22)) 40 .v|19|22 .i|19|22) (.check! (>=:fix:fix .i|19|22 0) 40 .v|19|22 .i|19|22) (vector-ref:trusted .v|19|22 .i|19|22))) .step-instr|6 .as|3) (unspecified)) (if .peep?|6 (let ((.src1|25 .source|14)) (let () (let ((.peeploop|28 (unspecified))) (begin (set! .peeploop|28 (lambda (.src1|29) (begin (peep .as|3) (let ((.src2|32 (as-source .as|3))) (if (not (eq? .src1|29 .src2|32)) (.peeploop|28 .src2|32) (unspecified)))))) (.peeploop|28 .src1|25))))) (unspecified)) (let ((.source|35 (as-source .as|3))) (begin (as-source! .as|3 (let ((.x|36|39 .source|35)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39)))) ((let ((.v|40|43 .assembly-table|6) (.i|40|43 (let ((.x|45|48 (let ((.x|49|52 .source|35)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))))) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))))) (begin (.check! (fixnum? .i|40|43) 40 .v|40|43 .i|40|43) (.check! (vector? .v|40|43) 40 .v|40|43 .i|40|43) (.check! (<:fix:fix .i|40|43 (vector-length:vec .v|40|43)) 40 .v|40|43 .i|40|43) (.check! (>=:fix:fix .i|40|43 0) 40 .v|40|43 .i|40|43) (vector-ref:trusted .v|40|43 .i|40|43))) (let ((.x|53|56 .source|35)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56))) .as|3) (.loop|9)))))))) (let* ((.source|57 (as-source .as|3)) (.r|60 (call-with-current-continuation (lambda (.k|69) (begin (as-retry! .as|3 (lambda () (.k|69 'retry))) (.doit|9)))))) (let () (if (eq? .r|60 'retry) (let ((.old|66 (short-effective-addresses))) (begin (as-reset! .as|3 .source|57) (dynamic-wind (lambda () (short-effective-addresses #f)) .doit|9 (lambda () (short-effective-addresses .old|66))))) .r|60)))))))) (.assemble1|2 .as|1 .finalize|1 .doc|1))))) 'assemble1))
+(let () (begin (set! assemble-pasteup (lambda (.as|1) (let ((.assemble-pasteup|2 0)) (begin (set! .assemble-pasteup|2 (lambda (.as|3) (let ((.pasteup-strings|4 (unspecified)) (.pasteup-code|4 (unspecified))) (begin (set! .pasteup-strings|4 (lambda () (let ((.code|8 (make-string (as-lc .as|3) #\space)) (.constants|8 (list->vector (as-constants .as|3)))) (let ((.paste-code!|9 (unspecified))) (begin (set! .paste-code!|9 (lambda (.strs|10 .i|10) (if (not (null? .strs|10)) (let* ((.s|13 (let ((.x|34|37 .strs|10)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37)))) (.n|16 (string-length .s|13))) (let () (let () (let ((.loop|20|23|26 (unspecified))) (begin (set! .loop|20|23|26 (lambda (.i|27 .j|27) (if (< .j|27 0) (.paste-code!|9 (let ((.x|29|32 .strs|10)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))) .i|27) (begin (begin #t (string-set! .code|8 .i|27 (string-ref .s|13 .j|27))) (.loop|20|23|26 (- .i|27 1) (- .j|27 1)))))) (.loop|20|23|26 .i|10 (- .n|16 1))))))) (unspecified)))) (.paste-code!|9 (as-code .as|3) (- (as-lc .as|3) 1)) (as-code! .as|3 (cons .code|8 '())) (cons .code|8 .constants|8)))))) (set! .pasteup-code|4 (lambda () (let ((.code|43 (make-bytevector (as-lc .as|3))) (.constants|43 (list->vector (as-constants .as|3)))) (let ((.paste-code!|44 (unspecified))) (begin (set! .paste-code!|44 (lambda (.bvs|45 .i|45) (if (not (null? .bvs|45)) (let* ((.bv|48 (let ((.x|69|72 .bvs|45)) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72)))) (.n|51 (bytevector-length .bv|48))) (let () (let () (let ((.loop|55|58|61 (unspecified))) (begin (set! .loop|55|58|61 (lambda (.i|62 .j|62) (if (< .j|62 0) (.paste-code!|44 (let ((.x|64|67 .bvs|45)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67))) .i|62) (begin (begin #t (bytevector-set! .code|43 .i|62 (bytevector-ref .bv|48 .j|62))) (.loop|55|58|61 (- .i|62 1) (- .j|62 1)))))) (.loop|55|58|61 .i|45 (- .n|51 1))))))) (unspecified)))) (.paste-code!|44 (as-code .as|3) (- (as-lc .as|3) 1)) (as-code! .as|3 (cons .code|43 '())) (cons .code|43 .constants|43)))))) (if (bytevector? (let ((.x|74|77 (as-code .as|3))) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) (.pasteup-code|4) (.pasteup-strings|4)))))) (.assemble-pasteup|2 .as|1))))) 'assemble-pasteup))
+(let () (begin (set! assemble-finalize! (lambda (.as|1) (let ((.assemble-finalize!|2 0)) (begin (set! .assemble-finalize!|2 (lambda (.as|3) (let ((.code|6 (let ((.x|101|104 (as-code .as|3))) (begin (.check! (pair? .x|101|104) 0 .x|101|104) (car:pair .x|101|104))))) (let ((.lookup-label|7 (unspecified)) (.apply-fixups!|7 (unspecified))) (begin (set! .lookup-label|7 (lambda (.l|8) (let ((.temp|9|12 (label-value .as|3 (label.ident .l|8)))) (if .temp|9|12 .temp|9|12 (asm-error "Assembler error -- undefined label " .l|8))))) (set! .apply-fixups!|7 (lambda (.fixups|14) (if (not (null? .fixups|14)) (let* ((.fixup|17 (let ((.x|73|76 .fixups|14)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76)))) (.i|20 (let ((.x|69|72 .fixup|17)) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72)))) (.size|23 (let ((.x|61|64 (let ((.x|65|68 .fixup|17)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68))))) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64)))) (.adjustment|26 (let ((.x|48|51 (let ((.x|52|55 (let ((.x|56|59 .fixup|17)) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))))) (begin (.check! (pair? .x|52|55) 1 .x|52|55) (cdr:pair .x|52|55))))) (begin (.check! (pair? .x|48|51) 0 .x|48|51) (car:pair .x|48|51)))) (.n|29 (if (label? .adjustment|26) (.lookup-label|7 .adjustment|26) .adjustment|26))) (let () (begin (let ((.temp|33|36 .size|23)) (if (memv .temp|33|36 '(0)) (fixup-proc .code|6 .i|20 .n|29) (if (memv .temp|33|36 '(1)) (fixup1 .code|6 .i|20 .n|29) (if (memv .temp|33|36 '(2)) (fixup2 .code|6 .i|20 .n|29) (if (memv .temp|33|36 '(3)) (fixup3 .code|6 .i|20 .n|29) (if (memv .temp|33|36 '(4)) (fixup4 .code|6 .i|20 .n|29) ???)))))) (.apply-fixups!|7 (let ((.x|43|46 .fixups|14)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))))) (unspecified)))) (.apply-fixups!|7 (reverse! (as-fixups .as|3))) (let () (let ((.loop|82|84|87 (unspecified))) (begin (set! .loop|82|84|87 (lambda (.y1|77|78|88) (if (null? .y1|77|78|88) (if #f #f (unspecified)) (begin (begin #t (let ((.nested-as-proc|92 (let ((.x|93|96 .y1|77|78|88)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))))) (.nested-as-proc|92))) (.loop|82|84|87 (let ((.x|97|100 .y1|77|78|88)) (begin (.check! (pair? .x|97|100) 1 .x|97|100) (cdr:pair .x|97|100)))))))) (.loop|82|84|87 (as-nested .as|3)))))))))) (.assemble-finalize!|2 .as|1))))) 'assemble-finalize!))
+(let () (begin (set! fixup1 (lambda (.code|1 .i|1 .n|1) (let ((.fixup1|2 0)) (begin (set! .fixup1|2 (lambda (.code|3 .i|3 .n|3) (bytevector-set! .code|3 .i|3 (+ .n|3 (bytevector-ref .code|3 .i|3))))) (.fixup1|2 .code|1 .i|1 .n|1))))) 'fixup1))
+(let () (begin (set! fixup2 (lambda (.code|1 .i|1 .n|1) (let ((.fixup2|2 0)) (begin (set! .fixup2|2 (lambda (.code|3 .i|3 .n|3) (let* ((.x|6 (+ (* 256 (bytevector-ref .code|3 .i|3)) (bytevector-ref .code|3 (+ .i|3 1)))) (.y|9 (+ .x|6 .n|3)) (.y0|12 (modulo .y|9 256)) (.y1|15 (modulo (quotient (- .y|9 .y0|12) 256) 256))) (let () (begin (bytevector-set! .code|3 .i|3 .y1|15) (bytevector-set! .code|3 (+ .i|3 1) .y0|12)))))) (.fixup2|2 .code|1 .i|1 .n|1))))) 'fixup2))
+(let () (begin (set! fixup3 (lambda (.code|1 .i|1 .n|1) (let ((.fixup3|2 0)) (begin (set! .fixup3|2 (lambda (.code|3 .i|3 .n|3) (let* ((.x|6 (+ (+ (* 65536 (bytevector-ref .code|3 .i|3)) (* 256 (bytevector-ref .code|3 (+ .i|3 1)))) (bytevector-ref .code|3 (+ .i|3 2)))) (.y|9 (+ .x|6 .n|3)) (.y0|12 (modulo .y|9 256)) (.y1|15 (modulo (quotient (- .y|9 .y0|12) 256) 256)) (.y2|18 (modulo (quotient (- (- .y|9 (* 256 .y1|15)) .y0|12) 256) 256))) (let () (begin (bytevector-set! .code|3 .i|3 .y2|18) (bytevector-set! .code|3 (+ .i|3 1) .y1|15) (bytevector-set! .code|3 (+ .i|3 2) .y0|12)))))) (.fixup3|2 .code|1 .i|1 .n|1))))) 'fixup3))
+(let () (begin (set! fixup4 (lambda (.code|1 .i|1 .n|1) (let ((.fixup4|2 0)) (begin (set! .fixup4|2 (lambda (.code|3 .i|3 .n|3) (let* ((.x|6 (+ (+ (+ (* 16777216 (bytevector-ref .code|3 .i|3)) (* 65536 (bytevector-ref .code|3 (+ .i|3 1)))) (* 256 (bytevector-ref .code|3 (+ .i|3 2)))) (bytevector-ref .code|3 (+ .i|3 3)))) (.y|9 (+ .x|6 .n|3)) (.y0|12 (modulo .y|9 256)) (.y1|15 (modulo (quotient (- .y|9 .y0|12) 256) 256)) (.y2|18 (modulo (quotient (- (- .y|9 (* 256 .y1|15)) .y0|12) 256) 256)) (.y3|21 (modulo (quotient (- (- (- .y|9 (* 65536 .y2|18)) (* 256 .y1|15)) .y0|12) 256) 256))) (let () (begin (bytevector-set! .code|3 .i|3 .y3|21) (bytevector-set! .code|3 (+ .i|3 1) .y2|18) (bytevector-set! .code|3 (+ .i|3 2) .y1|15) (bytevector-set! .code|3 (+ .i|3 3) .y0|12)))))) (.fixup4|2 .code|1 .i|1 .n|1))))) 'fixup4))
+(let () (begin (set! fixup-proc (lambda (.code|1 .i|1 .p|1) (let ((.fixup-proc|2 0)) (begin (set! .fixup-proc|2 (lambda (.code|3 .i|3 .p|3) (.p|3 .code|3 .i|3))) (.fixup-proc|2 .code|1 .i|1 .p|1))))) 'fixup-proc))
+(let () (begin (set! view-segment (lambda (.segment|1) (let ((.view-segment|2 0)) (begin (set! .view-segment|2 (lambda (.segment|3) (let ((.display-bytevector|4 (unspecified))) (begin (set! .display-bytevector|4 (lambda (.bv|5) (let ((.n|8 (bytevector-length .bv|5))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.i|16) (if (= .i|16 .n|8) (if #f #f (unspecified)) (begin (begin #t (if (zero? (remainder .i|16 4)) (write-char #\space) (unspecified)) (if (zero? (remainder .i|16 8)) (write-char #\space) (unspecified)) (if (zero? (remainder .i|16 32)) (newline) (unspecified)) (let ((.byte|21 (bytevector-ref .bv|5 .i|16))) (begin (write-char (string-ref (number->string (quotient .byte|21 16) 16) 0)) (write-char (string-ref (number->string (remainder .byte|21 16) 16) 0))))) (.loop|10|12|15 (+ .i|16 1)))))) (.loop|10|12|15 0))))))) (if (if (pair? .segment|3) (if (bytevector? (let ((.x|24|27 .segment|3)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27)))) (vector? (let ((.x|29|32 .segment|3)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32)))) #f) #f) (begin (.display-bytevector|4 (let ((.x|33|36 .segment|3)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))) (newline) (write (let ((.x|37|40 .segment|3)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))) (newline) (let () (let ((.loop|42|44|47 (unspecified))) (begin (set! .loop|42|44|47 (lambda (.constants|48) (if (let ((.temp|50|53 (null? .constants|48))) (if .temp|50|53 .temp|50|53 (null? (let ((.x|55|58 .constants|48)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58)))))) (if #f #f (unspecified)) (begin (begin #t (if (if (bytevector? (let ((.x|61|64 .constants|48)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64)))) (vector? (let ((.x|67|70 (let ((.x|71|74 .constants|48)) (begin (.check! (pair? .x|71|74) 1 .x|71|74) (cdr:pair .x|71|74))))) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70)))) #f) (.view-segment|2 (cons (let ((.x|75|78 .constants|48)) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))) (let ((.x|80|83 (let ((.x|84|87 .constants|48)) (begin (.check! (pair? .x|84|87) 1 .x|84|87) (cdr:pair .x|84|87))))) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83))))) (unspecified))) (.loop|42|44|47 (let ((.x|88|91 .constants|48)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91)))))))) (.loop|42|44|47 (vector->list (let ((.x|92|95 .segment|3)) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))))))))) (unspecified)))))) (.view-segment|2 .segment|1))))) 'view-segment))
+(let () (begin (set! test-asm (lambda (.emit|1) (let ((.test-asm|2 0)) (begin (set! .test-asm|2 (lambda (.emit|3) (let ((.as|6 (make-assembly-structure #f #f #f))) (begin (.emit|3 .as|6) (let ((.segment|9 (assemble-pasteup .as|6))) (begin (assemble-finalize! .as|6) (disassemble .segment|9))))))) (.test-asm|2 .emit|1))))) 'test-asm))
+(let () (begin (set! compile&assemble (lambda (.x|1) (let ((.compile&assemble|2 0)) (begin (set! .compile&assemble|2 (lambda (.x|3) (view-segment (assemble (compile .x|3))))) (.compile&assemble|2 .x|1))))) 'compile&assemble))
+(let () (begin (set! format-object (lambda (.x|1) (let ((.format-object|2 0)) (begin (set! .format-object|2 (lambda (.x|3) (let ((.format-improper-list|5 (unspecified)) (.format-list|5 (unspecified))) (begin (set! .format-improper-list|5 (lambda (.x|6) (let ((.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.x|8) (if (pair? (let ((.x|9|12 .x|8)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (cons (.format-object|2 (let ((.x|13|16 .x|8)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16)))) (cons " " (.loop|7 (let ((.x|17|20 .x|8)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20)))))) (let* ((.t1|21|24 (.format-object|2 (let ((.x|56|59 .x|8)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (.t2|21|27 (let* ((.t1|31|34 " . ") (.t2|31|37 (let* ((.t1|41|44 (.format-object|2 (let ((.x|52|55 .x|8)) (begin (.check! (pair? .x|52|55) 1 .x|52|55) (cdr:pair .x|52|55))))) (.t2|41|47 (cons ")" '()))) (let () (cons .t1|41|44 .t2|41|47))))) (let () (cons .t1|31|34 .t2|31|37))))) (let () (cons .t1|21|24 .t2|21|27)))))) (apply string-append (cons "(" (.loop|7 .x|6))))))) (set! .format-list|5 (lambda (.x|60) (let ((.loop|61 (unspecified))) (begin (set! .loop|61 (lambda (.x|62) (if (null? .x|62) '(")") (if (null? (let ((.x|65|68 .x|62)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68)))) (let* ((.t1|69|72 (.format-object|2 (let ((.x|80|83 .x|62)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83))))) (.t2|69|75 (cons ")" '()))) (let () (cons .t1|69|72 .t2|69|75))) (cons (.format-object|2 (let ((.x|85|88 .x|62)) (begin (.check! (pair? .x|85|88) 0 .x|85|88) (car:pair .x|85|88)))) (cons " " (.loop|61 (let ((.x|89|92 .x|62)) (begin (.check! (pair? .x|89|92) 1 .x|89|92) (cdr:pair .x|89|92)))))))))) (apply string-append (cons "(" (.loop|61 .x|60))))))) (if (null? .x|3) "()" (if (not .x|3) "#f" (if (eq? .x|3 #t) "#t" (if (symbol? .x|3) (symbol->string .x|3) (if (number? .x|3) (number->string .x|3) (if (char? .x|3) (string .x|3) (if (string? .x|3) .x|3 (if (procedure? .x|3) "#<procedure>" (if (bytevector? .x|3) "#<bytevector>" (if (eof-object? .x|3) "#<eof>" (if (port? .x|3) "#<port>" (if (eq? .x|3 (unspecified)) "#!unspecified" (if (eq? .x|3 (undefined)) "#!undefined" (if (vector? .x|3) (string-append "#" (.format-list|5 (vector->list .x|3))) (if (list? .x|3) (.format-list|5 .x|3) (if (pair? .x|3) (.format-improper-list|5 .x|3) "#<weird>")))))))))))))))))))) (.format-object|2 .x|1))))) 'format-object))
+(let () (begin (set! asm:endianness 'big) 'asm:endianness))
+(let () (begin (set! asm:bv (lambda (.n1|1 .n2|1 .n3|1 .n4|1) (let ((.asm:bv|2 0)) (begin (set! .asm:bv|2 (lambda (.n1|3 .n2|3 .n3|3 .n4|3) (let ((.bv|6 (make-bytevector 4))) (begin (bytevector-set! .bv|6 0 .n1|3) (bytevector-set! .bv|6 1 .n2|3) (bytevector-set! .bv|6 2 .n3|3) (bytevector-set! .bv|6 3 .n4|3) .bv|6)))) (.asm:bv|2 .n1|1 .n2|1 .n3|1 .n4|1))))) 'asm:bv))
+(let () (begin (set! asm:bv->int (lambda (.bv|1) (let ((.asm:bv->int|2 0)) (begin (set! .asm:bv->int|2 (lambda (.bv|3) (let ((.i|6 (+ (* (+ (* (+ (* (bytevector-ref .bv|3 0) 256) (bytevector-ref .bv|3 1)) 256) (bytevector-ref .bv|3 2)) 256) (bytevector-ref .bv|3 3)))) (if (> (bytevector-ref .bv|3 0) 127) (- 0 .i|6) .i|6)))) (.asm:bv->int|2 .bv|1))))) 'asm:bv->int))
+(let () (begin (set! asm:lsh (lambda (.m|1 .n|1) (let ((.asm:lsh|2 0)) (begin (set! .asm:lsh|2 (lambda (.m|3 .n|3) (if (not (bytevector? .m|3)) (.asm:lsh|2 (asm:int->bv .m|3) .n|3) (let ((.m|6 (bytevector-copy .m|3)) (.n|6 (remainder .n|3 33))) (begin (if (>= .n|6 8) (let ((.k|9 (quotient .n|6 8))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.i|16) (if (= (+ .i|16 .k|9) 4) (let () (let ((.loop|19|21|24 (unspecified))) (begin (set! .loop|19|21|24 (lambda (.i|25) (if (= .i|25 4) (if #f #f (unspecified)) (begin (begin #t (bytevector-set! .m|6 .i|25 0)) (.loop|19|21|24 (+ .i|25 1)))))) (.loop|19|21|24 .i|16)))) (begin (begin #t (bytevector-set! .m|6 .i|16 (bytevector-ref .m|6 (+ .i|16 .k|9)))) (.loop|10|12|15 (+ .i|16 1)))))) (.loop|10|12|15 0))))) (unspecified)) (let* ((.d0|31 (bytevector-ref .m|6 0)) (.d1|34 (bytevector-ref .m|6 1)) (.d2|37 (bytevector-ref .m|6 2)) (.d3|40 (bytevector-ref .m|6 3)) (.n|43 (remainder .n|6 8)) (.n-|46 (- 8 .n|43))) (let () (asm:bv (logand (logior (lsh .d0|31 .n|43) (rshl .d1|34 .n-|46)) 255) (logand (logior (lsh .d1|34 .n|43) (rshl .d2|37 .n-|46)) 255) (logand (logior (lsh .d2|37 .n|43) (rshl .d3|40 .n-|46)) 255) (logand (lsh .d3|40 .n|43) 255))))))))) (.asm:lsh|2 .m|1 .n|1))))) 'asm:lsh))
+(let () (begin (set! asm:rshl (lambda (.m|1 .n|1) (let ((.asm:rshl|2 0)) (begin (set! .asm:rshl|2 (lambda (.m|3 .n|3) (if (not (bytevector? .m|3)) (.asm:rshl|2 (asm:int->bv .m|3) .n|3) (let ((.m|6 (bytevector-copy .m|3)) (.n|6 (remainder .n|3 33))) (begin (if (>= .n|6 8) (let ((.k|9 (quotient .n|6 8))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.i|16) (if (< (- .i|16 .k|9) 0) (let () (let ((.loop|19|21|24 (unspecified))) (begin (set! .loop|19|21|24 (lambda (.i|25) (if (< .i|25 0) (if #f #f (unspecified)) (begin (begin #t (bytevector-set! .m|6 .i|25 0)) (.loop|19|21|24 (- .i|25 1)))))) (.loop|19|21|24 .i|16)))) (begin (begin #t (bytevector-set! .m|6 .i|16 (bytevector-ref .m|6 (- .i|16 .k|9)))) (.loop|10|12|15 (- .i|16 1)))))) (.loop|10|12|15 3))))) (unspecified)) (let* ((.d0|31 (bytevector-ref .m|6 0)) (.d1|34 (bytevector-ref .m|6 1)) (.d2|37 (bytevector-ref .m|6 2)) (.d3|40 (bytevector-ref .m|6 3)) (.n|43 (remainder .n|6 8)) (.n-|46 (- 8 .n|43))) (let () (asm:bv (rshl .d0|31 .n|43) (logand (logior (rshl .d1|34 .n|43) (lsh .d0|31 .n-|46)) 255) (logand (logior (rshl .d2|37 .n|43) (lsh .d1|34 .n-|46)) 255) (logand (logior (rshl .d3|40 .n|43) (lsh .d2|37 .n-|46)) 255))))))))) (.asm:rshl|2 .m|1 .n|1))))) 'asm:rshl))
+(let () (begin (set! asm:rsha (let ((.ones|3 (asm:bv 255 255 255 255))) (lambda (.m|4 .n|4) (let* ((.m|7 (if (bytevector? .m|4) .m|4 (asm:int->bv .m|4))) (.n|10 (remainder .n|4 33)) (.h|13 (rshl (bytevector-ref .m|7 0) 7)) (.k|16 (asm:rshl .m|7 .n|10))) (let () (if (zero? .h|13) .k|16 (asm:logior .k|16 (asm:lsh .ones|3 (- 32 .n|10))))))))) 'asm:rsha))
+(let () (begin (set! asm:int->bv (let ((.two^32|3 (expt 2 32))) (lambda (.m|4) (let* ((.m|7 (if (< .m|4 0) (+ .two^32|3 .m|4) .m|4)) (.b0|10 (remainder .m|7 256)) (.m|13 (quotient .m|7 256)) (.b1|16 (remainder .m|13 256)) (.m|19 (quotient .m|13 256)) (.b2|22 (remainder .m|19 256)) (.m|25 (quotient .m|19 256)) (.b3|28 (remainder .m|25 256))) (let () (asm:bv .b3|28 .b2|22 .b1|16 .b0|10)))))) 'asm:int->bv))
+(let () (begin (set! asm:logior (lambda .ops|1 (let ((.r|4 (asm:bv 0 0 0 0))) (let () (let ((.loop|5|7|10 (unspecified))) (begin (set! .loop|5|7|10 (lambda (.ops|11) (if (null? .ops|11) .r|4 (begin (begin #t (let* ((.op|16 (let ((.x|23|26 .ops|11)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) (.op|19 (if (bytevector? .op|16) .op|16 (asm:int->bv .op|16)))) (let () (begin (bytevector-set! .r|4 0 (logior (bytevector-ref .r|4 0) (bytevector-ref .op|19 0))) (bytevector-set! .r|4 1 (logior (bytevector-ref .r|4 1) (bytevector-ref .op|19 1))) (bytevector-set! .r|4 2 (logior (bytevector-ref .r|4 2) (bytevector-ref .op|19 2))) (bytevector-set! .r|4 3 (logior (bytevector-ref .r|4 3) (bytevector-ref .op|19 3))))))) (.loop|5|7|10 (let ((.x|27|30 .ops|11)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))))))) (.loop|5|7|10 .ops|1))))))) 'asm:logior))
+(let () (begin (set! asm:logand (lambda (.op1|1 .op2|1) (let ((.asm:logand|2 0)) (begin (set! .asm:logand|2 (lambda (.op1|3 .op2|3) (let ((.op1|6 (if (bytevector? .op1|3) .op1|3 (asm:int->bv .op1|3))) (.op2|6 (if (bytevector? .op2|3) .op2|3 (asm:int->bv .op2|3))) (.bv|6 (make-bytevector 4))) (begin (bytevector-set! .bv|6 0 (logand (bytevector-ref .op1|6 0) (bytevector-ref .op2|6 0))) (bytevector-set! .bv|6 1 (logand (bytevector-ref .op1|6 1) (bytevector-ref .op2|6 1))) (bytevector-set! .bv|6 2 (logand (bytevector-ref .op1|6 2) (bytevector-ref .op2|6 2))) (bytevector-set! .bv|6 3 (logand (bytevector-ref .op1|6 3) (bytevector-ref .op2|6 3))) .bv|6)))) (.asm:logand|2 .op1|1 .op2|1))))) 'asm:logand))
+(let () (begin (set! asm:lobits (let ((.v|3 (make-vector 33 '()))) (begin (let () (let ((.loop|5|7|10 (unspecified))) (begin (set! .loop|5|7|10 (lambda (.i|11) (if (= .i|11 33) (if #f #f (unspecified)) (begin (begin #t (let ((.v|14|17 .v|3) (.i|14|17 .i|11) (.x|14|17 (asm:int->bv (- (expt 2 .i|11) 1)))) (begin (.check! (fixnum? .i|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (vector? .v|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (<:fix:fix .i|14|17 (vector-length:vec .v|14|17)) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (>=:fix:fix .i|14|17 0) 41 .v|14|17 .i|14|17 .x|14|17) (vector-set!:trusted .v|14|17 .i|14|17 .x|14|17)))) (.loop|5|7|10 (+ .i|11 1)))))) (.loop|5|7|10 0)))) (lambda (.m|18 .n|18) (asm:logand .m|18 (let ((.v|19|22 .v|3) (.i|19|22 (remainder .n|18 33))) (begin (.check! (fixnum? .i|19|22) 40 .v|19|22 .i|19|22) (.check! (vector? .v|19|22) 40 .v|19|22 .i|19|22) (.check! (<:fix:fix .i|19|22 (vector-length:vec .v|19|22)) 40 .v|19|22 .i|19|22) (.check! (>=:fix:fix .i|19|22 0) 40 .v|19|22 .i|19|22) (vector-ref:trusted .v|19|22 .i|19|22)))))))) 'asm:lobits))
+(let () (begin (set! asm:hibits (lambda (.m|1 .n|1) (let ((.asm:hibits|2 0)) (begin (set! .asm:hibits|2 (lambda (.m|3 .n|3) (asm:rshl .m|3 (- 32 (remainder .n|3 33))))) (.asm:hibits|2 .m|1 .n|1))))) 'asm:hibits))
+(let () (begin (set! asm:fits? (let ((.v|3 (make-vector 33 '()))) (begin (let () (let ((.loop|5|7|10 (unspecified))) (begin (set! .loop|5|7|10 (lambda (.i|11) (if (= .i|11 33) (if #f #f (unspecified)) (begin (begin #t (let ((.v|14|17 .v|3) (.i|14|17 .i|11) (.x|14|17 (expt 2 .i|11))) (begin (.check! (fixnum? .i|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (vector? .v|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (<:fix:fix .i|14|17 (vector-length:vec .v|14|17)) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (>=:fix:fix .i|14|17 0) 41 .v|14|17 .i|14|17 .x|14|17) (vector-set!:trusted .v|14|17 .i|14|17 .x|14|17)))) (.loop|5|7|10 (+ .i|11 1)))))) (.loop|5|7|10 0)))) (lambda (.m|18 .n|18) (let ((.t|19|22 .m|18)) (if (<= (- 0 (let ((.v|25|28 .v|3) (.i|25|28 (- .n|18 1))) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28)))) .t|19|22) (<= .t|19|22 (- (let ((.v|30|33 .v|3) (.i|30|33 (- .n|18 1))) (begin (.check! (fixnum? .i|30|33) 40 .v|30|33 .i|30|33) (.check! (vector? .v|30|33) 40 .v|30|33 .i|30|33) (.check! (<:fix:fix .i|30|33 (vector-length:vec .v|30|33)) 40 .v|30|33 .i|30|33) (.check! (>=:fix:fix .i|30|33 0) 40 .v|30|33 .i|30|33) (vector-ref:trusted .v|30|33 .i|30|33))) 1)) #f)))))) 'asm:fits?))
+(let () (begin (set! asm:fits-unsigned? (let ((.v|3 (make-vector 33 '()))) (begin (let () (let ((.loop|5|7|10 (unspecified))) (begin (set! .loop|5|7|10 (lambda (.i|11) (if (= .i|11 33) (if #f #f (unspecified)) (begin (begin #t (let ((.v|14|17 .v|3) (.i|14|17 .i|11) (.x|14|17 (expt 2 .i|11))) (begin (.check! (fixnum? .i|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (vector? .v|14|17) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (<:fix:fix .i|14|17 (vector-length:vec .v|14|17)) 41 .v|14|17 .i|14|17 .x|14|17) (.check! (>=:fix:fix .i|14|17 0) 41 .v|14|17 .i|14|17 .x|14|17) (vector-set!:trusted .v|14|17 .i|14|17 .x|14|17)))) (.loop|5|7|10 (+ .i|11 1)))))) (.loop|5|7|10 0)))) (lambda (.m|18 .n|18) (let ((.t|19|22 .m|18)) (if (<= 0 .t|19|22) (<= .t|19|22 (- (let ((.v|25|28 .v|3) (.i|25|28 .n|18)) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28))) 1)) #f)))))) 'asm:fits-unsigned?))
+(let () (begin (set! asm:add (lambda (.a|1 .b|1) (let ((.asm:add|2 0)) (begin (set! .asm:add|2 (lambda (.a|3 .b|3) (asm:int->bv (+ (if (bytevector? .a|3) (asm:bv->int .a|3) .a|3) (if (bytevector? .b|3) (asm:bv->int .b|3) .b|3))))) (.asm:add|2 .a|1 .b|1))))) 'asm:add))
+(let () (begin (set! asm:signed (lambda (.n|1) (let ((.asm:signed|2 0)) (begin (set! .asm:signed|2 (lambda (.n|3) (if (< .n|3 2147483647) .n|3 (- .n|3 4294967296)))) (.asm:signed|2 .n|1))))) 'asm:signed))
+(let () (begin (set! asm:print-bv (lambda (.bv|1) (let ((.asm:print-bv|2 0)) (begin (set! .asm:print-bv|2 (lambda (.bv|3) (let ((.pdig|4 (unspecified)) (.hex|4 (unspecified))) (begin (set! .pdig|4 (lambda (.k|5) (begin (display (string-ref .hex|4 (quotient .k|5 16))) (display (string-ref .hex|4 (remainder .k|5 16))) (display " ")))) (set! .hex|4 "0123456789abcdef") (if (eq? asm:endianness 'little) (let () (let ((.loop|7|9|12 (unspecified))) (begin (set! .loop|7|9|12 (lambda (.i|13) (if (< .i|13 0) (if #f #f (unspecified)) (begin (begin #t (.pdig|4 (bytevector-ref .bv|3 .i|13))) (.loop|7|9|12 (- .i|13 1)))))) (.loop|7|9|12 3)))) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! .loop|17|19|22 (lambda (.i|23) (if (= .i|23 4) (if #f #f (unspecified)) (begin (begin #t (.pdig|4 (bytevector-ref .bv|3 .i|23))) (.loop|17|19|22 (+ .i|23 1)))))) (.loop|17|19|22 0))))))))) (.asm:print-bv|2 .bv|1))))) 'asm:print-bv))
+(let () (begin (set! dump-fasl-segment-to-port (lambda (.segment|1 .outp|1 . .rest|1) (let* ((.omit-code?|4 (not (null? .rest|1))) (.controllify|7 (lambda (.char|154) (integer->char (- (char->integer .char|154) 64)))) (.ctrlp|10 (.controllify|7 #\P)) (.ctrlb|13 (.controllify|7 #\B)) (.ctrlg|16 (.controllify|7 #\G)) (.doublequote|19 34) (.backslash|22 92) (.len|25 1024)) (let () (let ((.dump-fasl-segment|29 (unspecified)) (.dump-constvec|29 (unspecified)) (.dump-codevec|29 (unspecified)) (.putd|29 (unspecified)) (.puts|29 (unspecified)) (.putb|29 (unspecified)) (.putc|29 (unspecified)) (.flush|29 (unspecified)) (.ptr|29 (unspecified)) (.buffer|29 (unspecified))) (begin (set! .dump-fasl-segment|29 (lambda (.segment|30) (begin (if (not .omit-code?|4) (.putc|29 #\() (unspecified)) (.putc|29 #\#) (.putc|29 .ctrlp|10) (.putc|29 #\() (.dump-codevec|29 (let ((.x|31|34 .segment|30)) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34)))) (.putc|29 #\space) (.dump-constvec|29 (let ((.x|35|38 .segment|30)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38)))) (.puts|29 " #f)") (if (not .omit-code?|4) (.putc|29 #\)) (unspecified)) (.putc|29 #\newline)))) (set! .dump-constvec|29 (lambda (.cv|39) (begin (.puts|29 "#(") (let ((.f|40|43|46 (lambda (.const|66) (begin (.putc|29 #\space) (let ((.temp|67|70 (let ((.x|113|116 .const|66)) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116))))) (if (memv .temp|67|70 '(data)) (.putd|29 (let ((.x|73|76 (let ((.x|77|80 .const|66)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))))) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76)))) (if (memv .temp|67|70 '(constantvector)) (.dump-constvec|29 (let ((.x|83|86 (let ((.x|87|90 .const|66)) (begin (.check! (pair? .x|87|90) 1 .x|87|90) (cdr:pair .x|87|90))))) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86)))) (if (memv .temp|67|70 '(codevector)) (.dump-codevec|29 (let ((.x|93|96 (let ((.x|97|100 .const|66)) (begin (.check! (pair? .x|97|100) 1 .x|97|100) (cdr:pair .x|97|100))))) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96)))) (if (memv .temp|67|70 '(global)) (begin (.putc|29 #\#) (.putc|29 .ctrlg|16) (.putd|29 (let ((.x|103|106 (let ((.x|107|110 .const|66)) (begin (.check! (pair? .x|107|110) 1 .x|107|110) (cdr:pair .x|107|110))))) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106))))) (if (memv .temp|67|70 '(bits)) (error "BITS attribute is not supported in fasl files.") (error "Faulty .lop file."))))))))))) (let () (let ((.loop|48|50|53 (unspecified))) (begin (set! .loop|48|50|53 (lambda (.y1|40|41|54) (if (null? .y1|40|41|54) (if #f #f (unspecified)) (begin (begin #t (.f|40|43|46 (let ((.x|58|61 .y1|40|41|54)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))))) (.loop|48|50|53 (let ((.x|62|65 .y1|40|41|54)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65)))))))) (.loop|48|50|53 (vector->list .cv|39)))))) (.puts|29 ")") (.putc|29 #\newline)))) (set! .dump-codevec|29 (lambda (.bv|117) (if .omit-code?|4 (.puts|29 "#f") (begin (.putc|29 #\#) (.putc|29 .ctrlb|13) (.putc|29 #\") (let ((.limit|120 (bytevector-length .bv|117))) (let () (let ((.loop|121|123|126 (unspecified))) (begin (set! .loop|121|123|126 (lambda (.i|127) (if (= .i|127 .limit|120) (begin (.putc|29 #\") (.putc|29 #\newline)) (begin (begin #t (let ((.c|132 (bytevector-ref .bv|117 .i|127))) (begin (if (= .c|132 .doublequote|19) (.putc|29 #\\) (if (= .c|132 .backslash|22) (.putc|29 #\\) (unspecified))) (.putb|29 .c|132)))) (.loop|121|123|126 (+ .i|127 1)))))) (.loop|121|123|126 0))))))))) (set! .putd|29 (lambda (.d|135) (begin (.flush|29) (write-fasl-datum .d|135 .outp|1)))) (set! .puts|29 (lambda (.s|136) (let ((.ls|139 (string-length .s|136))) (if (>= (+ .ptr|29 .ls|139) .len|25) (begin (.flush|29) (write-bytevector-like .s|136 .outp|1)) (let () (let ((.loop|140|143|146 (unspecified))) (begin (set! .loop|140|143|146 (lambda (.i|147 .p|147) (if (< .i|147 0) (set! .ptr|29 (+ .ptr|29 .ls|139)) (begin (begin #t (string-set! .buffer|29 .p|147 (string-ref .s|136 .i|147))) (.loop|140|143|146 (- .i|147 1) (- .p|147 1)))))) (.loop|140|143|146 (- .ls|139 1) (+ (+ .ptr|29 .ls|139) -1))))))))) (set! .putb|29 (lambda (.b|151) (begin (if (= .ptr|29 .len|25) (.flush|29) (unspecified)) (string-set! .buffer|29 .ptr|29 (integer->char .b|151)) (set! .ptr|29 (+ .ptr|29 1))))) (set! .putc|29 (lambda (.c|152) (begin (if (= .ptr|29 .len|25) (.flush|29) (unspecified)) (string-set! .buffer|29 .ptr|29 .c|152) (set! .ptr|29 (+ .ptr|29 1))))) (set! .flush|29 (lambda () (begin (if (< .ptr|29 .len|25) (write-bytevector-like (substring .buffer|29 0 .ptr|29) .outp|1) (write-bytevector-like .buffer|29 .outp|1)) (set! .ptr|29 0)))) (set! .ptr|29 0) (set! .buffer|29 (make-string .len|25 #\&)) (.dump-fasl-segment|29 .segment|1) (.flush|29))))))) 'dump-fasl-segment-to-port))
+(let () (begin (set! generate-global-symbols (make-twobit-flag 'generate-global-symbols)) 'generate-global-symbols))
+(let () (generate-global-symbols #t))
+(let () (begin (set! heap.version-number 9) 'heap.version-number))
+(let () (begin (set! heap.root-names '(result argreg2 argreg3 reg0 reg1 reg2 reg3 reg3 reg5 reg6 reg7 reg8 reg9 reg10 reg11 reg12 reg13 reg14 reg15 reg16 reg17 reg18 reg19 reg20 reg21 reg22 reg23 reg24 reg25 reg26 reg27 reg28 reg29 reg30 reg31 cont startup callouts schcall-arg4 alloci-tmp)) 'heap.root-names))
+(let () (begin (set! build-heap-image (lambda (.output-file|1 .input-files|1) (let ((.build-heap-image|2 0)) (begin (set! .build-heap-image|2 (lambda (.output-file|3 .input-files|3) (let ((.process-input-files|4 (unspecified)) (.tmp-file|4 (unspecified))) (begin (set! .process-input-files|4 (lambda (.heap|5) (let ((.files|8 .input-files|3) (.inits|8 '())) (let () (let ((.loop|11 (unspecified))) (begin (set! .loop|11 (lambda (.files|12 .inits|12) (if (null? .files|12) (heap.thunks! .heap|5 (apply append .inits|12)) (let ((.filename|17 (let ((.x|23|26 .files|12)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (begin (display "Loading ") (display .filename|17) (newline) (.loop|11 (let ((.x|18|21 .files|12)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))) (append .inits|12 (cons (dump-file! .heap|5 .filename|17) '())))))))) (.loop|11 .files|8 .inits|8))))))) (set! .tmp-file|4 "HEAPDATA.dat") (delete-file .tmp-file|4) (let ((.heap|29 (make-heap #f (open-output-file .tmp-file|4)))) (begin (before-all-files .heap|29 .output-file|3 .input-files|3) (.process-input-files|4 .heap|29) (heap.set-root! .heap|29 'startup (dump-startup-procedure! .heap|29)) (heap.set-root! .heap|29 'callouts (dump-global! .heap|29 'millicode-support)) (write-header .heap|29 .output-file|3) (after-all-files .heap|29 .output-file|3 .input-files|3) (close-output-port (heap.output-port .heap|29)) (append-file-shell-command .tmp-file|4 .output-file|3) (load-map .heap|29) (unspecified))))))) (.build-heap-image|2 .output-file|1 .input-files|1))))) 'build-heap-image))
+(let () (begin (set! before-all-files (lambda (.heap|1 .output-file-name|1 .input-file-names|1) (let ((.before-all-files|2 0)) (begin (set! .before-all-files|2 (lambda (.heap|3 .output-file-name|3 .input-file-names|3) #t)) (.before-all-files|2 .heap|1 .output-file-name|1 .input-file-names|1))))) 'before-all-files))
+(let () (begin (set! after-all-files (lambda (.heap|1 .output-file-name|1 .input-file-names|1) (let ((.after-all-files|2 0)) (begin (set! .after-all-files|2 (lambda (.heap|3 .output-file-name|3 .input-file-names|3) #t)) (.after-all-files|2 .heap|1 .output-file-name|1 .input-file-names|1))))) 'after-all-files))
+(let () (begin (set! make-heap (lambda (.extra|1 .output-port|1) (let ((.make-heap|2 0)) (begin (set! .make-heap|2 (lambda (.extra|3 .output-port|3) (let* ((.t|4|11|16 '()) (.t|4|10|19 .output-port|3) (.t|4|9|22 .extra|3) (.t|4|8|25 (make-heap-symbol-table)) (.t|4|7|28 0) (.t|4|6|31 '()) (.t|4|5|34 heap.version-number) (.v|4|13|37 (make-vector 7 .t|4|11|16))) (let () (begin (let ((.v|41|44 .v|4|13|37) (.i|41|44 5) (.x|41|44 .t|4|10|19)) (begin (.check! (fixnum? .i|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (vector? .v|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (<:fix:fix .i|41|44 (vector-length:vec .v|41|44)) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (>=:fix:fix .i|41|44 0) 41 .v|41|44 .i|41|44 .x|41|44) (vector-set!:trusted .v|41|44 .i|41|44 .x|41|44))) (let ((.v|45|48 .v|4|13|37) (.i|45|48 4) (.x|45|48 .t|4|9|22)) (begin (.check! (fixnum? .i|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (vector? .v|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (<:fix:fix .i|45|48 (vector-length:vec .v|45|48)) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (>=:fix:fix .i|45|48 0) 41 .v|45|48 .i|45|48 .x|45|48) (vector-set!:trusted .v|45|48 .i|45|48 .x|45|48))) (let ((.v|49|52 .v|4|13|37) (.i|49|52 3) (.x|49|52 .t|4|8|25)) (begin (.check! (fixnum? .i|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (vector? .v|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (<:fix:fix .i|49|52 (vector-length:vec .v|49|52)) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (>=:fix:fix .i|49|52 0) 41 .v|49|52 .i|49|52 .x|49|52) (vector-set!:trusted .v|49|52 .i|49|52 .x|49|52))) (let ((.v|53|56 .v|4|13|37) (.i|53|56 2) (.x|53|56 .t|4|7|28)) (begin (.check! (fixnum? .i|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (vector? .v|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (<:fix:fix .i|53|56 (vector-length:vec .v|53|56)) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (>=:fix:fix .i|53|56 0) 41 .v|53|56 .i|53|56 .x|53|56) (vector-set!:trusted .v|53|56 .i|53|56 .x|53|56))) (let ((.v|57|60 .v|4|13|37) (.i|57|60 1) (.x|57|60 .t|4|6|31)) (begin (.check! (fixnum? .i|57|60) 41 .v|57|60 .i|57|60 .x|57|60) (.check! (vector? .v|57|60) 41 .v|57|60 .i|57|60 .x|57|60) (.check! (<:fix:fix .i|57|60 (vector-length:vec .v|57|60)) 41 .v|57|60 .i|57|60 .x|57|60) (.check! (>=:fix:fix .i|57|60 0) 41 .v|57|60 .i|57|60 .x|57|60) (vector-set!:trusted .v|57|60 .i|57|60 .x|57|60))) (let ((.v|61|64 .v|4|13|37) (.i|61|64 0) (.x|61|64 .t|4|5|34)) (begin (.check! (fixnum? .i|61|64) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (vector? .v|61|64) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (<:fix:fix .i|61|64 (vector-length:vec .v|61|64)) 41 .v|61|64 .i|61|64 .x|61|64) (.check! (>=:fix:fix .i|61|64 0) 41 .v|61|64 .i|61|64 .x|61|64) (vector-set!:trusted .v|61|64 .i|61|64 .x|61|64))) .v|4|13|37))))) (.make-heap|2 .extra|1 .output-port|1))))) 'make-heap))
+(let () (begin (set! heap.version (lambda (.h|1) (let ((.heap.version|2 0)) (begin (set! .heap.version|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.version|2 .h|1))))) 'heap.version))
+(let () (begin (set! heap.roots (lambda (.h|1) (let ((.heap.roots|2 0)) (begin (set! .heap.roots|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.roots|2 .h|1))))) 'heap.roots))
+(let () (begin (set! heap.top (lambda (.h|1) (let ((.heap.top|2 0)) (begin (set! .heap.top|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.top|2 .h|1))))) 'heap.top))
+(let () (begin (set! heap.symbol-table (lambda (.h|1) (let ((.heap.symbol-table|2 0)) (begin (set! .heap.symbol-table|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.symbol-table|2 .h|1))))) 'heap.symbol-table))
+(let () (begin (set! heap.extra (lambda (.h|1) (let ((.heap.extra|2 0)) (begin (set! .heap.extra|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 4)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.extra|2 .h|1))))) 'heap.extra))
+(let () (begin (set! heap.output-port (lambda (.h|1) (let ((.heap.output-port|2 0)) (begin (set! .heap.output-port|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 5)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.output-port|2 .h|1))))) 'heap.output-port))
+(let () (begin (set! heap.thunks (lambda (.h|1) (let ((.heap.thunks|2 0)) (begin (set! .heap.thunks|2 (lambda (.h|3) (let ((.v|4|7 .h|3) (.i|4|7 6)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.heap.thunks|2 .h|1))))) 'heap.thunks))
+(let () (begin (set! heap.roots! (lambda (.h|1 .x|1) (let ((.heap.roots!|2 0)) (begin (set! .heap.roots!|2 (lambda (.h|3 .x|3) (let ((.v|4|7 .h|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.heap.roots!|2 .h|1 .x|1))))) 'heap.roots!))
+(let () (begin (set! heap.top! (lambda (.h|1 .x|1) (let ((.heap.top!|2 0)) (begin (set! .heap.top!|2 (lambda (.h|3 .x|3) (let ((.v|4|7 .h|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.heap.top!|2 .h|1 .x|1))))) 'heap.top!))
+(let () (begin (set! heap.thunks! (lambda (.h|1 .x|1) (let ((.heap.thunks!|2 0)) (begin (set! .heap.thunks!|2 (lambda (.h|3 .x|3) (let ((.v|4|7 .h|3) (.i|4|7 6) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.heap.thunks!|2 .h|1 .x|1))))) 'heap.thunks!))
+(let () (begin (set! make-heap-symbol-table (lambda () (let ((.make-heap-symbol-table|2 0)) (begin (set! .make-heap-symbol-table|2 (lambda () (let* ((.t|4|6|11 0) (.t|4|5|14 '()) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))))) (.make-heap-symbol-table|2))))) 'make-heap-symbol-table))
+(let () (begin (set! symtab.symbols (lambda (.st|1) (let ((.symtab.symbols|2 0)) (begin (set! .symtab.symbols|2 (lambda (.st|3) (let ((.v|4|7 .st|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symtab.symbols|2 .st|1))))) 'symtab.symbols))
+(let () (begin (set! symtab.cell-no (lambda (.st|1) (let ((.symtab.cell-no|2 0)) (begin (set! .symtab.cell-no|2 (lambda (.st|3) (let ((.v|4|7 .st|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symtab.cell-no|2 .st|1))))) 'symtab.cell-no))
+(let () (begin (set! symtab.symbols! (lambda (.st|1 .x|1) (let ((.symtab.symbols!|2 0)) (begin (set! .symtab.symbols!|2 (lambda (.st|3 .x|3) (let ((.v|4|7 .st|3) (.i|4|7 0) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.symtab.symbols!|2 .st|1 .x|1))))) 'symtab.symbols!))
+(let () (begin (set! symtab.cell-no! (lambda (.st|1 .x|1) (let ((.symtab.cell-no!|2 0)) (begin (set! .symtab.cell-no!|2 (lambda (.st|3 .x|3) (let ((.v|4|7 .st|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.symtab.cell-no!|2 .st|1 .x|1))))) 'symtab.cell-no!))
+(let () (begin (set! make-symcell (lambda (.name|1) (let ((.make-symcell|2 0)) (begin (set! .make-symcell|2 (lambda (.name|3) (let* ((.t|4|8|13 '()) (.t|4|7|16 '()) (.t|4|6|19 '()) (.t|4|5|22 .name|3) (.v|4|10|25 (make-vector 4 .t|4|8|13))) (let () (begin (let ((.v|29|32 .v|4|10|25) (.i|29|32 2) (.x|29|32 .t|4|7|16)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) (let ((.v|33|36 .v|4|10|25) (.i|33|36 1) (.x|33|36 .t|4|6|19)) (begin (.check! (fixnum? .i|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (vector? .v|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (<:fix:fix .i|33|36 (vector-length:vec .v|33|36)) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (>=:fix:fix .i|33|36 0) 41 .v|33|36 .i|33|36 .x|33|36) (vector-set!:trusted .v|33|36 .i|33|36 .x|33|36))) (let ((.v|37|40 .v|4|10|25) (.i|37|40 0) (.x|37|40 .t|4|5|22)) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) .v|4|10|25))))) (.make-symcell|2 .name|1))))) 'make-symcell))
+(let () (begin (set! symcell.name (lambda (.sc|1) (let ((.symcell.name|2 0)) (begin (set! .symcell.name|2 (lambda (.sc|3) (let ((.v|4|7 .sc|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symcell.name|2 .sc|1))))) 'symcell.name))
+(let () (begin (set! symcell.symloc (lambda (.sc|1) (let ((.symcell.symloc|2 0)) (begin (set! .symcell.symloc|2 (lambda (.sc|3) (let ((.v|4|7 .sc|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symcell.symloc|2 .sc|1))))) 'symcell.symloc))
+(let () (begin (set! symcell.valloc (lambda (.sc|1) (let ((.symcell.valloc|2 0)) (begin (set! .symcell.valloc|2 (lambda (.sc|3) (let ((.v|4|7 .sc|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symcell.valloc|2 .sc|1))))) 'symcell.valloc))
+(let () (begin (set! symcell.valno (lambda (.sc|1) (let ((.symcell.valno|2 0)) (begin (set! .symcell.valno|2 (lambda (.sc|3) (let ((.v|4|7 .sc|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.symcell.valno|2 .sc|1))))) 'symcell.valno))
+(let () (begin (set! symcell.symloc! (lambda (.sc|1 .x|1) (let ((.symcell.symloc!|2 0)) (begin (set! .symcell.symloc!|2 (lambda (.sc|3 .x|3) (let ((.v|4|7 .sc|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.symcell.symloc!|2 .sc|1 .x|1))))) 'symcell.symloc!))
+(let () (begin (set! symcell.valloc! (lambda (.sc|1 .x|1) (let ((.symcell.valloc!|2 0)) (begin (set! .symcell.valloc!|2 (lambda (.sc|3 .x|3) (let ((.v|4|7 .sc|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.symcell.valloc!|2 .sc|1 .x|1))))) 'symcell.valloc!))
+(let () (begin (set! symcell.valno! (lambda (.sc|1 .x|1) (let ((.symcell.valno!|2 0)) (begin (set! .symcell.valno!|2 (lambda (.sc|3 .x|3) (let ((.v|4|7 .sc|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.symcell.valno!|2 .sc|1 .x|1))))) 'symcell.valno!))
+(let () (begin (set! symbol-cell (lambda (.h|1 .name|1) (let ((.symbol-cell|2 0)) (begin (set! .symbol-cell|2 (lambda (.h|3 .name|3) (let* ((.symtab|6 (heap.symbol-table .h|3)) (.symbols|9 (symtab.symbols .symtab|6))) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.symbols|13) (if (null? .symbols|13) (let ((.new-sym|17 (make-symcell .name|3))) (begin (symtab.symbols! .symtab|6 (cons .new-sym|17 (symtab.symbols .symtab|6))) .new-sym|17)) (if (eq? .name|3 (symcell.name (let ((.x|19|22 .symbols|13)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))))) (let ((.x|23|26 .symbols|13)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) (.loop|12 (let ((.x|28|31 .symbols|13)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31)))))))) (.loop|12 .symbols|9))))))) (.symbol-cell|2 .h|1 .name|1))))) 'symbol-cell))
+(let () (begin (set! twofiftysix^3 16777216) 'twofiftysix^3))
+(let () (begin (set! twofiftysix^2 65536) 'twofiftysix^2))
+(let () (begin (set! twofiftysix 256) 'twofiftysix))
+(let () (begin (set! heap.word-be! (lambda (.h|1 .w|1) (let ((.heap.word-be!|2 0)) (begin (set! .heap.word-be!|2 (lambda (.h|3 .w|3) (begin (heap.byte! .h|3 (quotient .w|3 twofiftysix^3)) (heap.byte! .h|3 (quotient (remainder .w|3 twofiftysix^3) twofiftysix^2)) (heap.byte! .h|3 (quotient (remainder .w|3 twofiftysix^2) twofiftysix)) (heap.byte! .h|3 (remainder .w|3 twofiftysix))))) (.heap.word-be!|2 .h|1 .w|1))))) 'heap.word-be!))
+(let () (begin (set! heap.word-el! (lambda (.h|1 .w|1) (let ((.heap.word-el!|2 0)) (begin (set! .heap.word-el!|2 (lambda (.h|3 .w|3) (begin (heap.byte! .h|3 (remainder .w|3 twofiftysix)) (heap.byte! .h|3 (quotient (remainder .w|3 twofiftysix^2) twofiftysix)) (heap.byte! .h|3 (quotient (remainder .w|3 twofiftysix^3) twofiftysix^2)) (heap.byte! .h|3 (quotient .w|3 twofiftysix^3))))) (.heap.word-el!|2 .h|1 .w|1))))) 'heap.word-el!))
+(let () (begin (set! heap.word! heap.word-be!) 'heap.word!))
+(let () (begin (set! dumpheap.set-endianness! (lambda (.which|1) (let ((.dumpheap.set-endianness!|2 0)) (begin (set! .dumpheap.set-endianness!|2 (lambda (.which|3) (let ((.temp|4|7 .which|3)) (if (memv .temp|4|7 '(big)) (set! heap.word! heap.word-be!) (if (memv .temp|4|7 '(little)) (set! heap.word! heap.word-el!) ???))))) (.dumpheap.set-endianness!|2 .which|1))))) 'dumpheap.set-endianness!))
+(let () (begin (set! heap.byte! (lambda (.h|1 .b|1) (let ((.heap.byte!|2 0)) (begin (set! .heap.byte!|2 (lambda (.h|3 .b|3) (begin (write-char (integer->char .b|3) (heap.output-port .h|3)) (heap.top! .h|3 (+ 1 (heap.top .h|3)))))) (.heap.byte!|2 .h|1 .b|1))))) 'heap.byte!))
+(let () (begin (set! heap.header-word! (lambda (.h|1 .immediate|1 .length|1) (let ((.heap.header-word!|2 0)) (begin (set! .heap.header-word!|2 (lambda (.h|3 .immediate|3 .length|3) (heap.word! .h|3 (+ (* .length|3 256) .immediate|3)))) (.heap.header-word!|2 .h|1 .immediate|1 .length|1))))) 'heap.header-word!))
+(let () (begin (set! heap.adjust! (lambda (.h|1) (let ((.heap.adjust!|2 0)) (begin (set! .heap.adjust!|2 (lambda (.h|3) (let* ((.p|6 (heap.top .h|3)) (.i|9 (- (* 8 (quotient (+ .p|6 7) 8)) .p|6))) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.i|13) (if (zero? .i|13) '() (begin (heap.byte! .h|3 0) (.loop|12 (- .i|13 1)))))) (.loop|12 .i|9))))))) (.heap.adjust!|2 .h|1))))) 'heap.adjust!))
+(let () (begin (set! heap.largest-fixnum (- (expt 2 29) 1)) 'heap.largest-fixnum))
+(let () (begin (set! heap.smallest-fixnum (- 0 (expt 2 29))) 'heap.smallest-fixnum))
+(let () (begin (set! heap.set-root! (lambda (.h|1 .name|1 .value|1) (let ((.heap.set-root!|2 0)) (begin (set! .heap.set-root!|2 (lambda (.h|3 .name|3 .value|3) (heap.roots! .h|3 (cons (cons .name|3 .value|3) (heap.roots .h|3))))) (.heap.set-root!|2 .h|1 .name|1 .value|1))))) 'heap.set-root!))
+(let () (begin (set! segment.code car) 'segment.code))
+(let () (begin (set! segment.constants cdr) 'segment.constants))
+(let () (begin (set! dump-file! (lambda (.h|1 .filename|1) (let ((.dump-file!|2 0)) (begin (set! .dump-file!|2 (lambda (.h|3 .filename|3) (begin (before-dump-file .h|3 .filename|3) (call-with-input-file .filename|3 (lambda (.in|4) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment|12 .thunks|12) (if (eof-object? .segment|12) (begin (after-dump-file .h|3 .filename|3) (reverse .thunks|12)) (begin #t (.loop|5|8|11 (read .in|4) (cons (dump-segment! .h|3 .segment|12) .thunks|12)))))) (.loop|5|8|11 (read .in|4) '()))))))))) (.dump-file!|2 .h|1 .filename|1))))) 'dump-file!))
+(let () (begin (set! before-dump-file (lambda (.h|1 .filename|1) (let ((.before-dump-file|2 0)) (begin (set! .before-dump-file|2 (lambda (.h|3 .filename|3) #t)) (.before-dump-file|2 .h|1 .filename|1))))) 'before-dump-file))
+(let () (begin (set! after-dump-file (lambda (.h|1 .filename|1) (let ((.after-dump-file|2 0)) (begin (set! .after-dump-file|2 (lambda (.h|3 .filename|3) #t)) (.after-dump-file|2 .h|1 .filename|1))))) 'after-dump-file))
+(let () (begin (set! dump-segment! (lambda (.h|1 .segment|1) (let ((.dump-segment!|2 0)) (begin (set! .dump-segment!|2 (lambda (.h|3 .segment|3) (let* ((.the-code|6 (dump-codevector! .h|3 (segment.code .segment|3))) (.the-consts|9 (dump-constantvector! .h|3 (segment.constants .segment|3)))) (let () (dump-thunk! .h|3 .the-code|6 .the-consts|9))))) (.dump-segment!|2 .h|1 .segment|1))))) 'dump-segment!))
+(let () (begin (set! dump-tagged-item! (lambda (.h|1 .item|1) (let ((.dump-tagged-item!|2 0)) (begin (set! .dump-tagged-item!|2 (lambda (.h|3 .item|3) (let ((.temp|4|7 (let ((.x|59|62 .item|3)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))))) (if (memv .temp|4|7 '(codevector)) (dump-codevector! .h|3 (let ((.x|10|13 (let ((.x|14|17 .item|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) (if (memv .temp|4|7 '(constantvector)) (dump-constantvector! .h|3 (let ((.x|20|23 (let ((.x|24|27 .item|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (if (memv .temp|4|7 '(data)) (dump-datum! .h|3 (let ((.x|30|33 (let ((.x|34|37 .item|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (if (memv .temp|4|7 '(global)) (dump-global! .h|3 (let ((.x|40|43 (let ((.x|44|47 .item|3)) (begin (.check! (pair? .x|44|47) 1 .x|44|47) (cdr:pair .x|44|47))))) (begin (.check! (pair? .x|40|43) 0 .x|40|43) (car:pair .x|40|43)))) (if (memv .temp|4|7 '(bits)) (let ((.x|50|53 (let ((.x|54|57 .item|3)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))) (error 'dump-tagged-item! "Unknown item ~a" .item|3))))))))) (.dump-tagged-item!|2 .h|1 .item|1))))) 'dump-tagged-item!))
+(let () (begin (set! dump-datum! (lambda (.h|1 .datum|1) (let ((.dump-datum!|2 0)) (begin (set! .dump-datum!|2 (lambda (.h|3 .datum|3) (let ((.rectnum?|5 (unspecified)) (.compnum?|5 (unspecified)) (.flonum?|5 (unspecified)) (.ratnum?|5 (unspecified)) (.bignum?|5 (unspecified)) (.fixnum?|5 (unspecified))) (begin (set! .rectnum?|5 (lambda (.x|6) (if (complex? .x|6) (if (exact? .x|6) (not (real? .x|6)) #f) #f))) (set! .compnum?|5 (lambda (.x|10) (if (complex? .x|10) (if (inexact? .x|10) (not (real? .x|10)) #f) #f))) (set! .flonum?|5 (lambda (.x|14) (if (real? .x|14) (inexact? .x|14) #f))) (set! .ratnum?|5 (lambda (.x|17) (if (rational? .x|17) (if (exact? .x|17) (not (integer? .x|17)) #f) #f))) (set! .bignum?|5 (lambda (.x|21) (if (integer? .x|21) (if (exact? .x|21) (let ((.temp|25|28 (> .x|21 heap.largest-fixnum))) (if .temp|25|28 .temp|25|28 (< .x|21 heap.smallest-fixnum))) #f) #f))) (set! .fixnum?|5 (lambda (.x|30) (if (integer? .x|30) (if (exact? .x|30) (let ((.t|34|37 .x|30)) (if (<= heap.smallest-fixnum .t|34|37) (<= .t|34|37 heap.largest-fixnum) #f)) #f) #f))) (if (.fixnum?|5 .datum|3) (dump-fixnum! .h|3 .datum|3) (if (.bignum?|5 .datum|3) (dump-bignum! .h|3 .datum|3) (if (.ratnum?|5 .datum|3) (dump-ratnum! .h|3 .datum|3) (if (.flonum?|5 .datum|3) (dump-flonum! .h|3 .datum|3) (if (.compnum?|5 .datum|3) (dump-compnum! .h|3 .datum|3) (if (.rectnum?|5 .datum|3) (dump-rectnum! .h|3 .datum|3) (if (char? .datum|3) (dump-char! .h|3 .datum|3) (if (null? .datum|3) $imm.null (if (eq? .datum|3 #t) $imm.true (if (eq? .datum|3 #f) $imm.false (if (equal? .datum|3 (unspecified)) $imm.unspecified (if (equal? .datum|3 (undefined)) $imm.undefined (if (vector? .datum|3) (dump-vector! .h|3 .datum|3 $tag.vector-typetag) (if (bytevector? .datum|3) (dump-bytevector! .h|3 .datum|3 $tag.bytevector-typetag) (if (pair? .datum|3) (dump-pair! .h|3 .datum|3) (if (string? .datum|3) (dump-string! .h|3 .datum|3) (if (symbol? .datum|3) (dump-symbol! .h|3 .datum|3) (error 'dump-datum! "Unsupported type of datum ~a" .datum|3)))))))))))))))))))))) (.dump-datum!|2 .h|1 .datum|1))))) 'dump-datum!))
+(let () (begin (set! dump-fixnum! (lambda (.h|1 .f|1) (let ((.dump-fixnum!|2 0)) (begin (set! .dump-fixnum!|2 (lambda (.h|3 .f|3) (if (< .f|3 0) (- 4294967296 (* (let ((.temp|5|8 .f|3)) (if (< .temp|5|8 0) (-- .temp|5|8) .temp|5|8)) 4)) (* 4 .f|3)))) (.dump-fixnum!|2 .h|1 .f|1))))) 'dump-fixnum!))
+(let () (begin (set! dump-char! (lambda (.h|1 .c|1) (let ((.dump-char!|2 0)) (begin (set! .dump-char!|2 (lambda (.h|3 .c|3) (+ (* (char->integer .c|3) twofiftysix^2) $imm.character))) (.dump-char!|2 .h|1 .c|1))))) 'dump-char!))
+(let () (begin (set! dump-bignum! (lambda (.h|1 .b|1) (let ((.dump-bignum!|2 0)) (begin (set! .dump-bignum!|2 (lambda (.h|3 .b|3) (dump-bytevector! .h|3 (bignum->bytevector .b|3) $tag.bignum-typetag))) (.dump-bignum!|2 .h|1 .b|1))))) 'dump-bignum!))
+(let () (begin (set! dump-ratnum! (lambda (.h|1 .r|1) (let ((.dump-ratnum!|2 0)) (begin (set! .dump-ratnum!|2 (lambda (.h|3 .r|3) (dump-vector! .h|3 (let* ((.t|4|6|11 (denominator .r|3)) (.t|4|5|14 (numerator .r|3)) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))) $tag.ratnum-typetag))) (.dump-ratnum!|2 .h|1 .r|1))))) 'dump-ratnum!))
+(let () (begin (set! dump-flonum! (lambda (.h|1 .f|1) (let ((.dump-flonum!|2 0)) (begin (set! .dump-flonum!|2 (lambda (.h|3 .f|3) (dump-bytevector! .h|3 (flonum->bytevector .f|3) $tag.flonum-typetag))) (.dump-flonum!|2 .h|1 .f|1))))) 'dump-flonum!))
+(let () (begin (set! dump-compnum! (lambda (.h|1 .c|1) (let ((.dump-compnum!|2 0)) (begin (set! .dump-compnum!|2 (lambda (.h|3 .c|3) (dump-bytevector! .h|3 (compnum->bytevector .c|3) $tag.compnum-typetag))) (.dump-compnum!|2 .h|1 .c|1))))) 'dump-compnum!))
+(let () (begin (set! dump-rectnum! (lambda (.h|1 .r|1) (let ((.dump-rectnum!|2 0)) (begin (set! .dump-rectnum!|2 (lambda (.h|3 .r|3) (dump-vector! .h|3 (let* ((.t|4|6|11 (imag-part .r|3)) (.t|4|5|14 (real-part .r|3)) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))) $tag.rectnum-typetag))) (.dump-rectnum!|2 .h|1 .r|1))))) 'dump-rectnum!))
+(let () (begin (set! dump-string! (lambda (.h|1 .s|1) (let ((.dump-string!|2 0)) (begin (set! .dump-string!|2 (lambda (.h|3 .s|3) (dump-bytevector! .h|3 (string->bytevector .s|3) $tag.string-typetag))) (.dump-string!|2 .h|1 .s|1))))) 'dump-string!))
+(let () (begin (set! dump-pair! (lambda (.h|1 .p|1) (let ((.dump-pair!|2 0)) (begin (set! .dump-pair!|2 (lambda (.h|3 .p|3) (let ((.the-car|6 (dump-datum! .h|3 (let ((.x|10|13 .p|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))))) (.the-cdr|6 (dump-datum! .h|3 (let ((.x|14|17 .p|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))))) (let ((.base|9 (heap.top .h|3))) (begin (heap.word! .h|3 .the-car|6) (heap.word! .h|3 .the-cdr|6) (+ .base|9 $tag.pair-tag)))))) (.dump-pair!|2 .h|1 .p|1))))) 'dump-pair!))
+(let () (begin (set! dump-bytevector! (lambda (.h|1 .bv|1 .variation|1) (let ((.dump-bytevector!|2 0)) (begin (set! .dump-bytevector!|2 (lambda (.h|3 .bv|3 .variation|3) (let ((.base|6 (heap.top .h|3)) (.l|6 (bytevector-length .bv|3))) (begin (heap.header-word! .h|3 (+ $imm.bytevector-header .variation|3) .l|6) (let ((.i|9 0)) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.i|13) (if (< .i|13 .l|6) (begin (heap.byte! .h|3 (bytevector-ref .bv|3 .i|13)) (.loop|12 (+ .i|13 1))) (begin (heap.adjust! .h|3) (+ .base|6 $tag.bytevector-tag))))) (.loop|12 .i|9))))))))) (.dump-bytevector!|2 .h|1 .bv|1 .variation|1))))) 'dump-bytevector!))
+(let () (begin (set! dump-vector! (lambda (.h|1 .v|1 .variation|1) (let ((.dump-vector!|2 0)) (begin (set! .dump-vector!|2 (lambda (.h|3 .v|3 .variation|3) (dump-vector-like! .h|3 .v|3 dump-datum! .variation|3))) (.dump-vector!|2 .h|1 .v|1 .variation|1))))) 'dump-vector!))
+(let () (begin (set! dump-vector-like! (lambda (.h|1 .cv|1 .recur!|1 .variation|1) (let ((.dump-vector-like!|2 0)) (begin (set! .dump-vector-like!|2 (lambda (.h|3 .cv|3 .recur!|3 .variation|3) (let* ((.l|6 (let ((.v|42|45 .cv|3)) (begin (.check! (vector? .v|42|45) 42 .v|42|45) (vector-length:vec .v|42|45)))) (.v|9 (make-vector .l|6 '()))) (let () (let ((.i|15 0)) (let () (let ((.loop|18 (unspecified))) (begin (set! .loop|18 (lambda (.i|19) (if (< .i|19 .l|6) (begin (let ((.v|20|23 .v|9) (.i|20|23 .i|19) (.x|20|23 (.recur!|3 .h|3 (let ((.v|24|27 .cv|3) (.i|24|27 .i|19)) (begin (.check! (fixnum? .i|24|27) 40 .v|24|27 .i|24|27) (.check! (vector? .v|24|27) 40 .v|24|27 .i|24|27) (.check! (<:fix:fix .i|24|27 (vector-length:vec .v|24|27)) 40 .v|24|27 .i|24|27) (.check! (>=:fix:fix .i|24|27 0) 40 .v|24|27 .i|24|27) (vector-ref:trusted .v|24|27 .i|24|27)))))) (begin (.check! (fixnum? .i|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (vector? .v|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (>=:fix:fix .i|20|23 0) 41 .v|20|23 .i|20|23 .x|20|23) (vector-set!:trusted .v|20|23 .i|20|23 .x|20|23))) (.loop|18 (+ .i|19 1))) (let ((.base|30 (heap.top .h|3))) (begin (heap.header-word! .h|3 (+ $imm.vector-header .variation|3) (* .l|6 4)) (let ((.i|33 0)) (let () (let ((.loop|36 (unspecified))) (begin (set! .loop|36 (lambda (.i|37) (if (< .i|37 .l|6) (begin (heap.word! .h|3 (let ((.v|38|41 .v|9) (.i|38|41 .i|37)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41)))) (.loop|36 (+ .i|37 1))) (begin (heap.adjust! .h|3) (+ .base|30 $tag.vector-tag))))) (.loop|36 .i|33)))))))))) (.loop|18 .i|15))))))))) (.dump-vector-like!|2 .h|1 .cv|1 .recur!|1 .variation|1))))) 'dump-vector-like!))
+(let () (begin (set! dump-codevector! (lambda (.h|1 .cv|1) (let ((.dump-codevector!|2 0)) (begin (set! .dump-codevector!|2 (lambda (.h|3 .cv|3) (dump-bytevector! .h|3 .cv|3 $tag.bytevector-typetag))) (.dump-codevector!|2 .h|1 .cv|1))))) 'dump-codevector!))
+(let () (begin (set! dump-constantvector! (lambda (.h|1 .cv|1) (let ((.dump-constantvector!|2 0)) (begin (set! .dump-constantvector!|2 (lambda (.h|3 .cv|3) (dump-vector-like! .h|3 .cv|3 dump-tagged-item! $tag.vector-typetag))) (.dump-constantvector!|2 .h|1 .cv|1))))) 'dump-constantvector!))
+(let () (begin (set! dump-symbol! (lambda (.h|1 .s|1) (let ((.dump-symbol!|2 0)) (begin (set! .dump-symbol!|2 (lambda (.h|3 .s|3) (let ((.x|6 (symbol-cell .h|3 .s|3))) (begin (if (null? (symcell.symloc .x|6)) (symcell.symloc! .x|6 (create-symbol! .h|3 .s|3)) (unspecified)) (symcell.symloc .x|6))))) (.dump-symbol!|2 .h|1 .s|1))))) 'dump-symbol!))
+(let () (begin (set! dump-global! (lambda (.h|1 .g|1) (let ((.dump-global!|2 0)) (begin (set! .dump-global!|2 (lambda (.h|3 .g|3) (let ((.x|6 (symbol-cell .h|3 .g|3))) (begin (if (null? (symcell.valloc .x|6)) (let ((.cell|9 (create-cell! .h|3 .g|3))) (begin (symcell.valloc! .x|6 (let ((.x|10|13 .cell|9)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) (symcell.valno! .x|6 (let ((.x|14|17 .cell|9)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))))) (unspecified)) (symcell.valloc .x|6))))) (.dump-global!|2 .h|1 .g|1))))) 'dump-global!))
+(let () (begin (set! dump-thunk! (lambda (.h|1 .code|1 .constants|1) (let ((.dump-thunk!|2 0)) (begin (set! .dump-thunk!|2 (lambda (.h|3 .code|3 .constants|3) (let ((.base|6 (heap.top .h|3))) (begin (heap.header-word! .h|3 $imm.procedure-header 8) (heap.word! .h|3 .code|3) (heap.word! .h|3 .constants|3) (heap.adjust! .h|3) (+ .base|6 $tag.procedure-tag))))) (.dump-thunk!|2 .h|1 .code|1 .constants|1))))) 'dump-thunk!))
+(let () (begin (set! dump-list-spine! (lambda (.h|1 .l|1) (let ((.dump-list-spine!|2 0)) (begin (set! .dump-list-spine!|2 (lambda (.h|3 .l|3) (if (null? .l|3) $imm.null (let ((.the-car|6 (let ((.x|10|13 .l|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) (.the-cdr|6 (.dump-list-spine!|2 .h|3 (let ((.x|14|17 .l|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))))) (let ((.base|9 (heap.top .h|3))) (begin (heap.word! .h|3 .the-car|6) (heap.word! .h|3 .the-cdr|6) (+ .base|9 $tag.pair-tag))))))) (.dump-list-spine!|2 .h|1 .l|1))))) 'dump-list-spine!))
+(let () (begin (set! dump-startup-procedure! (lambda (.h|1) (let ((.dump-startup-procedure!|2 0)) (begin (set! .dump-startup-procedure!|2 (lambda (.h|3) (let ((.thunks|6 (dump-list-spine! .h|3 (heap.thunks .h|3))) (.symbols|6 (dump-list-spine! .h|3 (symbol-locations .h|3)))) (dump-segment! .h|3 (construct-startup-procedure .symbols|6 .thunks|6))))) (.dump-startup-procedure!|2 .h|1))))) 'dump-startup-procedure!))
+(let () (begin (set! init-proc (.cons (.cons $.proc '()) (.cons (.cons $args= '(1)) (.cons (.cons $reg '(1)) (.cons (.cons $setreg '(2)) (.cons (.cons $const '((thunks))) (.cons (.cons $setreg '(1)) (.cons (.cons $.label '(0)) (.cons (.cons $reg '(1)) (.cons (.cons $op1 '(null?)) (.cons (.cons $branchf '(2)) (.cons (.cons $const '((symbols))) (.cons (.cons $setreg '(1)) (.cons (.cons $global '(go)) (.cons (.cons $invoke '(2)) (.cons (.cons $.label '(2)) (.cons (.cons $save '(2)) (.cons (.cons $store '(0 0)) (.cons (.cons $store '(1 1)) (.cons (.cons $store '(2 2)) (.cons (.cons $setrtn '(3)) (.cons (.cons $reg '(1)) (.cons (.cons $op1 '(car)) (.cons (.cons $invoke '(0)) (.cons (.cons $.label '(3)) (.cons (.cons $.cont '()) (.cons (.cons $restore '(2)) (.cons (.cons $pop '(2)) (.cons (.cons $reg '(1)) (.cons (.cons $op1 '(cdr)) (.cons (.cons $setreg '(1)) (.cons (.cons $branch '(0)) '())))))))))))))))))))))))))))))))) 'init-proc))
+(let () (begin (set! create-symbol! (lambda (.h|1 .s|1) (let ((.create-symbol!|2 0)) (begin (set! .create-symbol!|2 (lambda (.h|3 .s|3) (dump-vector-like! .h|3 (let* ((.t|4|7|12 '(data ())) (.t|4|6|15 '(data 0)) (.t|4|5|18 (.cons 'bits (.cons (dump-string! .h|3 (symbol->string .s|3)) '()))) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))) dump-tagged-item! $tag.symbol-typetag))) (.create-symbol!|2 .h|1 .s|1))))) 'create-symbol!))
+(let () (begin (set! create-cell! (lambda (.h|1 .s|1) (let ((.create-cell!|2 0)) (begin (set! .create-cell!|2 (lambda (.h|3 .s|3) (let* ((.symtab|6 (heap.symbol-table .h|3)) (.n|9 (symtab.cell-no .symtab|6)) (.p|12 (dump-pair! .h|3 (cons (undefined) (if (generate-global-symbols) .s|3 .n|9))))) (let () (begin (symtab.cell-no! .symtab|6 (+ .n|9 1)) (cons .p|12 .n|9)))))) (.create-cell!|2 .h|1 .s|1))))) 'create-cell!))
+(let () (begin (set! construct-startup-procedure (lambda (.symbol-list-addr|1 .init-list-addr|1) (let ((.construct-startup-procedure|2 0)) (begin (set! .construct-startup-procedure|2 (lambda (.symbol-list-addr|3 .init-list-addr|3) (let ((.patch-constant-vector!|4 (unspecified))) (begin (set! .patch-constant-vector!|4 (lambda (.v|5 .old|5 .new|5) (let ((.i|8 (- (let ((.v|21|24 .v|5)) (begin (.check! (vector? .v|21|24) 42 .v|21|24) (vector-length:vec .v|21|24))) 1))) (let () (let ((.loop|11 (unspecified))) (begin (set! .loop|11 (lambda (.i|12) (if (>= .i|12 0) (begin (if (equal? (let ((.v|13|16 .v|5) (.i|13|16 .i|12)) (begin (.check! (fixnum? .i|13|16) 40 .v|13|16 .i|13|16) (.check! (vector? .v|13|16) 40 .v|13|16 .i|13|16) (.check! (<:fix:fix .i|13|16 (vector-length:vec .v|13|16)) 40 .v|13|16 .i|13|16) (.check! (>=:fix:fix .i|13|16 0) 40 .v|13|16 .i|13|16) (vector-ref:trusted .v|13|16 .i|13|16))) .old|5) (let ((.v|17|20 .v|5) (.i|17|20 .i|12) (.x|17|20 .new|5)) (begin (.check! (fixnum? .i|17|20) 41 .v|17|20 .i|17|20 .x|17|20) (.check! (vector? .v|17|20) 41 .v|17|20 .i|17|20 .x|17|20) (.check! (<:fix:fix .i|17|20 (vector-length:vec .v|17|20)) 41 .v|17|20 .i|17|20 .x|17|20) (.check! (>=:fix:fix .i|17|20 0) 41 .v|17|20 .i|17|20 .x|17|20) (vector-set!:trusted .v|17|20 .i|17|20 .x|17|20))) (unspecified)) (.loop|11 (- .i|12 1))) (unspecified)))) (.loop|11 .i|8))))))) (display "Assembling final procedure") (newline) (let ((.e|27 (single-stepping))) (begin (single-stepping #f) (let ((.segment|30 (assemble init-proc))) (begin (single-stepping .e|27) (.patch-constant-vector!|4 (segment.constants .segment|30) '(data (thunks)) (.cons 'bits (.cons .init-list-addr|3 '()))) (.patch-constant-vector!|4 (segment.constants .segment|30) '(data (symbols)) (.cons 'bits (.cons .symbol-list-addr|3 '()))) .segment|30)))))))) (.construct-startup-procedure|2 .symbol-list-addr|1 .init-list-addr|1))))) 'construct-startup-procedure))
+(let () (begin (set! symbol-locations (lambda (.h|1) (let ((.symbol-locations|2 0)) (begin (set! .symbol-locations|2 (lambda (.h|3) (let ((.symbols|6 (symtab.symbols (heap.symbol-table .h|3))) (.res|6 '())) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.symbols|10 .res|10) (if (null? .symbols|10) (reverse .res|10) (if (not (null? (symcell.symloc (let ((.x|13|16 .symbols|10)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16)))))) (.loop|9 (let ((.x|17|20 .symbols|10)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (symcell.symloc (let ((.x|21|24 .symbols|10)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) .res|10)) (.loop|9 (let ((.x|26|29 .symbols|10)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) .res|10))))) (.loop|9 .symbols|6 .res|6))))))) (.symbol-locations|2 .h|1))))) 'symbol-locations))
+(let () (begin (set! load-map (lambda (.h|1) (let ((.load-map|2 0)) (begin (set! .load-map|2 (lambda (.h|3) (let ((.symbols|6 (symtab.symbols (heap.symbol-table .h|3))) (.res|6 '())) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.symbols|10 .res|10) (if (null? .symbols|10) (reverse .res|10) (if (not (null? (symcell.valloc (let ((.x|13|16 .symbols|10)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16)))))) (.loop|9 (let ((.x|17|20 .symbols|10)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (cons (symcell.name (let ((.x|21|24 .symbols|10)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) (symcell.valno (let ((.x|25|28 .symbols|10)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))))) .res|10)) (.loop|9 (let ((.x|30|33 .symbols|10)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) .res|10))))) (.loop|9 .symbols|6 .res|6))))))) (.load-map|2 .h|1))))) 'load-map))
+(let () (begin (set! write-header (lambda (.h|1 .output-file|1) (let ((.write-header|2 0)) (begin (set! .write-header|2 (lambda (.h|3 .output-file|3) (begin (delete-file .output-file|3) (call-with-output-file .output-file|3 (lambda (.out|4) (let ((.write-roots|5 (unspecified)) (.write-word|5 (unspecified))) (begin (set! .write-roots|5 (lambda () (let ((.assigned-roots|9 (heap.roots .h|3))) (let () (let ((.loop|15|17|20 (unspecified))) (begin (set! .loop|15|17|20 (lambda (.y1|10|11|21) (if (null? .y1|10|11|21) (if #f #f (unspecified)) (begin (begin #t (let* ((.root-name|25 (let ((.x|33|36 .y1|10|11|21)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))) (.probe|28 (assq .root-name|25 .assigned-roots|9))) (if .probe|28 (.write-word|5 (let ((.x|29|32 .probe|28)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32)))) (.write-word|5 $imm.false)))) (.loop|15|17|20 (let ((.x|37|40 .y1|10|11|21)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))))))) (.loop|15|17|20 heap.root-names))))))) (set! .write-word|5 (lambda (.w|41) (begin (display (integer->char (quotient .w|41 twofiftysix^3)) .out|4) (display (integer->char (quotient (remainder .w|41 twofiftysix^3) twofiftysix^2)) .out|4) (display (integer->char (quotient (remainder .w|41 twofiftysix^2) twofiftysix)) .out|4) (display (integer->char (remainder .w|41 twofiftysix)) .out|4)))) (.write-word|5 heap.version-number) (.write-roots|5) (.write-word|5 (quotient (heap.top .h|3) 4))))))))) (.write-header|2 .h|1 .output-file|1))))) 'write-header))
+(let () (begin (set! append-file-shell-command (lambda (.file-to-append|1 .file-to-append-to|1) (let ((.append-file-shell-command|2 0)) (begin (set! .append-file-shell-command|2 (lambda (.file-to-append|3 .file-to-append-to|3) (let ((.message|5 (unspecified))) (begin (set! .message|5 (lambda () (begin (display "You must execute the command") (newline) (display " cat ") (display .file-to-append|3) (display " >> ") (display .file-to-append-to|3) (newline) (display "to create the final heap image.") (newline)))) (let ((.temp|4|9 host-system)) (if (memv .temp|4|9 '(chez larceny)) (begin (display "Creating final image in \"") (display .file-to-append-to|3) (display "\"...") (newline) (if (zero? (system (string-append "cat " .file-to-append|3 " >> " .file-to-append-to|3))) (delete-file .file-to-append|3) (begin (display "Failed to create image!") (newline)))) (.message|5))))))) (.append-file-shell-command|2 .file-to-append|1 .file-to-append-to|1))))) 'append-file-shell-command))
+(let () (begin (set! assembly-table (lambda () (let ((.assembly-table|2 0)) (begin (set! .assembly-table|2 (lambda () $sparc-assembly-table$)) (.assembly-table|2))))) 'assembly-table))
+(let () (begin (set! listify? #f) 'listify?))
+(let () (begin (set! $sparc-assembly-table$ (make-vector *number-of-mnemonics* (lambda (.instruction|1 .as|1) (asm-error "Unrecognized mnemonic " .instruction|1)))) '$sparc-assembly-table$))
+(let () (begin (set! define-instruction (lambda (.i|1 .proc|1) (let ((.define-instruction|2 0)) (begin (set! .define-instruction|2 (lambda (.i|3 .proc|3) (begin (let ((.v|4|7 $sparc-assembly-table$) (.i|4|7 .i|3) (.x|4|7 .proc|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) #t))) (.define-instruction|2 .i|1 .proc|1))))) 'define-instruction))
+(let () (begin (set! list-instruction (lambda (.name|1 .instruction|1) (let ((.list-instruction|2 0)) (begin (set! .list-instruction|2 (lambda (.name|3 .instruction|3) (if listify? (begin (display list-indentation) (display " ") (display .name|3) (display (make-string (max (- 12 (string-length .name|3)) 1) #\space)) (if (not (null? (let ((.x|4|7 .instruction|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (begin (write (let ((.x|9|12 (let ((.x|13|16 .instruction|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (let () (let ((.loop|18|20|23 (unspecified))) (begin (set! .loop|18|20|23 (lambda (.operands|24) (if (null? .operands|24) (if #f #f (unspecified)) (begin (begin #t (write-char #\,) (write (let ((.x|27|30 .operands|24)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (.loop|18|20|23 (let ((.x|31|34 .operands|24)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))))) (.loop|18|20|23 (let ((.x|36|39 (let ((.x|40|43 .instruction|3)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39)))))))) (unspecified)) (newline) (flush-output-port)) (unspecified)))) (.list-instruction|2 .name|1 .instruction|1))))) 'list-instruction))
+(let () (begin (set! list-label (lambda (.instruction|1) (let ((.list-label|2 0)) (begin (set! .list-label|2 (lambda (.instruction|3) (if listify? (begin (display list-indentation) (write-char #\L) (write (let ((.x|5|8 (let ((.x|9|12 .instruction|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))) (newline)) (unspecified)))) (.list-label|2 .instruction|1))))) 'list-label))
+(let () (begin (set! list-lambda-start (lambda (.instruction|1) (let ((.list-lambda-start|2 0)) (begin (set! .list-lambda-start|2 (lambda (.instruction|3) (begin (list-instruction "lambda" (let* ((.t1|4|7 $lambda) (.t2|4|10 (let* ((.t1|14|17 '*) (.t2|14|20 (cons (operand2 .instruction|3) '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10)))) (set! list-indentation (string-append list-indentation "| "))))) (.list-lambda-start|2 .instruction|1))))) 'list-lambda-start))
+(let () (begin (set! list-lambda-end (lambda () (let ((.list-lambda-end|2 0)) (begin (set! .list-lambda-end|2 (lambda () (set! list-indentation (substring list-indentation 0 (- (string-length list-indentation) 4))))) (.list-lambda-end|2))))) 'list-lambda-end))
+(let () (begin (set! list-indentation "") 'list-indentation))
+(let () (define-instruction $.label (lambda (.instruction|1 .as|1) (begin (list-label .instruction|1) (sparc.label .as|1 (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $.proc (lambda (.instruction|1 .as|1) (begin (list-instruction ".proc" .instruction|1) #t))))
+(let () (define-instruction $.proc-doc (lambda (.instruction|1 .as|1) (begin (list-instruction ".proc-doc" .instruction|1) (add-documentation .as|1 (operand1 .instruction|1)) #t))))
+(let () (define-instruction $.cont (lambda (.instruction|1 .as|1) (begin (list-instruction ".cont" .instruction|1) #t))))
+(let () (define-instruction $.align (lambda (.instruction|1 .as|1) (begin (list-instruction ".align" .instruction|1) #t))))
+(let () (define-instruction $.end (lambda (.instruction|1 .as|1) #t)))
+(let () (define-instruction $.singlestep (lambda (.instruction|1 .as|1) (let ((.instr|4 (let ((.x|102|105 (as-source .as|1))) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105))))) (let ((.readify-instr|5 (unspecified)) (.special?|5 (unspecified))) (begin (set! .readify-instr|5 (lambda () (if (= (operand0 .instr|4) $lambda) (let* ((.t1|7|10 'lambda) (.t2|7|13 (let* ((.t1|17|20 '(...)) (.t2|17|23 (let* ((.t1|27|30 (let ((.x|56|59 (let ((.x|60|63 (let ((.x|64|67 .instr|4)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67))))) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))))) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59)))) (.t2|27|33 (cons (let ((.x|39|42 (let ((.x|43|46 (let ((.x|47|50 (let ((.x|51|54 .instr|4)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))))) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) '()))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) (let ((.x|68|71 (readify-lap (cons .instr|4 '())))) (begin (.check! (pair? .x|68|71) 0 .x|68|71) (car:pair .x|68|71)))))) (set! .special?|5 (lambda () (let* ((.op|76 (operand0 .instr|4)) (.temp|77|80 (= .op|76 $.label))) (if .temp|77|80 .temp|77|80 (let ((.temp|81|84 (= .op|76 $.proc))) (if .temp|81|84 .temp|81|84 (let ((.temp|85|88 (= .op|76 $.cont))) (if .temp|85|88 .temp|85|88 (let ((.temp|89|92 (= .op|76 $.align))) (if .temp|89|92 .temp|89|92 (if (= .op|76 $load) (= 0 (operand1 .instr|4)) #f))))))))))) (if (not (.special?|5)) (let ((.repr|98 (format-object (.readify-instr|5))) (.funky?|98 (= (operand0 .instr|4) $restore))) (let ((.o|101 (emit-datum .as|1 .repr|98))) (emit-singlestep-instr! .as|1 .funky?|98 0 .o|101))) (unspecified))))))))
+(let () (define-instruction $op1 (lambda (.instruction|1 .as|1) (begin (list-instruction "op1" .instruction|1) (emit-primop.1arg! .as|1 (operand1 .instruction|1))))))
+(let () (define-instruction $op2 (lambda (.instruction|1 .as|1) (begin (list-instruction "op2" .instruction|1) (emit-primop.2arg! .as|1 (operand1 .instruction|1) (regname (operand2 .instruction|1)))))))
+(let () (define-instruction $op3 (lambda (.instruction|1 .as|1) (begin (list-instruction "op3" .instruction|1) (emit-primop.3arg! .as|1 (operand1 .instruction|1) (regname (operand2 .instruction|1)) (regname (operand3 .instruction|1)))))))
+(let () (define-instruction $op2imm (lambda (.instruction|1 .as|1) (begin (list-instruction "op2imm" .instruction|1) (let ((.op|4 (let ((.temp|5|8 (operand1 .instruction|1))) (if (memv .temp|5|8 '(+)) 'internal:+/imm (if (memv .temp|5|8 '(-)) 'internal:-/imm (if (memv .temp|5|8 '(fx+)) 'internal:fx+/imm (if (memv .temp|5|8 '(fx-)) 'internal:fx-/imm (if (memv .temp|5|8 '(fx=)) 'internal:fx=/imm (if (memv .temp|5|8 '(fx<)) 'internal:fx</imm (if (memv .temp|5|8 '(fx<=)) 'internal:fx<=/imm (if (memv .temp|5|8 '(fx>)) 'internal:fx>/imm (if (memv .temp|5|8 '(fx>=)) 'internal:fx>=/imm (if (memv .temp|5|8 '(=:fix:fix)) 'internal:=:fix:fix/imm (if (memv .temp|5|8 '(<:fix:fix)) 'internal:<:fix:fix/imm (if (memv .temp|5|8 '(<=:fix:fix)) 'internal:<=:fix:fix/imm (if (memv .temp|5|8 '(>:fix:fix)) 'internal:>:fix:fix/imm (if (memv .temp|5|8 '(>=:fix:fix)) 'internal:>=:fix:fix/imm #f))))))))))))))))) (if .op|4 (emit-primop.4arg! .as|1 .op|4 $r.result (operand2 .instruction|1) $r.result) (begin (emit-constant->register .as|1 (operand2 .instruction|1) $r.argreg2) (emit-primop.2arg! .as|1 (operand1 .instruction|1) $r.argreg2))))))))
+(let () (define-instruction $const (lambda (.instruction|1 .as|1) (begin (list-instruction "const" .instruction|1) (emit-constant->register .as|1 (operand1 .instruction|1) $r.result)))))
+(let () (define-instruction $global (lambda (.instruction|1 .as|1) (begin (list-instruction "global" .instruction|1) (emit-global->register! .as|1 (emit-global .as|1 (operand1 .instruction|1)) $r.result)))))
+(let () (define-instruction $setglbl (lambda (.instruction|1 .as|1) (begin (list-instruction "setglbl" .instruction|1) (emit-register->global! .as|1 $r.result (emit-global .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $lambda (lambda (.instruction|1 .as|1) (let ((.code-offset|4 #f) (.const-offset|4 #f)) (begin (list-lambda-start .instruction|1) (assemble-nested-lambda .as|1 (operand1 .instruction|1) (operand3 .instruction|1) (lambda (.nested-as|5 .segment|5) (begin (set-constant! .as|1 .code-offset|4 (let ((.x|6|9 .segment|5)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (set-constant! .as|1 .const-offset|4 (let ((.x|10|13 .segment|5)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))))))) (list-lambda-end) (set! .code-offset|4 (emit-codevector .as|1 0)) (set! .const-offset|4 (emit-constantvector .as|1 0)) (emit-lambda! .as|1 .code-offset|4 .const-offset|4 (operand2 .instruction|1)))))))
+(let () (define-instruction $lexes (lambda (.instruction|1 .as|1) (begin (list-instruction "lexes" .instruction|1) (emit-lexes! .as|1 (operand1 .instruction|1))))))
+(let () (define-instruction $args= (lambda (.instruction|1 .as|1) (begin (list-instruction "args=" .instruction|1) (emit-args=! .as|1 (operand1 .instruction|1))))))
+(let () (define-instruction $args>= (lambda (.instruction|1 .as|1) (begin (list-instruction "args>=" .instruction|1) (emit-args>=! .as|1 (operand1 .instruction|1))))))
+(let () (define-instruction $invoke (lambda (.instruction|1 .as|1) (begin (list-instruction "invoke" .instruction|1) (emit-invoke .as|1 (operand1 .instruction|1) #f $m.invoke-ex)))))
+(let () (define-instruction $restore (lambda (.instruction|1 .as|1) (if (not (< (operand1 .instruction|1) 0)) (begin (list-instruction "restore" .instruction|1) (emit-restore! .as|1 (operand1 .instruction|1))) (unspecified)))))
+(let () (define-instruction $pop (lambda (.instruction|1 .as|1) (if (not (< (operand1 .instruction|1) 0)) (begin (list-instruction "pop" .instruction|1) (let ((.next|5 (next-instruction .as|1))) (if (if (peephole-optimization) (eqv? $return (operand0 .next|5)) #f) (begin (list-instruction "return" .next|5) (consume-next-instruction! .as|1) (emit-pop! .as|1 (operand1 .instruction|1) #t)) (emit-pop! .as|1 (operand1 .instruction|1) #f)))) (unspecified)))))
+(let () (define-instruction $stack (lambda (.instruction|1 .as|1) (begin (list-instruction "stack" .instruction|1) (emit-load! .as|1 (operand1 .instruction|1) $r.result)))))
+(let () (define-instruction $setstk (lambda (.instruction|1 .as|1) (begin (list-instruction "setstk" .instruction|1) (emit-store! .as|1 $r.result (operand1 .instruction|1))))))
+(let () (define-instruction $load (lambda (.instruction|1 .as|1) (begin (list-instruction "load" .instruction|1) (emit-load! .as|1 (operand2 .instruction|1) (regname (operand1 .instruction|1)))))))
+(let () (define-instruction $store (lambda (.instruction|1 .as|1) (begin (list-instruction "store" .instruction|1) (emit-store! .as|1 (regname (operand1 .instruction|1)) (operand2 .instruction|1))))))
+(let () (define-instruction $lexical (lambda (.instruction|1 .as|1) (begin (list-instruction "lexical" .instruction|1) (emit-lexical! .as|1 (operand1 .instruction|1) (operand2 .instruction|1))))))
+(let () (define-instruction $setlex (lambda (.instruction|1 .as|1) (begin (list-instruction "setlex" .instruction|1) (emit-setlex! .as|1 (operand1 .instruction|1) (operand2 .instruction|1))))))
+(let () (define-instruction $reg (lambda (.instruction|1 .as|1) (begin (list-instruction "reg" .instruction|1) (emit-register->register! .as|1 (regname (operand1 .instruction|1)) $r.result)))))
+(let () (define-instruction $setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "setreg" .instruction|1) (emit-register->register! .as|1 $r.result (regname (operand1 .instruction|1)))))))
+(let () (define-instruction $movereg (lambda (.instruction|1 .as|1) (begin (list-instruction "movereg" .instruction|1) (emit-register->register! .as|1 (regname (operand1 .instruction|1)) (regname (operand2 .instruction|1)))))))
+(let () (define-instruction $return (lambda (.instruction|1 .as|1) (begin (list-instruction "return" .instruction|1) (emit-return! .as|1)))))
+(let () (define-instruction $reg/return (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/return" .instruction|1) (emit-return-reg! .as|1 (regname (operand1 .instruction|1)))))))
+(let () (define-instruction $const/return (lambda (.instruction|1 .as|1) (begin (list-instruction "const/return" .instruction|1) (emit-return-const! .as|1 (operand1 .instruction|1))))))
+(let () (define-instruction $nop (lambda (.instruction|1 .as|1) (list-instruction "nop" .instruction|1))))
+(let () (define-instruction $save (lambda (.instruction|1 .as|1) (if (not (< (operand1 .instruction|1) 0)) (begin (list-instruction "save" .instruction|1) (let* ((.n|5 (operand1 .instruction|1)) (.v|8 (make-vector (+ .n|5 1) #t))) (let () (begin (emit-save0! .as|1 .n|5) (if (peephole-optimization) (let ((.instruction|14 (next-instruction .as|1))) (let () (let ((.loop|17 (unspecified))) (begin (set! .loop|17 (lambda (.instruction|18) (if (eqv? $store (operand0 .instruction|18)) (begin (list-instruction "store" .instruction|18) (emit-store! .as|1 (regname (operand1 .instruction|18)) (operand2 .instruction|18)) (consume-next-instruction! .as|1) (let ((.v|20|23 .v|8) (.i|20|23 (operand2 .instruction|18)) (.x|20|23 #f)) (begin (.check! (fixnum? .i|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (vector? .v|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (>=:fix:fix .i|20|23 0) 41 .v|20|23 .i|20|23 .x|20|23) (vector-set!:trusted .v|20|23 .i|20|23 .x|20|23))) (.loop|17 (next-instruction .as|1))) (unspecified)))) (.loop|17 .instruction|14))))) (unspecified)) (emit-save1! .as|1 .v|8))))) (unspecified)))))
+(let () (define-instruction $setrtn (lambda (.instruction|1 .as|1) (begin (list-instruction "setrtn" .instruction|1) (emit-setrtn! .as|1 (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $apply (lambda (.instruction|1 .as|1) (begin (list-instruction "apply" .instruction|1) (emit-apply! .as|1 (regname (operand1 .instruction|1)) (regname (operand2 .instruction|1)))))))
+(let () (define-instruction $jump (lambda (.instruction|1 .as|1) (begin (list-instruction "jump" .instruction|1) (emit-jump! .as|1 (operand1 .instruction|1) (make-asm-label .as|1 (operand2 .instruction|1)))))))
+(let () (define-instruction $skip (lambda (.instruction|1 .as|1) (begin (list-instruction "skip" .instruction|1) (emit-branch! .as|1 #f (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $branch (lambda (.instruction|1 .as|1) (begin (list-instruction "branch" .instruction|1) (emit-branch! .as|1 #t (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $branchf (lambda (.instruction|1 .as|1) (begin (list-instruction "branchf" .instruction|1) (emit-branchf! .as|1 (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $check (lambda (.instruction|1 .as|1) (begin (list-instruction "check" .instruction|1) (if (not (unsafe-code)) (emit-check! .as|1 $r.result (make-asm-label .as|1 (operand4 .instruction|1)) (let* ((.t1|2|5 (regname (operand1 .instruction|1))) (.t2|2|8 (let* ((.t1|12|15 (regname (operand2 .instruction|1))) (.t2|12|18 (cons (regname (operand3 .instruction|1)) '()))) (let () (cons .t1|12|15 .t2|12|18))))) (let () (cons .t1|2|5 .t2|2|8)))) (unspecified))))))
+(let () (define-instruction $trap (lambda (.instruction|1 .as|1) (begin (list-instruction "trap" .instruction|1) (emit-trap! .as|1 (regname (operand1 .instruction|1)) (regname (operand2 .instruction|1)) (regname (operand3 .instruction|1)) (operand4 .instruction|1))))))
+(let () (define-instruction $const/setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "const/setreg" .instruction|1) (let ((.x|4 (operand1 .instruction|1)) (.r|4 (operand2 .instruction|1))) (if (hwreg? .r|4) (emit-constant->register .as|1 .x|4 (regname .r|4)) (begin (emit-constant->register .as|1 .x|4 $r.tmp0) (emit-register->register! .as|1 $r.tmp0 (regname .r|4)))))))))
+(let () (begin (set! peep-regname (lambda (.r|1) (let ((.peep-regname|2 0)) (begin (set! .peep-regname|2 (lambda (.r|3) (if (eq? .r|3 'result) $r.result (regname .r|3)))) (.peep-regname|2 .r|1))))) 'peep-regname))
+(let () (define-instruction $reg/op1/branchf (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op1/branchf" .instruction|1) (emit-primop.3arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (make-asm-label .as|1 (operand3 .instruction|1)))))))
+(let () (define-instruction $reg/op2/branchf (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2/branchf" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (peep-regname (operand3 .instruction|1)) (make-asm-label .as|1 (operand4 .instruction|1)))))))
+(let () (define-instruction $reg/op2imm/branchf (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2imm/branchf" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (operand3 .instruction|1) (make-asm-label .as|1 (operand4 .instruction|1)))))))
+(let () (define-instruction $reg/op1/check (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op1/check" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (make-asm-label .as|1 (operand3 .instruction|1)) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.y1|2|3|14 .results|2|6|14) (if (null? .y1|2|3|14) (reverse .results|2|6|14) (begin #t (.loop|7|10|13 (let ((.x|18|21 .y1|2|3|14)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))) (cons (peep-regname (let ((.x|22|25 .y1|2|3|14)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25)))) .results|2|6|14)))))) (.loop|7|10|13 (operand4 .instruction|1) '())))))))))
+(let () (define-instruction $reg/op2/check (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2/check" .instruction|1) (emit-primop.5arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (peep-regname (operand3 .instruction|1)) (make-asm-label .as|1 (operand4 .instruction|1)) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.y1|2|3|14 .results|2|6|14) (if (null? .y1|2|3|14) (reverse .results|2|6|14) (begin #t (.loop|7|10|13 (let ((.x|18|21 .y1|2|3|14)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))) (cons (peep-regname (let ((.x|22|25 .y1|2|3|14)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25)))) .results|2|6|14)))))) (.loop|7|10|13 (operand5 .instruction|1) '())))))))))
+(let () (define-instruction $reg/op2imm/check (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2imm/check" .instruction|1) (emit-primop.5arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (operand3 .instruction|1) (make-asm-label .as|1 (operand4 .instruction|1)) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.y1|2|3|14 .results|2|6|14) (if (null? .y1|2|3|14) (reverse .results|2|6|14) (begin #t (.loop|7|10|13 (let ((.x|18|21 .y1|2|3|14)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))) (cons (peep-regname (let ((.x|22|25 .y1|2|3|14)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25)))) .results|2|6|14)))))) (.loop|7|10|13 (operand5 .instruction|1) '())))))))))
+(let () (define-instruction $reg/op1/setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op1/setreg" .instruction|1) (emit-primop.3arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (peep-regname (operand3 .instruction|1)))))))
+(let () (define-instruction $reg/op2/setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2/setreg" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (peep-regname (operand3 .instruction|1)) (peep-regname (operand4 .instruction|1)))))))
+(let () (define-instruction $reg/op2imm/setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op2imm/setreg" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (operand3 .instruction|1) (peep-regname (operand4 .instruction|1)))))))
+(let () (define-instruction $reg/op3 (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/op3" .instruction|1) (emit-primop.4arg! .as|1 (operand1 .instruction|1) (peep-regname (operand2 .instruction|1)) (peep-regname (operand3 .instruction|1)) (peep-regname (operand4 .instruction|1)))))))
+(let () (define-instruction $reg/branchf (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/branchf" .instruction|1) (emit-branchfreg! .as|1 (regname (operand1 .instruction|1)) (make-asm-label .as|1 (operand2 .instruction|1)))))))
+(let () (define-instruction $setrtn/branch (lambda (.instruction|1 .as|1) (begin (list-instruction "setrtn/branch" .instruction|1) (emit-branch-with-setrtn! .as|1 (make-asm-label .as|1 (operand1 .instruction|1)))))))
+(let () (define-instruction $setrtn/invoke (lambda (.instruction|1 .as|1) (begin (list-instruction "setrtn/invoke" .instruction|1) (emit-invoke .as|1 (operand1 .instruction|1) #t $m.invoke-ex)))))
+(let () (define-instruction $global/setreg (lambda (.instruction|1 .as|1) (begin (list-instruction "global/setreg" .instruction|1) (emit-global->register! .as|1 (emit-global .as|1 (operand1 .instruction|1)) (regname (operand2 .instruction|1)))))))
+(let () (define-instruction $global/invoke (lambda (.instruction|1 .as|1) (begin (list-instruction "global/invoke" .instruction|1) (emit-load-global .as|1 (emit-global .as|1 (operand1 .instruction|1)) $r.result #f) (emit-invoke .as|1 (operand2 .instruction|1) #f $m.global-invoke-ex)))))
+(let () (define-instruction $reg/setglbl (lambda (.instruction|1 .as|1) (begin (list-instruction "reg/setglbl" .instruction|1) (emit-register->global! .as|1 (regname (operand1 .instruction|1)) (emit-global .as|1 (operand2 .instruction|1)))))))
+(let () (begin (set! *peephole-table* (make-vector *number-of-mnemonics* #f)) '*peephole-table*))
+(let () (begin (set! define-peephole (lambda (.n|1 .p|1) (let ((.define-peephole|2 0)) (begin (set! .define-peephole|2 (lambda (.n|3 .p|3) (begin (let ((.v|4|7 *peephole-table*) (.i|4|7 .n|3) (.x|4|7 .p|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.define-peephole|2 .n|1 .p|1))))) 'define-peephole))
+(let () (begin (set! peep (lambda (.as|1) (let ((.peep|2 0)) (begin (set! .peep|2 (lambda (.as|3) (let ((.t0|6 (as-source .as|3))) (if (not (null? .t0|6)) (let* ((.i1|9 (let ((.x|59|62 .t0|6)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62)))) (.p|12 (let ((.v|51|54 *peephole-table*) (.i|51|54 (let ((.x|55|58 .i1|9)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58))))) (begin (.check! (fixnum? .i|51|54) 40 .v|51|54 .i|51|54) (.check! (vector? .v|51|54) 40 .v|51|54 .i|51|54) (.check! (<:fix:fix .i|51|54 (vector-length:vec .v|51|54)) 40 .v|51|54 .i|51|54) (.check! (>=:fix:fix .i|51|54 0) 40 .v|51|54 .i|51|54) (vector-ref:trusted .v|51|54 .i|51|54))))) (if .p|12 (let* ((.t1|15 (if (null? .t0|6) .t0|6 (let ((.x|47|50 .t0|6)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (.i2|18 (if (null? .t1|15) '(-1 0 0 0) (let ((.x|43|46 .t1|15)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) (.t2|21 (if (null? .t1|15) .t1|15 (let ((.x|39|42 .t1|15)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (.i3|24 (if (null? .t2|21) '(-1 0 0 0) (let ((.x|35|38 .t2|21)) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))))) (.t3|27 (if (null? .t2|21) .t2|21 (let ((.x|31|34 .t2|21)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))) (let () (.p|12 .as|3 .i1|9 .i2|18 .i3|24 .t1|15 .t2|21 .t3|27))) (unspecified))) (unspecified))))) (.peep|2 .as|1))))) 'peep))
+(let () (define-peephole $reg (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $return) (reg-return .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $setglbl) (reg-setglbl .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $op1) (if (= (let ((.x|18|21 .i3|1)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) $setreg) (reg-op1-setreg .as|1 .i1|1 .i2|1 .i3|1 .t2|1 .t3|1) (if (= (let ((.x|23|26 .i3|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) $branchf) (reg-op1-branchf .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (if (= (let ((.x|28|31 .i3|1)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) $check) (reg-op1-check .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (reg-op1 .as|1 .i1|1 .i2|1 .t2|1)))) (if (= (let ((.x|34|37 .i2|1)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) $op2) (if (= (let ((.x|39|42 .i3|1)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) $setreg) (reg-op2-setreg .as|1 .i1|1 .i2|1 .i3|1 .t2|1 .t3|1) (if (= (let ((.x|44|47 .i3|1)) (begin (.check! (pair? .x|44|47) 0 .x|44|47) (car:pair .x|44|47))) $branchf) (reg-op2-branchf .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (if (= (let ((.x|49|52 .i3|1)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))) $check) (reg-op2-check .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (reg-op2 .as|1 .i1|1 .i2|1 .t2|1)))) (if (= (let ((.x|55|58 .i2|1)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58))) $op2imm) (if (= (let ((.x|60|63 .i3|1)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63))) $setreg) (reg-op2imm-setreg .as|1 .i1|1 .i2|1 .i3|1 .t2|1 .t3|1) (if (= (let ((.x|65|68 .i3|1)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))) $branchf) (reg-op2imm-branchf .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (if (= (let ((.x|70|73 .i3|1)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))) $check) (reg-op2imm-check .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (reg-op2imm .as|1 .i1|1 .i2|1 .t2|1)))) (if (= (let ((.x|76|79 .i2|1)) (begin (.check! (pair? .x|76|79) 0 .x|76|79) (car:pair .x|76|79))) $op3) (reg-op3 .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|81|84 .i2|1)) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))) $setreg) (reg-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|86|89 .i2|1)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89))) $branchf) (reg-branchf .as|1 .i1|1 .i2|1 .t2|1) (unspecified))))))))))))
+(let () (define-peephole $op1 (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $branchf) (op1-branchf .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $setreg) (op1-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $check) (op1-check .as|1 .i1|1 .i2|1 .t2|1) (unspecified)))))))
+(let () (define-peephole $op2 (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $branchf) (op2-branchf .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $setreg) (op2-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $check) (op2-check .as|1 .i1|1 .i2|1 .t2|1) (unspecified)))))))
+(let () (define-peephole $op2imm (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $branchf) (op2imm-branchf .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $setreg) (op2imm-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $check) (op2imm-check .as|1 .i1|1 .i2|1 .t2|1) (unspecified)))))))
+(let () (define-peephole $const (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $setreg) (const-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $op2) (const-op2 .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $return) (const-return .as|1 .i1|1 .i2|1 .t2|1) (unspecified)))))))
+(let () (define-peephole $setrtn (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $branch) (if (= (let ((.x|8|11 .i3|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $.align) (if (not (null? .t3|1)) (let ((.i4|14 (let ((.x|20|23 .t3|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (.t4|14 (let ((.x|24|27 .t3|1)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (if (= (let ((.x|16|19 .i4|14)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))) $.label) (setrtn-branch .as|1 .i1|1 .i2|1 .i3|1 .i4|14 .t4|14) (unspecified))) (unspecified)) (unspecified)) (if (= (let ((.x|29|32 .i2|1)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32))) $invoke) (if (= (let ((.x|34|37 .i3|1)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) $.align) (if (not (null? .t3|1)) (let ((.i4|40 (let ((.x|46|49 .t3|1)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))) (.t4|40 (let ((.x|50|53 .t3|1)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53))))) (if (= (let ((.x|42|45 .i4|40)) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45))) $.label) (setrtn-invoke .as|1 .i1|1 .i2|1 .i3|1 .i4|40 .t4|40) (unspecified))) (unspecified)) (unspecified)) (unspecified))))))
+(let () (define-peephole $branch (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $.align) (if (= (let ((.x|8|11 .i3|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $.label) (branch-and-label .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (unspecified)) (unspecified)))))
+(let () (define-peephole $global (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $setreg) (global-setreg .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|8|11 .i2|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $invoke) (global-invoke .as|1 .i1|1 .i2|1 .t2|1) (if (= (let ((.x|13|16 .i2|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) $setrtn) (if (= (let ((.x|18|21 .i3|1)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) $invoke) (global-setrtn-invoke .as|1 .i1|1 .i2|1 .i3|1 .t3|1) (unspecified)) (unspecified)))))))
+(let () (define-peephole $reg/op1/check (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $reg) (if (= (let ((.x|8|11 .i3|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $op1) (if (not (null? .t3|1)) (let ((.i4|14 (let ((.x|20|23 .t3|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (.t4|14 (let ((.x|24|27 .t3|1)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (if (= (let ((.x|16|19 .i4|14)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))) $setreg) (reg/op1/check-reg-op1-setreg .as|1 .i1|1 .i2|1 .i3|1 .i4|14 .t4|14) (unspecified))) (unspecified)) (unspecified)) (unspecified)))))
+(let () (define-peephole $reg/op2/check (lambda (.as|1 .i1|1 .i2|1 .i3|1 .t1|1 .t2|1 .t3|1) (if (= (let ((.x|3|6 .i2|1)) (begin (.check! (pair? .x|3|6) 0 .x|3|6) (car:pair .x|3|6))) $reg) (if (= (let ((.x|8|11 .i3|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) $op2imm) (if (not (null? .t3|1)) (let ((.i4|14 (let ((.x|20|23 .t3|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (.t4|14 (let ((.x|24|27 .t3|1)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (if (= (let ((.x|16|19 .i4|14)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))) $check) (reg/op2/check-reg-op2imm-check .as|1 .i1|1 .i2|1 .i3|1 .i4|14 .t4|14) (unspecified))) (unspecified)) (unspecified)) (unspecified)))))
+(let () (begin (set! reg-return (lambda (.as|1 .i:reg|1 .i:return|1 .tail|1) (let ((.reg-return|2 0)) (begin (set! .reg-return|2 (lambda (.as|3 .i:reg|3 .i:return|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3))) (if (hwreg? .rs|6) (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/return) (.t2|7|13 (cons .rs|6 '()))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.reg-return|2 .as|1 .i:reg|1 .i:return|1 .tail|1))))) 'reg-return))
+(let () (begin (set! reg-op1-setreg (lambda (.as|1 .i:reg|1 .i:op1|1 .i:setreg|1 .tail-1|1 .tail|1) (let ((.reg-op1-setreg|2 0)) (begin (set! .reg-op1-setreg|2 (lambda (.as|3 .i:reg|3 .i:op1|3 .i:setreg|3 .tail-1|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.rd|6 (operand1 .i:setreg|3)) (.op|6 (operand1 .i:op1|3))) (if (hwreg? .rs|6) (if (hwreg? .rd|6) (peep-reg/op1/setreg .as|3 .op|6 .rs|6 .rd|6 .tail|3) (peep-reg/op1/setreg .as|3 .op|6 .rs|6 'result .tail-1|3)) (unspecified))))) (.reg-op1-setreg|2 .as|1 .i:reg|1 .i:op1|1 .i:setreg|1 .tail-1|1 .tail|1))))) 'reg-op1-setreg))
+(let () (begin (set! reg-op1 (lambda (.as|1 .i:reg|1 .i:op1|1 .tail|1) (let ((.reg-op1|2 0)) (begin (set! .reg-op1|2 (lambda (.as|3 .i:reg|3 .i:op1|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.op|6 (operand1 .i:op1|3))) (if (hwreg? .rs|6) (peep-reg/op1/setreg .as|3 .op|6 .rs|6 'result .tail|3) (unspecified))))) (.reg-op1|2 .as|1 .i:reg|1 .i:op1|1 .tail|1))))) 'reg-op1))
+(let () (begin (set! op1-setreg (lambda (.as|1 .i:op1|1 .i:setreg|1 .tail|1) (let ((.op1-setreg|2 0)) (begin (set! .op1-setreg|2 (lambda (.as|3 .i:op1|3 .i:setreg|3 .tail|3) (let ((.op|6 (operand1 .i:op1|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rd|6) (peep-reg/op1/setreg .as|3 .op|6 'result .rd|6 .tail|3) (unspecified))))) (.op1-setreg|2 .as|1 .i:op1|1 .i:setreg|1 .tail|1))))) 'op1-setreg))
+(let () (begin (set! peep-reg/op1/setreg (lambda (.as|1 .op|1 .rs|1 .rd|1 .tail|1) (let ((.peep-reg/op1/setreg|2 0)) (begin (set! .peep-reg/op1/setreg|2 (lambda (.as|3 .op|3 .rs|3 .rd|3 .tail|3) (let ((.op|6 (let ((.temp|38|41 .op|3)) (if (memv .temp|38|41 '(car)) 'internal:car (if (memv .temp|38|41 '(cdr)) 'internal:cdr (if (memv .temp|38|41 '(car:pair)) 'internal:car:pair (if (memv .temp|38|41 '(cdr:pair)) 'internal:cdr:pair (if (memv .temp|38|41 '(cell-ref)) 'internal:cell-ref (if (memv .temp|38|41 '(vector-length)) 'internal:vector-length (if (memv .temp|38|41 '(vector-length:vec)) 'internal:vector-length:vec (if (memv .temp|38|41 '(string-length)) 'internal:string-length (if (memv .temp|38|41 '(--)) 'internal:-- (if (memv .temp|38|41 '(fx--)) 'internal:fx-- (if (memv .temp|38|41 '(fxpositive?)) 'internal:fxpositive? (if (memv .temp|38|41 '(fxnegative?)) 'internal:fxnegative? (if (memv .temp|38|41 '(fxzero?)) 'internal:fxzero? #f)))))))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op1/setreg) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs|3) (.t2|27|33 (cons .rd|3 '()))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op1/setreg|2 .as|1 .op|1 .rs|1 .rd|1 .tail|1))))) 'peep-reg/op1/setreg))
+(let () (begin (set! reg-op2-setreg (lambda (.as|1 .i:reg|1 .i:op2|1 .i:setreg|1 .tail-1|1 .tail|1) (let ((.reg-op2-setreg|2 0)) (begin (set! .reg-op2-setreg|2 (lambda (.as|3 .i:reg|3 .i:op2|3 .i:setreg|3 .tail-1|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.rs2|6 (operand2 .i:op2|3)) (.op|6 (operand1 .i:op2|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rs1|6) (if (hwreg? .rd|6) (peep-reg/op2/setreg .as|3 .op|6 .rs1|6 .rs2|6 .rd|6 .tail|3) (peep-reg/op2/setreg .as|3 .op|6 .rs1|6 .rs2|6 'result .tail-1|3)) (unspecified))))) (.reg-op2-setreg|2 .as|1 .i:reg|1 .i:op2|1 .i:setreg|1 .tail-1|1 .tail|1))))) 'reg-op2-setreg))
+(let () (begin (set! reg-op2 (lambda (.as|1 .i:reg|1 .i:op2|1 .tail|1) (let ((.reg-op2|2 0)) (begin (set! .reg-op2|2 (lambda (.as|3 .i:reg|3 .i:op2|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.rs2|6 (operand2 .i:op2|3)) (.op|6 (operand1 .i:op2|3))) (if (hwreg? .rs1|6) (peep-reg/op2/setreg .as|3 .op|6 .rs1|6 .rs2|6 'result .tail|3) (unspecified))))) (.reg-op2|2 .as|1 .i:reg|1 .i:op2|1 .tail|1))))) 'reg-op2))
+(let () (begin (set! op2-setreg (lambda (.as|1 .i:op2|1 .i:setreg|1 .tail|1) (let ((.op2-setreg|2 0)) (begin (set! .op2-setreg|2 (lambda (.as|3 .i:op2|3 .i:setreg|3 .tail|3) (let ((.op|6 (operand1 .i:op2|3)) (.rs2|6 (operand2 .i:op2|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rd|6) (peep-reg/op2/setreg .as|3 .op|6 'result .rs2|6 .rd|6 .tail|3) (unspecified))))) (.op2-setreg|2 .as|1 .i:op2|1 .i:setreg|1 .tail|1))))) 'op2-setreg))
+(let () (begin (set! peep-reg/op2/setreg (lambda (.as|1 .op|1 .rs1|1 .rs2|1 .rd|1 .tail|1) (let ((.peep-reg/op2/setreg|2 0)) (begin (set! .peep-reg/op2/setreg|2 (lambda (.as|3 .op|3 .rs1|3 .rs2|3 .rd|3 .tail|3) (let ((.op|6 (let ((.temp|48|51 .op|3)) (if (memv .temp|48|51 '(+)) 'internal:+ (if (memv .temp|48|51 '(-)) 'internal:- (if (memv .temp|48|51 '(fx+)) 'internal:fx+ (if (memv .temp|48|51 '(fx-)) 'internal:fx- (if (memv .temp|48|51 '(fx=)) 'internal:fx= (if (memv .temp|48|51 '(fx>)) 'internal:fx> (if (memv .temp|48|51 '(fx>=)) 'internal:fx>= (if (memv .temp|48|51 '(fx<)) 'internal:fx< (if (memv .temp|48|51 '(fx<=)) 'internal:fx<= (if (memv .temp|48|51 '(eq?)) 'internal:eq? (if (memv .temp|48|51 '(cons)) 'internal:cons (if (memv .temp|48|51 '(vector-ref)) 'internal:vector-ref (if (memv .temp|48|51 '(vector-ref:trusted)) 'internal:vector-ref:trusted (if (memv .temp|48|51 '(string-ref)) 'internal:string-ref (if (memv .temp|48|51 '(set-car!)) 'internal:set-car! (if (memv .temp|48|51 '(set-cdr!)) 'internal:set-cdr! (if (memv .temp|48|51 '(cell-set!)) 'internal:cell-set! #f)))))))))))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2/setreg) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs1|3) (.t2|27|33 (let* ((.t1|37|40 .rs2|3) (.t2|37|43 (cons .rd|3 '()))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2/setreg|2 .as|1 .op|1 .rs1|1 .rs2|1 .rd|1 .tail|1))))) 'peep-reg/op2/setreg))
+(let () (begin (set! reg-op2imm-setreg (lambda (.as|1 .i:reg|1 .i:op2imm|1 .i:setreg|1 .tail-1|1 .tail|1) (let ((.reg-op2imm-setreg|2 0)) (begin (set! .reg-op2imm-setreg|2 (lambda (.as|3 .i:reg|3 .i:op2imm|3 .i:setreg|3 .tail-1|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.imm|6 (operand2 .i:op2imm|3)) (.op|6 (operand1 .i:op2imm|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rs|6) (if (hwreg? .rd|6) (peep-reg/op2imm/setreg .as|3 .op|6 .rs|6 .imm|6 .rd|6 .tail|3) (peep-reg/op2imm/setreg .as|3 .op|6 .rs|6 .imm|6 'result .tail-1|3)) (unspecified))))) (.reg-op2imm-setreg|2 .as|1 .i:reg|1 .i:op2imm|1 .i:setreg|1 .tail-1|1 .tail|1))))) 'reg-op2imm-setreg))
+(let () (begin (set! reg-op2imm (lambda (.as|1 .i:reg|1 .i:op2imm|1 .tail|1) (let ((.reg-op2imm|2 0)) (begin (set! .reg-op2imm|2 (lambda (.as|3 .i:reg|3 .i:op2imm|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.imm|6 (operand2 .i:op2imm|3)) (.op|6 (operand1 .i:op2imm|3))) (if (hwreg? .rs|6) (peep-reg/op2imm/setreg .as|3 .op|6 .rs|6 .imm|6 'result .tail|3) (unspecified))))) (.reg-op2imm|2 .as|1 .i:reg|1 .i:op2imm|1 .tail|1))))) 'reg-op2imm))
+(let () (begin (set! op2imm-setreg (lambda (.as|1 .i:op2imm|1 .i:setreg|1 .tail|1) (let ((.op2imm-setreg|2 0)) (begin (set! .op2imm-setreg|2 (lambda (.as|3 .i:op2imm|3 .i:setreg|3 .tail|3) (let ((.op|6 (operand1 .i:op2imm|3)) (.imm|6 (operand2 .i:op2imm|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rd|6) (peep-reg/op2imm/setreg .as|3 .op|6 'result .imm|6 .rd|6 .tail|3) (unspecified))))) (.op2imm-setreg|2 .as|1 .i:op2imm|1 .i:setreg|1 .tail|1))))) 'op2imm-setreg))
+(let () (begin (set! peep-reg/op2imm/setreg (lambda (.as|1 .op|1 .rs|1 .imm|1 .rd|1 .tail|1) (let ((.peep-reg/op2imm/setreg|2 0)) (begin (set! .peep-reg/op2imm/setreg|2 (lambda (.as|3 .op|3 .rs|3 .imm|3 .rd|3 .tail|3) (let ((.op|6 (let ((.temp|48|51 .op|3)) (if (memv .temp|48|51 '(+)) 'internal:+/imm (if (memv .temp|48|51 '(-)) 'internal:-/imm (if (memv .temp|48|51 '(fx+)) 'internal:fx+/imm (if (memv .temp|48|51 '(fx-)) 'internal:fx-/imm (if (memv .temp|48|51 '(fx=)) 'internal:fx=/imm (if (memv .temp|48|51 '(fx<)) 'internal:fx</imm (if (memv .temp|48|51 '(fx<=)) 'internal:fx<=/imm (if (memv .temp|48|51 '(fx>)) 'internal:fx>/imm (if (memv .temp|48|51 '(fx>=)) 'internal:fx>=/imm (if (memv .temp|48|51 '(eq?)) 'internal:eq?/imm (if (memv .temp|48|51 '(vector-ref)) 'internal:vector-ref/imm (if (memv .temp|48|51 '(string-ref)) 'internal:string-ref/imm #f))))))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2imm/setreg) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs|3) (.t2|27|33 (let* ((.t1|37|40 .imm|3) (.t2|37|43 (cons .rd|3 '()))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2imm/setreg|2 .as|1 .op|1 .rs|1 .imm|1 .rd|1 .tail|1))))) 'peep-reg/op2imm/setreg))
+(let () (begin (set! reg-op1-branchf (lambda (.as|1 .i:reg|1 .i:op1|1 .i:branchf|1 .tail|1) (let ((.reg-op1-branchf|2 0)) (begin (set! .reg-op1-branchf|2 (lambda (.as|3 .i:reg|3 .i:op1|3 .i:branchf|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.op|6 (operand1 .i:op1|3)) (.l|6 (operand1 .i:branchf|3))) (if (hwreg? .rs|6) (peep-reg/op1/branchf .as|3 .op|6 .rs|6 .l|6 .tail|3) (unspecified))))) (.reg-op1-branchf|2 .as|1 .i:reg|1 .i:op1|1 .i:branchf|1 .tail|1))))) 'reg-op1-branchf))
+(let () (begin (set! op1-branchf (lambda (.as|1 .i:op1|1 .i:branchf|1 .tail|1) (let ((.op1-branchf|2 0)) (begin (set! .op1-branchf|2 (lambda (.as|3 .i:op1|3 .i:branchf|3 .tail|3) (let ((.op|6 (operand1 .i:op1|3)) (.l|6 (operand1 .i:branchf|3))) (peep-reg/op1/branchf .as|3 .op|6 'result .l|6 .tail|3)))) (.op1-branchf|2 .as|1 .i:op1|1 .i:branchf|1 .tail|1))))) 'op1-branchf))
+(let () (begin (set! peep-reg/op1/branchf (lambda (.as|1 .op|1 .rs|1 .l|1 .tail|1) (let ((.peep-reg/op1/branchf|2 0)) (begin (set! .peep-reg/op1/branchf|2 (lambda (.as|3 .op|3 .rs|3 .l|3 .tail|3) (let ((.op|6 (let ((.temp|38|41 .op|3)) (if (memv .temp|38|41 '(null?)) 'internal:branchf-null? (if (memv .temp|38|41 '(pair?)) 'internal:branchf-pair? (if (memv .temp|38|41 '(zero?)) 'internal:branchf-zero? (if (memv .temp|38|41 '(eof-object?)) 'internal:branchf-eof-object? (if (memv .temp|38|41 '(fixnum?)) 'internal:branchf-fixnum? (if (memv .temp|38|41 '(char?)) 'internal:branchf-char? (if (memv .temp|38|41 '(fxzero?)) 'internal:branchf-fxzero? (if (memv .temp|38|41 '(fxnegative?)) 'internal:branchf-fxnegative? (if (memv .temp|38|41 '(fxpositive?)) 'internal:branchf-fxpositive? #f)))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op1/branchf) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs|3) (.t2|27|33 (cons .l|3 '()))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op1/branchf|2 .as|1 .op|1 .rs|1 .l|1 .tail|1))))) 'peep-reg/op1/branchf))
+(let () (begin (set! reg-op2-branchf (lambda (.as|1 .i:reg|1 .i:op2|1 .i:branchf|1 .tail|1) (let ((.reg-op2-branchf|2 0)) (begin (set! .reg-op2-branchf|2 (lambda (.as|3 .i:reg|3 .i:op2|3 .i:branchf|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.rs2|6 (operand2 .i:op2|3)) (.op|6 (operand1 .i:op2|3)) (.l|6 (operand1 .i:branchf|3))) (if (hwreg? .rs1|6) (peep-reg/op2/branchf .as|3 .op|6 .rs1|6 .rs2|6 .l|6 .tail|3) (unspecified))))) (.reg-op2-branchf|2 .as|1 .i:reg|1 .i:op2|1 .i:branchf|1 .tail|1))))) 'reg-op2-branchf))
+(let () (begin (set! op2-branchf (lambda (.as|1 .i:op2|1 .i:branchf|1 .tail|1) (let ((.op2-branchf|2 0)) (begin (set! .op2-branchf|2 (lambda (.as|3 .i:op2|3 .i:branchf|3 .tail|3) (let ((.op|6 (operand1 .i:op2|3)) (.rs2|6 (operand2 .i:op2|3)) (.l|6 (operand1 .i:branchf|3))) (peep-reg/op2/branchf .as|3 .op|6 'result .rs2|6 .l|6 .tail|3)))) (.op2-branchf|2 .as|1 .i:op2|1 .i:branchf|1 .tail|1))))) 'op2-branchf))
+(let () (begin (set! peep-reg/op2/branchf (lambda (.as|1 .op|1 .rs1|1 .rs2|1 .l|1 .tail|1) (let ((.peep-reg/op2/branchf|2 0)) (begin (set! .peep-reg/op2/branchf|2 (lambda (.as|3 .op|3 .rs1|3 .rs2|3 .l|3 .tail|3) (let ((.op|6 (let ((.temp|48|51 .op|3)) (if (memv .temp|48|51 '(<)) 'internal:branchf-< (if (memv .temp|48|51 '(>)) 'internal:branchf-> (if (memv .temp|48|51 '(>=)) 'internal:branchf->= (if (memv .temp|48|51 '(<=)) 'internal:branchf-<= (if (memv .temp|48|51 '(=)) 'internal:branchf-= (if (memv .temp|48|51 '(eq?)) 'internal:branchf-eq? (if (memv .temp|48|51 '(char=?)) 'internal:branchf-char=? (if (memv .temp|48|51 '(char>=?)) 'internal:branchf-char>=? (if (memv .temp|48|51 '(char>?)) 'internal:branchf-char>? (if (memv .temp|48|51 '(char<=?)) 'internal:branchf-char<=? (if (memv .temp|48|51 '(char<?)) 'internal:branchf-char<? (if (memv .temp|48|51 '(fx=)) 'internal:branchf-fx= (if (memv .temp|48|51 '(fx>)) 'internal:branchf-fx> (if (memv .temp|48|51 '(fx>=)) 'internal:branchf-fx>= (if (memv .temp|48|51 '(fx<)) 'internal:branchf-fx< (if (memv .temp|48|51 '(fx<=)) 'internal:branchf-fx<= #f))))))))))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2/branchf) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs1|3) (.t2|27|33 (let* ((.t1|37|40 .rs2|3) (.t2|37|43 (cons .l|3 '()))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2/branchf|2 .as|1 .op|1 .rs1|1 .rs2|1 .l|1 .tail|1))))) 'peep-reg/op2/branchf))
+(let () (begin (set! reg-op2imm-branchf (lambda (.as|1 .i:reg|1 .i:op2imm|1 .i:branchf|1 .tail|1) (let ((.reg-op2imm-branchf|2 0)) (begin (set! .reg-op2imm-branchf|2 (lambda (.as|3 .i:reg|3 .i:op2imm|3 .i:branchf|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.imm|6 (operand2 .i:op2imm|3)) (.op|6 (operand1 .i:op2imm|3)) (.l|6 (operand1 .i:branchf|3))) (if (hwreg? .rs|6) (peep-reg/op2imm/branchf .as|3 .op|6 .rs|6 .imm|6 .l|6 .tail|3) (unspecified))))) (.reg-op2imm-branchf|2 .as|1 .i:reg|1 .i:op2imm|1 .i:branchf|1 .tail|1))))) 'reg-op2imm-branchf))
+(let () (begin (set! op2imm-branchf (lambda (.as|1 .i:op2imm|1 .i:branchf|1 .tail|1) (let ((.op2imm-branchf|2 0)) (begin (set! .op2imm-branchf|2 (lambda (.as|3 .i:op2imm|3 .i:branchf|3 .tail|3) (let ((.op|6 (operand1 .i:op2imm|3)) (.imm|6 (operand2 .i:op2imm|3)) (.l|6 (operand1 .i:branchf|3))) (peep-reg/op2imm/branchf .as|3 .op|6 'result .imm|6 .l|6 .tail|3)))) (.op2imm-branchf|2 .as|1 .i:op2imm|1 .i:branchf|1 .tail|1))))) 'op2imm-branchf))
+(let () (begin (set! peep-reg/op2imm/branchf (lambda (.as|1 .op|1 .rs|1 .imm|1 .l|1 .tail|1) (let ((.peep-reg/op2imm/branchf|2 0)) (begin (set! .peep-reg/op2imm/branchf|2 (lambda (.as|3 .op|3 .rs|3 .imm|3 .l|3 .tail|3) (let ((.op|6 (let ((.temp|48|51 .op|3)) (if (memv .temp|48|51 '(<)) 'internal:branchf-</imm (if (memv .temp|48|51 '(>)) 'internal:branchf->/imm (if (memv .temp|48|51 '(>=)) 'internal:branchf->=/imm (if (memv .temp|48|51 '(<=)) 'internal:branchf-<=/imm (if (memv .temp|48|51 '(=)) 'internal:branchf-=/imm (if (memv .temp|48|51 '(eq?)) 'internal:branchf-eq?/imm (if (memv .temp|48|51 '(char=?)) 'internal:branchf-char=?/imm (if (memv .temp|48|51 '(char>=?)) 'internal:branchf-char>=?/imm (if (memv .temp|48|51 '(char>?)) 'internal:branchf-char>?/imm (if (memv .temp|48|51 '(char<=?)) 'internal:branchf-char<=?/imm (if (memv .temp|48|51 '(char<?)) 'internal:branchf-char<?/imm (if (memv .temp|48|51 '(fx=)) 'internal:branchf-fx=/imm (if (memv .temp|48|51 '(fx>)) 'internal:branchf-fx>/imm (if (memv .temp|48|51 '(fx>=)) 'internal:branchf-fx>=/imm (if (memv .temp|48|51 '(fx<)) 'internal:branchf-fx</imm (if (memv .temp|48|51 '(fx<=)) 'internal:branchf-fx<=/imm #f))))))))))))))))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2imm/branchf) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs|3) (.t2|27|33 (let* ((.t1|37|40 .imm|3) (.t2|37|43 (cons .l|3 '()))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2imm/branchf|2 .as|1 .op|1 .rs|1 .imm|1 .l|1 .tail|1))))) 'peep-reg/op2imm/branchf))
+(let () (begin (set! reg-op1-check (lambda (.as|1 .i:reg|1 .i:op1|1 .i:check|1 .tail|1) (let ((.reg-op1-check|2 0)) (begin (set! .reg-op1-check|2 (lambda (.as|3 .i:reg|3 .i:op1|3 .i:check|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.op|6 (operand1 .i:op1|3))) (if (hwreg? .rs|6) (peep-reg/op1/check .as|3 .op|6 .rs|6 (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3) (unspecified))))) (.reg-op1-check|2 .as|1 .i:reg|1 .i:op1|1 .i:check|1 .tail|1))))) 'reg-op1-check))
+(let () (begin (set! op1-check (lambda (.as|1 .i:op1|1 .i:check|1 .tail|1) (let ((.op1-check|2 0)) (begin (set! .op1-check|2 (lambda (.as|3 .i:op1|3 .i:check|3 .tail|3) (let ((.op|6 (operand1 .i:op1|3))) (peep-reg/op1/check .as|3 .op|6 'result (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)))) (.op1-check|2 .as|1 .i:op1|1 .i:check|1 .tail|1))))) 'op1-check))
+(let () (begin (set! peep-reg/op1/check (lambda (.as|1 .op|1 .rs|1 .l1|1 .liveregs|1 .tail|1) (let ((.peep-reg/op1/check|2 0)) (begin (set! .peep-reg/op1/check|2 (lambda (.as|3 .op|3 .rs|3 .l1|3 .liveregs|3 .tail|3) (let ((.op|6 (let ((.temp|48|51 .op|3)) (if (memv .temp|48|51 '(fixnum?)) 'internal:check-fixnum? (if (memv .temp|48|51 '(pair?)) 'internal:check-pair? (if (memv .temp|48|51 '(vector?)) 'internal:check-vector? #f)))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op1/check) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs|3) (.t2|27|33 (let* ((.t1|37|40 .l1|3) (.t2|37|43 (cons .liveregs|3 '()))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op1/check|2 .as|1 .op|1 .rs|1 .l1|1 .liveregs|1 .tail|1))))) 'peep-reg/op1/check))
+(let () (begin (set! reg-op2-check (lambda (.as|1 .i:reg|1 .i:op2|1 .i:check|1 .tail|1) (let ((.reg-op2-check|2 0)) (begin (set! .reg-op2-check|2 (lambda (.as|3 .i:reg|3 .i:op2|3 .i:check|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.rs2|6 (operand2 .i:op2|3)) (.op|6 (operand1 .i:op2|3))) (if (hwreg? .rs1|6) (peep-reg/op2/check .as|3 .op|6 .rs1|6 .rs2|6 (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3) (unspecified))))) (.reg-op2-check|2 .as|1 .i:reg|1 .i:op2|1 .i:check|1 .tail|1))))) 'reg-op2-check))
+(let () (begin (set! op2-check (lambda (.as|1 .i:op2|1 .i:check|1 .tail|1) (let ((.op2-check|2 0)) (begin (set! .op2-check|2 (lambda (.as|3 .i:op2|3 .i:check|3 .tail|3) (let ((.rs2|6 (operand2 .i:op2|3)) (.op|6 (operand1 .i:op2|3))) (peep-reg/op2/check .as|3 .op|6 'result .rs2|6 (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)))) (.op2-check|2 .as|1 .i:op2|1 .i:check|1 .tail|1))))) 'op2-check))
+(let () (begin (set! peep-reg/op2/check (lambda (.as|1 .op|1 .rs1|1 .rs2|1 .l1|1 .liveregs|1 .tail|1) (let ((.peep-reg/op2/check|2 0)) (begin (set! .peep-reg/op2/check|2 (lambda (.as|3 .op|3 .rs1|3 .rs2|3 .l1|3 .liveregs|3 .tail|3) (let ((.op|6 (let ((.temp|58|61 .op|3)) (if (memv .temp|58|61 '(<:fix:fix)) 'internal:check-<:fix:fix (if (memv .temp|58|61 '(<=:fix:fix)) 'internal:check-<=:fix:fix (if (memv .temp|58|61 '(>=:fix:fix)) 'internal:check->=:fix:fix #f)))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2/check) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs1|3) (.t2|27|33 (let* ((.t1|37|40 .rs2|3) (.t2|37|43 (let* ((.t1|47|50 .l1|3) (.t2|47|53 (cons .liveregs|3 '()))) (let () (cons .t1|47|50 .t2|47|53))))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2/check|2 .as|1 .op|1 .rs1|1 .rs2|1 .l1|1 .liveregs|1 .tail|1))))) 'peep-reg/op2/check))
+(let () (begin (set! reg-op2imm-check (lambda (.as|1 .i:reg|1 .i:op2imm|1 .i:check|1 .tail|1) (let ((.reg-op2imm-check|2 0)) (begin (set! .reg-op2imm-check|2 (lambda (.as|3 .i:reg|3 .i:op2imm|3 .i:check|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.op|6 (operand1 .i:op2imm|3)) (.imm|6 (operand2 .i:op2imm|3))) (if (hwreg? .rs1|6) (peep-reg/op2imm/check .as|3 .op|6 .rs1|6 .imm|6 (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3) (unspecified))))) (.reg-op2imm-check|2 .as|1 .i:reg|1 .i:op2imm|1 .i:check|1 .tail|1))))) 'reg-op2imm-check))
+(let () (begin (set! op2imm-check (lambda (.as|1 .i:op2imm|1 .i:check|1 .tail|1) (let ((.op2imm-check|2 0)) (begin (set! .op2imm-check|2 (lambda (.as|3 .i:op2imm|3 .i:check|3 .tail|3) (let ((.op|6 (operand1 .i:op2imm|3)) (.imm|6 (operand2 .i:op2imm|3))) (peep-reg/op2imm/check .as|3 .op|6 'result .imm|6 (operand4 .i:check|3) (let* ((.t1|7|10 (operand1 .i:check|3)) (.t2|7|13 (let* ((.t1|17|20 (operand2 .i:check|3)) (.t2|17|23 (cons (operand3 .i:check|3) '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)))) (.op2imm-check|2 .as|1 .i:op2imm|1 .i:check|1 .tail|1))))) 'op2imm-check))
+(let () (begin (set! peep-reg/op2imm/check (lambda (.as|1 .op|1 .rs1|1 .imm|1 .l1|1 .liveregs|1 .tail|1) (let ((.peep-reg/op2imm/check|2 0)) (begin (set! .peep-reg/op2imm/check|2 (lambda (.as|3 .op|3 .rs1|3 .imm|3 .l1|3 .liveregs|3 .tail|3) (let ((.op|6 (let ((.temp|58|61 .op|3)) (if (memv .temp|58|61 '(<:fix:fix)) 'internal:check-<:fix:fix/imm (if (memv .temp|58|61 '(<=:fix:fix)) 'internal:check-<=:fix:fix/imm (if (memv .temp|58|61 '(>=:fix:fix)) 'internal:check->=:fix:fix/imm #f)))))) (if .op|6 (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/op2imm/check) (.t2|7|13 (let* ((.t1|17|20 .op|6) (.t2|17|23 (let* ((.t1|27|30 .rs1|3) (.t2|27|33 (let* ((.t1|37|40 .imm|3) (.t2|37|43 (let* ((.t1|47|50 .l1|3) (.t2|47|53 (cons .liveregs|3 '()))) (let () (cons .t1|47|50 .t2|47|53))))) (let () (cons .t1|37|40 .t2|37|43))))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.peep-reg/op2imm/check|2 .as|1 .op|1 .rs1|1 .imm|1 .l1|1 .liveregs|1 .tail|1))))) 'peep-reg/op2imm/check))
+(let () (begin (set! reg/op1/check-reg-op1-setreg (lambda (.as|1 .i:ro1check|1 .i:reg|1 .i:op1|1 .i:setreg|1 .tail|1) (let ((.reg/op1/check-reg-op1-setreg|2 0)) (begin (set! .reg/op1/check-reg-op1-setreg|2 (lambda (.as|3 .i:ro1check|3 .i:reg|3 .i:op1|3 .i:setreg|3 .tail|3) (let ((.o1|6 (operand1 .i:ro1check|3)) (.r1|6 (operand2 .i:ro1check|3)) (.r2|6 (operand1 .i:reg|3)) (.o2|6 (operand1 .i:op1|3)) (.r3|6 (operand1 .i:setreg|3))) (if (if (eq? .o1|6 'internal:check-vector?) (if (eq? .r1|6 .r2|6) (if (eq? .o2|6 'vector-length:vec) (if (hwreg? .r1|6) (hwreg? .r3|6) #f) #f) #f) #f) (as-source! .as|3 (cons (let* ((.t1|12|15 $reg/op2/check) (.t2|12|18 (let* ((.t1|22|25 'internal:check-vector?/vector-length:vec) (.t2|22|28 (let* ((.t1|32|35 .r1|6) (.t2|32|38 (let* ((.t1|42|45 .r3|6) (.t2|42|48 (let* ((.t1|52|55 (operand3 .i:ro1check|3)) (.t2|52|58 (cons (operand4 .i:ro1check|3) '()))) (let () (cons .t1|52|55 .t2|52|58))))) (let () (cons .t1|42|45 .t2|42|48))))) (let () (cons .t1|32|35 .t2|32|38))))) (let () (cons .t1|22|25 .t2|22|28))))) (let () (cons .t1|12|15 .t2|12|18))) .tail|3)) (unspecified))))) (.reg/op1/check-reg-op1-setreg|2 .as|1 .i:ro1check|1 .i:reg|1 .i:op1|1 .i:setreg|1 .tail|1))))) 'reg/op1/check-reg-op1-setreg))
+(let () (begin (set! reg/op2/check-reg-op2imm-check (lambda (.as|1 .i:ro2check|1 .i:reg|1 .i:op2imm|1 .i:check|1 .tail|1) (let ((.reg/op2/check-reg-op2imm-check|2 0)) (begin (set! .reg/op2/check-reg-op2imm-check|2 (lambda (.as|3 .i:ro2check|3 .i:reg|3 .i:op2imm|3 .i:check|3 .tail|3) (let ((.o1|6 (operand1 .i:ro2check|3)) (.rs1|6 (operand2 .i:ro2check|3)) (.rs2|6 (operand3 .i:ro2check|3)) (.l1|6 (operand4 .i:ro2check|3)) (.live|6 (operand5 .i:ro2check|3)) (.rs3|6 (operand1 .i:reg|3)) (.o2|6 (operand1 .i:op2imm|3)) (.x|6 (operand2 .i:op2imm|3)) (.l2|6 (operand4 .i:check|3))) (if (if (eq? .o1|6 'internal:check-<:fix:fix) (if (eq? .o2|6 '>=:fix:fix) (if (eq? .rs1|6 .rs3|6) (if (eq? .x|6 0) (eq? .l1|6 .l2|6) #f) #f) #f) #f) (as-source! .as|3 (cons (let* ((.t1|12|15 $reg/op2/check) (.t2|12|18 (let* ((.t1|22|25 'internal:check-range) (.t2|22|28 (let* ((.t1|32|35 .rs1|6) (.t2|32|38 (let* ((.t1|42|45 .rs2|6) (.t2|42|48 (let* ((.t1|52|55 .l1|6) (.t2|52|58 (cons .live|6 '()))) (let () (cons .t1|52|55 .t2|52|58))))) (let () (cons .t1|42|45 .t2|42|48))))) (let () (cons .t1|32|35 .t2|32|38))))) (let () (cons .t1|22|25 .t2|22|28))))) (let () (cons .t1|12|15 .t2|12|18))) .tail|3)) (unspecified))))) (.reg/op2/check-reg-op2imm-check|2 .as|1 .i:ro2check|1 .i:reg|1 .i:op2imm|1 .i:check|1 .tail|1))))) 'reg/op2/check-reg-op2imm-check))
+(let () (begin (set! reg-op3 (lambda (.as|1 .i:reg|1 .i:op3|1 .tail|1) (let ((.reg-op3|2 0)) (begin (set! .reg-op3|2 (lambda (.as|3 .i:reg|3 .i:op3|3 .tail|3) (let ((.rs1|6 (operand1 .i:reg|3)) (.rs2|6 (operand2 .i:op3|3)) (.rs3|6 (operand3 .i:op3|3)) (.op|6 (operand1 .i:op3|3))) (if (hwreg? .rs1|6) (let ((.op|9 (let ((.temp|51|54 .op|6)) (if (memv .temp|51|54 '(vector-set!)) 'internal:vector-set! (if (memv .temp|51|54 '(string-set!)) 'internal:string-set! #f))))) (if .op|9 (as-source! .as|3 (cons (let* ((.t1|10|13 $reg/op3) (.t2|10|16 (let* ((.t1|20|23 .op|9) (.t2|20|26 (let* ((.t1|30|33 .rs1|6) (.t2|30|36 (let* ((.t1|40|43 .rs2|6) (.t2|40|46 (cons .rs3|6 '()))) (let () (cons .t1|40|43 .t2|40|46))))) (let () (cons .t1|30|33 .t2|30|36))))) (let () (cons .t1|20|23 .t2|20|26))))) (let () (cons .t1|10|13 .t2|10|16))) .tail|3)) (unspecified))) (unspecified))))) (.reg-op3|2 .as|1 .i:reg|1 .i:op3|1 .tail|1))))) 'reg-op3))
+(let () (begin (set! reg-setreg (lambda (.as|1 .i:reg|1 .i:setreg|1 .tail|1) (let ((.reg-setreg|2 0)) (begin (set! .reg-setreg|2 (lambda (.as|3 .i:reg|3 .i:setreg|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.rd|6 (operand1 .i:setreg|3))) (if (= .rs|6 .rd|6) (as-source! .as|3 .tail|3) (as-source! .as|3 (cons (let* ((.t1|7|10 $movereg) (.t2|7|13 (let* ((.t1|17|20 .rs|6) (.t2|17|23 (cons .rd|6 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)))))) (.reg-setreg|2 .as|1 .i:reg|1 .i:setreg|1 .tail|1))))) 'reg-setreg))
+(let () (begin (set! reg-branchf (lambda (.as|1 .i:reg|1 .i:branchf|1 .tail|1) (let ((.reg-branchf|2 0)) (begin (set! .reg-branchf|2 (lambda (.as|3 .i:reg|3 .i:branchf|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.l|6 (operand1 .i:branchf|3))) (if (hwreg? .rs|6) (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/branchf) (.t2|7|13 (let* ((.t1|17|20 .rs|6) (.t2|17|23 (cons .l|6 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.reg-branchf|2 .as|1 .i:reg|1 .i:branchf|1 .tail|1))))) 'reg-branchf))
+(let () (begin (set! const-setreg (lambda (.as|1 .i:const|1 .i:setreg|1 .tail|1) (let ((.const-setreg|2 0)) (begin (set! .const-setreg|2 (lambda (.as|3 .i:const|3 .i:setreg|3 .tail|3) (let ((.c|6 (operand1 .i:const|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rd|6) (as-source! .as|3 (cons (let* ((.t1|7|10 $const/setreg) (.t2|7|13 (let* ((.t1|17|20 .c|6) (.t2|17|23 (cons .rd|6 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.const-setreg|2 .as|1 .i:const|1 .i:setreg|1 .tail|1))))) 'const-setreg))
+(let () (begin (set! const-op2 (lambda (.as|1 .i:const|1 .i:op2|1 .tail|1) (let ((.const-op2|2 0)) (begin (set! .const-op2|2 (lambda (.as|3 .i:const|3 .i:op2|3 .tail|3) (let ((.vn|6 '#(make-vector:0 make-vector:1 make-vector:2 make-vector:3 make-vector:4 make-vector:5 make-vector:6 make-vector:7 make-vector:8 make-vector:9)) (.c|6 (operand1 .i:const|3)) (.op|6 (operand1 .i:op2|3)) (.r|6 (operand2 .i:op2|3))) (if (if (eq? .op|6 'make-vector) (if (fixnum? .c|6) (let ((.t|10|13 .c|6)) (if (<= 0 .t|10|13) (<= .t|10|13 9) #f)) #f) #f) (as-source! .as|3 (cons (let* ((.t1|16|19 $op2) (.t2|16|22 (let* ((.t1|26|29 (let ((.v|37|40 .vn|6) (.i|37|40 .c|6)) (begin (.check! (fixnum? .i|37|40) 40 .v|37|40 .i|37|40) (.check! (vector? .v|37|40) 40 .v|37|40 .i|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 40 .v|37|40 .i|37|40) (.check! (>=:fix:fix .i|37|40 0) 40 .v|37|40 .i|37|40) (vector-ref:trusted .v|37|40 .i|37|40)))) (.t2|26|32 (cons .r|6 '()))) (let () (cons .t1|26|29 .t2|26|32))))) (let () (cons .t1|16|19 .t2|16|22))) .tail|3)) (unspecified))))) (.const-op2|2 .as|1 .i:const|1 .i:op2|1 .tail|1))))) 'const-op2))
+(let () (begin (set! const-return (lambda (.as|1 .i:const|1 .i:return|1 .tail|1) (let ((.const-return|2 0)) (begin (set! .const-return|2 (lambda (.as|3 .i:const|3 .i:return|3 .tail|3) (let ((.c|6 (operand1 .i:const|3))) (if (let ((.temp|7|10 (if (number? .c|6) (immediate-int? .c|6) #f))) (if .temp|7|10 .temp|7|10 (let ((.temp|11|14 (null? .c|6))) (if .temp|11|14 .temp|11|14 (boolean? .c|6))))) (as-source! .as|3 (cons (let* ((.t1|18|21 $const/return) (.t2|18|24 (cons .c|6 '()))) (let () (cons .t1|18|21 .t2|18|24))) .tail|3)) (unspecified))))) (.const-return|2 .as|1 .i:const|1 .i:return|1 .tail|1))))) 'const-return))
+(let () (begin (set! setrtn-branch (lambda (.as|1 .i:setrtn|1 .i:branch|1 .i:align|1 .i:label|1 .tail|1) (let ((.setrtn-branch|2 0)) (begin (set! .setrtn-branch|2 (lambda (.as|3 .i:setrtn|3 .i:branch|3 .i:align|3 .i:label|3 .tail|3) (let ((.return-label|6 (operand1 .i:setrtn|3)) (.branch-ops|6 (let ((.x|7|10 .i:branch|3)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (.label|6 (operand1 .i:label|3))) (if (= .return-label|6 .label|6) (as-source! .as|3 (cons (cons $setrtn/branch .branch-ops|6) (cons .i:label|3 .tail|3))) (unspecified))))) (.setrtn-branch|2 .as|1 .i:setrtn|1 .i:branch|1 .i:align|1 .i:label|1 .tail|1))))) 'setrtn-branch))
+(let () (begin (set! setrtn-invoke (lambda (.as|1 .i:setrtn|1 .i:invoke|1 .i:align|1 .i:label|1 .tail|1) (let ((.setrtn-invoke|2 0)) (begin (set! .setrtn-invoke|2 (lambda (.as|3 .i:setrtn|3 .i:invoke|3 .i:align|3 .i:label|3 .tail|3) (let ((.return-label|6 (operand1 .i:setrtn|3)) (.invoke-ops|6 (operand1 .i:invoke|3)) (.label|6 (operand1 .i:label|3))) (if (if #f (= .return-label|6 .label|6) #f) (as-source! .as|3 (cons (cons $setrtn/invoke .invoke-ops|6) (cons .i:label|3 .tail|3))) (unspecified))))) (.setrtn-invoke|2 .as|1 .i:setrtn|1 .i:invoke|1 .i:align|1 .i:label|1 .tail|1))))) 'setrtn-invoke))
+(let () (begin (set! branch-and-label (lambda (.as|1 .i:branch|1 .i:align|1 .i:label|1 .tail|1) (let ((.branch-and-label|2 0)) (begin (set! .branch-and-label|2 (lambda (.as|3 .i:branch|3 .i:align|3 .i:label|3 .tail|3) (let ((.branch-label|6 (operand1 .i:branch|3)) (.label|6 (operand1 .i:label|3))) (if (= .branch-label|6 .label|6) (as-source! .as|3 (cons .i:align|3 (cons .i:label|3 .tail|3))) (unspecified))))) (.branch-and-label|2 .as|1 .i:branch|1 .i:align|1 .i:label|1 .tail|1))))) 'branch-and-label))
+(let () (begin (set! global-setreg (lambda (.as|1 .i:global|1 .i:setreg|1 .tail|1) (let ((.global-setreg|2 0)) (begin (set! .global-setreg|2 (lambda (.as|3 .i:global|3 .i:setreg|3 .tail|3) (let ((.global|6 (operand1 .i:global|3)) (.rd|6 (operand1 .i:setreg|3))) (if (hwreg? .rd|6) (as-source! .as|3 (cons (let* ((.t1|7|10 $global/setreg) (.t2|7|13 (let* ((.t1|17|20 .global|6) (.t2|17|23 (cons .rd|6 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.global-setreg|2 .as|1 .i:global|1 .i:setreg|1 .tail|1))))) 'global-setreg))
+(let () (begin (set! global-invoke (lambda (.as|1 .i:global|1 .i:invoke|1 .tail|1) (let ((.global-invoke|2 0)) (begin (set! .global-invoke|2 (lambda (.as|3 .i:global|3 .i:invoke|3 .tail|3) (let ((.global|6 (operand1 .i:global|3)) (.argc|6 (operand1 .i:invoke|3))) (if (not (if (unsafe-code) (catch-undefined-globals) #f)) (as-source! .as|3 (cons (let* ((.t1|9|12 $global/invoke) (.t2|9|15 (let* ((.t1|19|22 .global|6) (.t2|19|25 (cons .argc|6 '()))) (let () (cons .t1|19|22 .t2|19|25))))) (let () (cons .t1|9|12 .t2|9|15))) .tail|3)) (unspecified))))) (.global-invoke|2 .as|1 .i:global|1 .i:invoke|1 .tail|1))))) 'global-invoke))
+(let () (begin (set! global-setrtn-invoke (lambda (.as|1 .i:global|1 .i:setrtn|1 .i:invoke|1 .tail|1) (let ((.global-setrtn-invoke|2 0)) (begin (set! .global-setrtn-invoke|2 (lambda (.as|3 .i:global|3 .i:setrtn|3 .i:invoke|3 .tail|3) (let ((.global|6 (operand1 .i:global|3)) (.argc|6 (operand1 .i:invoke|3))) (if (not (if (unsafe-code) (catch-undefined-globals) #f)) (as-source! .as|3 (cons .i:setrtn|3 (cons (let* ((.t1|9|12 $global/invoke) (.t2|9|15 (let* ((.t1|19|22 .global|6) (.t2|19|25 (cons .argc|6 '()))) (let () (cons .t1|19|22 .t2|19|25))))) (let () (cons .t1|9|12 .t2|9|15))) .tail|3))) (unspecified))))) (.global-setrtn-invoke|2 .as|1 .i:global|1 .i:setrtn|1 .i:invoke|1 .tail|1))))) 'global-setrtn-invoke))
+(let () (begin (set! reg-setglbl (lambda (.as|1 .i:reg|1 .i:setglbl|1 .tail|1) (let ((.reg-setglbl|2 0)) (begin (set! .reg-setglbl|2 (lambda (.as|3 .i:reg|3 .i:setglbl|3 .tail|3) (let ((.rs|6 (operand1 .i:reg|3)) (.global|6 (operand1 .i:setglbl|3))) (if (hwreg? .rs|6) (as-source! .as|3 (cons (let* ((.t1|7|10 $reg/setglbl) (.t2|7|13 (let* ((.t1|17|20 .rs|6) (.t2|17|23 (cons .global|6 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))) .tail|3)) (unspecified))))) (.reg-setglbl|2 .as|1 .i:reg|1 .i:setglbl|1 .tail|1))))) 'reg-setglbl))
+(let () (begin (set! peeptest (lambda (.istream|1) (let ((.peeptest|2 0)) (begin (set! .peeptest|2 (lambda (.istream|3) (let* ((.as|6 (make-assembly-structure .istream|3)) (.l|9 '())) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.l|13) (if (null? (as-source .as|6)) (reverse .l|13) (begin (peep .as|6) (let ((.a|16 (let ((.x|21|24 (as-source .as|6))) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (begin (as-source! .as|6 (let ((.x|17|20 (as-source .as|6))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20)))) (.loop|12 (cons .a|16 .l|13)))))))) (.loop|12 .l|9))))))) (.peeptest|2 .istream|1))))) 'peeptest))
+(let () (begin (set! roundup8 (lambda (.n|1) (let ((.roundup8|2 0)) (begin (set! .roundup8|2 (lambda (.n|3) (* (quotient (+ .n|3 7) 8) 8))) (.roundup8|2 .n|1))))) 'roundup8))
+(let () (begin (set! regname (let ((.v|3 (let* ((.t|9|41|46 $r.reg31) (.t|9|40|49 $r.reg30) (.t|9|39|52 $r.reg29) (.t|9|38|55 $r.reg28) (.t|9|37|58 $r.reg27) (.t|9|36|61 $r.reg26) (.t|9|35|64 $r.reg25) (.t|9|34|67 $r.reg24) (.t|9|33|70 $r.reg23) (.t|9|32|73 $r.reg22) (.t|9|31|76 $r.reg21) (.t|9|30|79 $r.reg20) (.t|9|29|82 $r.reg19) (.t|9|28|85 $r.reg18) (.t|9|27|88 $r.reg17) (.t|9|26|91 $r.reg16) (.t|9|25|94 $r.reg15) (.t|9|24|97 $r.reg14) (.t|9|23|100 $r.reg13) (.t|9|22|103 $r.reg12) (.t|9|21|106 $r.reg11) (.t|9|20|109 $r.reg10) (.t|9|19|112 $r.reg9) (.t|9|18|115 $r.reg8) (.t|9|17|118 $r.reg7) (.t|9|16|121 $r.reg6) (.t|9|15|124 $r.reg5) (.t|9|14|127 $r.reg4) (.t|9|13|130 $r.reg3) (.t|9|12|133 $r.reg2) (.t|9|11|136 $r.reg1) (.t|9|10|139 $r.reg0) (.v|9|43|142 (make-vector 32 .t|9|41|46))) (let () (begin (let ((.v|146|149 .v|9|43|142) (.i|146|149 30) (.x|146|149 .t|9|40|49)) (begin (.check! (fixnum? .i|146|149) 41 .v|146|149 .i|146|149 .x|146|149) (.check! (vector? .v|146|149) 41 .v|146|149 .i|146|149 .x|146|149) (.check! (<:fix:fix .i|146|149 (vector-length:vec .v|146|149)) 41 .v|146|149 .i|146|149 .x|146|149) (.check! (>=:fix:fix .i|146|149 0) 41 .v|146|149 .i|146|149 .x|146|149) (vector-set!:trusted .v|146|149 .i|146|149 .x|146|149))) (let ((.v|150|153 .v|9|43|142) (.i|150|153 29) (.x|150|153 .t|9|39|52)) (begin (.check! (fixnum? .i|150|153) 41 .v|150|153 .i|150|153 .x|150|153) (.check! (vector? .v|150|153) 41 .v|150|153 .i|150|153 .x|150|153) (.check! (<:fix:fix .i|150|153 (vector-length:vec .v|150|153)) 41 .v|150|153 .i|150|153 .x|150|153) (.check! (>=:fix:fix .i|150|153 0) 41 .v|150|153 .i|150|153 .x|150|153) (vector-set!:trusted .v|150|153 .i|150|153 .x|150|153))) (let ((.v|154|157 .v|9|43|142) (.i|154|157 28) (.x|154|157 .t|9|38|55)) (begin (.check! (fixnum? .i|154|157) 41 .v|154|157 .i|154|157 .x|154|157) (.check! (vector? .v|154|157) 41 .v|154|157 .i|154|157 .x|154|157) (.check! (<:fix:fix .i|154|157 (vector-length:vec .v|154|157)) 41 .v|154|157 .i|154|157 .x|154|157) (.check! (>=:fix:fix .i|154|157 0) 41 .v|154|157 .i|154|157 .x|154|157) (vector-set!:trusted .v|154|157 .i|154|157 .x|154|157))) (let ((.v|158|161 .v|9|43|142) (.i|158|161 27) (.x|158|161 .t|9|37|58)) (begin (.check! (fixnum? .i|158|161) 41 .v|158|161 .i|158|161 .x|158|161) (.check! (vector? .v|158|161) 41 .v|158|161 .i|158|161 .x|158|161) (.check! (<:fix:fix .i|158|161 (vector-length:vec .v|158|161)) 41 .v|158|161 .i|158|161 .x|158|161) (.check! (>=:fix:fix .i|158|161 0) 41 .v|158|161 .i|158|161 .x|158|161) (vector-set!:trusted .v|158|161 .i|158|161 .x|158|161))) (let ((.v|162|165 .v|9|43|142) (.i|162|165 26) (.x|162|165 .t|9|36|61)) (begin (.check! (fixnum? .i|162|165) 41 .v|162|165 .i|162|165 .x|162|165) (.check! (vector? .v|162|165) 41 .v|162|165 .i|162|165 .x|162|165) (.check! (<:fix:fix .i|162|165 (vector-length:vec .v|162|165)) 41 .v|162|165 .i|162|165 .x|162|165) (.check! (>=:fix:fix .i|162|165 0) 41 .v|162|165 .i|162|165 .x|162|165) (vector-set!:trusted .v|162|165 .i|162|165 .x|162|165))) (let ((.v|166|169 .v|9|43|142) (.i|166|169 25) (.x|166|169 .t|9|35|64)) (begin (.check! (fixnum? .i|166|169) 41 .v|166|169 .i|166|169 .x|166|169) (.check! (vector? .v|166|169) 41 .v|166|169 .i|166|169 .x|166|169) (.check! (<:fix:fix .i|166|169 (vector-length:vec .v|166|169)) 41 .v|166|169 .i|166|169 .x|166|169) (.check! (>=:fix:fix .i|166|169 0) 41 .v|166|169 .i|166|169 .x|166|169) (vector-set!:trusted .v|166|169 .i|166|169 .x|166|169))) (let ((.v|170|173 .v|9|43|142) (.i|170|173 24) (.x|170|173 .t|9|34|67)) (begin (.check! (fixnum? .i|170|173) 41 .v|170|173 .i|170|173 .x|170|173) (.check! (vector? .v|170|173) 41 .v|170|173 .i|170|173 .x|170|173) (.check! (<:fix:fix .i|170|173 (vector-length:vec .v|170|173)) 41 .v|170|173 .i|170|173 .x|170|173) (.check! (>=:fix:fix .i|170|173 0) 41 .v|170|173 .i|170|173 .x|170|173) (vector-set!:trusted .v|170|173 .i|170|173 .x|170|173))) (let ((.v|174|177 .v|9|43|142) (.i|174|177 23) (.x|174|177 .t|9|33|70)) (begin (.check! (fixnum? .i|174|177) 41 .v|174|177 .i|174|177 .x|174|177) (.check! (vector? .v|174|177) 41 .v|174|177 .i|174|177 .x|174|177) (.check! (<:fix:fix .i|174|177 (vector-length:vec .v|174|177)) 41 .v|174|177 .i|174|177 .x|174|177) (.check! (>=:fix:fix .i|174|177 0) 41 .v|174|177 .i|174|177 .x|174|177) (vector-set!:trusted .v|174|177 .i|174|177 .x|174|177))) (let ((.v|178|181 .v|9|43|142) (.i|178|181 22) (.x|178|181 .t|9|32|73)) (begin (.check! (fixnum? .i|178|181) 41 .v|178|181 .i|178|181 .x|178|181) (.check! (vector? .v|178|181) 41 .v|178|181 .i|178|181 .x|178|181) (.check! (<:fix:fix .i|178|181 (vector-length:vec .v|178|181)) 41 .v|178|181 .i|178|181 .x|178|181) (.check! (>=:fix:fix .i|178|181 0) 41 .v|178|181 .i|178|181 .x|178|181) (vector-set!:trusted .v|178|181 .i|178|181 .x|178|181))) (let ((.v|182|185 .v|9|43|142) (.i|182|185 21) (.x|182|185 .t|9|31|76)) (begin (.check! (fixnum? .i|182|185) 41 .v|182|185 .i|182|185 .x|182|185) (.check! (vector? .v|182|185) 41 .v|182|185 .i|182|185 .x|182|185) (.check! (<:fix:fix .i|182|185 (vector-length:vec .v|182|185)) 41 .v|182|185 .i|182|185 .x|182|185) (.check! (>=:fix:fix .i|182|185 0) 41 .v|182|185 .i|182|185 .x|182|185) (vector-set!:trusted .v|182|185 .i|182|185 .x|182|185))) (let ((.v|186|189 .v|9|43|142) (.i|186|189 20) (.x|186|189 .t|9|30|79)) (begin (.check! (fixnum? .i|186|189) 41 .v|186|189 .i|186|189 .x|186|189) (.check! (vector? .v|186|189) 41 .v|186|189 .i|186|189 .x|186|189) (.check! (<:fix:fix .i|186|189 (vector-length:vec .v|186|189)) 41 .v|186|189 .i|186|189 .x|186|189) (.check! (>=:fix:fix .i|186|189 0) 41 .v|186|189 .i|186|189 .x|186|189) (vector-set!:trusted .v|186|189 .i|186|189 .x|186|189))) (let ((.v|190|193 .v|9|43|142) (.i|190|193 19) (.x|190|193 .t|9|29|82)) (begin (.check! (fixnum? .i|190|193) 41 .v|190|193 .i|190|193 .x|190|193) (.check! (vector? .v|190|193) 41 .v|190|193 .i|190|193 .x|190|193) (.check! (<:fix:fix .i|190|193 (vector-length:vec .v|190|193)) 41 .v|190|193 .i|190|193 .x|190|193) (.check! (>=:fix:fix .i|190|193 0) 41 .v|190|193 .i|190|193 .x|190|193) (vector-set!:trusted .v|190|193 .i|190|193 .x|190|193))) (let ((.v|194|197 .v|9|43|142) (.i|194|197 18) (.x|194|197 .t|9|28|85)) (begin (.check! (fixnum? .i|194|197) 41 .v|194|197 .i|194|197 .x|194|197) (.check! (vector? .v|194|197) 41 .v|194|197 .i|194|197 .x|194|197) (.check! (<:fix:fix .i|194|197 (vector-length:vec .v|194|197)) 41 .v|194|197 .i|194|197 .x|194|197) (.check! (>=:fix:fix .i|194|197 0) 41 .v|194|197 .i|194|197 .x|194|197) (vector-set!:trusted .v|194|197 .i|194|197 .x|194|197))) (let ((.v|198|201 .v|9|43|142) (.i|198|201 17) (.x|198|201 .t|9|27|88)) (begin (.check! (fixnum? .i|198|201) 41 .v|198|201 .i|198|201 .x|198|201) (.check! (vector? .v|198|201) 41 .v|198|201 .i|198|201 .x|198|201) (.check! (<:fix:fix .i|198|201 (vector-length:vec .v|198|201)) 41 .v|198|201 .i|198|201 .x|198|201) (.check! (>=:fix:fix .i|198|201 0) 41 .v|198|201 .i|198|201 .x|198|201) (vector-set!:trusted .v|198|201 .i|198|201 .x|198|201))) (let ((.v|202|205 .v|9|43|142) (.i|202|205 16) (.x|202|205 .t|9|26|91)) (begin (.check! (fixnum? .i|202|205) 41 .v|202|205 .i|202|205 .x|202|205) (.check! (vector? .v|202|205) 41 .v|202|205 .i|202|205 .x|202|205) (.check! (<:fix:fix .i|202|205 (vector-length:vec .v|202|205)) 41 .v|202|205 .i|202|205 .x|202|205) (.check! (>=:fix:fix .i|202|205 0) 41 .v|202|205 .i|202|205 .x|202|205) (vector-set!:trusted .v|202|205 .i|202|205 .x|202|205))) (let ((.v|206|209 .v|9|43|142) (.i|206|209 15) (.x|206|209 .t|9|25|94)) (begin (.check! (fixnum? .i|206|209) 41 .v|206|209 .i|206|209 .x|206|209) (.check! (vector? .v|206|209) 41 .v|206|209 .i|206|209 .x|206|209) (.check! (<:fix:fix .i|206|209 (vector-length:vec .v|206|209)) 41 .v|206|209 .i|206|209 .x|206|209) (.check! (>=:fix:fix .i|206|209 0) 41 .v|206|209 .i|206|209 .x|206|209) (vector-set!:trusted .v|206|209 .i|206|209 .x|206|209))) (let ((.v|210|213 .v|9|43|142) (.i|210|213 14) (.x|210|213 .t|9|24|97)) (begin (.check! (fixnum? .i|210|213) 41 .v|210|213 .i|210|213 .x|210|213) (.check! (vector? .v|210|213) 41 .v|210|213 .i|210|213 .x|210|213) (.check! (<:fix:fix .i|210|213 (vector-length:vec .v|210|213)) 41 .v|210|213 .i|210|213 .x|210|213) (.check! (>=:fix:fix .i|210|213 0) 41 .v|210|213 .i|210|213 .x|210|213) (vector-set!:trusted .v|210|213 .i|210|213 .x|210|213))) (let ((.v|214|217 .v|9|43|142) (.i|214|217 13) (.x|214|217 .t|9|23|100)) (begin (.check! (fixnum? .i|214|217) 41 .v|214|217 .i|214|217 .x|214|217) (.check! (vector? .v|214|217) 41 .v|214|217 .i|214|217 .x|214|217) (.check! (<:fix:fix .i|214|217 (vector-length:vec .v|214|217)) 41 .v|214|217 .i|214|217 .x|214|217) (.check! (>=:fix:fix .i|214|217 0) 41 .v|214|217 .i|214|217 .x|214|217) (vector-set!:trusted .v|214|217 .i|214|217 .x|214|217))) (let ((.v|218|221 .v|9|43|142) (.i|218|221 12) (.x|218|221 .t|9|22|103)) (begin (.check! (fixnum? .i|218|221) 41 .v|218|221 .i|218|221 .x|218|221) (.check! (vector? .v|218|221) 41 .v|218|221 .i|218|221 .x|218|221) (.check! (<:fix:fix .i|218|221 (vector-length:vec .v|218|221)) 41 .v|218|221 .i|218|221 .x|218|221) (.check! (>=:fix:fix .i|218|221 0) 41 .v|218|221 .i|218|221 .x|218|221) (vector-set!:trusted .v|218|221 .i|218|221 .x|218|221))) (let ((.v|222|225 .v|9|43|142) (.i|222|225 11) (.x|222|225 .t|9|21|106)) (begin (.check! (fixnum? .i|222|225) 41 .v|222|225 .i|222|225 .x|222|225) (.check! (vector? .v|222|225) 41 .v|222|225 .i|222|225 .x|222|225) (.check! (<:fix:fix .i|222|225 (vector-length:vec .v|222|225)) 41 .v|222|225 .i|222|225 .x|222|225) (.check! (>=:fix:fix .i|222|225 0) 41 .v|222|225 .i|222|225 .x|222|225) (vector-set!:trusted .v|222|225 .i|222|225 .x|222|225))) (let ((.v|226|229 .v|9|43|142) (.i|226|229 10) (.x|226|229 .t|9|20|109)) (begin (.check! (fixnum? .i|226|229) 41 .v|226|229 .i|226|229 .x|226|229) (.check! (vector? .v|226|229) 41 .v|226|229 .i|226|229 .x|226|229) (.check! (<:fix:fix .i|226|229 (vector-length:vec .v|226|229)) 41 .v|226|229 .i|226|229 .x|226|229) (.check! (>=:fix:fix .i|226|229 0) 41 .v|226|229 .i|226|229 .x|226|229) (vector-set!:trusted .v|226|229 .i|226|229 .x|226|229))) (let ((.v|230|233 .v|9|43|142) (.i|230|233 9) (.x|230|233 .t|9|19|112)) (begin (.check! (fixnum? .i|230|233) 41 .v|230|233 .i|230|233 .x|230|233) (.check! (vector? .v|230|233) 41 .v|230|233 .i|230|233 .x|230|233) (.check! (<:fix:fix .i|230|233 (vector-length:vec .v|230|233)) 41 .v|230|233 .i|230|233 .x|230|233) (.check! (>=:fix:fix .i|230|233 0) 41 .v|230|233 .i|230|233 .x|230|233) (vector-set!:trusted .v|230|233 .i|230|233 .x|230|233))) (let ((.v|234|237 .v|9|43|142) (.i|234|237 8) (.x|234|237 .t|9|18|115)) (begin (.check! (fixnum? .i|234|237) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (vector? .v|234|237) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (<:fix:fix .i|234|237 (vector-length:vec .v|234|237)) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (>=:fix:fix .i|234|237 0) 41 .v|234|237 .i|234|237 .x|234|237) (vector-set!:trusted .v|234|237 .i|234|237 .x|234|237))) (let ((.v|238|241 .v|9|43|142) (.i|238|241 7) (.x|238|241 .t|9|17|118)) (begin (.check! (fixnum? .i|238|241) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (vector? .v|238|241) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (<:fix:fix .i|238|241 (vector-length:vec .v|238|241)) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (>=:fix:fix .i|238|241 0) 41 .v|238|241 .i|238|241 .x|238|241) (vector-set!:trusted .v|238|241 .i|238|241 .x|238|241))) (let ((.v|242|245 .v|9|43|142) (.i|242|245 6) (.x|242|245 .t|9|16|121)) (begin (.check! (fixnum? .i|242|245) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (vector? .v|242|245) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (<:fix:fix .i|242|245 (vector-length:vec .v|242|245)) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (>=:fix:fix .i|242|245 0) 41 .v|242|245 .i|242|245 .x|242|245) (vector-set!:trusted .v|242|245 .i|242|245 .x|242|245))) (let ((.v|246|249 .v|9|43|142) (.i|246|249 5) (.x|246|249 .t|9|15|124)) (begin (.check! (fixnum? .i|246|249) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (vector? .v|246|249) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (<:fix:fix .i|246|249 (vector-length:vec .v|246|249)) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (>=:fix:fix .i|246|249 0) 41 .v|246|249 .i|246|249 .x|246|249) (vector-set!:trusted .v|246|249 .i|246|249 .x|246|249))) (let ((.v|250|253 .v|9|43|142) (.i|250|253 4) (.x|250|253 .t|9|14|127)) (begin (.check! (fixnum? .i|250|253) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (vector? .v|250|253) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (<:fix:fix .i|250|253 (vector-length:vec .v|250|253)) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (>=:fix:fix .i|250|253 0) 41 .v|250|253 .i|250|253 .x|250|253) (vector-set!:trusted .v|250|253 .i|250|253 .x|250|253))) (let ((.v|254|257 .v|9|43|142) (.i|254|257 3) (.x|254|257 .t|9|13|130)) (begin (.check! (fixnum? .i|254|257) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (vector? .v|254|257) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (<:fix:fix .i|254|257 (vector-length:vec .v|254|257)) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (>=:fix:fix .i|254|257 0) 41 .v|254|257 .i|254|257 .x|254|257) (vector-set!:trusted .v|254|257 .i|254|257 .x|254|257))) (let ((.v|258|261 .v|9|43|142) (.i|258|261 2) (.x|258|261 .t|9|12|133)) (begin (.check! (fixnum? .i|258|261) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (vector? .v|258|261) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (<:fix:fix .i|258|261 (vector-length:vec .v|258|261)) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (>=:fix:fix .i|258|261 0) 41 .v|258|261 .i|258|261 .x|258|261) (vector-set!:trusted .v|258|261 .i|258|261 .x|258|261))) (let ((.v|262|265 .v|9|43|142) (.i|262|265 1) (.x|262|265 .t|9|11|136)) (begin (.check! (fixnum? .i|262|265) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (vector? .v|262|265) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (<:fix:fix .i|262|265 (vector-length:vec .v|262|265)) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (>=:fix:fix .i|262|265 0) 41 .v|262|265 .i|262|265 .x|262|265) (vector-set!:trusted .v|262|265 .i|262|265 .x|262|265))) (let ((.v|266|269 .v|9|43|142) (.i|266|269 0) (.x|266|269 .t|9|10|139)) (begin (.check! (fixnum? .i|266|269) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (vector? .v|266|269) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (<:fix:fix .i|266|269 (vector-length:vec .v|266|269)) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (>=:fix:fix .i|266|269 0) 41 .v|266|269 .i|266|269 .x|266|269) (vector-set!:trusted .v|266|269 .i|266|269 .x|266|269))) .v|9|43|142))))) (lambda (.r|4) (let ((.v|5|8 .v|3) (.i|5|8 .r|4)) (begin (.check! (fixnum? .i|5|8) 40 .v|5|8 .i|5|8) (.check! (vector? .v|5|8) 40 .v|5|8 .i|5|8) (.check! (<:fix:fix .i|5|8 (vector-length:vec .v|5|8)) 40 .v|5|8 .i|5|8) (.check! (>=:fix:fix .i|5|8 0) 40 .v|5|8 .i|5|8) (vector-ref:trusted .v|5|8 .i|5|8)))))) 'regname))
+(let () (begin (set! hardware-mapped? (lambda (.r|1) (let ((.hardware-mapped?|2 0)) (begin (set! .hardware-mapped?|2 (lambda (.r|3) (let ((.temp|4|7 (if (>= .r|3 $r.reg0) (<= .r|3 $r.reg7) #f))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (= .r|3 $r.argreg2))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (= .r|3 $r.argreg3))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (= .r|3 $r.result))) (if .temp|16|19 .temp|16|19 (let ((.temp|20|23 (= .r|3 $r.g0))) (if .temp|20|23 .temp|20|23 (let ((.temp|24|27 (= .r|3 $r.tmp0))) (if .temp|24|27 .temp|24|27 (let ((.temp|28|31 (= .r|3 $r.tmp1))) (if .temp|28|31 .temp|28|31 (= .r|3 $r.tmp2))))))))))))))))) (.hardware-mapped?|2 .r|1))))) 'hardware-mapped?))
+(let () (begin (set! hwreg? (lambda (.x|1) (let ((.hwreg?|2 0)) (begin (set! .hwreg?|2 (lambda (.x|3) (let ((.t|4|7 .x|3)) (if (<= 0 .t|4|7) (<= .t|4|7 7) #f)))) (.hwreg?|2 .x|1))))) 'hwreg?))
+(let () (begin (set! immediate-int? (lambda (.x|1) (let ((.immediate-int?|2 0)) (begin (set! .immediate-int?|2 (lambda (.x|3) (if (exact? .x|3) (if (integer? .x|3) (let ((.t|7|10 .x|3)) (if (<= -1024 .t|7|10) (<= .t|7|10 1023) #f)) #f) #f))) (.immediate-int?|2 .x|1))))) 'immediate-int?))
+(let () (begin (set! fixnum-range? (let ((.-two^29|3 (- 0 (expt 2 29))) (.two^29-1|3 (- (expt 2 29) 1))) (lambda (.x|4) (let ((.t|5|8 .x|4)) (if (<= .-two^29|3 .t|5|8) (<= .t|5|8 .two^29-1|3) #f))))) 'fixnum-range?))
+(let () (begin (set! immediate-literal? (lambda (.x|1) (let ((.immediate-literal?|2 0)) (begin (set! .immediate-literal?|2 (lambda (.x|3) (let ((.t|4|7 .x|3)) (if (<= -4096 .t|4|7) (<= .t|4|7 4095) #f)))) (.immediate-literal?|2 .x|1))))) 'immediate-literal?))
+(let () (begin (set! swreg-global-offset (lambda (.r|1) (let ((.swreg-global-offset|2 0)) (begin (set! .swreg-global-offset|2 (lambda (.r|3) .r|3)) (.swreg-global-offset|2 .r|1))))) 'swreg-global-offset))
+(let () (begin (set! char->immediate (lambda (.c|1) (let ((.char->immediate|2 0)) (begin (set! .char->immediate|2 (lambda (.c|3) (+ (* (char->integer .c|3) 65536) $imm.character))) (.char->immediate|2 .c|1))))) 'char->immediate))
+(let () (begin (set! thefixnum (lambda (.x|1) (let ((.thefixnum|2 0)) (begin (set! .thefixnum|2 (lambda (.x|3) (* .x|3 4))) (.thefixnum|2 .x|1))))) 'thefixnum))
+(let () (begin (set! procedure-slot-offset (lambda (.n|1) (let ((.procedure-slot-offset|2 0)) (begin (set! .procedure-slot-offset|2 (lambda (.n|3) (+ 12 (* .n|3 4)))) (.procedure-slot-offset|2 .n|1))))) 'procedure-slot-offset))
+(let () (begin (set! force-hwreg! (lambda (.as|1 .src|1 .hwreg|1) (let ((.force-hwreg!|2 0)) (begin (set! .force-hwreg!|2 (lambda (.as|3 .src|3 .hwreg|3) (if (hardware-mapped? .src|3) .src|3 (emit-load-reg! .as|3 .src|3 .hwreg|3)))) (.force-hwreg!|2 .as|1 .src|1 .hwreg|1))))) 'force-hwreg!))
+(let () (begin (set! emit-constant->register (lambda (.as|1 .opd|1 .r|1) (let ((.emit-constant->register|2 0)) (begin (set! .emit-constant->register|2 (lambda (.as|3 .opd|3 .r|3) (if (if (integer? .opd|3) (exact? .opd|3) #f) (if (fixnum-range? .opd|3) (emit-immediate->register! .as|3 (thefixnum .opd|3) .r|3) (emit-const->register! .as|3 (emit-datum .as|3 .opd|3) .r|3)) (if (boolean? .opd|3) (emit-immediate->register! .as|3 (if (eq? .opd|3 #t) $imm.true $imm.false) .r|3) (if (equal? .opd|3 (eof-object)) (emit-immediate->register! .as|3 $imm.eof .r|3) (if (equal? .opd|3 (unspecified)) (emit-immediate->register! .as|3 $imm.unspecified .r|3) (if (equal? .opd|3 (undefined)) (emit-immediate->register! .as|3 $imm.undefined .r|3) (if (null? .opd|3) (emit-immediate->register! .as|3 $imm.null .r|3) (if (char? .opd|3) (emit-immediate->register! .as|3 (char->immediate .opd|3) .r|3) (emit-const->register! .as|3 (emit-datum .as|3 .opd|3) .r|3)))))))))) (.emit-constant->register|2 .as|1 .opd|1 .r|1))))) 'emit-constant->register))
+(let () (begin (set! emit-immediate->register! (lambda (.as|1 .i|1 .r|1) (let ((.emit-immediate->register!|2 0)) (begin (set! .emit-immediate->register!|2 (lambda (.as|3 .i|3 .r|3) (let ((.dest|6 (if (not (hardware-mapped? .r|3)) $r.tmp0 .r|3))) (begin (if (if (number? .i|3) (immediate-literal? .i|3) #f) (sparc.set .as|3 .i|3 .dest|6) (if (if (number? .i|3) (zero? (remainder (let ((.temp|13|16 .i|3)) (if (< .temp|13|16 0) (-- .temp|13|16) .temp|13|16)) 1024)) #f) (sparc.sethi .as|3 (.cons 'hi (.cons .i|3 '())) .dest|6) (begin (sparc.sethi .as|3 (.cons 'hi (.cons .i|3 '())) .dest|6) (sparc.ori .as|3 .dest|6 (.cons 'lo (.cons .i|3 '())) .dest|6)))) (if (not (hardware-mapped? .r|3)) (emit-store-reg! .as|3 .r|3 .dest|6) (unspecified)))))) (.emit-immediate->register!|2 .as|1 .i|1 .r|1))))) 'emit-immediate->register!))
+(let () (begin (set! emit-const->register! (lambda (.as|1 .offset|1 .r|1) (let ((.emit-const->register!|2 0)) (begin (set! .emit-const->register!|2 (lambda (.as|3 .offset|3 .r|3) (let ((.cvlabel|6 (+ 4 (- (* .offset|3 4) $tag.vector-tag)))) (if (hardware-mapped? .r|3) (begin (sparc.ldi .as|3 $r.reg0 $p.constvector $r.tmp0) (if (asm:fits? .cvlabel|6 13) (sparc.ldi .as|3 $r.tmp0 .cvlabel|6 .r|3) (begin (sparc.sethi .as|3 (.cons 'hi (.cons .cvlabel|6 '())) $r.tmp1) (sparc.addr .as|3 $r.tmp0 $r.tmp1 $r.tmp0) (sparc.ldi .as|3 $r.tmp0 (.cons 'lo (.cons .cvlabel|6 '())) .r|3)))) (begin (.emit-const->register!|2 .as|3 .offset|3 $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .r|3)))))) (.emit-const->register!|2 .as|1 .offset|1 .r|1))))) 'emit-const->register!))
+(let () (begin (set! emit-load-reg! (lambda (.as|1 .from|1 .to|1) (let ((.emit-load-reg!|2 0)) (begin (set! .emit-load-reg!|2 (lambda (.as|3 .from|3 .to|3) (if (let ((.temp|4|7 (hardware-mapped? .from|3))) (if .temp|4|7 .temp|4|7 (not (hardware-mapped? .to|3)))) (asm-error "emit-load-reg: " .from|3 .to|3) (begin (sparc.ldi .as|3 $r.globals (swreg-global-offset .from|3) .to|3) .to|3)))) (.emit-load-reg!|2 .as|1 .from|1 .to|1))))) 'emit-load-reg!))
+(let () (begin (set! emit-store-reg! (lambda (.as|1 .from|1 .to|1) (let ((.emit-store-reg!|2 0)) (begin (set! .emit-store-reg!|2 (lambda (.as|3 .from|3 .to|3) (if (let ((.temp|4|7 (not (hardware-mapped? .from|3)))) (if .temp|4|7 .temp|4|7 (hardware-mapped? .to|3))) (asm-error "emit-store-reg: " .from|3 .to|3) (begin (sparc.sti .as|3 .from|3 (swreg-global-offset .to|3) $r.globals) .to|3)))) (.emit-store-reg!|2 .as|1 .from|1 .to|1))))) 'emit-store-reg!))
+(let () (begin (set! emit-move2hwreg! (lambda (.as|1 .from|1 .to|1) (let ((.emit-move2hwreg!|2 0)) (begin (set! .emit-move2hwreg!|2 (lambda (.as|3 .from|3 .to|3) (begin (if (hardware-mapped? .from|3) (sparc.move .as|3 .from|3 .to|3) (emit-load-reg! .as|3 .from|3 .to|3)) .to|3))) (.emit-move2hwreg!|2 .as|1 .from|1 .to|1))))) 'emit-move2hwreg!))
+(let () (begin (set! emit-evaluate-cc! (lambda (.as|1 .branchf.a|1 .rd|1 .target|1) (let ((.emit-evaluate-cc!|2 0)) (begin (set! .emit-evaluate-cc!|2 (lambda (.as|3 .branchf.a|3 .rd|3 .target|3) (if .target|3 (begin (.branchf.a|3 .as|3 .target|3) (sparc.slot .as|3)) (let ((.target|6 (new-label))) (begin (.branchf.a|3 .as|3 .target|6) (sparc.set .as|3 $imm.false .rd|3) (sparc.set .as|3 $imm.true .rd|3) (sparc.label .as|3 .target|6)))))) (.emit-evaluate-cc!|2 .as|1 .branchf.a|1 .rd|1 .target|1))))) 'emit-evaluate-cc!))
+(let () (begin (set! emit-check! (lambda (.as|1 .rs0|1 .l1|1 .liveregs|1) (let ((.emit-check!|2 0)) (begin (set! .emit-check!|2 (lambda (.as|3 .rs0|3 .l1|3 .liveregs|3) (begin (sparc.cmpi .as|3 .rs0|3 $imm.false) (emit-checkcc! .as|3 sparc.be .l1|3 .liveregs|3)))) (.emit-check!|2 .as|1 .rs0|1 .l1|1 .liveregs|1))))) 'emit-check!))
+(let () (begin (set! emit-trap! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1 .exn|1) (let ((.emit-trap!|2 0)) (begin (set! .emit-trap!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rs3|3 .exn|3) (begin (if (not (= .rs3|3 $r.reg0)) (emit-move2hwreg! .as|3 .rs3|3 $r.argreg3) (unspecified)) (if (not (= .rs2|3 $r.reg0)) (emit-move2hwreg! .as|3 .rs2|3 $r.argreg2) (unspecified)) (if (not (= .rs1|3 $r.reg0)) (emit-move2hwreg! .as|3 .rs1|3 $r.result) (unspecified)) (millicode-call/numarg-in-reg .as|3 $m.exception (thefixnum .exn|3) $r.tmp0)))) (.emit-trap!|2 .as|1 .rs1|1 .rs2|1 .rs3|1 .exn|1))))) 'emit-trap!))
+(let () (begin '(define (emit-checkcc-and-fill-slot! as branch-ok.a branch-bad slot-filler l1) (let* ((situation (list exn rs1 rs2 rs3)) (l1 (exception-label as situation))) (if l1 (begin (branch-bad as l1) (if slot-filler (slot-filler as) (sparc.nop as))) (let* ((l1 (new-label)) (l2 (new-label))) (exception-label-set! as situation l1) (branch-ok.a as l2) (if slot-filler (slot-filler as) (sparc.slot as)) (sparc.label as l1) (cond ((= rs3 $r.reg0) #f) ((hardware-mapped? $r.argreg3) (emit-move2hwreg! as rs3 $r.argreg3)) ((hardware-mapped? rs3) (emit-store-reg! as rs3 $r.argreg3)) (else (emit-move2hwreg! as rs3 $r.tmp0) (emit-store-reg! as $r.tmp0 $r.argreg3))) (if (not (= rs2 $r.reg0)) (emit-move2hwreg! as rs2 $r.argreg2)) (if (not (= rs1 $r.reg0)) (emit-move2hwreg! as rs1 $r.result)) (sparc.jmpli as $r.millicode $m.exception $r.o7) (emit-immediate->register! as (thefixnum exn) $r.tmp0) (sparc.label as l2))))) #f))
+(let () (begin (set! emit-checkcc! (lambda (.as|1 .branch-bad|1 .l1|1 .liveregs|1) (let ((.emit-checkcc!|2 0)) (begin (set! .emit-checkcc!|2 (lambda (.as|3 .branch-bad|3 .l1|3 .liveregs|3) (begin (.branch-bad|3 .as|3 .l1|3) (apply sparc.slot2 .as|3 .liveregs|3)))) (.emit-checkcc!|2 .as|1 .branch-bad|1 .l1|1 .liveregs|1))))) 'emit-checkcc!))
+(let () (begin '(define (exception-label as situation) (let ((user-data (as-user as))) (if user-data (let ((exception-labels (assq 'exception-labels user-data))) (if exception-labels (let ((probe (assoc situation (cdr exception-labels)))) (if probe (cdr probe) #f)) #f)) #f))) '(define (exception-label-set! as situation label) (let ((user-data (as-user as))) (if user-data (let ((exception-labels (assq 'exception-labels user-data))) (if exception-labels (let ((probe (assoc situation (cdr exception-labels)))) (if probe (error "COMPILER BUG: Exception situation defined twice") (set-cdr! exception-labels (cons (cons situation label) (cdr exception-labels))))) (begin (as-user! as (cons (list 'exception-labels) user-data)) (exception-label-set! as situation label)))) (begin (as-user! as '()) (exception-label-set! as situation label))))) #f))
+(let () (begin (set! millicode-call/0arg (lambda (.as|1 .mproc|1) (let ((.millicode-call/0arg|2 0)) (begin (set! .millicode-call/0arg|2 (lambda (.as|3 .mproc|3) (begin (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (sparc.nop .as|3)))) (.millicode-call/0arg|2 .as|1 .mproc|1))))) 'millicode-call/0arg))
+(let () (begin (set! millicode-call/1arg (lambda (.as|1 .mproc|1 .r|1) (let ((.millicode-call/1arg|2 0)) (begin (set! .millicode-call/1arg|2 (lambda (.as|3 .mproc|3 .r|3) (begin (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (emit-move2hwreg! .as|3 .r|3 $r.argreg2)))) (.millicode-call/1arg|2 .as|1 .mproc|1 .r|1))))) 'millicode-call/1arg))
+(let () (begin (set! millicode-call/1arg-in-result (lambda (.as|1 .mproc|1 .r|1) (let ((.millicode-call/1arg-in-result|2 0)) (begin (set! .millicode-call/1arg-in-result|2 (lambda (.as|3 .mproc|3 .r|3) (millicode-call/1arg-in-reg .as|3 .mproc|3 .r|3 $r.result))) (.millicode-call/1arg-in-result|2 .as|1 .mproc|1 .r|1))))) 'millicode-call/1arg-in-result))
+(let () (begin (set! millicode-call/1arg-in-reg (lambda (.as|1 .mproc|1 .rs|1 .rd|1) (let ((.millicode-call/1arg-in-reg|2 0)) (begin (set! .millicode-call/1arg-in-reg|2 (lambda (.as|3 .mproc|3 .rs|3 .rd|3) (begin (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (emit-move2hwreg! .as|3 .rs|3 .rd|3)))) (.millicode-call/1arg-in-reg|2 .as|1 .mproc|1 .rs|1 .rd|1))))) 'millicode-call/1arg-in-reg))
+(let () (begin (set! millicode-call/numarg-in-result (lambda (.as|1 .mproc|1 .num|1) (let ((.millicode-call/numarg-in-result|2 0)) (begin (set! .millicode-call/numarg-in-result|2 (lambda (.as|3 .mproc|3 .num|3) (begin (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (sparc.set .as|3 .num|3 $r.result)))) (.millicode-call/numarg-in-result|2 .as|1 .mproc|1 .num|1))))) 'millicode-call/numarg-in-result))
+(let () (begin (set! millicode-call/numarg-in-reg (lambda (.as|1 .mproc|1 .num|1 .reg|1) (let ((.millicode-call/numarg-in-reg|2 0)) (begin (set! .millicode-call/numarg-in-reg|2 (lambda (.as|3 .mproc|3 .num|3 .reg|3) (begin (if (not (hardware-mapped? .reg|3)) (asm-error "millicode-call/numarg-in-reg requires HW register: " .reg|3) (unspecified)) (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (sparc.set .as|3 .num|3 .reg|3)))) (.millicode-call/numarg-in-reg|2 .as|1 .mproc|1 .num|1 .reg|1))))) 'millicode-call/numarg-in-reg))
+(let () (begin (set! millicode-call/2arg (lambda (.as|1 .mproc|1 .r1|1 .r2|1) (let ((.millicode-call/2arg|2 0)) (begin (set! .millicode-call/2arg|2 (lambda (.as|3 .mproc|3 .r1|3 .r2|3) (begin (emit-move2hwreg! .as|3 .r1|3 $r.argreg2) (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (emit-move2hwreg! .as|3 .r2|3 $r.argreg3)))) (.millicode-call/2arg|2 .as|1 .mproc|1 .r1|1 .r2|1))))) 'millicode-call/2arg))
+(let () (begin (set! millicode-call/ret (lambda (.as|1 .mproc|1 .label|1) (let ((.millicode-call/ret|2 0)) (begin (set! .millicode-call/ret|2 (lambda (.as|3 .mproc|3 .label|3) (if (short-effective-addresses) (begin (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (sparc.addi .as|3 $r.o7 (.cons '- (.cons .label|3 (.cons (.cons '- (.cons (here .as|3) '(4))) '(8)))) $r.o7)) (let ((.val|68 (.cons '- (.cons .label|3 (.cons (.cons '+ (.cons (here .as|3) '(8))) '(8)))))) (begin (sparc.sethi .as|3 (.cons 'hi (.cons .val|68 '())) $r.tmp1) (sparc.ori .as|3 $r.tmp1 (.cons 'lo (.cons .val|68 '())) $r.tmp1) (sparc.jmpli .as|3 $r.millicode .mproc|3 $r.o7) (sparc.addr .as|3 $r.o7 $r.tmp1 $r.o7)))))) (.millicode-call/ret|2 .as|1 .mproc|1 .label|1))))) 'millicode-call/ret))
+(let () (begin (set! check-timer (lambda (.as|1 .destination|1 .retry|1) (let ((.check-timer|2 0)) (begin (set! .check-timer|2 (lambda (.as|3 .destination|3 .retry|3) (begin (sparc.subicc .as|3 $r.timer 1 $r.timer) (sparc.bne.a .as|3 .destination|3) (sparc.slot .as|3) (millicode-call/ret .as|3 $m.timer-exception .retry|3)))) (.check-timer|2 .as|1 .destination|1 .retry|1))))) 'check-timer))
+(let () (begin (set! check-timer0 (lambda (.as|1) (let ((.check-timer0|2 0)) (begin (set! .check-timer0|2 (lambda (.as|3) (begin (sparc.subicc .as|3 $r.timer 1 $r.timer) (sparc.bne.a .as|3 (+ (here .as|3) 16)) (sparc.slot .as|3) (sparc.jmpli .as|3 $r.millicode $m.timer-exception $r.o7) (sparc.nop .as|3)))) (.check-timer0|2 .as|1))))) 'check-timer0))
+(let () (begin (set! sparc-instruction (undefined)) 'sparc-instruction))
+(let () (let ((.original-emit-label!|3 emit-label!) (.original-here|3 here)) (begin (set! emit-label! (lambda (.as|4 .l|4) (begin (assembler-value! .as|4 'slot2-info #f) (.original-emit-label!|3 .as|4 .l|4)))) (set! here (lambda (.as|5) (begin (assembler-value! .as|5 'slot2-info #f) (.original-here|3 .as|5)))) 'emit-label!)))
+(let () (let ((.emit!|3 (lambda (.as|567 .bits|567) (begin (assembler-value! .as|567 'slot2-info #f) (emit! .as|567 .bits|567)))) (.emit-fixup-proc!|3 (lambda (.as|568 .proc|568) (begin (assembler-value! .as|568 'slot2-info #f) (emit-fixup-proc! .as|568 .proc|568)))) (.goes-in-delay-slot2?|3 (lambda (.as|569 .rd|569) (let ((.regs|572 (assembler-value .as|569 'slot2-info))) (if .regs|572 (if (fill-delay-slots) (if (not (= .rd|569 $r.stkp)) (if (not (= .rd|569 $r.o7)) (not (memv .rd|569 .regs|572)) #f) #f) #f) #f))))) (let ((.fpop|4 (unspecified)) (.class-fpop2|4 (unspecified)) (.class-fpop1|4 (unspecified)) (.class-label|4 (unspecified)) (.class-call|4 (unspecified)) (.class11si|4 (unspecified)) (.class11sr|4 (unspecified)) (.class11i|4 (unspecified)) (.class11r|4 (unspecified)) (.class10i|4 (unspecified)) (.class10r|4 (unspecified)) (.class-slot2|4 (unspecified)) (.class-slot|4 (unspecified)) (.branch|4 (unspecified)) (.classf00a|4 (unspecified)) (.classf00b|4 (unspecified)) (.class00a|4 (unspecified)) (.class00b|4 (unspecified)) (.class-nop|4 (unspecified)) (.class-sethi|4 (unspecified)) (.is-a-delay-slot-instruction?|4 (unspecified)) (.not-a-delay-slot-instruction|4 (unspecified)) (.recover-branch-target|4 (unspecified)) (.remember-branch-target|4 (unspecified)) (.add1|4 (unspecified)) (.dep-call-offset!|4 (unspecified)) (.dep-imm22!|4 (unspecified)) (.dep-branch-offset!|4 (unspecified)) (.dep-imm!|4 (unspecified)) (.dep-rd!|4 (unspecified)) (.dep-rs2!|4 (unspecified)) (.dep-rs1!|4 (unspecified)) (.copy-instr|4 (unspecified)) (.copy|4 (unspecified)) (.copy!|4 (unspecified)) (.signal-error|4 (unspecified)) (.eval-expr|4 (unspecified)) (.two^32|4 (unspecified)) (.zero|4 (unspecified)) (.abit|4 (unspecified)) (.ibit|4 (unspecified))) (begin (set! .fpop|4 (lambda (.type|5 .opf|5) (let ((.bits|8 (asm:logior (asm:lsh 2 30) (asm:lsh .type|5 19) (asm:lsh .opf|5 5)))) (lambda (.as|9 .rs1|9 .rs2|9 .rd|9) (let ((.bits|12 (.copy|4 .bits|8))) (begin (.dep-rs1!|4 .bits|12 0 .rs1|9) (.dep-rs2!|4 .bits|12 0 .rs2|9) (.dep-rd!|4 .bits|12 0 .rd|9) (.emit!|3 .as|9 .bits|12))))))) (set! .class-fpop2|4 (lambda (.i|13) (.fpop|4 53 .i|13))) (set! .class-fpop1|4 (lambda (.i|14) (.fpop|4 52 .i|14))) (set! .class-label|4 (lambda () (lambda (.as|16 .label|16) (emit-label! .as|16 .label|16)))) (set! .class-call|4 (lambda () (let ((.code|20 (asm:lsh 1 30))) (lambda (.as|21 .target0|21) (let* ((.target|24 (.cons '- (.cons .target0|21 (.cons (here .as|21) '())))) (.fixup|27 (unspecified))) (begin (set! .fixup|27 (lambda (.bv|28 .loc|28) (let ((.e|31 (.eval-expr|4 .as|21 .target|24))) (if .e|31 (.dep-call-offset!|4 .bv|28 .loc|28 .e|31) (.signal-error|4 'fixup "call" .target0|21))))) (let ((.bits|32 (.copy|4 .code|20)) (.e|32 (.eval-expr|4 .as|21 .target|24))) (begin (.not-a-delay-slot-instruction|4 .as|21) (if .e|32 (.dep-call-offset!|4 .bits|32 0 .e|32) (.emit-fixup-proc!|3 .as|21 (lambda (.b|33 .l|33) (.fixup|27 .b|33 .l|33)))) (.emit!|3 .as|21 .bits|32))))))))) (set! .class11si|4 (lambda (.bits|66) (let ((.store-instr|69 (.class11i|4 .bits|66))) (lambda (.as|70 .a|70 .b|70 .c|70) (.store-instr|69 .as|70 .c|70 .b|70 .a|70))))) (set! .class11sr|4 (lambda (.bits|71) (let ((.store-instr|74 (.class11r|4 .bits|71))) (lambda (.as|75 .a|75 .b|75 .c|75) (.store-instr|74 .as|75 .c|75 .b|75 .a|75))))) (set! .class11i|4 (lambda (.bits|76) (let ((.bits|79 (asm:logior (asm:lsh 3 30) (asm:lsh .bits|76 19) .ibit|4))) (lambda (.as|80 .rs1|80 .e|80 .rd|80) (let ((.fixup|83 (unspecified)) (.expr|83 (unspecified))) (begin (set! .fixup|83 (lambda (.bv|84 .loc|84) (let ((.e|87 (.expr|83))) (if .e|87 (.dep-imm!|4 .bv|84 .loc|84 .e|87) (.signal-error|4 'fixup "Memory instruction" .e|87))))) (set! .expr|83 (lambda () (let ((.imm|91 (.eval-expr|4 .as|80 .e|80))) (if (not .imm|91) .imm|91 (if (asm:fits? .imm|91 13) .imm|91 (.signal-error|4 'toolarge "Memory instruction" .e|80 .imm|91)))))) (let ((.bits|95 (.copy|4 .bits|79)) (.e|95 (.expr|83))) (begin (.dep-rs1!|4 .bits|95 0 .rs1|80) (.dep-rd!|4 .bits|95 0 .rd|80) (if .e|95 (.dep-imm!|4 .bits|95 0 .e|95) (.emit-fixup-proc!|3 .as|80 (lambda (.b|96 .l|96) (.fixup|83 .b|96 .l|96)))) (.emit!|3 .as|80 .bits|95))))))))) (set! .class11r|4 (lambda (.bits|97) (let ((.bits|100 (asm:logior (asm:lsh 3 30) (asm:lsh .bits|97 19)))) (lambda (.as|101 .rs1|101 .rs2|101 .rd|101) (let ((.bits|104 (.copy|4 .bits|100))) (begin (.dep-rs1!|4 .bits|104 0 .rs1|101) (.dep-rs2!|4 .bits|104 0 .rs2|101) (.dep-rd!|4 .bits|104 0 .rd|101) (.emit!|3 .as|101 .bits|104))))))) (set! .class10i|4 (lambda (.bits|105 . .extra|105) (if (if (not (null? .extra|105)) (eq? (let ((.x|108|111 .extra|105)) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111))) 'wry) #f) (let ((.op|114 (.class10i|4 .bits|105))) (lambda (.as|115 .src|115) (.op|114 .as|115 0 .src|115 0))) (let ((.bits|118 (asm:logior (asm:lsh 2 30) (asm:lsh .bits|105 19) .ibit|4)) (.jump?|118 (if (not (null? .extra|105)) (eq? (let ((.x|143|146 .extra|105)) (begin (.check! (pair? .x|143|146) 0 .x|143|146) (car:pair .x|143|146))) 'jump) #f))) (lambda (.as|119 .rs1|119 .e|119 .rd|119) (let ((.fixup|122 (unspecified)) (.expr|122 (unspecified))) (begin (set! .fixup|122 (lambda (.bv|123 .loc|123) (let ((.e|126 (.expr|122))) (if .e|126 (.dep-imm!|4 .bv|123 .loc|123 .e|126) (.signal-error|4 'fixup "ALU instruction" .e|126))))) (set! .expr|122 (lambda () (let ((.imm|130 (.eval-expr|4 .as|119 .e|119))) (if (not .imm|130) .imm|130 (if (asm:fits? .imm|130 13) .imm|130 (if .jump?|118 (asm-value-too-large .as|119 "`jmpli'" .e|119 .imm|130) (asm-value-too-large .as|119 "ALU instruction" .e|119 .imm|130))))))) (let ((.bits|135 (.copy|4 .bits|118)) (.e|135 (.expr|122))) (begin (if .e|135 (.dep-imm!|4 .bits|135 0 .e|135) (.emit-fixup-proc!|3 .as|119 (lambda (.b|136 .l|136) (.fixup|122 .b|136 .l|136)))) (.dep-rs1!|4 .bits|135 0 .rs1|119) (.dep-rd!|4 .bits|135 0 .rd|119) (if .jump?|118 (begin (.not-a-delay-slot-instruction|4 .as|119) (.emit!|3 .as|119 .bits|135)) (if (.goes-in-delay-slot2?|3 .as|119 .rd|119) (.emit-fixup-proc!|3 .as|119 (lambda (.bv|139 .loc|139) (.copy!|4 .bv|139 (- .loc|139 4) .bits|135))) (.emit!|3 .as|119 .bits|135)))))))))))) (set! .class10r|4 (lambda (.bits|147 . .extra|147) (if (if (not (null? .extra|147)) (eq? (let ((.x|151|154 .extra|147)) (begin (.check! (pair? .x|151|154) 0 .x|151|154) (car:pair .x|151|154))) 'rdy) #f) (let ((.op|157 (.class10r|4 .bits|147))) (lambda (.as|158 .rd|158) (.op|157 .as|158 0 0 .rd|158))) (if (if (not (null? .extra|147)) (eq? (let ((.x|162|165 .extra|147)) (begin (.check! (pair? .x|162|165) 0 .x|162|165) (car:pair .x|162|165))) 'wry) #f) (let ((.op|168 (.class10r|4 .bits|147))) (lambda (.as|169 .rs|169) (.op|168 .as|169 .rs|169 0 0))) (let ((.bits|173 (asm:logior (asm:lsh 2 30) (asm:lsh .bits|147 19))) (.jump?|173 (if (not (null? .extra|147)) (eq? (let ((.x|184|187 .extra|147)) (begin (.check! (pair? .x|184|187) 0 .x|184|187) (car:pair .x|184|187))) 'jump) #f))) (lambda (.as|174 .rs1|174 .rs2|174 .rd|174) (let ((.bits|177 (.copy|4 .bits|173))) (begin (.dep-rs1!|4 .bits|177 0 .rs1|174) (.dep-rs2!|4 .bits|177 0 .rs2|174) (.dep-rd!|4 .bits|177 0 .rd|174) (if .jump?|173 (begin (.not-a-delay-slot-instruction|4 .as|174) (.emit!|3 .as|174 .bits|177)) (if (.goes-in-delay-slot2?|3 .as|174 .rd|174) (.emit-fixup-proc!|3 .as|174 (lambda (.bv|180 .loc|180) (.copy!|4 .bv|180 (- .loc|180 4) .bits|177))) (.emit!|3 .as|174 .bits|177))))))))))) (set! .class-slot2|4 (lambda () (let ((.nop-instr|191 (.class-nop|4 4))) (lambda (.as|192 . .regs|192) (begin (.nop-instr|191 .as|192) (assembler-value! .as|192 'slot2-info .regs|192)))))) (set! .class-slot|4 (lambda () (let ((.nop-instr|196 (.class-nop|4 4))) (lambda (.as|197) (let ((.fixup|198 (unspecified)) (.branch-target|198 (unspecified))) (begin (set! .fixup|198 (lambda (.bv|199 .loc|199) (let ((.bt|202 (let ((.temp|203|206 (.eval-expr|4 .as|197 .branch-target|198))) (if .temp|203|206 .temp|203|206 (asm-error "Branch fixup: can't happen: " .branch-target|198))))) (if (.is-a-delay-slot-instruction?|4 .as|197 .bv|199 .bt|202) (begin (.copy-instr|4 .bv|199 .bt|202 .loc|199) (.add1|4 .bv|199 (- .loc|199 4))) (unspecified))))) (set! .branch-target|198 (.recover-branch-target|4 .as|197)) (if (if .branch-target|198 (fill-delay-slots) #f) (.emit-fixup-proc!|3 .as|197 (lambda (.b|210 .l|210) (.fixup|198 .b|210 .l|210))) (unspecified)) (.nop-instr|196 .as|197))))))) (set! .branch|4 (lambda (.type|211 .bits|211 .annul|211) (let ((.fill-delay-slot?|214 (let ((.temp|268|271 (not (eq? .annul|211 .zero|4)))) (if .temp|268|271 .temp|268|271 (eq? .bits|211 8)))) (.bits|214 (asm:logior (asm:lsh .bits|211 25) (asm:lsh .type|211 22) .annul|211))) (lambda (.as|215 .target0|215) (let ((.target|218 (.cons '- (.cons .target0|215 (.cons (here .as|215) '()))))) (let ((.fixup|219 (unspecified)) (.expr|219 (unspecified))) (begin (set! .fixup|219 (lambda (.bv|220 .loc|220) (let ((.e|223 (.expr|219))) (if .e|223 (.dep-branch-offset!|4 .bv|220 .loc|220 .e|223) (.signal-error|4 'fixup "branch" .target0|215))))) (set! .expr|219 (lambda () (let ((.e|227 (.eval-expr|4 .as|215 .target|218))) (if (not .e|227) .e|227 (if (not (zero? (logand .e|227 3))) (.signal-error|4 'unaligned "branch" .target0|215) (if (asm:fits? .e|227 24) .e|227 (asm-value-too-large .as|215 "branch" .target|218 .e|227))))))) (if .fill-delay-slot?|214 (.remember-branch-target|4 .as|215 .target0|215) (.remember-branch-target|4 .as|215 #f)) (.not-a-delay-slot-instruction|4 .as|215) (let ((.bits|234 (.copy|4 .bits|214)) (.e|234 (.expr|219))) (begin (if .e|234 (.dep-branch-offset!|4 .bits|234 0 .e|234) (.emit-fixup-proc!|3 .as|215 (lambda (.b|235 .l|235) (.fixup|219 .b|235 .l|235)))) (.emit!|3 .as|215 .bits|234)))))))))) (set! .classf00a|4 (lambda (.i|273) (.branch|4 6 .i|273 .abit|4))) (set! .classf00b|4 (lambda (.i|274) (.branch|4 6 .i|274 .zero|4))) (set! .class00a|4 (lambda (.i|275) (.branch|4 2 .i|275 .abit|4))) (set! .class00b|4 (lambda (.i|276) (.branch|4 2 .i|276 .zero|4))) (set! .class-nop|4 (lambda (.i|277) (let ((.instr|280 (.class-sethi|4 .i|277))) (lambda (.as|281) (.instr|280 .as|281 0 $r.g0))))) (set! .class-sethi|4 (lambda (.bits|282) (let ((.bits|285 (asm:lsh .bits|282 22))) (lambda (.as|286 .val|286 .rd|286) (let ((.fixup2|287 (unspecified)) (.fixup|287 (unspecified))) (begin (set! .fixup2|287 (lambda (.bv|288 .loc|288) (begin (.copy!|4 .bv|288 .loc|288 .bits|285) (.dep-rd!|4 .bv|288 .loc|288 .rd|286) (.fixup|287 .bv|288 .loc|288)))) (set! .fixup|287 (lambda (.bv|289 .loc|289) (.dep-imm22!|4 .bv|289 .loc|289 (let ((.temp|290|293 (.eval-expr|4 .as|286 .val|286))) (if .temp|290|293 .temp|290|293 (.signal-error|4 'fixup "sethi" .val|286)))))) (if (.goes-in-delay-slot2?|3 .as|286 .rd|286) (.emit-fixup-proc!|3 .as|286 (lambda (.b|295 .l|295) (.fixup2|287 .b|295 (- .l|295 4)))) (let ((.bits|298 (.copy|4 .bits|285)) (.e|298 (.eval-expr|4 .as|286 .val|286))) (begin (if .e|298 (.dep-imm22!|4 .bits|298 0 .e|298) (.emit-fixup-proc!|3 .as|286 (lambda (.b|299 .l|299) (.fixup|287 .b|299 .l|299)))) (.dep-rd!|4 .bits|298 0 .rd|286) (.emit!|3 .as|286 .bits|298)))))))))) (set! .is-a-delay-slot-instruction?|4 (lambda (.as|300 .bv|300 .addr|300) (if (not (memv .addr|300 (let ((.temp|303|306 (assembler-value .as|300 'not-dsi))) (if .temp|303|306 .temp|303|306 '())))) (< .addr|300 (bytevector-length .bv|300)) #f))) (set! .not-a-delay-slot-instruction|4 (lambda (.as|309) (assembler-value! .as|309 'not-dsi (cons (here .as|309) (let ((.temp|310|313 (assembler-value .as|309 'not-dsi))) (if .temp|310|313 .temp|310|313 '())))))) (set! .recover-branch-target|4 (lambda (.as|315) (assembler-value .as|315 'branch-target))) (set! .remember-branch-target|4 (lambda (.as|316 .obj|316) (assembler-value! .as|316 'branch-target .obj|316))) (set! .add1|4 (lambda (.bv|317 .loc|317) (let* ((.r0|320 (+ (bytevector-ref .bv|317 (+ .loc|317 3)) 1)) (.d0|323 (logand .r0|320 255)) (.c0|326 (rshl .r0|320 8))) (let () (begin (bytevector-set! .bv|317 (+ .loc|317 3) .d0|323) (let* ((.r1|332 (+ (bytevector-ref .bv|317 (+ .loc|317 2)) .c0|326)) (.d1|335 (logand .r1|332 255)) (.c1|338 (rshl .r1|332 8))) (let () (begin (bytevector-set! .bv|317 (+ .loc|317 2) .d1|335) (let* ((.r2|344 (+ (bytevector-ref .bv|317 (+ .loc|317 1)) .c1|338)) (.d2|347 (logand .r2|344 255))) (let () (bytevector-set! .bv|317 (+ .loc|317 1) .d2|347))))))))))) (set! .dep-call-offset!|4 (lambda (.bits|351 .k|351 .offs|351) (if (fixnum? .offs|351) (begin (if (not (= (logand .offs|351 3) 0)) (.signal-error|4 'unaligned "call" .offs|351) (unspecified)) (bytevector-set! .bits|351 (+ .k|351 3) (logand (rsha .offs|351 2) 255)) (bytevector-set! .bits|351 (+ .k|351 2) (logand (rsha .offs|351 10) 255)) (bytevector-set! .bits|351 (+ .k|351 1) (logand (rsha .offs|351 18) 255)) (bytevector-set! .bits|351 .k|351 (logior (bytevector-ref .bits|351 .k|351) (logand (rsha .offs|351 26) 63)))) (if (bytevector? .offs|351) (begin (if (not (= (logand (bytevector-ref .offs|351 3) 3) 0)) (.signal-error|4 'unaligned "call" (asm:bv->int .offs|351)) (unspecified)) (let ((.offs|356 (asm:rsha .offs|351 2))) (begin (bytevector-set! .bits|351 (+ .k|351 3) (bytevector-ref .offs|356 3)) (bytevector-set! .bits|351 (+ .k|351 2) (bytevector-ref .offs|356 2)) (bytevector-set! .bits|351 (+ .k|351 1) (bytevector-ref .offs|356 1)) (bytevector-set! .bits|351 .k|351 (logior (bytevector-ref .bits|351 .k|351) (logand (bytevector-ref .offs|356 0) 63)))))) (.dep-call-offset!|4 .bits|351 .k|351 (asm:int->bv .offs|351)))))) (set! .dep-imm22!|4 (lambda (.bits|358 .k|358 .imm|358) (if (fixnum? .imm|358) (begin (bytevector-set! .bits|358 (+ .k|358 3) (logand .imm|358 255)) (bytevector-set! .bits|358 (+ .k|358 2) (logand (rsha .imm|358 8) 255)) (bytevector-set! .bits|358 (+ .k|358 1) (logior (bytevector-ref .bits|358 (+ .k|358 1)) (logand (rsha .imm|358 16) 63)))) (if (bytevector? .imm|358) (begin (bytevector-set! .bits|358 (+ .k|358 3) (bytevector-ref .imm|358 3)) (bytevector-set! .bits|358 (+ .k|358 2) (bytevector-ref .imm|358 2)) (bytevector-set! .bits|358 (+ .k|358 1) (logior (bytevector-ref .bits|358 (+ .k|358 1)) (logand (bytevector-ref .imm|358 1) 63)))) (.dep-imm22!|4 .bits|358 .k|358 (asm:int->bv .imm|358)))))) (set! .dep-branch-offset!|4 (lambda (.bits|362 .k|362 .offs|362) (if (fixnum? .offs|362) (begin (if (not (= (logand .offs|362 3) 0)) (.signal-error|4 'unaligned "branch" .offs|362) (unspecified)) (.dep-imm22!|4 .bits|362 .k|362 (rsha .offs|362 2))) (if (bytevector? .offs|362) (begin (if (not (= (logand (bytevector-ref .offs|362 3) 3) 0)) (.signal-error|4 'unaligned "branch" (asm:bv->int .offs|362)) (unspecified)) (.dep-imm22!|4 .bits|362 .k|362 (asm:rsha .offs|362 2))) (.dep-branch-offset!|4 .bits|362 .k|362 (asm:int->bv .offs|362)))))) (set! .dep-imm!|4 (lambda (.bits|366 .k|366 .imm|366) (if (fixnum? .imm|366) (begin (bytevector-set! .bits|366 (+ .k|366 3) (logand .imm|366 255)) (bytevector-set! .bits|366 (+ .k|366 2) (logior (bytevector-ref .bits|366 (+ .k|366 2)) (logand (rsha .imm|366 8) 31)))) (if (bytevector? .imm|366) (begin (bytevector-set! .bits|366 (+ .k|366 3) (bytevector-ref .imm|366 0)) (bytevector-set! .bits|366 (+ .k|366 2) (logior (bytevector-ref .bits|366 (+ .k|366 2)) (logand (bytevector-ref .imm|366 1) 31)))) (.dep-imm!|4 .bits|366 .k|366 (asm:int->bv .imm|366)))))) (set! .dep-rd!|4 (lambda (.bits|370 .k|370 .rd|370) (bytevector-set! .bits|370 .k|370 (logior (bytevector-ref .bits|370 .k|370) (lsh .rd|370 1))))) (set! .dep-rs2!|4 (lambda (.bits|371 .k|371 .rs2|371) (bytevector-set! .bits|371 (+ .k|371 3) (logior (bytevector-ref .bits|371 (+ .k|371 3)) .rs2|371)))) (set! .dep-rs1!|4 (lambda (.bits|372 .k|372 .rs1|372) (begin (bytevector-set! .bits|372 (+ .k|372 1) (logior (bytevector-ref .bits|372 (+ .k|372 1)) (rshl .rs1|372 2))) (bytevector-set! .bits|372 (+ .k|372 2) (logior (bytevector-ref .bits|372 (+ .k|372 2)) (lsh (logand .rs1|372 3) 6)))))) (set! .copy-instr|4 (lambda (.bv|373 .from|373 .to|373) (begin (bytevector-set! .bv|373 .to|373 (bytevector-ref .bv|373 .from|373)) (bytevector-set! .bv|373 (+ .to|373 1) (bytevector-ref .bv|373 (+ .from|373 1))) (bytevector-set! .bv|373 (+ .to|373 2) (bytevector-ref .bv|373 (+ .from|373 2))) (bytevector-set! .bv|373 (+ .to|373 3) (bytevector-ref .bv|373 (+ .from|373 3)))))) (set! .copy|4 (lambda (.bits|374) (let ((.bv|377 (make-bytevector 4))) (begin (bytevector-set! .bv|377 0 (bytevector-ref .bits|374 0)) (bytevector-set! .bv|377 1 (bytevector-ref .bits|374 1)) (bytevector-set! .bv|377 2 (bytevector-ref .bits|374 2)) (bytevector-set! .bv|377 3 (bytevector-ref .bits|374 3)) .bv|377)))) (set! .copy!|4 (lambda (.bv|378 .k|378 .bits|378) (begin (bytevector-set! .bv|378 .k|378 (bytevector-ref .bits|378 0)) (bytevector-set! .bv|378 (+ .k|378 1) (bytevector-ref .bits|378 1)) (bytevector-set! .bv|378 (+ .k|378 2) (bytevector-ref .bits|378 2)) (bytevector-set! .bv|378 (+ .k|378 3) (bytevector-ref .bits|378 3)) .bv|378))) (set! .signal-error|4 (lambda (.code|379 . .rest|379) (let ((.msg|381 (unspecified))) (begin (set! .msg|381 "SPARC assembler: ") (let ((.temp|380|384 .code|379)) (if (memv .temp|380|384 '(badexpr)) (asm-error .msg|381 "invalid expression " (let ((.x|386|389 .rest|379)) (begin (.check! (pair? .x|386|389) 0 .x|386|389) (car:pair .x|386|389)))) (if (memv .temp|380|384 '(toolarge)) (asm-error .msg|381 "value too large in " (let ((.x|391|394 .rest|379)) (begin (.check! (pair? .x|391|394) 0 .x|391|394) (car:pair .x|391|394))) ": " (let ((.x|396|399 (let ((.x|400|403 .rest|379)) (begin (.check! (pair? .x|400|403) 1 .x|400|403) (cdr:pair .x|400|403))))) (begin (.check! (pair? .x|396|399) 0 .x|396|399) (car:pair .x|396|399))) " = " (let ((.x|405|408 (let ((.x|409|412 (let ((.x|413|416 .rest|379)) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416))))) (begin (.check! (pair? .x|409|412) 1 .x|409|412) (cdr:pair .x|409|412))))) (begin (.check! (pair? .x|405|408) 0 .x|405|408) (car:pair .x|405|408)))) (if (memv .temp|380|384 '(fixup)) (asm-error .msg|381 "fixup failed in " (let ((.x|418|421 .rest|379)) (begin (.check! (pair? .x|418|421) 0 .x|418|421) (car:pair .x|418|421))) " for " (let ((.x|423|426 (let ((.x|427|430 .rest|379)) (begin (.check! (pair? .x|427|430) 1 .x|427|430) (cdr:pair .x|427|430))))) (begin (.check! (pair? .x|423|426) 0 .x|423|426) (car:pair .x|423|426)))) (if (memv .temp|380|384 '(unaligned)) (asm-error .msg|381 "unaligned target in " (let ((.x|432|435 .rest|379)) (begin (.check! (pair? .x|432|435) 0 .x|432|435) (car:pair .x|432|435))) ": " (let ((.x|437|440 (let ((.x|441|444 .rest|379)) (begin (.check! (pair? .x|441|444) 1 .x|441|444) (cdr:pair .x|441|444))))) (begin (.check! (pair? .x|437|440) 0 .x|437|440) (car:pair .x|437|440)))) (error "Invalid error code in assembler: " .code|379)))))))))) (set! .eval-expr|4 (lambda (.as|446 .e|446) (let ((.evaluate|447 (unspecified)) (.lobits|447 (unspecified)) (.hibits|447 (unspecified)) (.complement|447 (unspecified))) (begin (set! .evaluate|447 (lambda (.e|448) (if (integer? .e|448) .e|448 (if (label? .e|448) (label-value .as|446 .e|448) (if (eq? 'hi (let ((.x|452|455 .e|448)) (begin (.check! (pair? .x|452|455) 0 .x|452|455) (car:pair .x|452|455)))) (.hibits|447 (.evaluate|447 (let ((.x|457|460 (let ((.x|461|464 .e|448)) (begin (.check! (pair? .x|461|464) 1 .x|461|464) (cdr:pair .x|461|464))))) (begin (.check! (pair? .x|457|460) 0 .x|457|460) (car:pair .x|457|460))))) (if (eq? 'lo (let ((.x|466|469 .e|448)) (begin (.check! (pair? .x|466|469) 0 .x|466|469) (car:pair .x|466|469)))) (.lobits|447 (.evaluate|447 (let ((.x|471|474 (let ((.x|475|478 .e|448)) (begin (.check! (pair? .x|475|478) 1 .x|475|478) (cdr:pair .x|475|478))))) (begin (.check! (pair? .x|471|474) 0 .x|471|474) (car:pair .x|471|474))))) (if (eq? '+ (let ((.x|480|483 .e|448)) (begin (.check! (pair? .x|480|483) 0 .x|480|483) (car:pair .x|480|483)))) (let ((.e|486 (let ((.x|502|505 .e|448)) (begin (.check! (pair? .x|502|505) 1 .x|502|505) (cdr:pair .x|502|505)))) (.s|486 0)) (let () (let ((.loop|489 (unspecified))) (begin (set! .loop|489 (lambda (.e|490 .s|490) (if (null? .e|490) .s|490 (let ((.op|493 (.evaluate|447 (let ((.x|498|501 .e|490)) (begin (.check! (pair? .x|498|501) 0 .x|498|501) (car:pair .x|498|501)))))) (if (not .op|493) .op|493 (.loop|489 (let ((.x|494|497 .e|490)) (begin (.check! (pair? .x|494|497) 1 .x|494|497) (cdr:pair .x|494|497))) (+ .s|490 .op|493))))))) (.loop|489 .e|486 .s|486))))) (if (eq? '- (let ((.x|507|510 .e|448)) (begin (.check! (pair? .x|507|510) 0 .x|507|510) (car:pair .x|507|510)))) (let ((.e|513 (let ((.x|529|532 .e|448)) (begin (.check! (pair? .x|529|532) 1 .x|529|532) (cdr:pair .x|529|532)))) (.d|513 #f)) (let () (let ((.loop|516 (unspecified))) (begin (set! .loop|516 (lambda (.e|517 .d|517) (if (null? .e|517) .d|517 (let ((.op|520 (.evaluate|447 (let ((.x|525|528 .e|517)) (begin (.check! (pair? .x|525|528) 0 .x|525|528) (car:pair .x|525|528)))))) (if (not .op|520) .op|520 (.loop|516 (let ((.x|521|524 .e|517)) (begin (.check! (pair? .x|521|524) 1 .x|521|524) (cdr:pair .x|521|524))) (if .d|517 (- .d|517 .op|520) .op|520))))))) (.loop|516 .e|513 .d|513))))) (.signal-error|4 'badexpr .e|448))))))))) (set! .lobits|447 (lambda (.e|534) (if (not .e|534) .e|534 (if (< .e|534 0) (remainder (.complement|447 .e|534) 1024) (remainder .e|534 1024))))) (set! .hibits|447 (lambda (.e|538) (if (not .e|538) .e|538 (if (< .e|538 0) (.complement|447 (quotient (.complement|447 .e|538) 1024)) (quotient .e|538 1024))))) (set! .complement|447 (lambda (.x|542) (modulo (+ .two^32|4 .x|542) .two^32|4))) (.evaluate|447 .e|446))))) (set! .two^32|4 (expt 2 32)) (set! .zero|4 (asm:bv 0 0 0 0)) (set! .abit|4 (asm:bv 32 0 0 0)) (set! .ibit|4 (asm:bv 0 0 32 0)) (set! sparc-instruction (lambda (.kwd|543 . .ops|543) (let ((.temp|544|547 .kwd|543)) (if (memv .temp|544|547 '(i11)) (apply .class11i|4 .ops|543) (if (memv .temp|544|547 '(r11)) (apply .class11r|4 .ops|543) (if (memv .temp|544|547 '(si11)) (apply .class11si|4 .ops|543) (if (memv .temp|544|547 '(sr11)) (apply .class11sr|4 .ops|543) (if (memv .temp|544|547 '(sethi)) (apply .class-sethi|4 .ops|543) (if (memv .temp|544|547 '(r10)) (apply .class10r|4 .ops|543) (if (memv .temp|544|547 '(i10)) (apply .class10i|4 .ops|543) (if (memv .temp|544|547 '(b00)) (apply .class00b|4 .ops|543) (if (memv .temp|544|547 '(a00)) (apply .class00a|4 .ops|543) (if (memv .temp|544|547 '(call)) (apply .class-call|4 .ops|543) (if (memv .temp|544|547 '(label)) (apply .class-label|4 .ops|543) (if (memv .temp|544|547 '(nop)) (apply .class-nop|4 .ops|543) (if (memv .temp|544|547 '(slot)) (apply .class-slot|4 .ops|543) (if (memv .temp|544|547 '(slot2)) (apply .class-slot2|4 .ops|543) (if (memv .temp|544|547 '(fb00)) (apply .classf00b|4 .ops|543) (if (memv .temp|544|547 '(fa00)) (apply .classf00a|4 .ops|543) (if (memv .temp|544|547 '(fp)) (apply .class-fpop1|4 .ops|543) (if (memv .temp|544|547 '(fpcc)) (apply .class-fpop2|4 .ops|543) (asm-error "sparc-instruction: unrecognized class: " .kwd|543)))))))))))))))))))))) 'sparc-instruction))))
+(let () (begin (set! sparc.lddi (sparc-instruction 'i11 3)) 'sparc.lddi))
+(let () (begin (set! sparc.lddr (sparc-instruction 'r11 3)) 'sparc.lddr))
+(let () (begin (set! sparc.ldi (sparc-instruction 'i11 0)) 'sparc.ldi))
+(let () (begin (set! sparc.ldr (sparc-instruction 'r11 0)) 'sparc.ldr))
+(let () (begin (set! sparc.ldhi (sparc-instruction 'i11 2)) 'sparc.ldhi))
+(let () (begin (set! sparc.ldhr (sparc-instruction 'r11 2)) 'sparc.ldhr))
+(let () (begin (set! sparc.ldbi (sparc-instruction 'i11 1)) 'sparc.ldbi))
+(let () (begin (set! sparc.ldbr (sparc-instruction 'r11 1)) 'sparc.ldbr))
+(let () (begin (set! sparc.lddfi (sparc-instruction 'i11 35)) 'sparc.lddfi))
+(let () (begin (set! sparc.lddfr (sparc-instruction 'r11 35)) 'sparc.lddfr))
+(let () (begin (set! sparc.stdi (sparc-instruction 'si11 7)) 'sparc.stdi))
+(let () (begin (set! sparc.stdr (sparc-instruction 'sr11 7)) 'sparc.stdr))
+(let () (begin (set! sparc.sti (sparc-instruction 'si11 4)) 'sparc.sti))
+(let () (begin (set! sparc.str (sparc-instruction 'sr11 4)) 'sparc.str))
+(let () (begin (set! sparc.sthi (sparc-instruction 'si11 6)) 'sparc.sthi))
+(let () (begin (set! sparc.sthr (sparc-instruction 'sr11 6)) 'sparc.sthr))
+(let () (begin (set! sparc.stbi (sparc-instruction 'si11 5)) 'sparc.stbi))
+(let () (begin (set! sparc.stbr (sparc-instruction 'sr11 5)) 'sparc.stbr))
+(let () (begin (set! sparc.stdfi (sparc-instruction 'si11 39)) 'sparc.stdfi))
+(let () (begin (set! sparc.stdfr (sparc-instruction 'sr11 39)) 'sparc.stdfr))
+(let () (begin (set! sparc.sethi (sparc-instruction 'sethi 4)) 'sparc.sethi))
+(let () (begin (set! sparc.andr (sparc-instruction 'r10 1)) 'sparc.andr))
+(let () (begin (set! sparc.andrcc (sparc-instruction 'r10 17)) 'sparc.andrcc))
+(let () (begin (set! sparc.andi (sparc-instruction 'i10 1)) 'sparc.andi))
+(let () (begin (set! sparc.andicc (sparc-instruction 'i10 17)) 'sparc.andicc))
+(let () (begin (set! sparc.orr (sparc-instruction 'r10 2)) 'sparc.orr))
+(let () (begin (set! sparc.orrcc (sparc-instruction 'r10 18)) 'sparc.orrcc))
+(let () (begin (set! sparc.ori (sparc-instruction 'i10 2)) 'sparc.ori))
+(let () (begin (set! sparc.oricc (sparc-instruction 'i10 18)) 'sparc.oricc))
+(let () (begin (set! sparc.xorr (sparc-instruction 'r10 3)) 'sparc.xorr))
+(let () (begin (set! sparc.xorrcc (sparc-instruction 'r10 19)) 'sparc.xorrcc))
+(let () (begin (set! sparc.xori (sparc-instruction 'i10 3)) 'sparc.xori))
+(let () (begin (set! sparc.xoricc (sparc-instruction 'i10 19)) 'sparc.xoricc))
+(let () (begin (set! sparc.sllr (sparc-instruction 'r10 37)) 'sparc.sllr))
+(let () (begin (set! sparc.slli (sparc-instruction 'i10 37)) 'sparc.slli))
+(let () (begin (set! sparc.srlr (sparc-instruction 'r10 38)) 'sparc.srlr))
+(let () (begin (set! sparc.srli (sparc-instruction 'i10 38)) 'sparc.srli))
+(let () (begin (set! sparc.srar (sparc-instruction 'r10 39)) 'sparc.srar))
+(let () (begin (set! sparc.srai (sparc-instruction 'i10 39)) 'sparc.srai))
+(let () (begin (set! sparc.addr (sparc-instruction 'r10 0)) 'sparc.addr))
+(let () (begin (set! sparc.addrcc (sparc-instruction 'r10 16)) 'sparc.addrcc))
+(let () (begin (set! sparc.addi (sparc-instruction 'i10 0)) 'sparc.addi))
+(let () (begin (set! sparc.addicc (sparc-instruction 'i10 16)) 'sparc.addicc))
+(let () (begin (set! sparc.taddrcc (sparc-instruction 'r10 32)) 'sparc.taddrcc))
+(let () (begin (set! sparc.taddicc (sparc-instruction 'i10 32)) 'sparc.taddicc))
+(let () (begin (set! sparc.subr (sparc-instruction 'r10 4)) 'sparc.subr))
+(let () (begin (set! sparc.subrcc (sparc-instruction 'r10 20)) 'sparc.subrcc))
+(let () (begin (set! sparc.subi (sparc-instruction 'i10 4)) 'sparc.subi))
+(let () (begin (set! sparc.subicc (sparc-instruction 'i10 20)) 'sparc.subicc))
+(let () (begin (set! sparc.tsubrcc (sparc-instruction 'r10 33)) 'sparc.tsubrcc))
+(let () (begin (set! sparc.tsubicc (sparc-instruction 'i10 33)) 'sparc.tsubicc))
+(let () (begin (set! sparc.smulr (sparc-instruction 'r10 11)) 'sparc.smulr))
+(let () (begin (set! sparc.smulrcc (sparc-instruction 'r10 27)) 'sparc.smulrcc))
+(let () (begin (set! sparc.smuli (sparc-instruction 'i10 11)) 'sparc.smuli))
+(let () (begin (set! sparc.smulicc (sparc-instruction 'i10 27)) 'sparc.smulicc))
+(let () (begin (set! sparc.sdivr (sparc-instruction 'r10 15)) 'sparc.sdivr))
+(let () (begin (set! sparc.sdivrcc (sparc-instruction 'r10 31)) 'sparc.sdivrcc))
+(let () (begin (set! sparc.sdivi (sparc-instruction 'i10 15)) 'sparc.sdivi))
+(let () (begin (set! sparc.sdivicc (sparc-instruction 'i10 31)) 'sparc.sdivicc))
+(let () (begin (set! sparc.b (sparc-instruction 'b00 8)) 'sparc.b))
+(let () (begin (set! sparc.b.a (sparc-instruction 'a00 8)) 'sparc.b.a))
+(let () (begin (set! sparc.bne (sparc-instruction 'b00 9)) 'sparc.bne))
+(let () (begin (set! sparc.bne.a (sparc-instruction 'a00 9)) 'sparc.bne.a))
+(let () (begin (set! sparc.be (sparc-instruction 'b00 1)) 'sparc.be))
+(let () (begin (set! sparc.be.a (sparc-instruction 'a00 1)) 'sparc.be.a))
+(let () (begin (set! sparc.bg (sparc-instruction 'b00 10)) 'sparc.bg))
+(let () (begin (set! sparc.bg.a (sparc-instruction 'a00 10)) 'sparc.bg.a))
+(let () (begin (set! sparc.ble (sparc-instruction 'b00 2)) 'sparc.ble))
+(let () (begin (set! sparc.ble.a (sparc-instruction 'a00 2)) 'sparc.ble.a))
+(let () (begin (set! sparc.bge (sparc-instruction 'b00 11)) 'sparc.bge))
+(let () (begin (set! sparc.bge.a (sparc-instruction 'a00 11)) 'sparc.bge.a))
+(let () (begin (set! sparc.bl (sparc-instruction 'b00 3)) 'sparc.bl))
+(let () (begin (set! sparc.bl.a (sparc-instruction 'a00 3)) 'sparc.bl.a))
+(let () (begin (set! sparc.bgu (sparc-instruction 'b00 12)) 'sparc.bgu))
+(let () (begin (set! sparc.bgu.a (sparc-instruction 'a00 12)) 'sparc.bgu.a))
+(let () (begin (set! sparc.bleu (sparc-instruction 'b00 4)) 'sparc.bleu))
+(let () (begin (set! sparc.bleu.a (sparc-instruction 'a00 4)) 'sparc.bleu.a))
+(let () (begin (set! sparc.bcc (sparc-instruction 'b00 13)) 'sparc.bcc))
+(let () (begin (set! sparc.bcc.a (sparc-instruction 'a00 13)) 'sparc.bcc.a))
+(let () (begin (set! sparc.bcs (sparc-instruction 'b00 5)) 'sparc.bcs))
+(let () (begin (set! sparc.bcs.a (sparc-instruction 'a00 5)) 'sparc.bcs.a))
+(let () (begin (set! sparc.bpos (sparc-instruction 'b00 14)) 'sparc.bpos))
+(let () (begin (set! sparc.bpos.a (sparc-instruction 'a00 14)) 'sparc.bpos.a))
+(let () (begin (set! sparc.bneg (sparc-instruction 'b00 6)) 'sparc.bneg))
+(let () (begin (set! sparc.bneg.a (sparc-instruction 'a00 6)) 'sparc.bneg.a))
+(let () (begin (set! sparc.bvc (sparc-instruction 'b00 15)) 'sparc.bvc))
+(let () (begin (set! sparc.bvc.a (sparc-instruction 'a00 15)) 'sparc.bvc.a))
+(let () (begin (set! sparc.bvs (sparc-instruction 'b00 7)) 'sparc.bvs))
+(let () (begin (set! sparc.bvs.a (sparc-instruction 'a00 7)) 'sparc.bvs.a))
+(let () (begin (set! sparc.call (sparc-instruction 'call)) 'sparc.call))
+(let () (begin (set! sparc.jmplr (sparc-instruction 'r10 56 'jump)) 'sparc.jmplr))
+(let () (begin (set! sparc.jmpli (sparc-instruction 'i10 56 'jump)) 'sparc.jmpli))
+(let () (begin (set! sparc.nop (sparc-instruction 'nop 4)) 'sparc.nop))
+(let () (begin (set! sparc.ornr (sparc-instruction 'r10 6)) 'sparc.ornr))
+(let () (begin (set! sparc.orni (sparc-instruction 'i10 6)) 'sparc.orni))
+(let () (begin (set! sparc.ornrcc (sparc-instruction 'r10 22)) 'sparc.ornrcc))
+(let () (begin (set! sparc.ornicc (sparc-instruction 'i10 22)) 'sparc.ornicc))
+(let () (begin (set! sparc.andni (sparc-instruction 'i10 5)) 'sparc.andni))
+(let () (begin (set! sparc.andnr (sparc-instruction 'r10 5)) 'sparc.andnr))
+(let () (begin (set! sparc.andnicc (sparc-instruction 'i10 21)) 'sparc.andnicc))
+(let () (begin (set! sparc.andnrcc (sparc-instruction 'r10 21)) 'sparc.andnrcc))
+(let () (begin (set! sparc.rdy (sparc-instruction 'r10 40 'rdy)) 'sparc.rdy))
+(let () (begin (set! sparc.wryr (sparc-instruction 'r10 48 'wry)) 'sparc.wryr))
+(let () (begin (set! sparc.wryi (sparc-instruction 'i10 48 'wry)) 'sparc.wryi))
+(let () (begin (set! sparc.fb (sparc-instruction 'fb00 8)) 'sparc.fb))
+(let () (begin (set! sparc.fb.a (sparc-instruction 'fa00 8)) 'sparc.fb.a))
+(let () (begin (set! sparc.fbn (sparc-instruction 'fb00 0)) 'sparc.fbn))
+(let () (begin (set! sparc.fbn.a (sparc-instruction 'fa00 0)) 'sparc.fbn.a))
+(let () (begin (set! sparc.fbu (sparc-instruction 'fb00 7)) 'sparc.fbu))
+(let () (begin (set! sparc.fbu.a (sparc-instruction 'fa00 7)) 'sparc.fbu.a))
+(let () (begin (set! sparc.fbg (sparc-instruction 'fb00 6)) 'sparc.fbg))
+(let () (begin (set! sparc.fbg.a (sparc-instruction 'fa00 6)) 'sparc.fbg.a))
+(let () (begin (set! sparc.fbug (sparc-instruction 'fb00 5)) 'sparc.fbug))
+(let () (begin (set! sparc.fbug.a (sparc-instruction 'fa00 5)) 'sparc.fbug.a))
+(let () (begin (set! sparc.fbl (sparc-instruction 'fb00 4)) 'sparc.fbl))
+(let () (begin (set! sparc.fbl.a (sparc-instruction 'fa00 4)) 'sparc.fbl.a))
+(let () (begin (set! sparc.fbul (sparc-instruction 'fb00 3)) 'sparc.fbul))
+(let () (begin (set! sparc.fbul.a (sparc-instruction 'fa00 3)) 'sparc.fbul.a))
+(let () (begin (set! sparc.fblg (sparc-instruction 'fb00 2)) 'sparc.fblg))
+(let () (begin (set! sparc.fblg.a (sparc-instruction 'fa00 2)) 'sparc.fblg.a))
+(let () (begin (set! sparc.fbne (sparc-instruction 'fb00 1)) 'sparc.fbne))
+(let () (begin (set! sparc.fbne.a (sparc-instruction 'fa00 1)) 'sparc.fbne.a))
+(let () (begin (set! sparc.fbe (sparc-instruction 'fb00 9)) 'sparc.fbe))
+(let () (begin (set! sparc.fbe.a (sparc-instruction 'fa00 9)) 'sparc.fbe.a))
+(let () (begin (set! sparc.fbue (sparc-instruction 'fb00 10)) 'sparc.fbue))
+(let () (begin (set! sparc.fbue.a (sparc-instruction 'fa00 10)) 'sparc.fbue.a))
+(let () (begin (set! sparc.fbge (sparc-instruction 'fb00 11)) 'sparc.fbge))
+(let () (begin (set! sparc.fbge.a (sparc-instruction 'fa00 11)) 'sparc.fbge.a))
+(let () (begin (set! sparc.fbuge (sparc-instruction 'fb00 12)) 'sparc.fbuge))
+(let () (begin (set! sparc.fbuge.a (sparc-instruction 'fa00 12)) 'sparc.fbuge.a))
+(let () (begin (set! sparc.fble (sparc-instruction 'fb00 13)) 'sparc.fble))
+(let () (begin (set! sparc.fble.a (sparc-instruction 'fa00 13)) 'sparc.fble.a))
+(let () (begin (set! sparc.fbule (sparc-instruction 'fb00 14)) 'sparc.fbule))
+(let () (begin (set! sparc.fbule.a (sparc-instruction 'fa00 14)) 'sparc.fbule.a))
+(let () (begin (set! sparc.fbo (sparc-instruction 'fb00 15)) 'sparc.fbo))
+(let () (begin (set! sparc.fbo.a (sparc-instruction 'fa00 15)) 'sparc.fbo.a))
+(let () (begin (set! sparc.faddd (sparc-instruction 'fp 66)) 'sparc.faddd))
+(let () (begin (set! sparc.fsubd (sparc-instruction 'fp 70)) 'sparc.fsubd))
+(let () (begin (set! sparc.fmuld (sparc-instruction 'fp 74)) 'sparc.fmuld))
+(let () (begin (set! sparc.fdivd (sparc-instruction 'fp 78)) 'sparc.fdivd))
+(let () (begin (set! sparc%fnegs (sparc-instruction 'fp 5)) 'sparc%fnegs))
+(let () (begin (set! sparc%fmovs (sparc-instruction 'fp 1)) 'sparc%fmovs))
+(let () (begin (set! sparc%fabss (sparc-instruction 'fp 9)) 'sparc%fabss))
+(let () (begin (set! sparc%fcmpdcc (sparc-instruction 'fpcc 82)) 'sparc%fcmpdcc))
+(let () (begin (set! sparc.slot (sparc-instruction 'slot)) 'sparc.slot))
+(let () (begin (set! sparc.slot2 (sparc-instruction 'slot2)) 'sparc.slot2))
+(let () (begin (set! sparc.label (sparc-instruction 'label)) 'sparc.label))
+(let () (begin (set! sparc.bnz sparc.bne) 'sparc.bnz))
+(let () (begin (set! sparc.bnz.a sparc.bne.a) 'sparc.bnz.a))
+(let () (begin (set! sparc.bz sparc.be) 'sparc.bz))
+(let () (begin (set! sparc.bz.a sparc.be.a) 'sparc.bz.a))
+(let () (begin (set! sparc.bgeu sparc.bcc) 'sparc.bgeu))
+(let () (begin (set! sparc.bgeu.a sparc.bcc.a) 'sparc.bgeu.a))
+(let () (begin (set! sparc.blu sparc.bcs) 'sparc.blu))
+(let () (begin (set! sparc.blu.a sparc.bcs.a) 'sparc.blu.a))
+(let () (begin (set! sparc.cmpr (lambda (.as|1 .r1|1 .r2|1) (let ((.sparc.cmpr|2 0)) (begin (set! .sparc.cmpr|2 (lambda (.as|3 .r1|3 .r2|3) (sparc.subrcc .as|3 .r1|3 .r2|3 $r.g0))) (.sparc.cmpr|2 .as|1 .r1|1 .r2|1))))) 'sparc.cmpr))
+(let () (begin (set! sparc.cmpi (lambda (.as|1 .r|1 .imm|1) (let ((.sparc.cmpi|2 0)) (begin (set! .sparc.cmpi|2 (lambda (.as|3 .r|3 .imm|3) (sparc.subicc .as|3 .r|3 .imm|3 $r.g0))) (.sparc.cmpi|2 .as|1 .r|1 .imm|1))))) 'sparc.cmpi))
+(let () (begin (set! sparc.move (lambda (.as|1 .rs|1 .rd|1) (let ((.sparc.move|2 0)) (begin (set! .sparc.move|2 (lambda (.as|3 .rs|3 .rd|3) (sparc.orr .as|3 $r.g0 .rs|3 .rd|3))) (.sparc.move|2 .as|1 .rs|1 .rd|1))))) 'sparc.move))
+(let () (begin (set! sparc.set (lambda (.as|1 .imm|1 .rd|1) (let ((.sparc.set|2 0)) (begin (set! .sparc.set|2 (lambda (.as|3 .imm|3 .rd|3) (sparc.ori .as|3 $r.g0 .imm|3 .rd|3))) (.sparc.set|2 .as|1 .imm|1 .rd|1))))) 'sparc.set))
+(let () (begin (set! sparc.btsti (lambda (.as|1 .rs|1 .imm|1) (let ((.sparc.btsti|2 0)) (begin (set! .sparc.btsti|2 (lambda (.as|3 .rs|3 .imm|3) (sparc.andicc .as|3 .rs|3 .imm|3 $r.g0))) (.sparc.btsti|2 .as|1 .rs|1 .imm|1))))) 'sparc.btsti))
+(let () (begin (set! sparc.clr (lambda (.as|1 .rd|1) (let ((.sparc.clr|2 0)) (begin (set! .sparc.clr|2 (lambda (.as|3 .rd|3) (sparc.move .as|3 $r.g0 .rd|3))) (.sparc.clr|2 .as|1 .rd|1))))) 'sparc.clr))
+(let () (begin (set! sparc.deccc (lambda (.as|1 .rs|1 . .rest|1) (let ((.k|4 (if (null? .rest|1) 1 (if (null? (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (let ((.x|11|14 .rest|1)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (asm-error "sparc.deccc: too many operands: " .rest|1))))) (sparc.subicc .as|1 .rs|1 .k|4 .rs|1)))) 'sparc.deccc))
+(let () (begin (set! sparc.fmovd (lambda (.as|1 .rs|1 .rd|1) (let ((.sparc.fmovd|2 0)) (begin (set! .sparc.fmovd|2 (lambda (.as|3 .rs|3 .rd|3) (begin (sparc%fmovs .as|3 .rs|3 0 .rd|3) (sparc%fmovs .as|3 (+ .rs|3 1) 0 (+ .rd|3 1))))) (.sparc.fmovd|2 .as|1 .rs|1 .rd|1))))) 'sparc.fmovd))
+(let () (begin (set! sparc.fnegd (lambda (.as|1 .rs|1 .rd|1) (let ((.sparc.fnegd|2 0)) (begin (set! .sparc.fnegd|2 (lambda (.as|3 .rs|3 .rd|3) (begin (sparc%fnegs .as|3 .rs|3 0 .rd|3) (if (not (= .rs|3 .rd|3)) (sparc%fmovs .as|3 (+ .rs|3 1) 0 (+ .rd|3 1)) (unspecified))))) (.sparc.fnegd|2 .as|1 .rs|1 .rd|1))))) 'sparc.fnegd))
+(let () (begin (set! sparc.fabsd (lambda (.as|1 .rs|1 .rd|1) (let ((.sparc.fabsd|2 0)) (begin (set! .sparc.fabsd|2 (lambda (.as|3 .rs|3 .rd|3) (begin (sparc%fabss .as|3 .rs|3 0 .rd|3) (if (not (= .rs|3 .rd|3)) (sparc%fmovs .as|3 (+ .rs|3 1) 0 (+ .rd|3 1)) (unspecified))))) (.sparc.fabsd|2 .as|1 .rs|1 .rd|1))))) 'sparc.fabsd))
+(let () (begin (set! sparc.fcmpd (lambda (.as|1 .rs1|1 .rs2|1) (let ((.sparc.fcmpd|2 0)) (begin (set! .sparc.fcmpd|2 (lambda (.as|3 .rs1|3 .rs2|3) (sparc%fcmpdcc .as|3 .rs1|3 .rs2|3 0))) (.sparc.fcmpd|2 .as|1 .rs1|1 .rs2|1))))) 'sparc.fcmpd))
+(let () (begin (set! emit-register->global! (lambda (.as|1 .rs|1 .offset|1) (let ((.emit-register->global!|2 0)) (begin (set! .emit-register->global!|2 (lambda (.as|3 .rs|3 .offset|3) (if (= .rs|3 $r.result) (begin (sparc.move .as|3 $r.result $r.argreg2) (emit-const->register! .as|3 .offset|3 $r.result) (if (write-barrier) (sparc.jmpli .as|3 $r.millicode $m.addtrans $r.o7) (unspecified)) (sparc.sti .as|3 $r.argreg2 (- 0 $tag.pair-tag) $r.result)) (begin (emit-const->register! .as|3 .offset|3 $r.result) (sparc.sti .as|3 .rs|3 (- 0 $tag.pair-tag) $r.result) (if (write-barrier) (millicode-call/1arg .as|3 $m.addtrans .rs|3) (unspecified)))))) (.emit-register->global!|2 .as|1 .rs|1 .offset|1))))) 'emit-register->global!))
+(let () (begin (set! emit-global->register! (lambda (.as|1 .offset|1 .r|1) (let ((.emit-global->register!|2 0)) (begin (set! .emit-global->register!|2 (lambda (.as|3 .offset|3 .r|3) (emit-load-global .as|3 .offset|3 .r|3 (catch-undefined-globals)))) (.emit-global->register!|2 .as|1 .offset|1 .r|1))))) 'emit-global->register!))
+(let () (begin (set! emit-load-global (lambda (.as|1 .offset|1 .r|1 .check?|1) (let ((.emit-load-global|2 0)) (begin (set! .emit-load-global|2 (lambda (.as|3 .offset|3 .r|3 .check?|3) (let ((.emit-undef-check!|4 (unspecified))) (begin (set! .emit-undef-check!|4 (lambda (.as|5 .r|5) (if .check?|3 (let ((.global-ok|8 (new-label))) (begin (sparc.cmpi .as|5 .r|5 $imm.undefined) (sparc.bne.a .as|5 .global-ok|8) (sparc.slot .as|5) (millicode-call/0arg .as|5 $m.global-ex) (sparc.label .as|5 .global-ok|8))) (unspecified)))) (emit-const->register! .as|3 .offset|3 $r.argreg2) (if (hardware-mapped? .r|3) (begin (sparc.ldi .as|3 $r.argreg2 (- 0 $tag.pair-tag) .r|3) (.emit-undef-check!|4 .as|3 .r|3)) (begin (sparc.ldi .as|3 $r.argreg2 (- 0 $tag.pair-tag) $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .r|3) (.emit-undef-check!|4 .as|3 $r.tmp0))))))) (.emit-load-global|2 .as|1 .offset|1 .r|1 .check?|1))))) 'emit-load-global))
+(let () (begin (set! emit-register->register! (lambda (.as|1 .from|1 .to|1) (let ((.emit-register->register!|2 0)) (begin (set! .emit-register->register!|2 (lambda (.as|3 .from|3 .to|3) (if (not (= .from|3 .to|3)) (if (if (hardware-mapped? .from|3) (hardware-mapped? .to|3) #f) (sparc.move .as|3 .from|3 .to|3) (if (hardware-mapped? .from|3) (emit-store-reg! .as|3 .from|3 .to|3) (if (hardware-mapped? .to|3) (emit-load-reg! .as|3 .from|3 .to|3) (begin (emit-load-reg! .as|3 .from|3 $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .to|3))))) (unspecified)))) (.emit-register->register!|2 .as|1 .from|1 .to|1))))) 'emit-register->register!))
+(let () (begin (set! emit-args=! (lambda (.as|1 .n|1) (let ((.emit-args=!|2 0)) (begin (set! .emit-args=!|2 (lambda (.as|3 .n|3) (if (not (unsafe-code)) (let ((.l2|6 (new-label))) (begin (sparc.cmpi .as|3 $r.result (thefixnum .n|3)) (sparc.be.a .as|3 .l2|6) (sparc.slot .as|3) (millicode-call/numarg-in-reg .as|3 $m.argc-ex (thefixnum .n|3) $r.argreg2) (sparc.label .as|3 .l2|6))) (unspecified)))) (.emit-args=!|2 .as|1 .n|1))))) 'emit-args=!))
+(let () (begin (set! emit-args>=! (lambda (.as|1 .n|1) (let ((.emit-args>=!|2 0)) (begin (set! .emit-args>=!|2 (lambda (.as|3 .n|3) (let ((.l0|6 (new-label)) (.l99|6 (new-label)) (.l98|6 (new-label))) (begin (if (< .n|3 (- *lastreg* 1)) (let ((.dest|9 (regname (+ .n|3 1)))) (begin (sparc.cmpi .as|3 $r.result (thefixnum .n|3)) (if (hardware-mapped? .dest|9) (begin (sparc.be.a .as|3 .l99|6) (sparc.set .as|3 $imm.null .dest|9)) (begin (sparc.set .as|3 $imm.null $r.tmp0) (sparc.be.a .as|3 .l99|6) (sparc.sti .as|3 $r.tmp0 (swreg-global-offset .dest|9) $r.globals))) (sparc.cmpi .as|3 $r.result (thefixnum (+ .n|3 1))) (sparc.bne.a .as|3 .l98|6) (sparc.nop .as|3) (millicode-call/numarg-in-result .as|3 $m.alloc 8) (let ((.src1|12 (force-hwreg! .as|3 .dest|9 $r.tmp1))) (begin (sparc.set .as|3 $imm.null $r.tmp0) (sparc.sti .as|3 .src1|12 0 $r.result) (sparc.sti .as|3 $r.tmp0 4 $r.result) (sparc.addi .as|3 $r.result $tag.pair-tag $r.result) (sparc.b .as|3 .l99|6) (if (hardware-mapped? .dest|9) (sparc.move .as|3 $r.result .dest|9) (sparc.sti .as|3 $r.result (swreg-global-offset .dest|9) $r.globals)))))) (unspecified)) (sparc.label .as|3 .l98|6) (sparc.move .as|3 $r.reg0 $r.argreg3) (millicode-call/numarg-in-reg .as|3 $m.varargs (thefixnum .n|3) $r.argreg2) (sparc.label .as|3 .l99|6))))) (.emit-args>=!|2 .as|1 .n|1))))) 'emit-args>=!))
+(let () (begin (set! emit-invoke (lambda (.as|1 .n|1 .setrtn?|1 .mc-exception|1) (let ((.emit-invoke|2 0)) (begin (set! .emit-invoke|2 (lambda (.as|3 .n|3 .setrtn?|3 .mc-exception|3) (let ((.start|6 (new-label)) (.timer-ok|6 (new-label)) (.proc-ok|6 (new-label))) (begin (if (not (unsafe-code)) (begin (sparc.label .as|3 .start|6) (sparc.subicc .as|3 $r.timer 1 $r.timer) (sparc.bne .as|3 .timer-ok|6) (sparc.andi .as|3 $r.result $tag.tagmask $r.tmp0) (millicode-call/ret .as|3 $m.timer-exception .start|6) (sparc.label .as|3 .timer-ok|6) (sparc.cmpi .as|3 $r.tmp0 $tag.procedure-tag) (sparc.be.a .as|3 .proc-ok|6) (sparc.ldi .as|3 $r.result $p.codevector $r.tmp0) (millicode-call/ret .as|3 .mc-exception|3 .start|6) (sparc.label .as|3 .proc-ok|6)) (begin (sparc.label .as|3 .start|6) (sparc.subicc .as|3 $r.timer 1 $r.timer) (sparc.bne.a .as|3 .timer-ok|6) (sparc.ldi .as|3 $r.result $p.codevector $r.tmp0) (millicode-call/ret .as|3 $m.timer-exception .start|6) (sparc.label .as|3 .timer-ok|6))) (sparc.move .as|3 $r.result $r.reg0) (if .setrtn?|3 (begin (sparc.set .as|3 (thefixnum .n|3) $r.result) (sparc.jmpli .as|3 $r.tmp0 $p.codeoffset $r.o7) (sparc.sti .as|3 $r.o7 4 $r.stkp)) (begin (sparc.jmpli .as|3 $r.tmp0 $p.codeoffset $r.g0) (sparc.set .as|3 (thefixnum .n|3) $r.result))))))) (.emit-invoke|2 .as|1 .n|1 .setrtn?|1 .mc-exception|1))))) 'emit-invoke))
+(let () (begin (set! emit-save0! (lambda (.as|1 .n|1) (let ((.emit-save0!|2 0)) (begin (set! .emit-save0!|2 (lambda (.as|3 .n|3) (let* ((.l1|6 (new-label)) (.l0|9 (new-label)) (.framesize|12 (+ 8 (* (+ .n|3 1) 4))) (.realsize|15 (roundup8 (+ .framesize|12 4)))) (let () (begin (sparc.label .as|3 .l0|9) (sparc.subi .as|3 $r.stkp .realsize|15 $r.stkp) (sparc.cmpr .as|3 $r.stklim $r.stkp) (sparc.ble.a .as|3 .l1|6) (sparc.set .as|3 .framesize|12 $r.tmp0) (sparc.addi .as|3 $r.stkp .realsize|15 $r.stkp) (millicode-call/ret .as|3 $m.stkoflow .l0|9) (sparc.label .as|3 .l1|6) (sparc.sti .as|3 $r.tmp0 0 $r.stkp) (sparc.sti .as|3 $r.g0 4 $r.stkp)))))) (.emit-save0!|2 .as|1 .n|1))))) 'emit-save0!))
+(let () (begin (set! emit-save1! (lambda (.as|1 .v|1) (let ((.emit-save1!|2 0)) (begin (set! .emit-save1!|2 (lambda (.as|3 .v|3) (let ((.n|6 (let ((.v|21|24 .v|3)) (begin (.check! (vector? .v|21|24) 42 .v|21|24) (vector-length:vec .v|21|24))))) (let ((.i|9 0) (.offset|9 12)) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.i|13 .offset|13) (if (= .i|13 .n|6) #t (if (let ((.v|16|19 .v|3) (.i|16|19 .i|13)) (begin (.check! (fixnum? .i|16|19) 40 .v|16|19 .i|16|19) (.check! (vector? .v|16|19) 40 .v|16|19 .i|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 40 .v|16|19 .i|16|19) (.check! (>=:fix:fix .i|16|19 0) 40 .v|16|19 .i|16|19) (vector-ref:trusted .v|16|19 .i|16|19))) (begin (sparc.sti .as|3 $r.g0 .offset|13 $r.stkp) (.loop|12 (+ .i|13 1) (+ .offset|13 4))) (.loop|12 (+ .i|13 1) (+ .offset|13 4)))))) (.loop|12 .i|9 .offset|9)))))))) (.emit-save1!|2 .as|1 .v|1))))) 'emit-save1!))
+(let () (begin (set! emit-restore! (lambda (.as|1 .n|1) (let ((.emit-restore!|2 0)) (begin (set! .emit-restore!|2 (lambda (.as|3 .n|3) (let ((.n|6 (min .n|3 31))) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.i|15 .offset|15) (if (> .i|15 .n|6) (if #f #f (unspecified)) (begin (begin #t (let ((.r|20 (regname .i|15))) (if (hardware-mapped? .r|20) (sparc.ldi .as|3 $r.stkp .offset|15 .r|20) (begin (sparc.ldi .as|3 $r.stkp .offset|15 $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .r|20))))) (.loop|8|11|14 (+ .i|15 1) (+ .offset|15 4)))))) (.loop|8|11|14 0 12))))))) (.emit-restore!|2 .as|1 .n|1))))) 'emit-restore!))
+(let () (begin (set! emit-pop! (lambda (.as|1 .n|1 .returning?|1) (let ((.emit-pop!|2 0)) (begin (set! .emit-pop!|2 (lambda (.as|3 .n|3 .returning?|3) (let* ((.framesize|6 (+ 8 (* (+ .n|3 1) 4))) (.realsize|9 (roundup8 (+ .framesize|6 4)))) (let () (if .returning?|3 (begin (sparc.ldi .as|3 $r.stkp (+ .realsize|9 4) $r.o7) (sparc.jmpli .as|3 $r.o7 8 $r.g0) (sparc.addi .as|3 $r.stkp .realsize|9 $r.stkp)) (sparc.addi .as|3 $r.stkp .realsize|9 $r.stkp)))))) (.emit-pop!|2 .as|1 .n|1 .returning?|1))))) 'emit-pop!))
+(let () (begin (set! emit-setrtn! (lambda (.as|1 .label|1) (let ((.emit-setrtn!|2 0)) (begin (set! .emit-setrtn!|2 (lambda (.as|3 .label|3) (begin (emit-return-address! .as|3 .label|3) (sparc.sti .as|3 $r.o7 4 $r.stkp)))) (.emit-setrtn!|2 .as|1 .label|1))))) 'emit-setrtn!))
+(let () (begin (set! emit-apply! (lambda (.as|1 .r1|1 .r2|1) (let ((.emit-apply!|2 0)) (begin (set! .emit-apply!|2 (lambda (.as|3 .r1|3 .r2|3) (let ((.l0|6 (new-label))) (begin (check-timer0 .as|3) (sparc.label .as|3 .l0|6) (emit-move2hwreg! .as|3 .r1|3 $r.argreg2) (emit-move2hwreg! .as|3 .r2|3 $r.argreg3) (millicode-call/0arg .as|3 $m.apply))))) (.emit-apply!|2 .as|1 .r1|1 .r2|1))))) 'emit-apply!))
+(let () (begin (set! emit-load! (lambda (.as|1 .slot|1 .dest-reg|1) (let ((.emit-load!|2 0)) (begin (set! .emit-load!|2 (lambda (.as|3 .slot|3 .dest-reg|3) (if (hardware-mapped? .dest-reg|3) (sparc.ldi .as|3 $r.stkp (+ 12 (* .slot|3 4)) .dest-reg|3) (begin (sparc.ldi .as|3 $r.stkp (+ 12 (* .slot|3 4)) $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .dest-reg|3))))) (.emit-load!|2 .as|1 .slot|1 .dest-reg|1))))) 'emit-load!))
+(let () (begin (set! emit-store! (lambda (.as|1 .k|1 .n|1) (let ((.emit-store!|2 0)) (begin (set! .emit-store!|2 (lambda (.as|3 .k|3 .n|3) (if (hardware-mapped? .k|3) (sparc.sti .as|3 .k|3 (+ 12 (* .n|3 4)) $r.stkp) (begin (emit-load-reg! .as|3 .k|3 $r.tmp0) (sparc.sti .as|3 $r.tmp0 (+ 12 (* .n|3 4)) $r.stkp))))) (.emit-store!|2 .as|1 .k|1 .n|1))))) 'emit-store!))
+(let () (begin (set! emit-lexical! (lambda (.as|1 .m|1 .n|1) (let ((.emit-lexical!|2 0)) (begin (set! .emit-lexical!|2 (lambda (.as|3 .m|3 .n|3) (let ((.base|6 (emit-follow-chain! .as|3 .m|3))) (sparc.ldi .as|3 .base|6 (- (procedure-slot-offset .n|3) $tag.procedure-tag) $r.result)))) (.emit-lexical!|2 .as|1 .m|1 .n|1))))) 'emit-lexical!))
+(let () (begin (set! emit-setlex! (lambda (.as|1 .m|1 .n|1) (let ((.emit-setlex!|2 0)) (begin (set! .emit-setlex!|2 (lambda (.as|3 .m|3 .n|3) (let ((.base|6 (emit-follow-chain! .as|3 .m|3))) (begin (sparc.sti .as|3 $r.result (- (procedure-slot-offset .n|3) $tag.procedure-tag) .base|6) (if (write-barrier) (begin (sparc.move .as|3 $r.result $r.argreg2) (millicode-call/1arg-in-result .as|3 $m.addtrans .base|6)) (unspecified)))))) (.emit-setlex!|2 .as|1 .m|1 .n|1))))) 'emit-setlex!))
+(let () (begin (set! emit-follow-chain! (lambda (.as|1 .m|1) (let ((.emit-follow-chain!|2 0)) (begin (set! .emit-follow-chain!|2 (lambda (.as|3 .m|3) (let ((.q|6 .m|3)) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.q|10) (if (not (zero? .q|10)) (begin (sparc.ldi .as|3 (if (= .q|10 .m|3) $r.reg0 $r.argreg3) $p.linkoffset $r.argreg3) (.loop|9 (- .q|10 1))) (if (zero? .m|3) $r.reg0 $r.argreg3)))) (.loop|9 .q|6))))))) (.emit-follow-chain!|2 .as|1 .m|1))))) 'emit-follow-chain!))
+(let () (begin (set! emit-return! (lambda (.as|1) (let ((.emit-return!|2 0)) (begin (set! .emit-return!|2 (lambda (.as|3) (begin (sparc.ldi .as|3 $r.stkp 4 $r.o7) (sparc.jmpli .as|3 $r.o7 8 $r.g0) (sparc.nop .as|3)))) (.emit-return!|2 .as|1))))) 'emit-return!))
+(let () (begin (set! emit-return-reg! (lambda (.as|1 .r|1) (let ((.emit-return-reg!|2 0)) (begin (set! .emit-return-reg!|2 (lambda (.as|3 .r|3) (begin (sparc.ldi .as|3 $r.stkp 4 $r.o7) (sparc.jmpli .as|3 $r.o7 8 $r.g0) (sparc.move .as|3 .r|3 $r.result)))) (.emit-return-reg!|2 .as|1 .r|1))))) 'emit-return-reg!))
+(let () (begin (set! emit-return-const! (lambda (.as|1 .c|1) (let ((.emit-return-const!|2 0)) (begin (set! .emit-return-const!|2 (lambda (.as|3 .c|3) (begin (sparc.ldi .as|3 $r.stkp 4 $r.o7) (sparc.jmpli .as|3 $r.o7 8 $r.g0) (emit-constant->register .as|3 .c|3 $r.result)))) (.emit-return-const!|2 .as|1 .c|1))))) 'emit-return-const!))
+(let () (begin (set! emit-mvrtn! (lambda (.as|1) (let ((.emit-mvrtn!|2 0)) (begin (set! .emit-mvrtn!|2 (lambda (.as|3) (asm-error "multiple-value return has not been implemented (yet)."))) (.emit-mvrtn!|2 .as|1))))) 'emit-mvrtn!))
+(let () (begin (set! emit-lexes! (lambda (.as|1 .n-slots|1) (let ((.emit-lexes!|2 0)) (begin (set! .emit-lexes!|2 (lambda (.as|3 .n-slots|3) (begin (emit-alloc-proc! .as|3 .n-slots|3) (sparc.ldi .as|3 $r.reg0 $p.codevector $r.tmp0) (sparc.ldi .as|3 $r.reg0 $p.constvector $r.tmp1) (sparc.sti .as|3 $r.tmp0 $p.codevector $r.result) (sparc.sti .as|3 $r.tmp1 $p.constvector $r.result) (emit-init-proc-slots! .as|3 .n-slots|3)))) (.emit-lexes!|2 .as|1 .n-slots|1))))) 'emit-lexes!))
+(let () (begin (set! emit-lambda! (lambda (.as|1 .code-offs0|1 .const-offs0|1 .n-slots|1) (let ((.emit-lambda!|2 0)) (begin (set! .emit-lambda!|2 (lambda (.as|3 .code-offs0|3 .const-offs0|3 .n-slots|3) (let* ((.code-offs|6 (+ 4 (- (* 4 .code-offs0|3) $tag.vector-tag))) (.const-offs|9 (+ 4 (- (* 4 .const-offs0|3) $tag.vector-tag))) (.fits?|12 (asm:fits? .const-offs|9 13))) (let () (begin (emit-alloc-proc! .as|3 .n-slots|3) (if .fits?|12 (begin (sparc.ldi .as|3 $r.reg0 $p.constvector $r.tmp0) (sparc.ldi .as|3 $r.tmp0 .code-offs|6 $r.tmp1)) (emit-const->register! .as|3 .code-offs0|3 $r.tmp1)) (sparc.sti .as|3 $r.tmp1 $p.codevector $r.result) (if .fits?|12 (begin (sparc.ldi .as|3 $r.reg0 $p.constvector $r.tmp0) (sparc.ldi .as|3 $r.tmp0 .const-offs|9 $r.tmp1)) (emit-const->register! .as|3 .const-offs0|3 $r.tmp1)) (sparc.sti .as|3 $r.tmp1 $p.constvector $r.result) (emit-init-proc-slots! .as|3 .n-slots|3)))))) (.emit-lambda!|2 .as|1 .code-offs0|1 .const-offs0|1 .n-slots|1))))) 'emit-lambda!))
+(let () (begin (set! emit-alloc-proc! (let ((.two^12|3 (expt 2 12))) (lambda (.as|4 .n|4) (begin (millicode-call/numarg-in-result .as|4 $m.alloc (* (+ .n|4 4) 4)) (let ((.header|7 (+ (* (* (+ .n|4 3) 4) 256) $imm.procedure-header))) (begin (emit-immediate->register! .as|4 .header|7 $r.tmp0) (sparc.sti .as|4 $r.tmp0 0 $r.result) (sparc.addi .as|4 $r.result $tag.procedure-tag $r.result))))))) 'emit-alloc-proc!))
+(let () (begin (set! emit-init-proc-slots! (lambda (.as|1 .n|1) (let ((.emit-init-proc-slots!|2 0)) (begin (set! .emit-init-proc-slots!|2 (lambda (.as|3 .n|3) (let ((.save-list|5 (unspecified)) (.save-registers|5 (unspecified))) (begin (set! .save-list|5 (lambda (.lo|6 .hi|6 .offset|6) (begin (emit-load-reg! .as|3 $r.reg31 $r.tmp0) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.lo|15 .offset|15) (if (> .lo|15 .hi|6) (if #f #f (unspecified)) (begin (begin #t (sparc.ldi .as|3 $r.tmp0 (- 0 $tag.pair-tag) $r.tmp1) (sparc.sti .as|3 $r.tmp1 .offset|15 $r.result) (if (< .lo|15 .hi|6) (sparc.ldi .as|3 $r.tmp0 (+ (- 0 $tag.pair-tag) 4) $r.tmp0) (unspecified))) (.loop|8|11|14 (+ .lo|15 1) (+ .offset|15 4)))))) (.loop|8|11|14 .lo|6 .offset|6))))))) (set! .save-registers|5 (lambda (.lo|20 .hi|20 .offset|20) (let () (let ((.loop|22|25|28 (unspecified))) (begin (set! .loop|22|25|28 (lambda (.lo|29 .offset|29) (if (> .lo|29 .hi|20) (if #f #f (unspecified)) (begin (begin #t (let ((.r|34 (force-hwreg! .as|3 (regname .lo|29) $r.tmp0))) (sparc.sti .as|3 .r|34 .offset|29 $r.result))) (.loop|22|25|28 (+ .lo|29 1) (+ .offset|29 4)))))) (.loop|22|25|28 .lo|20 .offset|20)))))) (if (< .n|3 *lastreg*) (.save-registers|5 0 .n|3 $p.reg0) (begin (.save-registers|5 0 (- *lastreg* 1) $p.reg0) (.save-list|5 *lastreg* .n|3 (+ $p.reg0 (* *lastreg* 4))))))))) (.emit-init-proc-slots!|2 .as|1 .n|1))))) 'emit-init-proc-slots!))
+(let () (begin (set! emit-branch! (lambda (.as|1 .check-timer?|1 .label|1) (let ((.emit-branch!|2 0)) (begin (set! .emit-branch!|2 (lambda (.as|3 .check-timer?|3 .label|3) (if .check-timer?|3 (check-timer .as|3 .label|3 .label|3) (begin (sparc.b .as|3 .label|3) (sparc.slot .as|3))))) (.emit-branch!|2 .as|1 .check-timer?|1 .label|1))))) 'emit-branch!))
+(let () (begin (set! emit-branchf! (lambda (.as|1 .label|1) (let ((.emit-branchf!|2 0)) (begin (set! .emit-branchf!|2 (lambda (.as|3 .label|3) (emit-branchfreg! .as|3 $r.result .label|3))) (.emit-branchf!|2 .as|1 .label|1))))) 'emit-branchf!))
+(let () (begin (set! emit-branchfreg! (lambda (.as|1 .hwreg|1 .label|1) (let ((.emit-branchfreg!|2 0)) (begin (set! .emit-branchfreg!|2 (lambda (.as|3 .hwreg|3 .label|3) (begin (sparc.cmpi .as|3 .hwreg|3 $imm.false) (sparc.be.a .as|3 .label|3) (sparc.slot .as|3)))) (.emit-branchfreg!|2 .as|1 .hwreg|1 .label|1))))) 'emit-branchfreg!))
+(let () (begin (set! emit-branch-with-setrtn! (lambda (.as|1 .label|1) (let ((.emit-branch-with-setrtn!|2 0)) (begin (set! .emit-branch-with-setrtn!|2 (lambda (.as|3 .label|3) (begin (check-timer0 .as|3) (sparc.call .as|3 .label|3) (sparc.sti .as|3 $r.o7 4 $r.stkp)))) (.emit-branch-with-setrtn!|2 .as|1 .label|1))))) 'emit-branch-with-setrtn!))
+(let () (begin (set! emit-jump! (lambda (.as|1 .m|1 .label|1) (let ((.emit-jump!|2 0)) (begin (set! .emit-jump!|2 (lambda (.as|3 .m|3 .label|3) (let* ((.r|6 (emit-follow-chain! .as|3 .m|3)) (.labelv|9 (label-value .as|3 .label|3)) (.v|12 (if (number? .labelv|9) (+ .labelv|9 $p.codeoffset) (let* ((.t1|18|21 '+) (.t2|18|24 (let* ((.t1|28|31 .label|3) (.t2|28|34 (cons $p.codeoffset '()))) (let () (cons .t1|28|31 .t2|28|34))))) (let () (cons .t1|18|21 .t2|18|24)))))) (let () (begin (sparc.ldi .as|3 .r|6 $p.codevector $r.tmp0) (if (if (number? .v|12) (immediate-literal? .v|12) #f) (sparc.jmpli .as|3 $r.tmp0 .v|12 $r.g0) (begin (emit-immediate->register! .as|3 .v|12 $r.tmp1) (sparc.jmplr .as|3 $r.tmp0 $r.tmp1 $r.g0))) (sparc.move .as|3 .r|6 $r.reg0)))))) (.emit-jump!|2 .as|1 .m|1 .label|1))))) 'emit-jump!))
+(let () (begin (set! emit-singlestep-instr! (lambda (.as|1 .funky?|1 .funkyloc|1 .cvlabel|1) (let ((.emit-singlestep-instr!|2 0)) (begin (set! .emit-singlestep-instr!|2 (lambda (.as|3 .funky?|3 .funkyloc|3 .cvlabel|3) (begin (if .funky?|3 (sparc.ldi .as|3 $r.stkp (+ (thefixnum .funkyloc|3) 12) $r.reg0) (unspecified)) (millicode-call/numarg-in-reg .as|3 $m.singlestep (thefixnum .cvlabel|3) $r.argreg2)))) (.emit-singlestep-instr!|2 .as|1 .funky?|1 .funkyloc|1 .cvlabel|1))))) 'emit-singlestep-instr!))
+(let () (begin (set! emit-return-address! (lambda (.as|1 .label|1) (let ((.emit-return-address!|2 0)) (begin (set! .emit-return-address!|2 (lambda (.as|3 .label|3) (let* ((.loc|6 (here .as|3)) (.lloc|9 (label-value .as|3 .label|3))) (let () (let ((.emit-long|14 (unspecified)) (.emit-short|14 (unspecified))) (begin (set! .emit-long|14 (lambda (.val|15) (begin (sparc.sethi .as|3 (.cons 'hi (.cons .val|15 '())) $r.tmp0) (sparc.ori .as|3 $r.tmp0 (.cons 'lo (.cons .val|15 '())) $r.tmp0) (sparc.call .as|3 (+ .loc|6 16)) (sparc.addr .as|3 $r.o7 $r.tmp0 $r.o7)))) (set! .emit-short|14 (lambda (.val|62) (begin (sparc.call .as|3 (+ .loc|6 8)) (sparc.addi .as|3 $r.o7 .val|62 $r.o7)))) (if .lloc|9 (let ((.target-rel-addr|65 (- (- .lloc|9 .loc|6) 8))) (if (immediate-literal? .target-rel-addr|65) (.emit-short|14 .target-rel-addr|65) (.emit-long|14 (- .target-rel-addr|65 8)))) (if (short-effective-addresses) (.emit-short|14 (.cons '- (.cons .label|3 (.cons .loc|6 '(8))))) (.emit-long|14 (.cons '- (.cons .label|3 (.cons .loc|6 '(16))))))))))))) (.emit-return-address!|2 .as|1 .label|1))))) 'emit-return-address!))
+(let () (begin (set! operand5 (lambda (.instruction|1) (let ((.operand5|2 0)) (begin (set! .operand5|2 (lambda (.instruction|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 (let ((.x|25|28 .instruction|3)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.operand5|2 .instruction|1))))) 'operand5))
+(let () (begin (set! operand6 (lambda (.instruction|1) (let ((.operand6|2 0)) (begin (set! .operand6|2 (lambda (.instruction|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .instruction|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.operand6|2 .instruction|1))))) 'operand6))
+(let () (begin (set! operand7 (lambda (.instruction|1) (let ((.operand7|2 0)) (begin (set! .operand7|2 (lambda (.instruction|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 (let ((.x|34|37 .instruction|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.operand7|2 .instruction|1))))) 'operand7))
+(let () (begin (set! emit-primop.1arg! (lambda (.as|1 .op|1) (let ((.emit-primop.1arg!|2 0)) (begin (set! .emit-primop.1arg!|2 (lambda (.as|3 .op|3) ((find-primop .op|3) .as|3))) (.emit-primop.1arg!|2 .as|1 .op|1))))) 'emit-primop.1arg!))
+(let () (begin (set! emit-primop.2arg! (lambda (.as|1 .op|1 .r|1) (let ((.emit-primop.2arg!|2 0)) (begin (set! .emit-primop.2arg!|2 (lambda (.as|3 .op|3 .r|3) ((find-primop .op|3) .as|3 .r|3))) (.emit-primop.2arg!|2 .as|1 .op|1 .r|1))))) 'emit-primop.2arg!))
+(let () (begin (set! emit-primop.3arg! (lambda (.as|1 .a1|1 .a2|1 .a3|1) (let ((.emit-primop.3arg!|2 0)) (begin (set! .emit-primop.3arg!|2 (lambda (.as|3 .a1|3 .a2|3 .a3|3) ((find-primop .a1|3) .as|3 .a2|3 .a3|3))) (.emit-primop.3arg!|2 .as|1 .a1|1 .a2|1 .a3|1))))) 'emit-primop.3arg!))
+(let () (begin (set! emit-primop.4arg! (lambda (.as|1 .a1|1 .a2|1 .a3|1 .a4|1) (let ((.emit-primop.4arg!|2 0)) (begin (set! .emit-primop.4arg!|2 (lambda (.as|3 .a1|3 .a2|3 .a3|3 .a4|3) ((find-primop .a1|3) .as|3 .a2|3 .a3|3 .a4|3))) (.emit-primop.4arg!|2 .as|1 .a1|1 .a2|1 .a3|1 .a4|1))))) 'emit-primop.4arg!))
+(let () (begin (set! emit-primop.5arg! (lambda (.as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1) (let ((.emit-primop.5arg!|2 0)) (begin (set! .emit-primop.5arg!|2 (lambda (.as|3 .a1|3 .a2|3 .a3|3 .a4|3 .a5|3) ((find-primop .a1|3) .as|3 .a2|3 .a3|3 .a4|3 .a5|3))) (.emit-primop.5arg!|2 .as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1))))) 'emit-primop.5arg!))
+(let () (begin (set! emit-primop.6arg! (lambda (.as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1 .a6|1) (let ((.emit-primop.6arg!|2 0)) (begin (set! .emit-primop.6arg!|2 (lambda (.as|3 .a1|3 .a2|3 .a3|3 .a4|3 .a5|3 .a6|3) ((find-primop .a1|3) .as|3 .a2|3 .a3|3 .a4|3 .a5|3 .a6|3))) (.emit-primop.6arg!|2 .as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1 .a6|1))))) 'emit-primop.6arg!))
+(let () (begin (set! emit-primop.7arg! (lambda (.as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1 .a6|1 .a7|1) (let ((.emit-primop.7arg!|2 0)) (begin (set! .emit-primop.7arg!|2 (lambda (.as|3 .a1|3 .a2|3 .a3|3 .a4|3 .a5|3 .a6|3 .a7|3) ((find-primop .a1|3) .as|3 .a2|3 .a3|3 .a4|3 .a5|3 .a6|3 .a7|3))) (.emit-primop.7arg!|2 .as|1 .a1|1 .a2|1 .a3|1 .a4|1 .a5|1 .a6|1 .a7|1))))) 'emit-primop.7arg!))
+(let () (begin (set! primop-vector (make-vector 256 '())) 'primop-vector))
+(let () (begin (set! define-primop (lambda (.name|1 .proc|1) (let ((.define-primop|2 0)) (begin (set! .define-primop|2 (lambda (.name|3 .proc|3) (let ((.h|6 (logand (symbol-hash .name|3) 255))) (begin (let ((.v|7|10 primop-vector) (.i|7|10 .h|6) (.x|7|10 (cons (cons .name|3 .proc|3) (let ((.v|11|14 primop-vector) (.i|11|14 .h|6)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14)))))) (begin (.check! (fixnum? .i|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (vector? .v|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (>=:fix:fix .i|7|10 0) 41 .v|7|10 .i|7|10 .x|7|10) (vector-set!:trusted .v|7|10 .i|7|10 .x|7|10))) .name|3)))) (.define-primop|2 .name|1 .proc|1))))) 'define-primop))
+(let () (begin (set! find-primop (lambda (.name|1) (let ((.find-primop|2 0)) (begin (set! .find-primop|2 (lambda (.name|3) (let* ((.h|6 (logand (symbol-hash .name|3) 255)) (.x|7|10 (assq .name|3 (let ((.v|11|14 primop-vector) (.i|11|14 .h|6)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14)))))) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))))) (.find-primop|2 .name|1))))) 'find-primop))
+(let () (begin (set! for-each-primop (lambda (.proc|1) (let ((.for-each-primop|2 0)) (begin (set! .for-each-primop|2 (lambda (.proc|3) (let () (let ((.loop|5|7|10 (unspecified))) (begin (set! .loop|5|7|10 (lambda (.i|11) (if (= .i|11 (let ((.v|13|16 primop-vector)) (begin (.check! (vector? .v|13|16) 42 .v|13|16) (vector-length:vec .v|13|16)))) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let ((.p|33 (let ((.x|38|41 .y1|18|19|29)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (.proc|3 (let ((.x|34|37 .p|33)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37)))))) (.loop|23|25|28 (let ((.x|42|45 .y1|18|19|29)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))))))) (.loop|23|25|28 (let ((.v|46|49 primop-vector) (.i|46|49 .i|11)) (begin (.check! (fixnum? .i|46|49) 40 .v|46|49 .i|46|49) (.check! (vector? .v|46|49) 40 .v|46|49 .i|46|49) (.check! (<:fix:fix .i|46|49 (vector-length:vec .v|46|49)) 40 .v|46|49 .i|46|49) (.check! (>=:fix:fix .i|46|49 0) 40 .v|46|49 .i|46|49) (vector-ref:trusted .v|46|49 .i|46|49)))))))) (.loop|5|7|10 (+ .i|11 1)))))) (.loop|5|7|10 0)))))) (.for-each-primop|2 .proc|1))))) 'for-each-primop))
+(let () (define-primop 'unspecified (lambda (.as|1) (emit-immediate->register! .as|1 $imm.unspecified $r.result))))
+(let () (define-primop 'undefined (lambda (.as|1) (emit-immediate->register! .as|1 $imm.undefined $r.result))))
+(let () (define-primop 'eof-object (lambda (.as|1) (emit-immediate->register! .as|1 $imm.eof $r.result))))
+(let () (define-primop 'enable-interrupts (lambda (.as|1) (millicode-call/0arg .as|1 $m.enable-interrupts))))
+(let () (define-primop 'disable-interrupts (lambda (.as|1) (millicode-call/0arg .as|1 $m.disable-interrupts))))
+(let () (define-primop 'gc-counter (lambda (.as|1) (sparc.ldi .as|1 $r.globals $g.gccnt $r.result))))
+(let () (define-primop 'zero? (lambda (.as|1) (emit-cmp-primop! .as|1 sparc.be.a $m.zerop $r.g0))))
+(let () (define-primop '= (lambda (.as|1 .r|1) (emit-cmp-primop! .as|1 sparc.be.a $m.numeq .r|1))))
+(let () (define-primop '< (lambda (.as|1 .r|1) (emit-cmp-primop! .as|1 sparc.bl.a $m.numlt .r|1))))
+(let () (define-primop '<= (lambda (.as|1 .r|1) (emit-cmp-primop! .as|1 sparc.ble.a $m.numle .r|1))))
+(let () (define-primop '> (lambda (.as|1 .r|1) (emit-cmp-primop! .as|1 sparc.bg.a $m.numgt .r|1))))
+(let () (define-primop '>= (lambda (.as|1 .r|1) (emit-cmp-primop! .as|1 sparc.bge.a $m.numge .r|1))))
+(let () (define-primop 'complex? (lambda (.as|1) (millicode-call/0arg .as|1 $m.complexp))))
+(let () (define-primop 'real? (lambda (.as|1) (millicode-call/0arg .as|1 $m.realp))))
+(let () (define-primop 'rational? (lambda (.as|1) (millicode-call/0arg .as|1 $m.rationalp))))
+(let () (define-primop 'integer? (lambda (.as|1) (millicode-call/0arg .as|1 $m.integerp))))
+(let () (define-primop 'exact? (lambda (.as|1) (millicode-call/0arg .as|1 $m.exactp))))
+(let () (define-primop 'inexact? (lambda (.as|1) (millicode-call/0arg .as|1 $m.inexactp))))
+(let () (define-primop 'fixnum? (lambda (.as|1) (begin (sparc.btsti .as|1 $r.result 3) (emit-set-boolean! .as|1)))))
+(let () (define-primop '+ (lambda (.as|1 .r|1) (emit-primop.4arg! .as|1 'internal:+ $r.result .r|1 $r.result))))
+(let () (define-primop '- (lambda (.as|1 .r|1) (emit-primop.4arg! .as|1 'internal:- $r.result .r|1 $r.result))))
+(let () (define-primop '* (lambda (.as|1 .rs2|1) (emit-multiply-code .as|1 .rs2|1 #f))))
+(let () (begin (set! emit-multiply-code (lambda (.as|1 .rs2|1 .fixnum-arithmetic?|1) (let ((.emit-multiply-code|2 0)) (begin (set! .emit-multiply-code|2 (lambda (.as|3 .rs2|3 .fixnum-arithmetic?|3) (if (if (unsafe-code) .fixnum-arithmetic?|3 #f) (begin (sparc.srai .as|3 $r.result 2 $r.tmp0) (sparc.smulr .as|3 $r.tmp0 .rs2|3 $r.result)) (let ((.rs2|8 (force-hwreg! .as|3 .rs2|3 $r.argreg2)) (.lstart|8 (new-label)) (.ltagok|8 (new-label)) (.loflo|8 (new-label)) (.ldone|8 (new-label))) (begin (sparc.label .as|3 .lstart|8) (sparc.orr .as|3 $r.result .rs2|8 $r.tmp0) (sparc.btsti .as|3 $r.tmp0 3) (sparc.be.a .as|3 .ltagok|8) (sparc.srai .as|3 $r.result 2 $r.tmp0) (sparc.label .as|3 .loflo|8) (if (not (= .rs2|8 $r.argreg2)) (sparc.move .as|3 .rs2|8 $r.argreg2) (unspecified)) (if (not .fixnum-arithmetic?|3) (millicode-call/ret .as|3 $m.multiply .ldone|8) (begin (sparc.set .as|3 (thefixnum $ex.fx*) $r.tmp0) (millicode-call/ret .as|3 $m.exception .lstart|8))) (sparc.label .as|3 .ltagok|8) (sparc.smulr .as|3 $r.tmp0 .rs2|8 $r.tmp0) (sparc.rdy .as|3 $r.tmp1) (sparc.srai .as|3 $r.tmp0 31 $r.tmp2) (sparc.cmpr .as|3 $r.tmp1 $r.tmp2) (sparc.bne.a .as|3 .loflo|8) (sparc.slot .as|3) (sparc.move .as|3 $r.tmp0 $r.result) (sparc.label .as|3 .ldone|8)))))) (.emit-multiply-code|2 .as|1 .rs2|1 .fixnum-arithmetic?|1))))) 'emit-multiply-code))
+(let () (define-primop '/ (lambda (.as|1 .r|1) (millicode-call/1arg .as|1 $m.divide .r|1))))
+(let () (define-primop 'quotient (lambda (.as|1 .r|1) (millicode-call/1arg .as|1 $m.quotient .r|1))))
+(let () (define-primop 'remainder (lambda (.as|1 .r|1) (millicode-call/1arg .as|1 $m.remainder .r|1))))
+(let () (define-primop '-- (lambda (.as|1) (emit-negate .as|1 $r.result $r.result))))
+(let () (define-primop 'round (lambda (.as|1) (millicode-call/0arg .as|1 $m.round))))
+(let () (define-primop 'truncate (lambda (.as|1) (millicode-call/0arg .as|1 $m.truncate))))
+(let () (define-primop 'lognot (lambda (.as|1) (begin (if (not (unsafe-code)) (emit-assert-fixnum! .as|1 $r.result $ex.lognot) (unspecified)) (sparc.ornr .as|1 $r.g0 $r.result $r.result) (sparc.xori .as|1 $r.result 3 $r.result)))))
+(let () (define-primop 'logand (lambda (.as|1 .x|1) (logical-op .as|1 $r.result .x|1 $r.result sparc.andr $ex.logand))))
+(let () (define-primop 'logior (lambda (.as|1 .x|1) (logical-op .as|1 $r.result .x|1 $r.result sparc.orr $ex.logior))))
+(let () (define-primop 'logxor (lambda (.as|1 .x|1) (logical-op .as|1 $r.result .x|1 $r.result sparc.xorr $ex.logxor))))
+(let () (define-primop 'lsh (lambda (.as|1 .x|1) (emit-shift-operation .as|1 $ex.lsh $r.result .x|1 $r.result))))
+(let () (define-primop 'rshl (lambda (.as|1 .x|1) (emit-shift-operation .as|1 $ex.rshl $r.result .x|1 $r.result))))
+(let () (define-primop 'rsha (lambda (.as|1 .x|1) (emit-shift-operation .as|1 $ex.rsha $r.result .x|1 $r.result))))
+(let () (define-primop 'rot (lambda (.as|1 .x|1) (asm-error "Sparcasm: ROT primop is not implemented."))))
+(let () (define-primop 'null? (lambda (.as|1) (begin (sparc.cmpi .as|1 $r.result $imm.null) (emit-set-boolean! .as|1)))))
+(let () (define-primop 'pair? (lambda (.as|1) (emit-single-tagcheck->bool! .as|1 $tag.pair-tag))))
+(let () (define-primop 'eof-object? (lambda (.as|1) (begin (sparc.cmpi .as|1 $r.result $imm.eof) (emit-set-boolean! .as|1)))))
+(let () (define-primop 'flonum? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.flonum-typetag)))))
+(let () (define-primop 'compnum? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.compnum-typetag)))))
+(let () (define-primop 'symbol? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.symbol-typetag)))))
+(let () (define-primop 'port? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.port-typetag)))))
+(let () (define-primop 'structure? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.structure-typetag)))))
+(let () (define-primop 'char? (lambda (.as|1) (begin (sparc.andi .as|1 $r.result 255 $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $imm.character) (emit-set-boolean! .as|1)))))
+(let () (define-primop 'string? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.string-typetag)))))
+(let () (define-primop 'bytevector? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.bytevector-typetag)))))
+(let () (define-primop 'bytevector-like? (lambda (.as|1) (emit-single-tagcheck->bool! .as|1 $tag.bytevector-tag))))
+(let () (define-primop 'vector? (lambda (.as|1) (emit-double-tagcheck->bool! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.vector-typetag)))))
+(let () (define-primop 'vector-like? (lambda (.as|1) (emit-single-tagcheck->bool! .as|1 $tag.vector-tag))))
+(let () (define-primop 'procedure? (lambda (.as|1) (emit-single-tagcheck->bool! .as|1 $tag.procedure-tag))))
+(let () (define-primop 'cons (lambda (.as|1 .r|1) (emit-primop.4arg! .as|1 'internal:cons $r.result .r|1 $r.result))))
+(let () (define-primop 'car (lambda (.as|1) (emit-primop.3arg! .as|1 'internal:car $r.result $r.result))))
+(let () (define-primop 'cdr (lambda (.as|1) (emit-primop.3arg! .as|1 'internal:cdr $r.result $r.result))))
+(let () (define-primop 'car:pair (lambda (.as|1) (sparc.ldi .as|1 $r.result (- 0 $tag.pair-tag) $r.result))))
+(let () (define-primop 'cdr:pair (lambda (.as|1) (sparc.ldi .as|1 $r.result (- 4 $tag.pair-tag) $r.result))))
+(let () (define-primop 'set-car! (lambda (.as|1 .x|1) (begin (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.pair-tag $ex.car #f) (unspecified)) (emit-setcar/setcdr! .as|1 $r.result .x|1 0)))))
+(let () (define-primop 'set-cdr! (lambda (.as|1 .x|1) (begin (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.pair-tag $ex.cdr #f) (unspecified)) (emit-setcar/setcdr! .as|1 $r.result .x|1 4)))))
+(let () (define-primop 'make-cell (lambda (.as|1) (emit-primop.4arg! .as|1 'internal:cons $r.result $r.g0 $r.result))))
+(let () (define-primop 'cell-ref (lambda (.as|1) (emit-primop.3arg! .as|1 'internal:cell-ref $r.result $r.result))))
+(let () (define-primop 'cell-set! (lambda (.as|1 .r|1) (emit-setcar/setcdr! .as|1 $r.result .r|1 0))))
+(let () (define-primop 'syscall (lambda (.as|1) (millicode-call/0arg .as|1 $m.syscall))))
+(let () (define-primop 'break (lambda (.as|1) (millicode-call/0arg .as|1 $m.break))))
+(let () (define-primop 'creg (lambda (.as|1) (millicode-call/0arg .as|1 $m.creg))))
+(let () (define-primop 'creg-set! (lambda (.as|1) (millicode-call/0arg .as|1 $m.creg-set!))))
+(let () (define-primop 'typetag (lambda (.as|1) (millicode-call/0arg .as|1 $m.typetag))))
+(let () (define-primop 'typetag-set! (lambda (.as|1 .r|1) (millicode-call/1arg .as|1 $m.typetag-set .r|1))))
+(let () (define-primop 'exact->inexact (lambda (.as|1) (millicode-call/0arg .as|1 $m.exact->inexact))))
+(let () (define-primop 'inexact->exact (lambda (.as|1) (millicode-call/0arg .as|1 $m.inexact->exact))))
+(let () (define-primop 'real-part (lambda (.as|1) (millicode-call/0arg .as|1 $m.real-part))))
+(let () (define-primop 'imag-part (lambda (.as|1) (millicode-call/0arg .as|1 $m.imag-part))))
+(let () (define-primop 'char->integer (lambda (.as|1) (begin (if (not (unsafe-code)) (emit-assert-char! .as|1 $ex.char2int #f) (unspecified)) (sparc.srli .as|1 $r.result 14 $r.result)))))
+(let () (define-primop 'integer->char (lambda (.as|1) (begin (if (not (unsafe-code)) (emit-assert-fixnum! .as|1 $r.result $ex.int2char) (unspecified)) (sparc.andi .as|1 $r.result 1023 $r.result) (sparc.slli .as|1 $r.result 14 $r.result) (sparc.ori .as|1 $r.result $imm.character $r.result)))))
+(let () (define-primop 'not (lambda (.as|1) (begin (sparc.cmpi .as|1 $r.result $imm.false) (emit-set-boolean! .as|1)))))
+(let () (define-primop 'eq? (lambda (.as|1 .x|1) (emit-primop.4arg! .as|1 'internal:eq? $r.result .x|1 $r.result))))
+(let () (define-primop 'eqv? (lambda (.as|1 .x|1) (let ((.tmp|4 (force-hwreg! .as|1 .x|1 $r.tmp0)) (.l1|4 (new-label))) (begin (sparc.cmpr .as|1 $r.result .tmp|4) (sparc.be.a .as|1 .l1|4) (sparc.set .as|1 $imm.true $r.result) (millicode-call/1arg .as|1 $m.eqv .tmp|4) (sparc.label .as|1 .l1|4))))))
+(let () (define-primop 'make-bytevector (lambda (.as|1) (begin (if (not (unsafe-code)) (emit-assert-positive-fixnum! .as|1 $r.result $ex.mkbvl) (unspecified)) (emit-allocate-bytevector .as|1 (+ $imm.bytevector-header $tag.bytevector-typetag) #f) (sparc.addi .as|1 $r.result $tag.bytevector-tag $r.result)))))
+(let () (define-primop 'bytevector-fill! (lambda (.as|1 .rs2|1) (let* ((.fault|4 (emit-double-tagcheck-assert! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.bytevector-typetag) $ex.bvfill .rs2|1)) (.rs2|7 (force-hwreg! .as|1 .rs2|1 $r.argreg2))) (let () (begin (sparc.btsti .as|1 .rs2|7 3) (sparc.bne .as|1 .fault|4) (sparc.srai .as|1 .rs2|7 2 $r.tmp2) (sparc.ldi .as|1 $r.result (- 0 $tag.bytevector-tag) $r.tmp0) (sparc.addi .as|1 $r.result (- 4 $tag.bytevector-tag) $r.tmp1) (sparc.srai .as|1 $r.tmp0 8 $r.tmp0) (emit-bytevector-fill .as|1 $r.tmp0 $r.tmp1 $r.tmp2)))))))
+(let () (define-primop 'bytevector-length (lambda (.as|1) (emit-get-length! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.bytevector-typetag) $ex.bvlen $r.result $r.result))))
+(let () (define-primop 'bytevector-like-length (lambda (.as|1) (emit-get-length! .as|1 $tag.bytevector-tag #f $ex.bvllen $r.result $r.result))))
+(let () (define-primop 'bytevector-ref (lambda (.as|1 .r|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.bytevector-typetag) $ex.bvref .r|1) #f))) (emit-bytevector-like-ref! .as|1 $r.result .r|1 $r.result .fault|4 #f #t)))))
+(let () (define-primop 'bytevector-like-ref (lambda (.as|1 .r|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.bytevector-tag $ex.bvlref .r|1) #f))) (emit-bytevector-like-ref! .as|1 $r.result .r|1 $r.result .fault|4 #f #f)))))
+(let () (define-primop 'bytevector-set! (lambda (.as|1 .r1|1 .r2|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.bytevector-typetag) $ex.bvset .r1|1) #f))) (emit-bytevector-like-set! .as|1 .r1|1 .r2|1 .fault|4 #t)))))
+(let () (define-primop 'bytevector-like-set! (lambda (.as|1 .r1|1 .r2|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.bytevector-tag $ex.bvlset .r1|1) #f))) (emit-bytevector-like-set! .as|1 .r1|1 .r2|1 .fault|4 #f)))))
+(let () (define-primop 'sys$bvlcmp (lambda (.as|1 .x|1) (millicode-call/1arg .as|1 $m.bvlcmp .x|1))))
+(let () (define-primop 'make-string (lambda (.as|1 .rs2|1) (let ((.fault|4 (new-label)) (.start|4 (new-label))) (begin (sparc.label .as|1 .start|4) (let ((.rs2|7 (force-hwreg! .as|1 .rs2|1 $r.argreg2))) (begin (if (not (unsafe-code)) (let ((.l1|10 (new-label)) (.l2|10 (new-label))) (begin (sparc.tsubrcc .as|1 $r.result $r.g0 $r.g0) (sparc.bvc.a .as|1 .l1|10) (sparc.andi .as|1 .rs2|7 255 $r.tmp0) (sparc.label .as|1 .fault|4) (if (not (= .rs2|7 $r.argreg2)) (sparc.move .as|1 .rs2|7 $r.argreg2) (unspecified)) (sparc.set .as|1 (thefixnum $ex.mkbvl) $r.tmp0) (millicode-call/ret .as|1 $m.exception .start|4) (sparc.label .as|1 .l1|10) (sparc.bl .as|1 .fault|4) (sparc.cmpi .as|1 $r.tmp0 $imm.character) (sparc.bne .as|1 .fault|4) (sparc.move .as|1 $r.result $r.argreg3))) (sparc.move .as|1 $r.result $r.argreg3)) (emit-allocate-bytevector .as|1 (+ $imm.bytevector-header $tag.string-typetag) $r.argreg3) (sparc.srai .as|1 .rs2|7 16 $r.tmp1) (sparc.addi .as|1 $r.result 4 $r.result) (sparc.srai .as|1 $r.argreg3 2 $r.tmp0) (emit-bytevector-fill .as|1 $r.tmp0 $r.result $r.tmp1) (sparc.addi .as|1 $r.result (- $tag.bytevector-tag 4) $r.result))))))))
+(let () (define-primop 'string-length (lambda (.as|1) (emit-primop.3arg! .as|1 'internal:string-length $r.result $r.result))))
+(let () (define-primop 'string-ref (lambda (.as|1 .r|1) (emit-primop.4arg! .as|1 'internal:string-ref $r.result .r|1 $r.result))))
+(let () (define-primop 'string-set! (lambda (.as|1 .r1|1 .r2|1) (emit-string-set! .as|1 $r.result .r1|1 .r2|1))))
+(let () (define-primop 'sys$partial-list->vector (lambda (.as|1 .r|1) (millicode-call/1arg .as|1 $m.partial-list->vector .r|1))))
+(let () (define-primop 'make-procedure (lambda (.as|1) (emit-make-vector-like! .as|1 '() $imm.procedure-header $tag.procedure-tag))))
+(let () (define-primop 'make-vector (lambda (.as|1 .r|1) (emit-make-vector-like! .as|1 .r|1 (+ $imm.vector-header $tag.vector-typetag) $tag.vector-tag))))
+(let () (define-primop 'make-vector:0 (lambda (.as|1 .r|1) (make-vector-n .as|1 0 .r|1))))
+(let () (define-primop 'make-vector:1 (lambda (.as|1 .r|1) (make-vector-n .as|1 1 .r|1))))
+(let () (define-primop 'make-vector:2 (lambda (.as|1 .r|1) (make-vector-n .as|1 2 .r|1))))
+(let () (define-primop 'make-vector:3 (lambda (.as|1 .r|1) (make-vector-n .as|1 3 .r|1))))
+(let () (define-primop 'make-vector:4 (lambda (.as|1 .r|1) (make-vector-n .as|1 4 .r|1))))
+(let () (define-primop 'make-vector:5 (lambda (.as|1 .r|1) (make-vector-n .as|1 5 .r|1))))
+(let () (define-primop 'make-vector:6 (lambda (.as|1 .r|1) (make-vector-n .as|1 6 .r|1))))
+(let () (define-primop 'make-vector:7 (lambda (.as|1 .r|1) (make-vector-n .as|1 7 .r|1))))
+(let () (define-primop 'make-vector:8 (lambda (.as|1 .r|1) (make-vector-n .as|1 8 .r|1))))
+(let () (define-primop 'make-vector:9 (lambda (.as|1 .r|1) (make-vector-n .as|1 9 .r|1))))
+(let () (define-primop 'vector-length (lambda (.as|1) (emit-primop.3arg! .as|1 'internal:vector-length $r.result $r.result))))
+(let () (define-primop 'vector-like-length (lambda (.as|1) (emit-get-length! .as|1 $tag.vector-tag #f $ex.vllen $r.result $r.result))))
+(let () (define-primop 'vector-length:vec (lambda (.as|1) (emit-get-length-trusted! .as|1 $tag.vector-tag $r.result $r.result))))
+(let () (define-primop 'procedure-length (lambda (.as|1) (emit-get-length! .as|1 $tag.procedure-tag #f $ex.plen $r.result $r.result))))
+(let () (define-primop 'vector-ref (lambda (.as|1 .r|1) (emit-primop.4arg! .as|1 'internal:vector-ref $r.result .r|1 $r.result))))
+(let () (define-primop 'vector-like-ref (lambda (.as|1 .r|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.vector-tag $ex.vlref .r|1) #f))) (emit-vector-like-ref! .as|1 $r.result .r|1 $r.result .fault|4 $tag.vector-tag #f)))))
+(let () (define-primop 'vector-ref:trusted (lambda (.as|1 .rs2|1) (emit-vector-like-ref-trusted! .as|1 $r.result .rs2|1 $r.result $tag.vector-tag))))
+(let () (define-primop 'procedure-ref (lambda (.as|1 .r|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.procedure-tag $ex.pref .r|1) #f))) (emit-vector-like-ref! .as|1 $r.result .r|1 $r.result .fault|4 $tag.procedure-tag #f)))))
+(let () (define-primop 'vector-set! (lambda (.as|1 .r1|1 .r2|1) (emit-primop.4arg! .as|1 'internal:vector-set! $r.result .r1|1 .r2|1))))
+(let () (define-primop 'vector-like-set! (lambda (.as|1 .r1|1 .r2|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.vector-tag $ex.vlset .r1|1) #f))) (emit-vector-like-set! .as|1 $r.result .r1|1 .r2|1 .fault|4 $tag.vector-tag #f)))))
+(let () (define-primop 'vector-set!:trusted (lambda (.as|1 .rs2|1 .rs3|1) (emit-vector-like-set-trusted! .as|1 $r.result .rs2|1 .rs3|1 $tag.vector-tag))))
+(let () (define-primop 'procedure-set! (lambda (.as|1 .r1|1 .r2|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-single-tagcheck-assert! .as|1 $tag.procedure-tag $ex.pset .r1|1) #f))) (emit-vector-like-set! .as|1 $r.result .r1|1 .r2|1 .fault|4 $tag.procedure-tag #f)))))
+(let () (define-primop 'char<? (lambda (.as|1 .x|1) (emit-char-cmp .as|1 .x|1 sparc.bl.a $ex.char<?))))
+(let () (define-primop 'char<=? (lambda (.as|1 .x|1) (emit-char-cmp .as|1 .x|1 sparc.ble.a $ex.char<=?))))
+(let () (define-primop 'char=? (lambda (.as|1 .x|1) (emit-char-cmp .as|1 .x|1 sparc.be.a $ex.char=?))))
+(let () (define-primop 'char>? (lambda (.as|1 .x|1) (emit-char-cmp .as|1 .x|1 sparc.bg.a $ex.char>?))))
+(let () (define-primop 'char>=? (lambda (.as|1 .x|1) (emit-char-cmp .as|1 .x|1 sparc.bge.a $ex.char>=?))))
+(let () (define-primop 'sys$read-char (lambda (.as|1) (let ((.lfinish|4 (new-label)) (.lend|4 (new-label))) (begin (if (not (unsafe-code)) (begin (sparc.andi .as|1 $r.result $tag.tagmask $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $tag.vector-tag) (sparc.bne .as|1 .lfinish|4) (sparc.nop .as|1) (sparc.ldbi .as|1 $r.result 0 $r.tmp1)) (unspecified)) (sparc.ldi .as|1 $r.result 1 $r.tmp2) (if (not (unsafe-code)) (begin (sparc.cmpi .as|1 $r.tmp1 $hdr.port) (sparc.bne .as|1 .lfinish|4)) (unspecified)) (sparc.cmpi .as|1 $r.tmp2 $imm.false) (sparc.be .as|1 .lfinish|4) (sparc.ldi .as|1 $r.result 33 $r.tmp1) (sparc.ldi .as|1 $r.result 29 $r.tmp2) (sparc.ldi .as|1 $r.result 17 $r.tmp0) (sparc.cmpr .as|1 $r.tmp1 $r.tmp2) (sparc.bge .as|1 .lfinish|4) (sparc.subi .as|1 $r.tmp0 1 $r.tmp0) (sparc.srai .as|1 $r.tmp1 2 $r.tmp2) (sparc.ldbr .as|1 $r.tmp0 $r.tmp2 $r.tmp2) (sparc.addi .as|1 $r.tmp1 4 $r.tmp1) (sparc.sti .as|1 $r.tmp1 33 $r.result) (sparc.slli .as|1 $r.tmp2 16 $r.tmp2) (sparc.b .as|1 .lend|4) (sparc.ori .as|1 $r.tmp2 $imm.character $r.result) (sparc.label .as|1 .lfinish|4) (sparc.set .as|1 $imm.false $r.result) (sparc.label .as|1 .lend|4))))))
+(let () (define-primop 'internal:car (lambda (.as|1 .src1|1 .dest|1) (begin (internal-primop-invariant2 'internal:car .src1|1 .dest|1) (if (not (unsafe-code)) (emit-single-tagcheck-assert-reg! .as|1 $tag.pair-tag .src1|1 #f $ex.car) (unspecified)) (sparc.ldi .as|1 .src1|1 (- 0 $tag.pair-tag) .dest|1)))))
+(let () (define-primop 'internal:cdr (lambda (.as|1 .src1|1 .dest|1) (begin (internal-primop-invariant2 'internal:cdr .src1|1 .dest|1) (if (not (unsafe-code)) (emit-single-tagcheck-assert-reg! .as|1 $tag.pair-tag .src1|1 #f $ex.cdr) (unspecified)) (sparc.ldi .as|1 .src1|1 (- 4 $tag.pair-tag) .dest|1)))))
+(let () (define-primop 'internal:cell-ref (lambda (.as|1 .src1|1 .dest|1) (begin (internal-primop-invariant2 'internal:cell-ref .src1|1 .dest|1) (sparc.ldi .as|1 .src1|1 (- 0 $tag.pair-tag) .dest|1)))))
+(let () (define-primop 'internal:set-car! (lambda (.as|1 .rs1|1 .rs2|1 .dest-ignored|1) (begin (internal-primop-invariant2 'internal:set-car! .rs1|1 .dest-ignored|1) (if (not (unsafe-code)) (emit-single-tagcheck-assert-reg! .as|1 $tag.pair-tag .rs1|1 .rs2|1 $ex.car) (unspecified)) (emit-setcar/setcdr! .as|1 .rs1|1 .rs2|1 0)))))
+(let () (define-primop 'internal:set-cdr! (lambda (.as|1 .rs1|1 .rs2|1 .dest-ignored|1) (begin (internal-primop-invariant2 'internal:set-cdr! .rs1|1 .dest-ignored|1) (if (not (unsafe-code)) (emit-single-tagcheck-assert-reg! .as|1 $tag.pair-tag .rs1|1 .rs2|1 $ex.cdr) (unspecified)) (emit-setcar/setcdr! .as|1 .rs1|1 .rs2|1 4)))))
+(let () (define-primop 'internal:cell-set! (lambda (.as|1 .rs1|1 .rs2|1 .dest-ignored|1) (begin (internal-primop-invariant2 'internal:cell-set! .rs1|1 .dest-ignored|1) (emit-setcar/setcdr! .as|1 .rs1|1 .rs2|1 0)))))
+(let () (define-primop 'internal:cons (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (if (inline-allocation) (let ((.enough-memory|4 (new-label)) (.start|4 (new-label))) (begin (sparc.label .as|1 .start|4) (sparc.addi .as|1 $r.e-top 8 $r.e-top) (sparc.cmpr .as|1 $r.e-top $r.e-limit) (sparc.ble.a .as|1 .enough-memory|4) (sparc.sti .as|1 .rs1|1 -8 $r.e-top) (millicode-call/ret .as|1 $m.gc .start|4) (sparc.label .as|1 .enough-memory|4) (sparc.sti .as|1 (force-hwreg! .as|1 .rs2|1 $r.tmp0) -4 $r.e-top) (sparc.subi .as|1 $r.e-top (- 8 $tag.pair-tag) .rd|1))) (begin (if (= .rs1|1 $r.result) (sparc.move .as|1 $r.result $r.argreg2) (unspecified)) (millicode-call/numarg-in-result .as|1 $m.alloc 8) (if (= .rs1|1 $r.result) (sparc.sti .as|1 $r.argreg2 0 $r.result) (sparc.sti .as|1 .rs1|1 0 $r.result)) (sparc.sti .as|1 (force-hwreg! .as|1 .rs2|1 $r.tmp1) 4 $r.result) (sparc.addi .as|1 $r.result $tag.pair-tag .rd|1))))))
+(let () (define-primop 'internal:car:pair (lambda (.as|1 .src1|1 .dest|1) (begin (internal-primop-invariant2 'internal:car .src1|1 .dest|1) (sparc.ldi .as|1 .src1|1 (- 0 $tag.pair-tag) .dest|1)))))
+(let () (define-primop 'internal:cdr:pair (lambda (.as|1 .src1|1 .dest|1) (begin (internal-primop-invariant2 'internal:cdr .src1|1 .dest|1) (sparc.ldi .as|1 .src1|1 (- 4 $tag.pair-tag) .dest|1)))))
+(let () (define-primop 'internal:vector-length (lambda (.as|1 .rs|1 .rd|1) (begin (internal-primop-invariant2 'internal:vector-length .rs|1 .rd|1) (emit-get-length! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.vector-typetag) $ex.vlen .rs|1 .rd|1)))))
+(let () (define-primop 'internal:vector-ref (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (begin (internal-primop-invariant2 'internal:vector-ref .rs1|1 .rd|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert-reg/reg! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.vector-typetag) .rs1|1 .rs2|1 $ex.vref) (unspecified)))) (emit-vector-like-ref! .as|1 .rs1|1 .rs2|1 .rd|1 .fault|4 $tag.vector-tag #t))))))
+(let () (define-primop 'internal:vector-ref/imm (lambda (.as|1 .rs1|1 .imm|1 .rd|1) (begin (internal-primop-invariant2 'internal:vector-ref/imm .rs1|1 .rd|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert-reg/imm! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.vector-typetag) .rs1|1 .imm|1 $ex.vref) (unspecified)))) (emit-vector-like-ref/imm! .as|1 .rs1|1 .imm|1 .rd|1 .fault|4 $tag.vector-tag #t))))))
+(let () (define-primop 'internal:vector-set! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1) (begin (internal-primop-invariant1 'internal:vector-set! .rs1|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert-reg/reg! .as|1 $tag.vector-tag (+ $imm.vector-header $tag.vector-typetag) .rs1|1 .rs2|1 $ex.vset) (unspecified)))) (emit-vector-like-set! .as|1 .rs1|1 .rs2|1 .rs3|1 .fault|4 $tag.vector-tag #t))))))
+(let () (define-primop 'internal:vector-length:vec (lambda (.as|1 .rs1|1 .dst|1) (begin (internal-primop-invariant2 'internal:vector-length:vec .rs1|1 .dst|1) (emit-get-length-trusted! .as|1 $tag.vector-tag .rs1|1 .dst|1)))))
+(let () (define-primop 'internal:vector-ref:trusted (lambda (.as|1 .rs1|1 .rs2|1 .dst|1) (emit-vector-like-ref-trusted! .as|1 .rs1|1 .rs2|1 .dst|1 $tag.vector-tag))))
+(let () (define-primop 'internal:vector-set!:trusted (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1) (emit-vector-like-ref-trusted! .as|1 .rs1|1 .rs2|1 .rs3|1 $tag.vector-tag))))
+(let () (define-primop 'internal:string-length (lambda (.as|1 .rs|1 .rd|1) (begin (internal-primop-invariant2 'internal:string-length .rs|1 .rd|1) (emit-get-length! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.string-typetag) $ex.slen .rs|1 .rd|1)))))
+(let () (define-primop 'internal:string-ref (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (begin (internal-primop-invariant2 'internal:string-ref .rs1|1 .rd|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert-reg/reg! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.string-typetag) .rs1|1 .rs2|1 $ex.sref) (unspecified)))) (emit-bytevector-like-ref! .as|1 .rs1|1 .rs2|1 .rd|1 .fault|4 #t #t))))))
+(let () (define-primop 'internal:string-ref/imm (lambda (.as|1 .rs1|1 .imm|1 .rd|1) (begin (internal-primop-invariant2 'internal:string-ref/imm .rs1|1 .rd|1) (let ((.fault|4 (if (not (unsafe-code)) (emit-double-tagcheck-assert-reg/imm! .as|1 $tag.bytevector-tag (+ $imm.bytevector-header $tag.string-typetag) .rs1|1 .imm|1 $ex.sref) (unspecified)))) (emit-bytevector-like-ref/imm! .as|1 .rs1|1 .imm|1 .rd|1 .fault|4 #t #t))))))
+(let () (define-primop 'internal:string-set! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1) (begin (internal-primop-invariant1 'internal:string-set! .rs1|1) (emit-string-set! .as|1 .rs1|1 .rs2|1 .rs3|1)))))
+(let () (define-primop 'internal:+ (lambda (.as|1 .src1|1 .src2|1 .dest|1) (begin (internal-primop-invariant2 'internal:+ .src1|1 .dest|1) (emit-arith-primop! .as|1 sparc.taddrcc sparc.subr $m.add .src1|1 .src2|1 .dest|1 #t)))))
+(let () (define-primop 'internal:+/imm (lambda (.as|1 .src1|1 .imm|1 .dest|1) (begin (internal-primop-invariant2 'internal:+/imm .src1|1 .dest|1) (emit-arith-primop! .as|1 sparc.taddicc sparc.subi $m.add .src1|1 .imm|1 .dest|1 #f)))))
+(let () (define-primop 'internal:- (lambda (.as|1 .src1|1 .src2|1 .dest|1) (begin (internal-primop-invariant2 'internal:- .src1|1 .dest|1) (emit-arith-primop! .as|1 sparc.tsubrcc sparc.addr $m.subtract .src1|1 .src2|1 .dest|1 #t)))))
+(let () (define-primop 'internal:-/imm (lambda (.as|1 .src1|1 .imm|1 .dest|1) (begin (internal-primop-invariant2 'internal:-/imm .src1|1 .dest|1) (emit-arith-primop! .as|1 sparc.tsubicc sparc.addi $m.subtract .src1|1 .imm|1 .dest|1 #f)))))
+(let () (define-primop 'internal:-- (lambda (.as|1 .rs|1 .rd|1) (begin (internal-primop-invariant2 'internal:-- .rs|1 .rd|1) (emit-negate .as|1 .rs|1 .rd|1)))))
+(let () (define-primop 'internal:branchf-null? (lambda (.as|1 .reg|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-null? .reg|1) (sparc.cmpi .as|1 .reg|1 $imm.null) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:branchf-pair? (lambda (.as|1 .reg|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-pair? .reg|1) (sparc.andi .as|1 .reg|1 $tag.tagmask $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $tag.pair-tag) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:branchf-zero? (lambda (.as|1 .reg|1 .label|1) (begin (internal-primop-invariant1 'internal:brancf-zero? .reg|1) (emit-bcmp-primop! .as|1 sparc.bne.a .reg|1 $r.g0 .label|1 $m.zerop #t)))))
+(let () (define-primop 'internal:branchf-eof-object? (lambda (.as|1 .rs|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-eof-object? .rs|1) (sparc.cmpi .as|1 .rs|1 $imm.eof) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:branchf-fixnum? (lambda (.as|1 .rs|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-fixnum? .rs|1) (sparc.btsti .as|1 .rs|1 3) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:branchf-char? (lambda (.as|1 .rs|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char? .rs|1) (sparc.andi .as|1 .rs|1 255 $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $imm.character) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:branchf-= (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-= .src1|1) (emit-bcmp-primop! .as|1 sparc.bne.a .src1|1 .src2|1 .label|1 $m.numeq #t)))))
+(let () (define-primop 'internal:branchf-< (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-< .src1|1) (emit-bcmp-primop! .as|1 sparc.bge.a .src1|1 .src2|1 .label|1 $m.numlt #t)))))
+(let () (define-primop 'internal:branchf-<= (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-<= .src1|1) (emit-bcmp-primop! .as|1 sparc.bg.a .src1|1 .src2|1 .label|1 $m.numle #t)))))
+(let () (define-primop 'internal:branchf-> (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-> .src1|1) (emit-bcmp-primop! .as|1 sparc.ble.a .src1|1 .src2|1 .label|1 $m.numgt #t)))))
+(let () (define-primop 'internal:branchf->= (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf->= .src1|1) (emit-bcmp-primop! .as|1 sparc.bl.a .src1|1 .src2|1 .label|1 $m.numge #t)))))
+(let () (define-primop 'internal:branchf-=/imm (lambda (.as|1 .src1|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-=/imm .src1|1) (emit-bcmp-primop! .as|1 sparc.bne.a .src1|1 .imm|1 .label|1 $m.numeq #f)))))
+(let () (define-primop 'internal:branchf-</imm (lambda (.as|1 .src1|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-</imm .src1|1) (emit-bcmp-primop! .as|1 sparc.bge.a .src1|1 .imm|1 .label|1 $m.numlt #f)))))
+(let () (define-primop 'internal:branchf-<=/imm (lambda (.as|1 .src1|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-<=/imm .src1|1) (emit-bcmp-primop! .as|1 sparc.bg.a .src1|1 .imm|1 .label|1 $m.numle #f)))))
+(let () (define-primop 'internal:branchf->/imm (lambda (.as|1 .src1|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf->/imm .src1|1) (emit-bcmp-primop! .as|1 sparc.ble.a .src1|1 .imm|1 .label|1 $m.numgt #f)))))
+(let () (define-primop 'internal:branchf->=/imm (lambda (.as|1 .src1|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf->=/imm .src1|1) (emit-bcmp-primop! .as|1 sparc.bl.a .src1|1 .imm|1 .label|1 $m.numge #f)))))
+(let () (define-primop 'internal:branchf-char=? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char=? .src1|1) (emit-char-bcmp-primop! .as|1 sparc.bne.a .src1|1 .src2|1 .label|1 $ex.char=?)))))
+(let () (define-primop 'internal:branchf-char<=? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char<=? .src1|1) (emit-char-bcmp-primop! .as|1 sparc.bg.a .src1|1 .src2|1 .label|1 $ex.char<=?)))))
+(let () (define-primop 'internal:branchf-char<? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char<? .src1|1) (emit-char-bcmp-primop! .as|1 sparc.bge.a .src1|1 .src2|1 .label|1 $ex.char<?)))))
+(let () (define-primop 'internal:branchf-char>=? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char>=? .src1|1) (emit-char-bcmp-primop! .as|1 sparc.bl.a .src1|1 .src2|1 .label|1 $ex.char>=?)))))
+(let () (define-primop 'internal:branchf-char>? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char>=? .src1|1) (emit-char-bcmp-primop! .as|1 sparc.ble.a .src1|1 .src2|1 .label|1 $ex.char>?)))))
+(let () (define-primop 'internal:branchf-char=?/imm (lambda (.as|1 .src|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char=?/imm .src|1) (emit-char-bcmp-primop! .as|1 sparc.bne.a .src|1 .imm|1 .label|1 $ex.char=?)))))
+(let () (define-primop 'internal:branchf-char>=?/imm (lambda (.as|1 .src|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char>=?/imm .src|1) (emit-char-bcmp-primop! .as|1 sparc.bl.a .src|1 .imm|1 .label|1 $ex.char>=?)))))
+(let () (define-primop 'internal:branchf-char>?/imm (lambda (.as|1 .src|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char>?/imm .src|1) (emit-char-bcmp-primop! .as|1 sparc.ble.a .src|1 .imm|1 .label|1 $ex.char>?)))))
+(let () (define-primop 'internal:branchf-char<=?/imm (lambda (.as|1 .src|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char<=?/imm .src|1) (emit-char-bcmp-primop! .as|1 sparc.bg.a .src|1 .imm|1 .label|1 $ex.char<=?)))))
+(let () (define-primop 'internal:branchf-char<?/imm (lambda (.as|1 .src|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-char<?/imm .src|1) (emit-char-bcmp-primop! .as|1 sparc.bge.a .src|1 .imm|1 .label|1 $ex.char<?)))))
+(let () (define-primop 'internal:eq? (lambda (.as|1 .src1|1 .src2|1 .dest|1) (begin (internal-primop-invariant2 'internal:eq? .src1|1 .dest|1) (let ((.tmp|4 (force-hwreg! .as|1 .src2|1 $r.tmp0))) (begin (sparc.cmpr .as|1 .src1|1 .tmp|4) (emit-set-boolean-reg! .as|1 .dest|1)))))))
+(let () (define-primop 'internal:eq?/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (begin (internal-primop-invariant2 'internal:eq?/imm .rs|1 .rd|1) (if (fixnum? .imm|1) (sparc.cmpi .as|1 .rs|1 (thefixnum .imm|1)) (if (eq? .imm|1 #t) (sparc.cmpi .as|1 .rs|1 $imm.true) (if (eq? .imm|1 #f) (sparc.cmpi .as|1 .rs|1 $imm.false) (if (null? .imm|1) (sparc.cmpi .as|1 .rs|1 $imm.null) ???)))) (emit-set-boolean-reg! .as|1 .rd|1)))))
+(let () (define-primop 'internal:branchf-eq? (lambda (.as|1 .src1|1 .src2|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-eq? .src1|1) (let ((.src2|4 (force-hwreg! .as|1 .src2|1 $r.tmp0))) (begin (sparc.cmpr .as|1 .src1|1 .src2|4) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))))
+(let () (define-primop 'internal:branchf-eq?/imm (lambda (.as|1 .rs|1 .imm|1 .label|1) (begin (internal-primop-invariant1 'internal:branchf-eq?/imm .rs|1) (if (fixnum? .imm|1) (sparc.cmpi .as|1 .rs|1 (thefixnum .imm|1)) (if (eq? .imm|1 #t) (sparc.cmpi .as|1 .rs|1 $imm.true) (if (eq? .imm|1 #f) (sparc.cmpi .as|1 .rs|1 $imm.false) (if (null? .imm|1) (sparc.cmpi .as|1 .rs|1 $imm.null) ???)))) (sparc.bne.a .as|1 .label|1) (sparc.slot .as|1)))))
+(let () (define-primop 'internal:check-fixnum? (lambda (.as|1 .src|1 .l1|1 .liveregs|1) (begin (sparc.btsti .as|1 .src|1 3) (emit-checkcc! .as|1 sparc.bne .l1|1 .liveregs|1)))))
+(let () (define-primop 'internal:check-pair? (lambda (.as|1 .src|1 .l1|1 .liveregs|1) (begin (sparc.andi .as|1 .src|1 $tag.tagmask $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $tag.pair-tag) (emit-checkcc! .as|1 sparc.bne .l1|1 .liveregs|1)))))
+(let () (define-primop 'internal:check-vector? (lambda (.as|1 .src|1 .l1|1 .liveregs|1) (begin (sparc.andi .as|1 .src|1 $tag.tagmask $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $tag.vector-tag) (sparc.bne .as|1 .l1|1) (sparc.nop .as|1) (sparc.ldi .as|1 .src|1 (- 0 $tag.vector-tag) $r.tmp0) (sparc.andi .as|1 $r.tmp0 255 $r.tmp1) (sparc.cmpi .as|1 $r.tmp1 $imm.vector-header) (emit-checkcc! .as|1 sparc.bne .l1|1 .liveregs|1)))))
+(let () (define-primop 'internal:check-vector?/vector-length:vec (lambda (.as|1 .src|1 .dst|1 .l1|1 .liveregs|1) (begin (sparc.andi .as|1 .src|1 $tag.tagmask $r.tmp0) (sparc.cmpi .as|1 $r.tmp0 $tag.vector-tag) (sparc.bne .as|1 .l1|1) (sparc.nop .as|1) (sparc.ldi .as|1 .src|1 (- 0 $tag.vector-tag) $r.tmp0) (sparc.andi .as|1 $r.tmp0 255 $r.tmp1) (sparc.cmpi .as|1 $r.tmp1 $imm.vector-header) (sparc.bne .as|1 .l1|1) (apply sparc.slot2 .as|1 .liveregs|1) (sparc.srli .as|1 $r.tmp0 8 .dst|1)))))
+(let () (begin (set! internal-primop-invariant2 (lambda (.name|1 .a|1 .b|1) (let ((.internal-primop-invariant2|2 0)) (begin (set! .internal-primop-invariant2|2 (lambda (.name|3 .a|3 .b|3) (if (not (if (hardware-mapped? .a|3) (hardware-mapped? .b|3) #f)) (asm-error "SPARC assembler internal invariant violated by " .name|3 " on operands " .a|3 " and " .b|3) (unspecified)))) (.internal-primop-invariant2|2 .name|1 .a|1 .b|1))))) 'internal-primop-invariant2))
+(let () (begin (set! internal-primop-invariant1 (lambda (.name|1 .a|1) (let ((.internal-primop-invariant1|2 0)) (begin (set! .internal-primop-invariant1|2 (lambda (.name|3 .a|3) (if (not (hardware-mapped? .a|3)) (asm-error "SPARC assembler internal invariant violated by " .name|3 " on operand " .a|3) (unspecified)))) (.internal-primop-invariant1|2 .name|1 .a|1))))) 'internal-primop-invariant1))
+(let () (begin (set! logical-op (lambda (.as|1 .rs1|1 .rs2|1 .dest|1 .op|1 .excode|1) (let ((.logical-op|2 0)) (begin (set! .logical-op|2 (lambda (.as|3 .rs1|3 .rs2|3 .dest|3 .op|3 .excode|3) (let ((.fail|6 (unspecified))) (begin (set! .fail|6 (lambda (.rs1|7 .rs2|7 .l0|7) (begin (if (not (= .rs1|7 $r.result)) (sparc.move .as|3 .rs1|7 $r.result) (unspecified)) (if (not (= .rs2|7 $r.argreg2)) (sparc.move .as|3 .rs2|7 $r.argreg2) (unspecified)) (sparc.set .as|3 (thefixnum .excode|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|7)))) (let ((.l0|8 (new-label)) (.l1|8 (new-label))) (begin (sparc.label .as|3 .l0|8) (let ((.rs1|11 (force-hwreg! .as|3 .rs1|3 $r.result)) (.rs2|11 (force-hwreg! .as|3 .rs2|3 $r.argreg2)) (.u|11 (unsafe-code)) (.d|11 (hardware-mapped? .dest|3))) (if (if .u|11 .d|11 #f) (.op|3 .as|3 .rs1|11 .rs2|11 .dest|3) (if (if .u|11 (not .d|11) #f) (begin (.op|3 .as|3 .rs1|11 .rs2|11 $r.tmp0) (emit-store-reg! .as|3 $r.tmp0 .dest|3)) (if (if (not .u|11) .d|11 #f) (begin (sparc.orr .as|3 .rs1|11 .rs2|11 $r.tmp0) (sparc.btsti .as|3 $r.tmp0 3) (sparc.bz.a .as|3 .l1|8) (.op|3 .as|3 .rs1|11 .rs2|11 .dest|3) (.fail|6 .rs1|11 .rs2|11 .l0|8) (sparc.label .as|3 .l1|8)) (begin (sparc.orr .as|3 .rs1|11 .rs2|11 $r.tmp0) (sparc.btsti .as|3 $r.tmp0 3) (sparc.bz.a .as|3 .l1|8) (.op|3 .as|3 .rs1|11 .rs2|11 $r.tmp0) (.fail|6 .rs1|11 .rs2|11 .l0|8) (sparc.label .as|3 .l1|8) (emit-store-reg! .as|3 $r.tmp0 .dest|3)))))))))))) (.logical-op|2 .as|1 .rs1|1 .rs2|1 .dest|1 .op|1 .excode|1))))) 'logical-op))
+(let () (begin (set! emit-shift-operation (lambda (.as|1 .exn|1 .rs1|1 .rs2|1 .rd|1) (let ((.emit-shift-operation|2 0)) (begin (set! .emit-shift-operation|2 (lambda (.as|3 .exn|3 .rs1|3 .rs2|3 .rd|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (begin (if (not (unsafe-code)) (let ((.l0|9 (new-label)) (.fault|9 (new-label)) (.start|9 (new-label))) (begin (sparc.label .as|3 .start|9) (sparc.btsti .as|3 .rs1|3 3) (sparc.be.a .as|3 .l0|9) (sparc.andi .as|3 .rs2|6 124 $r.g0) (sparc.label .as|3 .fault|9) (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (if (not (= .rs2|6 $r.argreg2)) (emit-move2hwreg! .as|3 .rs2|6 $r.argreg2) (unspecified)) (sparc.set .as|3 (thefixnum .exn|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .start|9) (sparc.label .as|3 .l0|9) (sparc.bne .as|3 .fault|9) (sparc.srai .as|3 .rs2|6 2 $r.tmp1))) (sparc.srai .as|3 .rs2|6 2 $r.tmp1)) (if (= .exn|3 $ex.lsh) (sparc.sllr .as|3 .rs1|3 $r.tmp1 .rd|3) (if (= .exn|3 $ex.rshl) (begin (sparc.srlr .as|3 .rs1|3 $r.tmp1 .rd|3) (sparc.andni .as|3 .rd|3 3 .rd|3)) (if (= .exn|3 $ex.rsha) (begin (sparc.srar .as|3 .rs1|3 $r.tmp1 .rd|3) (sparc.andni .as|3 .rd|3 3 .rd|3)) ???))))))) (.emit-shift-operation|2 .as|1 .exn|1 .rs1|1 .rs2|1 .rd|1))))) 'emit-shift-operation))
+(let () (begin (set! emit-set-boolean! (lambda (.as|1) (let ((.emit-set-boolean!|2 0)) (begin (set! .emit-set-boolean!|2 (lambda (.as|3) (emit-set-boolean-reg! .as|3 $r.result))) (.emit-set-boolean!|2 .as|1))))) 'emit-set-boolean!))
+(let () (begin (set! emit-set-boolean-reg! (lambda (.as|1 .dest|1) (let ((.emit-set-boolean-reg!|2 0)) (begin (set! .emit-set-boolean-reg!|2 (lambda (.as|3 .dest|3) (let ((.l1|6 (new-label))) (begin (sparc.set .as|3 $imm.true .dest|3) (sparc.bne.a .as|3 .l1|6) (sparc.set .as|3 $imm.false .dest|3) (sparc.label .as|3 .l1|6))))) (.emit-set-boolean-reg!|2 .as|1 .dest|1))))) 'emit-set-boolean-reg!))
+(let () (begin (set! emit-single-tagcheck->bool! (lambda (.as|1 .tag|1) (let ((.emit-single-tagcheck->bool!|2 0)) (begin (set! .emit-single-tagcheck->bool!|2 (lambda (.as|3 .tag|3) (begin (sparc.andi .as|3 $r.result $tag.tagmask $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .tag|3) (emit-set-boolean! .as|3)))) (.emit-single-tagcheck->bool!|2 .as|1 .tag|1))))) 'emit-single-tagcheck->bool!))
+(let () (begin (set! emit-single-tagcheck-assert! (lambda (.as|1 .tag1|1 .excode|1 .reg2|1) (let ((.emit-single-tagcheck-assert!|2 0)) (begin (set! .emit-single-tagcheck-assert!|2 (lambda (.as|3 .tag1|3 .excode|3 .reg2|3) (emit-single-tagcheck-assert-reg! .as|3 .tag1|3 $r.result .reg2|3 .excode|3))) (.emit-single-tagcheck-assert!|2 .as|1 .tag1|1 .excode|1 .reg2|1))))) 'emit-single-tagcheck-assert!))
+(let () (begin (set! emit-single-tagcheck-assert-reg! (lambda (.as|1 .tag1|1 .reg|1 .reg2|1 .excode|1) (let ((.emit-single-tagcheck-assert-reg!|2 0)) (begin (set! .emit-single-tagcheck-assert-reg!|2 (lambda (.as|3 .tag1|3 .reg|3 .reg2|3 .excode|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label)) (.fault|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.andi .as|3 .reg|3 $tag.tagmask $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .tag1|3) (fault-if-ne .as|3 .excode|3 #f #f .reg|3 .reg2|3 .l0|6))))) (.emit-single-tagcheck-assert-reg!|2 .as|1 .tag1|1 .reg|1 .reg2|1 .excode|1))))) 'emit-single-tagcheck-assert-reg!))
+(let () (begin (set! emit-assert-fixnum! (lambda (.as|1 .reg|1 .excode|1) (let ((.emit-assert-fixnum!|2 0)) (begin (set! .emit-assert-fixnum!|2 (lambda (.as|3 .reg|3 .excode|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label)) (.fault|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.btsti .as|3 .reg|3 3) (fault-if-ne .as|3 .excode|3 #f #f .reg|3 #f .l0|6))))) (.emit-assert-fixnum!|2 .as|1 .reg|1 .excode|1))))) 'emit-assert-fixnum!))
+(let () (begin (set! emit-assert-char! (lambda (.as|1 .excode|1 .fault-label|1) (let ((.emit-assert-char!|2 0)) (begin (set! .emit-assert-char!|2 (lambda (.as|3 .excode|3 .fault-label|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label)) (.fault|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.andi .as|3 $r.result 255 $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 $imm.character) (fault-if-ne .as|3 .excode|3 #f .fault-label|3 #f #f .l0|6))))) (.emit-assert-char!|2 .as|1 .excode|1 .fault-label|1))))) 'emit-assert-char!))
+(let () (begin (set! fault-if-ne (lambda (.as|1 .excode|1 .cont-label|1 .fault-label|1 .reg1|1 .reg2|1 .ret-label|1) (let ((.fault-if-ne|2 0)) (begin (set! .fault-if-ne|2 (lambda (.as|3 .excode|3 .cont-label|3 .fault-label|3 .reg1|3 .reg2|3 .ret-label|3) (if .fault-label|3 (begin (if (if .reg2|3 (not (= .reg2|3 $r.argreg2)) #f) (emit-move2hwreg! .as|3 .reg2|3 $r.argreg2) (unspecified)) (sparc.bne .as|3 .fault-label|3) (if (if .reg1|3 (not (= .reg1|3 $r.result)) #f) (sparc.move .as|3 .reg1|3 $r.result) (sparc.nop .as|3)) .fault-label|3) (let ((.fault|10 (new-label)) (.l1|10 (new-label))) (begin (sparc.be.a .as|3 (let ((.temp|11|14 .cont-label|3)) (if .temp|11|14 .temp|11|14 .l1|10))) (sparc.slot .as|3) (sparc.label .as|3 .fault|10) (if (if .reg1|3 (not (= .reg1|3 $r.result)) #f) (sparc.move .as|3 .reg1|3 $r.result) (unspecified)) (if (if .reg2|3 (not (= .reg2|3 $r.argreg2)) #f) (emit-move2hwreg! .as|3 .reg2|3 $r.argreg2) (unspecified)) (sparc.set .as|3 (thefixnum .excode|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception (let ((.temp|20|23 .ret-label|3)) (if .temp|20|23 .temp|20|23 .l1|10))) (if (let ((.temp|25|28 (not .cont-label|3))) (if .temp|25|28 .temp|25|28 (not .ret-label|3))) (sparc.label .as|3 .l1|10) (unspecified)) .fault|10))))) (.fault-if-ne|2 .as|1 .excode|1 .cont-label|1 .fault-label|1 .reg1|1 .reg2|1 .ret-label|1))))) 'fault-if-ne))
+(let () (begin (set! emit-assert-positive-fixnum! (lambda (.as|1 .reg|1 .excode|1) (let ((.emit-assert-positive-fixnum!|2 0)) (begin (set! .emit-assert-positive-fixnum!|2 (lambda (.as|3 .reg|3 .excode|3) (let ((.l1|6 (new-label)) (.l2|6 (new-label)) (.l3|6 (new-label))) (begin (sparc.label .as|3 .l2|6) (sparc.tsubrcc .as|3 .reg|3 $r.g0 $r.g0) (sparc.bvc .as|3 .l1|6) (sparc.nop .as|3) (sparc.label .as|3 .l3|6) (if (not (= .reg|3 $r.result)) (sparc.move .as|3 .reg|3 $r.result) (unspecified)) (sparc.set .as|3 (thefixnum .excode|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l2|6) (sparc.label .as|3 .l1|6) (sparc.bl .as|3 .l3|6) (sparc.nop .as|3) .l3|6)))) (.emit-assert-positive-fixnum!|2 .as|1 .reg|1 .excode|1))))) 'emit-assert-positive-fixnum!))
+(let () (begin (set! emit-cmp-primop! (lambda (.as|1 .branch_t.a|1 .generic|1 .r|1) (let ((.emit-cmp-primop!|2 0)) (begin (set! .emit-cmp-primop!|2 (lambda (.as|3 .branch_t.a|3 .generic|3 .r|3) (let ((.ltagok|6 (new-label)) (.lcont|6 (new-label)) (.r|6 (force-hwreg! .as|3 .r|3 $r.argreg2))) (begin (sparc.tsubrcc .as|3 $r.result .r|6 $r.g0) (sparc.bvc.a .as|3 .ltagok|6) (sparc.set .as|3 $imm.false $r.result) (if (not (= .r|6 $r.argreg2)) (sparc.move .as|3 .r|6 $r.argreg2) (unspecified)) (millicode-call/ret .as|3 .generic|3 .lcont|6) (sparc.label .as|3 .ltagok|6) (.branch_t.a|3 .as|3 .lcont|6) (sparc.set .as|3 $imm.true $r.result) (sparc.label .as|3 .lcont|6))))) (.emit-cmp-primop!|2 .as|1 .branch_t.a|1 .generic|1 .r|1))))) 'emit-cmp-primop!))
+(let () (begin (set! emit-bcmp-primop! (lambda (.as|1 .branch_f.a|1 .src1|1 .src2|1 .lfalse|1 .generic|1 .src2isreg|1) (let ((.emit-bcmp-primop!|2 0)) (begin (set! .emit-bcmp-primop!|2 (lambda (.as|3 .branch_f.a|3 .src1|3 .src2|3 .lfalse|3 .generic|3 .src2isreg|3) (let ((.ltagok|6 (new-label)) (.ltrue|6 (new-label)) (.op2|6 (if .src2isreg|3 (force-hwreg! .as|3 .src2|3 $r.tmp1) (thefixnum .src2|3))) (.sub|6 (if .src2isreg|3 sparc.tsubrcc sparc.tsubicc)) (.mov|6 (if .src2isreg|3 sparc.move sparc.set))) (begin (.sub|6 .as|3 .src1|3 .op2|6 $r.g0) (sparc.bvc.a .as|3 .ltagok|6) (sparc.slot .as|3) (let ((.move-res|9 (not (= .src1|3 $r.result))) (.move-arg2|9 (let ((.temp|15|18 (not .src2isreg|3))) (if .temp|15|18 .temp|15|18 (not (= .op2|6 $r.argreg2)))))) (begin (if (if .move-arg2|9 .move-res|9 #f) (.mov|6 .as|3 .op2|6 $r.argreg2) (unspecified)) (sparc.jmpli .as|3 $r.millicode .generic|3 $r.o7) (if .move-res|9 (sparc.move .as|3 .src1|3 $r.result) (if .move-arg2|9 (.mov|6 .as|3 .op2|6 $r.argreg2) (sparc.nop .as|3))) (sparc.cmpi .as|3 $r.result $imm.false) (sparc.bne.a .as|3 .ltrue|6) (sparc.slot .as|3) (sparc.b .as|3 .lfalse|3) (sparc.slot .as|3))) (sparc.label .as|3 .ltagok|6) (.branch_f.a|3 .as|3 .lfalse|3) (sparc.slot .as|3) (sparc.label .as|3 .ltrue|6))))) (.emit-bcmp-primop!|2 .as|1 .branch_f.a|1 .src1|1 .src2|1 .lfalse|1 .generic|1 .src2isreg|1))))) 'emit-bcmp-primop!))
+(let () '(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg) (let ((l1 (new-label)) (op2 (if src2isreg (force-hwreg! as src2 $r.tmp1) (thefixnum src2)))) (if (and src2isreg (= op2 dest)) (begin (op as src1 op2 $r.tmp0) (sparc.bvc.a as l1) (sparc.move as $r.tmp0 dest)) (begin (op as src1 op2 dest) (sparc.bvc.a as l1) (sparc.slot as) (invop as dest op2 dest))) (let ((n (+ (if (not (= src1 $r.result)) 1 0) (if (or (not src2isreg) (not (= op2 $r.argreg2))) 1 0))) (mov2 (if src2isreg sparc.move sparc.set))) (if (= n 2) (mov2 as op2 $r.argreg2)) (sparc.jmpli as $r.millicode generic $r.o7) (cond ((= n 0) (sparc.nop as)) ((= n 1) (mov2 as op2 $r.argreg2)) (else (sparc.move as src1 $r.result))) (if (not (= dest $r.result)) (sparc.move as $r.result dest)) (sparc.label as l1)))))
+(let () (begin (set! emit-arith-primop! (lambda (.as|1 .op|1 .invop|1 .generic|1 .rs1|1 .rs2/imm|1 .rd|1 .op2isreg|1) (let ((.emit-arith-primop!|2 0)) (begin (set! .emit-arith-primop!|2 (lambda (.as|3 .op|3 .invop|3 .generic|3 .rs1|3 .rs2/imm|3 .rd|3 .op2isreg|3) (let ((.l1|6 (new-label))) (begin (if .op2isreg|3 (let ((.rs2|9 (force-hwreg! .as|3 .rs2/imm|3 $r.argreg2))) (begin (if (let ((.temp|11|14 (let ((.t|18|21 .rs2|9)) (if (= .rs1|3 .t|18|21) (= .t|18|21 .rd|3) #f)))) (if .temp|11|14 .temp|11|14 (if (= .rs2|9 .rd|3) (= .generic|3 $m.subtract) #f))) (begin (.op|3 .as|3 .rs1|3 .rs2|9 $r.tmp0) (sparc.bvc.a .as|3 .l1|6) (sparc.move .as|3 $r.tmp0 .rd|3)) (if (= .rs1|3 .rd|3) (begin (.op|3 .as|3 .rs1|3 .rs2|9 .rs1|3) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (.invop|3 .as|3 .rs1|3 .rs2|9 .rs1|3)) (if (= .rs2|9 .rd|3) (begin (.op|3 .as|3 .rs1|3 .rs2|9 .rs2|9) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (.invop|3 .as|3 .rs2|9 .rs1|3 .rs2|9)) (begin (.op|3 .as|3 .rs1|3 .rs2|9 .rd|3) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (if (if (not (= .rd|3 $r.result)) (not (= .rd|3 $r.argreg2)) #f) (sparc.clr .as|3 .rd|3) (unspecified)))))) (if (if (= .rs1|3 $r.result) (= .rs2|9 $r.argreg2) #f) (millicode-call/0arg .as|3 .generic|3) (if (= .rs1|3 $r.result) (millicode-call/1arg .as|3 .generic|3 .rs2|9) (if (= .rs2|9 $r.argreg2) (millicode-call/1arg-in-result .as|3 .generic|3 .rs1|3) (begin (sparc.move .as|3 .rs2|9 $r.argreg2) (millicode-call/1arg-in-result .as|3 .generic|3 .rs1|3))))))) (let ((.imm|37 (thefixnum .rs2/imm|3))) (begin (.op|3 .as|3 .rs1|3 .imm|37 .rd|3) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (.invop|3 .as|3 .rd|3 .imm|37 .rd|3) (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (millicode-call/numarg-in-reg .as|3 .generic|3 .imm|37 $r.argreg2)))) (if (not (= .rd|3 $r.result)) (sparc.move .as|3 $r.result .rd|3) (unspecified)) (sparc.label .as|3 .l1|6))))) (.emit-arith-primop!|2 .as|1 .op|1 .invop|1 .generic|1 .rs1|1 .rs2/imm|1 .rd|1 .op2isreg|1))))) 'emit-arith-primop!))
+(let () (begin (set! emit-negate (lambda (.as|1 .rs|1 .rd|1) (let ((.emit-negate|2 0)) (begin (set! .emit-negate|2 (lambda (.as|3 .rs|3 .rd|3) (let ((.l1|6 (new-label))) (begin (if (= .rs|3 .rd|3) (begin (sparc.tsubrcc .as|3 $r.g0 .rs|3 .rs|3) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (if (= .rs|3 $r.result) (begin (sparc.jmpli .as|3 $r.millicode $m.negate $r.o7) (sparc.subr .as|3 $r.g0 $r.result $r.result)) (begin (sparc.subr .as|3 $r.g0 .rs|3 .rs|3) (sparc.jmpli .as|3 $r.millicode $m.negate $r.o7) (sparc.move .as|3 .rs|3 $r.result)))) (begin (sparc.tsubrcc .as|3 $r.g0 .rs|3 .rd|3) (sparc.bvc.a .as|3 .l1|6) (sparc.slot .as|3) (if (= .rs|3 $r.result) (begin (sparc.jmpli .as|3 $r.millicode $m.negate $r.o7) (sparc.clr .as|3 .rd|3)) (if (= .rd|3 $r.result) (begin (sparc.jmpli .as|3 $r.millicode $m.negate $r.o7) (sparc.move .as|3 .rs|3 $r.result)) (begin (sparc.clr .as|3 .rd|3) (sparc.jmpli .as|3 $r.millicode $m.negate $r.o7) (sparc.move .as|3 .rs|3 $r.result)))))) (if (not (= .rd|3 $r.result)) (sparc.move .as|3 $r.result .rd|3) (unspecified)) (sparc.label .as|3 .l1|6))))) (.emit-negate|2 .as|1 .rs|1 .rd|1))))) 'emit-negate))
+(let () (begin (set! emit-char-cmp (lambda (.as|1 .r|1 .btrue.a|1 .excode|1) (let ((.emit-char-cmp|2 0)) (begin (set! .emit-char-cmp|2 (lambda (.as|3 .r|3 .btrue.a|3 .excode|3) (emit-charcmp! .as|3 (lambda () (let ((.l2|7 (new-label))) (begin (sparc.set .as|3 $imm.false $r.result) (.btrue.a|3 .as|3 .l2|7) (sparc.set .as|3 $imm.true $r.result) (sparc.label .as|3 .l2|7)))) $r.result .r|3 .excode|3))) (.emit-char-cmp|2 .as|1 .r|1 .btrue.a|1 .excode|1))))) 'emit-char-cmp))
+(let () (begin (set! emit-char-bcmp-primop! (lambda (.as|1 .bfalse.a|1 .op1|1 .op2|1 .l0|1 .excode|1) (let ((.emit-char-bcmp-primop!|2 0)) (begin (set! .emit-char-bcmp-primop!|2 (lambda (.as|3 .bfalse.a|3 .op1|3 .op2|3 .l0|3 .excode|3) (emit-charcmp! .as|3 (lambda () (begin (.bfalse.a|3 .as|3 .l0|3) (sparc.slot .as|3))) .op1|3 .op2|3 .excode|3))) (.emit-char-bcmp-primop!|2 .as|1 .bfalse.a|1 .op1|1 .op2|1 .l0|1 .excode|1))))) 'emit-char-bcmp-primop!))
+(let () (begin (set! emit-charcmp! (lambda (.as|1 .tail|1 .op1|1 .op2|1 .excode|1) (let ((.emit-charcmp!|2 0)) (begin (set! .emit-charcmp!|2 (lambda (.as|3 .tail|3 .op1|3 .op2|3 .excode|3) (let ((.op2|6 (if (char? .op2|3) .op2|3 (force-hwreg! .as|3 .op2|3 $r.argreg2)))) (begin (if (not (unsafe-code)) (let ((.l0|10 (new-label)) (.l1|10 (new-label)) (.fault|10 (new-label))) (begin (sparc.label .as|3 .l0|10) (if (char? .op2|6) (begin (sparc.xori .as|3 .op1|3 $imm.character $r.tmp0) (sparc.btsti .as|3 $r.tmp0 255) (sparc.srli .as|3 .op1|3 16 $r.tmp0) (sparc.be.a .as|3 .l1|10) (sparc.cmpi .as|3 $r.tmp0 (char->integer .op2|6))) (begin (sparc.andi .as|3 .op1|3 255 $r.tmp0) (sparc.andi .as|3 .op2|6 255 $r.tmp1) (sparc.cmpr .as|3 $r.tmp0 $r.tmp1) (sparc.bne .as|3 .fault|10) (sparc.cmpi .as|3 $r.tmp0 $imm.character) (sparc.be.a .as|3 .l1|10) (sparc.cmpr .as|3 .op1|3 .op2|6))) (sparc.label .as|3 .fault|10) (if (not (eqv? .op1|3 $r.result)) (sparc.move .as|3 .op1|3 $r.result) (unspecified)) (if (char? .op2|6) (emit-immediate->register! .as|3 (char->immediate .op2|6) $r.argreg2) (if (not (eqv? .op2|6 $r.argreg2)) (sparc.move .as|3 .op2|6 $r.argreg2) (unspecified))) (sparc.set .as|3 (thefixnum .excode|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|10) (sparc.label .as|3 .l1|10))) (if (not (char? .op2|6)) (sparc.cmpr .as|3 .op1|3 .op2|6) (begin (sparc.srli .as|3 .op1|3 16 $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 (char->integer .op2|6))))) (.tail|3))))) (.emit-charcmp!|2 .as|1 .tail|1 .op1|1 .op2|1 .excode|1))))) 'emit-charcmp!))
+(let () (begin (set! emit-setcar/setcdr! (lambda (.as|1 .rs1|1 .rs2|1 .offs|1) (let ((.emit-setcar/setcdr!|2 0)) (begin (set! .emit-setcar/setcdr!|2 (lambda (.as|3 .rs1|3 .rs2|3 .offs|3) (if (if (write-barrier) (hardware-mapped? .rs2|3) #f) (begin (sparc.sti .as|3 .rs2|3 (- .offs|3 $tag.pair-tag) .rs1|3) (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (millicode-call/1arg .as|3 $m.addtrans .rs2|3)) (if (write-barrier) (begin (emit-move2hwreg! .as|3 .rs2|3 $r.argreg2) (sparc.sti .as|3 $r.argreg2 (- .offs|3 $tag.pair-tag) .rs1|3) (millicode-call/1arg-in-result .as|3 $m.addtrans .rs1|3)) (if (hardware-mapped? .rs2|3) (sparc.sti .as|3 .rs2|3 (- .offs|3 $tag.pair-tag) .rs1|3) (begin (emit-move2hwreg! .as|3 .rs2|3 $r.argreg2) (sparc.sti .as|3 $r.argreg2 (- .offs|3 $tag.pair-tag) .rs1|3))))))) (.emit-setcar/setcdr!|2 .as|1 .rs1|1 .rs2|1 .offs|1))))) 'emit-setcar/setcdr!))
+(let () (begin (set! emit-double-tagcheck->bool! (lambda (.as|1 .tag1|1 .tag2|1) (let ((.emit-double-tagcheck->bool!|2 0)) (begin (set! .emit-double-tagcheck->bool!|2 (lambda (.as|3 .tag1|3 .tag2|3) (let ((.l1|6 (new-label))) (begin (sparc.andi .as|3 $r.result $tag.tagmask $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .tag1|3) (sparc.bne.a .as|3 .l1|6) (sparc.set .as|3 $imm.false $r.result) (sparc.ldbi .as|3 $r.result (+ (- 0 .tag1|3) 3) $r.tmp0) (sparc.set .as|3 $imm.true $r.result) (sparc.cmpi .as|3 $r.tmp0 .tag2|3) (sparc.bne.a .as|3 .l1|6) (sparc.set .as|3 $imm.false $r.result) (sparc.label .as|3 .l1|6))))) (.emit-double-tagcheck->bool!|2 .as|1 .tag1|1 .tag2|1))))) 'emit-double-tagcheck->bool!))
+(let () (begin (set! double-tagcheck-assert (lambda (.as|1 .tag1|1 .tag2|1 .rs1|1 .rs2/imm|1 .rs3|1 .excode|1 .imm?|1) (let ((.double-tagcheck-assert|2 0)) (begin (set! .double-tagcheck-assert|2 (lambda (.as|3 .tag1|3 .tag2|3 .rs1|3 .rs2/imm|3 .rs3|3 .excode|3 .imm?|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label)) (.fault|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.andi .as|3 .rs1|3 $tag.tagmask $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .tag1|3) (sparc.be.a .as|3 .l1|6) (sparc.ldi .as|3 .rs1|3 (- 0 .tag1|3) $r.tmp0) (sparc.label .as|3 .fault|6) (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (if .rs2/imm|3 (if .imm?|3 (sparc.set .as|3 (thefixnum .rs2/imm|3) $r.argreg2) (let ((.temp|10|13 (= .rs2/imm|3 $r.argreg2))) (if .temp|10|13 .temp|10|13 (emit-move2hwreg! .as|3 .rs2/imm|3 $r.argreg2)))) (unspecified)) (if (if .rs3|3 (not (= .rs3|3 $r.argreg3)) #f) (emit-move2hwreg! .as|3 .rs3|3 $r.argreg3) (unspecified)) (sparc.set .as|3 (thefixnum .excode|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|6) (sparc.label .as|3 .l1|6) (sparc.andi .as|3 $r.tmp0 255 $r.tmp1) (sparc.cmpi .as|3 $r.tmp1 .tag2|3) (sparc.bne.a .as|3 .fault|6) (sparc.slot .as|3) .fault|6)))) (.double-tagcheck-assert|2 .as|1 .tag1|1 .tag2|1 .rs1|1 .rs2/imm|1 .rs3|1 .excode|1 .imm?|1))))) 'double-tagcheck-assert))
+(let () (begin (set! emit-double-tagcheck-assert! (lambda (.as|1 .tag1|1 .tag2|1 .excode|1 .reg2|1) (let ((.emit-double-tagcheck-assert!|2 0)) (begin (set! .emit-double-tagcheck-assert!|2 (lambda (.as|3 .tag1|3 .tag2|3 .excode|3 .reg2|3) (double-tagcheck-assert .as|3 .tag1|3 .tag2|3 $r.result .reg2|3 #f .excode|3 #f))) (.emit-double-tagcheck-assert!|2 .as|1 .tag1|1 .tag2|1 .excode|1 .reg2|1))))) 'emit-double-tagcheck-assert!))
+(let () (begin (set! emit-double-tagcheck-assert-reg/reg! (lambda (.as|1 .tag1|1 .tag2|1 .rs1|1 .rs2|1 .excode|1) (let ((.emit-double-tagcheck-assert-reg/reg!|2 0)) (begin (set! .emit-double-tagcheck-assert-reg/reg!|2 (lambda (.as|3 .tag1|3 .tag2|3 .rs1|3 .rs2|3 .excode|3) (double-tagcheck-assert .as|3 .tag1|3 .tag2|3 .rs1|3 .rs2|3 #f .excode|3 #f))) (.emit-double-tagcheck-assert-reg/reg!|2 .as|1 .tag1|1 .tag2|1 .rs1|1 .rs2|1 .excode|1))))) 'emit-double-tagcheck-assert-reg/reg!))
+(let () (begin (set! emit-double-tagcheck-assert-reg/imm! (lambda (.as|1 .tag1|1 .tag2|1 .rs1|1 .imm|1 .excode|1) (let ((.emit-double-tagcheck-assert-reg/imm!|2 0)) (begin (set! .emit-double-tagcheck-assert-reg/imm!|2 (lambda (.as|3 .tag1|3 .tag2|3 .rs1|3 .imm|3 .excode|3) (double-tagcheck-assert .as|3 .tag1|3 .tag2|3 .rs1|3 .imm|3 #f .excode|3 #t))) (.emit-double-tagcheck-assert-reg/imm!|2 .as|1 .tag1|1 .tag2|1 .rs1|1 .imm|1 .excode|1))))) 'emit-double-tagcheck-assert-reg/imm!))
+(let () (begin (set! emit-get-length! (lambda (.as|1 .tag1|1 .tag2|1 .excode|1 .rs|1 .rd|1) (let ((.emit-get-length!|2 0)) (begin (set! .emit-get-length!|2 (lambda (.as|3 .tag1|3 .tag2|3 .excode|3 .rs|3 .rd|3) (begin (if (not (unsafe-code)) (if .tag2|3 (emit-double-tagcheck-assert-reg/reg! .as|3 .tag1|3 .tag2|3 .rs|3 .rd|3 .excode|3) (emit-single-tagcheck-assert-reg! .as|3 .tag1|3 .rs|3 .rd|3 .excode|3)) (unspecified)) (emit-get-length-trusted! .as|3 .tag1|3 .rs|3 .rd|3)))) (.emit-get-length!|2 .as|1 .tag1|1 .tag2|1 .excode|1 .rs|1 .rd|1))))) 'emit-get-length!))
+(let () (begin (set! emit-get-length-trusted! (lambda (.as|1 .tag1|1 .rs|1 .rd|1) (let ((.emit-get-length-trusted!|2 0)) (begin (set! .emit-get-length-trusted!|2 (lambda (.as|3 .tag1|3 .rs|3 .rd|3) (begin (sparc.ldi .as|3 .rs|3 (- 0 .tag1|3) $r.tmp0) (sparc.srli .as|3 $r.tmp0 8 .rd|3) (if (= .tag1|3 $tag.bytevector-tag) (sparc.slli .as|3 .rd|3 2 .rd|3) (unspecified))))) (.emit-get-length-trusted!|2 .as|1 .tag1|1 .rs|1 .rd|1))))) 'emit-get-length-trusted!))
+(let () (begin (set! emit-allocate-bytevector (lambda (.as|1 .hdr|1 .preserved-result|1) (let ((.emit-allocate-bytevector|2 0)) (begin (set! .emit-allocate-bytevector|2 (lambda (.as|3 .hdr|3 .preserved-result|3) (begin (if (not .preserved-result|3) (sparc.move .as|3 $r.result $r.argreg2) (unspecified)) (sparc.addi .as|3 $r.result 28 $r.result) (sparc.andi .as|3 $r.result (asm:signed 4294967280) $r.result) (sparc.jmpli .as|3 $r.millicode $m.alloc-bv $r.o7) (sparc.srai .as|3 $r.result 2 $r.result) (if (not .preserved-result|3) (sparc.slli .as|3 $r.argreg2 6 $r.tmp0) (sparc.slli .as|3 .preserved-result|3 6 $r.tmp0)) (sparc.addi .as|3 $r.tmp0 .hdr|3 $r.tmp0) (sparc.sti .as|3 $r.tmp0 0 $r.result)))) (.emit-allocate-bytevector|2 .as|1 .hdr|1 .preserved-result|1))))) 'emit-allocate-bytevector))
+(let () (begin (set! emit-bytevector-fill (lambda (.as|1 .r-bytecount|1 .r-pointer|1 .r-value|1) (let ((.emit-bytevector-fill|2 0)) (begin (set! .emit-bytevector-fill|2 (lambda (.as|3 .r-bytecount|3 .r-pointer|3 .r-value|3) (let ((.l2|6 (new-label)) (.l1|6 (new-label))) (begin (sparc.label .as|3 .l2|6) (sparc.deccc .as|3 .r-bytecount|3) (sparc.bge.a .as|3 .l2|6) (sparc.stbr .as|3 .r-value|3 .r-bytecount|3 .r-pointer|3) (sparc.label .as|3 .l1|6))))) (.emit-bytevector-fill|2 .as|1 .r-bytecount|1 .r-pointer|1 .r-value|1))))) 'emit-bytevector-fill))
+(let () (begin (set! emit-bytevector-like-ref! (lambda (.as|1 .rs1|1 .rs2|1 .rd|1 .fault|1 .charize?|1 .header-loaded?|1) (let ((.emit-bytevector-like-ref!|2 0)) (begin (set! .emit-bytevector-like-ref!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rd|3 .fault|3 .charize?|3 .header-loaded?|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (begin (if (not (unsafe-code)) (begin (sparc.btsti .as|3 .rs2|6 3) (sparc.bne .as|3 .fault|3) (if (not .header-loaded?|3) (sparc.ldi .as|3 .rs1|3 (- 0 $tag.bytevector-tag) $r.tmp0) (unspecified)) (sparc.srai .as|3 .rs2|6 2 $r.tmp1) (sparc.srli .as|3 $r.tmp0 8 $r.tmp0) (sparc.cmpr .as|3 $r.tmp0 $r.tmp1) (sparc.bleu .as|3 .fault|3)) (sparc.srai .as|3 .rs2|6 2 $r.tmp1)) (sparc.addi .as|3 .rs1|3 (- 4 $tag.bytevector-tag) $r.tmp0) (sparc.ldbr .as|3 $r.tmp0 $r.tmp1 $r.tmp0) (if (not .charize?|3) (sparc.slli .as|3 $r.tmp0 2 .rd|3) (begin (sparc.slli .as|3 $r.tmp0 16 .rd|3) (sparc.ori .as|3 .rd|3 $imm.character .rd|3))))))) (.emit-bytevector-like-ref!|2 .as|1 .rs1|1 .rs2|1 .rd|1 .fault|1 .charize?|1 .header-loaded?|1))))) 'emit-bytevector-like-ref!))
+(let () (begin (set! emit-bytevector-like-ref/imm! (lambda (.as|1 .rs1|1 .imm|1 .rd|1 .fault|1 .charize?|1 .header-loaded?|1) (let ((.emit-bytevector-like-ref/imm!|2 0)) (begin (set! .emit-bytevector-like-ref/imm!|2 (lambda (.as|3 .rs1|3 .imm|3 .rd|3 .fault|3 .charize?|3 .header-loaded?|3) (begin (if (not (unsafe-code)) (begin (if (not .header-loaded?|3) (sparc.ldi .as|3 .rs1|3 (- 0 $tag.bytevector-tag) $r.tmp0) (unspecified)) (sparc.srli .as|3 $r.tmp0 8 $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .imm|3) (sparc.bleu.a .as|3 .fault|3) (sparc.slot .as|3)) (unspecified)) (let ((.adjusted-offset|7 (+ (- 4 $tag.bytevector-tag) .imm|3))) (begin (if (immediate-literal? .adjusted-offset|7) (sparc.ldbi .as|3 .rs1|3 .adjusted-offset|7 $r.tmp0) (begin (sparc.addi .as|3 .rs1|3 (- 4 $tag.bytevector-tag) $r.tmp0) (sparc.ldbr .as|3 $r.tmp0 .imm|3 $r.tmp0))) (if (not .charize?|3) (sparc.slli .as|3 $r.tmp0 2 .rd|3) (begin (sparc.slli .as|3 $r.tmp0 16 .rd|3) (sparc.ori .as|3 .rd|3 $imm.character .rd|3)))))))) (.emit-bytevector-like-ref/imm!|2 .as|1 .rs1|1 .imm|1 .rd|1 .fault|1 .charize?|1 .header-loaded?|1))))) 'emit-bytevector-like-ref/imm!))
+(let () (begin (set! emit-bytevector-like-set! (lambda (.as|1 .idx|1 .byte|1 .fault|1 .header-loaded?|1) (let ((.emit-bytevector-like-set!|2 0)) (begin (set! .emit-bytevector-like-set!|2 (lambda (.as|3 .idx|3 .byte|3 .fault|3 .header-loaded?|3) (let ((.r1|6 (force-hwreg! .as|3 .idx|3 $r.tmp1)) (.r2|6 (force-hwreg! .as|3 .byte|3 $r.argreg3))) (begin (if (not (unsafe-code)) (begin (if (not .header-loaded?|3) (sparc.ldi .as|3 $r.result (- 0 $tag.bytevector-tag) $r.tmp0) (unspecified)) (sparc.orr .as|3 .r1|6 .r2|6 $r.tmp2) (sparc.btsti .as|3 $r.tmp2 3) (sparc.bnz .as|3 .fault|3) (sparc.srli .as|3 $r.tmp0 8 $r.tmp0) (sparc.srai .as|3 .r1|6 2 $r.tmp1) (sparc.cmpr .as|3 $r.tmp1 $r.tmp0) (sparc.bgeu .as|3 .fault|3)) (sparc.srai .as|3 .r1|6 2 $r.tmp1)) (sparc.srli .as|3 .r2|6 2 $r.tmp0) (sparc.addi .as|3 $r.result (- 4 $tag.bytevector-tag) $r.argreg2) (sparc.stbr .as|3 $r.tmp0 $r.tmp1 $r.argreg2))))) (.emit-bytevector-like-set!|2 .as|1 .idx|1 .byte|1 .fault|1 .header-loaded?|1))))) 'emit-bytevector-like-set!))
+(let () (begin (set! emit-string-set! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1) (let ((.emit-string-set!|2 0)) (begin (set! .emit-string-set!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rs3|3) (let* ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2)) (.rs3|9 (force-hwreg! .as|3 .rs3|3 $r.argreg3)) (.fault|12 (if (not (unsafe-code)) (double-tagcheck-assert .as|3 $tag.bytevector-tag (+ $imm.bytevector-header $tag.string-typetag) .rs1|3 .rs2|6 .rs3|9 $ex.sset #f) (unspecified)))) (let () (begin (if (not (unsafe-code)) (begin (sparc.btsti .as|3 .rs2|6 3) (sparc.bne .as|3 .fault|12) (sparc.srli .as|3 $r.tmp0 8 $r.tmp0) (sparc.srai .as|3 .rs2|6 2 $r.tmp1) (sparc.cmpr .as|3 $r.tmp1 $r.tmp0) (sparc.bgeu .as|3 .fault|12) (sparc.andi .as|3 .rs3|9 255 $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 $imm.character) (sparc.bne .as|3 .fault|12)) (sparc.srai .as|3 .rs2|6 2 $r.tmp1)) (sparc.subi .as|3 $r.tmp1 (- $tag.bytevector-tag 4) $r.tmp1) (sparc.srli .as|3 .rs3|9 16 $r.tmp0) (sparc.stbr .as|3 $r.tmp0 .rs1|3 $r.tmp1)))))) (.emit-string-set!|2 .as|1 .rs1|1 .rs2|1 .rs3|1))))) 'emit-string-set!))
+(let () (begin (set! make-vector-n (lambda (.as|1 .length|1 .r|1) (let ((.make-vector-n|2 0)) (begin (set! .make-vector-n|2 (lambda (.as|3 .length|3 .r|3) (begin (sparc.jmpli .as|3 $r.millicode $m.alloc $r.o7) (sparc.set .as|3 (thefixnum (+ .length|3 1)) $r.result) (emit-immediate->register! .as|3 (+ (+ (* 256 (thefixnum .length|3)) $imm.vector-header) $tag.vector-typetag) $r.tmp0) (sparc.sti .as|3 $r.tmp0 0 $r.result) (let ((.dest|7 (force-hwreg! .as|3 .r|3 $r.argreg2))) (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.i|15) (if (= .i|15 .length|3) (if #f #f (unspecified)) (begin (begin #t (sparc.sti .as|3 .dest|7 (* (+ .i|15 1) 4) $r.result)) (.loop|9|11|14 (+ .i|15 1)))))) (.loop|9|11|14 0))))) (sparc.addi .as|3 $r.result $tag.vector-tag $r.result)))) (.make-vector-n|2 .as|1 .length|1 .r|1))))) 'make-vector-n))
+(let () (begin (set! emit-make-vector-like! (lambda (.as|1 .r|1 .hdr|1 .ptrtag|1) (let ((.emit-make-vector-like!|2 0)) (begin (set! .emit-make-vector-like!|2 (lambda (.as|3 .r|3 .hdr|3 .ptrtag|3) (let ((.fault|6 (emit-assert-positive-fixnum! .as|3 $r.result $ex.mkvl))) (begin (sparc.move .as|3 $r.result $r.argreg3) (sparc.addi .as|3 $r.result 4 $r.result) (sparc.jmpli .as|3 $r.millicode $m.alloci $r.o7) (if (null? .r|3) (sparc.set .as|3 $imm.null $r.argreg2) (emit-move2hwreg! .as|3 .r|3 $r.argreg2)) (sparc.slli .as|3 $r.argreg3 8 $r.tmp0) (sparc.addi .as|3 $r.tmp0 .hdr|3 $r.tmp0) (sparc.sti .as|3 $r.tmp0 0 $r.result) (sparc.addi .as|3 $r.result .ptrtag|3 $r.result))))) (.emit-make-vector-like!|2 .as|1 .r|1 .hdr|1 .ptrtag|1))))) 'emit-make-vector-like!))
+(let () (begin (set! emit-vector-like-ref! (lambda (.as|1 .rs1|1 .rs2|1 .rd|1 .fault|1 .tag|1 .header-loaded?|1) (let ((.emit-vector-like-ref!|2 0)) (begin (set! .emit-vector-like-ref!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rd|3 .fault|3 .tag|3 .header-loaded?|3) (let ((.index|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (begin (if (not (unsafe-code)) (begin (if (not .header-loaded?|3) (sparc.ldi .as|3 .rs1|3 (- 0 .tag|3) $r.tmp0) (unspecified)) (sparc.btsti .as|3 .index|6 3) (sparc.bne .as|3 .fault|3) (sparc.srai .as|3 $r.tmp0 8 $r.tmp0) (sparc.cmpr .as|3 $r.tmp0 .index|6) (sparc.bleu .as|3 .fault|3)) (unspecified)) (emit-vector-like-ref-trusted! .as|3 .rs1|3 .index|6 .rd|3 .tag|3))))) (.emit-vector-like-ref!|2 .as|1 .rs1|1 .rs2|1 .rd|1 .fault|1 .tag|1 .header-loaded?|1))))) 'emit-vector-like-ref!))
+(let () (begin (set! emit-vector-like-ref-trusted! (lambda (.as|1 .rs1|1 .rs2|1 .rd|1 .tag|1) (let ((.emit-vector-like-ref-trusted!|2 0)) (begin (set! .emit-vector-like-ref-trusted!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rd|3 .tag|3) (let ((.index|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (begin (sparc.addi .as|3 .rs1|3 (- 4 .tag|3) $r.tmp0) (sparc.ldr .as|3 $r.tmp0 .index|6 .rd|3))))) (.emit-vector-like-ref-trusted!|2 .as|1 .rs1|1 .rs2|1 .rd|1 .tag|1))))) 'emit-vector-like-ref-trusted!))
+(let () (begin (set! emit-vector-like-ref/imm! (lambda (.as|1 .rs1|1 .imm|1 .rd|1 .fault|1 .tag|1 .header-loaded?|1) (let ((.emit-vector-like-ref/imm!|2 0)) (begin (set! .emit-vector-like-ref/imm!|2 (lambda (.as|3 .rs1|3 .imm|3 .rd|3 .fault|3 .tag|3 .header-loaded?|3) (begin (if (not (unsafe-code)) (begin (if (not .header-loaded?|3) (sparc.ldi .as|3 .rs1|3 (- 0 .tag|3) $r.tmp0) (unspecified)) (sparc.srai .as|3 $r.tmp0 10 $r.tmp0) (sparc.cmpi .as|3 $r.tmp0 .imm|3) (sparc.bleu .as|3 .fault|3) (sparc.nop .as|3)) (unspecified)) (emit-vector-like-ref/imm-trusted! .as|3 .rs1|3 .imm|3 .rd|3 .tag|3)))) (.emit-vector-like-ref/imm!|2 .as|1 .rs1|1 .imm|1 .rd|1 .fault|1 .tag|1 .header-loaded?|1))))) 'emit-vector-like-ref/imm!))
+(let () (begin (set! emit-vector-like-ref/imm-trusted! (lambda (.as|1 .rs1|1 .imm|1 .rd|1 .tag|1) (let ((.emit-vector-like-ref/imm-trusted!|2 0)) (begin (set! .emit-vector-like-ref/imm-trusted!|2 (lambda (.as|3 .rs1|3 .imm|3 .rd|3 .tag|3) (let* ((.offset|6 (* .imm|3 4)) (.adjusted-offset|9 (+ (- 4 .tag|3) .offset|6))) (let () (if (immediate-literal? .adjusted-offset|9) (sparc.ldi .as|3 .rs1|3 .adjusted-offset|9 .rd|3) (begin (sparc.addi .as|3 .rs1|3 (- 4 .tag|3) $r.tmp0) (sparc.ldi .as|3 $r.tmp0 .offset|6 .rd|3))))))) (.emit-vector-like-ref/imm-trusted!|2 .as|1 .rs1|1 .imm|1 .rd|1 .tag|1))))) 'emit-vector-like-ref/imm-trusted!))
+(let () (begin (set! emit-vector-like-set! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1 .fault|1 .tag|1 .header-loaded?|1) (let ((.emit-vector-like-set!|2 0)) (begin (set! .emit-vector-like-set!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rs3|3 .fault|3 .tag|3 .header-loaded?|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.tmp1)) (.rs3|6 (force-hwreg! .as|3 .rs3|3 $r.argreg2))) (begin (if (not (unsafe-code)) (begin (if (not .header-loaded?|3) (sparc.ldi .as|3 $r.result (- 0 .tag|3) $r.tmp0) (unspecified)) (sparc.btsti .as|3 .rs2|6 3) (sparc.bne .as|3 .fault|3) (sparc.srai .as|3 $r.tmp0 8 $r.tmp0) (sparc.cmpr .as|3 $r.tmp0 .rs2|6) (sparc.bleu .as|3 .fault|3)) (unspecified)) (emit-vector-like-set-trusted! .as|3 .rs1|3 .rs2|6 .rs3|6 .tag|3))))) (.emit-vector-like-set!|2 .as|1 .rs1|1 .rs2|1 .rs3|1 .fault|1 .tag|1 .header-loaded?|1))))) 'emit-vector-like-set!))
+(let () (begin (set! emit-vector-like-set-trusted! (lambda (.as|1 .rs1|1 .rs2|1 .rs3|1 .tag|1) (let ((.emit-vector-like-set-trusted!|2 0)) (begin (set! .emit-vector-like-set-trusted!|2 (lambda (.as|3 .rs1|3 .rs2|3 .rs3|3 .tag|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.tmp1)) (.rs3|6 (force-hwreg! .as|3 .rs3|3 $r.argreg2))) (begin (sparc.addr .as|3 .rs1|3 .rs2|6 $r.tmp0) (if (not (write-barrier)) (sparc.sti .as|3 .rs3|6 (- 4 .tag|3) $r.tmp0) (if (= .rs1|3 $r.result) (if (= .rs3|6 $r.argreg2) (begin (sparc.jmpli .as|3 $r.millicode $m.addtrans $r.o7) (sparc.sti .as|3 .rs3|6 (- 4 .tag|3) $r.tmp0)) (begin (sparc.sti .as|3 .rs3|6 (- 4 .tag|3) $r.tmp0) (millicode-call/1arg .as|3 $m.addtrans .rs3|6))) (if (= .rs3|6 $r.argreg2) (begin (sparc.sti .as|3 .rs3|6 (- 4 .tag|3) $r.tmp0) (millicode-call/1arg-in-result .as|3 $m.addtrans .rs1|3)) (begin (sparc.sti .as|3 .rs3|6 (- 4 .tag|3) $r.tmp0) (sparc.move .as|3 .rs1|3 $r.result) (millicode-call/1arg .as|3 $m.addtrans .rs3|6))))))))) (.emit-vector-like-set-trusted!|2 .as|1 .rs1|1 .rs2|1 .rs3|1 .tag|1))))) 'emit-vector-like-set-trusted!))
+(let () (define-primop 'most-negative-fixnum (lambda (.as|1) (emit-immediate->register! .as|1 (asm:signed 2147483648) $r.result))))
+(let () (define-primop 'most-positive-fixnum (lambda (.as|1) (emit-immediate->register! .as|1 (asm:signed 2147483644) $r.result))))
+(let () (define-primop 'fx+ (lambda (.as|1 .rs2|1) (emit-fixnum-arithmetic .as|1 sparc.taddrcc sparc.addr $r.result .rs2|1 $r.result $ex.fx+))))
+(let () (define-primop 'internal:fx+ (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-arithmetic .as|1 sparc.taddrcc sparc.addr .rs1|1 .rs2|1 .rd|1 $ex.fx+))))
+(let () (define-primop 'fx- (lambda (.as|1 .rs2|1) (emit-fixnum-arithmetic .as|1 sparc.tsubrcc sparc.subr $r.result .rs2|1 $r.result $ex.fx-))))
+(let () (define-primop 'internal:fx- (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-arithmetic .as|1 sparc.tsubrcc sparc.subr .rs1|1 .rs2|1 .rd|1 $ex.fx-))))
+(let () (define-primop 'fx-- (lambda (.as|1) (emit-fixnum-arithmetic .as|1 sparc.tsubrcc sparc.subr $r.g0 $r.result $r.result $ex.fx--))))
+(let () (define-primop 'internal:fx-- (lambda (.as|1 .rs|1 .rd|1) (emit-fixnum-arithmetic .as|1 sparc.tsubrcc sparc.subr $r.g0 .rs|1 .rd|1 $ex.fx--))))
+(let () (begin (set! emit-fixnum-arithmetic (lambda (.as|1 .op-check|1 .op-nocheck|1 .rs1|1 .rs2|1 .rd|1 .exn|1) (let ((.emit-fixnum-arithmetic|2 0)) (begin (set! .emit-fixnum-arithmetic|2 (lambda (.as|3 .op-check|3 .op-nocheck|3 .rs1|3 .rs2|3 .rd|3 .exn|3) (if (unsafe-code) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (.op-nocheck|3 .as|3 .rs1|3 .rs2|6 .rd|3)) (let ((.rs2|9 (force-hwreg! .as|3 .rs2|3 $r.argreg2)) (.l0|9 (new-label)) (.l1|9 (new-label))) (begin (sparc.label .as|3 .l0|9) (.op-check|3 .as|3 .rs1|3 .rs2|9 $r.tmp0) (sparc.bvc.a .as|3 .l1|9) (sparc.move .as|3 $r.tmp0 .rd|3) (if (not (= .exn|3 $ex.fx--)) (begin (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (if (not (= .rs2|9 $r.argreg2)) (sparc.move .as|3 .rs2|9 $r.argreg2) (unspecified))) (if (not (= .rs2|9 $r.result)) (sparc.move .as|3 .rs2|9 $r.result) (unspecified))) (sparc.set .as|3 (thefixnum .exn|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|9) (sparc.label .as|3 .l1|9)))))) (.emit-fixnum-arithmetic|2 .as|1 .op-check|1 .op-nocheck|1 .rs1|1 .rs2|1 .rd|1 .exn|1))))) 'emit-fixnum-arithmetic))
+(let () (define-primop 'fx* (lambda (.as|1 .rs2|1) (emit-multiply-code .as|1 .rs2|1 #t))))
+(let () (define-primop 'internal:fx+/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-arithmetic/imm .as|1 sparc.taddicc sparc.addi .rs|1 .imm|1 .rd|1 $ex.fx+))))
+(let () (define-primop 'internal:fx-/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-arithmetic/imm .as|1 sparc.tsubicc sparc.subi .rs|1 .imm|1 .rd|1 $ex.fx-))))
+(let () (begin (set! emit-fixnum-arithmetic/imm (lambda (.as|1 .op-check|1 .op-nocheck|1 .rs|1 .imm|1 .rd|1 .exn|1) (let ((.emit-fixnum-arithmetic/imm|2 0)) (begin (set! .emit-fixnum-arithmetic/imm|2 (lambda (.as|3 .op-check|3 .op-nocheck|3 .rs|3 .imm|3 .rd|3 .exn|3) (if (unsafe-code) (.op-nocheck|3 .as|3 .rs|3 (thefixnum .imm|3) .rd|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (.op-check|3 .as|3 .rs|3 (thefixnum .imm|3) $r.tmp0) (sparc.bvc.a .as|3 .l1|6) (sparc.move .as|3 $r.tmp0 .rd|3) (if (not (= .rs|3 $r.result)) (sparc.move .as|3 .rs|3 $r.result) (unspecified)) (sparc.set .as|3 (thefixnum .imm|3) $r.argreg2) (sparc.set .as|3 (thefixnum .exn|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|6) (sparc.label .as|3 .l1|6)))))) (.emit-fixnum-arithmetic/imm|2 .as|1 .op-check|1 .op-nocheck|1 .rs|1 .imm|1 .rd|1 .exn|1))))) 'emit-fixnum-arithmetic/imm))
+(let () (define-primop 'fx= (lambda (.as|1 .rs2|1) (emit-fixnum-compare .as|1 sparc.bne.a $r.result .rs2|1 $r.result $ex.fx= #f))))
+(let () (define-primop 'fx< (lambda (.as|1 .rs2|1) (emit-fixnum-compare .as|1 sparc.bge.a $r.result .rs2|1 $r.result $ex.fx< #f))))
+(let () (define-primop 'fx<= (lambda (.as|1 .rs2|1) (emit-fixnum-compare .as|1 sparc.bg.a $r.result .rs2|1 $r.result $ex.fx<= #f))))
+(let () (define-primop 'fx> (lambda (.as|1 .rs2|1) (emit-fixnum-compare .as|1 sparc.ble.a $r.result .rs2|1 $r.result $ex.fx> #f))))
+(let () (define-primop 'fx>= (lambda (.as|1 .rs2|1) (emit-fixnum-compare .as|1 sparc.bl.a $r.result .rs2|1 $r.result $ex.fx>= #f))))
+(let () (define-primop 'internal:fx= (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare .as|1 sparc.bne.a .rs1|1 .rs2|1 .rd|1 $ex.fx= #f))))
+(let () (define-primop 'internal:fx< (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare .as|1 sparc.bge.a .rs1|1 .rs2|1 .rd|1 $ex.fx< #f))))
+(let () (define-primop 'internal:fx<= (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare .as|1 sparc.bg.a .rs1|1 .rs2|1 .rd|1 $ex.fx<= #f))))
+(let () (define-primop 'internal:fx> (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare .as|1 sparc.ble.a .rs1|1 .rs2|1 .rd|1 $ex.fx> #f))))
+(let () (define-primop 'internal:fx>= (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare .as|1 sparc.bl.a .rs1|1 .rs2|1 .rd|1 $ex.fx>= #f))))
+(let () (define-primop 'fxpositive? (lambda (.as|1) (emit-fixnum-compare/imm .as|1 sparc.ble.a $r.result 0 $r.result $ex.fxpositive? #f))))
+(let () (define-primop 'fxnegative? (lambda (.as|1) (emit-fixnum-compare/imm .as|1 sparc.bge.a $r.result 0 $r.result $ex.fxnegative? #f))))
+(let () (define-primop 'fxzero? (lambda (.as|1) (emit-fixnum-compare/imm .as|1 sparc.bne.a $r.result 0 $r.result $ex.fxzero? #f))))
+(let () (define-primop 'internal:fxpositive? (lambda (.as|1 .rs|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.ble.a .rs|1 0 .rd|1 $ex.fxpositive? #f))))
+(let () (define-primop 'internal:fxnegative? (lambda (.as|1 .rs|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bge.a .rs|1 0 .rd|1 $ex.fxnegative? #f))))
+(let () (define-primop 'internal:fxzero? (lambda (.as|1 .rs|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bne.a .rs|1 0 .rd|1 $ex.fxzero? #f))))
+(let () (define-primop 'internal:fx=/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bne.a .rs|1 .imm|1 .rd|1 $ex.fx= #f))))
+(let () (define-primop 'internal:fx</imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bge.a .rs|1 .imm|1 .rd|1 $ex.fx< #f))))
+(let () (define-primop 'internal:fx<=/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bg.a .rs|1 .imm|1 .rd|1 $ex.fx<= #f))))
+(let () (define-primop 'internal:fx>/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.ble.a .rs|1 .imm|1 .rd|1 $ex.fx> #f))))
+(let () (define-primop 'internal:fx>=/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm .as|1 sparc.bl.a .rs|1 .imm|1 .rd|1 $ex.fx>= #f))))
+(let () (define-primop 'internal:branchf-fx= (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare .as|1 sparc.bne.a .rs1|1 .rs2|1 #f $ex.fx= .l|1))))
+(let () (define-primop 'internal:branchf-fx< (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare .as|1 sparc.bge.a .rs1|1 .rs2|1 #f $ex.fx< .l|1))))
+(let () (define-primop 'internal:branchf-fx<= (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare .as|1 sparc.bg.a .rs1|1 .rs2|1 #f $ex.fx<= .l|1))))
+(let () (define-primop 'internal:branchf-fx> (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare .as|1 sparc.ble.a .rs1|1 .rs2|1 #f $ex.fx> .l|1))))
+(let () (define-primop 'internal:branchf-fx>= (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare .as|1 sparc.bl.a .rs1|1 .rs2|1 #f $ex.fx>= .l|1))))
+(let () (define-primop 'internal:branchf-fxpositive? (lambda (.as|1 .rs1|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.ble.a .rs1|1 0 #f $ex.fxpositive? .l|1))))
+(let () (define-primop 'internal:branchf-fxnegative? (lambda (.as|1 .rs1|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bge.a .rs1|1 0 #f $ex.fxnegative? .l|1))))
+(let () (define-primop 'internal:branchf-fxzero? (lambda (.as|1 .rs1|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bne.a .rs1|1 0 #f $ex.fxzero? .l|1))))
+(let () (define-primop 'internal:branchf-fx=/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bne.a .rs|1 .imm|1 #f $ex.fx= .l|1))))
+(let () (define-primop 'internal:branchf-fx</imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bge.a .rs|1 .imm|1 #f $ex.fx< .l|1))))
+(let () (define-primop 'internal:branchf-fx<=/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bg.a .rs|1 .imm|1 #f $ex.fx<= .l|1))))
+(let () (define-primop 'internal:branchf-fx>/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.ble.a .rs|1 .imm|1 #f $ex.fx> .l|1))))
+(let () (define-primop 'internal:branchf-fx>=/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm .as|1 sparc.bl.a .rs|1 .imm|1 #f $ex.fx>= .l|1))))
+(let () (define-primop '=:fix:fix (lambda (.as|1 .rs2|1) (emit-fixnum-compare-trusted .as|1 sparc.bne.a $r.result .rs2|1 $r.result #f))))
+(let () (define-primop '<:fix:fix (lambda (.as|1 .rs2|1) (emit-fixnum-compare-trusted .as|1 sparc.bge.a $r.result .rs2|1 $r.result #f))))
+(let () (define-primop '<=:fix:fix (lambda (.as|1 .rs2|1) (emit-fixnum-compare-trusted .as|1 sparc.bg.a $r.result .rs2|1 $r.result #f))))
+(let () (define-primop '>:fix:fix (lambda (.as|1 .rs2|1) (emit-fixnum-compare-trusted .as|1 sparc.ble.a $r.result .rs2|1 $r.result #f))))
+(let () (define-primop '>=:fix:fix (lambda (.as|1 .rs2|1) (emit-fixnum-compare-trusted .as|1 sparc.bl.a $r.result .rs2|1 $r.result #f))))
+(let () (define-primop 'internal:=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare-trusted .as|1 sparc.bne.a .rs1|1 .rs2|1 .rd|1 #f))))
+(let () (define-primop 'internal:<:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare-trusted .as|1 sparc.bge.a .rs1|1 .rs2|1 .rd|1 #f))))
+(let () (define-primop 'internal:<=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare-trusted .as|1 sparc.bg.a .rs1|1 .rs2|1 .rd|1 #f))))
+(let () (define-primop 'internal:>:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare-trusted .as|1 sparc.ble.a .rs1|1 .rs2|1 .rd|1 #f))))
+(let () (define-primop 'internal:>=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .rd|1) (emit-fixnum-compare-trusted .as|1 sparc.bl.a .rs1|1 .rs2|1 .rd|1 #f))))
+(let () (define-primop 'internal:=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bne.a .rs|1 .imm|1 .rd|1 #f))))
+(let () (define-primop 'internal:<:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bge.a .rs|1 .imm|1 .rd|1 #f))))
+(let () (define-primop 'internal:<=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bg.a .rs|1 .imm|1 .rd|1 #f))))
+(let () (define-primop 'internal:>:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.ble.a .rs|1 .imm|1 .rd|1 #f))))
+(let () (define-primop 'internal:>=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .rd|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bl.a .rs|1 .imm|1 .rd|1 #f))))
+(let () (define-primop 'internal:branchf-=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare-trusted .as|1 sparc.bne.a .rs1|1 .rs2|1 #f .l|1))))
+(let () (define-primop 'internal:branchf-<:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare-trusted .as|1 sparc.bge.a .rs1|1 .rs2|1 #f .l|1))))
+(let () (define-primop 'internal:branchf-<=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare-trusted .as|1 sparc.bg.a .rs1|1 .rs2|1 #f .l|1))))
+(let () (define-primop 'internal:branchf->:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare-trusted .as|1 sparc.ble.a .rs1|1 .rs2|1 #f .l|1))))
+(let () (define-primop 'internal:branchf->=:fix:fix (lambda (.as|1 .rs1|1 .rs2|1 .l|1) (emit-fixnum-compare-trusted .as|1 sparc.bl.a .rs1|1 .rs2|1 #f .l|1))))
+(let () (define-primop 'internal:branchf-=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bne.a .rs|1 .imm|1 #f .l|1))))
+(let () (define-primop 'internal:branchf-<:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bge.a .rs|1 .imm|1 #f .l|1))))
+(let () (define-primop 'internal:branchf-<=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bg.a .rs|1 .imm|1 #f .l|1))))
+(let () (define-primop 'internal:branchf->:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.ble.a .rs|1 .imm|1 #f .l|1))))
+(let () (define-primop 'internal:branchf->=:fix:fix/imm (lambda (.as|1 .rs|1 .imm|1 .l|1) (emit-fixnum-compare/imm-trusted .as|1 sparc.bl.a .rs|1 .imm|1 #f .l|1))))
+(let () (define-primop 'internal:check-range (lambda (.as|1 .src1|1 .src2|1 .l1|1 .livregs|1) (let ((.src2|4 (force-hwreg! .as|1 .src2|1 $r.argreg2))) (emit-fixnum-compare-check .as|1 .src2|4 .src1|1 sparc.bleu .l1|1 .livregs|1)))))
+(let () (define-primop 'internal:check-=:fix:fix (lambda (.as|1 .src1|1 .src2|1 .l1|1 .liveregs|1) (emit-fixnum-compare-check .as|1 .src1|1 .src2|1 sparc.bne .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check-<:fix:fix (lambda (.as|1 .src1|1 .src2|1 .l1|1 .liveregs|1) (emit-fixnum-compare-check .as|1 .src1|1 .src2|1 sparc.bge .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check-<=:fix:fix (lambda (.as|1 .src1|1 .src2|1 .l1|1 .liveregs|1) (emit-fixnum-compare-check .as|1 .src1|1 .src2|1 sparc.bg .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check->:fix:fix (lambda (.as|1 .src1|1 .src2|1 .l1|1 .liveregs|1) (emit-fixnum-compare-check .as|1 .src1|1 .src2|1 sparc.ble .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check->=:fix:fix (lambda (.as|1 .src1|1 .src2|1 .l1|1 .liveregs|1) (emit-fixnum-compare-check .as|1 .src1|1 .src2|1 sparc.bl .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check-=:fix:fix/imm (lambda (.as|1 .src1|1 .imm|1 .l1|1 .liveregs|1) (emit-fixnum-compare/imm-check .as|1 .src1|1 .imm|1 sparc.bne .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check-<:fix:fix/imm (lambda (.as|1 .src1|1 .imm|1 .l1|1 .liveregs|1) (emit-fixnum-compare/imm-check .as|1 .src1|1 .imm|1 sparc.bge .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check-<=:fix:fix/imm (lambda (.as|1 .src1|1 .imm|1 .l1|1 .liveregs|1) (emit-fixnum-compare/imm-check .as|1 .src1|1 .imm|1 sparc.bg .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check->:fix:fix/imm (lambda (.as|1 .src1|1 .imm|1 .l1|1 .liveregs|1) (emit-fixnum-compare/imm-check .as|1 .src1|1 .imm|1 sparc.ble .l1|1 .liveregs|1))))
+(let () (define-primop 'internal:check->=:fix:fix/imm (lambda (.as|1 .src1|1 .imm|1 .l1|1 .liveregs|1) (emit-fixnum-compare/imm-check .as|1 .src1|1 .imm|1 sparc.bl .l1|1 .liveregs|1))))
+(let () (begin (set! emit-fixnum-compare (lambda (.as|1 .branchf.a|1 .rs1|1 .rs2|1 .rd|1 .exn|1 .target|1) (let ((.emit-fixnum-compare|2 0)) (begin (set! .emit-fixnum-compare|2 (lambda (.as|3 .branchf.a|3 .rs1|3 .rs2|3 .rd|3 .exn|3 .target|3) (if (unsafe-code) (emit-fixnum-compare-trusted .as|3 .branchf.a|3 .rs1|3 .rs2|3 .rd|3 .target|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2)) (.l0|6 (new-label)) (.l1|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.orr .as|3 .rs1|3 .rs2|6 $r.tmp0) (sparc.btsti .as|3 $r.tmp0 3) (sparc.be.a .as|3 .l1|6) (sparc.cmpr .as|3 .rs1|3 .rs2|6) (if (not (= .rs1|3 $r.result)) (sparc.move .as|3 .rs1|3 $r.result) (unspecified)) (if (not (= .rs2|6 $r.argreg2)) (sparc.move .as|3 .rs2|6 $r.argreg2) (unspecified)) (sparc.set .as|3 (thefixnum .exn|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|6) (sparc.label .as|3 .l1|6) (emit-evaluate-cc! .as|3 .branchf.a|3 .rd|3 .target|3)))))) (.emit-fixnum-compare|2 .as|1 .branchf.a|1 .rs1|1 .rs2|1 .rd|1 .exn|1 .target|1))))) 'emit-fixnum-compare))
+(let () (begin (set! emit-fixnum-compare-trusted (lambda (.as|1 .branchf.a|1 .rs1|1 .rs2|1 .rd|1 .target|1) (let ((.emit-fixnum-compare-trusted|2 0)) (begin (set! .emit-fixnum-compare-trusted|2 (lambda (.as|3 .branchf.a|3 .rs1|3 .rs2|3 .rd|3 .target|3) (let ((.rs2|6 (force-hwreg! .as|3 .rs2|3 $r.argreg2))) (begin (sparc.cmpr .as|3 .rs1|3 .rs2|6) (emit-evaluate-cc! .as|3 .branchf.a|3 .rd|3 .target|3))))) (.emit-fixnum-compare-trusted|2 .as|1 .branchf.a|1 .rs1|1 .rs2|1 .rd|1 .target|1))))) 'emit-fixnum-compare-trusted))
+(let () (begin (set! emit-fixnum-compare/imm (lambda (.as|1 .branchf.a|1 .rs|1 .imm|1 .rd|1 .exn|1 .target|1) (let ((.emit-fixnum-compare/imm|2 0)) (begin (set! .emit-fixnum-compare/imm|2 (lambda (.as|3 .branchf.a|3 .rs|3 .imm|3 .rd|3 .exn|3 .target|3) (begin (if (unsafe-code) (emit-fixnum-compare/imm-trusted .as|3 .branchf.a|3 .rs|3 .imm|3 .rd|3 .target|3) (let ((.l0|6 (new-label)) (.l1|6 (new-label))) (begin (sparc.label .as|3 .l0|6) (sparc.btsti .as|3 .rs|3 3) (sparc.be.a .as|3 .l1|6) (sparc.cmpi .as|3 .rs|3 (thefixnum .imm|3)) (if (not (= .rs|3 $r.result)) (sparc.move .as|3 .rs|3 $r.result) (unspecified)) (sparc.set .as|3 (thefixnum .imm|3) $r.argreg2) (sparc.set .as|3 (thefixnum .exn|3) $r.tmp0) (millicode-call/ret .as|3 $m.exception .l0|6) (sparc.label .as|3 .l1|6)))) (emit-evaluate-cc! .as|3 .branchf.a|3 .rd|3 .target|3)))) (.emit-fixnum-compare/imm|2 .as|1 .branchf.a|1 .rs|1 .imm|1 .rd|1 .exn|1 .target|1))))) 'emit-fixnum-compare/imm))
+(let () (begin (set! emit-fixnum-compare/imm-trusted (lambda (.as|1 .branchf.a|1 .rs|1 .imm|1 .rd|1 .target|1) (let ((.emit-fixnum-compare/imm-trusted|2 0)) (begin (set! .emit-fixnum-compare/imm-trusted|2 (lambda (.as|3 .branchf.a|3 .rs|3 .imm|3 .rd|3 .target|3) (begin (sparc.cmpi .as|3 .rs|3 (thefixnum .imm|3)) (emit-evaluate-cc! .as|3 .branchf.a|3 .rd|3 .target|3)))) (.emit-fixnum-compare/imm-trusted|2 .as|1 .branchf.a|1 .rs|1 .imm|1 .rd|1 .target|1))))) 'emit-fixnum-compare/imm-trusted))
+(let () (begin (set! emit-fixnum-compare-check (lambda (.as|1 .src1|1 .src2|1 .branch-bad|1 .l1|1 .liveregs|1) (let ((.emit-fixnum-compare-check|2 0)) (begin (set! .emit-fixnum-compare-check|2 (lambda (.as|3 .src1|3 .src2|3 .branch-bad|3 .l1|3 .liveregs|3) (begin (internal-primop-invariant1 'emit-fixnum-compare-check .src1|3) (let ((.src2|6 (force-hwreg! .as|3 .src2|3 $r.argreg2))) (begin (sparc.cmpr .as|3 .src1|3 .src2|6) (emit-checkcc! .as|3 .branch-bad|3 .l1|3 .liveregs|3)))))) (.emit-fixnum-compare-check|2 .as|1 .src1|1 .src2|1 .branch-bad|1 .l1|1 .liveregs|1))))) 'emit-fixnum-compare-check))
+(let () (begin (set! emit-fixnum-compare/imm-check (lambda (.as|1 .src1|1 .imm|1 .branch-bad|1 .l1|1 .liveregs|1) (let ((.emit-fixnum-compare/imm-check|2 0)) (begin (set! .emit-fixnum-compare/imm-check|2 (lambda (.as|3 .src1|3 .imm|3 .branch-bad|3 .l1|3 .liveregs|3) (begin (internal-primop-invariant1 'emit-fixnum-compare/imm-check .src1|3) (sparc.cmpi .as|3 .src1|3 .imm|3) (emit-checkcc! .as|3 .branch-bad|3 .l1|3 .liveregs|3)))) (.emit-fixnum-compare/imm-check|2 .as|1 .src1|1 .imm|1 .branch-bad|1 .l1|1 .liveregs|1))))) 'emit-fixnum-compare/imm-check))
+(let () (begin (set! short-effective-addresses (make-twobit-flag 'short-effective-addresses)) 'short-effective-addresses))
+(let () (begin (set! runtime-safety-checking (make-twobit-flag 'runtime-safety-checking)) 'runtime-safety-checking))
+(let () (begin (set! catch-undefined-globals (make-twobit-flag 'catch-undefined-globals)) 'catch-undefined-globals))
+(let () (begin (set! inline-allocation (make-twobit-flag 'inline-allocation)) 'inline-allocation))
+(let () (begin (set! write-barrier (make-twobit-flag 'write-barrier)) 'write-barrier))
+(let () (begin (set! peephole-optimization (make-twobit-flag 'peephole-optimization)) 'peephole-optimization))
+(let () (begin (set! single-stepping (make-twobit-flag 'single-stepping)) 'single-stepping))
+(let () (begin (set! fill-delay-slots (make-twobit-flag 'fill-delay-slots)) 'fill-delay-slots))
+(let () (begin (set! unsafe-code (lambda .args|1 (if (null? .args|1) (not (runtime-safety-checking)) (runtime-safety-checking (not (let ((.x|2|5 .args|1)) (begin (.check! (pair? .x|2|5) 0 .x|2|5) (car:pair .x|2|5)))))))) 'unsafe-code))
+(let () (begin (set! display-assembler-flags (lambda (.which|1) (let ((.display-assembler-flags|2 0)) (begin (set! .display-assembler-flags|2 (lambda (.which|3) (let ((.temp|4|7 .which|3)) (if (memv .temp|4|7 '(debugging)) (display-twobit-flag single-stepping) (if (memv .temp|4|7 '(safety)) (begin (display-twobit-flag write-barrier) (display-twobit-flag runtime-safety-checking) (if (runtime-safety-checking) (begin (display " ") (display-twobit-flag catch-undefined-globals)) (unspecified))) (if (memv .temp|4|7 '(optimization)) (begin (display-twobit-flag peephole-optimization) (display-twobit-flag inline-allocation) (display-twobit-flag fill-delay-slots)) #t)))))) (.display-assembler-flags|2 .which|1))))) 'display-assembler-flags))
+(let () (begin (set! set-assembler-flags! (lambda (.mode|1) (let ((.set-assembler-flags!|2 0)) (begin (set! .set-assembler-flags!|2 (lambda (.mode|3) (let ((.temp|4|7 .mode|3)) (if (memv .temp|4|7 '(no-optimization)) (begin (.set-assembler-flags!|2 'standard) (peephole-optimization #f) (fill-delay-slots #f)) (if (memv .temp|4|7 '(standard)) (begin (short-effective-addresses #t) (catch-undefined-globals #t) (inline-allocation #f) (peephole-optimization #t) (runtime-safety-checking #t) (write-barrier #t) (single-stepping #f) (fill-delay-slots #t)) (if (memv .temp|4|7 '(fast-safe default)) (begin (.set-assembler-flags!|2 'standard) (inline-allocation #t)) (if (memv .temp|4|7 '(fast-unsafe)) (begin (.set-assembler-flags!|2 'fast-safe) (catch-undefined-globals #f) (runtime-safety-checking #f)) (error "set-assembler-flags!: unknown mode " .mode|3)))))))) (.set-assembler-flags!|2 .mode|1))))) 'set-assembler-flags!))
+(let () (set-assembler-flags! 'default))
+(let () (begin (set! disassemble-codevector (lambda (.cv|1) (let ((.disassemble-codevector|2 0)) (begin (set! .disassemble-codevector|2 (lambda (.cv|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.addr|5 .ilist|5) (if (< .addr|5 0) .ilist|5 (.loop|4 (- .addr|5 4) (cons (disassemble-instruction (bytevector-word-ref .cv|3 .addr|5) .addr|5) .ilist|5))))) (.loop|4 (- (bytevector-length .cv|3) 4) '()))))) (.disassemble-codevector|2 .cv|1))))) 'disassemble-codevector))
+(let () (begin (set! disassemble-instruction (undefined)) 'disassemble-instruction))
+(let () (begin (set! *asm-annul* 1) '*asm-annul*))
+(let () (begin (set! *asm-immed* 2) '*asm-immed*))
+(let () (begin (set! *asm-store* 4) '*asm-store*))
+(let () (begin (set! *asm-load* 8) '*asm-load*))
+(let () (begin (set! *asm-branch* 16) '*asm-branch*))
+(let () (begin (set! *asm-freg* 32) '*asm-freg*))
+(let () (begin (set! *asm-fpop* 64) '*asm-fpop*))
+(let () (begin (set! *asm-no-op2* 128) '*asm-no-op2*))
+(let () (begin (set! *asm-no-op3* 256) '*asm-no-op3*))
+(let () (begin (set! *asm-bits* (.cons (.cons 'a *asm-annul*) (.cons (.cons 'i *asm-immed*) (.cons (.cons 's *asm-store*) (.cons (.cons 'l *asm-load*) (.cons (.cons 'b *asm-branch*) (.cons (.cons 'f *asm-freg*) (.cons (.cons 'fpop *asm-fpop*) (.cons (.cons 'no-op2 *asm-no-op2*) (.cons (.cons 'no-op3 *asm-no-op3*) '())))))))))) '*asm-bits*))
+(let () (begin (set! *asm-mnemonic-table* '()) '*asm-mnemonic-table*))
+(let () (begin (set! mnemonic (let ((.n|3 0)) (lambda (.name|4 . .rest|4) (let* ((.probe|7 (assq .name|4 *asm-mnemonic-table*)) (.code|10 (* 1024 (if .probe|7 (let ((.x|42|45 .probe|7)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) (let ((.code|48 .n|3)) (begin (set! .n|3 (+ .n|3 1)) (set! *asm-mnemonic-table* (cons (cons .name|4 .code|48) *asm-mnemonic-table*)) .code|48)))))) (let () (begin (let () (let ((.loop|19|21|24 (unspecified))) (begin (set! .loop|19|21|24 (lambda (.y1|14|15|25) (if (null? .y1|14|15|25) (if #f #f (unspecified)) (begin (begin #t (let ((.x|29 (let ((.x|34|37 .y1|14|15|25)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (set! .code|10 (+ .code|10 (let ((.x|30|33 (assq .x|29 *asm-bits*))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))))) (.loop|19|21|24 (let ((.x|38|41 .y1|14|15|25)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))))))) (.loop|19|21|24 .rest|4)))) .code|10)))))) 'mnemonic))
+(let () (begin (set! mnemonic:name (lambda (.mnemonic|1) (let ((.mnemonic:name|2 0)) (begin (set! .mnemonic:name|2 (lambda (.mnemonic|3) (let* ((.mnemonic|6 (quotient .mnemonic|3 1024)) (.t|9 *asm-mnemonic-table*)) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.t|13) (if (null? .t|13) #f (if (= (let ((.x|17|20 (let ((.x|21|24 .t|13)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) .mnemonic|6) (let ((.x|26|29 (let ((.x|30|33 .t|13)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) (.loop|12 (let ((.x|35|38 .t|13)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38)))))))) (.loop|12 .t|9))))))) (.mnemonic:name|2 .mnemonic|1))))) 'mnemonic:name))
+(let () (begin (set! mnemonic=? (lambda (.m|1 .name|1) (let ((.mnemonic=?|2 0)) (begin (set! .mnemonic=?|2 (lambda (.m|3 .name|3) (= (quotient .m|3 1024) (quotient (mnemonic .name|3) 1024)))) (.mnemonic=?|2 .m|1 .name|1))))) 'mnemonic=?))
+(let () (begin (set! mnemonic:test (lambda (.bit|1) (let ((.mnemonic:test|2 0)) (begin (set! .mnemonic:test|2 (lambda (.bit|3) (lambda (.mnemonic|4) (not (zero? (logand .mnemonic|4 .bit|3)))))) (.mnemonic:test|2 .bit|1))))) 'mnemonic:test))
+(let () (begin (set! mnemonic:test-not (lambda (.bit|1) (let ((.mnemonic:test-not|2 0)) (begin (set! .mnemonic:test-not|2 (lambda (.bit|3) (lambda (.mnemonic|4) (zero? (logand .mnemonic|4 .bit|3))))) (.mnemonic:test-not|2 .bit|1))))) 'mnemonic:test-not))
+(let () (begin (set! mnemonic:annul? (mnemonic:test *asm-annul*)) 'mnemonic:annul?))
+(let () (begin (set! mnemonic:immediate? (mnemonic:test *asm-immed*)) 'mnemonic:immediate?))
+(let () (begin (set! mnemonic:store? (mnemonic:test *asm-store*)) 'mnemonic:store?))
+(let () (begin (set! mnemonic:load? (mnemonic:test *asm-load*)) 'mnemonic:load?))
+(let () (begin (set! mnemonic:branch? (mnemonic:test *asm-branch*)) 'mnemonic:branch?))
+(let () (begin (set! mnemonic:freg? (mnemonic:test *asm-freg*)) 'mnemonic:freg?))
+(let () (begin (set! mnemonic:fpop? (mnemonic:test *asm-fpop*)) 'mnemonic:fpop?))
+(let () (begin (set! mnemonic:op2? (mnemonic:test-not *asm-no-op2*)) 'mnemonic:op2?))
+(let () (begin (set! mnemonic:op3? (mnemonic:test-not *asm-no-op3*)) 'mnemonic:op3?))
+(let () (let () (let ((.fpop-field|4 (unspecified)) (.imm30field|4 (unspecified)) (.imm22field|4 (unspecified)) (.imm13field|4 (unspecified)) (.rdfield|4 (unspecified)) (.rs1field|4 (unspecified)) (.rs2field|4 (unspecified)) (.ifield|4 (unspecified)) (.op3field|4 (unspecified)) (.op2field|4 (unspecified)) (.fpop-instruction|4 (unspecified)) (.nice-instruction|4 (unspecified)) (.class01|4 (unspecified)) (.fpop-names|4 (unspecified)) (.class11|4 (unspecified)) (.class10|4 (unspecified)) (.class00|4 (unspecified)) (.two^32|4 (unspecified)) (.two^30|4 (unspecified)) (.two^29|4 (unspecified)) (.two^25|4 (unspecified)) (.two^24|4 (unspecified)) (.two^22|4 (unspecified)) (.two^21|4 (unspecified)) (.two^19|4 (unspecified)) (.two^16|4 (unspecified)) (.two^14|4 (unspecified)) (.two^13|4 (unspecified)) (.two^12|4 (unspecified)) (.two^9|4 (unspecified)) (.two^8|4 (unspecified)) (.two^6|4 (unspecified)) (.two^5|4 (unspecified)) (.two^3|4 (unspecified))) (begin (set! .fpop-field|4 (lambda (.instr|5) (remainder (quotient .instr|5 .two^5|4) .two^9|4))) (set! .imm30field|4 (lambda (.instr|6) (let ((.x|9 (remainder .instr|6 .two^30|4))) (if (not (zero? (quotient .x|9 .two^29|4))) (- .x|9 .two^30|4) .x|9)))) (set! .imm22field|4 (lambda (.instr|10) (let ((.x|13 (remainder .instr|10 .two^22|4))) (if (not (zero? (quotient .x|13 .two^21|4))) (- .x|13 .two^22|4) .x|13)))) (set! .imm13field|4 (lambda (.instr|14) (let ((.x|17 (remainder .instr|14 .two^13|4))) (if (not (zero? (quotient .x|17 .two^12|4))) (- .x|17 .two^13|4) .x|17)))) (set! .rdfield|4 (lambda (.instr|18) (remainder (quotient .instr|18 .two^25|4) .two^5|4))) (set! .rs1field|4 (lambda (.instr|19) (remainder (quotient .instr|19 .two^14|4) .two^5|4))) (set! .rs2field|4 (lambda (.instr|20) (remainder .instr|20 .two^5|4))) (set! .ifield|4 (lambda (.instr|21) (remainder (quotient .instr|21 .two^13|4) 2))) (set! .op3field|4 (lambda (.instr|22) (remainder (quotient .instr|22 .two^19|4) .two^6|4))) (set! .op2field|4 (lambda (.instr|23) (remainder (quotient .instr|23 .two^22|4) .two^3|4))) (set! .fpop-instruction|4 (lambda (.ip|24 .instr|24) (let ((.rd|27 (.rdfield|4 .instr|24)) (.rs1|27 (.rs1field|4 .instr|24)) (.rs2|27 (.rs2field|4 .instr|24)) (.fpop|27 (.fpop-field|4 .instr|24))) (.cons (let ((.x|69|72 (assv .fpop|27 .fpop-names|4))) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))) (.cons .rs1|27 (.cons .rs2|27 (.cons .rd|27 '()))))))) (set! .nice-instruction|4 (lambda (.op3-table|74 .ip|74 .instr|74) (let* ((.op3|77 (.op3field|4 .instr|74)) (.imm|80 (.ifield|4 .instr|74)) (.rd|83 (.rdfield|4 .instr|74)) (.rs1|86 (.rs1field|4 .instr|74)) (.src2|89 (if (zero? .imm|80) (.rs2field|4 .instr|74) (.imm13field|4 .instr|74)))) (let () (let ((.op|95 ((if (zero? .imm|80) car cadr) (let ((.v|137|140 .op3-table|74) (.i|137|140 .op3|77)) (begin (.check! (fixnum? .i|137|140) 40 .v|137|140 .i|137|140) (.check! (vector? .v|137|140) 40 .v|137|140 .i|137|140) (.check! (<:fix:fix .i|137|140 (vector-length:vec .v|137|140)) 40 .v|137|140 .i|137|140) (.check! (>=:fix:fix .i|137|140 0) 40 .v|137|140 .i|137|140) (vector-ref:trusted .v|137|140 .i|137|140)))))) (.cons .op|95 (.cons .rs1|86 (.cons .src2|89 (.cons .rd|83 '()))))))))) (set! .class01|4 (lambda (.ip|141 .instr|141) (.cons (mnemonic 'call) (.cons (* 4 (.imm30field|4 .instr|141)) '())))) (set! .fpop-names|4 (.cons (.cons 1 (mnemonic 'fmovs 'fpop 'no-op2)) (.cons (.cons 5 (mnemonic 'fnegs 'fpop 'no-op2)) (.cons (.cons 9 (mnemonic 'fabss 'fpop 'no-op2)) (.cons (.cons 66 (mnemonic 'faddd 'fpop)) (.cons (.cons 70 (mnemonic 'fsubd 'fpop)) (.cons (.cons 74 (mnemonic 'fmuld 'fpop)) (.cons (.cons 78 (mnemonic 'fdivd 'fpop)) (.cons (.cons 82 (mnemonic 'fcmpd 'fpop 'no-op3)) '()))))))))) (set! .class11|4 (let ((.op3-table|316 (.list->vector (.cons (.cons (mnemonic 'ld 'l) (.cons (mnemonic 'ld 'i 'l) '())) (.cons (.cons (mnemonic 'ldb 'l) (.cons (mnemonic 'ldb 'i 'l) '())) (.cons (.cons (mnemonic 'ldh 'l) (.cons (mnemonic 'ldh 'i 'l) '())) (.cons (.cons (mnemonic 'ldd 'l) (.cons (mnemonic 'ldd 'i 'l) '())) (.cons (.cons (mnemonic 'st 's) (.cons (mnemonic 'st 'i 's) '())) (.cons (.cons (mnemonic 'stb 's) (.cons (mnemonic 'stb 'i 's) '())) (.cons (.cons (mnemonic 'sth 's) (.cons (mnemonic 'sth 'i 's) '())) (.cons (.cons (mnemonic 'std 's) (.cons (mnemonic 'std 'i 's) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'ldf 'f 'l) (.cons (mnemonic 'ldf 'i 'f 'l) '())) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'lddf 'f 'l) (.cons (mnemonic 'lddf 'i 'f 'l) '())) (.cons (.cons (mnemonic 'stf 'f 's) (.cons (mnemonic 'stf 'i 'f 's) '())) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'stdf 'f 's) (.cons (mnemonic 'stdf 'i 'f 's) '())) '((0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0) (0 0))))))))))))))))))))))))))))))))))))))))))))) (lambda (.ip|317 .instr|317) (.nice-instruction|4 .op3-table|316 .ip|317 .instr|317)))) (set! .class10|4 (let ((.op3-table|1546 (.list->vector (.cons (.cons (mnemonic 'add) (.cons (mnemonic 'add 'i) '())) (.cons (.cons (mnemonic 'and) (.cons (mnemonic 'and 'i) '())) (.cons (.cons (mnemonic 'or) (.cons (mnemonic 'or 'i) '())) (.cons (.cons (mnemonic 'xor) (.cons (mnemonic 'xor 'i) '())) (.cons (.cons (mnemonic 'sub) (.cons (mnemonic 'sub 'i) '())) (.cons (.cons (mnemonic 'andn) (.cons (mnemonic 'andn 'i) '())) (.cons (.cons (mnemonic 'orn) (.cons (mnemonic 'orn 'i) '())) (.cons (.cons (mnemonic 'xnor) (.cons (mnemonic 'xnor 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'smul) (.cons (mnemonic 'smul 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'sdiv) (.cons (mnemonic 'sdiv 'i) '())) (.cons (.cons (mnemonic 'addcc) (.cons (mnemonic 'addcc 'i) '())) (.cons (.cons (mnemonic 'andcc) (.cons (mnemonic 'andcc 'i) '())) (.cons (.cons (mnemonic 'orcc) (.cons (mnemonic 'orcc 'i) '())) (.cons (.cons (mnemonic 'xorcc) (.cons (mnemonic 'xorcc 'i) '())) (.cons (.cons (mnemonic 'subcc) (.cons (mnemonic 'subcc 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'smulcc) (.cons (mnemonic 'smulcc 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'sdivcc) (.cons (mnemonic 'sdivcc 'i) '())) (.cons (.cons (mnemonic 'taddcc) (.cons (mnemonic 'taddcc 'i) '())) (.cons (.cons (mnemonic 'tsubcc) (.cons (mnemonic 'tsubcc 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'sll) (.cons (mnemonic 'sll 'i) '())) (.cons (.cons (mnemonic 'srl) (.cons (mnemonic 'srl 'i) '())) (.cons (.cons (mnemonic 'sra) (.cons (mnemonic 'sra 'i) '())) (.cons (.cons (mnemonic 'rd) '(0)) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'wr) (.cons (mnemonic 'wr 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'jmpl) (.cons (mnemonic 'jmpl 'i) '())) (.cons '(0 0) (.cons '(0 0) (.cons '(0 0) (.cons (.cons (mnemonic 'save) (.cons (mnemonic 'save 'i) '())) (.cons (.cons (mnemonic 'restore) (.cons (mnemonic 'restore 'i) '())) '((0 0) (0 0))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (lambda (.ip|1547 .instr|1547) (let ((.op3|1550 (.op3field|4 .instr|1547))) (if (let ((.temp|1551|1554 (= .op3|1550 52))) (if .temp|1551|1554 .temp|1551|1554 (= .op3|1550 53))) (.fpop-instruction|4 .ip|1547 .instr|1547) (.nice-instruction|4 .op3-table|1546 .ip|1547 .instr|1547)))))) (set! .class00|4 (let ((.b-table|2988 (let* ((.t|3097|3129|3134 (mnemonic 'bvc 'a 'b)) (.t|3097|3128|3137 (mnemonic 'bpos 'a 'b)) (.t|3097|3127|3140 (mnemonic 'bcc 'a 'b)) (.t|3097|3126|3143 (mnemonic 'bgu 'a 'b)) (.t|3097|3125|3146 (mnemonic 'bge 'a 'b)) (.t|3097|3124|3149 (mnemonic 'bg 'a 'b)) (.t|3097|3123|3152 (mnemonic 'bne 'a 'b)) (.t|3097|3122|3155 (mnemonic 'ba 'a 'b)) (.t|3097|3121|3158 (mnemonic 'bvs 'a 'b)) (.t|3097|3120|3161 (mnemonic 'bneg 'a 'b)) (.t|3097|3119|3164 (mnemonic 'bcs 'a 'b)) (.t|3097|3118|3167 (mnemonic 'bleu 'a 'b)) (.t|3097|3117|3170 (mnemonic 'bl 'a 'b)) (.t|3097|3116|3173 (mnemonic 'ble 'a 'b)) (.t|3097|3115|3176 (mnemonic 'be 'a 'b)) (.t|3097|3114|3179 (mnemonic 'bn 'a 'b)) (.t|3097|3113|3182 (mnemonic 'bvc 'b)) (.t|3097|3112|3185 (mnemonic 'bpos 'b)) (.t|3097|3111|3188 (mnemonic 'bcc 'b)) (.t|3097|3110|3191 (mnemonic 'bgu 'b)) (.t|3097|3109|3194 (mnemonic 'bge 'b)) (.t|3097|3108|3197 (mnemonic 'bg 'b)) (.t|3097|3107|3200 (mnemonic 'bne 'b)) (.t|3097|3106|3203 (mnemonic 'ba 'b)) (.t|3097|3105|3206 (mnemonic 'bvs 'b)) (.t|3097|3104|3209 (mnemonic 'bneg 'b)) (.t|3097|3103|3212 (mnemonic 'bcs 'b)) (.t|3097|3102|3215 (mnemonic 'bleu 'b)) (.t|3097|3101|3218 (mnemonic 'bl 'b)) (.t|3097|3100|3221 (mnemonic 'ble 'b)) (.t|3097|3099|3224 (mnemonic 'be 'b)) (.t|3097|3098|3227 (mnemonic 'bn 'b)) (.v|3097|3131|3230 (make-vector 32 .t|3097|3129|3134))) (let () (begin (let ((.v|3234|3237 .v|3097|3131|3230) (.i|3234|3237 30) (.x|3234|3237 .t|3097|3128|3137)) (begin (.check! (fixnum? .i|3234|3237) 41 .v|3234|3237 .i|3234|3237 .x|3234|3237) (.check! (vector? .v|3234|3237) 41 .v|3234|3237 .i|3234|3237 .x|3234|3237) (.check! (<:fix:fix .i|3234|3237 (vector-length:vec .v|3234|3237)) 41 .v|3234|3237 .i|3234|3237 .x|3234|3237) (.check! (>=:fix:fix .i|3234|3237 0) 41 .v|3234|3237 .i|3234|3237 .x|3234|3237) (vector-set!:trusted .v|3234|3237 .i|3234|3237 .x|3234|3237))) (let ((.v|3238|3241 .v|3097|3131|3230) (.i|3238|3241 29) (.x|3238|3241 .t|3097|3127|3140)) (begin (.check! (fixnum? .i|3238|3241) 41 .v|3238|3241 .i|3238|3241 .x|3238|3241) (.check! (vector? .v|3238|3241) 41 .v|3238|3241 .i|3238|3241 .x|3238|3241) (.check! (<:fix:fix .i|3238|3241 (vector-length:vec .v|3238|3241)) 41 .v|3238|3241 .i|3238|3241 .x|3238|3241) (.check! (>=:fix:fix .i|3238|3241 0) 41 .v|3238|3241 .i|3238|3241 .x|3238|3241) (vector-set!:trusted .v|3238|3241 .i|3238|3241 .x|3238|3241))) (let ((.v|3242|3245 .v|3097|3131|3230) (.i|3242|3245 28) (.x|3242|3245 .t|3097|3126|3143)) (begin (.check! (fixnum? .i|3242|3245) 41 .v|3242|3245 .i|3242|3245 .x|3242|3245) (.check! (vector? .v|3242|3245) 41 .v|3242|3245 .i|3242|3245 .x|3242|3245) (.check! (<:fix:fix .i|3242|3245 (vector-length:vec .v|3242|3245)) 41 .v|3242|3245 .i|3242|3245 .x|3242|3245) (.check! (>=:fix:fix .i|3242|3245 0) 41 .v|3242|3245 .i|3242|3245 .x|3242|3245) (vector-set!:trusted .v|3242|3245 .i|3242|3245 .x|3242|3245))) (let ((.v|3246|3249 .v|3097|3131|3230) (.i|3246|3249 27) (.x|3246|3249 .t|3097|3125|3146)) (begin (.check! (fixnum? .i|3246|3249) 41 .v|3246|3249 .i|3246|3249 .x|3246|3249) (.check! (vector? .v|3246|3249) 41 .v|3246|3249 .i|3246|3249 .x|3246|3249) (.check! (<:fix:fix .i|3246|3249 (vector-length:vec .v|3246|3249)) 41 .v|3246|3249 .i|3246|3249 .x|3246|3249) (.check! (>=:fix:fix .i|3246|3249 0) 41 .v|3246|3249 .i|3246|3249 .x|3246|3249) (vector-set!:trusted .v|3246|3249 .i|3246|3249 .x|3246|3249))) (let ((.v|3250|3253 .v|3097|3131|3230) (.i|3250|3253 26) (.x|3250|3253 .t|3097|3124|3149)) (begin (.check! (fixnum? .i|3250|3253) 41 .v|3250|3253 .i|3250|3253 .x|3250|3253) (.check! (vector? .v|3250|3253) 41 .v|3250|3253 .i|3250|3253 .x|3250|3253) (.check! (<:fix:fix .i|3250|3253 (vector-length:vec .v|3250|3253)) 41 .v|3250|3253 .i|3250|3253 .x|3250|3253) (.check! (>=:fix:fix .i|3250|3253 0) 41 .v|3250|3253 .i|3250|3253 .x|3250|3253) (vector-set!:trusted .v|3250|3253 .i|3250|3253 .x|3250|3253))) (let ((.v|3254|3257 .v|3097|3131|3230) (.i|3254|3257 25) (.x|3254|3257 .t|3097|3123|3152)) (begin (.check! (fixnum? .i|3254|3257) 41 .v|3254|3257 .i|3254|3257 .x|3254|3257) (.check! (vector? .v|3254|3257) 41 .v|3254|3257 .i|3254|3257 .x|3254|3257) (.check! (<:fix:fix .i|3254|3257 (vector-length:vec .v|3254|3257)) 41 .v|3254|3257 .i|3254|3257 .x|3254|3257) (.check! (>=:fix:fix .i|3254|3257 0) 41 .v|3254|3257 .i|3254|3257 .x|3254|3257) (vector-set!:trusted .v|3254|3257 .i|3254|3257 .x|3254|3257))) (let ((.v|3258|3261 .v|3097|3131|3230) (.i|3258|3261 24) (.x|3258|3261 .t|3097|3122|3155)) (begin (.check! (fixnum? .i|3258|3261) 41 .v|3258|3261 .i|3258|3261 .x|3258|3261) (.check! (vector? .v|3258|3261) 41 .v|3258|3261 .i|3258|3261 .x|3258|3261) (.check! (<:fix:fix .i|3258|3261 (vector-length:vec .v|3258|3261)) 41 .v|3258|3261 .i|3258|3261 .x|3258|3261) (.check! (>=:fix:fix .i|3258|3261 0) 41 .v|3258|3261 .i|3258|3261 .x|3258|3261) (vector-set!:trusted .v|3258|3261 .i|3258|3261 .x|3258|3261))) (let ((.v|3262|3265 .v|3097|3131|3230) (.i|3262|3265 23) (.x|3262|3265 .t|3097|3121|3158)) (begin (.check! (fixnum? .i|3262|3265) 41 .v|3262|3265 .i|3262|3265 .x|3262|3265) (.check! (vector? .v|3262|3265) 41 .v|3262|3265 .i|3262|3265 .x|3262|3265) (.check! (<:fix:fix .i|3262|3265 (vector-length:vec .v|3262|3265)) 41 .v|3262|3265 .i|3262|3265 .x|3262|3265) (.check! (>=:fix:fix .i|3262|3265 0) 41 .v|3262|3265 .i|3262|3265 .x|3262|3265) (vector-set!:trusted .v|3262|3265 .i|3262|3265 .x|3262|3265))) (let ((.v|3266|3269 .v|3097|3131|3230) (.i|3266|3269 22) (.x|3266|3269 .t|3097|3120|3161)) (begin (.check! (fixnum? .i|3266|3269) 41 .v|3266|3269 .i|3266|3269 .x|3266|3269) (.check! (vector? .v|3266|3269) 41 .v|3266|3269 .i|3266|3269 .x|3266|3269) (.check! (<:fix:fix .i|3266|3269 (vector-length:vec .v|3266|3269)) 41 .v|3266|3269 .i|3266|3269 .x|3266|3269) (.check! (>=:fix:fix .i|3266|3269 0) 41 .v|3266|3269 .i|3266|3269 .x|3266|3269) (vector-set!:trusted .v|3266|3269 .i|3266|3269 .x|3266|3269))) (let ((.v|3270|3273 .v|3097|3131|3230) (.i|3270|3273 21) (.x|3270|3273 .t|3097|3119|3164)) (begin (.check! (fixnum? .i|3270|3273) 41 .v|3270|3273 .i|3270|3273 .x|3270|3273) (.check! (vector? .v|3270|3273) 41 .v|3270|3273 .i|3270|3273 .x|3270|3273) (.check! (<:fix:fix .i|3270|3273 (vector-length:vec .v|3270|3273)) 41 .v|3270|3273 .i|3270|3273 .x|3270|3273) (.check! (>=:fix:fix .i|3270|3273 0) 41 .v|3270|3273 .i|3270|3273 .x|3270|3273) (vector-set!:trusted .v|3270|3273 .i|3270|3273 .x|3270|3273))) (let ((.v|3274|3277 .v|3097|3131|3230) (.i|3274|3277 20) (.x|3274|3277 .t|3097|3118|3167)) (begin (.check! (fixnum? .i|3274|3277) 41 .v|3274|3277 .i|3274|3277 .x|3274|3277) (.check! (vector? .v|3274|3277) 41 .v|3274|3277 .i|3274|3277 .x|3274|3277) (.check! (<:fix:fix .i|3274|3277 (vector-length:vec .v|3274|3277)) 41 .v|3274|3277 .i|3274|3277 .x|3274|3277) (.check! (>=:fix:fix .i|3274|3277 0) 41 .v|3274|3277 .i|3274|3277 .x|3274|3277) (vector-set!:trusted .v|3274|3277 .i|3274|3277 .x|3274|3277))) (let ((.v|3278|3281 .v|3097|3131|3230) (.i|3278|3281 19) (.x|3278|3281 .t|3097|3117|3170)) (begin (.check! (fixnum? .i|3278|3281) 41 .v|3278|3281 .i|3278|3281 .x|3278|3281) (.check! (vector? .v|3278|3281) 41 .v|3278|3281 .i|3278|3281 .x|3278|3281) (.check! (<:fix:fix .i|3278|3281 (vector-length:vec .v|3278|3281)) 41 .v|3278|3281 .i|3278|3281 .x|3278|3281) (.check! (>=:fix:fix .i|3278|3281 0) 41 .v|3278|3281 .i|3278|3281 .x|3278|3281) (vector-set!:trusted .v|3278|3281 .i|3278|3281 .x|3278|3281))) (let ((.v|3282|3285 .v|3097|3131|3230) (.i|3282|3285 18) (.x|3282|3285 .t|3097|3116|3173)) (begin (.check! (fixnum? .i|3282|3285) 41 .v|3282|3285 .i|3282|3285 .x|3282|3285) (.check! (vector? .v|3282|3285) 41 .v|3282|3285 .i|3282|3285 .x|3282|3285) (.check! (<:fix:fix .i|3282|3285 (vector-length:vec .v|3282|3285)) 41 .v|3282|3285 .i|3282|3285 .x|3282|3285) (.check! (>=:fix:fix .i|3282|3285 0) 41 .v|3282|3285 .i|3282|3285 .x|3282|3285) (vector-set!:trusted .v|3282|3285 .i|3282|3285 .x|3282|3285))) (let ((.v|3286|3289 .v|3097|3131|3230) (.i|3286|3289 17) (.x|3286|3289 .t|3097|3115|3176)) (begin (.check! (fixnum? .i|3286|3289) 41 .v|3286|3289 .i|3286|3289 .x|3286|3289) (.check! (vector? .v|3286|3289) 41 .v|3286|3289 .i|3286|3289 .x|3286|3289) (.check! (<:fix:fix .i|3286|3289 (vector-length:vec .v|3286|3289)) 41 .v|3286|3289 .i|3286|3289 .x|3286|3289) (.check! (>=:fix:fix .i|3286|3289 0) 41 .v|3286|3289 .i|3286|3289 .x|3286|3289) (vector-set!:trusted .v|3286|3289 .i|3286|3289 .x|3286|3289))) (let ((.v|3290|3293 .v|3097|3131|3230) (.i|3290|3293 16) (.x|3290|3293 .t|3097|3114|3179)) (begin (.check! (fixnum? .i|3290|3293) 41 .v|3290|3293 .i|3290|3293 .x|3290|3293) (.check! (vector? .v|3290|3293) 41 .v|3290|3293 .i|3290|3293 .x|3290|3293) (.check! (<:fix:fix .i|3290|3293 (vector-length:vec .v|3290|3293)) 41 .v|3290|3293 .i|3290|3293 .x|3290|3293) (.check! (>=:fix:fix .i|3290|3293 0) 41 .v|3290|3293 .i|3290|3293 .x|3290|3293) (vector-set!:trusted .v|3290|3293 .i|3290|3293 .x|3290|3293))) (let ((.v|3294|3297 .v|3097|3131|3230) (.i|3294|3297 15) (.x|3294|3297 .t|3097|3113|3182)) (begin (.check! (fixnum? .i|3294|3297) 41 .v|3294|3297 .i|3294|3297 .x|3294|3297) (.check! (vector? .v|3294|3297) 41 .v|3294|3297 .i|3294|3297 .x|3294|3297) (.check! (<:fix:fix .i|3294|3297 (vector-length:vec .v|3294|3297)) 41 .v|3294|3297 .i|3294|3297 .x|3294|3297) (.check! (>=:fix:fix .i|3294|3297 0) 41 .v|3294|3297 .i|3294|3297 .x|3294|3297) (vector-set!:trusted .v|3294|3297 .i|3294|3297 .x|3294|3297))) (let ((.v|3298|3301 .v|3097|3131|3230) (.i|3298|3301 14) (.x|3298|3301 .t|3097|3112|3185)) (begin (.check! (fixnum? .i|3298|3301) 41 .v|3298|3301 .i|3298|3301 .x|3298|3301) (.check! (vector? .v|3298|3301) 41 .v|3298|3301 .i|3298|3301 .x|3298|3301) (.check! (<:fix:fix .i|3298|3301 (vector-length:vec .v|3298|3301)) 41 .v|3298|3301 .i|3298|3301 .x|3298|3301) (.check! (>=:fix:fix .i|3298|3301 0) 41 .v|3298|3301 .i|3298|3301 .x|3298|3301) (vector-set!:trusted .v|3298|3301 .i|3298|3301 .x|3298|3301))) (let ((.v|3302|3305 .v|3097|3131|3230) (.i|3302|3305 13) (.x|3302|3305 .t|3097|3111|3188)) (begin (.check! (fixnum? .i|3302|3305) 41 .v|3302|3305 .i|3302|3305 .x|3302|3305) (.check! (vector? .v|3302|3305) 41 .v|3302|3305 .i|3302|3305 .x|3302|3305) (.check! (<:fix:fix .i|3302|3305 (vector-length:vec .v|3302|3305)) 41 .v|3302|3305 .i|3302|3305 .x|3302|3305) (.check! (>=:fix:fix .i|3302|3305 0) 41 .v|3302|3305 .i|3302|3305 .x|3302|3305) (vector-set!:trusted .v|3302|3305 .i|3302|3305 .x|3302|3305))) (let ((.v|3306|3309 .v|3097|3131|3230) (.i|3306|3309 12) (.x|3306|3309 .t|3097|3110|3191)) (begin (.check! (fixnum? .i|3306|3309) 41 .v|3306|3309 .i|3306|3309 .x|3306|3309) (.check! (vector? .v|3306|3309) 41 .v|3306|3309 .i|3306|3309 .x|3306|3309) (.check! (<:fix:fix .i|3306|3309 (vector-length:vec .v|3306|3309)) 41 .v|3306|3309 .i|3306|3309 .x|3306|3309) (.check! (>=:fix:fix .i|3306|3309 0) 41 .v|3306|3309 .i|3306|3309 .x|3306|3309) (vector-set!:trusted .v|3306|3309 .i|3306|3309 .x|3306|3309))) (let ((.v|3310|3313 .v|3097|3131|3230) (.i|3310|3313 11) (.x|3310|3313 .t|3097|3109|3194)) (begin (.check! (fixnum? .i|3310|3313) 41 .v|3310|3313 .i|3310|3313 .x|3310|3313) (.check! (vector? .v|3310|3313) 41 .v|3310|3313 .i|3310|3313 .x|3310|3313) (.check! (<:fix:fix .i|3310|3313 (vector-length:vec .v|3310|3313)) 41 .v|3310|3313 .i|3310|3313 .x|3310|3313) (.check! (>=:fix:fix .i|3310|3313 0) 41 .v|3310|3313 .i|3310|3313 .x|3310|3313) (vector-set!:trusted .v|3310|3313 .i|3310|3313 .x|3310|3313))) (let ((.v|3314|3317 .v|3097|3131|3230) (.i|3314|3317 10) (.x|3314|3317 .t|3097|3108|3197)) (begin (.check! (fixnum? .i|3314|3317) 41 .v|3314|3317 .i|3314|3317 .x|3314|3317) (.check! (vector? .v|3314|3317) 41 .v|3314|3317 .i|3314|3317 .x|3314|3317) (.check! (<:fix:fix .i|3314|3317 (vector-length:vec .v|3314|3317)) 41 .v|3314|3317 .i|3314|3317 .x|3314|3317) (.check! (>=:fix:fix .i|3314|3317 0) 41 .v|3314|3317 .i|3314|3317 .x|3314|3317) (vector-set!:trusted .v|3314|3317 .i|3314|3317 .x|3314|3317))) (let ((.v|3318|3321 .v|3097|3131|3230) (.i|3318|3321 9) (.x|3318|3321 .t|3097|3107|3200)) (begin (.check! (fixnum? .i|3318|3321) 41 .v|3318|3321 .i|3318|3321 .x|3318|3321) (.check! (vector? .v|3318|3321) 41 .v|3318|3321 .i|3318|3321 .x|3318|3321) (.check! (<:fix:fix .i|3318|3321 (vector-length:vec .v|3318|3321)) 41 .v|3318|3321 .i|3318|3321 .x|3318|3321) (.check! (>=:fix:fix .i|3318|3321 0) 41 .v|3318|3321 .i|3318|3321 .x|3318|3321) (vector-set!:trusted .v|3318|3321 .i|3318|3321 .x|3318|3321))) (let ((.v|3322|3325 .v|3097|3131|3230) (.i|3322|3325 8) (.x|3322|3325 .t|3097|3106|3203)) (begin (.check! (fixnum? .i|3322|3325) 41 .v|3322|3325 .i|3322|3325 .x|3322|3325) (.check! (vector? .v|3322|3325) 41 .v|3322|3325 .i|3322|3325 .x|3322|3325) (.check! (<:fix:fix .i|3322|3325 (vector-length:vec .v|3322|3325)) 41 .v|3322|3325 .i|3322|3325 .x|3322|3325) (.check! (>=:fix:fix .i|3322|3325 0) 41 .v|3322|3325 .i|3322|3325 .x|3322|3325) (vector-set!:trusted .v|3322|3325 .i|3322|3325 .x|3322|3325))) (let ((.v|3326|3329 .v|3097|3131|3230) (.i|3326|3329 7) (.x|3326|3329 .t|3097|3105|3206)) (begin (.check! (fixnum? .i|3326|3329) 41 .v|3326|3329 .i|3326|3329 .x|3326|3329) (.check! (vector? .v|3326|3329) 41 .v|3326|3329 .i|3326|3329 .x|3326|3329) (.check! (<:fix:fix .i|3326|3329 (vector-length:vec .v|3326|3329)) 41 .v|3326|3329 .i|3326|3329 .x|3326|3329) (.check! (>=:fix:fix .i|3326|3329 0) 41 .v|3326|3329 .i|3326|3329 .x|3326|3329) (vector-set!:trusted .v|3326|3329 .i|3326|3329 .x|3326|3329))) (let ((.v|3330|3333 .v|3097|3131|3230) (.i|3330|3333 6) (.x|3330|3333 .t|3097|3104|3209)) (begin (.check! (fixnum? .i|3330|3333) 41 .v|3330|3333 .i|3330|3333 .x|3330|3333) (.check! (vector? .v|3330|3333) 41 .v|3330|3333 .i|3330|3333 .x|3330|3333) (.check! (<:fix:fix .i|3330|3333 (vector-length:vec .v|3330|3333)) 41 .v|3330|3333 .i|3330|3333 .x|3330|3333) (.check! (>=:fix:fix .i|3330|3333 0) 41 .v|3330|3333 .i|3330|3333 .x|3330|3333) (vector-set!:trusted .v|3330|3333 .i|3330|3333 .x|3330|3333))) (let ((.v|3334|3337 .v|3097|3131|3230) (.i|3334|3337 5) (.x|3334|3337 .t|3097|3103|3212)) (begin (.check! (fixnum? .i|3334|3337) 41 .v|3334|3337 .i|3334|3337 .x|3334|3337) (.check! (vector? .v|3334|3337) 41 .v|3334|3337 .i|3334|3337 .x|3334|3337) (.check! (<:fix:fix .i|3334|3337 (vector-length:vec .v|3334|3337)) 41 .v|3334|3337 .i|3334|3337 .x|3334|3337) (.check! (>=:fix:fix .i|3334|3337 0) 41 .v|3334|3337 .i|3334|3337 .x|3334|3337) (vector-set!:trusted .v|3334|3337 .i|3334|3337 .x|3334|3337))) (let ((.v|3338|3341 .v|3097|3131|3230) (.i|3338|3341 4) (.x|3338|3341 .t|3097|3102|3215)) (begin (.check! (fixnum? .i|3338|3341) 41 .v|3338|3341 .i|3338|3341 .x|3338|3341) (.check! (vector? .v|3338|3341) 41 .v|3338|3341 .i|3338|3341 .x|3338|3341) (.check! (<:fix:fix .i|3338|3341 (vector-length:vec .v|3338|3341)) 41 .v|3338|3341 .i|3338|3341 .x|3338|3341) (.check! (>=:fix:fix .i|3338|3341 0) 41 .v|3338|3341 .i|3338|3341 .x|3338|3341) (vector-set!:trusted .v|3338|3341 .i|3338|3341 .x|3338|3341))) (let ((.v|3342|3345 .v|3097|3131|3230) (.i|3342|3345 3) (.x|3342|3345 .t|3097|3101|3218)) (begin (.check! (fixnum? .i|3342|3345) 41 .v|3342|3345 .i|3342|3345 .x|3342|3345) (.check! (vector? .v|3342|3345) 41 .v|3342|3345 .i|3342|3345 .x|3342|3345) (.check! (<:fix:fix .i|3342|3345 (vector-length:vec .v|3342|3345)) 41 .v|3342|3345 .i|3342|3345 .x|3342|3345) (.check! (>=:fix:fix .i|3342|3345 0) 41 .v|3342|3345 .i|3342|3345 .x|3342|3345) (vector-set!:trusted .v|3342|3345 .i|3342|3345 .x|3342|3345))) (let ((.v|3346|3349 .v|3097|3131|3230) (.i|3346|3349 2) (.x|3346|3349 .t|3097|3100|3221)) (begin (.check! (fixnum? .i|3346|3349) 41 .v|3346|3349 .i|3346|3349 .x|3346|3349) (.check! (vector? .v|3346|3349) 41 .v|3346|3349 .i|3346|3349 .x|3346|3349) (.check! (<:fix:fix .i|3346|3349 (vector-length:vec .v|3346|3349)) 41 .v|3346|3349 .i|3346|3349 .x|3346|3349) (.check! (>=:fix:fix .i|3346|3349 0) 41 .v|3346|3349 .i|3346|3349 .x|3346|3349) (vector-set!:trusted .v|3346|3349 .i|3346|3349 .x|3346|3349))) (let ((.v|3350|3353 .v|3097|3131|3230) (.i|3350|3353 1) (.x|3350|3353 .t|3097|3099|3224)) (begin (.check! (fixnum? .i|3350|3353) 41 .v|3350|3353 .i|3350|3353 .x|3350|3353) (.check! (vector? .v|3350|3353) 41 .v|3350|3353 .i|3350|3353 .x|3350|3353) (.check! (<:fix:fix .i|3350|3353 (vector-length:vec .v|3350|3353)) 41 .v|3350|3353 .i|3350|3353 .x|3350|3353) (.check! (>=:fix:fix .i|3350|3353 0) 41 .v|3350|3353 .i|3350|3353 .x|3350|3353) (vector-set!:trusted .v|3350|3353 .i|3350|3353 .x|3350|3353))) (let ((.v|3354|3357 .v|3097|3131|3230) (.i|3354|3357 0) (.x|3354|3357 .t|3097|3098|3227)) (begin (.check! (fixnum? .i|3354|3357) 41 .v|3354|3357 .i|3354|3357 .x|3354|3357) (.check! (vector? .v|3354|3357) 41 .v|3354|3357 .i|3354|3357 .x|3354|3357) (.check! (<:fix:fix .i|3354|3357 (vector-length:vec .v|3354|3357)) 41 .v|3354|3357 .i|3354|3357 .x|3354|3357) (.check! (>=:fix:fix .i|3354|3357 0) 41 .v|3354|3357 .i|3354|3357 .x|3354|3357) (vector-set!:trusted .v|3354|3357 .i|3354|3357 .x|3354|3357))) .v|3097|3131|3230)))) (.fb-table|2988 (let* ((.t|3358|3390|3395 (mnemonic 'fbo 'a 'b)) (.t|3358|3389|3398 (mnemonic 'fbule 'a 'b)) (.t|3358|3388|3401 (mnemonic 'fble 'a 'b)) (.t|3358|3387|3404 (mnemonic 'fbuge 'a 'b)) (.t|3358|3386|3407 (mnemonic 'fbge 'a 'b)) (.t|3358|3385|3410 (mnemonic 'fbue 'a 'b)) (.t|3358|3384|3413 (mnemonic 'fbe 'a 'b)) (.t|3358|3383|3416 (mnemonic 'fba 'a 'b)) (.t|3358|3382|3419 (mnemonic 'fbu 'a 'b)) (.t|3358|3381|3422 (mnemonic 'fbg 'a 'b)) (.t|3358|3380|3425 (mnemonic 'fbug 'a 'b)) (.t|3358|3379|3428 (mnemonic 'fbl 'a 'b)) (.t|3358|3378|3431 (mnemonic 'fbul 'a 'b)) (.t|3358|3377|3434 (mnemonic 'fblg 'a 'b)) (.t|3358|3376|3437 (mnemonic 'fbne 'a 'b)) (.t|3358|3375|3440 (mnemonic 'fbn 'a 'b)) (.t|3358|3374|3443 (mnemonic 'fbo 'b)) (.t|3358|3373|3446 (mnemonic 'fbule 'b)) (.t|3358|3372|3449 (mnemonic 'fble 'b)) (.t|3358|3371|3452 (mnemonic 'fbuge 'b)) (.t|3358|3370|3455 (mnemonic 'fbge 'b)) (.t|3358|3369|3458 (mnemonic 'fbue 'b)) (.t|3358|3368|3461 (mnemonic 'fbe 'b)) (.t|3358|3367|3464 (mnemonic 'fba 'b)) (.t|3358|3366|3467 (mnemonic 'fbu 'b)) (.t|3358|3365|3470 (mnemonic 'fbg 'b)) (.t|3358|3364|3473 (mnemonic 'fbug 'b)) (.t|3358|3363|3476 (mnemonic 'fbl 'b)) (.t|3358|3362|3479 (mnemonic 'fbul 'b)) (.t|3358|3361|3482 (mnemonic 'fblg 'b)) (.t|3358|3360|3485 (mnemonic 'fbne 'b)) (.t|3358|3359|3488 (mnemonic 'fbn 'b)) (.v|3358|3392|3491 (make-vector 32 .t|3358|3390|3395))) (let () (begin (let ((.v|3495|3498 .v|3358|3392|3491) (.i|3495|3498 30) (.x|3495|3498 .t|3358|3389|3398)) (begin (.check! (fixnum? .i|3495|3498) 41 .v|3495|3498 .i|3495|3498 .x|3495|3498) (.check! (vector? .v|3495|3498) 41 .v|3495|3498 .i|3495|3498 .x|3495|3498) (.check! (<:fix:fix .i|3495|3498 (vector-length:vec .v|3495|3498)) 41 .v|3495|3498 .i|3495|3498 .x|3495|3498) (.check! (>=:fix:fix .i|3495|3498 0) 41 .v|3495|3498 .i|3495|3498 .x|3495|3498) (vector-set!:trusted .v|3495|3498 .i|3495|3498 .x|3495|3498))) (let ((.v|3499|3502 .v|3358|3392|3491) (.i|3499|3502 29) (.x|3499|3502 .t|3358|3388|3401)) (begin (.check! (fixnum? .i|3499|3502) 41 .v|3499|3502 .i|3499|3502 .x|3499|3502) (.check! (vector? .v|3499|3502) 41 .v|3499|3502 .i|3499|3502 .x|3499|3502) (.check! (<:fix:fix .i|3499|3502 (vector-length:vec .v|3499|3502)) 41 .v|3499|3502 .i|3499|3502 .x|3499|3502) (.check! (>=:fix:fix .i|3499|3502 0) 41 .v|3499|3502 .i|3499|3502 .x|3499|3502) (vector-set!:trusted .v|3499|3502 .i|3499|3502 .x|3499|3502))) (let ((.v|3503|3506 .v|3358|3392|3491) (.i|3503|3506 28) (.x|3503|3506 .t|3358|3387|3404)) (begin (.check! (fixnum? .i|3503|3506) 41 .v|3503|3506 .i|3503|3506 .x|3503|3506) (.check! (vector? .v|3503|3506) 41 .v|3503|3506 .i|3503|3506 .x|3503|3506) (.check! (<:fix:fix .i|3503|3506 (vector-length:vec .v|3503|3506)) 41 .v|3503|3506 .i|3503|3506 .x|3503|3506) (.check! (>=:fix:fix .i|3503|3506 0) 41 .v|3503|3506 .i|3503|3506 .x|3503|3506) (vector-set!:trusted .v|3503|3506 .i|3503|3506 .x|3503|3506))) (let ((.v|3507|3510 .v|3358|3392|3491) (.i|3507|3510 27) (.x|3507|3510 .t|3358|3386|3407)) (begin (.check! (fixnum? .i|3507|3510) 41 .v|3507|3510 .i|3507|3510 .x|3507|3510) (.check! (vector? .v|3507|3510) 41 .v|3507|3510 .i|3507|3510 .x|3507|3510) (.check! (<:fix:fix .i|3507|3510 (vector-length:vec .v|3507|3510)) 41 .v|3507|3510 .i|3507|3510 .x|3507|3510) (.check! (>=:fix:fix .i|3507|3510 0) 41 .v|3507|3510 .i|3507|3510 .x|3507|3510) (vector-set!:trusted .v|3507|3510 .i|3507|3510 .x|3507|3510))) (let ((.v|3511|3514 .v|3358|3392|3491) (.i|3511|3514 26) (.x|3511|3514 .t|3358|3385|3410)) (begin (.check! (fixnum? .i|3511|3514) 41 .v|3511|3514 .i|3511|3514 .x|3511|3514) (.check! (vector? .v|3511|3514) 41 .v|3511|3514 .i|3511|3514 .x|3511|3514) (.check! (<:fix:fix .i|3511|3514 (vector-length:vec .v|3511|3514)) 41 .v|3511|3514 .i|3511|3514 .x|3511|3514) (.check! (>=:fix:fix .i|3511|3514 0) 41 .v|3511|3514 .i|3511|3514 .x|3511|3514) (vector-set!:trusted .v|3511|3514 .i|3511|3514 .x|3511|3514))) (let ((.v|3515|3518 .v|3358|3392|3491) (.i|3515|3518 25) (.x|3515|3518 .t|3358|3384|3413)) (begin (.check! (fixnum? .i|3515|3518) 41 .v|3515|3518 .i|3515|3518 .x|3515|3518) (.check! (vector? .v|3515|3518) 41 .v|3515|3518 .i|3515|3518 .x|3515|3518) (.check! (<:fix:fix .i|3515|3518 (vector-length:vec .v|3515|3518)) 41 .v|3515|3518 .i|3515|3518 .x|3515|3518) (.check! (>=:fix:fix .i|3515|3518 0) 41 .v|3515|3518 .i|3515|3518 .x|3515|3518) (vector-set!:trusted .v|3515|3518 .i|3515|3518 .x|3515|3518))) (let ((.v|3519|3522 .v|3358|3392|3491) (.i|3519|3522 24) (.x|3519|3522 .t|3358|3383|3416)) (begin (.check! (fixnum? .i|3519|3522) 41 .v|3519|3522 .i|3519|3522 .x|3519|3522) (.check! (vector? .v|3519|3522) 41 .v|3519|3522 .i|3519|3522 .x|3519|3522) (.check! (<:fix:fix .i|3519|3522 (vector-length:vec .v|3519|3522)) 41 .v|3519|3522 .i|3519|3522 .x|3519|3522) (.check! (>=:fix:fix .i|3519|3522 0) 41 .v|3519|3522 .i|3519|3522 .x|3519|3522) (vector-set!:trusted .v|3519|3522 .i|3519|3522 .x|3519|3522))) (let ((.v|3523|3526 .v|3358|3392|3491) (.i|3523|3526 23) (.x|3523|3526 .t|3358|3382|3419)) (begin (.check! (fixnum? .i|3523|3526) 41 .v|3523|3526 .i|3523|3526 .x|3523|3526) (.check! (vector? .v|3523|3526) 41 .v|3523|3526 .i|3523|3526 .x|3523|3526) (.check! (<:fix:fix .i|3523|3526 (vector-length:vec .v|3523|3526)) 41 .v|3523|3526 .i|3523|3526 .x|3523|3526) (.check! (>=:fix:fix .i|3523|3526 0) 41 .v|3523|3526 .i|3523|3526 .x|3523|3526) (vector-set!:trusted .v|3523|3526 .i|3523|3526 .x|3523|3526))) (let ((.v|3527|3530 .v|3358|3392|3491) (.i|3527|3530 22) (.x|3527|3530 .t|3358|3381|3422)) (begin (.check! (fixnum? .i|3527|3530) 41 .v|3527|3530 .i|3527|3530 .x|3527|3530) (.check! (vector? .v|3527|3530) 41 .v|3527|3530 .i|3527|3530 .x|3527|3530) (.check! (<:fix:fix .i|3527|3530 (vector-length:vec .v|3527|3530)) 41 .v|3527|3530 .i|3527|3530 .x|3527|3530) (.check! (>=:fix:fix .i|3527|3530 0) 41 .v|3527|3530 .i|3527|3530 .x|3527|3530) (vector-set!:trusted .v|3527|3530 .i|3527|3530 .x|3527|3530))) (let ((.v|3531|3534 .v|3358|3392|3491) (.i|3531|3534 21) (.x|3531|3534 .t|3358|3380|3425)) (begin (.check! (fixnum? .i|3531|3534) 41 .v|3531|3534 .i|3531|3534 .x|3531|3534) (.check! (vector? .v|3531|3534) 41 .v|3531|3534 .i|3531|3534 .x|3531|3534) (.check! (<:fix:fix .i|3531|3534 (vector-length:vec .v|3531|3534)) 41 .v|3531|3534 .i|3531|3534 .x|3531|3534) (.check! (>=:fix:fix .i|3531|3534 0) 41 .v|3531|3534 .i|3531|3534 .x|3531|3534) (vector-set!:trusted .v|3531|3534 .i|3531|3534 .x|3531|3534))) (let ((.v|3535|3538 .v|3358|3392|3491) (.i|3535|3538 20) (.x|3535|3538 .t|3358|3379|3428)) (begin (.check! (fixnum? .i|3535|3538) 41 .v|3535|3538 .i|3535|3538 .x|3535|3538) (.check! (vector? .v|3535|3538) 41 .v|3535|3538 .i|3535|3538 .x|3535|3538) (.check! (<:fix:fix .i|3535|3538 (vector-length:vec .v|3535|3538)) 41 .v|3535|3538 .i|3535|3538 .x|3535|3538) (.check! (>=:fix:fix .i|3535|3538 0) 41 .v|3535|3538 .i|3535|3538 .x|3535|3538) (vector-set!:trusted .v|3535|3538 .i|3535|3538 .x|3535|3538))) (let ((.v|3539|3542 .v|3358|3392|3491) (.i|3539|3542 19) (.x|3539|3542 .t|3358|3378|3431)) (begin (.check! (fixnum? .i|3539|3542) 41 .v|3539|3542 .i|3539|3542 .x|3539|3542) (.check! (vector? .v|3539|3542) 41 .v|3539|3542 .i|3539|3542 .x|3539|3542) (.check! (<:fix:fix .i|3539|3542 (vector-length:vec .v|3539|3542)) 41 .v|3539|3542 .i|3539|3542 .x|3539|3542) (.check! (>=:fix:fix .i|3539|3542 0) 41 .v|3539|3542 .i|3539|3542 .x|3539|3542) (vector-set!:trusted .v|3539|3542 .i|3539|3542 .x|3539|3542))) (let ((.v|3543|3546 .v|3358|3392|3491) (.i|3543|3546 18) (.x|3543|3546 .t|3358|3377|3434)) (begin (.check! (fixnum? .i|3543|3546) 41 .v|3543|3546 .i|3543|3546 .x|3543|3546) (.check! (vector? .v|3543|3546) 41 .v|3543|3546 .i|3543|3546 .x|3543|3546) (.check! (<:fix:fix .i|3543|3546 (vector-length:vec .v|3543|3546)) 41 .v|3543|3546 .i|3543|3546 .x|3543|3546) (.check! (>=:fix:fix .i|3543|3546 0) 41 .v|3543|3546 .i|3543|3546 .x|3543|3546) (vector-set!:trusted .v|3543|3546 .i|3543|3546 .x|3543|3546))) (let ((.v|3547|3550 .v|3358|3392|3491) (.i|3547|3550 17) (.x|3547|3550 .t|3358|3376|3437)) (begin (.check! (fixnum? .i|3547|3550) 41 .v|3547|3550 .i|3547|3550 .x|3547|3550) (.check! (vector? .v|3547|3550) 41 .v|3547|3550 .i|3547|3550 .x|3547|3550) (.check! (<:fix:fix .i|3547|3550 (vector-length:vec .v|3547|3550)) 41 .v|3547|3550 .i|3547|3550 .x|3547|3550) (.check! (>=:fix:fix .i|3547|3550 0) 41 .v|3547|3550 .i|3547|3550 .x|3547|3550) (vector-set!:trusted .v|3547|3550 .i|3547|3550 .x|3547|3550))) (let ((.v|3551|3554 .v|3358|3392|3491) (.i|3551|3554 16) (.x|3551|3554 .t|3358|3375|3440)) (begin (.check! (fixnum? .i|3551|3554) 41 .v|3551|3554 .i|3551|3554 .x|3551|3554) (.check! (vector? .v|3551|3554) 41 .v|3551|3554 .i|3551|3554 .x|3551|3554) (.check! (<:fix:fix .i|3551|3554 (vector-length:vec .v|3551|3554)) 41 .v|3551|3554 .i|3551|3554 .x|3551|3554) (.check! (>=:fix:fix .i|3551|3554 0) 41 .v|3551|3554 .i|3551|3554 .x|3551|3554) (vector-set!:trusted .v|3551|3554 .i|3551|3554 .x|3551|3554))) (let ((.v|3555|3558 .v|3358|3392|3491) (.i|3555|3558 15) (.x|3555|3558 .t|3358|3374|3443)) (begin (.check! (fixnum? .i|3555|3558) 41 .v|3555|3558 .i|3555|3558 .x|3555|3558) (.check! (vector? .v|3555|3558) 41 .v|3555|3558 .i|3555|3558 .x|3555|3558) (.check! (<:fix:fix .i|3555|3558 (vector-length:vec .v|3555|3558)) 41 .v|3555|3558 .i|3555|3558 .x|3555|3558) (.check! (>=:fix:fix .i|3555|3558 0) 41 .v|3555|3558 .i|3555|3558 .x|3555|3558) (vector-set!:trusted .v|3555|3558 .i|3555|3558 .x|3555|3558))) (let ((.v|3559|3562 .v|3358|3392|3491) (.i|3559|3562 14) (.x|3559|3562 .t|3358|3373|3446)) (begin (.check! (fixnum? .i|3559|3562) 41 .v|3559|3562 .i|3559|3562 .x|3559|3562) (.check! (vector? .v|3559|3562) 41 .v|3559|3562 .i|3559|3562 .x|3559|3562) (.check! (<:fix:fix .i|3559|3562 (vector-length:vec .v|3559|3562)) 41 .v|3559|3562 .i|3559|3562 .x|3559|3562) (.check! (>=:fix:fix .i|3559|3562 0) 41 .v|3559|3562 .i|3559|3562 .x|3559|3562) (vector-set!:trusted .v|3559|3562 .i|3559|3562 .x|3559|3562))) (let ((.v|3563|3566 .v|3358|3392|3491) (.i|3563|3566 13) (.x|3563|3566 .t|3358|3372|3449)) (begin (.check! (fixnum? .i|3563|3566) 41 .v|3563|3566 .i|3563|3566 .x|3563|3566) (.check! (vector? .v|3563|3566) 41 .v|3563|3566 .i|3563|3566 .x|3563|3566) (.check! (<:fix:fix .i|3563|3566 (vector-length:vec .v|3563|3566)) 41 .v|3563|3566 .i|3563|3566 .x|3563|3566) (.check! (>=:fix:fix .i|3563|3566 0) 41 .v|3563|3566 .i|3563|3566 .x|3563|3566) (vector-set!:trusted .v|3563|3566 .i|3563|3566 .x|3563|3566))) (let ((.v|3567|3570 .v|3358|3392|3491) (.i|3567|3570 12) (.x|3567|3570 .t|3358|3371|3452)) (begin (.check! (fixnum? .i|3567|3570) 41 .v|3567|3570 .i|3567|3570 .x|3567|3570) (.check! (vector? .v|3567|3570) 41 .v|3567|3570 .i|3567|3570 .x|3567|3570) (.check! (<:fix:fix .i|3567|3570 (vector-length:vec .v|3567|3570)) 41 .v|3567|3570 .i|3567|3570 .x|3567|3570) (.check! (>=:fix:fix .i|3567|3570 0) 41 .v|3567|3570 .i|3567|3570 .x|3567|3570) (vector-set!:trusted .v|3567|3570 .i|3567|3570 .x|3567|3570))) (let ((.v|3571|3574 .v|3358|3392|3491) (.i|3571|3574 11) (.x|3571|3574 .t|3358|3370|3455)) (begin (.check! (fixnum? .i|3571|3574) 41 .v|3571|3574 .i|3571|3574 .x|3571|3574) (.check! (vector? .v|3571|3574) 41 .v|3571|3574 .i|3571|3574 .x|3571|3574) (.check! (<:fix:fix .i|3571|3574 (vector-length:vec .v|3571|3574)) 41 .v|3571|3574 .i|3571|3574 .x|3571|3574) (.check! (>=:fix:fix .i|3571|3574 0) 41 .v|3571|3574 .i|3571|3574 .x|3571|3574) (vector-set!:trusted .v|3571|3574 .i|3571|3574 .x|3571|3574))) (let ((.v|3575|3578 .v|3358|3392|3491) (.i|3575|3578 10) (.x|3575|3578 .t|3358|3369|3458)) (begin (.check! (fixnum? .i|3575|3578) 41 .v|3575|3578 .i|3575|3578 .x|3575|3578) (.check! (vector? .v|3575|3578) 41 .v|3575|3578 .i|3575|3578 .x|3575|3578) (.check! (<:fix:fix .i|3575|3578 (vector-length:vec .v|3575|3578)) 41 .v|3575|3578 .i|3575|3578 .x|3575|3578) (.check! (>=:fix:fix .i|3575|3578 0) 41 .v|3575|3578 .i|3575|3578 .x|3575|3578) (vector-set!:trusted .v|3575|3578 .i|3575|3578 .x|3575|3578))) (let ((.v|3579|3582 .v|3358|3392|3491) (.i|3579|3582 9) (.x|3579|3582 .t|3358|3368|3461)) (begin (.check! (fixnum? .i|3579|3582) 41 .v|3579|3582 .i|3579|3582 .x|3579|3582) (.check! (vector? .v|3579|3582) 41 .v|3579|3582 .i|3579|3582 .x|3579|3582) (.check! (<:fix:fix .i|3579|3582 (vector-length:vec .v|3579|3582)) 41 .v|3579|3582 .i|3579|3582 .x|3579|3582) (.check! (>=:fix:fix .i|3579|3582 0) 41 .v|3579|3582 .i|3579|3582 .x|3579|3582) (vector-set!:trusted .v|3579|3582 .i|3579|3582 .x|3579|3582))) (let ((.v|3583|3586 .v|3358|3392|3491) (.i|3583|3586 8) (.x|3583|3586 .t|3358|3367|3464)) (begin (.check! (fixnum? .i|3583|3586) 41 .v|3583|3586 .i|3583|3586 .x|3583|3586) (.check! (vector? .v|3583|3586) 41 .v|3583|3586 .i|3583|3586 .x|3583|3586) (.check! (<:fix:fix .i|3583|3586 (vector-length:vec .v|3583|3586)) 41 .v|3583|3586 .i|3583|3586 .x|3583|3586) (.check! (>=:fix:fix .i|3583|3586 0) 41 .v|3583|3586 .i|3583|3586 .x|3583|3586) (vector-set!:trusted .v|3583|3586 .i|3583|3586 .x|3583|3586))) (let ((.v|3587|3590 .v|3358|3392|3491) (.i|3587|3590 7) (.x|3587|3590 .t|3358|3366|3467)) (begin (.check! (fixnum? .i|3587|3590) 41 .v|3587|3590 .i|3587|3590 .x|3587|3590) (.check! (vector? .v|3587|3590) 41 .v|3587|3590 .i|3587|3590 .x|3587|3590) (.check! (<:fix:fix .i|3587|3590 (vector-length:vec .v|3587|3590)) 41 .v|3587|3590 .i|3587|3590 .x|3587|3590) (.check! (>=:fix:fix .i|3587|3590 0) 41 .v|3587|3590 .i|3587|3590 .x|3587|3590) (vector-set!:trusted .v|3587|3590 .i|3587|3590 .x|3587|3590))) (let ((.v|3591|3594 .v|3358|3392|3491) (.i|3591|3594 6) (.x|3591|3594 .t|3358|3365|3470)) (begin (.check! (fixnum? .i|3591|3594) 41 .v|3591|3594 .i|3591|3594 .x|3591|3594) (.check! (vector? .v|3591|3594) 41 .v|3591|3594 .i|3591|3594 .x|3591|3594) (.check! (<:fix:fix .i|3591|3594 (vector-length:vec .v|3591|3594)) 41 .v|3591|3594 .i|3591|3594 .x|3591|3594) (.check! (>=:fix:fix .i|3591|3594 0) 41 .v|3591|3594 .i|3591|3594 .x|3591|3594) (vector-set!:trusted .v|3591|3594 .i|3591|3594 .x|3591|3594))) (let ((.v|3595|3598 .v|3358|3392|3491) (.i|3595|3598 5) (.x|3595|3598 .t|3358|3364|3473)) (begin (.check! (fixnum? .i|3595|3598) 41 .v|3595|3598 .i|3595|3598 .x|3595|3598) (.check! (vector? .v|3595|3598) 41 .v|3595|3598 .i|3595|3598 .x|3595|3598) (.check! (<:fix:fix .i|3595|3598 (vector-length:vec .v|3595|3598)) 41 .v|3595|3598 .i|3595|3598 .x|3595|3598) (.check! (>=:fix:fix .i|3595|3598 0) 41 .v|3595|3598 .i|3595|3598 .x|3595|3598) (vector-set!:trusted .v|3595|3598 .i|3595|3598 .x|3595|3598))) (let ((.v|3599|3602 .v|3358|3392|3491) (.i|3599|3602 4) (.x|3599|3602 .t|3358|3363|3476)) (begin (.check! (fixnum? .i|3599|3602) 41 .v|3599|3602 .i|3599|3602 .x|3599|3602) (.check! (vector? .v|3599|3602) 41 .v|3599|3602 .i|3599|3602 .x|3599|3602) (.check! (<:fix:fix .i|3599|3602 (vector-length:vec .v|3599|3602)) 41 .v|3599|3602 .i|3599|3602 .x|3599|3602) (.check! (>=:fix:fix .i|3599|3602 0) 41 .v|3599|3602 .i|3599|3602 .x|3599|3602) (vector-set!:trusted .v|3599|3602 .i|3599|3602 .x|3599|3602))) (let ((.v|3603|3606 .v|3358|3392|3491) (.i|3603|3606 3) (.x|3603|3606 .t|3358|3362|3479)) (begin (.check! (fixnum? .i|3603|3606) 41 .v|3603|3606 .i|3603|3606 .x|3603|3606) (.check! (vector? .v|3603|3606) 41 .v|3603|3606 .i|3603|3606 .x|3603|3606) (.check! (<:fix:fix .i|3603|3606 (vector-length:vec .v|3603|3606)) 41 .v|3603|3606 .i|3603|3606 .x|3603|3606) (.check! (>=:fix:fix .i|3603|3606 0) 41 .v|3603|3606 .i|3603|3606 .x|3603|3606) (vector-set!:trusted .v|3603|3606 .i|3603|3606 .x|3603|3606))) (let ((.v|3607|3610 .v|3358|3392|3491) (.i|3607|3610 2) (.x|3607|3610 .t|3358|3361|3482)) (begin (.check! (fixnum? .i|3607|3610) 41 .v|3607|3610 .i|3607|3610 .x|3607|3610) (.check! (vector? .v|3607|3610) 41 .v|3607|3610 .i|3607|3610 .x|3607|3610) (.check! (<:fix:fix .i|3607|3610 (vector-length:vec .v|3607|3610)) 41 .v|3607|3610 .i|3607|3610 .x|3607|3610) (.check! (>=:fix:fix .i|3607|3610 0) 41 .v|3607|3610 .i|3607|3610 .x|3607|3610) (vector-set!:trusted .v|3607|3610 .i|3607|3610 .x|3607|3610))) (let ((.v|3611|3614 .v|3358|3392|3491) (.i|3611|3614 1) (.x|3611|3614 .t|3358|3360|3485)) (begin (.check! (fixnum? .i|3611|3614) 41 .v|3611|3614 .i|3611|3614 .x|3611|3614) (.check! (vector? .v|3611|3614) 41 .v|3611|3614 .i|3611|3614 .x|3611|3614) (.check! (<:fix:fix .i|3611|3614 (vector-length:vec .v|3611|3614)) 41 .v|3611|3614 .i|3611|3614 .x|3611|3614) (.check! (>=:fix:fix .i|3611|3614 0) 41 .v|3611|3614 .i|3611|3614 .x|3611|3614) (vector-set!:trusted .v|3611|3614 .i|3611|3614 .x|3611|3614))) (let ((.v|3615|3618 .v|3358|3392|3491) (.i|3615|3618 0) (.x|3615|3618 .t|3358|3359|3488)) (begin (.check! (fixnum? .i|3615|3618) 41 .v|3615|3618 .i|3615|3618 .x|3615|3618) (.check! (vector? .v|3615|3618) 41 .v|3615|3618 .i|3615|3618 .x|3615|3618) (.check! (<:fix:fix .i|3615|3618 (vector-length:vec .v|3615|3618)) 41 .v|3615|3618 .i|3615|3618 .x|3615|3618) (.check! (>=:fix:fix .i|3615|3618 0) 41 .v|3615|3618 .i|3615|3618 .x|3615|3618) (vector-set!:trusted .v|3615|3618 .i|3615|3618 .x|3615|3618))) .v|3358|3392|3491)))) (.nop|2988 (mnemonic 'nop)) (.sethi|2988 (mnemonic 'sethi))) (lambda (.ip|2989 .instr|2989) (let ((.op2|2992 (.op2field|4 .instr|2989))) (if (= .op2|2992 4) (if (zero? (.rdfield|4 .instr|2989)) (.cons .nop|2988 '()) (.cons .sethi|2988 (.cons (.imm22field|4 .instr|2989) (.cons (.rdfield|4 .instr|2989) '())))) (if (= .op2|2992 2) (.cons (let ((.v|3064|3067 .b-table|2988) (.i|3064|3067 (.rdfield|4 .instr|2989))) (begin (.check! (fixnum? .i|3064|3067) 40 .v|3064|3067 .i|3064|3067) (.check! (vector? .v|3064|3067) 40 .v|3064|3067 .i|3064|3067) (.check! (<:fix:fix .i|3064|3067 (vector-length:vec .v|3064|3067)) 40 .v|3064|3067 .i|3064|3067) (.check! (>=:fix:fix .i|3064|3067 0) 40 .v|3064|3067 .i|3064|3067) (vector-ref:trusted .v|3064|3067 .i|3064|3067))) (.cons (* 4 (.imm22field|4 .instr|2989)) '())) (if (= .op2|2992 6) (.cons (let ((.v|3092|3095 .fb-table|2988) (.i|3092|3095 (.rdfield|4 .instr|2989))) (begin (.check! (fixnum? .i|3092|3095) 40 .v|3092|3095 .i|3092|3095) (.check! (vector? .v|3092|3095) 40 .v|3092|3095 .i|3092|3095) (.check! (<:fix:fix .i|3092|3095 (vector-length:vec .v|3092|3095)) 40 .v|3092|3095 .i|3092|3095) (.check! (>=:fix:fix .i|3092|3095 0) 40 .v|3092|3095 .i|3092|3095) (vector-ref:trusted .v|3092|3095 .i|3092|3095))) (.cons (* 4 (.imm22field|4 .instr|2989)) '())) (disasm-error "Can't disassemble " (number->string .instr|2989 16) " at ip=" .ip|2989 " with op2=" .op2|2992)))))))) (set! .two^32|4 (expt 2 32)) (set! .two^30|4 (expt 2 30)) (set! .two^29|4 (expt 2 29)) (set! .two^25|4 (expt 2 25)) (set! .two^24|4 (expt 2 24)) (set! .two^22|4 (expt 2 22)) (set! .two^21|4 (expt 2 21)) (set! .two^19|4 (expt 2 19)) (set! .two^16|4 (expt 2 16)) (set! .two^14|4 (expt 2 14)) (set! .two^13|4 (expt 2 13)) (set! .two^12|4 (expt 2 12)) (set! .two^9|4 (expt 2 9)) (set! .two^8|4 (expt 2 8)) (set! .two^6|4 (expt 2 6)) (set! .two^5|4 (expt 2 5)) (set! .two^3|4 (expt 2 3)) (set! disassemble-instruction (let ((.class-table|3621 (let* ((.t|3627|3631|3636 .class11|4) (.t|3627|3630|3639 .class10|4) (.t|3627|3629|3642 .class01|4) (.t|3627|3628|3645 .class00|4) (.v|3627|3633|3648 (make-vector 4 .t|3627|3631|3636))) (let () (begin (let ((.v|3652|3655 .v|3627|3633|3648) (.i|3652|3655 2) (.x|3652|3655 .t|3627|3630|3639)) (begin (.check! (fixnum? .i|3652|3655) 41 .v|3652|3655 .i|3652|3655 .x|3652|3655) (.check! (vector? .v|3652|3655) 41 .v|3652|3655 .i|3652|3655 .x|3652|3655) (.check! (<:fix:fix .i|3652|3655 (vector-length:vec .v|3652|3655)) 41 .v|3652|3655 .i|3652|3655 .x|3652|3655) (.check! (>=:fix:fix .i|3652|3655 0) 41 .v|3652|3655 .i|3652|3655 .x|3652|3655) (vector-set!:trusted .v|3652|3655 .i|3652|3655 .x|3652|3655))) (let ((.v|3656|3659 .v|3627|3633|3648) (.i|3656|3659 1) (.x|3656|3659 .t|3627|3629|3642)) (begin (.check! (fixnum? .i|3656|3659) 41 .v|3656|3659 .i|3656|3659 .x|3656|3659) (.check! (vector? .v|3656|3659) 41 .v|3656|3659 .i|3656|3659 .x|3656|3659) (.check! (<:fix:fix .i|3656|3659 (vector-length:vec .v|3656|3659)) 41 .v|3656|3659 .i|3656|3659 .x|3656|3659) (.check! (>=:fix:fix .i|3656|3659 0) 41 .v|3656|3659 .i|3656|3659 .x|3656|3659) (vector-set!:trusted .v|3656|3659 .i|3656|3659 .x|3656|3659))) (let ((.v|3660|3663 .v|3627|3633|3648) (.i|3660|3663 0) (.x|3660|3663 .t|3627|3628|3645)) (begin (.check! (fixnum? .i|3660|3663) 41 .v|3660|3663 .i|3660|3663 .x|3660|3663) (.check! (vector? .v|3660|3663) 41 .v|3660|3663 .i|3660|3663 .x|3660|3663) (.check! (<:fix:fix .i|3660|3663 (vector-length:vec .v|3660|3663)) 41 .v|3660|3663 .i|3660|3663 .x|3660|3663) (.check! (>=:fix:fix .i|3660|3663 0) 41 .v|3660|3663 .i|3660|3663 .x|3660|3663) (vector-set!:trusted .v|3660|3663 .i|3660|3663 .x|3660|3663))) .v|3627|3633|3648))))) (lambda (.instr|3622 .addr|3622) ((let ((.v|3623|3626 .class-table|3621) (.i|3623|3626 (quotient .instr|3622 .two^30|4))) (begin (.check! (fixnum? .i|3623|3626) 40 .v|3623|3626 .i|3623|3626) (.check! (vector? .v|3623|3626) 40 .v|3623|3626 .i|3623|3626) (.check! (<:fix:fix .i|3623|3626 (vector-length:vec .v|3623|3626)) 40 .v|3623|3626 .i|3623|3626) (.check! (>=:fix:fix .i|3623|3626 0) 40 .v|3623|3626 .i|3623|3626) (vector-ref:trusted .v|3623|3626 .i|3623|3626))) .addr|3622 .instr|3622)))) 'disassemble-instruction))))
+(let () (begin (set! print-instructions (lambda (.ilist|1 . .rest|1) (let ((.print-ilist|4 (unspecified)) (.larceny-names?|4 (unspecified)) (.port|4 (unspecified))) (begin (set! .print-ilist|4 (lambda (.ilist|5 .a|5) (if (null? .ilist|5) '() (begin (display (format-instruction (let ((.x|6|9 .ilist|5)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .a|5 .larceny-names?|4) .port|4) (newline .port|4) (.print-ilist|4 (let ((.x|10|13 .ilist|5)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) (+ .a|5 4)))))) (set! .larceny-names?|4 #t) (set! .port|4 (current-output-port)) (let () (let ((.loop|3|15|18 (unspecified))) (begin (set! .loop|3|15|18 (lambda (.rest|19) (if (null? .rest|19) (if #f #f (unspecified)) (begin (begin #t (if (port? (let ((.x|23|26 .rest|19)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) (set! .port|4 (let ((.x|27|30 .rest|19)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30)))) (if (eq? (let ((.x|32|35 .rest|19)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) 'native-names) (set! .larceny-names?|4 #f) (unspecified)))) (.loop|3|15|18 (let ((.x|36|39 .rest|19)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39)))))))) (.loop|3|15|18 .rest|1)))) (.print-ilist|4 .ilist|1 0))))) 'print-instructions))
+(let () (begin (set! format-instruction (undefined)) 'format-instruction))
+(let () (begin (set! *format-instructions-pretty* #t) '*format-instructions-pretty*))
+(let () (let () (let ((.format-instr|4 (unspecified)) (.fpop|4 (unspecified)) (.wr|4 (unspecified)) (.rd|4 (unspecified)) (.call|4 (unspecified)) (.jmplr|4 (unspecified)) (.jmpli|4 (unspecified)) (.bimm|4 (unspecified)) (.lrr|4 (unspecified)) (.lir|4 (unspecified)) (.srr|4 (unspecified)) (.sir|4 (unspecified)) (.rir|4 (unspecified)) (.rrr|4 (unspecified)) (.sethi|4 (unspecified)) (.srcreg|4 (unspecified)) (.plus/minus|4 (unspecified)) (.millicode-call|4 (unspecified)) (.millicode-name|4 (unspecified)) (.heximm|4 (unspecified)) (.float-register-name|4 (unspecified)) (.larceny-register-name|4 (unspecified)) (.use-larceny-registers|4 (unspecified)) (.millicode-procs|4 (unspecified)) (.op|4 (unspecified)) (.op1|4 (unspecified)) (.op2|4 (unspecified)) (.op3|4 (unspecified)) (.tabstring|4 (unspecified)) (.larceny-register-table|4 (unspecified)) (.sparc-register-table|4 (unspecified))) (begin (set! .format-instr|4 (lambda (.i|5 .a|5 .larceny-names?|5) (begin (set! .use-larceny-registers|4 .larceny-names?|5) (let ((.m|8 (let ((.x|21|24 .i|5)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (string-append (number->string .a|5) .tabstring|4 (symbol->string (mnemonic:name .m|8)) (if (mnemonic:annul? .m|8) ",a" "") .tabstring|4 (if (mnemonic:store? .m|8) (if (mnemonic:immediate? .m|8) (.sir|4 .i|5) (.srr|4 .i|5)) (if (mnemonic:load? .m|8) (if (mnemonic:immediate? .m|8) (.lir|4 .i|5) (.lrr|4 .i|5)) (if (mnemonic:fpop? .m|8) (.fpop|4 .i|5 (mnemonic:op2? .m|8) (mnemonic:op3? .m|8)) (if (mnemonic:branch? .m|8) (.bimm|4 .i|5 .a|5) (if (mnemonic=? .m|8 'sethi) (.sethi|4 .i|5) (if (mnemonic=? .m|8 'nop) "" (if (mnemonic=? .m|8 'jmpl) (if (mnemonic:immediate? .m|8) (.jmpli|4 .i|5) (.jmplr|4 .i|5)) (if (mnemonic=? .m|8 'call) (.call|4 .i|5 .a|5) (if (mnemonic=? .m|8 'rd) (.rd|4 .i|5) (if (mnemonic=? .m|8 'wr) (.wr|4 .i|5 (mnemonic:immediate? .m|8)) (if (mnemonic:immediate? .m|8) (.rir|4 .i|5) (.rrr|4 .i|5))))))))))))))))) (set! .fpop|4 (lambda (.instr|25 .op2-used?|25 .op3-used?|25) (string-append (.float-register-name|4 (.op1|4 .instr|25)) ", " (if (if .op2-used?|25 .op3-used?|25 #f) (string-append (.float-register-name|4 (.op2|4 .instr|25)) ", " (.float-register-name|4 (.op3|4 .instr|25))) (if .op2-used?|25 (.float-register-name|4 (.op2|4 .instr|25)) (.float-register-name|4 (.op3|4 .instr|25))))))) (set! .wr|4 (lambda (.instr|31 .imm?|31) (if .imm?|31 (string-append (.larceny-register-name|4 (.op1|4 .instr|31)) ", " (number->string (.op2|4 .instr|31)) ", %y" (.larceny-register-name|4 (.op3|4 .instr|31))) (string-append (.larceny-register-name|4 (.op1|4 .instr|31)) ", " (.larceny-register-name|4 (.op2|4 .instr|31)) ", %y")))) (set! .rd|4 (lambda (.instr|32) (string-append "%y, " (.srcreg|4 .instr|32 .op3|4)))) (set! .call|4 (lambda (.instr|33 .addr|33) (string-append "#" (number->string (+ (.op1|4 .instr|33) .addr|33))))) (set! .jmplr|4 (lambda (.instr|34) (string-append (.larceny-register-name|4 (.op1|4 .instr|34)) "+" (.larceny-register-name|4 (.op2|4 .instr|34)) ", " (.larceny-register-name|4 (.op3|4 .instr|34))))) (set! .jmpli|4 (lambda (.instr|35) (string-append (.larceny-register-name|4 (.op1|4 .instr|35)) (.plus/minus|4 (.op2|4 .instr|35)) ", " (.larceny-register-name|4 (.op3|4 .instr|35)) (if (if (= (.op1|4 .instr|35) $r.globals) .use-larceny-registers|4 #f) (.millicode-call|4 (.op2|4 .instr|35)) (.heximm|4 (.op2|4 .instr|35)))))) (set! .bimm|4 (lambda (.instr|38 .addr|38) (string-append "#" (number->string (+ (.op1|4 .instr|38) .addr|38))))) (set! .lrr|4 (lambda (.instr|39) (string-append "[ " (.larceny-register-name|4 (.op1|4 .instr|39)) "+" (.larceny-register-name|4 (.op2|4 .instr|39)) " ], " (.srcreg|4 .instr|39 .op3|4)))) (set! .lir|4 (lambda (.instr|40) (string-append "[ " (.larceny-register-name|4 (.op1|4 .instr|40)) (.plus/minus|4 (.op2|4 .instr|40)) " ], " (.srcreg|4 .instr|40 .op3|4)))) (set! .srr|4 (lambda (.instr|41) (string-append (.srcreg|4 .instr|41 .op3|4) ", [ " (.larceny-register-name|4 (.op1|4 .instr|41)) "+" (.larceny-register-name|4 (.op2|4 .instr|41)) " ]"))) (set! .sir|4 (lambda (.instr|42) (string-append (.srcreg|4 .instr|42 .op3|4) ", [ " (.larceny-register-name|4 (.op1|4 .instr|42)) (.plus/minus|4 (.op2|4 .instr|42)) " ]"))) (set! .rir|4 (lambda (.instr|43) (string-append (.larceny-register-name|4 (.op1|4 .instr|43)) ", " (number->string (.op2|4 .instr|43)) ", " (.larceny-register-name|4 (.op3|4 .instr|43)) (.heximm|4 (.op2|4 .instr|43))))) (set! .rrr|4 (lambda (.instr|44) (string-append (.larceny-register-name|4 (.op1|4 .instr|44)) ", " (.larceny-register-name|4 (.op2|4 .instr|44)) ", " (.larceny-register-name|4 (.op3|4 .instr|44))))) (set! .sethi|4 (lambda (.instr|45) (string-append (number->string (* (.op1|4 .instr|45) 1024)) ", " (.larceny-register-name|4 (.op2|4 .instr|45)) (.heximm|4 (* (.op1|4 .instr|45) 1024))))) (set! .srcreg|4 (lambda (.instr|46 .extractor|46) (if (mnemonic:freg? (.op|4 .instr|46)) (.float-register-name|4 (.extractor|46 .instr|46)) (.larceny-register-name|4 (.extractor|46 .instr|46))))) (set! .plus/minus|4 (lambda (.n|47) (if (< .n|47 0) (string-append " - " (number->string (let ((.temp|49|52 .n|47)) (if (< .temp|49|52 0) (-- .temp|49|52) .temp|49|52)))) (if (if (= .n|47 0) *format-instructions-pretty* #f) "" (string-append " + " (number->string .n|47)))))) (set! .millicode-call|4 (lambda (.offset|57) (string-append .tabstring|4 "! " (.millicode-name|4 .offset|57)))) (set! .millicode-name|4 (lambda (.offset|58 . .rest|58) (if (null? .rest|58) (let ((.probe|61 (assv .offset|58 .millicode-procs|4))) (if .probe|61 (let ((.x|62|65 .probe|61)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) "[unknown]")) (set! .millicode-procs|4 (cons (cons .offset|58 (let ((.x|67|70 .rest|58)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70)))) .millicode-procs|4))))) (set! .heximm|4 (lambda (.n|71) (if (>= .n|71 16) (string-append .tabstring|4 "! 0x" (number->string .n|71 16)) ""))) (set! .float-register-name|4 (lambda (.reg|72) (string-append "%f" (number->string .reg|72)))) (set! .larceny-register-name|4 (lambda (.reg|73 . .rest|73) (if (null? .rest|73) (let ((.temp|74|77 (if .use-larceny-registers|4 (let ((.v|85|88 .larceny-register-table|4) (.i|85|88 .reg|73)) (begin (.check! (fixnum? .i|85|88) 40 .v|85|88 .i|85|88) (.check! (vector? .v|85|88) 40 .v|85|88 .i|85|88) (.check! (<:fix:fix .i|85|88 (vector-length:vec .v|85|88)) 40 .v|85|88 .i|85|88) (.check! (>=:fix:fix .i|85|88 0) 40 .v|85|88 .i|85|88) (vector-ref:trusted .v|85|88 .i|85|88))) #f))) (if .temp|74|77 .temp|74|77 (let ((.v|79|82 .sparc-register-table|4) (.i|79|82 .reg|73)) (begin (.check! (fixnum? .i|79|82) 40 .v|79|82 .i|79|82) (.check! (vector? .v|79|82) 40 .v|79|82 .i|79|82) (.check! (<:fix:fix .i|79|82 (vector-length:vec .v|79|82)) 40 .v|79|82 .i|79|82) (.check! (>=:fix:fix .i|79|82 0) 40 .v|79|82 .i|79|82) (vector-ref:trusted .v|79|82 .i|79|82))))) (let ((.v|89|92 .larceny-register-table|4) (.i|89|92 .reg|73) (.x|89|92 (let ((.x|93|96 .rest|73)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))))) (begin (.check! (fixnum? .i|89|92) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (vector? .v|89|92) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (<:fix:fix .i|89|92 (vector-length:vec .v|89|92)) 41 .v|89|92 .i|89|92 .x|89|92) (.check! (>=:fix:fix .i|89|92 0) 41 .v|89|92 .i|89|92 .x|89|92) (vector-set!:trusted .v|89|92 .i|89|92 .x|89|92)))))) (set! .use-larceny-registers|4 #t) (set! .millicode-procs|4 '()) (set! .op|4 car) (set! .op1|4 cadr) (set! .op2|4 caddr) (set! .op3|4 cadddr) (set! .tabstring|4 (string #\tab)) (set! .larceny-register-table|4 (make-vector 32 #f)) (set! .sparc-register-table|4 (let* ((.t|97|129|134 "%i7") (.t|97|128|137 "%i6") (.t|97|127|140 "%i5") (.t|97|126|143 "%i4") (.t|97|125|146 "%i3") (.t|97|124|149 "%i2") (.t|97|123|152 "%i1") (.t|97|122|155 "%i0") (.t|97|121|158 "%l7") (.t|97|120|161 "%l6") (.t|97|119|164 "%l5") (.t|97|118|167 "%l4") (.t|97|117|170 "%l3") (.t|97|116|173 "%l2") (.t|97|115|176 "%l1") (.t|97|114|179 "%l0") (.t|97|113|182 "%o7") (.t|97|112|185 "%o6") (.t|97|111|188 "%o5") (.t|97|110|191 "%o4") (.t|97|109|194 "%o3") (.t|97|108|197 "%o2") (.t|97|107|200 "%o1") (.t|97|106|203 "%o0") (.t|97|105|206 "%g7") (.t|97|104|209 "%g6") (.t|97|103|212 "%g5") (.t|97|102|215 "%g4") (.t|97|101|218 "%g3") (.t|97|100|221 "%g2") (.t|97|99|224 "%g1") (.t|97|98|227 "%g0") (.v|97|131|230 (make-vector 32 .t|97|129|134))) (let () (begin (let ((.v|234|237 .v|97|131|230) (.i|234|237 30) (.x|234|237 .t|97|128|137)) (begin (.check! (fixnum? .i|234|237) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (vector? .v|234|237) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (<:fix:fix .i|234|237 (vector-length:vec .v|234|237)) 41 .v|234|237 .i|234|237 .x|234|237) (.check! (>=:fix:fix .i|234|237 0) 41 .v|234|237 .i|234|237 .x|234|237) (vector-set!:trusted .v|234|237 .i|234|237 .x|234|237))) (let ((.v|238|241 .v|97|131|230) (.i|238|241 29) (.x|238|241 .t|97|127|140)) (begin (.check! (fixnum? .i|238|241) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (vector? .v|238|241) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (<:fix:fix .i|238|241 (vector-length:vec .v|238|241)) 41 .v|238|241 .i|238|241 .x|238|241) (.check! (>=:fix:fix .i|238|241 0) 41 .v|238|241 .i|238|241 .x|238|241) (vector-set!:trusted .v|238|241 .i|238|241 .x|238|241))) (let ((.v|242|245 .v|97|131|230) (.i|242|245 28) (.x|242|245 .t|97|126|143)) (begin (.check! (fixnum? .i|242|245) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (vector? .v|242|245) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (<:fix:fix .i|242|245 (vector-length:vec .v|242|245)) 41 .v|242|245 .i|242|245 .x|242|245) (.check! (>=:fix:fix .i|242|245 0) 41 .v|242|245 .i|242|245 .x|242|245) (vector-set!:trusted .v|242|245 .i|242|245 .x|242|245))) (let ((.v|246|249 .v|97|131|230) (.i|246|249 27) (.x|246|249 .t|97|125|146)) (begin (.check! (fixnum? .i|246|249) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (vector? .v|246|249) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (<:fix:fix .i|246|249 (vector-length:vec .v|246|249)) 41 .v|246|249 .i|246|249 .x|246|249) (.check! (>=:fix:fix .i|246|249 0) 41 .v|246|249 .i|246|249 .x|246|249) (vector-set!:trusted .v|246|249 .i|246|249 .x|246|249))) (let ((.v|250|253 .v|97|131|230) (.i|250|253 26) (.x|250|253 .t|97|124|149)) (begin (.check! (fixnum? .i|250|253) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (vector? .v|250|253) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (<:fix:fix .i|250|253 (vector-length:vec .v|250|253)) 41 .v|250|253 .i|250|253 .x|250|253) (.check! (>=:fix:fix .i|250|253 0) 41 .v|250|253 .i|250|253 .x|250|253) (vector-set!:trusted .v|250|253 .i|250|253 .x|250|253))) (let ((.v|254|257 .v|97|131|230) (.i|254|257 25) (.x|254|257 .t|97|123|152)) (begin (.check! (fixnum? .i|254|257) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (vector? .v|254|257) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (<:fix:fix .i|254|257 (vector-length:vec .v|254|257)) 41 .v|254|257 .i|254|257 .x|254|257) (.check! (>=:fix:fix .i|254|257 0) 41 .v|254|257 .i|254|257 .x|254|257) (vector-set!:trusted .v|254|257 .i|254|257 .x|254|257))) (let ((.v|258|261 .v|97|131|230) (.i|258|261 24) (.x|258|261 .t|97|122|155)) (begin (.check! (fixnum? .i|258|261) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (vector? .v|258|261) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (<:fix:fix .i|258|261 (vector-length:vec .v|258|261)) 41 .v|258|261 .i|258|261 .x|258|261) (.check! (>=:fix:fix .i|258|261 0) 41 .v|258|261 .i|258|261 .x|258|261) (vector-set!:trusted .v|258|261 .i|258|261 .x|258|261))) (let ((.v|262|265 .v|97|131|230) (.i|262|265 23) (.x|262|265 .t|97|121|158)) (begin (.check! (fixnum? .i|262|265) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (vector? .v|262|265) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (<:fix:fix .i|262|265 (vector-length:vec .v|262|265)) 41 .v|262|265 .i|262|265 .x|262|265) (.check! (>=:fix:fix .i|262|265 0) 41 .v|262|265 .i|262|265 .x|262|265) (vector-set!:trusted .v|262|265 .i|262|265 .x|262|265))) (let ((.v|266|269 .v|97|131|230) (.i|266|269 22) (.x|266|269 .t|97|120|161)) (begin (.check! (fixnum? .i|266|269) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (vector? .v|266|269) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (<:fix:fix .i|266|269 (vector-length:vec .v|266|269)) 41 .v|266|269 .i|266|269 .x|266|269) (.check! (>=:fix:fix .i|266|269 0) 41 .v|266|269 .i|266|269 .x|266|269) (vector-set!:trusted .v|266|269 .i|266|269 .x|266|269))) (let ((.v|270|273 .v|97|131|230) (.i|270|273 21) (.x|270|273 .t|97|119|164)) (begin (.check! (fixnum? .i|270|273) 41 .v|270|273 .i|270|273 .x|270|273) (.check! (vector? .v|270|273) 41 .v|270|273 .i|270|273 .x|270|273) (.check! (<:fix:fix .i|270|273 (vector-length:vec .v|270|273)) 41 .v|270|273 .i|270|273 .x|270|273) (.check! (>=:fix:fix .i|270|273 0) 41 .v|270|273 .i|270|273 .x|270|273) (vector-set!:trusted .v|270|273 .i|270|273 .x|270|273))) (let ((.v|274|277 .v|97|131|230) (.i|274|277 20) (.x|274|277 .t|97|118|167)) (begin (.check! (fixnum? .i|274|277) 41 .v|274|277 .i|274|277 .x|274|277) (.check! (vector? .v|274|277) 41 .v|274|277 .i|274|277 .x|274|277) (.check! (<:fix:fix .i|274|277 (vector-length:vec .v|274|277)) 41 .v|274|277 .i|274|277 .x|274|277) (.check! (>=:fix:fix .i|274|277 0) 41 .v|274|277 .i|274|277 .x|274|277) (vector-set!:trusted .v|274|277 .i|274|277 .x|274|277))) (let ((.v|278|281 .v|97|131|230) (.i|278|281 19) (.x|278|281 .t|97|117|170)) (begin (.check! (fixnum? .i|278|281) 41 .v|278|281 .i|278|281 .x|278|281) (.check! (vector? .v|278|281) 41 .v|278|281 .i|278|281 .x|278|281) (.check! (<:fix:fix .i|278|281 (vector-length:vec .v|278|281)) 41 .v|278|281 .i|278|281 .x|278|281) (.check! (>=:fix:fix .i|278|281 0) 41 .v|278|281 .i|278|281 .x|278|281) (vector-set!:trusted .v|278|281 .i|278|281 .x|278|281))) (let ((.v|282|285 .v|97|131|230) (.i|282|285 18) (.x|282|285 .t|97|116|173)) (begin (.check! (fixnum? .i|282|285) 41 .v|282|285 .i|282|285 .x|282|285) (.check! (vector? .v|282|285) 41 .v|282|285 .i|282|285 .x|282|285) (.check! (<:fix:fix .i|282|285 (vector-length:vec .v|282|285)) 41 .v|282|285 .i|282|285 .x|282|285) (.check! (>=:fix:fix .i|282|285 0) 41 .v|282|285 .i|282|285 .x|282|285) (vector-set!:trusted .v|282|285 .i|282|285 .x|282|285))) (let ((.v|286|289 .v|97|131|230) (.i|286|289 17) (.x|286|289 .t|97|115|176)) (begin (.check! (fixnum? .i|286|289) 41 .v|286|289 .i|286|289 .x|286|289) (.check! (vector? .v|286|289) 41 .v|286|289 .i|286|289 .x|286|289) (.check! (<:fix:fix .i|286|289 (vector-length:vec .v|286|289)) 41 .v|286|289 .i|286|289 .x|286|289) (.check! (>=:fix:fix .i|286|289 0) 41 .v|286|289 .i|286|289 .x|286|289) (vector-set!:trusted .v|286|289 .i|286|289 .x|286|289))) (let ((.v|290|293 .v|97|131|230) (.i|290|293 16) (.x|290|293 .t|97|114|179)) (begin (.check! (fixnum? .i|290|293) 41 .v|290|293 .i|290|293 .x|290|293) (.check! (vector? .v|290|293) 41 .v|290|293 .i|290|293 .x|290|293) (.check! (<:fix:fix .i|290|293 (vector-length:vec .v|290|293)) 41 .v|290|293 .i|290|293 .x|290|293) (.check! (>=:fix:fix .i|290|293 0) 41 .v|290|293 .i|290|293 .x|290|293) (vector-set!:trusted .v|290|293 .i|290|293 .x|290|293))) (let ((.v|294|297 .v|97|131|230) (.i|294|297 15) (.x|294|297 .t|97|113|182)) (begin (.check! (fixnum? .i|294|297) 41 .v|294|297 .i|294|297 .x|294|297) (.check! (vector? .v|294|297) 41 .v|294|297 .i|294|297 .x|294|297) (.check! (<:fix:fix .i|294|297 (vector-length:vec .v|294|297)) 41 .v|294|297 .i|294|297 .x|294|297) (.check! (>=:fix:fix .i|294|297 0) 41 .v|294|297 .i|294|297 .x|294|297) (vector-set!:trusted .v|294|297 .i|294|297 .x|294|297))) (let ((.v|298|301 .v|97|131|230) (.i|298|301 14) (.x|298|301 .t|97|112|185)) (begin (.check! (fixnum? .i|298|301) 41 .v|298|301 .i|298|301 .x|298|301) (.check! (vector? .v|298|301) 41 .v|298|301 .i|298|301 .x|298|301) (.check! (<:fix:fix .i|298|301 (vector-length:vec .v|298|301)) 41 .v|298|301 .i|298|301 .x|298|301) (.check! (>=:fix:fix .i|298|301 0) 41 .v|298|301 .i|298|301 .x|298|301) (vector-set!:trusted .v|298|301 .i|298|301 .x|298|301))) (let ((.v|302|305 .v|97|131|230) (.i|302|305 13) (.x|302|305 .t|97|111|188)) (begin (.check! (fixnum? .i|302|305) 41 .v|302|305 .i|302|305 .x|302|305) (.check! (vector? .v|302|305) 41 .v|302|305 .i|302|305 .x|302|305) (.check! (<:fix:fix .i|302|305 (vector-length:vec .v|302|305)) 41 .v|302|305 .i|302|305 .x|302|305) (.check! (>=:fix:fix .i|302|305 0) 41 .v|302|305 .i|302|305 .x|302|305) (vector-set!:trusted .v|302|305 .i|302|305 .x|302|305))) (let ((.v|306|309 .v|97|131|230) (.i|306|309 12) (.x|306|309 .t|97|110|191)) (begin (.check! (fixnum? .i|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (vector? .v|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (<:fix:fix .i|306|309 (vector-length:vec .v|306|309)) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (>=:fix:fix .i|306|309 0) 41 .v|306|309 .i|306|309 .x|306|309) (vector-set!:trusted .v|306|309 .i|306|309 .x|306|309))) (let ((.v|310|313 .v|97|131|230) (.i|310|313 11) (.x|310|313 .t|97|109|194)) (begin (.check! (fixnum? .i|310|313) 41 .v|310|313 .i|310|313 .x|310|313) (.check! (vector? .v|310|313) 41 .v|310|313 .i|310|313 .x|310|313) (.check! (<:fix:fix .i|310|313 (vector-length:vec .v|310|313)) 41 .v|310|313 .i|310|313 .x|310|313) (.check! (>=:fix:fix .i|310|313 0) 41 .v|310|313 .i|310|313 .x|310|313) (vector-set!:trusted .v|310|313 .i|310|313 .x|310|313))) (let ((.v|314|317 .v|97|131|230) (.i|314|317 10) (.x|314|317 .t|97|108|197)) (begin (.check! (fixnum? .i|314|317) 41 .v|314|317 .i|314|317 .x|314|317) (.check! (vector? .v|314|317) 41 .v|314|317 .i|314|317 .x|314|317) (.check! (<:fix:fix .i|314|317 (vector-length:vec .v|314|317)) 41 .v|314|317 .i|314|317 .x|314|317) (.check! (>=:fix:fix .i|314|317 0) 41 .v|314|317 .i|314|317 .x|314|317) (vector-set!:trusted .v|314|317 .i|314|317 .x|314|317))) (let ((.v|318|321 .v|97|131|230) (.i|318|321 9) (.x|318|321 .t|97|107|200)) (begin (.check! (fixnum? .i|318|321) 41 .v|318|321 .i|318|321 .x|318|321) (.check! (vector? .v|318|321) 41 .v|318|321 .i|318|321 .x|318|321) (.check! (<:fix:fix .i|318|321 (vector-length:vec .v|318|321)) 41 .v|318|321 .i|318|321 .x|318|321) (.check! (>=:fix:fix .i|318|321 0) 41 .v|318|321 .i|318|321 .x|318|321) (vector-set!:trusted .v|318|321 .i|318|321 .x|318|321))) (let ((.v|322|325 .v|97|131|230) (.i|322|325 8) (.x|322|325 .t|97|106|203)) (begin (.check! (fixnum? .i|322|325) 41 .v|322|325 .i|322|325 .x|322|325) (.check! (vector? .v|322|325) 41 .v|322|325 .i|322|325 .x|322|325) (.check! (<:fix:fix .i|322|325 (vector-length:vec .v|322|325)) 41 .v|322|325 .i|322|325 .x|322|325) (.check! (>=:fix:fix .i|322|325 0) 41 .v|322|325 .i|322|325 .x|322|325) (vector-set!:trusted .v|322|325 .i|322|325 .x|322|325))) (let ((.v|326|329 .v|97|131|230) (.i|326|329 7) (.x|326|329 .t|97|105|206)) (begin (.check! (fixnum? .i|326|329) 41 .v|326|329 .i|326|329 .x|326|329) (.check! (vector? .v|326|329) 41 .v|326|329 .i|326|329 .x|326|329) (.check! (<:fix:fix .i|326|329 (vector-length:vec .v|326|329)) 41 .v|326|329 .i|326|329 .x|326|329) (.check! (>=:fix:fix .i|326|329 0) 41 .v|326|329 .i|326|329 .x|326|329) (vector-set!:trusted .v|326|329 .i|326|329 .x|326|329))) (let ((.v|330|333 .v|97|131|230) (.i|330|333 6) (.x|330|333 .t|97|104|209)) (begin (.check! (fixnum? .i|330|333) 41 .v|330|333 .i|330|333 .x|330|333) (.check! (vector? .v|330|333) 41 .v|330|333 .i|330|333 .x|330|333) (.check! (<:fix:fix .i|330|333 (vector-length:vec .v|330|333)) 41 .v|330|333 .i|330|333 .x|330|333) (.check! (>=:fix:fix .i|330|333 0) 41 .v|330|333 .i|330|333 .x|330|333) (vector-set!:trusted .v|330|333 .i|330|333 .x|330|333))) (let ((.v|334|337 .v|97|131|230) (.i|334|337 5) (.x|334|337 .t|97|103|212)) (begin (.check! (fixnum? .i|334|337) 41 .v|334|337 .i|334|337 .x|334|337) (.check! (vector? .v|334|337) 41 .v|334|337 .i|334|337 .x|334|337) (.check! (<:fix:fix .i|334|337 (vector-length:vec .v|334|337)) 41 .v|334|337 .i|334|337 .x|334|337) (.check! (>=:fix:fix .i|334|337 0) 41 .v|334|337 .i|334|337 .x|334|337) (vector-set!:trusted .v|334|337 .i|334|337 .x|334|337))) (let ((.v|338|341 .v|97|131|230) (.i|338|341 4) (.x|338|341 .t|97|102|215)) (begin (.check! (fixnum? .i|338|341) 41 .v|338|341 .i|338|341 .x|338|341) (.check! (vector? .v|338|341) 41 .v|338|341 .i|338|341 .x|338|341) (.check! (<:fix:fix .i|338|341 (vector-length:vec .v|338|341)) 41 .v|338|341 .i|338|341 .x|338|341) (.check! (>=:fix:fix .i|338|341 0) 41 .v|338|341 .i|338|341 .x|338|341) (vector-set!:trusted .v|338|341 .i|338|341 .x|338|341))) (let ((.v|342|345 .v|97|131|230) (.i|342|345 3) (.x|342|345 .t|97|101|218)) (begin (.check! (fixnum? .i|342|345) 41 .v|342|345 .i|342|345 .x|342|345) (.check! (vector? .v|342|345) 41 .v|342|345 .i|342|345 .x|342|345) (.check! (<:fix:fix .i|342|345 (vector-length:vec .v|342|345)) 41 .v|342|345 .i|342|345 .x|342|345) (.check! (>=:fix:fix .i|342|345 0) 41 .v|342|345 .i|342|345 .x|342|345) (vector-set!:trusted .v|342|345 .i|342|345 .x|342|345))) (let ((.v|346|349 .v|97|131|230) (.i|346|349 2) (.x|346|349 .t|97|100|221)) (begin (.check! (fixnum? .i|346|349) 41 .v|346|349 .i|346|349 .x|346|349) (.check! (vector? .v|346|349) 41 .v|346|349 .i|346|349 .x|346|349) (.check! (<:fix:fix .i|346|349 (vector-length:vec .v|346|349)) 41 .v|346|349 .i|346|349 .x|346|349) (.check! (>=:fix:fix .i|346|349 0) 41 .v|346|349 .i|346|349 .x|346|349) (vector-set!:trusted .v|346|349 .i|346|349 .x|346|349))) (let ((.v|350|353 .v|97|131|230) (.i|350|353 1) (.x|350|353 .t|97|99|224)) (begin (.check! (fixnum? .i|350|353) 41 .v|350|353 .i|350|353 .x|350|353) (.check! (vector? .v|350|353) 41 .v|350|353 .i|350|353 .x|350|353) (.check! (<:fix:fix .i|350|353 (vector-length:vec .v|350|353)) 41 .v|350|353 .i|350|353 .x|350|353) (.check! (>=:fix:fix .i|350|353 0) 41 .v|350|353 .i|350|353 .x|350|353) (vector-set!:trusted .v|350|353 .i|350|353 .x|350|353))) (let ((.v|354|357 .v|97|131|230) (.i|354|357 0) (.x|354|357 .t|97|98|227)) (begin (.check! (fixnum? .i|354|357) 41 .v|354|357 .i|354|357 .x|354|357) (.check! (vector? .v|354|357) 41 .v|354|357 .i|354|357 .x|354|357) (.check! (<:fix:fix .i|354|357 (vector-length:vec .v|354|357)) 41 .v|354|357 .i|354|357 .x|354|357) (.check! (>=:fix:fix .i|354|357 0) 41 .v|354|357 .i|354|357 .x|354|357) (vector-set!:trusted .v|354|357 .i|354|357 .x|354|357))) .v|97|131|230)))) (.larceny-register-name|4 $r.tmp0 "%tmp0") (.larceny-register-name|4 $r.result "%result") (.larceny-register-name|4 $r.argreg2 "%argreg2") (.larceny-register-name|4 $r.argreg3 "%argreg3") (.larceny-register-name|4 $r.tmp1 "%tmp1") (.larceny-register-name|4 $r.tmp2 "%tmp2") (.larceny-register-name|4 $r.reg0 "%r0") (.larceny-register-name|4 $r.reg1 "%r1") (.larceny-register-name|4 $r.reg2 "%r2") (.larceny-register-name|4 $r.reg3 "%r3") (.larceny-register-name|4 $r.reg4 "%r4") (.larceny-register-name|4 $r.reg5 "%r5") (.larceny-register-name|4 $r.reg6 "%r6") (.larceny-register-name|4 $r.reg7 "%r7") (.larceny-register-name|4 $r.e-top "%etop") (.larceny-register-name|4 $r.e-limit "%elim") (.larceny-register-name|4 $r.timer "%timer") (.larceny-register-name|4 $r.millicode "%millicode") (.larceny-register-name|4 $r.globals "%globals") (.larceny-register-name|4 $r.stkp "%stkp") (.millicode-name|4 $m.alloc "alloc") (.millicode-name|4 $m.alloci "alloci") (.millicode-name|4 $m.gc "gc") (.millicode-name|4 $m.addtrans "addtrans") (.millicode-name|4 $m.stkoflow "stkoflow") (.millicode-name|4 $m.stkuflow "stkuflow") (.millicode-name|4 $m.creg "creg") (.millicode-name|4 $m.creg-set! "creg-set!") (.millicode-name|4 $m.add "+") (.millicode-name|4 $m.subtract "- (binary)") (.millicode-name|4 $m.multiply "*") (.millicode-name|4 $m.quotient "quotient") (.millicode-name|4 $m.remainder "remainder") (.millicode-name|4 $m.divide "/") (.millicode-name|4 $m.modulo "modulo") (.millicode-name|4 $m.negate "- (unary)") (.millicode-name|4 $m.numeq "=") (.millicode-name|4 $m.numlt "<") (.millicode-name|4 $m.numle "<=") (.millicode-name|4 $m.numgt ">") (.millicode-name|4 $m.numge ">=") (.millicode-name|4 $m.zerop "zero?") (.millicode-name|4 $m.complexp "complex?") (.millicode-name|4 $m.realp "real?") (.millicode-name|4 $m.rationalp "rational?") (.millicode-name|4 $m.integerp "integer?") (.millicode-name|4 $m.exactp "exact?") (.millicode-name|4 $m.inexactp "inexact?") (.millicode-name|4 $m.exact->inexact "exact->inexact") (.millicode-name|4 $m.inexact->exact "inexact->exact") (.millicode-name|4 $m.make-rectangular "make-rectangular") (.millicode-name|4 $m.real-part "real-part") (.millicode-name|4 $m.imag-part "imag-part") (.millicode-name|4 $m.sqrt "sqrt") (.millicode-name|4 $m.round "round") (.millicode-name|4 $m.truncate "truncate") (.millicode-name|4 $m.apply "apply") (.millicode-name|4 $m.varargs "varargs") (.millicode-name|4 $m.typetag "typetag") (.millicode-name|4 $m.typetag-set "typetag-set") (.millicode-name|4 $m.break "break") (.millicode-name|4 $m.eqv "eqv?") (.millicode-name|4 $m.partial-list->vector "partial-list->vector") (.millicode-name|4 $m.timer-exception "timer-exception") (.millicode-name|4 $m.exception "exception") (.millicode-name|4 $m.singlestep "singlestep") (.millicode-name|4 $m.syscall "syscall") (.millicode-name|4 $m.bvlcmp "bvlcmp") (.millicode-name|4 $m.enable-interrupts "enable-interrupts") (.millicode-name|4 $m.disable-interrupts "disable-interrupts") (.millicode-name|4 $m.alloc-bv "alloc-bv") (.millicode-name|4 $m.global-ex "global-exception") (.millicode-name|4 $m.invoke-ex "invoke-exception") (.millicode-name|4 $m.global-invoke-ex "global-invoke-exception") (.millicode-name|4 $m.argc-ex "argc-exception") (set! format-instruction .format-instr|4) 'format-instruction))))
+(let () (begin (set! twobit-benchmark (lambda .rest|1 (let ((.k|4 (if (null? .rest|1) 1 (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))))) (begin (compiler-switches 'fast-safe) (benchmark-block-mode #t) (run-benchmark "twobit" .k|4 (lambda () (compile-file "benchmarks/twobit-input.sch")) (lambda (.result|6) #t)))))) 'twobit-benchmark))
--- /dev/null
+(let () (begin (set! make-relative-filename (lambda .components|1 (let ((.construct|2 (unspecified))) (begin (set! .construct|2 (lambda (.l|3) (if (null? (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) .l|3 (cons (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (cons "/" (.construct|2 (let ((.x|12|15 .l|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))))))) (if (null? (let ((.x|16|19 .components|1)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.x|20|23 .components|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (apply string-append (.construct|2 .components|1))))))) 'make-relative-filename))
+(let () (begin (set! pathname-append (lambda .components|1 (let ((.construct|4 (unspecified))) (begin (set! .construct|4 (lambda (.l|5) (if (null? (let ((.x|7|10 .l|5)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) .l|5 (if (string=? (let ((.x|12|15 .l|5)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))) "") (.construct|4 (let ((.x|16|19 .l|5)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (if (char=? #\/ (string-ref (let ((.x|21|24 .l|5)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))) (- (string-length (let ((.x|25|28 .l|5)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) 1))) (cons (let ((.x|29|32 .l|5)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32))) (.construct|4 (let ((.x|33|36 .l|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (cons (let ((.x|38|41 .l|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (cons "/" (.construct|4 (let ((.x|42|45 .l|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))))))))) (let ((.n|46 (if (null? (let ((.x|47|50 .components|1)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))) (let ((.x|51|54 .components|1)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))) (apply string-append (.construct|4 .components|1))))) (if (not (char=? #\/ (string-ref .n|46 (- (string-length .n|46) 1)))) (string-append .n|46 "/") .n|46)))))) 'pathname-append))
+(let () (begin (set! make-nbuild-parameter (lambda (.dir|1 .source?|1 .verbose?|1 .hostdir|1 .hostname|1) (let ((.make-nbuild-parameter|2 0)) (begin (set! .make-nbuild-parameter|2 (lambda (.dir|3 .source?|3 .verbose?|3 .hostdir|3 .hostname|3) (let ((.parameters|6 (.cons (.cons 'compiler (pathname-append .dir|3 "Compiler")) (.cons (.cons 'util (pathname-append .dir|3 "Util")) (.cons (.cons 'build (pathname-append .dir|3 "Rts" "Build")) (.cons (.cons 'source (pathname-append .dir|3 "Lib")) (.cons (.cons 'common-source (pathname-append .dir|3 "Lib" "Common")) (.cons (.cons 'repl-source (pathname-append .dir|3 "Repl")) (.cons (.cons 'interp-source (pathname-append .dir|3 "Eval")) (.cons (.cons 'machine-source (pathname-append .dir|3 "Lib" "Sparc")) (.cons (.cons 'common-asm (pathname-append .dir|3 "Asm" "Common")) (.cons (.cons 'sparc-asm (pathname-append .dir|3 "Asm" "Sparc")) (.cons '(target-machine . sparc) (.cons '(endianness . big) (.cons '(word-size . 32) (.cons (.cons 'always-source? .source?|3) (.cons (.cons 'verbose-load? .verbose?|3) (.cons (.cons 'compatibility (pathname-append .dir|3 "Compat" .hostdir|3)) (.cons (.cons 'host-system .hostname|3) '()))))))))))))))))))) (lambda (.key|7) (let ((.probe|10 (assq .key|7 .parameters|6))) (if .probe|10 (let ((.x|11|14 .probe|10)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))) #f)))))) (.make-nbuild-parameter|2 .dir|1 .source?|1 .verbose?|1 .hostdir|1 .hostname|1))))) 'make-nbuild-parameter))
+(let () (begin (set! nbuild-parameter (make-nbuild-parameter "" #f #f "Larceny" "Larceny")) 'nbuild-parameter))
+(let () (begin (set! aremq! (lambda (.key|1 .alist|1) (let ((.aremq!|2 0)) (begin (set! .aremq!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (eq? .key|3 (let ((.x|7|10 (let ((.x|11|14 .alist|3)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))))) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (.aremq!|2 .key|3 (let ((.x|15|18 .alist|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))) (begin (set-cdr! .alist|3 (.aremq!|2 .key|3 (let ((.x|20|23 .alist|3)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) .alist|3))))) (.aremq!|2 .key|1 .alist|1))))) 'aremq!))
+(let () (begin (set! aremv! (lambda (.key|1 .alist|1) (let ((.aremv!|2 0)) (begin (set! .aremv!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (eqv? .key|3 (let ((.x|8|11 (let ((.x|12|15 .alist|3)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) (.aremv!|2 .key|3 (let ((.x|16|19 .alist|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (begin (set-cdr! .alist|3 (.aremv!|2 .key|3 (let ((.x|21|24 .alist|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) .alist|3))))) (.aremv!|2 .key|1 .alist|1))))) 'aremv!))
+(let () (begin (set! aremove! (lambda (.key|1 .alist|1) (let ((.aremove!|2 0)) (begin (set! .aremove!|2 (lambda (.key|3 .alist|3) (if (null? .alist|3) .alist|3 (if (equal? .key|3 (let ((.x|7|10 (let ((.x|11|14 .alist|3)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))))) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (.aremove!|2 .key|3 (let ((.x|15|18 .alist|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))) (begin (set-cdr! .alist|3 (.aremove!|2 .key|3 (let ((.x|20|23 .alist|3)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) .alist|3))))) (.aremove!|2 .key|1 .alist|1))))) 'aremove!))
+(let () (begin (set! filter (lambda (.select?|1 .list|1) (let ((.filter|2 0)) (begin (set! .filter|2 (lambda (.select?|3 .list|3) (if (null? .list|3) .list|3 (if (.select?|3 (let ((.x|6|9 .list|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (cons (let ((.x|10|13 .list|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.filter|2 .select?|3 (let ((.x|14|17 .list|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (.filter|2 .select?|3 (let ((.x|19|22 .list|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (.filter|2 .select?|1 .list|1))))) 'filter))
+(let () (begin (set! find (lambda (.selected?|1 .list|1) (let ((.find|2 0)) (begin (set! .find|2 (lambda (.selected?|3 .list|3) (if (null? .list|3) #f (if (.selected?|3 (let ((.x|6|9 .list|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (let ((.x|10|13 .list|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.find|2 .selected?|3 (let ((.x|15|18 .list|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))))) (.find|2 .selected?|1 .list|1))))) 'find))
+(let () (begin (set! remove-duplicates (lambda (.list|1 .same?|1) (let ((.remove-duplicates|2 0)) (begin (set! .remove-duplicates|2 (lambda (.list|3 .same?|3) (let ((.member?|5 (unspecified))) (begin (set! .member?|5 (lambda (.x|6 .list|6) (if (null? .list|6) #f (if (.same?|3 .x|6 (let ((.x|9|12 .list|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) #t (.member?|5 .x|6 (let ((.x|14|17 .list|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))))))) (if (null? .list|3) .list|3 (if (.member?|5 (let ((.x|19|22 .list|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) (let ((.x|23|26 .list|3)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))) (.remove-duplicates|2 (let ((.x|27|30 .list|3)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))) .same?|3) (cons (let ((.x|32|35 .list|3)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) (.remove-duplicates|2 (let ((.x|36|39 .list|3)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) .same?|3)))))))) (.remove-duplicates|2 .list|1 .same?|1))))) 'remove-duplicates))
+(let () (begin (set! least (lambda (.less?|1 .list|1) (let ((.least|2 0)) (begin (set! .least|2 (lambda (.less?|3 .list|3) (reduce (lambda (.a|4 .b|4) (if (.less?|3 .a|4 .b|4) .a|4 .b|4)) #f .list|3))) (.least|2 .less?|1 .list|1))))) 'least))
+(let () (begin (set! greatest (lambda (.greater?|1 .list|1) (let ((.greatest|2 0)) (begin (set! .greatest|2 (lambda (.greater?|3 .list|3) (reduce (lambda (.a|4 .b|4) (if (.greater?|3 .a|4 .b|4) .a|4 .b|4)) #f .list|3))) (.greatest|2 .greater?|1 .list|1))))) 'greatest))
+(let () (begin (set! mappend (lambda (.proc|1 .l|1) (let ((.mappend|2 0)) (begin (set! .mappend|2 (lambda (.proc|3 .l|3) (apply append (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (.proc|3 (let ((.x|24|27 .y1|4|5|16)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27)))) .results|4|8|16)))))) (.loop|9|12|15 .l|3 '()))))))) (.mappend|2 .proc|1 .l|1))))) 'mappend))
+(let () (begin (set! make-list (lambda (.nelem|1 . .rest|1) (let* ((.val|4 (if (null? .rest|1) #f (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))))) (.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.n|6 .l|6) (if (zero? .n|6) .l|6 (.loop|5 (- .n|6 1) (cons .val|4 .l|6))))) (.loop|5 .nelem|1 '()))))) 'make-list))
+(let () (begin (set! reduce (lambda (.proc|1 .initial|1 .l|1) (let ((.reduce|2 0)) (begin (set! .reduce|2 (lambda (.proc|3 .initial|3 .l|3) (let ((.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.val|6 .l|6) (if (null? .l|6) .val|6 (.loop|5 (.proc|3 .val|6 (let ((.x|7|10 .l|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (let ((.x|11|14 .l|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))))))) (if (null? .l|3) .initial|3 (if (null? (let ((.x|16|19 .l|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.x|20|23 .l|3)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (.loop|5 (let ((.x|25|28 .l|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|29|32 .l|3)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32)))))))))) (.reduce|2 .proc|1 .initial|1 .l|1))))) 'reduce))
+(let () (begin (set! reduce-right (lambda (.proc|1 .initial|1 .l|1) (let ((.reduce-right|2 0)) (begin (set! .reduce-right|2 (lambda (.proc|3 .initial|3 .l|3) (let ((.loop|5 (unspecified))) (begin (set! .loop|5 (lambda (.l|6) (if (null? (let ((.x|7|10 .l|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (let ((.x|11|14 .l|6)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (.proc|3 (let ((.x|15|18 .l|6)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.loop|5 (let ((.x|19|22 .l|6)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (if (null? .l|3) .initial|3 (if (null? (let ((.x|24|27 .l|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (let ((.x|28|31 .l|3)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) (.loop|5 .l|3))))))) (.reduce-right|2 .proc|1 .initial|1 .l|1))))) 'reduce-right))
+(let () (begin (set! fold-left (lambda (.proc|1 .initial|1 .l|1) (let ((.fold-left|2 0)) (begin (set! .fold-left|2 (lambda (.proc|3 .initial|3 .l|3) (if (null? .l|3) .initial|3 (.fold-left|2 .proc|3 (.proc|3 .initial|3 (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))))))) (.fold-left|2 .proc|1 .initial|1 .l|1))))) 'fold-left))
+(let () (begin (set! fold-right (lambda (.proc|1 .initial|1 .l|1) (let ((.fold-right|2 0)) (begin (set! .fold-right|2 (lambda (.proc|3 .initial|3 .l|3) (if (null? .l|3) .initial|3 (.proc|3 (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (.fold-right|2 .proc|3 .initial|3 (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))))))) (.fold-right|2 .proc|1 .initial|1 .l|1))))) 'fold-right))
+(let () (begin (set! iota (lambda (.n|1) (let ((.iota|2 0)) (begin (set! .iota|2 (lambda (.n|3) (let ((.n|6 (- .n|3 1)) (.r|6 '())) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.n|10 .r|10) (let ((.r|13 (cons .n|10 .r|10))) (if (= .n|10 0) .r|13 (.loop|9 (- .n|10 1) .r|13))))) (.loop|9 .n|6 .r|6))))))) (.iota|2 .n|1))))) 'iota))
+(let () (begin (set! list-head (lambda (.l|1 .n|1) (let ((.list-head|2 0)) (begin (set! .list-head|2 (lambda (.l|3 .n|3) (if (zero? .n|3) '() (cons (let ((.x|4|7 .l|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (.list-head|2 (let ((.x|8|11 .l|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) (- .n|3 1)))))) (.list-head|2 .l|1 .n|1))))) 'list-head))
+(let () (begin (set! $$trace (lambda (.x|1) (let ((.$$trace|2 0)) (begin (set! .$$trace|2 (lambda (.x|3) #t)) (.$$trace|2 .x|1))))) '$$trace))
+(let () (begin (set! host-system 'larceny) 'host-system))
+(let () (begin (set! .check! (lambda (.flag|1 .exn|1 . .args|1) (if (not .flag|1) (apply error "Runtime check exception: " .exn|1 .args|1) (unspecified)))) '.check!))
+(let () (begin (set! compat:initialize (lambda .rest|1 (if (null? .rest|1) (let ((.dir|4 (nbuild-parameter 'compatibility))) (begin (compat:load (string-append .dir|4 "compat2.sch")) (compat:load (string-append .dir|4 "../../Auxlib/list.sch")) (compat:load (string-append .dir|4 "../../Auxlib/pp.sch")))) (unspecified)))) 'compat:initialize))
+(let () (begin (set! with-optimization (lambda (.level|1 .thunk|1) (let ((.with-optimization|2 0)) (begin (set! .with-optimization|2 (lambda (.level|3 .thunk|3) (.thunk|3))) (.with-optimization|2 .level|1 .thunk|1))))) 'with-optimization))
+(let () (begin (set! call-with-error-control (lambda (.thunk1|1 .thunk2|1) (let ((.call-with-error-control|2 0)) (begin (set! .call-with-error-control|2 (lambda (.thunk1|3 .thunk2|3) (let ((.eh|6 (error-handler))) (begin (error-handler (lambda .args|7 (begin (error-handler .eh|6) (.thunk2|3) (apply .eh|6 .args|7)))) (.thunk1|3) (error-handler .eh|6))))) (.call-with-error-control|2 .thunk1|1 .thunk2|1))))) 'call-with-error-control))
+(let () (begin (set! larc-new-extension (lambda (.fn|1 .ext|1) (let ((.larc-new-extension|2 0)) (begin (set! .larc-new-extension|2 (lambda (.fn|3 .ext|3) (let* ((.l|6 (string-length .fn|3)) (.x|9 (let ((.i|15 (- .l|6 1))) (let () (let ((.loop|18 (unspecified))) (begin (set! .loop|18 (lambda (.i|19) (if (< .i|19 0) #f (if (char=? (string-ref .fn|3 .i|19) #\.) (+ .i|19 1) (.loop|18 (- .i|19 1)))))) (.loop|18 .i|15))))))) (let () (if (not .x|9) (string-append .fn|3 "." .ext|3) (string-append (substring .fn|3 0 .x|9) .ext|3)))))) (.larc-new-extension|2 .fn|1 .ext|1))))) 'larc-new-extension))
+(let () (begin (set! compat:load (lambda (.filename|1) (let ((.compat:load|2 0)) (begin (set! .compat:load|2 (lambda (.filename|3) (let ((.loadit|4 (unspecified))) (begin (set! .loadit|4 (lambda (.fn|5) (begin (if (nbuild-parameter 'verbose-load?) (format #t "~a~%" .fn|5) (unspecified)) (load .fn|5)))) (if (nbuild-parameter 'always-source?) (.loadit|4 .filename|3) (let ((.fn|8 (larc-new-extension .filename|3 "fasl"))) (if (if (file-exists? .fn|8) (compat:file-newer? .fn|8 .filename|3) #f) (.loadit|4 .fn|8) (.loadit|4 .filename|3)))))))) (.compat:load|2 .filename|1))))) 'compat:load))
+(let () (begin (set! compat:file-newer? (lambda (.a|1 .b|1) (let ((.compat:file-newer?|2 0)) (begin (set! .compat:file-newer?|2 (lambda (.a|3 .b|3) (let* ((.ta|6 (file-modification-time .a|3)) (.tb|9 (file-modification-time .b|3)) (.limit|12 (let ((.v|42|45 .ta|6)) (begin (.check! (vector? .v|42|45) 42 .v|42|45) (vector-length:vec .v|42|45))))) (let () (let ((.i|18 0)) (let () (let ((.loop|21 (unspecified))) (begin (set! .loop|21 (lambda (.i|22) (if (= .i|22 .limit|12) #f (if (= (let ((.v|25|28 .ta|6) (.i|25|28 .i|22)) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28))) (let ((.v|29|32 .tb|9) (.i|29|32 .i|22)) (begin (.check! (fixnum? .i|29|32) 40 .v|29|32 .i|29|32) (.check! (vector? .v|29|32) 40 .v|29|32 .i|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 40 .v|29|32 .i|29|32) (.check! (>=:fix:fix .i|29|32 0) 40 .v|29|32 .i|29|32) (vector-ref:trusted .v|29|32 .i|29|32)))) (.loop|21 (+ .i|22 1)) (> (let ((.v|34|37 .ta|6) (.i|34|37 .i|22)) (begin (.check! (fixnum? .i|34|37) 40 .v|34|37 .i|34|37) (.check! (vector? .v|34|37) 40 .v|34|37 .i|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 40 .v|34|37 .i|34|37) (.check! (>=:fix:fix .i|34|37 0) 40 .v|34|37 .i|34|37) (vector-ref:trusted .v|34|37 .i|34|37))) (let ((.v|38|41 .tb|9) (.i|38|41 .i|22)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41)))))))) (.loop|21 .i|18))))))))) (.compat:file-newer?|2 .a|1 .b|1))))) 'compat:file-newer?))
+(let () (begin (set! host-system 'larceny) 'host-system))
+(let () (begin (set! compat:sort (lambda (.list|1 .less?|1) (sort .list|1 .less?|1))) 'compat:sort))
+(let () (begin (set! compat:char->integer char->integer) 'compat:char->integer))
+(let () (begin (set! write-lop (lambda (.item|1 .port|1) (let ((.write-lop|2 0)) (begin (set! .write-lop|2 (lambda (.item|3 .port|3) (begin (lowlevel-write .item|3 .port|3) (newline .port|3) (newline .port|3)))) (.write-lop|2 .item|1 .port|1))))) 'write-lop))
+(let () (begin (set! write-fasl-datum lowlevel-write) 'write-fasl-datum))
+(let () (begin (set! misc->bytevector (lambda (.x|1) (let ((.misc->bytevector|2 0)) (begin (set! .misc->bytevector|2 (lambda (.x|3) (let ((.bv|6 (bytevector-like-copy .x|3))) (begin (typetag-set! .bv|6 $tag.bytevector-typetag) .bv|6)))) (.misc->bytevector|2 .x|1))))) 'misc->bytevector))
+(let () (begin (set! string->bytevector misc->bytevector) 'string->bytevector))
+(let () (begin (set! bignum->bytevector misc->bytevector) 'bignum->bytevector))
+(let () (begin (set! flonum->bytevector (lambda (.x|1) (let ((.flonum->bytevector|2 0)) (begin (set! .flonum->bytevector|2 (lambda (.x|3) (clear-first-word (misc->bytevector .x|3)))) (.flonum->bytevector|2 .x|1))))) 'flonum->bytevector))
+(let () (begin (set! compnum->bytevector (lambda (.x|1) (let ((.compnum->bytevector|2 0)) (begin (set! .compnum->bytevector|2 (lambda (.x|3) (clear-first-word (misc->bytevector .x|3)))) (.compnum->bytevector|2 .x|1))))) 'compnum->bytevector))
+(let () (begin (set! clear-first-word (lambda (.bv|1) (let ((.clear-first-word|2 0)) (begin (set! .clear-first-word|2 (lambda (.bv|3) (begin (bytevector-like-set! .bv|3 0 0) (bytevector-like-set! .bv|3 1 0) (bytevector-like-set! .bv|3 2 0) (bytevector-like-set! .bv|3 3 0) .bv|3))) (.clear-first-word|2 .bv|1))))) 'clear-first-word))
+(let () (begin (set! list->bytevector (lambda (.l|1) (let ((.list->bytevector|2 0)) (begin (set! .list->bytevector|2 (lambda (.l|3) (let ((.b|6 (make-bytevector (length .l|3)))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.i|14 .l|14) (if (null? .l|14) .b|6 (begin (begin #t (bytevector-set! .b|6 .i|14 (let ((.x|17|20 .l|14)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (.loop|7|10|13 (+ .i|14 1) (let ((.x|21|24 .l|14)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))))))) (.loop|7|10|13 0 .l|3))))))) (.list->bytevector|2 .l|1))))) 'list->bytevector))
+(let () (begin (set! bytevector-word-ref (let ((.two^8|3 (expt 2 8)) (.two^16|3 (expt 2 16)) (.two^24|3 (expt 2 24))) (lambda (.bv|4 .i|4) (+ (+ (+ (* (bytevector-ref .bv|4 .i|4) .two^24|3) (* (bytevector-ref .bv|4 (+ .i|4 1)) .two^16|3)) (* (bytevector-ref .bv|4 (+ .i|4 2)) .two^8|3)) (bytevector-ref .bv|4 (+ .i|4 3)))))) 'bytevector-word-ref))
+(let () (begin (set! twobit-format (lambda (.fmt|1 . .rest|1) (let ((.out|4 (open-output-string))) (begin (apply format .out|4 .fmt|1 .rest|1) (get-output-string .out|4))))) 'twobit-format))
+(let () (begin (set! an-arbitrary-number (lambda () (let ((.an-arbitrary-number|2 0)) (begin (set! .an-arbitrary-number|2 (lambda () (begin (system "echo \\\"`date`\\\" > a-random-number") (let ((.x|6 (string-hash (call-with-input-file "a-random-number" read)))) (begin (delete-file "a-random-number") .x|6))))) (.an-arbitrary-number|2))))) 'an-arbitrary-number))
+(let () (begin (set! cerror error) 'cerror))
+(let () (begin (set! empty-set (lambda () (let ((.empty-set|2 0)) (begin (set! .empty-set|2 (lambda () '())) (.empty-set|2))))) 'empty-set))
+(let () (begin (set! empty-set? (lambda (.x|1) (let ((.empty-set?|2 0)) (begin (set! .empty-set?|2 (lambda (.x|3) (null? .x|3))) (.empty-set?|2 .x|1))))) 'empty-set?))
+(let () (begin (set! make-set (lambda (.x|1) (let ((.make-set|2 0)) (begin (set! .make-set|2 (lambda (.x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.x|5 .y|5) (if (null? .x|5) .y|5 (if (member (let ((.x|8|11 .x|5)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .y|5) (.loop|4 (let ((.x|12|15 .x|5)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) .y|5) (.loop|4 (let ((.x|17|20 .x|5)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (let ((.x|21|24 .x|5)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))) .y|5)))))) (.loop|4 .x|3 '()))))) (.make-set|2 .x|1))))) 'make-set))
+(let () (begin (set! set-equal? (lambda (.x|1 .y|1) (let ((.set-equal?|2 0)) (begin (set! .set-equal?|2 (lambda (.x|3 .y|3) (if (subset? .x|3 .y|3) (subset? .y|3 .x|3) #f))) (.set-equal?|2 .x|1 .y|1))))) 'set-equal?))
+(let () (begin (set! subset? (lambda (.x|1 .y|1) (let ((.subset?|2 0)) (begin (set! .subset?|2 (lambda (.x|3 .y|3) (every? (lambda (.x|4) (member .x|4 .y|3)) .x|3))) (.subset?|2 .x|1 .y|1))))) 'subset?))
+(let () (begin (set! apply-union (undefined)) 'apply-union))
+(let () (begin (set! union (let () (let ((.union2|3 (unspecified))) (begin (set! .union2|3 (lambda (.x|4 .y|4) (if (null? .x|4) .y|4 (if (member (let ((.x|7|10 .x|4)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) .y|4) (.union2|3 (let ((.x|11|14 .x|4)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))) .y|4) (.union2|3 (let ((.x|16|19 .x|4)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (cons (let ((.x|20|23 .x|4)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) .y|4)))))) (set! apply-union (lambda (.sets|24) (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.sets|32 .result|32) (if (null? .sets|32) .result|32 (begin #t (.loop|25|28|31 (let ((.x|35|38 .sets|32)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (.union2|3 (let ((.x|39|42 .sets|32)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) .result|32)))))) (.loop|25|28|31 .sets|24 '())))))) (lambda .args|43 (if (null? .args|43) '() (if (null? (let ((.x|46|49 .args|43)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49)))) (let ((.x|50|53 .args|43)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))) (if (null? (let ((.x|56|59 (let ((.x|60|63 .args|43)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))))) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59)))) (.union2|3 (let ((.x|64|67 .args|43)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))) (let ((.x|69|72 (let ((.x|73|76 .args|43)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72)))) (.union2|3 (.union2|3 (let ((.x|78|81 .args|43)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81))) (let ((.x|83|86 (let ((.x|87|90 .args|43)) (begin (.check! (pair? .x|87|90) 1 .x|87|90) (cdr:pair .x|87|90))))) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86)))) (apply union (let ((.x|92|95 (let ((.x|96|99 .args|43)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))))))))))))) 'union))
+(let () (begin (set! intersection (let () (let ((.intersection2|3 (unspecified))) (begin (set! .intersection2|3 (lambda (.x|4 .y|4) (if (null? .x|4) '() (if (member (let ((.x|7|10 .x|4)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) .y|4) (cons (let ((.x|11|14 .x|4)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (.intersection2|3 (let ((.x|15|18 .x|4)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .y|4)) (.intersection2|3 (let ((.x|20|23 .x|4)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) .y|4))))) (lambda .args|24 (if (null? .args|24) '() (if (null? (let ((.x|27|30 .args|24)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (let ((.x|31|34 .args|24)) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))) (if (null? (let ((.x|37|40 (let ((.x|41|44 .args|24)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))) (.intersection2|3 (let ((.x|45|48 .args|24)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))) (let ((.x|50|53 (let ((.x|54|57 .args|24)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53)))) (.intersection2|3 (.intersection2|3 (let ((.x|59|62 .args|24)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|64|67 (let ((.x|68|71 .args|24)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (apply intersection (let ((.x|73|76 (let ((.x|77|80 .args|24)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))))) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))))))))))) 'intersection))
+(let () (begin (set! difference (lambda (.x|1 .y|1) (let ((.difference|2 0)) (begin (set! .difference|2 (lambda (.x|3 .y|3) (if (null? .x|3) '() (if (member (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .y|3) (.difference|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) .y|3) (cons (let ((.x|15|18 .x|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.difference|2 (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))) .y|3)))))) (.difference|2 .x|1 .y|1))))) 'difference))
+(let () (begin (set! object-hash (lambda (.x|1) 0)) 'object-hash))
+(let () (begin (set! equal-hash (lambda (.x|1) 0)) 'equal-hash))
+(let () (let ((.n|3 16777216) (.n-1|3 16777215) (.adj:fixnum|3 9000000) (.adj:negative|3 8000000) (.adj:large|3 7900000) (.adj:ratnum|3 7800000) (.adj:complex|3 7700000) (.adj:flonum|3 7000000) (.adj:compnum|3 6900000) (.adj:char|3 6111000) (.adj:string|3 5022200) (.adj:vector|3 4003330) (.adj:misc|3 3000444) (.adj:pair|3 2555000) (.adj:proc|3 2321001) (.adj:iport|3 2321002) (.adj:oport|3 2321003) (.adj:weird|3 2321004) (.budget0|3 32)) (let ((.hash-on-equal|4 (unspecified)) (.combine|4 (unspecified))) (begin (set! .hash-on-equal|4 (lambda (.x|5 .budget|5) (if (> .budget|5 0) (if (string? .x|5) (string-hash .x|5) (if (pair? .x|5) (let ((.budget|10 (quotient .budget|5 2))) (.combine|4 (.hash-on-equal|4 (let ((.x|11|14 .x|5)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) .budget|10) (.hash-on-equal|4 (let ((.x|15|18 .x|5)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .budget|10))) (if (vector? .x|5) (let ((.n|22 (let ((.v|35|38 .x|5)) (begin (.check! (vector? .v|35|38) 42 .v|35|38) (vector-length:vec .v|35|38)))) (.budget|22 (quotient .budget|5 4))) (if (> .n|22 0) (.combine|4 (.combine|4 (.hash-on-equal|4 (let ((.v|23|26 .x|5) (.i|23|26 0)) (begin (.check! (fixnum? .i|23|26) 40 .v|23|26 .i|23|26) (.check! (vector? .v|23|26) 40 .v|23|26 .i|23|26) (.check! (<:fix:fix .i|23|26 (vector-length:vec .v|23|26)) 40 .v|23|26 .i|23|26) (.check! (>=:fix:fix .i|23|26 0) 40 .v|23|26 .i|23|26) (vector-ref:trusted .v|23|26 .i|23|26))) .budget|22) (.hash-on-equal|4 (let ((.v|27|30 .x|5) (.i|27|30 (- .n|22 1))) (begin (.check! (fixnum? .i|27|30) 40 .v|27|30 .i|27|30) (.check! (vector? .v|27|30) 40 .v|27|30 .i|27|30) (.check! (<:fix:fix .i|27|30 (vector-length:vec .v|27|30)) 40 .v|27|30 .i|27|30) (.check! (>=:fix:fix .i|27|30 0) 40 .v|27|30 .i|27|30) (vector-ref:trusted .v|27|30 .i|27|30))) .budget|22)) (.hash-on-equal|4 (let ((.v|31|34 .x|5) (.i|31|34 (quotient .n|22 2))) (begin (.check! (fixnum? .i|31|34) 40 .v|31|34 .i|31|34) (.check! (vector? .v|31|34) 40 .v|31|34 .i|31|34) (.check! (<:fix:fix .i|31|34 (vector-length:vec .v|31|34)) 40 .v|31|34 .i|31|34) (.check! (>=:fix:fix .i|31|34 0) 40 .v|31|34 .i|31|34) (vector-ref:trusted .v|31|34 .i|31|34))) (+ .budget|22 .budget|22))) .adj:vector|3)) (object-hash .x|5)))) .adj:weird|3))) (set! .combine|4 (lambda (.hash|40 .adjustment|40) (modulo (+ (+ (+ .hash|40 .hash|40) .hash|40) .adjustment|40) 16777216))) (set! object-hash (lambda (.x|43) (if (symbol? .x|43) (symbol-hash .x|43) (if (number? .x|43) (if (exact? .x|43) (if (integer? .x|43) (if (< .x|43 0) (.combine|4 (object-hash (- 0 .x|43)) .adj:negative|3) (if (< .x|43 .n|3) (.combine|4 .x|43 .adj:fixnum|3) (.combine|4 (modulo .x|43 .n|3) .adj:large|3))) (if (rational? .x|43) (.combine|4 (.combine|4 (object-hash (numerator .x|43)) .adj:ratnum|3) (object-hash (denominator .x|43))) (if (real? .x|43) .adj:weird|3 (if (complex? .x|43) (.combine|4 (.combine|4 (object-hash (real-part .x|43)) .adj:complex|3) (object-hash (imag-part .x|43))) .adj:weird|3)))) (if #t .adj:flonum|3 (if (rational? .x|43) (.combine|4 (.combine|4 (object-hash (inexact->exact (numerator .x|43))) .adj:flonum|3) (object-hash (inexact->exact (denominator .x|43)))) (if (real? .x|43) .adj:weird|3 (if (complex? .x|43) (.combine|4 (.combine|4 (object-hash (real-part .x|43)) .adj:compnum|3) (object-hash (imag-part .x|43))) .adj:weird|3))))) (if (char? .x|43) (.combine|4 (char->integer .x|43) .adj:char|3) (if (string? .x|43) (.combine|4 (string-length .x|43) .adj:string|3) (if (vector? .x|43) (.combine|4 (let ((.v|64|67 .x|43)) (begin (.check! (vector? .v|64|67) 42 .v|64|67) (vector-length:vec .v|64|67))) .adj:vector|3) (if (eq? .x|43 #t) (.combine|4 1 .adj:misc|3) (if (eq? .x|43 #f) (.combine|4 2 .adj:misc|3) (if (null? .x|43) (.combine|4 3 .adj:misc|3) (if (pair? .x|43) .adj:pair|3 (if (procedure? .x|43) .adj:proc|3 (if (input-port? .x|43) .adj:iport|3 (if (output-port? .x|43) .adj:oport|3 .adj:weird|3)))))))))))))) (set! equal-hash (lambda (.x|76) (.hash-on-equal|4 .x|76 .budget0|3)))))))
+(let () (begin (set! make-hashtable (lambda .args|1 '*)) 'make-hashtable))
+(let () (begin (set! hashtable-contains? (lambda (.ht|1 .key|1) #f)) 'hashtable-contains?))
+(let () (begin (set! hashtable-fetch (lambda (.ht|1 .key|1 .flag|1) .flag|1)) 'hashtable-fetch))
+(let () (begin (set! hashtable-get (lambda (.ht|1 .key|1) (hashtable-fetch .ht|1 .key|1 #f))) 'hashtable-get))
+(let () (begin (set! hashtable-put! (lambda (.ht|1 .key|1 .val|1) '*)) 'hashtable-put!))
+(let () (begin (set! hashtable-remove! (lambda (.ht|1 .key|1) '*)) 'hashtable-remove!))
+(let () (begin (set! hashtable-clear! (lambda (.ht|1) '*)) 'hashtable-clear!))
+(let () (begin (set! hashtable-size (lambda (.ht|1) 0)) 'hashtable-size))
+(let () (begin (set! hashtable-for-each (lambda (.ht|1 .proc|1) '*)) 'hashtable-for-each))
+(let () (begin (set! hashtable-map (lambda (.ht|1 .proc|1) '())) 'hashtable-map))
+(let () (begin (set! hashtable-copy (lambda (.ht|1) .ht|1)) 'hashtable-copy))
+(let () (let ((.doc|3 (cons "HASHTABLE" '())) (.count|3 (lambda (.ht|484) (let ((.v|485|488 .ht|484) (.i|485|488 1)) (begin (.check! (fixnum? .i|485|488) 40 .v|485|488 .i|485|488) (.check! (vector? .v|485|488) 40 .v|485|488 .i|485|488) (.check! (<:fix:fix .i|485|488 (vector-length:vec .v|485|488)) 40 .v|485|488 .i|485|488) (.check! (>=:fix:fix .i|485|488 0) 40 .v|485|488 .i|485|488) (vector-ref:trusted .v|485|488 .i|485|488))))) (.count!|3 (lambda (.ht|489 .n|489) (let ((.v|490|493 .ht|489) (.i|490|493 1) (.x|490|493 .n|489)) (begin (.check! (fixnum? .i|490|493) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (vector? .v|490|493) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (<:fix:fix .i|490|493 (vector-length:vec .v|490|493)) 41 .v|490|493 .i|490|493 .x|490|493) (.check! (>=:fix:fix .i|490|493 0) 41 .v|490|493 .i|490|493 .x|490|493) (vector-set!:trusted .v|490|493 .i|490|493 .x|490|493))))) (.hasher|3 (lambda (.ht|494) (let ((.v|495|498 .ht|494) (.i|495|498 2)) (begin (.check! (fixnum? .i|495|498) 40 .v|495|498 .i|495|498) (.check! (vector? .v|495|498) 40 .v|495|498 .i|495|498) (.check! (<:fix:fix .i|495|498 (vector-length:vec .v|495|498)) 40 .v|495|498 .i|495|498) (.check! (>=:fix:fix .i|495|498 0) 40 .v|495|498 .i|495|498) (vector-ref:trusted .v|495|498 .i|495|498))))) (.searcher|3 (lambda (.ht|499) (let ((.v|500|503 .ht|499) (.i|500|503 3)) (begin (.check! (fixnum? .i|500|503) 40 .v|500|503 .i|500|503) (.check! (vector? .v|500|503) 40 .v|500|503 .i|500|503) (.check! (<:fix:fix .i|500|503 (vector-length:vec .v|500|503)) 40 .v|500|503 .i|500|503) (.check! (>=:fix:fix .i|500|503 0) 40 .v|500|503 .i|500|503) (vector-ref:trusted .v|500|503 .i|500|503))))) (.buckets|3 (lambda (.ht|504) (let ((.v|505|508 .ht|504) (.i|505|508 4)) (begin (.check! (fixnum? .i|505|508) 40 .v|505|508 .i|505|508) (.check! (vector? .v|505|508) 40 .v|505|508 .i|505|508) (.check! (<:fix:fix .i|505|508 (vector-length:vec .v|505|508)) 40 .v|505|508 .i|505|508) (.check! (>=:fix:fix .i|505|508 0) 40 .v|505|508 .i|505|508) (vector-ref:trusted .v|505|508 .i|505|508))))) (.buckets!|3 (lambda (.ht|509 .v|509) (let ((.v|510|513 .ht|509) (.i|510|513 4) (.x|510|513 .v|509)) (begin (.check! (fixnum? .i|510|513) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (vector? .v|510|513) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (<:fix:fix .i|510|513 (vector-length:vec .v|510|513)) 41 .v|510|513 .i|510|513 .x|510|513) (.check! (>=:fix:fix .i|510|513 0) 41 .v|510|513 .i|510|513 .x|510|513) (vector-set!:trusted .v|510|513 .i|510|513 .x|510|513))))) (.defaultn|3 10)) (let ((.hashtable?|6 (lambda (.ht|470) (if (vector? .ht|470) (if (= 5 (let ((.v|473|476 .ht|470)) (begin (.check! (vector? .v|473|476) 42 .v|473|476) (vector-length:vec .v|473|476)))) (eq? .doc|3 (let ((.v|478|481 .ht|470) (.i|478|481 0)) (begin (.check! (fixnum? .i|478|481) 40 .v|478|481 .i|478|481) (.check! (vector? .v|478|481) 40 .v|478|481 .i|478|481) (.check! (<:fix:fix .i|478|481 (vector-length:vec .v|478|481)) 40 .v|478|481 .i|478|481) (.check! (>=:fix:fix .i|478|481 0) 40 .v|478|481 .i|478|481) (vector-ref:trusted .v|478|481 .i|478|481)))) #f) #f))) (.hashtable-error|6 (lambda (.x|482) (begin (display "ERROR: Bad hash table: ") (newline) (write .x|482) (newline))))) (let ((.ht-copy|7 (unspecified)) (.ht-map|7 (unspecified)) (.ht-for-each|7 (unspecified)) (.size|7 (unspecified)) (.clear!|7 (unspecified)) (.remove!|7 (unspecified)) (.put!|7 (unspecified)) (.fetch|7 (unspecified)) (.contains?|7 (unspecified)) (.contents|7 (unspecified)) (.resize|7 (unspecified)) (.remq1|7 (unspecified)) (.substitute1|7 (unspecified)) (.make-ht|7 (unspecified))) (begin (set! .ht-copy|7 (lambda (.ht|8) (if (.hashtable?|6 .ht|8) (let* ((.newtable|11 (make-hashtable (.hasher|3 .ht|8) (.searcher|3 .ht|8) 0)) (.v|14 (.buckets|3 .ht|8)) (.n|17 (let ((.v|42|45 .v|14)) (begin (.check! (vector? .v|42|45) 42 .v|42|45) (vector-length:vec .v|42|45)))) (.newvector|20 (make-vector .n|17 '()))) (let () (begin (.count!|3 .newtable|11 (.count|3 .ht|8)) (.buckets!|3 .newtable|11 .newvector|20) (let () (let ((.loop|25|27|30 (unspecified))) (begin (set! .loop|25|27|30 (lambda (.i|31) (if (= .i|31 .n|17) (if #f #f (unspecified)) (begin (begin #t (let ((.v|34|37 .newvector|20) (.i|34|37 .i|31) (.x|34|37 (append (let ((.v|38|41 .v|14) (.i|38|41 .i|31)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))) '()))) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37)))) (.loop|25|27|30 (+ .i|31 1)))))) (.loop|25|27|30 0)))) .newtable|11))) (.hashtable-error|6 .ht|8)))) (set! .ht-map|7 (lambda (.f|46 .ht|46) (if (.hashtable?|6 .ht|46) (let* ((.v|49 (.contents|7 .ht|46)) (.n|52 (let ((.v|81|84 .v|49)) (begin (.check! (vector? .v|81|84) 42 .v|81|84) (vector-length:vec .v|81|84))))) (let () (let () (let ((.loop|56|59|62 (unspecified))) (begin (set! .loop|56|59|62 (lambda (.j|63 .results|63) (if (= .j|63 .n|52) (reverse .results|63) (begin #t (.loop|56|59|62 (+ .j|63 1) (let ((.x|68 (let ((.v|77|80 .v|49) (.i|77|80 .j|63)) (begin (.check! (fixnum? .i|77|80) 40 .v|77|80 .i|77|80) (.check! (vector? .v|77|80) 40 .v|77|80 .i|77|80) (.check! (<:fix:fix .i|77|80 (vector-length:vec .v|77|80)) 40 .v|77|80 .i|77|80) (.check! (>=:fix:fix .i|77|80 0) 40 .v|77|80 .i|77|80) (vector-ref:trusted .v|77|80 .i|77|80))))) (cons (.f|46 (let ((.x|69|72 .x|68)) (begin (.check! (pair? .x|69|72) 0 .x|69|72) (car:pair .x|69|72))) (let ((.x|73|76 .x|68)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76)))) .results|63))))))) (.loop|56|59|62 0 '())))))) (.hashtable-error|6 .ht|46)))) (set! .ht-for-each|7 (lambda (.f|85 .ht|85) (if (.hashtable?|6 .ht|85) (let* ((.v|88 (.contents|7 .ht|85)) (.n|91 (let ((.v|120|123 .v|88)) (begin (.check! (vector? .v|120|123) 42 .v|120|123) (vector-length:vec .v|120|123))))) (let () (let () (let ((.loop|96|98|101 (unspecified))) (begin (set! .loop|96|98|101 (lambda (.j|102) (if (= .j|102 .n|91) (if #f #f (unspecified)) (begin (begin #t (let ((.x|107 (let ((.v|116|119 .v|88) (.i|116|119 .j|102)) (begin (.check! (fixnum? .i|116|119) 40 .v|116|119 .i|116|119) (.check! (vector? .v|116|119) 40 .v|116|119 .i|116|119) (.check! (<:fix:fix .i|116|119 (vector-length:vec .v|116|119)) 40 .v|116|119 .i|116|119) (.check! (>=:fix:fix .i|116|119 0) 40 .v|116|119 .i|116|119) (vector-ref:trusted .v|116|119 .i|116|119))))) (.f|85 (let ((.x|108|111 .x|107)) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111))) (let ((.x|112|115 .x|107)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115)))))) (.loop|96|98|101 (+ .j|102 1)))))) (.loop|96|98|101 0)))))) (.hashtable-error|6 .ht|85)))) (set! .size|7 (lambda (.ht|124) (if (.hashtable?|6 .ht|124) (.count|3 .ht|124) (.hashtable-error|6 .ht|124)))) (set! .clear!|7 (lambda (.ht|125) (if (.hashtable?|6 .ht|125) (call-without-interrupts (lambda () (begin (.count!|3 .ht|125 0) (.buckets!|3 .ht|125 (make-vector .defaultn|3 '())) #f))) (.hashtable-error|6 .ht|125)))) (set! .remove!|7 (lambda (.ht|127 .key|127) (if (.hashtable?|6 .ht|127) (call-without-interrupts (lambda () (let* ((.v|131 (.buckets|3 .ht|127)) (.n|134 (let ((.v|155|158 .v|131)) (begin (.check! (vector? .v|155|158) 42 .v|155|158) (vector-length:vec .v|155|158)))) (.h|137 (modulo ((.hasher|3 .ht|127) .key|127) .n|134)) (.b|140 (let ((.v|151|154 .v|131) (.i|151|154 .h|137)) (begin (.check! (fixnum? .i|151|154) 40 .v|151|154 .i|151|154) (.check! (vector? .v|151|154) 40 .v|151|154 .i|151|154) (.check! (<:fix:fix .i|151|154 (vector-length:vec .v|151|154)) 40 .v|151|154 .i|151|154) (.check! (>=:fix:fix .i|151|154 0) 40 .v|151|154 .i|151|154) (vector-ref:trusted .v|151|154 .i|151|154)))) (.probe|143 ((.searcher|3 .ht|127) .key|127 .b|140))) (let () (begin (if .probe|143 (begin (.count!|3 .ht|127 (- (.count|3 .ht|127) 1)) (let ((.v|147|150 .v|131) (.i|147|150 .h|137) (.x|147|150 (.remq1|7 .probe|143 .b|140))) (begin (.check! (fixnum? .i|147|150) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (vector? .v|147|150) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (<:fix:fix .i|147|150 (vector-length:vec .v|147|150)) 41 .v|147|150 .i|147|150 .x|147|150) (.check! (>=:fix:fix .i|147|150 0) 41 .v|147|150 .i|147|150 .x|147|150) (vector-set!:trusted .v|147|150 .i|147|150 .x|147|150))) (if (< (* 2 (+ .defaultn|3 (.count|3 .ht|127))) .n|134) (.resize|7 .ht|127) (unspecified))) (unspecified)) #f))))) (.hashtable-error|6 .ht|127)))) (set! .put!|7 (lambda (.ht|159 .key|159 .val|159) (if (.hashtable?|6 .ht|159) (call-without-interrupts (lambda () (begin (let* ((.v|163 (.buckets|3 .ht|159)) (.n|166 (let ((.v|191|194 .v|163)) (begin (.check! (vector? .v|191|194) 42 .v|191|194) (vector-length:vec .v|191|194)))) (.h|169 (modulo ((.hasher|3 .ht|159) .key|159) .n|166)) (.b|172 (let ((.v|187|190 .v|163) (.i|187|190 .h|169)) (begin (.check! (fixnum? .i|187|190) 40 .v|187|190 .i|187|190) (.check! (vector? .v|187|190) 40 .v|187|190 .i|187|190) (.check! (<:fix:fix .i|187|190 (vector-length:vec .v|187|190)) 40 .v|187|190 .i|187|190) (.check! (>=:fix:fix .i|187|190 0) 40 .v|187|190 .i|187|190) (vector-ref:trusted .v|187|190 .i|187|190)))) (.probe|175 ((.searcher|3 .ht|159) .key|159 .b|172))) (let () (if .probe|175 (let ((.v|179|182 .v|163) (.i|179|182 .h|169) (.x|179|182 (.substitute1|7 (cons .key|159 .val|159) .probe|175 .b|172))) (begin (.check! (fixnum? .i|179|182) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (vector? .v|179|182) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (<:fix:fix .i|179|182 (vector-length:vec .v|179|182)) 41 .v|179|182 .i|179|182 .x|179|182) (.check! (>=:fix:fix .i|179|182 0) 41 .v|179|182 .i|179|182 .x|179|182) (vector-set!:trusted .v|179|182 .i|179|182 .x|179|182))) (begin (.count!|3 .ht|159 (+ (.count|3 .ht|159) 1)) (let ((.v|183|186 .v|163) (.i|183|186 .h|169) (.x|183|186 (cons (cons .key|159 .val|159) .b|172))) (begin (.check! (fixnum? .i|183|186) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (vector? .v|183|186) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (<:fix:fix .i|183|186 (vector-length:vec .v|183|186)) 41 .v|183|186 .i|183|186 .x|183|186) (.check! (>=:fix:fix .i|183|186 0) 41 .v|183|186 .i|183|186 .x|183|186) (vector-set!:trusted .v|183|186 .i|183|186 .x|183|186))) (if (> (.count|3 .ht|159) .n|166) (.resize|7 .ht|159) (unspecified)))))) #f))) (.hashtable-error|6 .ht|159)))) (set! .fetch|7 (lambda (.ht|195 .key|195 .flag|195) (if (.hashtable?|6 .ht|195) (let* ((.v|198 (.buckets|3 .ht|195)) (.n|201 (let ((.v|222|225 .v|198)) (begin (.check! (vector? .v|222|225) 42 .v|222|225) (vector-length:vec .v|222|225)))) (.h|204 (modulo ((.hasher|3 .ht|195) .key|195) .n|201)) (.b|207 (let ((.v|218|221 .v|198) (.i|218|221 .h|204)) (begin (.check! (fixnum? .i|218|221) 40 .v|218|221 .i|218|221) (.check! (vector? .v|218|221) 40 .v|218|221 .i|218|221) (.check! (<:fix:fix .i|218|221 (vector-length:vec .v|218|221)) 40 .v|218|221 .i|218|221) (.check! (>=:fix:fix .i|218|221 0) 40 .v|218|221 .i|218|221) (vector-ref:trusted .v|218|221 .i|218|221)))) (.probe|210 ((.searcher|3 .ht|195) .key|195 .b|207))) (let () (if .probe|210 (let ((.x|214|217 .probe|210)) (begin (.check! (pair? .x|214|217) 1 .x|214|217) (cdr:pair .x|214|217))) .flag|195))) (.hashtable-error|6 .ht|195)))) (set! .contains?|7 (lambda (.ht|226 .key|226) (if (.hashtable?|6 .ht|226) (let* ((.v|229 (.buckets|3 .ht|226)) (.n|232 (let ((.v|246|249 .v|229)) (begin (.check! (vector? .v|246|249) 42 .v|246|249) (vector-length:vec .v|246|249)))) (.h|235 (modulo ((.hasher|3 .ht|226) .key|226) .n|232)) (.b|238 (let ((.v|242|245 .v|229) (.i|242|245 .h|235)) (begin (.check! (fixnum? .i|242|245) 40 .v|242|245 .i|242|245) (.check! (vector? .v|242|245) 40 .v|242|245 .i|242|245) (.check! (<:fix:fix .i|242|245 (vector-length:vec .v|242|245)) 40 .v|242|245 .i|242|245) (.check! (>=:fix:fix .i|242|245 0) 40 .v|242|245 .i|242|245) (vector-ref:trusted .v|242|245 .i|242|245))))) (let () (if ((.searcher|3 .ht|226) .key|226 .b|238) #t #f))) (.hashtable-error|6 .ht|226)))) (set! .contents|7 (lambda (.ht|250) (let* ((.v|253 (.buckets|3 .ht|250)) (.n|256 (let ((.v|296|299 .v|253)) (begin (.check! (vector? .v|296|299) 42 .v|296|299) (vector-length:vec .v|296|299)))) (.z|259 (make-vector (.count|3 .ht|250) '()))) (let () (let ((.loop|263 (unspecified))) (begin (set! .loop|263 (lambda (.i|264 .bucket|264 .j|264) (if (null? .bucket|264) (if (= .i|264 .n|256) (if (= .j|264 (let ((.v|265|268 .z|259)) (begin (.check! (vector? .v|265|268) 42 .v|265|268) (vector-length:vec .v|265|268)))) .z|259 (begin (display "BUG in hashtable") (newline) '#())) (.loop|263 (+ .i|264 1) (let ((.v|269|272 .v|253) (.i|269|272 .i|264)) (begin (.check! (fixnum? .i|269|272) 40 .v|269|272 .i|269|272) (.check! (vector? .v|269|272) 40 .v|269|272 .i|269|272) (.check! (<:fix:fix .i|269|272 (vector-length:vec .v|269|272)) 40 .v|269|272 .i|269|272) (.check! (>=:fix:fix .i|269|272 0) 40 .v|269|272 .i|269|272) (vector-ref:trusted .v|269|272 .i|269|272))) .j|264)) (let ((.entry|275 (let ((.x|292|295 .bucket|264)) (begin (.check! (pair? .x|292|295) 0 .x|292|295) (car:pair .x|292|295))))) (begin (let ((.v|276|279 .z|259) (.i|276|279 .j|264) (.x|276|279 (cons (let ((.x|280|283 .entry|275)) (begin (.check! (pair? .x|280|283) 0 .x|280|283) (car:pair .x|280|283))) (let ((.x|284|287 .entry|275)) (begin (.check! (pair? .x|284|287) 1 .x|284|287) (cdr:pair .x|284|287)))))) (begin (.check! (fixnum? .i|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (vector? .v|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (<:fix:fix .i|276|279 (vector-length:vec .v|276|279)) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (>=:fix:fix .i|276|279 0) 41 .v|276|279 .i|276|279 .x|276|279) (vector-set!:trusted .v|276|279 .i|276|279 .x|276|279))) (.loop|263 .i|264 (let ((.x|288|291 .bucket|264)) (begin (.check! (pair? .x|288|291) 1 .x|288|291) (cdr:pair .x|288|291))) (+ .j|264 1))))))) (.loop|263 0 '() 0))))))) (set! .resize|7 (lambda (.ht0|300) (call-without-interrupts (lambda () (let ((.ht|304 (.make-ht|7 (.hasher|3 .ht0|300) (.searcher|3 .ht0|300) (+ 1 (* 2 (.count|3 .ht0|300)))))) (begin (.ht-for-each|7 (lambda (.key|305 .val|305) (.put!|7 .ht|304 .key|305 .val|305)) .ht0|300) (.buckets!|3 .ht0|300 (.buckets|3 .ht|304)))))))) (set! .remq1|7 (lambda (.x|306 .y|306) (if (eq? .x|306 (let ((.x|308|311 .y|306)) (begin (.check! (pair? .x|308|311) 0 .x|308|311) (car:pair .x|308|311)))) (let ((.x|312|315 .y|306)) (begin (.check! (pair? .x|312|315) 1 .x|312|315) (cdr:pair .x|312|315))) (cons (let ((.x|317|320 .y|306)) (begin (.check! (pair? .x|317|320) 0 .x|317|320) (car:pair .x|317|320))) (.remq1|7 .x|306 (let ((.x|321|324 .y|306)) (begin (.check! (pair? .x|321|324) 1 .x|321|324) (cdr:pair .x|321|324)))))))) (set! .substitute1|7 (lambda (.x|325 .y|325 .z|325) (if (eq? .y|325 (let ((.x|327|330 .z|325)) (begin (.check! (pair? .x|327|330) 0 .x|327|330) (car:pair .x|327|330)))) (cons .x|325 (let ((.x|331|334 .z|325)) (begin (.check! (pair? .x|331|334) 1 .x|331|334) (cdr:pair .x|331|334)))) (cons (let ((.x|336|339 .z|325)) (begin (.check! (pair? .x|336|339) 0 .x|336|339) (car:pair .x|336|339))) (.substitute1|7 .x|325 .y|325 (let ((.x|340|343 .z|325)) (begin (.check! (pair? .x|340|343) 1 .x|340|343) (cdr:pair .x|340|343)))))))) (set! .make-ht|7 (lambda (.hashfun|344 .searcher|344 .size|344) (let* ((.t|345|350|355 (make-vector .size|344 '())) (.t|345|349|358 .searcher|344) (.t|345|348|361 .hashfun|344) (.t|345|347|364 0) (.t|345|346|367 .doc|3) (.v|345|352|370 (make-vector 5 .t|345|350|355))) (let () (begin (let ((.v|374|377 .v|345|352|370) (.i|374|377 3) (.x|374|377 .t|345|349|358)) (begin (.check! (fixnum? .i|374|377) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (vector? .v|374|377) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (<:fix:fix .i|374|377 (vector-length:vec .v|374|377)) 41 .v|374|377 .i|374|377 .x|374|377) (.check! (>=:fix:fix .i|374|377 0) 41 .v|374|377 .i|374|377 .x|374|377) (vector-set!:trusted .v|374|377 .i|374|377 .x|374|377))) (let ((.v|378|381 .v|345|352|370) (.i|378|381 2) (.x|378|381 .t|345|348|361)) (begin (.check! (fixnum? .i|378|381) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (vector? .v|378|381) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (<:fix:fix .i|378|381 (vector-length:vec .v|378|381)) 41 .v|378|381 .i|378|381 .x|378|381) (.check! (>=:fix:fix .i|378|381 0) 41 .v|378|381 .i|378|381 .x|378|381) (vector-set!:trusted .v|378|381 .i|378|381 .x|378|381))) (let ((.v|382|385 .v|345|352|370) (.i|382|385 1) (.x|382|385 .t|345|347|364)) (begin (.check! (fixnum? .i|382|385) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (vector? .v|382|385) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (<:fix:fix .i|382|385 (vector-length:vec .v|382|385)) 41 .v|382|385 .i|382|385 .x|382|385) (.check! (>=:fix:fix .i|382|385 0) 41 .v|382|385 .i|382|385 .x|382|385) (vector-set!:trusted .v|382|385 .i|382|385 .x|382|385))) (let ((.v|386|389 .v|345|352|370) (.i|386|389 0) (.x|386|389 .t|345|346|367)) (begin (.check! (fixnum? .i|386|389) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (vector? .v|386|389) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (<:fix:fix .i|386|389 (vector-length:vec .v|386|389)) 41 .v|386|389 .i|386|389 .x|386|389) (.check! (>=:fix:fix .i|386|389 0) 41 .v|386|389 .i|386|389 .x|386|389) (vector-set!:trusted .v|386|389 .i|386|389 .x|386|389))) .v|345|352|370))))) (set! make-hashtable (lambda .args|390 (let* ((.hashfun|393 (if (null? .args|390) object-hash (let ((.x|456|459 .args|390)) (begin (.check! (pair? .x|456|459) 0 .x|456|459) (car:pair .x|456|459))))) (.searcher|396 (if (let ((.temp|438|441 (null? .args|390))) (if .temp|438|441 .temp|438|441 (null? (let ((.x|443|446 .args|390)) (begin (.check! (pair? .x|443|446) 1 .x|443|446) (cdr:pair .x|443|446)))))) assv (let ((.x|448|451 (let ((.x|452|455 .args|390)) (begin (.check! (pair? .x|452|455) 1 .x|452|455) (cdr:pair .x|452|455))))) (begin (.check! (pair? .x|448|451) 0 .x|448|451) (car:pair .x|448|451))))) (.size|399 (if (let ((.temp|403|406 (null? .args|390))) (if .temp|403|406 .temp|403|406 (let ((.temp|407|410 (null? (let ((.x|421|424 .args|390)) (begin (.check! (pair? .x|421|424) 1 .x|421|424) (cdr:pair .x|421|424)))))) (if .temp|407|410 .temp|407|410 (null? (let ((.x|413|416 (let ((.x|417|420 .args|390)) (begin (.check! (pair? .x|417|420) 1 .x|417|420) (cdr:pair .x|417|420))))) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416)))))))) .defaultn|3 (let ((.x|426|429 (let ((.x|430|433 (let ((.x|434|437 .args|390)) (begin (.check! (pair? .x|434|437) 1 .x|434|437) (cdr:pair .x|434|437))))) (begin (.check! (pair? .x|430|433) 1 .x|430|433) (cdr:pair .x|430|433))))) (begin (.check! (pair? .x|426|429) 0 .x|426|429) (car:pair .x|426|429)))))) (let () (.make-ht|7 .hashfun|393 .searcher|396 .size|399))))) (set! hashtable-contains? (lambda (.ht|460 .key|460) (.contains?|7 .ht|460 .key|460))) (set! hashtable-fetch (lambda (.ht|461 .key|461 .flag|461) (.fetch|7 .ht|461 .key|461 .flag|461))) (set! hashtable-get (lambda (.ht|462 .key|462) (.fetch|7 .ht|462 .key|462 #f))) (set! hashtable-put! (lambda (.ht|463 .key|463 .val|463) (.put!|7 .ht|463 .key|463 .val|463))) (set! hashtable-remove! (lambda (.ht|464 .key|464) (.remove!|7 .ht|464 .key|464))) (set! hashtable-clear! (lambda (.ht|465) (.clear!|7 .ht|465))) (set! hashtable-size (lambda (.ht|466) (.size|7 .ht|466))) (set! hashtable-for-each (lambda (.ht|467 .proc|467) (.ht-for-each|7 .ht|467 .proc|467))) (set! hashtable-map (lambda (.ht|468 .proc|468) (.ht-map|7 .ht|468 .proc|468))) (set! hashtable-copy (lambda (.ht|469) (.ht-copy|7 .ht|469))) #f)))))
+(let () (begin (set! make-hashtree (lambda .args|1 '*)) 'make-hashtree))
+(let () (begin (set! hashtree-contains? (lambda (.ht|1 .key|1) #f)) 'hashtree-contains?))
+(let () (begin (set! hashtree-fetch (lambda (.ht|1 .key|1 .flag|1) .flag|1)) 'hashtree-fetch))
+(let () (begin (set! hashtree-get (lambda (.ht|1 .key|1) (hashtree-fetch .ht|1 .key|1 #f))) 'hashtree-get))
+(let () (begin (set! hashtree-put (lambda (.ht|1 .key|1 .val|1) '*)) 'hashtree-put))
+(let () (begin (set! hashtree-remove (lambda (.ht|1 .key|1) '*)) 'hashtree-remove))
+(let () (begin (set! hashtree-size (lambda (.ht|1) 0)) 'hashtree-size))
+(let () (begin (set! hashtree-for-each (lambda (.ht|1 .proc|1) '*)) 'hashtree-for-each))
+(let () (begin (set! hashtree-map (lambda (.ht|1 .proc|1) '())) 'hashtree-map))
+(let () (let ((.doc|3 (cons "hashtree" '())) (.count|3 (lambda (.ht|334) (let ((.v|335|338 .ht|334) (.i|335|338 1)) (begin (.check! (fixnum? .i|335|338) 40 .v|335|338 .i|335|338) (.check! (vector? .v|335|338) 40 .v|335|338 .i|335|338) (.check! (<:fix:fix .i|335|338 (vector-length:vec .v|335|338)) 40 .v|335|338 .i|335|338) (.check! (>=:fix:fix .i|335|338 0) 40 .v|335|338 .i|335|338) (vector-ref:trusted .v|335|338 .i|335|338))))) (.hasher|3 (lambda (.ht|339) (let ((.v|340|343 .ht|339) (.i|340|343 2)) (begin (.check! (fixnum? .i|340|343) 40 .v|340|343 .i|340|343) (.check! (vector? .v|340|343) 40 .v|340|343 .i|340|343) (.check! (<:fix:fix .i|340|343 (vector-length:vec .v|340|343)) 40 .v|340|343 .i|340|343) (.check! (>=:fix:fix .i|340|343 0) 40 .v|340|343 .i|340|343) (vector-ref:trusted .v|340|343 .i|340|343))))) (.searcher|3 (lambda (.ht|344) (let ((.v|345|348 .ht|344) (.i|345|348 3)) (begin (.check! (fixnum? .i|345|348) 40 .v|345|348 .i|345|348) (.check! (vector? .v|345|348) 40 .v|345|348 .i|345|348) (.check! (<:fix:fix .i|345|348 (vector-length:vec .v|345|348)) 40 .v|345|348 .i|345|348) (.check! (>=:fix:fix .i|345|348 0) 40 .v|345|348 .i|345|348) (vector-ref:trusted .v|345|348 .i|345|348))))) (.buckets|3 (lambda (.ht|349) (let ((.v|350|353 .ht|349) (.i|350|353 4)) (begin (.check! (fixnum? .i|350|353) 40 .v|350|353 .i|350|353) (.check! (vector? .v|350|353) 40 .v|350|353 .i|350|353) (.check! (<:fix:fix .i|350|353 (vector-length:vec .v|350|353)) 40 .v|350|353 .i|350|353) (.check! (>=:fix:fix .i|350|353 0) 40 .v|350|353 .i|350|353) (vector-ref:trusted .v|350|353 .i|350|353))))) (.make-empty-buckets|3 (lambda () '())) (.make-buckets|3 (lambda (.h|355 .alist|355 .buckets1|355 .buckets2|355) (let* ((.t1|356|359 .h|355) (.t2|356|362 (let* ((.t1|366|369 .alist|355) (.t2|366|372 (let* ((.t1|376|379 .buckets1|355) (.t2|376|382 (cons .buckets2|355 '()))) (let () (cons .t1|376|379 .t2|376|382))))) (let () (cons .t1|366|369 .t2|366|372))))) (let () (cons .t1|356|359 .t2|356|362))))) (.buckets-empty?|3 (lambda (.buckets|387) (null? .buckets|387))) (.buckets-n|3 (lambda (.buckets|388) (let ((.x|389|392 .buckets|388)) (begin (.check! (pair? .x|389|392) 0 .x|389|392) (car:pair .x|389|392))))) (.buckets-alist|3 (lambda (.buckets|393) (let ((.x|395|398 (let ((.x|399|402 .buckets|393)) (begin (.check! (pair? .x|399|402) 1 .x|399|402) (cdr:pair .x|399|402))))) (begin (.check! (pair? .x|395|398) 0 .x|395|398) (car:pair .x|395|398))))) (.buckets-left|3 (lambda (.buckets|403) (let ((.x|405|408 (let ((.x|409|412 (let ((.x|413|416 .buckets|403)) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416))))) (begin (.check! (pair? .x|409|412) 1 .x|409|412) (cdr:pair .x|409|412))))) (begin (.check! (pair? .x|405|408) 0 .x|405|408) (car:pair .x|405|408))))) (.buckets-right|3 (lambda (.buckets|417) (let ((.x|419|422 (let ((.x|423|426 (let ((.x|427|430 (let ((.x|431|434 .buckets|417)) (begin (.check! (pair? .x|431|434) 1 .x|431|434) (cdr:pair .x|431|434))))) (begin (.check! (pair? .x|427|430) 1 .x|427|430) (cdr:pair .x|427|430))))) (begin (.check! (pair? .x|423|426) 1 .x|423|426) (cdr:pair .x|423|426))))) (begin (.check! (pair? .x|419|422) 0 .x|419|422) (car:pair .x|419|422)))))) (let ((.hashtree?|6 (lambda (.ht|320) (if (vector? .ht|320) (if (= 5 (let ((.v|323|326 .ht|320)) (begin (.check! (vector? .v|323|326) 42 .v|323|326) (vector-length:vec .v|323|326)))) (eq? .doc|3 (let ((.v|328|331 .ht|320) (.i|328|331 0)) (begin (.check! (fixnum? .i|328|331) 40 .v|328|331 .i|328|331) (.check! (vector? .v|328|331) 40 .v|328|331 .i|328|331) (.check! (<:fix:fix .i|328|331 (vector-length:vec .v|328|331)) 40 .v|328|331 .i|328|331) (.check! (>=:fix:fix .i|328|331 0) 40 .v|328|331 .i|328|331) (vector-ref:trusted .v|328|331 .i|328|331)))) #f) #f))) (.hashtree-error|6 (lambda (.x|332) (begin (display "ERROR: Bad hash tree: ") (newline) (write .x|332) (newline))))) (let ((.ht-map|7 (unspecified)) (.ht-for-each|7 (unspecified)) (.size|7 (unspecified)) (.remove|7 (unspecified)) (.put|7 (unspecified)) (.find-bucket|7 (unspecified)) (.fetch|7 (unspecified)) (.contains?|7 (unspecified)) (.contents|7 (unspecified)) (.remq1|7 (unspecified)) (.substitute1|7 (unspecified)) (.make-ht|7 (unspecified))) (begin (set! .ht-map|7 (lambda (.f|8 .ht|8) (if (.hashtree?|6 .ht|8) (let () (let ((.loop|14|17|20 (unspecified))) (begin (set! .loop|14|17|20 (lambda (.y1|9|10|21 .results|9|13|21) (if (null? .y1|9|10|21) (reverse .results|9|13|21) (begin #t (.loop|14|17|20 (let ((.x|25|28 .y1|9|10|21)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) (cons (let ((.association|29 (let ((.x|38|41 .y1|9|10|21)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (.f|8 (let ((.x|30|33 .association|29)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|34|37 .association|29)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) .results|9|13|21)))))) (.loop|14|17|20 (.contents|7 .ht|8) '())))) (.hashtree-error|6 .ht|8)))) (set! .ht-for-each|7 (lambda (.f|42 .ht|42) (if (.hashtree?|6 .ht|42) (let () (let ((.loop|48|50|53 (unspecified))) (begin (set! .loop|48|50|53 (lambda (.y1|43|44|54) (if (null? .y1|43|44|54) (if #f #f (unspecified)) (begin (begin #t (let ((.association|58 (let ((.x|67|70 .y1|43|44|54)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (.f|42 (let ((.x|59|62 .association|58)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|63|66 .association|58)) (begin (.check! (pair? .x|63|66) 1 .x|63|66) (cdr:pair .x|63|66)))))) (.loop|48|50|53 (let ((.x|71|74 .y1|43|44|54)) (begin (.check! (pair? .x|71|74) 1 .x|71|74) (cdr:pair .x|71|74)))))))) (.loop|48|50|53 (.contents|7 .ht|42))))) (.hashtree-error|6 .ht|42)))) (set! .size|7 (lambda (.ht|75) (if (.hashtree?|6 .ht|75) (.count|3 .ht|75) (.hashtree-error|6 .ht|75)))) (set! .remove|7 (lambda (.ht|76 .key|76) (if (.hashtree?|6 .ht|76) (let ((.t|79 (.buckets|3 .ht|76)) (.h|79 ((.hasher|3 .ht|76) .key|76)) (.c|79 (.count|3 .ht|76))) (let ((.remove|82 (unspecified))) (begin (set! .remove|82 (lambda (.t|83 .h|83) (if (.buckets-empty?|3 .t|83) .t|83 (let ((.n|86 (.buckets-n|3 .t|83)) (.alist|86 (.buckets-alist|3 .t|83)) (.left|86 (.buckets-left|3 .t|83)) (.right|86 (.buckets-right|3 .t|83))) (if (< .h|83 .n|86) (.make-buckets|3 .n|86 .alist|86 (.remove|82 .left|86 .h|83) .right|86) (if (< .n|86 .h|83) (.make-buckets|3 .n|86 .alist|86 .left|86 (.remove|82 .right|86 .h|83)) (let ((.probe|92 ((.searcher|3 .ht|76) .key|76 .alist|86))) (if .probe|92 (begin (set! .c|79 (- .c|79 1)) (.make-buckets|3 .n|86 (.remq1|7 .probe|92 .alist|86) .left|86 .right|86)) .t|83)))))))) (let ((.buckets|93 (.remove|82 .t|79 .h|79))) (.make-ht|7 .c|79 (.hasher|3 .ht|76) (.searcher|3 .ht|76) .buckets|93))))) (.hashtree-error|6 .ht|76)))) (set! .put|7 (lambda (.ht|94 .key|94 .val|94) (if (.hashtree?|6 .ht|94) (let ((.t|97 (.buckets|3 .ht|94)) (.h|97 ((.hasher|3 .ht|94) .key|94)) (.association|97 (cons .key|94 .val|94)) (.c|97 (.count|3 .ht|94))) (let ((.put|100 (unspecified))) (begin (set! .put|100 (lambda (.t|101 .h|101) (if (.buckets-empty?|3 .t|101) (begin (set! .c|97 (+ .c|97 1)) (.make-buckets|3 .h|101 (cons .association|97 '()) .t|101 .t|101)) (let ((.n|105 (.buckets-n|3 .t|101)) (.alist|105 (.buckets-alist|3 .t|101)) (.left|105 (.buckets-left|3 .t|101)) (.right|105 (.buckets-right|3 .t|101))) (if (< .h|101 .n|105) (.make-buckets|3 .n|105 .alist|105 (.put|100 (.buckets-left|3 .t|101) .h|101) .right|105) (if (< .n|105 .h|101) (.make-buckets|3 .n|105 .alist|105 .left|105 (.put|100 (.buckets-right|3 .t|101) .h|101)) (let ((.probe|111 ((.searcher|3 .ht|94) .key|94 .alist|105))) (if .probe|111 (.make-buckets|3 .n|105 (.substitute1|7 .association|97 .probe|111 .alist|105) .left|105 .right|105) (begin (set! .c|97 (+ .c|97 1)) (.make-buckets|3 .n|105 (cons .association|97 .alist|105) .left|105 .right|105)))))))))) (let ((.buckets|112 (.put|100 .t|97 .h|97))) (.make-ht|7 .c|97 (.hasher|3 .ht|94) (.searcher|3 .ht|94) .buckets|112))))) (.hashtree-error|6 .ht|94)))) (set! .find-bucket|7 (lambda (.t|113 .h|113) (if (.buckets-empty?|3 .t|113) '() (let ((.n|116 (.buckets-n|3 .t|113))) (if (< .h|113 .n|116) (.find-bucket|7 (.buckets-left|3 .t|113) .h|113) (if (< .n|116 .h|113) (.find-bucket|7 (.buckets-right|3 .t|113) .h|113) (.buckets-alist|3 .t|113))))))) (set! .fetch|7 (lambda (.ht|120 .key|120 .flag|120) (if (.hashtree?|6 .ht|120) (let* ((.t|123 (.buckets|3 .ht|120)) (.h|126 ((.hasher|3 .ht|120) .key|120)) (.probe|129 ((.searcher|3 .ht|120) .key|120 (.find-bucket|7 .t|123 .h|126)))) (let () (if .probe|129 (let ((.x|133|136 .probe|129)) (begin (.check! (pair? .x|133|136) 1 .x|133|136) (cdr:pair .x|133|136))) .flag|120))) (.hashtree-error|6 .ht|120)))) (set! .contains?|7 (lambda (.ht|137 .key|137) (if (.hashtree?|6 .ht|137) (let* ((.t|140 (.buckets|3 .ht|137)) (.h|143 ((.hasher|3 .ht|137) .key|137))) (let () (if ((.searcher|3 .ht|137) .key|137 (.find-bucket|7 .t|140 .h|143)) #t #f))) (.hashtree-error|6 .ht|137)))) (set! .contents|7 (lambda (.ht|147) (let ((.t|150 (.buckets|3 .ht|147))) (let () (let ((.randomize-combine|154 (unspecified)) (.randomize3|154 (unspecified)) (.randomize2|154 (unspecified)) (.randomize1|154 (unspecified)) (.append-reverse|154 (unspecified)) (.contents|154 (unspecified))) (begin (set! .randomize-combine|154 (lambda (.alist1|155 .alist2|155 .alist3|155) (if (null? .alist2|155) .alist1|155 (if (null? .alist3|155) (.append-reverse|154 .alist2|155 .alist1|155) (.append-reverse|154 (.randomize1|154 .alist3|155 '() '() '()) (.append-reverse|154 (.randomize1|154 .alist1|155 '() '() '()) (.randomize1|154 .alist2|155 '() '() '()))))))) (set! .randomize3|154 (lambda (.alist|159 .alist1|159 .alist2|159 .alist3|159) (if (null? .alist|159) (.randomize-combine|154 .alist1|159 .alist2|159 .alist3|159) (.randomize1|154 (let ((.x|160|163 .alist|159)) (begin (.check! (pair? .x|160|163) 1 .x|160|163) (cdr:pair .x|160|163))) .alist1|159 .alist2|159 (cons (let ((.x|164|167 .alist|159)) (begin (.check! (pair? .x|164|167) 0 .x|164|167) (car:pair .x|164|167))) .alist3|159))))) (set! .randomize2|154 (lambda (.alist|168 .alist1|168 .alist2|168 .alist3|168) (if (null? .alist|168) (.randomize-combine|154 .alist1|168 .alist2|168 .alist3|168) (.randomize3|154 (let ((.x|169|172 .alist|168)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172))) .alist1|168 (cons (let ((.x|173|176 .alist|168)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176))) .alist2|168) .alist3|168)))) (set! .randomize1|154 (lambda (.alist|177 .alist1|177 .alist2|177 .alist3|177) (if (null? .alist|177) (.randomize-combine|154 .alist1|177 .alist2|177 .alist3|177) (.randomize2|154 (let ((.x|178|181 .alist|177)) (begin (.check! (pair? .x|178|181) 1 .x|178|181) (cdr:pair .x|178|181))) (cons (let ((.x|182|185 .alist|177)) (begin (.check! (pair? .x|182|185) 0 .x|182|185) (car:pair .x|182|185))) .alist1|177) .alist2|177 .alist3|177)))) (set! .append-reverse|154 (lambda (.x|186 .y|186) (if (null? .x|186) .y|186 (.append-reverse|154 (let ((.x|187|190 .x|186)) (begin (.check! (pair? .x|187|190) 1 .x|187|190) (cdr:pair .x|187|190))) (cons (let ((.x|191|194 .x|186)) (begin (.check! (pair? .x|191|194) 0 .x|191|194) (car:pair .x|191|194))) .y|186))))) (set! .contents|154 (lambda (.t|195 .alist|195) (if (.buckets-empty?|3 .t|195) .alist|195 (.contents|154 (.buckets-left|3 .t|195) (.contents|154 (.buckets-right|3 .t|195) (.append-reverse|154 (.buckets-alist|3 .t|195) .alist|195)))))) (.randomize1|154 (.contents|154 .t|150 '()) '() '() '()))))))) (set! .remq1|7 (lambda (.x|196 .y|196) (if (eq? .x|196 (let ((.x|198|201 .y|196)) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) (let ((.x|202|205 .y|196)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))) (cons (let ((.x|207|210 .y|196)) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210))) (.remq1|7 .x|196 (let ((.x|211|214 .y|196)) (begin (.check! (pair? .x|211|214) 1 .x|211|214) (cdr:pair .x|211|214)))))))) (set! .substitute1|7 (lambda (.x|215 .y|215 .z|215) (if (eq? .y|215 (let ((.x|217|220 .z|215)) (begin (.check! (pair? .x|217|220) 0 .x|217|220) (car:pair .x|217|220)))) (cons .x|215 (let ((.x|221|224 .z|215)) (begin (.check! (pair? .x|221|224) 1 .x|221|224) (cdr:pair .x|221|224)))) (cons (let ((.x|226|229 .z|215)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229))) (.substitute1|7 .x|215 .y|215 (let ((.x|230|233 .z|215)) (begin (.check! (pair? .x|230|233) 1 .x|230|233) (cdr:pair .x|230|233)))))))) (set! .make-ht|7 (lambda (.count|234 .hashfun|234 .searcher|234 .buckets|234) (let* ((.t|235|240|245 .buckets|234) (.t|235|239|248 .searcher|234) (.t|235|238|251 .hashfun|234) (.t|235|237|254 .count|234) (.t|235|236|257 .doc|3) (.v|235|242|260 (make-vector 5 .t|235|240|245))) (let () (begin (let ((.v|264|267 .v|235|242|260) (.i|264|267 3) (.x|264|267 .t|235|239|248)) (begin (.check! (fixnum? .i|264|267) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (vector? .v|264|267) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (<:fix:fix .i|264|267 (vector-length:vec .v|264|267)) 41 .v|264|267 .i|264|267 .x|264|267) (.check! (>=:fix:fix .i|264|267 0) 41 .v|264|267 .i|264|267 .x|264|267) (vector-set!:trusted .v|264|267 .i|264|267 .x|264|267))) (let ((.v|268|271 .v|235|242|260) (.i|268|271 2) (.x|268|271 .t|235|238|251)) (begin (.check! (fixnum? .i|268|271) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (vector? .v|268|271) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (<:fix:fix .i|268|271 (vector-length:vec .v|268|271)) 41 .v|268|271 .i|268|271 .x|268|271) (.check! (>=:fix:fix .i|268|271 0) 41 .v|268|271 .i|268|271 .x|268|271) (vector-set!:trusted .v|268|271 .i|268|271 .x|268|271))) (let ((.v|272|275 .v|235|242|260) (.i|272|275 1) (.x|272|275 .t|235|237|254)) (begin (.check! (fixnum? .i|272|275) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (vector? .v|272|275) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (<:fix:fix .i|272|275 (vector-length:vec .v|272|275)) 41 .v|272|275 .i|272|275 .x|272|275) (.check! (>=:fix:fix .i|272|275 0) 41 .v|272|275 .i|272|275 .x|272|275) (vector-set!:trusted .v|272|275 .i|272|275 .x|272|275))) (let ((.v|276|279 .v|235|242|260) (.i|276|279 0) (.x|276|279 .t|235|236|257)) (begin (.check! (fixnum? .i|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (vector? .v|276|279) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (<:fix:fix .i|276|279 (vector-length:vec .v|276|279)) 41 .v|276|279 .i|276|279 .x|276|279) (.check! (>=:fix:fix .i|276|279 0) 41 .v|276|279 .i|276|279 .x|276|279) (vector-set!:trusted .v|276|279 .i|276|279 .x|276|279))) .v|235|242|260))))) (set! make-hashtree (lambda .args|280 (let* ((.hashfun|283 (if (null? .args|280) object-hash (let ((.x|308|311 .args|280)) (begin (.check! (pair? .x|308|311) 0 .x|308|311) (car:pair .x|308|311))))) (.searcher|286 (if (let ((.temp|290|293 (null? .args|280))) (if .temp|290|293 .temp|290|293 (null? (let ((.x|295|298 .args|280)) (begin (.check! (pair? .x|295|298) 1 .x|295|298) (cdr:pair .x|295|298)))))) assv (let ((.x|300|303 (let ((.x|304|307 .args|280)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))))) (begin (.check! (pair? .x|300|303) 0 .x|300|303) (car:pair .x|300|303)))))) (let () (.make-ht|7 0 .hashfun|283 .searcher|286 (.make-empty-buckets|3)))))) (set! hashtree-contains? (lambda (.ht|312 .key|312) (.contains?|7 .ht|312 .key|312))) (set! hashtree-fetch (lambda (.ht|313 .key|313 .flag|313) (.fetch|7 .ht|313 .key|313 .flag|313))) (set! hashtree-get (lambda (.ht|314 .key|314) (.fetch|7 .ht|314 .key|314 #f))) (set! hashtree-put (lambda (.ht|315 .key|315 .val|315) (.put|7 .ht|315 .key|315 .val|315))) (set! hashtree-remove (lambda (.ht|316 .key|316) (.remove|7 .ht|316 .key|316))) (set! hashtree-size (lambda (.ht|317) (.size|7 .ht|317))) (set! hashtree-for-each (lambda (.ht|318 .proc|318) (.ht-for-each|7 .ht|318 .proc|318))) (set! hashtree-map (lambda (.ht|319 .proc|319) (.ht-map|7 .ht|319 .proc|319))) #f)))))
+(let () (begin (set! make-twobit-flag (undefined)) 'make-twobit-flag))
+(let () (begin (set! display-twobit-flag (undefined)) 'display-twobit-flag))
+(let () (begin (set! make-twobit-flag (lambda (.name|1) (let ((.display-flag|4 (unspecified)) (.twobit-warning|4 (unspecified))) (begin (set! .display-flag|4 (lambda (.state|5) (begin (display (if .state|5 " + " " - ")) (display .name|1) (display " is ") (display (if .state|5 "on" "off")) (newline)))) (set! .twobit-warning|4 (lambda () (begin (display "Error: incorrect arguments to ") (write .name|1) (newline) (reset)))) (let ((.state|7 #t)) (lambda .args|8 (if (null? .args|8) .state|7 (if (if (null? (let ((.x|12|15 .args|8)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15)))) (boolean? (let ((.x|17|20 .args|8)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20)))) #f) (begin (set! .state|7 (let ((.x|21|24 .args|8)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) .state|7) (if (if (null? (let ((.x|27|30 .args|8)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (eq? (let ((.x|32|35 .args|8)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) 'display) #f) (.display-flag|4 .state|7) (.twobit-warning|4)))))))))) 'make-twobit-flag))
+(let () (begin (set! display-twobit-flag (lambda (.flag|1) (let ((.display-twobit-flag|2 0)) (begin (set! .display-twobit-flag|2 (lambda (.flag|3) (.flag|3 'display))) (.display-twobit-flag|2 .flag|1))))) 'display-twobit-flag))
+(let () (begin (set! issue-warnings (make-twobit-flag 'issue-warnings)) 'issue-warnings))
+(let () (begin (set! include-source-code (make-twobit-flag 'include-source-code)) 'include-source-code))
+(let () (begin (set! include-variable-names (make-twobit-flag 'include-variable-names)) 'include-variable-names))
+(let () (begin (set! include-procedure-names (make-twobit-flag 'include-procedure-names)) 'include-procedure-names))
+(let () (begin (set! avoid-space-leaks (make-twobit-flag 'avoid-space-leaks)) 'avoid-space-leaks))
+(let () (begin (set! integrate-usual-procedures (make-twobit-flag 'integrate-usual-procedures)) 'integrate-usual-procedures))
+(let () (begin (set! control-optimization (make-twobit-flag 'control-optimization)) 'control-optimization))
+(let () (begin (set! parallel-assignment-optimization (make-twobit-flag 'parallel-assignment-optimization)) 'parallel-assignment-optimization))
+(let () (begin (set! lambda-optimization (make-twobit-flag 'lambda-optimization)) 'lambda-optimization))
+(let () (begin (set! benchmark-mode (make-twobit-flag 'benchmark-mode)) 'benchmark-mode))
+(let () (begin (set! benchmark-block-mode (make-twobit-flag 'benchmark-block-mode)) 'benchmark-block-mode))
+(let () (begin (set! global-optimization (make-twobit-flag 'global-optimization)) 'global-optimization))
+(let () (begin (set! interprocedural-inlining (make-twobit-flag 'interprocedural-inlining)) 'interprocedural-inlining))
+(let () (begin (set! interprocedural-constant-propagation (make-twobit-flag 'interprocedural-constant-propagation)) 'interprocedural-constant-propagation))
+(let () (begin (set! common-subexpression-elimination (make-twobit-flag 'common-subexpression-elimination)) 'common-subexpression-elimination))
+(let () (begin (set! representation-inference (make-twobit-flag 'representation-inference)) 'representation-inference))
+(let () (begin (set! local-optimization (make-twobit-flag 'local-optimization)) 'local-optimization))
+(let () (begin (set! ignore-space-leaks (lambda .args|1 (if (null? .args|1) (not (avoid-space-leaks)) (avoid-space-leaks (not (let ((.x|2|5 .args|1)) (begin (.check! (pair? .x|2|5) 0 .x|2|5) (car:pair .x|2|5)))))))) 'ignore-space-leaks))
+(let () (begin (set! lambda-optimizations lambda-optimization) 'lambda-optimizations))
+(let () (begin (set! local-optimizations local-optimization) 'local-optimizations))
+(let () (begin (set! set-compiler-flags! (lambda (.how|1) (let ((.set-compiler-flags!|2 0)) (begin (set! .set-compiler-flags!|2 (lambda (.how|3) (let ((.temp|4|7 .how|3)) (if (memv .temp|4|7 '(no-optimization)) (begin (.set-compiler-flags!|2 'standard) (avoid-space-leaks #t) (integrate-usual-procedures #f) (control-optimization #f) (parallel-assignment-optimization #f) (lambda-optimization #f) (benchmark-mode #f) (benchmark-block-mode #f) (global-optimization #f) (interprocedural-inlining #f) (interprocedural-constant-propagation #f) (common-subexpression-elimination #f) (representation-inference #f) (local-optimization #f)) (if (memv .temp|4|7 '(standard)) (begin (issue-warnings #t) (include-source-code #f) (include-procedure-names #t) (include-variable-names #t) (avoid-space-leaks #f) (runtime-safety-checking #t) (integrate-usual-procedures #f) (control-optimization #t) (parallel-assignment-optimization #t) (lambda-optimization #t) (benchmark-mode #f) (benchmark-block-mode #f) (global-optimization #t) (interprocedural-inlining #t) (interprocedural-constant-propagation #t) (common-subexpression-elimination #t) (representation-inference #t) (local-optimization #t)) (if (memv .temp|4|7 '(fast-safe)) (let ((.bbmode|13 (benchmark-block-mode))) (begin (.set-compiler-flags!|2 'standard) (integrate-usual-procedures #t) (benchmark-mode #t) (benchmark-block-mode .bbmode|13))) (if (memv .temp|4|7 '(fast-unsafe)) (begin (.set-compiler-flags!|2 'fast-safe) (runtime-safety-checking #f)) (error "set-compiler-flags!: unknown mode " .how|3)))))))) (.set-compiler-flags!|2 .how|1))))) 'set-compiler-flags!))
+(let () (begin (set! display-twobit-flags (lambda (.which|1) (let ((.display-twobit-flags|2 0)) (begin (set! .display-twobit-flags|2 (lambda (.which|3) (let ((.temp|4|7 .which|3)) (if (memv .temp|4|7 '(debugging)) (begin (display-twobit-flag issue-warnings) (display-twobit-flag include-procedure-names) (display-twobit-flag include-variable-names) (display-twobit-flag include-source-code)) (if (memv .temp|4|7 '(safety)) (display-twobit-flag avoid-space-leaks) (if (memv .temp|4|7 '(optimization)) (begin (display-twobit-flag integrate-usual-procedures) (display-twobit-flag control-optimization) (display-twobit-flag parallel-assignment-optimization) (display-twobit-flag lambda-optimization) (display-twobit-flag benchmark-mode) (display-twobit-flag benchmark-block-mode) (display-twobit-flag global-optimization) (if (global-optimization) (begin (display " ") (display-twobit-flag interprocedural-inlining) (display " ") (display-twobit-flag interprocedural-constant-propagation) (display " ") (display-twobit-flag common-subexpression-elimination) (display " ") (display-twobit-flag representation-inference)) (unspecified)) (display-twobit-flag local-optimization)) #t)))))) (.display-twobit-flags|2 .which|1))))) 'display-twobit-flags))
+(let () ($$trace "pass1.aux"))
+(let () (begin (set! @maxargs-with-rest-arg@ 1000000) '@maxargs-with-rest-arg@))
+(let () (begin (set! prim-entry (lambda (.name|1) (let ((.prim-entry|2 0)) (begin (set! .prim-entry|2 (lambda (.name|3) #f)) (.prim-entry|2 .name|1))))) 'prim-entry))
+(let () (begin (set! prim-arity (lambda (.name|1) (let ((.prim-arity|2 0)) (begin (set! .prim-arity|2 (lambda (.name|3) 0)) (.prim-arity|2 .name|1))))) 'prim-arity))
+(let () (begin (set! prim-opcodename (lambda (.name|1) (let ((.prim-opcodename|2 0)) (begin (set! .prim-opcodename|2 (lambda (.name|3) .name|3)) (.prim-opcodename|2 .name|1))))) 'prim-opcodename))
+(let () (begin (set! m-warn (lambda (.msg|1 . .more|1) (if (issue-warnings) (begin (display "WARNING from macro expander:") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1)))))) (unspecified)))) 'm-warn))
+(let () (begin (set! m-error (lambda (.msg|1 . .more|1) (begin (display "ERROR detected during macro expansion:") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1))))) (m-quit (make-constant #f))))) 'm-error))
+(let () (begin (set! m-bug (lambda (.msg|1 . .more|1) (begin (display "BUG in macro expander: ") (newline) (display .msg|1) (newline) (let ((.f|2|5|8 (lambda (.x|28) (begin (write .x|28) (newline))))) (let () (let ((.loop|10|12|15 (unspecified))) (begin (set! .loop|10|12|15 (lambda (.y1|2|3|16) (if (null? .y1|2|3|16) (if #f #f (unspecified)) (begin (begin #t (.f|2|5|8 (let ((.x|20|23 .y1|2|3|16)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (.loop|10|12|15 (let ((.x|24|27 .y1|2|3|16)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|10|12|15 .more|1))))) (m-quit (make-constant #f))))) 'm-bug))
+(let () '(define (make-null-terminated x) (cond ((null? x) '()) ((pair? x) (cons (car x) (make-null-terminated (cdr x)))) (else (list x)))))
+(let () (begin (set! safe-length (lambda (.x|1) (let ((.safe-length|2 0)) (begin (set! .safe-length|2 (lambda (.x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.x|5 .n|5) (if (null? .x|5) .n|5 (if (pair? .x|5) (.loop|4 (let ((.x|8|11 .x|5)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) (+ .n|5 1)) -1)))) (.loop|4 .x|3 0))))) (.safe-length|2 .x|1))))) 'safe-length))
+(let () (begin (set! filter1 (lambda (.p|1 .x|1) (let ((.filter1|2 0)) (begin (set! .filter1|2 (lambda (.p|3 .x|3) (if (null? .x|3) '() (if (.p|3 (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (cons (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.filter1|2 .p|3 (let ((.x|14|17 .x|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (.filter1|2 .p|3 (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22)))))))) (.filter1|2 .p|1 .x|1))))) 'filter1))
+(let () (begin (set! every1? (lambda (.p|1 .x|1) (let ((.every1?|2 0)) (begin (set! .every1?|2 (lambda (.p|3 .x|3) (if (null? .x|3) #t (if (.p|3 (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (.every1?|2 .p|3 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) #f)))) (.every1?|2 .p|1 .x|1))))) 'every1?))
+(let () (begin (set! union2 (lambda (.x|1 .y|1) (let ((.union2|2 0)) (begin (set! .union2|2 (lambda (.x|3 .y|3) (if (null? .x|3) .y|3 (if (member (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .y|3) (.union2|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) .y|3) (.union2|2 (let ((.x|15|18 .x|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) (cons (let ((.x|19|22 .x|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) .y|3)))))) (.union2|2 .x|1 .y|1))))) 'union2))
+(let () (begin (set! copy-alist (lambda (.alist|1) (let ((.copy-alist|2 0)) (begin (set! .copy-alist|2 (lambda (.alist|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.x|24 (let ((.x|33|36 .y1|4|5|16)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (cons (let ((.x|25|28 .x|24)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|29|32 .x|24)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) .results|4|8|16)))))) (.loop|9|12|15 .alist|3 '())))))) (.copy-alist|2 .alist|1))))) 'copy-alist))
+(let () '(define remq! (letrec ((loop (lambda (x y prev) (cond ((null? y) #t) ((eq? x (car y)) (set-cdr! prev (cdr y)) (loop x (cdr prev) prev)) (else (loop x (cdr y) y)))))) (lambda (x y) (cond ((null? y) '()) ((eq? x (car y)) (remq! x (cdr y))) (else (loop x (cdr y) y) y))))))
+(let () (begin (set! integrable? (lambda (.name|1) (let ((.integrable?|2 0)) (begin (set! .integrable?|2 (lambda (.name|3) (if (integrate-usual-procedures) (prim-entry .name|3) #f))) (.integrable?|2 .name|1))))) 'integrable?))
+(let () (begin (set! make-readable (lambda (.exp|1 . .rest|1) (let ((.fancy?|4 (if (not (null? .rest|1)) (let ((.x|963|966 .rest|1)) (begin (.check! (pair? .x|963|966) 0 .x|963|966) (car:pair .x|963|966))) #f))) (let ((.make-readable-let*|5 (unspecified)) (.make-readable-let|5 (unspecified)) (.make-readable-call|5 (unspecified)) (.make-readable-quote|5 (unspecified)) (.make-readable|5 (unspecified))) (begin (set! .make-readable-let*|5 (lambda (.exp|6 .vars|6 .inits|6 .defs|6) (if (if (null? .defs|6) (if (call? .exp|6) (if (lambda? (call.proc .exp|6)) (= 1 (length (lambda.args (call.proc .exp|6)))) #f) #f) #f) (let ((.proc|13 (call.proc .exp|6)) (.arg|13 (let ((.x|92|95 (call.args .exp|6))) (begin (.check! (pair? .x|92|95) 0 .x|92|95) (car:pair .x|92|95))))) (if (if (call? .arg|13) (if (lambda? (call.proc .arg|13)) (if (= 1 (length (lambda.args (call.proc .arg|13)))) (null? (lambda.defs (call.proc .arg|13))) #f) #f) #f) (.make-readable-let*|5 (make-call .proc|13 (cons (lambda.body (call.proc .arg|13)) '())) (cons (let ((.x|19|22 (lambda.args (call.proc .arg|13)))) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))) .vars|6) (cons (.make-readable|5 (let ((.x|23|26 (call.args .arg|13))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) .inits|6) '()) (.make-readable-let*|5 (lambda.body .proc|13) (cons (let ((.x|27|30 (lambda.args .proc|13))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))) .vars|6) (cons (.make-readable|5 (let ((.x|31|34 (call.args .exp|6))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34)))) .inits|6) (let () (let ((.loop|40|43|46 (unspecified))) (begin (set! .loop|40|43|46 (lambda (.y1|35|36|47 .results|35|39|47) (if (null? .y1|35|36|47) (reverse .results|35|39|47) (begin #t (.loop|40|43|46 (let ((.x|51|54 .y1|35|36|47)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (cons (let ((.def|55 (let ((.x|88|91 .y1|35|36|47)) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91))))) (.cons 'define (.cons (def.lhs .def|55) (.cons (.make-readable|5 (def.rhs .def|55)) '())))) .results|35|39|47)))))) (.loop|40|43|46 (reverse (lambda.defs .proc|13)) '()))))))) (if (let ((.temp|97|100 (not (null? .vars|6)))) (if .temp|97|100 .temp|97|100 (not (null? .defs|6)))) (.cons 'let* (.cons (let () (let ((.loop|147|151|154 (unspecified))) (begin (set! .loop|147|151|154 (lambda (.y1|141|143|155 .y1|141|142|155 .results|141|146|155) (if (let ((.temp|157|160 (null? .y1|141|143|155))) (if .temp|157|160 .temp|157|160 (null? .y1|141|142|155))) (reverse .results|141|146|155) (begin #t (.loop|147|151|154 (let ((.x|163|166 .y1|141|143|155)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))) (let ((.x|167|170 .y1|141|142|155)) (begin (.check! (pair? .x|167|170) 1 .x|167|170) (cdr:pair .x|167|170))) (cons (let* ((.t1|171|174 (let ((.x|186|189 .y1|141|143|155)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) (.t2|171|177 (cons (let ((.x|182|185 .y1|141|142|155)) (begin (.check! (pair? .x|182|185) 0 .x|182|185) (car:pair .x|182|185))) '()))) (let () (cons .t1|171|174 .t2|171|177))) .results|141|146|155)))))) (.loop|147|151|154 (reverse .vars|6) (reverse .inits|6) '())))) (append .defs|6 (.cons (.make-readable|5 .exp|6) '())))) (if (if (call? .exp|6) (lambda? (call.proc .exp|6)) #f) (let ((.proc|195 (call.proc .exp|6))) (.cons 'let (.cons (let () (let ((.loop|241|245|248 (unspecified))) (begin (set! .loop|241|245|248 (lambda (.y1|235|237|249 .y1|235|236|249 .results|235|240|249) (if (let ((.temp|251|254 (null? .y1|235|237|249))) (if .temp|251|254 .temp|251|254 (null? .y1|235|236|249))) (reverse .results|235|240|249) (begin #t (.loop|241|245|248 (let ((.x|257|260 .y1|235|237|249)) (begin (.check! (pair? .x|257|260) 1 .x|257|260) (cdr:pair .x|257|260))) (let ((.x|261|264 .y1|235|236|249)) (begin (.check! (pair? .x|261|264) 1 .x|261|264) (cdr:pair .x|261|264))) (cons (let* ((.t1|265|268 (let ((.x|280|283 .y1|235|237|249)) (begin (.check! (pair? .x|280|283) 0 .x|280|283) (car:pair .x|280|283)))) (.t2|265|271 (cons (let ((.x|276|279 .y1|235|236|249)) (begin (.check! (pair? .x|276|279) 0 .x|276|279) (car:pair .x|276|279))) '()))) (let () (cons .t1|265|268 .t2|265|271))) .results|235|240|249)))))) (.loop|241|245|248 (lambda.args .proc|195) (let () (let ((.loop|289|292|295 (unspecified))) (begin (set! .loop|289|292|295 (lambda (.y1|284|285|296 .results|284|288|296) (if (null? .y1|284|285|296) (reverse .results|284|288|296) (begin #t (.loop|289|292|295 (let ((.x|300|303 .y1|284|285|296)) (begin (.check! (pair? .x|300|303) 1 .x|300|303) (cdr:pair .x|300|303))) (cons (.make-readable|5 (let ((.x|304|307 .y1|284|285|296)) (begin (.check! (pair? .x|304|307) 0 .x|304|307) (car:pair .x|304|307)))) .results|284|288|296)))))) (.loop|289|292|295 (call.args .exp|6) '())))) '())))) (append (let () (let ((.loop|313|316|319 (unspecified))) (begin (set! .loop|313|316|319 (lambda (.y1|308|309|320 .results|308|312|320) (if (null? .y1|308|309|320) (reverse .results|308|312|320) (begin #t (.loop|313|316|319 (let ((.x|324|327 .y1|308|309|320)) (begin (.check! (pair? .x|324|327) 1 .x|324|327) (cdr:pair .x|324|327))) (cons (let ((.def|328 (let ((.x|361|364 .y1|308|309|320)) (begin (.check! (pair? .x|361|364) 0 .x|361|364) (car:pair .x|361|364))))) (.cons 'define (.cons (def.lhs .def|328) (.cons (.make-readable|5 (def.rhs .def|328)) '())))) .results|308|312|320)))))) (.loop|313|316|319 (lambda.defs .proc|195) '())))) (.cons (.make-readable|5 (lambda.body .proc|195)) '()))))) (.make-readable|5 .exp|6)))))) (set! .make-readable-let|5 (lambda (.exp|366) (let* ((.l|369 (call.proc .exp|366)) (.formals|372 (lambda.args .l|369)) (.args|375 (let () (let ((.loop|646|649|652 (unspecified))) (begin (set! .loop|646|649|652 (lambda (.y1|641|642|653 .results|641|645|653) (if (null? .y1|641|642|653) (reverse .results|641|645|653) (begin #t (.loop|646|649|652 (let ((.x|657|660 .y1|641|642|653)) (begin (.check! (pair? .x|657|660) 1 .x|657|660) (cdr:pair .x|657|660))) (cons (.make-readable|5 (let ((.x|661|664 .y1|641|642|653)) (begin (.check! (pair? .x|661|664) 0 .x|661|664) (car:pair .x|661|664)))) .results|641|645|653)))))) (.loop|646|649|652 (call.args .exp|366) '()))))) (.body|378 (.make-readable|5 (lambda.body .l|369)))) (let () (if (if (null? (lambda.defs .l|369)) (if (= (length .args|375) 1) (if (pair? .body|378) (let ((.temp|386|389 (if (eq? (let ((.x|396|399 .body|378)) (begin (.check! (pair? .x|396|399) 0 .x|396|399) (car:pair .x|396|399))) 'let) (= (length (let ((.x|402|405 (let ((.x|406|409 .body|378)) (begin (.check! (pair? .x|406|409) 1 .x|406|409) (cdr:pair .x|406|409))))) (begin (.check! (pair? .x|402|405) 0 .x|402|405) (car:pair .x|402|405)))) 1) #f))) (if .temp|386|389 .temp|386|389 (eq? (let ((.x|391|394 .body|378)) (begin (.check! (pair? .x|391|394) 0 .x|391|394) (car:pair .x|391|394))) 'let*))) #f) #f) #f) (.cons 'let* (.cons (.cons (.cons (let ((.x|470|473 .formals|372)) (begin (.check! (pair? .x|470|473) 0 .x|470|473) (car:pair .x|470|473))) (.cons (let ((.x|474|477 .args|375)) (begin (.check! (pair? .x|474|477) 0 .x|474|477) (car:pair .x|474|477))) '())) (let ((.x|479|482 (let ((.x|483|486 .body|378)) (begin (.check! (pair? .x|483|486) 1 .x|483|486) (cdr:pair .x|483|486))))) (begin (.check! (pair? .x|479|482) 0 .x|479|482) (car:pair .x|479|482)))) (let ((.x|488|491 (let ((.x|492|495 .body|378)) (begin (.check! (pair? .x|492|495) 1 .x|492|495) (cdr:pair .x|492|495))))) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))))) (.cons 'let (.cons (let () (let ((.loop|541|545|548 (unspecified))) (begin (set! .loop|541|545|548 (lambda (.y1|535|537|549 .y1|535|536|549 .results|535|540|549) (if (let ((.temp|551|554 (null? .y1|535|537|549))) (if .temp|551|554 .temp|551|554 (null? .y1|535|536|549))) (reverse .results|535|540|549) (begin #t (.loop|541|545|548 (let ((.x|557|560 .y1|535|537|549)) (begin (.check! (pair? .x|557|560) 1 .x|557|560) (cdr:pair .x|557|560))) (let ((.x|561|564 .y1|535|536|549)) (begin (.check! (pair? .x|561|564) 1 .x|561|564) (cdr:pair .x|561|564))) (cons (let* ((.t1|565|568 (let ((.x|580|583 .y1|535|537|549)) (begin (.check! (pair? .x|580|583) 0 .x|580|583) (car:pair .x|580|583)))) (.t2|565|571 (cons (let ((.x|576|579 .y1|535|536|549)) (begin (.check! (pair? .x|576|579) 0 .x|576|579) (car:pair .x|576|579))) '()))) (let () (cons .t1|565|568 .t2|565|571))) .results|535|540|549)))))) (.loop|541|545|548 (lambda.args .l|369) .args|375 '())))) (append (let () (let ((.loop|589|592|595 (unspecified))) (begin (set! .loop|589|592|595 (lambda (.y1|584|585|596 .results|584|588|596) (if (null? .y1|584|585|596) (reverse .results|584|588|596) (begin #t (.loop|589|592|595 (let ((.x|600|603 .y1|584|585|596)) (begin (.check! (pair? .x|600|603) 1 .x|600|603) (cdr:pair .x|600|603))) (cons (let ((.def|604 (let ((.x|637|640 .y1|584|585|596)) (begin (.check! (pair? .x|637|640) 0 .x|637|640) (car:pair .x|637|640))))) (.cons 'define (.cons (def.lhs .def|604) (.cons (.make-readable|5 (def.rhs .def|604)) '())))) .results|584|588|596)))))) (.loop|589|592|595 (lambda.defs .l|369) '())))) (.cons .body|378 '()))))))))) (set! .make-readable-call|5 (lambda (.exp|665) (let ((.proc|668 (call.proc .exp|665))) (if (if .fancy?|4 (if (lambda? .proc|668) (list? (lambda.args .proc|668)) #f) #f) (.make-readable-let|5 .exp|665) (.cons (.make-readable|5 (call.proc .exp|665)) (let () (let ((.loop|696|699|702 (unspecified))) (begin (set! .loop|696|699|702 (lambda (.y1|691|692|703 .results|691|695|703) (if (null? .y1|691|692|703) (reverse .results|691|695|703) (begin #t (.loop|696|699|702 (let ((.x|707|710 .y1|691|692|703)) (begin (.check! (pair? .x|707|710) 1 .x|707|710) (cdr:pair .x|707|710))) (cons (.make-readable|5 (let ((.x|711|714 .y1|691|692|703)) (begin (.check! (pair? .x|711|714) 0 .x|711|714) (car:pair .x|711|714)))) .results|691|695|703)))))) (.loop|696|699|702 (call.args .exp|665) '()))))))))) (set! .make-readable-quote|5 (lambda (.exp|715) (let ((.x|718 (constant.value .exp|715))) (if (if .fancy?|4 (let ((.temp|721|724 (boolean? .x|718))) (if .temp|721|724 .temp|721|724 (let ((.temp|725|728 (number? .x|718))) (if .temp|725|728 .temp|725|728 (let ((.temp|729|732 (char? .x|718))) (if .temp|729|732 .temp|729|732 (string? .x|718))))))) #f) .x|718 .exp|715)))) (set! .make-readable|5 (lambda (.exp|734) (let ((.temp|735|738 (let ((.x|957|960 .exp|734)) (begin (.check! (pair? .x|957|960) 0 .x|957|960) (car:pair .x|957|960))))) (if (memv .temp|735|738 '(quote)) (.make-readable-quote|5 .exp|734) (if (memv .temp|735|738 '(lambda)) (.cons 'lambda (.cons (lambda.args .exp|734) (append (let () (let ((.loop|785|788|791 (unspecified))) (begin (set! .loop|785|788|791 (lambda (.y1|780|781|792 .results|780|784|792) (if (null? .y1|780|781|792) (reverse .results|780|784|792) (begin #t (.loop|785|788|791 (let ((.x|796|799 .y1|780|781|792)) (begin (.check! (pair? .x|796|799) 1 .x|796|799) (cdr:pair .x|796|799))) (cons (let ((.def|800 (let ((.x|833|836 .y1|780|781|792)) (begin (.check! (pair? .x|833|836) 0 .x|833|836) (car:pair .x|833|836))))) (.cons 'define (.cons (def.lhs .def|800) (.cons (.make-readable|5 (def.rhs .def|800)) '())))) .results|780|784|792)))))) (.loop|785|788|791 (lambda.defs .exp|734) '())))) (.cons (.make-readable|5 (lambda.body .exp|734)) '())))) (if (memv .temp|735|738 '(set!)) (.cons 'set! (.cons (assignment.lhs .exp|734) (.cons (.make-readable|5 (assignment.rhs .exp|734)) '()))) (if (memv .temp|735|738 '(if)) (.cons 'if (.cons (.make-readable|5 (if.test .exp|734)) (.cons (.make-readable|5 (if.then .exp|734)) (.cons (.make-readable|5 (if.else .exp|734)) '())))) (if (memv .temp|735|738 '(begin)) (if (variable? .exp|734) (variable.name .exp|734) (.cons 'begin (let () (let ((.loop|937|940|943 (unspecified))) (begin (set! .loop|937|940|943 (lambda (.y1|932|933|944 .results|932|936|944) (if (null? .y1|932|933|944) (reverse .results|932|936|944) (begin #t (.loop|937|940|943 (let ((.x|948|951 .y1|932|933|944)) (begin (.check! (pair? .x|948|951) 1 .x|948|951) (cdr:pair .x|948|951))) (cons (.make-readable|5 (let ((.x|952|955 .y1|932|933|944)) (begin (.check! (pair? .x|952|955) 0 .x|952|955) (car:pair .x|952|955)))) .results|932|936|944)))))) (.loop|937|940|943 (begin.exprs .exp|734) '())))))) (.make-readable-call|5 .exp|734))))))))) (.make-readable|5 .exp|1)))))) 'make-readable))
+(let () (begin (set! make-unreadable (lambda (.exp|1) (let ((.make-unreadable|2 0)) (begin (set! .make-unreadable|2 (lambda (.exp|3) (if (symbol? .exp|3) (let* ((.t1|5|8 'begin) (.t2|5|11 (cons .exp|3 '()))) (let () (cons .t1|5|8 .t2|5|11))) (if (pair? .exp|3) (let ((.temp|17|20 (let ((.x|291|294 .exp|3)) (begin (.check! (pair? .x|291|294) 0 .x|291|294) (car:pair .x|291|294))))) (if (memv .temp|17|20 '(quote)) .exp|3 (if (memv .temp|17|20 '(lambda)) (let* ((.t1|23|26 'lambda) (.t2|23|29 (let* ((.t1|33|36 (let ((.x|105|108 (let ((.x|109|112 .exp|3)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))))) (begin (.check! (pair? .x|105|108) 0 .x|105|108) (car:pair .x|105|108)))) (.t2|33|39 (let* ((.t1|43|46 '(begin)) (.t2|43|49 (let* ((.t1|53|56 (let* ((.t1|73|76 '()) (.t2|73|79 (let* ((.t1|83|86 '()) (.t2|83|89 (let* ((.t1|93|96 '()) (.t2|93|99 (cons '() '()))) (let () (cons .t1|93|96 .t2|93|99))))) (let () (cons .t1|83|86 .t2|83|89))))) (let () (cons .t1|73|76 .t2|73|79)))) (.t2|53|59 (cons (.make-unreadable|2 (cons 'begin (let ((.x|65|68 (let ((.x|69|72 .exp|3)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68))))) '()))) (let () (cons .t1|53|56 .t2|53|59))))) (let () (cons .t1|43|46 .t2|43|49))))) (let () (cons .t1|33|36 .t2|33|39))))) (let () (cons .t1|23|26 .t2|23|29))) (if (memv .temp|17|20 '(set!)) (let* ((.t1|114|117 'set!) (.t2|114|120 (let* ((.t1|124|127 (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152)))) (.t2|124|130 (cons (.make-unreadable|2 (let ((.x|136|139 (let ((.x|140|143 (let ((.x|144|147 .exp|3)) (begin (.check! (pair? .x|144|147) 1 .x|144|147) (cdr:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))))) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139)))) '()))) (let () (cons .t1|124|127 .t2|124|130))))) (let () (cons .t1|114|117 .t2|114|120))) (if (memv .temp|17|20 '(if)) (let* ((.t1|158|161 'if) (.t2|158|164 (let* ((.t1|168|171 (.make-unreadable|2 (let ((.x|220|223 (let ((.x|224|227 .exp|3)) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227))))) (begin (.check! (pair? .x|220|223) 0 .x|220|223) (car:pair .x|220|223))))) (.t2|168|174 (let* ((.t1|178|181 (.make-unreadable|2 (let ((.x|207|210 (let ((.x|211|214 (let ((.x|215|218 .exp|3)) (begin (.check! (pair? .x|215|218) 1 .x|215|218) (cdr:pair .x|215|218))))) (begin (.check! (pair? .x|211|214) 1 .x|211|214) (cdr:pair .x|211|214))))) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210))))) (.t2|178|184 (cons (if (= (length .exp|3) 3) '(unspecified) (.make-unreadable|2 (let ((.x|190|193 (let ((.x|194|197 (let ((.x|198|201 (let ((.x|202|205 .exp|3)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))))) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))))) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))))) '()))) (let () (cons .t1|178|181 .t2|178|184))))) (let () (cons .t1|168|171 .t2|168|174))))) (let () (cons .t1|158|161 .t2|158|164))) (if (memv .temp|17|20 '(begin)) (if (= (length .exp|3) 2) (.make-unreadable|2 (let ((.x|230|233 (let ((.x|234|237 .exp|3)) (begin (.check! (pair? .x|234|237) 1 .x|234|237) (cdr:pair .x|234|237))))) (begin (.check! (pair? .x|230|233) 0 .x|230|233) (car:pair .x|230|233)))) (cons 'begin (let () (let ((.loop|243|246|249 (unspecified))) (begin (set! .loop|243|246|249 (lambda (.y1|238|239|250 .results|238|242|250) (if (null? .y1|238|239|250) (reverse .results|238|242|250) (begin #t (.loop|243|246|249 (let ((.x|254|257 .y1|238|239|250)) (begin (.check! (pair? .x|254|257) 1 .x|254|257) (cdr:pair .x|254|257))) (cons (.make-unreadable|2 (let ((.x|258|261 .y1|238|239|250)) (begin (.check! (pair? .x|258|261) 0 .x|258|261) (car:pair .x|258|261)))) .results|238|242|250)))))) (.loop|243|246|249 (let ((.x|262|265 .exp|3)) (begin (.check! (pair? .x|262|265) 1 .x|262|265) (cdr:pair .x|262|265))) '())))))) (let () (let ((.loop|272|275|278 (unspecified))) (begin (set! .loop|272|275|278 (lambda (.y1|267|268|279 .results|267|271|279) (if (null? .y1|267|268|279) (reverse .results|267|271|279) (begin #t (.loop|272|275|278 (let ((.x|283|286 .y1|267|268|279)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))) (cons (.make-unreadable|2 (let ((.x|287|290 .y1|267|268|279)) (begin (.check! (pair? .x|287|290) 0 .x|287|290) (car:pair .x|287|290)))) .results|267|271|279)))))) (.loop|272|275|278 .exp|3 '())))))))))) (let* ((.t1|296|299 'quote) (.t2|296|302 (cons .exp|3 '()))) (let () (cons .t1|296|299 .t2|296|302))))))) (.make-unreadable|2 .exp|1))))) 'make-unreadable))
+(let () ($$trace "pass2.aux"))
+(let () (begin (set! constant? (lambda (.exp|1) (let ((.constant?|2 0)) (begin (set! .constant?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'quote))) (.constant?|2 .exp|1))))) 'constant?))
+(let () (begin (set! variable? (lambda (.exp|1) (let ((.variable?|2 0)) (begin (set! .variable?|2 (lambda (.exp|3) (if (eq? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) 'begin) (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) #f))) (.variable?|2 .exp|1))))) 'variable?))
+(let () (begin (set! lambda? (lambda (.exp|1) (let ((.lambda?|2 0)) (begin (set! .lambda?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'lambda))) (.lambda?|2 .exp|1))))) 'lambda?))
+(let () (begin (set! call? (lambda (.exp|1) (let ((.call?|2 0)) (begin (set! .call?|2 (lambda (.exp|3) (pair? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))))) (.call?|2 .exp|1))))) 'call?))
+(let () (begin (set! assignment? (lambda (.exp|1) (let ((.assignment?|2 0)) (begin (set! .assignment?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'set!))) (.assignment?|2 .exp|1))))) 'assignment?))
+(let () (begin (set! conditional? (lambda (.exp|1) (let ((.conditional?|2 0)) (begin (set! .conditional?|2 (lambda (.exp|3) (eq? (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'if))) (.conditional?|2 .exp|1))))) 'conditional?))
+(let () (begin (set! begin? (lambda (.exp|1) (let ((.begin?|2 0)) (begin (set! .begin?|2 (lambda (.exp|3) (if (eq? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) 'begin) (not (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14))))) #f))) (.begin?|2 .exp|1))))) 'begin?))
+(let () (begin (set! make-constant (lambda (.value|1) (let ((.make-constant|2 0)) (begin (set! .make-constant|2 (lambda (.value|3) (let* ((.t1|4|7 'quote) (.t2|4|10 (cons .value|3 '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constant|2 .value|1))))) 'make-constant))
+(let () (begin (set! make-variable (lambda (.name|1) (let ((.make-variable|2 0)) (begin (set! .make-variable|2 (lambda (.name|3) (let* ((.t1|4|7 'begin) (.t2|4|10 (cons .name|3 '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-variable|2 .name|1))))) 'make-variable))
+(let () (begin (set! make-lambda (lambda (.formals|1 .defs|1 .r|1 .f|1 .g|1 .decls|1 .doc|1 .body|1) (let ((.make-lambda|2 0)) (begin (set! .make-lambda|2 (lambda (.formals|3 .defs|3 .r|3 .f|3 .g|3 .decls|3 .doc|3 .body|3) (let* ((.t1|4|7 'lambda) (.t2|4|10 (let* ((.t1|14|17 .formals|3) (.t2|14|20 (let* ((.t1|24|27 (cons 'begin .defs|3)) (.t2|24|30 (let* ((.t1|34|37 (let* ((.t1|45|48 'quote) (.t2|45|51 (cons (let* ((.t1|56|59 .r|3) (.t2|56|62 (let* ((.t1|66|69 .f|3) (.t2|66|72 (let* ((.t1|76|79 .g|3) (.t2|76|82 (let* ((.t1|86|89 .decls|3) (.t2|86|92 (cons .doc|3 '()))) (let () (cons .t1|86|89 .t2|86|92))))) (let () (cons .t1|76|79 .t2|76|82))))) (let () (cons .t1|66|69 .t2|66|72))))) (let () (cons .t1|56|59 .t2|56|62))) '()))) (let () (cons .t1|45|48 .t2|45|51)))) (.t2|34|40 (cons .body|3 '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-lambda|2 .formals|1 .defs|1 .r|1 .f|1 .g|1 .decls|1 .doc|1 .body|1))))) 'make-lambda))
+(let () (begin (set! make-call (lambda (.proc|1 .args|1) (let ((.make-call|2 0)) (begin (set! .make-call|2 (lambda (.proc|3 .args|3) (cons .proc|3 (append .args|3 '())))) (.make-call|2 .proc|1 .args|1))))) 'make-call))
+(let () (begin (set! make-assignment (lambda (.lhs|1 .rhs|1) (let ((.make-assignment|2 0)) (begin (set! .make-assignment|2 (lambda (.lhs|3 .rhs|3) (let* ((.t1|4|7 'set!) (.t2|4|10 (let* ((.t1|14|17 .lhs|3) (.t2|14|20 (cons .rhs|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-assignment|2 .lhs|1 .rhs|1))))) 'make-assignment))
+(let () (begin (set! make-conditional (lambda (.e0|1 .e1|1 .e2|1) (let ((.make-conditional|2 0)) (begin (set! .make-conditional|2 (lambda (.e0|3 .e1|3 .e2|3) (let* ((.t1|4|7 'if) (.t2|4|10 (let* ((.t1|14|17 .e0|3) (.t2|14|20 (let* ((.t1|24|27 .e1|3) (.t2|24|30 (cons .e2|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-conditional|2 .e0|1 .e1|1 .e2|1))))) 'make-conditional))
+(let () (begin (set! make-begin (lambda (.exprs|1) (let ((.make-begin|2 0)) (begin (set! .make-begin|2 (lambda (.exprs|3) (if (null? (let ((.x|4|7 .exprs|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (let ((.x|8|11 .exprs|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (cons 'begin (append .exprs|3 '()))))) (.make-begin|2 .exprs|1))))) 'make-begin))
+(let () (begin (set! make-definition (lambda (.lhs|1 .rhs|1) (let ((.make-definition|2 0)) (begin (set! .make-definition|2 (lambda (.lhs|3 .rhs|3) (let* ((.t1|4|7 'define) (.t2|4|10 (let* ((.t1|14|17 .lhs|3) (.t2|14|20 (cons .rhs|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-definition|2 .lhs|1 .rhs|1))))) 'make-definition))
+(let () (begin (set! constant.value (lambda (.exp|1) (let ((.constant.value|2 0)) (begin (set! .constant.value|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constant.value|2 .exp|1))))) 'constant.value))
+(let () (begin (set! variable.name (lambda (.exp|1) (let ((.variable.name|2 0)) (begin (set! .variable.name|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.variable.name|2 .exp|1))))) 'variable.name))
+(let () (begin (set! lambda.args (lambda (.exp|1) (let ((.lambda.args|2 0)) (begin (set! .lambda.args|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.args|2 .exp|1))))) 'lambda.args))
+(let () (begin (set! lambda.defs (lambda (.exp|1) (let ((.lambda.defs|2 0)) (begin (set! .lambda.defs|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.lambda.defs|2 .exp|1))))) 'lambda.defs))
+(let () (begin (set! lambda.r (lambda (.exp|1) (let ((.lambda.r|2 0)) (begin (set! .lambda.r|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.r|2 .exp|1))))) 'lambda.r))
+(let () (begin (set! lambda.f (lambda (.exp|1) (let ((.lambda.f|2 0)) (begin (set! .lambda.f|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|23|26 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 .exp|3)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.f|2 .exp|1))))) 'lambda.f))
+(let () (begin (set! lambda.g (lambda (.exp|1) (let ((.lambda.g|2 0)) (begin (set! .lambda.g|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .exp|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.g|2 .exp|1))))) 'lambda.g))
+(let () (begin (set! lambda.decls (lambda (.exp|1) (let ((.lambda.decls|2 0)) (begin (set! .lambda.decls|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 .exp|3)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.lambda.decls|2 .exp|1))))) 'lambda.decls))
+(let () (begin (set! lambda.doc (lambda (.exp|1) (let ((.lambda.doc|2 0)) (begin (set! .lambda.doc|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 (let ((.x|26|29 (let ((.x|30|33 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 (let ((.x|47|50 .exp|3)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.doc|2 .exp|1))))) 'lambda.doc))
+(let () (begin (set! lambda.body (lambda (.exp|1) (let ((.lambda.body|2 0)) (begin (set! .lambda.body|2 (lambda (.exp|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .exp|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.lambda.body|2 .exp|1))))) 'lambda.body))
+(let () (begin (set! call.proc (lambda (.exp|1) (let ((.call.proc|2 0)) (begin (set! .call.proc|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.call.proc|2 .exp|1))))) 'call.proc))
+(let () (begin (set! call.args (lambda (.exp|1) (let ((.call.args|2 0)) (begin (set! .call.args|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.call.args|2 .exp|1))))) 'call.args))
+(let () (begin (set! assignment.lhs (lambda (.exp|1) (let ((.assignment.lhs|2 0)) (begin (set! .assignment.lhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignment.lhs|2 .exp|1))))) 'assignment.lhs))
+(let () (begin (set! assignment.rhs (lambda (.exp|1) (let ((.assignment.rhs|2 0)) (begin (set! .assignment.rhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignment.rhs|2 .exp|1))))) 'assignment.rhs))
+(let () (begin (set! if.test (lambda (.exp|1) (let ((.if.test|2 0)) (begin (set! .if.test|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.test|2 .exp|1))))) 'if.test))
+(let () (begin (set! if.then (lambda (.exp|1) (let ((.if.then|2 0)) (begin (set! .if.then|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.then|2 .exp|1))))) 'if.then))
+(let () (begin (set! if.else (lambda (.exp|1) (let ((.if.else|2 0)) (begin (set! .if.else|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.if.else|2 .exp|1))))) 'if.else))
+(let () (begin (set! begin.exprs (lambda (.exp|1) (let ((.begin.exprs|2 0)) (begin (set! .begin.exprs|2 (lambda (.exp|3) (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))))) (.begin.exprs|2 .exp|1))))) 'begin.exprs))
+(let () (begin (set! def.lhs (lambda (.exp|1) (let ((.def.lhs|2 0)) (begin (set! .def.lhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.def.lhs|2 .exp|1))))) 'def.lhs))
+(let () (begin (set! def.rhs (lambda (.exp|1) (let ((.def.rhs|2 0)) (begin (set! .def.rhs|2 (lambda (.exp|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.def.rhs|2 .exp|1))))) 'def.rhs))
+(let () (begin (set! variable-set! (lambda (.exp|1 .newexp|1) (let ((.variable-set!|2 0)) (begin (set! .variable-set!|2 (lambda (.exp|3 .newexp|3) (begin (set-car! .exp|3 (let ((.x|4|7 .newexp|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (set-cdr! .exp|3 (append (let ((.x|8|11 .newexp|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11))) '()))))) (.variable-set!|2 .exp|1 .newexp|1))))) 'variable-set!))
+(let () (begin (set! lambda.args-set! (lambda (.exp|1 .args|1) (let ((.lambda.args-set!|2 0)) (begin (set! .lambda.args-set!|2 (lambda (.exp|3 .args|3) (set-car! (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .args|3))) (.lambda.args-set!|2 .exp|1 .args|1))))) 'lambda.args-set!))
+(let () (begin (set! lambda.defs-set! (lambda (.exp|1 .defs|1) (let ((.lambda.defs-set!|2 0)) (begin (set! .lambda.defs-set!|2 (lambda (.exp|3 .defs|3) (set-cdr! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) .defs|3))) (.lambda.defs-set!|2 .exp|1 .defs|1))))) 'lambda.defs-set!))
+(let () (begin (set! lambda.r-set! (lambda (.exp|1 .r|1) (let ((.lambda.r-set!|2 0)) (begin (set! .lambda.r-set!|2 (lambda (.exp|3 .r|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .exp|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) .r|3))) (.lambda.r-set!|2 .exp|1 .r|1))))) 'lambda.r-set!))
+(let () (begin (set! lambda.f-set! (lambda (.exp|1 .f|1) (let ((.lambda.f-set!|2 0)) (begin (set! .lambda.f-set!|2 (lambda (.exp|3 .f|3) (set-car! (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .f|3))) (.lambda.f-set!|2 .exp|1 .f|1))))) 'lambda.f-set!))
+(let () (begin (set! lambda.g-set! (lambda (.exp|1 .g|1) (let ((.lambda.g-set!|2 0)) (begin (set! .lambda.g-set!|2 (lambda (.exp|3 .g|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|23|26 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 .exp|3)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .g|3))) (.lambda.g-set!|2 .exp|1 .g|1))))) 'lambda.g-set!))
+(let () (begin (set! lambda.decls-set! (lambda (.exp|1 .decls|1) (let ((.lambda.decls-set!|2 0)) (begin (set! .lambda.decls-set!|2 (lambda (.exp|3 .decls|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|27|30 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .exp|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))))) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .decls|3))) (.lambda.decls-set!|2 .exp|1 .decls|1))))) 'lambda.decls-set!))
+(let () (begin (set! lambda.doc-set! (lambda (.exp|1 .doc|1) (let ((.lambda.doc-set!|2 0)) (begin (set! .lambda.doc-set!|2 (lambda (.exp|3 .doc|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 .exp|3)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .doc|3))) (.lambda.doc-set!|2 .exp|1 .doc|1))))) 'lambda.doc-set!))
+(let () (begin (set! lambda.body-set! (lambda (.exp|1 .exp0|1) (let ((.lambda.body-set!|2 0)) (begin (set! .lambda.body-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.lambda.body-set!|2 .exp|1 .exp0|1))))) 'lambda.body-set!))
+(let () (begin (set! call.proc-set! (lambda (.exp|1 .exp0|1) (let ((.call.proc-set!|2 0)) (begin (set! .call.proc-set!|2 (lambda (.exp|3 .exp0|3) (set-car! .exp|3 .exp0|3))) (.call.proc-set!|2 .exp|1 .exp0|1))))) 'call.proc-set!))
+(let () (begin (set! call.args-set! (lambda (.exp|1 .exprs|1) (let ((.call.args-set!|2 0)) (begin (set! .call.args-set!|2 (lambda (.exp|3 .exprs|3) (set-cdr! .exp|3 .exprs|3))) (.call.args-set!|2 .exp|1 .exprs|1))))) 'call.args-set!))
+(let () (begin (set! assignment.rhs-set! (lambda (.exp|1 .exp0|1) (let ((.assignment.rhs-set!|2 0)) (begin (set! .assignment.rhs-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.assignment.rhs-set!|2 .exp|1 .exp0|1))))) 'assignment.rhs-set!))
+(let () (begin (set! if.test-set! (lambda (.exp|1 .exp0|1) (let ((.if.test-set!|2 0)) (begin (set! .if.test-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|4|7 .exp|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .exp0|3))) (.if.test-set!|2 .exp|1 .exp0|1))))) 'if.test-set!))
+(let () (begin (set! if.then-set! (lambda (.exp|1 .exp0|1) (let ((.if.then-set!|2 0)) (begin (set! .if.then-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .exp|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.if.then-set!|2 .exp|1 .exp0|1))))) 'if.then-set!))
+(let () (begin (set! if.else-set! (lambda (.exp|1 .exp0|1) (let ((.if.else-set!|2 0)) (begin (set! .if.else-set!|2 (lambda (.exp|3 .exp0|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .exp|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .exp0|3))) (.if.else-set!|2 .exp|1 .exp0|1))))) 'if.else-set!))
+(let () (begin (set! begin.exprs-set! (lambda (.exp|1 .exprs|1) (let ((.begin.exprs-set!|2 0)) (begin (set! .begin.exprs-set!|2 (lambda (.exp|3 .exprs|3) (set-cdr! .exp|3 .exprs|3))) (.begin.exprs-set!|2 .exp|1 .exprs|1))))) 'begin.exprs-set!))
+(let () (begin (set! expression-set! variable-set!) 'expression-set!))
+(let () (begin (set! make-doc (lambda (.name|1 .arity|1 .formals|1 .source-code|1 .filename|1 .filepos|1) (let ((.make-doc|2 0)) (begin (set! .make-doc|2 (lambda (.name|3 .arity|3 .formals|3 .source-code|3 .filename|3 .filepos|3) (let* ((.t|4|10|15 .formals|3) (.t|4|9|18 .filepos|3) (.t|4|8|21 .filename|3) (.t|4|7|24 .arity|3) (.t|4|6|27 .source-code|3) (.t|4|5|30 .name|3) (.v|4|12|33 (make-vector 6 .t|4|10|15))) (let () (begin (let ((.v|37|40 .v|4|12|33) (.i|37|40 4) (.x|37|40 .t|4|9|18)) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) (let ((.v|41|44 .v|4|12|33) (.i|41|44 3) (.x|41|44 .t|4|8|21)) (begin (.check! (fixnum? .i|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (vector? .v|41|44) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (<:fix:fix .i|41|44 (vector-length:vec .v|41|44)) 41 .v|41|44 .i|41|44 .x|41|44) (.check! (>=:fix:fix .i|41|44 0) 41 .v|41|44 .i|41|44 .x|41|44) (vector-set!:trusted .v|41|44 .i|41|44 .x|41|44))) (let ((.v|45|48 .v|4|12|33) (.i|45|48 2) (.x|45|48 .t|4|7|24)) (begin (.check! (fixnum? .i|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (vector? .v|45|48) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (<:fix:fix .i|45|48 (vector-length:vec .v|45|48)) 41 .v|45|48 .i|45|48 .x|45|48) (.check! (>=:fix:fix .i|45|48 0) 41 .v|45|48 .i|45|48 .x|45|48) (vector-set!:trusted .v|45|48 .i|45|48 .x|45|48))) (let ((.v|49|52 .v|4|12|33) (.i|49|52 1) (.x|49|52 .t|4|6|27)) (begin (.check! (fixnum? .i|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (vector? .v|49|52) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (<:fix:fix .i|49|52 (vector-length:vec .v|49|52)) 41 .v|49|52 .i|49|52 .x|49|52) (.check! (>=:fix:fix .i|49|52 0) 41 .v|49|52 .i|49|52 .x|49|52) (vector-set!:trusted .v|49|52 .i|49|52 .x|49|52))) (let ((.v|53|56 .v|4|12|33) (.i|53|56 0) (.x|53|56 .t|4|5|30)) (begin (.check! (fixnum? .i|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (vector? .v|53|56) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (<:fix:fix .i|53|56 (vector-length:vec .v|53|56)) 41 .v|53|56 .i|53|56 .x|53|56) (.check! (>=:fix:fix .i|53|56 0) 41 .v|53|56 .i|53|56 .x|53|56) (vector-set!:trusted .v|53|56 .i|53|56 .x|53|56))) .v|4|12|33))))) (.make-doc|2 .name|1 .arity|1 .formals|1 .source-code|1 .filename|1 .filepos|1))))) 'make-doc))
+(let () (begin (set! doc.name (lambda (.d|1) (let ((.doc.name|2 0)) (begin (set! .doc.name|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.name|2 .d|1))))) 'doc.name))
+(let () (begin (set! doc.code (lambda (.d|1) (let ((.doc.code|2 0)) (begin (set! .doc.code|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.code|2 .d|1))))) 'doc.code))
+(let () (begin (set! doc.arity (lambda (.d|1) (let ((.doc.arity|2 0)) (begin (set! .doc.arity|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.arity|2 .d|1))))) 'doc.arity))
+(let () (begin (set! doc.file (lambda (.d|1) (let ((.doc.file|2 0)) (begin (set! .doc.file|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.file|2 .d|1))))) 'doc.file))
+(let () (begin (set! doc.filepos (lambda (.d|1) (let ((.doc.filepos|2 0)) (begin (set! .doc.filepos|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 4)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.filepos|2 .d|1))))) 'doc.filepos))
+(let () (begin (set! doc.formals (lambda (.d|1) (let ((.doc.formals|2 0)) (begin (set! .doc.formals|2 (lambda (.d|3) (let ((.v|4|7 .d|3) (.i|4|7 5)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.doc.formals|2 .d|1))))) 'doc.formals))
+(let () (begin (set! doc.name-set! (lambda (.d|1 .x|1) (let ((.doc.name-set!|2 0)) (begin (set! .doc.name-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 0) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.name-set!|2 .d|1 .x|1))))) 'doc.name-set!))
+(let () (begin (set! doc.code-set! (lambda (.d|1 .x|1) (let ((.doc.code-set!|2 0)) (begin (set! .doc.code-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.code-set!|2 .d|1 .x|1))))) 'doc.code-set!))
+(let () (begin (set! doc.arity-set! (lambda (.d|1 .x|1) (let ((.doc.arity-set!|2 0)) (begin (set! .doc.arity-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.arity-set!|2 .d|1 .x|1))))) 'doc.arity-set!))
+(let () (begin (set! doc.file-set! (lambda (.d|1 .x|1) (let ((.doc.file-set!|2 0)) (begin (set! .doc.file-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.file-set!|2 .d|1 .x|1))))) 'doc.file-set!))
+(let () (begin (set! doc.filepos-set! (lambda (.d|1 .x|1) (let ((.doc.filepos-set!|2 0)) (begin (set! .doc.filepos-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 4) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.filepos-set!|2 .d|1 .x|1))))) 'doc.filepos-set!))
+(let () (begin (set! doc.formals-set! (lambda (.d|1 .x|1) (let ((.doc.formals-set!|2 0)) (begin (set! .doc.formals-set!|2 (lambda (.d|3 .x|3) (if .d|3 (let ((.v|4|7 .d|3) (.i|4|7 5) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (unspecified)))) (.doc.formals-set!|2 .d|1 .x|1))))) 'doc.formals-set!))
+(let () (begin (set! doc-copy (lambda (.d|1) (let ((.doc-copy|2 0)) (begin (set! .doc-copy|2 (lambda (.d|3) (list->vector (vector->list .d|3)))) (.doc-copy|2 .d|1))))) 'doc-copy))
+(let () (begin (set! ignored? (lambda (.name|1) (let ((.ignored?|2 0)) (begin (set! .ignored?|2 (lambda (.name|3) (eq? .name|3 name:ignored))) (.ignored?|2 .name|1))))) 'ignored?))
+(let () (begin (set! flag-as-ignored (lambda (.name|1 .l|1) (let ((.flag-as-ignored|2 0)) (begin (set! .flag-as-ignored|2 (lambda (.name|3 .l|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.name|5 .formals|5) (if (null? .formals|5) #t (if (symbol? .formals|5) #t (if (eq? .name|5 (let ((.x|9|12 .formals|5)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (begin (set-car! .formals|5 name:ignored) (if (not (local? (lambda.r .l|3) name:ignored)) (lambda.r-set! .l|3 (cons (make-r-entry name:ignored '() '() '()) (lambda.r .l|3))) (unspecified))) (.loop|4 .name|5 (let ((.x|14|17 .formals|5)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))))))) (.loop|4 .name|3 (lambda.args .l|3)))))) (.flag-as-ignored|2 .name|1 .l|1))))) 'flag-as-ignored))
+(let () (begin (set! make-null-terminated (lambda (.formals|1) (let ((.make-null-terminated|2 0)) (begin (set! .make-null-terminated|2 (lambda (.formals|3) (if (null? .formals|3) '() (if (symbol? .formals|3) (cons .formals|3 '()) (cons (let ((.x|8|11 .formals|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (.make-null-terminated|2 (let ((.x|12|15 .formals|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))))))) (.make-null-terminated|2 .formals|1))))) 'make-null-terminated))
+(let () (begin (set! list-head (lambda (.x|1 .n|1) (let ((.list-head|2 0)) (begin (set! .list-head|2 (lambda (.x|3 .n|3) (if (zero? .n|3) '() (cons (let ((.x|6|9 .x|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) (.list-head|2 (let ((.x|10|13 .x|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))) (- .n|3 1)))))) (.list-head|2 .x|1 .n|1))))) 'list-head))
+(let () (begin (set! remq (lambda (.x|1 .y|1) (let ((.remq|2 0)) (begin (set! .remq|2 (lambda (.x|3 .y|3) (if (null? .y|3) '() (if (eq? .x|3 (let ((.x|6|9 .y|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) (.remq|2 .x|3 (let ((.x|10|13 .y|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) (cons (let ((.x|15|18 .y|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (.remq|2 .x|3 (let ((.x|19|22 .y|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))))) (.remq|2 .x|1 .y|1))))) 'remq))
+(let () (begin (set! make-call-to-list (lambda (.args|1) (let ((.make-call-to-list|2 0)) (begin (set! .make-call-to-list|2 (lambda (.args|3) (if (null? .args|3) (make-constant '()) (if (null? (let ((.x|6|9 .args|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (make-call (make-variable name:cons) (let* ((.t1|10|13 (let ((.x|21|24 .args|3)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) (.t2|10|16 (cons (make-constant '()) '()))) (let () (cons .t1|10|13 .t2|10|16)))) (make-call (make-variable name:list) .args|3))))) (.make-call-to-list|2 .args|1))))) 'make-call-to-list))
+(let () (begin (set! pass2-error (lambda (.i|1 . .etc|1) (apply cerror (cons (let ((.v|2|5 pass2-error-messages) (.i|2|5 .i|1)) (begin (.check! (fixnum? .i|2|5) 40 .v|2|5 .i|2|5) (.check! (vector? .v|2|5) 40 .v|2|5 .i|2|5) (.check! (<:fix:fix .i|2|5 (vector-length:vec .v|2|5)) 40 .v|2|5 .i|2|5) (.check! (>=:fix:fix .i|2|5 0) 40 .v|2|5 .i|2|5) (vector-ref:trusted .v|2|5 .i|2|5))) .etc|1)))) 'pass2-error))
+(let () (begin (set! pass2-error-messages '#("System error: violation of an invariant in pass 2" "Wrong number of arguments to known procedure")) 'pass2-error-messages))
+(let () (begin (set! p2error:violation-of-invariant 0) 'p2error:violation-of-invariant))
+(let () (begin (set! p2error:wna 1) 'p2error:wna))
+(let () (begin (set! make-r-entry (lambda (.name|1 .refs|1 .assigns|1 .calls|1) (let ((.make-r-entry|2 0)) (begin (set! .make-r-entry|2 (lambda (.name|3 .refs|3 .assigns|3 .calls|3) (let* ((.t1|4|7 .name|3) (.t2|4|10 (let* ((.t1|14|17 .refs|3) (.t2|14|20 (let* ((.t1|24|27 .assigns|3) (.t2|24|30 (cons .calls|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-r-entry|2 .name|1 .refs|1 .assigns|1 .calls|1))))) 'make-r-entry))
+(let () (begin (set! r-entry.name (lambda (.x|1) (let ((.r-entry.name|2 0)) (begin (set! .r-entry.name|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.r-entry.name|2 .x|1))))) 'r-entry.name))
+(let () (begin (set! r-entry.references (lambda (.x|1) (let ((.r-entry.references|2 0)) (begin (set! .r-entry.references|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.references|2 .x|1))))) 'r-entry.references))
+(let () (begin (set! r-entry.assignments (lambda (.x|1) (let ((.r-entry.assignments|2 0)) (begin (set! .r-entry.assignments|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.assignments|2 .x|1))))) 'r-entry.assignments))
+(let () (begin (set! r-entry.calls (lambda (.x|1) (let ((.r-entry.calls|2 0)) (begin (set! .r-entry.calls|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .x|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.r-entry.calls|2 .x|1))))) 'r-entry.calls))
+(let () (begin (set! r-entry.references-set! (lambda (.x|1 .refs|1) (let ((.r-entry.references-set!|2 0)) (begin (set! .r-entry.references-set!|2 (lambda (.x|3 .refs|3) (set-car! (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .refs|3))) (.r-entry.references-set!|2 .x|1 .refs|1))))) 'r-entry.references-set!))
+(let () (begin (set! r-entry.assignments-set! (lambda (.x|1 .assignments|1) (let ((.r-entry.assignments-set!|2 0)) (begin (set! .r-entry.assignments-set!|2 (lambda (.x|3 .assignments|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .assignments|3))) (.r-entry.assignments-set!|2 .x|1 .assignments|1))))) 'r-entry.assignments-set!))
+(let () (begin (set! r-entry.calls-set! (lambda (.x|1 .calls|1) (let ((.r-entry.calls-set!|2 0)) (begin (set! .r-entry.calls-set!|2 (lambda (.x|3 .calls|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .calls|3))) (.r-entry.calls-set!|2 .x|1 .calls|1))))) 'r-entry.calls-set!))
+(let () (begin (set! local? (lambda (.r|1 .i|1) (let ((.local?|2 0)) (begin (set! .local?|2 (lambda (.r|3 .i|3) (assq .i|3 .r|3))) (.local?|2 .r|1 .i|1))))) 'local?))
+(let () (begin (set! r-entry (lambda (.r|1 .i|1) (let ((.r-entry|2 0)) (begin (set! .r-entry|2 (lambda (.r|3 .i|3) (assq .i|3 .r|3))) (.r-entry|2 .r|1 .i|1))))) 'r-entry))
+(let () (begin (set! r-lookup (lambda (.r|1 .i|1) (let ((.r-lookup|2 0)) (begin (set! .r-lookup|2 (lambda (.r|3 .i|3) (let ((.temp|4|7 (assq .i|3 .r|3))) (if .temp|4|7 .temp|4|7 (pass2-error p2error:violation-of-invariant .r|3 .i|3))))) (.r-lookup|2 .r|1 .i|1))))) 'r-lookup))
+(let () (begin (set! references (lambda (.r|1 .i|1) (let ((.references|2 0)) (begin (set! .references|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.references|2 .r|1 .i|1))))) 'references))
+(let () (begin (set! assignments (lambda (.r|1 .i|1) (let ((.assignments|2 0)) (begin (set! .assignments|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assignments|2 .r|1 .i|1))))) 'assignments))
+(let () (begin (set! calls (lambda (.r|1 .i|1) (let ((.calls|2 0)) (begin (set! .calls|2 (lambda (.r|3 .i|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.calls|2 .r|1 .i|1))))) 'calls))
+(let () (begin (set! references-set! (lambda (.r|1 .i|1 .x|1) (let ((.references-set!|2 0)) (begin (set! .references-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|4|7 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .x|3))) (.references-set!|2 .r|1 .i|1 .x|1))))) 'references-set!))
+(let () (begin (set! assignments-set! (lambda (.r|1 .i|1 .x|1) (let ((.assignments-set!|2 0)) (begin (set! .assignments-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .x|3))) (.assignments-set!|2 .r|1 .i|1 .x|1))))) 'assignments-set!))
+(let () (begin (set! calls-set! (lambda (.r|1 .i|1 .x|1) (let ((.calls-set!|2 0)) (begin (set! .calls-set!|2 (lambda (.r|3 .i|3 .x|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (r-lookup .r|3 .i|3))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .x|3))) (.calls-set!|2 .r|1 .i|1 .x|1))))) 'calls-set!))
+(let () (begin (set! make-notepad (lambda (.l|1) (let ((.make-notepad|2 0)) (begin (set! .make-notepad|2 (lambda (.l|3) (let* ((.t|4|8|13 '()) (.t|4|7|16 '()) (.t|4|6|19 '()) (.t|4|5|22 .l|3) (.v|4|10|25 (make-vector 4 .t|4|8|13))) (let () (begin (let ((.v|29|32 .v|4|10|25) (.i|29|32 2) (.x|29|32 .t|4|7|16)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) (let ((.v|33|36 .v|4|10|25) (.i|33|36 1) (.x|33|36 .t|4|6|19)) (begin (.check! (fixnum? .i|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (vector? .v|33|36) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (<:fix:fix .i|33|36 (vector-length:vec .v|33|36)) 41 .v|33|36 .i|33|36 .x|33|36) (.check! (>=:fix:fix .i|33|36 0) 41 .v|33|36 .i|33|36 .x|33|36) (vector-set!:trusted .v|33|36 .i|33|36 .x|33|36))) (let ((.v|37|40 .v|4|10|25) (.i|37|40 0) (.x|37|40 .t|4|5|22)) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) .v|4|10|25))))) (.make-notepad|2 .l|1))))) 'make-notepad))
+(let () (begin (set! notepad.parent (lambda (.np|1) (let ((.notepad.parent|2 0)) (begin (set! .notepad.parent|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 0)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.parent|2 .np|1))))) 'notepad.parent))
+(let () (begin (set! notepad.lambdas (lambda (.np|1) (let ((.notepad.lambdas|2 0)) (begin (set! .notepad.lambdas|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.lambdas|2 .np|1))))) 'notepad.lambdas))
+(let () (begin (set! notepad.nonescaping (lambda (.np|1) (let ((.notepad.nonescaping|2 0)) (begin (set! .notepad.nonescaping|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.nonescaping|2 .np|1))))) 'notepad.nonescaping))
+(let () (begin (set! notepad.vars (lambda (.np|1) (let ((.notepad.vars|2 0)) (begin (set! .notepad.vars|2 (lambda (.np|3) (let ((.v|4|7 .np|3) (.i|4|7 3)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.notepad.vars|2 .np|1))))) 'notepad.vars))
+(let () (begin (set! notepad.lambdas-set! (lambda (.np|1 .x|1) (let ((.notepad.lambdas-set!|2 0)) (begin (set! .notepad.lambdas-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 1) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.lambdas-set!|2 .np|1 .x|1))))) 'notepad.lambdas-set!))
+(let () (begin (set! notepad.nonescaping-set! (lambda (.np|1 .x|1) (let ((.notepad.nonescaping-set!|2 0)) (begin (set! .notepad.nonescaping-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 2) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.nonescaping-set!|2 .np|1 .x|1))))) 'notepad.nonescaping-set!))
+(let () (begin (set! notepad.vars-set! (lambda (.np|1 .x|1) (let ((.notepad.vars-set!|2 0)) (begin (set! .notepad.vars-set!|2 (lambda (.np|3 .x|3) (let ((.v|4|7 .np|3) (.i|4|7 3) (.x|4|7 .x|3)) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))))) (.notepad.vars-set!|2 .np|1 .x|1))))) 'notepad.vars-set!))
+(let () (begin (set! notepad-lambda-add! (lambda (.np|1 .l|1) (let ((.notepad-lambda-add!|2 0)) (begin (set! .notepad-lambda-add!|2 (lambda (.np|3 .l|3) (notepad.lambdas-set! .np|3 (cons .l|3 (notepad.lambdas .np|3))))) (.notepad-lambda-add!|2 .np|1 .l|1))))) 'notepad-lambda-add!))
+(let () (begin (set! notepad-nonescaping-add! (lambda (.np|1 .l|1) (let ((.notepad-nonescaping-add!|2 0)) (begin (set! .notepad-nonescaping-add!|2 (lambda (.np|3 .l|3) (notepad.nonescaping-set! .np|3 (cons .l|3 (notepad.nonescaping .np|3))))) (.notepad-nonescaping-add!|2 .np|1 .l|1))))) 'notepad-nonescaping-add!))
+(let () (begin (set! notepad-var-add! (lambda (.np|1 .i|1) (let ((.notepad-var-add!|2 0)) (begin (set! .notepad-var-add!|2 (lambda (.np|3 .i|3) (let ((.vars|6 (notepad.vars .np|3))) (if (not (memq .i|3 .vars|6)) (notepad.vars-set! .np|3 (cons .i|3 .vars|6)) (unspecified))))) (.notepad-var-add!|2 .np|1 .i|1))))) 'notepad-var-add!))
+(let () (begin (set! notepad-captured-variables (lambda (.np|1) (let ((.notepad-captured-variables|2 0)) (begin (set! .notepad-captured-variables|2 (lambda (.np|3) (let ((.nonescaping|6 (notepad.nonescaping .np|3))) (apply-union (let () (let ((.loop|12|15|18 (unspecified))) (begin (set! .loop|12|15|18 (lambda (.y1|7|8|19 .results|7|11|19) (if (null? .y1|7|8|19) (reverse .results|7|11|19) (begin #t (.loop|12|15|18 (let ((.x|23|26 .y1|7|8|19)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))) (cons (let ((.l|27 (let ((.x|28|31 .y1|7|8|19)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (if (memq .l|27 .nonescaping|6) (lambda.g .l|27) (lambda.f .l|27))) .results|7|11|19)))))) (.loop|12|15|18 (notepad.lambdas .np|3) '())))))))) (.notepad-captured-variables|2 .np|1))))) 'notepad-captured-variables))
+(let () (begin (set! notepad-free-variables (lambda (.np|1) (let ((.notepad-free-variables|2 0)) (begin (set! .notepad-free-variables|2 (lambda (.np|3) (let () (let ((.loop|4|7|10 (unspecified))) (begin (set! .loop|4|7|10 (lambda (.lambdas|11 .fv|11) (if (null? .lambdas|11) .fv|11 (begin #t (.loop|4|7|10 (let ((.x|14|17 .lambdas|11)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (let ((.l|20 (let ((.x|21|24 .lambdas|11)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (union (difference (lambda.f .l|20) (make-null-terminated (lambda.args .l|20))) .fv|11))))))) (.loop|4|7|10 (notepad.lambdas .np|3) (notepad.vars .np|3))))))) (.notepad-free-variables|2 .np|1))))) 'notepad-free-variables))
+(let () ($$trace "prefs"))
+(let () (begin (set! begin1 (string->symbol "Begin")) 'begin1))
+(let () (begin (set! define1 (string->symbol "Define")) 'define1))
+(let () (begin (set! quote1 (string->symbol "Quote")) 'quote1))
+(let () (begin (set! lambda1 (string->symbol "Lambda")) 'lambda1))
+(let () (begin (set! if1 (string->symbol "If")) 'if1))
+(let () (begin (set! set!1 (string->symbol "Set!")) 'set!1))
+(let () (begin (set! undefined1 (cons (string->symbol "Undefined") '())) 'undefined1))
+(let () (begin (set! renaming-prefix-character #\.) 'renaming-prefix-character))
+(let () (begin (set! renaming-suffix-character #\|) 'renaming-suffix-character))
+(let () (begin (set! renaming-prefix (string renaming-prefix-character)) 'renaming-prefix))
+(let () (begin (set! renaming-suffix (string renaming-suffix-character)) 'renaming-suffix))
+(let () (begin (set! make-toplevel-definition (lambda (.id|1 .exp|1) (let ((.make-toplevel-definition|2 0)) (begin (set! .make-toplevel-definition|2 (lambda (.id|3 .exp|3) (begin (if (lambda? .exp|3) (doc.name-set! (lambda.doc .exp|3) .id|3) (unspecified)) (make-begin (let* ((.t1|4|7 (make-assignment .id|3 .exp|3)) (.t2|4|10 (cons (make-constant .id|3) '()))) (let () (cons .t1|4|7 .t2|4|10))))))) (.make-toplevel-definition|2 .id|1 .exp|1))))) 'make-toplevel-definition))
+(let () (begin (set! make-undefined (lambda () (let ((.make-undefined|2 0)) (begin (set! .make-undefined|2 (lambda () (make-call (make-variable 'undefined) '()))) (.make-undefined|2))))) 'make-undefined))
+(let () (begin (set! make-unspecified (lambda () (let ((.make-unspecified|2 0)) (begin (set! .make-unspecified|2 (lambda () (make-call (make-variable 'unspecified) '()))) (.make-unspecified|2))))) 'make-unspecified))
+(let () ($$trace "syntaxenv"))
+(let () (begin (set! standard-syntactic-environment '((quote special quote) (lambda special lambda) (if special if) (set! special set!) (begin special begin) (define special define) (define-inline special define-inline) (define-syntax special define-syntax) (let-syntax special let-syntax) (letrec-syntax special letrec-syntax) (syntax-rules special syntax-rules))) 'standard-syntactic-environment))
+(let () (begin (set! lambda0 (string->symbol " lambda ")) 'lambda0))
+(let () (begin (set! set!0 (string->symbol " set! ")) 'set!0))
+(let () (begin (set! syntactic-copy (lambda (.env|1) (let ((.syntactic-copy|2 0)) (begin (set! .syntactic-copy|2 (lambda (.env|3) (copy-alist .env|3))) (.syntactic-copy|2 .env|1))))) 'syntactic-copy))
+(let () (begin (set! make-basic-syntactic-environment (lambda () (let ((.make-basic-syntactic-environment|2 0)) (begin (set! .make-basic-syntactic-environment|2 (lambda () (cons (cons lambda0 (let ((.x|4|7 (assq 'lambda standard-syntactic-environment))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (cons (cons set!0 (let ((.x|8|11 (assq 'set! standard-syntactic-environment))) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))) (syntactic-copy standard-syntactic-environment))))) (.make-basic-syntactic-environment|2))))) 'make-basic-syntactic-environment))
+(let () (begin (set! global-syntactic-environment (make-basic-syntactic-environment)) 'global-syntactic-environment))
+(let () (begin (set! global-syntactic-environment-set! (lambda (.env|1) (let ((.global-syntactic-environment-set!|2 0)) (begin (set! .global-syntactic-environment-set!|2 (lambda (.env|3) (begin (set-cdr! global-syntactic-environment .env|3) #t))) (.global-syntactic-environment-set!|2 .env|1))))) 'global-syntactic-environment-set!))
+(let () (begin (set! syntactic-bind-globally! (lambda (.id|1 .denotation|1) (let ((.syntactic-bind-globally!|2 0)) (begin (set! .syntactic-bind-globally!|2 (lambda (.id|3 .denotation|3) (if (if (identifier-denotation? .denotation|3) (eq? .id|3 (identifier-name .denotation|3)) #f) (let () (let ((.remove-bindings-for-id|8 (unspecified))) (begin (set! .remove-bindings-for-id|8 (lambda (.bindings|9) (if (null? .bindings|9) '() (if (eq? (let ((.x|13|16 (let ((.x|17|20 .bindings|9)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) .id|3) (.remove-bindings-for-id|8 (let ((.x|21|24 .bindings|9)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) (cons (let ((.x|26|29 .bindings|9)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) (.remove-bindings-for-id|8 (let ((.x|30|33 .bindings|9)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))))))) (global-syntactic-environment-set! (.remove-bindings-for-id|8 (let ((.x|34|37 global-syntactic-environment)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37)))))))) (let ((.x|40 (assq .id|3 global-syntactic-environment))) (if .x|40 (begin (set-cdr! .x|40 .denotation|3) #t) (global-syntactic-environment-set! (cons (cons .id|3 .denotation|3) (let ((.x|41|44 global-syntactic-environment)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44)))))))))) (.syntactic-bind-globally!|2 .id|1 .denotation|1))))) 'syntactic-bind-globally!))
+(let () (begin (set! syntactic-divert (lambda (.env1|1 .env2|1) (let ((.syntactic-divert|2 0)) (begin (set! .syntactic-divert|2 (lambda (.env1|3 .env2|3) (append .env2|3 .env1|3))) (.syntactic-divert|2 .env1|1 .env2|1))))) 'syntactic-divert))
+(let () (begin (set! syntactic-extend (lambda (.env|1 .ids|1 .denotations|1) (let ((.syntactic-extend|2 0)) (begin (set! .syntactic-extend|2 (lambda (.env|3 .ids|3 .denotations|3) (syntactic-divert .env|3 (let () (let ((.loop|10|14|17 (unspecified))) (begin (set! .loop|10|14|17 (lambda (.y1|4|6|18 .y1|4|5|18 .results|4|9|18) (if (let ((.temp|20|23 (null? .y1|4|6|18))) (if .temp|20|23 .temp|20|23 (null? .y1|4|5|18))) (reverse .results|4|9|18) (begin #t (.loop|10|14|17 (let ((.x|26|29 .y1|4|6|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (let ((.x|30|33 .y1|4|5|18)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) (cons (cons (let ((.x|34|37 .y1|4|6|18)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) (let ((.x|38|41 .y1|4|5|18)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41)))) .results|4|9|18)))))) (.loop|10|14|17 .ids|3 .denotations|3 '()))))))) (.syntactic-extend|2 .env|1 .ids|1 .denotations|1))))) 'syntactic-extend))
+(let () (begin (set! syntactic-lookup (lambda (.env|1 .id|1) (let ((.syntactic-lookup|2 0)) (begin (set! .syntactic-lookup|2 (lambda (.env|3 .id|3) (let ((.entry|6 (assq .id|3 .env|3))) (if .entry|6 (let ((.x|7|10 .entry|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) (make-identifier-denotation .id|3))))) (.syntactic-lookup|2 .env|1 .id|1))))) 'syntactic-lookup))
+(let () (begin (set! syntactic-assign! (lambda (.env|1 .id|1 .denotation|1) (let ((.syntactic-assign!|2 0)) (begin (set! .syntactic-assign!|2 (lambda (.env|3 .id|3 .denotation|3) (let ((.entry|6 (assq .id|3 .env|3))) (if .entry|6 (set-cdr! .entry|6 .denotation|3) (m-bug "Bug detected in syntactic-assign!" .env|3 .id|3 .denotation|3))))) (.syntactic-assign!|2 .env|1 .id|1 .denotation|1))))) 'syntactic-assign!))
+(let () (begin (set! denotation-class car) 'denotation-class))
+(let () (begin (set! special-denotation? (lambda (.denotation|1) (let ((.special-denotation?|2 0)) (begin (set! .special-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'special))) (.special-denotation?|2 .denotation|1))))) 'special-denotation?))
+(let () (begin (set! macro-denotation? (lambda (.denotation|1) (let ((.macro-denotation?|2 0)) (begin (set! .macro-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'macro))) (.macro-denotation?|2 .denotation|1))))) 'macro-denotation?))
+(let () (begin (set! inline-denotation? (lambda (.denotation|1) (let ((.inline-denotation?|2 0)) (begin (set! .inline-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'inline))) (.inline-denotation?|2 .denotation|1))))) 'inline-denotation?))
+(let () (begin (set! identifier-denotation? (lambda (.denotation|1) (let ((.identifier-denotation?|2 0)) (begin (set! .identifier-denotation?|2 (lambda (.denotation|3) (eq? (denotation-class .denotation|3) 'identifier))) (.identifier-denotation?|2 .denotation|1))))) 'identifier-denotation?))
+(let () (begin (set! make-macro-denotation (lambda (.rules|1 .env|1) (let ((.make-macro-denotation|2 0)) (begin (set! .make-macro-denotation|2 (lambda (.rules|3 .env|3) (let* ((.t1|4|7 'macro) (.t2|4|10 (let* ((.t1|14|17 .rules|3) (.t2|14|20 (cons .env|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-macro-denotation|2 .rules|1 .env|1))))) 'make-macro-denotation))
+(let () (begin (set! make-inline-denotation (lambda (.id|1 .rules|1 .env|1) (let ((.make-inline-denotation|2 0)) (begin (set! .make-inline-denotation|2 (lambda (.id|3 .rules|3 .env|3) (let* ((.t1|4|7 'inline) (.t2|4|10 (let* ((.t1|14|17 .rules|3) (.t2|14|20 (let* ((.t1|24|27 .env|3) (.t2|24|30 (cons .id|3 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-inline-denotation|2 .id|1 .rules|1 .env|1))))) 'make-inline-denotation))
+(let () (begin (set! make-identifier-denotation (lambda (.id|1) (let ((.make-identifier-denotation|2 0)) (begin (set! .make-identifier-denotation|2 (lambda (.id|3) (let* ((.t1|4|7 'identifier) (.t2|4|10 (let* ((.t1|14|17 .id|3) (.t2|14|20 (let* ((.t1|24|27 '()) (.t2|24|30 (let* ((.t1|34|37 '()) (.t2|34|40 (cons '() '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-identifier-denotation|2 .id|1))))) 'make-identifier-denotation))
+(let () (begin (set! macro-rules cadr) 'macro-rules))
+(let () (begin (set! macro-env caddr) 'macro-env))
+(let () (begin (set! inline-rules macro-rules) 'inline-rules))
+(let () (begin (set! inline-env macro-env) 'inline-env))
+(let () (begin (set! inline-name cadddr) 'inline-name))
+(let () (begin (set! identifier-name cadr) 'identifier-name))
+(let () (begin (set! identifier-r-entry cdr) 'identifier-r-entry))
+(let () (begin (set! same-denotation? (lambda (.d1|1 .d2|1) (let ((.same-denotation?|2 0)) (begin (set! .same-denotation?|2 (lambda (.d1|3 .d2|3) (let ((.temp|4|7 (eq? .d1|3 .d2|3))) (if .temp|4|7 .temp|4|7 (if (identifier-denotation? .d1|3) (if (identifier-denotation? .d2|3) (eq? (identifier-name .d1|3) (identifier-name .d2|3)) #f) #f))))) (.same-denotation?|2 .d1|1 .d2|1))))) 'same-denotation?))
+(let () (begin (set! denotation-of-quote (syntactic-lookup standard-syntactic-environment 'quote)) 'denotation-of-quote))
+(let () (begin (set! denotation-of-lambda (syntactic-lookup standard-syntactic-environment 'lambda)) 'denotation-of-lambda))
+(let () (begin (set! denotation-of-if (syntactic-lookup standard-syntactic-environment 'if)) 'denotation-of-if))
+(let () (begin (set! denotation-of-set! (syntactic-lookup standard-syntactic-environment 'set!)) 'denotation-of-set!))
+(let () (begin (set! denotation-of-begin (syntactic-lookup standard-syntactic-environment 'begin)) 'denotation-of-begin))
+(let () (begin (set! denotation-of-define (syntactic-lookup standard-syntactic-environment 'define)) 'denotation-of-define))
+(let () (begin (set! denotation-of-define-inline (syntactic-lookup standard-syntactic-environment 'define-inline)) 'denotation-of-define-inline))
+(let () (begin (set! denotation-of-define-syntax (syntactic-lookup standard-syntactic-environment 'define-syntax)) 'denotation-of-define-syntax))
+(let () (begin (set! denotation-of-let-syntax (syntactic-lookup standard-syntactic-environment 'let-syntax)) 'denotation-of-let-syntax))
+(let () (begin (set! denotation-of-letrec-syntax (syntactic-lookup standard-syntactic-environment 'letrec-syntax)) 'denotation-of-letrec-syntax))
+(let () (begin (set! denotation-of-syntax-rules (syntactic-lookup standard-syntactic-environment 'syntax-rules)) 'denotation-of-syntax-rules))
+(let () (begin (set! denotation-of-... (syntactic-lookup standard-syntactic-environment '...)) 'denotation-of-...))
+(let () (begin (set! denotation-of-transformer (syntactic-lookup standard-syntactic-environment 'transformer)) 'denotation-of-transformer))
+(let () (begin (set! syntactic-alias (lambda (.env|1 .alist|1 .env2|1) (let ((.syntactic-alias|2 0)) (begin (set! .syntactic-alias|2 (lambda (.env|3 .alist|3 .env2|3) (syntactic-divert .env|3 (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.name-pair|24 (let ((.x|36|39 .y1|4|5|16)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (let ((.old-name|27 (let ((.x|28|31 .name-pair|24)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.new-name|27 (let ((.x|32|35 .name-pair|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))))) (cons .new-name|27 (syntactic-lookup .env2|3 .old-name|27)))) .results|4|8|16)))))) (.loop|9|12|15 .alist|3 '()))))))) (.syntactic-alias|2 .env|1 .alist|1 .env2|1))))) 'syntactic-alias))
+(let () (begin (set! syntactic-rename (lambda (.env|1 .alist|1) (let ((.syntactic-rename|2 0)) (begin (set! .syntactic-rename|2 (lambda (.env|3 .alist|3) (if (null? .alist|3) .env|3 (let* ((.old|6 (let ((.x|30|33 (let ((.x|34|37 .alist|3)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (.new|9 (let ((.x|21|24 (let ((.x|25|28 .alist|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) (.denotation|12 (make-identifier-denotation .new|9))) (let () (.syntactic-rename|2 (cons (cons .old|6 .denotation|12) (cons (cons .new|9 .denotation|12) .env|3)) (let ((.x|16|19 .alist|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))))))) (.syntactic-rename|2 .env|1 .alist|1))))) 'syntactic-rename))
+(let () (begin (set! renaming-counter 0) 'renaming-counter))
+(let () (begin (set! make-rename-procedure (lambda () (let ((.make-rename-procedure|2 0)) (begin (set! .make-rename-procedure|2 (lambda () (begin (set! renaming-counter (+ renaming-counter 1)) (let ((.suffix|6 (string-append renaming-suffix (number->string renaming-counter)))) (lambda (.sym|7) (if (symbol? .sym|7) (let ((.s|10 (symbol->string .sym|7))) (if (if (> (string-length .s|10) 0) (char=? (string-ref .s|10 0) renaming-prefix-character) #f) (string->symbol (string-append .s|10 .suffix|6)) (string->symbol (string-append renaming-prefix .s|10 .suffix|6)))) (m-warn "Illegal use of rename procedure" 'ok:fixme .sym|7))))))) (.make-rename-procedure|2))))) 'make-rename-procedure))
+(let () (begin (set! m-strip (lambda (.x|1) (let ((.m-strip|2 0)) (begin (set! .m-strip|2 (lambda (.x|3) (let ((.original-symbol|5 (unspecified))) (begin (set! .original-symbol|5 (lambda (.x|6) (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.sym|10 .s|10 .i|10 .n|10) (if (= .i|10 .n|10) .sym|10 (if (char=? (string-ref .s|10 .i|10) renaming-suffix-character) (string->symbol (substring .s|10 1 .i|10)) (.loop|9 .sym|10 .s|10 (+ .i|10 1) .n|10))))) (let ((.s|14 (symbol->string .x|6))) (if (if (> (string-length .s|14) 0) (char=? (string-ref .s|14 0) renaming-prefix-character) #f) (.loop|9 .x|6 .s|14 0 (string-length .s|14)) .x|6)))))) (if (symbol? .x|3) (.original-symbol|5 .x|3) (if (pair? .x|3) (let ((.a|21 (.m-strip|2 (let ((.x|32|35 .x|3)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))))) (.b|21 (.m-strip|2 (let ((.x|36|39 .x|3)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39)))))) (if (if (eq? .a|21 (let ((.x|23|26 .x|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26)))) (eq? .b|21 (let ((.x|28|31 .x|3)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31)))) #f) .x|3 (cons .a|21 .b|21))) (if (vector? .x|3) (let* ((.v|43 (vector->list .x|3)) (.v2|46 (let () (let ((.loop|55|58|61 (unspecified))) (begin (set! .loop|55|58|61 (lambda (.y1|50|51|62 .results|50|54|62) (if (null? .y1|50|51|62) (reverse .results|50|54|62) (begin #t (.loop|55|58|61 (let ((.x|66|69 .y1|50|51|62)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (cons (.m-strip|2 (let ((.x|70|73 .y1|50|51|62)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) .results|50|54|62)))))) (.loop|55|58|61 .v|43 '())))))) (let () (if (equal? .v|43 .v2|46) .x|3 (list->vector .v2|46)))) .x|3))))))) (.m-strip|2 .x|1))))) 'm-strip))
+(let () (begin (set! rename-vars (lambda (.original-vars|1) (let ((.rename-vars|2 0)) (begin (set! .rename-vars|2 (lambda (.original-vars|3) (let* ((.rename|6 (make-rename-procedure)) (.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.vars|8 .newvars|8) (if (null? .vars|8) (reverse .newvars|8) (if (pair? .vars|8) (let ((.var|13 (let ((.x|18|21 .vars|8)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if (symbol? .var|13) (.loop|7 (let ((.x|14|17 .vars|8)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (cons (cons .var|13 (.rename|6 .var|13)) .newvars|8)) (m-error "Illegal variable" .var|13))) (if (symbol? .vars|8) (.loop|7 (cons .vars|8 '()) .newvars|8) (m-error "Malformed parameter list" .original-vars|3)))))) (.loop|7 .original-vars|3 '()))))) (.rename-vars|2 .original-vars|1))))) 'rename-vars))
+(let () (begin (set! rename-formals (lambda (.formals|1 .alist|1) (let ((.rename-formals|2 0)) (begin (set! .rename-formals|2 (lambda (.formals|3 .alist|3) (if (null? .formals|3) '() (if (pair? .formals|3) (cons (let ((.x|6|9 (assq (let ((.x|10|13 .formals|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) .alist|3))) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9))) (.rename-formals|2 (let ((.x|14|17 .formals|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) .alist|3)) (let ((.x|19|22 (assq .formals|3 .alist|3))) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))) (.rename-formals|2 .formals|1 .alist|1))))) 'rename-formals))
+(let () ($$trace "syntaxrules"))
+(let () (begin (set! pattern-variable-flag (cons 'v '())) 'pattern-variable-flag))
+(let () (begin (set! ellipsis-pattern-flag (cons 'e '())) 'ellipsis-pattern-flag))
+(let () (begin (set! ellipsis-template-flag ellipsis-pattern-flag) 'ellipsis-template-flag))
+(let () (begin (set! make-patternvar (lambda (.v|1 .rank|1) (let ((.make-patternvar|2 0)) (begin (set! .make-patternvar|2 (lambda (.v|3 .rank|3) (let* ((.t|4|7|12 .rank|3) (.t|4|6|15 .v|3) (.t|4|5|18 pattern-variable-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-patternvar|2 .v|1 .rank|1))))) 'make-patternvar))
+(let () (begin (set! make-ellipsis-pattern (lambda (.p|1 .vars|1) (let ((.make-ellipsis-pattern|2 0)) (begin (set! .make-ellipsis-pattern|2 (lambda (.p|3 .vars|3) (let* ((.t|4|7|12 .vars|3) (.t|4|6|15 .p|3) (.t|4|5|18 ellipsis-pattern-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-ellipsis-pattern|2 .p|1 .vars|1))))) 'make-ellipsis-pattern))
+(let () (begin (set! make-ellipsis-template (lambda (.t|1 .vars|1) (let ((.make-ellipsis-template|2 0)) (begin (set! .make-ellipsis-template|2 (lambda (.t|3 .vars|3) (let* ((.t|4|7|12 .vars|3) (.t|4|6|15 .t|3) (.t|4|5|18 ellipsis-template-flag) (.v|4|9|21 (make-vector 3 .t|4|7|12))) (let () (begin (let ((.v|25|28 .v|4|9|21) (.i|25|28 1) (.x|25|28 .t|4|6|15)) (begin (.check! (fixnum? .i|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (vector? .v|25|28) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 41 .v|25|28 .i|25|28 .x|25|28) (.check! (>=:fix:fix .i|25|28 0) 41 .v|25|28 .i|25|28 .x|25|28) (vector-set!:trusted .v|25|28 .i|25|28 .x|25|28))) (let ((.v|29|32 .v|4|9|21) (.i|29|32 0) (.x|29|32 .t|4|5|18)) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) .v|4|9|21))))) (.make-ellipsis-template|2 .t|1 .vars|1))))) 'make-ellipsis-template))
+(let () (begin (set! patternvar? (lambda (.x|1) (let ((.patternvar?|2 0)) (begin (set! .patternvar?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) pattern-variable-flag) #f) #f))) (.patternvar?|2 .x|1))))) 'patternvar?))
+(let () (begin (set! ellipsis-pattern? (lambda (.x|1) (let ((.ellipsis-pattern?|2 0)) (begin (set! .ellipsis-pattern?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) ellipsis-pattern-flag) #f) #f))) (.ellipsis-pattern?|2 .x|1))))) 'ellipsis-pattern?))
+(let () (begin (set! ellipsis-template? (lambda (.x|1) (let ((.ellipsis-template?|2 0)) (begin (set! .ellipsis-template?|2 (lambda (.x|3) (if (vector? .x|3) (if (= (let ((.v|6|9 .x|3)) (begin (.check! (vector? .v|6|9) 42 .v|6|9) (vector-length:vec .v|6|9))) 3) (eq? (let ((.v|11|14 .x|3) (.i|11|14 0)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14))) ellipsis-template-flag) #f) #f))) (.ellipsis-template?|2 .x|1))))) 'ellipsis-template?))
+(let () (begin (set! patternvar-name (lambda (.v|1) (let ((.patternvar-name|2 0)) (begin (set! .patternvar-name|2 (lambda (.v|3) (let ((.v|4|7 .v|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.patternvar-name|2 .v|1))))) 'patternvar-name))
+(let () (begin (set! patternvar-rank (lambda (.v|1) (let ((.patternvar-rank|2 0)) (begin (set! .patternvar-rank|2 (lambda (.v|3) (let ((.v|4|7 .v|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.patternvar-rank|2 .v|1))))) 'patternvar-rank))
+(let () (begin (set! ellipsis-pattern (lambda (.p|1) (let ((.ellipsis-pattern|2 0)) (begin (set! .ellipsis-pattern|2 (lambda (.p|3) (let ((.v|4|7 .p|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-pattern|2 .p|1))))) 'ellipsis-pattern))
+(let () (begin (set! ellipsis-pattern-vars (lambda (.p|1) (let ((.ellipsis-pattern-vars|2 0)) (begin (set! .ellipsis-pattern-vars|2 (lambda (.p|3) (let ((.v|4|7 .p|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-pattern-vars|2 .p|1))))) 'ellipsis-pattern-vars))
+(let () (begin (set! ellipsis-template (lambda (.t|1) (let ((.ellipsis-template|2 0)) (begin (set! .ellipsis-template|2 (lambda (.t|3) (let ((.v|4|7 .t|3) (.i|4|7 1)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-template|2 .t|1))))) 'ellipsis-template))
+(let () (begin (set! ellipsis-template-vars (lambda (.t|1) (let ((.ellipsis-template-vars|2 0)) (begin (set! .ellipsis-template-vars|2 (lambda (.t|3) (let ((.v|4|7 .t|3) (.i|4|7 2)) (begin (.check! (fixnum? .i|4|7) 40 .v|4|7 .i|4|7) (.check! (vector? .v|4|7) 40 .v|4|7 .i|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 40 .v|4|7 .i|4|7) (.check! (>=:fix:fix .i|4|7 0) 40 .v|4|7 .i|4|7) (vector-ref:trusted .v|4|7 .i|4|7))))) (.ellipsis-template-vars|2 .t|1))))) 'ellipsis-template-vars))
+(let () (begin (set! pattern-variable (lambda (.v|1 .vars|1) (let ((.pattern-variable|2 0)) (begin (set! .pattern-variable|2 (lambda (.v|3 .vars|3) (if (null? .vars|3) #f (if (eq? .v|3 (patternvar-name (let ((.x|6|9 .vars|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))))) (let ((.x|10|13 .vars|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) (.pattern-variable|2 .v|3 (let ((.x|15|18 .vars|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))))) (.pattern-variable|2 .v|1 .vars|1))))) 'pattern-variable))
+(let () (begin (set! m-compile-transformer-spec (lambda (.spec|1 .env|1) (let ((.m-compile-transformer-spec|2 0)) (begin (set! .m-compile-transformer-spec|2 (lambda (.spec|3 .env|3) (if (if (> (safe-length .spec|3) 1) (eq? (syntactic-lookup .env|3 (let ((.x|6|9 .spec|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) denotation-of-syntax-rules) #f) (let ((.literals|12 (let ((.x|72|75 (let ((.x|76|79 .spec|3)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))))) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.rules|12 (let ((.x|81|84 (let ((.x|85|88 .spec|3)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88))))) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84))))) (begin (if (let ((.temp|13|16 (not (list? .literals|12)))) (if .temp|13|16 .temp|13|16 (not (every1? (lambda (.rule|18) (if (= (safe-length .rule|18) 2) (pair? (let ((.x|21|24 .rule|18)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) #f)) .rules|12)))) (m-error "Malformed syntax-rules" .spec|3) (unspecified)) (let* ((.t1|25|28 'macro) (.t2|25|31 (let* ((.t1|35|38 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (let ((.rule|66 (let ((.x|67|70 .y1|46|47|58)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (m-compile-rule .rule|66 .literals|12 .env|3)) .results|46|50|58)))))) (.loop|51|54|57 .rules|12 '()))))) (.t2|35|41 (cons .env|3 '()))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))))) (m-error "Malformed syntax-rules" .spec|3)))) (.m-compile-transformer-spec|2 .spec|1 .env|1))))) 'm-compile-transformer-spec))
+(let () (begin (set! m-compile-rule (lambda (.rule|1 .literals|1 .env|1) (let ((.m-compile-rule|2 0)) (begin (set! .m-compile-rule|2 (lambda (.rule|3 .literals|3 .env|3) (m-compile-pattern (let ((.x|4|7 (let ((.x|8|11 .rule|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .literals|3 .env|3 (lambda (.compiled-rule|12 .patternvars|12) (cons .compiled-rule|12 (m-compile-template (let ((.x|14|17 (let ((.x|18|21 .rule|3)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))) .patternvars|12 .env|3)))))) (.m-compile-rule|2 .rule|1 .literals|1 .env|1))))) 'm-compile-rule))
+(let () (begin (set! m-compile-pattern (lambda (.p|1 .literals|1 .env|1 .k|1) (let ((.m-compile-pattern|2 0)) (begin (set! .m-compile-pattern|2 (lambda (.p|3 .literals|3 .env|3 .k|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.p|5 .vars|5 .rank|5 .k|5) (if (symbol? .p|5) (if (memq .p|5 .literals|3) (.k|5 .p|5 .vars|5) (let ((.var|9 (make-patternvar .p|5 .rank|5))) (.k|5 .var|9 (cons .var|9 .vars|5)))) (if (null? .p|5) (.k|5 '() .vars|5) (if (pair? .p|5) (if (if (pair? (let ((.x|13|16 .p|5)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16)))) (if (symbol? (let ((.x|19|22 (let ((.x|23|26 .p|5)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))))) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (same-denotation? (syntactic-lookup .env|3 (let ((.x|29|32 (let ((.x|33|36 .p|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) denotation-of-...) #f) #f) (if (null? (let ((.x|38|41 (let ((.x|42|45 .p|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))) (.loop|4 (let ((.x|46|49 .p|5)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) '() (+ .rank|5 1) (lambda (.p|50 .vars1|50) (.k|5 (make-ellipsis-pattern .p|50 .vars1|50) (union2 .vars1|50 .vars|5)))) (m-error "Malformed pattern" .p|5)) (.loop|4 (let ((.x|51|54 .p|5)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))) .vars|5 .rank|5 (lambda (.p1|55 .vars|55) (.loop|4 (let ((.x|56|59 .p|5)) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) .vars|55 .rank|5 (lambda (.p2|60 .vars|60) (.k|5 (cons .p1|55 .p2|60) .vars|60)))))) (if (vector? .p|5) (.loop|4 (vector->list .p|5) .vars|5 .rank|5 (lambda (.p|62 .vars|62) (.k|5 (make-vector 1 .p|62) .vars|62))) (.k|5 .p|5 .vars|5))))))) (.loop|4 .p|3 '() 0 .k|3))))) (.m-compile-pattern|2 .p|1 .literals|1 .env|1 .k|1))))) 'm-compile-pattern))
+(let () (begin (set! m-compile-template (lambda (.t|1 .vars|1 .env|1) (let ((.m-compile-template|2 0)) (begin (set! .m-compile-template|2 (lambda (.t|3 .vars|3 .env|3) (let ((.loop1|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .loop1|4 (lambda (.t|5 .inserted|5 .referenced|5 .rank|5 .escaped?|5 .k|5) (.loop|4 (let ((.x|6|9 .t|5)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) .inserted|5 '() (+ .rank|5 1) .escaped?|5 (lambda (.t1|10 .inserted|10 .referenced1|10) (.loop|4 (let ((.x|12|15 (let ((.x|16|19 .t|5)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) .inserted|10 (append .referenced1|10 .referenced|5) .rank|5 .escaped?|5 (lambda (.t2|20 .inserted|20 .referenced|20) (.k|5 (cons (make-ellipsis-template .t1|10 (filter1 (lambda (.var|21) (> (patternvar-rank .var|21) .rank|5)) .referenced1|10)) .t2|20) .inserted|20 .referenced|20))))))) (set! .loop|4 (lambda (.t|22 .inserted|22 .referenced|22 .rank|22 .escaped?|22 .k|22) (if (symbol? .t|22) (let ((.x|26 (pattern-variable .t|22 .vars|3))) (if .x|26 (if (>= .rank|22 (patternvar-rank .x|26)) (.k|22 .x|26 .inserted|22 (cons .x|26 .referenced|22)) (m-error "Too few ellipses follow pattern variable in template" (patternvar-name .x|26))) (.k|22 .t|22 (cons .t|22 .inserted|22) .referenced|22))) (if (null? .t|22) (.k|22 '() .inserted|22 .referenced|22) (if (pair? .t|22) (if (if (not .escaped?|22) (if (symbol? (let ((.x|32|35 .t|22)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35)))) (if (same-denotation? (syntactic-lookup .env|3 (let ((.x|37|40 .t|22)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) denotation-of-...) (if (pair? (let ((.x|42|45 .t|22)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))) (null? (let ((.x|48|51 (let ((.x|52|55 .t|22)) (begin (.check! (pair? .x|52|55) 1 .x|52|55) (cdr:pair .x|52|55))))) (begin (.check! (pair? .x|48|51) 1 .x|48|51) (cdr:pair .x|48|51)))) #f) #f) #f) #f) (.loop|4 (let ((.x|57|60 (let ((.x|61|64 .t|22)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))))) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))) .inserted|22 .referenced|22 .rank|22 #t .k|22) (if (if (not .escaped?|22) (if (pair? (let ((.x|68|71 .t|22)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71)))) (if (symbol? (let ((.x|74|77 (let ((.x|78|81 .t|22)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))))) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) (same-denotation? (syntactic-lookup .env|3 (let ((.x|84|87 (let ((.x|88|91 .t|22)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))))) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87)))) denotation-of-...) #f) #f) #f) (.loop1|4 .t|22 .inserted|22 .referenced|22 .rank|22 .escaped?|22 .k|22) (.loop|4 (let ((.x|93|96 .t|22)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))) .inserted|22 .referenced|22 .rank|22 .escaped?|22 (lambda (.t1|97 .inserted|97 .referenced|97) (.loop|4 (let ((.x|98|101 .t|22)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) .inserted|97 .referenced|97 .rank|22 .escaped?|22 (lambda (.t2|102 .inserted|102 .referenced|102) (.k|22 (cons .t1|97 .t2|102) .inserted|102 .referenced|102))))))) (if (vector? .t|22) (.loop|4 (vector->list .t|22) .inserted|22 .referenced|22 .rank|22 .escaped?|22 (lambda (.t|104 .inserted|104 .referenced|104) (.k|22 (make-vector 1 .t|104) .inserted|104 .referenced|104))) (.k|22 .t|22 .inserted|22 .referenced|22))))))) (.loop|4 .t|3 '() '() 0 #f (lambda (.t|107 .inserted|107 .referenced|107) (let* ((.t1|108|111 .t|107) (.t2|108|114 (cons .inserted|107 '()))) (let () (cons .t1|108|111 .t2|108|114))))))))) (.m-compile-template|2 .t|1 .vars|1 .env|1))))) 'm-compile-template))
+(let () (begin (set! empty-pattern-variable-environment (cons (make-patternvar (string->symbol "") 0) '())) 'empty-pattern-variable-environment))
+(let () (begin (set! m-match (lambda (.f|1 .p|1 .env-def|1 .env-use|1) (let ((.m-match|2 0)) (begin (set! .m-match|2 (lambda (.f|3 .p|3 .env-def|3 .env-use|3) (let ((.match1|4 (unspecified)) (.match|4 (unspecified))) (begin (set! .match1|4 (lambda (.f|5 .p|5 .answer|5 .rank|5) (if (not (list? .f|5)) #f (if (null? .f|5) (append (let () (let ((.loop|13|16|19 (unspecified))) (begin (set! .loop|13|16|19 (lambda (.y1|8|9|20 .results|8|12|20) (if (null? .y1|8|9|20) (reverse .results|8|12|20) (begin #t (.loop|13|16|19 (let ((.x|24|27 .y1|8|9|20)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))) (cons (let ((.var|28 (let ((.x|29|32 .y1|8|9|20)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32))))) (cons .var|28 '())) .results|8|12|20)))))) (.loop|13|16|19 (ellipsis-pattern-vars .p|5) '())))) .answer|5) (let* ((.p1|36 (ellipsis-pattern .p|5)) (.answers|39 (let () (let ((.loop|103|106|109 (unspecified))) (begin (set! .loop|103|106|109 (lambda (.y1|98|99|110 .results|98|102|110) (if (null? .y1|98|99|110) (reverse .results|98|102|110) (begin #t (.loop|103|106|109 (let ((.x|114|117 .y1|98|99|110)) (begin (.check! (pair? .x|114|117) 1 .x|114|117) (cdr:pair .x|114|117))) (cons (let ((.f|118 (let ((.x|119|122 .y1|98|99|110)) (begin (.check! (pair? .x|119|122) 0 .x|119|122) (car:pair .x|119|122))))) (.match|4 .f|118 .p1|36 .answer|5 .rank|5)) .results|98|102|110)))))) (.loop|103|106|109 .f|5 '())))))) (let () (if (every1? (lambda (.answer|43) .answer|43) .answers|39) (append (let () (let ((.loop|49|52|55 (unspecified))) (begin (set! .loop|49|52|55 (lambda (.y1|44|45|56 .results|44|48|56) (if (null? .y1|44|45|56) (reverse .results|44|48|56) (begin #t (.loop|49|52|55 (let ((.x|60|63 .y1|44|45|56)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))) (cons (let ((.var|64 (let ((.x|94|97 .y1|44|45|56)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) (cons .var|64 (let () (let ((.loop|70|73|76 (unspecified))) (begin (set! .loop|70|73|76 (lambda (.y1|65|66|77 .results|65|69|77) (if (null? .y1|65|66|77) (reverse .results|65|69|77) (begin #t (.loop|70|73|76 (let ((.x|81|84 .y1|65|66|77)) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84))) (cons (let* ((.answer|85 (let ((.x|90|93 .y1|65|66|77)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (.x|86|89 (assq .var|64 .answer|85))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))) .results|65|69|77)))))) (.loop|70|73|76 .answers|39 '())))))) .results|44|48|56)))))) (.loop|49|52|55 (ellipsis-pattern-vars .p|5) '())))) .answer|5) #f))))))) (set! .match|4 (lambda (.f|123 .p|123 .answer|123 .rank|123) (if (null? .p|123) (if (null? .f|123) .answer|123 #f) (if (pair? .p|123) (if (pair? .f|123) (let ((.answer|132 (.match|4 (let ((.x|143|146 .f|123)) (begin (.check! (pair? .x|143|146) 0 .x|143|146) (car:pair .x|143|146))) (let ((.x|147|150 .p|123)) (begin (.check! (pair? .x|147|150) 0 .x|147|150) (car:pair .x|147|150))) .answer|123 .rank|123))) (if .answer|132 (.match|4 (let ((.x|135|138 .f|123)) (begin (.check! (pair? .x|135|138) 1 .x|135|138) (cdr:pair .x|135|138))) (let ((.x|139|142 .p|123)) (begin (.check! (pair? .x|139|142) 1 .x|139|142) (cdr:pair .x|139|142))) .answer|132 .rank|123) #f)) #f) (if (symbol? .p|123) (if (symbol? .f|123) (if (same-denotation? (syntactic-lookup .env-def|3 .p|123) (syntactic-lookup .env-use|3 .f|123)) .answer|123 #f) #f) (if (patternvar? .p|123) (cons (cons .p|123 .f|123) .answer|123) (if (ellipsis-pattern? .p|123) (.match1|4 .f|123 .p|123 .answer|123 (+ .rank|123 1)) (if (vector? .p|123) (if (vector? .f|123) (.match|4 (vector->list .f|123) (let ((.v|160|163 .p|123) (.i|160|163 0)) (begin (.check! (fixnum? .i|160|163) 40 .v|160|163 .i|160|163) (.check! (vector? .v|160|163) 40 .v|160|163 .i|160|163) (.check! (<:fix:fix .i|160|163 (vector-length:vec .v|160|163)) 40 .v|160|163 .i|160|163) (.check! (>=:fix:fix .i|160|163 0) 40 .v|160|163 .i|160|163) (vector-ref:trusted .v|160|163 .i|160|163))) .answer|123 .rank|123) #f) (if (equal? .f|123 .p|123) .answer|123 #f))))))))) (.match|4 .f|3 .p|3 empty-pattern-variable-environment 0))))) (.m-match|2 .f|1 .p|1 .env-def|1 .env-use|1))))) 'm-match))
+(let () (begin (set! m-rewrite (lambda (.t|1 .alist|1) (let ((.m-rewrite|2 0)) (begin (set! .m-rewrite|2 (lambda (.t|3 .alist|3) (let ((.make-columns|4 (unspecified)) (.rewrite1|4 (unspecified)) (.rewrite|4 (unspecified))) (begin (set! .make-columns|4 (lambda (.vars|5 .rows|5 .alist|5) (let ((.loop|6 (unspecified))) (begin (set! .loop|6 (lambda (.rows|7) (if (null? (let ((.x|8|11 .rows|7)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) '() (cons (append (let () (let ((.loop|18|22|25 (unspecified))) (begin (set! .loop|18|22|25 (lambda (.y1|12|14|26 .y1|12|13|26 .results|12|17|26) (if (let ((.temp|28|31 (null? .y1|12|14|26))) (if .temp|28|31 .temp|28|31 (null? .y1|12|13|26))) (reverse .results|12|17|26) (begin #t (.loop|18|22|25 (let ((.x|34|37 .y1|12|14|26)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) (let ((.x|38|41 .y1|12|13|26)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (cons (let ((.var|42 (let ((.x|47|50 .y1|12|14|26)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) (.row|42 (let ((.x|51|54 .y1|12|13|26)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54))))) (cons .var|42 (let ((.x|43|46 .row|42)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) .results|12|17|26)))))) (.loop|18|22|25 .vars|5 .rows|7 '())))) .alist|5) (.loop|6 (let () (let ((.loop|60|63|66 (unspecified))) (begin (set! .loop|60|63|66 (lambda (.y1|55|56|67 .results|55|59|67) (if (null? .y1|55|56|67) (reverse .results|55|59|67) (begin #t (.loop|60|63|66 (let ((.x|71|74 .y1|55|56|67)) (begin (.check! (pair? .x|71|74) 1 .x|71|74) (cdr:pair .x|71|74))) (cons (let ((.x|75|78 (let ((.x|79|82 .y1|55|56|67)) (begin (.check! (pair? .x|79|82) 0 .x|79|82) (car:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 1 .x|75|78) (cdr:pair .x|75|78))) .results|55|59|67)))))) (.loop|60|63|66 .rows|7 '()))))))))) (if (let ((.temp|83|86 (null? (let ((.x|112|115 .rows|5)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115)))))) (if .temp|83|86 .temp|83|86 (apply = (let () (let ((.loop|93|96|99 (unspecified))) (begin (set! .loop|93|96|99 (lambda (.y1|88|89|100 .results|88|92|100) (if (null? .y1|88|89|100) (reverse .results|88|92|100) (begin #t (.loop|93|96|99 (let ((.x|104|107 .y1|88|89|100)) (begin (.check! (pair? .x|104|107) 1 .x|104|107) (cdr:pair .x|104|107))) (cons (length (let ((.x|108|111 .y1|88|89|100)) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111)))) .results|88|92|100)))))) (.loop|93|96|99 .rows|5 '()))))))) (.loop|6 .rows|5) (m-error "Use of macro is not consistent with definition" .vars|5 .rows|5)))))) (set! .rewrite1|4 (lambda (.t|116 .alist|116 .rank|116) (let* ((.t1|119 (ellipsis-template .t|116)) (.vars|122 (ellipsis-template-vars .t|116)) (.rows|125 (let () (let ((.loop|159|162|165 (unspecified))) (begin (set! .loop|159|162|165 (lambda (.y1|154|155|166 .results|154|158|166) (if (null? .y1|154|155|166) (reverse .results|154|158|166) (begin #t (.loop|159|162|165 (let ((.x|170|173 .y1|154|155|166)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))) (cons (let* ((.var|174 (let ((.x|179|182 .y1|154|155|166)) (begin (.check! (pair? .x|179|182) 0 .x|179|182) (car:pair .x|179|182)))) (.x|175|178 (assq .var|174 .alist|116))) (begin (.check! (pair? .x|175|178) 1 .x|175|178) (cdr:pair .x|175|178))) .results|154|158|166)))))) (.loop|159|162|165 .vars|122 '())))))) (let () (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (let ((.alist|149 (let ((.x|150|153 .y1|129|130|141)) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))))) (.rewrite|4 .t1|119 .alist|149 .rank|116)) .results|129|133|141)))))) (.loop|134|137|140 (.make-columns|4 .vars|122 .rows|125 .alist|116) '())))))))) (set! .rewrite|4 (lambda (.t|183 .alist|183 .rank|183) (if (null? .t|183) '() (if (pair? .t|183) ((if (ellipsis-pattern? (let ((.x|186|189 .t|183)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) append cons) (.rewrite|4 (let ((.x|190|193 .t|183)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))) .alist|183 .rank|183) (.rewrite|4 (let ((.x|194|197 .t|183)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) .alist|183 .rank|183)) (if (symbol? .t|183) (let ((.x|199|202 (assq .t|183 .alist|183))) (begin (.check! (pair? .x|199|202) 1 .x|199|202) (cdr:pair .x|199|202))) (if (patternvar? .t|183) (let ((.x|204|207 (assq .t|183 .alist|183))) (begin (.check! (pair? .x|204|207) 1 .x|204|207) (cdr:pair .x|204|207))) (if (ellipsis-template? .t|183) (.rewrite1|4 .t|183 .alist|183 (+ .rank|183 1)) (if (vector? .t|183) (list->vector (.rewrite|4 (let ((.v|210|213 .t|183) (.i|210|213 0)) (begin (.check! (fixnum? .i|210|213) 40 .v|210|213 .i|210|213) (.check! (vector? .v|210|213) 40 .v|210|213 .i|210|213) (.check! (<:fix:fix .i|210|213 (vector-length:vec .v|210|213)) 40 .v|210|213 .i|210|213) (.check! (>=:fix:fix .i|210|213 0) 40 .v|210|213 .i|210|213) (vector-ref:trusted .v|210|213 .i|210|213))) .alist|183 .rank|183)) .t|183)))))))) (.rewrite|4 .t|3 .alist|3 0))))) (.m-rewrite|2 .t|1 .alist|1))))) 'm-rewrite))
+(let () (begin (set! m-transcribe0 (lambda (.exp|1 .env-use|1 .k|1 .inline?|1) (let ((.m-transcribe0|2 0)) (begin (set! .m-transcribe0|2 (lambda (.exp|3 .env-use|3 .k|3 .inline?|3) (let* ((.m|6 (syntactic-lookup .env-use|3 (let ((.x|86|89 .exp|3)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89))))) (.rules|9 (macro-rules .m|6)) (.env-def|12 (macro-env .m|6)) (.f|15 (let ((.x|82|85 .exp|3)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (let () (let ((.loop|19 (unspecified))) (begin (set! .loop|19 (lambda (.rules|20) (if (null? .rules|20) (if .inline?|3 (.k|3 .exp|3 .env-use|3) (m-error "Use of macro does not match definition" .exp|3)) (let* ((.rule|23 (let ((.x|78|81 .rules|20)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.pattern|26 (let ((.x|74|77 .rule|23)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) (.alist|29 (m-match .f|15 .pattern|26 .env-def|12 .env-use|3))) (let () (if .alist|29 (let* ((.template|35 (let ((.x|62|65 (let ((.x|66|69 .rule|23)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (.inserted|38 (let ((.x|49|52 (let ((.x|53|56 (let ((.x|57|60 .rule|23)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60))))) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))))) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52)))) (.alist2|41 (rename-vars .inserted|38)) (.newexp|44 (m-rewrite .template|35 (append .alist2|41 .alist|29)))) (let () (.k|3 .newexp|44 (syntactic-alias .env-use|3 .alist2|41 .env-def|12)))) (.loop|19 (let ((.x|70|73 .rules|20)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73)))))))))) (if (procedure? .rules|9) (m-transcribe-low-level .exp|3 .env-use|3 .k|3 .rules|9 .env-def|12) (.loop|19 .rules|9)))))))) (.m-transcribe0|2 .exp|1 .env-use|1 .k|1 .inline?|1))))) 'm-transcribe0))
+(let () (begin (set! m-transcribe (lambda (.exp|1 .env-use|1 .k|1) (let ((.m-transcribe|2 0)) (begin (set! .m-transcribe|2 (lambda (.exp|3 .env-use|3 .k|3) (m-transcribe0 .exp|3 .env-use|3 .k|3 #f))) (.m-transcribe|2 .exp|1 .env-use|1 .k|1))))) 'm-transcribe))
+(let () (begin (set! m-transcribe-inline (lambda (.exp|1 .env-use|1 .k|1) (let ((.m-transcribe-inline|2 0)) (begin (set! .m-transcribe-inline|2 (lambda (.exp|3 .env-use|3 .k|3) (m-transcribe0 .exp|3 .env-use|3 .k|3 #t))) (.m-transcribe-inline|2 .exp|1 .env-use|1 .k|1))))) 'm-transcribe-inline))
+(let () ($$trace "lowlevel"))
+(let () (begin (set! m-transcribe-low-level (lambda (.exp|1 .env-use|1 .k|1 .transformer|1 .env-def|1) (let ((.m-transcribe-low-level|2 0)) (begin (set! .m-transcribe-low-level|2 (lambda (.exp|3 .env-use|3 .k|3 .transformer|3 .env-def|3) (let ((.rename0|6 (make-rename-procedure)) (.renamed|6 '()) (.ok|6 #t)) (let ((.lookup|9 (unspecified))) (begin (set! .lookup|9 (lambda (.sym|10) (let ((.alist|13 .renamed|6)) (let () (let ((.loop|16 (unspecified))) (begin (set! .loop|16 (lambda (.alist|17) (if (null? .alist|17) (syntactic-lookup .env-use|3 .sym|10) (if (eq? .sym|10 (let ((.x|20|23 (let ((.x|24|27 .alist|17)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) (syntactic-lookup .env-def|3 (let ((.x|28|31 (let ((.x|32|35 .alist|17)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))))) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.loop|16 (let ((.x|37|40 .alist|17)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))))))) (.loop|16 .alist|13))))))) (let ((.rename|41 (lambda (.sym|45) (if .ok|6 (let ((.probe|48 (assq .sym|45 .renamed|6))) (if .probe|48 (let ((.x|49|52 .probe|48)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.sym2|55 (.rename0|6 .sym|45))) (begin (set! .renamed|6 (cons (cons .sym|45 .sym2|55) .renamed|6)) .sym2|55)))) (m-error "Illegal use of a rename procedure" .sym|45)))) (.compare|41 (lambda (.sym1|56 .sym2|56) (same-denotation? (.lookup|9 .sym1|56) (.lookup|9 .sym2|56))))) (let ((.exp2|44 (.transformer|3 .exp|3 .rename|41 .compare|41))) (begin (set! .ok|6 #f) (.k|3 .exp2|44 (syntactic-alias .env-use|3 .renamed|6 .env-def|3)))))))))) (.m-transcribe-low-level|2 .exp|1 .env-use|1 .k|1 .transformer|1 .env-def|1))))) 'm-transcribe-low-level))
+(let () (begin (set! identifier? symbol?) 'identifier?))
+(let () (begin (set! identifier->symbol (lambda (.id|1) (let ((.identifier->symbol|2 0)) (begin (set! .identifier->symbol|2 (lambda (.id|3) (m-strip .id|3))) (.identifier->symbol|2 .id|1))))) 'identifier->symbol))
+(let () ($$trace "expand"))
+(let () (begin (set! define-syntax-scope (let ((.flag|3 'letrec)) (lambda .args|4 (if (null? .args|4) .flag|3 (if (not (null? (let ((.x|7|10 .args|4)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))))) (apply m-warn "Too many arguments passed to define-syntax-scope" .args|4) (if (let ((.t0|12|13|16 (let ((.x|42|45 .args|4)) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45)))) (.t1|12|13|16 '(letrec letrec* let*))) (if (eq? .t0|12|13|16 'letrec) .t1|12|13|16 (let ((.t1|12|13|20 (let ((.x|38|41 .t1|12|13|16)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))))) (if (eq? .t0|12|13|16 'letrec*) .t1|12|13|20 (let ((.t1|12|13|24 (let ((.x|34|37 .t1|12|13|20)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (if (eq? .t0|12|13|16 'let*) .t1|12|13|24 (let ((.t1|12|13|28 (let ((.x|30|33 .t1|12|13|24)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) #f))))))) (set! .flag|3 (let ((.x|46|49 .args|4)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))) (m-warn "Unrecognized argument to define-syntax-scope" (let ((.x|51|54 .args|4)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))))))))) 'define-syntax-scope))
+(let () (begin (set! macro-expand (lambda (.def-or-exp|1) (let ((.macro-expand|2 0)) (begin (set! .macro-expand|2 (lambda (.def-or-exp|3) (call-with-current-continuation (lambda (.k|4) (begin (set! m-quit .k|4) (set! renaming-counter 0) (make-call (make-lambda '() '() '() '() '() '() #f (desugar-definitions .def-or-exp|3 global-syntactic-environment make-toplevel-definition)) '())))))) (.macro-expand|2 .def-or-exp|1))))) 'macro-expand))
+(let () (begin (set! desugar-definitions (lambda (.exp|1 .env|1 .make-toplevel-definition|1) (let ((.desugar-definitions|2 0)) (begin (set! .desugar-definitions|2 (lambda (.exp|3 .env|3 .make-toplevel-definition|3) (let () (let ((.redefinition|6 (unspecified)) (.desugar-define|6 (unspecified)) (.define-syntax-loop|6 (unspecified)) (.define-loop|6 (unspecified))) (begin (set! .redefinition|6 (lambda (.id|7) (if (symbol? .id|7) (if (not (identifier-denotation? (syntactic-lookup global-syntactic-environment .id|7))) (if (issue-warnings) (m-warn "Redefining " .id|7) (unspecified)) (unspecified)) (m-error "Malformed variable or keyword" .id|7)))) (set! .desugar-define|6 (lambda (.exp|8 .env|8) (if (null? (let ((.x|10|13 .exp|8)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) (m-error "Malformed definition" .exp|8) (if (null? (let ((.x|16|19 (let ((.x|20|23 .exp|8)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (let ((.id|26 (let ((.x|33|36 (let ((.x|37|40 .exp|8)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (if (let ((.temp|27|30 (null? pass1-block-inlines))) (if .temp|27|30 .temp|27|30 (not (memq .id|26 pass1-block-inlines)))) (begin (.redefinition|6 .id|26) (syntactic-bind-globally! .id|26 (make-identifier-denotation .id|26))) (unspecified)) (.make-toplevel-definition|3 .id|26 (make-undefined)))) (if (pair? (let ((.x|43|46 (let ((.x|47|50 .exp|8)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) (.desugar-define|6 (let* ((.def|53 (let ((.x|343|346 .exp|8)) (begin (.check! (pair? .x|343|346) 0 .x|343|346) (car:pair .x|343|346)))) (.pattern|56 (let ((.x|335|338 (let ((.x|339|342 .exp|8)) (begin (.check! (pair? .x|339|342) 1 .x|339|342) (cdr:pair .x|339|342))))) (begin (.check! (pair? .x|335|338) 0 .x|335|338) (car:pair .x|335|338)))) (.f|59 (let ((.x|330|333 .pattern|56)) (begin (.check! (pair? .x|330|333) 0 .x|330|333) (car:pair .x|330|333)))) (.args|62 (let ((.x|326|329 .pattern|56)) (begin (.check! (pair? .x|326|329) 1 .x|326|329) (cdr:pair .x|326|329)))) (.body|65 (let ((.x|318|321 (let ((.x|322|325 .exp|8)) (begin (.check! (pair? .x|322|325) 1 .x|322|325) (cdr:pair .x|322|325))))) (begin (.check! (pair? .x|318|321) 1 .x|318|321) (cdr:pair .x|318|321))))) (let () (if (if (symbol? (let ((.x|70|73 (let ((.x|75|78 (let ((.x|79|82 .exp|8)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))))) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) (if (benchmark-mode) (list? (let ((.x|86|89 (let ((.x|90|93 .exp|8)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89)))) #f) #f) (.cons .def|53 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 (.cons (.cons (.cons lambda0 (.cons (.cons .f|59 '()) (.cons (.cons set!0 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 .body|65)) '()))) (.cons .pattern|56 '())))) '(0)) '()))) '()))) (.cons .def|53 (.cons .f|59 (.cons (.cons lambda0 (.cons .args|62 .body|65)) '())))))) .env|8) (if (> (length .exp|8) 3) (m-error "Malformed definition" .exp|8) (let ((.id|351 (let ((.x|371|374 (let ((.x|375|378 .exp|8)) (begin (.check! (pair? .x|375|378) 1 .x|375|378) (cdr:pair .x|375|378))))) (begin (.check! (pair? .x|371|374) 0 .x|371|374) (car:pair .x|371|374))))) (begin (if (let ((.temp|352|355 (null? pass1-block-inlines))) (if .temp|352|355 .temp|352|355 (not (memq .id|351 pass1-block-inlines)))) (begin (.redefinition|6 .id|351) (syntactic-bind-globally! .id|351 (make-identifier-denotation .id|351))) (unspecified)) (.make-toplevel-definition|3 .id|351 (m-expand (let ((.x|358|361 (let ((.x|362|365 (let ((.x|366|369 .exp|8)) (begin (.check! (pair? .x|366|369) 1 .x|366|369) (cdr:pair .x|366|369))))) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))))) (begin (.check! (pair? .x|358|361) 0 .x|358|361) (car:pair .x|358|361))) .env|8)))))))))) (set! .define-syntax-loop|6 (lambda (.exp|379 .rest|379 .env|379) (if (if (pair? .exp|379) (if (symbol? (let ((.x|383|386 .exp|379)) (begin (.check! (pair? .x|383|386) 0 .x|383|386) (car:pair .x|383|386)))) (if (eq? (syntactic-lookup .env|379 (let ((.x|388|391 .exp|379)) (begin (.check! (pair? .x|388|391) 0 .x|388|391) (car:pair .x|388|391)))) denotation-of-begin) (pair? (let ((.x|393|396 .exp|379)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396)))) #f) #f) #f) (.define-syntax-loop|6 (let ((.x|398|401 (let ((.x|402|405 .exp|379)) (begin (.check! (pair? .x|402|405) 1 .x|402|405) (cdr:pair .x|402|405))))) (begin (.check! (pair? .x|398|401) 0 .x|398|401) (car:pair .x|398|401))) (append (let ((.x|407|410 (let ((.x|411|414 .exp|379)) (begin (.check! (pair? .x|411|414) 1 .x|411|414) (cdr:pair .x|411|414))))) (begin (.check! (pair? .x|407|410) 1 .x|407|410) (cdr:pair .x|407|410))) .rest|379) .env|379) (if (if (pair? .exp|379) (if (symbol? (let ((.x|418|421 .exp|379)) (begin (.check! (pair? .x|418|421) 0 .x|418|421) (car:pair .x|418|421)))) (eq? (syntactic-lookup .env|379 (let ((.x|423|426 .exp|379)) (begin (.check! (pair? .x|423|426) 0 .x|423|426) (car:pair .x|423|426)))) denotation-of-define-syntax) #f) #f) (begin (if (pair? (let ((.x|427|430 .exp|379)) (begin (.check! (pair? .x|427|430) 1 .x|427|430) (cdr:pair .x|427|430)))) (.redefinition|6 (let ((.x|432|435 (let ((.x|436|439 .exp|379)) (begin (.check! (pair? .x|436|439) 1 .x|436|439) (cdr:pair .x|436|439))))) (begin (.check! (pair? .x|432|435) 0 .x|432|435) (car:pair .x|432|435)))) (unspecified)) (if (null? .rest|379) (m-define-syntax .exp|379 .env|379) (begin (m-define-syntax .exp|379 .env|379) (.define-syntax-loop|6 (let ((.x|440|443 .rest|379)) (begin (.check! (pair? .x|440|443) 0 .x|440|443) (car:pair .x|440|443))) (let ((.x|444|447 .rest|379)) (begin (.check! (pair? .x|444|447) 1 .x|444|447) (cdr:pair .x|444|447))) .env|379)))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|451|454 .exp|379)) (begin (.check! (pair? .x|451|454) 0 .x|451|454) (car:pair .x|451|454)))) (eq? (syntactic-lookup .env|379 (let ((.x|456|459 .exp|379)) (begin (.check! (pair? .x|456|459) 0 .x|456|459) (car:pair .x|456|459)))) denotation-of-define-inline) #f) #f) (begin (if (pair? (let ((.x|460|463 .exp|379)) (begin (.check! (pair? .x|460|463) 1 .x|460|463) (cdr:pair .x|460|463)))) (.redefinition|6 (let ((.x|465|468 (let ((.x|469|472 .exp|379)) (begin (.check! (pair? .x|469|472) 1 .x|469|472) (cdr:pair .x|469|472))))) (begin (.check! (pair? .x|465|468) 0 .x|465|468) (car:pair .x|465|468)))) (unspecified)) (if (null? .rest|379) (m-define-inline .exp|379 .env|379) (begin (m-define-inline .exp|379 .env|379) (.define-syntax-loop|6 (let ((.x|473|476 .rest|379)) (begin (.check! (pair? .x|473|476) 0 .x|473|476) (car:pair .x|473|476))) (let ((.x|477|480 .rest|379)) (begin (.check! (pair? .x|477|480) 1 .x|477|480) (cdr:pair .x|477|480))) .env|379)))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|484|487 .exp|379)) (begin (.check! (pair? .x|484|487) 0 .x|484|487) (car:pair .x|484|487)))) (macro-denotation? (syntactic-lookup .env|379 (let ((.x|489|492 .exp|379)) (begin (.check! (pair? .x|489|492) 0 .x|489|492) (car:pair .x|489|492))))) #f) #f) (m-transcribe .exp|379 .env|379 (lambda (.exp|493 .env|493) (.define-syntax-loop|6 .exp|493 .rest|379 .env|493))) (if (if (pair? .exp|379) (if (symbol? (let ((.x|497|500 .exp|379)) (begin (.check! (pair? .x|497|500) 0 .x|497|500) (car:pair .x|497|500)))) (eq? (syntactic-lookup .env|379 (let ((.x|502|505 .exp|379)) (begin (.check! (pair? .x|502|505) 0 .x|502|505) (car:pair .x|502|505)))) denotation-of-define) #f) #f) (.define-loop|6 .exp|379 .rest|379 '() .env|379) (if (null? .rest|379) (m-expand .exp|379 .env|379) (make-begin (let () (let ((.loop|513|516|519 (unspecified))) (begin (set! .loop|513|516|519 (lambda (.y1|508|509|520 .results|508|512|520) (if (null? .y1|508|509|520) (reverse .results|508|512|520) (begin #t (.loop|513|516|519 (let ((.x|524|527 .y1|508|509|520)) (begin (.check! (pair? .x|524|527) 1 .x|524|527) (cdr:pair .x|524|527))) (cons (let ((.exp|528 (let ((.x|529|532 .y1|508|509|520)) (begin (.check! (pair? .x|529|532) 0 .x|529|532) (car:pair .x|529|532))))) (m-expand .exp|528 .env|379)) .results|508|512|520)))))) (.loop|513|516|519 (cons .exp|379 .rest|379) '()))))))))))))) (set! .define-loop|6 (lambda (.exp|533 .rest|533 .first|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|537|540 .exp|533)) (begin (.check! (pair? .x|537|540) 0 .x|537|540) (car:pair .x|537|540)))) (if (eq? (syntactic-lookup .env|533 (let ((.x|542|545 .exp|533)) (begin (.check! (pair? .x|542|545) 0 .x|542|545) (car:pair .x|542|545)))) denotation-of-begin) (pair? (let ((.x|547|550 .exp|533)) (begin (.check! (pair? .x|547|550) 1 .x|547|550) (cdr:pair .x|547|550)))) #f) #f) #f) (.define-loop|6 (let ((.x|552|555 (let ((.x|556|559 .exp|533)) (begin (.check! (pair? .x|556|559) 1 .x|556|559) (cdr:pair .x|556|559))))) (begin (.check! (pair? .x|552|555) 0 .x|552|555) (car:pair .x|552|555))) (append (let ((.x|561|564 (let ((.x|565|568 .exp|533)) (begin (.check! (pair? .x|565|568) 1 .x|565|568) (cdr:pair .x|565|568))))) (begin (.check! (pair? .x|561|564) 1 .x|561|564) (cdr:pair .x|561|564))) .rest|533) .first|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|572|575 .exp|533)) (begin (.check! (pair? .x|572|575) 0 .x|572|575) (car:pair .x|572|575)))) (eq? (syntactic-lookup .env|533 (let ((.x|577|580 .exp|533)) (begin (.check! (pair? .x|577|580) 0 .x|577|580) (car:pair .x|577|580)))) denotation-of-define) #f) #f) (let ((.exp|583 (.desugar-define|6 .exp|533 .env|533))) (if (if (null? .first|533) (null? .rest|533) #f) .exp|583 (if (null? .rest|533) (make-begin (reverse (cons .exp|583 .first|533))) (.define-loop|6 (let ((.x|589|592 .rest|533)) (begin (.check! (pair? .x|589|592) 0 .x|589|592) (car:pair .x|589|592))) (let ((.x|593|596 .rest|533)) (begin (.check! (pair? .x|593|596) 1 .x|593|596) (cdr:pair .x|593|596))) (cons .exp|583 .first|533) .env|533)))) (if (if (pair? .exp|533) (if (symbol? (let ((.x|600|603 .exp|533)) (begin (.check! (pair? .x|600|603) 0 .x|600|603) (car:pair .x|600|603)))) (if (let ((.temp|605|608 (eq? (syntactic-lookup .env|533 (let ((.x|614|617 .exp|533)) (begin (.check! (pair? .x|614|617) 0 .x|614|617) (car:pair .x|614|617)))) denotation-of-define-syntax))) (if .temp|605|608 .temp|605|608 (eq? (syntactic-lookup .env|533 (let ((.x|610|613 .exp|533)) (begin (.check! (pair? .x|610|613) 0 .x|610|613) (car:pair .x|610|613)))) denotation-of-define-inline))) (null? .first|533) #f) #f) #f) (.define-syntax-loop|6 .exp|533 .rest|533 .env|533) (if (if (pair? .exp|533) (if (symbol? (let ((.x|622|625 .exp|533)) (begin (.check! (pair? .x|622|625) 0 .x|622|625) (car:pair .x|622|625)))) (macro-denotation? (syntactic-lookup .env|533 (let ((.x|627|630 .exp|533)) (begin (.check! (pair? .x|627|630) 0 .x|627|630) (car:pair .x|627|630))))) #f) #f) (m-transcribe .exp|533 .env|533 (lambda (.exp|631 .env|631) (.define-loop|6 .exp|631 .rest|533 .first|533 .env|631))) (if (if (null? .first|533) (null? .rest|533) #f) (m-expand .exp|533 .env|533) (if (null? .rest|533) (make-begin (reverse (cons (m-expand .exp|533 .env|533) .first|533))) (make-begin (append (reverse .first|533) (let () (let ((.loop|642|645|648 (unspecified))) (begin (set! .loop|642|645|648 (lambda (.y1|637|638|649 .results|637|641|649) (if (null? .y1|637|638|649) (reverse .results|637|641|649) (begin #t (.loop|642|645|648 (let ((.x|653|656 .y1|637|638|649)) (begin (.check! (pair? .x|653|656) 1 .x|653|656) (cdr:pair .x|653|656))) (cons (let ((.exp|657 (let ((.x|658|661 .y1|637|638|649)) (begin (.check! (pair? .x|658|661) 0 .x|658|661) (car:pair .x|658|661))))) (m-expand .exp|657 .env|533)) .results|637|641|649)))))) (.loop|642|645|648 (cons .exp|533 .rest|533) '())))))))))))))) (.define-loop|6 .exp|3 '() '() .env|3)))))) (.desugar-definitions|2 .exp|1 .env|1 .make-toplevel-definition|1))))) 'desugar-definitions))
+(let () (begin (set! m-expand (lambda (.exp|1 .env|1) (let ((.m-expand|2 0)) (begin (set! .m-expand|2 (lambda (.exp|3 .env|3) (if (not (pair? .exp|3)) (m-atom .exp|3 .env|3) (if (not (symbol? (let ((.x|6|9 .exp|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))))) (m-application .exp|3 .env|3) (let* ((.keyword|13 (syntactic-lookup .env|3 (let ((.x|41|44 .exp|3)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (.temp|14|17 (denotation-class .keyword|13))) (if (memv .temp|14|17 '(special)) (if (eq? .keyword|13 denotation-of-quote) (m-quote .exp|3) (if (eq? .keyword|13 denotation-of-lambda) (m-lambda .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-if) (m-if .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-set!) (m-set .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-begin) (m-begin .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-let-syntax) (m-let-syntax .exp|3 .env|3) (if (eq? .keyword|13 denotation-of-letrec-syntax) (m-letrec-syntax .exp|3 .env|3) (if (let ((.temp|27|30 (eq? .keyword|13 denotation-of-define))) (if .temp|27|30 .temp|27|30 (let ((.temp|31|34 (eq? .keyword|13 denotation-of-define-syntax))) (if .temp|31|34 .temp|31|34 (eq? .keyword|13 denotation-of-define-inline))))) (m-error "Definition out of context" .exp|3) (m-bug "Bug detected in m-expand" .exp|3 .env|3))))))))) (if (memv .temp|14|17 '(macro)) (m-macro .exp|3 .env|3) (if (memv .temp|14|17 '(inline)) (m-inline .exp|3 .env|3) (if (memv .temp|14|17 '(identifier)) (m-application .exp|3 .env|3) (m-bug "Bug detected in m-expand" .exp|3 .env|3)))))))))) (.m-expand|2 .exp|1 .env|1))))) 'm-expand))
+(let () (begin (set! m-atom (lambda (.exp|1 .env|1) (let ((.m-atom|2 0)) (begin (set! .m-atom|2 (lambda (.exp|3 .env|3) (if (not (symbol? .exp|3)) (begin (if (if (not (boolean? .exp|3)) (if (not (number? .exp|3)) (if (not (char? .exp|3)) (if (not (string? .exp|3)) (if (not (procedure? .exp|3)) (not (eq? .exp|3 (unspecified))) #f) #f) #f) #f) #f) (m-warn "Malformed constant -- should be quoted" .exp|3) (unspecified)) (make-constant .exp|3)) (let* ((.denotation|14 (syntactic-lookup .env|3 .exp|3)) (.temp|15|18 (denotation-class .denotation|14))) (if (memv .temp|15|18 '(special macro)) (begin (m-warn "Syntactic keyword used as a variable" .exp|3) (make-constant #t)) (if (memv .temp|15|18 '(inline)) (make-variable (inline-name .denotation|14)) (if (memv .temp|15|18 '(identifier)) (let ((.var|24 (make-variable (identifier-name .denotation|14))) (.r-entry|24 (identifier-r-entry .denotation|14))) (begin (r-entry.references-set! .r-entry|24 (cons .var|24 (r-entry.references .r-entry|24))) .var|24)) (m-bug "Bug detected by m-atom" .exp|3 .env|3)))))))) (.m-atom|2 .exp|1 .env|1))))) 'm-atom))
+(let () (begin (set! m-quote (lambda (.exp|1) (let ((.m-quote|2 0)) (begin (set! .m-quote|2 (lambda (.exp|3) (if (if (pair? (let ((.x|5|8 .exp|3)) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8)))) (null? (let ((.x|11|14 (let ((.x|15|18 .exp|3)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) #f) (make-constant (m-strip (let ((.x|20|23 (let ((.x|24|27 .exp|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (m-error "Malformed quoted constant" .exp|3)))) (.m-quote|2 .exp|1))))) 'm-quote))
+(let () (begin (set! m-lambda (lambda (.exp|1 .env|1) (let ((.m-lambda|2 0)) (begin (set! .m-lambda|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 2) (let* ((.formals|6 (let ((.x|242|245 (let ((.x|246|249 .exp|3)) (begin (.check! (pair? .x|246|249) 1 .x|246|249) (cdr:pair .x|246|249))))) (begin (.check! (pair? .x|242|245) 0 .x|242|245) (car:pair .x|242|245)))) (.alist|9 (rename-vars .formals|6)) (.env|12 (syntactic-rename .env|3 .alist|9)) (.body|15 (let ((.x|233|236 (let ((.x|237|240 .exp|3)) (begin (.check! (pair? .x|237|240) 1 .x|237|240) (cdr:pair .x|237|240))))) (begin (.check! (pair? .x|233|236) 1 .x|233|236) (cdr:pair .x|233|236))))) (let () (begin (let () (let ((.loop|20|22|25 (unspecified))) (begin (set! .loop|20|22|25 (lambda (.alist|26) (if (null? .alist|26) (if #f #f (unspecified)) (begin (begin #t (if (assq (let ((.x|30|33 (let ((.x|34|37 .alist|26)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|38|41 .alist|26)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))) (m-error "Malformed parameter list" .formals|6) (unspecified))) (.loop|20|22|25 (let ((.x|42|45 .alist|26)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))))))) (.loop|20|22|25 .alist|9)))) (if (if (not (list? .formals|6)) (> (length .alist|9) @maxargs-with-rest-arg@) #f) (let ((.temp|50 (let ((.x|195|198 (rename-vars '(temp)))) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))))) (.m-lambda|2 (.cons lambda0 (.cons .temp|50 (.cons (.cons (.cons lambda0 (.cons (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.x|140|143 (let ((.x|144|147 .y1|120|121|132)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 0 .x|140|143) (car:pair .x|140|143))) .results|120|124|132)))))) (.loop|125|128|131 .alist|9 '())))) (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 1 .x|149|152) (cdr:pair .x|149|152))))) (let () (let ((.loop|157|161|164 (unspecified))) (begin (set! .loop|157|161|164 (lambda (.actuals|165 .path|165 .formals|165) (if (symbol? .formals|165) (append (reverse .actuals|165) (cons .path|165 '())) (begin #t (.loop|157|161|164 (cons (let* ((.t1|169|172 name:car) (.t2|169|175 (cons .path|165 '()))) (let () (cons .t1|169|172 .t2|169|175))) .actuals|165) (let* ((.t1|180|183 name:cdr) (.t2|180|186 (cons .path|165 '()))) (let () (cons .t1|180|183 .t2|180|186))) (let ((.x|191|194 .formals|165)) (begin (.check! (pair? .x|191|194) 1 .x|191|194) (cdr:pair .x|191|194)))))))) (.loop|157|161|164 '() .temp|50 .formals|6))))) '()))) .env|12)) (make-lambda (rename-formals .formals|6 .alist|9) '() (let () (let ((.loop|204|207|210 (unspecified))) (begin (set! .loop|204|207|210 (lambda (.y1|199|200|211 .results|199|203|211) (if (null? .y1|199|200|211) (reverse .results|199|203|211) (begin #t (.loop|204|207|210 (let ((.x|215|218 .y1|199|200|211)) (begin (.check! (pair? .x|215|218) 1 .x|215|218) (cdr:pair .x|215|218))) (cons (let* ((.entry|219 (let ((.x|228|231 .y1|199|200|211)) (begin (.check! (pair? .x|228|231) 0 .x|228|231) (car:pair .x|228|231)))) (.x|220|223 (syntactic-lookup .env|12 (let ((.x|224|227 .entry|219)) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227)))))) (begin (.check! (pair? .x|220|223) 1 .x|220|223) (cdr:pair .x|220|223))) .results|199|203|211)))))) (.loop|204|207|210 .alist|9 '())))) '() '() '() (make-doc #f (if (list? .formals|6) (length .alist|9) (exact->inexact (- (length .alist|9) 1))) (if (include-variable-names) .formals|6 #f) (if (include-source-code) .exp|3 #f) source-file-name source-file-position) (m-body .body|15 .env|12)))))) (m-error "Malformed lambda expression" .exp|3)))) (.m-lambda|2 .exp|1 .env|1))))) 'm-lambda))
+(let () (begin (set! m-body (lambda (.body|1 .env|1) (let ((.m-body|2 0)) (begin (set! .m-body|2 (lambda (.body|3 .env|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.body|5 .env|5 .defs|5) (begin (if (null? .body|5) (m-error "Empty body") (unspecified)) (let ((.exp|8 (let ((.x|50|53 .body|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (if (pair? .exp|8) (symbol? (let ((.x|11|14 .exp|8)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) #f) (let* ((.denotation|17 (syntactic-lookup .env|5 (let ((.x|46|49 .exp|8)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))))) (.temp|18|21 (denotation-class .denotation|17))) (if (memv .temp|18|21 '(special)) (if (eq? .denotation|17 denotation-of-begin) (.loop|4 (append (let ((.x|24|27 .exp|8)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))) (let ((.x|28|31 .body|5)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31)))) .env|5 .defs|5) (if (eq? .denotation|17 denotation-of-define) (.loop|4 (let ((.x|33|36 .body|5)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))) .env|5 (cons .exp|8 .defs|5)) (finalize-body .body|5 .env|5 .defs|5))) (if (memv .temp|18|21 '(macro)) (m-transcribe .exp|8 .env|5 (lambda (.exp|39 .env|39) (.loop|4 (cons .exp|39 (let ((.x|40|43 .body|5)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43)))) .env|39 .defs|5))) (if (memv .temp|18|21 '(inline identifier)) (finalize-body .body|5 .env|5 .defs|5) (m-bug "Bug detected in m-body" .body|5 .env|5))))) (finalize-body .body|5 .env|5 .defs|5)))))) (.loop|4 .body|3 .env|3 '()))))) (.m-body|2 .body|1 .env|1))))) 'm-body))
+(let () (begin (set! finalize-body (lambda (.body|1 .env|1 .defs|1) (let ((.finalize-body|2 0)) (begin (set! .finalize-body|2 (lambda (.body|3 .env|3 .defs|3) (if (null? .defs|3) (let ((.body|6 (let () (let ((.loop|20|23|26 (unspecified))) (begin (set! .loop|20|23|26 (lambda (.y1|15|16|27 .results|15|19|27) (if (null? .y1|15|16|27) (reverse .results|15|19|27) (begin #t (.loop|20|23|26 (let ((.x|31|34 .y1|15|16|27)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) (cons (let ((.exp|35 (let ((.x|36|39 .y1|15|16|27)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (m-expand .exp|35 .env|3)) .results|15|19|27)))))) (.loop|20|23|26 .body|3 '())))))) (if (null? (let ((.x|7|10 .body|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10)))) (let ((.x|11|14 .body|6)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (make-begin .body|6))) (let () (let ((.expand-letrec|43 (unspecified)) (.desugar-definition|43 (unspecified)) (.sort-defs|43 (unspecified))) (begin (set! .expand-letrec|43 (lambda (.bindings|44 .body|44) (make-call (m-expand (.cons lambda0 (.cons (let () (let ((.loop|85|88|91 (unspecified))) (begin (set! .loop|85|88|91 (lambda (.y1|80|81|92 .results|80|84|92) (if (null? .y1|80|81|92) (reverse .results|80|84|92) (begin #t (.loop|85|88|91 (let ((.x|96|99 .y1|80|81|92)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))) (cons (let ((.x|100|103 (let ((.x|104|107 .y1|80|81|92)) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))))) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103))) .results|80|84|92)))))) (.loop|85|88|91 .bindings|44 '())))) (append (let () (let ((.loop|113|116|119 (unspecified))) (begin (set! .loop|113|116|119 (lambda (.y1|108|109|120 .results|108|112|120) (if (null? .y1|108|109|120) (reverse .results|108|112|120) (begin #t (.loop|113|116|119 (let ((.x|124|127 .y1|108|109|120)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.binding|128 (let ((.x|174|177 .y1|108|109|120)) (begin (.check! (pair? .x|174|177) 0 .x|174|177) (car:pair .x|174|177))))) (.cons set!0 (.cons (let ((.x|161|164 .binding|128)) (begin (.check! (pair? .x|161|164) 0 .x|161|164) (car:pair .x|161|164))) (.cons (let ((.x|166|169 (let ((.x|170|173 .binding|128)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))))) (begin (.check! (pair? .x|166|169) 0 .x|166|169) (car:pair .x|166|169))) '())))) .results|108|112|120)))))) (.loop|113|116|119 .bindings|44 '())))) .body|44))) .env|3) (let () (let ((.loop|183|186|189 (unspecified))) (begin (set! .loop|183|186|189 (lambda (.y1|178|179|190 .results|178|182|190) (if (null? .y1|178|179|190) (reverse .results|178|182|190) (begin #t (.loop|183|186|189 (let ((.x|194|197 .y1|178|179|190)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) (cons (let ((.binding|198 (let ((.x|199|202 .y1|178|179|190)) (begin (.check! (pair? .x|199|202) 0 .x|199|202) (car:pair .x|199|202))))) (make-unspecified)) .results|178|182|190)))))) (.loop|183|186|189 .bindings|44 '()))))))) (set! .desugar-definition|43 (lambda (.def|203) (if (> (safe-length .def|203) 2) (if (pair? (let ((.x|206|209 (let ((.x|210|213 .def|203)) (begin (.check! (pair? .x|210|213) 1 .x|210|213) (cdr:pair .x|210|213))))) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))) (.desugar-definition|43 (.cons (let ((.x|269|272 .def|203)) (begin (.check! (pair? .x|269|272) 0 .x|269|272) (car:pair .x|269|272))) (.cons (let ((.x|273|276 (let ((.x|278|281 (let ((.x|282|285 .def|203)) (begin (.check! (pair? .x|282|285) 1 .x|282|285) (cdr:pair .x|282|285))))) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281))))) (begin (.check! (pair? .x|273|276) 0 .x|273|276) (car:pair .x|273|276))) (.cons (.cons lambda0 (.cons (let ((.x|286|289 (let ((.x|291|294 (let ((.x|295|298 .def|203)) (begin (.check! (pair? .x|295|298) 1 .x|295|298) (cdr:pair .x|295|298))))) (begin (.check! (pair? .x|291|294) 0 .x|291|294) (car:pair .x|291|294))))) (begin (.check! (pair? .x|286|289) 1 .x|286|289) (cdr:pair .x|286|289))) (let ((.x|300|303 (let ((.x|304|307 .def|203)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))))) (begin (.check! (pair? .x|300|303) 1 .x|300|303) (cdr:pair .x|300|303))))) '())))) (if (if (= (length .def|203) 3) (symbol? (let ((.x|312|315 (let ((.x|316|319 .def|203)) (begin (.check! (pair? .x|316|319) 1 .x|316|319) (cdr:pair .x|316|319))))) (begin (.check! (pair? .x|312|315) 0 .x|312|315) (car:pair .x|312|315)))) #f) (let ((.x|320|323 .def|203)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) (m-error "Malformed definition" .def|203))) (m-error "Malformed definition" .def|203)))) (set! .sort-defs|43 (lambda (.defs|325) (let* ((.augmented|328 (let () (let ((.loop|382|385|388 (unspecified))) (begin (set! .loop|382|385|388 (lambda (.y1|377|378|389 .results|377|381|389) (if (null? .y1|377|378|389) (reverse .results|377|381|389) (begin #t (.loop|382|385|388 (let ((.x|393|396 .y1|377|378|389)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396))) (cons (let* ((.def|397 (let ((.x|420|423 .y1|377|378|389)) (begin (.check! (pair? .x|420|423) 0 .x|420|423) (car:pair .x|420|423)))) (.rhs|400 (let ((.x|412|415 (let ((.x|416|419 .def|397)) (begin (.check! (pair? .x|416|419) 1 .x|416|419) (cdr:pair .x|416|419))))) (begin (.check! (pair? .x|412|415) 0 .x|412|415) (car:pair .x|412|415))))) (if (not (pair? .rhs|400)) (cons 'trivial .def|397) (let ((.denotation|403 (syntactic-lookup .env|3 (let ((.x|407|410 .rhs|400)) (begin (.check! (pair? .x|407|410) 0 .x|407|410) (car:pair .x|407|410)))))) (if (eq? .denotation|403 denotation-of-lambda) (cons 'procedure .def|397) (if (eq? .denotation|403 denotation-of-quote) (cons 'trivial .def|397) (cons 'miscellaneous .def|397)))))) .results|377|381|389)))))) (.loop|382|385|388 .defs|325 '()))))) (.sorted|331 (twobit-sort (lambda (.x|363 .y|363) (let ((.temp|364|367 (eq? (let ((.x|373|376 .x|363)) (begin (.check! (pair? .x|373|376) 0 .x|373|376) (car:pair .x|373|376))) 'procedure))) (if .temp|364|367 .temp|364|367 (eq? (let ((.x|369|372 .y|363)) (begin (.check! (pair? .x|369|372) 0 .x|369|372) (car:pair .x|369|372))) 'miscellaneous)))) .augmented|328))) (let () (let () (let ((.loop|340|343|346 (unspecified))) (begin (set! .loop|340|343|346 (lambda (.y1|335|336|347 .results|335|339|347) (if (null? .y1|335|336|347) (reverse .results|335|339|347) (begin #t (.loop|340|343|346 (let ((.x|351|354 .y1|335|336|347)) (begin (.check! (pair? .x|351|354) 1 .x|351|354) (cdr:pair .x|351|354))) (cons (let ((.x|355|358 (let ((.x|359|362 .y1|335|336|347)) (begin (.check! (pair? .x|359|362) 0 .x|359|362) (car:pair .x|359|362))))) (begin (.check! (pair? .x|355|358) 1 .x|355|358) (cdr:pair .x|355|358))) .results|335|339|347)))))) (.loop|340|343|346 .sorted|331 '())))))))) (.expand-letrec|43 (.sort-defs|43 (let () (let ((.loop|429|432|435 (unspecified))) (begin (set! .loop|429|432|435 (lambda (.y1|424|425|436 .results|424|428|436) (if (null? .y1|424|425|436) (reverse .results|424|428|436) (begin #t (.loop|429|432|435 (let ((.x|440|443 .y1|424|425|436)) (begin (.check! (pair? .x|440|443) 1 .x|440|443) (cdr:pair .x|440|443))) (cons (.desugar-definition|43 (let ((.x|444|447 .y1|424|425|436)) (begin (.check! (pair? .x|444|447) 0 .x|444|447) (car:pair .x|444|447)))) .results|424|428|436)))))) (.loop|429|432|435 (reverse .defs|3) '()))))) .body|3))))))) (.finalize-body|2 .body|1 .env|1 .defs|1))))) 'finalize-body))
+(let () (begin (set! m-if (lambda (.exp|1 .env|1) (let ((.m-if|2 0)) (begin (set! .m-if|2 (lambda (.exp|3 .env|3) (let ((.n|6 (safe-length .exp|3))) (if (let ((.temp|7|10 (= .n|6 3))) (if .temp|7|10 .temp|7|10 (= .n|6 4))) (make-conditional (m-expand (let ((.x|13|16 (let ((.x|17|20 .exp|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) .env|3) (m-expand (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))) .env|3) (if (= .n|6 3) (make-unspecified) (m-expand (let ((.x|35|38 (let ((.x|39|42 (let ((.x|43|46 (let ((.x|47|50 .exp|3)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))) .env|3))) (m-error "Malformed if expression" .exp|3))))) (.m-if|2 .exp|1 .env|1))))) 'm-if))
+(let () (begin (set! m-set (lambda (.exp|1 .env|1) (let ((.m-set|2 0)) (begin (set! .m-set|2 (lambda (.exp|3 .env|3) (if (= (safe-length .exp|3) 3) (let ((.lhs|6 (m-expand (let ((.x|28|31 (let ((.x|32|35 .exp|3)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))))) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) .env|3)) (.rhs|6 (m-expand (let ((.x|37|40 (let ((.x|41|44 (let ((.x|45|48 .exp|3)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))))) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))) .env|3))) (if (variable? .lhs|6) (let* ((.x|9 (variable.name .lhs|6)) (.assignment|12 (make-assignment .x|9 .rhs|6)) (.denotation|15 (syntactic-lookup .env|3 .x|9))) (let () (begin (if (identifier-denotation? .denotation|15) (let ((.r-entry|21 (identifier-r-entry .denotation|15))) (begin (r-entry.references-set! .r-entry|21 (remq .lhs|6 (r-entry.references .r-entry|21))) (r-entry.assignments-set! .r-entry|21 (cons .assignment|12 (r-entry.assignments .r-entry|21))))) (unspecified)) (if (if (lambda? .rhs|6) (include-procedure-names) #f) (let ((.doc|26 (lambda.doc .rhs|6))) (doc.name-set! .doc|26 .x|9)) (unspecified)) (if pass1-block-compiling? (set! pass1-block-assignments (cons .x|9 pass1-block-assignments)) (unspecified)) .assignment|12))) (m-error "Malformed assignment" .exp|3))) (m-error "Malformed assignment" .exp|3)))) (.m-set|2 .exp|1 .env|1))))) 'm-set))
+(let () (begin (set! m-begin (lambda (.exp|1 .env|1) (let ((.m-begin|2 0)) (begin (set! .m-begin|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 1) (make-begin (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.y1|5|6|17 .results|5|9|17) (if (null? .y1|5|6|17) (reverse .results|5|9|17) (begin #t (.loop|10|13|16 (let ((.x|21|24 .y1|5|6|17)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) (cons (let ((.exp|25 (let ((.x|26|29 .y1|5|6|17)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (m-expand .exp|25 .env|3)) .results|5|9|17)))))) (.loop|10|13|16 (let ((.x|30|33 .exp|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) '()))))) (if (= (safe-length .exp|3) 1) (begin (m-warn "Non-standard begin expression" .exp|3) (make-unspecified)) (m-error "Malformed begin expression" .exp|3))))) (.m-begin|2 .exp|1 .env|1))))) 'm-begin))
+(let () (begin (set! m-application (lambda (.exp|1 .env|1) (let ((.m-application|2 0)) (begin (set! .m-application|2 (lambda (.exp|3 .env|3) (if (> (safe-length .exp|3) 0) (let* ((.proc|6 (m-expand (let ((.x|129|132 .exp|3)) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .env|3)) (.args|9 (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.exp|120 (let ((.x|121|124 .y1|100|101|112)) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))))) (m-expand .exp|120 .env|3)) .results|100|104|112)))))) (.loop|105|108|111 (let ((.x|125|128 .exp|3)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) '()))))) (.call|12 (make-call .proc|6 .args|9))) (let () (if (variable? .proc|6) (let* ((.procname|18 (variable.name .proc|6)) (.entry|21 (if (not (null? .args|9)) (if (constant? (let ((.x|57|60 .args|9)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60)))) (if (integrate-usual-procedures) (if (every1? constant? .args|9) (let ((.entry|66 (constant-folding-entry .procname|18))) (if .entry|66 (let ((.predicates|71 (constant-folding-predicates .entry|66))) (if (= (length .args|9) (length .predicates|71)) (let ((.args|76 .args|9) (.predicates|76 .predicates|71)) (let () (let ((.loop|79 (unspecified))) (begin (set! .loop|79 (lambda (.args|80 .predicates|80) (if (null? .args|80) .entry|66 (if ((let ((.x|83|86 .predicates|80)) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86))) (constant.value (let ((.x|87|90 .args|80)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (.loop|79 (let ((.x|91|94 .args|80)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (let ((.x|95|98 .predicates|80)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98)))) #f)))) (.loop|79 .args|76 .predicates|76))))) #f)) #f)) #f) #f) #f) #f))) (let () (if .entry|21 (make-constant (apply (constant-folding-folder .entry|21) (let () (let ((.loop|30|33|36 (unspecified))) (begin (set! .loop|30|33|36 (lambda (.y1|25|26|37 .results|25|29|37) (if (null? .y1|25|26|37) (reverse .results|25|29|37) (begin #t (.loop|30|33|36 (let ((.x|41|44 .y1|25|26|37)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))) (cons (constant.value (let ((.x|45|48 .y1|25|26|37)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48)))) .results|25|29|37)))))) (.loop|30|33|36 .args|9 '())))))) (let ((.denotation|51 (syntactic-lookup .env|3 .procname|18))) (begin (if (identifier-denotation? .denotation|51) (let ((.r-entry|54 (identifier-r-entry .denotation|51))) (r-entry.calls-set! .r-entry|54 (cons .call|12 (r-entry.calls .r-entry|54)))) (unspecified)) .call|12))))) .call|12))) (m-error "Malformed application" .exp|3)))) (.m-application|2 .exp|1 .env|1))))) 'm-application))
+(let () (begin (set! m-define-inline (lambda (.exp|1 .env|1) (let ((.m-define-inline|2 0)) (begin (set! .m-define-inline|2 (lambda (.exp|3 .env|3) (if (if (= (safe-length .exp|3) 3) (symbol? (let ((.x|8|11 (let ((.x|12|15 .exp|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) #f) (let ((.name|18 (let ((.x|36|39 (let ((.x|40|43 .exp|3)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (begin (m-define-syntax1 .name|18 (let ((.x|20|23 (let ((.x|24|27 (let ((.x|28|31 .exp|3)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))))) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) .env|3 (define-syntax-scope)) (let ((.denotation|34 (syntactic-lookup global-syntactic-environment .name|18))) (syntactic-bind-globally! .name|18 (make-inline-denotation .name|18 (macro-rules .denotation|34) (macro-env .denotation|34)))) (make-constant .name|18))) (m-error "Malformed define-inline" .exp|3)))) (.m-define-inline|2 .exp|1 .env|1))))) 'm-define-inline))
+(let () (begin (set! m-define-syntax (lambda (.exp|1 .env|1) (let ((.m-define-syntax|2 0)) (begin (set! .m-define-syntax|2 (lambda (.exp|3 .env|3) (if (if (= (safe-length .exp|3) 3) (symbol? (let ((.x|8|11 (let ((.x|12|15 .exp|3)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11)))) #f) (m-define-syntax1 (let ((.x|17|20 (let ((.x|21|24 .exp|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))) (let ((.x|26|29 (let ((.x|30|33 (let ((.x|34|37 .exp|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) .env|3 (define-syntax-scope)) (if (if (= (safe-length .exp|3) 4) (if (symbol? (let ((.x|42|45 (let ((.x|46|49 .exp|3)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))))) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45)))) (let ((.t0|51|52|55 (let ((.x|82|85 (let ((.x|86|89 (let ((.x|90|93 .exp|3)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) (.t1|51|52|55 '(letrec letrec* let*))) (if (eq? .t0|51|52|55 'letrec) .t1|51|52|55 (let ((.t1|51|52|59 (let ((.x|77|80 .t1|51|52|55)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))))) (if (eq? .t0|51|52|55 'letrec*) .t1|51|52|59 (let ((.t1|51|52|63 (let ((.x|73|76 .t1|51|52|59)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (if (eq? .t0|51|52|55 'let*) .t1|51|52|63 (let ((.t1|51|52|67 (let ((.x|69|72 .t1|51|52|63)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) #f))))))) #f) #f) (m-define-syntax1 (let ((.x|95|98 (let ((.x|99|102 .exp|3)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))) (let ((.x|104|107 (let ((.x|108|111 (let ((.x|112|115 (let ((.x|116|119 .exp|3)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))))) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))))) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111))))) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))) .env|3 (let ((.x|121|124 (let ((.x|125|128 (let ((.x|129|132 .exp|3)) (begin (.check! (pair? .x|129|132) 1 .x|129|132) (cdr:pair .x|129|132))))) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))))) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124)))) (m-error "Malformed define-syntax" .exp|3))))) (.m-define-syntax|2 .exp|1 .env|1))))) 'm-define-syntax))
+(let () (begin (set! m-define-syntax1 (lambda (.keyword|1 .spec|1 .env|1 .scope|1) (let ((.m-define-syntax1|2 0)) (begin (set! .m-define-syntax1|2 (lambda (.keyword|3 .spec|3 .env|3 .scope|3) (begin (if (if (pair? .spec|3) (symbol? (let ((.x|6|9 .spec|3)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9)))) #f) (let* ((.transformer-keyword|12 (let ((.x|39|42 .spec|3)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42)))) (.denotation|15 (syntactic-lookup .env|3 .transformer-keyword|12))) (let () (if (eq? .denotation|15 denotation-of-syntax-rules) (let ((.temp|20|23 .scope|3)) (if (memv .temp|20|23 '(letrec)) (m-define-syntax-letrec .keyword|3 .spec|3 .env|3) (if (memv .temp|20|23 '(letrec*)) (m-define-syntax-letrec* .keyword|3 .spec|3 .env|3) (if (memv .temp|20|23 '(let*)) (m-define-syntax-let* .keyword|3 .spec|3 .env|3) (m-bug "Weird scope" .scope|3))))) (if (same-denotation? .denotation|15 denotation-of-transformer) (syntactic-bind-globally! .keyword|3 (make-macro-denotation (eval (let ((.x|30|33 (let ((.x|34|37 .spec|3)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) .env|3)) (m-error "Malformed syntax transformer" .spec|3))))) (m-error "Malformed syntax transformer" .spec|3)) (make-constant .keyword|3)))) (.m-define-syntax1|2 .keyword|1 .spec|1 .env|1 .scope|1))))) 'm-define-syntax1))
+(let () (begin (set! m-define-syntax-letrec (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-letrec|2 0)) (begin (set! .m-define-syntax-letrec|2 (lambda (.keyword|3 .spec|3 .env|3) (syntactic-bind-globally! .keyword|3 (m-compile-transformer-spec .spec|3 .env|3)))) (.m-define-syntax-letrec|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-letrec))
+(let () (begin (set! m-define-syntax-letrec* (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-letrec*|2 0)) (begin (set! .m-define-syntax-letrec*|2 (lambda (.keyword|3 .spec|3 .env|3) (let* ((.env|6 (syntactic-extend (syntactic-copy .env|3) (cons .keyword|3 '()) '((fake denotation)))) (.transformer|9 (m-compile-transformer-spec .spec|3 .env|6))) (let () (begin (syntactic-assign! .env|6 .keyword|3 .transformer|9) (syntactic-bind-globally! .keyword|3 .transformer|9)))))) (.m-define-syntax-letrec*|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-letrec*))
+(let () (begin (set! m-define-syntax-let* (lambda (.keyword|1 .spec|1 .env|1) (let ((.m-define-syntax-let*|2 0)) (begin (set! .m-define-syntax-let*|2 (lambda (.keyword|3 .spec|3 .env|3) (syntactic-bind-globally! .keyword|3 (m-compile-transformer-spec .spec|3 (syntactic-copy .env|3))))) (.m-define-syntax-let*|2 .keyword|1 .spec|1 .env|1))))) 'm-define-syntax-let*))
+(let () (begin (set! m-let-syntax (lambda (.exp|1 .env|1) (let ((.m-let-syntax|2 0)) (begin (set! .m-let-syntax|2 (lambda (.exp|3 .env|3) (if (if (> (safe-length .exp|3) 2) (every1? (lambda (.binding|6) (if (pair? .binding|6) (if (symbol? (let ((.x|9|12 .binding|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (if (pair? (let ((.x|14|17 .binding|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))) (null? (let ((.x|20|23 (let ((.x|24|27 .binding|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) #f) #f) #f)) (let ((.x|29|32 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) #f) (m-body (let ((.x|38|41 (let ((.x|42|45 .exp|3)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))))) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (syntactic-extend .env|3 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (let ((.x|66|69 (let ((.x|70|73 .y1|46|47|58)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69))) .results|46|50|58)))))) (.loop|51|54|57 (let ((.x|75|78 (let ((.x|79|82 .exp|3)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))) '())))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.y1|83|84|95 .results|83|87|95) (if (null? .y1|83|84|95) (reverse .results|83|87|95) (begin #t (.loop|88|91|94 (let ((.x|99|102 .y1|83|84|95)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (cons (let ((.spec|103 (let ((.x|104|107 .y1|83|84|95)) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107))))) (m-compile-transformer-spec .spec|103 .env|3)) .results|83|87|95)))))) (.loop|88|91|94 (let () (let ((.loop|113|116|119 (unspecified))) (begin (set! .loop|113|116|119 (lambda (.y1|108|109|120 .results|108|112|120) (if (null? .y1|108|109|120) (reverse .results|108|112|120) (begin #t (.loop|113|116|119 (let ((.x|124|127 .y1|108|109|120)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.x|129|132 (let ((.x|133|136 (let ((.x|137|140 .y1|108|109|120)) (begin (.check! (pair? .x|137|140) 0 .x|137|140) (car:pair .x|137|140))))) (begin (.check! (pair? .x|133|136) 1 .x|133|136) (cdr:pair .x|133|136))))) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .results|108|112|120)))))) (.loop|113|116|119 (let ((.x|142|145 (let ((.x|146|149 .exp|3)) (begin (.check! (pair? .x|146|149) 1 .x|146|149) (cdr:pair .x|146|149))))) (begin (.check! (pair? .x|142|145) 0 .x|142|145) (car:pair .x|142|145))) '())))) '())))))) (m-error "Malformed let-syntax" .exp|3)))) (.m-let-syntax|2 .exp|1 .env|1))))) 'm-let-syntax))
+(let () (begin (set! m-letrec-syntax (lambda (.exp|1 .env|1) (let ((.m-letrec-syntax|2 0)) (begin (set! .m-letrec-syntax|2 (lambda (.exp|3 .env|3) (if (if (> (safe-length .exp|3) 2) (every1? (lambda (.binding|6) (if (pair? .binding|6) (if (symbol? (let ((.x|9|12 .binding|6)) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12)))) (if (pair? (let ((.x|14|17 .binding|6)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17)))) (null? (let ((.x|20|23 (let ((.x|24|27 .binding|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))) #f) #f) #f)) (let ((.x|29|32 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) #f) (let ((.env|39 (syntactic-extend .env|3 (let () (let ((.loop|171|174|177 (unspecified))) (begin (set! .loop|171|174|177 (lambda (.y1|166|167|178 .results|166|170|178) (if (null? .y1|166|167|178) (reverse .results|166|170|178) (begin #t (.loop|171|174|177 (let ((.x|182|185 .y1|166|167|178)) (begin (.check! (pair? .x|182|185) 1 .x|182|185) (cdr:pair .x|182|185))) (cons (let ((.x|186|189 (let ((.x|190|193 .y1|166|167|178)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193))))) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189))) .results|166|170|178)))))) (.loop|171|174|177 (let ((.x|195|198 (let ((.x|199|202 .exp|3)) (begin (.check! (pair? .x|199|202) 1 .x|199|202) (cdr:pair .x|199|202))))) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))) '())))) (let () (let ((.loop|208|211|214 (unspecified))) (begin (set! .loop|208|211|214 (lambda (.y1|203|204|215 .results|203|207|215) (if (null? .y1|203|204|215) (reverse .results|203|207|215) (begin #t (.loop|208|211|214 (let ((.x|219|222 .y1|203|204|215)) (begin (.check! (pair? .x|219|222) 1 .x|219|222) (cdr:pair .x|219|222))) (cons (let ((.id|223 (let ((.x|224|227 .y1|203|204|215)) (begin (.check! (pair? .x|224|227) 0 .x|224|227) (car:pair .x|224|227))))) '(fake denotation)) .results|203|207|215)))))) (.loop|208|211|214 (let ((.x|229|232 (let ((.x|233|236 .exp|3)) (begin (.check! (pair? .x|233|236) 1 .x|233|236) (cdr:pair .x|233|236))))) (begin (.check! (pair? .x|229|232) 0 .x|229|232) (car:pair .x|229|232))) '()))))))) (begin (let () (let ((.loop|46|49|52 (unspecified))) (begin (set! .loop|46|49|52 (lambda (.y1|40|42|53 .y1|40|41|53) (if (let ((.temp|55|58 (null? .y1|40|42|53))) (if .temp|55|58 .temp|55|58 (null? .y1|40|41|53))) (if #f #f (unspecified)) (begin (begin #t (let ((.id|61 (let ((.x|62|65 .y1|40|42|53)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (.spec|61 (let ((.x|66|69 .y1|40|41|53)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69))))) (syntactic-assign! .env|39 .id|61 (m-compile-transformer-spec .spec|61 .env|39)))) (.loop|46|49|52 (let ((.x|70|73 .y1|40|42|53)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (let ((.x|74|77 .y1|40|41|53)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77)))))))) (.loop|46|49|52 (let () (let ((.loop|83|86|89 (unspecified))) (begin (set! .loop|83|86|89 (lambda (.y1|78|79|90 .results|78|82|90) (if (null? .y1|78|79|90) (reverse .results|78|82|90) (begin #t (.loop|83|86|89 (let ((.x|94|97 .y1|78|79|90)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))) (cons (let ((.x|98|101 (let ((.x|102|105 .y1|78|79|90)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105))))) (begin (.check! (pair? .x|98|101) 0 .x|98|101) (car:pair .x|98|101))) .results|78|82|90)))))) (.loop|83|86|89 (let ((.x|107|110 (let ((.x|111|114 .exp|3)) (begin (.check! (pair? .x|111|114) 1 .x|111|114) (cdr:pair .x|111|114))))) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))) '())))) (let () (let ((.loop|120|123|126 (unspecified))) (begin (set! .loop|120|123|126 (lambda (.y1|115|116|127 .results|115|119|127) (if (null? .y1|115|116|127) (reverse .results|115|119|127) (begin #t (.loop|120|123|126 (let ((.x|131|134 .y1|115|116|127)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134))) (cons (let ((.x|136|139 (let ((.x|140|143 (let ((.x|144|147 .y1|115|116|127)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))))) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))))) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))) .results|115|119|127)))))) (.loop|120|123|126 (let ((.x|149|152 (let ((.x|153|156 .exp|3)) (begin (.check! (pair? .x|153|156) 1 .x|153|156) (cdr:pair .x|153|156))))) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152))) '())))))))) (m-body (let ((.x|158|161 (let ((.x|162|165 .exp|3)) (begin (.check! (pair? .x|162|165) 1 .x|162|165) (cdr:pair .x|162|165))))) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))) .env|39))) (m-error "Malformed let-syntax" .exp|3)))) (.m-letrec-syntax|2 .exp|1 .env|1))))) 'm-letrec-syntax))
+(let () (begin (set! m-macro (lambda (.exp|1 .env|1) (let ((.m-macro|2 0)) (begin (set! .m-macro|2 (lambda (.exp|3 .env|3) (m-transcribe .exp|3 .env|3 (lambda (.exp|4 .env|4) (m-expand .exp|4 .env|4))))) (.m-macro|2 .exp|1 .env|1))))) 'm-macro))
+(let () (begin (set! m-inline (lambda (.exp|1 .env|1) (let ((.m-inline|2 0)) (begin (set! .m-inline|2 (lambda (.exp|3 .env|3) (if (integrate-usual-procedures) (m-transcribe-inline .exp|3 .env|3 (lambda (.newexp|4 .env|4) (if (eq? .exp|3 .newexp|4) (m-application .exp|3 .env|4) (m-expand .newexp|4 .env|4)))) (m-application .exp|3 .env|3)))) (.m-inline|2 .exp|1 .env|1))))) 'm-inline))
+(let () (begin (set! m-quit (lambda (.v|1) .v|1)) 'm-quit))
+(let () ($$trace "usual"))
+(let () (define-syntax-scope 'letrec*))
+(let () (let () (let ((.loop|6|8|11 (unspecified))) (begin (set! .loop|6|8|11 (lambda (.y1|1|2|12) (if (null? .y1|1|2|12) (if #f #f (unspecified)) (begin (begin #t (let ((.form|16 (let ((.x|17|20 .y1|1|2|12)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))) (macro-expand .form|16))) (.loop|6|8|11 (let ((.x|21|24 .y1|1|2|12)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))))))) (.loop|6|8|11 '((define-syntax let (syntax-rules () ((let ((?name ?val) ...) ?body ?body1 ...) ((lambda (?name ...) ?body ?body1 ...) ?val ...)))) (define-syntax let* (syntax-rules () ((let* () ?body ?body1 ...) (let () ?body ?body1 ...)) ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...) (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...))))) (define-syntax letrec (syntax-rules (lambda quote) ((letrec ((?name ?val) ...) ?body ?body2 ...) ((lambda () (define ?name ?val) ... ?body ?body2 ...))))) (define-syntax let let* (syntax-rules () ((let (?bindings ...) . ?body) (let (?bindings ...) . ?body)) ((let ?tag ((?name ?val) ...) ?body ?body1 ...) (let ((?name ?val) ...) (letrec ((?tag (lambda (?name ...) ?body ?body1 ...))) (?tag ?name ...)))))) (define-syntax and (syntax-rules () ((and) #t) ((and ?e) ?e) ((and ?e1 ?e2 ?e3 ...) (if ?e1 (and ?e2 ?e3 ...) #f)))) (define-syntax or (syntax-rules () ((or) #f) ((or ?e) ?e) ((or ?e1 ?e2 ?e3 ...) (let ((temp ?e1)) (if temp temp (or ?e2 ?e3 ...)))))) (define-syntax cond (syntax-rules (else =>) ((cond (else ?result ?result2 ...)) (begin ?result ?result2 ...)) ((cond (?test => ?result)) (let ((temp ?test)) (if temp (?result temp)))) ((cond (?test)) ?test) ((cond (?test ?result ?result2 ...)) (if ?test (begin ?result ?result2 ...))) ((cond (?test => ?result) ?clause ?clause2 ...) (let ((temp ?test)) (if temp (?result temp) (cond ?clause ?clause2 ...)))) ((cond (?test) ?clause ?clause2 ...) (or ?test (cond ?clause ?clause2 ...))) ((cond (?test ?result ?result2 ...) ?clause ?clause2 ...) (if ?test (begin ?result ?result2 ...) (cond ?clause ?clause2 ...))))) (define-syntax do (syntax-rules () ((do (?bindings0 ...) (?test) ?body0 ...) (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...)) ((do (?bindings0 ...) ?clause0 ?body0 ...) (letrec-syntax ((do-aux (... (syntax-rules () ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...) (letrec ((loop (lambda (?name ...) (cond ?clause (else (begin #t ?body ...) (loop ?step ...)))))) (loop ?init ...))) ((do-aux ((?name ?init ?step) ?todo ...) (?bindings ...) ?clause ?body ...) (do-aux (?todo ...) (?bindings ... (?name ?init ?step)) ?clause ?body ...)) ((do-aux ((?name ?init) ?todo ...) (?bindings ...) ?clause ?body ...) (do-aux (?todo ...) (?bindings ... (?name ?init ?name)) ?clause ?body ...)))))) (do-aux (?bindings0 ...) () ?clause0 ?body0 ...))))) (define-syntax delay (syntax-rules () ((delay ?e) (.make-promise (lambda () ?e))))) (define-syntax case (syntax-rules (else) ((case ?e1 (else ?body ?body2 ...)) (begin ?e1 ?body ?body2 ...)) ((case ?e1 (?z ?body ?body2 ...)) (if (memv ?e1 '?z) (begin ?body ?body2 ...))) ((case ?e1 ?clause1 ?clause2 ?clause3 ...) (letrec-syntax ((case-aux (... (syntax-rules (else) ((case-aux ?temp (else ?body ?body2 ...)) (begin ?body ?body2 ...)) ((case-aux ?temp ((?z ...) ?body ?body2 ...)) (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...))) ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...) (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...) (case-aux ?temp ?c1 ?c2 ...))) ((case-aux ?temp (?z ?body ...) ?c1 ...) (case-aux ?temp ((?z) ?body ...) ?c1 ...)))))) (let ((temp ?e1)) (case-aux temp ?clause1 ?clause2 ?clause3 ...)))))) (begin (define-syntax .finalize-quasiquote letrec (syntax-rules (quote unquote unquote-splicing) ((.finalize-quasiquote quote ?arg ?return) (.interpret-continuation ?return '?arg)) ((.finalize-quasiquote unquote ?arg ?return) (.interpret-continuation ?return ?arg)) ((.finalize-quasiquote unquote-splicing ?arg ?return) (syntax-error ",@ in illegal context" ?arg)) ((.finalize-quasiquote ?mode ?arg ?return) (.interpret-continuation ?return (?mode . ?arg))))) (define-syntax .descend-quasiquote letrec (syntax-rules (quasiquote unquote unquote-splicing) ((.descend-quasiquote `?y ?x ?level ?return) (.descend-quasiquote-pair ?x ?x (?level) ?return)) ((.descend-quasiquote ,?y ?x () ?return) (.interpret-continuation ?return unquote ?y)) ((.descend-quasiquote ,?y ?x (?level) ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote ,@?y ?x () ?return) (.interpret-continuation ?return unquote-splicing ?y)) ((.descend-quasiquote ,@?y ?x (?level) ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote (?y . ?z) ?x ?level ?return) (.descend-quasiquote-pair ?x ?x ?level ?return)) ((.descend-quasiquote #(?y ...) ?x ?level ?return) (.descend-quasiquote-vector ?x ?x ?level ?return)) ((.descend-quasiquote ?y ?x ?level ?return) (.interpret-continuation ?return quote ?x)))) (define-syntax .descend-quasiquote-pair letrec (syntax-rules (quote unquote unquote-splicing) ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return) (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return))))) (define-syntax .descend-quasiquote-vector letrec (syntax-rules (quote) ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return) (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return))))) (define-syntax .interpret-continuation letrec (syntax-rules (quote unquote unquote-splicing) ((.interpret-continuation (-1) ?e) ?e) ((.interpret-continuation (0) ?mode ?arg) (.finalize-quasiquote ?mode ?arg (-1))) ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg) (.descend-quasiquote ?cdrx ?cdrx ?level (2 ?car-mode ?car-arg ?x ?return))) ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg) (.interpret-continuation ?return quote ?x)) ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ()) (.interpret-continuation ?return unquote ?car-arg)) ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) ?cdr-mode ?cdr-arg) (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return))) ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return) ?cdr-mode ?cdr-arg) (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return))) ((.interpret-continuation (3 ?car-arg ?return) ?e) (.interpret-continuation ?return append (?car-arg ?e))) ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1) (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return))) ((.interpret-continuation (5 ?e1 ?return) ?e2) (.interpret-continuation ?return .cons (?e1 ?e2))) ((.interpret-continuation (6 ?x ?return) quote ?arg) (.interpret-continuation ?return quote ?x)) ((.interpret-continuation (6 ?x ?return) ?mode ?arg) (.finalize-quasiquote ?mode ?arg (7 ?return))) ((.interpret-continuation (7 ?return) ?e) (.interpret-continuation ?return .list->vector (?e))))) (define-syntax quasiquote letrec (syntax-rules () (`?x (.descend-quasiquote ?x ?x () (0)))))) (define-syntax let*-syntax (syntax-rules () ((let*-syntax () ?body) (let-syntax () ?body)) ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body) (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))))))))
+(let () (define-syntax-scope 'letrec))
+(let () (begin (set! standard-syntactic-environment (syntactic-copy global-syntactic-environment)) 'standard-syntactic-environment))
+(let () (begin (set! make-standard-syntactic-environment (lambda () (let ((.make-standard-syntactic-environment|2 0)) (begin (set! .make-standard-syntactic-environment|2 (lambda () (syntactic-copy standard-syntactic-environment))) (.make-standard-syntactic-environment|2))))) 'make-standard-syntactic-environment))
+(let () (begin (set! copy-exp (lambda (.exp|1) (let ((.copy-exp|2 0)) (begin (set! .copy-exp|2 (lambda (.exp|3) (let ((.copy|4 (unspecified)) (.lexical-lookup|4 (unspecified)) (.env-unbind-multiple!|4 (unspecified)) (.env-bind-multiple!|4 (unspecified)) (.env-lookup|4 (unspecified)) (.env-unbind!|4 (unspecified)) (.env-bind!|4 (unspecified)) (.make-env|4 (unspecified)) (.rename-formals|4 (unspecified)) (.rename-vars|4 (unspecified)) (.renaming-counter|4 (unspecified)) (.original-names|4 (unspecified)) (.special-names|4 (unspecified))) (begin (set! .copy|4 (lambda (.exp|5 .env|5 .notepad|5 .r-table|5) (if (constant? .exp|5) .exp|5 (if (lambda? .exp|5) (let* ((.bvl|10 (make-null-terminated (lambda.args .exp|5))) (.newnames|13 (.rename-vars|4 .bvl|10)) (.procnames|16 (let () (let ((.loop|172|175|178 (unspecified))) (begin (set! .loop|172|175|178 (lambda (.y1|167|168|179 .results|167|171|179) (if (null? .y1|167|168|179) (reverse .results|167|171|179) (begin #t (.loop|172|175|178 (let ((.x|183|186 .y1|167|168|179)) (begin (.check! (pair? .x|183|186) 1 .x|183|186) (cdr:pair .x|183|186))) (cons (def.lhs (let ((.x|187|190 .y1|167|168|179)) (begin (.check! (pair? .x|187|190) 0 .x|187|190) (car:pair .x|187|190)))) .results|167|171|179)))))) (.loop|172|175|178 (lambda.defs .exp|5) '()))))) (.newprocnames|19 (.rename-vars|4 .procnames|16)) (.refinfo|22 (let () (let ((.loop|147|150|153 (unspecified))) (begin (set! .loop|147|150|153 (lambda (.y1|142|143|154 .results|142|146|154) (if (null? .y1|142|143|154) (reverse .results|142|146|154) (begin #t (.loop|147|150|153 (let ((.x|158|161 .y1|142|143|154)) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))) (cons (let ((.var|162 (let ((.x|163|166 .y1|142|143|154)) (begin (.check! (pair? .x|163|166) 0 .x|163|166) (car:pair .x|163|166))))) (make-r-entry .var|162 '() '() '())) .results|142|146|154)))))) (.loop|147|150|153 (append .newnames|13 .newprocnames|19) '()))))) (.newexp|25 (make-lambda (.rename-formals|4 (lambda.args .exp|5) .newnames|13) '() .refinfo|22 '() '() (lambda.decls .exp|5) (lambda.doc .exp|5) (lambda.body .exp|5)))) (let () (begin (.env-bind-multiple!|4 .env|5 .procnames|16 .newprocnames|19) (.env-bind-multiple!|4 .env|5 .bvl|10 .newnames|13) (let () (let ((.loop|34|36|39 (unspecified))) (begin (set! .loop|34|36|39 (lambda (.y1|29|30|40) (if (null? .y1|29|30|40) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|44 (let ((.x|45|48 .y1|29|30|40)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))))) (.env-bind!|4 .r-table|5 (r-entry.name .entry|44) .entry|44))) (.loop|34|36|39 (let ((.x|49|52 .y1|29|30|40)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52)))))))) (.loop|34|36|39 .refinfo|22)))) (notepad-lambda-add! .notepad|5 .newexp|25) (let ((.newnotepad|55 (make-notepad .notepad|5))) (begin (let () (let ((.loop|62|65|68 (unspecified))) (begin (set! .loop|62|65|68 (lambda (.y1|56|58|69 .y1|56|57|69) (if (let ((.temp|71|74 (null? .y1|56|58|69))) (if .temp|71|74 .temp|71|74 (null? .y1|56|57|69))) (if #f #f (unspecified)) (begin (begin #t (let ((.name|77 (let ((.x|78|81 .y1|56|58|69)) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.rhs|77 (let ((.x|82|85 .y1|56|57|69)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85))))) (lambda.defs-set! .newexp|25 (cons (make-definition .name|77 (.copy|4 .rhs|77 .env|5 .newnotepad|55 .r-table|5)) (lambda.defs .newexp|25))))) (.loop|62|65|68 (let ((.x|86|89 .y1|56|58|69)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))) (let ((.x|90|93 .y1|56|57|69)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93)))))))) (.loop|62|65|68 (reverse .newprocnames|19) (let () (let ((.loop|99|102|105 (unspecified))) (begin (set! .loop|99|102|105 (lambda (.y1|94|95|106 .results|94|98|106) (if (null? .y1|94|95|106) (reverse .results|94|98|106) (begin #t (.loop|99|102|105 (let ((.x|110|113 .y1|94|95|106)) (begin (.check! (pair? .x|110|113) 1 .x|110|113) (cdr:pair .x|110|113))) (cons (def.rhs (let ((.x|114|117 .y1|94|95|106)) (begin (.check! (pair? .x|114|117) 0 .x|114|117) (car:pair .x|114|117)))) .results|94|98|106)))))) (.loop|99|102|105 (reverse (lambda.defs .exp|5)) '())))))))) (lambda.body-set! .newexp|25 (.copy|4 (lambda.body .exp|5) .env|5 .newnotepad|55 .r-table|5)) (lambda.f-set! .newexp|25 (notepad-free-variables .newnotepad|55)) (lambda.g-set! .newexp|25 (notepad-captured-variables .newnotepad|55)))) (.env-unbind-multiple!|4 .env|5 .procnames|16) (.env-unbind-multiple!|4 .env|5 .bvl|10) (let () (let ((.loop|123|125|128 (unspecified))) (begin (set! .loop|123|125|128 (lambda (.y1|118|119|129) (if (null? .y1|118|119|129) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|133 (let ((.x|134|137 .y1|118|119|129)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137))))) (.env-unbind!|4 .r-table|5 (r-entry.name .entry|133)))) (.loop|123|125|128 (let ((.x|138|141 .y1|118|119|129)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141)))))))) (.loop|123|125|128 .refinfo|22)))) .newexp|25))) (if (assignment? .exp|5) (let* ((.oldname|194 (assignment.lhs .exp|5)) (.name|197 (.env-lookup|4 .env|5 .oldname|194 .oldname|194)) (.varinfo|200 (.env-lookup|4 .r-table|5 .name|197 #f)) (.newexp|203 (make-assignment .name|197 (.copy|4 (assignment.rhs .exp|5) .env|5 .notepad|5 .r-table|5)))) (let () (begin (notepad-var-add! .notepad|5 .name|197) (if .varinfo|200 (r-entry.assignments-set! .varinfo|200 (cons .newexp|203 (r-entry.assignments .varinfo|200))) (unspecified)) .newexp|203))) (if (conditional? .exp|5) (make-conditional (.copy|4 (if.test .exp|5) .env|5 .notepad|5 .r-table|5) (.copy|4 (if.then .exp|5) .env|5 .notepad|5 .r-table|5) (.copy|4 (if.else .exp|5) .env|5 .notepad|5 .r-table|5)) (if (begin? .exp|5) (make-begin (let () (let ((.loop|214|217|220 (unspecified))) (begin (set! .loop|214|217|220 (lambda (.y1|209|210|221 .results|209|213|221) (if (null? .y1|209|210|221) (reverse .results|209|213|221) (begin #t (.loop|214|217|220 (let ((.x|225|228 .y1|209|210|221)) (begin (.check! (pair? .x|225|228) 1 .x|225|228) (cdr:pair .x|225|228))) (cons (let ((.exp|229 (let ((.x|230|233 .y1|209|210|221)) (begin (.check! (pair? .x|230|233) 0 .x|230|233) (car:pair .x|230|233))))) (.copy|4 .exp|229 .env|5 .notepad|5 .r-table|5)) .results|209|213|221)))))) (.loop|214|217|220 (begin.exprs .exp|5) '()))))) (if (variable? .exp|5) (let* ((.oldname|237 (variable.name .exp|5)) (.name|240 (.env-lookup|4 .env|5 .oldname|237 .oldname|237)) (.varinfo|243 (.env-lookup|4 .r-table|5 .name|240 #f)) (.newexp|246 (make-variable .name|240))) (let () (begin (notepad-var-add! .notepad|5 .name|240) (if .varinfo|243 (r-entry.references-set! .varinfo|243 (cons .newexp|246 (r-entry.references .varinfo|243))) (unspecified)) .newexp|246))) (if (call? .exp|5) (let ((.newexp|253 (make-call (.copy|4 (call.proc .exp|5) .env|5 .notepad|5 .r-table|5) (let () (let ((.loop|262|265|268 (unspecified))) (begin (set! .loop|262|265|268 (lambda (.y1|257|258|269 .results|257|261|269) (if (null? .y1|257|258|269) (reverse .results|257|261|269) (begin #t (.loop|262|265|268 (let ((.x|273|276 .y1|257|258|269)) (begin (.check! (pair? .x|273|276) 1 .x|273|276) (cdr:pair .x|273|276))) (cons (let ((.exp|277 (let ((.x|278|281 .y1|257|258|269)) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281))))) (.copy|4 .exp|277 .env|5 .notepad|5 .r-table|5)) .results|257|261|269)))))) (.loop|262|265|268 (call.args .exp|5) '()))))))) (begin (if (variable? (call.proc .newexp|253)) (let ((.varinfo|256 (.env-lookup|4 .r-table|5 (variable.name (call.proc .newexp|253)) #f))) (if .varinfo|256 (r-entry.calls-set! .varinfo|256 (cons .newexp|253 (r-entry.calls .varinfo|256))) (unspecified))) (unspecified)) (if (lambda? (call.proc .newexp|253)) (notepad-nonescaping-add! .notepad|5 (call.proc .newexp|253)) (unspecified)) .newexp|253)) ???))))))))) (set! .lexical-lookup|4 (lambda (.r-table|283 .name|283) (assq .name|283 .r-table|283))) (set! .env-unbind-multiple!|4 (lambda (.env|284 .symbols|284) (let () (let ((.loop|290|292|295 (unspecified))) (begin (set! .loop|290|292|295 (lambda (.y1|285|286|296) (if (null? .y1|285|286|296) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|300 (let ((.x|301|304 .y1|285|286|296)) (begin (.check! (pair? .x|301|304) 0 .x|301|304) (car:pair .x|301|304))))) (.env-unbind!|4 .env|284 .sym|300))) (.loop|290|292|295 (let ((.x|305|308 .y1|285|286|296)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308)))))))) (.loop|290|292|295 .symbols|284)))))) (set! .env-bind-multiple!|4 (lambda (.env|309 .symbols|309 .infos|309) (let () (let ((.loop|316|319|322 (unspecified))) (begin (set! .loop|316|319|322 (lambda (.y1|310|312|323 .y1|310|311|323) (if (let ((.temp|325|328 (null? .y1|310|312|323))) (if .temp|325|328 .temp|325|328 (null? .y1|310|311|323))) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|331 (let ((.x|332|335 .y1|310|312|323)) (begin (.check! (pair? .x|332|335) 0 .x|332|335) (car:pair .x|332|335)))) (.info|331 (let ((.x|336|339 .y1|310|311|323)) (begin (.check! (pair? .x|336|339) 0 .x|336|339) (car:pair .x|336|339))))) (.env-bind!|4 .env|309 .sym|331 .info|331))) (.loop|316|319|322 (let ((.x|340|343 .y1|310|312|323)) (begin (.check! (pair? .x|340|343) 1 .x|340|343) (cdr:pair .x|340|343))) (let ((.x|344|347 .y1|310|311|323)) (begin (.check! (pair? .x|344|347) 1 .x|344|347) (cdr:pair .x|344|347)))))))) (.loop|316|319|322 .symbols|309 .infos|309)))))) (set! .env-lookup|4 (lambda (.env|348 .sym|348 .default|348) (let ((.stack|351 (hashtable-get .env|348 .sym|348))) (if .stack|351 (let ((.x|352|355 .stack|351)) (begin (.check! (pair? .x|352|355) 0 .x|352|355) (car:pair .x|352|355))) .default|348)))) (set! .env-unbind!|4 (lambda (.env|356 .sym|356) (let ((.stack|359 (hashtable-get .env|356 .sym|356))) (hashtable-put! .env|356 .sym|356 (let ((.x|360|363 .stack|359)) (begin (.check! (pair? .x|360|363) 1 .x|360|363) (cdr:pair .x|360|363))))))) (set! .env-bind!|4 (lambda (.env|364 .sym|364 .info|364) (let ((.stack|367 (hashtable-get .env|364 .sym|364))) (hashtable-put! .env|364 .sym|364 (cons .info|364 .stack|367))))) (set! .make-env|4 (lambda () (make-hashtable symbol-hash assq))) (set! .rename-formals|4 (lambda (.formals|369 .newnames|369) (if (null? .formals|369) '() (if (symbol? .formals|369) (let ((.x|372|375 .newnames|369)) (begin (.check! (pair? .x|372|375) 0 .x|372|375) (car:pair .x|372|375))) (if (memq (let ((.x|377|380 .formals|369)) (begin (.check! (pair? .x|377|380) 0 .x|377|380) (car:pair .x|377|380))) .special-names|4) (cons (let ((.x|381|384 .formals|369)) (begin (.check! (pair? .x|381|384) 0 .x|381|384) (car:pair .x|381|384))) (.rename-formals|4 (let ((.x|385|388 .formals|369)) (begin (.check! (pair? .x|385|388) 1 .x|385|388) (cdr:pair .x|385|388))) (let ((.x|389|392 .newnames|369)) (begin (.check! (pair? .x|389|392) 1 .x|389|392) (cdr:pair .x|389|392))))) (cons (let ((.x|394|397 .newnames|369)) (begin (.check! (pair? .x|394|397) 0 .x|394|397) (car:pair .x|394|397))) (.rename-formals|4 (let ((.x|398|401 .formals|369)) (begin (.check! (pair? .x|398|401) 1 .x|398|401) (cdr:pair .x|398|401))) (let ((.x|402|405 .newnames|369)) (begin (.check! (pair? .x|402|405) 1 .x|402|405) (cdr:pair .x|402|405)))))))))) (set! .rename-vars|4 (lambda (.vars|406) (let ((.rename|409 (make-rename-procedure))) (let () (let ((.loop|415|418|421 (unspecified))) (begin (set! .loop|415|418|421 (lambda (.y1|410|411|422 .results|410|414|422) (if (null? .y1|410|411|422) (reverse .results|410|414|422) (begin #t (.loop|415|418|421 (let ((.x|426|429 .y1|410|411|422)) (begin (.check! (pair? .x|426|429) 1 .x|426|429) (cdr:pair .x|426|429))) (cons (let ((.var|430 (let ((.x|434|437 .y1|410|411|422)) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437))))) (if (memq .var|430 .special-names|4) .var|430 (if (hashtable-get .original-names|4 .var|430) (.rename|409 .var|430) (begin (hashtable-put! .original-names|4 .var|430 #t) .var|430)))) .results|410|414|422)))))) (.loop|415|418|421 .vars|406 '()))))))) (set! .renaming-counter|4 0) (set! .original-names|4 (make-hashtable symbol-hash assq)) (set! .special-names|4 (cons name:ignored argument-registers)) (.copy|4 .exp|3 (.make-env|4) (make-notepad #f) (.make-env|4)))))) (.copy-exp|2 .exp|1))))) 'copy-exp))
+(let () (begin (set! check-referencing-invariants (lambda (.exp|1 . .flags|1) (let ((.check-free-variables?|4 (memq 'free .flags|1)) (.check-referencing?|4 (memq 'reference .flags|1)) (.first-violation?|4 #t)) (let ((.lookup|5 (unspecified)) (.return|5 (unspecified)) (.check|5 (unspecified))) (begin (set! .lookup|5 (lambda (.env|6 .i|6) (if (null? .env|6) #f (let* ((.rinfo|9 (r-entry (lambda.r (let ((.x|19|22 .env|6)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) .i|6)) (.temp|10|13 .rinfo|9)) (if .temp|10|13 .temp|10|13 (.lookup|5 (let ((.x|15|18 .env|6)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .i|6)))))) (set! .return|5 (lambda (.exp|23 .flag|23) (if .flag|23 #t (if .first-violation?|4 (begin (set! .first-violation?|4 #f) (display "Violation of referencing invariants") (newline) (pretty-print (make-readable .exp|23)) #f) (begin (pretty-print (make-readable .exp|23)) #f))))) (set! .check|5 (lambda (.exp|27 .env|27) (if (constant? .exp|27) (.return|5 .exp|27 #t) (if (lambda? .exp|27) (let ((.env|32 (cons .exp|27 .env|27))) (.return|5 .exp|27 (if (every? (lambda (.exp|34) (.check|5 .exp|34 .env|32)) (let () (let ((.loop|40|43|46 (unspecified))) (begin (set! .loop|40|43|46 (lambda (.y1|35|36|47 .results|35|39|47) (if (null? .y1|35|36|47) (reverse .results|35|39|47) (begin #t (.loop|40|43|46 (let ((.x|51|54 .y1|35|36|47)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (cons (def.rhs (let ((.x|55|58 .y1|35|36|47)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58)))) .results|35|39|47)))))) (.loop|40|43|46 (lambda.defs .exp|27) '()))))) (if (.check|5 (lambda.body .exp|27) .env|32) (if (if (if .check-free-variables?|4 (not (null? .env|32)) #f) (subset? (difference (lambda.f .exp|27) (make-null-terminated (lambda.args .exp|27))) (lambda.f (let ((.x|63|66 .env|32)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))))) #t) (if .check-referencing?|4 (let ((.env|70 (cons .exp|27 .env|32)) (.r|70 (lambda.r .exp|27))) (every? (lambda (.formal|71) (let ((.temp|72|75 (ignored? .formal|71))) (if .temp|72|75 .temp|72|75 (r-entry .r|70 .formal|71)))) (make-null-terminated (lambda.args .exp|27)))) #t) #f) #f) #f))) (if (variable? .exp|27) (.return|5 .exp|27 (if (if (if .check-free-variables?|4 (not (null? .env|27)) #f) (memq (variable.name .exp|27) (lambda.f (let ((.x|81|84 .env|27)) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))))) #t) (if .check-referencing?|4 (let ((.rinfo|88 (.lookup|5 .env|27 (variable.name .exp|27)))) (if .rinfo|88 (memq .exp|27 (r-entry.references .rinfo|88)) #t)) #t) #f)) (if (assignment? .exp|27) (.return|5 .exp|27 (if (.check|5 (assignment.rhs .exp|27) .env|27) (if (if (if .check-free-variables?|4 (not (null? .env|27)) #f) (memq (assignment.lhs .exp|27) (lambda.f (let ((.x|94|97 .env|27)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) #t) (if .check-referencing?|4 (let ((.rinfo|101 (.lookup|5 .env|27 (assignment.lhs .exp|27)))) (if .rinfo|101 (memq .exp|27 (r-entry.assignments .rinfo|101)) #t)) #t) #f) #f)) (if (conditional? .exp|27) (.return|5 .exp|27 (if (.check|5 (if.test .exp|27) .env|27) (if (.check|5 (if.then .exp|27) .env|27) (.check|5 (if.else .exp|27) .env|27) #f) #f)) (if (begin? .exp|27) (.return|5 .exp|27 (every? (lambda (.exp|107) (.check|5 .exp|107 .env|27)) (begin.exprs .exp|27))) (if (call? .exp|27) (.return|5 .exp|27 (if (.check|5 (call.proc .exp|27) .env|27) (if (every? (lambda (.exp|111) (.check|5 .exp|111 .env|27)) (call.args .exp|27)) (if (if .check-referencing?|4 (variable? (call.proc .exp|27)) #f) (let ((.rinfo|117 (.lookup|5 .env|27 (variable.name (call.proc .exp|27))))) (if .rinfo|117 (memq .exp|27 (r-entry.calls .rinfo|117)) #t)) #t) #f) #f)) ???))))))))) (if (null? .flags|1) (begin (set! .check-free-variables?|4 #t) (set! .check-referencing?|4 #t)) (unspecified)) (.check|5 .exp|1 '())))))) 'check-referencing-invariants))
+(let () (begin (set! compute-free-variables! (lambda (.exp|1) (let ((.compute-free-variables!|2 0)) (begin (set! .compute-free-variables!|2 (lambda (.exp|3) (let ((.free|4 (unspecified)) (.set->list|4 (unspecified)) (.union3|4 (unspecified)) (.union2|4 (unspecified)) (.singleton|4 (unspecified)) (.empty-set|4 (unspecified))) (begin (set! .free|4 (lambda (.exp|5) (if (constant? .exp|5) .empty-set|4 (if (lambda? .exp|5) (let* ((.defs|10 (lambda.defs .exp|5)) (.formals|13 (make-set (make-null-terminated (lambda.args .exp|5)))) (.defined|16 (make-set (let () (let ((.loop|59|62|65 (unspecified))) (begin (set! .loop|59|62|65 (lambda (.y1|54|55|66 .results|54|58|66) (if (null? .y1|54|55|66) (reverse .results|54|58|66) (begin #t (.loop|59|62|65 (let ((.x|70|73 .y1|54|55|66)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (cons (def.lhs (let ((.x|74|77 .y1|54|55|66)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77)))) .results|54|58|66)))))) (.loop|59|62|65 .defs|10 '())))))) (.fdefs|19 (apply-union (let () (let ((.loop|34|37|40 (unspecified))) (begin (set! .loop|34|37|40 (lambda (.y1|29|30|41 .results|29|33|41) (if (null? .y1|29|30|41) (reverse .results|29|33|41) (begin #t (.loop|34|37|40 (let ((.x|45|48 .y1|29|30|41)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))) (cons (let ((.def|49 (let ((.x|50|53 .y1|29|30|41)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (.free|4 (def.rhs .def|49))) .results|29|33|41)))))) (.loop|34|37|40 .defs|10 '())))))) (.fbody|22 (.free|4 (lambda.body .exp|5))) (.f|25 (.union2|4 .fdefs|19 .fbody|22))) (let () (begin (lambda.f-set! .exp|5 (.set->list|4 .f|25)) (lambda.g-set! .exp|5 (.set->list|4 .f|25)) (difference .f|25 (.union2|4 .formals|13 .defined|16))))) (if (assignment? .exp|5) (.union2|4 (make-set (cons (assignment.lhs .exp|5) '())) (.free|4 (assignment.rhs .exp|5))) (if (conditional? .exp|5) (.union3|4 (.free|4 (if.test .exp|5)) (.free|4 (if.then .exp|5)) (.free|4 (if.else .exp|5))) (if (begin? .exp|5) (apply-union (let () (let ((.loop|87|90|93 (unspecified))) (begin (set! .loop|87|90|93 (lambda (.y1|82|83|94 .results|82|86|94) (if (null? .y1|82|83|94) (reverse .results|82|86|94) (begin #t (.loop|87|90|93 (let ((.x|98|101 .y1|82|83|94)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) (cons (let ((.exp|102 (let ((.x|103|106 .y1|82|83|94)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106))))) (.free|4 .exp|102)) .results|82|86|94)))))) (.loop|87|90|93 (begin.exprs .exp|5) '()))))) (if (variable? .exp|5) (.singleton|4 (variable.name .exp|5)) (if (call? .exp|5) (.union2|4 (.free|4 (call.proc .exp|5)) (apply-union (let () (let ((.loop|114|117|120 (unspecified))) (begin (set! .loop|114|117|120 (lambda (.y1|109|110|121 .results|109|113|121) (if (null? .y1|109|110|121) (reverse .results|109|113|121) (begin #t (.loop|114|117|120 (let ((.x|125|128 .y1|109|110|121)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) (cons (let ((.exp|129 (let ((.x|130|133 .y1|109|110|121)) (begin (.check! (pair? .x|130|133) 0 .x|130|133) (car:pair .x|130|133))))) (.free|4 .exp|129)) .results|109|113|121)))))) (.loop|114|117|120 (call.args .exp|5) '())))))) ???))))))))) (set! .set->list|4 (lambda (.set|135) .set|135)) (set! .union3|4 (lambda (.x|136 .y|136 .z|136) (union .x|136 .y|136 .z|136))) (set! .union2|4 (lambda (.x|137 .y|137) (union .x|137 .y|137))) (set! .singleton|4 (lambda (.x|138) (cons .x|138 '()))) (set! .empty-set|4 (make-set '())) (.free|4 .exp|3))))) (.compute-free-variables!|2 .exp|1))))) 'compute-free-variables!))
+(let () (begin '(define (compute-free-variables! exp) (define empty-set (make-hashtree symbol-hash assq)) (define (singleton x) (hashtree-put empty-set x #t)) (define (make-set values) (if (null? values) empty-set (hashtree-put (make-set (cdr values)) (car values) #t))) (define (union2 x y) (hashtree-for-each (lambda (key val) (set! x (hashtree-put x key #t))) y) x) (define (union3 x y z) (union2 (union2 x y) z)) (define (apply-union sets) (cond ((null? sets) (make-set '())) ((null? (cdr sets)) (car sets)) (else (union2 (car sets) (apply-union (cdr sets)))))) (define (difference x y) (hashtree-for-each (lambda (key val) (set! x (hashtree-remove x key))) y) x) (define (set->list set) (hashtree-map (lambda (sym val) sym) set)) (define (free exp) (cond ((constant? exp) empty-set) ((lambda? exp) (let* ((defs (lambda.defs exp)) (formals (make-set (make-null-terminated (lambda.args exp)))) (defined (make-set (map def.lhs defs))) (fdefs (apply-union (map (lambda (def) (free (def.rhs def))) defs))) (fbody (free (lambda.body exp))) (f (union2 fdefs fbody))) (lambda.f-set! exp (set->list f)) (lambda.g-set! exp (set->list f)) (difference f (union2 formals defined)))) ((assignment? exp) (union2 (make-set (list (assignment.lhs exp))) (free (assignment.rhs exp)))) ((conditional? exp) (union3 (free (if.test exp)) (free (if.then exp)) (free (if.else exp)))) ((begin? exp) (apply-union (map (lambda (exp) (free exp)) (begin.exprs exp)))) ((variable? exp) (singleton (variable.name exp))) ((call? exp) (union2 (free (call.proc exp)) (apply-union (map (lambda (exp) (free exp)) (call.args exp))))) (else ???))) (hashtree-map (lambda (sym val) sym) (free exp))) #t))
+(let () ($$trace "pass1"))
+(let () (begin (set! source-file-name #f) 'source-file-name))
+(let () (begin (set! source-file-position #f) 'source-file-position))
+(let () (begin (set! pass1-block-compiling? #f) 'pass1-block-compiling?))
+(let () (begin (set! pass1-block-assignments '()) 'pass1-block-assignments))
+(let () (begin (set! pass1-block-inlines '()) 'pass1-block-inlines))
+(let () (begin (set! pass1 (lambda (.def-or-exp|1 . .rest|1) (begin (set! source-file-name #f) (set! source-file-position #f) (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (if (not (null? .rest|1)) (begin (set! source-file-name (let ((.x|2|5 .rest|1)) (begin (.check! (pair? .x|2|5) 0 .x|2|5) (car:pair .x|2|5)))) (if (not (null? (let ((.x|6|9 .rest|1)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9))))) (set! source-file-position (let ((.x|11|14 (let ((.x|15|18 .rest|1)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) (unspecified))) (unspecified)) (set! renaming-counter 0) (macro-expand .def-or-exp|1)))) 'pass1))
+(let () (begin (set! pass1-block (lambda (.forms|1 . .rest|1) (let ((.part3|2 (unspecified)) (.part2|2 (unspecified)) (.part1|2 (unspecified))) (begin (set! .part3|2 (lambda (.alist|3 .definitions0|3 .definitions1|3 .forms|3) (begin (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (let* ((.constnames0|6 (let () (let ((.loop|211|214|217 (unspecified))) (begin (set! .loop|211|214|217 (lambda (.y1|206|207|218 .results|206|210|218) (if (null? .y1|206|207|218) (reverse .results|206|210|218) (begin #t (.loop|211|214|217 (let ((.x|222|225 .y1|206|207|218)) (begin (.check! (pair? .x|222|225) 1 .x|222|225) (cdr:pair .x|222|225))) (cons (assignment.lhs (let ((.x|226|229 .y1|206|207|218)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229)))) .results|206|210|218)))))) (.loop|211|214|217 .definitions0|3 '()))))) (.constnames1|9 (let () (let ((.loop|182|185|188 (unspecified))) (begin (set! .loop|182|185|188 (lambda (.y1|177|178|189 .results|177|181|189) (if (null? .y1|177|178|189) (reverse .results|177|181|189) (begin #t (.loop|182|185|188 (let ((.x|193|196 .y1|177|178|189)) (begin (.check! (pair? .x|193|196) 1 .x|193|196) (cdr:pair .x|193|196))) (cons (let* ((.id0|197 (let ((.x|202|205 .y1|177|178|189)) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205)))) (.x|198|201 (assq .id0|197 .alist|3))) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))) .results|177|181|189)))))) (.loop|182|185|188 .constnames0|6 '()))))) (.procnames1|12 (let () (let ((.loop|158|161|164 (unspecified))) (begin (set! .loop|158|161|164 (lambda (.y1|153|154|165 .results|153|157|165) (if (null? .y1|153|154|165) (reverse .results|153|157|165) (begin #t (.loop|158|161|164 (let ((.x|169|172 .y1|153|154|165)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172))) (cons (assignment.lhs (let ((.x|173|176 .y1|153|154|165)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176)))) .results|153|157|165)))))) (.loop|158|161|164 .definitions1|3 '())))))) (let () (copy-exp (make-call (make-lambda .constnames1|9 '() '() '() '() '() #f (make-begin (let* ((.t1|16|19 (make-begin (cons (make-constant #f) (reverse (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.id|120 (let ((.x|125|128 .y1|100|101|112)) (begin (.check! (pair? .x|125|128) 0 .x|125|128) (car:pair .x|125|128))))) (make-assignment .id|120 (make-variable (let ((.x|121|124 (assq .id|120 .alist|3))) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))) .results|100|104|112)))))) (.loop|105|108|111 .constnames0|6 '())))))))) (.t2|16|22 (cons (make-call (make-lambda .constnames0|6 '() '() '() '() '() #f (make-call (make-lambda (let () (let ((.loop|32|35|38 (unspecified))) (begin (set! .loop|32|35|38 (lambda (.y1|27|28|39 .results|27|31|39) (if (null? .y1|27|28|39) (reverse .results|27|31|39) (begin #t (.loop|32|35|38 (let ((.x|43|46 .y1|27|28|39)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))) (cons (assignment.lhs (let ((.x|47|50 .y1|27|28|39)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) .results|27|31|39)))))) (.loop|32|35|38 .definitions1|3 '())))) '() '() '() '() '() #f (make-begin (cons (make-constant #f) (append .definitions1|3 .forms|3)))) (let () (let ((.loop|56|59|62 (unspecified))) (begin (set! .loop|56|59|62 (lambda (.y1|51|52|63 .results|51|55|63) (if (null? .y1|51|52|63) (reverse .results|51|55|63) (begin #t (.loop|56|59|62 (let ((.x|67|70 .y1|51|52|63)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))) (cons (let ((.ignored|71 (let ((.x|72|75 .y1|51|52|63)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75))))) (make-unspecified)) .results|51|55|63)))))) (.loop|56|59|62 .definitions1|3 '())))))) (let () (let ((.loop|81|84|87 (unspecified))) (begin (set! .loop|81|84|87 (lambda (.y1|76|77|88 .results|76|80|88) (if (null? .y1|76|77|88) (reverse .results|76|80|88) (begin #t (.loop|81|84|87 (let ((.x|92|95 .y1|76|77|88)) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))) (cons (make-variable (let ((.x|96|99 .y1|76|77|88)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99)))) .results|76|80|88)))))) (.loop|81|84|87 .constnames1|9 '()))))) '()))) (let () (cons .t1|16|19 .t2|16|22))))) (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (assignment.rhs (let ((.x|149|152 .y1|129|130|141)) (begin (.check! (pair? .x|149|152) 0 .x|149|152) (car:pair .x|149|152)))) .results|129|133|141)))))) (.loop|134|137|140 .definitions0|3 '()))))))))))) (set! .part2|2 (lambda (.defined|230) (begin (set! pass1-block-compiling? #f) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (set! renaming-counter 0) (let* ((.rename|233 (make-rename-procedure)) (.alist|236 (let () (let ((.loop|354|357|360 (unspecified))) (begin (set! .loop|354|357|360 (lambda (.y1|349|350|361 .results|349|353|361) (if (null? .y1|349|350|361) (reverse .results|349|353|361) (begin #t (.loop|354|357|360 (let ((.x|365|368 .y1|349|350|361)) (begin (.check! (pair? .x|365|368) 1 .x|365|368) (cdr:pair .x|365|368))) (cons (let ((.id|369 (let ((.x|370|373 .y1|349|350|361)) (begin (.check! (pair? .x|370|373) 0 .x|370|373) (car:pair .x|370|373))))) (cons .id|369 (.rename|233 .id|369))) .results|349|353|361)))))) (.loop|354|357|360 .defined|230 '()))))) (.definitions0|239 '()) (.definitions1|242 '())) (let () (let ((.make-toplevel-definition|248 (unspecified))) (begin (set! .make-toplevel-definition|248 (lambda (.id|249 .exp|249) (begin (if (lambda? .exp|249) (doc.name-set! (lambda.doc .exp|249) .id|249) (unspecified)) (let ((.probe|252 (assq .id|249 .alist|236))) (if .probe|252 (let ((.id1|255 (let ((.x|283|286 .probe|252)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))))) (if (constant? .exp|249) (begin (set! .definitions0|239 (cons (make-assignment .id|249 .exp|249) .definitions0|239)) (make-constant .id|249)) (if (lambda? .exp|249) (begin (set! .definitions1|242 (cons (make-assignment .id1|255 .exp|249) .definitions1|242)) (make-assignment .id|249 (make-lambda (lambda.args .exp|249) '() '() '() '() '() (lambda.doc .exp|249) (make-call (make-variable .id1|255) (let () (let ((.loop|263|266|269 (unspecified))) (begin (set! .loop|263|266|269 (lambda (.y1|258|259|270 .results|258|262|270) (if (null? .y1|258|259|270) (reverse .results|258|262|270) (begin #t (.loop|263|266|269 (let ((.x|274|277 .y1|258|259|270)) (begin (.check! (pair? .x|274|277) 1 .x|274|277) (cdr:pair .x|274|277))) (cons (make-variable (let ((.x|278|281 .y1|258|259|270)) (begin (.check! (pair? .x|278|281) 0 .x|278|281) (car:pair .x|278|281)))) .results|258|262|270)))))) (.loop|263|266|269 (lambda.args .exp|249) '())))))))) (m-error "Inconsistent macro expansion" (make-readable .exp|249))))) (make-assignment .id|249 .exp|249)))))) (let ((.env0|287 (syntactic-copy global-syntactic-environment)) (.bmode|287 (benchmark-mode)) (.wmode|287 (issue-warnings))) (begin (issue-warnings #f) (let () (let ((.loop|293|295|298 (unspecified))) (begin (set! .loop|293|295|298 (lambda (.y1|288|289|299) (if (null? .y1|288|289|299) (if #f #f (unspecified)) (begin (begin #t (let ((.pair|303 (let ((.x|320|323 .y1|288|289|299)) (begin (.check! (pair? .x|320|323) 0 .x|320|323) (car:pair .x|320|323))))) (let ((.id0|306 (let ((.x|312|315 .pair|303)) (begin (.check! (pair? .x|312|315) 0 .x|312|315) (car:pair .x|312|315)))) (.id1|306 (let ((.x|316|319 .pair|303)) (begin (.check! (pair? .x|316|319) 1 .x|316|319) (cdr:pair .x|316|319))))) (begin (syntactic-bind-globally! .id0|306 (make-inline-denotation .id0|306 (lambda (.exp|307 .rename|307 .compare|307) (cons .id1|306 (let ((.x|308|311 .exp|307)) (begin (.check! (pair? .x|308|311) 1 .x|308|311) (cdr:pair .x|308|311))))) global-syntactic-environment)) (set! pass1-block-inlines (cons .id0|306 pass1-block-inlines)))))) (.loop|293|295|298 (let ((.x|324|327 .y1|288|289|299)) (begin (.check! (pair? .x|324|327) 1 .x|324|327) (cdr:pair .x|324|327)))))))) (.loop|293|295|298 .alist|236)))) (benchmark-mode #f) (issue-warnings .wmode|287) (let ((.forms|330 (let () (let ((.loop|331|334|337 (unspecified))) (begin (set! .loop|331|334|337 (lambda (.forms|338 .newforms|338) (if (null? .forms|338) (reverse .newforms|338) (begin #t (.loop|331|334|337 (let ((.x|341|344 .forms|338)) (begin (.check! (pair? .x|341|344) 1 .x|341|344) (cdr:pair .x|341|344))) (cons (desugar-definitions (let ((.x|345|348 .forms|338)) (begin (.check! (pair? .x|345|348) 0 .x|345|348) (car:pair .x|345|348))) global-syntactic-environment .make-toplevel-definition|248) .newforms|338)))))) (.loop|331|334|337 .forms|1 '())))))) (begin (benchmark-mode .bmode|287) (set! global-syntactic-environment .env0|287) (.part3|2 .alist|236 .definitions0|239 .definitions1|242 .forms|330)))))))))))) (set! .part1|2 (lambda () (begin (set! pass1-block-compiling? #t) (set! pass1-block-assignments '()) (set! pass1-block-inlines '()) (set! renaming-counter 0) (let ((.env0|377 (syntactic-copy global-syntactic-environment)) (.bmode|377 (benchmark-mode)) (.wmode|377 (issue-warnings)) (.defined|377 '())) (let ((.make-toplevel-definition|378 (unspecified))) (begin (set! .make-toplevel-definition|378 (lambda (.id|379 .exp|379) (begin (if (memq .id|379 .defined|377) (set! pass1-block-assignments (cons .id|379 pass1-block-assignments)) (if (let ((.temp|382|385 (constant? .exp|379))) (if .temp|382|385 .temp|382|385 (if (lambda? .exp|379) (list? (lambda.args .exp|379)) #f))) (set! .defined|377 (cons .id|379 .defined|377)) (unspecified))) (make-begin (let* ((.t1|389|392 (make-assignment .id|379 .exp|379)) (.t2|389|395 (cons (make-constant .id|379) '()))) (let () (cons .t1|389|392 .t2|389|395))))))) (benchmark-mode #f) (issue-warnings #f) (let () (let ((.loop|405|407|410 (unspecified))) (begin (set! .loop|405|407|410 (lambda (.y1|400|401|411) (if (null? .y1|400|401|411) (if #f #f (unspecified)) (begin (begin #t (let ((.form|415 (let ((.x|416|419 .y1|400|401|411)) (begin (.check! (pair? .x|416|419) 0 .x|416|419) (car:pair .x|416|419))))) (desugar-definitions .form|415 global-syntactic-environment .make-toplevel-definition|378))) (.loop|405|407|410 (let ((.x|420|423 .y1|400|401|411)) (begin (.check! (pair? .x|420|423) 1 .x|420|423) (cdr:pair .x|420|423)))))))) (.loop|405|407|410 .forms|1)))) (set! global-syntactic-environment .env0|377) (benchmark-mode .bmode|377) (issue-warnings .wmode|377) (.part2|2 (filter (lambda (.id|424) (not (memq .id|424 pass1-block-assignments))) (reverse .defined|377))))))))) (set! source-file-name #f) (set! source-file-position #f) (if (not (null? .rest|1)) (begin (set! source-file-name (let ((.x|425|428 .rest|1)) (begin (.check! (pair? .x|425|428) 0 .x|425|428) (car:pair .x|425|428)))) (if (not (null? (let ((.x|429|432 .rest|1)) (begin (.check! (pair? .x|429|432) 1 .x|429|432) (cdr:pair .x|429|432))))) (set! source-file-position (let ((.x|434|437 (let ((.x|438|441 .rest|1)) (begin (.check! (pair? .x|438|441) 1 .x|438|441) (cdr:pair .x|438|441))))) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437)))) (unspecified))) (unspecified)) (.part1|2))))) 'pass1-block))
+(let () (begin (set! make-available-table (lambda () (let ((.make-available-table|2 0)) (begin (set! .make-available-table|2 (lambda () (let* ((.t|4|6|11 '()) (.t|4|5|14 '()) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))))) (.make-available-table|2))))) 'make-available-table))
+(let () (begin (set! copy-available-table (lambda (.available|1) (let ((.copy-available-table|2 0)) (begin (set! .copy-available-table|2 (lambda (.available|3) (let* ((.t|4|6|11 (let ((.v|29|32 .available|3) (.i|29|32 1)) (begin (.check! (fixnum? .i|29|32) 40 .v|29|32 .i|29|32) (.check! (vector? .v|29|32) 40 .v|29|32 .i|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 40 .v|29|32 .i|29|32) (.check! (>=:fix:fix .i|29|32 0) 40 .v|29|32 .i|29|32) (vector-ref:trusted .v|29|32 .i|29|32)))) (.t|4|5|14 (let ((.v|25|28 .available|3) (.i|25|28 0)) (begin (.check! (fixnum? .i|25|28) 40 .v|25|28 .i|25|28) (.check! (vector? .v|25|28) 40 .v|25|28 .i|25|28) (.check! (<:fix:fix .i|25|28 (vector-length:vec .v|25|28)) 40 .v|25|28 .i|25|28) (.check! (>=:fix:fix .i|25|28 0) 40 .v|25|28 .i|25|28) (vector-ref:trusted .v|25|28 .i|25|28)))) (.v|4|8|17 (make-vector 2 .t|4|6|11))) (let () (begin (let ((.v|21|24 .v|4|8|17) (.i|21|24 0) (.x|21|24 .t|4|5|14)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) .v|4|8|17))))) (.copy-available-table|2 .available|1))))) 'copy-available-table))
+(let () (begin (set! available-expression (lambda (.available|1 .e|1) (let ((.available-expression|2 0)) (begin (set! .available-expression|2 (lambda (.available|3 .e|3) (let ((.binding|6 (assoc .e|3 (let ((.v|16|19 .available|3) (.i|16|19 0)) (begin (.check! (fixnum? .i|16|19) 40 .v|16|19 .i|16|19) (.check! (vector? .v|16|19) 40 .v|16|19 .i|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 40 .v|16|19 .i|16|19) (.check! (>=:fix:fix .i|16|19 0) 40 .v|16|19 .i|16|19) (vector-ref:trusted .v|16|19 .i|16|19)))))) (if .binding|6 (let ((.x|8|11 (let ((.x|12|15 .binding|6)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) #f)))) (.available-expression|2 .available|1 .e|1))))) 'available-expression))
+(let () (begin (set! available-variable (lambda (.available|1 .t|1) (let ((.available-variable|2 0)) (begin (set! .available-variable|2 (lambda (.available|3 .t|3) (let ((.binding|6 (assq .t|3 (let ((.v|16|19 .available|3) (.i|16|19 1)) (begin (.check! (fixnum? .i|16|19) 40 .v|16|19 .i|16|19) (.check! (vector? .v|16|19) 40 .v|16|19 .i|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 40 .v|16|19 .i|16|19) (.check! (>=:fix:fix .i|16|19 0) 40 .v|16|19 .i|16|19) (vector-ref:trusted .v|16|19 .i|16|19)))))) (if .binding|6 (let ((.x|8|11 (let ((.x|12|15 .binding|6)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))))) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) #f)))) (.available-variable|2 .available|1 .t|1))))) 'available-variable))
+(let () (begin (set! available-extend! (lambda (.available|1 .t|1 .e|1 .k|1) (let ((.available-extend!|2 0)) (begin (set! .available-extend!|2 (lambda (.available|3 .t|3 .e|3 .k|3) (if (constant? .e|3) (let ((.v|5|8 .available|3) (.i|5|8 1) (.x|5|8 (cons (let* ((.t1|9|12 .t|3) (.t2|9|15 (let* ((.t1|19|22 .e|3) (.t2|19|25 (cons .k|3 '()))) (let () (cons .t1|19|22 .t2|19|25))))) (let () (cons .t1|9|12 .t2|9|15))) (let ((.v|30|33 .available|3) (.i|30|33 1)) (begin (.check! (fixnum? .i|30|33) 40 .v|30|33 .i|30|33) (.check! (vector? .v|30|33) 40 .v|30|33 .i|30|33) (.check! (<:fix:fix .i|30|33 (vector-length:vec .v|30|33)) 40 .v|30|33 .i|30|33) (.check! (>=:fix:fix .i|30|33 0) 40 .v|30|33 .i|30|33) (vector-ref:trusted .v|30|33 .i|30|33)))))) (begin (.check! (fixnum? .i|5|8) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (vector? .v|5|8) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (<:fix:fix .i|5|8 (vector-length:vec .v|5|8)) 41 .v|5|8 .i|5|8 .x|5|8) (.check! (>=:fix:fix .i|5|8 0) 41 .v|5|8 .i|5|8 .x|5|8) (vector-set!:trusted .v|5|8 .i|5|8 .x|5|8))) (if (if (variable? .e|3) (eq? .k|3 available:killer:none) #f) (let ((.v|37|40 .available|3) (.i|37|40 1) (.x|37|40 (cons (let* ((.t1|41|44 .t|3) (.t2|41|47 (let* ((.t1|51|54 .e|3) (.t2|51|57 (cons .k|3 '()))) (let () (cons .t1|51|54 .t2|51|57))))) (let () (cons .t1|41|44 .t2|41|47))) (let ((.v|62|65 .available|3) (.i|62|65 1)) (begin (.check! (fixnum? .i|62|65) 40 .v|62|65 .i|62|65) (.check! (vector? .v|62|65) 40 .v|62|65 .i|62|65) (.check! (<:fix:fix .i|62|65 (vector-length:vec .v|62|65)) 40 .v|62|65 .i|62|65) (.check! (>=:fix:fix .i|62|65 0) 40 .v|62|65 .i|62|65) (vector-ref:trusted .v|62|65 .i|62|65)))))) (begin (.check! (fixnum? .i|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (vector? .v|37|40) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (<:fix:fix .i|37|40 (vector-length:vec .v|37|40)) 41 .v|37|40 .i|37|40 .x|37|40) (.check! (>=:fix:fix .i|37|40 0) 41 .v|37|40 .i|37|40 .x|37|40) (vector-set!:trusted .v|37|40 .i|37|40 .x|37|40))) (let ((.v|67|70 .available|3) (.i|67|70 0) (.x|67|70 (cons (let* ((.t1|71|74 .e|3) (.t2|71|77 (let* ((.t1|81|84 .t|3) (.t2|81|87 (cons .k|3 '()))) (let () (cons .t1|81|84 .t2|81|87))))) (let () (cons .t1|71|74 .t2|71|77))) (let ((.v|92|95 .available|3) (.i|92|95 0)) (begin (.check! (fixnum? .i|92|95) 40 .v|92|95 .i|92|95) (.check! (vector? .v|92|95) 40 .v|92|95 .i|92|95) (.check! (<:fix:fix .i|92|95 (vector-length:vec .v|92|95)) 40 .v|92|95 .i|92|95) (.check! (>=:fix:fix .i|92|95 0) 40 .v|92|95 .i|92|95) (vector-ref:trusted .v|92|95 .i|92|95)))))) (begin (.check! (fixnum? .i|67|70) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (vector? .v|67|70) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (<:fix:fix .i|67|70 (vector-length:vec .v|67|70)) 41 .v|67|70 .i|67|70 .x|67|70) (.check! (>=:fix:fix .i|67|70 0) 41 .v|67|70 .i|67|70 .x|67|70) (vector-set!:trusted .v|67|70 .i|67|70 .x|67|70))))))) (.available-extend!|2 .available|1 .t|1 .e|1 .k|1))))) 'available-extend!))
+(let () (begin (set! available-kill! (lambda (.available|1 .k|1) (let ((.available-kill!|2 0)) (begin (set! .available-kill!|2 (lambda (.available|3 .k|3) (begin (let ((.v|4|7 .available|3) (.i|4|7 0) (.x|4|7 (filter (lambda (.binding|8) (zero? (logand .k|3 (let ((.x|10|13 (let ((.x|14|17 (let ((.x|18|21 .binding|8)) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))))) (let ((.v|22|25 .available|3) (.i|22|25 0)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25)))))) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (let ((.v|26|29 .available|3) (.i|26|29 1) (.x|26|29 (filter (lambda (.binding|30) (zero? (logand .k|3 (let ((.x|32|35 (let ((.x|36|39 (let ((.x|40|43 .binding|30)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))))) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35)))))) (let ((.v|44|47 .available|3) (.i|44|47 1)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47)))))) (begin (.check! (fixnum? .i|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (vector? .v|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (<:fix:fix .i|26|29 (vector-length:vec .v|26|29)) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (>=:fix:fix .i|26|29 0) 41 .v|26|29 .i|26|29 .x|26|29) (vector-set!:trusted .v|26|29 .i|26|29 .x|26|29)))))) (.available-kill!|2 .available|1 .k|1))))) 'available-kill!))
+(let () (begin (set! available-intersect! (lambda (.available0|1 .available1|1 .available2|1) (let ((.available-intersect!|2 0)) (begin (set! .available-intersect!|2 (lambda (.available0|3 .available1|3 .available2|3) (begin (let ((.v|4|7 .available0|3) (.i|4|7 0) (.x|4|7 (intersection (let ((.v|8|11 .available1|3) (.i|8|11 0)) (begin (.check! (fixnum? .i|8|11) 40 .v|8|11 .i|8|11) (.check! (vector? .v|8|11) 40 .v|8|11 .i|8|11) (.check! (<:fix:fix .i|8|11 (vector-length:vec .v|8|11)) 40 .v|8|11 .i|8|11) (.check! (>=:fix:fix .i|8|11 0) 40 .v|8|11 .i|8|11) (vector-ref:trusted .v|8|11 .i|8|11))) (let ((.v|12|15 .available2|3) (.i|12|15 0)) (begin (.check! (fixnum? .i|12|15) 40 .v|12|15 .i|12|15) (.check! (vector? .v|12|15) 40 .v|12|15 .i|12|15) (.check! (<:fix:fix .i|12|15 (vector-length:vec .v|12|15)) 40 .v|12|15 .i|12|15) (.check! (>=:fix:fix .i|12|15 0) 40 .v|12|15 .i|12|15) (vector-ref:trusted .v|12|15 .i|12|15)))))) (begin (.check! (fixnum? .i|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (vector? .v|4|7) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (<:fix:fix .i|4|7 (vector-length:vec .v|4|7)) 41 .v|4|7 .i|4|7 .x|4|7) (.check! (>=:fix:fix .i|4|7 0) 41 .v|4|7 .i|4|7 .x|4|7) (vector-set!:trusted .v|4|7 .i|4|7 .x|4|7))) (let ((.v|16|19 .available0|3) (.i|16|19 1) (.x|16|19 (intersection (let ((.v|20|23 .available1|3) (.i|20|23 1)) (begin (.check! (fixnum? .i|20|23) 40 .v|20|23 .i|20|23) (.check! (vector? .v|20|23) 40 .v|20|23 .i|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 40 .v|20|23 .i|20|23) (.check! (>=:fix:fix .i|20|23 0) 40 .v|20|23 .i|20|23) (vector-ref:trusted .v|20|23 .i|20|23))) (let ((.v|24|27 .available2|3) (.i|24|27 1)) (begin (.check! (fixnum? .i|24|27) 40 .v|24|27 .i|24|27) (.check! (vector? .v|24|27) 40 .v|24|27 .i|24|27) (.check! (<:fix:fix .i|24|27 (vector-length:vec .v|24|27)) 40 .v|24|27 .i|24|27) (.check! (>=:fix:fix .i|24|27 0) 40 .v|24|27 .i|24|27) (vector-ref:trusted .v|24|27 .i|24|27)))))) (begin (.check! (fixnum? .i|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (vector? .v|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (>=:fix:fix .i|16|19 0) 41 .v|16|19 .i|16|19 .x|16|19) (vector-set!:trusted .v|16|19 .i|16|19 .x|16|19)))))) (.available-intersect!|2 .available0|1 .available1|1 .available2|1))))) 'available-intersect!))
+(let () (begin (set! available:killer:globals 2) 'available:killer:globals))
+(let () (begin (set! available:killer:car 4) 'available:killer:car))
+(let () (begin (set! available:killer:cdr 8) 'available:killer:cdr))
+(let () (begin (set! available:killer:string 16) 'available:killer:string))
+(let () (begin (set! available:killer:vector 32) 'available:killer:vector))
+(let () (begin (set! available:killer:cell 64) 'available:killer:cell))
+(let () (begin (set! available:killer:io 128) 'available:killer:io))
+(let () (begin (set! available:killer:none 0) 'available:killer:none))
+(let () (begin (set! available:killer:all 1022) 'available:killer:all))
+(let () (begin (set! available:killer:immortal 0) 'available:killer:immortal))
+(let () (begin (set! available:killer:dead 1023) 'available:killer:dead))
+(let () (begin (set! available:killer-combine (lambda (.k1|1 .k2|1) (let ((.available:killer-combine|2 0)) (begin (set! .available:killer-combine|2 (lambda (.k1|3 .k2|3) (logior .k1|3 .k2|3))) (.available:killer-combine|2 .k1|1 .k2|1))))) 'available:killer-combine))
+(let () (begin (set! simple-lambda? (lambda (.l|1) (let ((.simple-lambda?|2 0)) (begin (set! .simple-lambda?|2 (lambda (.l|3) (if (null? (lambda.defs .l|3)) (every? (lambda (.decl|6) (eq? .decl|6 a-normal-form-declaration)) (lambda.decls .l|3)) #f))) (.simple-lambda?|2 .l|1))))) 'simple-lambda?))
+(let () (begin (set! real-call? (lambda (.e|1) (let ((.real-call?|2 0)) (begin (set! .real-call?|2 (lambda (.e|3) (if (call? .e|3) (let ((.proc|8 (call.proc .e|3))) (if (not (lambda? .proc|8)) (let ((.temp|11|14 (not (variable? .proc|8)))) (if .temp|11|14 .temp|11|14 (let* ((.f|18 (variable.name .proc|8)) (.temp|19|22 (not (integrate-usual-procedures)))) (if .temp|19|22 .temp|19|22 (not (prim-entry .f|18)))))) #f)) #f))) (.real-call?|2 .e|1))))) 'real-call?))
+(let () (begin (set! prim-call (lambda (.e|1) (let ((.prim-call|2 0)) (begin (set! .prim-call|2 (lambda (.e|3) (if (call? .e|3) (let ((.proc|8 (call.proc .e|3))) (if (variable? .proc|8) (if (integrate-usual-procedures) (prim-entry (variable.name .proc|8)) #f) #f)) #f))) (.prim-call|2 .e|1))))) 'prim-call))
+(let () (begin (set! no-side-effects? (lambda (.e|1) (let ((.no-side-effects?|2 0)) (begin (set! .no-side-effects?|2 (lambda (.e|3) (let ((.temp|4|7 (constant? .e|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (variable? .e|3))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (lambda? .e|3))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (if (conditional? .e|3) (if (.no-side-effects?|2 (if.test .e|3)) (if (.no-side-effects?|2 (if.then .e|3)) (.no-side-effects?|2 (if.else .e|3)) #f) #f) #f))) (if .temp|16|19 .temp|16|19 (if (call? .e|3) (let ((.proc|25 (call.proc .e|3))) (if (variable? .proc|25) (if (integrate-usual-procedures) (let ((.entry|31 (prim-entry (variable.name .proc|25)))) (if .entry|31 (not (eq? available:killer:dead (prim-lives-until .entry|31))) #f)) #f) #f)) #f))))))))))) (.no-side-effects?|2 .e|1))))) 'no-side-effects?))
+(let () (begin (set! temporary-used-once? (lambda (.t|1 .e|1 .used-once|1) (let ((.temporary-used-once?|2 0)) (begin (set! .temporary-used-once?|2 (lambda (.t|3 .e|3 .used-once|3) (if (call? .e|3) (let ((.proc|7 (call.proc .e|3)) (.args|7 (call.args .e|3))) (let ((.temp|8|11 (if (lambda? .proc|7) (if (not (memq .t|3 (lambda.f .proc|7))) (if (pair? .args|7) (if (null? (let ((.x|47|50 .args|7)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))) (.temporary-used-once?|2 .t|3 (let ((.x|52|55 .args|7)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))) .used-once|3) #f) #f) #f) #f))) (if .temp|8|11 .temp|8|11 (let () (let ((.loop|13|16|19 (unspecified))) (begin (set! .loop|13|16|19 (lambda (.exprs|20 .n|20) (if (let ((.temp|22|25 (null? .exprs|20))) (if .temp|22|25 .temp|22|25 (> .n|20 1))) (= .n|20 1) (begin #t (.loop|13|16|19 (let ((.x|28|31 .exprs|20)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))) (let ((.exp|34 (let ((.x|38|41 .exprs|20)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (if (constant? .exp|34) .n|20 (if (variable? .exp|34) (if (eq? .t|3 (variable.name .exp|34)) (+ .n|20 1) .n|20) 2)))))))) (.loop|13|16|19 (cons .proc|7 (call.args .e|3)) 0))))))) (memq .t|3 .used-once|3)))) (.temporary-used-once?|2 .t|1 .e|1 .used-once|1))))) 'temporary-used-once?))
+(let () (begin (set! make-regbinding (lambda (.lhs|1 .rhs|1 .use|1) (let ((.make-regbinding|2 0)) (begin (set! .make-regbinding|2 (lambda (.lhs|3 .rhs|3 .use|3) (let* ((.t1|4|7 .lhs|3) (.t2|4|10 (let* ((.t1|14|17 .rhs|3) (.t2|14|20 (cons .use|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-regbinding|2 .lhs|1 .rhs|1 .use|1))))) 'make-regbinding))
+(let () (begin (set! regbinding.lhs (lambda (.x|1) (let ((.regbinding.lhs|2 0)) (begin (set! .regbinding.lhs|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.regbinding.lhs|2 .x|1))))) 'regbinding.lhs))
+(let () (begin (set! regbinding.rhs (lambda (.x|1) (let ((.regbinding.rhs|2 0)) (begin (set! .regbinding.rhs|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.regbinding.rhs|2 .x|1))))) 'regbinding.rhs))
+(let () (begin (set! regbinding.use (lambda (.x|1) (let ((.regbinding.use|2 0)) (begin (set! .regbinding.use|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.regbinding.use|2 .x|1))))) 'regbinding.use))
+(let () (begin (set! wrap-with-register-bindings (lambda (.regbindings|1 .e|1 .f|1) (let ((.wrap-with-register-bindings|2 0)) (begin (set! .wrap-with-register-bindings|2 (lambda (.regbindings|3 .e|3 .f|3) (if (null? .regbindings|3) (values .e|3 .f|3) (let* ((.regbinding|6 (let ((.x|25|28 .regbindings|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) (.r|9 (regbinding.lhs .regbinding|6)) (.x|12 (regbinding.rhs .regbinding|6))) (let () (.wrap-with-register-bindings|2 (let ((.x|16|19 .regbindings|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (make-call (make-lambda (cons .r|9 '()) '() '() .f|3 .f|3 (cons a-normal-form-declaration '()) #f .e|3) (cons (make-variable .x|12) '())) (union (cons .x|12 '()) (difference .f|3 (cons .r|9 '()))))))))) (.wrap-with-register-bindings|2 .regbindings|1 .e|1 .f|1))))) 'wrap-with-register-bindings))
+(let () (begin (set! register-bindings (lambda (.regbindings|1 .x|1) (let ((.register-bindings|2 0)) (begin (set! .register-bindings|2 (lambda (.regbindings|3 .x|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.regbindings|5 .to-x|5 .others|5) (if (null? .regbindings|5) (values .to-x|5 .others|5) (if (eq? .x|3 (regbinding.rhs (let ((.x|8|11 .regbindings|5)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))))) (.loop|4 (let ((.x|12|15 .regbindings|5)) (begin (.check! (pair? .x|12|15) 1 .x|12|15) (cdr:pair .x|12|15))) (cons (let ((.x|16|19 .regbindings|5)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))) .to-x|5) .others|5) (.loop|4 (let ((.x|21|24 .regbindings|5)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) .to-x|5 (cons (let ((.x|25|28 .regbindings|5)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) .others|5)))))) (.loop|4 .regbindings|3 '() '()))))) (.register-bindings|2 .regbindings|1 .x|1))))) 'register-bindings))
+(let () (begin (set! declaration-error (lambda (.e|1) (let ((.declaration-error|2 0)) (begin (set! .declaration-error|2 (lambda (.e|3) (if (issue-warnings) (begin (display "WARNING: Assertion is false: ") (write (make-readable .e|3 #t)) (newline)) (unspecified)))) (.declaration-error|2 .e|1))))) 'declaration-error))
+(let () (begin (set! *nreps* 0) '*nreps*))
+(let () (begin (set! *rep-encodings* '()) '*rep-encodings*))
+(let () (begin (set! *rep-decodings* '()) '*rep-decodings*))
+(let () (begin (set! *rep-subtypes* '()) '*rep-subtypes*))
+(let () (begin (set! *rep-joins* (make-bytevector 0)) '*rep-joins*))
+(let () (begin (set! *rep-meets* (make-bytevector 0)) '*rep-meets*))
+(let () (begin (set! *rep-joins-special* '#()) '*rep-joins-special*))
+(let () (begin (set! *rep-meets-special* '#()) '*rep-meets-special*))
+(let () (begin (set! representation-error (lambda (.msg|1 . .stuff|1) (apply error (if (string? .msg|1) (string-append "Bug in flow analysis: " .msg|1) .msg|1) .stuff|1))) 'representation-error))
+(let () (begin (set! symbol->rep (lambda (.sym|1) (let ((.symbol->rep|2 0)) (begin (set! .symbol->rep|2 (lambda (.sym|3) (let ((.probe|6 (assq .sym|3 *rep-encodings*))) (if .probe|6 (let ((.x|7|10 .probe|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) (let ((.rep|13 *nreps*)) (begin (set! *nreps* (+ *nreps* 1)) (if (> *nreps* 255) (representation-error "Too many representation types") (unspecified)) (set! *rep-encodings* (cons (cons .sym|3 .rep|13) *rep-encodings*)) (set! *rep-decodings* (cons (cons .rep|13 .sym|3) *rep-decodings*)) .rep|13)))))) (.symbol->rep|2 .sym|1))))) 'symbol->rep))
+(let () (begin (set! rep->symbol (lambda (.rep|1) (let ((.rep->symbol|2 0)) (begin (set! .rep->symbol|2 (lambda (.rep|3) (if (pair? .rep|3) (cons (.rep->symbol|2 (let ((.x|4|7 .rep|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7)))) (let ((.x|8|11 .rep|3)) (begin (.check! (pair? .x|8|11) 1 .x|8|11) (cdr:pair .x|8|11)))) (let ((.probe|14 (assv .rep|3 *rep-decodings*))) (if .probe|14 (let ((.x|15|18 .probe|14)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) 'unknown))))) (.rep->symbol|2 .rep|1))))) 'rep->symbol))
+(let () (begin (set! representation-table (lambda (.table|1) (let ((.representation-table|2 0)) (begin (set! .representation-table|2 (lambda (.table|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let ((.row|24 (let ((.x|74|77 .y1|4|5|16)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77))))) (let () (let ((.loop|30|33|36 (unspecified))) (begin (set! .loop|30|33|36 (lambda (.y1|25|26|37 .results|25|29|37) (if (null? .y1|25|26|37) (reverse .results|25|29|37) (begin #t (.loop|30|33|36 (let ((.x|41|44 .y1|25|26|37)) (begin (.check! (pair? .x|41|44) 1 .x|41|44) (cdr:pair .x|41|44))) (cons (let ((.x|45 (let ((.x|70|73 .y1|25|26|37)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (if (list? .x|45) (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.y1|46|47|58 .results|46|50|58) (if (null? .y1|46|47|58) (reverse .results|46|50|58) (begin #t (.loop|51|54|57 (let ((.x|62|65 .y1|46|47|58)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons (symbol->rep (let ((.x|66|69 .y1|46|47|58)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69)))) .results|46|50|58)))))) (.loop|51|54|57 .x|45 '())))) .x|45)) .results|25|29|37)))))) (.loop|30|33|36 .row|24 '()))))) .results|4|8|16)))))) (.loop|9|12|15 .table|3 '())))))) (.representation-table|2 .table|1))))) 'representation-table))
+(let () (begin (set! define-subtype (lambda (.sym1|1 .sym2|1) (let ((.define-subtype|2 0)) (begin (set! .define-subtype|2 (lambda (.sym1|3 .sym2|3) (let* ((.rep2|6 (symbol->rep .sym2|3)) (.rep1|9 (symbol->rep .sym1|3))) (let () (begin (set! *rep-subtypes* (cons (cons .rep1|9 .rep2|6) *rep-subtypes*)) .sym1|3))))) (.define-subtype|2 .sym1|1 .sym2|1))))) 'define-subtype))
+(let () (begin (set! define-intersection (lambda (.sym1|1 .sym2|1 .sym3|1) (let ((.define-intersection|2 0)) (begin (set! .define-intersection|2 (lambda (.sym1|3 .sym2|3 .sym3|3) (let ((.rep1|6 (symbol->rep .sym1|3)) (.rep2|6 (symbol->rep .sym2|3)) (.rep3|6 (symbol->rep .sym3|3))) (begin (representation-aset! *rep-meets* .rep1|6 .rep2|6 .rep3|6) (representation-aset! *rep-meets* .rep2|6 .rep1|6 .rep3|6))))) (.define-intersection|2 .sym1|1 .sym2|1 .sym3|1))))) 'define-intersection))
+(let () (begin (set! representation-aref (lambda (.bv|1 .i|1 .j|1) (let ((.representation-aref|2 0)) (begin (set! .representation-aref|2 (lambda (.bv|3 .i|3 .j|3) (bytevector-ref .bv|3 (+ (* *nreps* .i|3) .j|3)))) (.representation-aref|2 .bv|1 .i|1 .j|1))))) 'representation-aref))
+(let () (begin (set! representation-aset! (lambda (.bv|1 .i|1 .j|1 .x|1) (let ((.representation-aset!|2 0)) (begin (set! .representation-aset!|2 (lambda (.bv|3 .i|3 .j|3 .x|3) (bytevector-set! .bv|3 (+ (* *nreps* .i|3) .j|3) .x|3))) (.representation-aset!|2 .bv|1 .i|1 .j|1 .x|1))))) 'representation-aset!))
+(let () (begin (set! compute-unions! (lambda () (let ((.compute-unions!|2 0)) (begin (set! .compute-unions!|2 (lambda () (begin (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let ((.sym|19 (let ((.x|20|23 .y1|4|5|15)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (define-subtype 'bottom .sym|19))) (.loop|9|11|14 (let ((.x|24|27 .y1|4|5|15)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))))) (.loop|9|11|14 (let () (let ((.loop|33|36|39 (unspecified))) (begin (set! .loop|33|36|39 (lambda (.y1|28|29|40 .results|28|32|40) (if (null? .y1|28|29|40) (reverse .results|28|32|40) (begin #t (.loop|33|36|39 (let ((.x|44|47 .y1|28|29|40)) (begin (.check! (pair? .x|44|47) 1 .x|44|47) (cdr:pair .x|44|47))) (cons (let ((.x|48|51 (let ((.x|52|55 .y1|28|29|40)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (begin (.check! (pair? .x|48|51) 0 .x|48|51) (car:pair .x|48|51))) .results|28|32|40)))))) (.loop|33|36|39 *rep-encodings* '())))))))) (let* ((.debugging?|58 #f) (.n|61 *nreps*) (.n^2|64 (* .n|61 .n|61)) (.matrix|67 (make-bytevector .n^2|64))) (let () (let ((.compute-joins!|73 (unspecified)) (.compute-transitive-closure!|73 (unspecified)) (.join|73 (unspecified)) (.lub|73 (unspecified))) (begin (set! .compute-joins!|73 (lambda () (begin (let ((.default|77 (lambda (.x|78 .y|78) (error "Compiler bug: special meet or join" .x|78 .y|78)))) (begin (set! *rep-joins-special* (make-vector .n|61 .default|77)) (set! *rep-meets-special* (make-vector .n|61 .default|77)))) (set! *rep-joins* (make-bytevector .n^2|64)) (set! *rep-meets* (make-bytevector .n^2|64)) (let () (let ((.loop|80|82|85 (unspecified))) (begin (set! .loop|80|82|85 (lambda (.i|86) (if (= .i|86 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|90|92|95 (unspecified))) (begin (set! .loop|90|92|95 (lambda (.j|96) (if (= .j|96 .n|61) (if #f #f (unspecified)) (begin (begin #t (representation-aset! *rep-joins* .i|86 .j|96 (.join|73 .i|86 .j|96))) (.loop|90|92|95 (+ .j|96 1)))))) (.loop|90|92|95 0))))) (.loop|80|82|85 (+ .i|86 1)))))) (.loop|80|82|85 0))))))) (set! .compute-transitive-closure!|73 (lambda () (let* ((.changed?|102 #f) (.loop|103 (unspecified))) (begin (set! .loop|103 (lambda () (begin (let () (let ((.loop|106|108|111 (unspecified))) (begin (set! .loop|106|108|111 (lambda (.i|112) (if (= .i|112 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|116|118|121 (unspecified))) (begin (set! .loop|116|118|121 (lambda (.k|122) (if (= .k|122 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.j|132 .sum|132) (if (= .j|132 .n|61) (if (> .sum|132 0) (let ((.x|136 (representation-aref .matrix|67 .i|112 .k|122))) (if (zero? .x|136) (begin (set! .changed?|102 #t) (representation-aset! .matrix|67 .i|112 .k|122 1)) (unspecified))) (unspecified)) (begin #t (.loop|125|128|131 (+ .j|132 1) (logior .sum|132 (logand (representation-aref .matrix|67 .i|112 .j|132) (representation-aref .matrix|67 .j|132 .k|122)))))))) (.loop|125|128|131 0 0))))) (.loop|116|118|121 (+ .k|122 1)))))) (.loop|116|118|121 0))))) (.loop|106|108|111 (+ .i|112 1)))))) (.loop|106|108|111 0)))) (if .changed?|102 (begin (set! .changed?|102 #f) (.loop|103)) (unspecified))))) (.loop|103))))) (set! .join|73 (lambda (.i|138 .j|138) (.lub|73 .i|138 .j|138 (lambda (.rep1|139 .rep2|139) (= 1 (representation-aref .matrix|67 .rep1|139 .rep2|139)))))) (set! .lub|73 (lambda (.rep1|140 .rep2|140 .subtype?|140) (let () (let ((.loop|141|144|147 (unspecified))) (begin (set! .loop|141|144|147 (lambda (.i|148 .bounds|148) (if (= .i|148 .n|61) (let ((.x|150|153 (twobit-sort .subtype?|140 .bounds|148))) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))) (begin #t (.loop|141|144|147 (+ .i|148 1) (if (if (.subtype?|140 .rep1|140 .i|148) (.subtype?|140 .rep2|140 .i|148) #f) (cons .i|148 .bounds|148) .bounds|148)))))) (.loop|141|144|147 0 '())))))) (let () (let ((.loop|72|158|161 (unspecified))) (begin (set! .loop|72|158|161 (lambda (.i|162) (if (= .i|162 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|166|168|171 (unspecified))) (begin (set! .loop|166|168|171 (lambda (.j|172) (if (= .j|172 .n|61) (if #f #f (unspecified)) (begin (begin #t (representation-aset! .matrix|67 .i|162 .j|172 0)) (.loop|166|168|171 (+ .j|172 1)))))) (.loop|166|168|171 0)))) (representation-aset! .matrix|67 .i|162 .i|162 1)) (.loop|72|158|161 (+ .i|162 1)))))) (.loop|72|158|161 0)))) (let () (let ((.loop|180|182|185 (unspecified))) (begin (set! .loop|180|182|185 (lambda (.y1|175|176|186) (if (null? .y1|175|176|186) (if #f #f (unspecified)) (begin (begin #t (let ((.subtype|190 (let ((.x|202|205 .y1|175|176|186)) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205))))) (let ((.rep1|193 (let ((.x|194|197 .subtype|190)) (begin (.check! (pair? .x|194|197) 0 .x|194|197) (car:pair .x|194|197)))) (.rep2|193 (let ((.x|198|201 .subtype|190)) (begin (.check! (pair? .x|198|201) 1 .x|198|201) (cdr:pair .x|198|201))))) (representation-aset! .matrix|67 .rep1|193 .rep2|193 1)))) (.loop|180|182|185 (let ((.x|206|209 .y1|175|176|186)) (begin (.check! (pair? .x|206|209) 1 .x|206|209) (cdr:pair .x|206|209)))))))) (.loop|180|182|185 *rep-subtypes*)))) (.compute-transitive-closure!|73) (if .debugging?|58 (let () (let ((.loop|211|213|216 (unspecified))) (begin (set! .loop|211|213|216 (lambda (.i|217) (if (= .i|217 .n|61) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|221|223|226 (unspecified))) (begin (set! .loop|221|223|226 (lambda (.j|227) (if (= .j|227 .n|61) (if #f #f (unspecified)) (begin (begin #t (write-char #\space) (write (representation-aref .matrix|67 .i|217 .j|227))) (.loop|221|223|226 (+ .j|227 1)))))) (.loop|221|223|226 0)))) (newline)) (.loop|211|213|216 (+ .i|217 1)))))) (.loop|211|213|216 0)))) (unspecified)) (.compute-joins!|73) (set! *rep-subtypes* '())))))))) (.compute-unions!|2))))) 'compute-unions!))
+(let () (begin (set! compute-intersections! (lambda () (let ((.compute-intersections!|2 0)) (begin (set! .compute-intersections!|2 (lambda () (let* ((.n|6 *nreps*) (.meet|9 (unspecified))) (begin (set! .meet|9 (lambda (.i|10 .j|10) (let ((.k|13 (representation-union .i|10 .j|10))) (if (= .i|10 .k|13) .j|10 .i|10)))) (let () (let ((.loop|8|15|18 (unspecified))) (begin (set! .loop|8|15|18 (lambda (.i|19) (if (= .i|19 .n|6) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.j|29) (if (= .j|29 .n|6) (if #f #f (unspecified)) (begin (begin #t (representation-aset! *rep-meets* .i|19 .j|29 (.meet|9 .i|19 .j|29))) (.loop|23|25|28 (+ .j|29 1)))))) (.loop|23|25|28 0))))) (.loop|8|15|18 (+ .i|19 1)))))) (.loop|8|15|18 0)))))))) (.compute-intersections!|2))))) 'compute-intersections!))
+(let () (begin (set! compute-type-structure! (lambda () (let ((.compute-type-structure!|2 0)) (begin (set! .compute-type-structure!|2 (lambda () (begin (compute-unions!) (compute-intersections!)))) (.compute-type-structure!|2))))) 'compute-type-structure!))
+(let () (begin (set! representation-subtype? (lambda (.rep1|1 .rep2|1) (let ((.representation-subtype?|2 0)) (begin (set! .representation-subtype?|2 (lambda (.rep1|3 .rep2|3) (equal? .rep2|3 (representation-union .rep1|3 .rep2|3)))) (.representation-subtype?|2 .rep1|1 .rep2|1))))) 'representation-subtype?))
+(let () (begin (set! representation-union (lambda (.rep1|1 .rep2|1) (let ((.representation-union|2 0)) (begin (set! .representation-union|2 (lambda (.rep1|3 .rep2|3) (if (fixnum? .rep1|3) (if (fixnum? .rep2|3) (representation-aref *rep-joins* .rep1|3 .rep2|3) (.representation-union|2 .rep1|3 (let ((.x|4|7 .rep2|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (if (fixnum? .rep2|3) (.representation-union|2 (let ((.x|8|11 .rep1|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .rep2|3) (let ((.r1|14 (let ((.x|19|22 .rep1|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (.r2|14 (let ((.x|23|26 .rep2|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (= .r1|14 .r2|14) ((let ((.v|15|18 *rep-joins-special*) (.i|15|18 .r1|14)) (begin (.check! (fixnum? .i|15|18) 40 .v|15|18 .i|15|18) (.check! (vector? .v|15|18) 40 .v|15|18 .i|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 40 .v|15|18 .i|15|18) (.check! (>=:fix:fix .i|15|18 0) 40 .v|15|18 .i|15|18) (vector-ref:trusted .v|15|18 .i|15|18))) .rep1|3 .rep2|3) (.representation-union|2 .r1|14 .r2|14))))))) (.representation-union|2 .rep1|1 .rep2|1))))) 'representation-union))
+(let () (begin (set! representation-intersection (lambda (.rep1|1 .rep2|1) (let ((.representation-intersection|2 0)) (begin (set! .representation-intersection|2 (lambda (.rep1|3 .rep2|3) (if (fixnum? .rep1|3) (if (fixnum? .rep2|3) (representation-aref *rep-meets* .rep1|3 .rep2|3) (.representation-intersection|2 .rep1|3 (let ((.x|4|7 .rep2|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (if (fixnum? .rep2|3) (.representation-intersection|2 (let ((.x|8|11 .rep1|3)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) .rep2|3) (let ((.r1|14 (let ((.x|19|22 .rep1|3)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22)))) (.r2|14 (let ((.x|23|26 .rep2|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (= .r1|14 .r2|14) ((let ((.v|15|18 *rep-meets-special*) (.i|15|18 .r1|14)) (begin (.check! (fixnum? .i|15|18) 40 .v|15|18 .i|15|18) (.check! (vector? .v|15|18) 40 .v|15|18 .i|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 40 .v|15|18 .i|15|18) (.check! (>=:fix:fix .i|15|18 0) 40 .v|15|18 .i|15|18) (vector-ref:trusted .v|15|18 .i|15|18))) .rep1|3 .rep2|3) (.representation-intersection|2 .r1|14 .r2|14))))))) (.representation-intersection|2 .rep1|1 .rep2|1))))) 'representation-intersection))
+(let () (begin (set! display-unions-and-intersections (lambda () (let ((.display-unions-and-intersections|2 0)) (begin (set! .display-unions-and-intersections|2 (lambda () (let* ((.column-width|6 10) (.columns/row|9 (quotient 80 .column-width|6))) (let () (let ((.display-matrix|13 (unspecified)) (.display-symbol|13 (unspecified))) (begin (set! .display-matrix|13 (lambda (.f|14 .i|14 .n|14) (begin (display (make-string .column-width|6 #\space)) (let () (let ((.loop|16|18|21 (unspecified))) (begin (set! .loop|16|18|21 (lambda (.i|22) (if (= .i|22 .n|14) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol .i|22))) (.loop|16|18|21 (+ .i|22 1)))))) (.loop|16|18|21 .i|14)))) (newline) (newline) (let () (let ((.loop|26|28|31 (unspecified))) (begin (set! .loop|26|28|31 (lambda (.k|32) (if (= .k|32 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol .k|32)) (let () (let ((.loop|36|38|41 (unspecified))) (begin (set! .loop|36|38|41 (lambda (.i|42) (if (= .i|42 .n|14) (if #f #f (unspecified)) (begin (begin #t (.display-symbol|13 (rep->symbol (.f|14 .k|32 .i|42)))) (.loop|36|38|41 (+ .i|42 1)))))) (.loop|36|38|41 .i|14)))) (newline)) (.loop|26|28|31 (+ .k|32 1)))))) (.loop|26|28|31 0)))) (newline) (newline)))) (set! .display-symbol|13 (lambda (.sym|45) (let* ((.s|48 (symbol->string .sym|45)) (.n|51 (string-length .s|48))) (let () (if (< .n|51 .column-width|6) (begin (display .s|48) (display (make-string (- .column-width|6 .n|51) #\space))) (begin (display (substring .s|48 0 (- .column-width|6 1))) (write-char #\space))))))) (display "Unions:") (newline) (newline) (let () (let ((.loop|56|58|61 (unspecified))) (begin (set! .loop|56|58|61 (lambda (.i|62) (if (>= .i|62 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-matrix|13 representation-union .i|62 (min *nreps* (+ .i|62 .columns/row|9)))) (.loop|56|58|61 (+ .i|62 .columns/row|9)))))) (.loop|56|58|61 0)))) (display "Intersections:") (newline) (newline) (let () (let ((.loop|66|68|71 (unspecified))) (begin (set! .loop|66|68|71 (lambda (.i|72) (if (>= .i|72 *nreps*) (if #f #f (unspecified)) (begin (begin #t (.display-matrix|13 representation-intersection .i|72 (min *nreps* (+ .i|72 .columns/row|9)))) (.loop|66|68|71 (+ .i|72 .columns/row|9)))))) (.loop|66|68|71 0)))))))))) (.display-unions-and-intersections|2))))) 'display-unions-and-intersections))
+(let () (begin (set! rep-specific? (lambda (.f|1 .rs|1) (let ((.rep-specific?|2 0)) (begin (set! .rep-specific?|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-specific caddr))) (.rep-specific?|2 .f|1 .rs|1))))) 'rep-specific?))
+(let () (begin (set! rep-result? (lambda (.f|1 .rs|1) (let ((.rep-result?|2 0)) (begin (set! .rep-result?|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-result caaddr))) (.rep-result?|2 .f|1 .rs|1))))) 'rep-result?))
+(let () (begin (set! rep-if-true (lambda (.f|1 .rs|1) (let ((.rep-if-true|2 0)) (begin (set! .rep-if-true|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-informing caddr))) (.rep-if-true|2 .f|1 .rs|1))))) 'rep-if-true))
+(let () (begin (set! rep-if-false (lambda (.f|1 .rs|1) (let ((.rep-if-false|2 0)) (begin (set! .rep-if-false|2 (lambda (.f|3 .rs|3) (rep-match .f|3 .rs|3 rep-informing cadddr))) (.rep-if-false|2 .f|1 .rs|1))))) 'rep-if-false))
+(let () (begin (set! rep-match (lambda (.f|1 .rs|1 .table|1 .selector|1) (let ((.rep-match|2 0)) (begin (set! .rep-match|2 (lambda (.f|3 .rs|3 .table|3 .selector|3) (let* ((.n|6 (length .rs|3)) (.entries|9 .table|3)) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.entries|13) (if (null? .entries|13) #f (if (eq? .f|3 (let ((.x|16|19 (let ((.x|20|23 .entries|13)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (let ((.rs0|26 (let ((.x|88|91 (let ((.x|92|95 (let ((.x|96|99 .entries|13)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))))) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91))))) (if (if (= .n|6 (length .rs0|26)) (every? (lambda (.r1+r2|29) (let ((.r1|32 (let ((.x|33|36 .r1+r2|29)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))) (.r2|32 (let ((.x|37|40 .r1+r2|29)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (representation-subtype? .r1|32 .r2|32))) (let () (let ((.loop|47|51|54 (unspecified))) (begin (set! .loop|47|51|54 (lambda (.y1|41|43|55 .y1|41|42|55 .results|41|46|55) (if (let ((.temp|57|60 (null? .y1|41|43|55))) (if .temp|57|60 .temp|57|60 (null? .y1|41|42|55))) (reverse .results|41|46|55) (begin #t (.loop|47|51|54 (let ((.x|63|66 .y1|41|43|55)) (begin (.check! (pair? .x|63|66) 1 .x|63|66) (cdr:pair .x|63|66))) (let ((.x|67|70 .y1|41|42|55)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))) (cons (cons (let ((.x|71|74 .y1|41|43|55)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74))) (let ((.x|75|78 .y1|41|42|55)) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78)))) .results|41|46|55)))))) (.loop|47|51|54 .rs|3 .rs0|26 '()))))) #f) (.selector|3 (let ((.x|79|82 .entries|13)) (begin (.check! (pair? .x|79|82) 0 .x|79|82) (car:pair .x|79|82)))) (.loop|12 (let ((.x|83|86 .entries|13)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86)))))) (.loop|12 (let ((.x|101|104 .entries|13)) (begin (.check! (pair? .x|101|104) 1 .x|101|104) (cdr:pair .x|101|104)))))))) (.loop|12 .entries|9))))))) (.rep-match|2 .f|1 .rs|1 .table|1 .selector|1))))) 'rep-match))
+(let () (begin (set! aeval (lambda (.e|1 .types|1 .constraints|1) (let ((.aeval|2 0)) (begin (set! .aeval|2 (lambda (.e|3 .types|3 .constraints|3) (if (call? .e|3) (let ((.proc|7 (call.proc .e|3))) (if (variable? .proc|7) (let* ((.op|10 (variable.name .proc|7)) (.argtypes|13 (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.y1|20|21|32 .results|20|24|32) (if (null? .y1|20|21|32) (reverse .results|20|24|32) (begin #t (.loop|25|28|31 (let ((.x|36|39 .y1|20|21|32)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.e|40 (let ((.x|41|44 .y1|20|21|32)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (.aeval|2 .e|40 .types|3 .constraints|3)) .results|20|24|32)))))) (.loop|25|28|31 (call.args .e|3) '()))))) (.type|16 (rep-result? .op|10 .argtypes|13))) (let () (if .type|16 .type|16 rep:object))) rep:object)) (if (variable? .e|3) (representation-typeof (variable.name .e|3) .types|3 .constraints|3) (if (constant? .e|3) (representation-of-value (constant.value .e|3)) rep:object))))) (.aeval|2 .e|1 .types|1 .constraints|1))))) 'aeval))
+(let () (begin (set! representation-typeof (lambda (.name|1 .types|1 .constraints|1) (let ((.representation-typeof|2 0)) (begin (set! .representation-typeof|2 (lambda (.name|3 .types|3 .constraints|3) (let ((.t0|6 (hashtable-fetch .types|3 .name|3 rep:object)) (.cs|6 (hashtable-fetch (constraints.table .constraints|3) .name|3 '()))) (let ((.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.type|8 .cs|8) (if (null? .cs|8) .type|8 (let* ((.c|11 (let ((.x|28|31 .cs|8)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.cs|14 (let ((.x|24|27 .cs|8)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (.e|17 (constraint.rhs .c|11))) (let () (if (constant? .e|17) (.loop|7 (representation-intersection .type|8 (constant.value .e|17)) .cs|14) (if (call? .e|17) (.loop|7 (representation-intersection .type|8 (aeval .e|17 .types|3 .constraints|3)) .cs|14) (.loop|7 .type|8 .cs|14)))))))) (.loop|7 .t0|6 .cs|6)))))) (.representation-typeof|2 .name|1 .types|1 .constraints|1))))) 'representation-typeof))
+(let () (begin (set! make-constraint (lambda (.t|1 .e|1 .k|1) (let ((.make-constraint|2 0)) (begin (set! .make-constraint|2 (lambda (.t|3 .e|3 .k|3) (let* ((.t1|4|7 .t|3) (.t2|4|10 (let* ((.t1|14|17 .e|3) (.t2|14|20 (cons .k|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constraint|2 .t|1 .e|1 .k|1))))) 'make-constraint))
+(let () (begin (set! constraint.lhs (lambda (.c|1) (let ((.constraint.lhs|2 0)) (begin (set! .constraint.lhs|2 (lambda (.c|3) (let ((.x|4|7 .c|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.constraint.lhs|2 .c|1))))) 'constraint.lhs))
+(let () (begin (set! constraint.rhs (lambda (.c|1) (let ((.constraint.rhs|2 0)) (begin (set! .constraint.rhs|2 (lambda (.c|3) (let ((.x|5|8 (let ((.x|9|12 .c|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraint.rhs|2 .c|1))))) 'constraint.rhs))
+(let () (begin (set! constraint.killer (lambda (.c|1) (let ((.constraint.killer|2 0)) (begin (set! .constraint.killer|2 (lambda (.c|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .c|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraint.killer|2 .c|1))))) 'constraint.killer))
+(let () (begin (set! make-type-constraint (lambda (.t|1 .type|1 .k|1) (let ((.make-type-constraint|2 0)) (begin (set! .make-type-constraint|2 (lambda (.t|3 .type|3 .k|3) (make-constraint .t|3 (make-constant .type|3) .k|3))) (.make-type-constraint|2 .t|1 .type|1 .k|1))))) 'make-type-constraint))
+(let () (begin (set! constraints-add! (lambda (.types|1 .constraints|1 .new|1) (let ((.constraints-add!|2 0)) (begin (set! .constraints-add!|2 (lambda (.types|3 .constraints|3 .new|3) (let* ((.debugging?|6 #f) (.t|9 (constraint.lhs .new|3)) (.e|12 (constraint.rhs .new|3)) (.k|15 (constraint.killer .new|3)) (.cs|18 (constraints-for-variable .constraints|3 .t|9))) (let () (let ((.record-new-reps!|22 (unspecified)) (.loop|22 (unspecified))) (begin (set! .record-new-reps!|22 (lambda (.args|23 .argtypes|23 .reps|23 .k2|23) (begin (if .debugging?|6 (begin (write (let* ((.t1|24|27 (let () (let ((.loop|98|101|104 (unspecified))) (begin (set! .loop|98|101|104 (lambda (.y1|93|94|105 .results|93|97|105) (if (null? .y1|93|94|105) (reverse .results|93|97|105) (begin #t (.loop|98|101|104 (let ((.x|109|112 .y1|93|94|105)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))) (cons (make-readable (let ((.x|113|116 .y1|93|94|105)) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .results|93|97|105)))))) (.loop|98|101|104 .args|23 '()))))) (.t2|24|30 (let* ((.t1|34|37 (let () (let ((.loop|74|77|80 (unspecified))) (begin (set! .loop|74|77|80 (lambda (.y1|69|70|81 .results|69|73|81) (if (null? .y1|69|70|81) (reverse .results|69|73|81) (begin #t (.loop|74|77|80 (let ((.x|85|88 .y1|69|70|81)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88))) (cons (rep->symbol (let ((.x|89|92 .y1|69|70|81)) (begin (.check! (pair? .x|89|92) 0 .x|89|92) (car:pair .x|89|92)))) .results|69|73|81)))))) (.loop|74|77|80 .argtypes|23 '()))))) (.t2|34|40 (cons (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (rep->symbol (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .reps|23 '())))) '()))) (let () (cons .t1|34|37 .t2|34|40))))) (let () (cons .t1|24|27 .t2|24|30)))) (newline)) (unspecified)) (let () (let ((.loop|124|128|131 (unspecified))) (begin (set! .loop|124|128|131 (lambda (.y1|117|120|132 .y1|117|119|132 .y1|117|118|132) (if (let ((.temp|134|137 (null? .y1|117|120|132))) (if .temp|134|137 .temp|134|137 (let ((.temp|138|141 (null? .y1|117|119|132))) (if .temp|138|141 .temp|138|141 (null? .y1|117|118|132))))) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|144 (let ((.x|148|151 .y1|117|120|132)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151)))) (.type0|144 (let ((.x|152|155 .y1|117|119|132)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155)))) (.type1|144 (let ((.x|156|159 .y1|117|118|132)) (begin (.check! (pair? .x|156|159) 0 .x|156|159) (car:pair .x|156|159))))) (if (not (representation-subtype? .type0|144 .type1|144)) (if (variable? .arg|144) (let ((.name|147 (variable.name .arg|144))) (if (hashtable-get .types|3 .name|147) (.constraints-add!|2 .types|3 .constraints|3 (make-type-constraint .name|147 .type1|144 (available:killer-combine .k|15 .k2|23))) (cerror "Compiler bug: unexpected global: " .name|147))) (unspecified)) (unspecified)))) (.loop|124|128|131 (let ((.x|160|163 .y1|117|120|132)) (begin (.check! (pair? .x|160|163) 1 .x|160|163) (cdr:pair .x|160|163))) (let ((.x|164|167 .y1|117|119|132)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (let ((.x|168|171 .y1|117|118|132)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171)))))))) (.loop|124|128|131 .args|23 .argtypes|23 .reps|23))))))) (set! .loop|22 (lambda (.type|172 .k|172 .cs|172 .newcs|172) (if (null? .cs|172) (cons (make-type-constraint .t|9 .type|172 .k|172) .newcs|172) (let* ((.c2|175 (let ((.x|249|252 .cs|172)) (begin (.check! (pair? .x|249|252) 0 .x|249|252) (car:pair .x|249|252)))) (.cs|178 (let ((.x|245|248 .cs|172)) (begin (.check! (pair? .x|245|248) 1 .x|245|248) (cdr:pair .x|245|248)))) (.e2|181 (constraint.rhs .c2|175)) (.k2|184 (constraint.killer .c2|175))) (let () (if (constant? .e2|181) (let* ((.type2|190 (constant.value .e2|181)) (.type3|193 (representation-intersection .type|172 .type2|190))) (let () (if (eq? .type2|190 .type3|193) (if (= .k2|184 (logand .k|172 .k2|184)) (append .newcs|172 .cs|178) (.loop|22 (representation-intersection .type|172 .type2|190) (available:killer-combine .k|172 .k2|184) .cs|178 (cons .c2|175 .newcs|172))) (if (representation-subtype? .type|172 .type3|193) (if (= .k|172 (logand .k|172 .k2|184)) (.loop|22 .type|172 .k|172 .cs|178 .newcs|172) (.loop|22 .type|172 .k|172 .cs|178 (cons .c2|175 .newcs|172))) (.loop|22 .type3|193 (available:killer-combine .k|172 .k2|184) .cs|178 (cons .c2|175 .newcs|172)))))) (let* ((.op|202 (variable.name (call.proc .e2|181))) (.args|205 (call.args .e2|181)) (.argtypes|208 (let () (let ((.loop|225|228|231 (unspecified))) (begin (set! .loop|225|228|231 (lambda (.y1|220|221|232 .results|220|224|232) (if (null? .y1|220|221|232) (reverse .results|220|224|232) (begin #t (.loop|225|228|231 (let ((.x|236|239 .y1|220|221|232)) (begin (.check! (pair? .x|236|239) 1 .x|236|239) (cdr:pair .x|236|239))) (cons (let ((.exp|240 (let ((.x|241|244 .y1|220|221|232)) (begin (.check! (pair? .x|241|244) 0 .x|241|244) (car:pair .x|241|244))))) (aeval .exp|240 .types|3 .constraints|3)) .results|220|224|232)))))) (.loop|225|228|231 .args|205 '())))))) (let () (begin (if (representation-subtype? .type|172 rep:true) (let ((.reps|215 (rep-if-true .op|202 .argtypes|208))) (if .reps|215 (.record-new-reps!|22 .args|205 .argtypes|208 .reps|215 .k2|184) (unspecified))) (if (representation-subtype? .type|172 rep:false) (let ((.reps|219 (rep-if-false .op|202 .argtypes|208))) (if .reps|219 (.record-new-reps!|22 .args|205 .argtypes|208 .reps|219 .k2|184) (unspecified))) (unspecified))) (.loop|22 .type|172 .k|172 .cs|178 (cons .c2|175 .newcs|172))))))))))) (if (not (zero? .k|15)) (constraints-add-killedby! .constraints|3 .t|9 .k|15) (unspecified)) (let* ((.table|255 (constraints.table .constraints|3)) (.cs|258 (hashtable-fetch .table|255 .t|9 '()))) (let () (if (constant? .e|12) (let ((.type|265 (constant.value .e|12))) (begin (if .debugging?|6 (begin (display .t|9) (display " : ") (display (rep->symbol .type|265)) (newline)) (unspecified)) (let ((.cs|268 (.loop|22 .type|265 .k|15 .cs|258 '()))) (begin (hashtable-put! .table|255 .t|9 .cs|268) .constraints|3)))) (begin (if .debugging?|6 (begin (display .t|9) (display " = ") (display (make-readable .e|12 #t)) (newline)) (unspecified)) (if (not (null? .cs|258)) (begin (display "Compiler bug: ") (write .t|9) (display " has unexpectedly nonempty constraints") (newline)) (unspecified)) (hashtable-put! .table|255 .t|9 (cons (let* ((.t1|271|274 .t|9) (.t2|271|277 (let* ((.t1|281|284 .e|12) (.t2|281|287 (cons .k|15 '()))) (let () (cons .t1|281|284 .t2|281|287))))) (let () (cons .t1|271|274 .t2|271|277))) '())) .constraints|3)))))))))) (.constraints-add!|2 .types|1 .constraints|1 .new|1))))) 'constraints-add!))
+(let () (begin (set! number-of-basic-killers (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.i|8 .k|8) (if (> .k|8 available:killer:dead) .i|8 (begin #t (.loop|1|4|7 (+ .i|8 1) (+ .k|8 .k|8)))))) (.loop|1|4|7 0 1))))) 'number-of-basic-killers))
+(let () (begin (set! constraints.table (lambda (.constraints|1) (let ((.constraints.table|2 0)) (begin (set! .constraints.table|2 (lambda (.constraints|3) (let ((.x|4|7 .constraints|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.constraints.table|2 .constraints|1))))) 'constraints.table))
+(let () (begin (set! constraints.killed (lambda (.constraints|1) (let ((.constraints.killed|2 0)) (begin (set! .constraints.killed|2 (lambda (.constraints|3) (let ((.x|5|8 (let ((.x|9|12 .constraints|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.constraints.killed|2 .constraints|1))))) 'constraints.killed))
+(let () (begin (set! make-constraints-table (lambda () (let ((.make-constraints-table|2 0)) (begin (set! .make-constraints-table|2 (lambda () (let* ((.t1|4|7 (make-hashtable symbol-hash assq)) (.t2|4|10 (cons (make-vector number-of-basic-killers '()) '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.make-constraints-table|2))))) 'make-constraints-table))
+(let () (begin (set! copy-constraints-table (lambda (.constraints|1) (let ((.copy-constraints-table|2 0)) (begin (set! .copy-constraints-table|2 (lambda (.constraints|3) (let* ((.t1|4|7 (hashtable-copy (constraints.table .constraints|3))) (.t2|4|10 (cons (list->vector (vector->list (constraints.killed .constraints|3))) '()))) (let () (cons .t1|4|7 .t2|4|10))))) (.copy-constraints-table|2 .constraints|1))))) 'copy-constraints-table))
+(let () (begin (set! constraints-for-variable (lambda (.constraints|1 .t|1) (let ((.constraints-for-variable|2 0)) (begin (set! .constraints-for-variable|2 (lambda (.constraints|3 .t|3) (hashtable-fetch (constraints.table .constraints|3) .t|3 '()))) (.constraints-for-variable|2 .constraints|1 .t|1))))) 'constraints-for-variable))
+(let () (begin (set! constraints-add-killedby! (lambda (.constraints|1 .t|1 .k0|1) (let ((.constraints-add-killedby!|2 0)) (begin (set! .constraints-add-killedby!|2 (lambda (.constraints|3 .t|3 .k0|3) (if (not (zero? .k0|3)) (let ((.v|6 (constraints.killed .constraints|3))) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.i|15 .k|15) (if (= .i|15 number-of-basic-killers) (if #f #f (unspecified)) (begin (begin #t (if (not (zero? (logand .k|15 .k0|3))) (let ((.v|18|21 .v|6) (.i|18|21 .i|15) (.x|18|21 (cons .t|3 (let ((.v|22|25 .v|6) (.i|22|25 .i|15)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25)))))) (begin (.check! (fixnum? .i|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (vector? .v|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (<:fix:fix .i|18|21 (vector-length:vec .v|18|21)) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (>=:fix:fix .i|18|21 0) 41 .v|18|21 .i|18|21 .x|18|21) (vector-set!:trusted .v|18|21 .i|18|21 .x|18|21))) (unspecified))) (.loop|8|11|14 (+ .i|15 1) (+ .k|15 .k|15)))))) (.loop|8|11|14 0 1))))) (unspecified)))) (.constraints-add-killedby!|2 .constraints|1 .t|1 .k0|1))))) 'constraints-add-killedby!))
+(let () (begin (set! constraints-kill! (lambda (.constraints|1 .k|1) (let ((.constraints-kill!|2 0)) (begin (set! .constraints-kill!|2 (lambda (.constraints|3 .k|3) (if (not (zero? .k|3)) (let ((.table|6 (constraints.table .constraints|3)) (.killed|6 (constraints.killed .constraints|3))) (let ((.examine!|9 (unspecified))) (begin (set! .examine!|9 (lambda (.t|10) (let ((.cs|13 (filter (lambda (.c|14) (zero? (logand (constraint.killer .c|14) .k|3))) (hashtable-fetch .table|6 .t|10 '())))) (if (null? .cs|13) (hashtable-remove! .table|6 .t|10) (hashtable-put! .table|6 .t|10 .cs|13))))) (let () (let ((.loop|8|17|20 (unspecified))) (begin (set! .loop|8|17|20 (lambda (.i|21 .j|21) (if (= .i|21 number-of-basic-killers) (if #f #f (unspecified)) (begin (begin #t (if (not (zero? (logand .j|21 .k|3))) (begin (let () (let ((.loop|29|31|34 (unspecified))) (begin (set! .loop|29|31|34 (lambda (.y1|24|25|35) (if (null? .y1|24|25|35) (if #f #f (unspecified)) (begin (begin #t (.examine!|9 (let ((.x|39|42 .y1|24|25|35)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))))) (.loop|29|31|34 (let ((.x|43|46 .y1|24|25|35)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))))) (.loop|29|31|34 (let ((.v|47|50 .killed|6) (.i|47|50 .i|21)) (begin (.check! (fixnum? .i|47|50) 40 .v|47|50 .i|47|50) (.check! (vector? .v|47|50) 40 .v|47|50 .i|47|50) (.check! (<:fix:fix .i|47|50 (vector-length:vec .v|47|50)) 40 .v|47|50 .i|47|50) (.check! (>=:fix:fix .i|47|50 0) 40 .v|47|50 .i|47|50) (vector-ref:trusted .v|47|50 .i|47|50))))))) (let ((.v|51|54 .killed|6) (.i|51|54 .i|21) (.x|51|54 '())) (begin (.check! (fixnum? .i|51|54) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (vector? .v|51|54) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (<:fix:fix .i|51|54 (vector-length:vec .v|51|54)) 41 .v|51|54 .i|51|54 .x|51|54) (.check! (>=:fix:fix .i|51|54 0) 41 .v|51|54 .i|51|54 .x|51|54) (vector-set!:trusted .v|51|54 .i|51|54 .x|51|54)))) (unspecified))) (.loop|8|17|20 (+ .i|21 1) (+ .j|21 .j|21)))))) (.loop|8|17|20 0 1))))))) (unspecified)))) (.constraints-kill!|2 .constraints|1 .k|1))))) 'constraints-kill!))
+(let () (begin (set! constraints-intersect! (lambda (.constraints0|1 .constraints1|1 .constraints2|1) (let ((.constraints-intersect!|2 0)) (begin (set! .constraints-intersect!|2 (lambda (.constraints0|3 .constraints1|3 .constraints2|3) (let ((.table0|6 (constraints.table .constraints0|3)) (.table1|6 (constraints.table .constraints1|3)) (.table2|6 (constraints.table .constraints2|3))) (if (eq? .table0|6 .table1|6) (hashtable-for-each (lambda (.t|7 .cs|7) (if (not (null? .cs|7)) (hashtable-put! .table0|6 .t|7 (cs-intersect (hashtable-fetch .table2|6 .t|7 '()) .cs|7)) (unspecified))) .table1|6) (begin (.constraints-intersect!|2 .constraints0|3 .constraints0|3 .constraints1|3) (.constraints-intersect!|2 .constraints0|3 .constraints0|3 .constraints2|3)))))) (.constraints-intersect!|2 .constraints0|1 .constraints1|1 .constraints2|1))))) 'constraints-intersect!))
+(let () (begin (set! cs-intersect (lambda (.cs1|1 .cs2|1) (let ((.cs-intersect|2 0)) (begin (set! .cs-intersect|2 (lambda (.cs1|3 .cs2|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.cs|5 .init|5 .rep|5 .krep|5) (if (null? .cs|5) (values .init|5 .rep|5 .krep|5) (let* ((.c|8 (let ((.x|28|31 .cs|5)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.cs|11 (let ((.x|24|27 .cs|5)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))) (.e2|14 (constraint.rhs .c|8)) (.k2|17 (constraint.killer .c|8))) (let () (if (constant? .e2|14) (.loop|4 .cs|11 .init|5 (representation-intersection .rep|5 (constant.value .e2|14)) (available:killer-combine .krep|5 .k2|17)) (if (call? .e2|14) (if .init|5 (begin (display "Compiler bug in cs-intersect") (break)) (.loop|4 .cs|11 .c|8 .rep|5 .krep|5)) (error "Compiler bug in cs-intersect")))))))) (call-with-values (lambda () (.loop|4 .cs1|3 #f rep:object available:killer:none)) (lambda (.c1|33 .rep1|33 .krep1|33) (call-with-values (lambda () (.loop|4 .cs2|3 #f rep:object available:killer:none)) (lambda (.c2|35 .rep2|35 .krep2|35) (let ((.c|38 (if (equal? .c1|33 .c2|35) .c1|33 #f)) (.rep|38 (representation-union .rep1|33 .rep2|35)) (.krep|38 (available:killer-combine .krep1|33 .krep2|35))) (if (eq? .rep|38 rep:object) (if .c|38 (cons .c|38 '()) '()) (let ((.t|42 (constraint.lhs (let ((.x|55|58 .cs1|3)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58)))))) (if .c|38 (let* ((.t1|43|46 .c|38) (.t2|43|49 (cons (make-type-constraint .t|42 .rep|38 .krep|38) '()))) (let () (cons .t1|43|46 .t2|43|49))) (cons (make-type-constraint .t|42 .rep|38 .krep|38) '()))))))))))))) (.cs-intersect|2 .cs1|1 .cs2|1))))) 'cs-intersect))
+(let () (begin (set! $gc.ephemeral 0) '$gc.ephemeral))
+(let () (begin (set! $gc.tenuring 1) '$gc.tenuring))
+(let () (begin (set! $gc.full 2) '$gc.full))
+(let () (begin (set! $mstat.wallocated-hi 0) '$mstat.wallocated-hi))
+(let () (begin (set! $mstat.wallocated-lo 1) '$mstat.wallocated-lo))
+(let () (begin (set! $mstat.wcollected-hi 2) '$mstat.wcollected-hi))
+(let () (begin (set! $mstat.wcollected-lo 3) '$mstat.wcollected-lo))
+(let () (begin (set! $mstat.wcopied-hi 4) '$mstat.wcopied-hi))
+(let () (begin (set! $mstat.wcopied-lo 5) '$mstat.wcopied-lo))
+(let () (begin (set! $mstat.gctime 6) '$mstat.gctime))
+(let () (begin (set! $mstat.wlive 7) '$mstat.wlive))
+(let () (begin (set! $mstat.gc-last-gen 8) '$mstat.gc-last-gen))
+(let () (begin (set! $mstat.gc-last-type 9) '$mstat.gc-last-type))
+(let () (begin (set! $mstat.generations 10) '$mstat.generations))
+(let () (begin (set! $mstat.g-gc-count 0) '$mstat.g-gc-count))
+(let () (begin (set! $mstat.g-prom-count 1) '$mstat.g-prom-count))
+(let () (begin (set! $mstat.g-gctime 2) '$mstat.g-gctime))
+(let () (begin (set! $mstat.g-wlive 3) '$mstat.g-wlive))
+(let () (begin (set! $mstat.g-np-youngp 4) '$mstat.g-np-youngp))
+(let () (begin (set! $mstat.g-np-oldp 5) '$mstat.g-np-oldp))
+(let () (begin (set! $mstat.g-np-j 6) '$mstat.g-np-j))
+(let () (begin (set! $mstat.g-np-k 7) '$mstat.g-np-k))
+(let () (begin (set! $mstat.g-alloc 8) '$mstat.g-alloc))
+(let () (begin (set! $mstat.g-target 9) '$mstat.g-target))
+(let () (begin (set! $mstat.g-promtime 10) '$mstat.g-promtime))
+(let () (begin (set! $mstat.remsets 11) '$mstat.remsets))
+(let () (begin (set! $mstat.r-apool 0) '$mstat.r-apool))
+(let () (begin (set! $mstat.r-upool 1) '$mstat.r-upool))
+(let () (begin (set! $mstat.r-ahash 2) '$mstat.r-ahash))
+(let () (begin (set! $mstat.r-uhash 3) '$mstat.r-uhash))
+(let () (begin (set! $mstat.r-hrec-hi 4) '$mstat.r-hrec-hi))
+(let () (begin (set! $mstat.r-hrec-lo 5) '$mstat.r-hrec-lo))
+(let () (begin (set! $mstat.r-hrem-hi 6) '$mstat.r-hrem-hi))
+(let () (begin (set! $mstat.r-hrem-lo 7) '$mstat.r-hrem-lo))
+(let () (begin (set! $mstat.r-hscan-hi 8) '$mstat.r-hscan-hi))
+(let () (begin (set! $mstat.r-hscan-lo 9) '$mstat.r-hscan-lo))
+(let () (begin (set! $mstat.r-wscan-hi 10) '$mstat.r-wscan-hi))
+(let () (begin (set! $mstat.r-wscan-lo 11) '$mstat.r-wscan-lo))
+(let () (begin (set! $mstat.r-ssbrec-hi 12) '$mstat.r-ssbrec-hi))
+(let () (begin (set! $mstat.r-ssbrec-lo 13) '$mstat.r-ssbrec-lo))
+(let () (begin (set! $mstat.r-np-p 14) '$mstat.r-np-p))
+(let () (begin (set! $mstat.fflushed-hi 12) '$mstat.fflushed-hi))
+(let () (begin (set! $mstat.fflushed-lo 13) '$mstat.fflushed-lo))
+(let () (begin (set! $mstat.wflushed-hi 14) '$mstat.wflushed-hi))
+(let () (begin (set! $mstat.wflushed-lo 15) '$mstat.wflushed-lo))
+(let () (begin (set! $mstat.stk-created 16) '$mstat.stk-created))
+(let () (begin (set! $mstat.frestored-hi 17) '$mstat.frestored-hi))
+(let () (begin (set! $mstat.frestored-lo 18) '$mstat.frestored-lo))
+(let () (begin (set! $mstat.words-heap 19) '$mstat.words-heap))
+(let () (begin (set! $mstat.words-remset 20) '$mstat.words-remset))
+(let () (begin (set! $mstat.words-rts 21) '$mstat.words-rts))
+(let () (begin (set! $mstat.swb-assign 22) '$mstat.swb-assign))
+(let () (begin (set! $mstat.swb-lhs-ok 23) '$mstat.swb-lhs-ok))
+(let () (begin (set! $mstat.swb-rhs-const 24) '$mstat.swb-rhs-const))
+(let () (begin (set! $mstat.swb-not-xgen 25) '$mstat.swb-not-xgen))
+(let () (begin (set! $mstat.swb-trans 26) '$mstat.swb-trans))
+(let () (begin (set! $mstat.rtime 27) '$mstat.rtime))
+(let () (begin (set! $mstat.stime 28) '$mstat.stime))
+(let () (begin (set! $mstat.utime 29) '$mstat.utime))
+(let () (begin (set! $mstat.minfaults 30) '$mstat.minfaults))
+(let () (begin (set! $mstat.majfaults 31) '$mstat.majfaults))
+(let () (begin (set! $mstat.np-remsetp 32) '$mstat.np-remsetp))
+(let () (begin (set! $mstat.max-heap 33) '$mstat.max-heap))
+(let () (begin (set! $mstat.promtime 34) '$mstat.promtime))
+(let () (begin (set! $mstat.wmoved-hi 35) '$mstat.wmoved-hi))
+(let () (begin (set! $mstat.wmoved-lo 36) '$mstat.wmoved-lo))
+(let () (begin (set! $mstat.vsize 37) '$mstat.vsize))
+(let () (begin (set! $g.reg0 12) '$g.reg0))
+(let () (begin (set! $r.reg8 44) '$r.reg8))
+(let () (begin (set! $r.reg9 48) '$r.reg9))
+(let () (begin (set! $r.reg10 52) '$r.reg10))
+(let () (begin (set! $r.reg11 56) '$r.reg11))
+(let () (begin (set! $r.reg12 60) '$r.reg12))
+(let () (begin (set! $r.reg13 64) '$r.reg13))
+(let () (begin (set! $r.reg14 68) '$r.reg14))
+(let () (begin (set! $r.reg15 72) '$r.reg15))
+(let () (begin (set! $r.reg16 76) '$r.reg16))
+(let () (begin (set! $r.reg17 80) '$r.reg17))
+(let () (begin (set! $r.reg18 84) '$r.reg18))
+(let () (begin (set! $r.reg19 88) '$r.reg19))
+(let () (begin (set! $r.reg20 92) '$r.reg20))
+(let () (begin (set! $r.reg21 96) '$r.reg21))
+(let () (begin (set! $r.reg22 100) '$r.reg22))
+(let () (begin (set! $r.reg23 104) '$r.reg23))
+(let () (begin (set! $r.reg24 108) '$r.reg24))
+(let () (begin (set! $r.reg25 112) '$r.reg25))
+(let () (begin (set! $r.reg26 116) '$r.reg26))
+(let () (begin (set! $r.reg27 120) '$r.reg27))
+(let () (begin (set! $r.reg28 124) '$r.reg28))
+(let () (begin (set! $r.reg29 128) '$r.reg29))
+(let () (begin (set! $r.reg30 132) '$r.reg30))
+(let () (begin (set! $r.reg31 136) '$r.reg31))
+(let () (begin (set! $g.stkbot 180) '$g.stkbot))
+(let () (begin (set! $g.gccnt 420) '$g.gccnt))
+(let () (begin (set! $m.alloc 1024) '$m.alloc))
+(let () (begin (set! $m.alloci 1032) '$m.alloci))
+(let () (begin (set! $m.gc 1040) '$m.gc))
+(let () (begin (set! $m.addtrans 1048) '$m.addtrans))
+(let () (begin (set! $m.stkoflow 1056) '$m.stkoflow))
+(let () (begin (set! $m.stkuflow 1072) '$m.stkuflow))
+(let () (begin (set! $m.creg 1080) '$m.creg))
+(let () (begin (set! $m.creg-set! 1088) '$m.creg-set!))
+(let () (begin (set! $m.add 1096) '$m.add))
+(let () (begin (set! $m.subtract 1104) '$m.subtract))
+(let () (begin (set! $m.multiply 1112) '$m.multiply))
+(let () (begin (set! $m.quotient 1120) '$m.quotient))
+(let () (begin (set! $m.remainder 1128) '$m.remainder))
+(let () (begin (set! $m.divide 1136) '$m.divide))
+(let () (begin (set! $m.modulo 1144) '$m.modulo))
+(let () (begin (set! $m.negate 1152) '$m.negate))
+(let () (begin (set! $m.numeq 1160) '$m.numeq))
+(let () (begin (set! $m.numlt 1168) '$m.numlt))
+(let () (begin (set! $m.numle 1176) '$m.numle))
+(let () (begin (set! $m.numgt 1184) '$m.numgt))
+(let () (begin (set! $m.numge 1192) '$m.numge))
+(let () (begin (set! $m.zerop 1200) '$m.zerop))
+(let () (begin (set! $m.complexp 1208) '$m.complexp))
+(let () (begin (set! $m.realp 1216) '$m.realp))
+(let () (begin (set! $m.rationalp 1224) '$m.rationalp))
+(let () (begin (set! $m.integerp 1232) '$m.integerp))
+(let () (begin (set! $m.exactp 1240) '$m.exactp))
+(let () (begin (set! $m.inexactp 1248) '$m.inexactp))
+(let () (begin (set! $m.exact->inexact 1256) '$m.exact->inexact))
+(let () (begin (set! $m.inexact->exact 1264) '$m.inexact->exact))
+(let () (begin (set! $m.make-rectangular 1272) '$m.make-rectangular))
+(let () (begin (set! $m.real-part 1280) '$m.real-part))
+(let () (begin (set! $m.imag-part 1288) '$m.imag-part))
+(let () (begin (set! $m.sqrt 1296) '$m.sqrt))
+(let () (begin (set! $m.round 1304) '$m.round))
+(let () (begin (set! $m.truncate 1312) '$m.truncate))
+(let () (begin (set! $m.apply 1320) '$m.apply))
+(let () (begin (set! $m.varargs 1328) '$m.varargs))
+(let () (begin (set! $m.typetag 1336) '$m.typetag))
+(let () (begin (set! $m.typetag-set 1344) '$m.typetag-set))
+(let () (begin (set! $m.break 1352) '$m.break))
+(let () (begin (set! $m.eqv 1360) '$m.eqv))
+(let () (begin (set! $m.partial-list->vector 1368) '$m.partial-list->vector))
+(let () (begin (set! $m.timer-exception 1376) '$m.timer-exception))
+(let () (begin (set! $m.exception 1384) '$m.exception))
+(let () (begin (set! $m.singlestep 1392) '$m.singlestep))
+(let () (begin (set! $m.syscall 1400) '$m.syscall))
+(let () (begin (set! $m.bvlcmp 1408) '$m.bvlcmp))
+(let () (begin (set! $m.enable-interrupts 1416) '$m.enable-interrupts))
+(let () (begin (set! $m.disable-interrupts 1424) '$m.disable-interrupts))
+(let () (begin (set! $m.alloc-bv 1432) '$m.alloc-bv))
+(let () (begin (set! $m.global-ex 1440) '$m.global-ex))
+(let () (begin (set! $m.invoke-ex 1448) '$m.invoke-ex))
+(let () (begin (set! $m.global-invoke-ex 1456) '$m.global-invoke-ex))
+(let () (begin (set! $m.argc-ex 1464) '$m.argc-ex))
+(let () (begin (set! $r.g0 0) '$r.g0))
+(let () (begin (set! $r.g1 1) '$r.g1))
+(let () (begin (set! $r.g2 2) '$r.g2))
+(let () (begin (set! $r.g3 3) '$r.g3))
+(let () (begin (set! $r.g4 4) '$r.g4))
+(let () (begin (set! $r.g5 5) '$r.g5))
+(let () (begin (set! $r.g6 6) '$r.g6))
+(let () (begin (set! $r.g7 7) '$r.g7))
+(let () (begin (set! $r.o0 8) '$r.o0))
+(let () (begin (set! $r.o1 9) '$r.o1))
+(let () (begin (set! $r.o2 10) '$r.o2))
+(let () (begin (set! $r.o3 11) '$r.o3))
+(let () (begin (set! $r.o4 12) '$r.o4))
+(let () (begin (set! $r.o5 13) '$r.o5))
+(let () (begin (set! $r.o6 14) '$r.o6))
+(let () (begin (set! $r.o7 15) '$r.o7))
+(let () (begin (set! $r.l0 16) '$r.l0))
+(let () (begin (set! $r.l1 17) '$r.l1))
+(let () (begin (set! $r.l2 18) '$r.l2))
+(let () (begin (set! $r.l3 19) '$r.l3))
+(let () (begin (set! $r.l4 20) '$r.l4))
+(let () (begin (set! $r.l5 21) '$r.l5))
+(let () (begin (set! $r.l6 22) '$r.l6))
+(let () (begin (set! $r.l7 23) '$r.l7))
+(let () (begin (set! $r.i0 24) '$r.i0))
+(let () (begin (set! $r.i1 25) '$r.i1))
+(let () (begin (set! $r.i2 26) '$r.i2))
+(let () (begin (set! $r.i3 27) '$r.i3))
+(let () (begin (set! $r.i4 28) '$r.i4))
+(let () (begin (set! $r.i5 29) '$r.i5))
+(let () (begin (set! $r.i6 30) '$r.i6))
+(let () (begin (set! $r.i7 31) '$r.i7))
+(let () (begin (set! $r.result $r.o0) '$r.result))
+(let () (begin (set! $r.argreg2 $r.o1) '$r.argreg2))
+(let () (begin (set! $r.argreg3 $r.o2) '$r.argreg3))
+(let () (begin (set! $r.stkp $r.o3) '$r.stkp))
+(let () (begin (set! $r.stklim $r.i0) '$r.stklim))
+(let () (begin (set! $r.tmp1 $r.o4) '$r.tmp1))
+(let () (begin (set! $r.tmp2 $r.o5) '$r.tmp2))
+(let () (begin (set! $r.tmp0 $r.g1) '$r.tmp0))
+(let () (begin (set! $r.e-top $r.i0) '$r.e-top))
+(let () (begin (set! $r.e-limit $r.o3) '$r.e-limit))
+(let () (begin (set! $r.timer $r.i4) '$r.timer))
+(let () (begin (set! $r.millicode $r.i7) '$r.millicode))
+(let () (begin (set! $r.globals $r.i7) '$r.globals))
+(let () (begin (set! $r.reg0 $r.l0) '$r.reg0))
+(let () (begin (set! $r.reg1 $r.l1) '$r.reg1))
+(let () (begin (set! $r.reg2 $r.l2) '$r.reg2))
+(let () (begin (set! $r.reg3 $r.l3) '$r.reg3))
+(let () (begin (set! $r.reg4 $r.l4) '$r.reg4))
+(let () (begin (set! $r.reg5 $r.l5) '$r.reg5))
+(let () (begin (set! $r.reg6 $r.l6) '$r.reg6))
+(let () (begin (set! $r.reg7 $r.l7) '$r.reg7))
+(let () (begin (set! $ex.car 0) '$ex.car))
+(let () (begin (set! $ex.cdr 1) '$ex.cdr))
+(let () (begin (set! $ex.setcar 2) '$ex.setcar))
+(let () (begin (set! $ex.setcdr 3) '$ex.setcdr))
+(let () (begin (set! $ex.add 10) '$ex.add))
+(let () (begin (set! $ex.sub 11) '$ex.sub))
+(let () (begin (set! $ex.mul 12) '$ex.mul))
+(let () (begin (set! $ex.div 13) '$ex.div))
+(let () (begin (set! $ex.lessp 14) '$ex.lessp))
+(let () (begin (set! $ex.lesseqp 15) '$ex.lesseqp))
+(let () (begin (set! $ex.equalp 16) '$ex.equalp))
+(let () (begin (set! $ex.greatereqp 17) '$ex.greatereqp))
+(let () (begin (set! $ex.greaterp 18) '$ex.greaterp))
+(let () (begin (set! $ex.quotient 19) '$ex.quotient))
+(let () (begin (set! $ex.remainder 20) '$ex.remainder))
+(let () (begin (set! $ex.modulo 21) '$ex.modulo))
+(let () (begin (set! $ex.logior 22) '$ex.logior))
+(let () (begin (set! $ex.logand 23) '$ex.logand))
+(let () (begin (set! $ex.logxor 24) '$ex.logxor))
+(let () (begin (set! $ex.lognot 25) '$ex.lognot))
+(let () (begin (set! $ex.lsh 26) '$ex.lsh))
+(let () (begin (set! $ex.rsha 27) '$ex.rsha))
+(let () (begin (set! $ex.rshl 28) '$ex.rshl))
+(let () (begin (set! $ex.e2i 29) '$ex.e2i))
+(let () (begin (set! $ex.i2e 30) '$ex.i2e))
+(let () (begin (set! $ex.exactp 31) '$ex.exactp))
+(let () (begin (set! $ex.inexactp 32) '$ex.inexactp))
+(let () (begin (set! $ex.round 33) '$ex.round))
+(let () (begin (set! $ex.trunc 34) '$ex.trunc))
+(let () (begin (set! $ex.zerop 35) '$ex.zerop))
+(let () (begin (set! $ex.neg 36) '$ex.neg))
+(let () (begin (set! $ex.abs 37) '$ex.abs))
+(let () (begin (set! $ex.realpart 38) '$ex.realpart))
+(let () (begin (set! $ex.imagpart 39) '$ex.imagpart))
+(let () (begin (set! $ex.vref 40) '$ex.vref))
+(let () (begin (set! $ex.vset 41) '$ex.vset))
+(let () (begin (set! $ex.vlen 42) '$ex.vlen))
+(let () (begin (set! $ex.pref 50) '$ex.pref))
+(let () (begin (set! $ex.pset 51) '$ex.pset))
+(let () (begin (set! $ex.plen 52) '$ex.plen))
+(let () (begin (set! $ex.sref 60) '$ex.sref))
+(let () (begin (set! $ex.sset 61) '$ex.sset))
+(let () (begin (set! $ex.slen 62) '$ex.slen))
+(let () (begin (set! $ex.bvref 70) '$ex.bvref))
+(let () (begin (set! $ex.bvset 71) '$ex.bvset))
+(let () (begin (set! $ex.bvlen 72) '$ex.bvlen))
+(let () (begin (set! $ex.bvlref 80) '$ex.bvlref))
+(let () (begin (set! $ex.bvlset 81) '$ex.bvlset))
+(let () (begin (set! $ex.bvllen 82) '$ex.bvllen))
+(let () (begin (set! $ex.vlref 90) '$ex.vlref))
+(let () (begin (set! $ex.vlset 91) '$ex.vlset))
+(let () (begin (set! $ex.vllen 92) '$ex.vllen))
+(let () (begin (set! $ex.typetag 100) '$ex.typetag))
+(let () (begin (set! $ex.typetagset 101) '$ex.typetagset))
+(let () (begin (set! $ex.apply 102) '$ex.apply))
+(let () (begin (set! $ex.argc 103) '$ex.argc))
+(let () (begin (set! $ex.vargc 104) '$ex.vargc))
+(let () (begin (set! $ex.nonproc 105) '$ex.nonproc))
+(let () (begin (set! $ex.undef-global 106) '$ex.undef-global))
+(let () (begin (set! $ex.dump 107) '$ex.dump))
+(let () (begin (set! $ex.dumpfail 108) '$ex.dumpfail))
+(let () (begin (set! $ex.timer 109) '$ex.timer))
+(let () (begin (set! $ex.unsupported 110) '$ex.unsupported))
+(let () (begin (set! $ex.int2char 111) '$ex.int2char))
+(let () (begin (set! $ex.char2int 112) '$ex.char2int))
+(let () (begin (set! $ex.mkbvl 113) '$ex.mkbvl))
+(let () (begin (set! $ex.mkvl 114) '$ex.mkvl))
+(let () (begin (set! $ex.char<? 115) '$ex.char<?))
+(let () (begin (set! $ex.char<=? 116) '$ex.char<=?))
+(let () (begin (set! $ex.char=? 117) '$ex.char=?))
+(let () (begin (set! $ex.char>? 118) '$ex.char>?))
+(let () (begin (set! $ex.char>=? 119) '$ex.char>=?))
+(let () (begin (set! $ex.bvfill 120) '$ex.bvfill))
+(let () (begin (set! $ex.enable-interrupts 121) '$ex.enable-interrupts))
+(let () (begin (set! $ex.keyboard-interrupt 122) '$ex.keyboard-interrupt))
+(let () (begin (set! $ex.arithmetic-exception 123) '$ex.arithmetic-exception))
+(let () (begin (set! $ex.global-invoke 124) '$ex.global-invoke))
+(let () (begin (set! $ex.fx+ 140) '$ex.fx+))
+(let () (begin (set! $ex.fx- 141) '$ex.fx-))
+(let () (begin (set! $ex.fx-- 142) '$ex.fx--))
+(let () (begin (set! $ex.fx= 143) '$ex.fx=))
+(let () (begin (set! $ex.fx< 144) '$ex.fx<))
+(let () (begin (set! $ex.fx<= 145) '$ex.fx<=))
+(let () (begin (set! $ex.fx> 146) '$ex.fx>))
+(let () (begin (set! $ex.fx>= 147) '$ex.fx>=))
+(let () (begin (set! $ex.fxpositive? 148) '$ex.fxpositive?))
+(let () (begin (set! $ex.fxnegative? 149) '$ex.fxnegative?))
+(let () (begin (set! $ex.fxzero? 150) '$ex.fxzero?))
+(let () (begin (set! $ex.fx* 151) '$ex.fx*))
+(let () (begin (set! $tag.tagmask 7) '$tag.tagmask))
+(let () (begin (set! $tag.pair-tag 1) '$tag.pair-tag))
+(let () (begin (set! $tag.vector-tag 3) '$tag.vector-tag))
+(let () (begin (set! $tag.bytevector-tag 5) '$tag.bytevector-tag))
+(let () (begin (set! $tag.procedure-tag 7) '$tag.procedure-tag))
+(let () (begin (set! $imm.vector-header 162) '$imm.vector-header))
+(let () (begin (set! $imm.bytevector-header 194) '$imm.bytevector-header))
+(let () (begin (set! $imm.procedure-header 254) '$imm.procedure-header))
+(let () (begin (set! $imm.true 6) '$imm.true))
+(let () (begin (set! $imm.false 2) '$imm.false))
+(let () (begin (set! $imm.null 10) '$imm.null))
+(let () (begin (set! $imm.unspecified 278) '$imm.unspecified))
+(let () (begin (set! $imm.eof 534) '$imm.eof))
+(let () (begin (set! $imm.undefined 790) '$imm.undefined))
+(let () (begin (set! $imm.character 38) '$imm.character))
+(let () (begin (set! $tag.vector-typetag 0) '$tag.vector-typetag))
+(let () (begin (set! $tag.rectnum-typetag 4) '$tag.rectnum-typetag))
+(let () (begin (set! $tag.ratnum-typetag 8) '$tag.ratnum-typetag))
+(let () (begin (set! $tag.symbol-typetag 12) '$tag.symbol-typetag))
+(let () (begin (set! $tag.port-typetag 16) '$tag.port-typetag))
+(let () (begin (set! $tag.structure-typetag 20) '$tag.structure-typetag))
+(let () (begin (set! $tag.bytevector-typetag 0) '$tag.bytevector-typetag))
+(let () (begin (set! $tag.string-typetag 4) '$tag.string-typetag))
+(let () (begin (set! $tag.flonum-typetag 8) '$tag.flonum-typetag))
+(let () (begin (set! $tag.compnum-typetag 12) '$tag.compnum-typetag))
+(let () (begin (set! $tag.bignum-typetag 16) '$tag.bignum-typetag))
+(let () (begin (set! $hdr.port 178) '$hdr.port))
+(let () (begin (set! $hdr.struct 182) '$hdr.struct))
+(let () (begin (set! $p.codevector -3) '$p.codevector))
+(let () (begin (set! $p.constvector 1) '$p.constvector))
+(let () (begin (set! $p.linkoffset 5) '$p.linkoffset))
+(let () (begin (set! $p.reg0 5) '$p.reg0))
+(let () (begin (set! $p.codeoffset -1) '$p.codeoffset))
+(let () (begin (set! twobit-sort (lambda (.less?|1 .list|1) (compat:sort .list|1 .less?|1))) 'twobit-sort))
+(let () (begin (set! renaming-prefix ".") 'renaming-prefix))
+(let () (begin (set! cell-prefix (string-append renaming-prefix "CELL:")) 'cell-prefix))
+(let () (begin (set! name:check! '.check!) 'name:check!))
+(let () (begin (set! name:cons '.cons) 'name:cons))
+(let () (begin (set! name:list '.list) 'name:list))
+(let () (begin (set! name:make-cell '.make-cell) 'name:make-cell))
+(let () (begin (set! name:cell-ref '.cell-ref) 'name:cell-ref))
+(let () (begin (set! name:cell-set! '.cell-set!) 'name:cell-set!))
+(let () (begin (set! name:ignored (string->symbol "IGNORED")) 'name:ignored))
+(let () (begin (set! name:car '.car) 'name:car))
+(let () (begin (set! name:cdr '.cdr) 'name:cdr))
+(let () (begin (set! name:not 'not) 'name:not))
+(let () (begin (set! name:memq 'memq) 'name:memq))
+(let () (begin (set! name:memv 'memv) 'name:memv))
+(let () (begin (set! name:eq? 'eq?) 'name:eq?))
+(let () (begin (set! name:eqv? 'eqv?) 'name:eqv?))
+(let () (begin (set! name:fixnum? 'fixnum?) 'name:fixnum?))
+(let () (begin (set! name:char? 'char?) 'name:char?))
+(let () (begin (set! name:symbol? 'symbol?) 'name:symbol?))
+(let () (begin (set! name:fx< '<:fix:fix) 'name:fx<))
+(let () (begin (set! name:fx- 'fx-) 'name:fx-))
+(let () (begin (set! name:char->integer 'char->integer) 'name:char->integer))
+(let () (begin (set! name:vector-ref 'vector-ref:trusted) 'name:vector-ref))
+(let () (begin (set! constant-folding-entry (lambda (.name|1) (let ((.constant-folding-entry|2 0)) (begin (set! .constant-folding-entry|2 (lambda (.name|3) (assq .name|3 $usual-constant-folding-procedures$))) (.constant-folding-entry|2 .name|1))))) 'constant-folding-entry))
+(let () (begin (set! constant-folding-predicates cadr) 'constant-folding-predicates))
+(let () (begin (set! constant-folding-folder caddr) 'constant-folding-folder))
+(let () (begin (set! $usual-constant-folding-procedures$ (let ((.always?|3 (lambda (.x|1468) #t)) (.charcode?|3 (lambda (.n|1469) (if (number? .n|1469) (if (exact? .n|1469) (if (<= 0 .n|1469) (< .n|1469 128) #f) #f) #f))) (.ratnum?|3 (lambda (.n|1474) (if (number? .n|1474) (if (exact? .n|1474) (rational? .n|1474) #f) #f))) (.smallint?|3 (lambda (.n|1478) (smallint? .n|1478)))) (.cons (.cons 'integer->char (.cons (.cons .charcode?|3 '()) (.cons integer->char '()))) (.cons (.cons 'char->integer (.cons (.cons char? '()) (.cons char->integer '()))) (.cons (.cons 'zero? (.cons (.cons .ratnum?|3 '()) (.cons zero? '()))) (.cons (.cons '< (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons < '()))) (.cons (.cons '<= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons <= '()))) (.cons (.cons '= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons = '()))) (.cons (.cons '>= (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons >= '()))) (.cons (.cons '> (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons > '()))) (.cons (.cons '+ (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons + '()))) (.cons (.cons '- (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons - '()))) (.cons (.cons '* (.cons (.cons .ratnum?|3 (.cons .ratnum?|3 '())) (.cons * '()))) (.cons (.cons '-- (.cons (.cons .ratnum?|3 '()) (.cons (lambda (.x|1467) (- 0 .x|1467)) '()))) (.cons (.cons 'eq? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons eq? '()))) (.cons (.cons 'eqv? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons eqv? '()))) (.cons (.cons 'equal? (.cons (.cons .always?|3 (.cons .always?|3 '())) (.cons equal? '()))) (.cons (.cons 'memq (.cons (.cons .always?|3 (.cons list? '())) (.cons memq '()))) (.cons (.cons 'memv (.cons (.cons .always?|3 (.cons list? '())) (.cons memv '()))) (.cons (.cons 'member (.cons (.cons .always?|3 (.cons list? '())) (.cons member '()))) (.cons (.cons 'assq (.cons (.cons .always?|3 (.cons list? '())) (.cons assq '()))) (.cons (.cons 'assv (.cons (.cons .always?|3 (.cons list? '())) (.cons assv '()))) (.cons (.cons 'assoc (.cons (.cons .always?|3 (.cons list? '())) (.cons assoc '()))) (.cons (.cons 'length (.cons (.cons list? '()) (.cons length '()))) (.cons (.cons 'fixnum? (.cons (.cons .smallint?|3 '()) (.cons .smallint?|3 '()))) (.cons (.cons '=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons = '()))) (.cons (.cons '<:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons < '()))) (.cons (.cons '<=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons <= '()))) (.cons (.cons '>:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons > '()))) (.cons (.cons '>=:fix:fix (.cons (.cons .smallint?|3 (.cons .smallint?|3 '())) (.cons >= '()))) '())))))))))))))))))))))))))))))) '$usual-constant-folding-procedures$))
+(let () (begin '(define (.check! flag exn . args) (if (not flag) (apply error "Runtime check exception: " exn args))) #t))
+(let () (let () (let ((.loop|6|8|11 (unspecified))) (begin (set! .loop|6|8|11 (lambda (.y1|1|2|12) (if (null? .y1|1|2|12) (if #f #f (unspecified)) (begin (begin #t (pass1 (let ((.x|16|19 .y1|1|2|12)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19))))) (.loop|6|8|11 (let ((.x|20|23 .y1|1|2|12)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23)))))))) (.loop|6|8|11 (.cons (.cons 'define-inline (.cons 'car (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(car x0) (.cons (.cons 'let (.cons '((x x0)) (.cons (.cons '.check! (.cons '(pair? x) (.cons $ex.car '(x)))) '((car:pair x))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'cdr (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(car x0) (.cons (.cons 'let (.cons '((x x0)) (.cons (.cons '.check! (.cons '(pair? x) (.cons $ex.cdr '(x)))) '((cdr:pair x))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-length (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-length v0) (.cons (.cons 'let (.cons '((v v0)) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vlen '(v)))) '((vector-length:vec v))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-ref (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-ref v0 i0) (.cons (.cons 'let (.cons '((v v0) (i i0)) (.cons (.cons '.check! (.cons '(fixnum? i) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(<:fix:fix i (vector-length:vec v)) (.cons $ex.vref '(v i)))) (.cons (.cons '.check! (.cons '(>=:fix:fix i 0) (.cons $ex.vref '(v i)))) '((vector-ref:trusted v i)))))))) '())) '()))) '()))) (.cons (.cons 'define-inline (.cons 'vector-set! (.cons (.cons 'syntax-rules (.cons '() (.cons (.cons '(vector-set! v0 i0 x0) (.cons (.cons 'let (.cons '((v v0) (i i0) (x x0)) (.cons (.cons '.check! (.cons '(fixnum? i) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(vector? v) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(<:fix:fix i (vector-length:vec v)) (.cons $ex.vset '(v i x)))) (.cons (.cons '.check! (.cons '(>=:fix:fix i 0) (.cons $ex.vset '(v i x)))) '((vector-set!:trusted v i x)))))))) '())) '()))) '()))) '((define-inline list (syntax-rules () ((list) '()) ((list ?e) (cons ?e '())) ((list ?e1 ?e2 ...) (let* ((t1 ?e1) (t2 (list ?e2 ...))) (cons t1 t2))))) (define-inline vector (syntax-rules () ((vector) '#()) ((vector ?e) (make-vector 1 ?e)) ((vector ?e1 ?e2 ...) (letrec-syntax ((vector-aux1 (... (syntax-rules () ((vector-aux1 () ?n ?exps ?indexes ?temps) (vector-aux2 ?n ?exps ?indexes ?temps)) ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps) (vector-aux1 (?exp2 ...) (+ ?n 1) (?exp1 . ?exps) (?n . ?indexes) (t . ?temps)))))) (vector-aux2 (... (syntax-rules () ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...)) (let* ((?t1 ?exp1) (?t2 ?exp2) ... (v (make-vector ?n ?t1))) (vector-set! v ?n2 ?t2) ... v)))))) (vector-aux1 (?e1 ?e2 ...) 0 () () ()))))) (define-inline cadddr (syntax-rules () ((cadddr ?e) (car (cdr (cdr (cdr ?e))))))) (define-inline cddddr (syntax-rules () ((cddddr ?e) (cdr (cdr (cdr (cdr ?e))))))) (define-inline cdddr (syntax-rules () ((cdddr ?e) (cdr (cdr (cdr ?e)))))) (define-inline caddr (syntax-rules () ((caddr ?e) (car (cdr (cdr ?e)))))) (define-inline cddr (syntax-rules () ((cddr ?e) (cdr (cdr ?e))))) (define-inline cdar (syntax-rules () ((cdar ?e) (cdr (car ?e))))) (define-inline cadr (syntax-rules () ((cadr ?e) (car (cdr ?e))))) (define-inline caar (syntax-rules () ((caar ?e) (car (car ?e))))) (define-inline make-vector (syntax-rules () ((make-vector ?n) (make-vector ?n '())))) (define-inline make-string (syntax-rules () ((make-string ?n) (make-string ?n #\space)))) (define-inline = (syntax-rules () ((= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (= ?e1 t) (= t ?e3 ?e4 ...)))))) (define-inline < (syntax-rules () ((< ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (< ?e1 t) (< t ?e3 ?e4 ...)))))) (define-inline > (syntax-rules () ((> ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (> ?e1 t) (> t ?e3 ?e4 ...)))))) (define-inline <= (syntax-rules () ((<= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (<= ?e1 t) (<= t ?e3 ?e4 ...)))))) (define-inline >= (syntax-rules () ((>= ?e1 ?e2 ?e3 ?e4 ...) (let ((t ?e2)) (and (>= ?e1 t) (>= t ?e3 ?e4 ...)))))) (define-inline + (syntax-rules () ((+) 0) ((+ ?e) ?e) ((+ ?e1 ?e2 ?e3 ?e4 ...) (+ (+ ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline * (syntax-rules () ((*) 1) ((* ?e) ?e) ((* ?e1 ?e2 ?e3 ?e4 ...) (* (* ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline - (syntax-rules () ((- ?e) (- 0 ?e)) ((- ?e1 ?e2 ?e3 ?e4 ...) (- (- ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline / (syntax-rules () ((/ ?e) (/ 1 ?e)) ((/ ?e1 ?e2 ?e3 ?e4 ...) (/ (/ ?e1 ?e2) ?e3 ?e4 ...)))) (define-inline abs (syntax-rules () ((abs ?z) (let ((temp ?z)) (if (< temp 0) (-- temp) temp))))) (define-inline negative? (syntax-rules () ((negative? ?x) (< ?x 0)))) (define-inline positive? (syntax-rules () ((positive? ?x) (> ?x 0)))) (define-inline eqv? (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (define (constant? exp) (or (boolean? exp) (char? exp) (and (pair? exp) (= (length exp) 2) (identifier? (car exp)) (compare (car exp) (rename 'quote)) (symbol? (cadr exp))))) (if (or (constant? arg1) (constant? arg2)) (cons (rename 'eq?) (cdr exp)) exp))))) (define-inline memq (syntax-rules (quote) ((memq ?expr '(?datum ...)) (letrec-syntax ((memq0 (... (syntax-rules (quote) ((memq0 '?xx '(?d ...)) (let ((t1 '(?d ...))) (memq1 '?xx t1 (?d ...)))) ((memq0 ?e '(?d ...)) (let ((t0 ?e) (t1 '(?d ...))) (memq1 t0 t1 (?d ...))))))) (memq1 (... (syntax-rules () ((memq1 ?t0 ?t1 ()) #f) ((memq1 ?t0 ?t1 (?d1 ?d2 ...)) (if (eq? ?t0 '?d1) ?t1 (let ((?t1 (cdr ?t1))) (memq1 ?t0 ?t1 (?d2 ...))))))))) (memq0 ?expr '(?datum ...)))))) (define-inline memv (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (if (or (boolean? arg1) (fixnum? arg1) (char? arg1) (and (pair? arg1) (= (length arg1) 2) (identifier? (car arg1)) (compare (car arg1) (rename 'quote)) (symbol? (cadr arg1))) (and (pair? arg2) (= (length arg2) 2) (identifier? (car arg2)) (compare (car arg2) (rename 'quote)) (every1? (lambda (x) (or (boolean? x) (fixnum? x) (char? x) (symbol? x))) (cadr arg2)))) (cons (rename 'memq) (cdr exp)) exp))))) (define-inline assv (transformer (lambda (exp rename compare) (let ((arg1 (cadr exp)) (arg2 (caddr exp))) (if (or (boolean? arg1) (char? arg1) (and (pair? arg1) (= (length arg1) 2) (identifier? (car arg1)) (compare (car arg1) (rename 'quote)) (symbol? (cadr arg1))) (and (pair? arg2) (= (length arg2) 2) (identifier? (car arg2)) (compare (car arg2) (rename 'quote)) (every1? (lambda (y) (and (pair? y) (let ((x (car y))) (or (boolean? x) (char? x) (symbol? x))))) (cadr arg2)))) (cons (rename 'assq) (cdr exp)) exp))))) (define-inline map (syntax-rules (lambda) ((map ?proc ?exp1 ?exp2 ...) (letrec-syntax ((loop (... (syntax-rules (lambda) ((loop 1 () (?y1 ?y2 ...) ?f ?exprs) (loop 2 (?y1 ?y2 ...) ?f ?exprs)) ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs) (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs)) ((loop 2 ?ys (lambda ?formals ?body) ?exprs) (loop 3 ?ys (lambda ?formals ?body) ?exprs)) ((loop 2 ?ys (?f1 . ?f2) ?exprs) (let ((f (?f1 . ?f2))) (loop 3 ?ys f ?exprs))) ((loop 2 ?ys ?f ?exprs) (loop 3 ?ys ?f ?exprs)) ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...)) (do ((?y1 ?e1 (cdr ?y1)) (?y2 ?e2 (cdr ?y2)) ... (results '() (cons (?f (car ?y1) (car ?y2) ...) results))) ((or (null? ?y1) (null? ?y2) ...) (reverse results)))))))) (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...)))))) (define-inline for-each (syntax-rules (lambda) ((for-each ?proc ?exp1 ?exp2 ...) (letrec-syntax ((loop (... (syntax-rules (lambda) ((loop 1 () (?y1 ?y2 ...) ?f ?exprs) (loop 2 (?y1 ?y2 ...) ?f ?exprs)) ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs) (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs)) ((loop 2 ?ys (lambda ?formals ?body) ?exprs) (loop 3 ?ys (lambda ?formals ?body) ?exprs)) ((loop 2 ?ys (?f1 . ?f2) ?exprs) (let ((f (?f1 . ?f2))) (loop 3 ?ys f ?exprs))) ((loop 2 ?ys ?f ?exprs) (loop 3 ?ys ?f ?exprs)) ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...)) (do ((?y1 ?e1 (cdr ?y1)) (?y2 ?e2 (cdr ?y2)) ...) ((or (null? ?y1) (null? ?y2) ...) (if #f #f)) (?f (car ?y1) (car ?y2) ...))))))) (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...)))))))))))))))))
+(let () (begin (set! extended-syntactic-environment (syntactic-copy global-syntactic-environment)) 'extended-syntactic-environment))
+(let () (begin (set! make-extended-syntactic-environment (lambda () (let ((.make-extended-syntactic-environment|2 0)) (begin (set! .make-extended-syntactic-environment|2 (lambda () (syntactic-copy extended-syntactic-environment))) (.make-extended-syntactic-environment|2))))) 'make-extended-syntactic-environment))
+(let () (begin (set! instruction.op car) 'instruction.op))
+(let () (begin (set! instruction.arg1 cadr) 'instruction.arg1))
+(let () (begin (set! instruction.arg2 caddr) 'instruction.arg2))
+(let () (begin (set! instruction.arg3 cadddr) 'instruction.arg3))
+(let () (begin (set! *mnemonic-names* '()) '*mnemonic-names*))
+(let () (begin '(define *last-reserved-mnemonic* 32767) '(define make-mnemonic (let ((count 0)) (lambda (name) (set! count (+ count 1)) (if (= count *last-reserved-mnemonic*) (error "Error in make-mnemonic: conflict: " name)) (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*)) count))) '(define (reserved-mnemonic name value) (if (and (> value 0) (< value *last-reserved-mnemonic*)) (set! *last-reserved-mnemonic* value)) (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*)) value) #t))
+(let () (begin (set! make-mnemonic (let ((.count|3 0)) (lambda (.name|4) (begin (set! .count|3 (+ .count|3 1)) (set! *mnemonic-names* (cons (cons .count|3 .name|4) *mnemonic-names*)) .count|3)))) 'make-mnemonic))
+(let () (begin (set! reserved-mnemonic (lambda (.name|1 .ignored|1) (let ((.reserved-mnemonic|2 0)) (begin (set! .reserved-mnemonic|2 (lambda (.name|3 .ignored|3) (make-mnemonic .name|3))) (.reserved-mnemonic|2 .name|1 .ignored|1))))) 'reserved-mnemonic))
+(let () (begin (set! $.linearize (reserved-mnemonic '.linearize -1)) '$.linearize))
+(let () (begin (set! $.label (reserved-mnemonic '.label 63)) '$.label))
+(let () (begin (set! $.proc (reserved-mnemonic '.proc 62)) '$.proc))
+(let () (begin (set! $.cont (reserved-mnemonic '.cont 61)) '$.cont))
+(let () (begin (set! $.align (reserved-mnemonic '.align 60)) '$.align))
+(let () (begin (set! $.asm (reserved-mnemonic '.asm 59)) '$.asm))
+(let () (begin (set! $.proc-doc (reserved-mnemonic '.proc-doc 58)) '$.proc-doc))
+(let () (begin (set! $.end (reserved-mnemonic '.end 57)) '$.end))
+(let () (begin (set! $.singlestep (reserved-mnemonic '.singlestep 56)) '$.singlestep))
+(let () (begin (set! $.entry (reserved-mnemonic '.entry 55)) '$.entry))
+(let () (begin (set! $op1 (make-mnemonic 'op1)) '$op1))
+(let () (begin (set! $op2 (make-mnemonic 'op2)) '$op2))
+(let () (begin (set! $op3 (make-mnemonic 'op3)) '$op3))
+(let () (begin (set! $op2imm (make-mnemonic 'op2imm)) '$op2imm))
+(let () (begin (set! $const (make-mnemonic 'const)) '$const))
+(let () (begin (set! $global (make-mnemonic 'global)) '$global))
+(let () (begin (set! $setglbl (make-mnemonic 'setglbl)) '$setglbl))
+(let () (begin (set! $lexical (make-mnemonic 'lexical)) '$lexical))
+(let () (begin (set! $setlex (make-mnemonic 'setlex)) '$setlex))
+(let () (begin (set! $stack (make-mnemonic 'stack)) '$stack))
+(let () (begin (set! $setstk (make-mnemonic 'setstk)) '$setstk))
+(let () (begin (set! $load (make-mnemonic 'load)) '$load))
+(let () (begin (set! $store (make-mnemonic 'store)) '$store))
+(let () (begin (set! $reg (make-mnemonic 'reg)) '$reg))
+(let () (begin (set! $setreg (make-mnemonic 'setreg)) '$setreg))
+(let () (begin (set! $movereg (make-mnemonic 'movereg)) '$movereg))
+(let () (begin (set! $lambda (make-mnemonic 'lambda)) '$lambda))
+(let () (begin (set! $lexes (make-mnemonic 'lexes)) '$lexes))
+(let () (begin (set! $args= (make-mnemonic 'args=)) '$args=))
+(let () (begin (set! $args>= (make-mnemonic 'args>=)) '$args>=))
+(let () (begin (set! $invoke (make-mnemonic 'invoke)) '$invoke))
+(let () (begin (set! $save (make-mnemonic 'save)) '$save))
+(let () (begin (set! $setrtn (make-mnemonic 'setrtn)) '$setrtn))
+(let () (begin (set! $restore (make-mnemonic 'restore)) '$restore))
+(let () (begin (set! $pop (make-mnemonic 'pop)) '$pop))
+(let () (begin (set! $popstk (make-mnemonic 'popstk)) '$popstk))
+(let () (begin (set! $return (make-mnemonic 'return)) '$return))
+(let () (begin (set! $mvrtn (make-mnemonic 'mvrtn)) '$mvrtn))
+(let () (begin (set! $apply (make-mnemonic 'apply)) '$apply))
+(let () (begin (set! $nop (make-mnemonic 'nop)) '$nop))
+(let () (begin (set! $jump (make-mnemonic 'jump)) '$jump))
+(let () (begin (set! $skip (make-mnemonic 'skip)) '$skip))
+(let () (begin (set! $branch (make-mnemonic 'branch)) '$branch))
+(let () (begin (set! $branchf (make-mnemonic 'branchf)) '$branchf))
+(let () (begin (set! $check (make-mnemonic 'check)) '$check))
+(let () (begin (set! $trap (make-mnemonic 'trap)) '$trap))
+(let () (begin (set! @maxargs-with-rest-arg@ 30) '@maxargs-with-rest-arg@))
+(let () (begin (set! *nregs* 32) '*nregs*))
+(let () (begin (set! *lastreg* (- *nregs* 1)) '*lastreg*))
+(let () (begin (set! *fullregs* (quotient *nregs* 2)) '*fullregs*))
+(let () (begin (set! *nhwregs* 8) '*nhwregs*))
+(let () (begin (set! *regnames* (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.alist|8 .r|8) (if (<= .r|8 0) .alist|8 (begin #t (.loop|1|4|7 (cons (cons (string->symbol (string-append ".REG" (number->string .r|8))) .r|8) .alist|8) (- .r|8 1)))))) (.loop|1|4|7 '() (- *nhwregs* 1)))))) '*regnames*))
+(let () (begin (set! *number-of-mnemonics* 72) '*number-of-mnemonics*))
+(let () (begin (set! prim-entry (lambda (.name|1) (let ((.prim-entry|2 0)) (begin (set! .prim-entry|2 (lambda (.name|3) (assq .name|3 $usual-integrable-procedures$))) (.prim-entry|2 .name|1))))) 'prim-entry))
+(let () (begin (set! prim-arity cadr) 'prim-arity))
+(let () (begin (set! prim-opcodename caddr) 'prim-opcodename))
+(let () (begin (set! prim-immediate? cadddr) 'prim-immediate?))
+(let () (begin (set! prim-primcode (lambda (.entry|1) (let ((.prim-primcode|2 0)) (begin (set! .prim-primcode|2 (lambda (.entry|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.prim-primcode|2 .entry|1))))) 'prim-primcode))
+(let () (begin (set! smallint? (let* ((.least|3 (- 0 (expt 2 29))) (.greatest|6 (- (- 0 .least|3) 1))) (let () (lambda (.x|10) (if (number? .x|10) (if (exact? .x|10) (if (integer? .x|10) (let ((.t|15|18 .x|10)) (if (<= .least|3 .t|15|18) (<= .t|15|18 .greatest|6) #f)) #f) #f) #f))))) 'smallint?))
+(let () (begin (set! sparc-imm? (lambda (.x|1) (let ((.sparc-imm?|2 0)) (begin (set! .sparc-imm?|2 (lambda (.x|3) (if (fixnum? .x|3) (let ((.t|6|9 .x|3)) (if (<= -1024 .t|6|9) (<= .t|6|9 1023) #f)) #f))) (.sparc-imm?|2 .x|1))))) 'sparc-imm?))
+(let () (begin (set! sparc-eq-imm? (lambda (.x|1) (let ((.sparc-eq-imm?|2 0)) (begin (set! .sparc-eq-imm?|2 (lambda (.x|3) (let ((.temp|4|7 (sparc-imm? .x|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (eq? .x|3 #t))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (eq? .x|3 #f))) (if .temp|12|15 .temp|12|15 (eq? .x|3 '()))))))))) (.sparc-eq-imm?|2 .x|1))))) 'sparc-eq-imm?))
+(let () (begin (set! valid-typetag? (lambda (.x|1) (let ((.valid-typetag?|2 0)) (begin (set! .valid-typetag?|2 (lambda (.x|3) (if (fixnum? .x|3) (let ((.t|6|9 .x|3)) (if (<= 0 .t|6|9) (<= .t|6|9 7) #f)) #f))) (.valid-typetag?|2 .x|1))))) 'valid-typetag?))
+(let () (begin (set! fixnum-primitives (lambda () (let ((.fixnum-primitives|2 0)) (begin (set! .fixnum-primitives|2 (lambda () #t)) (.fixnum-primitives|2))))) 'fixnum-primitives))
+(let () (begin (set! flonum-primitives (lambda () (let ((.flonum-primitives|2 0)) (begin (set! .flonum-primitives|2 (lambda () #t)) (.flonum-primitives|2))))) 'flonum-primitives))
+(let () (begin (set! prim-lives-until (lambda (.entry|1) (let ((.prim-lives-until|2 0)) (begin (set! .prim-lives-until|2 (lambda (.entry|3) (list-ref .entry|3 5))) (.prim-lives-until|2 .entry|1))))) 'prim-lives-until))
+(let () (begin (set! prim-kills (lambda (.entry|1) (let ((.prim-kills|2 0)) (begin (set! .prim-kills|2 (lambda (.entry|3) (list-ref .entry|3 6))) (.prim-kills|2 .entry|1))))) 'prim-kills))
+(let () (begin (set! $usual-integrable-procedures$ (let ((.:globals|3 available:killer:globals) (.:car|3 available:killer:car) (.:cdr|3 available:killer:cdr) (.:string|3 available:killer:string) (.:vector|3 available:killer:vector) (.:cell|3 available:killer:cell) (.:io|3 available:killer:io) (.:none|3 available:killer:none) (.:all|3 available:killer:all) (.:immortal|3 available:killer:immortal) (.:dead|3 available:killer:dead)) (.cons (.cons 'break (.cons 0 (.cons 'break (.cons #f (.cons 3 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'creg (.cons 0 (.cons 'creg (.cons #f (.cons 7 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'unspecified (.cons 0 (.cons 'unspecified (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'undefined (.cons 0 (.cons 'undefined (.cons #f (.cons 8 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eof-object (.cons 0 (.cons 'eof-object (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'enable-interrupts (.cons 1 (.cons 'enable-interrupts (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'disable-interrupts (.cons 0 (.cons 'disable-interrupts (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'typetag (.cons 1 (.cons 'typetag (.cons #f (.cons 17 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'not (.cons 1 (.cons 'not (.cons #f (.cons 24 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'null? (.cons 1 (.cons 'null? (.cons #f (.cons 25 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'pair? (.cons 1 (.cons 'pair? (.cons #f (.cons 26 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eof-object? (.cons 1 (.cons 'eof-object? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'port? (.cons 1 (.cons 'port? (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'structure? (.cons 1 (.cons 'structure? (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'car (.cons 1 (.cons 'car (.cons #f (.cons 27 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons name:car (.cons 1 (.cons 'car (.cons #f (.cons 27 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cdr (.cons 1 (.cons 'cdr (.cons #f (.cons 28 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cdr (.cons 1 (.cons 'cdr (.cons #f (.cons 28 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons 'symbol? (.cons 1 (.cons 'symbol? (.cons #f (.cons 31 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'number? (.cons 1 (.cons 'complex? (.cons #f (.cons 32 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'complex? (.cons 1 (.cons 'complex? (.cons #f (.cons 32 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'real? (.cons 1 (.cons 'rational? (.cons #f (.cons 33 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rational? (.cons 1 (.cons 'rational? (.cons #f (.cons 33 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'integer? (.cons 1 (.cons 'integer? (.cons #f (.cons 34 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fixnum? (.cons 1 (.cons 'fixnum? (.cons #f (.cons 35 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'flonum? (.cons 1 (.cons 'flonum? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'compnum? (.cons 1 (.cons 'compnum? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'exact? (.cons 1 (.cons 'exact? (.cons #f (.cons 36 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'inexact? (.cons 1 (.cons 'inexact? (.cons #f (.cons 37 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'exact->inexact (.cons 1 (.cons 'exact->inexact (.cons #f (.cons 38 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'inexact->exact (.cons 1 (.cons 'inexact->exact (.cons #f (.cons 39 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'round (.cons 1 (.cons 'round (.cons #f (.cons 40 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'truncate (.cons 1 (.cons 'truncate (.cons #f (.cons 41 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'zero? (.cons 1 (.cons 'zero? (.cons #f (.cons 44 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '-- (.cons 1 (.cons '-- (.cons #f (.cons 45 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'lognot (.cons 1 (.cons 'lognot (.cons #f (.cons 47 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'real-part (.cons 1 (.cons 'real-part (.cons #f (.cons 62 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'imag-part (.cons 1 (.cons 'imag-part (.cons #f (.cons 63 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char? (.cons 1 (.cons 'char? (.cons #f (.cons 64 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char->integer (.cons 1 (.cons 'char->integer (.cons #f (.cons 65 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'integer->char (.cons 1 (.cons 'integer->char (.cons #f (.cons 66 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string? (.cons 1 (.cons 'string? (.cons #f (.cons 80 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-length (.cons 1 (.cons 'string-length (.cons #f (.cons 81 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector? (.cons 1 (.cons 'vector? (.cons #f (.cons 82 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-length (.cons 1 (.cons 'vector-length (.cons #f (.cons 83 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector? (.cons 1 (.cons 'bytevector? (.cons #f (.cons 84 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-length (.cons 1 (.cons 'bytevector-length (.cons #f (.cons 85 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-fill! (.cons 2 (.cons 'bytevector-fill! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'make-bytevector (.cons 1 (.cons 'make-bytevector (.cons #f (.cons 86 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure? (.cons 1 (.cons 'procedure? (.cons #f (.cons 88 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure-length (.cons 1 (.cons 'procedure-length (.cons #f (.cons 89 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'make-procedure (.cons 1 (.cons 'make-procedure (.cons #f (.cons 90 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'creg-set! (.cons 1 (.cons 'creg-set! (.cons #f (.cons 113 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:make-cell (.cons 1 (.cons 'make-cell (.cons #f (.cons 126 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cell-ref (.cons 1 (.cons 'cell-ref (.cons #f (.cons 127 (.cons .:cell|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cell-set! (.cons 2 (.cons 'cell-set! (.cons #f (.cons 223 (.cons .:dead|3 (.cons .:cell|3 '()))))))) (.cons (.cons 'typetag-set! (.cons 2 (.cons 'typetag-set! (.cons valid-typetag? (.cons 160 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'eq? (.cons 2 (.cons 'eq? (.cons sparc-eq-imm? (.cons 161 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'eqv? (.cons 2 (.cons 'eqv? (.cons #f (.cons 162 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cons (.cons 2 (.cons 'cons (.cons #f (.cons 168 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons name:cons (.cons 2 (.cons 'cons (.cons #f (.cons 168 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'set-car! (.cons 2 (.cons 'set-car! (.cons #f (.cons 169 (.cons .:dead|3 (.cons .:car|3 '()))))))) (.cons (.cons 'set-cdr! (.cons 2 (.cons 'set-cdr! (.cons #f (.cons 170 (.cons .:dead|3 (.cons .:cdr|3 '()))))))) (.cons (.cons '+ (.cons 2 (.cons '+ (.cons sparc-imm? (.cons 176 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '- (.cons 2 (.cons '- (.cons sparc-imm? (.cons 177 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '* (.cons 2 (.cons '* (.cons sparc-imm? (.cons 178 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '/ (.cons 2 (.cons '/ (.cons #f (.cons 179 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'quotient (.cons 2 (.cons 'quotient (.cons #f (.cons 180 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '< (.cons 2 (.cons '< (.cons sparc-imm? (.cons 181 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<= (.cons 2 (.cons '<= (.cons sparc-imm? (.cons 182 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '= (.cons 2 (.cons '= (.cons sparc-imm? (.cons 183 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '> (.cons 2 (.cons '> (.cons sparc-imm? (.cons 184 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>= (.cons 2 (.cons '>= (.cons sparc-imm? (.cons 185 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logand (.cons 2 (.cons 'logand (.cons #f (.cons 192 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logior (.cons 2 (.cons 'logior (.cons #f (.cons 193 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'logxor (.cons 2 (.cons 'logxor (.cons #f (.cons 194 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'lsh (.cons 2 (.cons 'lsh (.cons #f (.cons 195 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rsha (.cons 2 (.cons 'rsha (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rshl (.cons 2 (.cons 'rshl (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'rot (.cons 2 (.cons 'rot (.cons #f (.cons 196 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'make-string (.cons 2 (.cons 'make-string (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-ref (.cons 2 (.cons 'string-ref (.cons sparc-imm? (.cons 209 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'string-set! (.cons 3 (.cons 'string-set! (.cons sparc-imm? (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'make-vector (.cons 2 (.cons 'make-vector (.cons #f (.cons 210 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-ref (.cons 2 (.cons 'vector-ref (.cons sparc-imm? (.cons 211 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-ref (.cons 2 (.cons 'bytevector-ref (.cons sparc-imm? (.cons 213 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'procedure-ref (.cons 2 (.cons 'procedure-ref (.cons #f (.cons 215 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char<? (.cons 2 (.cons 'char<? (.cons char? (.cons 224 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char<=? (.cons 2 (.cons 'char<=? (.cons char? (.cons 225 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char=? (.cons 2 (.cons 'char=? (.cons char? (.cons 226 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char>? (.cons 2 (.cons 'char>? (.cons char? (.cons 227 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'char>=? (.cons 2 (.cons 'char>=? (.cons char? (.cons 228 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'sys$partial-list->vector (.cons 2 (.cons 'sys$partial-list->vector (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'vector-set! (.cons 3 (.cons 'vector-set! (.cons #f (.cons 241 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'bytevector-set! (.cons 3 (.cons 'bytevector-set! (.cons #f (.cons 242 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'procedure-set! (.cons 3 (.cons 'procedure-set! (.cons #f (.cons 243 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'bytevector-like? (.cons 1 (.cons 'bytevector-like? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-like? (.cons 1 (.cons 'vector-like? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-ref (.cons 2 (.cons 'bytevector-like-ref (.cons #f (.cons -1 (.cons .:string|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-set! (.cons 3 (.cons 'bytevector-like-set! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:string|3 '()))))))) (.cons (.cons 'sys$bvlcmp (.cons 2 (.cons 'sys$bvlcmp (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:all|3 '()))))))) (.cons (.cons 'vector-like-ref (.cons 2 (.cons 'vector-like-ref (.cons #f (.cons -1 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-like-set! (.cons 3 (.cons 'vector-like-set! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'vector-like-length (.cons 1 (.cons 'vector-like-length (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'bytevector-like-length (.cons 1 (.cons 'bytevector-like-length (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'remainder (.cons 2 (.cons 'remainder (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'sys$read-char (.cons 1 (.cons 'sys$read-char (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:io|3 '()))))))) (.cons (.cons 'gc-counter (.cons 0 (.cons 'gc-counter (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (append (if (fixnum-primitives) (.cons (.cons 'most-positive-fixnum (.cons 0 (.cons 'most-positive-fixnum (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'most-negative-fixnum (.cons 0 (.cons 'most-negative-fixnum (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx+ (.cons 2 (.cons 'fx+ (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx- (.cons 2 (.cons 'fx- (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx-- (.cons 1 (.cons 'fx-- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx* (.cons 2 (.cons 'fx* (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx= (.cons 2 (.cons 'fx= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx< (.cons 2 (.cons 'fx< (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx<= (.cons 2 (.cons 'fx<= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx> (.cons 2 (.cons 'fx> (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fx>= (.cons 2 (.cons 'fx>= (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxzero? (.cons 1 (.cons 'fxzero? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxpositive? (.cons 1 (.cons 'fxpositive? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fxnegative? (.cons 1 (.cons 'fxnegative? (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '())))))))))))))) '()) (append (if (flonum-primitives) (.cons (.cons 'fl+ (.cons 2 (.cons '+ (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl- (.cons 2 (.cons '- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl-- (.cons 1 (.cons '-- (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl* (.cons 2 (.cons '* (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl= (.cons 2 (.cons '= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl< (.cons 2 (.cons '< (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl<= (.cons 2 (.cons '<= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl> (.cons 2 (.cons '> (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'fl>= (.cons 2 (.cons '>= (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '()))))))))) '()) (.cons (.cons name:check! (.cons -1 (.cons 'check! (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-length:vec (.cons 1 (.cons 'vector-length:vec (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-ref:trusted (.cons 2 (.cons 'vector-ref:trusted (.cons sparc-imm? (.cons -1 (.cons .:vector|3 (.cons .:none|3 '()))))))) (.cons (.cons 'vector-set!:trusted (.cons 3 (.cons 'vector-set!:trusted (.cons #f (.cons -1 (.cons .:dead|3 (.cons .:vector|3 '()))))))) (.cons (.cons 'car:pair (.cons 1 (.cons 'car:pair (.cons #f (.cons -1 (.cons .:car|3 (.cons .:none|3 '()))))))) (.cons (.cons 'cdr:pair (.cons 1 (.cons 'cdr:pair (.cons #f (.cons -1 (.cons .:cdr|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:fix:fix (.cons 2 (.cons '=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<:fix:fix (.cons 2 (.cons '<:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '<=:fix:fix (.cons 2 (.cons '<=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>=:fix:fix (.cons 2 (.cons '>=:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '>:fix:fix (.cons 2 (.cons '>:fix:fix (.cons sparc-imm? (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:idx:idx (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:fix:fix (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:exi:exi (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '+:flo:flo (.cons 2 (.cons '+:idx:idx (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:flo:flo (.cons 2 (.cons '=:flo:flo (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:obj:flo (.cons 2 (.cons '=:obj:flo (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) (.cons (.cons '=:flo:obj (.cons 2 (.cons '=:flo:obj (.cons #f (.cons -1 (.cons .:immortal|3 (.cons .:none|3 '()))))))) '())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) '$usual-integrable-procedures$))
+(let () (begin (set! $immediate-primops$ '((typetag-set! 128) (eq? 129) (+ 130) (- 131) (< 132) (<= 133) (= 134) (> 135) (>= 136) (char<? 137) (char<=? 138) (char=? 139) (char>? 140) (char>=? 141) (string-ref 144) (vector-ref 145) (bytevector-ref 146) (bytevector-like-ref -1) (vector-like-ref -1) (fx+ -1) (fx- -1) (fx-- -1) (fx= -1) (fx< -1) (fx<= -1) (fx> -1) (fx>= -1))) '$immediate-primops$))
+(let () (begin (set! $reg/op1/branchf (make-mnemonic 'reg/op1/branchf)) '$reg/op1/branchf))
+(let () (begin (set! $reg/op2/branchf (make-mnemonic 'reg/op2/branchf)) '$reg/op2/branchf))
+(let () (begin (set! $reg/op2imm/branchf (make-mnemonic 'reg/op2imm/branchf)) '$reg/op2imm/branchf))
+(let () (begin (set! $reg/op1/check (make-mnemonic 'reg/op1/check)) '$reg/op1/check))
+(let () (begin (set! $reg/op2/check (make-mnemonic 'reg/op2/check)) '$reg/op2/check))
+(let () (begin (set! $reg/op2imm/check (make-mnemonic 'reg/op2imm/check)) '$reg/op2imm/check))
+(let () (begin (set! $reg/op1/setreg (make-mnemonic 'reg/op1/setreg)) '$reg/op1/setreg))
+(let () (begin (set! $reg/op2/setreg (make-mnemonic 'reg/op2/setreg)) '$reg/op2/setreg))
+(let () (begin (set! $reg/op2imm/setreg (make-mnemonic 'reg/op2imm/setreg)) '$reg/op2imm/setreg))
+(let () (begin (set! $reg/branchf (make-mnemonic 'reg/branchf)) '$reg/branchf))
+(let () (begin (set! $reg/return (make-mnemonic 'reg/return)) '$reg/return))
+(let () (begin (set! $reg/setglbl (make-mnemonic 'reg/setglbl)) '$reg/setglbl))
+(let () (begin (set! $reg/op3 (make-mnemonic 'reg/op3)) '$reg/op3))
+(let () (begin (set! $const/setreg (make-mnemonic 'const/setreg)) '$const/setreg))
+(let () (begin (set! $const/return (make-mnemonic 'const/return)) '$const/return))
+(let () (begin (set! $global/setreg (make-mnemonic 'global/setreg)) '$global/setreg))
+(let () (begin (set! $setrtn/branch (make-mnemonic 'setrtn/branch)) '$setrtn/branch))
+(let () (begin (set! $setrtn/invoke (make-mnemonic 'setrtn/invoke)) '$setrtn/invoke))
+(let () (begin (set! $global/invoke (make-mnemonic 'global/invoke)) '$global/invoke))
+(let () (begin (set! $cons 'cons) '$cons))
+(let () (begin (set! $car:pair 'car) '$car:pair))
+(let () (begin (set! $cdr:pair 'cdr) '$cdr:pair))
+(let () (define-subtype 'true 'object))
+(let () (define-subtype 'eqtype 'object))
+(let () (define-subtype 'nonpointer 'eqtype))
+(let () (define-subtype 'eqtype1 'eqtype))
+(let () (define-subtype 'boolean 'nonpointer))
+(let () (define-subtype 'truth 'eqtype1))
+(let () (define-subtype 'truth 'boolean))
+(let () (define-subtype 'false 'boolean))
+(let () (define-subtype 'eqtype1 'true))
+(let () (define-subtype 'procedure 'true))
+(let () (define-subtype 'vector 'true))
+(let () (define-subtype 'bytevector 'true))
+(let () (define-subtype 'string 'true))
+(let () (define-subtype 'pair 'true))
+(let () (define-subtype 'emptylist 'eqtype1))
+(let () (define-subtype 'emptylist 'nonpointer))
+(let () (define-subtype 'symbol 'eqtype1))
+(let () (define-subtype 'char 'eqtype1))
+(let () (define-subtype 'char 'nonpointer))
+(let () (define-subtype 'number 'true))
+(let () (define-subtype 'inexact 'number))
+(let () (define-subtype 'flonum 'inexact))
+(let () (define-subtype 'integer 'number))
+(let () (define-subtype 'exact 'number))
+(let () (define-subtype 'exactint 'integer))
+(let () (define-subtype 'exactint 'exact))
+(let () (define-subtype 'fixnum 'exactint))
+(let () (define-subtype '!fixnum 'fixnum))
+(let () (define-subtype 'fixnum! 'fixnum))
+(let () (define-subtype 'index '!fixnum))
+(let () (define-subtype 'index 'fixnum!))
+(let () (define-subtype 'zero 'index))
+(let () (define-subtype 'fixnum 'eqtype1))
+(let () (define-subtype 'fixnum 'nonpointer))
+(let () (compute-type-structure!))
+(let () (define-intersection 'true 'eqtype 'eqtype1))
+(let () (define-intersection 'true 'boolean 'truth))
+(let () (define-intersection 'exact 'integer 'exactint))
+(let () (define-intersection '!fixnum 'fixnum! 'index))
+(let () (begin (set! rep:min_fixnum (- 0 (expt 2 29))) 'rep:min_fixnum))
+(let () (begin (set! rep:max_fixnum (- (expt 2 29) 1)) 'rep:max_fixnum))
+(let () (begin (set! rep:max_index (- (expt 2 24) 1)) 'rep:max_index))
+(let () (begin (set! rep:object (symbol->rep 'object)) 'rep:object))
+(let () (begin (set! rep:true (symbol->rep 'true)) 'rep:true))
+(let () (begin (set! rep:truth (symbol->rep 'truth)) 'rep:truth))
+(let () (begin (set! rep:false (symbol->rep 'false)) 'rep:false))
+(let () (begin (set! rep:boolean (symbol->rep 'boolean)) 'rep:boolean))
+(let () (begin (set! rep:pair (symbol->rep 'pair)) 'rep:pair))
+(let () (begin (set! rep:symbol (symbol->rep 'symbol)) 'rep:symbol))
+(let () (begin (set! rep:number (symbol->rep 'number)) 'rep:number))
+(let () (begin (set! rep:zero (symbol->rep 'zero)) 'rep:zero))
+(let () (begin (set! rep:index (symbol->rep 'index)) 'rep:index))
+(let () (begin (set! rep:fixnum (symbol->rep 'fixnum)) 'rep:fixnum))
+(let () (begin (set! rep:exactint (symbol->rep 'exactint)) 'rep:exactint))
+(let () (begin (set! rep:flonum (symbol->rep 'flonum)) 'rep:flonum))
+(let () (begin (set! rep:exact (symbol->rep 'exact)) 'rep:exact))
+(let () (begin (set! rep:inexact (symbol->rep 'inexact)) 'rep:inexact))
+(let () (begin (set! rep:integer (symbol->rep 'integer)) 'rep:integer))
+(let () (begin (set! rep:char (symbol->rep 'char)) 'rep:char))
+(let () (begin (set! rep:string (symbol->rep 'string)) 'rep:string))
+(let () (begin (set! rep:vector (symbol->rep 'vector)) 'rep:vector))
+(let () (begin (set! rep:procedure (symbol->rep 'procedure)) 'rep:procedure))
+(let () (begin (set! rep:bottom (symbol->rep 'bottom)) 'rep:bottom))
+(let () (begin (set! representation-of-value (lambda (.x|1) (let ((.representation-of-value|2 0)) (begin (set! .representation-of-value|2 (lambda (.x|3) (if (boolean? .x|3) (if .x|3 rep:truth rep:false) (if (pair? .x|3) rep:pair (if (symbol? .x|3) rep:symbol (if (number? .x|3) (if (if (exact? .x|3) (integer? .x|3) #f) (if (zero? .x|3) rep:zero (if (let ((.t|13|16 .x|3)) (if (<= 0 .t|13|16) (<= .t|13|16 rep:max_index) #f)) rep:index (if (let ((.t|20|23 .x|3)) (if (<= rep:min_fixnum .t|20|23) (<= .t|20|23 rep:max_fixnum) #f)) rep:fixnum rep:exactint))) (if (if (inexact? .x|3) (real? .x|3) #f) rep:flonum rep:number)) (if (char? .x|3) rep:char (if (string? .x|3) rep:string (if (vector? .x|3) rep:vector rep:true))))))))) (.representation-of-value|2 .x|1))))) 'representation-of-value))
+(let () (begin (set! rep-specific (representation-table '((= (fixnum fixnum) =:fix:fix) (< (fixnum fixnum) <:fix:fix) (<= (fixnum fixnum) <=:fix:fix) (> (fixnum fixnum) >:fix:fix) (>= (fixnum fixnum) >=:fix:fix)))) 'rep-specific))
+(let () (begin (set! rep-result (representation-table '((fixnum? (fixnum) (truth)) (vector? (vector) (truth)) (<= (zero !fixnum) (truth)) (>= (!fixnum zero) (truth)) (<=:fix:fix (zero !fixnum) (truth)) (>=:fix:fix (!fixnum zero) (truth)) (+ (index index) (!fixnum)) (+ (fixnum fixnum) (exactint)) (- (index index) (fixnum!)) (- (fixnum fixnum) (exactint)) (+ (flonum flonum) (flonum)) (- (flonum flonum) (flonum)) (make-vector (object object) (vector)) (vector-length:vec (vector) (index)) (cons (object object) (pair)) (= (number number) (boolean)) (< (number number) (boolean)) (<= (number number) (boolean)) (> (number number) (boolean)) (>= (number number) (boolean)) (=:fix:fix (fixnum fixnum) (boolean)) (<:fix:fix (fixnum fixnum) (boolean)) (<=:fix:fix (fixnum fixnum) (boolean)) (>:fix:fix (fixnum fixnum) (boolean)) (>=:fix:fix (fixnum fixnum) (boolean))))) 'rep-result))
+(let () (begin (set! rep-informing (representation-table '((fixnum? (object) (fixnum) (object)) (flonum? (object) (flonum) (object)) (vector? (object) (vector) (object)) (pair? (object) (pair) (object)) (= (exactint index) (index index) (exactint index)) (= (index exactint) (index index) (index exactint)) (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum)) (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint)) (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!)) (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint)) (< (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (< (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (> (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (> (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (=:fix:fix (exactint index) (index index) (exactint index)) (=:fix:fix (index exactint) (index index) (index exactint)) (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum)) (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint)) (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!)) (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint)) (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!)) (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index)) (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!)) (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum)) (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum)) (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index)) (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum)) (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!)) (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))))) 'rep-informing))
+(let () (begin (set! pass2 (lambda (.exp|1) (let ((.pass2|2 0)) (begin (set! .pass2|2 (lambda (.exp|3) (simplify .exp|3 (make-notepad #f)))) (.pass2|2 .exp|1))))) 'pass2))
+(let () (begin (set! simplify (lambda (.exp|1 .notepad|1) (let ((.simplify|2 0)) (begin (set! .simplify|2 (lambda (.exp|3 .notepad|3) (let ((.temp|4|7 (let ((.x|14|17 .exp|3)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (if (memv .temp|4|7 '(quote)) .exp|3 (if (memv .temp|4|7 '(lambda)) (simplify-lambda .exp|3 .notepad|3) (if (memv .temp|4|7 '(set!)) (simplify-assignment .exp|3 .notepad|3) (if (memv .temp|4|7 '(if)) (simplify-conditional .exp|3 .notepad|3) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (begin (notepad-var-add! .notepad|3 (variable.name .exp|3)) .exp|3) (simplify-sequential .exp|3 .notepad|3)) (simplify-call .exp|3 .notepad|3))))))))) (.simplify|2 .exp|1 .notepad|1))))) 'simplify))
+(let () (begin (set! simplify-lambda (lambda (.exp|1 .notepad|1) (let ((.simplify-lambda|2 0)) (begin (set! .simplify-lambda|2 (lambda (.exp|3 .notepad|3) (begin (notepad-lambda-add! .notepad|3 .exp|3) (let ((.defs|6 (lambda.defs .exp|3)) (.body|6 (lambda.body .exp|3)) (.newnotepad|6 (make-notepad .exp|3))) (begin (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|7|8|18) (if (null? .y1|7|8|18) (if #f #f (unspecified)) (begin (begin #t (let ((.def|22 (let ((.x|23|26 .y1|7|8|18)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (.simplify-lambda|2 (def.rhs .def|22) .newnotepad|6))) (.loop|12|14|17 (let ((.x|27|30 .y1|7|8|18)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))))))) (.loop|12|14|17 .defs|6)))) (lambda.body-set! .exp|3 (simplify .body|6 .newnotepad|6)) (lambda.f-set! .exp|3 (notepad-free-variables .newnotepad|6)) (lambda.g-set! .exp|3 (notepad-captured-variables .newnotepad|6)) (single-assignment-analysis .exp|3 .newnotepad|6) (let ((.known-lambdas|33 (notepad.nonescaping .newnotepad|6))) (let () (let ((.loop|39|41|44 (unspecified))) (begin (set! .loop|39|41|44 (lambda (.y1|34|35|45) (if (null? .y1|34|35|45) (if #f #f (unspecified)) (begin (begin #t (let ((.l|49 (let ((.x|50|53 .y1|34|35|45)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memq .l|49 .known-lambdas|33) (lambda-lifting .l|49 .exp|3) (lambda-lifting .l|49 .l|49)))) (.loop|39|41|44 (let ((.x|54|57 .y1|34|35|45)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))))))) (.loop|39|41|44 (notepad.lambdas .newnotepad|6)))))))) (single-assignment-elimination .exp|3 .notepad|3) (assignment-elimination .exp|3) (if (not (notepad.parent .notepad|3)) (lambda-lifting .exp|3 .exp|3) (unspecified)) .exp|3))) (.simplify-lambda|2 .exp|1 .notepad|1))))) 'simplify-lambda))
+(let () (begin (set! simplify-assignment (lambda (.exp|1 .notepad|1) (let ((.simplify-assignment|2 0)) (begin (set! .simplify-assignment|2 (lambda (.exp|3 .notepad|3) (begin (notepad-var-add! .notepad|3 (assignment.lhs .exp|3)) (let ((.rhs|6 (simplify (assignment.rhs .exp|3) .notepad|3))) (if (begin? .rhs|6) (let ((.exprs|10 (reverse (begin.exprs .rhs|6)))) (begin (assignment.rhs-set! .exp|3 (let ((.x|11|14 .exprs|10)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14)))) (post-simplify-begin (make-begin (reverse (cons .exp|3 (let ((.x|15|18 .exprs|10)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18)))))) .notepad|3))) (begin (assignment.rhs-set! .exp|3 .rhs|6) .exp|3)))))) (.simplify-assignment|2 .exp|1 .notepad|1))))) 'simplify-assignment))
+(let () (begin (set! simplify-sequential (lambda (.exp|1 .notepad|1) (let ((.simplify-sequential|2 0)) (begin (set! .simplify-sequential|2 (lambda (.exp|3 .notepad|3) (let ((.exprs|6 (let () (let ((.loop|12|15|18 (unspecified))) (begin (set! .loop|12|15|18 (lambda (.y1|7|8|19 .results|7|11|19) (if (null? .y1|7|8|19) (reverse .results|7|11|19) (begin #t (.loop|12|15|18 (let ((.x|23|26 .y1|7|8|19)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26))) (cons (let ((.exp|27 (let ((.x|28|31 .y1|7|8|19)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (simplify .exp|27 .notepad|3)) .results|7|11|19)))))) (.loop|12|15|18 (begin.exprs .exp|3) '())))))) (begin (begin.exprs-set! .exp|3 .exprs|6) (post-simplify-begin .exp|3 .notepad|3))))) (.simplify-sequential|2 .exp|1 .notepad|1))))) 'simplify-sequential))
+(let () (begin (set! post-simplify-begin (lambda (.exp|1 .notepad|1) (let ((.post-simplify-begin|2 0)) (begin (set! .post-simplify-begin|2 (lambda (.exp|3 .notepad|3) (let ((.unspecified-expression|6 (make-unspecified))) (let ((.filter|9 (unspecified)) (.flatten|9 (unspecified))) (begin (set! .filter|9 (lambda (.exprs|10 .filtered|10) (if (null? .exprs|10) .filtered|10 (let ((.exp|13 (let ((.x|39|42 .exprs|10)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))))) (if (constant? .exp|13) (.filter|9 (let ((.x|15|18 .exprs|10)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) .filtered|10) (if (variable? .exp|13) (.filter|9 (let ((.x|20|23 .exprs|10)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) .filtered|10) (if (lambda? .exp|13) (begin (notepad.lambdas-set! .notepad|3 (remq .exp|13 (notepad.lambdas .notepad|3))) (.filter|9 (let ((.x|25|28 .exprs|10)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .filtered|10)) (if (equal? .exp|13 .unspecified-expression|6) (.filter|9 (let ((.x|30|33 .exprs|10)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) .filtered|10) (.filter|9 (let ((.x|35|38 .exprs|10)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (cons .exp|13 .filtered|10)))))))))) (set! .flatten|9 (lambda (.exprs|43 .flattened|43) (if (null? .exprs|43) .flattened|43 (if (begin? (let ((.x|46|49 .exprs|43)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))) (.flatten|9 (let ((.x|50|53 .exprs|43)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53))) (.flatten|9 (begin.exprs (let ((.x|54|57 .exprs|43)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) .flattened|43)) (.flatten|9 (let ((.x|59|62 .exprs|43)) (begin (.check! (pair? .x|59|62) 1 .x|59|62) (cdr:pair .x|59|62))) (cons (let ((.x|63|66 .exprs|43)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))) .flattened|43)))))) (let ((.exprs|67 (.flatten|9 (begin.exprs .exp|3) '()))) (begin (begin.exprs-set! .exp|3 (.filter|9 (let ((.x|68|71 .exprs|67)) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))) (cons (let ((.x|73|76 .exprs|67)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76))) '()))) (if (null? (let ((.x|77|80 (begin.exprs .exp|3))) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80)))) (let ((.x|81|84 (begin.exprs .exp|3))) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))) .exp|3)))))))) (.post-simplify-begin|2 .exp|1 .notepad|1))))) 'post-simplify-begin))
+(let () (begin (set! simplify-call (lambda (.exp|1 .notepad|1) (let ((.simplify-call|2 0)) (begin (set! .simplify-call|2 (lambda (.exp|3 .notepad|3) (let ((.finish|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .finish|4 (lambda (.newargs|5 .exprs|5) (begin (call.args-set! .exp|3 (reverse .newargs|5)) (let* ((.newexp|8 (if (lambda? (call.proc .exp|3)) (simplify-let .exp|3 .notepad|3) (begin (call.proc-set! .exp|3 (simplify (call.proc .exp|3) .notepad|3)) .exp|3))) (.newexp|11 (if (if (call? .newexp|8) (variable? (call.proc .newexp|8)) #f) (let* ((.procname|35 (variable.name (call.proc .newexp|8))) (.args|38 (call.args .newexp|8)) (.entry|41 (if (not (null? .args|38)) (if (constant? (let ((.x|71|74 .args|38)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74)))) (if (integrate-usual-procedures) (if (every? constant? .args|38) (let ((.entry|80 (constant-folding-entry .procname|35))) (if .entry|80 (let ((.predicates|85 (constant-folding-predicates .entry|80))) (if (= (length .args|38) (length .predicates|85)) (let ((.args|90 .args|38) (.predicates|90 .predicates|85)) (let () (let ((.loop|93 (unspecified))) (begin (set! .loop|93 (lambda (.args|94 .predicates|94) (if (null? .args|94) .entry|80 (if ((let ((.x|97|100 .predicates|94)) (begin (.check! (pair? .x|97|100) 0 .x|97|100) (car:pair .x|97|100))) (constant.value (let ((.x|101|104 .args|94)) (begin (.check! (pair? .x|101|104) 0 .x|101|104) (car:pair .x|101|104))))) (.loop|93 (let ((.x|105|108 .args|94)) (begin (.check! (pair? .x|105|108) 1 .x|105|108) (cdr:pair .x|105|108))) (let ((.x|109|112 .predicates|94)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112)))) #f)))) (.loop|93 .args|90 .predicates|90))))) #f)) #f)) #f) #f) #f) #f))) (let () (if .entry|41 (make-constant (apply (constant-folding-folder .entry|41) (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (constant.value (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .args|38 '())))))) .newexp|8))) .newexp|8))) (let () (if (if (call? .newexp|11) (begin? (call.proc .newexp|11)) #f) (let ((.exprs0|20 (reverse (begin.exprs (call.proc .newexp|11))))) (begin (call.proc-set! .newexp|11 (let ((.x|21|24 .exprs0|20)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24)))) (post-simplify-begin (make-begin (reverse (cons .newexp|11 (append (let ((.x|25|28 .exprs0|20)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .exprs|5)))) .notepad|3))) (if (null? .exprs|5) .newexp|11 (post-simplify-begin (make-begin (reverse (cons .newexp|11 .exprs|5))) .notepad|3)))))))) (set! .loop|4 (lambda (.args|114 .newargs|114 .exprs|114) (if (null? .args|114) (.finish|4 .newargs|114 .exprs|114) (if (begin? (let ((.x|117|120 .args|114)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120)))) (let ((.newexprs|123 (reverse (begin.exprs (let ((.x|136|139 .args|114)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))))))) (.loop|4 (let ((.x|124|127 .args|114)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) (cons (let ((.x|128|131 .newexprs|123)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))) .newargs|114) (append (let ((.x|132|135 .newexprs|123)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))) .exprs|114))) (.loop|4 (let ((.x|141|144 .args|114)) (begin (.check! (pair? .x|141|144) 1 .x|141|144) (cdr:pair .x|141|144))) (cons (let ((.x|145|148 .args|114)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))) .newargs|114) .exprs|114))))) (call.args-set! .exp|3 (let () (let ((.loop|154|157|160 (unspecified))) (begin (set! .loop|154|157|160 (lambda (.y1|149|150|161 .results|149|153|161) (if (null? .y1|149|150|161) (reverse .results|149|153|161) (begin #t (.loop|154|157|160 (let ((.x|165|168 .y1|149|150|161)) (begin (.check! (pair? .x|165|168) 1 .x|165|168) (cdr:pair .x|165|168))) (cons (let ((.arg|169 (let ((.x|170|173 .y1|149|150|161)) (begin (.check! (pair? .x|170|173) 0 .x|170|173) (car:pair .x|170|173))))) (simplify .arg|169 .notepad|3)) .results|149|153|161)))))) (.loop|154|157|160 (call.args .exp|3) '()))))) (.loop|4 (call.args .exp|3) '() '()))))) (.simplify-call|2 .exp|1 .notepad|1))))) 'simplify-call))
+(let () (begin (set! simplify-let (lambda (.exp|1 .notepad|1) (let ((.simplify-let|2 0)) (begin (set! .simplify-let|2 (lambda (.exp|3 .notepad|3) (let ((.return2|4 (unspecified)) (.loop2|4 (unspecified)) (.return1-finish|4 (unspecified)) (.return1|4 (unspecified)) (.loop1|4 (unspecified)) (.proc|4 (unspecified))) (begin (set! .return2|4 (lambda (.rev-formals|5 .rev-actuals|5 .rev-for-effect|5) (let ((.formals|8 (reverse .rev-formals|5)) (.actuals|8 (reverse .rev-actuals|5)) (.for-effect|8 (reverse .rev-for-effect|5))) (begin (lambda.args-set! .proc|4 .formals|8) (call.args-set! .exp|3 .actuals|8) (let ((.exp|11 (if (if (null? .actuals|8) (let ((.temp|15|18 (null? (lambda.defs .proc|4)))) (if .temp|15|18 .temp|15|18 (if (notepad.parent .notepad|3) (policy:lift? .proc|4 (notepad.parent .notepad|3) (let () (let ((.loop|27|30|33 (unspecified))) (begin (set! .loop|27|30|33 (lambda (.y1|22|23|34 .results|22|26|34) (if (null? .y1|22|23|34) (reverse .results|22|26|34) (begin #t (.loop|27|30|33 (let ((.x|38|41 .y1|22|23|34)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))) (cons (let ((.def|42 (let ((.x|43|46 .y1|22|23|34)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) '()) .results|22|26|34)))))) (.loop|27|30|33 (lambda.defs .proc|4) '()))))) #f))) #f) (begin (let () (let ((.loop|52|54|57 (unspecified))) (begin (set! .loop|52|54|57 (lambda (.y1|47|48|58) (if (null? .y1|47|48|58) (if #f #f (unspecified)) (begin (begin #t (let ((.i|62 (let ((.x|63|66 .y1|47|48|58)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))))) (notepad-var-add! .notepad|3 .i|62))) (.loop|52|54|57 (let ((.x|67|70 .y1|47|48|58)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70)))))))) (.loop|52|54|57 (lambda.f .proc|4))))) (if (not (null? (lambda.defs .proc|4))) (let ((.parent|73 (notepad.parent .notepad|3)) (.defs|73 (lambda.defs .proc|4)) (.r|73 (lambda.r .proc|4))) (begin (lambda.defs-set! .parent|73 (append .defs|73 (lambda.defs .parent|73))) (lambda.defs-set! .proc|4 '()) (lambda.r-set! .parent|73 (append (let () (let ((.loop|79|82|85 (unspecified))) (begin (set! .loop|79|82|85 (lambda (.y1|74|75|86 .results|74|78|86) (if (null? .y1|74|75|86) (reverse .results|74|78|86) (begin #t (.loop|79|82|85 (let ((.x|90|93 .y1|74|75|86)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))) (cons (let ((.def|94 (let ((.x|95|98 .y1|74|75|86)) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (r-lookup .r|73 (def.lhs .def|94))) .results|74|78|86)))))) (.loop|79|82|85 .defs|73 '())))) (lambda.r .parent|73))))) (unspecified)) (lambda.body .proc|4)) .exp|3))) (if (null? .for-effect|8) .exp|11 (post-simplify-begin (make-begin (append .for-effect|8 (cons .exp|11 '()))) .notepad|3))))))) (set! .loop2|4 (lambda (.formals|99 .actuals|99 .processed-formals|99 .processed-actuals|99 .for-effect|99) (if (null? .formals|99) (.return2|4 .processed-formals|99 .processed-actuals|99 .for-effect|99) (if (ignored? (let ((.x|102|105 .formals|99)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) (.loop2|4 (let ((.x|106|109 .formals|99)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109))) (let ((.x|110|113 .actuals|99)) (begin (.check! (pair? .x|110|113) 1 .x|110|113) (cdr:pair .x|110|113))) .processed-formals|99 .processed-actuals|99 (cons (let ((.x|114|117 .actuals|99)) (begin (.check! (pair? .x|114|117) 0 .x|114|117) (car:pair .x|114|117))) .for-effect|99)) (.loop2|4 (let ((.x|119|122 .formals|99)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122))) (let ((.x|123|126 .actuals|99)) (begin (.check! (pair? .x|123|126) 1 .x|123|126) (cdr:pair .x|123|126))) (cons (let ((.x|127|130 .formals|99)) (begin (.check! (pair? .x|127|130) 0 .x|127|130) (car:pair .x|127|130))) .processed-formals|99) (cons (let ((.x|131|134 .actuals|99)) (begin (.check! (pair? .x|131|134) 0 .x|131|134) (car:pair .x|131|134))) .processed-actuals|99) .for-effect|99))))) (set! .return1-finish|4 (lambda (.formals|135 .actuals|135) (begin (simplify-lambda .proc|4 .notepad|3) (.loop2|4 .formals|135 .actuals|135 '() '() '())))) (set! .return1|4 (lambda (.rev-formals|136 .rev-actuals|136) (let ((.formals|139 (reverse .rev-formals|136)) (.actuals|139 (reverse .rev-actuals|136))) (begin (lambda.args-set! .proc|4 .formals|139) (if (if (not (null? .formals|139)) (if (null? (let ((.x|142|145 .formals|139)) (begin (.check! (pair? .x|142|145) 1 .x|142|145) (cdr:pair .x|142|145)))) (let* ((.x|149 (let ((.x|161|164 .formals|139)) (begin (.check! (pair? .x|161|164) 0 .x|161|164) (car:pair .x|161|164)))) (.r|152 (lambda.r .proc|4)) (.refs|155 (references .r|152 .x|149))) (let () (if (= 1 (length .refs|155)) (null? (assignments .r|152 .x|149)) #f))) #f) #f) (let ((.x|167 (let ((.x|186|189 .formals|139)) (begin (.check! (pair? .x|186|189) 0 .x|186|189) (car:pair .x|186|189)))) (.body|167 (lambda.body .proc|4))) (if (if (variable? .body|167) (eq? .x|167 (variable.name .body|167)) #f) (simplify (let ((.x|171|174 .actuals|139)) (begin (.check! (pair? .x|171|174) 0 .x|171|174) (car:pair .x|171|174))) .notepad|3) (if (if (conditional? .body|167) (let ((.b0|180 (if.test .body|167))) (begin (variable? .b0|180) (eq? .x|167 (variable.name .b0|180)))) #f) (begin (if.test-set! .body|167 (let ((.x|181|184 .actuals|139)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184)))) (simplify .body|167 .notepad|3)) (.return1-finish|4 .formals|139 .actuals|139)))) (.return1-finish|4 .formals|139 .actuals|139)))))) (set! .loop1|4 (lambda (.formals|190 .actuals|190 .processed-formals|190 .processed-actuals|190) (if (null? .formals|190) (begin (if (not (null? .actuals|190)) (pass2-error p2error:wna .exp|3) (unspecified)) (.return1|4 .processed-formals|190 .processed-actuals|190)) (if (symbol? .formals|190) (.return1|4 (cons .formals|190 .processed-formals|190) (cons (make-call-to-list .actuals|190) .processed-actuals|190)) (if (null? .actuals|190) (begin (pass2-error p2error:wna .exp|3) (.return1|4 .processed-formals|190 .processed-actuals|190)) (if (if (lambda? (let ((.x|196|199 .actuals|190)) (begin (.check! (pair? .x|196|199) 0 .x|196|199) (car:pair .x|196|199)))) (let ((.rinfo|203 (r-lookup (lambda.r .proc|4) (let ((.x|206|209 .formals|190)) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))))) (if (null? (r-entry.assignments .rinfo|203)) (= (length (r-entry.references .rinfo|203)) (length (r-entry.calls .rinfo|203))) #f)) #f) (begin (let ((.i|212 (let ((.x|213|216 .formals|190)) (begin (.check! (pair? .x|213|216) 0 .x|213|216) (car:pair .x|213|216)))) (.l|212 (let ((.x|217|220 .actuals|190)) (begin (.check! (pair? .x|217|220) 0 .x|217|220) (car:pair .x|217|220))))) (begin (notepad-nonescaping-add! .notepad|3 .l|212) (lambda.defs-set! .proc|4 (cons (make-definition .i|212 .l|212) (lambda.defs .proc|4))) (standardize-known-calls .l|212 (r-entry.calls (r-lookup (lambda.r .proc|4) .i|212))) (lambda.f-set! .proc|4 (union (lambda.f .proc|4) (free-variables .l|212))) (lambda.g-set! .proc|4 (union (lambda.g .proc|4) (lambda.g .l|212))))) (.loop1|4 (let ((.x|221|224 .formals|190)) (begin (.check! (pair? .x|221|224) 1 .x|221|224) (cdr:pair .x|221|224))) (let ((.x|225|228 .actuals|190)) (begin (.check! (pair? .x|225|228) 1 .x|225|228) (cdr:pair .x|225|228))) .processed-formals|190 .processed-actuals|190)) (if (if (constant? (let ((.x|231|234 .actuals|190)) (begin (.check! (pair? .x|231|234) 0 .x|231|234) (car:pair .x|231|234)))) (let* ((.x|238 (constant.value (let ((.x|252|255 .actuals|190)) (begin (.check! (pair? .x|252|255) 0 .x|252|255) (car:pair .x|252|255))))) (.temp|239|242 (boolean? .x|238))) (if .temp|239|242 .temp|239|242 (let ((.temp|243|246 (number? .x|238))) (if .temp|243|246 .temp|243|246 (let ((.temp|247|250 (symbol? .x|238))) (if .temp|247|250 .temp|247|250 (char? .x|238))))))) #f) (let* ((.i|258 (let ((.x|317|320 .formals|190)) (begin (.check! (pair? .x|317|320) 0 .x|317|320) (car:pair .x|317|320)))) (.rinfo|261 (r-lookup (lambda.r .proc|4) .i|258))) (let () (if (null? (r-entry.assignments .rinfo|261)) (begin (let () (let ((.loop|270|272|275 (unspecified))) (begin (set! .loop|270|272|275 (lambda (.y1|265|266|276) (if (null? .y1|265|266|276) (if #f #f (unspecified)) (begin (begin #t (let ((.ref|280 (let ((.x|285|288 .y1|265|266|276)) (begin (.check! (pair? .x|285|288) 0 .x|285|288) (car:pair .x|285|288))))) (variable-set! .ref|280 (let ((.x|281|284 .actuals|190)) (begin (.check! (pair? .x|281|284) 0 .x|281|284) (car:pair .x|281|284)))))) (.loop|270|272|275 (let ((.x|289|292 .y1|265|266|276)) (begin (.check! (pair? .x|289|292) 1 .x|289|292) (cdr:pair .x|289|292)))))))) (.loop|270|272|275 (r-entry.references .rinfo|261))))) (lambda.r-set! .proc|4 (remq .rinfo|261 (lambda.r .proc|4))) (lambda.f-set! .proc|4 (remq .i|258 (lambda.f .proc|4))) (lambda.g-set! .proc|4 (remq .i|258 (lambda.g .proc|4))) (.loop1|4 (let ((.x|293|296 .formals|190)) (begin (.check! (pair? .x|293|296) 1 .x|293|296) (cdr:pair .x|293|296))) (let ((.x|297|300 .actuals|190)) (begin (.check! (pair? .x|297|300) 1 .x|297|300) (cdr:pair .x|297|300))) .processed-formals|190 .processed-actuals|190)) (.loop1|4 (let ((.x|301|304 .formals|190)) (begin (.check! (pair? .x|301|304) 1 .x|301|304) (cdr:pair .x|301|304))) (let ((.x|305|308 .actuals|190)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308))) (cons (let ((.x|309|312 .formals|190)) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))) .processed-formals|190) (cons (let ((.x|313|316 .actuals|190)) (begin (.check! (pair? .x|313|316) 0 .x|313|316) (car:pair .x|313|316))) .processed-actuals|190))))) (begin (if (null? .actuals|190) (pass2-error p2error:wna .exp|3) (unspecified)) (.loop1|4 (let ((.x|322|325 .formals|190)) (begin (.check! (pair? .x|322|325) 1 .x|322|325) (cdr:pair .x|322|325))) (let ((.x|326|329 .actuals|190)) (begin (.check! (pair? .x|326|329) 1 .x|326|329) (cdr:pair .x|326|329))) (cons (let ((.x|330|333 .formals|190)) (begin (.check! (pair? .x|330|333) 0 .x|330|333) (car:pair .x|330|333))) .processed-formals|190) (cons (let ((.x|334|337 .actuals|190)) (begin (.check! (pair? .x|334|337) 0 .x|334|337) (car:pair .x|334|337))) .processed-actuals|190)))))))))) (set! .proc|4 (call.proc .exp|3)) (notepad-nonescaping-add! .notepad|3 .proc|4) (.loop1|4 (lambda.args .proc|4) (call.args .exp|3) '() '()))))) (.simplify-let|2 .exp|1 .notepad|1))))) 'simplify-let))
+(let () (begin (set! single-assignment-analysis (lambda (.l|1 .notepad|1) (let ((.single-assignment-analysis|2 0)) (begin (set! .single-assignment-analysis|2 (lambda (.l|3 .notepad|3) (let ((.formals|6 (lambda.args .l|3)) (.defs|6 (lambda.defs .l|3)) (.r|6 (lambda.r .l|3)) (.body|6 (lambda.body .l|3))) (let ((.finish!|7 (unspecified))) (begin (set! .finish!|7 (lambda (.exprs|8 .escapees|8) (begin (begin.exprs-set! .body|6 (append (reverse .escapees|8) .exprs|8)) (lambda.body-set! .l|3 (post-simplify-begin .body|6 '()))))) (if (begin? .body|6) (let ((.exprs|11 (begin.exprs .body|6)) (.escapees|11 '())) (let () (let ((.loop|14 (unspecified))) (begin (set! .loop|14 (lambda (.exprs|15 .escapees|15) (let ((.first|18 (let ((.x|43|46 .exprs|15)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46))))) (if (if (assignment? .first|18) (not (null? (let ((.x|21|24 .exprs|15)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) #f) (let ((.i|27 (assignment.lhs .first|18)) (.rhs|27 (assignment.rhs .first|18))) (if (if (lambda? .rhs|27) (if (local? .r|6 .i|27) (= 1 (length (assignments .r|6 .i|27))) #f) #f) (if (= (length (calls .r|6 .i|27)) (length (references .r|6 .i|27))) (begin (notepad-nonescaping-add! .notepad|3 .rhs|27) (flag-as-ignored .i|27 .l|3) (lambda.defs-set! .l|3 (cons (make-definition .i|27 .rhs|27) (lambda.defs .l|3))) (assignments-set! .r|6 .i|27 '()) (standardize-known-calls .rhs|27 (r-entry.calls (r-lookup .r|6 .i|27))) (.loop|14 (let ((.x|31|34 .exprs|15)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) .escapees|15)) (.loop|14 (let ((.x|35|38 .exprs|15)) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))) (cons (let ((.x|39|42 .exprs|15)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42))) .escapees|15))) (.finish!|7 .exprs|15 .escapees|15))) (.finish!|7 .exprs|15 .escapees|15))))) (.loop|14 .exprs|11 .escapees|11))))) (unspecified))))))) (.single-assignment-analysis|2 .l|1 .notepad|1))))) 'single-assignment-analysis))
+(let () (begin (set! standardize-known-calls (lambda (.l|1 .calls|1) (let ((.standardize-known-calls|2 0)) (begin (set! .standardize-known-calls|2 (lambda (.l|3 .calls|3) (let ((.formals|6 (lambda.args .l|3))) (if (not (list? .formals|6)) (let* ((.newformals|10 (make-null-terminated .formals|6)) (.n|13 (- (length .newformals|10) 1))) (let () (begin (lambda.args-set! .l|3 .newformals|10) (let () (let ((.loop|22|24|27 (unspecified))) (begin (set! .loop|22|24|27 (lambda (.y1|17|18|28) (if (null? .y1|17|18|28) (if #f #f (unspecified)) (begin (begin #t (let ((.call|32 (let ((.x|34|37 .y1|17|18|28)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (if (>= (length (call.args .call|32)) .n|13) (call.args-set! .call|32 (append (list-head (call.args .call|32) .n|13) (cons (make-call-to-list (list-tail (call.args .call|32) .n|13)) '()))) (pass2-error p2error:wna .call|32)))) (.loop|22|24|27 (let ((.x|38|41 .y1|17|18|28)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))))))) (.loop|22|24|27 .calls|3))))))) (let ((.n|45 (length .formals|6))) (let () (let ((.loop|51|53|56 (unspecified))) (begin (set! .loop|51|53|56 (lambda (.y1|46|47|57) (if (null? .y1|46|47|57) (if #f #f (unspecified)) (begin (begin #t (let ((.call|61 (let ((.x|62|65 .y1|46|47|57)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65))))) (if (not (= (length (call.args .call|61)) .n|45)) (pass2-error p2error:wna .call|61) (unspecified)))) (.loop|51|53|56 (let ((.x|66|69 .y1|46|47|57)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69)))))))) (.loop|51|53|56 .calls|3))))))))) (.standardize-known-calls|2 .l|1 .calls|1))))) 'standardize-known-calls))
+(let () (begin (set! single-assignment-elimination (lambda (.l|1 .notepad|1) (let ((.single-assignment-elimination|2 0)) (begin (set! .single-assignment-elimination|2 (lambda (.l|3 .notepad|3) (begin (if (begin? (lambda.body .l|3)) (let* ((.formals|6 (make-null-terminated (lambda.args .l|3))) (.defined|9 (let () (let ((.loop|190|193|196 (unspecified))) (begin (set! .loop|190|193|196 (lambda (.y1|185|186|197 .results|185|189|197) (if (null? .y1|185|186|197) (reverse .results|185|189|197) (begin #t (.loop|190|193|196 (let ((.x|201|204 .y1|185|186|197)) (begin (.check! (pair? .x|201|204) 1 .x|201|204) (cdr:pair .x|201|204))) (cons (def.lhs (let ((.x|205|208 .y1|185|186|197)) (begin (.check! (pair? .x|205|208) 0 .x|205|208) (car:pair .x|205|208)))) .results|185|189|197)))))) (.loop|190|193|196 (lambda.defs .l|3) '()))))) (.escaping|12 (intersection .formals|6 (notepad-captured-variables .notepad|3))) (.r|15 (lambda.r .l|3))) (let () (let ((.return-loop|19 (unspecified)) (.return|19 (unspecified)) (.loop|19 (unspecified))) (begin (set! .return-loop|19 (lambda (.assigns|20 .body|20) (if (null? .assigns|20) (let ((.l3|23 (call.proc .body|20))) (begin (lambda.body-set! .l|3 .body|20) (lambda-lifting .l3|23 .l|3))) (let* ((.i|26 (assignment.lhs (let ((.x|56|59 .assigns|20)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (.e|29 (assignment.rhs (let ((.x|52|55 .assigns|20)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (.l3|32 (call.proc .body|20)) (.f|35 (remq .i|26 (lambda.f .l3|32))) (.g|38 (remq .i|26 (lambda.g .l3|32)))) (let () (begin (flag-as-ignored .i|26 .l|3) (assignments-set! .r|15 .i|26 '()) (let ((.l2|44 (make-lambda (cons .i|26 '()) '() (cons (r-entry .r|15 .i|26) '()) .f|35 .g|38 (lambda.decls .l|3) (lambda.doc .l|3) .body|20))) (begin (lambda.r-set! .l|3 (remq (r-entry .r|15 .i|26) .r|15)) (lambda-lifting .l3|32 .l2|44) (.return-loop|19 (let ((.x|45|48 .assigns|20)) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48))) (make-call .l2|44 (cons .e|29 '()))))))))))) (set! .return|19 (lambda (.exprs|60 .assigns|60) (if (not (null? .assigns|60)) (let ((.i|63 (assignment.lhs (let ((.x|122|125 .assigns|60)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (.e|63 (assignment.rhs (let ((.x|126|129 .assigns|60)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129))))) (.defs|63 (lambda.defs .l|3)) (.f|63 (lambda.f .l|3)) (.g|63 (lambda.g .l|3))) (begin (flag-as-ignored .i|63 .l|3) (assignments-set! .r|15 .i|63 '()) (let ((.l2|66 (make-lambda (cons .i|63 '()) .defs|63 (cons (r-entry .r|15 .i|63) (let () (let ((.loop|102|105|108 (unspecified))) (begin (set! .loop|102|105|108 (lambda (.y1|97|98|109 .results|97|101|109) (if (null? .y1|97|98|109) (reverse .results|97|101|109) (begin #t (.loop|102|105|108 (let ((.x|113|116 .y1|97|98|109)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116))) (cons (let ((.def|117 (let ((.x|118|121 .y1|97|98|109)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121))))) (r-entry .r|15 (def.lhs .def|117))) .results|97|101|109)))))) (.loop|102|105|108 .defs|63 '()))))) .f|63 .g|63 (lambda.decls .l|3) (lambda.doc .l|3) (make-begin .exprs|60)))) (begin (lambda.defs-set! .l|3 '()) (let () (let ((.loop|72|74|77 (unspecified))) (begin (set! .loop|72|74|77 (lambda (.y1|67|68|78) (if (null? .y1|67|68|78) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|82 (let ((.x|83|86 .y1|67|68|78)) (begin (.check! (pair? .x|83|86) 0 .x|83|86) (car:pair .x|83|86))))) (lambda.r-set! .l|3 (remq .entry|82 .r|15)))) (.loop|72|74|77 (let ((.x|87|90 .y1|67|68|78)) (begin (.check! (pair? .x|87|90) 1 .x|87|90) (cdr:pair .x|87|90)))))))) (.loop|72|74|77 (lambda.r .l2|66))))) (.return-loop|19 (let ((.x|91|94 .assigns|60)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (make-call .l2|66 (cons .e|63 '()))))))) (unspecified)))) (set! .loop|19 (lambda (.exprs|130 .assigns|130 .call-has-occurred?|130 .free|130) (if (null? (let ((.x|132|135 .exprs|130)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135)))) (.return|19 .exprs|130 .assigns|130) (if (assignment? (let ((.x|137|140 .exprs|130)) (begin (.check! (pair? .x|137|140) 0 .x|137|140) (car:pair .x|137|140)))) (let ((.i1|143 (assignment.lhs (let ((.x|176|179 .exprs|130)) (begin (.check! (pair? .x|176|179) 0 .x|176|179) (car:pair .x|176|179))))) (.e1|143 (assignment.rhs (let ((.x|180|183 .exprs|130)) (begin (.check! (pair? .x|180|183) 0 .x|180|183) (car:pair .x|180|183)))))) (if (if (memq .i1|143 .formals|6) (if (= (length (assignments .r|15 .i1|143)) 1) (not (if .call-has-occurred?|130 (memq .i1|143 .escaping|12) #f)) #f) #f) (let* ((.free-in-e1|151 (free-variables .e1|143)) (.newfree|154 (union .free-in-e1|151 .free|130))) (let () (if (let ((.temp|158|161 (memq .i1|143 .newfree|154))) (if .temp|158|161 .temp|158|161 (not (empty-set? (intersection .free-in-e1|151 .defined|9))))) (.return|19 .exprs|130 .assigns|130) (.loop|19 (let ((.x|163|166 .exprs|130)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))) (cons (let ((.x|167|170 .exprs|130)) (begin (.check! (pair? .x|167|170) 0 .x|167|170) (car:pair .x|167|170))) .assigns|130) (let ((.temp|171|174 .call-has-occurred?|130)) (if .temp|171|174 .temp|171|174 (might-return-twice? .e1|143))) .newfree|154)))) (.return|19 .exprs|130 .assigns|130))) (.return|19 .exprs|130 .assigns|130))))) (.loop|19 (begin.exprs (lambda.body .l|3)) '() #f '()))))) (unspecified)) .l|3))) (.single-assignment-elimination|2 .l|1 .notepad|1))))) 'single-assignment-elimination))
+(let () (begin (set! free-variables (lambda (.exp|1) (let ((.free-variables|2 0)) (begin (set! .free-variables|2 (lambda (.exp|3) (let ((.temp|4|7 (let ((.x|64|67 .exp|3)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))))) (if (memv .temp|4|7 '(quote)) '() (if (memv .temp|4|7 '(lambda)) (difference (lambda.f .exp|3) (make-null-terminated (lambda.args .exp|3))) (if (memv .temp|4|7 '(set!)) (union (cons (assignment.lhs .exp|3) '()) (.free-variables|2 (assignment.rhs .exp|3))) (if (memv .temp|4|7 '(if)) (union (.free-variables|2 (if.test .exp|3)) (.free-variables|2 (if.then .exp|3)) (.free-variables|2 (if.else .exp|3))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (cons (variable.name .exp|3) '()) (apply union (let () (let ((.loop|20|23|26 (unspecified))) (begin (set! .loop|20|23|26 (lambda (.y1|15|16|27 .results|15|19|27) (if (null? .y1|15|16|27) (reverse .results|15|19|27) (begin #t (.loop|20|23|26 (let ((.x|31|34 .y1|15|16|27)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34))) (cons (.free-variables|2 (let ((.x|35|38 .y1|15|16|27)) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38)))) .results|15|19|27)))))) (.loop|20|23|26 (begin.exprs .exp|3) '())))))) (apply union (let () (let ((.loop|45|48|51 (unspecified))) (begin (set! .loop|45|48|51 (lambda (.y1|40|41|52 .results|40|44|52) (if (null? .y1|40|41|52) (reverse .results|40|44|52) (begin #t (.loop|45|48|51 (let ((.x|56|59 .y1|40|41|52)) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) (cons (.free-variables|2 (let ((.x|60|63 .y1|40|41|52)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63)))) .results|40|44|52)))))) (.loop|45|48|51 .exp|3 '()))))))))))))) (.free-variables|2 .exp|1))))) 'free-variables))
+(let () (begin (set! might-return-twice? (lambda (.exp|1) (let ((.might-return-twice?|2 0)) (begin (set! .might-return-twice?|2 (lambda (.exp|3) (let ((.temp|4|7 (let ((.x|23|26 .exp|3)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (if (memv .temp|4|7 '(quote)) #f (if (memv .temp|4|7 '(lambda)) #f (if (memv .temp|4|7 '(set!)) (.might-return-twice?|2 (assignment.rhs .exp|3)) (if (memv .temp|4|7 '(if)) (let ((.temp|12|15 (.might-return-twice?|2 (if.test .exp|3)))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (.might-return-twice?|2 (if.then .exp|3)))) (if .temp|16|19 .temp|16|19 (.might-return-twice?|2 (if.else .exp|3)))))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) #f (some? .might-return-twice?|2 (begin.exprs .exp|3))) #t)))))))) (.might-return-twice?|2 .exp|1))))) 'might-return-twice?))
+(let () (begin (set! assignment-elimination (lambda (.l|1) (let ((.assignment-elimination|2 0)) (begin (set! .assignment-elimination|2 (lambda (.l|3) (let ((.r|6 (lambda.r .l|3))) (let ((.update-old-reference-info!|7 (unspecified)) (.new-reference-info|7 (unspecified)) (.cellify!|7 (unspecified)) (.generate-new-name|7 (unspecified)) (.eliminate|7 (unspecified)) (.loop|7 (unspecified))) (begin (set! .update-old-reference-info!|7 (lambda (.ref|8) (begin (references-set! .r|6 (variable.name .ref|8) (cons .ref|8 '())) (assignments-set! .r|6 (variable.name .ref|8) '()) (calls-set! .r|6 (variable.name .ref|8) '())))) (set! .new-reference-info|7 (lambda (.augmented-entry|10) (make-r-entry (let ((.x|11|14 .augmented-entry|10)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (r-entry.references (let ((.x|16|19 (let ((.x|20|23 .augmented-entry|10)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))))) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) '() '()))) (set! .cellify!|7 (lambda (.augmented-entry|24) (let ((.newname|27 (let ((.x|90|93 .augmented-entry|24)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (.entry|27 (let ((.x|95|98 (let ((.x|99|102 .augmented-entry|24)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (begin (let () (let ((.loop|29|31|34 (unspecified))) (begin (set! .loop|29|31|34 (lambda (.refs|35) (if (null? .refs|35) (if #f #f (unspecified)) (begin (begin #t (let* ((.reference|40 (let ((.x|51|54 .refs|35)) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))) (.newref|43 (make-variable .newname|27))) (let () (begin (set-car! .reference|40 (make-variable name:cell-ref)) (set-car! (let ((.x|47|50 .reference|40)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))) .newref|43) (set-car! .refs|35 .newref|43))))) (.loop|29|31|34 (let ((.x|55|58 .refs|35)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58)))))))) (.loop|29|31|34 (r-entry.references .entry|27))))) (let () (let ((.loop|60|62|65 (unspecified))) (begin (set! .loop|60|62|65 (lambda (.assigns|66) (if (null? .assigns|66) (if #f #f (unspecified)) (begin (begin #t (let* ((.assignment|71 (let ((.x|82|85 .assigns|66)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) (.newref|74 (make-variable .newname|27))) (let () (begin (set-car! .assignment|71 (make-variable name:cell-set!)) (set-car! (let ((.x|78|81 .assignment|71)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) .newref|74) (r-entry.references-set! .entry|27 (cons .newref|74 (r-entry.references .entry|27))))))) (.loop|60|62|65 (let ((.x|86|89 .assigns|66)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89)))))))) (.loop|60|62|65 (r-entry.assignments .entry|27))))) (r-entry.assignments-set! .entry|27 '()))))) (set! .generate-new-name|7 (lambda (.name|103) (string->symbol (string-append cell-prefix (symbol->string .name|103))))) (set! .eliminate|7 (lambda (.assigned|104) (let* ((.oldnames|107 (let () (let ((.loop|554|557|560 (unspecified))) (begin (set! .loop|554|557|560 (lambda (.y1|549|550|561 .results|549|553|561) (if (null? .y1|549|550|561) (reverse .results|549|553|561) (begin #t (.loop|554|557|560 (let ((.x|565|568 .y1|549|550|561)) (begin (.check! (pair? .x|565|568) 1 .x|565|568) (cdr:pair .x|565|568))) (cons (r-entry.name (let ((.x|569|572 .y1|549|550|561)) (begin (.check! (pair? .x|569|572) 0 .x|569|572) (car:pair .x|569|572)))) .results|549|553|561)))))) (.loop|554|557|560 .assigned|104 '()))))) (.newnames|110 (let () (let ((.loop|530|533|536 (unspecified))) (begin (set! .loop|530|533|536 (lambda (.y1|525|526|537 .results|525|529|537) (if (null? .y1|525|526|537) (reverse .results|525|529|537) (begin #t (.loop|530|533|536 (let ((.x|541|544 .y1|525|526|537)) (begin (.check! (pair? .x|541|544) 1 .x|541|544) (cdr:pair .x|541|544))) (cons (.generate-new-name|7 (let ((.x|545|548 .y1|525|526|537)) (begin (.check! (pair? .x|545|548) 0 .x|545|548) (car:pair .x|545|548)))) .results|525|529|537)))))) (.loop|530|533|536 .oldnames|107 '())))))) (let () (let ((.augmented-entries|116 (let () (let ((.loop|444|448|451 (unspecified))) (begin (set! .loop|444|448|451 (lambda (.y1|438|440|452 .y1|438|439|452 .results|438|443|452) (if (let ((.temp|454|457 (null? .y1|438|440|452))) (if .temp|454|457 .temp|454|457 (null? .y1|438|439|452))) (reverse .results|438|443|452) (begin #t (.loop|444|448|451 (let ((.x|460|463 .y1|438|440|452)) (begin (.check! (pair? .x|460|463) 1 .x|460|463) (cdr:pair .x|460|463))) (let ((.x|464|467 .y1|438|439|452)) (begin (.check! (pair? .x|464|467) 1 .x|464|467) (cdr:pair .x|464|467))) (cons (let* ((.t1|468|471 (let ((.x|483|486 .y1|438|440|452)) (begin (.check! (pair? .x|483|486) 0 .x|483|486) (car:pair .x|483|486)))) (.t2|468|474 (cons (let ((.x|479|482 .y1|438|439|452)) (begin (.check! (pair? .x|479|482) 0 .x|479|482) (car:pair .x|479|482))) '()))) (let () (cons .t1|468|471 .t2|468|474))) .results|438|443|452)))))) (.loop|444|448|451 .newnames|110 .assigned|104 '()))))) (.renaming-alist|116 (let () (let ((.loop|493|497|500 (unspecified))) (begin (set! .loop|493|497|500 (lambda (.y1|487|489|501 .y1|487|488|501 .results|487|492|501) (if (let ((.temp|503|506 (null? .y1|487|489|501))) (if .temp|503|506 .temp|503|506 (null? .y1|487|488|501))) (reverse .results|487|492|501) (begin #t (.loop|493|497|500 (let ((.x|509|512 .y1|487|489|501)) (begin (.check! (pair? .x|509|512) 1 .x|509|512) (cdr:pair .x|509|512))) (let ((.x|513|516 .y1|487|488|501)) (begin (.check! (pair? .x|513|516) 1 .x|513|516) (cdr:pair .x|513|516))) (cons (cons (let ((.x|517|520 .y1|487|489|501)) (begin (.check! (pair? .x|517|520) 0 .x|517|520) (car:pair .x|517|520))) (let ((.x|521|524 .y1|487|488|501)) (begin (.check! (pair? .x|521|524) 0 .x|521|524) (car:pair .x|521|524)))) .results|487|492|501)))))) (.loop|493|497|500 .oldnames|107 .newnames|110 '()))))) (.defs|116 (lambda.defs .l|3))) (begin (let () (let ((.loop|122|124|127 (unspecified))) (begin (set! .loop|122|124|127 (lambda (.y1|117|118|128) (if (null? .y1|117|118|128) (if #f #f (unspecified)) (begin (begin #t (.cellify!|7 (let ((.x|132|135 .y1|117|118|128)) (begin (.check! (pair? .x|132|135) 0 .x|132|135) (car:pair .x|132|135))))) (.loop|122|124|127 (let ((.x|136|139 .y1|117|118|128)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139)))))))) (.loop|122|124|127 .augmented-entries|116)))) (let () (let ((.loop|145|147|150 (unspecified))) (begin (set! .loop|145|147|150 (lambda (.y1|140|141|151) (if (null? .y1|140|141|151) (if #f #f (unspecified)) (begin (begin #t (let ((.def|155 (let ((.x|181|184 .y1|140|141|151)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184))))) (let () (let ((.loop|157|159|162 (unspecified))) (begin (set! .loop|157|159|162 (lambda (.free|163) (if (null? .free|163) (if #f #f (unspecified)) (begin (begin #t (let ((.z|168 (assq (let ((.x|173|176 .free|163)) (begin (.check! (pair? .x|173|176) 0 .x|173|176) (car:pair .x|173|176))) .renaming-alist|116))) (if .z|168 (set-car! .free|163 (let ((.x|169|172 .z|168)) (begin (.check! (pair? .x|169|172) 1 .x|169|172) (cdr:pair .x|169|172)))) (unspecified)))) (.loop|157|159|162 (let ((.x|177|180 .free|163)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180)))))))) (.loop|157|159|162 (lambda.f (def.rhs .def|155)))))))) (.loop|145|147|150 (let ((.x|185|188 .y1|140|141|151)) (begin (.check! (pair? .x|185|188) 1 .x|185|188) (cdr:pair .x|185|188)))))))) (.loop|145|147|150 .defs|116)))) (let ((.newbody|191 (make-call (make-lambda (let () (let ((.loop|294|297|300 (unspecified))) (begin (set! .loop|294|297|300 (lambda (.y1|289|290|301 .results|289|293|301) (if (null? .y1|289|290|301) (reverse .results|289|293|301) (begin #t (.loop|294|297|300 (let ((.x|305|308 .y1|289|290|301)) (begin (.check! (pair? .x|305|308) 1 .x|305|308) (cdr:pair .x|305|308))) (cons (let ((.x|309|312 (let ((.x|313|316 .y1|289|290|301)) (begin (.check! (pair? .x|313|316) 0 .x|313|316) (car:pair .x|313|316))))) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))) .results|289|293|301)))))) (.loop|294|297|300 .augmented-entries|116 '())))) .defs|116 (union (let () (let ((.loop|322|325|328 (unspecified))) (begin (set! .loop|322|325|328 (lambda (.y1|317|318|329 .results|317|321|329) (if (null? .y1|317|318|329) (reverse .results|317|321|329) (begin #t (.loop|322|325|328 (let ((.x|333|336 .y1|317|318|329)) (begin (.check! (pair? .x|333|336) 1 .x|333|336) (cdr:pair .x|333|336))) (cons (let ((.def|337 (let ((.x|338|341 .y1|317|318|329)) (begin (.check! (pair? .x|338|341) 0 .x|338|341) (car:pair .x|338|341))))) (r-entry .r|6 (def.lhs .def|337))) .results|317|321|329)))))) (.loop|322|325|328 .defs|116 '())))) (let () (let ((.loop|347|350|353 (unspecified))) (begin (set! .loop|347|350|353 (lambda (.y1|342|343|354 .results|342|346|354) (if (null? .y1|342|343|354) (reverse .results|342|346|354) (begin #t (.loop|347|350|353 (let ((.x|358|361 .y1|342|343|354)) (begin (.check! (pair? .x|358|361) 1 .x|358|361) (cdr:pair .x|358|361))) (cons (.new-reference-info|7 (let ((.x|362|365 .y1|342|343|354)) (begin (.check! (pair? .x|362|365) 0 .x|362|365) (car:pair .x|362|365)))) .results|342|346|354)))))) (.loop|347|350|353 .augmented-entries|116 '()))))) (union (let* ((.t1|366|369 name:cell-ref) (.t2|366|372 (cons name:cell-set! '()))) (let () (cons .t1|366|369 .t2|366|372))) .newnames|110 (difference (lambda.f .l|3) .oldnames|107)) (union (let* ((.t1|377|380 name:cell-ref) (.t2|377|383 (cons name:cell-set! '()))) (let () (cons .t1|377|380 .t2|377|383))) .newnames|110 (difference (lambda.g .l|3) .oldnames|107)) (lambda.decls .l|3) (lambda.doc .l|3) (lambda.body .l|3)) (let () (let ((.loop|393|396|399 (unspecified))) (begin (set! .loop|393|396|399 (lambda (.y1|388|389|400 .results|388|392|400) (if (null? .y1|388|389|400) (reverse .results|388|392|400) (begin #t (.loop|393|396|399 (let ((.x|404|407 .y1|388|389|400)) (begin (.check! (pair? .x|404|407) 1 .x|404|407) (cdr:pair .x|404|407))) (cons (let ((.name|408 (let ((.x|410|413 .y1|388|389|400)) (begin (.check! (pair? .x|410|413) 0 .x|410|413) (car:pair .x|410|413))))) (make-call (make-variable name:make-cell) (cons (make-variable .name|408) '()))) .results|388|392|400)))))) (.loop|393|396|399 (let () (let ((.loop|419|422|425 (unspecified))) (begin (set! .loop|419|422|425 (lambda (.y1|414|415|426 .results|414|418|426) (if (null? .y1|414|415|426) (reverse .results|414|418|426) (begin #t (.loop|419|422|425 (let ((.x|430|433 .y1|414|415|426)) (begin (.check! (pair? .x|430|433) 1 .x|430|433) (cdr:pair .x|430|433))) (cons (r-entry.name (let ((.x|434|437 .y1|414|415|426)) (begin (.check! (pair? .x|434|437) 0 .x|434|437) (car:pair .x|434|437)))) .results|414|418|426)))))) (.loop|419|422|425 .assigned|104 '())))) '()))))))) (begin (lambda.f-set! .l|3 (union (let* ((.t1|192|195 name:make-cell) (.t2|192|198 (let* ((.t1|202|205 name:cell-ref) (.t2|202|208 (cons name:cell-set! '()))) (let () (cons .t1|202|205 .t2|202|208))))) (let () (cons .t1|192|195 .t2|192|198))) (difference (lambda.f .l|3) (let () (let ((.loop|218|221|224 (unspecified))) (begin (set! .loop|218|221|224 (lambda (.y1|213|214|225 .results|213|217|225) (if (null? .y1|213|214|225) (reverse .results|213|217|225) (begin #t (.loop|218|221|224 (let ((.x|229|232 .y1|213|214|225)) (begin (.check! (pair? .x|229|232) 1 .x|229|232) (cdr:pair .x|229|232))) (cons (def.lhs (let ((.x|233|236 .y1|213|214|225)) (begin (.check! (pair? .x|233|236) 0 .x|233|236) (car:pair .x|233|236)))) .results|213|217|225)))))) (.loop|218|221|224 (lambda.defs .l|3) '()))))))) (lambda.defs-set! .l|3 '()) (let () (let ((.loop|242|244|247 (unspecified))) (begin (set! .loop|242|244|247 (lambda (.y1|237|238|248) (if (null? .y1|237|238|248) (if #f #f (unspecified)) (begin (begin #t (.update-old-reference-info!|7 (let ((.x|252|255 .y1|237|238|248)) (begin (.check! (pair? .x|252|255) 0 .x|252|255) (car:pair .x|252|255))))) (.loop|242|244|247 (let ((.x|256|259 .y1|237|238|248)) (begin (.check! (pair? .x|256|259) 1 .x|256|259) (cdr:pair .x|256|259)))))))) (.loop|242|244|247 (let () (let ((.loop|265|268|271 (unspecified))) (begin (set! .loop|265|268|271 (lambda (.y1|260|261|272 .results|260|264|272) (if (null? .y1|260|261|272) (reverse .results|260|264|272) (begin #t (.loop|265|268|271 (let ((.x|276|279 .y1|260|261|272)) (begin (.check! (pair? .x|276|279) 1 .x|276|279) (cdr:pair .x|276|279))) (cons (let* ((.arg|280 (let ((.x|285|288 .y1|260|261|272)) (begin (.check! (pair? .x|285|288) 0 .x|285|288) (car:pair .x|285|288)))) (.x|281|284 (call.args .arg|280))) (begin (.check! (pair? .x|281|284) 0 .x|281|284) (car:pair .x|281|284))) .results|260|264|272)))))) (.loop|265|268|271 (call.args .newbody|191) '())))))))) (lambda.body-set! .l|3 .newbody|191) (lambda-lifting (call.proc .newbody|191) .l|3))))))))) (set! .loop|7 (lambda (.entries|573 .assigned|573) (if (null? .entries|573) (if (not (null? .assigned|573)) (.eliminate|7 .assigned|573) (unspecified)) (if (not (null? (r-entry.assignments (let ((.x|576|579 .entries|573)) (begin (.check! (pair? .x|576|579) 0 .x|576|579) (car:pair .x|576|579)))))) (.loop|7 (let ((.x|580|583 .entries|573)) (begin (.check! (pair? .x|580|583) 1 .x|580|583) (cdr:pair .x|580|583))) (cons (let ((.x|584|587 .entries|573)) (begin (.check! (pair? .x|584|587) 0 .x|584|587) (car:pair .x|584|587))) .assigned|573)) (if (null? (r-entry.references (let ((.x|589|592 .entries|573)) (begin (.check! (pair? .x|589|592) 0 .x|589|592) (car:pair .x|589|592))))) (begin (flag-as-ignored (r-entry.name (let ((.x|593|596 .entries|573)) (begin (.check! (pair? .x|593|596) 0 .x|593|596) (car:pair .x|593|596)))) .l|3) (.loop|7 (let ((.x|597|600 .entries|573)) (begin (.check! (pair? .x|597|600) 1 .x|597|600) (cdr:pair .x|597|600))) .assigned|573)) (.loop|7 (let ((.x|602|605 .entries|573)) (begin (.check! (pair? .x|602|605) 1 .x|602|605) (cdr:pair .x|602|605))) .assigned|573)))))) (.loop|7 .r|6 '())))))) (.assignment-elimination|2 .l|1))))) 'assignment-elimination))
+(let () (begin (set! lambda-lifting (lambda (.l2|1 .l|1) (let ((.lambda-lifting|2 0)) (begin (set! .lambda-lifting|2 (lambda (.l2|3 .l|3) (let ((.lift|4 (unspecified))) (begin (set! .lift|4 (lambda (.l2|5 .l|5 .args-to-add|5) (let ((.formals|8 (make-null-terminated (lambda.args .l2|5)))) (begin (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.defs|17 .args-to-add|17) (if (null? .defs|17) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|22 (let ((.x|99|102 .defs|17)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.entry|25 (r-lookup (lambda.r .l2|5) (def.lhs .def|22))) (.calls|28 (r-entry.calls .entry|25)) (.added|31 (twobit-sort (lambda (.x|89 .y|89) (let ((.xx|92 (memq .x|89 .formals|8)) (.yy|92 (memq .y|89 .formals|8))) (if (if .xx|92 .yy|92 #f) (> (length .xx|92) (length .yy|92)) #t))) (let ((.x|95|98 .args-to-add|17)) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98))))) (.l3|34 (def.rhs .def|22))) (let () (begin (lambda.f-set! .l3|34 (union .added|31 (lambda.f .l3|34))) (lambda.args-set! .l3|34 (append .added|31 (lambda.args .l3|34))) (let () (let ((.loop|43|45|48 (unspecified))) (begin (set! .loop|43|45|48 (lambda (.y1|38|39|49) (if (null? .y1|38|39|49) (if #f #f (unspecified)) (begin (begin #t (let* ((.call|53 (let ((.x|81|84 .y1|38|39|49)) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84)))) (.newargs|56 (let () (let ((.loop|62|65|68 (unspecified))) (begin (set! .loop|62|65|68 (lambda (.y1|57|58|69 .results|57|61|69) (if (null? .y1|57|58|69) (reverse .results|57|61|69) (begin #t (.loop|62|65|68 (let ((.x|73|76 .y1|57|58|69)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))) (cons (make-variable (let ((.x|77|80 .y1|57|58|69)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80)))) .results|57|61|69)))))) (.loop|62|65|68 .added|31 '())))))) (call.args-set! .call|53 (append .newargs|56 (call.args .call|53))))) (.loop|43|45|48 (let ((.x|85|88 .y1|38|39|49)) (begin (.check! (pair? .x|85|88) 1 .x|85|88) (cdr:pair .x|85|88)))))))) (.loop|43|45|48 .calls|28)))) (lambda.r-set! .l2|5 (remq .entry|25 (lambda.r .l2|5))) (lambda.r-set! .l|5 (cons .entry|25 (lambda.r .l|5))))))) (.loop|10|13|16 (let ((.x|103|106 .defs|17)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))) (let ((.x|107|110 .args-to-add|17)) (begin (.check! (pair? .x|107|110) 1 .x|107|110) (cdr:pair .x|107|110)))))))) (.loop|10|13|16 (lambda.defs .l2|5) .args-to-add|5)))) (if (not (eq? .l2|5 .l|5)) (begin (lambda.defs-set! .l|5 (append (lambda.defs .l2|5) (lambda.defs .l|5))) (lambda.defs-set! .l2|5 '())) (unspecified)))))) (if .l|3 (if (not (null? (lambda.defs .l2|3))) (let ((.args-to-add|113 (compute-added-arguments (lambda.defs .l2|3) (make-null-terminated (lambda.args .l2|3))))) (if (policy:lift? .l2|3 .l|3 .args-to-add|113) (.lift|4 .l2|3 .l|3 .args-to-add|113) (unspecified))) (unspecified)) (unspecified)))))) (.lambda-lifting|2 .l2|1 .l|1))))) 'lambda-lifting))
+(let () (begin (set! compute-added-arguments (lambda (.defs|1 .formals|1) (let ((.compute-added-arguments|2 0)) (begin (set! .compute-added-arguments|2 (lambda (.defs|3 .formals|3) (let ((.procs|6 (let () (let ((.loop|159|162|165 (unspecified))) (begin (set! .loop|159|162|165 (lambda (.y1|154|155|166 .results|154|158|166) (if (null? .y1|154|155|166) (reverse .results|154|158|166) (begin #t (.loop|159|162|165 (let ((.x|170|173 .y1|154|155|166)) (begin (.check! (pair? .x|170|173) 1 .x|170|173) (cdr:pair .x|170|173))) (cons (def.lhs (let ((.x|174|177 .y1|154|155|166)) (begin (.check! (pair? .x|174|177) 0 .x|174|177) (car:pair .x|174|177)))) .results|154|158|166)))))) (.loop|159|162|165 .defs|3 '()))))) (.freevars|6 (let () (let ((.loop|183|186|189 (unspecified))) (begin (set! .loop|183|186|189 (lambda (.y1|178|179|190 .results|178|182|190) (if (null? .y1|178|179|190) (reverse .results|178|182|190) (begin #t (.loop|183|186|189 (let ((.x|194|197 .y1|178|179|190)) (begin (.check! (pair? .x|194|197) 1 .x|194|197) (cdr:pair .x|194|197))) (cons (lambda.f (let ((.x|198|201 .y1|178|179|190)) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) .results|178|182|190)))))) (.loop|183|186|189 (let () (let ((.loop|207|210|213 (unspecified))) (begin (set! .loop|207|210|213 (lambda (.y1|202|203|214 .results|202|206|214) (if (null? .y1|202|203|214) (reverse .results|202|206|214) (begin #t (.loop|207|210|213 (let ((.x|218|221 .y1|202|203|214)) (begin (.check! (pair? .x|218|221) 1 .x|218|221) (cdr:pair .x|218|221))) (cons (def.rhs (let ((.x|222|225 .y1|202|203|214)) (begin (.check! (pair? .x|222|225) 0 .x|222|225) (car:pair .x|222|225)))) .results|202|206|214)))))) (.loop|207|210|213 .defs|3 '())))) '())))))) (let ((.callgraph|9 (let () (let ((.loop|84|87|90 (unspecified))) (begin (set! .loop|84|87|90 (lambda (.y1|79|80|91 .results|79|83|91) (if (null? .y1|79|80|91) (reverse .results|79|83|91) (begin #t (.loop|84|87|90 (let ((.x|95|98 .y1|79|80|91)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (cons (let ((.names|99 (let ((.x|125|128 .y1|79|80|91)) (begin (.check! (pair? .x|125|128) 0 .x|125|128) (car:pair .x|125|128))))) (let () (let ((.loop|105|108|111 (unspecified))) (begin (set! .loop|105|108|111 (lambda (.y1|100|101|112 .results|100|104|112) (if (null? .y1|100|101|112) (reverse .results|100|104|112) (begin #t (.loop|105|108|111 (let ((.x|116|119 .y1|100|101|112)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons (let ((.name|120 (let ((.x|121|124 .y1|100|101|112)) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))))) (position .name|120 .procs|6)) .results|100|104|112)))))) (.loop|105|108|111 (intersection .names|99 .procs|6) '()))))) .results|79|83|91)))))) (.loop|84|87|90 .freevars|6 '()))))) (.added_0|9 (let () (let ((.loop|134|137|140 (unspecified))) (begin (set! .loop|134|137|140 (lambda (.y1|129|130|141 .results|129|133|141) (if (null? .y1|129|130|141) (reverse .results|129|133|141) (begin #t (.loop|134|137|140 (let ((.x|145|148 .y1|129|130|141)) (begin (.check! (pair? .x|145|148) 1 .x|145|148) (cdr:pair .x|145|148))) (cons (let ((.names|149 (let ((.x|150|153 .y1|129|130|141)) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153))))) (intersection .names|149 .formals|3)) .results|129|133|141)))))) (.loop|134|137|140 .freevars|6 '())))))) (vector->list (compute-fixedpoint (make-vector (length .procs|6) '()) (list->vector (let () (let ((.loop|16|20|23 (unspecified))) (begin (set! .loop|16|20|23 (lambda (.y1|10|12|24 .y1|10|11|24 .results|10|15|24) (if (let ((.temp|26|29 (null? .y1|10|12|24))) (if .temp|26|29 .temp|26|29 (null? .y1|10|11|24))) (reverse .results|10|15|24) (begin #t (.loop|16|20|23 (let ((.x|32|35 .y1|10|12|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) (let ((.x|36|39 .y1|10|11|24)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.term0|40 (let ((.x|71|74 .y1|10|12|24)) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74)))) (.indexes|40 (let ((.x|75|78 .y1|10|11|24)) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))))) (lambda (.approximations|41) (union .term0|40 (apply union (let () (let ((.loop|47|50|53 (unspecified))) (begin (set! .loop|47|50|53 (lambda (.y1|42|43|54 .results|42|46|54) (if (null? .y1|42|43|54) (reverse .results|42|46|54) (begin #t (.loop|47|50|53 (let ((.x|58|61 .y1|42|43|54)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) (cons (let ((.i|62 (let ((.x|67|70 .y1|42|43|54)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) (let ((.v|63|66 .approximations|41) (.i|63|66 .i|62)) (begin (.check! (fixnum? .i|63|66) 40 .v|63|66 .i|63|66) (.check! (vector? .v|63|66) 40 .v|63|66 .i|63|66) (.check! (<:fix:fix .i|63|66 (vector-length:vec .v|63|66)) 40 .v|63|66 .i|63|66) (.check! (>=:fix:fix .i|63|66 0) 40 .v|63|66 .i|63|66) (vector-ref:trusted .v|63|66 .i|63|66)))) .results|42|46|54)))))) (.loop|47|50|53 .indexes|40 '())))))))) .results|10|15|24)))))) (.loop|16|20|23 .added_0|9 .callgraph|9 '()))))) set-equal?)))))) (.compute-added-arguments|2 .defs|1 .formals|1))))) 'compute-added-arguments))
+(let () (begin (set! position (lambda (.x|1 .l|1) (let ((.position|2 0)) (begin (set! .position|2 (lambda (.x|3 .l|3) (if (eq? .x|3 (let ((.x|5|8 .l|3)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))) 0 (+ 1 (.position|2 .x|3 (let ((.x|10|13 .l|3)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))))))) (.position|2 .x|1 .l|1))))) 'position))
+(let () (begin (set! compute-fixedpoint (lambda (.v|1 .functions|1 .equiv?|1) (let ((.compute-fixedpoint|2 0)) (begin (set! .compute-fixedpoint|2 (lambda (.v|3 .functions|3 .equiv?|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.i|5 .flag|5) (if (< .i|5 0) (if .flag|5 (.loop|4 (- (let ((.v|7|10 .v|3)) (begin (.check! (vector? .v|7|10) 42 .v|7|10) (vector-length:vec .v|7|10))) 1) #f) .v|3) (let ((.next_i|13 ((let ((.v|22|25 .functions|3) (.i|22|25 .i|5)) (begin (.check! (fixnum? .i|22|25) 40 .v|22|25 .i|22|25) (.check! (vector? .v|22|25) 40 .v|22|25 .i|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 40 .v|22|25 .i|22|25) (.check! (>=:fix:fix .i|22|25 0) 40 .v|22|25 .i|22|25) (vector-ref:trusted .v|22|25 .i|22|25))) .v|3))) (if (.equiv?|3 .next_i|13 (let ((.v|14|17 .v|3) (.i|14|17 .i|5)) (begin (.check! (fixnum? .i|14|17) 40 .v|14|17 .i|14|17) (.check! (vector? .v|14|17) 40 .v|14|17 .i|14|17) (.check! (<:fix:fix .i|14|17 (vector-length:vec .v|14|17)) 40 .v|14|17 .i|14|17) (.check! (>=:fix:fix .i|14|17 0) 40 .v|14|17 .i|14|17) (vector-ref:trusted .v|14|17 .i|14|17)))) (.loop|4 (- .i|5 1) .flag|5) (begin (let ((.v|18|21 .v|3) (.i|18|21 .i|5) (.x|18|21 .next_i|13)) (begin (.check! (fixnum? .i|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (vector? .v|18|21) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (<:fix:fix .i|18|21 (vector-length:vec .v|18|21)) 41 .v|18|21 .i|18|21 .x|18|21) (.check! (>=:fix:fix .i|18|21 0) 41 .v|18|21 .i|18|21 .x|18|21) (vector-set!:trusted .v|18|21 .i|18|21 .x|18|21))) (.loop|4 (- .i|5 1) #t))))))) (.loop|4 (- (let ((.v|26|29 .v|3)) (begin (.check! (vector? .v|26|29) 42 .v|26|29) (vector-length:vec .v|26|29))) 1) #f))))) (.compute-fixedpoint|2 .v|1 .functions|1 .equiv?|1))))) 'compute-fixedpoint))
+(let () (begin (set! policy:lift? (lambda (.l2|1 .l|1 .args-to-add|1) (let ((.policy:lift?|2 0)) (begin (set! .policy:lift?|2 (lambda (.l2|3 .l|3 .args-to-add|3) (if (lambda-optimizations) (if (not (lambda? (lambda.body .l2|3))) (every? (lambda (.addlist|7) (< (length .addlist|7) 6)) .args-to-add|3) #f) #f))) (.policy:lift?|2 .l2|1 .l|1 .args-to-add|1))))) 'policy:lift?))
+(let () (begin (set! simplify-conditional (lambda (.exp|1 .notepad|1) (let ((.simplify-conditional|2 0)) (begin (set! .simplify-conditional|2 (lambda (.exp|3 .notepad|3) (let ((.coercion-to-boolean?|4 (unspecified))) (begin (set! .coercion-to-boolean?|4 (lambda (.exp|5) (if (conditional? .exp|5) (let ((.e1|10 (if.then .exp|5)) (.e2|10 (if.else .exp|5))) (if (constant? .e1|10) (if (eq? #t (constant.value .e1|10)) (if (constant? .e2|10) (eq? #f (constant.value .e2|10)) #f) #f) #f)) #f))) (if (not (control-optimization)) (begin (if.test-set! .exp|3 (simplify (if.test .exp|3) .notepad|3)) (if.then-set! .exp|3 (simplify (if.then .exp|3) .notepad|3)) (if.else-set! .exp|3 (simplify (if.else .exp|3) .notepad|3)) .exp|3) (let ((.test|17 (if.test .exp|3))) (let () (if (if (call? .test|17) (if (lambda? (call.proc .test|17)) (let* ((.l|26 (call.proc .test|17)) (.body|29 (lambda.body .l|26))) (let () (if (conditional? .body|29) (let ((.r|37 (lambda.r .l|26)) (.b0|37 (if.test .body|29)) (.b1|37 (if.then .body|29))) (if (variable? .b0|37) (if (variable? .b1|37) (let ((.x|43 (variable.name .b0|37))) (if (eq? .x|43 (variable.name .b1|37)) (if (local? .r|37 .x|43) (if (= 1 (length .r|37)) (= 1 (length (call.args .test|17))) #f) #f) #f)) #f) #f)) #f))) #f) #f) (let* ((.l|50 (call.proc .test|17)) (.r|53 (lambda.r .l|50)) (.body|56 (lambda.body .l|50)) (.ref|59 (if.then .body|56)) (.x|62 (variable.name .ref|59)) (.entry|65 (r-entry .r|53 .x|62))) (let () (begin (if.then-set! .body|56 (make-constant #t)) (if.else-set! .body|56 (make-conditional (if.else .body|56) (make-constant #t) (make-constant #f))) (r-entry.references-set! .entry|65 (remq .ref|59 (r-entry.references .entry|65))) (.simplify-conditional|2 .exp|3 .notepad|3)))) (let ((.test|71 (simplify (if.test .exp|3) .notepad|3))) (let () (let ((.loop|74 (unspecified))) (begin (set! .loop|74 (lambda (.test|75) (begin (if.test-set! .exp|3 .test|75) (if (constant? .test|75) (simplify (if (constant.value .test|75) (if.then .exp|3) (if.else .exp|3)) .notepad|3) (if (if (conditional? .test|75) (if (constant? (if.then .test|75)) (constant? (if.else .test|75)) #f) #f) (if (if (constant.value (if.then .test|75)) (constant.value (if.else .test|75)) #f) (post-simplify-begin (make-begin (let* ((.t1|84|87 (if.test .test|75)) (.t2|84|90 (cons (simplify (if.then .exp|3) .notepad|3) '()))) (let () (cons .t1|84|87 .t2|84|90)))) .notepad|3) (if (if (not (constant.value (if.then .test|75))) (not (constant.value (if.else .test|75))) #f) (post-simplify-begin (make-begin (let* ((.t1|98|101 (if.test .test|75)) (.t2|98|104 (cons (simplify (if.else .exp|3) .notepad|3) '()))) (let () (cons .t1|98|101 .t2|98|104)))) .notepad|3) (begin (if (not (constant.value (if.then .test|75))) (let ((.temp|112 (if.then .exp|3))) (begin (if.then-set! .exp|3 (if.else .exp|3)) (if.else-set! .exp|3 .temp|112))) (unspecified)) (if.test-set! .exp|3 (if.test .test|75)) (.loop|74 (if.test .exp|3))))) (if (if (conditional? .test|75) (let ((.temp|116|119 (.coercion-to-boolean?|4 (if.then .test|75)))) (if .temp|116|119 .temp|116|119 (.coercion-to-boolean?|4 (if.else .test|75)))) #f) (begin (if (.coercion-to-boolean?|4 (if.then .test|75)) (if.then-set! .test|75 (if.test (if.then .test|75))) (if.else-set! .test|75 (if.test (if.else .test|75)))) (.loop|74 .test|75)) (let ((.temp|121|124 (if (conditional? .test|75) (if (variable? (if.test .test|75)) (let* ((.x|168 (variable.name (if.test .test|75))) (.temp|169|172 (if (variable? (if.then .test|75)) (if (eq? .x|168 (variable.name (if.then .test|75))) 1 #f) #f))) (if .temp|169|172 .temp|169|172 (if (variable? (if.else .test|75)) (if (eq? .x|168 (variable.name (if.else .test|75))) 2 #f) #f))) #f) #f))) (if .temp|121|124 (let ((.n|125 .temp|121|124)) (begin (let ((.temp|126|129 .n|125)) (if (memv .temp|126|129 '(1)) (if.then-set! .test|75 (make-constant #t)) (if (memv .temp|126|129 '(2)) (if.else-set! .test|75 (make-constant #f)) (unspecified)))) (.loop|74 .test|75))) (if (begin? .test|75) (let ((.exprs|135 (reverse (begin.exprs .test|75)))) (begin (if.test-set! .exp|3 (let ((.x|136|139 .exprs|135)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139)))) (post-simplify-begin (make-begin (reverse (cons (.loop|74 (let ((.x|140|143 .exprs|135)) (begin (.check! (pair? .x|140|143) 0 .x|140|143) (car:pair .x|140|143)))) (let ((.x|144|147 .exprs|135)) (begin (.check! (pair? .x|144|147) 1 .x|144|147) (cdr:pair .x|144|147)))))) .notepad|3))) (if (if (call? .test|75) (if (variable? (call.proc .test|75)) (if (eq? (variable.name (call.proc .test|75)) name:not) (if (integrable? name:not) (if (integrate-usual-procedures) (= (length (call.args .test|75)) 1) #f) #f) #f) #f) #f) (begin (let ((.temp|157 (if.then .exp|3))) (begin (if.then-set! .exp|3 (if.else .exp|3)) (if.else-set! .exp|3 .temp|157))) (.loop|74 (let ((.x|158|161 (call.args .test|75))) (begin (.check! (pair? .x|158|161) 0 .x|158|161) (car:pair .x|158|161))))) (simplify-case .exp|3 .notepad|3))))))))))) (.loop|74 .test|71))))))))))))) (.simplify-conditional|2 .exp|1 .notepad|1))))) 'simplify-conditional))
+(let () (begin (set! simplify-case (lambda (.exp|1 .notepad|1) (let ((.simplify-case|2 0)) (begin (set! .simplify-case|2 (lambda (.exp|3 .notepad|3) (let ((.e0|6 (if.test .exp|3))) (if (if (call? .e0|6) (if (variable? (call.proc .e0|6)) (if (let* ((.name|12 (variable.name (call.proc .e0|6))) (.temp|13|16 (eq? .name|12 name:eq?))) (if .temp|13|16 .temp|13|16 (let ((.temp|17|20 (eq? .name|12 name:eqv?))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (eq? .name|12 name:memq))) (if .temp|21|24 .temp|21|24 (eq? .name|12 name:memv))))))) (if (integrate-usual-procedures) (if (= (length (call.args .e0|6)) 2) (if (variable? (let ((.x|29|32 (call.args .e0|6))) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) (constant? (let ((.x|35|38 (let ((.x|39|42 (call.args .e0|6))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38)))) #f) #f) #f) #f) #f) #f) (simplify-case-clauses (variable.name (let ((.x|43|46 (call.args .e0|6))) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) .exp|3 .notepad|3) (begin (if.then-set! .exp|3 (simplify (if.then .exp|3) .notepad|3)) (if.else-set! .exp|3 (simplify (if.else .exp|3) .notepad|3)) .exp|3))))) (.simplify-case|2 .exp|1 .notepad|1))))) 'simplify-case))
+(let () (begin (set! simplify-case-clauses (lambda (.var0|1 .e|1 .notepad|1) (let ((.simplify-case-clauses|2 0)) (begin (set! .simplify-case-clauses|2 (lambda (.var0|3 .e|3 .notepad|3) (let ((.analyze|4 (unspecified)) (.finish|4 (unspecified)) (.remove-duplicates|4 (unspecified)) (.collect-clauses|4 (unspecified)) (.notepad2|4 (unspecified))) (begin (set! .analyze|4 (lambda (.default|5 .fix|5 .chr|5 .sym|5 .other|5 .constants|5) (begin (notepad-var-add! .notepad2|4 .var0|3) (let () (let ((.loop|11|13|16 (unspecified))) (begin (set! .loop|11|13|16 (lambda (.y1|6|7|17) (if (null? .y1|6|7|17) (if #f #f (unspecified)) (begin (begin #t (let ((.l|21 (let ((.x|22|25 .y1|6|7|17)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (notepad-lambda-add! .notepad|3 .l|21))) (.loop|11|13|16 (let ((.x|26|29 .y1|6|7|17)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))) (.loop|11|13|16 (notepad.lambdas .notepad2|4))))) (let () (let ((.loop|35|37|40 (unspecified))) (begin (set! .loop|35|37|40 (lambda (.y1|30|31|41) (if (null? .y1|30|31|41) (if #f #f (unspecified)) (begin (begin #t (let ((.l|45 (let ((.x|46|49 .y1|30|31|41)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))))) (notepad-nonescaping-add! .notepad|3 .l|45))) (.loop|35|37|40 (let ((.x|50|53 .y1|30|31|41)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53)))))))) (.loop|35|37|40 (notepad.nonescaping .notepad2|4))))) (let () (let ((.loop|59|61|64 (unspecified))) (begin (set! .loop|59|61|64 (lambda (.y1|54|55|65) (if (null? .y1|54|55|65) (if #f #f (unspecified)) (begin (begin #t (let ((.var|69 (let ((.x|70|73 .y1|54|55|65)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))))) (notepad-var-add! .notepad|3 .var|69))) (.loop|59|61|64 (let ((.x|74|77 .y1|54|55|65)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77)))))))) (.loop|59|61|64 (append (let* ((.t1|78|81 name:fixnum?) (.t2|78|84 (let* ((.t1|88|91 name:char?) (.t2|88|94 (let* ((.t1|98|101 name:symbol?) (.t2|98|104 (let* ((.t1|108|111 name:fx<) (.t2|108|114 (let* ((.t1|118|121 name:fx-) (.t2|118|124 (let* ((.t1|128|131 name:char->integer) (.t2|128|134 (cons name:vector-ref '()))) (let () (cons .t1|128|131 .t2|128|134))))) (let () (cons .t1|118|121 .t2|118|124))))) (let () (cons .t1|108|111 .t2|108|114))))) (let () (cons .t1|98|101 .t2|98|104))))) (let () (cons .t1|88|91 .t2|88|94))))) (let () (cons .t1|78|81 .t2|78|84))) (notepad.vars .notepad2|4)))))) (analyze-clauses (notepad.vars .notepad2|4) .var0|3 .default|5 (reverse .fix|5) (reverse .chr|5) (reverse .sym|5) (reverse .other|5) .constants|5)))) (set! .finish|4 (lambda (.e|139 .fix|139 .chr|139 .sym|139 .other|139 .constants|139) (begin (if.else-set! .e|139 (simplify (if.else .e|139) .notepad2|4)) (.analyze|4 .e|139 .fix|139 .chr|139 .sym|139 .other|139 .constants|139)))) (set! .remove-duplicates|4 (lambda (.data|140 .set|140) (let ((.originals|143 .data|140) (.data|143 '()) (.set|143 .set|140)) (let () (let ((.loop|146 (unspecified))) (begin (set! .loop|146 (lambda (.originals|147 .data|147 .set|147) (if (null? .originals|147) (values .data|147 .set|147) (let ((.x|150 (let ((.x|152|155 .originals|147)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155)))) (.originals|150 (let ((.x|156|159 .originals|147)) (begin (.check! (pair? .x|156|159) 1 .x|156|159) (cdr:pair .x|156|159))))) (if (memv .x|150 .set|147) (.loop|146 .originals|150 .data|147 .set|147) (.loop|146 .originals|150 (cons .x|150 .data|147) (cons .x|150 .set|147))))))) (.loop|146 .originals|143 .data|143 .set|143))))))) (set! .collect-clauses|4 (lambda (.e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (if (not (conditional? .e|160)) (.analyze|4 (simplify .e|160 .notepad2|4) .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.test|163 (simplify (if.test .e|160) .notepad2|4)) (.code|163 (simplify (if.then .e|160) .notepad2|4))) (begin (if.test-set! .e|160 .test|163) (if.then-set! .e|160 .code|163) (if (not (call? .test|163)) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.proc|166 (call.proc .test|163)) (.args|166 (call.args .test|163))) (if (not (if (variable? .proc|166) (if (let* ((.name|171 (variable.name .proc|166)) (.temp|172|175 (eq? .name|171 name:eq?))) (if .temp|172|175 .temp|172|175 (let ((.temp|176|179 (eq? .name|171 name:eqv?))) (if .temp|176|179 .temp|176|179 (let ((.temp|180|183 (eq? .name|171 name:memq))) (if .temp|180|183 .temp|180|183 (eq? .name|171 name:memv))))))) (if (= (length .args|166) 2) (if (variable? (let ((.x|187|190 .args|166)) (begin (.check! (pair? .x|187|190) 0 .x|187|190) (car:pair .x|187|190)))) (if (eq? (variable.name (let ((.x|192|195 .args|166)) (begin (.check! (pair? .x|192|195) 0 .x|192|195) (car:pair .x|192|195)))) .var0|3) (constant? (let ((.x|198|201 (let ((.x|202|205 .args|166)) (begin (.check! (pair? .x|202|205) 1 .x|202|205) (cdr:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) #f) #f) #f) #f) #f)) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (let ((.pred|208 (variable.name .proc|166)) (.datum|208 (constant.value (let ((.x|257|260 (let ((.x|261|264 .args|166)) (begin (.check! (pair? .x|261|264) 1 .x|261|264) (cdr:pair .x|261|264))))) (begin (.check! (pair? .x|257|260) 0 .x|257|260) (car:pair .x|257|260)))))) (if (let ((.temp|209|212 (if (let ((.temp|224|227 (eq? .pred|208 name:memv))) (if .temp|224|227 .temp|224|227 (eq? .pred|208 name:memq))) (not (list? .datum|208)) #f))) (if .temp|209|212 .temp|209|212 (let ((.temp|213|216 (if (eq? .pred|208 name:eq?) (not (eqv-is-ok? .datum|208)) #f))) (if .temp|213|216 .temp|213|216 (if (eq? .pred|208 name:memq) (not (every? (lambda (.datum|220) (eqv-is-ok? .datum|220)) .datum|208)) #f))))) (.finish|4 .e|160 .fix|160 .chr|160 .sym|160 .other|160 .constants|160) (call-with-values (lambda () (.remove-duplicates|4 (if (let ((.temp|231|234 (eq? .pred|208 name:eqv?))) (if .temp|231|234 .temp|231|234 (eq? .pred|208 name:eq?))) (cons .datum|208 '()) .datum|208) .constants|160)) (lambda (.data|237 .constants|237) (let ((.clause|240 (let* ((.t1|245|248 .data|237) (.t2|245|251 (cons .code|163 '()))) (let () (cons .t1|245|248 .t2|245|251)))) (.e2|240 (if.else .e|160))) (if (every? smallint? .data|237) (.collect-clauses|4 .e2|240 (cons .clause|240 .fix|160) .chr|160 .sym|160 .other|160 .constants|237) (if (every? char? .data|237) (.collect-clauses|4 .e2|240 .fix|160 (cons .clause|240 .chr|160) .sym|160 .other|160 .constants|237) (if (every? symbol? .data|237) (.collect-clauses|4 .e2|240 .fix|160 .chr|160 (cons .clause|240 .sym|160) .other|160 .constants|237) (.collect-clauses|4 .e2|240 .fix|160 .chr|160 .sym|160 (cons .clause|240 .other|160) .constants|237))))))))))))))))) (set! .notepad2|4 (make-notepad (notepad.parent .notepad|3))) (.collect-clauses|4 .e|3 '() '() '() '() '()))))) (.simplify-case-clauses|2 .var0|1 .e|1 .notepad|1))))) 'simplify-case-clauses))
+(let () (begin (set! eqv-is-ok? (lambda (.x|1) (let ((.eqv-is-ok?|2 0)) (begin (set! .eqv-is-ok?|2 (lambda (.x|3) (let ((.temp|4|7 (smallint? .x|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (char? .x|3))) (if .temp|8|11 .temp|8|11 (let ((.temp|12|15 (symbol? .x|3))) (if .temp|12|15 .temp|12|15 (boolean? .x|3))))))))) (.eqv-is-ok?|2 .x|1))))) 'eqv-is-ok?))
+(let () (begin (set! eq-is-ok? (lambda (.x|1) (let ((.eq-is-ok?|2 0)) (begin (set! .eq-is-ok?|2 (lambda (.x|3) (eqv-is-ok? .x|3))) (.eq-is-ok?|2 .x|1))))) 'eq-is-ok?))
+(let () (begin (set! analyze-clauses (lambda (.f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1) (let ((.analyze-clauses|2 0)) (begin (set! .analyze-clauses|2 (lambda (.f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3) (if (let ((.temp|5|8 (if (null? .fix|3) (null? .chr|3) #f))) (if .temp|5|8 .temp|5|8 (< (length .constants|3) 12))) (implement-clauses-by-sequential-search .var0|3 .default|3 (append .fix|3 .chr|3 .sym|3 .other|3)) (implement-clauses .f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3)))) (.analyze-clauses|2 .f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1))))) 'analyze-clauses))
+(let () (begin (set! implement-clauses (lambda (.f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1) (let ((.implement-clauses|2 0)) (begin (set! .implement-clauses|2 (lambda (.f|3 .var0|3 .default|3 .fix|3 .chr|3 .sym|3 .other|3 .constants|3) (let* ((.name:n|6 ((make-rename-procedure) 'n)) (.entry|9 (make-r-entry .name:n|6 '() '() '())) (.f|12 (union (make-set (cons .name:n|6 '())) .f|3)) (.l|15 (make-lambda (cons .name:n|6 '()) '() '() .f|12 '() '() #f (implement-case-dispatch .name:n|6 (cons .default|3 (let () (let ((.loop|138|141|144 (unspecified))) (begin (set! .loop|138|141|144 (lambda (.y1|133|134|145 .results|133|137|145) (if (null? .y1|133|134|145) (reverse .results|133|137|145) (begin #t (.loop|138|141|144 (let ((.x|149|152 .y1|133|134|145)) (begin (.check! (pair? .x|149|152) 1 .x|149|152) (cdr:pair .x|149|152))) (cons (let ((.x|154|157 (let ((.x|158|161 (let ((.x|162|165 .y1|133|134|145)) (begin (.check! (pair? .x|162|165) 0 .x|162|165) (car:pair .x|162|165))))) (begin (.check! (pair? .x|158|161) 1 .x|158|161) (cdr:pair .x|158|161))))) (begin (.check! (pair? .x|154|157) 0 .x|154|157) (car:pair .x|154|157))) .results|133|137|145)))))) (.loop|138|141|144 (append .other|3 .fix|3 .chr|3 .sym|3) '()))))))))) (let () (make-call .l|15 (cons (implement-dispatch 0 .var0|3 (let () (let ((.loop|25|28|31 (unspecified))) (begin (set! .loop|25|28|31 (lambda (.y1|20|21|32 .results|20|24|32) (if (null? .y1|20|21|32) (reverse .results|20|24|32) (begin #t (.loop|25|28|31 (let ((.x|36|39 .y1|20|21|32)) (begin (.check! (pair? .x|36|39) 1 .x|36|39) (cdr:pair .x|36|39))) (cons (let ((.x|40|43 (let ((.x|44|47 .y1|20|21|32)) (begin (.check! (pair? .x|44|47) 0 .x|44|47) (car:pair .x|44|47))))) (begin (.check! (pair? .x|40|43) 0 .x|40|43) (car:pair .x|40|43))) .results|20|24|32)))))) (.loop|25|28|31 .other|3 '())))) (let () (let ((.loop|53|56|59 (unspecified))) (begin (set! .loop|53|56|59 (lambda (.y1|48|49|60 .results|48|52|60) (if (null? .y1|48|49|60) (reverse .results|48|52|60) (begin #t (.loop|53|56|59 (let ((.x|64|67 .y1|48|49|60)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67))) (cons (let ((.x|68|71 (let ((.x|72|75 .y1|48|49|60)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75))))) (begin (.check! (pair? .x|68|71) 0 .x|68|71) (car:pair .x|68|71))) .results|48|52|60)))))) (.loop|53|56|59 .fix|3 '())))) (let () (let ((.loop|81|84|87 (unspecified))) (begin (set! .loop|81|84|87 (lambda (.y1|76|77|88 .results|76|80|88) (if (null? .y1|76|77|88) (reverse .results|76|80|88) (begin #t (.loop|81|84|87 (let ((.x|92|95 .y1|76|77|88)) (begin (.check! (pair? .x|92|95) 1 .x|92|95) (cdr:pair .x|92|95))) (cons (let ((.x|96|99 (let ((.x|100|103 .y1|76|77|88)) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103))))) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99))) .results|76|80|88)))))) (.loop|81|84|87 .chr|3 '())))) (let () (let ((.loop|109|112|115 (unspecified))) (begin (set! .loop|109|112|115 (lambda (.y1|104|105|116 .results|104|108|116) (if (null? .y1|104|105|116) (reverse .results|104|108|116) (begin #t (.loop|109|112|115 (let ((.x|120|123 .y1|104|105|116)) (begin (.check! (pair? .x|120|123) 1 .x|120|123) (cdr:pair .x|120|123))) (cons (let ((.x|124|127 (let ((.x|128|131 .y1|104|105|116)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))))) (begin (.check! (pair? .x|124|127) 0 .x|124|127) (car:pair .x|124|127))) .results|104|108|116)))))) (.loop|109|112|115 .sym|3 '()))))) '())))))) (.implement-clauses|2 .f|1 .var0|1 .default|1 .fix|1 .chr|1 .sym|1 .other|1 .constants|1))))) 'implement-clauses))
+(let () (begin (set! implement-case-dispatch (lambda (.var0|1 .exprs|1) (let ((.implement-case-dispatch|2 0)) (begin (set! .implement-case-dispatch|2 (lambda (.var0|3 .exprs|3) (implement-intervals .var0|3 (let () (let ((.loop|10|14|17 (unspecified))) (begin (set! .loop|10|14|17 (lambda (.y1|4|6|18 .y1|4|5|18 .results|4|9|18) (if (let ((.temp|20|23 (null? .y1|4|6|18))) (if .temp|20|23 .temp|20|23 (null? .y1|4|5|18))) (reverse .results|4|9|18) (begin #t (.loop|10|14|17 (let ((.x|26|29 .y1|4|6|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (let ((.x|30|33 .y1|4|5|18)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))) (cons (let ((.n|34 (let ((.x|56|59 .y1|4|6|18)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59)))) (.code|34 (let ((.x|60|63 .y1|4|5|18)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63))))) (let* ((.t1|35|38 .n|34) (.t2|35|41 (let* ((.t1|45|48 (+ .n|34 1)) (.t2|45|51 (cons .code|34 '()))) (let () (cons .t1|45|48 .t2|45|51))))) (let () (cons .t1|35|38 .t2|35|41)))) .results|4|9|18)))))) (.loop|10|14|17 (iota (length .exprs|3)) .exprs|3 '()))))))) (.implement-case-dispatch|2 .var0|1 .exprs|1))))) 'implement-case-dispatch))
+(let () (begin (set! implement-dispatch (lambda (.prior|1 .var0|1 .other|1 .fix|1 .chr|1 .sym|1) (let ((.implement-dispatch|2 0)) (begin (set! .implement-dispatch|2 (lambda (.prior|3 .var0|3 .other|3 .fix|3 .chr|3 .sym|3) (if (not (null? .other|3)) (implement-dispatch-other (.implement-dispatch|2 (+ .prior|3 (length .other|3)) .var0|3 .fix|3 .chr|3 .sym|3 '()) .prior|3 var .other|3) (if (not (null? .fix|3)) (make-conditional (make-call (make-variable name:fixnum?) (cons (make-variable .var0|3) '())) (implement-dispatch-fixnum .prior|3 .var0|3 .fix|3) (.implement-dispatch|2 (+ .prior|3 (length .fix|3)) .var0|3 '() .chr|3 .sym|3 .other|3)) (if (not (null? .chr|3)) (make-conditional (make-call (make-variable name:char?) (cons (make-variable .var0|3) '())) (implement-dispatch-char .prior|3 .var0|3 .chr|3) (.implement-dispatch|2 (+ .prior|3 (length .chr|3)) .var0|3 .fix|3 '() .sym|3 .other|3)) (if (not (null? .sym|3)) (make-conditional (make-call (make-variable name:symbol?) (cons (make-variable .var0|3) '())) (implement-dispatch-symbol .prior|3 .var0|3 .sym|3) (.implement-dispatch|2 (+ .prior|3 (length .sym|3)) .var0|3 .fix|3 .chr|3 '() .other|3)) (make-constant 0))))))) (.implement-dispatch|2 .prior|1 .var0|1 .other|1 .fix|1 .chr|1 .sym|1))))) 'implement-dispatch))
+(let () (begin (set! implement-dispatch-fixnum (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-fixnum|2 0)) (begin (set! .implement-dispatch-fixnum|2 (lambda (.prior|3 .var0|3 .lists|3) (let ((.complete-intervals|6 (unspecified)) (.extract-intervals|6 (unspecified)) (.calculate-intervals|6 (unspecified))) (begin (set! .complete-intervals|6 (lambda (.intervals|7) (if (null? .intervals|7) .intervals|7 (if (null? (let ((.x|10|13 .intervals|7)) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13)))) .intervals|7 (let* ((.i1|17 (let ((.x|80|83 .intervals|7)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) (.i2|20 (let ((.x|72|75 (let ((.x|76|79 .intervals|7)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))))) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.end1|23 (let ((.x|63|66 (let ((.x|67|70 .i1|17)) (begin (.check! (pair? .x|67|70) 1 .x|67|70) (cdr:pair .x|67|70))))) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) (.start2|26 (let ((.x|58|61 .i2|20)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61)))) (.intervals|29 (.complete-intervals|6 (let ((.x|54|57 .intervals|7)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))))) (let () (if (= .end1|23 .start2|26) (cons .i1|17 .intervals|29) (cons .i1|17 (cons (let* ((.t1|33|36 .end1|23) (.t2|33|39 (let* ((.t1|43|46 .start2|26) (.t2|43|49 (cons (make-constant 0) '()))) (let () (cons .t1|43|46 .t2|43|49))))) (let () (cons .t1|33|36 .t2|33|39))) .intervals|29))))))))) (set! .extract-intervals|6 (lambda (.n|84 .constants|84) (if (null? .constants|84) '() (let ((.k0|87 (let ((.x|136|139 .constants|84)) (begin (.check! (pair? .x|136|139) 0 .x|136|139) (car:pair .x|136|139))))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.constants|95 .k1|95) (if (let ((.temp|97|100 (null? .constants|95))) (if .temp|97|100 .temp|97|100 (not (= .k1|95 (let ((.x|102|105 .constants|95)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105))))))) (cons (let* ((.t1|106|109 .k0|87) (.t2|106|112 (let* ((.t1|116|119 .k1|95) (.t2|116|122 (cons (make-constant .n|84) '()))) (let () (cons .t1|116|119 .t2|116|122))))) (let () (cons .t1|106|109 .t2|106|112))) (.extract-intervals|6 .n|84 .constants|95)) (begin #t (.loop|88|91|94 (let ((.x|128|131 .constants|95)) (begin (.check! (pair? .x|128|131) 1 .x|128|131) (cdr:pair .x|128|131))) (+ .k1|95 1)))))) (.loop|88|91|94 (let ((.x|132|135 .constants|84)) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))) (+ .k0|87 1))))))))) (set! .calculate-intervals|6 (lambda (.n|140 .lists|140) (let ((.loop|141 (unspecified))) (begin (set! .loop|141 (lambda (.n|142 .lists|142 .intervals|142) (if (null? .lists|142) (twobit-sort (lambda (.interval1|143 .interval2|143) (< (let ((.x|144|147 .interval1|143)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147))) (let ((.x|148|151 .interval2|143)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151))))) .intervals|142) (let ((.constants|154 (twobit-sort < (let ((.x|159|162 .lists|142)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162)))))) (.loop|141 (+ .n|142 1) (let ((.x|155|158 .lists|142)) (begin (.check! (pair? .x|155|158) 1 .x|155|158) (cdr:pair .x|155|158))) (append (.extract-intervals|6 .n|142 .constants|154) .intervals|142)))))) (.loop|141 .n|140 .lists|140 '()))))) (let* ((.intervals|163 (.complete-intervals|6 (.calculate-intervals|6 (+ .prior|3 1) .lists|3))) (.lo|166 (let ((.x|206|209 (let ((.x|210|213 .intervals|163)) (begin (.check! (pair? .x|210|213) 0 .x|210|213) (car:pair .x|210|213))))) (begin (.check! (pair? .x|206|209) 0 .x|206|209) (car:pair .x|206|209)))) (.hi|169 (let ((.x|198|201 (let ((.x|202|205 (reverse .intervals|163))) (begin (.check! (pair? .x|202|205) 0 .x|202|205) (car:pair .x|202|205))))) (begin (.check! (pair? .x|198|201) 0 .x|198|201) (car:pair .x|198|201)))) (.p|172 (length .intervals|163))) (let () (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|176|179 (make-variable .var0|3)) (.t2|176|182 (cons (make-constant .lo|166) '()))) (let () (cons .t1|176|179 .t2|176|182)))) (make-constant 0) (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|187|190 (make-variable .var0|3)) (.t2|187|193 (cons (make-constant (+ .hi|169 1)) '()))) (let () (cons .t1|187|190 .t2|187|193)))) (if (< (- .hi|169 .lo|166) (* 5 .p|172)) (implement-table-lookup .var0|3 (+ .prior|3 1) .lists|3 .lo|166 .hi|169) (implement-intervals .var0|3 .intervals|163)) (make-constant 0))))))))) (.implement-dispatch-fixnum|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-fixnum))
+(let () (begin (set! implement-dispatch-char (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-char|2 0)) (begin (set! .implement-dispatch-char|2 (lambda (.prior|3 .var0|3 .lists|3) (let* ((.lists|6 (let () (let ((.loop|67|70|73 (unspecified))) (begin (set! .loop|67|70|73 (lambda (.y1|62|63|74 .results|62|66|74) (if (null? .y1|62|63|74) (reverse .results|62|66|74) (begin #t (.loop|67|70|73 (let ((.x|78|81 .y1|62|63|74)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (cons (let ((.constants|82 (let ((.x|107|110 .y1|62|63|74)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))))) (let () (let ((.loop|88|91|94 (unspecified))) (begin (set! .loop|88|91|94 (lambda (.y1|83|84|95 .results|83|87|95) (if (null? .y1|83|84|95) (reverse .results|83|87|95) (begin #t (.loop|88|91|94 (let ((.x|99|102 .y1|83|84|95)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (cons (compat:char->integer (let ((.x|103|106 .y1|83|84|95)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106)))) .results|83|87|95)))))) (.loop|88|91|94 .constants|82 '()))))) .results|62|66|74)))))) (.loop|67|70|73 .lists|3 '()))))) (.name:n|9 ((make-rename-procedure) 'n)) (.f|12 (let* ((.t1|21|24 .name:n|9) (.t2|21|27 (let* ((.t1|31|34 name:eq?) (.t2|31|37 (let* ((.t1|41|44 name:fx<) (.t2|41|47 (let* ((.t1|51|54 name:fx-) (.t2|51|57 (cons name:vector-ref '()))) (let () (cons .t1|51|54 .t2|51|57))))) (let () (cons .t1|41|44 .t2|41|47))))) (let () (cons .t1|31|34 .t2|31|37))))) (let () (cons .t1|21|24 .t2|21|27)))) (.l|15 (make-lambda (cons .name:n|9 '()) '() '() .f|12 '() '() #f (implement-dispatch-fixnum .prior|3 .name:n|9 .lists|6)))) (let () (make-call .l|15 (make-call (make-variable name:char->integer) (cons (make-variable .var0|3) '()))))))) (.implement-dispatch-char|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-char))
+(let () (begin (set! implement-dispatch-symbol (lambda (.prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-symbol|2 0)) (begin (set! .implement-dispatch-symbol|2 (lambda (.prior|3 .var0|3 .lists|3) (implement-dispatch-other (make-constant 0) .prior|3 .var0|3 .lists|3))) (.implement-dispatch-symbol|2 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-symbol))
+(let () (begin (set! implement-dispatch-other (lambda (.default|1 .prior|1 .var0|1 .lists|1) (let ((.implement-dispatch-other|2 0)) (begin (set! .implement-dispatch-other|2 (lambda (.default|3 .prior|3 .var0|3 .lists|3) (if (null? .lists|3) .default|3 (let* ((.constants|6 (let ((.x|20|23 .lists|3)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23)))) (.lists|9 (let ((.x|16|19 .lists|3)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19)))) (.n|12 (+ .prior|3 1))) (let () (make-conditional (make-call-to-memv .var0|3 .constants|6) (make-constant .n|12) (.implement-dispatch-other|2 .default|3 .n|12 .var0|3 .lists|9))))))) (.implement-dispatch-other|2 .default|1 .prior|1 .var0|1 .lists|1))))) 'implement-dispatch-other))
+(let () (begin (set! make-call-to-memv (lambda (.var0|1 .constants|1) (let ((.make-call-to-memv|2 0)) (begin (set! .make-call-to-memv|2 (lambda (.var0|3 .constants|3) (if (null? .constants|3) (make-constant #f) (if (null? (let ((.x|6|9 .constants|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (make-call-to-eqv .var0|3 (let ((.x|10|13 .constants|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) (make-conditional (make-call-to-eqv .var0|3 (let ((.x|15|18 .constants|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18)))) (make-constant #t) (.make-call-to-memv|2 .var0|3 (let ((.x|19|22 .constants|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))))))) (.make-call-to-memv|2 .var0|1 .constants|1))))) 'make-call-to-memv))
+(let () (begin (set! make-call-to-eqv (lambda (.var0|1 .constant|1) (let ((.make-call-to-eqv|2 0)) (begin (set! .make-call-to-eqv|2 (lambda (.var0|3 .constant|3) (make-call (make-variable (if (eq-is-ok? .constant|3) name:eq? name:eqv?)) (let* ((.t1|4|7 (make-variable .var0|3)) (.t2|4|10 (cons (make-constant .constant|3) '()))) (let () (cons .t1|4|7 .t2|4|10)))))) (.make-call-to-eqv|2 .var0|1 .constant|1))))) 'make-call-to-eqv))
+(let () (begin (set! implement-table-lookup (lambda (.var0|1 .index|1 .lists|1 .lo|1 .hi|1) (let ((.implement-table-lookup|2 0)) (begin (set! .implement-table-lookup|2 (lambda (.var0|3 .index|3 .lists|3 .lo|3 .hi|3) (let ((.v|6 (make-vector (+ 1 (- .hi|3 .lo|3)) 0))) (begin (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.index|15 .lists|15) (if (null? .lists|15) (if #f #f (unspecified)) (begin (begin #t (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let ((.k|33 (let ((.x|38|41 .y1|18|19|29)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))))) (let ((.v|34|37 .v|6) (.i|34|37 (- .k|33 .lo|3)) (.x|34|37 .index|15)) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37))))) (.loop|23|25|28 (let ((.x|42|45 .y1|18|19|29)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45)))))))) (.loop|23|25|28 (let ((.x|46|49 .lists|15)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49)))))))) (.loop|8|11|14 (+ .index|15 1) (let ((.x|50|53 .lists|15)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53)))))))) (.loop|8|11|14 .index|3 .lists|3)))) (make-call (make-variable name:vector-ref) (let* ((.t1|54|57 (make-constant .v|6)) (.t2|54|60 (cons (make-call (make-variable name:fx-) (let* ((.t1|65|68 (make-variable .var0|3)) (.t2|65|71 (cons (make-constant .lo|3) '()))) (let () (cons .t1|65|68 .t2|65|71)))) '()))) (let () (cons .t1|54|57 .t2|54|60)))))))) (.implement-table-lookup|2 .var0|1 .index|1 .lists|1 .lo|1 .hi|1))))) 'implement-table-lookup))
+(let () (begin (set! implement-intervals (lambda (.var0|1 .intervals|1) (let ((.implement-intervals|2 0)) (begin (set! .implement-intervals|2 (lambda (.var0|3 .intervals|3) (if (null? (let ((.x|4|7 .intervals|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7)))) (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .intervals|3)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) (let ((.n|27 (quotient (length .intervals|3) 2))) (let () (let ((.loop|28|32|35 (unspecified))) (begin (set! .loop|28|32|35 (lambda (.n|36 .intervals1|36 .intervals2|36) (if (zero? .n|36) (let ((.intervals1|40 (reverse .intervals1|36)) (.m|40 (let ((.x|52|55 (let ((.x|56|59 .intervals2|36)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))))) (make-conditional (make-call (make-variable name:fx<) (let* ((.t1|41|44 (make-variable .var0|3)) (.t2|41|47 (cons (make-constant .m|40) '()))) (let () (cons .t1|41|44 .t2|41|47)))) (.implement-intervals|2 .var0|3 .intervals1|40) (.implement-intervals|2 .var0|3 .intervals2|36))) (begin #t (.loop|28|32|35 (- .n|36 1) (cons (let ((.x|61|64 .intervals2|36)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))) .intervals1|36) (let ((.x|65|68 .intervals2|36)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68)))))))) (.loop|28|32|35 .n|27 '() .intervals|3)))))))) (.implement-intervals|2 .var0|1 .intervals|1))))) 'implement-intervals))
+(let () (begin (set! *memq-threshold* 20) '*memq-threshold*))
+(let () (begin (set! *memv-threshold* 4) '*memv-threshold*))
+(let () (begin (set! implement-clauses-by-sequential-search (lambda (.var0|1 .default|1 .clauses|1) (let ((.implement-clauses-by-sequential-search|2 0)) (begin (set! .implement-clauses-by-sequential-search|2 (lambda (.var0|3 .default|3 .clauses|3) (if (null? .clauses|3) .default|3 (let* ((.case1|6 (let ((.x|36|39 .clauses|3)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) (.clauses|9 (let ((.x|32|35 .clauses|3)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))) (.constants1|12 (let ((.x|28|31 .case1|6)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31)))) (.code1|15 (let ((.x|20|23 (let ((.x|24|27 .case1|6)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) (let () (make-conditional (make-call-to-memv .var0|3 .constants1|12) .code1|15 (.implement-clauses-by-sequential-search|2 .var0|3 .default|3 .clauses|9))))))) (.implement-clauses-by-sequential-search|2 .var0|1 .default|1 .clauses|1))))) 'implement-clauses-by-sequential-search))
+(let () (begin (set! callgraphnode.name (lambda (.x|1) (let ((.callgraphnode.name|2 0)) (begin (set! .callgraphnode.name|2 (lambda (.x|3) (let ((.x|4|7 .x|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.callgraphnode.name|2 .x|1))))) 'callgraphnode.name))
+(let () (begin (set! callgraphnode.code (lambda (.x|1) (let ((.callgraphnode.code|2 0)) (begin (set! .callgraphnode.code|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 .x|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.code|2 .x|1))))) 'callgraphnode.code))
+(let () (begin (set! callgraphnode.vars (lambda (.x|1) (let ((.callgraphnode.vars|2 0)) (begin (set! .callgraphnode.vars|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .x|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.vars|2 .x|1))))) 'callgraphnode.vars))
+(let () (begin (set! callgraphnode.tailcalls (lambda (.x|1) (let ((.callgraphnode.tailcalls|2 0)) (begin (set! .callgraphnode.tailcalls|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 .x|3)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.tailcalls|2 .x|1))))) 'callgraphnode.tailcalls))
+(let () (begin (set! callgraphnode.nontailcalls (lambda (.x|1) (let ((.callgraphnode.nontailcalls|2 0)) (begin (set! .callgraphnode.nontailcalls|2 (lambda (.x|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .x|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.callgraphnode.nontailcalls|2 .x|1))))) 'callgraphnode.nontailcalls))
+(let () (begin (set! callgraphnode.size (lambda (.x|1) (let ((.callgraphnode.size|2 0)) (begin (set! .callgraphnode.size|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .x|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.size|2 .x|1))))) 'callgraphnode.size))
+(let () (begin (set! callgraphnode.info (lambda (.x|1) (let ((.callgraphnode.info|2 0)) (begin (set! .callgraphnode.info|2 (lambda (.x|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 (let ((.x|30|33 .x|3)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33))))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.callgraphnode.info|2 .x|1))))) 'callgraphnode.info))
+(let () (begin (set! callgraphnode.size! (lambda (.x|1 .v|1) (let ((.callgraphnode.size!|2 0)) (begin (set! .callgraphnode.size!|2 (lambda (.x|3 .v|3) (begin (set-car! (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .x|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .v|3) #f))) (.callgraphnode.size!|2 .x|1 .v|1))))) 'callgraphnode.size!))
+(let () (begin (set! callgraphnode.info! (lambda (.x|1 .v|1) (let ((.callgraphnode.info!|2 0)) (begin (set! .callgraphnode.info!|2 (lambda (.x|3 .v|3) (begin (set-car! (let ((.x|5|8 (let ((.x|9|12 (let ((.x|14|17 (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .x|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21))))) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .v|3) #f))) (.callgraphnode.info!|2 .x|1 .v|1))))) 'callgraphnode.info!))
+(let () (begin (set! callgraph (lambda (.exp|1) (let ((.callgraph|2 0)) (begin (set! .callgraph|2 (lambda (.exp|3) (let ((.adjoin|6 (unspecified))) (begin (set! .adjoin|6 (lambda (.x|7 .z|7) (if (memq .x|7 .z|7) .z|7 (cons .x|7 .z|7)))) (let* ((.result|8 '()) (.add-vertex!|9 (unspecified))) (begin (set! .add-vertex!|9 (lambda (.name|10 .l|10 .vars|10 .known|10) (let ((.tailcalls|13 '()) (.nontailcalls|13 '()) (.size|13 0)) (let ((.graph-lambda!|14 (unspecified)) (.graph!|14 (unspecified))) (begin (set! .graph-lambda!|14 (lambda (.l|15 .vars|15 .known|15 .tail?|15) (let* ((.defs|18 (lambda.defs .l|15)) (.newknown|21 (let () (let ((.loop|67|70|73 (unspecified))) (begin (set! .loop|67|70|73 (lambda (.y1|62|63|74 .results|62|66|74) (if (null? .y1|62|63|74) (reverse .results|62|66|74) (begin #t (.loop|67|70|73 (let ((.x|78|81 .y1|62|63|74)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (cons (def.lhs (let ((.x|82|85 .y1|62|63|74)) (begin (.check! (pair? .x|82|85) 0 .x|82|85) (car:pair .x|82|85)))) .results|62|66|74)))))) (.loop|67|70|73 .defs|18 '()))))) (.vars|24 (append .newknown|21 (make-null-terminated (lambda.args .l|15)) .vars|15)) (.known|27 (append .newknown|21 .known|15))) (let () (begin (let ((.f|31|34|37 (lambda (.def|57) (begin (.add-vertex!|9 (def.lhs .def|57) (def.rhs .def|57) .vars|24 .known|27) (set! .size|13 (+ .size|13 (callgraphnode.size (let ((.x|58|61 .result|8)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61)))))))))) (let () (let ((.loop|39|41|44 (unspecified))) (begin (set! .loop|39|41|44 (lambda (.y1|31|32|45) (if (null? .y1|31|32|45) (if #f #f (unspecified)) (begin (begin #t (.f|31|34|37 (let ((.x|49|52 .y1|31|32|45)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))))) (.loop|39|41|44 (let ((.x|53|56 .y1|31|32|45)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56)))))))) (.loop|39|41|44 .defs|18))))) (.graph!|14 (lambda.body .l|15) .vars|24 .known|27 .tail?|15)))))) (set! .graph!|14 (lambda (.exp|86 .vars|86 .known|86 .tail?|86) (begin (set! .size|13 (+ .size|13 1)) (let ((.temp|87|90 (let ((.x|159|162 .exp|86)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))))) (if (memv .temp|87|90 '(quote)) #f (if (memv .temp|87|90 '(lambda)) (begin (.add-vertex!|9 #f .exp|86 .vars|86 .known|86) (set! .size|13 (+ .size|13 (callgraphnode.size (let ((.x|93|96 .result|8)) (begin (.check! (pair? .x|93|96) 0 .x|93|96) (car:pair .x|93|96))))))) (if (memv .temp|87|90 '(set!)) (.graph!|14 (assignment.rhs .exp|86) .vars|86 .known|86 #f) (if (memv .temp|87|90 '(if)) (begin (.graph!|14 (if.test .exp|86) .vars|86 .known|86 #f) (.graph!|14 (if.then .exp|86) .vars|86 .known|86 .tail?|86) (.graph!|14 (if.else .exp|86) .vars|86 .known|86 .tail?|86)) (if (memv .temp|87|90 '(begin)) (if (not (variable? .exp|86)) (let () (let ((.loop|100|102|105 (unspecified))) (begin (set! .loop|100|102|105 (lambda (.exprs|106) (if (null? (let ((.x|108|111 .exprs|106)) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111)))) (.graph!|14 (let ((.x|112|115 .exprs|106)) (begin (.check! (pair? .x|112|115) 0 .x|112|115) (car:pair .x|112|115))) .vars|86 .known|86 .tail?|86) (begin (begin #t (.graph!|14 (let ((.x|117|120 .exprs|106)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120))) .vars|86 .known|86 #f)) (.loop|100|102|105 (let ((.x|121|124 .exprs|106)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))))) (.loop|100|102|105 (begin.exprs .exp|86))))) (unspecified)) (let ((.proc|128 (call.proc .exp|86))) (begin (if (variable? .proc|128) (let ((.name|132 (variable.name .proc|128))) (if (memq .name|132 .known|86) (if .tail?|86 (set! .tailcalls|13 (.adjoin|6 .name|132 .tailcalls|13)) (set! .nontailcalls|13 (.adjoin|6 .name|132 .nontailcalls|13))) (unspecified))) (if (lambda? .proc|128) (.graph-lambda!|14 .proc|128 .vars|86 .known|86 .tail?|86) (.graph!|14 .proc|128 .vars|86 .known|86 #f))) (let () (let ((.loop|140|142|145 (unspecified))) (begin (set! .loop|140|142|145 (lambda (.y1|135|136|146) (if (null? .y1|135|136|146) (if #f #f (unspecified)) (begin (begin #t (let ((.exp|150 (let ((.x|151|154 .y1|135|136|146)) (begin (.check! (pair? .x|151|154) 0 .x|151|154) (car:pair .x|151|154))))) (.graph!|14 .exp|150 .vars|86 .known|86 #f))) (.loop|140|142|145 (let ((.x|155|158 .y1|135|136|146)) (begin (.check! (pair? .x|155|158) 1 .x|155|158) (cdr:pair .x|155|158)))))))) (.loop|140|142|145 (call.args .exp|86)))))))))))))))) (.graph-lambda!|14 .l|10 .vars|10 .known|10 #t) (set! .result|8 (cons (let* ((.t1|163|166 .name|10) (.t2|163|169 (let* ((.t1|173|176 .l|10) (.t2|173|179 (let* ((.t1|183|186 .vars|10) (.t2|183|189 (let* ((.t1|193|196 .tailcalls|13) (.t2|193|199 (let* ((.t1|203|206 .nontailcalls|13) (.t2|203|209 (let* ((.t1|213|216 .size|13) (.t2|213|219 (cons #f '()))) (let () (cons .t1|213|216 .t2|213|219))))) (let () (cons .t1|203|206 .t2|203|209))))) (let () (cons .t1|193|196 .t2|193|199))))) (let () (cons .t1|183|186 .t2|183|189))))) (let () (cons .t1|173|176 .t2|173|179))))) (let () (cons .t1|163|166 .t2|163|169))) .result|8))))))) (.add-vertex!|9 #t (make-lambda '() '() '() '() '() '() '() .exp|3) '() '()) .result|8)))))) (.callgraph|2 .exp|1))))) 'callgraph))
+(let () (begin (set! view-callgraph (lambda (.g|1) (let ((.view-callgraph|2 0)) (begin (set! .view-callgraph|2 (lambda (.g|3) (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let ((.entry|19 (let ((.x|26|29 .y1|4|5|15)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (let ((.name|22 (callgraphnode.name .entry|19)) (.exp|22 (callgraphnode.code .entry|19)) (.vars|22 (callgraphnode.vars .entry|19)) (.tail|22 (callgraphnode.tailcalls .entry|19)) (.nt|22 (callgraphnode.nontailcalls .entry|19)) (.size|22 (callgraphnode.size .entry|19))) (begin (if (symbol? .name|22) (write .name|22) (if .name|22 (display "TOP LEVEL EXPRESSION") (display "ESCAPING LAMBDA EXPRESSION"))) (display ":") (newline) (display "Size: ") (write .size|22) (newline) (display "Tail calls: ") (write .tail|22) (newline) (display "Non-tail calls: ") (write .nt|22) (newline) (newline))))) (.loop|9|11|14 (let ((.x|30|33 .y1|4|5|15)) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33)))))))) (.loop|9|11|14 .g|3)))))) (.view-callgraph|2 .g|1))))) 'view-callgraph))
+(let () (begin (set! *tail-threshold* 10) '*tail-threshold*))
+(let () (begin (set! *nontail-threshold* 20) '*nontail-threshold*))
+(let () (begin (set! *multiplier* 300) '*multiplier*))
+(let () (begin (set! inline-using-callgraph! (lambda (.g|1) (let ((.inline-using-callgraph!|2 0)) (begin (set! .inline-using-callgraph!|2 (lambda (.g|3) (let ((.known|6 (make-hashtable)) (.category2|6 '()) (.category3|6 '())) (begin (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|7|8|18) (if (null? .y1|7|8|18) (if #f #f (unspecified)) (begin (begin #t (let ((.node|22 (let ((.x|28|31 .y1|7|8|18)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))))) (let ((.name|25 (callgraphnode.name .node|22)) (.tcalls|25 (callgraphnode.tailcalls .node|22)) (.ncalls|25 (callgraphnode.nontailcalls .node|22))) (begin (if (symbol? .name|25) (hashtable-put! .known|6 .name|25 .node|22) (unspecified)) (if (if (null? .tcalls|25) (null? .ncalls|25) #f) (if (< (callgraphnode.size .node|22) *nontail-threshold*) (callgraphnode.info! .node|22 #t) (unspecified)) (if (symbol? .name|25) (set! .category2|6 (cons .node|22 .category2|6)) (set! .category3|6 (cons .node|22 .category3|6)))))))) (.loop|12|14|17 (let ((.x|32|35 .y1|7|8|18)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))))))) (.loop|12|14|17 .g|3)))) (set! .category2|6 (twobit-sort (lambda (.x|36 .y|36) (< (callgraphnode.size .x|36) (callgraphnode.size .y|36))) .category2|6)) (let () (let ((.loop|42|44|47 (unspecified))) (begin (set! .loop|42|44|47 (lambda (.y1|37|38|48) (if (null? .y1|37|38|48) (if #f #f (unspecified)) (begin (begin #t (let ((.node|52 (let ((.x|53|56 .y1|37|38|48)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56))))) (inline-node! .node|52 .known|6))) (.loop|42|44|47 (let ((.x|57|60 .y1|37|38|48)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60)))))))) (.loop|42|44|47 .category2|6)))) (let () (let ((.loop|66|68|71 (unspecified))) (begin (set! .loop|66|68|71 (lambda (.y1|61|62|72) (if (null? .y1|61|62|72) (if #f #f (unspecified)) (begin (begin #t (let ((.node|76 (let ((.x|77|80 .y1|61|62|72)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (inline-node! .node|76 .known|6))) (.loop|66|68|71 (let ((.x|81|84 .y1|61|62|72)) (begin (.check! (pair? .x|81|84) 1 .x|81|84) (cdr:pair .x|81|84)))))))) (.loop|66|68|71 .category3|6)))) (hashtable-for-each (lambda (.name|85 .node|85) (callgraphnode.info! .node|85 #f)) .known|6))))) (.inline-using-callgraph!|2 .g|1))))) 'inline-using-callgraph!))
+(let () (begin (set! inline-node! (lambda (.node|1 .known|1) (let ((.inline-node!|2 0)) (begin (set! .inline-node!|2 (lambda (.node|3 .known|3) (let* ((.debugging?|6 #f) (.name|9 (callgraphnode.name .node|3)) (.exp|12 (callgraphnode.code .node|3)) (.size0|15 (callgraphnode.size .node|3)) (.budget|18 (quotient (* (- *multiplier* 100) .size0|15) 100)) (.tail-threshold|21 *tail-threshold*) (.nontail-threshold|24 *nontail-threshold*)) (let () (let ((.inline|28 (unspecified))) (begin (set! .inline|28 (lambda (.exp|29 .tail?|29 .budget|29) (if (> .budget|29 0) (let ((.temp|31|34 (let ((.x|122|125 .exp|29)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (if (memv .temp|31|34 ''lambda) .budget|29 (if (memv .temp|31|34 '(set!)) (.inline|28 (assignment.rhs .exp|29) #f .budget|29) (if (memv .temp|31|34 '(if)) (let* ((.budget|40 (.inline|28 (if.test .exp|29) #f .budget|29)) (.budget|43 (.inline|28 (if.then .exp|29) .tail?|29 .budget|40)) (.budget|46 (.inline|28 (if.else .exp|29) .tail?|29 .budget|43))) (let () .budget|46)) (if (memv .temp|31|34 '(begin)) (if (variable? .exp|29) .budget|29 (let () (let ((.loop|51|54|57 (unspecified))) (begin (set! .loop|51|54|57 (lambda (.exprs|58 .budget|58) (if (null? (let ((.x|60|63 .exprs|58)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63)))) (.inline|28 (let ((.x|64|67 .exprs|58)) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67))) .tail?|29 .budget|58) (begin #t (.loop|51|54|57 (let ((.x|69|72 .exprs|58)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))) (.inline|28 (let ((.x|73|76 .exprs|58)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76))) #f .budget|58)))))) (.loop|51|54|57 (begin.exprs .exp|29) .budget|29))))) (let* ((.budget|80 (let () (let ((.loop|104|107|110 (unspecified))) (begin (set! .loop|104|107|110 (lambda (.exprs|111 .budget|111) (if (null? .exprs|111) .budget|111 (begin #t (.loop|104|107|110 (let ((.x|114|117 .exprs|111)) (begin (.check! (pair? .x|114|117) 1 .x|114|117) (cdr:pair .x|114|117))) (.inline|28 (let ((.x|118|121 .exprs|111)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121))) #f .budget|111)))))) (.loop|104|107|110 (call.args .exp|29) .budget|29))))) (.proc|83 (call.proc .exp|29))) (if (variable? .proc|83) (let* ((.procname|87 (variable.name .proc|83)) (.procnode|90 (hashtable-get .known|3 .procname|87))) (let () (if .procnode|90 (let ((.size|96 (callgraphnode.size .procnode|90)) (.info|96 (callgraphnode.info .procnode|90))) (if (if .info|96 (if (<= .size|96 .budget|80) (<= .size|96 (if .tail?|29 .tail-threshold|21 .nontail-threshold|24)) #f) #f) (begin (if .debugging?|6 (begin (display " Inlining ") (write (variable.name .proc|83)) (newline)) (unspecified)) (call.proc-set! .exp|29 (copy-exp (callgraphnode.code .procnode|90))) (callgraphnode.size! .node|3 (+ (callgraphnode.size .node|3) .size|96)) (- .budget|80 .size|96)) (begin (if (if #f .debugging?|6 #f) (begin (display " Declining to inline ") (write (variable.name .proc|83)) (newline)) (unspecified)) .budget|80))) .budget|80))) (if (lambda? .proc|83) (.inline|28 (lambda.body .proc|83) .tail?|29 .budget|80) (.inline|28 .proc|83 #f .budget|80))))))))) -1))) (if (if #f .debugging?|6 #f) (begin (display "Processing ") (write .name|9) (newline)) (unspecified)) (let ((.budget|130 (.inline|28 (if (lambda? .exp|12) (lambda.body .exp|12) .exp|12) #t .budget|18))) (begin (if (if (< .budget|130 0) .debugging?|6 #f) (begin (display "Ran out of inlining budget for ") (write (callgraphnode.name .node|3)) (newline)) (unspecified)) (if (<= (callgraphnode.size .node|3) .nontail-threshold|24) (callgraphnode.info! .node|3 #t) (unspecified)) #f)))))))) (.inline-node!|2 .node|1 .known|1))))) 'inline-node!))
+(let () (begin (set! test-inlining (lambda (.test0|1) (let ((.test-inlining|2 0)) (begin (set! .test-inlining|2 (lambda (.test0|3) (let ((.g0|4 (unspecified)) (.exp0|4 (unspecified))) (begin (set! .g0|4 (begin (display "Computing call graph...") (newline) (callgraph .exp0|4))) (set! .exp0|4 (begin (display "Compiling...") (newline) (pass2 (pass1 .test0|3)))) (display "Inlining...") (newline) (inline-using-callgraph! .g0|4) (pretty-print (make-readable (copy-exp .exp0|4))))))) (.test-inlining|2 .test0|1))))) 'test-inlining))
+(let () (begin (set! *constant-propagation-limit* 5) '*constant-propagation-limit*))
+(let () (begin (set! constant-propagation (lambda (.exp|1) (let ((.constant-propagation|2 0)) (begin (set! .constant-propagation|2 (lambda (.exp|3) (let ((.constant-propagation|4 (unspecified))) (begin (set! .constant-propagation|4 (lambda (.exp|5 .i|5) (if (< .i|5 *constant-propagation-limit*) (let* ((.g|8 (callgraph .exp|5)) (.l|11 (callgraphnode.code (let ((.x|21|24 .g|8)) (begin (.check! (pair? .x|21|24) 0 .x|21|24) (car:pair .x|21|24))))) (.variables|14 (constant-propagation-using-callgraph .g|8)) (.changed?|17 (constant-folding! .l|11 .variables|14))) (let () (if .changed?|17 (.constant-propagation|4 (lambda.body .l|11) (+ .i|5 1)) (lambda.body .l|11)))) (unspecified)))) (.constant-propagation|4 .exp|3 0))))) (.constant-propagation|2 .exp|1))))) 'constant-propagation))
+(let () (begin (set! constant-propagation-using-callgraph (lambda (.g|1) (let ((.constant-propagation-using-callgraph|2 0)) (begin (set! .constant-propagation-using-callgraph|2 (lambda (.g|3) (let ((.debugging?|6 #f) (.folding?|6 (integrate-usual-procedures)) (.known|6 (make-hashtable)) (.variables|6 (make-hashtable)) (.counter|6 0)) (let ((.collect!|7 (unspecified)) (.combine-symbolic|7 (unspecified)) (.aeval1-error|7 (unspecified)) (.aeval1|7 (unspecified)) (.aeval|7 (unspecified)) (.join|7 (unspecified))) (begin (set! .collect!|7 (lambda (.exp|8) (let ((.temp|9|12 (let ((.x|148|151 .exp|8)) (begin (.check! (pair? .x|148|151) 0 .x|148|151) (car:pair .x|148|151))))) (if (memv .temp|9|12 '(quote)) (cons .exp|8 '()) (if (memv .temp|9|12 '(lambda)) #t (if (memv .temp|9|12 '(set!)) (begin (.collect!|7 (assignment.rhs .exp|8)) '()) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) (cons .exp|8 '()) (let () (let ((.loop|19|21|24 (unspecified))) (begin (set! .loop|19|21|24 (lambda (.exprs|25) (if (null? (let ((.x|27|30 .exprs|25)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30)))) (.collect!|7 (let ((.x|31|34 .exprs|25)) (begin (.check! (pair? .x|31|34) 0 .x|31|34) (car:pair .x|31|34)))) (begin (begin #t (.collect!|7 (let ((.x|36|39 .exprs|25)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (.loop|19|21|24 (let ((.x|40|43 .exprs|25)) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43)))))))) (.loop|19|21|24 (begin.exprs .exp|8)))))) (if (memv .temp|9|12 '(if)) (begin (.collect!|7 (if.test .exp|8)) (.collect!|7 (if.then .exp|8)) (.collect!|7 (if.else .exp|8)) #t) (let () (let ((.loop|46|49|52 (unspecified))) (begin (set! .loop|46|49|52 (lambda (.exprs|53 .reps|53) (if (null? .exprs|53) (let* ((.proc|57 (call.proc .exp|8)) (.put-args!|59 (unspecified))) (begin (set! .put-args!|59 (lambda (.args|60 .reps|60) (if (pair? .args|60) (let ((.v|64 (let ((.x|73|76 .args|60)) (begin (.check! (pair? .x|73|76) 0 .x|73|76) (car:pair .x|73|76)))) (.rep|64 (let ((.x|77|80 .reps|60)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (begin (hashtable-put! .variables|6 .v|64 .rep|64) (.put-args!|59 (let ((.x|65|68 .args|60)) (begin (.check! (pair? .x|65|68) 1 .x|65|68) (cdr:pair .x|65|68))) (let ((.x|69|72 .reps|60)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72)))))) (if (symbol? .args|60) (hashtable-put! .variables|6 .args|60 #t) #f)))) (if (variable? .proc|57) (let* ((.procname|85 (variable.name .proc|57)) (.procnode|88 (hashtable-get .known|6 .procname|85)) (.entry|91 (if .folding?|6 (constant-folding-entry .procname|85) #f))) (let () (if .procnode|88 (begin (let () (let ((.loop|102|105|108 (unspecified))) (begin (set! .loop|102|105|108 (lambda (.y1|96|98|109 .y1|96|97|109) (if (let ((.temp|111|114 (null? .y1|96|98|109))) (if .temp|111|114 .temp|111|114 (null? .y1|96|97|109))) (if #f #f (unspecified)) (begin (begin #t (let ((.v|117 (let ((.x|118|121 .y1|96|98|109)) (begin (.check! (pair? .x|118|121) 0 .x|118|121) (car:pair .x|118|121)))) (.rep|117 (let ((.x|122|125 .y1|96|97|109)) (begin (.check! (pair? .x|122|125) 0 .x|122|125) (car:pair .x|122|125))))) (hashtable-put! .variables|6 .v|117 (.combine-symbolic|7 .rep|117 (hashtable-get .variables|6 .v|117))))) (.loop|102|105|108 (let ((.x|126|129 .y1|96|98|109)) (begin (.check! (pair? .x|126|129) 1 .x|126|129) (cdr:pair .x|126|129))) (let ((.x|130|133 .y1|96|97|109)) (begin (.check! (pair? .x|130|133) 1 .x|130|133) (cdr:pair .x|130|133)))))))) (.loop|102|105|108 (lambda.args (callgraphnode.code .procnode|88)) .reps|53)))) (cons (make-variable .procname|85) '())) (if .entry|91 #t #t)))) (if (lambda? .proc|57) (begin (.put-args!|59 (lambda.args .proc|57) .reps|53) (.collect!|7 (lambda.body .proc|57))) (begin (.collect!|7 .proc|57) #t))))) (begin #t (.loop|46|49|52 (let ((.x|140|143 .exprs|53)) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))) (cons (.collect!|7 (let ((.x|144|147 .exprs|53)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147)))) .reps|53)))))) (.loop|46|49|52 (reverse (call.args .exp|8)) '())))))))))))) (set! .combine-symbolic|7 (lambda (.rep1|152 .rep2|152) (if (eq? .rep1|152 #t) #t (if (eq? .rep2|152 #t) #t (append .rep1|152 .rep2|152))))) (set! .aeval1-error|7 (lambda () (error "Compiler bug: constant propagation (aeval1)"))) (set! .aeval1|7 (lambda (.exp|157 .env|157) (let ((.temp|158|161 (let ((.x|238|241 .exp|157)) (begin (.check! (pair? .x|238|241) 0 .x|238|241) (car:pair .x|238|241))))) (if (memv .temp|158|161 '(quote)) .exp|157 (if (memv .temp|158|161 '(lambda)) #t (if (memv .temp|158|161 '(set!)) #f (if (memv .temp|158|161 '(begin)) (if (variable? .exp|157) (let* ((.name|168 (variable.name .exp|157)) (.i|171 (hashtable-get .variables|6 .name|168))) (let () (if .i|171 (let ((.v|175|178 .env|157) (.i|175|178 .i|171)) (begin (.check! (fixnum? .i|175|178) 40 .v|175|178 .i|175|178) (.check! (vector? .v|175|178) 40 .v|175|178 .i|175|178) (.check! (<:fix:fix .i|175|178 (vector-length:vec .v|175|178)) 40 .v|175|178 .i|175|178) (.check! (>=:fix:fix .i|175|178 0) 40 .v|175|178 .i|175|178) (vector-ref:trusted .v|175|178 .i|175|178))) #t))) (.aeval1-error|7)) (if (memv .temp|158|161 '(if)) (let* ((.val0|182 (.aeval1|7 (if.test .exp|157) .env|157)) (.val1|185 (.aeval1|7 (if.then .exp|157) .env|157)) (.val2|188 (.aeval1|7 (if.else .exp|157) .env|157))) (let () (if (eq? .val0|182 #t) (.join|7 .val1|185 .val2|188) (if (pair? .val0|182) (if (constant.value .val0|182) .val1|185 .val2|188) #f)))) (let () (let ((.loop|196|199|202 (unspecified))) (begin (set! .loop|196|199|202 (lambda (.exprs|203 .vals|203) (if (null? .exprs|203) (let ((.proc|207 (call.proc .exp|157))) (if (variable? .proc|207) (let* ((.procname|211 (variable.name .proc|207)) (.procnode|214 (hashtable-get .known|6 .procname|211)) (.entry|217 (if .folding?|6 (constant-folding-entry .procname|211) #f))) (let () (if .procnode|214 (let ((.v|222|225 .env|157) (.i|222|225 (hashtable-get .variables|6 .procname|211))) (begin (.check! (fixnum? .i|222|225) 40 .v|222|225 .i|222|225) (.check! (vector? .v|222|225) 40 .v|222|225 .i|222|225) (.check! (<:fix:fix .i|222|225 (vector-length:vec .v|222|225)) 40 .v|222|225 .i|222|225) (.check! (>=:fix:fix .i|222|225 0) 40 .v|222|225 .i|222|225) (vector-ref:trusted .v|222|225 .i|222|225))) (if .entry|217 #t (.aeval1-error|7))))) (.aeval1-error|7))) (begin #t (.loop|196|199|202 (let ((.x|230|233 .exprs|203)) (begin (.check! (pair? .x|230|233) 1 .x|230|233) (cdr:pair .x|230|233))) (cons (.aeval1|7 (let ((.x|234|237 .exprs|203)) (begin (.check! (pair? .x|234|237) 0 .x|234|237) (car:pair .x|234|237))) .env|157) .vals|203)))))) (.loop|196|199|202 (reverse (call.args .exp|157)) '())))))))))))) (set! .aeval|7 (lambda (.rep|242 .env|242) (if (eq? .rep|242 #t) #t (if (null? .rep|242) #f (if (null? (let ((.x|246|249 .rep|242)) (begin (.check! (pair? .x|246|249) 1 .x|246|249) (cdr:pair .x|246|249)))) (.aeval1|7 (let ((.x|250|253 .rep|242)) (begin (.check! (pair? .x|250|253) 0 .x|250|253) (car:pair .x|250|253))) .env|242) (.join|7 (.aeval1|7 (let ((.x|255|258 .rep|242)) (begin (.check! (pair? .x|255|258) 0 .x|255|258) (car:pair .x|255|258))) .env|242) (.aeval|7 (let ((.x|259|262 .rep|242)) (begin (.check! (pair? .x|259|262) 1 .x|259|262) (cdr:pair .x|259|262))) .env|242))))))) (set! .join|7 (lambda (.x|263 .y|263) (if (boolean? .x|263) (if .x|263 #t .y|263) (if (boolean? .y|263) (.join|7 .y|263 .x|263) (if (equal? .x|263 .y|263) .x|263 #t))))) (let () (let ((.loop|273|275|278 (unspecified))) (begin (set! .loop|273|275|278 (lambda (.y1|268|269|279) (if (null? .y1|268|269|279) (if #f #f (unspecified)) (begin (begin #t (let* ((.node|283 (let ((.x|323|326 .y1|268|269|279)) (begin (.check! (pair? .x|323|326) 0 .x|323|326) (car:pair .x|323|326)))) (.name|286 (callgraphnode.name .node|283)) (.code|289 (callgraphnode.code .node|283)) (.known?|292 (symbol? .name|286)) (.rep|295 (if .known?|292 '() #t))) (let () (begin (if .known?|292 (hashtable-put! .known|6 .name|286 .node|283) (unspecified)) (if (lambda? .code|289) (let () (let ((.loop|304|306|309 (unspecified))) (begin (set! .loop|304|306|309 (lambda (.y1|299|300|310) (if (null? .y1|299|300|310) (if #f #f (unspecified)) (begin (begin #t (let ((.var|314 (let ((.x|315|318 .y1|299|300|310)) (begin (.check! (pair? .x|315|318) 0 .x|315|318) (car:pair .x|315|318))))) (hashtable-put! .variables|6 .var|314 .rep|295))) (.loop|304|306|309 (let ((.x|319|322 .y1|299|300|310)) (begin (.check! (pair? .x|319|322) 1 .x|319|322) (cdr:pair .x|319|322)))))))) (.loop|304|306|309 (make-null-terminated (lambda.args .code|289)))))) (unspecified)))))) (.loop|273|275|278 (let ((.x|327|330 .y1|268|269|279)) (begin (.check! (pair? .x|327|330) 1 .x|327|330) (cdr:pair .x|327|330)))))))) (.loop|273|275|278 .g|3)))) (let () (let ((.loop|336|338|341 (unspecified))) (begin (set! .loop|336|338|341 (lambda (.y1|331|332|342) (if (null? .y1|331|332|342) (if #f #f (unspecified)) (begin (begin #t (let ((.node|346 (let ((.x|352|355 .y1|331|332|342)) (begin (.check! (pair? .x|352|355) 0 .x|352|355) (car:pair .x|352|355))))) (let ((.name|349 (callgraphnode.name .node|346)) (.code|349 (callgraphnode.code .node|346))) (if (symbol? .name|349) (hashtable-put! .variables|6 .name|349 (.collect!|7 (lambda.body .code|349))) (.collect!|7 (lambda.body .code|349)))))) (.loop|336|338|341 (let ((.x|356|359 .y1|331|332|342)) (begin (.check! (pair? .x|356|359) 1 .x|356|359) (cdr:pair .x|356|359)))))))) (.loop|336|338|341 .g|3)))) (if (if #f .debugging?|6 #f) (begin (hashtable-for-each (lambda (.v|362 .rep|362) (begin (write .v|362) (display ": ") (write .rep|362) (newline))) .variables|6) (display "----------------------------------------") (newline)) (unspecified)) (let* ((.n|365 (hashtable-size .variables|6)) (.vars|368 (hashtable-map (lambda (.v|482 .rep|482) .v|482) .variables|6)) (.reps|371 (let () (let ((.loop|462|465|468 (unspecified))) (begin (set! .loop|462|465|468 (lambda (.y1|457|458|469 .results|457|461|469) (if (null? .y1|457|458|469) (reverse .results|457|461|469) (begin #t (.loop|462|465|468 (let ((.x|473|476 .y1|457|458|469)) (begin (.check! (pair? .x|473|476) 1 .x|473|476) (cdr:pair .x|473|476))) (cons (let ((.v|477 (let ((.x|478|481 .y1|457|458|469)) (begin (.check! (pair? .x|478|481) 0 .x|478|481) (car:pair .x|478|481))))) (hashtable-get .variables|6 .v|477)) .results|457|461|469)))))) (.loop|462|465|468 .vars|368 '()))))) (.init|374 (make-vector .n|365 #f)) (.next|377 (make-vector .n|365 '()))) (let () (begin (let () (let ((.loop|382|386|389 (unspecified))) (begin (set! .loop|382|386|389 (lambda (.i|390 .vars|390 .reps|390) (if (= .i|390 .n|365) (if #f #f (unspecified)) (begin (begin #t (hashtable-put! .variables|6 (let ((.x|393|396 .vars|390)) (begin (.check! (pair? .x|393|396) 0 .x|393|396) (car:pair .x|393|396))) .i|390) (let ((.v|397|400 .next|377) (.i|397|400 .i|390) (.x|397|400 (let ((.rep|403 (let ((.x|405|408 .reps|390)) (begin (.check! (pair? .x|405|408) 0 .x|405|408) (car:pair .x|405|408))))) (lambda (.env|404) (.aeval|7 .rep|403 .env|404))))) (begin (.check! (fixnum? .i|397|400) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (vector? .v|397|400) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (<:fix:fix .i|397|400 (vector-length:vec .v|397|400)) 41 .v|397|400 .i|397|400 .x|397|400) (.check! (>=:fix:fix .i|397|400 0) 41 .v|397|400 .i|397|400 .x|397|400) (vector-set!:trusted .v|397|400 .i|397|400 .x|397|400)))) (.loop|382|386|389 (+ .i|390 1) (let ((.x|409|412 .vars|390)) (begin (.check! (pair? .x|409|412) 1 .x|409|412) (cdr:pair .x|409|412))) (let ((.x|413|416 .reps|390)) (begin (.check! (pair? .x|413|416) 1 .x|413|416) (cdr:pair .x|413|416)))))))) (.loop|382|386|389 0 .vars|368 .reps|371)))) (compute-fixedpoint .init|374 .next|377 equal?) (let () (let ((.loop|422|424|427 (unspecified))) (begin (set! .loop|422|424|427 (lambda (.y1|417|418|428) (if (null? .y1|417|418|428) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|432 (let ((.x|448|451 .y1|417|418|428)) (begin (.check! (pair? .x|448|451) 0 .x|448|451) (car:pair .x|448|451)))) (.i|435 (hashtable-get .variables|6 .v|432)) (.aval|438 (let ((.v|444|447 .init|374) (.i|444|447 .i|435)) (begin (.check! (fixnum? .i|444|447) 40 .v|444|447 .i|444|447) (.check! (vector? .v|444|447) 40 .v|444|447 .i|444|447) (.check! (<:fix:fix .i|444|447 (vector-length:vec .v|444|447)) 40 .v|444|447 .i|444|447) (.check! (>=:fix:fix .i|444|447 0) 40 .v|444|447 .i|444|447) (vector-ref:trusted .v|444|447 .i|444|447))))) (let () (begin (hashtable-put! .variables|6 .v|432 .aval|438) (if (if .debugging?|6 (not (eq? .aval|438 #t)) #f) (begin (write .v|432) (display ": ") (write .aval|438) (newline)) (unspecified)))))) (.loop|422|424|427 (let ((.x|452|455 .y1|417|418|428)) (begin (.check! (pair? .x|452|455) 1 .x|452|455) (cdr:pair .x|452|455)))))))) (.loop|422|424|427 .vars|368)))) .variables|6)))))))) (.constant-propagation-using-callgraph|2 .g|1))))) 'constant-propagation-using-callgraph))
+(let () (begin (set! constant-folding! (lambda (.l|1 .variables|1) (let ((.constant-folding!|2 0)) (begin (set! .constant-folding!|2 (lambda (.l|3 .variables|3) (let ((.debugging?|6 #f) (.msg1|6 " Propagating constant value for ") (.msg2|6 " Folding: ") (.msg3|6 " ==> ") (.folding?|6 (integrate-usual-procedures)) (.changed?|6 #f)) (let ((.fold!|7 (unspecified)) (.delete-ignored-args!|7 (unspecified))) (begin (set! .fold!|7 (lambda (.exp|8) (let ((.temp|9|12 (let ((.x|403|406 .exp|8)) (begin (.check! (pair? .x|403|406) 0 .x|403|406) (car:pair .x|403|406))))) (if (memv .temp|9|12 '(quote)) .exp|8 (if (memv .temp|9|12 '(lambda)) (let ((.rinfo|17 (lambda.r .exp|8)) (.known|17 (let () (let ((.loop|166|169|172 (unspecified))) (begin (set! .loop|166|169|172 (lambda (.y1|161|162|173 .results|161|165|173) (if (null? .y1|161|162|173) (reverse .results|161|165|173) (begin #t (.loop|166|169|172 (let ((.x|177|180 .y1|161|162|173)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180))) (cons (def.lhs (let ((.x|181|184 .y1|161|162|173)) (begin (.check! (pair? .x|181|184) 0 .x|181|184) (car:pair .x|181|184)))) .results|161|165|173)))))) (.loop|166|169|172 (lambda.defs .exp|8) '())))))) (begin (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let* ((.entry|33 (let ((.x|102|105 .y1|18|19|29)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) (.v|36 (r-entry.name .entry|33)) (.aval|39 (hashtable-fetch .variables|3 .v|36 #t))) (let () (if (if (pair? .aval|39) (not (memq .v|36 .known|17)) #f) (let ((.x|47 (constant.value .aval|39))) (if (let ((.temp|48|51 (boolean? .x|47))) (if .temp|48|51 .temp|48|51 (let ((.temp|52|55 (null? .x|47))) (if .temp|52|55 .temp|52|55 (let ((.temp|56|59 (symbol? .x|47))) (if .temp|56|59 .temp|56|59 (let ((.temp|60|63 (number? .x|47))) (if .temp|60|63 .temp|60|63 (let ((.temp|64|67 (char? .x|47))) (if .temp|64|67 .temp|64|67 (if (vector? .x|47) (zero? (let ((.v|71|74 .x|47)) (begin (.check! (vector? .v|71|74) 42 .v|71|74) (vector-length:vec .v|71|74)))) #f))))))))))) (let ((.refs|77 (r-entry.references .entry|33))) (begin (let () (let ((.loop|83|85|88 (unspecified))) (begin (set! .loop|83|85|88 (lambda (.y1|78|79|89) (if (null? .y1|78|79|89) (if #f #f (unspecified)) (begin (begin #t (let ((.ref|93 (let ((.x|94|97 .y1|78|79|89)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))))) (variable-set! .ref|93 .aval|39))) (.loop|83|85|88 (let ((.x|98|101 .y1|78|79|89)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101)))))))) (.loop|83|85|88 .refs|77)))) (lambda.r-set! .exp|8 (remq .entry|33 (lambda.r .exp|8))) (flag-as-ignored .v|36 .exp|8) (if .debugging?|6 (begin (display .msg1|6) (write .v|36) (display ": ") (write .aval|39) (newline)) (unspecified)))) (unspecified))) (unspecified))))) (.loop|23|25|28 (let ((.x|106|109 .y1|18|19|29)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109)))))))) (.loop|23|25|28 .rinfo|17)))) (let () (let ((.loop|115|117|120 (unspecified))) (begin (set! .loop|115|117|120 (lambda (.y1|110|111|121) (if (null? .y1|110|111|121) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|125 (let ((.x|153|156 .y1|110|111|121)) (begin (.check! (pair? .x|153|156) 0 .x|153|156) (car:pair .x|153|156)))) (.name|128 (def.lhs .def|125)) (.rhs|131 (def.rhs .def|125)) (.entry|134 (r-lookup .rinfo|17 .name|128)) (.calls|137 (r-entry.calls .entry|134))) (let () (if (null? .calls|137) (begin (lambda.defs-set! .exp|8 (remq .def|125 (lambda.defs .exp|8))) (lambda.r-set! .exp|8 (remq .entry|134 (lambda.r .exp|8)))) (let* ((.formals0|143 (append (lambda.args .rhs|131) '())) (.l|146 (.fold!|7 .rhs|131)) (.formals1|149 (lambda.args .l|146))) (let () (if (not (equal? .formals0|143 .formals1|149)) (.delete-ignored-args!|7 .l|146 .formals0|143 .calls|137) (unspecified)))))))) (.loop|115|117|120 (let ((.x|157|160 .y1|110|111|121)) (begin (.check! (pair? .x|157|160) 1 .x|157|160) (cdr:pair .x|157|160)))))))) (.loop|115|117|120 (lambda.defs .exp|8))))) (lambda.body-set! .exp|8 (.fold!|7 (lambda.body .exp|8))) .exp|8)) (if (memv .temp|9|12 '(set!)) (begin (assignment.rhs-set! .exp|8 (.fold!|7 (assignment.rhs .exp|8))) .exp|8) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) .exp|8 (post-simplify-begin (make-begin (let () (let ((.loop|192|195|198 (unspecified))) (begin (set! .loop|192|195|198 (lambda (.y1|187|188|199 .results|187|191|199) (if (null? .y1|187|188|199) (reverse .results|187|191|199) (begin #t (.loop|192|195|198 (let ((.x|203|206 .y1|187|188|199)) (begin (.check! (pair? .x|203|206) 1 .x|203|206) (cdr:pair .x|203|206))) (cons (.fold!|7 (let ((.x|207|210 .y1|187|188|199)) (begin (.check! (pair? .x|207|210) 0 .x|207|210) (car:pair .x|207|210)))) .results|187|191|199)))))) (.loop|192|195|198 (begin.exprs .exp|8) '()))))) (make-notepad #f))) (if (memv .temp|9|12 '(if)) (let ((.exp0|214 (.fold!|7 (if.test .exp|8))) (.exp1|214 (.fold!|7 (if.then .exp|8))) (.exp2|214 (.fold!|7 (if.else .exp|8)))) (if (constant? .exp0|214) (let ((.newexp|217 (if (constant.value .exp0|214) .exp1|214 .exp2|214))) (begin (if .debugging?|6 (begin (display .msg2|6) (write (make-readable .exp|8)) (display .msg3|6) (write (make-readable .newexp|217)) (newline)) (unspecified)) (set! .changed?|6 #t) .newexp|217)) (make-conditional .exp0|214 .exp1|214 .exp2|214))) (let ((.args|221 (let () (let ((.loop|384|387|390 (unspecified))) (begin (set! .loop|384|387|390 (lambda (.y1|379|380|391 .results|379|383|391) (if (null? .y1|379|380|391) (reverse .results|379|383|391) (begin #t (.loop|384|387|390 (let ((.x|395|398 .y1|379|380|391)) (begin (.check! (pair? .x|395|398) 1 .x|395|398) (cdr:pair .x|395|398))) (cons (.fold!|7 (let ((.x|399|402 .y1|379|380|391)) (begin (.check! (pair? .x|399|402) 0 .x|399|402) (car:pair .x|399|402)))) .results|379|383|391)))))) (.loop|384|387|390 (call.args .exp|8) '()))))) (.proc|221 (.fold!|7 (call.proc .exp|8)))) (if (if .folding?|6 (if (variable? .proc|221) (if (every? constant? .args|221) (let ((.entry|229 (constant-folding-entry (variable.name .proc|221)))) (if .entry|229 (let ((.preds|234 (constant-folding-predicates .entry|229))) (if (= (length .args|221) (length .preds|234)) (every? (lambda (.x|237) .x|237) (let () (let ((.loop|244|248|251 (unspecified))) (begin (set! .loop|244|248|251 (lambda (.y1|238|240|252 .y1|238|239|252 .results|238|243|252) (if (let ((.temp|254|257 (null? .y1|238|240|252))) (if .temp|254|257 .temp|254|257 (null? .y1|238|239|252))) (reverse .results|238|243|252) (begin #t (.loop|244|248|251 (let ((.x|260|263 .y1|238|240|252)) (begin (.check! (pair? .x|260|263) 1 .x|260|263) (cdr:pair .x|260|263))) (let ((.x|264|267 .y1|238|239|252)) (begin (.check! (pair? .x|264|267) 1 .x|264|267) (cdr:pair .x|264|267))) (cons (let ((.f|268 (let ((.x|269|272 .y1|238|240|252)) (begin (.check! (pair? .x|269|272) 0 .x|269|272) (car:pair .x|269|272)))) (.v|268 (let ((.x|273|276 .y1|238|239|252)) (begin (.check! (pair? .x|273|276) 0 .x|273|276) (car:pair .x|273|276))))) (.f|268 .v|268)) .results|238|243|252)))))) (.loop|244|248|251 (constant-folding-predicates .entry|229) (let () (let ((.loop|282|285|288 (unspecified))) (begin (set! .loop|282|285|288 (lambda (.y1|277|278|289 .results|277|281|289) (if (null? .y1|277|278|289) (reverse .results|277|281|289) (begin #t (.loop|282|285|288 (let ((.x|293|296 .y1|277|278|289)) (begin (.check! (pair? .x|293|296) 1 .x|293|296) (cdr:pair .x|293|296))) (cons (constant.value (let ((.x|297|300 .y1|277|278|289)) (begin (.check! (pair? .x|297|300) 0 .x|297|300) (car:pair .x|297|300)))) .results|277|281|289)))))) (.loop|282|285|288 .args|221 '())))) '()))))) #f)) #f)) #f) #f) #f) (begin (set! .changed?|6 #t) (let ((.result|303 (make-constant (apply (constant-folding-folder (constant-folding-entry (variable.name .proc|221))) (let () (let ((.loop|309|312|315 (unspecified))) (begin (set! .loop|309|312|315 (lambda (.y1|304|305|316 .results|304|308|316) (if (null? .y1|304|305|316) (reverse .results|304|308|316) (begin #t (.loop|309|312|315 (let ((.x|320|323 .y1|304|305|316)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) (cons (constant.value (let ((.x|324|327 .y1|304|305|316)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327)))) .results|304|308|316)))))) (.loop|309|312|315 .args|221 '())))))))) (begin (if .debugging?|6 (begin (display .msg2|6) (write (make-readable (make-call .proc|221 .args|221))) (display .msg3|6) (write .result|303) (newline)) (unspecified)) .result|303))) (if (if (lambda? .proc|221) (list? (lambda.args .proc|221)) #f) (let ((.formals|333 (reverse (lambda.args .proc|221))) (.actuals|333 (reverse .args|221)) (.processed-formals|333 '()) (.processed-actuals|333 '()) (.for-effect|333 '())) (let () (let ((.loop|336 (unspecified))) (begin (set! .loop|336 (lambda (.formals|337 .actuals|337 .processed-formals|337 .processed-actuals|337 .for-effect|337) (if (null? .formals|337) (begin (lambda.args-set! .proc|221 .processed-formals|337) (call.args-set! .exp|8 .processed-actuals|337) (let ((.call|341 (if (if (null? .processed-formals|337) (null? (lambda.defs .proc|221)) #f) (lambda.body .proc|221) .exp|8))) (if (null? .for-effect|337) .call|341 (post-simplify-begin (make-begin (reverse (cons .call|341 .for-effect|337))) (make-notepad #f))))) (if (ignored? (let ((.x|345|348 .formals|337)) (begin (.check! (pair? .x|345|348) 0 .x|345|348) (car:pair .x|345|348)))) (.loop|336 (let ((.x|349|352 .formals|337)) (begin (.check! (pair? .x|349|352) 1 .x|349|352) (cdr:pair .x|349|352))) (let ((.x|353|356 .actuals|337)) (begin (.check! (pair? .x|353|356) 1 .x|353|356) (cdr:pair .x|353|356))) .processed-formals|337 .processed-actuals|337 (cons (let ((.x|357|360 .actuals|337)) (begin (.check! (pair? .x|357|360) 0 .x|357|360) (car:pair .x|357|360))) .for-effect|337)) (.loop|336 (let ((.x|362|365 .formals|337)) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))) (let ((.x|366|369 .actuals|337)) (begin (.check! (pair? .x|366|369) 1 .x|366|369) (cdr:pair .x|366|369))) (cons (let ((.x|370|373 .formals|337)) (begin (.check! (pair? .x|370|373) 0 .x|370|373) (car:pair .x|370|373))) .processed-formals|337) (cons (let ((.x|374|377 .actuals|337)) (begin (.check! (pair? .x|374|377) 0 .x|374|377) (car:pair .x|374|377))) .processed-actuals|337) .for-effect|337))))) (.loop|336 .formals|333 .actuals|333 .processed-formals|333 .processed-actuals|333 .for-effect|333))))) (begin (call.proc-set! .exp|8 .proc|221) (call.args-set! .exp|8 .args|221) .exp|8)))))))))))) (set! .delete-ignored-args!|7 (lambda (.l|407 .formals0|407 .calls|407) (let ((.formals1|410 (lambda.args .l|407))) (begin (let () (let ((.loop|416|418|421 (unspecified))) (begin (set! .loop|416|418|421 (lambda (.y1|411|412|422) (if (null? .y1|411|412|422) (if #f #f (unspecified)) (begin (begin #t (let ((.call|426 (let ((.x|465|468 .y1|411|412|422)) (begin (.check! (pair? .x|465|468) 0 .x|465|468) (car:pair .x|465|468))))) (let () (let ((.loop|427|432|435 (unspecified))) (begin (set! .loop|427|432|435 (lambda (.formals0|436 .formals1|436 .args|436 .newargs|436) (if (null? .formals0|436) (call.args-set! .call|426 (reverse .newargs|436)) (begin #t (.loop|427|432|435 (let ((.x|439|442 .formals0|436)) (begin (.check! (pair? .x|439|442) 1 .x|439|442) (cdr:pair .x|439|442))) (let ((.x|443|446 .formals1|436)) (begin (.check! (pair? .x|443|446) 1 .x|443|446) (cdr:pair .x|443|446))) (let ((.x|447|450 .args|436)) (begin (.check! (pair? .x|447|450) 1 .x|447|450) (cdr:pair .x|447|450))) (if (if (eq? (let ((.x|452|455 .formals1|436)) (begin (.check! (pair? .x|452|455) 0 .x|452|455) (car:pair .x|452|455))) name:ignored) (pair? (hashtable-get .variables|3 (let ((.x|457|460 .formals0|436)) (begin (.check! (pair? .x|457|460) 0 .x|457|460) (car:pair .x|457|460))))) #f) .newargs|436 (cons (let ((.x|461|464 .args|436)) (begin (.check! (pair? .x|461|464) 0 .x|461|464) (car:pair .x|461|464))) .newargs|436))))))) (.loop|427|432|435 .formals0|407 .formals1|410 (call.args .call|426) '())))))) (.loop|416|418|421 (let ((.x|469|472 .y1|411|412|422)) (begin (.check! (pair? .x|469|472) 1 .x|469|472) (cdr:pair .x|469|472)))))))) (.loop|416|418|421 .calls|407)))) (let () (let ((.loop|473|477|480 (unspecified))) (begin (set! .loop|473|477|480 (lambda (.formals0|481 .formals1|481 .formals2|481) (if (null? .formals0|481) (lambda.args-set! .l|407 (reverse .formals2|481)) (begin #t (.loop|473|477|480 (let ((.x|484|487 .formals0|481)) (begin (.check! (pair? .x|484|487) 1 .x|484|487) (cdr:pair .x|484|487))) (let ((.x|488|491 .formals1|481)) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))) (if (if (not (eq? (let ((.x|493|496 .formals0|481)) (begin (.check! (pair? .x|493|496) 0 .x|493|496) (car:pair .x|493|496))) (let ((.x|497|500 .formals1|481)) (begin (.check! (pair? .x|497|500) 0 .x|497|500) (car:pair .x|497|500))))) (if (eq? (let ((.x|502|505 .formals1|481)) (begin (.check! (pair? .x|502|505) 0 .x|502|505) (car:pair .x|502|505))) name:ignored) (pair? (hashtable-get .variables|3 (let ((.x|507|510 .formals0|481)) (begin (.check! (pair? .x|507|510) 0 .x|507|510) (car:pair .x|507|510))))) #f) #f) .formals2|481 (cons (let ((.x|511|514 .formals1|481)) (begin (.check! (pair? .x|511|514) 0 .x|511|514) (car:pair .x|511|514))) .formals2|481))))))) (.loop|473|477|480 .formals0|407 .formals1|410 '())))))))) (.fold!|7 .l|3) .changed?|6))))) (.constant-folding!|2 .l|1 .variables|1))))) 'constant-folding!))
+(let () (begin (set! a-normal-form-declaration (cons 'anf '())) 'a-normal-form-declaration))
+(let () (begin (set! a-normal-form (lambda (.e|1 . .rest|1) (let ((.complicated?|2 (unspecified)) (.normalize-let|2 (unspecified)) (.normalize-let-error|2 (unspecified)) (.unpermute|2 (unspecified)) (.permute|2 (unspecified)) (.anf-order-of-evaluation|2 (unspecified)) (.anf-call|2 (unspecified)) (.anf-conditional|2 (unspecified)) (.anf-assignment|2 (unspecified)) (.anf-lambda|2 (unspecified)) (.anf-sequential|2 (unspecified)) (.anf-make-let*|2 (unspecified)) (.anf-result|2 (unspecified)) (.anf-bind|2 (unspecified)) (.anf-bind-name|2 (unspecified)) (.anf-bind-dummy|2 (unspecified)) (.anf|2 (unspecified)) (.newtemp|2 (unspecified)) (.a-normal-form|2 (unspecified)) (.temp-counter|2 (unspecified)) (.anf:dummy|2 (unspecified)) (.temp-prefix|2 (unspecified))) (begin (set! .complicated?|2 (lambda (.exp|3) (let* ((.budget|6 10) (.complicated?|7 (unspecified))) (begin (set! .complicated?|7 (lambda (.exp|8) (begin (set! .budget|6 (- .budget|6 1)) (if (zero? .budget|6) #t (let ((.temp|9|12 (let ((.x|34|37 .exp|8)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (if (memv .temp|9|12 '(quote)) #f (if (memv .temp|9|12 '(lambda)) #f (if (memv .temp|9|12 '(set!)) (.complicated?|7 (assignment.rhs .exp|8)) (if (memv .temp|9|12 '(if)) (let ((.temp|17|20 (.complicated?|7 (if.test .exp|8)))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (.complicated?|7 (if.then .exp|8)))) (if .temp|21|24 .temp|21|24 (.complicated?|7 (if.else .exp|8)))))) (if (memv .temp|9|12 '(begin)) (if (variable? .exp|8) #f (some? .complicated?|7 (begin.exprs .exp|8))) (let ((.proc|30 (call.proc .exp|8))) (if (if (variable? .proc|30) (if (integrate-usual-procedures) (prim-entry (variable.name .proc|30)) #f) #f) (some? .complicated?|7 (call.args .exp|8)) #t)))))))))))) (.complicated?|7 .exp|3))))) (set! .normalize-let|2 (lambda (.exp|38) (let ((.l|41 (call.proc .exp|38))) (let () (let ((.formals|47 (lambda.args .l|41)) (.args|47 (call.args .exp|38)) (.newformals|47 '()) (.newargs|47 '())) (let () (let ((.loop|50 (unspecified))) (begin (set! .loop|50 (lambda (.formals|51 .args|51 .newformals|51 .newargs|51) (if (null? .formals|51) (if (null? .args|51) (begin (lambda.args-set! .l|41 (reverse .newformals|51)) (call.args-set! .exp|38 (reverse .newargs|51))) (begin (.normalize-let-error|2 .exp|38) (.loop|50 (cons (.newtemp|2) '()) .args|51 .newformals|51 .newargs|51))) (if (pair? .formals|51) (if (pair? .args|51) (.loop|50 (let ((.x|55|58 .formals|51)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))) (let ((.x|59|62 .args|51)) (begin (.check! (pair? .x|59|62) 1 .x|59|62) (cdr:pair .x|59|62))) (cons (let ((.x|63|66 .formals|51)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66))) .newformals|51) (cons (let ((.x|67|70 .args|51)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))) .newargs|51)) (begin (.normalize-let-error|2 .exp|38) (.loop|50 .formals|51 (cons (make-constant 0) .args|51) .newformals|51 .newargs|51))) (.loop|50 (cons .formals|51 '()) (cons (make-call-to-list .args|51) '()) .newformals|51 .newargs|51))))) (.loop|50 .formals|47 .args|47 .newformals|47 .newargs|47))))))))) (set! .normalize-let-error|2 (lambda (.exp|74) (if (issue-warnings) (begin (display "WARNING from compiler: ") (display "Wrong number of arguments ") (display "to lambda expression") (newline) (pretty-print (make-readable .exp|74) #t) (newline)) (unspecified)))) (set! .unpermute|2 (lambda (.things|75 .pi|75) (let* ((.v0|78 (list->vector .things|75)) (.v1|81 (make-vector (let ((.v|112|115 .v0|78)) (begin (.check! (vector? .v|112|115) 42 .v|112|115) (vector-length:vec .v|112|115))) '()))) (let () (let () (let ((.loop|85|88|91 (unspecified))) (begin (set! .loop|85|88|91 (lambda (.pi|92 .k|92) (if (null? .pi|92) (vector->list .v1|81) (begin (begin #t (let ((.v|95|98 .v1|81) (.i|95|98 (let ((.x|99|102 .pi|92)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.x|95|98 (let ((.v|103|106 .v0|78) (.i|103|106 .k|92)) (begin (.check! (fixnum? .i|103|106) 40 .v|103|106 .i|103|106) (.check! (vector? .v|103|106) 40 .v|103|106 .i|103|106) (.check! (<:fix:fix .i|103|106 (vector-length:vec .v|103|106)) 40 .v|103|106 .i|103|106) (.check! (>=:fix:fix .i|103|106 0) 40 .v|103|106 .i|103|106) (vector-ref:trusted .v|103|106 .i|103|106))))) (begin (.check! (fixnum? .i|95|98) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (vector? .v|95|98) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (<:fix:fix .i|95|98 (vector-length:vec .v|95|98)) 41 .v|95|98 .i|95|98 .x|95|98) (.check! (>=:fix:fix .i|95|98 0) 41 .v|95|98 .i|95|98 .x|95|98) (vector-set!:trusted .v|95|98 .i|95|98 .x|95|98)))) (.loop|85|88|91 (let ((.x|107|110 .pi|92)) (begin (.check! (pair? .x|107|110) 1 .x|107|110) (cdr:pair .x|107|110))) (+ .k|92 1)))))) (.loop|85|88|91 .pi|75 0)))))))) (set! .permute|2 (lambda (.things|116 .pi|116) (let ((.v|119 (list->vector .things|116))) (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.i|140 (let ((.x|145|148 .y1|120|121|132)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))))) (let ((.v|141|144 .v|119) (.i|141|144 .i|140)) (begin (.check! (fixnum? .i|141|144) 40 .v|141|144 .i|141|144) (.check! (vector? .v|141|144) 40 .v|141|144 .i|141|144) (.check! (<:fix:fix .i|141|144 (vector-length:vec .v|141|144)) 40 .v|141|144 .i|141|144) (.check! (>=:fix:fix .i|141|144 0) 40 .v|141|144 .i|141|144) (vector-ref:trusted .v|141|144 .i|141|144)))) .results|120|124|132)))))) (.loop|125|128|131 .pi|116 '()))))))) (set! .anf-order-of-evaluation|2 (lambda (.exprs|149 .regvars|149 .for-primop?|149) (let ((.ordering|150 (unspecified))) (begin (set! .ordering|150 (lambda (.targets|151 .exprs|151 .alist|151) (let* ((.para|154 (parallel-assignment .targets|151 .alist|151 .exprs|151)) (.temp|155|158 .para|154)) (if .temp|155|158 .temp|155|158 (cons (let ((.x|160|163 .targets|151)) (begin (.check! (pair? .x|160|163) 0 .x|160|163) (car:pair .x|160|163))) (.ordering|150 (let ((.x|164|167 .targets|151)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (let ((.x|168|171 .exprs|151)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171))) .alist|151)))))) (if (parallel-assignment-optimization) (if (null? .exprs|149) '() (if (null? (let ((.x|174|177 .exprs|149)) (begin (.check! (pair? .x|174|177) 1 .x|174|177) (cdr:pair .x|174|177)))) '(0) (let* ((.contains-call?|181 #f) (.vexprs|184 (list->vector .exprs|149)) (.vindexes|187 (list->vector (iota (let ((.v|264|267 .vexprs|184)) (begin (.check! (vector? .v|264|267) 42 .v|264|267) (vector-length:vec .v|264|267)))))) (.contains-call?|190 #f) (.categories|193 (list->vector (let () (let ((.loop|240|243|246 (unspecified))) (begin (set! .loop|240|243|246 (lambda (.y1|235|236|247 .results|235|239|247) (if (null? .y1|235|236|247) (reverse .results|235|239|247) (begin #t (.loop|240|243|246 (let ((.x|251|254 .y1|235|236|247)) (begin (.check! (pair? .x|251|254) 1 .x|251|254) (cdr:pair .x|251|254))) (cons (let ((.e|255 (let ((.x|260|263 .y1|235|236|247)) (begin (.check! (pair? .x|260|263) 0 .x|260|263) (car:pair .x|260|263))))) (if (constant? .e|255) 2 (if (variable? .e|255) 2 (if (.complicated?|2 .e|255) (begin (set! .contains-call?|190 #t) 1) 0)))) .results|235|239|247)))))) (.loop|240|243|246 .exprs|149 '()))))))) (let () (if .contains-call?|190 (twobit-sort (lambda (.i|198 .j|198) (< (let ((.v|199|202 .categories|193) (.i|199|202 .i|198)) (begin (.check! (fixnum? .i|199|202) 40 .v|199|202 .i|199|202) (.check! (vector? .v|199|202) 40 .v|199|202 .i|199|202) (.check! (<:fix:fix .i|199|202 (vector-length:vec .v|199|202)) 40 .v|199|202 .i|199|202) (.check! (>=:fix:fix .i|199|202 0) 40 .v|199|202 .i|199|202) (vector-ref:trusted .v|199|202 .i|199|202))) (let ((.v|203|206 .categories|193) (.i|203|206 .j|198)) (begin (.check! (fixnum? .i|203|206) 40 .v|203|206 .i|203|206) (.check! (vector? .v|203|206) 40 .v|203|206 .i|203|206) (.check! (<:fix:fix .i|203|206 (vector-length:vec .v|203|206)) 40 .v|203|206 .i|203|206) (.check! (>=:fix:fix .i|203|206 0) 40 .v|203|206 .i|203|206) (vector-ref:trusted .v|203|206 .i|203|206))))) (iota (length .exprs|149))) (if .for-primop?|149 (reverse (iota (length .exprs|149))) (let* ((.targets|211 (iota (length .exprs|149))) (.pairup|212 (unspecified))) (begin (set! .pairup|212 (lambda (.regvars|213 .targets|213) (if (let ((.temp|214|217 (null? .targets|213))) (if .temp|214|217 .temp|214|217 (null? .regvars|213))) '() (cons (cons (let ((.x|219|222 .regvars|213)) (begin (.check! (pair? .x|219|222) 0 .x|219|222) (car:pair .x|219|222))) (let ((.x|223|226 .targets|213)) (begin (.check! (pair? .x|223|226) 0 .x|223|226) (car:pair .x|223|226)))) (.pairup|212 (let ((.x|227|230 .regvars|213)) (begin (.check! (pair? .x|227|230) 1 .x|227|230) (cdr:pair .x|227|230))) (let ((.x|231|234 .targets|213)) (begin (.check! (pair? .x|231|234) 1 .x|231|234) (cdr:pair .x|231|234)))))))) (.ordering|150 .targets|211 .exprs|149 (.pairup|212 .regvars|149 .targets|211)))))))))) (iota (length .exprs|149))))))) (set! .anf-call|2 (lambda (.e|268 .bindings|268 .regvars|268) (let* ((.proc|271 (call.proc .e|268)) (.args|274 (call.args .e|268))) (let () (let ((.let-loop|279 (unspecified)) (.loop|279 (unspecified))) (begin (set! .let-loop|279 (lambda (.exprs|280 .bindings|280 .regvars|280 .vars|280) (if (null? .exprs|280) (if (null? (lambda.defs .proc|271)) (.anf|2 (lambda.body .proc|271) .bindings|280 .regvars|280) (let ((.bindings|283 (.anf-bind|2 (make-lambda '() (lambda.defs .proc|271) '() '() '() (cons a-normal-form-declaration (lambda.decls .proc|271)) (lambda.doc .proc|271) (lambda.body .proc|271)) .bindings|280 '()))) (.anf-bind-dummy|2 (make-call (.anf-result|2 .bindings|283) '()) .bindings|283))) (.let-loop|279 (let ((.x|284|287 .exprs|280)) (begin (.check! (pair? .x|284|287) 1 .x|284|287) (cdr:pair .x|284|287))) (.anf-bind-name|2 (let ((.x|288|291 .vars|280)) (begin (.check! (pair? .x|288|291) 0 .x|288|291) (car:pair .x|288|291))) (let ((.x|292|295 .exprs|280)) (begin (.check! (pair? .x|292|295) 0 .x|292|295) (car:pair .x|292|295))) .bindings|280 .regvars|280) .regvars|280 (let ((.x|296|299 .vars|280)) (begin (.check! (pair? .x|296|299) 1 .x|296|299) (cdr:pair .x|296|299))))))) (set! .loop|279 (lambda (.exprs|300 .bindings|300 .names|300 .rename-always?|300) (if (null? .exprs|300) (values .bindings|300 (reverse .names|300)) (let ((.e|303 (let ((.x|332|335 .exprs|300)) (begin (.check! (pair? .x|332|335) 0 .x|332|335) (car:pair .x|332|335))))) (if (let ((.temp|304|307 .rename-always?|300)) (if .temp|304|307 .temp|304|307 (not (let ((.temp|309|312 (constant? .e|303))) (if .temp|309|312 .temp|309|312 (variable? .e|303)))))) (let ((.bindings|316 (.anf-bind|2 (let ((.x|324|327 .exprs|300)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327))) .bindings|300 .regvars|268))) (let () (.loop|279 (let ((.x|320|323 .exprs|300)) (begin (.check! (pair? .x|320|323) 1 .x|320|323) (cdr:pair .x|320|323))) .bindings|316 (cons (.anf-result|2 .bindings|316) .names|300) .rename-always?|300))) (.loop|279 (let ((.x|328|331 .exprs|300)) (begin (.check! (pair? .x|328|331) 1 .x|328|331) (cdr:pair .x|328|331))) .bindings|300 (cons .e|303 .names|300) .rename-always?|300)))))) (if (lambda? .proc|271) (let ((.formals|338 (lambda.args .proc|271))) (if (list? .formals|338) (let* ((.pi|341 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f)) (.exprs|344 (.permute|2 .args|274 .pi|341)) (.names|347 (.permute|2 (lambda.args .proc|271) .pi|341))) (let () (.let-loop|279 (reverse .exprs|344) .bindings|268 .regvars|268 (reverse .names|347)))) (.anf-call|2 (.normalize-let|2 .e|268) .bindings|268 .regvars|268))) (if (not (variable? .proc|271)) (let ((.pi|354 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|354) .bindings|268 '() #t)) (lambda (.bindings|356 .names|356) (let ((.bindings|359 (.anf-bind|2 .proc|271 .bindings|356 .regvars|268))) (.anf-bind-dummy|2 (make-call (.anf-result|2 .bindings|359) (.unpermute|2 .names|356 .pi|354)) .bindings|359))))) (if (if (integrate-usual-procedures) (prim-entry (variable.name .proc|271)) #f) (let ((.pi|365 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #t))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|365) .bindings|268 '() #t)) (lambda (.bindings|367 .names|367) (.anf-bind-dummy|2 (make-call .proc|271 (.unpermute|2 .names|367 .pi|365)) .bindings|367)))) (if (memq (variable.name .proc|271) .regvars|268) (let* ((.exprs|371 (cons .proc|271 .args|274)) (.pi|374 (.anf-order-of-evaluation|2 .exprs|371 (cons name:ignored .regvars|268) #f))) (let () (call-with-values (lambda () (.loop|279 (.permute|2 .exprs|371 .pi|374) .bindings|268 '() #t)) (lambda (.bindings|379 .names|379) (let ((.names|382 (.unpermute|2 .names|379 .pi|374))) (.anf-bind-dummy|2 (make-call (let ((.x|383|386 .names|382)) (begin (.check! (pair? .x|383|386) 0 .x|383|386) (car:pair .x|383|386))) (let ((.x|387|390 .names|382)) (begin (.check! (pair? .x|387|390) 1 .x|387|390) (cdr:pair .x|387|390)))) .bindings|379)))))) (let ((.pi|394 (.anf-order-of-evaluation|2 .args|274 .regvars|268 #f))) (call-with-values (lambda () (.loop|279 (.permute|2 .args|274 .pi|394) .bindings|268 '() #t)) (lambda (.bindings|396 .names|396) (.anf-bind-dummy|2 (make-call .proc|271 (.unpermute|2 .names|396 .pi|394)) .bindings|396)))))))))))))) (set! .anf-conditional|2 (lambda (.e|397 .bindings|397 .regvars|397) (let ((.e0|400 (if.test .e|397)) (.e1|400 (if.then .e|397)) (.e2|400 (if.else .e|397))) (if (variable? .e0|400) (let ((.e1|403 (.anf-make-let*|2 (.anf|2 .e1|400 '() .regvars|397))) (.e2|403 (.anf-make-let*|2 (.anf|2 .e2|400 '() .regvars|397)))) (.anf-bind-dummy|2 (make-conditional .e0|400 .e1|403 .e2|403) .bindings|397)) (let* ((.bindings|406 (.anf-bind|2 .e0|400 .bindings|397 .regvars|397)) (.e1|409 (.anf-make-let*|2 (.anf|2 .e1|400 '() .regvars|397))) (.e2|412 (.anf-make-let*|2 (.anf|2 .e2|400 '() .regvars|397)))) (let () (.anf-bind-dummy|2 (make-conditional (.anf-result|2 .bindings|406) .e1|409 .e2|412) .bindings|406))))))) (set! .anf-assignment|2 (lambda (.e|416 .bindings|416 .regvars|416) (let ((.i|419 (assignment.lhs .e|416)) (.e1|419 (assignment.rhs .e|416))) (if (variable? .e1|419) (.anf-bind-dummy|2 .e|416 .bindings|416) (let* ((.bindings|422 (.anf-bind|2 .e1|419 .bindings|416 .regvars|416)) (.t1|425 (.anf-result|2 .bindings|422))) (let () (.anf-bind-dummy|2 (make-assignment .i|419 .t1|425) .bindings|422))))))) (set! .anf-lambda|2 (lambda (.l|429 .bindings|429 .regvars|429) (.anf-bind-dummy|2 (make-lambda (lambda.args .l|429) (let () (let ((.loop|435|438|441 (unspecified))) (begin (set! .loop|435|438|441 (lambda (.y1|430|431|442 .results|430|434|442) (if (null? .y1|430|431|442) (reverse .results|430|434|442) (begin #t (.loop|435|438|441 (let ((.x|446|449 .y1|430|431|442)) (begin (.check! (pair? .x|446|449) 1 .x|446|449) (cdr:pair .x|446|449))) (cons (let ((.def|450 (let ((.x|451|454 .y1|430|431|442)) (begin (.check! (pair? .x|451|454) 0 .x|451|454) (car:pair .x|451|454))))) (make-definition (def.lhs .def|450) (.a-normal-form|2 (def.rhs .def|450)))) .results|430|434|442)))))) (.loop|435|438|441 (lambda.defs .l|429) '())))) '() '() '() (cons a-normal-form-declaration (lambda.decls .l|429)) (lambda.doc .l|429) (.anf-make-let*|2 (.anf|2 (lambda.body .l|429) '() (make-null-terminated (lambda.args .l|429))))) .bindings|429))) (set! .anf-sequential|2 (lambda (.e|455 .bindings|455 .regvars|455) (let () (let ((.loop|456|459|462 (unspecified))) (begin (set! .loop|456|459|462 (lambda (.bindings|463 .exprs|463) (if (null? (let ((.x|465|468 .exprs|463)) (begin (.check! (pair? .x|465|468) 1 .x|465|468) (cdr:pair .x|465|468)))) (.anf|2 (let ((.x|469|472 .exprs|463)) (begin (.check! (pair? .x|469|472) 0 .x|469|472) (car:pair .x|469|472))) .bindings|463 .regvars|455) (begin #t (.loop|456|459|462 (.anf-bind|2 (let ((.x|474|477 .exprs|463)) (begin (.check! (pair? .x|474|477) 0 .x|474|477) (car:pair .x|474|477))) .bindings|463 .regvars|455) (let ((.x|478|481 .exprs|463)) (begin (.check! (pair? .x|478|481) 1 .x|478|481) (cdr:pair .x|478|481)))))))) (.loop|456|459|462 .bindings|455 (begin.exprs .e|455))))))) (set! .anf-make-let*|2 (lambda (.bindings|482) (let ((.loop|483 (unspecified))) (begin (set! .loop|483 (lambda (.bindings|484 .body|484) (if (null? .bindings|484) .body|484 (let ((.t1|487 (let ((.x|495|498 (let ((.x|499|502 .bindings|484)) (begin (.check! (pair? .x|499|502) 0 .x|499|502) (car:pair .x|499|502))))) (begin (.check! (pair? .x|495|498) 0 .x|495|498) (car:pair .x|495|498)))) (.e1|487 (let ((.x|504|507 (let ((.x|508|511 (let ((.x|512|515 .bindings|484)) (begin (.check! (pair? .x|512|515) 0 .x|512|515) (car:pair .x|512|515))))) (begin (.check! (pair? .x|508|511) 1 .x|508|511) (cdr:pair .x|508|511))))) (begin (.check! (pair? .x|504|507) 0 .x|504|507) (car:pair .x|504|507))))) (.loop|483 (let ((.x|488|491 .bindings|484)) (begin (.check! (pair? .x|488|491) 1 .x|488|491) (cdr:pair .x|488|491))) (make-call (make-lambda (cons .t1|487 '()) '() '() '() '() (cons a-normal-form-declaration '()) '() .body|484) (cons .e1|487 '()))))))) (.loop|483 (let ((.x|516|519 .bindings|482)) (begin (.check! (pair? .x|516|519) 1 .x|516|519) (cdr:pair .x|516|519))) (let ((.x|521|524 (let ((.x|525|528 (let ((.x|529|532 .bindings|482)) (begin (.check! (pair? .x|529|532) 0 .x|529|532) (car:pair .x|529|532))))) (begin (.check! (pair? .x|525|528) 1 .x|525|528) (cdr:pair .x|525|528))))) (begin (.check! (pair? .x|521|524) 0 .x|521|524) (car:pair .x|521|524)))))))) (set! .anf-result|2 (lambda (.bindings|533) (make-variable (let ((.x|534|537 (let ((.x|538|541 .bindings|533)) (begin (.check! (pair? .x|538|541) 0 .x|538|541) (car:pair .x|538|541))))) (begin (.check! (pair? .x|534|537) 0 .x|534|537) (car:pair .x|534|537)))))) (set! .anf-bind|2 (lambda (.e|542 .bindings|542 .regvars|542) (let ((.bindings|545 (.anf|2 .e|542 .bindings|542 .regvars|542))) (cons (let* ((.t1|546|549 (.newtemp|2)) (.t2|546|552 (cons (let ((.x|558|561 (let ((.x|562|565 (let ((.x|566|569 .bindings|545)) (begin (.check! (pair? .x|566|569) 0 .x|566|569) (car:pair .x|566|569))))) (begin (.check! (pair? .x|562|565) 1 .x|562|565) (cdr:pair .x|562|565))))) (begin (.check! (pair? .x|558|561) 0 .x|558|561) (car:pair .x|558|561))) '()))) (let () (cons .t1|546|549 .t2|546|552))) (let ((.x|570|573 .bindings|545)) (begin (.check! (pair? .x|570|573) 1 .x|570|573) (cdr:pair .x|570|573))))))) (set! .anf-bind-name|2 (lambda (.name|574 .e|574 .bindings|574 .regvars|574) (let ((.bindings|577 (.anf|2 .e|574 .bindings|574 .regvars|574))) (cons (let* ((.t1|578|581 .name|574) (.t2|578|584 (cons (let ((.x|590|593 (let ((.x|594|597 (let ((.x|598|601 .bindings|577)) (begin (.check! (pair? .x|598|601) 0 .x|598|601) (car:pair .x|598|601))))) (begin (.check! (pair? .x|594|597) 1 .x|594|597) (cdr:pair .x|594|597))))) (begin (.check! (pair? .x|590|593) 0 .x|590|593) (car:pair .x|590|593))) '()))) (let () (cons .t1|578|581 .t2|578|584))) (let ((.x|602|605 .bindings|577)) (begin (.check! (pair? .x|602|605) 1 .x|602|605) (cdr:pair .x|602|605))))))) (set! .anf-bind-dummy|2 (lambda (.e|606 .bindings|606) (cons (let* ((.t1|607|610 .anf:dummy|2) (.t2|607|613 (cons .e|606 '()))) (let () (cons .t1|607|610 .t2|607|613))) .bindings|606))) (set! .anf|2 (lambda (.e|618 .bindings|618 .regvars|618) (let ((.temp|619|622 (let ((.x|629|632 .e|618)) (begin (.check! (pair? .x|629|632) 0 .x|629|632) (car:pair .x|629|632))))) (if (memv .temp|619|622 '(quote)) (.anf-bind-dummy|2 .e|618 .bindings|618) (if (memv .temp|619|622 '(begin)) (if (variable? .e|618) (.anf-bind-dummy|2 .e|618 .bindings|618) (.anf-sequential|2 .e|618 .bindings|618 .regvars|618)) (if (memv .temp|619|622 '(lambda)) (.anf-lambda|2 .e|618 .bindings|618 .regvars|618) (if (memv .temp|619|622 '(set!)) (.anf-assignment|2 .e|618 .bindings|618 .regvars|618) (if (memv .temp|619|622 '(if)) (.anf-conditional|2 .e|618 .bindings|618 .regvars|618) (.anf-call|2 .e|618 .bindings|618 .regvars|618))))))))) (set! .newtemp|2 (lambda () (begin (set! .temp-counter|2 (+ .temp-counter|2 1)) (string->symbol (string-append .temp-prefix|2 (number->string .temp-counter|2)))))) (set! .a-normal-form|2 (lambda (.e|634) (.anf-make-let*|2 (.anf|2 .e|634 '() '())))) (set! .temp-counter|2 0) (set! .anf:dummy|2 (string->symbol "RESULT")) (set! .temp-prefix|2 (if (let ((.temp|635|638 (null? .rest|1))) (if .temp|635|638 .temp|635|638 (not (string? (let ((.x|640|643 .rest|1)) (begin (.check! (pair? .x|640|643) 0 .x|640|643) (car:pair .x|640|643))))))) (string-append renaming-prefix "T") (let ((.x|644|647 .rest|1)) (begin (.check! (pair? .x|644|647) 0 .x|644|647) (car:pair .x|644|647))))) (.a-normal-form|2 .e|1))))) 'a-normal-form))
+(let () (begin (set! post-simplify-anf (lambda (.l0|1 .t1|1 .e0|1 .e1|1 .free|1 .regbindings|1 .l2|1) (let ((.post-simplify-anf|2 0)) (begin (set! .post-simplify-anf|2 (lambda (.l0|3 .t1|3 .e0|3 .e1|3 .free|3 .regbindings|3 .l2|3) (let ((.return-normally|4 (unspecified))) (begin (set! .return-normally|4 (lambda () (values (make-call .l0|3 (cons .e1|3 '())) .free|3 .regbindings|3))) (.return-normally|4))))) (.post-simplify-anf|2 .l0|1 .t1|1 .e0|1 .e1|1 .free|1 .regbindings|1 .l2|1))))) 'post-simplify-anf))
+(let () (begin (set! argument-registers (let () (let ((.loop|1|4|7 (unspecified))) (begin (set! .loop|1|4|7 (lambda (.n|8 .regs|8) (if (zero? .n|8) .regs|8 (begin #t (.loop|1|4|7 (- .n|8 1) (cons (string->symbol (string-append ".REG" (number->string .n|8))) .regs|8)))))) (.loop|1|4|7 (- *nregs* 2) '()))))) 'argument-registers))
+(let () (begin (set! intraprocedural-commoning (lambda (.e|1 . .flags|1) (let ((.debugging?|2 (unspecified)) (.commoning?|2 (unspecified)) (.target-registers?|2 (unspecified))) (begin (set! .debugging?|2 #f) (set! .commoning?|2 (let ((.temp|3|6 (null? .flags|1))) (if .temp|3|6 .temp|3|6 (memq 'commoning .flags|1)))) (set! .target-registers?|2 (let ((.temp|8|11 (null? .flags|1))) (if .temp|8|11 .temp|8|11 (memq 'target-registers .flags|1)))) (call-with-current-continuation (lambda (.return|13) (let ((.scan-body|14 (unspecified)) (.error|14 (unspecified))) (begin (set! .scan-body|14 (lambda (.e|15 .env|15 .available|15 .regvars|15) (let ((.scan-rhs|16 (unspecified)) (.scan-defs|16 (unspecified)) (.scan-let0|16 (unspecified)) (.scan-binding-phase3|16 (unspecified)) (.scan-binding-phase2|16 (unspecified)) (.scan-binding|16 (unspecified)) (.scan|16 (unspecified)) (.available-add!|16 (unspecified)) (.global?|16 (unspecified)) (.environment-lookup|16 (unspecified)) (.environment-extend*|16 (unspecified)) (.environment-extend|16 (unspecified)) (.make-empty-environment|16 (unspecified)) (.abandon-expression!|16 (unspecified)) (.used-variable!|16 (unspecified)) (.closed-over-local-variable!|16 (unspecified)) (.adjust-local-variable!|16 (unspecified)) (.used-local-variable!|16 (unspecified)) (.record-local-variable!|16 (unspecified)) (.local-variable-used-once?|16 (unspecified)) (.local-variable-not-used?|16 (unspecified)) (.local-variable?|16 (unspecified)) (.local-variables|16 (unspecified))) (begin (set! .scan-rhs|16 (lambda (.e|17 .env|17 .available|17) (if (constant? .e|17) (values .e|17 (empty-set) '()) (if (variable? .e|17) (let* ((.name|22 (variable.name .e|17)) (.enew|25 (if .commoning?|2 (if (.global?|16 .name|22) (let ((.t|34 (available-expression .available|17 .e|17))) (if .t|34 (make-variable .t|34) #f)) (available-variable .available|17 .name|22)) #f))) (let () (if .enew|25 (.scan-rhs|16 .enew|25 .env|17 .available|17) (begin (.used-variable!|16 .name|22) (values .e|17 (cons .name|22 '()) '()))))) (if (lambda? .e|17) (let* ((.formals|38 (make-null-terminated (lambda.args .e|17))) (.env|41 (.environment-extend*|16 (.environment-extend*|16 .env|17 .formals|38) (let () (let ((.loop|87|90|93 (unspecified))) (begin (set! .loop|87|90|93 (lambda (.y1|82|83|94 .results|82|86|94) (if (null? .y1|82|83|94) (reverse .results|82|86|94) (begin #t (.loop|87|90|93 (let ((.x|98|101 .y1|82|83|94)) (begin (.check! (pair? .x|98|101) 1 .x|98|101) (cdr:pair .x|98|101))) (cons (def.lhs (let ((.x|102|105 .y1|82|83|94)) (begin (.check! (pair? .x|102|105) 0 .x|102|105) (car:pair .x|102|105)))) .results|82|86|94)))))) (.loop|87|90|93 (lambda.defs .e|17) '())))))) (.fdefs|44 (.scan-defs|16 .e|17 .env|41 .available|17))) (let () (call-with-values (lambda () (let ((.available|51 (copy-available-table .available|17))) (begin (available-kill! .available|51 available:killer:all) (.scan-body|14 (lambda.body .e|17) .env|41 .available|51 .formals|38)))) (lambda (.e0|52 .f0|52 .regbindings0|52) (call-with-values (lambda () (wrap-with-register-bindings .regbindings0|52 .e0|52 .f0|52)) (lambda (.e0|54 .f0|54) (begin (lambda.body-set! .e|17 .e0|54) (let ((.f|57 (union .fdefs|44 .f0|54))) (begin (let () (let ((.loop|63|65|68 (unspecified))) (begin (set! .loop|63|65|68 (lambda (.y1|58|59|69) (if (null? .y1|58|59|69) (if #f #f (unspecified)) (begin (begin #t (let ((.x|73 (let ((.x|74|77 .y1|58|59|69)) (begin (.check! (pair? .x|74|77) 0 .x|74|77) (car:pair .x|74|77))))) (.closed-over-local-variable!|16 .x|73))) (.loop|63|65|68 (let ((.x|78|81 .y1|58|59|69)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81)))))))) (.loop|63|65|68 .f|57)))) (lambda.f-set! .e|17 .f|57) (lambda.g-set! .e|17 .f|57) (values .e|17 (difference .f|57 (make-null-terminated (lambda.args .e|17))) '())))))))))) (if (conditional? .e|17) (let ((.e0|109 (if.test .e|17)) (.e1|109 (if.then .e|17)) (.e2|109 (if.else .e|17))) (if (constant? .e0|109) (let ((.e1|112 (if (constant.value .e0|109) .e1|109 .e2|109))) (call-with-values (lambda () (.scan|16 .e1|112 .env|17 .available|17)) (lambda (.e1|114 .f1|114 .regbindings1|114) (if (let ((.temp|116|119 (not (call? .e1|114)))) (if .temp|116|119 .temp|116|119 (not (lambda? (call.proc .e1|114))))) (values .e1|114 .f1|114 .regbindings1|114) (values (make-conditional (make-constant #t) .e1|114 (make-constant 0)) .f1|114 .regbindings1|114))))) (call-with-values (lambda () (.scan|16 .e0|109 .env|17 .available|17)) (lambda (.e0|123 .f0|123 .regbindings0|123) (begin (if (not (null? .regbindings0|123)) (.error|14 'scan-rhs 'if) (unspecified)) (if (not (eq? .e0|123 (if.test .e|17))) (.scan-rhs|16 (make-conditional .e0|123 .e1|109 .e2|109) .env|17 .available|17) (let ((.available1|126 (copy-available-table .available|17)) (.available2|126 (copy-available-table .available|17))) (begin (if (variable? .e0|123) (let ((.t0|129 (variable.name .e0|123))) (.available-add!|16 .available2|126 .t0|129 (make-constant #f))) (.error|14 (make-readable .e|17 #t))) (call-with-values (lambda () (.scan|16 .e1|109 .env|17 .available1|126)) (lambda (.e1|131 .f1|131 .regbindings1|131) (call-with-values (lambda () (wrap-with-register-bindings .regbindings1|131 .e1|131 .f1|131)) (lambda (.e1|133 .f1|133) (call-with-values (lambda () (.scan|16 .e2|109 .env|17 .available2|126)) (lambda (.e2|135 .f2|135 .regbindings2|135) (call-with-values (lambda () (wrap-with-register-bindings .regbindings2|135 .e2|135 .f2|135)) (lambda (.e2|137 .f2|137) (let ((.e|140 (make-conditional .e0|123 .e1|133 .e2|137)) (.f|140 (union .f0|123 .f1|133 .f2|137))) (begin (available-intersect! .available|17 .available1|126 .available2|126) (values .e|140 .f|140 '()))))))))))))))))))) (if (assignment? .e|17) (call-with-values (lambda () (.scan-rhs|16 (assignment.rhs .e|17) .env|17 .available|17)) (lambda (.e1|143 .f1|143 .regbindings1|143) (begin (if (not (null? .regbindings1|143)) (.error|14 'scan-rhs 'set!) (unspecified)) (available-kill! .available|17 available:killer:globals) (values (make-assignment (assignment.lhs .e|17) .e1|143) (union (cons (assignment.lhs .e|17) '()) .f1|143) '())))) (if (begin? .e|17) (.error|14 'scan-rhs 'begin) (if (real-call? .e|17) (let* ((.e0|149 (call.proc .e|17)) (.args|152 (call.args .e|17)) (.regcontents|155 (append .regvars|15 (let () (let ((.loop|308|311|314 (unspecified))) (begin (set! .loop|308|311|314 (lambda (.y1|303|304|315 .results|303|307|315) (if (null? .y1|303|304|315) (reverse .results|303|307|315) (begin #t (.loop|308|311|314 (let ((.x|319|322 .y1|303|304|315)) (begin (.check! (pair? .x|319|322) 1 .x|319|322) (cdr:pair .x|319|322))) (cons (let ((.x|323 (let ((.x|324|327 .y1|303|304|315)) (begin (.check! (pair? .x|324|327) 0 .x|324|327) (car:pair .x|324|327))))) #f) .results|303|307|315)))))) (.loop|308|311|314 .args|152 '()))))))) (let () (let ((.args|161 .args|152) (.regs|161 argument-registers) (.regcontents|161 .regcontents|155) (.newargs|161 '()) (.regbindings|161 '()) (.f|161 (if (variable? .e0|149) (let ((.f|301 (variable.name .e0|149))) (begin (.used-variable!|16 .f|301) (cons .f|301 '()))) (empty-set)))) (let () (let ((.loop|164 (unspecified))) (begin (set! .loop|164 (lambda (.args|165 .regs|165 .regcontents|165 .newargs|165 .regbindings|165 .f|165) (if (null? .args|165) (begin (available-kill! .available|17 available:killer:all) (values (make-call .e0|149 (reverse .newargs|165)) .f|165 .regbindings|165)) (if (null? .regs|165) (let ((.arg|170 (let ((.x|183|186 .args|165)) (begin (.check! (pair? .x|183|186) 0 .x|183|186) (car:pair .x|183|186))))) (.loop|164 (let ((.x|171|174 .args|165)) (begin (.check! (pair? .x|171|174) 1 .x|171|174) (cdr:pair .x|171|174))) '() (let ((.x|175|178 .regcontents|165)) (begin (.check! (pair? .x|175|178) 1 .x|175|178) (cdr:pair .x|175|178))) (cons .arg|170 .newargs|165) .regbindings|165 (if (variable? .arg|170) (let ((.name|181 (variable.name .arg|170))) (begin (.used-variable!|16 .name|181) (union (cons .name|181 '()) .f|165))) .f|165))) (if (if .commoning?|2 (if (variable? (let ((.x|190|193 .args|165)) (begin (.check! (pair? .x|190|193) 0 .x|190|193) (car:pair .x|190|193)))) (available-variable .available|17 (variable.name (let ((.x|195|198 .args|165)) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198))))) #f) #f) (let* ((.name|201 (variable.name (let ((.x|212|215 .args|165)) (begin (.check! (pair? .x|212|215) 0 .x|212|215) (car:pair .x|212|215))))) (.enew|204 (available-variable .available|17 .name|201))) (let () (.loop|164 (cons .enew|204 (let ((.x|208|211 .args|165)) (begin (.check! (pair? .x|208|211) 1 .x|208|211) (cdr:pair .x|208|211)))) .regs|165 .regcontents|165 .newargs|165 .regbindings|165 .f|165))) (if (if .target-registers?|2 (if (variable? (let ((.x|219|222 .args|165)) (begin (.check! (pair? .x|219|222) 0 .x|219|222) (car:pair .x|219|222)))) (let* ((.x|226 (variable.name (let ((.x|238|241 .args|165)) (begin (.check! (pair? .x|238|241) 0 .x|238|241) (car:pair .x|238|241))))) (.temp|227|230 (.local-variable-not-used?|16 .x|226))) (if .temp|227|230 .temp|227|230 (if (memq .x|226 .regvars|15) (not (eq? .x|226 (let ((.x|234|237 .regcontents|165)) (begin (.check! (pair? .x|234|237) 0 .x|234|237) (car:pair .x|234|237))))) #f))) #f) #f) (let* ((.x|244 (variable.name (let ((.x|271|274 .args|165)) (begin (.check! (pair? .x|271|274) 0 .x|271|274) (car:pair .x|271|274))))) (.r|247 (let ((.x|267|270 .regs|165)) (begin (.check! (pair? .x|267|270) 0 .x|267|270) (car:pair .x|267|270)))) (.newarg|250 (make-variable .r|247))) (let () (begin (.used-variable!|16 .x|244) (.loop|164 (let ((.x|254|257 .args|165)) (begin (.check! (pair? .x|254|257) 1 .x|254|257) (cdr:pair .x|254|257))) (let ((.x|258|261 .regs|165)) (begin (.check! (pair? .x|258|261) 1 .x|258|261) (cdr:pair .x|258|261))) (let ((.x|262|265 .regcontents|165)) (begin (.check! (pair? .x|262|265) 1 .x|262|265) (cdr:pair .x|262|265))) (cons .newarg|250 .newargs|165) (cons (make-regbinding .r|247 .x|244 .newarg|250) .regbindings|165) (union (cons .r|247 '()) .f|165))))) (let ((.e1|278 (let ((.x|295|298 .args|165)) (begin (.check! (pair? .x|295|298) 0 .x|295|298) (car:pair .x|295|298))))) (.loop|164 (let ((.x|279|282 .args|165)) (begin (.check! (pair? .x|279|282) 1 .x|279|282) (cdr:pair .x|279|282))) (let ((.x|283|286 .regs|165)) (begin (.check! (pair? .x|283|286) 1 .x|283|286) (cdr:pair .x|283|286))) (let ((.x|287|290 .regcontents|165)) (begin (.check! (pair? .x|287|290) 1 .x|287|290) (cdr:pair .x|287|290))) (cons .e1|278 .newargs|165) .regbindings|165 (if (variable? .e1|278) (let ((.name|293 (variable.name .e1|278))) (begin (.used-variable!|16 .name|293) (union (cons .name|293 '()) .f|165))) .f|165))))))))) (.loop|164 .args|161 .regs|161 .regcontents|161 .newargs|161 .regbindings|161 .f|161))))))) (if (call? .e|17) (let* ((.e0|331 (call.proc .e|17)) (.f0|334 (variable.name .e0|331))) (let () (let ((.args|340 (call.args .e|17)) (.newargs|340 '()) (.f|340 (cons .f0|334 '()))) (let () (let ((.loop|343 (unspecified))) (begin (set! .loop|343 (lambda (.args|344 .newargs|344 .f|344) (if (null? .args|344) (let* ((.e|348 (make-call .e0|331 (reverse .newargs|344))) (.t|351 (if .commoning?|2 (available-expression .available|17 .e|348) #f))) (let () (if .t|351 (begin (.abandon-expression!|16 .e|348) (.scan-rhs|16 (make-variable .t|351) .env|17 .available|17)) (begin (available-kill! .available|17 (prim-kills (prim-entry .f0|334))) (if (eq? .f0|334 name:check!) (let ((.x|358 (let ((.x|363|366 (call.args .e|348))) (begin (.check! (pair? .x|363|366) 0 .x|363|366) (car:pair .x|363|366))))) (if (not (runtime-safety-checking)) (begin (.abandon-expression!|16 .e|348) (.scan-rhs|16 .x|358 .env|17 .available|17)) (if (variable? .x|358) (begin (.available-add!|16 .available|17 (variable.name .x|358) (make-constant #t)) (values .e|348 .f|344 '())) (if (constant.value .x|358) (begin (.abandon-expression!|16 .e|348) (values .x|358 '() '())) (begin (declaration-error .e|348) (values .e|348 .f|344 '())))))) (values .e|348 .f|344 '())))))) (if (variable? (let ((.x|371|374 .args|344)) (begin (.check! (pair? .x|371|374) 0 .x|371|374) (car:pair .x|371|374)))) (let* ((.e1|377 (let ((.x|402|405 .args|344)) (begin (.check! (pair? .x|402|405) 0 .x|402|405) (car:pair .x|402|405)))) (.x|380 (variable.name .e1|377)) (.enew|383 (if .commoning?|2 (available-variable .available|17 .x|380) #f))) (let () (if .enew|383 (.loop|343 (cons .enew|383 (let ((.x|387|390 .args|344)) (begin (.check! (pair? .x|387|390) 1 .x|387|390) (cdr:pair .x|387|390)))) .newargs|344 (remq .x|380 .f|344)) (begin (.used-variable!|16 .x|380) (.loop|343 (let ((.x|391|394 .args|344)) (begin (.check! (pair? .x|391|394) 1 .x|391|394) (cdr:pair .x|391|394))) (cons (let ((.x|395|398 .args|344)) (begin (.check! (pair? .x|395|398) 0 .x|395|398) (car:pair .x|395|398))) .newargs|344) (union (cons .x|380 '()) .f|344)))))) (.loop|343 (let ((.x|407|410 .args|344)) (begin (.check! (pair? .x|407|410) 1 .x|407|410) (cdr:pair .x|407|410))) (cons (let ((.x|411|414 .args|344)) (begin (.check! (pair? .x|411|414) 0 .x|411|414) (car:pair .x|411|414))) .newargs|344) .f|344))))) (.loop|343 .args|340 .newargs|340 .f|340))))))) (.error|14 'scan-rhs (make-readable .e|17)))))))))))) (set! .scan-defs|16 (lambda (.l|417 .env|417 .available|417) (let ((.defs|420 (lambda.defs .l|417)) (.newdefs|420 '()) (.fdefs|420 '())) (let () (let ((.loop|423 (unspecified))) (begin (set! .loop|423 (lambda (.defs|424 .newdefs|424 .fdefs|424) (if (null? .defs|424) (begin (lambda.defs-set! .l|417 (reverse .newdefs|424)) .fdefs|424) (let ((.def|427 (let ((.x|470|473 .defs|424)) (begin (.check! (pair? .x|470|473) 0 .x|470|473) (car:pair .x|470|473))))) (call-with-values (lambda () (let* ((.ldef|431 (def.rhs .def|427)) (.lformals|434 (make-null-terminated (lambda.args .ldef|431))) (.lenv|437 (.environment-extend*|16 (.environment-extend*|16 .env|417 .lformals|434) (let () (let ((.loop|446|449|452 (unspecified))) (begin (set! .loop|446|449|452 (lambda (.y1|441|442|453 .results|441|445|453) (if (null? .y1|441|442|453) (reverse .results|441|445|453) (begin #t (.loop|446|449|452 (let ((.x|457|460 .y1|441|442|453)) (begin (.check! (pair? .x|457|460) 1 .x|457|460) (cdr:pair .x|457|460))) (cons (def.lhs (let ((.x|461|464 .y1|441|442|453)) (begin (.check! (pair? .x|461|464) 0 .x|461|464) (car:pair .x|461|464)))) .results|441|445|453)))))) (.loop|446|449|452 (lambda.defs .ldef|431) '()))))))) (let () (.scan|16 .ldef|431 .lenv|437 .available|417)))) (lambda (.rhs|465 .frhs|465 .empty|465) (begin (if (not (null? .empty|465)) (.error|14 'scan-binding 'def) (unspecified)) (.loop|423 (let ((.x|466|469 .defs|424)) (begin (.check! (pair? .x|466|469) 1 .x|466|469) (cdr:pair .x|466|469))) (cons (make-definition (def.lhs .def|427) .rhs|465) .newdefs|424) (union .frhs|465 .fdefs|424))))))))) (.loop|423 .defs|420 .newdefs|420 .fdefs|420))))))) (set! .scan-let0|16 (lambda (.e|474 .env|474 .available|474) (let ((.l|477 (call.proc .e|474))) (if (simple-lambda? .l|477) (.scan|16 (lambda.body .l|477) .env|474 .available|474) (let ((.t1|480 (make-variable name:ignored))) (begin (lambda.args-set! .l|477 (cons .t1|480 '())) (call-with-values (lambda () (.scan|16 (make-call .l|477 (cons (make-constant 0) '())) .env|474 .available|474)) (lambda (.e|484 .f|484 .regbindings|484) (begin (lambda.args-set! .l|477 '()) (values (make-call .l|477 '()) .f|484 .regbindings|484)))))))))) (set! .scan-binding-phase3|16 (lambda (.l|485 .e0|485 .e1|485 .f|485 .f1|485 .regbindings0|485 .regbindings1|485) (let* ((.args|488 (lambda.args .l|485)) (.t1|491 (let ((.x|517|520 .args|488)) (begin (.check! (pair? .x|517|520) 0 .x|517|520) (car:pair .x|517|520)))) (.free|494 (union .f1|485 (difference .f|485 .args|488))) (.simple-let?|497 (simple-lambda? .l|485)) (.regbindings|500 (if (null? .regbindings0|485) .regbindings1|485 (if (null? .regbindings1|485) .regbindings0|485 (.error|14 'scan-binding 'regbindings))))) (let () (begin (lambda.body-set! .l|485 .e0|485) (lambda.f-set! .l|485 .f|485) (lambda.g-set! .l|485 .f|485) (if (if .simple-let?|497 (if (not (memq .t1|491 .f|485)) (no-side-effects? .e1|485) #f) #f) (begin (.abandon-expression!|16 .e1|485) (values .e0|485 .f|485 .regbindings0|485)) (if (if .target-registers?|2 (if .simple-let?|497 (.local-variable-used-once?|16 .t1|491) #f) #f) (post-simplify-anf .l|485 .t1|491 .e0|485 .e1|485 .free|494 .regbindings|500 #f) (values (make-call .l|485 (cons .e1|485 '())) .free|494 .regbindings|500)))))))) (set! .scan-binding-phase2|16 (lambda (.l|521 .t1|521 .e0|521 .e1|521 .f0|521 .f1|521 .fdefs|521 .regbindings0|521 .regbindings1|521) (let ((.phase2e|522 (unspecified)) (.phase2d|522 (unspecified)) (.phase2c|522 (unspecified)) (.phase2b|522 (unspecified)) (.phase2a|522 (unspecified))) (begin (set! .phase2e|522 (lambda (.towrap|523 .regbindings0|523) (call-with-values (lambda () (wrap-with-register-bindings .towrap|523 .e0|521 .f0|521)) (lambda (.e0|525 .f0|525) (let ((.f|528 (union .fdefs|521 .f0|525))) (.scan-binding-phase3|16 .l|521 .e0|525 .e1|521 .f|528 .f1|521 .regbindings0|523 .regbindings1|521)))))) (set! .phase2d|522 (lambda (.towrap|529 .regbindings-t1|529 .regbindings0|529) (begin (if (not (null? (let ((.x|530|533 .regbindings-t1|529)) (begin (.check! (pair? .x|530|533) 1 .x|530|533) (cdr:pair .x|530|533))))) (.error|14 "incorrect number of uses" .t1|521) (unspecified)) (let* ((.regbinding|536 (let ((.x|544|547 .regbindings-t1|529)) (begin (.check! (pair? .x|544|547) 0 .x|544|547) (car:pair .x|544|547)))) (.r|539 (regbinding.lhs .regbinding|536))) (let () (begin (lambda.args-set! .l|521 (cons .r|539 '())) (.phase2e|522 .towrap|529 .regbindings0|529))))))) (set! .phase2c|522 (lambda (.towrap|548 .rb1|548 .regbindings0|548) (if (if (not (null? .rb1|548)) (.local-variable-used-once?|16 .t1|521) #f) (.phase2d|522 .towrap|548 .rb1|548 .regbindings0|548) (.phase2e|522 (append .rb1|548 .towrap|548) .regbindings0|548)))) (set! .phase2b|522 (lambda (.rb1|553 .rb2|553 .rb3|553) (if (let ((.temp|554|557 (conditional? .e1|521))) (if .temp|554|557 .temp|554|557 (real-call? .e1|521))) (.phase2c|522 (append .rb2|553 .rb3|553) .rb1|553 '()) (.phase2c|522 .rb2|553 .rb1|553 .rb3|553)))) (set! .phase2a|522 (lambda () (let () (let ((.loop|560|564|567 (unspecified))) (begin (set! .loop|560|564|567 (lambda (.rvars|568 .regs|568 .regs1|568) (if (let ((.temp|570|573 (null? .rvars|568))) (if .temp|570|573 .temp|570|573 (null? .regs|568))) (let ((.regbindings|577 .regbindings0|521) (.rb1|577 '()) (.rb2|577 '()) (.rb3|577 '())) (let () (let ((.loop|580 (unspecified))) (begin (set! .loop|580 (lambda (.regbindings|581 .rb1|581 .rb2|581 .rb3|581) (if (null? .regbindings|581) (.phase2b|522 .rb1|581 .rb2|581 .rb3|581) (let* ((.binding|584 (let ((.x|604|607 .regbindings|581)) (begin (.check! (pair? .x|604|607) 0 .x|604|607) (car:pair .x|604|607)))) (.regbindings|587 (let ((.x|600|603 .regbindings|581)) (begin (.check! (pair? .x|600|603) 1 .x|600|603) (cdr:pair .x|600|603)))) (.lhs|590 (regbinding.lhs .binding|584)) (.rhs|593 (regbinding.rhs .binding|584))) (let () (if (eq? .rhs|593 .t1|521) (.loop|580 .regbindings|587 (cons .binding|584 .rb1|581) .rb2|581 .rb3|581) (if (memq .lhs|590 .regs1|568) (.loop|580 .regbindings|587 .rb1|581 (cons .binding|584 .rb2|581) .rb3|581) (.loop|580 .regbindings|587 .rb1|581 .rb2|581 (cons .binding|584 .rb3|581))))))))) (.loop|580 .regbindings|577 .rb1|577 .rb2|577 .rb3|577))))) (begin #t (.loop|560|564|567 (let ((.x|609|612 .rvars|568)) (begin (.check! (pair? .x|609|612) 1 .x|609|612) (cdr:pair .x|609|612))) (let ((.x|613|616 .regs|568)) (begin (.check! (pair? .x|613|616) 1 .x|613|616) (cdr:pair .x|613|616))) (if (memq (let ((.x|617|620 .rvars|568)) (begin (.check! (pair? .x|617|620) 0 .x|617|620) (car:pair .x|617|620))) .f1|521) (cons (let ((.x|621|624 .regs|568)) (begin (.check! (pair? .x|621|624) 0 .x|621|624) (car:pair .x|621|624))) .regs1|568) .regs1|568)))))) (.loop|560|564|567 .regvars|15 argument-registers '())))))) (.phase2a|522))))) (set! .scan-binding|16 (lambda (.e|625 .env|625 .available|625) (let* ((.l|628 (call.proc .e|625)) (.t1|631 (let ((.x|685|688 (lambda.args .l|628))) (begin (.check! (pair? .x|685|688) 0 .x|685|688) (car:pair .x|685|688)))) (.e1|634 (let ((.x|681|684 (call.args .e|625))) (begin (.check! (pair? .x|681|684) 0 .x|681|684) (car:pair .x|681|684)))) (.e0|637 (lambda.body .l|628))) (let () (begin (.record-local-variable!|16 .t1|631) (call-with-values (lambda () (.scan-rhs|16 .e1|634 .env|625 .available|625)) (lambda (.e1|642 .f1|642 .regbindings1|642) (begin (.available-add!|16 .available|625 .t1|631 .e1|642) (let* ((.env|645 (let ((.formals|656 (make-null-terminated (lambda.args .l|628)))) (.environment-extend*|16 (.environment-extend*|16 .env|625 .formals|656) (let () (let ((.loop|662|665|668 (unspecified))) (begin (set! .loop|662|665|668 (lambda (.y1|657|658|669 .results|657|661|669) (if (null? .y1|657|658|669) (reverse .results|657|661|669) (begin #t (.loop|662|665|668 (let ((.x|673|676 .y1|657|658|669)) (begin (.check! (pair? .x|673|676) 1 .x|673|676) (cdr:pair .x|673|676))) (cons (def.lhs (let ((.x|677|680 .y1|657|658|669)) (begin (.check! (pair? .x|677|680) 0 .x|677|680) (car:pair .x|677|680)))) .results|657|661|669)))))) (.loop|662|665|668 (lambda.defs .l|628) '()))))))) (.fdefs|648 (.scan-defs|16 .l|628 .env|645 .available|625))) (let () (call-with-values (lambda () (.scan|16 .e0|637 .env|645 .available|625)) (lambda (.e0|653 .f0|653 .regbindings0|653) (begin (lambda.body-set! .l|628 .e0|653) (if .target-registers?|2 (.scan-binding-phase2|16 .l|628 .t1|631 .e0|653 .e1|642 .f0|653 .f1|642 .fdefs|648 .regbindings0|653 .regbindings1|642) (.scan-binding-phase3|16 .l|628 .e0|653 .e1|642 (union .f0|653 .fdefs|648) .f1|642 .regbindings0|653 .regbindings1|642))))))))))))))) (set! .scan|16 (lambda (.e|689 .env|689 .available|689) (if (not (call? .e|689)) (.scan-rhs|16 .e|689 .env|689 .available|689) (let ((.proc|692 (call.proc .e|689))) (if (not (lambda? .proc|692)) (.scan-rhs|16 .e|689 .env|689 .available|689) (let ((.vars|695 (lambda.args .proc|692))) (if (null? .vars|695) (.scan-let0|16 .e|689 .env|689 .available|689) (if (null? (let ((.x|698|701 .vars|695)) (begin (.check! (pair? .x|698|701) 1 .x|698|701) (cdr:pair .x|698|701)))) (.scan-binding|16 .e|689 .env|689 .available|689) (.error|14 (make-readable .e|689)))))))))) (set! .available-add!|16 (lambda (.available|703 .t|703 .e|703) (if (constant? .e|703) (available-extend! .available|703 .t|703 .e|703 available:killer:immortal) (if (variable? .e|703) (available-extend! .available|703 .t|703 .e|703 (if (.global?|16 (variable.name .e|703)) available:killer:globals available:killer:immortal)) (let ((.entry|709 (prim-call .e|703))) (if .entry|709 (let ((.killer|712 (prim-lives-until .entry|709))) (if (not (eq? .killer|712 available:killer:dead)) (let () (let ((.loop|713|716|719 (unspecified))) (begin (set! .loop|713|716|719 (lambda (.args|720 .k|720) (if (null? .args|720) (available-extend! .available|703 .t|703 .e|703 (logior .killer|712 .k|720)) (begin #t (.loop|713|716|719 (let ((.x|723|726 .args|720)) (begin (.check! (pair? .x|723|726) 1 .x|723|726) (cdr:pair .x|723|726))) (let ((.arg|729 (let ((.x|732|735 .args|720)) (begin (.check! (pair? .x|732|735) 0 .x|732|735) (car:pair .x|732|735))))) (if (if (variable? .arg|729) (.global?|16 (variable.name .arg|729)) #f) available:killer:globals .k|720))))))) (.loop|713|716|719 (call.args .e|703) .killer|712)))) (unspecified))) (unspecified))))))) (set! .global?|16 (lambda (.x|736) (if (.local-variable?|16 .x|736) #f (if (.environment-lookup|16 .env|15 .x|736) #f #t)))) (set! .environment-lookup|16 (lambda (.env|740 .sym|740) (hashtree-get .env|740 .sym|740))) (set! .environment-extend*|16 (lambda (.env|741 .symbols|741) (if (null? .symbols|741) .env|741 (.environment-extend*|16 (hashtree-put .env|741 (let ((.x|742|745 .symbols|741)) (begin (.check! (pair? .x|742|745) 0 .x|742|745) (car:pair .x|742|745))) #t) (let ((.x|746|749 .symbols|741)) (begin (.check! (pair? .x|746|749) 1 .x|746|749) (cdr:pair .x|746|749))))))) (set! .environment-extend|16 (lambda (.env|750 .sym|750) (hashtree-put .env|750 .sym|750 #t))) (set! .make-empty-environment|16 (lambda () (make-hashtree symbol-hash assq))) (set! .abandon-expression!|16 (lambda (.e|752) (if (variable? .e|752) (.adjust-local-variable!|16 (variable.name .e|752) -1) (if (conditional? .e|752) (begin (.abandon-expression!|16 (if.test .e|752)) (.abandon-expression!|16 (if.then .e|752)) (.abandon-expression!|16 (if.else .e|752))) (if (call? .e|752) (let () (let ((.loop|761|763|766 (unspecified))) (begin (set! .loop|761|763|766 (lambda (.y1|756|757|767) (if (null? .y1|756|757|767) (if #f #f (unspecified)) (begin (begin #t (let ((.exp|771 (let ((.x|775|778 .y1|756|757|767)) (begin (.check! (pair? .x|775|778) 0 .x|775|778) (car:pair .x|775|778))))) (if (variable? .exp|771) (let ((.name|774 (variable.name .exp|771))) (if (.local-variable?|16 .name|774) (.adjust-local-variable!|16 .name|774 -1) (unspecified))) (unspecified)))) (.loop|761|763|766 (let ((.x|779|782 .y1|756|757|767)) (begin (.check! (pair? .x|779|782) 1 .x|779|782) (cdr:pair .x|779|782)))))))) (.loop|761|763|766 (cons (call.proc .e|752) (call.args .e|752)))))) (unspecified)))))) (set! .used-variable!|16 (lambda (.sym|783) (.used-local-variable!|16 .sym|783))) (set! .closed-over-local-variable!|16 (lambda (.sym|784) (hashtable-put! .local-variables|16 .sym|784 1000000))) (set! .adjust-local-variable!|16 (lambda (.sym|785 .n|785) (let ((.m|788 (hashtable-get .local-variables|16 .sym|785))) (begin (if .debugging?|2 (if (if .m|788 (> .m|788 0) #f) (begin (write (let* ((.t1|791|794 .sym|785) (.t2|791|797 (cons (+ .m|788 .n|785) '()))) (let () (cons .t1|791|794 .t2|791|797)))) (newline)) (unspecified)) (unspecified)) (if .m|788 (hashtable-put! .local-variables|16 .sym|785 (+ .m|788 .n|785)) (unspecified)))))) (set! .used-local-variable!|16 (lambda (.sym|802) (.adjust-local-variable!|16 .sym|802 1))) (set! .record-local-variable!|16 (lambda (.sym|803) (hashtable-put! .local-variables|16 .sym|803 0))) (set! .local-variable-used-once?|16 (lambda (.sym|804) (= 1 (hashtable-fetch .local-variables|16 .sym|804 0)))) (set! .local-variable-not-used?|16 (lambda (.sym|805) (= 0 (hashtable-fetch .local-variables|16 .sym|805 -1)))) (set! .local-variable?|16 (lambda (.sym|806) (hashtable-get .local-variables|16 .sym|806))) (set! .local-variables|16 (make-hashtable symbol-hash assq)) (call-with-values (lambda () (.scan|16 .e|15 .env|15 .available|15)) (lambda (.e|808 .f|808 .regbindings|808) (call-with-values (lambda () (wrap-with-register-bindings .regbindings|808 .e|808 .f|808)) (lambda (.e|810 .f|810) (values .e|810 .f|810 '()))))))))) (set! .error|14 (lambda .stuff|811 (begin (display "Bug detected during intraprocedural optimization") (newline) (let ((.f|812|815|818 (lambda (.s|838) (begin (display .s|838) (newline))))) (let () (let ((.loop|820|822|825 (unspecified))) (begin (set! .loop|820|822|825 (lambda (.y1|812|813|826) (if (null? .y1|812|813|826) (if #f #f (unspecified)) (begin (begin #t (.f|812|815|818 (let ((.x|830|833 .y1|812|813|826)) (begin (.check! (pair? .x|830|833) 0 .x|830|833) (car:pair .x|830|833))))) (.loop|820|822|825 (let ((.x|834|837 .y1|812|813|826)) (begin (.check! (pair? .x|834|837) 1 .x|834|837) (cdr:pair .x|834|837)))))))) (.loop|820|822|825 .stuff|811))))) (.return|13 (make-constant #f))))) (call-with-values (lambda () (.scan-body|14 .e|1 (make-hashtree symbol-hash assq) (make-available-table) '())) (lambda (.e|840 .f|840 .regbindings|840) (begin (if (not (null? .regbindings|840)) (.error|14 'scan-body) (unspecified)) .e|840))))))))))) 'intraprocedural-commoning))
+(let () (begin (set! representation-analysis (lambda (.exp|1) (let ((.representation-analysis|2 0)) (begin (set! .representation-analysis|2 (lambda (.exp|3) (let* ((.debugging?|6 #f) (.integrate-usual?|9 (integrate-usual-procedures)) (.known|12 (make-hashtable symbol-hash assq)) (.types|15 (make-hashtable symbol-hash assq)) (.g|18 (callgraph .exp|3)) (.schedule|21 (cons (callgraphnode.code (let ((.x|734|737 .g|18)) (begin (.check! (pair? .x|734|737) 0 .x|734|737) (car:pair .x|734|737)))) '())) (.changed?|24 #f) (.mutate?|27 #f)) (let () (let ((.display-all-types|31 (unspecified)) (.display-types|31 (unspecified)) (.analyze-unknown-lambda|31 (unspecified)) (.analyze-known-local-procedure|31 (unspecified)) (.analyze-unknown-call|31 (unspecified)) (.analyze-known-call|31 (unspecified)) (.analyze-primop-call|31 (unspecified)) (.analyze-let1|31 (unspecified)) (.analyze-let0|31 (unspecified)) (.analyze|31 (unspecified)) (.lookup-node|31 (unspecified)) (.lookup-code|31 (unspecified)) (.update-typevar!|31 (unspecified)) (.known-procedure-is-callable?|31 (unspecified)) (.schedule-local-procedures!|31 (unspecified)) (.schedule-callers!|31 (unspecified)) (.schedule-known-procedure!|31 (unspecified)) (.schedule!|31 (unspecified))) (begin (set! .display-all-types|31 (lambda () (let* ((.vars|35 (hashtable-map (lambda (.x|70 .type|70) .x|70) .types|15)) (.vars|38 (twobit-sort (lambda (.var1|69 .var2|69) (string<=? (symbol->string .var1|69) (symbol->string .var2|69))) .vars|35))) (let () (let ((.f|42|45|48 (lambda (.x|68) (begin (write .x|68) (display ": ") (write (rep->symbol (hashtable-get .types|15 .x|68))) (newline))))) (let () (let ((.loop|50|52|55 (unspecified))) (begin (set! .loop|50|52|55 (lambda (.y1|42|43|56) (if (null? .y1|42|43|56) (if #f #f (unspecified)) (begin (begin #t (.f|42|45|48 (let ((.x|60|63 .y1|42|43|56)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63))))) (.loop|50|52|55 (let ((.x|64|67 .y1|42|43|56)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67)))))))) (.loop|50|52|55 .vars|38))))))))) (set! .display-types|31 (lambda () (hashtable-for-each (lambda (.f|72 .vars|72) (begin (write .f|72) (display " : returns ") (write (rep->symbol (hashtable-get .types|15 .f|72))) (newline) (let ((.f|73|76|79 (lambda (.x|99) (begin (display " ") (write .x|99) (display ": ") (write (rep->symbol (hashtable-get .types|15 .x|99))) (newline))))) (let () (let ((.loop|81|83|86 (unspecified))) (begin (set! .loop|81|83|86 (lambda (.y1|73|74|87) (if (null? .y1|73|74|87) (if #f #f (unspecified)) (begin (begin #t (.f|73|76|79 (let ((.x|91|94 .y1|73|74|87)) (begin (.check! (pair? .x|91|94) 0 .x|91|94) (car:pair .x|91|94))))) (.loop|81|83|86 (let ((.x|95|98 .y1|73|74|87)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98)))))))) (.loop|81|83|86 .vars|72))))))) .known|12))) (set! .analyze-unknown-lambda|31 (lambda (.l|100) (begin (if .debugging?|6 (begin (display "Analyzing escaping lambda expression") (newline)) (unspecified)) (.schedule-local-procedures!|31 .l|100) (let ((.vars|103 (make-null-terminated (lambda.args .l|100)))) (begin (let () (let ((.loop|109|111|114 (unspecified))) (begin (set! .loop|109|111|114 (lambda (.y1|104|105|115) (if (null? .y1|104|105|115) (if #f #f (unspecified)) (begin (begin #t (let ((.var|119 (let ((.x|120|123 .y1|104|105|115)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123))))) (hashtable-put! .types|15 .var|119 rep:object))) (.loop|109|111|114 (let ((.x|124|127 .y1|104|105|115)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127)))))))) (.loop|109|111|114 .vars|103)))) (.analyze|31 (lambda.body .l|100) (make-constraints-table))))))) (set! .analyze-known-local-procedure|31 (lambda (.name|128) (begin (if .debugging?|6 (begin (display "Analyzing ") (display .name|128) (newline)) (unspecified)) (let ((.l|131 (.lookup-code|31 .name|128)) (.constraints|131 (make-constraints-table))) (begin (.schedule-local-procedures!|31 .l|131) (let ((.type|134 (.analyze|31 (lambda.body .l|131) .constraints|131))) (begin (if (.update-typevar!|31 .name|128 .type|134) (.schedule-callers!|31 .name|128) (unspecified)) .type|134))))))) (set! .analyze-unknown-call|31 (lambda (.exp|135 .constraints|135) (begin (.analyze|31 (call.proc .exp|135) .constraints|135) (let () (let ((.loop|141|143|146 (unspecified))) (begin (set! .loop|141|143|146 (lambda (.y1|136|137|147) (if (null? .y1|136|137|147) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|151 (let ((.x|152|155 .y1|136|137|147)) (begin (.check! (pair? .x|152|155) 0 .x|152|155) (car:pair .x|152|155))))) (.analyze|31 .arg|151 .constraints|135))) (.loop|141|143|146 (let ((.x|156|159 .y1|136|137|147)) (begin (.check! (pair? .x|156|159) 1 .x|156|159) (cdr:pair .x|156|159)))))))) (.loop|141|143|146 (call.args .exp|135))))) (constraints-kill! .constraints|135 available:killer:all) rep:object))) (set! .analyze-known-call|31 (lambda (.exp|160 .constraints|160 .vars|160) (let* ((.procname|163 (variable.name (call.proc .exp|160))) (.args|166 (call.args .exp|160)) (.argtypes|169 (let () (let ((.loop|216|219|222 (unspecified))) (begin (set! .loop|216|219|222 (lambda (.y1|211|212|223 .results|211|215|223) (if (null? .y1|211|212|223) (reverse .results|211|215|223) (begin #t (.loop|216|219|222 (let ((.x|227|230 .y1|211|212|223)) (begin (.check! (pair? .x|227|230) 1 .x|227|230) (cdr:pair .x|227|230))) (cons (let ((.arg|231 (let ((.x|232|235 .y1|211|212|223)) (begin (.check! (pair? .x|232|235) 0 .x|232|235) (car:pair .x|232|235))))) (.analyze|31 .arg|231 .constraints|160)) .results|211|215|223)))))) (.loop|216|219|222 .args|166 '())))))) (let () (begin (if (not (.known-procedure-is-callable?|31 .procname|163)) (.schedule-known-procedure!|31 .procname|163) (unspecified)) (let () (let ((.loop|179|182|185 (unspecified))) (begin (set! .loop|179|182|185 (lambda (.y1|173|175|186 .y1|173|174|186) (if (let ((.temp|188|191 (null? .y1|173|175|186))) (if .temp|188|191 .temp|188|191 (null? .y1|173|174|186))) (if #f #f (unspecified)) (begin (begin #t (let ((.var|194 (let ((.x|195|198 .y1|173|175|186)) (begin (.check! (pair? .x|195|198) 0 .x|195|198) (car:pair .x|195|198)))) (.type|194 (let ((.x|199|202 .y1|173|174|186)) (begin (.check! (pair? .x|199|202) 0 .x|199|202) (car:pair .x|199|202))))) (if (.update-typevar!|31 .var|194 .type|194) (.schedule-known-procedure!|31 .procname|163) (unspecified)))) (.loop|179|182|185 (let ((.x|203|206 .y1|173|175|186)) (begin (.check! (pair? .x|203|206) 1 .x|203|206) (cdr:pair .x|203|206))) (let ((.x|207|210 .y1|173|174|186)) (begin (.check! (pair? .x|207|210) 1 .x|207|210) (cdr:pair .x|207|210)))))))) (.loop|179|182|185 .vars|160 .argtypes|169)))) (constraints-kill! .constraints|160 available:killer:all) (hashtable-get .types|15 .procname|163)))))) (set! .analyze-primop-call|31 (lambda (.exp|236 .constraints|236 .entry|236) (let* ((.op|239 (prim-opcodename .entry|236)) (.args|242 (call.args .exp|236)) (.argtypes|245 (let () (let ((.loop|293|296|299 (unspecified))) (begin (set! .loop|293|296|299 (lambda (.y1|288|289|300 .results|288|292|300) (if (null? .y1|288|289|300) (reverse .results|288|292|300) (begin #t (.loop|293|296|299 (let ((.x|304|307 .y1|288|289|300)) (begin (.check! (pair? .x|304|307) 1 .x|304|307) (cdr:pair .x|304|307))) (cons (let ((.arg|308 (let ((.x|309|312 .y1|288|289|300)) (begin (.check! (pair? .x|309|312) 0 .x|309|312) (car:pair .x|309|312))))) (.analyze|31 .arg|308 .constraints|236)) .results|288|292|300)))))) (.loop|293|296|299 .args|242 '()))))) (.type|248 (rep-result? .op|239 .argtypes|245))) (let () (begin (constraints-kill! .constraints|236 (prim-kills .entry|236)) (if (if (eq? .op|239 'check!) (variable? (let ((.x|255|258 .args|242)) (begin (.check! (pair? .x|255|258) 0 .x|255|258) (car:pair .x|255|258)))) #f) (let ((.varname|261 (variable.name (let ((.x|272|275 .args|242)) (begin (.check! (pair? .x|272|275) 0 .x|272|275) (car:pair .x|272|275)))))) (begin (if (if .mutate?|27 (representation-subtype? (let ((.x|264|267 .argtypes|245)) (begin (.check! (pair? .x|264|267) 0 .x|264|267) (car:pair .x|264|267))) rep:true) #f) (call.args-set! .exp|236 (cons (make-constant #t) (let ((.x|268|271 .args|242)) (begin (.check! (pair? .x|268|271) 1 .x|268|271) (cdr:pair .x|268|271))))) (unspecified)) (constraints-add! .types|15 .constraints|236 (make-type-constraint .varname|261 rep:true available:killer:immortal)))) (let ((.temp|276|279 (if .mutate?|27 (rep-specific? .op|239 .argtypes|245) #f))) (if .temp|276|279 (let ((.newop|280 .temp|276|279)) (call.proc-set! .exp|236 (make-variable .newop|280))) (unspecified)))) (let ((.temp|283|286 .type|248)) (if .temp|283|286 .temp|283|286 rep:object))))))) (set! .analyze-let1|31 (lambda (.exp|313 .constraints|313) (let* ((.proc|316 (call.proc .exp|313)) (.vars|319 (lambda.args .proc|316))) (let () (begin (.schedule-local-procedures!|31 .proc|316) (if (if (pair? .vars|319) (null? (let ((.x|325|328 .vars|319)) (begin (.check! (pair? .x|325|328) 1 .x|325|328) (cdr:pair .x|325|328)))) #f) (let* ((.t1|331 (let ((.x|359|362 .vars|319)) (begin (.check! (pair? .x|359|362) 0 .x|359|362) (car:pair .x|359|362)))) (.e1|334 (let ((.x|355|358 (call.args .exp|313))) (begin (.check! (pair? .x|355|358) 0 .x|355|358) (car:pair .x|355|358))))) (let () (begin (if (if .integrate-usual?|9 (call? .e1|334) #f) (let ((.proc|342 (call.proc .e1|334)) (.args|342 (call.args .e1|334))) (if (variable? .proc|342) (let* ((.op|345 (variable.name .proc|342)) (.entry|348 (prim-entry .op|345)) (.k1|351 (if .entry|348 (prim-lives-until .entry|348) available:killer:dead))) (let () (if (not (= .k1|351 available:killer:dead)) (constraints-add! .types|15 .constraints|313 (make-constraint .t1|331 (make-call .proc|342 .args|342) .k1|351)) (unspecified)))) (unspecified))) (unspecified)) (.update-typevar!|31 .t1|331 (.analyze|31 .e1|334 .constraints|313)) (.analyze|31 (lambda.body .proc|316) .constraints|313)))) (.analyze-unknown-call|31 .exp|313 .constraints|313))))))) (set! .analyze-let0|31 (lambda (.exp|363 .constraints|363) (let ((.proc|366 (call.proc .exp|363))) (begin (.schedule-local-procedures!|31 .proc|366) (if (null? (lambda.args .proc|366)) (.analyze|31 (lambda.body .exp|363) .constraints|363) (.analyze-unknown-call|31 .exp|363 .constraints|363)))))) (set! .analyze|31 (lambda (.exp|367 .constraints|367) (begin (if (if #f .debugging?|6 #f) (begin (display "Analyzing: ") (newline) (pretty-print (make-readable .exp|367 #t)) (newline)) (unspecified)) (let ((.temp|370|373 (let ((.x|463|466 .exp|367)) (begin (.check! (pair? .x|463|466) 0 .x|463|466) (car:pair .x|463|466))))) (if (memv .temp|370|373 '(quote)) (representation-of-value (constant.value .exp|367)) (if (memv .temp|370|373 '(begin)) (let ((.name|378 (variable.name .exp|367))) (let () (representation-typeof .name|378 .types|15 .constraints|367))) (if (memv .temp|370|373 '(lambda)) (begin (.schedule!|31 .exp|367) rep:procedure) (if (memv .temp|370|373 '(set!)) (begin (.analyze|31 (assignment.rhs .exp|367) .constraints|367) (constraints-kill! .constraints|367 available:killer:globals) rep:object) (if (memv .temp|370|373 '(if)) (let* ((.e0|387 (if.test .exp|367)) (.e1|390 (if.then .exp|367)) (.e2|393 (if.else .exp|367)) (.type0|396 (.analyze|31 .e0|387 .constraints|367))) (let () (begin (if .mutate?|27 (if (representation-subtype? .type0|396 rep:true) (if.test-set! .exp|367 (make-constant #t)) (if (representation-subtype? .type0|396 rep:false) (if.test-set! .exp|367 (make-constant #f)) (unspecified))) (unspecified)) (if (representation-subtype? .type0|396 rep:true) (.analyze|31 .e1|390 .constraints|367) (if (representation-subtype? .type0|396 rep:false) (.analyze|31 .e2|393 .constraints|367) (if (variable? .e0|387) (let* ((.t0|407 (variable.name .e0|387)) (.ignored|410 (.analyze|31 .e0|387 .constraints|367)) (.constraints1|413 (copy-constraints-table .constraints|367)) (.constraints2|416 (copy-constraints-table .constraints|367))) (let () (begin (constraints-add! .types|15 .constraints1|413 (make-type-constraint .t0|407 rep:true available:killer:immortal)) (constraints-add! .types|15 .constraints2|416 (make-type-constraint .t0|407 rep:false available:killer:immortal)) (let* ((.type1|422 (.analyze|31 .e1|390 .constraints1|413)) (.type2|425 (.analyze|31 .e2|393 .constraints2|416)) (.type|428 (representation-union .type1|422 .type2|425))) (let () (begin (constraints-intersect! .constraints|367 .constraints1|413 .constraints2|416) .type|428)))))) (representation-error "Bad ANF" (make-readable .exp|367 #t)))))))) (let ((.proc|436 (call.proc .exp|367)) (.args|436 (call.args .exp|367))) (if (lambda? .proc|436) (if (null? .args|436) (.analyze-let0|31 .exp|367 .constraints|367) (if (null? (let ((.x|440|443 .args|436)) (begin (.check! (pair? .x|440|443) 1 .x|440|443) (cdr:pair .x|440|443)))) (.analyze-let1|31 .exp|367 .constraints|367) (error "Compiler bug: pass3rep"))) (if (variable? .proc|436) (let ((.procname|448 (variable.name .proc|436))) (let () (let ((.temp|452|455 (hashtable-get .known|12 .procname|448))) (if .temp|452|455 (let ((.vars|456 .temp|452|455)) (.analyze-known-call|31 .exp|367 .constraints|367 .vars|456)) (if .integrate-usual?|9 (let ((.entry|460 (prim-entry .procname|448))) (if .entry|460 (.analyze-primop-call|31 .exp|367 .constraints|367 .entry|460) (.analyze-unknown-call|31 .exp|367 .constraints|367))) (.analyze-unknown-call|31 .exp|367 .constraints|367)))))) (.analyze-unknown-call|31 .exp|367 .constraints|367))))))))))))) (set! .lookup-node|31 (lambda (.l|467) (let ((.g|470 .g|18)) (let () (let ((.loop|473 (unspecified))) (begin (set! .loop|473 (lambda (.g|474) (if (null? .g|474) (error "Unknown lambda expression" (make-readable .l|467 #t)) (if (eq? .l|467 (callgraphnode.code (let ((.x|477|480 .g|474)) (begin (.check! (pair? .x|477|480) 0 .x|477|480) (car:pair .x|477|480))))) (let ((.x|481|484 .g|474)) (begin (.check! (pair? .x|481|484) 0 .x|481|484) (car:pair .x|481|484))) (.loop|473 (let ((.x|486|489 .g|474)) (begin (.check! (pair? .x|486|489) 1 .x|486|489) (cdr:pair .x|486|489)))))))) (.loop|473 .g|470))))))) (set! .lookup-code|31 (lambda (.name|490) (callgraphnode.code (assq .name|490 .g|18)))) (set! .update-typevar!|31 (lambda (.tv|491 .type|491) (let* ((.type0|494 (hashtable-get .types|15 .tv|491)) (.type0|497 (let ((.temp|506|509 .type0|494)) (if .temp|506|509 .temp|506|509 (begin (hashtable-put! .types|15 .tv|491 rep:bottom) rep:bottom)))) (.type1|500 (representation-union .type0|497 .type|491))) (let () (if (eq? .type0|497 .type1|500) #f (begin (hashtable-put! .types|15 .tv|491 .type1|500) (set! .changed?|24 #t) (if (if .debugging?|6 .mutate?|27 #f) (begin (display "******** Changing type of ") (display .tv|491) (display " from ") (display (rep->symbol .type0|497)) (display " to ") (display (rep->symbol .type1|500)) (newline)) (unspecified)) #t)))))) (set! .known-procedure-is-callable?|31 (lambda (.name|511) (callgraphnode.info (assq .name|511 .g|18)))) (set! .schedule-local-procedures!|31 (lambda (.l|512) (let () (let ((.loop|518|520|523 (unspecified))) (begin (set! .loop|518|520|523 (lambda (.y1|513|514|524) (if (null? .y1|513|514|524) (if #f #f (unspecified)) (begin (begin #t (let* ((.def|528 (let ((.x|532|535 .y1|513|514|524)) (begin (.check! (pair? .x|532|535) 0 .x|532|535) (car:pair .x|532|535)))) (.name|531 (def.lhs .def|528))) (if (.known-procedure-is-callable?|31 .name|531) (.schedule!|31 .name|531) (unspecified)))) (.loop|518|520|523 (let ((.x|536|539 .y1|513|514|524)) (begin (.check! (pair? .x|536|539) 1 .x|536|539) (cdr:pair .x|536|539)))))))) (.loop|518|520|523 (lambda.defs .l|512))))))) (set! .schedule-callers!|31 (lambda (.name|540) (let () (let ((.loop|546|548|551 (unspecified))) (begin (set! .loop|546|548|551 (lambda (.y1|541|542|552) (if (null? .y1|541|542|552) (if #f #f (unspecified)) (begin (begin #t (let ((.node|556 (let ((.x|567|570 .y1|541|542|552)) (begin (.check! (pair? .x|567|570) 0 .x|567|570) (car:pair .x|567|570))))) (if (if (callgraphnode.info .node|556) (let ((.temp|559|562 (memq .name|540 (callgraphnode.tailcalls .node|556)))) (if .temp|559|562 .temp|559|562 (memq .name|540 (callgraphnode.nontailcalls .node|556)))) #f) (let ((.caller|566 (callgraphnode.name .node|556))) (if .caller|566 (.schedule!|31 .caller|566) (.schedule!|31 (callgraphnode.code .node|556)))) (unspecified)))) (.loop|546|548|551 (let ((.x|571|574 .y1|541|542|552)) (begin (.check! (pair? .x|571|574) 1 .x|571|574) (cdr:pair .x|571|574)))))))) (.loop|546|548|551 .g|18)))))) (set! .schedule-known-procedure!|31 (lambda (.name|575) (begin (callgraphnode.info! (assq .name|575 .g|18) #t) (.schedule!|31 .name|575)))) (set! .schedule!|31 (lambda (.job|576) (if (not (memq .job|576 .schedule|21)) (begin (set! .schedule|21 (cons .job|576 .schedule|21)) (if (not (symbol? .job|576)) (callgraphnode.info! (.lookup-node|31 .job|576) #t) (unspecified))) (unspecified)))) '(if debugging? (begin (pretty-print (make-readable (car schedule) #t)) (newline))) (if .debugging?|6 (view-callgraph .g|18) (unspecified)) (let () (let ((.loop|582|584|587 (unspecified))) (begin (set! .loop|582|584|587 (lambda (.y1|577|578|588) (if (null? .y1|577|578|588) (if #f #f (unspecified)) (begin (begin #t (let* ((.node|592 (let ((.x|635|638 .y1|577|578|588)) (begin (.check! (pair? .x|635|638) 0 .x|635|638) (car:pair .x|635|638)))) (.name|595 (callgraphnode.name .node|592)) (.code|598 (callgraphnode.code .node|592)) (.vars|601 (make-null-terminated (lambda.args .code|598))) (.known?|604 (symbol? .name|595)) (.rep|607 (if .known?|604 rep:bottom rep:object))) (let () (begin (callgraphnode.info! .node|592 #f) (if .known?|604 (begin (hashtable-put! .known|12 .name|595 .vars|601) (hashtable-put! .types|15 .name|595 .rep|607)) (unspecified)) (let () (let ((.loop|616|618|621 (unspecified))) (begin (set! .loop|616|618|621 (lambda (.y1|611|612|622) (if (null? .y1|611|612|622) (if #f #f (unspecified)) (begin (begin #t (let ((.var|626 (let ((.x|627|630 .y1|611|612|622)) (begin (.check! (pair? .x|627|630) 0 .x|627|630) (car:pair .x|627|630))))) (hashtable-put! .types|15 .var|626 .rep|607))) (.loop|616|618|621 (let ((.x|631|634 .y1|611|612|622)) (begin (.check! (pair? .x|631|634) 1 .x|631|634) (cdr:pair .x|631|634)))))))) (.loop|616|618|621 .vars|601)))))))) (.loop|582|584|587 (let ((.x|639|642 .y1|577|578|588)) (begin (.check! (pair? .x|639|642) 1 .x|639|642) (cdr:pair .x|639|642)))))))) (.loop|582|584|587 .g|18)))) (let () (let () (let ((.loop|648 (unspecified))) (begin (set! .loop|648 (lambda () (if (not (null? .schedule|21)) (let ((.job|653 (let ((.x|658|661 .schedule|21)) (begin (.check! (pair? .x|658|661) 0 .x|658|661) (car:pair .x|658|661))))) (begin (set! .schedule|21 (let ((.x|654|657 .schedule|21)) (begin (.check! (pair? .x|654|657) 1 .x|654|657) (cdr:pair .x|654|657)))) (if (symbol? .job|653) (.analyze-known-local-procedure|31 .job|653) (.analyze-unknown-lambda|31 .job|653)) (.loop|648))) (if .changed?|24 (begin (set! .changed?|24 #f) (set! .schedule|21 (cons (callgraphnode.code (let ((.x|664|667 .g|18)) (begin (.check! (pair? .x|664|667) 0 .x|664|667) (car:pair .x|664|667)))) '())) (if .debugging?|6 (begin (.display-all-types|31) (newline)) (unspecified)) (.loop|648)) (unspecified))))) (.loop|648))))) (if .debugging?|6 (.display-types|31) (unspecified)) (set! .mutate?|27 #t) (set! .schedule|21 (cons (callgraphnode.code (let ((.x|668|671 .g|18)) (begin (.check! (pair? .x|668|671) 0 .x|668|671) (car:pair .x|668|671)))) (let () (let ((.loop|677|680|683 (unspecified))) (begin (set! .loop|677|680|683 (lambda (.y1|672|673|684 .results|672|676|684) (if (null? .y1|672|673|684) (reverse .results|672|676|684) (begin #t (.loop|677|680|683 (let ((.x|688|691 .y1|672|673|684)) (begin (.check! (pair? .x|688|691) 1 .x|688|691) (cdr:pair .x|688|691))) (cons (callgraphnode.name (let ((.x|692|695 .y1|672|673|684)) (begin (.check! (pair? .x|692|695) 0 .x|692|695) (car:pair .x|692|695)))) .results|672|676|684)))))) (.loop|677|680|683 (filter (lambda (.node|696) (let* ((.name|699 (callgraphnode.name .node|696)) (.known?|702 (symbol? .name|699)) (.marked?|705 (.known-procedure-is-callable?|31 .name|699))) (let () (begin (callgraphnode.info! .node|696 #f) (if .known?|702 .marked?|705 #f))))) .g|18) '())))))) (let () (let () (let ((.loop|716 (unspecified))) (begin (set! .loop|716 (lambda () (if (not (null? .schedule|21)) (let ((.job|720 (let ((.x|725|728 .schedule|21)) (begin (.check! (pair? .x|725|728) 0 .x|725|728) (car:pair .x|725|728))))) (begin (set! .schedule|21 (let ((.x|721|724 .schedule|21)) (begin (.check! (pair? .x|721|724) 1 .x|721|724) (cdr:pair .x|721|724)))) (if (symbol? .job|720) (.analyze-known-local-procedure|31 .job|720) (.analyze-unknown-lambda|31 .job|720)) (.loop|716))) (unspecified)))) (.loop|716))))) (if .changed?|24 (error "Compiler bug in representation inference") (unspecified)) (if .debugging?|6 (pretty-print (make-readable (callgraphnode.code (let ((.x|729|732 .g|18)) (begin (.check! (pair? .x|729|732) 0 .x|729|732) (car:pair .x|729|732)))) #t)) (unspecified)) .exp|3)))))) (.representation-analysis|2 .exp|1))))) 'representation-analysis))
+(let () (begin (set! pass3 (lambda (.exp|1) (let ((.pass3|2 0)) (begin (set! .pass3|2 (lambda (.exp|3) (let ((.verify|4 (unspecified)) (.finish|4 (unspecified)) (.phase4|4 (unspecified)) (.phase3|4 (unspecified)) (.phase2|4 (unspecified)) (.phase1|4 (unspecified))) (begin (set! .verify|4 (lambda (.exp|5) (begin (check-referencing-invariants .exp|5 'free) .exp|5))) (set! .finish|4 (lambda (.exp|6) (if (if (not (interprocedural-constant-propagation)) (not (common-subexpression-elimination)) #f) (begin (compute-free-variables! .exp|6) .exp|6) .exp|6))) (set! .phase4|4 (lambda (.exp|9) (if (representation-inference) (let ((.exp|12 (if (common-subexpression-elimination) .exp|9 (if (interprocedural-constant-propagation) (a-normal-form .exp|9) (a-normal-form (copy-exp .exp|9)))))) (intraprocedural-commoning (representation-analysis .exp|12))) .exp|9))) (set! .phase3|4 (lambda (.exp|16) (if (common-subexpression-elimination) (let* ((.exp|19 (if (interprocedural-constant-propagation) .exp|16 (copy-exp .exp|16))) (.exp|22 (a-normal-form .exp|19))) (let () (if (representation-inference) (intraprocedural-commoning .exp|22 'commoning) (intraprocedural-commoning .exp|22)))) .exp|16))) (set! .phase2|4 (lambda (.exp|26) (if (interprocedural-constant-propagation) (constant-propagation (copy-exp .exp|26)) .exp|26))) (set! .phase1|4 (lambda (.exp|27) (if (interprocedural-inlining) (let ((.g|30 (callgraph .exp|27))) (begin (inline-using-callgraph! .g|30) .exp|27)) .exp|27))) (if (global-optimization) (.verify|4 (.finish|4 (.phase4|4 (.phase3|4 (.phase2|4 (.phase1|4 .exp|3)))))) (begin (compute-free-variables! .exp|3) (.verify|4 .exp|3))))))) (.pass3|2 .exp|1))))) 'pass3))
+(let () (begin (set! init-labels (lambda () (let ((.init-labels|2 0)) (begin (set! .init-labels|2 (lambda () (set! cg-label-counter 1000))) (.init-labels|2))))) 'init-labels))
+(let () (begin (set! make-label (lambda () (let ((.make-label|2 0)) (begin (set! .make-label|2 (lambda () (begin (set! cg-label-counter (+ cg-label-counter 1)) cg-label-counter))) (.make-label|2))))) 'make-label))
+(let () (begin (set! cg-label-counter 1000) 'cg-label-counter))
+(let () (begin (set! make-assembly-stream (lambda () (let ((.make-assembly-stream|2 0)) (begin (set! .make-assembly-stream|2 (lambda () (let ((.code|6 (cons (cons 0 '()) '()))) (begin (set-cdr! .code|6 (let ((.x|7|10 .code|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) (let* ((.t1|11|14 .code|6) (.t2|11|17 (cons #f '()))) (let () (cons .t1|11|14 .t2|11|17))))))) (.make-assembly-stream|2))))) 'make-assembly-stream))
+(let () (begin (set! assembly-stream-code (lambda (.output|1) (let ((.assembly-stream-code|2 0)) (begin (set! .assembly-stream-code|2 (lambda (.output|3) (if (local-optimizations) (filter-basic-blocks (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .output|3)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8)))) (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .output|3)) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 1 .x|18|21) (cdr:pair .x|18|21)))))) (.assembly-stream-code|2 .output|1))))) 'assembly-stream-code))
+(let () (begin (set! assembly-stream-info (lambda (.output|1) (let ((.assembly-stream-info|2 0)) (begin (set! .assembly-stream-info|2 (lambda (.output|3) (let ((.x|5|8 (let ((.x|9|12 .output|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.assembly-stream-info|2 .output|1))))) 'assembly-stream-info))
+(let () (begin (set! assembly-stream-info! (lambda (.output|1 .x|1) (let ((.assembly-stream-info!|2 0)) (begin (set! .assembly-stream-info!|2 (lambda (.output|3 .x|3) (begin (set-car! (let ((.x|4|7 .output|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .x|3) #f))) (.assembly-stream-info!|2 .output|1 .x|1))))) 'assembly-stream-info!))
+(let () (begin (set! gen-instruction! (lambda (.output|1 .instruction|1) (let ((.gen-instruction!|2 0)) (begin (set! .gen-instruction!|2 (lambda (.output|3 .instruction|3) (let ((.pair|6 (cons .instruction|3 '())) (.code|6 (let ((.x|12|15 .output|3)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))) (begin (set-cdr! (let ((.x|7|10 .code|6)) (begin (.check! (pair? .x|7|10) 1 .x|7|10) (cdr:pair .x|7|10))) .pair|6) (set-cdr! .code|6 .pair|6) .output|3)))) (.gen-instruction!|2 .output|1 .instruction|1))))) 'gen-instruction!))
+(let () (begin (set! gen! (lambda (.output|1 . .instruction|1) (gen-instruction! .output|1 .instruction|1))) 'gen!))
+(let () (begin (set! gen-save! (lambda (.output|1 .frame|1 .t0|1) (let ((.gen-save!|2 0)) (begin (set! .gen-save!|2 (lambda (.output|3 .frame|3 .t0|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (begin (gen-instruction! .output|3 (cons $save .size|6)) (gen-store! .output|3 .frame|3 0 .t0|3) (cgframe:stale-set! .frame|3 '()))))) (.gen-save!|2 .output|1 .frame|1 .t0|1))))) 'gen-save!))
+(let () (begin (set! gen-restore! (lambda (.output|1 .frame|1) (let ((.gen-restore!|2 0)) (begin (set! .gen-restore!|2 (lambda (.output|3 .frame|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (gen-instruction! .output|3 (cons $restore .size|6))))) (.gen-restore!|2 .output|1 .frame|1))))) 'gen-restore!))
+(let () (begin (set! gen-pop! (lambda (.output|1 .frame|1) (let ((.gen-pop!|2 0)) (begin (set! .gen-pop!|2 (lambda (.output|3 .frame|3) (let ((.size|6 (cgframe-size-cell .frame|3))) (gen-instruction! .output|3 (cons $pop .size|6))))) (.gen-pop!|2 .output|1 .frame|1))))) 'gen-pop!))
+(let () (begin (set! gen-setstk! (lambda (.output|1 .frame|1 .tempname|1) (let ((.gen-setstk!|2 0)) (begin (set! .gen-setstk!|2 (lambda (.output|3 .frame|3 .tempname|3) (let ((.instruction|6 (let* ((.t1|7|10 $nop) (.t2|7|13 (let* ((.t1|17|20 $setstk) (.t2|17|23 (cons -1 '()))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))))) (begin (cgframe-bind! .frame|3 .tempname|3 .instruction|6) (gen-instruction! .output|3 .instruction|6))))) (.gen-setstk!|2 .output|1 .frame|1 .tempname|1))))) 'gen-setstk!))
+(let () (begin (set! gen-store! (lambda (.output|1 .frame|1 .r|1 .tempname|1) (let ((.gen-store!|2 0)) (begin (set! .gen-store!|2 (lambda (.output|3 .frame|3 .r|3 .tempname|3) (let ((.instruction|6 (let* ((.t1|7|10 $nop) (.t2|7|13 (let* ((.t1|17|20 $store) (.t2|17|23 (let* ((.t1|27|30 .r|3) (.t2|27|33 (cons -1 '()))) (let () (cons .t1|27|30 .t2|27|33))))) (let () (cons .t1|17|20 .t2|17|23))))) (let () (cons .t1|7|10 .t2|7|13))))) (begin (cgframe-bind! .frame|3 .tempname|3 .instruction|6) (gen-instruction! .output|3 .instruction|6))))) (.gen-store!|2 .output|1 .frame|1 .r|1 .tempname|1))))) 'gen-store!))
+(let () (begin (set! gen-load! (lambda (.output|1 .frame|1 .r|1 .tempname|1) (let ((.gen-load!|2 0)) (begin (set! .gen-load!|2 (lambda (.output|3 .frame|3 .r|3 .tempname|3) (begin (cgframe-touch! .frame|3 .tempname|3) (let ((.n|6 (entry.slotnum (cgframe-lookup .frame|3 .tempname|3)))) (gen! .output|3 $load .r|3 .n|6))))) (.gen-load!|2 .output|1 .frame|1 .r|1 .tempname|1))))) 'gen-load!))
+(let () (begin (set! gen-stack! (lambda (.output|1 .frame|1 .tempname|1) (let ((.gen-stack!|2 0)) (begin (set! .gen-stack!|2 (lambda (.output|3 .frame|3 .tempname|3) (begin (cgframe-touch! .frame|3 .tempname|3) (let ((.n|6 (entry.slotnum (cgframe-lookup .frame|3 .tempname|3)))) (gen! .output|3 $stack .n|6))))) (.gen-stack!|2 .output|1 .frame|1 .tempname|1))))) 'gen-stack!))
+(let () (begin (set! init-temps (lambda () (let ((.init-temps|2 0)) (begin (set! .init-temps|2 (lambda () (set! newtemp-counter 5000))) (.init-temps|2))))) 'init-temps))
+(let () (begin (set! newtemp (lambda () (let ((.newtemp|2 0)) (begin (set! .newtemp|2 (lambda () (begin (set! newtemp-counter (+ newtemp-counter 1)) newtemp-counter))) (.newtemp|2))))) 'newtemp))
+(let () (begin (set! newtemp-counter 5000) 'newtemp-counter))
+(let () (begin (set! newtemps (lambda (.n|1) (let ((.newtemps|2 0)) (begin (set! .newtemps|2 (lambda (.n|3) (if (zero? .n|3) '() (cons (newtemp) (.newtemps|2 (- .n|3 1)))))) (.newtemps|2 .n|1))))) 'newtemps))
+(let () (begin (set! cgreg-makeregs (lambda (.n|1 .v1|1 .v2|1) (let ((.cgreg-makeregs|2 0)) (begin (set! .cgreg-makeregs|2 (lambda (.n|3 .v1|3 .v2|3) (let* ((.t1|4|7 .n|3) (.t2|4|10 (let* ((.t1|14|17 .v1|3) (.t2|14|20 (cons .v2|3 '()))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.cgreg-makeregs|2 .n|1 .v1|1 .v2|1))))) 'cgreg-makeregs))
+(let () (begin (set! cgreg-liveregs (lambda (.regs|1) (let ((.cgreg-liveregs|2 0)) (begin (set! .cgreg-liveregs|2 (lambda (.regs|3) (let ((.x|4|7 .regs|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.cgreg-liveregs|2 .regs|1))))) 'cgreg-liveregs))
+(let () (begin (set! cgreg-contents (lambda (.regs|1) (let ((.cgreg-contents|2 0)) (begin (set! .cgreg-contents|2 (lambda (.regs|3) (let ((.x|5|8 (let ((.x|9|12 .regs|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.cgreg-contents|2 .regs|1))))) 'cgreg-contents))
+(let () (begin (set! cgreg-stale (lambda (.regs|1) (let ((.cgreg-stale|2 0)) (begin (set! .cgreg-stale|2 (lambda (.regs|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .regs|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))))) (.cgreg-stale|2 .regs|1))))) 'cgreg-stale))
+(let () (begin (set! cgreg-liveregs-set! (lambda (.regs|1 .n|1) (let ((.cgreg-liveregs-set!|2 0)) (begin (set! .cgreg-liveregs-set!|2 (lambda (.regs|3 .n|3) (begin (set-car! .regs|3 .n|3) .regs|3))) (.cgreg-liveregs-set!|2 .regs|1 .n|1))))) 'cgreg-liveregs-set!))
+(let () (begin (set! cgreg-initial (lambda () (let ((.cgreg-initial|2 0)) (begin (set! .cgreg-initial|2 (lambda () (let ((.v1|6 (make-vector *nregs* #f)) (.v2|6 (make-vector *nregs* #f))) (cgreg-makeregs 0 .v1|6 .v2|6)))) (.cgreg-initial|2))))) 'cgreg-initial))
+(let () (begin (set! cgreg-copy (lambda (.regs|1) (let ((.cgreg-copy|2 0)) (begin (set! .cgreg-copy|2 (lambda (.regs|3) (let* ((.newregs|6 (cgreg-initial)) (.v1a|9 (cgreg-contents .regs|3)) (.v2a|12 (cgreg-stale .regs|3)) (.v1|15 (cgreg-contents .newregs|6)) (.v2|18 (cgreg-stale .newregs|6)) (.n|21 (let ((.v|50|53 .v1a|9)) (begin (.check! (vector? .v|50|53) 42 .v|50|53) (vector-length:vec .v|50|53))))) (let () (begin (cgreg-liveregs-set! .newregs|6 (cgreg-liveregs .regs|3)) (let () (let ((.loop|25|27|30 (unspecified))) (begin (set! .loop|25|27|30 (lambda (.i|31) (if (= .i|31 .n|21) .newregs|6 (begin (begin #t (let ((.v|34|37 .v1|15) (.i|34|37 .i|31) (.x|34|37 (let ((.v|38|41 .v1a|9) (.i|38|41 .i|31)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))))) (begin (.check! (fixnum? .i|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (vector? .v|34|37) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 41 .v|34|37 .i|34|37 .x|34|37) (.check! (>=:fix:fix .i|34|37 0) 41 .v|34|37 .i|34|37 .x|34|37) (vector-set!:trusted .v|34|37 .i|34|37 .x|34|37))) (let ((.v|42|45 .v2|18) (.i|42|45 .i|31) (.x|42|45 (let ((.v|46|49 .v2a|12) (.i|46|49 .i|31)) (begin (.check! (fixnum? .i|46|49) 40 .v|46|49 .i|46|49) (.check! (vector? .v|46|49) 40 .v|46|49 .i|46|49) (.check! (<:fix:fix .i|46|49 (vector-length:vec .v|46|49)) 40 .v|46|49 .i|46|49) (.check! (>=:fix:fix .i|46|49 0) 40 .v|46|49 .i|46|49) (vector-ref:trusted .v|46|49 .i|46|49))))) (begin (.check! (fixnum? .i|42|45) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (vector? .v|42|45) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (<:fix:fix .i|42|45 (vector-length:vec .v|42|45)) 41 .v|42|45 .i|42|45 .x|42|45) (.check! (>=:fix:fix .i|42|45 0) 41 .v|42|45 .i|42|45 .x|42|45) (vector-set!:trusted .v|42|45 .i|42|45 .x|42|45)))) (.loop|25|27|30 (+ .i|31 1)))))) (.loop|25|27|30 0))))))))) (.cgreg-copy|2 .regs|1))))) 'cgreg-copy))
+(let () (begin (set! cgreg-tos (lambda (.regs|1) (let ((.cgreg-tos|2 0)) (begin (set! .cgreg-tos|2 (lambda (.regs|3) (- (cgreg-liveregs .regs|3) 1))) (.cgreg-tos|2 .regs|1))))) 'cgreg-tos))
+(let () (begin (set! cgreg-live (lambda (.regs|1 .r|1) (let ((.cgreg-live|2 0)) (begin (set! .cgreg-live|2 (lambda (.regs|3 .r|3) (if (eq? .r|3 'result) (cgreg-tos .regs|3) (max .r|3 (cgreg-tos .regs|3))))) (.cgreg-live|2 .regs|1 .r|1))))) 'cgreg-live))
+(let () (begin (set! cgreg-vars (lambda (.regs|1) (let ((.cgreg-vars|2 0)) (begin (set! .cgreg-vars|2 (lambda (.regs|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.i|14 .vars|14) (if (< .i|14 0) .vars|14 (begin #t (.loop|7|10|13 (- .i|14 1) (cons (let ((.v|17|20 .v|6) (.i|17|20 .i|14)) (begin (.check! (fixnum? .i|17|20) 40 .v|17|20 .i|17|20) (.check! (vector? .v|17|20) 40 .v|17|20 .i|17|20) (.check! (<:fix:fix .i|17|20 (vector-length:vec .v|17|20)) 40 .v|17|20 .i|17|20) (.check! (>=:fix:fix .i|17|20 0) 40 .v|17|20 .i|17|20) (vector-ref:trusted .v|17|20 .i|17|20))) .vars|14)))))) (.loop|7|10|13 (- .m|6 1) '()))))))) (.cgreg-vars|2 .regs|1))))) 'cgreg-vars))
+(let () (begin (set! cgreg-bind! (lambda (.regs|1 .r|1 .t|1) (let ((.cgreg-bind!|2 0)) (begin (set! .cgreg-bind!|2 (lambda (.regs|3 .r|3 .t|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (begin (let ((.v|7|10 .v|6) (.i|7|10 .r|3) (.x|7|10 .t|3)) (begin (.check! (fixnum? .i|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (vector? .v|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (>=:fix:fix .i|7|10 0) 41 .v|7|10 .i|7|10 .x|7|10) (vector-set!:trusted .v|7|10 .i|7|10 .x|7|10))) (if (>= .r|3 .m|6) (cgreg-liveregs-set! .regs|3 (+ .r|3 1)) (unspecified)))))) (.cgreg-bind!|2 .regs|1 .r|1 .t|1))))) 'cgreg-bind!))
+(let () (begin (set! cgreg-bindregs! (lambda (.regs|1 .vars|1) (let ((.cgreg-bindregs!|2 0)) (begin (set! .cgreg-bindregs!|2 (lambda (.regs|3 .vars|3) (let () (let ((.loop|4|8|11 (unspecified))) (begin (set! .loop|4|8|11 (lambda (.m|12 .v|12 .vars|12) (if (null? .vars|12) (begin (cgreg-liveregs-set! .regs|3 .m|12) .regs|3) (begin (begin #t (let ((.v|15|18 .v|12) (.i|15|18 .m|12) (.x|15|18 (let ((.x|19|22 .vars|12)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))))) (begin (.check! (fixnum? .i|15|18) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (vector? .v|15|18) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (<:fix:fix .i|15|18 (vector-length:vec .v|15|18)) 41 .v|15|18 .i|15|18 .x|15|18) (.check! (>=:fix:fix .i|15|18 0) 41 .v|15|18 .i|15|18 .x|15|18) (vector-set!:trusted .v|15|18 .i|15|18 .x|15|18)))) (.loop|4|8|11 (+ .m|12 1) .v|12 (let ((.x|23|26 .vars|12)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))))))) (.loop|4|8|11 (cgreg-liveregs .regs|3) (cgreg-contents .regs|3) .vars|3)))))) (.cgreg-bindregs!|2 .regs|1 .vars|1))))) 'cgreg-bindregs!))
+(let () (begin (set! cgreg-rename! (lambda (.regs|1 .alist|1) (let ((.cgreg-rename!|2 0)) (begin (set! .cgreg-rename!|2 (lambda (.regs|3 .alist|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .v|12) (if (< .i|12 0) (if #f #f (unspecified)) (begin (begin #t (let ((.var|18 (let ((.v|31|34 .v|12) (.i|31|34 .i|12)) (begin (.check! (fixnum? .i|31|34) 40 .v|31|34 .i|31|34) (.check! (vector? .v|31|34) 40 .v|31|34 .i|31|34) (.check! (<:fix:fix .i|31|34 (vector-length:vec .v|31|34)) 40 .v|31|34 .i|31|34) (.check! (>=:fix:fix .i|31|34 0) 40 .v|31|34 .i|31|34) (vector-ref:trusted .v|31|34 .i|31|34))))) (if .var|18 (let ((.probe|21 (assv .var|18 .alist|3))) (if .probe|21 (let ((.v|22|25 .v|12) (.i|22|25 .i|12) (.x|22|25 (let ((.x|26|29 .probe|21)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (fixnum? .i|22|25) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (vector? .v|22|25) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (<:fix:fix .i|22|25 (vector-length:vec .v|22|25)) 41 .v|22|25 .i|22|25 .x|22|25) (.check! (>=:fix:fix .i|22|25 0) 41 .v|22|25 .i|22|25 .x|22|25) (vector-set!:trusted .v|22|25 .i|22|25 .x|22|25))) (unspecified))) (unspecified)))) (.loop|5|8|11 (- .i|12 1) .v|12))))) (.loop|5|8|11 (- (cgreg-liveregs .regs|3) 1) (cgreg-contents .regs|3))))))) (.cgreg-rename!|2 .regs|1 .alist|1))))) 'cgreg-rename!))
+(let () (begin (set! cgreg-release! (lambda (.regs|1 .r|1) (let ((.cgreg-release!|2 0)) (begin (set! .cgreg-release!|2 (lambda (.regs|3 .r|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (begin (let ((.v|7|10 .v|6) (.i|7|10 .r|3) (.x|7|10 #f)) (begin (.check! (fixnum? .i|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (vector? .v|7|10) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 41 .v|7|10 .i|7|10 .x|7|10) (.check! (>=:fix:fix .i|7|10 0) 41 .v|7|10 .i|7|10 .x|7|10) (vector-set!:trusted .v|7|10 .i|7|10 .x|7|10))) (let ((.v|11|14 (cgreg-stale .regs|3)) (.i|11|14 .r|3) (.x|11|14 #t)) (begin (.check! (fixnum? .i|11|14) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (vector? .v|11|14) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 41 .v|11|14 .i|11|14 .x|11|14) (.check! (>=:fix:fix .i|11|14 0) 41 .v|11|14 .i|11|14 .x|11|14) (vector-set!:trusted .v|11|14 .i|11|14 .x|11|14))) (if (= .r|3 (- .m|6 1)) (let () (let ((.loop|15|17|20 (unspecified))) (begin (set! .loop|15|17|20 (lambda (.m|21) (if (let ((.temp|23|26 (< .m|21 0))) (if .temp|23|26 .temp|23|26 (let ((.v|28|31 .v|6) (.i|28|31 .m|21)) (begin (.check! (fixnum? .i|28|31) 40 .v|28|31 .i|28|31) (.check! (vector? .v|28|31) 40 .v|28|31 .i|28|31) (.check! (<:fix:fix .i|28|31 (vector-length:vec .v|28|31)) 40 .v|28|31 .i|28|31) (.check! (>=:fix:fix .i|28|31 0) 40 .v|28|31 .i|28|31) (vector-ref:trusted .v|28|31 .i|28|31))))) (cgreg-liveregs-set! .regs|3 (+ .m|21 1)) (begin #t (.loop|15|17|20 (- .m|21 1)))))) (.loop|15|17|20 .r|3)))) (unspecified)))))) (.cgreg-release!|2 .regs|1 .r|1))))) 'cgreg-release!))
+(let () (begin (set! cgreg-release-except! (lambda (.regs|1 .vars|1) (let ((.cgreg-release-except!|2 0)) (begin (set! .cgreg-release-except!|2 (lambda (.regs|3 .vars|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .v|12) (if (< .i|12 0) (if #f #f (unspecified)) (begin (begin #t (let ((.var|18 (let ((.v|21|24 .v|12) (.i|21|24 .i|12)) (begin (.check! (fixnum? .i|21|24) 40 .v|21|24 .i|21|24) (.check! (vector? .v|21|24) 40 .v|21|24 .i|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 40 .v|21|24 .i|21|24) (.check! (>=:fix:fix .i|21|24 0) 40 .v|21|24 .i|21|24) (vector-ref:trusted .v|21|24 .i|21|24))))) (if (if .var|18 (not (memq .var|18 .vars|3)) #f) (cgreg-release! .regs|3 .i|12) (unspecified)))) (.loop|5|8|11 (- .i|12 1) .v|12))))) (.loop|5|8|11 (- (cgreg-liveregs .regs|3) 1) (cgreg-contents .regs|3))))))) (.cgreg-release-except!|2 .regs|1 .vars|1))))) 'cgreg-release-except!))
+(let () (begin (set! cgreg-clear! (lambda (.regs|1) (let ((.cgreg-clear!|2 0)) (begin (set! .cgreg-clear!|2 (lambda (.regs|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v1|6 (cgreg-contents .regs|3)) (.v2|6 (cgreg-stale .regs|3))) (let () (let ((.loop|7|9|12 (unspecified))) (begin (set! .loop|7|9|12 (lambda (.r|13) (if (= .r|13 .m|6) (cgreg-liveregs-set! .regs|3 0) (begin (begin #t (let ((.v|16|19 .v1|6) (.i|16|19 .r|13) (.x|16|19 #f)) (begin (.check! (fixnum? .i|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (vector? .v|16|19) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (<:fix:fix .i|16|19 (vector-length:vec .v|16|19)) 41 .v|16|19 .i|16|19 .x|16|19) (.check! (>=:fix:fix .i|16|19 0) 41 .v|16|19 .i|16|19 .x|16|19) (vector-set!:trusted .v|16|19 .i|16|19 .x|16|19))) (let ((.v|20|23 .v2|6) (.i|20|23 .r|13) (.x|20|23 #t)) (begin (.check! (fixnum? .i|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (vector? .v|20|23) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (<:fix:fix .i|20|23 (vector-length:vec .v|20|23)) 41 .v|20|23 .i|20|23 .x|20|23) (.check! (>=:fix:fix .i|20|23 0) 41 .v|20|23 .i|20|23 .x|20|23) (vector-set!:trusted .v|20|23 .i|20|23 .x|20|23)))) (.loop|7|9|12 (+ .r|13 1)))))) (.loop|7|9|12 0))))))) (.cgreg-clear!|2 .regs|1))))) 'cgreg-clear!))
+(let () (begin (set! cgreg-lookup (lambda (.regs|1 .var|1) (let ((.cgreg-lookup|2 0)) (begin (set! .cgreg-lookup|2 (lambda (.regs|3 .var|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (let ((.loop|7 (unspecified))) (begin (set! .loop|7 (lambda (.i|8) (if (< .i|8 0) #f (if (eq? .var|3 (let ((.v|11|14 .v|6) (.i|11|14 .i|8)) (begin (.check! (fixnum? .i|11|14) 40 .v|11|14 .i|11|14) (.check! (vector? .v|11|14) 40 .v|11|14 .i|11|14) (.check! (<:fix:fix .i|11|14 (vector-length:vec .v|11|14)) 40 .v|11|14 .i|11|14) (.check! (>=:fix:fix .i|11|14 0) 40 .v|11|14 .i|11|14) (vector-ref:trusted .v|11|14 .i|11|14)))) (let* ((.t1|15|18 .var|3) (.t2|15|21 (let* ((.t1|25|28 'register) (.t2|25|31 (let* ((.t1|35|38 .i|8) (.t2|35|41 (cons '(object) '()))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))))) (let () (cons .t1|15|18 .t2|15|21))) (.loop|7 (- .i|8 1)))))) (.loop|7 (- .m|6 1))))))) (.cgreg-lookup|2 .regs|1 .var|1))))) 'cgreg-lookup))
+(let () (begin (set! cgreg-lookup-reg (lambda (.regs|1 .r|1) (let ((.cgreg-lookup-reg|2 0)) (begin (set! .cgreg-lookup-reg|2 (lambda (.regs|3 .r|3) (let ((.m|6 (cgreg-liveregs .regs|3)) (.v|6 (cgreg-contents .regs|3))) (if (<= .m|6 .r|3) #f (let ((.v|7|10 .v|6) (.i|7|10 .r|3)) (begin (.check! (fixnum? .i|7|10) 40 .v|7|10 .i|7|10) (.check! (vector? .v|7|10) 40 .v|7|10 .i|7|10) (.check! (<:fix:fix .i|7|10 (vector-length:vec .v|7|10)) 40 .v|7|10 .i|7|10) (.check! (>=:fix:fix .i|7|10 0) 40 .v|7|10 .i|7|10) (vector-ref:trusted .v|7|10 .i|7|10))))))) (.cgreg-lookup-reg|2 .regs|1 .r|1))))) 'cgreg-lookup-reg))
+(let () (begin (set! cgreg-join! (lambda (.regs1|1 .regs2|1) (let ((.cgreg-join!|2 0)) (begin (set! .cgreg-join!|2 (lambda (.regs1|3 .regs2|3) (let ((.m1|6 (cgreg-liveregs .regs1|3)) (.m2|6 (cgreg-liveregs .regs2|3)) (.v1|6 (cgreg-contents .regs1|3)) (.v2|6 (cgreg-contents .regs2|3)) (.stale1|6 (cgreg-stale .regs1|3))) (let () (let ((.loop|7|9|12 (unspecified))) (begin (set! .loop|7|9|12 (lambda (.i|13) (if (< .i|13 0) (cgreg-liveregs-set! .regs1|3 (min .m1|6 .m2|6)) (begin (begin #t (let ((.x1|18 (let ((.v|34|37 .v1|6) (.i|34|37 .i|13)) (begin (.check! (fixnum? .i|34|37) 40 .v|34|37 .i|34|37) (.check! (vector? .v|34|37) 40 .v|34|37 .i|34|37) (.check! (<:fix:fix .i|34|37 (vector-length:vec .v|34|37)) 40 .v|34|37 .i|34|37) (.check! (>=:fix:fix .i|34|37 0) 40 .v|34|37 .i|34|37) (vector-ref:trusted .v|34|37 .i|34|37)))) (.x2|18 (let ((.v|38|41 .v2|6) (.i|38|41 .i|13)) (begin (.check! (fixnum? .i|38|41) 40 .v|38|41 .i|38|41) (.check! (vector? .v|38|41) 40 .v|38|41 .i|38|41) (.check! (<:fix:fix .i|38|41 (vector-length:vec .v|38|41)) 40 .v|38|41 .i|38|41) (.check! (>=:fix:fix .i|38|41 0) 40 .v|38|41 .i|38|41) (vector-ref:trusted .v|38|41 .i|38|41))))) (if (eq? .x1|18 .x2|18) #t (if (not .x1|18) (if .x2|18 (let ((.v|21|24 .stale1|6) (.i|21|24 .i|13) (.x|21|24 #t)) (begin (.check! (fixnum? .i|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (vector? .v|21|24) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (<:fix:fix .i|21|24 (vector-length:vec .v|21|24)) 41 .v|21|24 .i|21|24 .x|21|24) (.check! (>=:fix:fix .i|21|24 0) 41 .v|21|24 .i|21|24 .x|21|24) (vector-set!:trusted .v|21|24 .i|21|24 .x|21|24))) (unspecified)) (begin (let ((.v|26|29 .v1|6) (.i|26|29 .i|13) (.x|26|29 #f)) (begin (.check! (fixnum? .i|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (vector? .v|26|29) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (<:fix:fix .i|26|29 (vector-length:vec .v|26|29)) 41 .v|26|29 .i|26|29 .x|26|29) (.check! (>=:fix:fix .i|26|29 0) 41 .v|26|29 .i|26|29 .x|26|29) (vector-set!:trusted .v|26|29 .i|26|29 .x|26|29))) (let ((.v|30|33 .stale1|6) (.i|30|33 .i|13) (.x|30|33 #t)) (begin (.check! (fixnum? .i|30|33) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (vector? .v|30|33) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (<:fix:fix .i|30|33 (vector-length:vec .v|30|33)) 41 .v|30|33 .i|30|33 .x|30|33) (.check! (>=:fix:fix .i|30|33 0) 41 .v|30|33 .i|30|33 .x|30|33) (vector-set!:trusted .v|30|33 .i|30|33 .x|30|33)))))))) (.loop|7|9|12 (- .i|13 1)))))) (.loop|7|9|12 (- (max .m1|6 .m2|6) 1)))))))) (.cgreg-join!|2 .regs1|1 .regs2|1))))) 'cgreg-join!))
+(let () (begin (set! cgframe:slots car) 'cgframe:slots))
+(let () (begin (set! cgframe:stale cadr) 'cgframe:stale))
+(let () (begin (set! cgframe:livevars caddr) 'cgframe:livevars))
+(let () (begin (set! cgframe:slot.name car) 'cgframe:slot.name))
+(let () (begin (set! cgframe:slot.offset cadr) 'cgframe:slot.offset))
+(let () (begin (set! cgframe:slot.instruction caddr) 'cgframe:slot.instruction))
+(let () (begin (set! cgframe:slot.stale cadddr) 'cgframe:slot.stale))
+(let () (begin (set! cgframe:slots-set! set-car!) 'cgframe:slots-set!))
+(let () (begin (set! cgframe:stale-set! (lambda (.frame|1 .stale|1) (let ((.cgframe:stale-set!|2 0)) (begin (set! .cgframe:stale-set!|2 (lambda (.frame|3 .stale|3) (set-car! (let ((.x|4|7 .frame|3)) (begin (.check! (pair? .x|4|7) 1 .x|4|7) (cdr:pair .x|4|7))) .stale|3))) (.cgframe:stale-set!|2 .frame|1 .stale|1))))) 'cgframe:stale-set!))
+(let () (begin (set! cgframe:livevars-set! (lambda (.frame|1 .vars|1) (let ((.cgframe:livevars-set!|2 0)) (begin (set! .cgframe:livevars-set!|2 (lambda (.frame|3 .vars|3) (set-car! (let ((.x|5|8 (let ((.x|9|12 .frame|3)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))) .vars|3))) (.cgframe:livevars-set!|2 .frame|1 .vars|1))))) 'cgframe:livevars-set!))
+(let () (begin (set! cgframe:slot.name-set! set-car!) 'cgframe:slot.name-set!))
+(let () (begin (set! cgframe:slot.offset-set! (lambda (.entry|1 .n|1) (let ((.cgframe:slot.offset-set!|2 0)) (begin (set! .cgframe:slot.offset-set!|2 (lambda (.entry|3 .n|3) (let ((.instruction|6 (let ((.x|65|68 (let ((.x|69|72 (let ((.x|73|76 .entry|3)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76))))) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))))) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (if (let ((.temp|7|10 (not (eq? #f (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20))))))) (if .temp|7|10 .temp|7|10 (not (eq? $nop (let ((.x|12|15 .instruction|6)) (begin (.check! (pair? .x|12|15) 0 .x|12|15) (car:pair .x|12|15))))))) (error "Compiler bug: cgframe" .entry|3) (begin (set-car! (let ((.x|25|28 .entry|3)) (begin (.check! (pair? .x|25|28) 1 .x|25|28) (cdr:pair .x|25|28))) .n|3) (set-car! .instruction|6 (let ((.x|30|33 (let ((.x|34|37 .instruction|6)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))))) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (set-cdr! .instruction|6 (let ((.x|39|42 (let ((.x|43|46 .instruction|6)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42)))) (if (eq? $setstk (let ((.x|47|50 .instruction|6)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50)))) (set-car! (let ((.x|51|54 .instruction|6)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) .n|3) (set-car! (let ((.x|56|59 (let ((.x|60|63 .instruction|6)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63))))) (begin (.check! (pair? .x|56|59) 1 .x|56|59) (cdr:pair .x|56|59))) .n|3))))))) (.cgframe:slot.offset-set!|2 .entry|1 .n|1))))) 'cgframe:slot.offset-set!))
+(let () (begin (set! cgframe:unused-slot (lambda (.frame|1 .entry|1) (let ((.cgframe:unused-slot|2 0)) (begin (set! .cgframe:unused-slot|2 (lambda (.frame|3 .entry|3) (let* ((.stale|6 (cgframe:slot.stale .entry|3)) (.probe|9 (assq #t .stale|6))) (let () (if .probe|9 (let ((.n|15 (let ((.x|16|19 .probe|9)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))))) (begin (if (zero? .n|15) (cgframe-used! .frame|3) (unspecified)) (set-car! .probe|9 #f) .n|15)) (let* ((.cell|22 (cgframe-size-cell .frame|3)) (.n|25 (+ 1 (let ((.x|29|32 .cell|22)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))))) (let () (begin (set-car! .cell|22 .n|25) (if (zero? .n|25) (.cgframe:unused-slot|2 .frame|3 .entry|3) .n|25))))))))) (.cgframe:unused-slot|2 .frame|1 .entry|1))))) 'cgframe:unused-slot))
+(let () (begin (set! cgframe-initial (lambda () (let ((.cgframe-initial|2 0)) (begin (set! .cgframe-initial|2 (lambda () (let* ((.t1|4|7 '()) (.t2|4|10 (let* ((.t1|14|17 (cons (cons #t 0) '())) (.t2|14|20 (let* ((.t1|24|27 #f) (.t2|24|30 (cons -1 '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))))) (.cgframe-initial|2))))) 'cgframe-initial))
+(let () (begin (set! cgframe-livevars cgframe:livevars) 'cgframe-livevars))
+(let () (begin (set! cgframe-livevars-set! cgframe:livevars-set!) 'cgframe-livevars-set!))
+(let () (begin (set! cgframe-size-cell (lambda (.frame|1) (let ((.cgframe-size-cell|2 0)) (begin (set! .cgframe-size-cell|2 (lambda (.frame|3) (let ((.x|5|8 (let ((.x|9|12 (let ((.x|13|16 .frame|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|5|8) 1 .x|5|8) (cdr:pair .x|5|8))))) (.cgframe-size-cell|2 .frame|1))))) 'cgframe-size-cell))
+(let () (begin (set! cgframe-size (lambda (.frame|1) (let ((.cgframe-size|2 0)) (begin (set! .cgframe-size|2 (lambda (.frame|3) (let ((.x|4|7 (cgframe-size-cell .frame|3))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.cgframe-size|2 .frame|1))))) 'cgframe-size))
+(let () (begin (set! cgframe-used! (lambda (.frame|1) (let ((.cgframe-used!|2 0)) (begin (set! .cgframe-used!|2 (lambda (.frame|3) (if (< (cgframe-size .frame|3) 0) (set-car! (cgframe-size-cell .frame|3) 0) (unspecified)))) (.cgframe-used!|2 .frame|1))))) 'cgframe-used!))
+(let () (begin (set! cgframe-bind! (lambda (.frame|1 .var|1 .instruction|1) (let ((.cgframe-bind!|2 0)) (begin (set! .cgframe-bind!|2 (lambda (.frame|3 .var|3 .instruction|3) (cgframe:slots-set! .frame|3 (cons (let* ((.t1|4|7 .var|3) (.t2|4|10 (let* ((.t1|14|17 #f) (.t2|14|20 (let* ((.t1|24|27 .instruction|3) (.t2|24|30 (cons (cgframe:stale .frame|3) '()))) (let () (cons .t1|24|27 .t2|24|30))))) (let () (cons .t1|14|17 .t2|14|20))))) (let () (cons .t1|4|7 .t2|4|10))) (cgframe:slots .frame|3))))) (.cgframe-bind!|2 .frame|1 .var|1 .instruction|1))))) 'cgframe-bind!))
+(let () (begin (set! cgframe-touch! (lambda (.frame|1 .var|1) (let ((.cgframe-touch!|2 0)) (begin (set! .cgframe-touch!|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (if (eq? #f .n|9) (let ((.n|12 (cgframe:unused-slot .frame|3 .entry|6))) (cgframe:slot.offset-set! .entry|6 .n|12)) (unspecified))) (error "Compiler bug: cgframe-touch!" .frame|3 .var|3))))) (.cgframe-touch!|2 .frame|1 .var|1))))) 'cgframe-touch!))
+(let () (begin (set! cgframe-rename! (lambda (.frame|1 .alist|1) (let ((.cgframe-rename!|2 0)) (begin (set! .cgframe-rename!|2 (lambda (.frame|3 .alist|3) (let () (let ((.loop|9|11|14 (unspecified))) (begin (set! .loop|9|11|14 (lambda (.y1|4|5|15) (if (null? .y1|4|5|15) (if #f #f (unspecified)) (begin (begin #t (let* ((.entry|19 (let ((.x|27|30 .y1|4|5|15)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30)))) (.probe|22 (assq (cgframe:slot.name .entry|19) .alist|3))) (if .probe|22 (cgframe:slot.name-set! .entry|19 (let ((.x|23|26 .probe|22)) (begin (.check! (pair? .x|23|26) 1 .x|23|26) (cdr:pair .x|23|26)))) (unspecified)))) (.loop|9|11|14 (let ((.x|31|34 .y1|4|5|15)) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))))) (.loop|9|11|14 (cgframe:slots .frame|3))))))) (.cgframe-rename!|2 .frame|1 .alist|1))))) 'cgframe-rename!))
+(let () (begin (set! cgframe-release! (lambda (.frame|1 .var|1) (let ((.cgframe-release!|2 0)) (begin (set! .cgframe-release!|2 (lambda (.frame|3 .var|3) (let* ((.slots|6 (cgframe:slots .frame|3)) (.entry|9 (assq .var|3 .slots|6))) (let () (if .entry|9 (begin (cgframe:slots-set! .frame|3 (remq .entry|9 .slots|6)) (let ((.n|15 (cgframe:slot.offset .entry|9))) (if (if (not (eq? #f .n|15)) (not (zero? .n|15)) #f) (cgframe:stale-set! .frame|3 (cons (cons #t .n|15) (cgframe:stale .frame|3))) (unspecified)))) (unspecified)))))) (.cgframe-release!|2 .frame|1 .var|1))))) 'cgframe-release!))
+(let () (begin (set! cgframe-release-except! (lambda (.frame|1 .vars|1) (let ((.cgframe-release-except!|2 0)) (begin (set! .cgframe-release-except!|2 (lambda (.frame|3 .vars|3) (let ((.slots|6 (reverse (cgframe:slots .frame|3))) (.newslots|6 '()) (.stale|6 (cgframe:stale .frame|3))) (let () (let ((.loop|9 (unspecified))) (begin (set! .loop|9 (lambda (.slots|10 .newslots|10 .stale|10) (if (null? .slots|10) (begin (cgframe:slots-set! .frame|3 .newslots|10) (cgframe:stale-set! .frame|3 .stale|10)) (let ((.slot|13 (let ((.x|36|39 .slots|10)) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39))))) (if (memq (cgframe:slot.name .slot|13) .vars|3) (.loop|9 (let ((.x|14|17 .slots|10)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))) (cons .slot|13 .newslots|10) .stale|10) (let ((.n|20 (cgframe:slot.offset .slot|13))) (if (eq? .n|20 #f) (.loop|9 (let ((.x|22|25 .slots|10)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) .newslots|10 .stale|10) (if (zero? .n|20) (.loop|9 (let ((.x|27|30 .slots|10)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))) (cons .slot|13 .newslots|10) .stale|10) (.loop|9 (let ((.x|32|35 .slots|10)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) .newslots|10 (cons (cons #t .n|20) .stale|10)))))))))) (.loop|9 .slots|6 .newslots|6 .stale|6))))))) (.cgframe-release-except!|2 .frame|1 .vars|1))))) 'cgframe-release-except!))
+(let () (begin (set! cgframe-lookup (lambda (.frame|1 .var|1) (let ((.cgframe-lookup|2 0)) (begin (set! .cgframe-lookup|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (begin (if (eq? #f .n|9) (cgframe-touch! .frame|3 .var|3) (unspecified)) (let* ((.t1|10|13 .var|3) (.t2|10|16 (let* ((.t1|20|23 'frame) (.t2|20|26 (let* ((.t1|30|33 (cgframe:slot.offset .entry|6)) (.t2|30|36 (cons '(object) '()))) (let () (cons .t1|30|33 .t2|30|36))))) (let () (cons .t1|20|23 .t2|20|26))))) (let () (cons .t1|10|13 .t2|10|16))))) #f)))) (.cgframe-lookup|2 .frame|1 .var|1))))) 'cgframe-lookup))
+(let () (begin (set! cgframe-spilled? (lambda (.frame|1 .var|1) (let ((.cgframe-spilled?|2 0)) (begin (set! .cgframe-spilled?|2 (lambda (.frame|3 .var|3) (let ((.entry|6 (assq .var|3 (cgframe:slots .frame|3)))) (if .entry|6 (let ((.n|9 (cgframe:slot.offset .entry|6))) (not (eq? #f .n|9))) #f)))) (.cgframe-spilled?|2 .frame|1 .var|1))))) 'cgframe-spilled?))
+(let () (begin (set! cgframe-copy (lambda (.frame|1) (let ((.cgframe-copy|2 0)) (begin (set! .cgframe-copy|2 (lambda (.frame|3) (cons (let ((.x|4|7 .frame|3)) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) (cons (let ((.x|9|12 (let ((.x|13|16 .frame|3)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) (cons (let ((.x|18|21 (let ((.x|22|25 (let ((.x|26|29 .frame|3)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (let ((.x|31|34 (let ((.x|35|38 (let ((.x|39|42 .frame|3)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 1 .x|35|38) (cdr:pair .x|35|38))))) (begin (.check! (pair? .x|31|34) 1 .x|31|34) (cdr:pair .x|31|34)))))))) (.cgframe-copy|2 .frame|1))))) 'cgframe-copy))
+(let () (begin (set! cgframe-update-stale! (lambda (.frame|1) (let ((.cgframe-update-stale!|2 0)) (begin (set! .cgframe-update-stale!|2 (lambda (.frame|3) (let* ((.n|6 (cgframe-size .frame|3)) (.v|9 (make-vector (+ 1 .n|6) #t)) (.stale|12 (cgframe:stale .frame|3))) (let () (begin (let () (let ((.loop|21|23|26 (unspecified))) (begin (set! .loop|21|23|26 (lambda (.y1|16|17|27) (if (null? .y1|16|17|27) (if #f #f (unspecified)) (begin (begin #t (let ((.x|31 (let ((.x|47|50 .y1|16|17|27)) (begin (.check! (pair? .x|47|50) 0 .x|47|50) (car:pair .x|47|50))))) (if (let ((.x|32|35 .x|31)) (begin (.check! (pair? .x|32|35) 0 .x|32|35) (car:pair .x|32|35))) (let ((.i|38 (let ((.x|43|46 .x|31)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46))))) (if (<= .i|38 .n|6) (let ((.v|39|42 .v|9) (.i|39|42 .i|38) (.x|39|42 #f)) (begin (.check! (fixnum? .i|39|42) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (vector? .v|39|42) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (<:fix:fix .i|39|42 (vector-length:vec .v|39|42)) 41 .v|39|42 .i|39|42 .x|39|42) (.check! (>=:fix:fix .i|39|42 0) 41 .v|39|42 .i|39|42 .x|39|42) (vector-set!:trusted .v|39|42 .i|39|42 .x|39|42))) (unspecified))) (unspecified)))) (.loop|21|23|26 (let ((.x|51|54 .y1|16|17|27)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54)))))))) (.loop|21|23|26 .stale|12)))) (let () (let ((.loop|60|62|65 (unspecified))) (begin (set! .loop|60|62|65 (lambda (.y1|55|56|66) (if (null? .y1|55|56|66) (if #f #f (unspecified)) (begin (begin #t (let* ((.slot|70 (let ((.x|117|120 .y1|55|56|66)) (begin (.check! (pair? .x|117|120) 0 .x|117|120) (car:pair .x|117|120)))) (.offset|73 (cgframe:slot.offset .slot|70))) (if .offset|73 (let ((.v|74|77 .v|9) (.i|74|77 .offset|73) (.x|74|77 #f)) (begin (.check! (fixnum? .i|74|77) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (vector? .v|74|77) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (<:fix:fix .i|74|77 (vector-length:vec .v|74|77)) 41 .v|74|77 .i|74|77 .x|74|77) (.check! (>=:fix:fix .i|74|77 0) 41 .v|74|77 .i|74|77 .x|74|77) (vector-set!:trusted .v|74|77 .i|74|77 .x|74|77))) (let () (let ((.loop|83|85|88 (unspecified))) (begin (set! .loop|83|85|88 (lambda (.y1|78|79|89) (if (null? .y1|78|79|89) (if #f #f (unspecified)) (begin (begin #t (let ((.stale|93 (let ((.x|109|112 .y1|78|79|89)) (begin (.check! (pair? .x|109|112) 0 .x|109|112) (car:pair .x|109|112))))) (if (let ((.x|94|97 .stale|93)) (begin (.check! (pair? .x|94|97) 0 .x|94|97) (car:pair .x|94|97))) (let ((.i|100 (let ((.x|105|108 .stale|93)) (begin (.check! (pair? .x|105|108) 1 .x|105|108) (cdr:pair .x|105|108))))) (if (< .i|100 .n|6) (let ((.v|101|104 .v|9) (.i|101|104 .i|100) (.x|101|104 #f)) (begin (.check! (fixnum? .i|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (vector? .v|101|104) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (<:fix:fix .i|101|104 (vector-length:vec .v|101|104)) 41 .v|101|104 .i|101|104 .x|101|104) (.check! (>=:fix:fix .i|101|104 0) 41 .v|101|104 .i|101|104 .x|101|104) (vector-set!:trusted .v|101|104 .i|101|104 .x|101|104))) (unspecified))) (unspecified)))) (.loop|83|85|88 (let ((.x|113|116 .y1|78|79|89)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116)))))))) (.loop|83|85|88 (cgframe:slot.stale .slot|70)))))))) (.loop|60|62|65 (let ((.x|121|124 .y1|55|56|66)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124)))))))) (.loop|60|62|65 (cgframe:slots .frame|3))))) (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.i|132 .stale|132) (if (<= .i|132 0) (cgframe:stale-set! .frame|3 .stale|132) (begin #t (.loop|125|128|131 (- .i|132 1) (if (let ((.v|135|138 .v|9) (.i|135|138 .i|132)) (begin (.check! (fixnum? .i|135|138) 40 .v|135|138 .i|135|138) (.check! (vector? .v|135|138) 40 .v|135|138 .i|135|138) (.check! (<:fix:fix .i|135|138 (vector-length:vec .v|135|138)) 40 .v|135|138 .i|135|138) (.check! (>=:fix:fix .i|135|138 0) 40 .v|135|138 .i|135|138) (vector-ref:trusted .v|135|138 .i|135|138))) (cons (cons #t .i|132) .stale|132) .stale|132)))))) (.loop|125|128|131 .n|6 (filter car .stale|12)))))))))) (.cgframe-update-stale!|2 .frame|1))))) 'cgframe-update-stale!))
+(let () (begin (set! cgframe-join! (lambda (.frame1|1 .frame2|1) (let ((.cgframe-join!|2 0)) (begin (set! .cgframe-join!|2 (lambda (.frame1|3 .frame2|3) (let* ((.slots1|6 (cgframe:slots .frame1|3)) (.slots2|9 (cgframe:slots .frame2|3)) (.slots|12 (intersection .slots1|6 .slots2|9)) (.deadslots|15 (append (difference .slots1|6 .slots|12) (difference .slots2|9 .slots|12))) (.deadoffsets|18 (make-set (filter (lambda (.x|59) (not (eq? .x|59 #f))) (let () (let ((.loop|65|68|71 (unspecified))) (begin (set! .loop|65|68|71 (lambda (.y1|60|61|72 .results|60|64|72) (if (null? .y1|60|61|72) (reverse .results|60|64|72) (begin #t (.loop|65|68|71 (let ((.x|76|79 .y1|60|61|72)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons (cgframe:slot.offset (let ((.x|80|83 .y1|60|61|72)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) .results|60|64|72)))))) (.loop|65|68|71 .deadslots|15 '()))))))) (.stale1|21 (cgframe:stale .frame1|3)) (.stale2|24 (cgframe:stale .frame2|3)) (.stale|27 (intersection .stale1|21 .stale2|24)) (.stale|30 (append (let () (let ((.loop|39|42|45 (unspecified))) (begin (set! .loop|39|42|45 (lambda (.y1|34|35|46 .results|34|38|46) (if (null? .y1|34|35|46) (reverse .results|34|38|46) (begin #t (.loop|39|42|45 (let ((.x|50|53 .y1|34|35|46)) (begin (.check! (pair? .x|50|53) 1 .x|50|53) (cdr:pair .x|50|53))) (cons (let ((.n|54 (let ((.x|55|58 .y1|34|35|46)) (begin (.check! (pair? .x|55|58) 0 .x|55|58) (car:pair .x|55|58))))) (cons #t .n|54)) .results|34|38|46)))))) (.loop|39|42|45 .deadoffsets|18 '())))) .stale|27))) (let () (begin (cgframe:slots-set! .frame1|3 .slots|12) (cgframe:stale-set! .frame1|3 .stale|30)))))) (.cgframe-join!|2 .frame1|1 .frame2|1))))) 'cgframe-join!))
+(let () (begin (set! entry.name car) 'entry.name))
+(let () (begin (set! entry.kind cadr) 'entry.kind))
+(let () (begin (set! entry.rib caddr) 'entry.rib))
+(let () (begin (set! entry.offset cadddr) 'entry.offset))
+(let () (begin (set! entry.label cadddr) 'entry.label))
+(let () (begin (set! entry.regnum caddr) 'entry.regnum))
+(let () (begin (set! entry.slotnum caddr) 'entry.slotnum))
+(let () (begin (set! entry.arity caddr) 'entry.arity))
+(let () (begin (set! entry.op cadddr) 'entry.op))
+(let () (begin (set! entry.imm (lambda (.entry|1) (let ((.entry.imm|2 0)) (begin (set! .entry.imm|2 (lambda (.entry|3) (let ((.x|4|7 (let ((.x|9|12 (let ((.x|13|16 (let ((.x|17|20 (let ((.x|21|24 .entry|3)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))))) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))))) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.entry.imm|2 .entry|1))))) 'entry.imm))
+(let () (begin (set! cgenv-initial (lambda (.integrable|1) (let ((.cgenv-initial|2 0)) (begin (set! .cgenv-initial|2 (lambda (.integrable|3) (cons (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.y1|5|6|17 .results|5|9|17) (if (null? .y1|5|6|17) (reverse .results|5|9|17) (begin #t (.loop|10|13|16 (let ((.x|21|24 .y1|5|6|17)) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24))) (cons (let* ((.x|25 (let ((.x|120|123 .y1|5|6|17)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123)))) (.t1|26|29 (let ((.x|116|119 .x|25)) (begin (.check! (pair? .x|116|119) 0 .x|116|119) (car:pair .x|116|119)))) (.t2|26|32 (let* ((.t1|36|39 'integrable) (.t2|36|42 (let* ((.t1|46|49 (let ((.x|108|111 (let ((.x|112|115 .x|25)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))))) (begin (.check! (pair? .x|108|111) 0 .x|108|111) (car:pair .x|108|111)))) (.t2|46|52 (let* ((.t1|56|59 (let ((.x|95|98 (let ((.x|99|102 (let ((.x|103|106 .x|25)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))))) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))))) (begin (.check! (pair? .x|95|98) 0 .x|95|98) (car:pair .x|95|98)))) (.t2|56|62 (let* ((.t1|66|69 (let ((.x|78|81 (let ((.x|82|85 (let ((.x|86|89 (let ((.x|90|93 .x|25)) (begin (.check! (pair? .x|90|93) 1 .x|90|93) (cdr:pair .x|90|93))))) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (.t2|66|72 (cons '(object) '()))) (let () (cons .t1|66|69 .t2|66|72))))) (let () (cons .t1|56|59 .t2|56|62))))) (let () (cons .t1|46|49 .t2|46|52))))) (let () (cons .t1|36|39 .t2|36|42))))) (let () (cons .t1|26|29 .t2|26|32))) .results|5|9|17)))))) (.loop|10|13|16 .integrable|3 '())))) '()))) (.cgenv-initial|2 .integrable|1))))) 'cgenv-initial))
+(let () (begin (set! cgenv-lookup (lambda (.env|1 .id|1) (let ((.cgenv-lookup|2 0)) (begin (set! .cgenv-lookup|2 (lambda (.env|3 .id|3) (let ((.loop|4 (unspecified))) (begin (set! .loop|4 (lambda (.ribs|5 .m|5) (if (null? .ribs|5) (cons .id|3 '(global (object))) (let ((.x|8 (assq .id|3 (let ((.x|66|69 .ribs|5)) (begin (.check! (pair? .x|66|69) 0 .x|66|69) (car:pair .x|66|69)))))) (if .x|8 (let ((.temp|9|12 (let ((.x|54|57 (let ((.x|58|61 .x|8)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))))) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57))))) (if (memv .temp|9|12 '(lexical)) (cons .id|3 (cons (let ((.x|15|18 (let ((.x|19|22 .x|8)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))))) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) (cons .m|5 (let ((.x|24|27 (let ((.x|28|31 .x|8)) (begin (.check! (pair? .x|28|31) 1 .x|28|31) (cdr:pair .x|28|31))))) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27)))))) (if (memv .temp|9|12 '(procedure)) (cons .id|3 (cons (let ((.x|34|37 (let ((.x|38|41 .x|8)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41))))) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) (cons .m|5 (let ((.x|43|46 (let ((.x|47|50 .x|8)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50))))) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))) (if (memv .temp|9|12 '(integrable)) (if (integrate-usual-procedures) .x|8 (.loop|4 '() .m|5)) ???)))) (.loop|4 (let ((.x|62|65 .ribs|5)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (+ .m|5 1))))))) (.loop|4 .env|3 0))))) (.cgenv-lookup|2 .env|1 .id|1))))) 'cgenv-lookup))
+(let () (begin (set! cgenv-extend (lambda (.env|1 .vars|1 .procs|1) (let ((.cgenv-extend|2 0)) (begin (set! .cgenv-extend|2 (lambda (.env|3 .vars|3 .procs|3) (cons (let () (let ((.loop|4|8|11 (unspecified))) (begin (set! .loop|4|8|11 (lambda (.n|12 .vars|12 .rib|12) (if (null? .vars|12) .rib|12 (begin #t (.loop|4|8|11 (+ .n|12 1) (let ((.x|15|18 .vars|12)) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))) (cons (let* ((.t1|19|22 (let ((.x|50|53 .vars|12)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53)))) (.t2|19|25 (let* ((.t1|29|32 'lexical) (.t2|29|35 (let* ((.t1|39|42 .n|12) (.t2|39|45 (cons '(object) '()))) (let () (cons .t1|39|42 .t2|39|45))))) (let () (cons .t1|29|32 .t2|29|35))))) (let () (cons .t1|19|22 .t2|19|25))) .rib|12)))))) (.loop|4|8|11 0 .vars|3 (let () (let ((.loop|59|62|65 (unspecified))) (begin (set! .loop|59|62|65 (lambda (.y1|54|55|66 .results|54|58|66) (if (null? .y1|54|55|66) (reverse .results|54|58|66) (begin #t (.loop|59|62|65 (let ((.x|70|73 .y1|54|55|66)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73))) (cons (let* ((.id|74 (let ((.x|106|109 .y1|54|55|66)) (begin (.check! (pair? .x|106|109) 0 .x|106|109) (car:pair .x|106|109)))) (.t1|75|78 .id|74) (.t2|75|81 (let* ((.t1|85|88 'procedure) (.t2|85|91 (let* ((.t1|95|98 (make-label)) (.t2|95|101 (cons '(object) '()))) (let () (cons .t1|95|98 .t2|95|101))))) (let () (cons .t1|85|88 .t2|85|91))))) (let () (cons .t1|75|78 .t2|75|81))) .results|54|58|66)))))) (.loop|59|62|65 .procs|3 '())))))))) .env|3))) (.cgenv-extend|2 .env|1 .vars|1 .procs|1))))) 'cgenv-extend))
+(let () (begin (set! cgenv-bindprocs (lambda (.env|1 .procs|1) (let ((.cgenv-bindprocs|2 0)) (begin (set! .cgenv-bindprocs|2 (lambda (.env|3 .procs|3) (cons (append (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let* ((.id|24 (let ((.x|56|59 .y1|4|5|16)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59)))) (.t1|25|28 .id|24) (.t2|25|31 (let* ((.t1|35|38 'procedure) (.t2|35|41 (let* ((.t1|45|48 (make-label)) (.t2|45|51 (cons '(object) '()))) (let () (cons .t1|45|48 .t2|45|51))))) (let () (cons .t1|35|38 .t2|35|41))))) (let () (cons .t1|25|28 .t2|25|31))) .results|4|8|16)))))) (.loop|9|12|15 .procs|3 '())))) (let ((.x|60|63 .env|3)) (begin (.check! (pair? .x|60|63) 0 .x|60|63) (car:pair .x|60|63)))) (let ((.x|64|67 .env|3)) (begin (.check! (pair? .x|64|67) 1 .x|64|67) (cdr:pair .x|64|67)))))) (.cgenv-bindprocs|2 .env|1 .procs|1))))) 'cgenv-bindprocs))
+(let () (begin (set! var-lookup (lambda (.var|1 .regs|1 .frame|1 .env|1) (let ((.var-lookup|2 0)) (begin (set! .var-lookup|2 (lambda (.var|3 .regs|3 .frame|3 .env|3) (let ((.temp|4|7 (cgreg-lookup .regs|3 .var|3))) (if .temp|4|7 .temp|4|7 (let ((.temp|8|11 (cgframe-lookup .frame|3 .var|3))) (if .temp|8|11 .temp|8|11 (cgenv-lookup .env|3 .var|3))))))) (.var-lookup|2 .var|1 .regs|1 .frame|1 .env|1))))) 'var-lookup))
+(let () (begin (set! compile (lambda (.x|1) (pass4 (pass3 (pass2 (pass1 .x|1))) $usual-integrable-procedures$))) 'compile))
+(let () (begin (set! compile-block (lambda (.x|1) (pass4 (pass3 (pass2 (pass1-block .x|1))) $usual-integrable-procedures$))) 'compile-block))
+(let () (begin (set! foo (lambda (.x|1) (pretty-print (compile .x|1)))) 'foo))
+(let () (begin (set! minregs (lambda (.x|1) (let ((.minregs|2 0)) (begin (set! .minregs|2 (lambda (.x|3) (let ((.defregs|4 (unspecified))) (begin (set! .defregs|4 (lambda (.r|5) (begin (set! *nregs* .r|5) (set! *lastreg* (- *nregs* 1)) (set! *fullregs* (quotient *nregs* 2))))) (.defregs|4 32) (let* ((.code|8 (assemble (compile .x|3))) (.binary-search|9 (unspecified))) (begin (set! .binary-search|9 (lambda (.m1|10 .m2|10) (if (= (+ .m1|10 1) .m2|10) .m2|10 (let ((.midpt|13 (quotient (+ .m1|10 .m2|10) 2))) (begin (.defregs|4 .midpt|13) (if (equal? .code|8 (assemble (compile .x|3))) (.binary-search|9 .m1|10 .midpt|13) (.binary-search|9 .midpt|13 .m2|10))))))) (.defregs|4 4) (let ((.newcode|16 (assemble (compile .x|3)))) (if (equal? .code|8 .newcode|16) 4 (.binary-search|9 4 32))))))))) (.minregs|2 .x|1))))) 'minregs))
+(let () (begin (set! pass4 (lambda (.exp|1 .integrable|1) (let ((.pass4|2 0)) (begin (set! .pass4|2 (lambda (.exp|3 .integrable|3) (begin (init-labels) (init-temps) (let ((.output|6 (make-assembly-stream)) (.frame|6 (cgframe-initial)) (.regs|6 (cgreg-initial)) (.t0|6 (newtemp))) (begin (assembly-stream-info! .output|6 (make-hashtable equal-hash assoc)) (cgreg-bind! .regs|6 0 .t0|6) (gen-save! .output|6 .frame|6 .t0|6) (cg0 .output|6 .exp|3 'result .regs|6 .frame|6 (cgenv-initial .integrable|3) #t) (pass4-code .output|6)))))) (.pass4|2 .exp|1 .integrable|1))))) 'pass4))
+(let () (begin (set! pass4-code (lambda (.output|1) (let ((.pass4-code|2 0)) (begin (set! .pass4-code|2 (lambda (.output|3) (begin (hashtable-for-each (lambda (.situation|4 .label|4) (cg-trap .output|3 .situation|4 .label|4)) (assembly-stream-info .output|3)) (assembly-stream-code .output|3)))) (.pass4-code|2 .output|1))))) 'pass4-code))
+(let () (begin (set! cg0 (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg0|2 0)) (begin (set! .cg0|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.temp|4|7 (let ((.x|14|17 .exp|3)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17))))) (if (memv .temp|4|7 '(quote)) (begin (gen! .output|3 $const (constant.value .exp|3)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (memv .temp|4|7 '(lambda)) (begin (cg-lambda .output|3 .exp|3 .regs|3 .frame|3 .env|3) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (memv .temp|4|7 '(set!)) (begin (.cg0|2 .output|3 (assignment.rhs .exp|3) 'result .regs|3 .frame|3 .env|3 #f) (cg-assignment-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|4|7 '(if)) (cg-if .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) (cg-variable .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (cg-sequential .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (cg-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))) (.cg0|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg0))
+(let () (begin (set! cg-lambda (lambda (.output|1 .exp|1 .regs|1 .frame|1 .env|1) (let ((.cg-lambda|2 0)) (begin (set! .cg-lambda|2 (lambda (.output|3 .exp|3 .regs|3 .frame|3 .env|3) (let* ((.args|6 (lambda.args .exp|3)) (.vars|9 (make-null-terminated .args|6)) (.free|12 (difference (lambda.f .exp|3) .vars|9)) (.free|15 (cg-sort-vars .free|12 .regs|3 .frame|3 .env|3)) (.newenv|18 (cgenv-extend .env|3 (cons #t .free|15) '())) (.newoutput|21 (make-assembly-stream))) (let () (begin (assembly-stream-info! .newoutput|21 (make-hashtable equal-hash assoc)) (gen! .newoutput|21 $.proc) (if (list? .args|6) (gen! .newoutput|21 $args= (length .args|6)) (gen! .newoutput|21 $args>= (- (length .vars|9) 1))) (cg-known-lambda .newoutput|21 .exp|3 .newenv|18) (cg-eval-vars .output|3 .free|15 .regs|3 .frame|3 .env|3) '(if (not (ignore-space-leaks)) (begin (gen! output $const #f) (gen! output $setreg 0))) (gen! .output|3 $lambda (pass4-code .newoutput|21) (length .free|15) (lambda.doc .exp|3)) '(if (not (ignore-space-leaks)) (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))))) (.cg-lambda|2 .output|1 .exp|1 .regs|1 .frame|1 .env|1))))) 'cg-lambda))
+(let () (begin (set! cg-sort-vars (lambda (.free|1 .regs|1 .frame|1 .env|1) (let ((.cg-sort-vars|2 0)) (begin (set! .cg-sort-vars|2 (lambda (.free|3 .regs|3 .frame|3 .env|3) (let* ((.free|6 (filter (lambda (.var|74) (let ((.temp|75|78 (entry.kind (var-lookup .var|74 .regs|3 .frame|3 .env|3)))) (if (memv .temp|75|78 '(register frame)) #t (if (memv .temp|75|78 '(lexical)) (not (ignore-space-leaks)) #f)))) .free|3)) (.n|9 (length .free|6)) (.m|12 (min .n|9 (- *nregs* 1))) (.vec|15 (make-vector .m|12 #f))) (let () (let ((.loop2|19 (unspecified)) (.loop1|19 (unspecified))) (begin (set! .loop2|19 (lambda (.i|20 .free|20) (if (null? .free|20) (vector->list .vec|15) (if (= .i|20 .m|12) (append (vector->list .vec|15) .free|20) (if (let ((.v|24|27 .vec|15) (.i|24|27 .i|20)) (begin (.check! (fixnum? .i|24|27) 40 .v|24|27 .i|24|27) (.check! (vector? .v|24|27) 40 .v|24|27 .i|24|27) (.check! (<:fix:fix .i|24|27 (vector-length:vec .v|24|27)) 40 .v|24|27 .i|24|27) (.check! (>=:fix:fix .i|24|27 0) 40 .v|24|27 .i|24|27) (vector-ref:trusted .v|24|27 .i|24|27))) (.loop2|19 (+ .i|20 1) .free|20) (begin (let ((.v|29|32 .vec|15) (.i|29|32 .i|20) (.x|29|32 (let ((.x|33|36 .free|20)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (.check! (fixnum? .i|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (vector? .v|29|32) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (<:fix:fix .i|29|32 (vector-length:vec .v|29|32)) 41 .v|29|32 .i|29|32 .x|29|32) (.check! (>=:fix:fix .i|29|32 0) 41 .v|29|32 .i|29|32 .x|29|32) (vector-set!:trusted .v|29|32 .i|29|32 .x|29|32))) (.loop2|19 (+ .i|20 1) (let ((.x|37|40 .free|20)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40)))))))))) (set! .loop1|19 (lambda (.free|41 .free-notregister|41) (if (null? .free|41) (.loop2|19 0 .free-notregister|41) (let* ((.var|44 (let ((.x|70|73 .free|41)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73)))) (.entry|47 (cgreg-lookup .regs|3 .var|44))) (let () (if .entry|47 (let ((.r|53 (entry.regnum .entry|47))) (if (<= .r|53 .n|9) (begin (let ((.v|54|57 .vec|15) (.i|54|57 (- .r|53 1)) (.x|54|57 .var|44)) (begin (.check! (fixnum? .i|54|57) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (vector? .v|54|57) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (<:fix:fix .i|54|57 (vector-length:vec .v|54|57)) 41 .v|54|57 .i|54|57 .x|54|57) (.check! (>=:fix:fix .i|54|57 0) 41 .v|54|57 .i|54|57 .x|54|57) (vector-set!:trusted .v|54|57 .i|54|57 .x|54|57))) (.loop1|19 (let ((.x|58|61 .free|41)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) .free-notregister|41)) (.loop1|19 (let ((.x|62|65 .free|41)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))) (cons .var|44 .free-notregister|41)))) (.loop1|19 (let ((.x|66|69 .free|41)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (cons .var|44 .free-notregister|41)))))))) (.loop1|19 .free|6 '()))))))) (.cg-sort-vars|2 .free|1 .regs|1 .frame|1 .env|1))))) 'cg-sort-vars))
+(let () (begin (set! cg-eval-vars (lambda (.output|1 .free|1 .regs|1 .frame|1 .env|1) (let ((.cg-eval-vars|2 0)) (begin (set! .cg-eval-vars|2 (lambda (.output|3 .free|3 .regs|3 .frame|3 .env|3) (let ((.n|6 (length .free|3)) (.r-1|6 (- *nregs* 1))) (begin (if (>= .n|6 .r-1|6) (begin (gen! .output|3 $const '()) (gen! .output|3 $setreg .r-1|6) (cgreg-release! .regs|3 .r-1|6)) (unspecified)) (let () (let ((.loop|8|11|14 (unspecified))) (begin (set! .loop|8|11|14 (lambda (.r|15 .vars|15) (if (zero? .r|15) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|20 (let ((.x|39|42 .vars|15)) (begin (.check! (pair? .x|39|42) 0 .x|39|42) (car:pair .x|39|42)))) (.entry|23 (var-lookup .v|20 .regs|3 .frame|3 .env|3))) (let () (begin (let ((.temp|27|30 (entry.kind .entry|23))) (if (memv .temp|27|30 '(register)) (let ((.r1|34 (entry.regnum .entry|23))) (if (not (eqv? .r|15 .r1|34)) (if (< .r|15 .r-1|6) (begin (gen! .output|3 $movereg .r1|34 .r|15) (cgreg-bind! .regs|3 .r|15 .v|20)) (gen! .output|3 $reg .r1|34 .v|20)) (unspecified))) (if (memv .temp|27|30 '(frame)) (if (< .r|15 .r-1|6) (begin (gen-load! .output|3 .frame|3 .r|15 .v|20) (cgreg-bind! .regs|3 .r|15 .v|20)) (gen-stack! .output|3 .frame|3 .v|20)) (if (memv .temp|27|30 '(lexical)) (begin (gen! .output|3 $lexical (entry.rib .entry|23) (entry.offset .entry|23) .v|20) (if (< .r|15 .r-1|6) (begin (gen! .output|3 $setreg .r|15) (cgreg-bind! .regs|3 .r|15 .v|20) (gen-store! .output|3 .frame|3 .r|15 .v|20)) (unspecified))) (error "Bug in cg-close-lambda"))))) (if (>= .r|15 .r-1|6) (begin (gen! .output|3 $op2 $cons .r-1|6) (gen! .output|3 $setreg .r-1|6)) (unspecified)))))) (.loop|8|11|14 (- .r|15 1) (let ((.x|43|46 .vars|15)) (begin (.check! (pair? .x|43|46) 1 .x|43|46) (cdr:pair .x|43|46)))))))) (.loop|8|11|14 .n|6 (reverse .free|3))))))))) (.cg-eval-vars|2 .output|1 .free|1 .regs|1 .frame|1 .env|1))))) 'cg-eval-vars))
+(let () (begin (set! cg-known-lambda (lambda (.output|1 .exp|1 .env|1) (let ((.cg-known-lambda|2 0)) (begin (set! .cg-known-lambda|2 (lambda (.output|3 .exp|3 .env|3) (let* ((.vars|6 (make-null-terminated (lambda.args .exp|3))) (.regs|9 (cgreg-initial)) (.frame|12 (cgframe-initial)) (.t0|15 (newtemp))) (let () (begin (if (member a-normal-form-declaration (lambda.decls .exp|3)) (cgframe-livevars-set! .frame|12 '()) (unspecified)) (cgreg-bind! .regs|9 0 .t0|15) (gen-save! .output|3 .frame|12 .t0|15) (let () (let ((.loop|19|22|25 (unspecified))) (begin (set! .loop|19|22|25 (lambda (.r|26 .vars|26) (if (let ((.temp|28|31 (null? .vars|26))) (if .temp|28|31 .temp|28|31 (= .r|26 *lastreg*))) (if (not (null? .vars|26)) (begin (gen! .output|3 $movereg *lastreg* 1) (cgreg-release! .regs|9 1) (let () (let ((.loop|34|36|39 (unspecified))) (begin (set! .loop|34|36|39 (lambda (.vars|40) (if (null? .vars|40) (if #f #f (unspecified)) (begin (begin #t (gen! .output|3 $reg 1) (gen! .output|3 $op1 $car:pair) (gen-setstk! .output|3 .frame|12 (let ((.x|43|46 .vars|40)) (begin (.check! (pair? .x|43|46) 0 .x|43|46) (car:pair .x|43|46)))) (gen! .output|3 $reg 1) (gen! .output|3 $op1 $cdr:pair) (gen! .output|3 $setreg 1)) (.loop|34|36|39 (let ((.x|47|50 .vars|40)) (begin (.check! (pair? .x|47|50) 1 .x|47|50) (cdr:pair .x|47|50)))))))) (.loop|34|36|39 .vars|26))))) (unspecified)) (begin (begin #t (cgreg-bind! .regs|9 .r|26 (let ((.x|52|55 .vars|26)) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55)))) (gen-store! .output|3 .frame|12 .r|26 (let ((.x|56|59 .vars|26)) (begin (.check! (pair? .x|56|59) 0 .x|56|59) (car:pair .x|56|59))))) (.loop|19|22|25 (+ .r|26 1) (let ((.x|60|63 .vars|26)) (begin (.check! (pair? .x|60|63) 1 .x|60|63) (cdr:pair .x|60|63)))))))) (.loop|19|22|25 1 .vars|6)))) (cg-body .output|3 .exp|3 'result .regs|9 .frame|12 .env|3 #t)))))) (.cg-known-lambda|2 .output|1 .exp|1 .env|1))))) 'cg-known-lambda))
+(let () (begin (set! cg-body (lambda (.output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-body|2 0)) (begin (set! .cg-body|2 (lambda (.output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.exp|6 (lambda.body .l|3)) (.defs|9 (lambda.defs .l|3)) (.free|12 (apply-union (let () (let ((.loop|153|156|159 (unspecified))) (begin (set! .loop|153|156|159 (lambda (.y1|148|149|160 .results|148|152|160) (if (null? .y1|148|149|160) (reverse .results|148|152|160) (begin #t (.loop|153|156|159 (let ((.x|164|167 .y1|148|149|160)) (begin (.check! (pair? .x|164|167) 1 .x|164|167) (cdr:pair .x|164|167))) (cons (let* ((.def|168 (let ((.x|172|175 .y1|148|149|160)) (begin (.check! (pair? .x|172|175) 0 .x|172|175) (car:pair .x|172|175)))) (.l|171 (def.rhs .def|168))) (difference (lambda.f .l|171) (lambda.args .l|171))) .results|148|152|160)))))) (.loop|153|156|159 .defs|9 '()))))))) (let () (if (let ((.temp|17|20 (null? .defs|9))) (if .temp|17|20 .temp|17|20 (let ((.temp|21|24 (constant? .exp|6))) (if .temp|21|24 .temp|21|24 (variable? .exp|6))))) (cg0 .output|3 .exp|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (lambda? .exp|6) (let* ((.free|29 (cg-sort-vars (union .free|12 (difference (lambda.f .exp|6) (make-null-terminated (lambda.args .exp|6)))) .regs|3 .frame|3 .env|3)) (.newenv1|32 (cgenv-extend .env|3 (cons #t .free|29) (let () (let ((.loop|50|53|56 (unspecified))) (begin (set! .loop|50|53|56 (lambda (.y1|45|46|57 .results|45|49|57) (if (null? .y1|45|46|57) (reverse .results|45|49|57) (begin #t (.loop|50|53|56 (let ((.x|61|64 .y1|45|46|57)) (begin (.check! (pair? .x|61|64) 1 .x|61|64) (cdr:pair .x|61|64))) (cons (def.lhs (let ((.x|65|68 .y1|45|46|57)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68)))) .results|45|49|57)))))) (.loop|50|53|56 .defs|9 '())))))) (.args|35 (lambda.args .exp|6)) (.vars|38 (make-null-terminated .args|35)) (.newoutput|41 (make-assembly-stream))) (let () (begin (assembly-stream-info! .newoutput|41 (make-hashtable equal-hash assoc)) (gen! .newoutput|41 $.proc) (if (list? .args|35) (gen! .newoutput|41 $args= (length .args|35)) (gen! .newoutput|41 $args>= (- (length .vars|38) 1))) (cg-known-lambda .newoutput|41 .exp|6 .newenv1|32) (cg-defs .newoutput|41 .defs|9 .newenv1|32) (cg-eval-vars .output|3 .free|29 .regs|3 .frame|3 .env|3) (gen! .output|3 $lambda (pass4-code .newoutput|41) (length .free|29) (lambda.doc .exp|6)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))))) (if (every? (lambda (.def|70) (every? (lambda (.v|71) (let ((.temp|72|75 (entry.kind (var-lookup .v|71 .regs|3 .frame|3 .env|3)))) (if (memv .temp|72|75 '(register frame)) #f #t))) (let ((.ldef|80 (def.rhs .def|70))) (difference (lambda.f .ldef|80) (lambda.args .ldef|80))))) .defs|9) (let* ((.newenv|83 (cgenv-bindprocs .env|3 (let () (let ((.loop|98|101|104 (unspecified))) (begin (set! .loop|98|101|104 (lambda (.y1|93|94|105 .results|93|97|105) (if (null? .y1|93|94|105) (reverse .results|93|97|105) (begin #t (.loop|98|101|104 (let ((.x|109|112 .y1|93|94|105)) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))) (cons (def.lhs (let ((.x|113|116 .y1|93|94|105)) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .results|93|97|105)))))) (.loop|98|101|104 .defs|9 '())))))) (.l|86 (make-label)) (.r|89 (cg0 .output|3 .exp|6 .target|3 .regs|3 .frame|3 .newenv|83 .tail?|3))) (let () (begin (if (not .tail?|3) (gen! .output|3 $skip .l|86 (cgreg-live .regs|3 .r|89)) (unspecified)) (cg-defs .output|3 .defs|9 .newenv|83) (if (not .tail?|3) (gen! .output|3 $.label .l|86) (unspecified)) .r|89))) (let ((.free|120 (cg-sort-vars .free|12 .regs|3 .frame|3 .env|3))) (begin (cg-eval-vars .output|3 .free|120 .regs|3 .frame|3 .env|3) '(if (not (ignore-space-leaks)) (begin (gen! output $const #f) (gen! output $setreg 0))) (let ((.t0|123 (cgreg-lookup-reg .regs|3 0)) (.t1|123 (newtemp)) (.newenv|123 (cgenv-extend .env|3 (cons #t .free|120) (let () (let ((.loop|129|132|135 (unspecified))) (begin (set! .loop|129|132|135 (lambda (.y1|124|125|136 .results|124|128|136) (if (null? .y1|124|125|136) (reverse .results|124|128|136) (begin #t (.loop|129|132|135 (let ((.x|140|143 .y1|124|125|136)) (begin (.check! (pair? .x|140|143) 1 .x|140|143) (cdr:pair .x|140|143))) (cons (def.lhs (let ((.x|144|147 .y1|124|125|136)) (begin (.check! (pair? .x|144|147) 0 .x|144|147) (car:pair .x|144|147)))) .results|124|128|136)))))) (.loop|129|132|135 .defs|9 '())))))) (.l|123 (make-label))) (begin (gen! .output|3 $lexes (length .free|120) .free|120) (gen! .output|3 $setreg 0) (cgreg-bind! .regs|3 0 .t1|123) (if .tail?|3 (begin (cgframe-release! .frame|3 .t0|123) (gen-store! .output|3 .frame|3 0 .t1|123) (cg0 .output|3 .exp|6 'result .regs|3 .frame|3 .newenv|123 #t) (cg-defs .output|3 .defs|9 .newenv|123) 'result) (begin (gen-store! .output|3 .frame|3 0 .t1|123) (cg0 .output|3 .exp|6 'result .regs|3 .frame|3 .newenv|123 #f) (gen! .output|3 $skip .l|123 (cgreg-tos .regs|3)) (cg-defs .output|3 .defs|9 .newenv|123) (gen! .output|3 $.label .l|123) (gen-load! .output|3 .frame|3 0 .t0|123) (cgreg-bind! .regs|3 0 .t0|123) (cgframe-release! .frame|3 .t1|123) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))))))) (.cg-body|2 .output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-body))
+(let () (begin (set! cg-defs (lambda (.output|1 .defs|1 .env|1) (let ((.cg-defs|2 0)) (begin (set! .cg-defs|2 (lambda (.output|3 .defs|3 .env|3) (let ((.f|4|7|10 (lambda (.def|30) (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label (entry.label (cgenv-lookup .env|3 (def.lhs .def|30)))) (gen! .output|3 $.proc) (gen! .output|3 $.proc-doc (lambda.doc (def.rhs .def|30))) (cg-known-lambda .output|3 (def.rhs .def|30) .env|3))))) (let () (let ((.loop|12|14|17 (unspecified))) (begin (set! .loop|12|14|17 (lambda (.y1|4|5|18) (if (null? .y1|4|5|18) (if #f #f (unspecified)) (begin (begin #t (.f|4|7|10 (let ((.x|22|25 .y1|4|5|18)) (begin (.check! (pair? .x|22|25) 0 .x|22|25) (car:pair .x|22|25))))) (.loop|12|14|17 (let ((.x|26|29 .y1|4|5|18)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))) (.loop|12|14|17 .defs|3))))))) (.cg-defs|2 .output|1 .defs|1 .env|1))))) 'cg-defs))
+(let () (begin (set! cg-assignment-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-assignment-result|2 0)) (begin (set! .cg-assignment-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (gen! .output|3 $setglbl (assignment.lhs .exp|3)) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))))) (.cg-assignment-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-assignment-result))
+(let () (begin (set! cg-if (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-if|2 0)) (begin (set! .cg-if|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (constant? (if.test .exp|3)) (cg0 .output|3 (if (constant.value (if.test .exp|3)) (if.then .exp|3) (if.else .exp|3)) .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (if.test .exp|3) 'result .regs|3 .frame|3 .env|3 #f) (cg-if-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))) (.cg-if|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-if))
+(let () (begin (set! cg-if-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-if-result|2 0)) (begin (set! .cg-if-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.l1|6 (make-label)) (.l2|6 (make-label))) (begin (gen! .output|3 $branchf .l1|6 (cgreg-tos .regs|3)) (let* ((.regs2|9 (cgreg-copy .regs|3)) (.frame1|12 (if (if .tail?|3 (< (cgframe-size .frame|3) 0) #f) (cgframe-initial) .frame|3)) (.frame2|15 (if (eq? .frame|3 .frame1|12) (cgframe-copy .frame1|12) (cgframe-initial))) (.t0|18 (cgreg-lookup-reg .regs|3 0))) (let () (begin (if (not (eq? .frame|3 .frame1|12)) (let ((.live|24 (cgframe-livevars .frame|3))) (begin (cgframe-livevars-set! .frame1|12 .live|24) (cgframe-livevars-set! .frame2|15 .live|24) (gen-save! .output|3 .frame1|12 .t0|18) (cg-saveregs .output|3 .regs|3 .frame1|12))) (unspecified)) (let ((.r|27 (cg0 .output|3 (if.then .exp|3) .target|3 .regs|3 .frame1|12 .env|3 .tail?|3))) (begin (if (not .tail?|3) (gen! .output|3 $skip .l2|6 (cgreg-live .regs|3 .r|27)) (unspecified)) (gen! .output|3 $.label .l1|6) (if (not (eq? .frame|3 .frame1|12)) (begin (gen-save! .output|3 .frame2|15 .t0|18) (cg-saveregs .output|3 .regs2|9 .frame2|15)) (cgframe-update-stale! .frame2|15)) (cg0 .output|3 (if.else .exp|3) .r|27 .regs2|9 .frame2|15 .env|3 .tail?|3) (if (not .tail?|3) (begin (gen! .output|3 $.label .l2|6) (cgreg-join! .regs|3 .regs2|9) (cgframe-join! .frame1|12 .frame2|15)) (unspecified)) (if (if (not .target|3) (if (not (eq? .r|27 'result)) (not (cgreg-lookup-reg .regs|3 .r|27)) #f) #f) (cg-move .output|3 .frame|3 .regs|3 .r|27 'result) .r|27)))))))))) (.cg-if-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-if-result))
+(let () (begin (set! cg-variable (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-variable|2 0)) (begin (set! .cg-variable|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.return-nostore|6 (unspecified)) (.return|6 (unspecified))) (begin (set! .return-nostore|6 (lambda (.id|7) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (if (if .target|3 (not (eq? 'result .target|3)) #f) (begin (gen! .output|3 $setreg .target|3) (cgreg-bind! .regs|3 .target|3 .id|7) .target|3) 'result)))) (set! .return|6 (lambda (.id|10) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (if (if .target|3 (not (eq? 'result .target|3)) #f) (begin (gen! .output|3 $setreg .target|3) (cgreg-bind! .regs|3 .target|3 .id|10) (gen-store! .output|3 .frame|3 .target|3 .id|10) .target|3) 'result)))) (let* ((.id|13 (variable.name .exp|3)) (.entry|16 (var-lookup .id|13 .regs|3 .frame|3 .env|3))) (let () (let ((.temp|20|23 (entry.kind .entry|16))) (if (memv .temp|20|23 '(global integrable)) (begin (gen! .output|3 $global .id|13) (.return|6 (newtemp))) (if (memv .temp|20|23 '(lexical)) (let ((.m|28 (entry.rib .entry|16)) (.n|28 (entry.offset .entry|16))) (begin (gen! .output|3 $lexical .m|28 .n|28 .id|13) (if (let ((.temp|29|32 (zero? .m|28))) (if .temp|29|32 .temp|29|32 (< (cgframe-size .frame|3) 0))) (.return-nostore|6 .id|13) (.return|6 .id|13)))) (if (memv .temp|20|23 '(procedure)) (error "Bug in cg-variable" .exp|3) (if (memv .temp|20|23 '(register)) (let ((.r|39 (entry.regnum .entry|16))) (if (let ((.temp|40|43 .tail?|3)) (if .temp|40|43 .temp|40|43 (if .target|3 (not (eqv? .target|3 .r|39)) #f))) (begin (gen! .output|3 $reg (entry.regnum .entry|16) .id|13) (.return-nostore|6 .id|13)) .r|39)) (if (memv .temp|20|23 '(frame)) (if (eq? .target|3 'result) (begin (gen-stack! .output|3 .frame|3 .id|13) (.return|6 .id|13)) (if .target|3 (begin (gen-load! .output|3 .frame|3 .target|3 .id|13) (cgreg-bind! .regs|3 .target|3 .id|13) .target|3) (let ((.r|54 (choose-register .regs|3 .frame|3))) (begin (gen-load! .output|3 .frame|3 .r|54 .id|13) (cgreg-bind! .regs|3 .r|54 .id|13) .r|54)))) (error "Bug in cg-variable" .exp|3))))))))))))) (.cg-variable|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-variable))
+(let () (begin (set! cg-sequential (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-sequential|2 0)) (begin (set! .cg-sequential|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (cg-sequential-loop .output|3 (begin.exprs .exp|3) .target|3 .regs|3 .frame|3 .env|3 .tail?|3))) (.cg-sequential|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-sequential))
+(let () (begin (set! cg-sequential-loop (lambda (.output|1 .exprs|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-sequential-loop|2 0)) (begin (set! .cg-sequential-loop|2 (lambda (.output|3 .exprs|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (null? .exprs|3) (begin (gen! .output|3 $const unspecified) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (null? (let ((.x|6|9 .exprs|3)) (begin (.check! (pair? .x|6|9) 1 .x|6|9) (cdr:pair .x|6|9)))) (cg0 .output|3 (let ((.x|10|13 .exprs|3)) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13))) .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (let ((.x|15|18 .exprs|3)) (begin (.check! (pair? .x|15|18) 0 .x|15|18) (car:pair .x|15|18))) #f .regs|3 .frame|3 .env|3 #f) (.cg-sequential-loop|2 .output|3 (let ((.x|19|22 .exprs|3)) (begin (.check! (pair? .x|19|22) 1 .x|19|22) (cdr:pair .x|19|22))) .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))))) (.cg-sequential-loop|2 .output|1 .exprs|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-sequential-loop))
+(let () (begin (set! cg-saveregs (lambda (.output|1 .regs|1 .frame|1) (let ((.cg-saveregs|2 0)) (begin (set! .cg-saveregs|2 (lambda (.output|3 .regs|3 .frame|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.i|12 .vars|12) (if (null? .vars|12) (if #f #f (unspecified)) (begin (begin #t (let ((.t|17 (let ((.x|18|21 .vars|12)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if .t|17 (gen-store! .output|3 .frame|3 .i|12 .t|17) (unspecified)))) (.loop|5|8|11 (+ .i|12 1) (let ((.x|22|25 .vars|12)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25)))))))) (.loop|5|8|11 1 (let ((.x|26|29 (cgreg-vars .regs|3))) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))))))))) (.cg-saveregs|2 .output|1 .regs|1 .frame|1))))) 'cg-saveregs))
+(let () (begin (set! cg-move (lambda (.output|1 .frame|1 .regs|1 .src|1 .dst|1) (let ((.cg-move|2 0)) (begin (set! .cg-move|2 (lambda (.output|3 .frame|3 .regs|3 .src|3 .dst|3) (let ((.bind|5 (unspecified))) (begin (set! .bind|5 (lambda (.dst|6) (let ((.temp|9 (newtemp))) (begin (cgreg-bind! .regs|3 .dst|6 .temp|9) (gen-store! .output|3 .frame|3 .dst|6 .temp|9) .dst|6)))) (if (not .dst|3) .src|3 (if (eqv? .src|3 .dst|3) .dst|3 (if (eq? .dst|3 'result) (begin (gen! .output|3 $reg .src|3) .dst|3) (if (eq? .src|3 'result) (begin (gen! .output|3 $setreg .dst|3) (.bind|5 .dst|3)) (if (if (not (zero? .src|3)) (not (zero? .dst|3)) #f) (begin (gen! .output|3 $movereg .src|3 .dst|3) (.bind|5 .dst|3)) (begin (gen! .output|3 $reg .src|3) (gen! .output|3 $setreg .dst|3) (.bind|5 .dst|3))))))))))) (.cg-move|2 .output|1 .frame|1 .regs|1 .src|1 .dst|1))))) 'cg-move))
+(let () (begin (set! choose-register (lambda (.regs|1 .frame|1) (let ((.choose-register|2 0)) (begin (set! .choose-register|2 (lambda (.regs|3 .frame|3) (let ((.x|4|7 (choose-registers .regs|3 .frame|3 1))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))))) (.choose-register|2 .regs|1 .frame|1))))) 'choose-register))
+(let () (begin (set! choose-registers (lambda (.regs|1 .frame|1 .n|1) (let ((.choose-registers|2 0)) (begin (set! .choose-registers|2 (lambda (.regs|3 .frame|3 .n|3) (let ((.hardcase|4 (unspecified)) (.loop2|4 (unspecified)) (.loop1|4 (unspecified))) (begin (set! .hardcase|4 (lambda () (let* ((.frame-exists?|8 (not (< (cgframe-size .frame|3) 0))) (.stufftosort|11 (let () (let ((.loop|172|175|178 (unspecified))) (begin (set! .loop|172|175|178 (lambda (.y1|167|168|179 .results|167|171|179) (if (null? .y1|167|168|179) (reverse .results|167|171|179) (begin #t (.loop|172|175|178 (let ((.x|183|186 .y1|167|168|179)) (begin (.check! (pair? .x|183|186) 1 .x|183|186) (cdr:pair .x|183|186))) (cons (let* ((.r|187 (let ((.x|220|223 .y1|167|168|179)) (begin (.check! (pair? .x|220|223) 0 .x|220|223) (car:pair .x|220|223)))) (.t|190 (cgreg-lookup-reg .regs|3 .r|187)) (.spilled?|193 (if .t|190 (cgframe-spilled? .frame|3 .t|190) #f))) (let () (let* ((.t1|197|200 .r|187) (.t2|197|203 (let* ((.t1|207|210 .t|190) (.t2|207|213 (cons .spilled?|193 '()))) (let () (cons .t1|207|210 .t2|207|213))))) (let () (cons .t1|197|200 .t2|197|203))))) .results|167|171|179)))))) (.loop|172|175|178 (let ((.x|224|227 (iota *nregs*))) (begin (.check! (pair? .x|224|227) 1 .x|224|227) (cdr:pair .x|224|227))) '()))))) (.registers|14 (twobit-sort (lambda (.x1|65 .x2|65) (let ((.r1|68 (let ((.x|141|144 .x1|65)) (begin (.check! (pair? .x|141|144) 0 .x|141|144) (car:pair .x|141|144)))) (.r2|68 (let ((.x|145|148 .x2|65)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148)))) (.t1|68 (let ((.x|150|153 (let ((.x|154|157 .x1|65)) (begin (.check! (pair? .x|154|157) 1 .x|154|157) (cdr:pair .x|154|157))))) (begin (.check! (pair? .x|150|153) 0 .x|150|153) (car:pair .x|150|153)))) (.t2|68 (let ((.x|159|162 (let ((.x|163|166 .x2|65)) (begin (.check! (pair? .x|163|166) 1 .x|163|166) (cdr:pair .x|163|166))))) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))))) (if (< .r1|68 *nhwregs*) (if (not .t1|68) #t (if (< .r2|68 *nhwregs*) (if (not .t2|68) #f (if (let ((.x|75|78 (let ((.x|79|82 (let ((.x|83|86 .x1|65)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86))))) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (begin (.check! (pair? .x|75|78) 0 .x|75|78) (car:pair .x|75|78))) #t (if (let ((.x|89|92 (let ((.x|93|96 (let ((.x|97|100 .x2|65)) (begin (.check! (pair? .x|97|100) 1 .x|97|100) (cdr:pair .x|97|100))))) (begin (.check! (pair? .x|93|96) 1 .x|93|96) (cdr:pair .x|93|96))))) (begin (.check! (pair? .x|89|92) 0 .x|89|92) (car:pair .x|89|92))) #f #t))) (if .frame-exists?|8 #t (if .t2|68 #t #f)))) (if (< .r2|68 *nhwregs*) (if .frame-exists?|8 #f (if .t1|68 #f (if .t2|68 #t #f))) (if .t1|68 (if (if (let ((.x|113|116 (let ((.x|117|120 (let ((.x|121|124 .x1|65)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124))))) (begin (.check! (pair? .x|117|120) 1 .x|117|120) (cdr:pair .x|117|120))))) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116))) (if .t2|68 (not (let ((.x|128|131 (let ((.x|132|135 (let ((.x|136|139 .x2|65)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))))) (begin (.check! (pair? .x|132|135) 1 .x|132|135) (cdr:pair .x|132|135))))) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131)))) #f) #f) #t #f) #t))))) .stufftosort|11))) (let () (begin '(for-each (lambda (register) (let ((t (cadr register)) (spilled? (caddr register))) (if (and t (not spilled?)) (cgframe-touch! frame t)))) registers) (let () (let ((.loop|18|22|25 (unspecified))) (begin (set! .loop|18|22|25 (lambda (.sorted|26 .rs|26 .n|26) (if (zero? .n|26) (reverse .rs|26) (begin #t (.loop|18|22|25 (let ((.x|29|32 .sorted|26)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))) (cons (let ((.x|33|36 .sorted|26)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))) .rs|26) (- .n|26 1)))))) (.loop|18|22|25 (let () (let ((.loop|42|45|48 (unspecified))) (begin (set! .loop|42|45|48 (lambda (.y1|37|38|49 .results|37|41|49) (if (null? .y1|37|38|49) (reverse .results|37|41|49) (begin #t (.loop|42|45|48 (let ((.x|53|56 .y1|37|38|49)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) (cons (let ((.x|57|60 (let ((.x|61|64 .y1|37|38|49)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))))) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))) .results|37|41|49)))))) (.loop|42|45|48 .registers|14 '())))) '() .n|3))))))))) (set! .loop2|4 (lambda (.i|229 .n|229 .good|229) (if (zero? .n|229) .good|229 (if (zero? .i|229) (.hardcase|4) (let ((.t|235 (cgreg-lookup-reg .regs|3 .i|229))) (if (if .t|235 (cgframe-spilled? .frame|3 .t|235) #f) (.loop2|4 (- .i|229 1) (- .n|229 1) (cons .i|229 .good|229)) (.loop2|4 (- .i|229 1) .n|229 .good|229))))))) (set! .loop1|4 (lambda (.i|238 .n|238 .good|238) (if (zero? .n|238) .good|238 (if (zero? .i|238) (if (< (cgframe-size .frame|3) 0) (.hardcase|4) (.loop2|4 (- *nhwregs* 1) .n|238 .good|238)) (if (cgreg-lookup-reg .regs|3 .i|238) (.loop1|4 (- .i|238 1) .n|238 .good|238) (.loop1|4 (- .i|238 1) (- .n|238 1) (cons .i|238 .good|238))))))) (if (< .n|3 *nregs*) (.loop1|4 (- *nhwregs* 1) .n|3 '()) (error (string-append "Compiler bug: can't allocate " (number->string .n|3) " registers on this target."))))))) (.choose-registers|2 .regs|1 .frame|1 .n|1))))) 'choose-registers))
+(let () (begin (set! cg-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-call|2 0)) (begin (set! .cg-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.proc|6 (call.proc .exp|3))) (if (if (lambda? .proc|6) (list? (lambda.args .proc|6)) #f) (cg-let .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (not (variable? .proc|6)) (cg-unknown-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.entry|14 (var-lookup (variable.name .proc|6) .regs|3 .frame|3 .env|3)) (.temp|15|18 (entry.kind .entry|14))) (if (memv .temp|15|18 '(global lexical frame register)) (cg-unknown-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|15|18 '(integrable)) (cg-integrable-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|15|18 '(procedure)) (cg-known-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Bug in cg-call" .exp|3)))))))))) (.cg-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-call))
+(let () (begin (set! cg-unknown-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-unknown-call|2 0)) (begin (set! .cg-unknown-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.args|9 (call.args .exp|3)) (.n|12 (length .args|9)) (.l|15 (make-label))) (let () (if (>= (+ .n|12 1) *lastreg*) (cg-big-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.r0|23 (cgreg-lookup-reg .regs|3 0))) (begin (if (variable? .proc|6) (let ((.entry|26 (cgreg-lookup .regs|3 (variable.name .proc|6)))) (begin (if (if .entry|26 (<= (entry.regnum .entry|26) .n|12) #f) (begin (cg-arguments .output|3 (iota1 (+ .n|12 1)) (append .args|9 (cons .proc|6 '())) .regs|3 .frame|3 .env|3) (gen! .output|3 $reg (+ .n|12 1))) (begin (cg-arguments .output|3 (iota1 .n|12) .args|9 .regs|3 .frame|3 .env|3) (cg0 .output|3 .proc|6 'result .regs|3 .frame|3 .env|3 #f))) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|15))) (gen! .output|3 $invoke .n|12))) (begin (cg-arguments .output|3 (iota1 (+ .n|12 1)) (append .args|9 (cons .proc|6 '())) .regs|3 .frame|3 .env|3) (gen! .output|3 $reg (+ .n|12 1)) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|15))) (gen! .output|3 $invoke .n|12))) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|15) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|23) (gen-load! .output|3 .frame|3 0 .r0|23) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))) (.cg-unknown-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-unknown-call))
+(let () (begin (set! cg-known-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-known-call|2 0)) (begin (set! .cg-known-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|6 (call.args .exp|3)) (.n|9 (length .args|6)) (.l|12 (make-label))) (let () (if (>= (+ .n|9 1) *lastreg*) (cg-big-call .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.r0|20 (cgreg-lookup-reg .regs|3 0))) (begin (cg-arguments .output|3 (iota1 .n|9) .args|6 .regs|3 .frame|3 .env|3) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|12))) (let* ((.entry|23 (cgenv-lookup .env|3 (variable.name (call.proc .exp|3)))) (.label|26 (entry.label .entry|23)) (.m|29 (entry.rib .entry|23))) (let () (if (zero? .m|29) (gen! .output|3 $branch .label|26 .n|9) (gen! .output|3 $jump .m|29 .label|26 .n|9)))) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|12) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|20) (gen-load! .output|3 .frame|3 0 .r0|20) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))))) (.cg-known-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-known-call))
+(let () (begin (set! cg-big-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-big-call|2 0)) (begin (set! .cg-big-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.args|9 (call.args .exp|3)) (.n|12 (length .args|9)) (.argslots|15 (newtemps .n|12)) (.procslot|18 (newtemp)) (.r0|21 (cgreg-lookup-reg .regs|3 0)) (.r-1|24 (- *nregs* 1)) (.entry|27 (if (variable? .proc|6) (let ((.entry|103 (var-lookup (variable.name .proc|6) .regs|3 .frame|3 .env|3))) (if (eq? (entry.kind .entry|103) 'procedure) .entry|103 #f)) #f)) (.l|30 (make-label))) (let () (begin (if (not .entry|27) (begin (cg0 .output|3 .proc|6 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .procslot|18)) (unspecified)) (let ((.f|34|38|41 (lambda (.arg|74 .argslot|74) (begin (cg0 .output|3 .arg|74 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .argslot|74))))) (let () (let ((.loop|43|46|49 (unspecified))) (begin (set! .loop|43|46|49 (lambda (.y1|34|36|50 .y1|34|35|50) (if (let ((.temp|52|55 (null? .y1|34|36|50))) (if .temp|52|55 .temp|52|55 (null? .y1|34|35|50))) (if #f #f (unspecified)) (begin (begin #t (.f|34|38|41 (let ((.x|58|61 .y1|34|36|50)) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) (let ((.x|62|65 .y1|34|35|50)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65))))) (.loop|43|46|49 (let ((.x|66|69 .y1|34|36|50)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))) (let ((.x|70|73 .y1|34|35|50)) (begin (.check! (pair? .x|70|73) 1 .x|70|73) (cdr:pair .x|70|73)))))))) (.loop|43|46|49 .args|9 .argslots|15))))) (cgreg-clear! .regs|3) (gen! .output|3 $const '()) (gen! .output|3 $setreg .r-1|24) (let () (let ((.loop|76|79|82 (unspecified))) (begin (set! .loop|76|79|82 (lambda (.i|83 .slots|83) (if (zero? .i|83) (if #f #f (unspecified)) (begin (begin #t (if (< .i|83 .r-1|24) (gen-load! .output|3 .frame|3 .i|83 (let ((.x|86|89 .slots|83)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89)))) (begin (gen-stack! .output|3 .frame|3 (let ((.x|90|93 .slots|83)) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) (gen! .output|3 $op2 $cons .r-1|24) (gen! .output|3 $setreg .r-1|24)))) (.loop|76|79|82 (- .i|83 1) (let ((.x|94|97 .slots|83)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97)))))))) (.loop|76|79|82 .n|12 (reverse .argslots|15))))) (if (not .entry|27) (gen-stack! .output|3 .frame|3 .procslot|18) (unspecified)) (if .tail?|3 (gen-pop! .output|3 .frame|3) (begin (cgframe-used! .frame|3) (gen! .output|3 $setrtn .l|30))) (if .entry|27 (let ((.label|100 (entry.label .entry|27)) (.m|100 (entry.rib .entry|27))) (if (zero? .m|100) (gen! .output|3 $branch .label|100 .n|12) (gen! .output|3 $jump .m|100 .label|100 .n|12))) (gen! .output|3 $invoke .n|12)) (if .tail?|3 'result (begin (gen! .output|3 $.align 4) (gen! .output|3 $.label .l|30) (gen! .output|3 $.cont) (cgreg-clear! .regs|3) (cgreg-bind! .regs|3 0 .r0|21) (gen-load! .output|3 .frame|3 0 .r0|21) (cg-move .output|3 .frame|3 .regs|3 'result .target|3)))))))) (.cg-big-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-big-call))
+(let () (begin (set! cg-integrable-call (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-integrable-call|2 0)) (begin (set! .cg-integrable-call|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.args|6 (call.args .exp|3)) (.entry|6 (var-lookup (variable.name (call.proc .exp|3)) .regs|3 .frame|3 .env|3))) (if (= (entry.arity .entry|6) (length .args|6)) (begin (let ((.temp|7|10 (entry.arity .entry|6))) (if (memv .temp|7|10 '(0)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(1)) (begin (cg0 .output|3 (let ((.x|13|16 .args|6)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))) 'result .regs|3 .frame|3 .env|3 #f) (gen! .output|3 $op1 (entry.op .entry|6))) (if (memv .temp|7|10 '(2)) (cg-integrable-call2 .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (if (memv .temp|7|10 '(3)) (cg-integrable-call3 .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (error "Bug detected by cg-integrable-call" (make-readable .exp|3))))))) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (< (entry.arity .entry|6) 0) (cg-special .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Wrong number of arguments to integrable procedure" (make-readable .exp|3))))))) (.cg-integrable-call|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-integrable-call))
+(let () (begin (set! cg-integrable-call2 (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-integrable-call2|2 0)) (begin (set! .cg-integrable-call2|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (begin (let ((.op|6 (entry.op .entry|3))) (if (if (entry.imm .entry|3) (if (constant? (let ((.x|10|13 (let ((.x|14|17 .args|3)) (begin (.check! (pair? .x|14|17) 1 .x|14|17) (cdr:pair .x|14|17))))) (begin (.check! (pair? .x|10|13) 0 .x|10|13) (car:pair .x|10|13)))) ((entry.imm .entry|3) (constant.value (let ((.x|20|23 (let ((.x|24|27 .args|3)) (begin (.check! (pair? .x|24|27) 1 .x|24|27) (cdr:pair .x|24|27))))) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))))) #f) #f) (begin (cg0 .output|3 (let ((.x|28|31 .args|3)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) 'result .regs|3 .frame|3 .env|3 #f) (gen! .output|3 $op2imm .op|6 (constant.value (let ((.x|33|36 (let ((.x|37|40 .args|3)) (begin (.check! (pair? .x|37|40) 1 .x|37|40) (cdr:pair .x|37|40))))) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36)))))) (let* ((.reg2|43 (cg0 .output|3 (let ((.x|78|81 (let ((.x|82|85 .args|3)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81))) #f .regs|3 .frame|3 .env|3 #f)) (.r2|46 (choose-register .regs|3 .frame|3)) (.t2|49 (if (eq? .reg2|43 'result) (let ((.t2|76 (newtemp))) (begin (gen! .output|3 $setreg .r2|46) (cgreg-bind! .regs|3 .r2|46 .t2|76) (gen-store! .output|3 .frame|3 .r2|46 .t2|76) .t2|76)) (cgreg-lookup-reg .regs|3 .reg2|43)))) (let () (begin (cg0 .output|3 (let ((.x|53|56 .args|3)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56))) 'result .regs|3 .frame|3 .env|3 #f) (let ((.r2|59 (let ((.temp|63|66 (let ((.entry|73 (cgreg-lookup .regs|3 .t2|49))) (if .entry|73 (entry.regnum .entry|73) #f)))) (if .temp|63|66 .temp|63|66 (let ((.r2|70 (choose-register .regs|3 .frame|3))) (begin (cgreg-bind! .regs|3 .r2|70 .t2|49) (gen-load! .output|3 .frame|3 .r2|70 .t2|49) .r2|70)))))) (let () (begin (gen! .output|3 $op2 (entry.op .entry|3) .r2|59) (if (eq? .reg2|43 'result) (begin (cgreg-release! .regs|3 .r2|59) (cgframe-release! .frame|3 .t2|49)) (unspecified)))))))))) 'result))) (.cg-integrable-call2|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-integrable-call2))
+(let () (begin (set! cg-integrable-call3 (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-integrable-call3|2 0)) (begin (set! .cg-integrable-call3|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (begin (let* ((.reg2|6 (cg0 .output|3 (let ((.x|121|124 (let ((.x|125|128 .args|3)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))))) (begin (.check! (pair? .x|121|124) 0 .x|121|124) (car:pair .x|121|124))) #f .regs|3 .frame|3 .env|3 #f)) (.r2|9 (choose-register .regs|3 .frame|3)) (.t2|12 (if (eq? .reg2|6 'result) (let ((.t2|119 (newtemp))) (begin (gen! .output|3 $setreg .r2|9) (cgreg-bind! .regs|3 .r2|9 .t2|119) (gen-store! .output|3 .frame|3 .r2|9 .t2|119) .t2|119)) (cgreg-lookup-reg .regs|3 .reg2|6))) (.reg3|15 (cg0 .output|3 (let ((.x|105|108 (let ((.x|109|112 (let ((.x|113|116 .args|3)) (begin (.check! (pair? .x|113|116) 1 .x|113|116) (cdr:pair .x|113|116))))) (begin (.check! (pair? .x|109|112) 1 .x|109|112) (cdr:pair .x|109|112))))) (begin (.check! (pair? .x|105|108) 0 .x|105|108) (car:pair .x|105|108))) #f .regs|3 .frame|3 .env|3 #f)) (.spillregs|18 (choose-registers .regs|3 .frame|3 2)) (.t3|21 (if (eq? .reg3|15 'result) (let ((.t3|86 (newtemp)) (.r3|86 (if (eq? .t2|12 (cgreg-lookup-reg .regs|3 (let ((.x|87|90 .spillregs|18)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (let ((.x|92|95 (let ((.x|96|99 .spillregs|18)) (begin (.check! (pair? .x|96|99) 1 .x|96|99) (cdr:pair .x|96|99))))) (begin (.check! (pair? .x|92|95) 0 .x|92|95) (car:pair .x|92|95))) (let ((.x|100|103 .spillregs|18)) (begin (.check! (pair? .x|100|103) 0 .x|100|103) (car:pair .x|100|103)))))) (begin (gen! .output|3 $setreg .r3|86) (cgreg-bind! .regs|3 .r3|86 .t3|86) (gen-store! .output|3 .frame|3 .r3|86 .t3|86) .t3|86)) (cgreg-lookup-reg .regs|3 .reg3|15)))) (let () (begin (cg0 .output|3 (let ((.x|25|28 .args|3)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) 'result .regs|3 .frame|3 .env|3 #f) (let* ((.spillregs|31 (choose-registers .regs|3 .frame|3 2)) (.r2|34 (let ((.temp|69|72 (let ((.entry|83 (cgreg-lookup .regs|3 .t2|12))) (if .entry|83 (entry.regnum .entry|83) #f)))) (if .temp|69|72 .temp|69|72 (let ((.r2|76 (let ((.x|77|80 .spillregs|31)) (begin (.check! (pair? .x|77|80) 0 .x|77|80) (car:pair .x|77|80))))) (begin (cgreg-bind! .regs|3 .r2|76 .t2|12) (gen-load! .output|3 .frame|3 .r2|76 .t2|12) .r2|76))))) (.r3|37 (let ((.temp|41|44 (let ((.entry|68 (cgreg-lookup .regs|3 .t3|21))) (if .entry|68 (entry.regnum .entry|68) #f)))) (if .temp|41|44 .temp|41|44 (let ((.r3|48 (if (eq? .r2|34 (let ((.x|49|52 .spillregs|31)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52)))) (let ((.x|54|57 (let ((.x|58|61 .spillregs|31)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))))) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57))) (let ((.x|62|65 .spillregs|31)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))))) (begin (cgreg-bind! .regs|3 .r3|48 .t3|21) (gen-load! .output|3 .frame|3 .r3|48 .t3|21) .r3|48)))))) (let () (begin (gen! .output|3 $op3 (entry.op .entry|3) .r2|34 .r3|37) (if (eq? .reg2|6 'result) (begin (cgreg-release! .regs|3 .r2|34) (cgframe-release! .frame|3 .t2|12)) (unspecified)) (if (eq? .reg3|15 'result) (begin (cgreg-release! .regs|3 .r3|37) (cgframe-release! .frame|3 .t3|21)) (unspecified)))))))) 'result))) (.cg-integrable-call3|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-integrable-call3))
+(let () (begin (set! cg-primop-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-primop-args|2 0)) (begin (set! .cg-primop-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.finish-loop|4 (unspecified)) (.eval-first-into-result|4 (unspecified)) (.eval-loop|4 (unspecified))) (begin (set! .finish-loop|4 (lambda (.disjoint|5 .temps|5 .mask|5 .registers|5) (if (null? .temps|5) .registers|5 (let* ((.t|8 (let ((.x|54|57 .temps|5)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) (.entry|11 (cgreg-lookup .regs|3 .t|8))) (let () (if .entry|11 (let ((.r|17 (entry.regnum .entry|11))) (begin (if (let ((.x|18|21 .mask|5)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (begin (cgreg-release! .regs|3 .r|17) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|22|25 .temps|5)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) (let ((.x|26|29 .mask|5)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (cons .r|17 .registers|5)))) (let ((.r|32 (let ((.x|50|53 .disjoint|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .r|32 .registers|5) (.finish-loop|4 (let ((.x|34|37 .disjoint|5)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) .temps|5 .mask|5 .registers|5) (begin (gen-load! .output|3 .frame|3 .r|32 .t|8) (cgreg-bind! .regs|3 .r|32 .t|8) (if (let ((.x|38|41 .mask|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (begin (cgreg-release! .regs|3 .r|32) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|42|45 .temps|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) (let ((.x|46|49 .mask|5)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))) (cons .r|32 .registers|5))))))))))) (set! .eval-first-into-result|4 (lambda (.temps|58 .mask|58) (begin (cg0 .output|3 (let ((.x|59|62 .args|3)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) 'result .regs|3 .frame|3 .env|3 #f) (.finish-loop|4 (choose-registers .regs|3 .frame|3 (length .temps|58)) .temps|58 .mask|58 '())))) (set! .eval-loop|4 (lambda (.args|63 .temps|63 .mask|63) (if (null? .args|63) (.eval-first-into-result|4 .temps|63 .mask|63) (let ((.reg|66 (cg0 .output|3 (let ((.x|84|87 .args|63)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) #f .regs|3 .frame|3 .env|3 #f))) (if (eq? .reg|66 'result) (let* ((.r|69 (choose-register .regs|3 .frame|3)) (.t|72 (newtemp))) (let () (begin (gen! .output|3 $setreg .r|69) (cgreg-bind! .regs|3 .r|69 .t|72) (gen-store! .output|3 .frame|3 .r|69 .t|72) (.eval-loop|4 (let ((.x|76|79 .args|63)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons .t|72 .temps|63) (cons #t .mask|63))))) (.eval-loop|4 (let ((.x|80|83 .args|63)) (begin (.check! (pair? .x|80|83) 1 .x|80|83) (cdr:pair .x|80|83))) (cons (cgreg-lookup-reg .regs|3 .reg|66) .temps|63) (cons #f .mask|63))))))) (if (< (length .args|3) *nregs*) (.eval-loop|4 (let ((.x|88|91 .args|3)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))) '() '()) (error "Bug detected by cg-primop-args" .args|3)))))) (.cg-primop-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-primop-args))
+(let () (begin (set! cg-arguments (lambda (.output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-arguments|2 0)) (begin (set! .cg-arguments|2 (lambda (.output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.evalargs0|4 (unspecified)) (.evalargs|4 (unspecified)) (.sortargs|4 (unspecified))) (begin (set! .evalargs0|4 (lambda (.targets|5 .args|5 .temps|5) (if (not (null? .targets|5)) (let ((.para|8 (let ((.regvars|92 (let () (let ((.loop|139|142|145 (unspecified))) (begin (set! .loop|139|142|145 (lambda (.y1|134|135|146 .results|134|138|146) (if (null? .y1|134|135|146) (reverse .results|134|138|146) (begin #t (.loop|139|142|145 (let ((.x|150|153 .y1|134|135|146)) (begin (.check! (pair? .x|150|153) 1 .x|150|153) (cdr:pair .x|150|153))) (cons (let ((.reg|154 (let ((.x|155|158 .y1|134|135|146)) (begin (.check! (pair? .x|155|158) 0 .x|155|158) (car:pair .x|155|158))))) (cgreg-lookup-reg .regs|3 .reg|154)) .results|134|138|146)))))) (.loop|139|142|145 .targets|5 '())))))) (let () (parallel-assignment .targets|5 (let () (let ((.loop|102|106|109 (unspecified))) (begin (set! .loop|102|106|109 (lambda (.y1|96|98|110 .y1|96|97|110 .results|96|101|110) (if (let ((.temp|112|115 (null? .y1|96|98|110))) (if .temp|112|115 .temp|112|115 (null? .y1|96|97|110))) (reverse .results|96|101|110) (begin #t (.loop|102|106|109 (let ((.x|118|121 .y1|96|98|110)) (begin (.check! (pair? .x|118|121) 1 .x|118|121) (cdr:pair .x|118|121))) (let ((.x|122|125 .y1|96|97|110)) (begin (.check! (pair? .x|122|125) 1 .x|122|125) (cdr:pair .x|122|125))) (cons (cons (let ((.x|126|129 .y1|96|98|110)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129))) (let ((.x|130|133 .y1|96|97|110)) (begin (.check! (pair? .x|130|133) 0 .x|130|133) (car:pair .x|130|133)))) .results|96|101|110)))))) (.loop|102|106|109 .regvars|92 .targets|5 '())))) .args|5))))) (if .para|8 (let ((.targets|11 .para|8) (.args|11 (cg-permute .args|5 .targets|5 .para|8)) (.temps|11 (cg-permute .temps|5 .targets|5 .para|8))) (let ((.f|12|17|20 (lambda (.arg|66 .r|66 .t|66) (begin (cg0 .output|3 .arg|66 .r|66 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|66 .t|66) (gen-store! .output|3 .frame|3 .r|66 .t|66))))) (let () (let ((.loop|22|26|29 (unspecified))) (begin (set! .loop|22|26|29 (lambda (.y1|12|15|30 .y1|12|14|30 .y1|12|13|30) (if (let ((.temp|32|35 (null? .y1|12|15|30))) (if .temp|32|35 .temp|32|35 (let ((.temp|36|39 (null? .y1|12|14|30))) (if .temp|36|39 .temp|36|39 (null? .y1|12|13|30))))) (if #f #f (unspecified)) (begin (begin #t (.f|12|17|20 (let ((.x|42|45 .y1|12|15|30)) (begin (.check! (pair? .x|42|45) 0 .x|42|45) (car:pair .x|42|45))) (let ((.x|46|49 .y1|12|14|30)) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) (let ((.x|50|53 .y1|12|13|30)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (.loop|22|26|29 (let ((.x|54|57 .y1|12|15|30)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))) (let ((.x|58|61 .y1|12|14|30)) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61))) (let ((.x|62|65 .y1|12|13|30)) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65)))))))) (.loop|22|26|29 .args|11 .para|8 .temps|11)))))) (let ((.r|69 (choose-register .regs|3 .frame|3)) (.t|69 (let ((.x|86|89 .temps|5)) (begin (.check! (pair? .x|86|89) 0 .x|86|89) (car:pair .x|86|89))))) (begin (cg0 .output|3 (let ((.x|70|73 .args|5)) (begin (.check! (pair? .x|70|73) 0 .x|70|73) (car:pair .x|70|73))) .r|69 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|69 .t|69) (gen-store! .output|3 .frame|3 .r|69 .t|69) (.evalargs0|4 (let ((.x|74|77 .targets|5)) (begin (.check! (pair? .x|74|77) 1 .x|74|77) (cdr:pair .x|74|77))) (let ((.x|78|81 .args|5)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))) (let ((.x|82|85 .temps|5)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85)))))))) (unspecified)))) (set! .evalargs|4 (lambda (.targets1|159 .args1|159 .targets2|159 .args2|159) (let* ((.temps1|162 (newtemps (length .targets1|159))) (.temps2|165 (newtemps (length .targets2|159)))) (let () (begin (if (not (null? .args1|159)) (let ((.f|169|173|176 (lambda (.arg|217 .temp|217) (begin (cg0 .output|3 .arg|217 'result .regs|3 .frame|3 .env|3 #f) (gen-setstk! .output|3 .frame|3 .temp|217))))) (let () (let ((.loop|178|181|184 (unspecified))) (begin (set! .loop|178|181|184 (lambda (.y1|169|171|185 .y1|169|170|185) (if (let ((.temp|187|190 (null? .y1|169|171|185))) (if .temp|187|190 .temp|187|190 (null? .y1|169|170|185))) (if #f #f (unspecified)) (begin (begin #t (.f|169|173|176 (let ((.x|193|196 .y1|169|171|185)) (begin (.check! (pair? .x|193|196) 0 .x|193|196) (car:pair .x|193|196))) (let ((.x|197|200 .y1|169|170|185)) (begin (.check! (pair? .x|197|200) 0 .x|197|200) (car:pair .x|197|200))))) (.loop|178|181|184 (let ((.x|201|204 .y1|169|171|185)) (begin (.check! (pair? .x|201|204) 1 .x|201|204) (cdr:pair .x|201|204))) (let ((.x|205|208 .y1|169|170|185)) (begin (.check! (pair? .x|205|208) 1 .x|205|208) (cdr:pair .x|205|208)))))))) (.loop|178|181|184 (let ((.x|209|212 .args1|159)) (begin (.check! (pair? .x|209|212) 1 .x|209|212) (cdr:pair .x|209|212))) (let ((.x|213|216 .temps1|162)) (begin (.check! (pair? .x|213|216) 1 .x|213|216) (cdr:pair .x|213|216)))))))) (unspecified)) (if (not (null? .args1|159)) (.evalargs0|4 (cons (let ((.x|218|221 .targets1|159)) (begin (.check! (pair? .x|218|221) 0 .x|218|221) (car:pair .x|218|221))) .targets2|159) (cons (let ((.x|222|225 .args1|159)) (begin (.check! (pair? .x|222|225) 0 .x|222|225) (car:pair .x|222|225))) .args2|159) (cons (let ((.x|226|229 .temps1|162)) (begin (.check! (pair? .x|226|229) 0 .x|226|229) (car:pair .x|226|229))) .temps2|165)) (.evalargs0|4 .targets2|159 .args2|159 .temps2|165)) (let () (let ((.loop|236|239|242 (unspecified))) (begin (set! .loop|236|239|242 (lambda (.y1|230|232|243 .y1|230|231|243) (if (let ((.temp|245|248 (null? .y1|230|232|243))) (if .temp|245|248 .temp|245|248 (null? .y1|230|231|243))) (if #f #f (unspecified)) (begin (begin #t (let ((.r|251 (let ((.x|264|267 .y1|230|232|243)) (begin (.check! (pair? .x|264|267) 0 .x|264|267) (car:pair .x|264|267)))) (.t|251 (let ((.x|268|271 .y1|230|231|243)) (begin (.check! (pair? .x|268|271) 0 .x|268|271) (car:pair .x|268|271))))) (let ((.temp|254 (cgreg-lookup-reg .regs|3 .r|251))) (begin (if (not (eq? .temp|254 .t|251)) (let ((.entry|257 (var-lookup .t|251 .regs|3 .frame|3 .env|3))) (begin (let ((.temp|258|261 (entry.kind .entry|257))) (if (memv .temp|258|261 '(register)) (gen! .output|3 $movereg (entry.regnum .entry|257) .r|251) (if (memv .temp|258|261 '(frame)) (gen-load! .output|3 .frame|3 .r|251 .t|251) (unspecified)))) (cgreg-bind! .regs|3 .r|251 .t|251))) (unspecified)) (cgframe-release! .frame|3 .t|251))))) (.loop|236|239|242 (let ((.x|272|275 .y1|230|232|243)) (begin (.check! (pair? .x|272|275) 1 .x|272|275) (cdr:pair .x|272|275))) (let ((.x|276|279 .y1|230|231|243)) (begin (.check! (pair? .x|276|279) 1 .x|276|279) (cdr:pair .x|276|279)))))))) (.loop|236|239|242 (append .targets1|159 .targets2|159) (append .temps1|162 .temps2|165)))))))))) (set! .sortargs|4 (lambda (.targets|280 .args|280 .targets1|280 .args1|280 .targets2|280 .args2|280) (if (null? .args|280) (.evalargs|4 .targets1|280 .args1|280 .targets2|280 .args2|280) (let ((.target|283 (let ((.x|284|287 .targets|280)) (begin (.check! (pair? .x|284|287) 0 .x|284|287) (car:pair .x|284|287)))) (.arg|283 (let ((.x|288|291 .args|280)) (begin (.check! (pair? .x|288|291) 0 .x|288|291) (car:pair .x|288|291)))) (.targets|283 (let ((.x|292|295 .targets|280)) (begin (.check! (pair? .x|292|295) 1 .x|292|295) (cdr:pair .x|292|295)))) (.args|283 (let ((.x|296|299 .args|280)) (begin (.check! (pair? .x|296|299) 1 .x|296|299) (cdr:pair .x|296|299))))) (if (complicated? .arg|283 .env|3) (.sortargs|4 .targets|283 .args|283 (cons .target|283 .targets1|280) (cons .arg|283 .args1|280) .targets2|280 .args2|280) (.sortargs|4 .targets|283 .args|283 .targets1|280 .args1|280 (cons .target|283 .targets2|280) (cons .arg|283 .args2|280))))))) (if (parallel-assignment-optimization) (.sortargs|4 (reverse .targets|3) (reverse .args|3) '() '() '() '()) (cg-evalargs .output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3)))))) (.cg-arguments|2 .output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-arguments))
+(let () (begin (set! cg-evalargs (lambda (.output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-evalargs|2 0)) (begin (set! .cg-evalargs|2 (lambda (.output|3 .targets|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.temps|6 (newtemps (length .targets|3)))) (begin (let ((.f|7|12|15 (lambda (.arg|61 .r|61 .t|61) (begin (cg0 .output|3 .arg|61 .r|61 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|61 .t|61) (gen-store! .output|3 .frame|3 .r|61 .t|61))))) (let () (let ((.loop|17|21|24 (unspecified))) (begin (set! .loop|17|21|24 (lambda (.y1|7|10|25 .y1|7|9|25 .y1|7|8|25) (if (let ((.temp|27|30 (null? .y1|7|10|25))) (if .temp|27|30 .temp|27|30 (let ((.temp|31|34 (null? .y1|7|9|25))) (if .temp|31|34 .temp|31|34 (null? .y1|7|8|25))))) (if #f #f (unspecified)) (begin (begin #t (.f|7|12|15 (let ((.x|37|40 .y1|7|10|25)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))) (let ((.x|41|44 .y1|7|9|25)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))) (let ((.x|45|48 .y1|7|8|25)) (begin (.check! (pair? .x|45|48) 0 .x|45|48) (car:pair .x|45|48))))) (.loop|17|21|24 (let ((.x|49|52 .y1|7|10|25)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.x|53|56 .y1|7|9|25)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) (let ((.x|57|60 .y1|7|8|25)) (begin (.check! (pair? .x|57|60) 1 .x|57|60) (cdr:pair .x|57|60)))))))) (.loop|17|21|24 .args|3 .targets|3 .temps|6))))) (let () (let ((.loop|68|71|74 (unspecified))) (begin (set! .loop|68|71|74 (lambda (.y1|62|64|75 .y1|62|63|75) (if (let ((.temp|77|80 (null? .y1|62|64|75))) (if .temp|77|80 .temp|77|80 (null? .y1|62|63|75))) (if #f #f (unspecified)) (begin (begin #t (let ((.r|83 (let ((.x|87|90 .y1|62|64|75)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90)))) (.t|83 (let ((.x|91|94 .y1|62|63|75)) (begin (.check! (pair? .x|91|94) 0 .x|91|94) (car:pair .x|91|94))))) (let ((.temp|86 (cgreg-lookup-reg .regs|3 .r|83))) (begin (if (not (eq? .temp|86 .t|83)) (begin (gen-load! .output|3 .frame|3 .r|83 .t|83) (cgreg-bind! .regs|3 .r|83 .t|83)) (unspecified)) (cgframe-release! .frame|3 .t|83))))) (.loop|68|71|74 (let ((.x|95|98 .y1|62|64|75)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (let ((.x|99|102 .y1|62|63|75)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102)))))))) (.loop|68|71|74 .targets|3 .temps|6)))))))) (.cg-evalargs|2 .output|1 .targets|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-evalargs))
+(let () (begin (set! complicated? (lambda (.exp|1 .env|1) (let ((.complicated?|2 0)) (begin (set! .complicated?|2 (lambda (.exp|3 .env|3) (let ((.temp|4|7 (let ((.x|33|36 .exp|3)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (if (memv .temp|4|7 '(quote)) #f (if (memv .temp|4|7 '(lambda)) #t (if (memv .temp|4|7 '(set!)) (.complicated?|2 (assignment.rhs .exp|3) .env|3) (if (memv .temp|4|7 '(if)) (let ((.temp|12|15 (.complicated?|2 (if.test .exp|3) .env|3))) (if .temp|12|15 .temp|12|15 (let ((.temp|16|19 (.complicated?|2 (if.then .exp|3) .env|3))) (if .temp|16|19 .temp|16|19 (.complicated?|2 (if.else .exp|3) .env|3))))) (if (memv .temp|4|7 '(begin)) (if (variable? .exp|3) #f (some? (lambda (.exp|22) (.complicated?|2 .exp|22 .env|3)) (begin.exprs .exp|3))) (let ((.proc|26 (call.proc .exp|3))) (if (if (variable? .proc|26) (let ((.entry|31 (cgenv-lookup .env|3 (variable.name .proc|26)))) (eq? (entry.kind .entry|31) 'integrable)) #f) (some? (lambda (.exp|32) (.complicated?|2 .exp|32 .env|3)) (call.args .exp|3)) #t)))))))))) (.complicated?|2 .exp|1 .env|1))))) 'complicated?))
+(let () (begin (set! cg-permute (lambda (.src|1 .key|1 .newkey|1) (let ((.cg-permute|2 0)) (begin (set! .cg-permute|2 (lambda (.src|3 .key|3 .newkey|3) (let ((.alist|6 (let () (let ((.loop|35|39|42 (unspecified))) (begin (set! .loop|35|39|42 (lambda (.y1|29|31|43 .y1|29|30|43 .results|29|34|43) (if (let ((.temp|45|48 (null? .y1|29|31|43))) (if .temp|45|48 .temp|45|48 (null? .y1|29|30|43))) (reverse .results|29|34|43) (begin #t (.loop|35|39|42 (let ((.x|51|54 .y1|29|31|43)) (begin (.check! (pair? .x|51|54) 1 .x|51|54) (cdr:pair .x|51|54))) (let ((.x|55|58 .y1|29|30|43)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))) (cons (cons (let ((.x|59|62 .y1|29|31|43)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) (let ((.x|63|66 .y1|29|30|43)) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) .results|29|34|43)))))) (.loop|35|39|42 .key|3 (iota (length .key|3)) '())))))) (let () (let ((.loop|7|10|13 (unspecified))) (begin (set! .loop|7|10|13 (lambda (.newkey|14 .dest|14) (if (null? .newkey|14) (reverse .dest|14) (begin #t (.loop|7|10|13 (let ((.x|17|20 .newkey|14)) (begin (.check! (pair? .x|17|20) 1 .x|17|20) (cdr:pair .x|17|20))) (cons (list-ref .src|3 (let ((.x|21|24 (assq (let ((.x|25|28 .newkey|14)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) .alist|6))) (begin (.check! (pair? .x|21|24) 1 .x|21|24) (cdr:pair .x|21|24)))) .dest|14)))))) (.loop|7|10|13 .newkey|3 '()))))))) (.cg-permute|2 .src|1 .key|1 .newkey|1))))) 'cg-permute))
+(let () (begin (set! parallel-assignment (lambda (.regnums|1 .alist|1 .exps|1) (if (null? .regnums|1) #t (let ((.x|4 (toposort (dependency-graph .regnums|1 .alist|1 .exps|1)))) (if .x|4 (reverse .x|4) #f))))) 'parallel-assignment))
+(let () (begin (set! dependency-graph (lambda (.regnums|1 .alist|1 .exps|1) (let ((.names|4 (let () (let ((.loop|66|69|72 (unspecified))) (begin (set! .loop|66|69|72 (lambda (.y1|61|62|73 .results|61|65|73) (if (null? .y1|61|62|73) (reverse .results|61|65|73) (begin #t (.loop|66|69|72 (let ((.x|77|80 .y1|61|62|73)) (begin (.check! (pair? .x|77|80) 1 .x|77|80) (cdr:pair .x|77|80))) (cons (let ((.x|81|84 (let ((.x|85|88 .y1|61|62|73)) (begin (.check! (pair? .x|85|88) 0 .x|85|88) (car:pair .x|85|88))))) (begin (.check! (pair? .x|81|84) 0 .x|81|84) (car:pair .x|81|84))) .results|61|65|73)))))) (.loop|66|69|72 .alist|1 '())))))) (let () (let ((.loop|5|9|12 (unspecified))) (begin (set! .loop|5|9|12 (lambda (.regnums|13 .exps|13 .l|13) (if (null? .regnums|13) .l|13 (begin #t (.loop|5|9|12 (let ((.x|16|19 .regnums|13)) (begin (.check! (pair? .x|16|19) 1 .x|16|19) (cdr:pair .x|16|19))) (let ((.x|20|23 .exps|13)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (cons (let ((.x|24|27 .regnums|13)) (begin (.check! (pair? .x|24|27) 0 .x|24|27) (car:pair .x|24|27))) (let () (let ((.loop|33|36|39 (unspecified))) (begin (set! .loop|33|36|39 (lambda (.y1|28|29|40 .results|28|32|40) (if (null? .y1|28|29|40) (reverse .results|28|32|40) (begin #t (.loop|33|36|39 (let ((.x|44|47 .y1|28|29|40)) (begin (.check! (pair? .x|44|47) 1 .x|44|47) (cdr:pair .x|44|47))) (cons (let* ((.var|48 (let ((.x|53|56 .y1|28|29|40)) (begin (.check! (pair? .x|53|56) 0 .x|53|56) (car:pair .x|53|56)))) (.x|49|52 (assq .var|48 .alist|1))) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) .results|28|32|40)))))) (.loop|33|36|39 (intersection (freevariables (let ((.x|57|60 .exps|13)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60)))) .names|4) '()))))) .l|13)))))) (.loop|5|9|12 .regnums|1 .exps|1 '()))))))) 'dependency-graph))
+(let () (begin (set! toposort (lambda (.graph|1) (if (null? (let ((.x|3|6 .graph|1)) (begin (.check! (pair? .x|3|6) 1 .x|3|6) (cdr:pair .x|3|6)))) (cons (let ((.x|9|12 (let ((.x|13|16 .graph|1)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (.check! (pair? .x|9|12) 0 .x|9|12) (car:pair .x|9|12))) '()) (toposort2 .graph|1 '())))) 'toposort))
+(let () (begin (set! toposort2 (lambda (.totry|1 .tried|1) (if (null? .totry|1) #f (if (let ((.temp|4|7 (null? (let ((.x|45|48 (let ((.x|49|52 .totry|1)) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))))) (begin (.check! (pair? .x|45|48) 1 .x|45|48) (cdr:pair .x|45|48)))))) (if .temp|4|7 .temp|4|7 (if (null? (let ((.x|11|14 (let ((.x|15|18 (let ((.x|19|22 .totry|1)) (begin (.check! (pair? .x|19|22) 0 .x|19|22) (car:pair .x|19|22))))) (begin (.check! (pair? .x|15|18) 1 .x|15|18) (cdr:pair .x|15|18))))) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (eq? (let ((.x|25|28 (let ((.x|29|32 (let ((.x|33|36 .totry|1)) (begin (.check! (pair? .x|33|36) 0 .x|33|36) (car:pair .x|33|36))))) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) (let ((.x|37|40 (let ((.x|41|44 .totry|1)) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44))))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) #f))) (if (if (null? (let ((.x|54|57 .totry|1)) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57)))) (null? .tried|1) #f) (cons (let ((.x|61|64 (let ((.x|65|68 .totry|1)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64))) '()) (let* ((.node|71 (let ((.x|116|119 (let ((.x|120|123 .totry|1)) (begin (.check! (pair? .x|120|123) 0 .x|120|123) (car:pair .x|120|123))))) (begin (.check! (pair? .x|116|119) 0 .x|116|119) (car:pair .x|116|119)))) (.x|74 (toposort2 (let () (let ((.loop|83|86|89 (unspecified))) (begin (set! .loop|83|86|89 (lambda (.y1|78|79|90 .results|78|82|90) (if (null? .y1|78|79|90) (reverse .results|78|82|90) (begin #t (.loop|83|86|89 (let ((.x|94|97 .y1|78|79|90)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))) (cons (let ((.y|98 (let ((.x|107|110 .y1|78|79|90)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))))) (cons (let ((.x|99|102 .y|98)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102))) (remove .node|71 (let ((.x|103|106 .y|98)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106)))))) .results|78|82|90)))))) (.loop|83|86|89 (append (let ((.x|111|114 .totry|1)) (begin (.check! (pair? .x|111|114) 1 .x|111|114) (cdr:pair .x|111|114))) .tried|1) '())))) '()))) (let () (if .x|74 (cons .node|71 .x|74) #f)))) (toposort2 (let ((.x|125|128 .totry|1)) (begin (.check! (pair? .x|125|128) 1 .x|125|128) (cdr:pair .x|125|128))) (cons (let ((.x|129|132 .totry|1)) (begin (.check! (pair? .x|129|132) 0 .x|129|132) (car:pair .x|129|132))) .tried|1)))))) 'toposort2))
+(let () (begin (set! iota (lambda (.n|1) (iota2 .n|1 '()))) 'iota))
+(let () (begin (set! iota1 (lambda (.n|1) (let ((.x|2|5 (iota2 (+ .n|1 1) '()))) (begin (.check! (pair? .x|2|5) 1 .x|2|5) (cdr:pair .x|2|5))))) 'iota1))
+(let () (begin (set! iota2 (lambda (.n|1 .l|1) (if (zero? .n|1) .l|1 (let ((.n|4 (- .n|1 1))) (iota2 .n|4 (cons .n|4 .l|1)))))) 'iota2))
+(let () (begin (set! freevariables (lambda (.exp|1) (let ((.freevariables|2 0)) (begin (set! .freevariables|2 (lambda (.exp|3) (freevars2 .exp|3 '()))) (.freevariables|2 .exp|1))))) 'freevariables))
+(let () (begin (set! freevars2 (lambda (.exp|1 .env|1) (let ((.freevars2|2 0)) (begin (set! .freevars2|2 (lambda (.exp|3 .env|3) (if (symbol? .exp|3) (if (memq .exp|3 .env|3) '() (cons .exp|3 '())) (if (not (pair? .exp|3)) '() (let ((.keyword|10 (let ((.x|145|148 .exp|3)) (begin (.check! (pair? .x|145|148) 0 .x|145|148) (car:pair .x|145|148))))) (if (eq? .keyword|10 'quote) '() (if (eq? .keyword|10 'lambda) (let ((.env|15 (append (make-null-terminated (let ((.x|51|54 (let ((.x|55|58 .exp|3)) (begin (.check! (pair? .x|55|58) 1 .x|55|58) (cdr:pair .x|55|58))))) (begin (.check! (pair? .x|51|54) 0 .x|51|54) (car:pair .x|51|54)))) .env|3))) (apply-union (let () (let ((.loop|21|24|27 (unspecified))) (begin (set! .loop|21|24|27 (lambda (.y1|16|17|28 .results|16|20|28) (if (null? .y1|16|17|28) (reverse .results|16|20|28) (begin #t (.loop|21|24|27 (let ((.x|32|35 .y1|16|17|28)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35))) (cons (let ((.x|36 (let ((.x|37|40 .y1|16|17|28)) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40))))) (.freevars2|2 .x|36 .env|15)) .results|16|20|28)))))) (.loop|21|24|27 (let ((.x|42|45 (let ((.x|46|49 .exp|3)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))))) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) '())))))) (if (let ((.t0|60|61|64 .keyword|10) (.t1|60|61|64 '(if set! begin))) (if (eq? .t0|60|61|64 'if) .t1|60|61|64 (let ((.t1|60|61|68 (let ((.x|86|89 .t1|60|61|64)) (begin (.check! (pair? .x|86|89) 1 .x|86|89) (cdr:pair .x|86|89))))) (if (eq? .t0|60|61|64 'set!) .t1|60|61|68 (let ((.t1|60|61|72 (let ((.x|82|85 .t1|60|61|68)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (if (eq? .t0|60|61|64 'begin) .t1|60|61|72 (let ((.t1|60|61|76 (let ((.x|78|81 .t1|60|61|72)) (begin (.check! (pair? .x|78|81) 1 .x|78|81) (cdr:pair .x|78|81))))) #f))))))) (apply-union (let () (let ((.loop|95|98|101 (unspecified))) (begin (set! .loop|95|98|101 (lambda (.y1|90|91|102 .results|90|94|102) (if (null? .y1|90|91|102) (reverse .results|90|94|102) (begin #t (.loop|95|98|101 (let ((.x|106|109 .y1|90|91|102)) (begin (.check! (pair? .x|106|109) 1 .x|106|109) (cdr:pair .x|106|109))) (cons (let ((.x|110 (let ((.x|111|114 .y1|90|91|102)) (begin (.check! (pair? .x|111|114) 0 .x|111|114) (car:pair .x|111|114))))) (.freevars2|2 .x|110 .env|3)) .results|90|94|102)))))) (.loop|95|98|101 (let ((.x|115|118 .exp|3)) (begin (.check! (pair? .x|115|118) 1 .x|115|118) (cdr:pair .x|115|118))) '()))))) (apply-union (let () (let ((.loop|125|128|131 (unspecified))) (begin (set! .loop|125|128|131 (lambda (.y1|120|121|132 .results|120|124|132) (if (null? .y1|120|121|132) (reverse .results|120|124|132) (begin #t (.loop|125|128|131 (let ((.x|136|139 .y1|120|121|132)) (begin (.check! (pair? .x|136|139) 1 .x|136|139) (cdr:pair .x|136|139))) (cons (let ((.x|140 (let ((.x|141|144 .y1|120|121|132)) (begin (.check! (pair? .x|141|144) 0 .x|141|144) (car:pair .x|141|144))))) (.freevars2|2 .x|140 .env|3)) .results|120|124|132)))))) (.loop|125|128|131 .exp|3 '()))))))))))))) (.freevars2|2 .exp|1 .env|1))))) 'freevars2))
+(let () (begin (set! cg-let (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let|2 0)) (begin (set! .cg-let|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.vars|9 (lambda.args .proc|6)) (.n|12 (length .vars|9)) (.free|15 (lambda.f .proc|6)) (.live|18 (cgframe-livevars .frame|3))) (let () (if (if (null? (lambda.defs .proc|6)) (= .n|12 1) #f) (cg-let1 .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|26 (call.args .exp|3)) (.temps|29 (newtemps .n|12)) (.alist|32 (let () (let ((.loop|83|87|90 (unspecified))) (begin (set! .loop|83|87|90 (lambda (.y1|77|79|91 .y1|77|78|91 .results|77|82|91) (if (let ((.temp|93|96 (null? .y1|77|79|91))) (if .temp|93|96 .temp|93|96 (null? .y1|77|78|91))) (reverse .results|77|82|91) (begin #t (.loop|83|87|90 (let ((.x|99|102 .y1|77|79|91)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) (let ((.x|103|106 .y1|77|78|91)) (begin (.check! (pair? .x|103|106) 1 .x|103|106) (cdr:pair .x|103|106))) (cons (cons (let ((.x|107|110 .y1|77|79|91)) (begin (.check! (pair? .x|107|110) 0 .x|107|110) (car:pair .x|107|110))) (let ((.x|111|114 .y1|77|78|91)) (begin (.check! (pair? .x|111|114) 0 .x|111|114) (car:pair .x|111|114)))) .results|77|82|91)))))) (.loop|83|87|90 .temps|29 .vars|9 '())))))) (let () (begin (let () (let ((.loop|42|45|48 (unspecified))) (begin (set! .loop|42|45|48 (lambda (.y1|36|38|49 .y1|36|37|49) (if (let ((.temp|51|54 (null? .y1|36|38|49))) (if .temp|51|54 .temp|51|54 (null? .y1|36|37|49))) (if #f #f (unspecified)) (begin (begin #t (let ((.arg|57 (let ((.x|61|64 .y1|36|38|49)) (begin (.check! (pair? .x|61|64) 0 .x|61|64) (car:pair .x|61|64)))) (.t|57 (let ((.x|65|68 .y1|36|37|49)) (begin (.check! (pair? .x|65|68) 0 .x|65|68) (car:pair .x|65|68))))) (let ((.r|60 (choose-register .regs|3 .frame|3))) (begin (cg0 .output|3 .arg|57 .r|60 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|60 .t|57) (gen-store! .output|3 .frame|3 .r|60 .t|57))))) (.loop|42|45|48 (let ((.x|69|72 .y1|36|38|49)) (begin (.check! (pair? .x|69|72) 1 .x|69|72) (cdr:pair .x|69|72))) (let ((.x|73|76 .y1|36|37|49)) (begin (.check! (pair? .x|73|76) 1 .x|73|76) (cdr:pair .x|73|76)))))))) (.loop|42|45|48 .args|26 .temps|29)))) (cgreg-rename! .regs|3 .alist|32) (cgframe-rename! .frame|3 .alist|32) (cg-let-release! .free|15 .live|18 .regs|3 .frame|3 .tail?|3) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))) (.cg-let|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let))
+(let () (begin (set! cg-let-release! (lambda (.free|1 .live|1 .regs|1 .frame|1 .tail?|1) (let ((.cg-let-release!|2 0)) (begin (set! .cg-let-release!|2 (lambda (.free|3 .live|3 .regs|3 .frame|3 .tail?|3) (if .tail?|3 (let ((.keepers|7 (cons (cgreg-lookup-reg .regs|3 0) .free|3))) (begin (cgreg-release-except! .regs|3 .keepers|7) (cgframe-release-except! .frame|3 .keepers|7))) (if .live|3 (let ((.keepers|11 (cons (cgreg-lookup-reg .regs|3 0) (union .live|3 .free|3)))) (begin (cgreg-release-except! .regs|3 .keepers|11) (cgframe-release-except! .frame|3 .keepers|11))) (unspecified))))) (.cg-let-release!|2 .free|1 .live|1 .regs|1 .frame|1 .tail?|1))))) 'cg-let-release!))
+(let () (begin (set! cg-let-body (lambda (.output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let-body|2 0)) (begin (set! .cg-let-body|2 (lambda (.output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.vars|6 (lambda.args .l|3)) (.free|6 (lambda.f .l|3)) (.live|6 (cgframe-livevars .frame|3))) (let ((.r|9 (cg-body .output|3 .l|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))) (begin (let () (let ((.loop|15|17|20 (unspecified))) (begin (set! .loop|15|17|20 (lambda (.y1|10|11|21) (if (null? .y1|10|11|21) (if #f #f (unspecified)) (begin (begin #t (let* ((.v|25 (let ((.x|29|32 .y1|10|11|21)) (begin (.check! (pair? .x|29|32) 0 .x|29|32) (car:pair .x|29|32)))) (.entry|28 (cgreg-lookup .regs|3 .v|25))) (begin (if .entry|28 (cgreg-release! .regs|3 (entry.regnum .entry|28)) (unspecified)) (cgframe-release! .frame|3 .v|25)))) (.loop|15|17|20 (let ((.x|33|36 .y1|10|11|21)) (begin (.check! (pair? .x|33|36) 1 .x|33|36) (cdr:pair .x|33|36)))))))) (.loop|15|17|20 .vars|6)))) (if (if (not .target|3) (if (not (eq? .r|9 'result)) (not (cgreg-lookup-reg .regs|3 .r|9)) #f) #f) (cg-move .output|3 .frame|3 .regs|3 .r|9 'result) .r|9)))))) (.cg-let-body|2 .output|1 .l|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let-body))
+(let () (begin (set! cg-let1 (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let1|2 0)) (begin (set! .cg-let1|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.v|9 (let ((.x|41|44 (lambda.args .proc|6))) (begin (.check! (pair? .x|41|44) 0 .x|41|44) (car:pair .x|41|44)))) (.arg|12 (let ((.x|37|40 (call.args .exp|3))) (begin (.check! (pair? .x|37|40) 0 .x|37|40) (car:pair .x|37|40)))) (.free|15 (lambda.f .proc|6)) (.live|18 (cgframe-livevars .frame|3)) (.body|21 (lambda.body .proc|6))) (let () (let ((.finish|25 (unspecified)) (.release-registers!|25 (unspecified)) (.evaluate-into-register|25 (unspecified))) (begin (set! .finish|25 (lambda () (begin (.release-registers!|25) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))) (set! .release-registers!|25 (lambda () (begin (cgframe-livevars-set! .frame|3 .live|18) (cg-let-release! .free|15 .live|18 .regs|3 .frame|3 .tail?|3)))) (set! .evaluate-into-register|25 (lambda (.r|28) (begin (cg0 .output|3 .arg|12 .r|28 .regs|3 .frame|3 .env|3 #f) (cgreg-bind! .regs|3 .r|28 .v|9) (gen-store! .output|3 .frame|3 .r|28 .v|9) .r|28))) (if .live|18 (cgframe-livevars-set! .frame|3 (union .live|18 .free|15)) (unspecified)) (if (assq .v|9 *regnames*) (begin (.evaluate-into-register|25 (let ((.x|30|33 (assq .v|9 *regnames*))) (begin (.check! (pair? .x|30|33) 1 .x|30|33) (cdr:pair .x|30|33)))) (.finish|25)) (if (not (memq .v|9 .free|15)) (begin (cg0 .output|3 .arg|12 #f .regs|3 .frame|3 .env|3 #f) (.finish|25)) (if .live|18 (begin (cg0 .output|3 .arg|12 'result .regs|3 .frame|3 .env|3 #f) (.release-registers!|25) (cg-let1-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (begin (.evaluate-into-register|25 (choose-register .regs|3 .frame|3)) (.finish|25))))))))))) (.cg-let1|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let1))
+(let () (begin (set! cg-let1-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-let1-result|2 0)) (begin (set! .cg-let1-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.proc|6 (call.proc .exp|3)) (.v|9 (let ((.x|63|66 (lambda.args .proc|6))) (begin (.check! (pair? .x|63|66) 0 .x|63|66) (car:pair .x|63|66)))) (.free|12 (lambda.f .proc|6)) (.live|15 (cgframe-livevars .frame|3)) (.body|18 (lambda.body .proc|6)) (.pattern|21 (cg-let-used-once .v|9 .body|18))) (let () (let ((.release-registers!|26 (unspecified)) (.move-to-register|26 (unspecified))) (begin (set! .release-registers!|26 (lambda () (begin (cgframe-livevars-set! .frame|3 .live|15) (cg-let-release! .free|12 .live|15 .regs|3 .frame|3 .tail?|3)))) (set! .move-to-register|26 (lambda (.r|28) (begin (gen! .output|3 $setreg .r|28) (cgreg-bind! .regs|3 .r|28 .v|9) (gen-store! .output|3 .frame|3 .r|28 .v|9) .r|28))) (let ((.temp|25|31 .pattern|21)) (if (memv .temp|25|31 '(if)) (cg-if-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-if)) (begin (if .live|15 (cgframe-livevars-set! .frame|3 (union .live|15 .free|12)) (unspecified)) (cg-if-result .output|3 (let ((.x|34|37 (call.args .body|18))) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))) 'result .regs|3 .frame|3 .env|3 #f) (.release-registers!|26) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(set!)) (cg-assignment-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-set!)) (begin (cg-assignment-result .output|3 (let ((.x|40|43 (call.args .body|18))) (begin (.check! (pair? .x|40|43) 0 .x|40|43) (car:pair .x|40|43))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(primop)) (cg-primop-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(let-primop)) (begin (cg-primop-result .output|3 (let ((.x|46|49 (call.args .body|18))) (begin (.check! (pair? .x|46|49) 0 .x|46|49) (car:pair .x|46|49))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (if (memv .temp|25|31 '(_called)) (cg-call-result .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (if (memv .temp|25|31 '(_let-called)) (begin (cg-call-result .output|3 (let ((.x|52|55 (call.args .body|18))) (begin (.check! (pair? .x|52|55) 0 .x|52|55) (car:pair .x|52|55))) 'result .regs|3 .frame|3 .env|3 #f) (.cg-let1-result|2 .output|3 .body|18 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)) (begin (if (assq .v|9 *regnames*) (.move-to-register|26 (let ((.x|58|61 (assq .v|9 *regnames*))) (begin (.check! (pair? .x|58|61) 1 .x|58|61) (cdr:pair .x|58|61)))) (if (memq .v|9 .free|12) (.move-to-register|26 (choose-register .regs|3 .frame|3)) (unspecified))) (cg-let-body .output|3 .proc|6 .target|3 .regs|3 .frame|3 .env|3 .tail?|3))))))))))))))))) (.cg-let1-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-let1-result))
+(let () (begin (set! cg-primop-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-primop-result|2 0)) (begin (set! .cg-primop-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.args|6 (call.args .exp|3)) (.entry|6 (var-lookup (variable.name (call.proc .exp|3)) .regs|3 .frame|3 .env|3))) (if (= (entry.arity .entry|6) (length .args|6)) (begin (let ((.temp|7|10 (entry.arity .entry|6))) (if (memv .temp|7|10 '(0)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(1)) (gen! .output|3 $op1 (entry.op .entry|6)) (if (memv .temp|7|10 '(2)) (cg-primop2-result! .output|3 .entry|6 .args|6 .regs|3 .frame|3 .env|3) (if (memv .temp|7|10 '(3)) (let ((.rs|17 (cg-result-args .output|3 .args|6 .regs|3 .frame|3 .env|3))) (gen! .output|3 $op3 (entry.op .entry|6) (let ((.x|18|21 .rs|17)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (let ((.x|23|26 (let ((.x|27|30 .rs|17)) (begin (.check! (pair? .x|27|30) 1 .x|27|30) (cdr:pair .x|27|30))))) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))))) (error "Bug detected by cg-primop-result" (make-readable .exp|3))))))) (if .tail?|3 (begin (gen-pop! .output|3 .frame|3) (gen! .output|3 $return) 'result) (cg-move .output|3 .frame|3 .regs|3 'result .target|3))) (if (< (entry.arity .entry|6) 0) (cg-special-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (error "Wrong number of arguments to integrable procedure" (make-readable .exp|3))))))) (.cg-primop-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-primop-result))
+(let () (begin (set! cg-primop2-result! (lambda (.output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-primop2-result!|2 0)) (begin (set! .cg-primop2-result!|2 (lambda (.output|3 .entry|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.op|6 (entry.op .entry|3)) (.arg2|6 (let ((.x|18|21 (let ((.x|22|25 .args|3)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))))) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))))) (if (if (constant? .arg2|6) (if (entry.imm .entry|3) ((entry.imm .entry|3) (constant.value .arg2|6)) #f) #f) (gen! .output|3 $op2imm .op|6 (constant.value .arg2|6)) (let ((.rs|12 (cg-result-args .output|3 .args|3 .regs|3 .frame|3 .env|3))) (gen! .output|3 $op2 .op|6 (let ((.x|13|16 .rs|12)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))))))) (.cg-primop2-result!|2 .output|1 .entry|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-primop2-result!))
+(let () (begin (set! cg-result-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-result-args|2 0)) (begin (set! .cg-result-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.save-result!|4 (unspecified)) (.loop|4 (unspecified))) (begin (set! .save-result!|4 (lambda (.args|5 .registers|5 .rr|5 .rs|5 .temps|5) (let ((.r|8 (let ((.x|13|16 .registers|5)) (begin (.check! (pair? .x|13|16) 0 .x|13|16) (car:pair .x|13|16))))) (begin (gen! .output|3 $setreg .r|8) (.loop|4 .args|5 (let ((.x|9|12 .registers|5)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12))) .r|8 .rs|5 .temps|5))))) (set! .loop|4 (lambda (.args|17 .registers|17 .rr|17 .rs|17 .temps|17) (if (null? .args|17) (begin (if (not (eq? .rr|17 'result)) (gen! .output|3 $reg .rr|17) (unspecified)) (let () (let ((.loop|23|25|28 (unspecified))) (begin (set! .loop|23|25|28 (lambda (.y1|18|19|29) (if (null? .y1|18|19|29) (if #f #f (unspecified)) (begin (begin #t (let ((.r|33 (let ((.x|34|37 .y1|18|19|29)) (begin (.check! (pair? .x|34|37) 0 .x|34|37) (car:pair .x|34|37))))) (cgreg-release! .regs|3 .r|33))) (.loop|23|25|28 (let ((.x|38|41 .y1|18|19|29)) (begin (.check! (pair? .x|38|41) 1 .x|38|41) (cdr:pair .x|38|41)))))))) (.loop|23|25|28 .temps|17)))) (reverse .rs|17)) (let ((.arg|44 (let ((.x|134|137 .args|17)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137))))) (if (constant? .arg|44) (let ((.r|48 (let ((.x|57|60 .registers|17)) (begin (.check! (pair? .x|57|60) 0 .x|57|60) (car:pair .x|57|60))))) (begin (gen! .output|3 $const/setreg (constant.value .arg|44) .r|48) (cgreg-bind! .regs|3 .r|48 #t) (.loop|4 (let ((.x|49|52 .args|17)) (begin (.check! (pair? .x|49|52) 1 .x|49|52) (cdr:pair .x|49|52))) (let ((.x|53|56 .registers|17)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))) .rr|17 (cons .r|48 .rs|17) (cons .r|48 .temps|17)))) (if (variable? .arg|44) (let* ((.id|64 (variable.name .arg|44)) (.entry|67 (var-lookup .id|64 .regs|3 .frame|3 .env|3))) (let () (let ((.temp|71|74 (entry.kind .entry|67))) (if (memv .temp|71|74 '(global integrable)) (if (eq? .rr|17 'result) (.save-result!|4 .args|17 .registers|17 .rr|17 .rs|17 .temps|17) (let ((.r|78 (let ((.x|87|90 .registers|17)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (begin (gen! .output|3 $global .id|64) (gen! .output|3 $setreg .r|78) (cgreg-bind! .regs|3 .r|78 .id|64) (.loop|4 (let ((.x|79|82 .args|17)) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))) (let ((.x|83|86 .registers|17)) (begin (.check! (pair? .x|83|86) 1 .x|83|86) (cdr:pair .x|83|86))) .rr|17 (cons .r|78 .rs|17) (cons .r|78 .temps|17))))) (if (memv .temp|71|74 '(lexical)) (if (eq? .rr|17 'result) (.save-result!|4 .args|17 .registers|17 .rr|17 .rs|17 .temps|17) (let ((.m|94 (entry.rib .entry|67)) (.n|94 (entry.offset .entry|67)) (.r|94 (let ((.x|103|106 .registers|17)) (begin (.check! (pair? .x|103|106) 0 .x|103|106) (car:pair .x|103|106))))) (begin (gen! .output|3 $lexical .m|94 .n|94 .id|64) (gen! .output|3 $setreg .r|94) (cgreg-bind! .regs|3 .r|94 .id|64) (.loop|4 (let ((.x|95|98 .args|17)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))) (let ((.x|99|102 .registers|17)) (begin (.check! (pair? .x|99|102) 1 .x|99|102) (cdr:pair .x|99|102))) .rr|17 (cons .r|94 .rs|17) (cons .r|94 .temps|17))))) (if (memv .temp|71|74 '(procedure)) (error "Bug in cg-variable" .arg|44) (if (memv .temp|71|74 '(register)) (let ((.r|111 (entry.regnum .entry|67))) (.loop|4 (let ((.x|112|115 .args|17)) (begin (.check! (pair? .x|112|115) 1 .x|112|115) (cdr:pair .x|112|115))) .registers|17 .rr|17 (cons .r|111 .rs|17) .temps|17)) (if (memv .temp|71|74 '(frame)) (let ((.r|119 (let ((.x|128|131 .registers|17)) (begin (.check! (pair? .x|128|131) 0 .x|128|131) (car:pair .x|128|131))))) (begin (gen-load! .output|3 .frame|3 .r|119 .id|64) (cgreg-bind! .regs|3 .r|119 .id|64) (.loop|4 (let ((.x|120|123 .args|17)) (begin (.check! (pair? .x|120|123) 1 .x|120|123) (cdr:pair .x|120|123))) (let ((.x|124|127 .registers|17)) (begin (.check! (pair? .x|124|127) 1 .x|124|127) (cdr:pair .x|124|127))) .rr|17 (cons .r|119 .rs|17) (cons .r|119 .temps|17)))) (error "Bug in cg-result-args" .arg|44))))))))) (error "Bug in cg-result-args"))))))) (.loop|4 (let ((.x|138|141 .args|3)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141))) (choose-registers .regs|3 .frame|3 (length .args|3)) 'result '() '()))))) (.cg-result-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-result-args))
+(let () (begin (set! cg-let-used-once (lambda (.t1|1 .exp|1) (let ((.cg-let-used-once|2 0)) (begin (set! .cg-let-used-once|2 (lambda (.t1|3 .exp|3) (let ((.cg-let-used-once|4 (unspecified)) (.budget|4 (unspecified))) (begin (set! .cg-let-used-once|4 (lambda (.t1|5 .exp|5) (let ((.used-in-args?|6 (unspecified)) (.used?|6 (unspecified))) (begin (set! .used-in-args?|6 (lambda (.t1|7 .args|7) (if (null? .args|7) #f (let ((.temp|8|11 (.used?|6 .t1|7 (let ((.x|17|20 .args|7)) (begin (.check! (pair? .x|17|20) 0 .x|17|20) (car:pair .x|17|20)))))) (if .temp|8|11 .temp|8|11 (.used-in-args?|6 .t1|7 (let ((.x|13|16 .args|7)) (begin (.check! (pair? .x|13|16) 1 .x|13|16) (cdr:pair .x|13|16))))))))) (set! .used?|6 (lambda (.t1|21 .exp|21) (begin (set! .budget|4 (- .budget|4 1)) (if (< .budget|4 0) #t (if (constant? .exp|21) #f (if (variable? .exp|21) (eq? .t1|21 (variable.name .exp|21)) (if (lambda? .exp|21) (memq .t1|21 (lambda.f .exp|21)) (if (assignment? .exp|21) (.used?|6 .t1|21 (assignment.rhs .exp|21)) (if (call? .exp|21) (let ((.temp|29|32 (.used?|6 .t1|21 (call.proc .exp|21)))) (if .temp|29|32 .temp|29|32 (.used-in-args?|6 .t1|21 (call.args .exp|21)))) (if (conditional? .exp|21) (let ((.temp|35|38 (.used?|6 .t1|21 (if.test .exp|21)))) (if .temp|35|38 .temp|35|38 (let ((.temp|39|42 (.used?|6 .t1|21 (if.then .exp|21)))) (if .temp|39|42 .temp|39|42 (.used?|6 .t1|21 (if.else .exp|21)))))) #t)))))))))) (set! .budget|4 (- .budget|4 1)) (if (< .budget|4 0) #f (if (call? .exp|5) (let ((.proc|50 (call.proc .exp|5)) (.args|50 (call.args .exp|5))) (if (variable? .proc|50) (let ((.f|54 (variable.name .proc|50))) (if (eq? .f|54 .t1|5) (if (not (.used-in-args?|6 .t1|5 .args|50)) 'called #f) (if (if (integrable? .f|54) (if (not (null? .args|50)) (if (variable? (let ((.x|62|65 .args|50)) (begin (.check! (pair? .x|62|65) 0 .x|62|65) (car:pair .x|62|65)))) (eq? .t1|5 (variable.name (let ((.x|67|70 .args|50)) (begin (.check! (pair? .x|67|70) 0 .x|67|70) (car:pair .x|67|70))))) #f) #f) #f) (if (not (.used-in-args?|6 .t1|5 (let ((.x|72|75 .args|50)) (begin (.check! (pair? .x|72|75) 1 .x|72|75) (cdr:pair .x|72|75))))) 'primop #f) #f))) (if (lambda? .proc|50) (if (not (memq .t1|5 (lambda.f .proc|50))) (if (not (null? .args|50)) (if (null? (let ((.x|82|85 .args|50)) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85)))) (let ((.temp|87|90 (.cg-let-used-once|4 .t1|5 (let ((.x|96|99 .args|50)) (begin (.check! (pair? .x|96|99) 0 .x|96|99) (car:pair .x|96|99)))))) (if (memv .temp|87|90 '(if)) 'let-if (if (memv .temp|87|90 '(primop)) 'let-primop (if (memv .temp|87|90 '(called)) 'let-called (if (memv .temp|87|90 '(set!)) 'let-set! #f))))) #f) #f) #f) #f))) (if (conditional? .exp|5) (let ((.e0|104 (if.test .exp|5))) (if (variable? .e0|104) (if (eq? .t1|5 (variable.name .e0|104)) (if (not (.used?|6 .t1|5 (if.then .exp|5))) (if (not (.used?|6 .t1|5 (if.else .exp|5))) 'if #f) #f) #f) #f)) (if (assignment? .exp|5) (let ((.rhs|113 (assignment.rhs .exp|5))) (if (variable? .rhs|113) (if (eq? .t1|5 (variable.name .rhs|113)) 'set! #f) #f)) #f)))))))) (set! .budget|4 20) (.cg-let-used-once|4 .t1|3 .exp|3))))) (.cg-let-used-once|2 .t1|1 .exp|1))))) 'cg-let-used-once))
+(let () (begin (set! cg-let-transform (lambda (.pattern|1 .exp|1 .e1|1) (let ((.cg-let-transform|2 0)) (begin (set! .cg-let-transform|2 (lambda (.pattern|3 .exp|3 .e1|3) (let ((.temp|4|7 .pattern|3)) (if (memv .temp|4|7 '(if)) (make-conditional .e1|3 (if.then .exp|3) (if.else .exp|3)) (if (memv .temp|4|7 '(primop)) (make-call (call.proc .exp|3) (cons .e1|3 (let ((.x|10|13 (call.args .exp|3))) (begin (.check! (pair? .x|10|13) 1 .x|10|13) (cdr:pair .x|10|13))))) (if (memv .temp|4|7 '(called)) (make-call .e1|3 (call.args .exp|3)) (if (memv .temp|4|7 '(set!)) (make-assignment (assignment.lhs .exp|3) .e1|3) (if (memv .temp|4|7 '(let-if let-primop let-called let-set!)) (make-call (call.proc .exp|3) (cons (.cg-let-transform|2 (let ((.temp|18|21 .pattern|3)) (if (memv .temp|18|21 '(let-if)) 'if (if (memv .temp|18|21 '(let-primop)) 'primop (if (memv .temp|18|21 '(let-called)) 'called (if (memv .temp|18|21 '(let-set!)) 'set! (unspecified)))))) (let ((.x|26|29 (call.args .exp|3))) (begin (.check! (pair? .x|26|29) 0 .x|26|29) (car:pair .x|26|29))) .e1|3) '())) (error "Unrecognized pattern in cg-let-transform" .pattern|3))))))))) (.cg-let-transform|2 .pattern|1 .exp|1 .e1|1))))) 'cg-let-transform))
+(let () (begin (set! cg-special (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-special|2 0)) (begin (set! .cg-special|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.name|6 (variable.name (call.proc .exp|3)))) (if (eq? .name|6 name:check!) (if (runtime-safety-checking) (cg-check .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (unspecified)) (error "Compiler bug: cg-special" (make-readable .exp|3)))))) (.cg-special|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-special))
+(let () (begin (set! cg-special-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-special-result|2 0)) (begin (set! .cg-special-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let ((.name|6 (variable.name (call.proc .exp|3)))) (if (eq? .name|6 name:check!) (if (runtime-safety-checking) (cg-check-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (unspecified)) (error "Compiler bug: cg-special" (make-readable .exp|3)))))) (.cg-special-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-special-result))
+(let () (begin (set! cg-check (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-check|2 0)) (begin (set! .cg-check|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (begin (cg0 .output|3 (let ((.x|4|7 (call.args .exp|3))) (begin (.check! (pair? .x|4|7) 0 .x|4|7) (car:pair .x|4|7))) 'result .regs|3 .frame|3 .env|3 #f) (cg-check-result .output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3)))) (.cg-check|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-check))
+(let () (begin (set! cg-check-result (lambda (.output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1) (let ((.cg-check-result|2 0)) (begin (set! .cg-check-result|2 (lambda (.output|3 .exp|3 .target|3 .regs|3 .frame|3 .env|3 .tail?|3) (let* ((.args|6 (call.args .exp|3)) (.nargs|9 (length .args|6)) (.valexps|12 (let ((.x|173|176 (let ((.x|177|180 .args|6)) (begin (.check! (pair? .x|177|180) 1 .x|177|180) (cdr:pair .x|177|180))))) (begin (.check! (pair? .x|173|176) 1 .x|173|176) (cdr:pair .x|173|176))))) (let () (if (if (let ((.t|17|20 .nargs|9)) (if (<= 2 .t|17|20) (<= .t|17|20 5) #f)) (if (constant? (let ((.x|25|28 (let ((.x|29|32 .args|6)) (begin (.check! (pair? .x|29|32) 1 .x|29|32) (cdr:pair .x|29|32))))) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28)))) (every? (lambda (.exp|34) (let ((.temp|35|38 (constant? .exp|34))) (if .temp|35|38 .temp|35|38 (variable? .exp|34)))) .valexps|12) #f) #f) (let* ((.exn|42 (constant.value (let ((.x|164|167 (let ((.x|168|171 .args|6)) (begin (.check! (pair? .x|168|171) 1 .x|168|171) (cdr:pair .x|168|171))))) (begin (.check! (pair? .x|164|167) 0 .x|164|167) (car:pair .x|164|167))))) (.vars|45 (filter variable? .valexps|12)) (.rs|48 (cg-result-args .output|3 (cons (let ((.x|159|162 .args|6)) (begin (.check! (pair? .x|159|162) 0 .x|159|162) (car:pair .x|159|162))) .vars|45) .regs|3 .frame|3 .env|3))) (let () (let ((.registers|54 .rs|48) (.exps|54 .valexps|12) (.operands|54 '())) (let () (let ((.loop|57 (unspecified))) (begin (set! .loop|57 (lambda (.registers|58 .exps|58 .operands|58) (if (null? .exps|58) (let* ((.situation|62 (cons .exn|42 (reverse .operands|58))) (.ht|65 (assembly-stream-info .output|3)) (.l1|68 (let ((.temp|125|128 (hashtable-get .ht|65 .situation|62))) (if .temp|125|128 .temp|125|128 (let ((.l1|132 (make-label))) (begin (hashtable-put! .ht|65 .situation|62 .l1|132) .l1|132)))))) (let () (let ((.translate|73 (unspecified))) (begin (set! .translate|73 (lambda (.r|74) (if (number? .r|74) .r|74 0))) (let ((.temp|72|77 (length .operands|58))) (if (memv .temp|72|77 '(0)) (gen! .output|3 $check 0 0 0 .l1|68) (if (memv .temp|72|77 '(1)) (gen! .output|3 $check (.translate|73 (let ((.x|80|83 .operands|58)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83)))) 0 0 .l1|68) (if (memv .temp|72|77 '(2)) (gen! .output|3 $check (.translate|73 (let ((.x|85|88 .operands|58)) (begin (.check! (pair? .x|85|88) 0 .x|85|88) (car:pair .x|85|88)))) (.translate|73 (let ((.x|90|93 (let ((.x|94|97 .operands|58)) (begin (.check! (pair? .x|94|97) 1 .x|94|97) (cdr:pair .x|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93)))) 0 .l1|68) (if (memv .temp|72|77 '(3)) (gen! .output|3 $check (.translate|73 (let ((.x|99|102 .operands|58)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.translate|73 (let ((.x|104|107 (let ((.x|108|111 .operands|58)) (begin (.check! (pair? .x|108|111) 1 .x|108|111) (cdr:pair .x|108|111))))) (begin (.check! (pair? .x|104|107) 0 .x|104|107) (car:pair .x|104|107)))) (.translate|73 (let ((.x|113|116 (let ((.x|117|120 (let ((.x|121|124 .operands|58)) (begin (.check! (pair? .x|121|124) 1 .x|121|124) (cdr:pair .x|121|124))))) (begin (.check! (pair? .x|117|120) 1 .x|117|120) (cdr:pair .x|117|120))))) (begin (.check! (pair? .x|113|116) 0 .x|113|116) (car:pair .x|113|116)))) .l1|68) (unspecified)))))))))) (if (constant? (let ((.x|134|137 .exps|58)) (begin (.check! (pair? .x|134|137) 0 .x|134|137) (car:pair .x|134|137)))) (.loop|57 .registers|58 (let ((.x|138|141 .exps|58)) (begin (.check! (pair? .x|138|141) 1 .x|138|141) (cdr:pair .x|138|141))) (cons (let ((.x|142|145 .exps|58)) (begin (.check! (pair? .x|142|145) 0 .x|142|145) (car:pair .x|142|145))) .operands|58)) (.loop|57 (let ((.x|147|150 .registers|58)) (begin (.check! (pair? .x|147|150) 1 .x|147|150) (cdr:pair .x|147|150))) (let ((.x|151|154 .exps|58)) (begin (.check! (pair? .x|151|154) 1 .x|151|154) (cdr:pair .x|151|154))) (cons (let ((.x|155|158 .registers|58)) (begin (.check! (pair? .x|155|158) 0 .x|155|158) (car:pair .x|155|158))) .operands|58)))))) (.loop|57 .registers|54 .exps|54 .operands|54))))))) (error "Compiler bug: runtime check" (make-readable .exp|3))))))) (.cg-check-result|2 .output|1 .exp|1 .target|1 .regs|1 .frame|1 .env|1 .tail?|1))))) 'cg-check-result))
+(let () (begin (set! cg-trap (lambda (.output|1 .situation|1 .l1|1) (let ((.cg-trap|2 0)) (begin (set! .cg-trap|2 (lambda (.output|3 .situation|3 .l1|3) (let* ((.exn|6 (let ((.x|99|102 .situation|3)) (begin (.check! (pair? .x|99|102) 0 .x|99|102) (car:pair .x|99|102)))) (.operands|9 (let ((.x|95|98 .situation|3)) (begin (.check! (pair? .x|95|98) 1 .x|95|98) (cdr:pair .x|95|98))))) (let () (begin (gen! .output|3 $.label .l1|3) (let* ((.liveregs|15 (filter number? .operands|9)) (.loop|16 (unspecified))) (begin (set! .loop|16 (lambda (.operands|17 .registers|17 .r|17) (if (null? .operands|17) (let ((.temp|19|22 (length .registers|17))) (if (memv .temp|19|22 '(0)) (gen! .output|3 $trap 0 0 0 .exn|6) (if (memv .temp|19|22 '(1)) (gen! .output|3 $trap (let ((.x|25|28 .registers|17)) (begin (.check! (pair? .x|25|28) 0 .x|25|28) (car:pair .x|25|28))) 0 0 .exn|6) (if (memv .temp|19|22 '(2)) (gen! .output|3 $trap (let ((.x|30|33 .registers|17)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33))) (let ((.x|35|38 (let ((.x|39|42 .registers|17)) (begin (.check! (pair? .x|39|42) 1 .x|39|42) (cdr:pair .x|39|42))))) (begin (.check! (pair? .x|35|38) 0 .x|35|38) (car:pair .x|35|38))) 0 .exn|6) (if (memv .temp|19|22 '(3)) (gen! .output|3 $trap (let ((.x|44|47 .registers|17)) (begin (.check! (pair? .x|44|47) 0 .x|44|47) (car:pair .x|44|47))) (let ((.x|49|52 (let ((.x|53|56 .registers|17)) (begin (.check! (pair? .x|53|56) 1 .x|53|56) (cdr:pair .x|53|56))))) (begin (.check! (pair? .x|49|52) 0 .x|49|52) (car:pair .x|49|52))) (let ((.x|58|61 (let ((.x|62|65 (let ((.x|66|69 .registers|17)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))))) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) .exn|6) "Compiler bug: trap"))))) (if (number? (let ((.x|72|75 .operands|17)) (begin (.check! (pair? .x|72|75) 0 .x|72|75) (car:pair .x|72|75)))) (.loop|16 (let ((.x|76|79 .operands|17)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons (let ((.x|80|83 .operands|17)) (begin (.check! (pair? .x|80|83) 0 .x|80|83) (car:pair .x|80|83))) .registers|17) .r|17) (if (memv .r|17 .liveregs|15) (.loop|16 .operands|17 .registers|17 (+ .r|17 1)) (begin (gen! .output|3 $const (constant.value (let ((.x|87|90 .operands|17)) (begin (.check! (pair? .x|87|90) 0 .x|87|90) (car:pair .x|87|90))))) (gen! .output|3 $setreg .r|17) (.loop|16 (let ((.x|91|94 .operands|17)) (begin (.check! (pair? .x|91|94) 1 .x|91|94) (cdr:pair .x|91|94))) (cons .r|17 .registers|17) (+ .r|17 1)))))))) (.loop|16 (reverse .operands|9) '() 1)))))))) (.cg-trap|2 .output|1 .situation|1 .l1|1))))) 'cg-trap))
+(let () (begin (set! cg-check-args (lambda (.output|1 .args|1 .regs|1 .frame|1 .env|1) (let ((.cg-check-args|2 0)) (begin (set! .cg-check-args|2 (lambda (.output|3 .args|3 .regs|3 .frame|3 .env|3) (let ((.finish-loop|4 (unspecified)) (.eval-first-into-result|4 (unspecified)) (.eval-loop|4 (unspecified))) (begin (set! .finish-loop|4 (lambda (.disjoint|5 .temps|5 .mask|5 .registers|5) (if (null? .temps|5) .registers|5 (let* ((.t|8 (let ((.x|54|57 .temps|5)) (begin (.check! (pair? .x|54|57) 0 .x|54|57) (car:pair .x|54|57)))) (.entry|11 (cgreg-lookup .regs|3 .t|8))) (let () (if .entry|11 (let ((.r|17 (entry.regnum .entry|11))) (begin (if (let ((.x|18|21 .mask|5)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) (begin (cgreg-release! .regs|3 .r|17) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|22|25 .temps|5)) (begin (.check! (pair? .x|22|25) 1 .x|22|25) (cdr:pair .x|22|25))) (let ((.x|26|29 .mask|5)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29))) (cons .r|17 .registers|5)))) (let ((.r|32 (let ((.x|50|53 .disjoint|5)) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .r|32 .registers|5) (.finish-loop|4 (let ((.x|34|37 .disjoint|5)) (begin (.check! (pair? .x|34|37) 1 .x|34|37) (cdr:pair .x|34|37))) .temps|5 .mask|5 .registers|5) (begin (gen-load! .output|3 .frame|3 .r|32 .t|8) (cgreg-bind! .regs|3 .r|32 .t|8) (if (let ((.x|38|41 .mask|5)) (begin (.check! (pair? .x|38|41) 0 .x|38|41) (car:pair .x|38|41))) (begin (cgreg-release! .regs|3 .r|32) (cgframe-release! .frame|3 .t|8)) (unspecified)) (.finish-loop|4 .disjoint|5 (let ((.x|42|45 .temps|5)) (begin (.check! (pair? .x|42|45) 1 .x|42|45) (cdr:pair .x|42|45))) (let ((.x|46|49 .mask|5)) (begin (.check! (pair? .x|46|49) 1 .x|46|49) (cdr:pair .x|46|49))) (cons .r|32 .registers|5))))))))))) (set! .eval-first-into-result|4 (lambda (.temps|58 .mask|58) (begin (cg0 .output|3 (let ((.x|59|62 .args|3)) (begin (.check! (pair? .x|59|62) 0 .x|59|62) (car:pair .x|59|62))) 'result .regs|3 .frame|3 .env|3 #f) (.finish-loop|4 (choose-registers .regs|3 .frame|3 (length .temps|58)) .temps|58 .mask|58 '())))) (set! .eval-loop|4 (lambda (.args|63 .temps|63 .mask|63) (if (null? .args|63) (.eval-first-into-result|4 .temps|63 .mask|63) (let ((.reg|66 (cg0 .output|3 (let ((.x|84|87 .args|63)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) #f .regs|3 .frame|3 .env|3 #f))) (if (eq? .reg|66 'result) (let* ((.r|69 (choose-register .regs|3 .frame|3)) (.t|72 (newtemp))) (let () (begin (gen! .output|3 $setreg .r|69) (cgreg-bind! .regs|3 .r|69 .t|72) (gen-store! .output|3 .frame|3 .r|69 .t|72) (.eval-loop|4 (let ((.x|76|79 .args|63)) (begin (.check! (pair? .x|76|79) 1 .x|76|79) (cdr:pair .x|76|79))) (cons .t|72 .temps|63) (cons #t .mask|63))))) (.eval-loop|4 (let ((.x|80|83 .args|63)) (begin (.check! (pair? .x|80|83) 1 .x|80|83) (cdr:pair .x|80|83))) (cons (cgreg-lookup-reg .regs|3 .reg|66) .temps|63) (cons #f .mask|63))))))) (if (< (length .args|3) *nregs*) (.eval-loop|4 (let ((.x|88|91 .args|3)) (begin (.check! (pair? .x|88|91) 1 .x|88|91) (cdr:pair .x|88|91))) '() '()) (error "Bug detected by cg-primop-args" .args|3)))))) (.cg-check-args|2 .output|1 .args|1 .regs|1 .frame|1 .env|1))))) 'cg-check-args))
+(let () (begin (set! filter-basic-blocks (let* ((.suppression-message|3 "Local optimization detected a useless instruction.") (.forward:normal|6 0) (.forward:nop|9 1) (.forward:ends-block|12 2) (.forward:interesting|15 3) (.forward:kills-all-registers|18 4) (.forward:nop-if-arg1-is-negative|21 5) (.backward:normal|24 0) (.backward:ends-block|27 1) (.backward:begins-block|30 2) (.backward:uses-arg1|33 4) (.backward:uses-arg2|36 8) (.backward:uses-arg3|39 16) (.backward:kills-arg1|42 32) (.backward:kills-arg2|45 64) (.backward:uses-many|48 128) (.dispatch-table-size|51 *number-of-mnemonics*) (.forward-table|54 (make-bytevector .dispatch-table-size|51)) (.backward-table|57 (make-bytevector .dispatch-table-size|51))) (let () (begin (let () (let ((.loop|62|64|67 (unspecified))) (begin (set! .loop|62|64|67 (lambda (.i|68) (if (= .i|68 .dispatch-table-size|51) (if #f #f (unspecified)) (begin (begin #t (bytevector-set! .forward-table|54 .i|68 .forward:normal|6) (bytevector-set! .backward-table|57 .i|68 .backward:normal|24)) (.loop|62|64|67 (+ .i|68 1)))))) (.loop|62|64|67 0)))) (bytevector-set! .forward-table|54 $nop .forward:nop|9) (bytevector-set! .forward-table|54 $invoke .forward:ends-block|12) (bytevector-set! .forward-table|54 $return .forward:ends-block|12) (bytevector-set! .forward-table|54 $skip .forward:ends-block|12) (bytevector-set! .forward-table|54 $branch .forward:ends-block|12) (bytevector-set! .forward-table|54 $branchf .forward:ends-block|12) (bytevector-set! .forward-table|54 $jump .forward:ends-block|12) (bytevector-set! .forward-table|54 $.align .forward:ends-block|12) (bytevector-set! .forward-table|54 $.proc .forward:ends-block|12) (bytevector-set! .forward-table|54 $.cont .forward:ends-block|12) (bytevector-set! .forward-table|54 $.label .forward:ends-block|12) (bytevector-set! .forward-table|54 $store .forward:interesting|15) (bytevector-set! .forward-table|54 $load .forward:interesting|15) (bytevector-set! .forward-table|54 $setstk .forward:interesting|15) (bytevector-set! .forward-table|54 $setreg .forward:interesting|15) (bytevector-set! .forward-table|54 $movereg .forward:interesting|15) (bytevector-set! .forward-table|54 $const/setreg .forward:interesting|15) (bytevector-set! .forward-table|54 $args>= .forward:kills-all-registers|18) (bytevector-set! .forward-table|54 $popstk .forward:kills-all-registers|18) (bytevector-set! .forward-table|54 $save .forward:nop-if-arg1-is-negative|21) (bytevector-set! .forward-table|54 $restore .forward:nop-if-arg1-is-negative|21) (bytevector-set! .forward-table|54 $pop .forward:nop-if-arg1-is-negative|21) (bytevector-set! .backward-table|57 $invoke .backward:ends-block|27) (bytevector-set! .backward-table|57 $return .backward:ends-block|27) (bytevector-set! .backward-table|57 $skip .backward:ends-block|27) (bytevector-set! .backward-table|57 $branch .backward:ends-block|27) (bytevector-set! .backward-table|57 $branchf .backward:ends-block|27) (bytevector-set! .backward-table|57 $jump .backward:begins-block|30) (bytevector-set! .backward-table|57 $.align .backward:begins-block|30) (bytevector-set! .backward-table|57 $.proc .backward:begins-block|30) (bytevector-set! .backward-table|57 $.cont .backward:begins-block|30) (bytevector-set! .backward-table|57 $.label .backward:begins-block|30) (bytevector-set! .backward-table|57 $op2 .backward:uses-arg2|36) (bytevector-set! .backward-table|57 $op3 (logior .backward:uses-arg2|36 .backward:uses-arg3|39)) (bytevector-set! .backward-table|57 $check (logior .backward:uses-arg1|33 (logior .backward:uses-arg2|36 .backward:uses-arg3|39))) (bytevector-set! .backward-table|57 $trap (logior .backward:uses-arg1|33 (logior .backward:uses-arg2|36 .backward:uses-arg3|39))) (bytevector-set! .backward-table|57 $store .backward:uses-arg1|33) (bytevector-set! .backward-table|57 $reg .backward:uses-arg1|33) (bytevector-set! .backward-table|57 $load .backward:kills-arg1|42) (bytevector-set! .backward-table|57 $setreg .backward:kills-arg1|42) (bytevector-set! .backward-table|57 $movereg (logior .backward:uses-arg1|33 .backward:kills-arg2|45)) (bytevector-set! .backward-table|57 $const/setreg .backward:kills-arg2|45) (bytevector-set! .backward-table|57 $lambda .backward:uses-many|48) (bytevector-set! .backward-table|57 $lexes .backward:uses-many|48) (bytevector-set! .backward-table|57 $args>= .backward:uses-many|48) (lambda (.instructions|71) (let* ((.*nregs*|74 *nregs*) (.registers|77 (make-vector .*nregs*|74 #f)) (.label-table|80 (make-hashtable (lambda (.n|532) .n|532) assv))) (let () (let ((.local-optimization-error|84 (unspecified)) (.suppress-backwards|84 (unspecified)) (.suppress-forwards|84 (unspecified)) (.backwards0|84 (unspecified)) (.backwards|84 (unspecified)) (.forwards-label|84 (unspecified)) (.forwards|84 (unspecified)) (.kill-stack!|84 (unspecified)) (.subvector-fill!|84 (unspecified)) (.vector-fill!|84 (unspecified)) (.lookup-label|84 (unspecified)) (.compute-transitive-closure!|84 (unspecified))) (begin (set! .local-optimization-error|84 (lambda (.op|85) (error "Compiler bug: local optimization" .op|85))) (set! .suppress-backwards|84 (lambda (.instruction|86 .instructions|86 .filtered|86) (begin (if (issue-warnings) '(begin (display suppression-message) (newline)) (unspecified)) (.backwards|84 .instructions|86 .filtered|86)))) (set! .suppress-forwards|84 (lambda (.instruction|87 .instructions|87 .filtered|87) (begin (if (issue-warnings) '(begin (display suppression-message) (newline)) (unspecified)) (.forwards|84 .instructions|87 .filtered|87)))) (set! .backwards0|84 (lambda (.instructions|88 .filtered|88) (if (null? .instructions|88) .filtered|88 (let* ((.instruction|91 (let ((.x|233|236 .instructions|88)) (begin (.check! (pair? .x|233|236) 0 .x|233|236) (car:pair .x|233|236)))) (.mnemonic|94 (instruction.op .instruction|91))) (let () (if (let ((.temp|99|102 (eqv? .mnemonic|94 $.label))) (if .temp|99|102 .temp|99|102 (let ((.temp|103|106 (eqv? .mnemonic|94 $.proc))) (if .temp|103|106 .temp|103|106 (let ((.temp|107|110 (eqv? .mnemonic|94 $.cont))) (if .temp|107|110 .temp|107|110 (eqv? .mnemonic|94 $.align))))))) (.backwards0|84 (let ((.x|116|119 .instructions|88)) (begin (.check! (pair? .x|116|119) 1 .x|116|119) (cdr:pair .x|116|119))) (cons .instruction|91 .filtered|88)) (if (eqv? .mnemonic|94 $return) (begin (.vector-fill!|84 .registers|77 #f) (let ((.v|122|125 .registers|77) (.i|122|125 0) (.x|122|125 #t)) (begin (.check! (fixnum? .i|122|125) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (vector? .v|122|125) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (<:fix:fix .i|122|125 (vector-length:vec .v|122|125)) 41 .v|122|125 .i|122|125 .x|122|125) (.check! (>=:fix:fix .i|122|125 0) 41 .v|122|125 .i|122|125 .x|122|125) (vector-set!:trusted .v|122|125 .i|122|125 .x|122|125))) (.backwards|84 (let ((.x|126|129 .instructions|88)) (begin (.check! (pair? .x|126|129) 1 .x|126|129) (cdr:pair .x|126|129))) (cons .instruction|91 .filtered|88))) (if (eqv? .mnemonic|94 $invoke) (let ((.n+1|134 (min .*nregs*|74 (+ (instruction.arg1 .instruction|91) 1)))) (begin (.subvector-fill!|84 .registers|77 0 .n+1|134 #t) (.subvector-fill!|84 .registers|77 .n+1|134 .*nregs*|74 #f) (.backwards|84 (let ((.x|135|138 .instructions|88)) (begin (.check! (pair? .x|135|138) 1 .x|135|138) (cdr:pair .x|135|138))) (cons .instruction|91 .filtered|88)))) (if (let ((.temp|140|143 (eqv? .mnemonic|94 $skip))) (if .temp|140|143 .temp|140|143 (eqv? .mnemonic|94 $branch))) (let* ((.live|149 (instruction.arg2 .instruction|91)) (.n+1|152 (min .*nregs*|74 (+ .live|149 1)))) (let () (begin (.subvector-fill!|84 .registers|77 0 .n+1|152 #t) (.subvector-fill!|84 .registers|77 .n+1|152 .*nregs*|74 #f) (let ((.instruction|158 (let* ((.t1|163|166 .mnemonic|94) (.t2|163|169 (let* ((.t1|173|176 (.lookup-label|84 (instruction.arg1 .instruction|91))) (.t2|173|179 (cons .live|149 '()))) (let () (cons .t1|173|176 .t2|173|179))))) (let () (cons .t1|163|166 .t2|163|169))))) (.backwards|84 (let ((.x|159|162 .instructions|88)) (begin (.check! (pair? .x|159|162) 1 .x|159|162) (cdr:pair .x|159|162))) (cons .instruction|158 .filtered|88)))))) (if (eqv? .mnemonic|94 $jump) (let ((.n+1|188 (min .*nregs*|74 (+ (instruction.arg3 .instruction|91) 1)))) (begin (.subvector-fill!|84 .registers|77 0 .n+1|188 #t) (.subvector-fill!|84 .registers|77 .n+1|188 .*nregs*|74 #f) (.backwards|84 (let ((.x|189|192 .instructions|88)) (begin (.check! (pair? .x|189|192) 1 .x|189|192) (cdr:pair .x|189|192))) (cons .instruction|91 .filtered|88)))) (if (eqv? .mnemonic|94 $branchf) (let* ((.live|197 (instruction.arg2 .instruction|91)) (.n+1|200 (min .*nregs*|74 (+ .live|197 1)))) (let () (begin (.subvector-fill!|84 .registers|77 0 .n+1|200 #t) (let ((.instruction|206 (let* ((.t1|211|214 .mnemonic|94) (.t2|211|217 (let* ((.t1|221|224 (.lookup-label|84 (instruction.arg1 .instruction|91))) (.t2|221|227 (cons .live|197 '()))) (let () (cons .t1|221|224 .t2|221|227))))) (let () (cons .t1|211|214 .t2|211|217))))) (.backwards|84 (let ((.x|207|210 .instructions|88)) (begin (.check! (pair? .x|207|210) 1 .x|207|210) (cdr:pair .x|207|210))) (cons .instruction|206 .filtered|88)))))) (.backwards|84 .instructions|88 .filtered|88)))))))))))) (set! .backwards|84 (lambda (.instructions|237 .filtered|237) (if (null? .instructions|237) .filtered|237 (let* ((.instruction|240 (let ((.x|329|332 .instructions|237)) (begin (.check! (pair? .x|329|332) 0 .x|329|332) (car:pair .x|329|332)))) (.instructions|243 (let ((.x|325|328 .instructions|237)) (begin (.check! (pair? .x|325|328) 1 .x|325|328) (cdr:pair .x|325|328)))) (.op|246 (instruction.op .instruction|240)) (.flags|249 (bytevector-ref .backward-table|57 .op|246))) (let () (if (eqv? .flags|249 .backward:normal|24) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237)) (if (eqv? .flags|249 .backward:ends-block|27) (.backwards0|84 (cons .instruction|240 .instructions|243) .filtered|237) (if (eqv? .flags|249 .backward:begins-block|30) (.backwards0|84 .instructions|243 (cons .instruction|240 .filtered|237)) (if (eqv? .flags|249 .backward:uses-many|48) (if (let ((.temp|262|265 (eqv? .op|246 $lambda))) (if .temp|262|265 .temp|262|265 (eqv? .op|246 $lexes))) (let ((.live|271 (if (eqv? .op|246 $lexes) (instruction.arg1 .instruction|240) (instruction.arg2 .instruction|240)))) (begin (.subvector-fill!|84 .registers|77 0 (min .*nregs*|74 (+ 1 .live|271)) #t) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237)))) (if (eqv? .op|246 $args>=) (begin (.vector-fill!|84 .registers|77 #t) (.backwards|84 .instructions|243 (cons .instruction|240 .filtered|237))) (.local-optimization-error|84 .op|246))) (if (if (eqv? (logand .flags|249 .backward:kills-arg1|42) .backward:kills-arg1|42) (not (let ((.v|280|283 .registers|77) (.i|280|283 (instruction.arg1 .instruction|240))) (begin (.check! (fixnum? .i|280|283) 40 .v|280|283 .i|280|283) (.check! (vector? .v|280|283) 40 .v|280|283 .i|280|283) (.check! (<:fix:fix .i|280|283 (vector-length:vec .v|280|283)) 40 .v|280|283 .i|280|283) (.check! (>=:fix:fix .i|280|283 0) 40 .v|280|283 .i|280|283) (vector-ref:trusted .v|280|283 .i|280|283)))) #f) (.suppress-backwards|84 .instruction|240 .instructions|243 .filtered|237) (if (if (eqv? (logand .flags|249 .backward:kills-arg2|45) .backward:kills-arg2|45) (not (let ((.v|288|291 .registers|77) (.i|288|291 (instruction.arg2 .instruction|240))) (begin (.check! (fixnum? .i|288|291) 40 .v|288|291 .i|288|291) (.check! (vector? .v|288|291) 40 .v|288|291 .i|288|291) (.check! (<:fix:fix .i|288|291 (vector-length:vec .v|288|291)) 40 .v|288|291 .i|288|291) (.check! (>=:fix:fix .i|288|291 0) 40 .v|288|291 .i|288|291) (vector-ref:trusted .v|288|291 .i|288|291)))) #f) (.suppress-backwards|84 .instruction|240 .instructions|243 .filtered|237) (if (if (eqv? .op|246 $movereg) (= (instruction.arg1 .instruction|240) (instruction.arg2 .instruction|240)) #f) (.backwards|84 .instructions|243 .filtered|237) (let ((.filtered|299 (cons .instruction|240 .filtered|237))) (begin (if (eqv? (logand .flags|249 .backward:kills-arg1|42) .backward:kills-arg1|42) (let ((.v|301|304 .registers|77) (.i|301|304 (instruction.arg1 .instruction|240)) (.x|301|304 #f)) (begin (.check! (fixnum? .i|301|304) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (vector? .v|301|304) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (<:fix:fix .i|301|304 (vector-length:vec .v|301|304)) 41 .v|301|304 .i|301|304 .x|301|304) (.check! (>=:fix:fix .i|301|304 0) 41 .v|301|304 .i|301|304 .x|301|304) (vector-set!:trusted .v|301|304 .i|301|304 .x|301|304))) (unspecified)) (if (eqv? (logand .flags|249 .backward:kills-arg2|45) .backward:kills-arg2|45) (let ((.v|306|309 .registers|77) (.i|306|309 (instruction.arg2 .instruction|240)) (.x|306|309 #f)) (begin (.check! (fixnum? .i|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (vector? .v|306|309) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (<:fix:fix .i|306|309 (vector-length:vec .v|306|309)) 41 .v|306|309 .i|306|309 .x|306|309) (.check! (>=:fix:fix .i|306|309 0) 41 .v|306|309 .i|306|309 .x|306|309) (vector-set!:trusted .v|306|309 .i|306|309 .x|306|309))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg1|33) .backward:uses-arg1|33) (let ((.v|311|314 .registers|77) (.i|311|314 (instruction.arg1 .instruction|240)) (.x|311|314 #t)) (begin (.check! (fixnum? .i|311|314) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (vector? .v|311|314) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (<:fix:fix .i|311|314 (vector-length:vec .v|311|314)) 41 .v|311|314 .i|311|314 .x|311|314) (.check! (>=:fix:fix .i|311|314 0) 41 .v|311|314 .i|311|314 .x|311|314) (vector-set!:trusted .v|311|314 .i|311|314 .x|311|314))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg2|36) .backward:uses-arg2|36) (let ((.v|316|319 .registers|77) (.i|316|319 (instruction.arg2 .instruction|240)) (.x|316|319 #t)) (begin (.check! (fixnum? .i|316|319) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (vector? .v|316|319) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (<:fix:fix .i|316|319 (vector-length:vec .v|316|319)) 41 .v|316|319 .i|316|319 .x|316|319) (.check! (>=:fix:fix .i|316|319 0) 41 .v|316|319 .i|316|319 .x|316|319) (vector-set!:trusted .v|316|319 .i|316|319 .x|316|319))) (unspecified)) (if (eqv? (logand .flags|249 .backward:uses-arg3|39) .backward:uses-arg3|39) (let ((.v|321|324 .registers|77) (.i|321|324 (instruction.arg3 .instruction|240)) (.x|321|324 #t)) (begin (.check! (fixnum? .i|321|324) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (vector? .v|321|324) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (<:fix:fix .i|321|324 (vector-length:vec .v|321|324)) 41 .v|321|324 .i|321|324 .x|321|324) (.check! (>=:fix:fix .i|321|324 0) 41 .v|321|324 .i|321|324 .x|321|324) (vector-set!:trusted .v|321|324 .i|321|324 .x|321|324))) (unspecified)) (.backwards|84 .instructions|243 .filtered|299))))))))))))))) (set! .forwards-label|84 (lambda (.instruction1|333 .instructions|333 .filtered|333) (let ((.label1|336 (instruction.arg1 .instruction1|333))) (if (null? .instructions|333) (.forwards|84 .instructions|333 (let ((.x|337|340 .filtered|333)) (begin (.check! (pair? .x|337|340) 1 .x|337|340) (cdr:pair .x|337|340)))) (let ((.instructions|343 .instructions|333) (.filtered|343 (cons .instruction1|333 .filtered|333))) (let () (let ((.loop|346 (unspecified))) (begin (set! .loop|346 (lambda (.instructions|347 .filtered|347) (let* ((.instruction|350 (let ((.x|398|401 .instructions|347)) (begin (.check! (pair? .x|398|401) 0 .x|398|401) (car:pair .x|398|401)))) (.op|353 (instruction.op .instruction|350)) (.flags|356 (bytevector-ref .forward-table|54 .op|353))) (let () (if (eqv? .flags|356 .forward:nop|9) (.loop|346 (let ((.x|362|365 .instructions|347)) (begin (.check! (pair? .x|362|365) 1 .x|362|365) (cdr:pair .x|362|365))) .filtered|347) (if (if (eqv? .flags|356 .forward:nop-if-arg1-is-negative|21) (< (instruction.arg1 .instruction|350) 0) #f) (.loop|346 (let ((.x|371|374 .instructions|347)) (begin (.check! (pair? .x|371|374) 1 .x|371|374) (cdr:pair .x|371|374))) .filtered|347) (if (eqv? .op|353 $.label) (let ((.label2|379 (instruction.arg1 .instruction|350))) (begin (hashtable-put! .label-table|80 .label1|336 .label2|379) (.forwards-label|84 .instruction|350 (let ((.x|380|383 .instructions|347)) (begin (.check! (pair? .x|380|383) 1 .x|380|383) (cdr:pair .x|380|383))) (let ((.x|384|387 .filtered|347)) (begin (.check! (pair? .x|384|387) 1 .x|384|387) (cdr:pair .x|384|387)))))) (if (eqv? .op|353 $skip) (let ((.label2|392 (instruction.arg1 .instruction|350))) (begin (hashtable-put! .label-table|80 .label1|336 .label2|392) (.forwards|84 .instructions|347 (let ((.x|393|396 .filtered|347)) (begin (.check! (pair? .x|393|396) 1 .x|393|396) (cdr:pair .x|393|396)))))) (.forwards|84 .instructions|347 .filtered|347))))))))) (.loop|346 .instructions|343 .filtered|343))))))))) (set! .forwards|84 (lambda (.instructions|402 .filtered|402) (if (null? .instructions|402) (begin (.vector-fill!|84 .registers|77 #f) (let ((.v|403|406 .registers|77) (.i|403|406 0) (.x|403|406 #t)) (begin (.check! (fixnum? .i|403|406) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (vector? .v|403|406) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (<:fix:fix .i|403|406 (vector-length:vec .v|403|406)) 41 .v|403|406 .i|403|406 .x|403|406) (.check! (>=:fix:fix .i|403|406 0) 41 .v|403|406 .i|403|406 .x|403|406) (vector-set!:trusted .v|403|406 .i|403|406 .x|403|406))) (.compute-transitive-closure!|84) (.backwards0|84 .filtered|402 '())) (let* ((.instruction|409 (let ((.x|486|489 .instructions|402)) (begin (.check! (pair? .x|486|489) 0 .x|486|489) (car:pair .x|486|489)))) (.instructions|412 (let ((.x|482|485 .instructions|402)) (begin (.check! (pair? .x|482|485) 1 .x|482|485) (cdr:pair .x|482|485)))) (.op|415 (instruction.op .instruction|409)) (.flags|418 (bytevector-ref .forward-table|54 .op|415))) (let () (if (eqv? .flags|418 .forward:normal|6) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)) (if (eqv? .flags|418 .forward:nop|9) (.forwards|84 .instructions|412 .filtered|402) (if (eqv? .flags|418 .forward:nop-if-arg1-is-negative|21) (if (< (instruction.arg1 .instruction|409) 0) (.forwards|84 .instructions|412 .filtered|402) (begin (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)))) (if (eqv? .flags|418 .forward:kills-all-registers|18) (begin (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .flags|418 .forward:ends-block|12) (begin (.vector-fill!|84 .registers|77 #f) (if (eqv? .op|415 $.label) (.forwards-label|84 .instruction|409 .instructions|412 .filtered|402) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402)))) (if (eqv? .flags|418 .forward:interesting|15) (if (eqv? .op|415 $setreg) (begin (let ((.v|438|441 .registers|77) (.i|438|441 (instruction.arg1 .instruction|409)) (.x|438|441 #f)) (begin (.check! (fixnum? .i|438|441) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (vector? .v|438|441) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (<:fix:fix .i|438|441 (vector-length:vec .v|438|441)) 41 .v|438|441 .i|438|441 .x|438|441) (.check! (>=:fix:fix .i|438|441 0) 41 .v|438|441 .i|438|441 .x|438|441) (vector-set!:trusted .v|438|441 .i|438|441 .x|438|441))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $const/setreg) (begin (let ((.v|444|447 .registers|77) (.i|444|447 (instruction.arg2 .instruction|409)) (.x|444|447 #f)) (begin (.check! (fixnum? .i|444|447) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (vector? .v|444|447) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (<:fix:fix .i|444|447 (vector-length:vec .v|444|447)) 41 .v|444|447 .i|444|447 .x|444|447) (.check! (>=:fix:fix .i|444|447 0) 41 .v|444|447 .i|444|447 .x|444|447) (vector-set!:trusted .v|444|447 .i|444|447 .x|444|447))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $movereg) (begin (let ((.v|450|453 .registers|77) (.i|450|453 (instruction.arg2 .instruction|409)) (.x|450|453 #f)) (begin (.check! (fixnum? .i|450|453) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (vector? .v|450|453) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (<:fix:fix .i|450|453 (vector-length:vec .v|450|453)) 41 .v|450|453 .i|450|453 .x|450|453) (.check! (>=:fix:fix .i|450|453 0) 41 .v|450|453 .i|450|453 .x|450|453) (vector-set!:trusted .v|450|453 .i|450|453 .x|450|453))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $setstk) (begin (.kill-stack!|84 (instruction.arg1 .instruction|409)) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))) (if (eqv? .op|415 $load) (let ((.i|460 (instruction.arg1 .instruction|409)) (.j|460 (instruction.arg2 .instruction|409))) (if (eqv? (let ((.v|462|465 .registers|77) (.i|462|465 .i|460)) (begin (.check! (fixnum? .i|462|465) 40 .v|462|465 .i|462|465) (.check! (vector? .v|462|465) 40 .v|462|465 .i|462|465) (.check! (<:fix:fix .i|462|465 (vector-length:vec .v|462|465)) 40 .v|462|465 .i|462|465) (.check! (>=:fix:fix .i|462|465 0) 40 .v|462|465 .i|462|465) (vector-ref:trusted .v|462|465 .i|462|465))) .j|460) (.suppress-forwards|84 .instruction|409 .instructions|412 .filtered|402) (begin (let ((.v|466|469 .registers|77) (.i|466|469 .i|460) (.x|466|469 .j|460)) (begin (.check! (fixnum? .i|466|469) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (vector? .v|466|469) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (<:fix:fix .i|466|469 (vector-length:vec .v|466|469)) 41 .v|466|469 .i|466|469 .x|466|469) (.check! (>=:fix:fix .i|466|469 0) 41 .v|466|469 .i|466|469 .x|466|469) (vector-set!:trusted .v|466|469 .i|466|469 .x|466|469))) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))))) (if (eqv? .op|415 $store) (let ((.i|474 (instruction.arg1 .instruction|409)) (.j|474 (instruction.arg2 .instruction|409))) (if (eqv? (let ((.v|476|479 .registers|77) (.i|476|479 .i|474)) (begin (.check! (fixnum? .i|476|479) 40 .v|476|479 .i|476|479) (.check! (vector? .v|476|479) 40 .v|476|479 .i|476|479) (.check! (<:fix:fix .i|476|479 (vector-length:vec .v|476|479)) 40 .v|476|479 .i|476|479) (.check! (>=:fix:fix .i|476|479 0) 40 .v|476|479 .i|476|479) (vector-ref:trusted .v|476|479 .i|476|479))) .j|474) (.suppress-forwards|84 .instruction|409 .instructions|412 .filtered|402) (begin (.kill-stack!|84 .j|474) (.forwards|84 .instructions|412 (cons .instruction|409 .filtered|402))))) (.local-optimization-error|84 .op|415))))))) (.local-optimization-error|84 .op|415)))))))))))) (set! .kill-stack!|84 (lambda (.j|490) (let () (let ((.loop|492|494|497 (unspecified))) (begin (set! .loop|492|494|497 (lambda (.i|498) (if (= .i|498 .*nregs*|74) (if #f #f (unspecified)) (begin (begin #t (let ((.x|503 (let ((.v|510|513 .registers|77) (.i|510|513 .i|498)) (begin (.check! (fixnum? .i|510|513) 40 .v|510|513 .i|510|513) (.check! (vector? .v|510|513) 40 .v|510|513 .i|510|513) (.check! (<:fix:fix .i|510|513 (vector-length:vec .v|510|513)) 40 .v|510|513 .i|510|513) (.check! (>=:fix:fix .i|510|513 0) 40 .v|510|513 .i|510|513) (vector-ref:trusted .v|510|513 .i|510|513))))) (if (if .x|503 (= .x|503 .j|490) #f) (let ((.v|506|509 .registers|77) (.i|506|509 .i|498) (.x|506|509 #f)) (begin (.check! (fixnum? .i|506|509) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (vector? .v|506|509) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (<:fix:fix .i|506|509 (vector-length:vec .v|506|509)) 41 .v|506|509 .i|506|509 .x|506|509) (.check! (>=:fix:fix .i|506|509 0) 41 .v|506|509 .i|506|509 .x|506|509) (vector-set!:trusted .v|506|509 .i|506|509 .x|506|509))) (unspecified)))) (.loop|492|494|497 (+ .i|498 1)))))) (.loop|492|494|497 0)))))) (set! .subvector-fill!|84 (lambda (.v|514 .i|514 .j|514 .x|514) (if (< .i|514 .j|514) (begin (let ((.v|515|518 .v|514) (.i|515|518 .i|514) (.x|515|518 .x|514)) (begin (.check! (fixnum? .i|515|518) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (vector? .v|515|518) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (<:fix:fix .i|515|518 (vector-length:vec .v|515|518)) 41 .v|515|518 .i|515|518 .x|515|518) (.check! (>=:fix:fix .i|515|518 0) 41 .v|515|518 .i|515|518 .x|515|518) (vector-set!:trusted .v|515|518 .i|515|518 .x|515|518))) (.subvector-fill!|84 .v|514 (+ .i|514 1) .j|514 .x|514)) (unspecified)))) (set! .vector-fill!|84 (lambda (.v|519 .x|519) (.subvector-fill!|84 .v|519 0 (let ((.v|520|523 .v|519)) (begin (.check! (vector? .v|520|523) 42 .v|520|523) (vector-length:vec .v|520|523))) .x|519))) (set! .lookup-label|84 (lambda (.x|524) (hashtable-fetch .label-table|80 .x|524 .x|524))) (set! .compute-transitive-closure!|84 (lambda () (let ((.lookup|526 (unspecified))) (begin (set! .lookup|526 (lambda (.x|527) (let ((.y|530 (hashtable-get .label-table|80 .x|527))) (if .y|530 (.lookup|526 .y|530) .x|527)))) (hashtable-for-each (lambda (.x|531 .y|531) (hashtable-put! .label-table|80 .x|531 (.lookup|526 .y|531))) .label-table|80))))) (.vector-fill!|84 .registers|77 #f) (.forwards|84 .instructions|71 '())))))))))) 'filter-basic-blocks))
+(let () (begin (set! *scheme-file-types* '(".sch" ".scm")) '*scheme-file-types*))
+(let () (begin (set! *lap-file-type* ".lap") '*lap-file-type*))
+(let () (begin (set! *mal-file-type* ".mal") '*mal-file-type*))
+(let () (begin (set! *lop-file-type* ".lop") '*lop-file-type*))
+(let () (begin (set! *fasl-file-type* ".fasl") '*fasl-file-type*))
+(let () (begin (set! compile-file (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|11|14 .rest|1)) (begin (.check! (pair? .x|11|14) 0 .x|11|14) (car:pair .x|11|14))) (rewrite-file-type .infilename|1 *scheme-file-types* *fasl-file-type*))) (.user|6 (assembly-user-data))) (begin (if (if (not (integrate-usual-procedures)) (issue-warnings) #f) (begin (display "WARNING from compiler: ") (display "integrate-usual-procedures is turned off") (newline) (display "Performance is likely to be poor.") (newline)) (unspecified)) (if (benchmark-block-mode) (process-file-block .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.forms|9) (assemble (compile-block .forms|9) .user|6))) (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.expr|10) (assemble (compile .expr|10) .user|6)))) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Compile-file not supported on this target architecture.") (.doit|2)))))) 'compile-file))
+(let () (begin (set! assemble-file (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 (let* ((.t1|12|15 *lap-file-type*) (.t2|12|18 (cons *mal-file-type* '()))) (let () (cons .t1|12|15 .t2|12|18))) *fasl-file-type*))) (.malfile?|6 (file-type=? .infilename|1 *mal-file-type*)) (.user|6 (assembly-user-data))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) (assemble (if .malfile?|6 (eval .x|7) .x|7) .user|6))) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Assemble-file not supported on this target architecture.") (.doit|2)))))) 'assemble-file))
+(let () (begin (set! compile-expression (let () (let ((.compile-expression|4 (unspecified))) (begin (set! .compile-expression|4 (lambda (.expr|5 .env|5) (let* ((.syntax-env|8 (let ((.temp|15|18 (environment-tag .env|5))) (if (memv .temp|15|18 '(0 1)) (make-standard-syntactic-environment) (if (memv .temp|15|18 '(2)) global-syntactic-environment (begin (error "Invalid environment for compile-expression: " .env|5) #t))))) (.current-env|11 global-syntactic-environment)) (dynamic-wind (lambda () (set! global-syntactic-environment .syntax-env|8)) (lambda () (assemble (compile .expr|5))) (lambda () (set! global-syntactic-environment .current-env|11)))))) .compile-expression|4)))) 'compile-expression))
+(let () (begin (set! macro-expand-expression (let () (let ((.macro-expand-expression|4 (unspecified))) (begin (set! .macro-expand-expression|4 (lambda (.expr|5 .env|5) (let* ((.syntax-env|8 (let ((.temp|15|18 (environment-tag .env|5))) (if (memv .temp|15|18 '(0 1)) (make-standard-syntactic-environment) (if (memv .temp|15|18 '(2)) global-syntactic-environment (begin (error "Invalid environment for compile-expression: " .env|5) #t))))) (.current-env|11 global-syntactic-environment)) (dynamic-wind (lambda () (set! global-syntactic-environment .syntax-env|8)) (lambda () (make-readable (macro-expand .expr|5))) (lambda () (set! global-syntactic-environment .current-env|11)))))) .macro-expand-expression|4)))) 'macro-expand-expression))
+(let () (begin (set! compile313 (lambda (.infilename|1 . .rest|1) (let ((.outfilename|4 (if (not (null? .rest|1)) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8))) (rewrite-file-type .infilename|1 *scheme-file-types* *lap-file-type*))) (.write-lap|4 (lambda (.item|9 .port|9) (begin (write .item|9 .port|9) (newline .port|9) (newline .port|9))))) (begin (if (benchmark-block-mode) (process-file-block .infilename|1 .outfilename|4 .write-lap|4 compile-block) (process-file .infilename|1 .outfilename|4 .write-lap|4 compile)) (unspecified))))) 'compile313))
+(let () (begin (set! assemble313 (lambda (.file|1 . .rest|1) (let ((.outputfile|4 (if (not (null? .rest|1)) (let ((.x|6|9 .rest|1)) (begin (.check! (pair? .x|6|9) 0 .x|6|9) (car:pair .x|6|9))) (rewrite-file-type .file|1 (let* ((.t1|10|13 *lap-file-type*) (.t2|10|16 (cons *mal-file-type* '()))) (let () (cons .t1|10|13 .t2|10|16))) *lop-file-type*))) (.malfile?|4 (file-type=? .file|1 *mal-file-type*)) (.user|4 (assembly-user-data))) (begin (process-file .file|1 .outputfile|4 write-lop (lambda (.x|5) (assemble (if .malfile?|4 (eval .x|5) .x|5) .user|4))) (unspecified))))) 'assemble313))
+(let () (begin (set! compile-and-assemble313 (lambda (.input-file|1 . .rest|1) (let ((.output-file|4 (if (not (null? .rest|1)) (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10))) (rewrite-file-type .input-file|1 *scheme-file-types* *lop-file-type*))) (.user|4 (assembly-user-data))) (begin (if (benchmark-block-mode) (process-file-block .input-file|1 .output-file|4 write-lop (lambda (.x|5) (assemble (compile-block .x|5) .user|4))) (process-file .input-file|1 .output-file|4 write-lop (lambda (.x|6) (assemble (compile .x|6) .user|4)))) (unspecified))))) 'compile-and-assemble313))
+(let () (begin (set! make-fasl (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 *lop-file-type* *fasl-file-type*)))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) .x|7)) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Make-fasl not supported on this target architecture.") (.doit|2)))))) 'make-fasl))
+(let () (begin (set! disassemble (lambda (.item|1 . .rest|1) (let ((.output-port|4 (if (null? .rest|1) (current-output-port) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))))) (begin (disassemble-item .item|1 #f .output-port|4) (unspecified))))) 'disassemble))
+(let () (begin (set! disassemble-item (lambda (.item|1 .segment-no|1 .port|1) (let ((.disassemble-item|2 0)) (begin (set! .disassemble-item|2 (lambda (.item|3 .segment-no|3 .port|3) (let ((.print-segment|5 (unspecified)) (.print-constvector|5 (unspecified)) (.print|5 (unspecified))) (begin (set! .print-segment|5 (lambda (.segment|6) (begin (.print|5 "Segment # " .segment-no|3) (print-instructions (disassemble-codevector (let ((.x|7|10 .segment|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) .port|3) (.print-constvector|5 (let ((.x|11|14 .segment|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (.print|5 "========================================")))) (set! .print-constvector|5 (lambda (.cv|15) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! .loop|17|19|22 (lambda (.i|23) (if (= .i|23 (let ((.v|25|28 .cv|15)) (begin (.check! (vector? .v|25|28) 42 .v|25|28) (vector-length:vec .v|25|28)))) (if #f #f (unspecified)) (begin (begin #t (.print|5 "------------------------------------------") (.print|5 "Constant vector element # " .i|23) (let ((.temp|30|33 (let ((.x|90|93 (let ((.v|94|97 .cv|15) (.i|94|97 .i|23)) (begin (.check! (fixnum? .i|94|97) 40 .v|94|97 .i|94|97) (.check! (vector? .v|94|97) 40 .v|94|97 .i|94|97) (.check! (<:fix:fix .i|94|97 (vector-length:vec .v|94|97)) 40 .v|94|97 .i|94|97) (.check! (>=:fix:fix .i|94|97 0) 40 .v|94|97 .i|94|97) (vector-ref:trusted .v|94|97 .i|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93))))) (if (memv .temp|30|33 '(codevector)) (begin (.print|5 "Code vector") (print-instructions (disassemble-codevector (let ((.x|36|39 (let ((.x|40|43 (let ((.v|44|47 .cv|15) (.i|44|47 .i|23)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47))))) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) .port|3)) (if (memv .temp|30|33 '(constantvector)) (begin (.print|5 "Constant vector") (.print-constvector|5 (let ((.x|50|53 (let ((.x|54|57 (let ((.v|58|61 .cv|15) (.i|58|61 .i|23)) (begin (.check! (fixnum? .i|58|61) 40 .v|58|61 .i|58|61) (.check! (vector? .v|58|61) 40 .v|58|61 .i|58|61) (.check! (<:fix:fix .i|58|61 (vector-length:vec .v|58|61)) 40 .v|58|61 .i|58|61) (.check! (>=:fix:fix .i|58|61 0) 40 .v|58|61 .i|58|61) (vector-ref:trusted .v|58|61 .i|58|61))))) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .temp|30|33 '(global)) (.print|5 "Global: " (let ((.x|64|67 (let ((.x|68|71 (let ((.v|72|75 .cv|15) (.i|72|75 .i|23)) (begin (.check! (fixnum? .i|72|75) 40 .v|72|75 .i|72|75) (.check! (vector? .v|72|75) 40 .v|72|75 .i|72|75) (.check! (<:fix:fix .i|72|75 (vector-length:vec .v|72|75)) 40 .v|72|75 .i|72|75) (.check! (>=:fix:fix .i|72|75 0) 40 .v|72|75 .i|72|75) (vector-ref:trusted .v|72|75 .i|72|75))))) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (if (memv .temp|30|33 '(data)) (.print|5 "Data: " (let ((.x|78|81 (let ((.x|82|85 (let ((.v|86|89 .cv|15) (.i|86|89 .i|23)) (begin (.check! (fixnum? .i|86|89) 40 .v|86|89 .i|86|89) (.check! (vector? .v|86|89) 40 .v|86|89 .i|86|89) (.check! (<:fix:fix .i|86|89 (vector-length:vec .v|86|89)) 40 .v|86|89 .i|86|89) (.check! (>=:fix:fix .i|86|89 0) 40 .v|86|89 .i|86|89) (vector-ref:trusted .v|86|89 .i|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (unspecified))))))) (.loop|17|19|22 (+ .i|23 1)))))) (.loop|17|19|22 0)))))) (set! .print|5 (lambda .rest|98 (begin (let () (let ((.loop|104|106|109 (unspecified))) (begin (set! .loop|104|106|109 (lambda (.y1|99|100|110) (if (null? .y1|99|100|110) (if #f #f (unspecified)) (begin (begin #t (let ((.x|114 (let ((.x|115|118 .y1|99|100|110)) (begin (.check! (pair? .x|115|118) 0 .x|115|118) (car:pair .x|115|118))))) (display .x|114 .port|3))) (.loop|104|106|109 (let ((.x|119|122 .y1|99|100|110)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122)))))))) (.loop|104|106|109 .rest|98)))) (newline .port|3)))) (if (procedure? .item|3) (print-instructions (disassemble-codevector (procedure-ref .item|3 0)) .port|3) (if (if (pair? .item|3) (if (bytevector? (let ((.x|126|129 .item|3)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129)))) (vector? (let ((.x|131|134 .item|3)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134)))) #f) #f) (.print-segment|5 .item|3) (error "disassemble-item: " .item|3 " is not disassemblable."))))))) (.disassemble-item|2 .item|1 .segment-no|1 .port|1))))) 'disassemble-item))
+(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "\; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
+(let () (begin (set! compiler-switches (lambda .rest|1 (let ((.fast-unsafe-code|3 (unspecified)) (.fast-safe-code|3 (unspecified)) (.standard-code|3 (unspecified)) (.slow-code|3 (unspecified))) (begin (set! .fast-unsafe-code|3 (lambda () (begin (set-compiler-flags! 'fast-unsafe) (set-assembler-flags! 'fast-unsafe)))) (set! .fast-safe-code|3 (lambda () (begin (set-compiler-flags! 'fast-safe) (set-assembler-flags! 'fast-safe)))) (set! .standard-code|3 (lambda () (begin (set-compiler-flags! 'standard) (set-assembler-flags! 'standard)))) (set! .slow-code|3 (lambda () (begin (set-compiler-flags! 'no-optimization) (set-assembler-flags! 'no-optimization)))) (if (null? .rest|1) (begin (display "Debugging:") (newline) (display-twobit-flags 'debugging) (display-assembler-flags 'debugging) (newline) (display "Safety:") (newline) (display-twobit-flags 'safety) (display-assembler-flags 'safety) (newline) (display "Speed:") (newline) (display-twobit-flags 'optimization) (display-assembler-flags 'optimization) (if #f #f (unspecified))) (if (null? (let ((.x|9|12 .rest|1)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (begin (let ((.temp|13|16 (let ((.x|27|30 .rest|1)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (if (memv .temp|13|16 '(0 slow)) (.slow-code|3) (if (memv .temp|13|16 '(1 standard)) (.standard-code|3) (if (memv .temp|13|16 '(2 fast-safe)) (.fast-safe-code|3) (if (memv .temp|13|16 '(3 fast-unsafe)) (.fast-unsafe-code|3) (if (memv .temp|13|16 '(default factory-settings)) (begin (.fast-safe-code|3) (include-source-code #t) (benchmark-mode #f) (benchmark-block-mode #f) (common-subexpression-elimination #f) (representation-inference #f)) (error "Unrecognized flag " (let ((.x|23|26 .rest|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) " to compiler-switches."))))))) (unspecified)) (error "Too many arguments to compiler-switches."))))))) 'compiler-switches))
+(let () (begin (set! process-file (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file|2 0)) (begin (set! .process-file|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let ((.x|12 (read .inport|9))) (let () (let ((.loop|15 (unspecified))) (begin (set! .loop|15 (lambda (.x|16) (if (eof-object? .x|16) #t (begin (.writer|3 (.processer|3 .x|16) .outport|8) (.loop|15 (read .inport|9)))))) (.loop|15 .x|12)))))))))))) (let ((.current-syntactic-environment|17 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|17)))))))) (.process-file|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file))
+(let () (begin (set! process-file-block (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file-block|2 0)) (begin (set! .process-file-block|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.x|17 .forms|17) (if (eof-object? .x|17) (.writer|3 (.processer|3 (reverse .forms|17)) .outport|8) (begin #t (.loop|10|13|16 (read .inport|9) (cons .x|17 .forms|17)))))) (.loop|10|13|16 (read .inport|9) '()))))))))))) (let ((.current-syntactic-environment|20 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|20)))))))) (.process-file-block|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file-block))
+(let () (begin (set! rewrite-file-type (lambda (.filename|1 .matches|1 .new|1) (let ((.rewrite-file-type|2 0)) (begin (set! .rewrite-file-type|2 (lambda (.filename|3 .matches|3 .new|3) (if (not (pair? .matches|3)) (.rewrite-file-type|2 .filename|3 (cons .matches|3 '()) .new|3) (let* ((.j|7 (string-length .filename|3)) (.m|10 .matches|3)) (let () (let ((.loop|13 (unspecified))) (begin (set! .loop|13 (lambda (.m|14) (if (null? .m|14) (string-append .filename|3 .new|3) (let* ((.n|19 (let ((.x|30|33 .m|14)) (begin (.check! (pair? .x|30|33) 0 .x|30|33) (car:pair .x|30|33)))) (.l|22 (string-length .n|19))) (let () (if (file-type=? .filename|3 .n|19) (string-append (substring .filename|3 0 (- .j|7 .l|22)) .new|3) (.loop|13 (let ((.x|26|29 .m|14)) (begin (.check! (pair? .x|26|29) 1 .x|26|29) (cdr:pair .x|26|29)))))))))) (.loop|13 .m|10)))))))) (.rewrite-file-type|2 .filename|1 .matches|1 .new|1))))) 'rewrite-file-type))
+(let () (begin (set! file-type=? (lambda (.file-name|1 .type-name|1) (let ((.file-type=?|2 0)) (begin (set! .file-type=?|2 (lambda (.file-name|3 .type-name|3) (let ((.fl|6 (string-length .file-name|3)) (.tl|6 (string-length .type-name|3))) (if (>= .fl|6 .tl|6) (string-ci=? .type-name|3 (substring .file-name|3 (- .fl|6 .tl|6) .fl|6)) #f)))) (.file-type=?|2 .file-name|1 .type-name|1))))) 'file-type=?))
+(let () (begin (set! readify-lap (lambda (.code|1) (let ((.readify-lap|2 0)) (begin (set! .readify-lap|2 (lambda (.code|3) (let () (let ((.loop|9|12|15 (unspecified))) (begin (set! .loop|9|12|15 (lambda (.y1|4|5|16 .results|4|8|16) (if (null? .y1|4|5|16) (reverse .results|4|8|16) (begin #t (.loop|9|12|15 (let ((.x|20|23 .y1|4|5|16)) (begin (.check! (pair? .x|20|23) 1 .x|20|23) (cdr:pair .x|20|23))) (cons (let* ((.x|24 (let ((.x|88|91 .y1|4|5|16)) (begin (.check! (pair? .x|88|91) 0 .x|88|91) (car:pair .x|88|91)))) (.iname|27 (let ((.x|79|82 (assv (let ((.x|84|87 .x|24)) (begin (.check! (pair? .x|84|87) 0 .x|84|87) (car:pair .x|84|87))) *mnemonic-names*))) (begin (.check! (pair? .x|79|82) 1 .x|79|82) (cdr:pair .x|79|82))))) (if (not (= (let ((.x|28|31 .x|24)) (begin (.check! (pair? .x|28|31) 0 .x|28|31) (car:pair .x|28|31))) $lambda)) (cons .iname|27 (let ((.x|32|35 .x|24)) (begin (.check! (pair? .x|32|35) 1 .x|32|35) (cdr:pair .x|32|35)))) (let* ((.t1|36|39 .iname|27) (.t2|36|42 (let* ((.t1|46|49 (.readify-lap|2 (let ((.x|71|74 (let ((.x|75|78 .x|24)) (begin (.check! (pair? .x|75|78) 1 .x|75|78) (cdr:pair .x|75|78))))) (begin (.check! (pair? .x|71|74) 0 .x|71|74) (car:pair .x|71|74))))) (.t2|46|52 (cons (let ((.x|58|61 (let ((.x|62|65 (let ((.x|66|69 .x|24)) (begin (.check! (pair? .x|66|69) 1 .x|66|69) (cdr:pair .x|66|69))))) (begin (.check! (pair? .x|62|65) 1 .x|62|65) (cdr:pair .x|62|65))))) (begin (.check! (pair? .x|58|61) 0 .x|58|61) (car:pair .x|58|61))) '()))) (let () (cons .t1|46|49 .t2|46|52))))) (let () (cons .t1|36|39 .t2|36|42))))) .results|4|8|16)))))) (.loop|9|12|15 .code|3 '())))))) (.readify-lap|2 .code|1))))) 'readify-lap))
+(let () (begin (set! readify-file (lambda (.f|1 . .o|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let* ((.i|6 (open-input-file .f|1)) (.x|9 (read .i|6))) (let () (let ((.loop|12 (unspecified))) (begin (set! .loop|12 (lambda (.x|13) (if (not (eof-object? .x|13)) (begin (pretty-print (readify-lap .x|13)) (.loop|12 (read .i|6))) (unspecified)))) (.loop|12 .x|9))))))) (if (null? .o|1) (.doit|2) (begin (delete-file (let ((.x|14|17 .o|1)) (begin (.check! (pair? .x|14|17) 0 .x|14|17) (car:pair .x|14|17)))) (with-output-to-file (let ((.x|18|21 .o|1)) (begin (.check! (pair? .x|18|21) 0 .x|18|21) (car:pair .x|18|21))) .doit|2))))))) 'readify-file))
+(let () (begin (set! twobit-benchmark (lambda .rest|1 (let ((.k|4 (if (null? .rest|1) 1 (let ((.x|7|10 .rest|1)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))))) (begin (compiler-switches 'fast-safe) (benchmark-block-mode #t) (run-benchmark "twobit" .k|4 (lambda () (compile-file "benchmarks/twobit-input.sch")) (lambda (.result|6) #t)))))) 'twobit-benchmark))
--- /dev/null
+; This benchmark was obtained from Andrew Wright,
+; based on Fritz Henglein's code.
+; 970215 / wdc Removed most i/o and added dynamic-benchmark.
+; 990707 / lth Added a quote and changed the call to run-benchmark.
+; 010404 / wdc Changed the input file path name to "dynamic-input.sch".
+
+;; Fritz's dynamic type inferencer, set up to run on itself
+;; (see the end of this file).
+
+;----------------------------------------------------------------------------
+; Environment management
+;----------------------------------------------------------------------------
+
+;; environments are lists of pairs, the first component being the key
+
+;; general environment operations
+;;
+;; empty-env: Env
+;; gen-binding: Key x Value -> Binding
+;; binding-key: Binding -> Key
+;; binding-value: Binding -> Value
+;; binding-show: Binding -> Symbol*
+;; extend-env-with-binding: Env x Binding -> Env
+;; extend-env-with-env: Env x Env -> Env
+;; lookup: Key x Env -> (Binding + False)
+;; env->list: Env -> Binding*
+;; env-show: Env -> Symbol*
+
+
+; bindings
+
+(define gen-binding cons)
+; generates a type binding, binding a symbol to a type variable
+
+(define binding-key car)
+; returns the key of a type binding
+
+(define binding-value cdr)
+; returns the tvariable of a type binding
+
+(define (key-show key)
+ ; default show procedure for keys
+ key)
+
+(define (value-show value)
+ ; default show procedure for values
+ value)
+
+(define (binding-show binding)
+ ; returns a printable representation of a type binding
+ (cons (key-show (binding-key binding))
+ (cons ': (value-show (binding-value binding)))))
+
+
+; environments
+
+(define dynamic-empty-env '())
+; returns the empty environment
+
+(define (extend-env-with-binding env binding)
+ ; extends env with a binding, which hides any other binding in env
+ ; for the same key (see dynamic-lookup)
+ ; returns the extended environment
+ (cons binding env))
+
+(define (extend-env-with-env env ext-env)
+ ; extends environment env with environment ext-env
+ ; a binding for a key in ext-env hides any binding in env for
+ ; the same key (see dynamic-lookup)
+ ; returns the extended environment
+ (append ext-env env))
+
+(define dynamic-lookup (lambda (x l) (assv x l)))
+; returns the first pair in env that matches the key; returns #f
+; if no such pair exists
+
+(define (env->list e)
+ ; converts an environment to a list of bindings
+ e)
+
+(define (env-show env)
+ ; returns a printable list representation of a type environment
+ (map binding-show env))
+;----------------------------------------------------------------------------
+; Parsing for Scheme
+;----------------------------------------------------------------------------
+
+
+;; Needed packages: environment management
+
+;(load "env-mgmt.ss")
+;(load "pars-act.ss")
+
+;; Lexical notions
+
+(define syntactic-keywords
+ ;; source: IEEE Scheme, 7.1, <expression keyword>, <syntactic keyword>
+ '(lambda if set! begin cond and or case let let* letrec do
+ quasiquote else => define unquote unquote-splicing))
+
+
+;; Parse routines
+
+; Datum
+
+; dynamic-parse-datum: parses nonterminal <datum>
+
+(define (dynamic-parse-datum e)
+ ;; Source: IEEE Scheme, sect. 7.2, <datum>
+ ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as
+ ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18)
+ ;; ***Note***: quasi-quotations are not permitted! (It would be
+ ;; necessary to pass the environment to dynamic-parse-datum.)
+ (cond
+ ((null? e)
+ (dynamic-parse-action-null-const))
+ ((boolean? e)
+ (dynamic-parse-action-boolean-const e))
+ ((char? e)
+ (dynamic-parse-action-char-const e))
+ ((number? e)
+ (dynamic-parse-action-number-const e))
+ ((string? e)
+ (dynamic-parse-action-string-const e))
+ ((symbol? e)
+ (dynamic-parse-action-symbol-const e))
+ ((vector? e)
+ (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e))))
+ ((pair? e)
+ (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
+ (dynamic-parse-datum (cdr e))))
+ (else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))
+
+
+; VarDef
+
+; dynamic-parse-formal: parses nonterminal <variable> in defining occurrence position
+
+(define (dynamic-parse-formal f-env e)
+ ; e is an arbitrary object, f-env is a forbidden environment;
+ ; returns: a variable definition (a binding for the symbol), plus
+ ; the value of the binding as a result
+ (if (symbol? e)
+ (cond
+ ((memq e syntactic-keywords)
+ (error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
+ ((dynamic-lookup e f-env)
+ (error 'dynamic-parse-formal "Duplicate variable definition: ~s" e))
+ (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
+ (cons (gen-binding e dynamic-parse-action-result)
+ dynamic-parse-action-result))))
+ (error 'dynamic-parse-formal "Not an identifier: ~s" e)))
+
+; dynamic-parse-formal*
+
+(define (dynamic-parse-formal* formals)
+ ;; parses a list of formals and returns a pair consisting of generated
+ ;; environment and list of parsing action results
+ (letrec
+ ((pf*
+ (lambda (f-env results formals)
+ ;; f-env: "forbidden" environment (to avoid duplicate defs)
+ ;; results: the results of the parsing actions
+ ;; formals: the unprocessed formals
+ ;; Note: generates the results of formals in reverse order!
+ (cond
+ ((null? formals)
+ (cons f-env results))
+ ((pair? formals)
+ (let* ((fst-formal (car formals))
+ (binding-result (dynamic-parse-formal f-env fst-formal))
+ (binding (car binding-result))
+ (var-result (cdr binding-result)))
+ (pf*
+ (extend-env-with-binding f-env binding)
+ (cons var-result results)
+ (cdr formals))))
+ (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
+ (let ((renv-rres (pf* dynamic-empty-env '() formals)))
+ (cons (car renv-rres) (reverse (cdr renv-rres))))))
+
+
+; dynamic-parse-formals: parses <formals>
+
+(define (dynamic-parse-formals formals)
+ ;; parses <formals>; see IEEE Scheme, sect. 7.3
+ ;; returns a pair: env and result
+ (letrec ((pfs (lambda (f-env formals)
+ (cond
+ ((null? formals)
+ (cons dynamic-empty-env (dynamic-parse-action-null-formal)))
+ ((pair? formals)
+ (let* ((fst-formal (car formals))
+ (rem-formals (cdr formals))
+ (bind-res (dynamic-parse-formal f-env fst-formal))
+ (bind (car bind-res))
+ (res (cdr bind-res))
+ (nf-env (extend-env-with-binding f-env bind))
+ (renv-res* (pfs nf-env rem-formals))
+ (renv (car renv-res*))
+ (res* (cdr renv-res*)))
+ (cons
+ (extend-env-with-binding renv bind)
+ (dynamic-parse-action-pair-formal res res*))))
+ (else
+ (let* ((bind-res (dynamic-parse-formal f-env formals))
+ (bind (car bind-res))
+ (res (cdr bind-res)))
+ (cons
+ (extend-env-with-binding dynamic-empty-env bind)
+ res)))))))
+ (pfs dynamic-empty-env formals)))
+
+
+; Expr
+
+; dynamic-parse-expression: parses nonterminal <expression>
+
+(define (dynamic-parse-expression env e)
+ (cond
+ ((symbol? e)
+ (dynamic-parse-variable env e))
+ ((pair? e)
+ (let ((op (car e)) (args (cdr e)))
+ (case op
+ ((quote) (dynamic-parse-quote env args))
+ ((lambda) (dynamic-parse-lambda env args))
+ ((if) (dynamic-parse-if env args))
+ ((set!) (dynamic-parse-set env args))
+ ((begin) (dynamic-parse-begin env args))
+ ((cond) (dynamic-parse-cond env args))
+ ((case) (dynamic-parse-case env args))
+ ((and) (dynamic-parse-and env args))
+ ((or) (dynamic-parse-or env args))
+ ((let) (dynamic-parse-let env args))
+ ((let*) (dynamic-parse-let* env args))
+ ((letrec) (dynamic-parse-letrec env args))
+ ((do) (dynamic-parse-do env args))
+ ((quasiquote) (dynamic-parse-quasiquote env args))
+ (else (dynamic-parse-procedure-call env op args)))))
+ (else (dynamic-parse-datum e))))
+
+; dynamic-parse-expression*
+
+(define (dynamic-parse-expression* env exprs)
+ ;; Parses lists of expressions (returns them in the right order!)
+ (letrec ((pe*
+ (lambda (results es)
+ (cond
+ ((null? es) results)
+ ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
+ (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es))))))
+ (reverse (pe* '() exprs))))
+
+
+; dynamic-parse-expressions
+
+(define (dynamic-parse-expressions env exprs)
+ ;; parses lists of arguments of a procedure call
+ (cond
+ ((null? exprs) (dynamic-parse-action-null-arg))
+ ((pair? exprs) (let* ((fst-expr (car exprs))
+ (rem-exprs (cdr exprs))
+ (fst-res (dynamic-parse-expression env fst-expr))
+ (rem-res (dynamic-parse-expressions env rem-exprs)))
+ (dynamic-parse-action-pair-arg fst-res rem-res)))
+ (else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
+ exprs))))
+
+
+; dynamic-parse-variable: parses variables (applied occurrences)
+
+(define (dynamic-parse-variable env e)
+ (if (symbol? e)
+ (if (memq e syntactic-keywords)
+ (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e)
+ (let ((assoc-var-def (dynamic-lookup e env)))
+ (if assoc-var-def
+ (dynamic-parse-action-variable (binding-value assoc-var-def))
+ (dynamic-parse-action-identifier e))))
+ (error 'dynamic-parse-variable "Not an identifier: ~s" e)))
+
+
+; dynamic-parse-procedure-call
+
+(define (dynamic-parse-procedure-call env op args)
+ (dynamic-parse-action-procedure-call
+ (dynamic-parse-expression env op)
+ (dynamic-parse-expressions env args)))
+
+
+; dynamic-parse-quote
+
+(define (dynamic-parse-quote env args)
+ (if (list-of-1? args)
+ (dynamic-parse-datum (car args))
+ (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args)))
+
+
+; dynamic-parse-lambda
+
+(define (dynamic-parse-lambda env args)
+ (if (pair? args)
+ (let* ((formals (car args))
+ (body (cdr args))
+ (nenv-fresults (dynamic-parse-formals formals))
+ (nenv (car nenv-fresults))
+ (fresults (cdr nenv-fresults)))
+ (dynamic-parse-action-lambda-expression
+ fresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args)))
+
+
+; dynamic-parse-body
+
+(define (dynamic-parse-body env body)
+ ; <body> = <definition>* <expression>+
+ (define (def-var* f-env body)
+ ; finds the defined variables in a body and returns an
+ ; environment containing them
+ (if (pair? body)
+ (let ((n-env (def-var f-env (car body))))
+ (if n-env
+ (def-var* n-env (cdr body))
+ f-env))
+ f-env))
+ (define (def-var f-env clause)
+ ; finds the defined variables in a single clause and extends
+ ; f-env accordingly; returns false if it's not a definition
+ (if (pair? clause)
+ (case (car clause)
+ ((define) (if (pair? (cdr clause))
+ (let ((pattern (cadr clause)))
+ (cond
+ ((symbol? pattern)
+ (extend-env-with-binding
+ f-env
+ (gen-binding pattern
+ (dynamic-parse-action-var-def pattern))))
+ ((and (pair? pattern) (symbol? (car pattern)))
+ (extend-env-with-binding
+ f-env
+ (gen-binding (car pattern)
+ (dynamic-parse-action-var-def
+ (car pattern)))))
+ (else f-env)))
+ f-env))
+ ((begin) (def-var* f-env (cdr clause)))
+ (else #f))
+ #f))
+ (if (pair? body)
+ (dynamic-parse-command* (def-var* env body) body)
+ (error 'dynamic-parse-body "Illegal body: ~s" body)))
+
+; dynamic-parse-if
+
+(define (dynamic-parse-if env args)
+ (cond
+ ((list-of-3? args)
+ (dynamic-parse-action-conditional
+ (dynamic-parse-expression env (car args))
+ (dynamic-parse-expression env (cadr args))
+ (dynamic-parse-expression env (caddr args))))
+ ((list-of-2? args)
+ (dynamic-parse-action-conditional
+ (dynamic-parse-expression env (car args))
+ (dynamic-parse-expression env (cadr args))
+ (dynamic-parse-action-empty)))
+ (else (error 'dynamic-parse-if "Not an if-expression: ~s" args))))
+
+
+; dynamic-parse-set
+
+(define (dynamic-parse-set env args)
+ (if (list-of-2? args)
+ (dynamic-parse-action-assignment
+ (dynamic-parse-variable env (car args))
+ (dynamic-parse-expression env (cadr args)))
+ (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args)))
+
+
+; dynamic-parse-begin
+
+(define (dynamic-parse-begin env args)
+ (dynamic-parse-action-begin-expression
+ (dynamic-parse-body env args)))
+
+
+; dynamic-parse-cond
+
+(define (dynamic-parse-cond env args)
+ (if (and (pair? args) (list? args))
+ (dynamic-parse-action-cond-expression
+ (map (lambda (e)
+ (dynamic-parse-cond-clause env e))
+ args))
+ (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))
+
+; dynamic-parse-cond-clause
+
+(define (dynamic-parse-cond-clause env e)
+ ;; ***Note***: Only (<test> <sequence>) is permitted!
+ (if (pair? e)
+ (cons
+ (if (eqv? (car e) 'else)
+ (dynamic-parse-action-empty)
+ (dynamic-parse-expression env (car e)))
+ (dynamic-parse-body env (cdr e)))
+ (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))
+
+
+; dynamic-parse-and
+
+(define (dynamic-parse-and env args)
+ (if (list? args)
+ (dynamic-parse-action-and-expression
+ (dynamic-parse-expression* env args))
+ (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))
+
+
+; dynamic-parse-or
+
+(define (dynamic-parse-or env args)
+ (if (list? args)
+ (dynamic-parse-action-or-expression
+ (dynamic-parse-expression* env args))
+ (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))
+
+
+; dynamic-parse-case
+
+(define (dynamic-parse-case env args)
+ (if (and (list? args) (> (length args) 1))
+ (dynamic-parse-action-case-expression
+ (dynamic-parse-expression env (car args))
+ (map (lambda (e)
+ (dynamic-parse-case-clause env e))
+ (cdr args)))
+ (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))
+
+; dynamic-parse-case-clause
+
+(define (dynamic-parse-case-clause env e)
+ (if (pair? e)
+ (cons
+ (cond
+ ((eqv? (car e) 'else)
+ (list (dynamic-parse-action-empty)))
+ ((list? (car e))
+ (map dynamic-parse-datum (car e)))
+ (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
+ (dynamic-parse-body env (cdr e)))
+ (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))
+
+
+; dynamic-parse-let
+
+(define (dynamic-parse-let env args)
+ (if (pair? args)
+ (if (symbol? (car args))
+ (dynamic-parse-named-let env args)
+ (dynamic-parse-normal-let env args))
+ (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))
+
+
+; dynamic-parse-normal-let
+
+(define (dynamic-parse-normal-let env args)
+ ;; parses "normal" let-expressions
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-parallel-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-let-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body))))
+
+; dynamic-parse-named-let
+
+(define (dynamic-parse-named-let env args)
+ ;; parses a named let-expression
+ (if (pair? (cdr args))
+ (let* ((variable (car args))
+ (bindings (cadr args))
+ (body (cddr args))
+ (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
+ (vbind (car vbind-vres))
+ (vres (cdr vbind-vres))
+ (env-ast (dynamic-parse-parallel-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-named-let-expression
+ vres bresults
+ (dynamic-parse-body (extend-env-with-env
+ (extend-env-with-binding env vbind)
+ nenv) body)))
+ (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))
+
+
+; dynamic-parse-parallel-bindings
+
+(define (dynamic-parse-parallel-bindings env bindings)
+ ; returns a pair consisting of an environment
+ ; and a list of pairs (variable . asg)
+ ; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (if (list-of-list-of-2s? bindings)
+ (let* ((env-formals-asg
+ (dynamic-parse-formal* (map car bindings)))
+ (nenv (car env-formals-asg))
+ (bresults (cdr env-formals-asg))
+ (exprs-asg
+ (dynamic-parse-expression* env (map cadr bindings))))
+ (cons nenv (cons bresults exprs-asg)))
+ (error 'dynamic-parse-parallel-bindings
+ "Not a list of bindings: ~s" bindings)))
+
+
+; dynamic-parse-let*
+
+(define (dynamic-parse-let* env args)
+ (if (pair? args)
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-sequential-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-let*-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))
+
+; dynamic-parse-sequential-bindings
+
+(define (dynamic-parse-sequential-bindings env bindings)
+ ; returns a pair consisting of an environment
+ ; and a list of pairs (variable . asg)
+ ;; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (letrec
+ ((psb
+ (lambda (f-env c-env var-defs expr-asgs binds)
+ ;; f-env: forbidden environment
+ ;; c-env: constructed environment
+ ;; var-defs: results of formals
+ ;; expr-asgs: results of corresponding expressions
+ ;; binds: reminding bindings to process
+ (cond
+ ((null? binds)
+ (cons f-env (cons var-defs expr-asgs)))
+ ((pair? binds)
+ (let ((fst-bind (car binds)))
+ (if (list-of-2? fst-bind)
+ (let* ((fbinding-bres
+ (dynamic-parse-formal f-env (car fst-bind)))
+ (fbind (car fbinding-bres))
+ (bres (cdr fbinding-bres))
+ (new-expr-asg
+ (dynamic-parse-expression c-env (cadr fst-bind))))
+ (psb
+ (extend-env-with-binding f-env fbind)
+ (extend-env-with-binding c-env fbind)
+ (cons bres var-defs)
+ (cons new-expr-asg expr-asgs)
+ (cdr binds)))
+ (error 'dynamic-parse-sequential-bindings
+ "Illegal binding: ~s" fst-bind))))
+ (else (error 'dynamic-parse-sequential-bindings
+ "Illegal bindings: ~s" binds))))))
+ (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
+ (cons (car env-vdefs-easgs)
+ (cons (reverse (cadr env-vdefs-easgs))
+ (reverse (cddr env-vdefs-easgs)))))))
+
+
+; dynamic-parse-letrec
+
+(define (dynamic-parse-letrec env args)
+ (if (pair? args)
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-recursive-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-letrec-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))
+
+; dynamic-parse-recursive-bindings
+
+(define (dynamic-parse-recursive-bindings env bindings)
+ ;; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (if (list-of-list-of-2s? bindings)
+ (let* ((env-formals-asg
+ (dynamic-parse-formal* (map car bindings)))
+ (formals-env
+ (car env-formals-asg))
+ (formals-res
+ (cdr env-formals-asg))
+ (exprs-asg
+ (dynamic-parse-expression*
+ (extend-env-with-env env formals-env)
+ (map cadr bindings))))
+ (cons
+ formals-env
+ (cons formals-res exprs-asg)))
+ (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
+
+
+; dynamic-parse-do
+
+(define (dynamic-parse-do env args)
+ ;; parses do-expressions
+ ;; ***Note***: Not implemented!
+ (error 'dynamic-parse-do "Nothing yet..."))
+
+; dynamic-parse-quasiquote
+
+(define (dynamic-parse-quasiquote env args)
+ ;; ***Note***: Not implemented!
+ (error 'dynamic-parse-quasiquote "Nothing yet..."))
+
+
+;; Command
+
+; dynamic-parse-command
+
+(define (dynamic-parse-command env c)
+ (if (pair? c)
+ (let ((op (car c))
+ (args (cdr c)))
+ (case op
+ ((define) (dynamic-parse-define env args))
+; ((begin) (dynamic-parse-command* env args)) ;; AKW
+ ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
+ (else (dynamic-parse-expression env c))))
+ (dynamic-parse-expression env c)))
+
+
+; dynamic-parse-command*
+
+(define (dynamic-parse-command* env commands)
+ ;; parses a sequence of commands
+ (if (list? commands)
+ (map (lambda (command) (dynamic-parse-command env command)) commands)
+ (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))
+
+
+; dynamic-parse-define
+
+(define (dynamic-parse-define env args)
+ ;; three cases -- see IEEE Scheme, sect. 5.2
+ ;; ***Note***: the parser admits forms (define (x . y) ...)
+ ;; ***Note***: Variables are treated as applied occurrences!
+ (if (pair? args)
+ (let ((pattern (car args))
+ (exp-or-body (cdr args)))
+ (cond
+ ((symbol? pattern)
+ (if (list-of-1? exp-or-body)
+ (dynamic-parse-action-definition
+ (dynamic-parse-variable env pattern)
+ (dynamic-parse-expression env (car exp-or-body)))
+ (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
+ ((pair? pattern)
+ (let* ((function-name (car pattern))
+ (function-arg-names (cdr pattern))
+ (env-ast (dynamic-parse-formals function-arg-names))
+ (formals-env (car env-ast))
+ (formals-ast (cdr env-ast)))
+ (dynamic-parse-action-function-definition
+ (dynamic-parse-variable env function-name)
+ formals-ast
+ (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
+ (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
+ (error 'dynamic-parse-define "Not a valid definition: ~s" args)))
+
+;; Auxiliary routines
+
+; forall?
+
+(define (forall? pred list)
+ (if (null? list)
+ #t
+ (and (pred (car list)) (forall? pred (cdr list)))))
+
+; list-of-1?
+
+(define (list-of-1? l)
+ (and (pair? l) (null? (cdr l))))
+
+; list-of-2?
+
+(define (list-of-2? l)
+ (and (pair? l) (pair? (cdr l)) (null? (cddr l))))
+
+; list-of-3?
+
+(define (list-of-3? l)
+ (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))
+
+; list-of-list-of-2s?
+
+(define (list-of-list-of-2s? e)
+ (cond
+ ((null? e)
+ #t)
+ ((pair? e)
+ (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
+ (else #f)))
+
+
+;; File processing
+
+; dynamic-parse-from-port
+
+(define (dynamic-parse-from-port port)
+ (let ((next-input (read port)))
+ (if (eof-object? next-input)
+ '()
+ (dynamic-parse-action-commands
+ (dynamic-parse-command dynamic-empty-env next-input)
+ (dynamic-parse-from-port port)))))
+
+; dynamic-parse-file
+
+(define (dynamic-parse-file file-name)
+ (let ((input-port (open-input-file file-name)))
+ (dynamic-parse-from-port input-port)))
+;----------------------------------------------------------------------------
+; Implementation of Union/find data structure in Scheme
+;----------------------------------------------------------------------------
+
+;; for union/find the following attributes are necessary: rank, parent
+;; (see Tarjan, "Data structures and network algorithms", 1983)
+;; In the Scheme realization an element is represented as a single
+;; cons cell; its address is the element itself; the car field contains
+;; the parent, the cdr field is an address for a cons
+;; cell containing the rank (car field) and the information (cdr field)
+
+
+;; general union/find data structure
+;;
+;; gen-element: Info -> Elem
+;; find: Elem -> Elem
+;; link: Elem! x Elem! -> Elem
+;; asymm-link: Elem! x Elem! -> Elem
+;; info: Elem -> Info
+;; set-info!: Elem! x Info -> Void
+
+
+(define (gen-element info)
+ ; generates a new element: the parent field is initialized to '(),
+ ; the rank field to 0
+ (cons '() (cons 0 info)))
+
+(define info (lambda (l) (cddr l)))
+ ; returns the information stored in an element
+
+(define (set-info! elem info)
+ ; sets the info-field of elem to info
+ (set-cdr! (cdr elem) info))
+
+; (define (find! x)
+; ; finds the class representative of x and sets the parent field
+; ; directly to the class representative (a class representative has
+; ; '() as its parent) (uses path halving)
+; ;(display "Find!: ")
+; ;(display (pretty-print (info x)))
+; ;(newline)
+; (let ((px (car x)))
+; (if (null? px)
+; x
+; (let ((ppx (car px)))
+; (if (null? ppx)
+; px
+; (begin
+; (set-car! x ppx)
+; (find! ppx)))))))
+
+(define (find! elem)
+ ; finds the class representative of elem and sets the parent field
+ ; directly to the class representative (a class representative has
+ ; '() as its parent)
+ ;(display "Find!: ")
+ ;(display (pretty-print (info elem)))
+ ;(newline)
+ (let ((p-elem (car elem)))
+ (if (null? p-elem)
+ elem
+ (let ((rep-elem (find! p-elem)))
+ (set-car! elem rep-elem)
+ rep-elem))))
+
+(define (link! elem-1 elem-2)
+ ; links class elements by rank
+ ; they must be distinct class representatives
+ ; returns the class representative of the merged equivalence classes
+ ;(display "Link!: ")
+ ;(display (pretty-print (list (info elem-1) (info elem-2))))
+ ;(newline)
+ (let ((rank-1 (cadr elem-1))
+ (rank-2 (cadr elem-2)))
+ (cond
+ ((= rank-1 rank-2)
+ (set-car! (cdr elem-2) (+ rank-2 1))
+ (set-car! elem-1 elem-2)
+ elem-2)
+ ((> rank-1 rank-2)
+ (set-car! elem-2 elem-1)
+ elem-1)
+ (else
+ (set-car! elem-1 elem-2)
+ elem-2))))
+
+(define asymm-link! (lambda (l x) (set-car! l x)))
+
+;(define (asymm-link! elem-1 elem-2)
+ ; links elem-1 onto elem-2 no matter what rank;
+ ; does not update the rank of elem-2 and does not return a value
+ ; the two arguments must be distinct
+ ;(display "AsymmLink: ")
+ ;(display (pretty-print (list (info elem-1) (info elem-2))))
+ ;(newline)
+ ;(set-car! elem-1 elem-2))
+
+;----------------------------------------------------------------------------
+; Type management
+;----------------------------------------------------------------------------
+
+; introduces type variables and types for Scheme,
+
+
+;; type TVar (type variables)
+;;
+;; gen-tvar: () -> TVar
+;; gen-type: TCon x TVar* -> TVar
+;; dynamic: TVar
+;; tvar-id: TVar -> Symbol
+;; tvar-def: TVar -> Type + Null
+;; tvar-show: TVar -> Symbol*
+;;
+;; set-def!: !TVar x TCon x TVar* -> Null
+;; equiv!: !TVar x !TVar -> Null
+;;
+;;
+;; type TCon (type constructors)
+;;
+;; ...
+;;
+;; type Type (types)
+;;
+;; gen-type: TCon x TVar* -> Type
+;; type-con: Type -> TCon
+;; type-args: Type -> TVar*
+;;
+;; boolean: TVar
+;; character: TVar
+;; null: TVar
+;; pair: TVar x TVar -> TVar
+;; procedure: TVar x TVar* -> TVar
+;; charseq: TVar
+;; symbol: TVar
+;; array: TVar -> TVar
+
+
+; Needed packages: union/find
+
+;(load "union-fi.so")
+
+; TVar
+
+(define counter 0)
+; counter for generating tvar id's
+
+(define (gen-id)
+ ; generates a new id (for printing purposes)
+ (set! counter (+ counter 1))
+ counter)
+
+(define (gen-tvar)
+ ; generates a new type variable from a new symbol
+ ; uses union/find elements with two info fields
+ ; a type variable has exactly four fields:
+ ; car: TVar (the parent field; initially null)
+ ; cadr: Number (the rank field; is always nonnegative)
+ ; caddr: Symbol (the type variable identifier; used only for printing)
+ ; cdddr: Type (the leq field; initially null)
+ (gen-element (cons (gen-id) '())))
+
+(define (gen-type tcon targs)
+ ; generates a new type variable with an associated type definition
+ (gen-element (cons (gen-id) (cons tcon targs))))
+
+(define dynamic (gen-element (cons 0 '())))
+; the special type variable dynamic
+; Generic operations
+
+(define (tvar-id tvar)
+ ; returns the (printable) symbol representing the type variable
+ (car (info tvar)))
+
+(define (tvar-def tvar)
+ ; returns the type definition (if any) of the type variable
+ (cdr (info tvar)))
+
+(define (set-def! tvar tcon targs)
+ ; sets the type definition part of tvar to type
+ (set-cdr! (info tvar) (cons tcon targs))
+ '())
+
+(define (reset-def! tvar)
+ ; resets the type definition part of tvar to nil
+ (set-cdr! (info tvar) '()))
+
+(define type-con (lambda (l) (car l)))
+; returns the type constructor of a type definition
+
+(define type-args (lambda (l) (cdr l)))
+; returns the type variables of a type definition
+
+(define (tvar->string tvar)
+ ; converts a tvar's id to a string
+ (if (eqv? (tvar-id tvar) 0)
+ "Dynamic"
+ (string-append "t#" (number->string (tvar-id tvar) 10))))
+
+(define (tvar-show tv)
+ ; returns a printable list representation of type variable tv
+ (let* ((tv-rep (find! tv))
+ (tv-def (tvar-def tv-rep)))
+ (cons (tvar->string tv-rep)
+ (if (null? tv-def)
+ '()
+ (cons 'is (type-show tv-def))))))
+
+(define (type-show type)
+ ; returns a printable list representation of type definition type
+ (cond
+ ((eqv? (type-con type) ptype-con)
+ (let ((new-tvar (gen-tvar)))
+ (cons ptype-con
+ (cons (tvar-show new-tvar)
+ (tvar-show ((type-args type) new-tvar))))))
+ (else
+ (cons (type-con type)
+ (map (lambda (tv)
+ (tvar->string (find! tv)))
+ (type-args type))))))
+
+
+
+; Special type operations
+
+; type constructor literals
+
+(define boolean-con 'boolean)
+(define char-con 'char)
+(define null-con 'null)
+(define number-con 'number)
+(define pair-con 'pair)
+(define procedure-con 'procedure)
+(define string-con 'string)
+(define symbol-con 'symbol)
+(define vector-con 'vector)
+
+; type constants and type constructors
+
+(define (null)
+ ; ***Note***: Temporarily changed to be a pair!
+ ; (gen-type null-con '())
+ (pair (gen-tvar) (gen-tvar)))
+(define (boolean)
+ (gen-type boolean-con '()))
+(define (character)
+ (gen-type char-con '()))
+(define (number)
+ (gen-type number-con '()))
+(define (charseq)
+ (gen-type string-con '()))
+(define (symbol)
+ (gen-type symbol-con '()))
+(define (pair tvar-1 tvar-2)
+ (gen-type pair-con (list tvar-1 tvar-2)))
+(define (array tvar)
+ (gen-type vector-con (list tvar)))
+(define (procedure arg-tvar res-tvar)
+ (gen-type procedure-con (list arg-tvar res-tvar)))
+
+
+; equivalencing of type variables
+
+(define (equiv! tv1 tv2)
+ (let* ((tv1-rep (find! tv1))
+ (tv2-rep (find! tv2))
+ (tv1-def (tvar-def tv1-rep))
+ (tv2-def (tvar-def tv2-rep)))
+ (cond
+ ((eqv? tv1-rep tv2-rep)
+ '())
+ ((eqv? tv2-rep dynamic)
+ (equiv-with-dynamic! tv1-rep))
+ ((eqv? tv1-rep dynamic)
+ (equiv-with-dynamic! tv2-rep))
+ ((null? tv1-def)
+ (if (null? tv2-def)
+ ; both tv1 and tv2 are distinct type variables
+ (link! tv1-rep tv2-rep)
+ ; tv1 is a type variable, tv2 is a (nondynamic) type
+ (asymm-link! tv1-rep tv2-rep)))
+ ((null? tv2-def)
+ ; tv1 is a (nondynamic) type, tv2 is a type variable
+ (asymm-link! tv2-rep tv1-rep))
+ ((eqv? (type-con tv1-def) (type-con tv2-def))
+ ; both tv1 and tv2 are (nondynamic) types with equal numbers of
+ ; arguments
+ (link! tv1-rep tv2-rep)
+ (map equiv! (type-args tv1-def) (type-args tv2-def)))
+ (else
+ ; tv1 and tv2 are types with distinct type constructors or different
+ ; numbers of arguments
+ (equiv-with-dynamic! tv1-rep)
+ (equiv-with-dynamic! tv2-rep))))
+ '())
+
+(define (equiv-with-dynamic! tv)
+ (let ((tv-rep (find! tv)))
+ (if (not (eqv? tv-rep dynamic))
+ (let ((tv-def (tvar-def tv-rep)))
+ (asymm-link! tv-rep dynamic)
+ (if (not (null? tv-def))
+ (map equiv-with-dynamic! (type-args tv-def))))))
+ '())
+;----------------------------------------------------------------------------
+; Polymorphic type management
+;----------------------------------------------------------------------------
+
+; introduces parametric polymorphic types
+
+
+;; forall: (Tvar -> Tvar) -> TVar
+;; fix: (Tvar -> Tvar) -> Tvar
+;;
+;; instantiate-type: TVar -> TVar
+
+; type constructor literal for polymorphic types
+
+(define ptype-con 'forall)
+
+(define (forall tv-func)
+ (gen-type ptype-con tv-func))
+
+(define (forall2 tv-func2)
+ (forall (lambda (tv1)
+ (forall (lambda (tv2)
+ (tv-func2 tv1 tv2))))))
+
+(define (forall3 tv-func3)
+ (forall (lambda (tv1)
+ (forall2 (lambda (tv2 tv3)
+ (tv-func3 tv1 tv2 tv3))))))
+
+(define (forall4 tv-func4)
+ (forall (lambda (tv1)
+ (forall3 (lambda (tv2 tv3 tv4)
+ (tv-func4 tv1 tv2 tv3 tv4))))))
+
+(define (forall5 tv-func5)
+ (forall (lambda (tv1)
+ (forall4 (lambda (tv2 tv3 tv4 tv5)
+ (tv-func5 tv1 tv2 tv3 tv4 tv5))))))
+
+
+; (polymorphic) instantiation
+
+(define (instantiate-type tv)
+ ; instantiates type tv and returns a generic instance
+ (let* ((tv-rep (find! tv))
+ (tv-def (tvar-def tv-rep)))
+ (cond
+ ((null? tv-def)
+ tv-rep)
+ ((eqv? (type-con tv-def) ptype-con)
+ (instantiate-type ((type-args tv-def) (gen-tvar))))
+ (else
+ tv-rep))))
+
+(define (fix tv-func)
+ ; forms a recursive type: the fixed point of type mapping tv-func
+ (let* ((new-tvar (gen-tvar))
+ (inst-tvar (tv-func new-tvar))
+ (inst-def (tvar-def inst-tvar)))
+ (if (null? inst-def)
+ (error 'fix "Illegal recursive type: ~s"
+ (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
+ (begin
+ (set-def! new-tvar
+ (type-con inst-def)
+ (type-args inst-def))
+ new-tvar))))
+
+
+;----------------------------------------------------------------------------
+; Constraint management
+;----------------------------------------------------------------------------
+
+
+; constraints
+
+(define gen-constr (lambda (a b) (cons a b)))
+; generates an equality between tvar1 and tvar2
+
+(define constr-lhs (lambda (c) (car c)))
+; returns the left-hand side of a constraint
+
+(define constr-rhs (lambda (c) (cdr c)))
+; returns the right-hand side of a constraint
+
+(define (constr-show c)
+ (cons (tvar-show (car c))
+ (cons '=
+ (cons (tvar-show (cdr c)) '()))))
+
+
+; constraint set management
+
+(define global-constraints '())
+
+(define (init-global-constraints!)
+ (set! global-constraints '()))
+
+(define (add-constr! lhs rhs)
+ (set! global-constraints
+ (cons (gen-constr lhs rhs) global-constraints))
+ '())
+
+(define (glob-constr-show)
+ ; returns printable version of global constraints
+ (map constr-show global-constraints))
+
+
+; constraint normalization
+
+; Needed packages: type management
+
+;(load "typ-mgmt.so")
+
+(define (normalize-global-constraints!)
+ (normalize! global-constraints)
+ (init-global-constraints!))
+
+(define (normalize! constraints)
+ (map (lambda (c)
+ (equiv! (constr-lhs c) (constr-rhs c))) constraints))
+; ----------------------------------------------------------------------------
+; Abstract syntax definition and parse actions
+; ----------------------------------------------------------------------------
+
+; Needed packages: ast-gen.ss
+;(load "ast-gen.ss")
+
+;; Abstract syntax
+;;
+;; VarDef
+;;
+;; Identifier = Symbol - SyntacticKeywords
+;; SyntacticKeywords = { ... } (see Section 7.1, IEEE Scheme Standard)
+;;
+;; Datum
+;;
+;; null-const: Null -> Datum
+;; boolean-const: Bool -> Datum
+;; char-const: Char -> Datum
+;; number-const: Number -> Datum
+;; string-const: String -> Datum
+;; vector-const: Datum* -> Datum
+;; pair-const: Datum x Datum -> Datum
+;;
+;; Expr
+;;
+;; Datum < Expr
+;;
+;; var-def: Identifier -> VarDef
+;; variable: VarDef -> Expr
+;; identifier: Identifier -> Expr
+;; procedure-call: Expr x Expr* -> Expr
+;; lambda-expression: Formals x Body -> Expr
+;; conditional: Expr x Expr x Expr -> Expr
+;; assignment: Variable x Expr -> Expr
+;; cond-expression: CondClause+ -> Expr
+;; case-expression: Expr x CaseClause* -> Expr
+;; and-expression: Expr* -> Expr
+;; or-expression: Expr* -> Expr
+;; let-expression: (VarDef* x Expr*) x Body -> Expr
+;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
+;; let*-expression: (VarDef* x Expr*) x Body -> Expr
+;; letrec-expression: (VarDef* x Expr*) x Body -> Expr
+;; begin-expression: Expr+ -> Expr
+;; do-expression: IterDef* x CondClause x Expr* -> Expr
+;; empty: -> Expr
+;;
+;; VarDef* < Formals
+;;
+;; simple-formal: VarDef -> Formals
+;; dotted-formals: VarDef* x VarDef -> Formals
+;;
+;; Body = Definition* x Expr+ (reversed)
+;; CondClause = Expr x Expr+
+;; CaseClause = Datum* x Expr+
+;; IterDef = VarDef x Expr x Expr
+;;
+;; Definition
+;;
+;; definition: Identifier x Expr -> Definition
+;; function-definition: Identifier x Formals x Body -> Definition
+;; begin-command: Definition* -> Definition
+;;
+;; Expr < Command
+;; Definition < Command
+;;
+;; Program = Command*
+
+
+;; Abstract syntax operators
+
+; Datum
+
+(define null-const 0)
+(define boolean-const 1)
+(define char-const 2)
+(define number-const 3)
+(define string-const 4)
+(define symbol-const 5)
+(define vector-const 6)
+(define pair-const 7)
+
+; Bindings
+
+(define var-def 8)
+(define null-def 29)
+(define pair-def 30)
+
+; Expr
+
+(define variable 9)
+(define identifier 10)
+(define procedure-call 11)
+(define lambda-expression 12)
+(define conditional 13)
+(define assignment 14)
+(define cond-expression 15)
+(define case-expression 16)
+(define and-expression 17)
+(define or-expression 18)
+(define let-expression 19)
+(define named-let-expression 20)
+(define let*-expression 21)
+(define letrec-expression 22)
+(define begin-expression 23)
+(define do-expression 24)
+(define empty 25)
+(define null-arg 31)
+(define pair-arg 32)
+
+; Command
+
+(define definition 26)
+(define function-definition 27)
+(define begin-command 28)
+
+
+;; Parse actions for abstract syntax construction
+
+(define (dynamic-parse-action-null-const)
+ ;; dynamic-parse-action for '()
+ (ast-gen null-const '()))
+
+(define (dynamic-parse-action-boolean-const e)
+ ;; dynamic-parse-action for #f and #t
+ (ast-gen boolean-const e))
+
+(define (dynamic-parse-action-char-const e)
+ ;; dynamic-parse-action for character constants
+ (ast-gen char-const e))
+
+(define (dynamic-parse-action-number-const e)
+ ;; dynamic-parse-action for number constants
+ (ast-gen number-const e))
+
+(define (dynamic-parse-action-string-const e)
+ ;; dynamic-parse-action for string literals
+ (ast-gen string-const e))
+
+(define (dynamic-parse-action-symbol-const e)
+ ;; dynamic-parse-action for symbol constants
+ (ast-gen symbol-const e))
+
+(define (dynamic-parse-action-vector-const e)
+ ;; dynamic-parse-action for vector literals
+ (ast-gen vector-const e))
+
+(define (dynamic-parse-action-pair-const e1 e2)
+ ;; dynamic-parse-action for pairs
+ (ast-gen pair-const (cons e1 e2)))
+
+(define (dynamic-parse-action-var-def e)
+ ;; dynamic-parse-action for defining occurrences of variables;
+ ;; e is a symbol
+ (ast-gen var-def e))
+
+(define (dynamic-parse-action-null-formal)
+ ;; dynamic-parse-action for null-list of formals
+ (ast-gen null-def '()))
+
+(define (dynamic-parse-action-pair-formal d1 d2)
+ ;; dynamic-parse-action for non-null list of formals;
+ ;; d1 is the result of parsing the first formal,
+ ;; d2 the result of parsing the remaining formals
+ (ast-gen pair-def (cons d1 d2)))
+
+(define (dynamic-parse-action-variable e)
+ ;; dynamic-parse-action for applied occurrences of variables
+ ;; ***Note***: e is the result of a dynamic-parse-action on the
+ ;; corresponding variable definition!
+ (ast-gen variable e))
+
+(define (dynamic-parse-action-identifier e)
+ ;; dynamic-parse-action for undeclared identifiers (free variable
+ ;; occurrences)
+ ;; ***Note***: e is a symbol (legal identifier)
+ (ast-gen identifier e))
+
+(define (dynamic-parse-action-null-arg)
+ ;; dynamic-parse-action for a null list of arguments in a procedure call
+ (ast-gen null-arg '()))
+
+(define (dynamic-parse-action-pair-arg a1 a2)
+ ;; dynamic-parse-action for a non-null list of arguments in a procedure call
+ ;; a1 is the result of parsing the first argument,
+ ;; a2 the result of parsing the remaining arguments
+ (ast-gen pair-arg (cons a1 a2)))
+
+(define (dynamic-parse-action-procedure-call op args)
+ ;; dynamic-parse-action for procedure calls: op function, args list of arguments
+ (ast-gen procedure-call (cons op args)))
+
+(define (dynamic-parse-action-lambda-expression formals body)
+ ;; dynamic-parse-action for lambda-abstractions
+ (ast-gen lambda-expression (cons formals body)))
+
+(define (dynamic-parse-action-conditional test then-branch else-branch)
+ ;; dynamic-parse-action for conditionals (if-then-else expressions)
+ (ast-gen conditional (cons test (cons then-branch else-branch))))
+
+(define (dynamic-parse-action-empty)
+ ;; dynamic-parse-action for missing or empty field
+ (ast-gen empty '()))
+
+(define (dynamic-parse-action-assignment lhs rhs)
+ ;; dynamic-parse-action for assignment
+ (ast-gen assignment (cons lhs rhs)))
+
+(define (dynamic-parse-action-begin-expression body)
+ ;; dynamic-parse-action for begin-expression
+ (ast-gen begin-expression body))
+
+(define (dynamic-parse-action-cond-expression clauses)
+ ;; dynamic-parse-action for cond-expressions
+ (ast-gen cond-expression clauses))
+
+(define (dynamic-parse-action-and-expression args)
+ ;; dynamic-parse-action for and-expressions
+ (ast-gen and-expression args))
+
+(define (dynamic-parse-action-or-expression args)
+ ;; dynamic-parse-action for or-expressions
+ (ast-gen or-expression args))
+
+(define (dynamic-parse-action-case-expression key clauses)
+ ;; dynamic-parse-action for case-expressions
+ (ast-gen case-expression (cons key clauses)))
+
+(define (dynamic-parse-action-let-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen let-expression (cons bindings body)))
+
+(define (dynamic-parse-action-named-let-expression variable bindings body)
+ ;; dynamic-parse-action for named-let expressions
+ (ast-gen named-let-expression (cons variable (cons bindings body))))
+
+(define (dynamic-parse-action-let*-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen let*-expression (cons bindings body)))
+
+(define (dynamic-parse-action-letrec-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen letrec-expression (cons bindings body)))
+
+(define (dynamic-parse-action-definition variable expr)
+ ;; dynamic-parse-action for simple definitions
+ (ast-gen definition (cons variable expr)))
+
+(define (dynamic-parse-action-function-definition variable formals body)
+ ;; dynamic-parse-action for function definitions
+ (ast-gen function-definition (cons variable (cons formals body))))
+
+
+(define dynamic-parse-action-commands (lambda (a b) (cons a b)))
+;; dynamic-parse-action for processing a command result followed by a the
+;; result of processing the remaining commands
+
+
+;; Pretty-printing abstract syntax trees
+
+(define (ast-show ast)
+ ;; converts abstract syntax tree to list representation (Scheme program)
+ ;; ***Note***: check translation of constructors to numbers at the top of the file
+ (let ((syntax-op (ast-con ast))
+ (syntax-arg (ast-arg ast)))
+ (case syntax-op
+ ((0 1 2 3 4 8 10) syntax-arg)
+ ((29 31) '())
+ ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((5) (list 'quote syntax-arg))
+ ((6) (list->vector (map ast-show syntax-arg)))
+ ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((12) (cons 'lambda (cons (ast-show (car syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((13) (cons 'if (cons (ast-show (car syntax-arg))
+ (cons (ast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (ast-show alt))))))))
+ ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (ast-show guard))
+ (map ast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (ast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map ast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map ast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map ast-show syntax-arg)))
+ ((18) (cons 'or (map ast-show syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (ast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map ast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map ast-show syntax-arg)))
+ ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'ast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (ast-show (car syntax-arg))
+ (ast-show (cdr syntax-arg))))
+ ((27) (cons 'define
+ (cons
+ (cons (ast-show (car syntax-arg))
+ (ast-show (cadr syntax-arg)))
+ (map ast-show (cddr syntax-arg)))))
+ ((28) (cons 'begin
+ (map ast-show syntax-arg)))
+ (else (error 'ast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))))
+
+
+;; ast*-show
+
+(define (ast*-show p)
+ ;; shows a list of abstract syntax trees
+ (map ast-show p))
+
+
+;; datum-show
+
+(define (datum-show ast)
+ ;; prints an abstract syntax tree as a datum
+ (case (ast-con ast)
+ ((0 1 2 3 4 5) (ast-arg ast))
+ ((6) (list->vector (map datum-show (ast-arg ast))))
+ ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
+ (else (error 'datum-show "This should not happen!"))))
+
+; write-to-port
+
+(define (write-to-port prog port)
+ ; writes a program to a port
+ (for-each
+ (lambda (command)
+ (pretty-print command port)
+ (newline port))
+ prog)
+ '())
+
+; write-file
+
+(define (write-to-file prog filename)
+ ; write a program to a file
+ (let ((port (open-output-file filename)))
+ (write-to-port prog port)
+ (close-output-port port)
+ '()))
+
+; ----------------------------------------------------------------------------
+; Typed abstract syntax tree management: constraint generation, display, etc.
+; ----------------------------------------------------------------------------
+
+
+;; Abstract syntax operations, incl. constraint generation
+
+(define (ast-gen syntax-op arg)
+ ; generates all attributes and performs semantic side effects
+ (let ((ntvar
+ (case syntax-op
+ ((0 29 31) (null))
+ ((1) (boolean))
+ ((2) (character))
+ ((3) (number))
+ ((4) (charseq))
+ ((5) (symbol))
+ ((6) (let ((aux-tvar (gen-tvar)))
+ (for-each (lambda (t)
+ (add-constr! t aux-tvar))
+ (map ast-tvar arg))
+ (array aux-tvar)))
+ ((7 30 32) (let ((t1 (ast-tvar (car arg)))
+ (t2 (ast-tvar (cdr arg))))
+ (pair t1 t2)))
+ ((8) (gen-tvar))
+ ((9) (ast-tvar arg))
+ ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
+ (if in-env
+ (instantiate-type (binding-value in-env))
+ (let ((new-tvar (gen-tvar)))
+ (set! dynamic-top-level-env (extend-env-with-binding
+ dynamic-top-level-env
+ (gen-binding arg new-tvar)))
+ new-tvar))))
+ ((11) (let ((new-tvar (gen-tvar)))
+ (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
+ (ast-tvar (car arg)))
+ new-tvar))
+ ((12) (procedure (ast-tvar (car arg))
+ (ast-tvar (tail (cdr arg)))))
+ ((13) (let ((t-test (ast-tvar (car arg)))
+ (t-consequent (ast-tvar (cadr arg)))
+ (t-alternate (ast-tvar (cddr arg))))
+ (add-constr! (boolean) t-test)
+ (add-constr! t-consequent t-alternate)
+ t-consequent))
+ ((14) (let ((var-tvar (ast-tvar (car arg)))
+ (exp-tvar (ast-tvar (cdr arg))))
+ (add-constr! var-tvar exp-tvar)
+ var-tvar))
+ ((15) (let ((new-tvar (gen-tvar)))
+ (for-each (lambda (body)
+ (add-constr! (ast-tvar (tail body)) new-tvar))
+ (map cdr arg))
+ (for-each (lambda (e)
+ (add-constr! (boolean) (ast-tvar e)))
+ (map car arg))
+ new-tvar))
+ ((16) (let* ((new-tvar (gen-tvar))
+ (t-key (ast-tvar (car arg)))
+ (case-clauses (cdr arg)))
+ (for-each (lambda (exprs)
+ (for-each (lambda (e)
+ (add-constr! (ast-tvar e) t-key))
+ exprs))
+ (map car case-clauses))
+ (for-each (lambda (body)
+ (add-constr! (ast-tvar (tail body)) new-tvar))
+ (map cdr case-clauses))
+ new-tvar))
+ ((17 18) (for-each (lambda (e)
+ (add-constr! (boolean) (ast-tvar e)))
+ arg)
+ (boolean))
+ ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
+ (def-expr-types (map ast-tvar (cdar arg)))
+ (body-type (ast-tvar (tail (cdr arg)))))
+ (for-each add-constr! var-def-tvars def-expr-types)
+ body-type))
+ ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
+ (def-expr-types (map ast-tvar (cdadr arg)))
+ (body-type (ast-tvar (tail (cddr arg))))
+ (named-var-type (ast-tvar (car arg))))
+ (for-each add-constr! var-def-tvars def-expr-types)
+ (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
+ named-var-type)
+ body-type))
+ ((23) (ast-tvar (tail arg)))
+ ((24) (error 'ast-gen
+ "Do-expressions not handled! (Argument: ~s) arg"))
+ ((25) (gen-tvar))
+ ((26) (let ((t-var (ast-tvar (car arg)))
+ (t-exp (ast-tvar (cdr arg))))
+ (add-constr! t-var t-exp)
+ t-var))
+ ((27) (let ((t-var (ast-tvar (car arg)))
+ (t-formals (ast-tvar (cadr arg)))
+ (t-body (ast-tvar (tail (cddr arg)))))
+ (add-constr! (procedure t-formals t-body) t-var)
+ t-var))
+ ((28) (gen-tvar))
+ (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
+ (cons syntax-op (cons ntvar arg))))
+
+(define ast-con car)
+;; extracts the ast-constructor from an abstract syntax tree
+
+(define ast-arg cddr)
+;; extracts the ast-argument from an abstract syntax tree
+
+(define ast-tvar cadr)
+;; extracts the tvar from an abstract syntax tree
+
+
+;; tail
+
+(define (tail l)
+ ;; returns the tail of a nonempty list
+ (if (null? (cdr l))
+ (car l)
+ (tail (cdr l))))
+
+; convert-tvars
+
+(define (convert-tvars tvar-list)
+ ;; converts a list of tvars to a single tvar
+ (cond
+ ((null? tvar-list) (null))
+ ((pair? tvar-list) (pair (car tvar-list)
+ (convert-tvars (cdr tvar-list))))
+ (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))
+
+
+;; Pretty-printing abstract syntax trees
+
+(define (tast-show ast)
+ ;; converts abstract syntax tree to list representation (Scheme program)
+ (let ((syntax-op (ast-con ast))
+ (syntax-tvar (tvar-show (ast-tvar ast)))
+ (syntax-arg (ast-arg ast)))
+ (cons
+ (case syntax-op
+ ((0 1 2 3 4 8 10) syntax-arg)
+ ((29 31) '())
+ ((30 32) (cons (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((5) (list 'quote syntax-arg))
+ ((6) (list->vector (map tast-show syntax-arg)))
+ ((7) (list 'cons (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
+ ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((13) (cons 'if (cons (tast-show (car syntax-arg))
+ (cons (tast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (tast-show alt))))))))
+ ((14) (list 'set! (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (tast-show guard))
+ (map tast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (tast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map tast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map tast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map tast-show syntax-arg)))
+ ((18) (cons 'or (map tast-show syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (tast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map tast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map tast-show syntax-arg)))
+ ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'tast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((27) (cons 'define
+ (cons
+ (cons (tast-show (car syntax-arg))
+ (tast-show (cadr syntax-arg)))
+ (map tast-show (cddr syntax-arg)))))
+ ((28) (cons 'begin
+ (map tast-show syntax-arg)))
+ (else (error 'tast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))
+ syntax-tvar)))
+
+;; tast*-show
+
+(define (tast*-show p)
+ ;; shows a list of abstract syntax trees
+ (map tast-show p))
+
+
+;; counters for tagging/untagging
+
+(define untag-counter 0)
+(define no-untag-counter 0)
+(define tag-counter 0)
+(define no-tag-counter 0)
+(define may-untag-counter 0)
+(define no-may-untag-counter 0)
+
+(define (reset-counters!)
+ (set! untag-counter 0)
+ (set! no-untag-counter 0)
+ (set! tag-counter 0)
+ (set! no-tag-counter 0)
+ (set! may-untag-counter 0)
+ (set! no-may-untag-counter 0))
+
+(define (counters-show)
+ (list
+ (cons tag-counter no-tag-counter)
+ (cons untag-counter no-untag-counter)
+ (cons may-untag-counter no-may-untag-counter)))
+
+
+;; tag-show
+
+(define (tag-show tvar-rep prog)
+ ; display prog with tagging operation
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! tag-counter (+ tag-counter 1))
+ (list 'tag prog))
+ (begin
+ (set! no-tag-counter (+ no-tag-counter 1))
+ (list 'no-tag prog))))
+
+
+;; untag-show
+
+(define (untag-show tvar-rep prog)
+ ; display prog with untagging operation
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! untag-counter (+ untag-counter 1))
+ (list 'untag prog))
+ (begin
+ (set! no-untag-counter (+ no-untag-counter 1))
+ (list 'no-untag prog))))
+
+(define (may-untag-show tvar-rep prog)
+ ; display possible untagging in actual arguments
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! may-untag-counter (+ may-untag-counter 1))
+ (list 'may-untag prog))
+ (begin
+ (set! no-may-untag-counter (+ no-may-untag-counter 1))
+ (list 'no-may-untag prog))))
+
+
+;; tag-ast-show
+
+(define (tag-ast-show ast)
+ ;; converts typed and normalized abstract syntax tree to
+ ;; a Scheme program with explicit tagging and untagging operations
+ (let ((syntax-op (ast-con ast))
+ (syntax-tvar (find! (ast-tvar ast)))
+ (syntax-arg (ast-arg ast)))
+ (case syntax-op
+ ((0 1 2 3 4)
+ (tag-show syntax-tvar syntax-arg))
+ ((8 10) syntax-arg)
+ ((29 31) '())
+ ((30) (cons (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
+ (tag-ast-show (car syntax-arg)))
+ (tag-ast-show (cdr syntax-arg))))
+ ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
+ ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
+ ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg)))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
+ (cons (untag-show proc-tvar
+ (tag-ast-show (car syntax-arg)))
+ (tag-ast-show (cdr syntax-arg)))))
+ ((12) (tag-show syntax-tvar
+ (cons 'lambda (cons (tag-ast-show (car syntax-arg))
+ (map tag-ast-show (cdr syntax-arg))))))
+ ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
+ (cons 'if (cons (untag-show test-tvar
+ (tag-ast-show (car syntax-arg)))
+ (cons (tag-ast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (tag-ast-show alt)))))))))
+ ((14) (list 'set! (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (untag-show (find! (ast-tvar guard))
+ (tag-ast-show guard)))
+ (map tag-ast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (tag-ast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map tag-ast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map tag-ast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map
+ (lambda (ast)
+ (let ((bool-tvar (find! (ast-tvar ast))))
+ (untag-show bool-tvar (tag-ast-show ast))))
+ syntax-arg)))
+ ((18) (cons 'or (map
+ (lambda (ast)
+ (let ((bool-tvar (find! (ast-tvar ast))))
+ (untag-show bool-tvar (tag-ast-show ast))))
+ syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (tag-ast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map tag-ast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map tag-ast-show syntax-arg)))
+ ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg)))))
+ (list 'define
+ (tag-ast-show (car syntax-arg))
+ (tag-show func-tvar
+ (cons 'lambda
+ (cons (tag-ast-show (cadr syntax-arg))
+ (map tag-ast-show (cddr syntax-arg))))))))
+ ((28) (cons 'begin
+ (map tag-ast-show syntax-arg)))
+ (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))))
+
+
+; tag-ast*-show
+
+(define (tag-ast*-show p)
+ ; display list of commands/expressions with tagging/untagging
+ ; operations
+ (map tag-ast-show p))
+; ----------------------------------------------------------------------------
+; Top level type environment
+; ----------------------------------------------------------------------------
+
+
+; Needed packages: type management (monomorphic and polymorphic)
+
+;(load "typ-mgmt.ss")
+;(load "ptyp-mgm.ss")
+
+
+; type environment for miscellaneous
+
+(define misc-env
+ (list
+ (cons 'quote (forall (lambda (tv) tv)))
+ (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ ))
+
+; type environment for input/output
+
+(define io-env
+ (list
+ (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic))
+ (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean)))
+ (cons 'read (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'write (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'display (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'newline (procedure (null) dynamic))
+ (cons 'pretty-print (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))))
+
+
+; type environment for Booleans
+
+(define boolean-env
+ (list
+ (cons 'boolean? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ ;(cons #f (boolean))
+ ; #f doesn't exist in Chez Scheme, but gets mapped to null!
+ (cons #t (boolean))
+ (cons 'not (procedure (convert-tvars (list (boolean))) (boolean)))
+ ))
+
+
+; type environment for pairs and lists
+
+(define (list-type tv)
+ (fix (lambda (tv2) (pair tv tv2))))
+
+(define list-env
+ (list
+ (cons 'pair? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'null? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'list? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'cons (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list tv1 tv2))
+ (pair tv1 tv2)))))
+ (cons 'car (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ tv1))))
+ (cons 'cdr (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ tv2))))
+ (cons 'set-car! (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)
+ tv1))
+ dynamic))))
+ (cons 'set-cdr! (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)
+ tv2))
+ dynamic))))
+ (cons 'caar (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 tv2) tv3)))
+ tv1))))
+ (cons 'cdar (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 tv2) tv3)))
+ tv2))))
+
+ (cons 'cadr (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 tv3))))
+ tv2))))
+ (cons 'cddr (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 tv3))))
+ tv3))))
+ (cons 'caaar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair (pair tv1 tv2) tv3) tv4)))
+ tv1))))
+ (cons 'cdaar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair (pair tv1 tv2) tv3) tv4)))
+ tv2))))
+ (cons 'cadar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
+ tv2))))
+ (cons 'cddar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
+ tv3))))
+ (cons 'caadr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair (pair tv2 tv3) tv4))))
+ tv2))))
+ (cons 'cdadr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair (pair tv2 tv3) tv4))))
+ tv3))))
+ (cons 'caddr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
+ tv3))))
+ (cons 'cdddr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
+ tv4))))
+ (cons 'cadddr
+ (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
+ (procedure (convert-tvars
+ (list (pair tv1
+ (pair tv2
+ (pair tv3
+ (pair tv4 tv5))))))
+ tv4))))
+ (cons 'cddddr
+ (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
+ (procedure (convert-tvars
+ (list (pair tv1
+ (pair tv2
+ (pair tv3
+ (pair tv4 tv5))))))
+ tv5))))
+ (cons 'list (forall (lambda (tv)
+ (procedure tv tv))))
+ (cons 'length (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)))
+ (number)))))
+ (cons 'append (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)
+ (list-type tv)))
+ (list-type tv)))))
+ (cons 'reverse (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)))
+ (list-type tv)))))
+ (cons 'list-ref (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)
+ (number)))
+ tv))))
+ (cons 'memq (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'memv (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'member (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'assq (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ (cons 'assv (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ (cons 'assoc (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ ))
+
+
+(define symbol-env
+ (list
+ (cons 'symbol? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq)))
+ (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol)))
+ ))
+
+(define number-env
+ (list
+ (cons 'number? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons '+ (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '- (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '* (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '/ (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons 'number->string (procedure (convert-tvars (list (number))) (charseq)))
+ (cons 'string->number (procedure (convert-tvars (list (charseq))) (number)))
+ ))
+
+(define char-env
+ (list
+ (cons 'char? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'char->integer (procedure (convert-tvars (list (character)))
+ (number)))
+ (cons 'integer->char (procedure (convert-tvars (list (number)))
+ (character)))
+ ))
+
+(define string-env
+ (list
+ (cons 'string? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ ))
+
+(define vector-env
+ (list
+ (cons 'vector? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'make-vector (forall (lambda (tv)
+ (procedure (convert-tvars (list (number)))
+ (array tv)))))
+ (cons 'vector-length (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)))
+ (number)))))
+ (cons 'vector-ref (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)
+ (number)))
+ tv))))
+ (cons 'vector-set! (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)
+ (number)
+ tv))
+ dynamic))))
+ ))
+
+(define procedure-env
+ (list
+ (cons 'procedure? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'map (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)
+ (list-type tv1)))
+ (list-type tv2)))))
+ (cons 'foreach (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)
+ (list-type tv1)))
+ (list-type tv2)))))
+ (cons 'call-with-current-continuation
+ (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure
+ (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)))
+ tv2)))
+ tv2))))
+ ))
+
+
+; global top level environment
+
+(define (global-env)
+ (append misc-env
+ io-env
+ boolean-env
+ symbol-env
+ number-env
+ char-env
+ string-env
+ vector-env
+ procedure-env
+ list-env))
+
+(define dynamic-top-level-env (global-env))
+
+(define (init-dynamic-top-level-env!)
+ (set! dynamic-top-level-env (global-env))
+ '())
+
+(define (dynamic-top-level-env-show)
+ ; displays the top level environment
+ (map (lambda (binding)
+ (cons (key-show (binding-key binding))
+ (cons ': (tvar-show (binding-value binding)))))
+ (env->list dynamic-top-level-env)))
+; ----------------------------------------------------------------------------
+; Dynamic type inference for Scheme
+; ----------------------------------------------------------------------------
+
+; Needed packages:
+
+(define (ic!) (init-global-constraints!))
+(define (pc) (glob-constr-show))
+(define (lc) (length global-constraints))
+(define (n!) (normalize-global-constraints!))
+(define (pt) (dynamic-top-level-env-show))
+(define (it!) (init-dynamic-top-level-env!))
+(define (io!) (set! tag-ops 0) (set! no-ops 0))
+(define (i!) (ic!) (it!) (io!) '())
+
+(define tag-ops 0)
+(define no-ops 0)
+
+
+; This wasn't intended to be an i/o benchmark,
+; so let's read the file just once.
+
+(define *forms*
+ (call-with-input-file
+ "dynamic-input.sch"
+ (lambda (port)
+ (define (loop forms)
+ (let ((form (read port)))
+ (if (eof-object? form)
+ (reverse forms)
+ (loop (cons form forms)))))
+ (loop '()))))
+
+(define (dynamic-parse-forms forms)
+ (if (null? forms)
+ '()
+ (let ((next-input (car forms)))
+ (dynamic-parse-action-commands
+ (dynamic-parse-command dynamic-empty-env next-input)
+ (dynamic-parse-forms (cdr forms))))))
+
+(define doit
+ (lambda ()
+ (i!)
+ (let ((foo (dynamic-parse-forms *forms*)))
+ (normalize-global-constraints!)
+ (reset-counters!)
+ (tag-ast*-show foo)
+ (counters-show))))
+
+(define (dynamic-benchmark . rest)
+ (let ((n (if (null? rest) 1 (car rest))))
+ (run-benchmark "dynamic"
+ n
+ doit
+ (lambda (result)
+ #t))))
+
+; eof
--- /dev/null
+;;; EARLEY -- Earley's parser, written by Marc Feeley.
+
+; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $
+; 990708 / lth -- changed 'main' to 'earley-benchmark'.
+;
+; (make-parser grammar lexer) is used to create a parser from the grammar
+; description `grammar' and the lexer function `lexer'.
+;
+; A grammar is a list of definitions. Each definition defines a non-terminal
+; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
+; A given non-terminal can only be defined once. The first non-terminal
+; defined is the grammar's goal. Each rule is a possibly empty list of
+; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
+; can be any scheme value. Note that all grammar symbols are treated as
+; non-terminals. This is fine though because the lexer will be outputing
+; non-terminals.
+;
+; The lexer defines what a token is and the mapping between tokens and
+; the grammar's non-terminals. It is a function of one argument, the input,
+; that returns the list of tokens corresponding to the input. Each token is
+; represented by a list. The first element is some `user-defined' information
+; associated with the token and the rest represents the token's class(es) (as a
+; list of non-terminals that this token corresponds to).
+;
+; The result of `make-parser' is a function that parses the single input it
+; is given into the grammar's goal. The result is a `parse' which can be
+; manipulated with the procedures: `parse->parsed?', `parse->trees'
+; and `parse->nb-trees' (see below).
+;
+; Let's assume that we want a parser for the grammar
+;
+; S -> x = E
+; E -> E + E | V
+; V -> V y |
+;
+; and that the input to the parser is a string of characters. Also, assume we
+; would like to map the characters `x', `y', `+' and `=' into the corresponding
+; non-terminals in the grammar. Such a parser could be created with
+;
+; (make-parser
+; '(
+; (s (x = e))
+; (e (e + e) (v))
+; (v (v y) ())
+; )
+; (lambda (str)
+; (map (lambda (char)
+; (list char ; user-info = the character itself
+; (case char
+; ((#\x) 'x)
+; ((#\y) 'y)
+; ((#\+) '+)
+; ((#\=) '=)
+; (else (fatal-error "lexer error")))))
+; (string->list str)))
+; )
+;
+; An alternative definition (that does not check for lexical errors) is
+;
+; (make-parser
+; '(
+; (s (#\x #\= e))
+; (e (e #\+ e) (v))
+; (v (v #\y) ())
+; )
+; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
+; )
+;
+; To help with the rest of the discussion, here are a few definitions:
+;
+; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
+; It indicates a point between two input tokens (0 = beginning, `n' = end).
+; For example, if `n' = 4, there are 5 input pointers:
+;
+; input token1 token2 token3 token4
+; input pointers 0 1 2 3 4
+;
+; A configuration indicates the extent to which a given rule is parsed (this
+; is the common `dot notation'). For simplicity, a configuration is
+; represented as an integer, with successive configurations in the same
+; rule associated with successive integers. It is assumed that the grammar
+; has been extended with rules to aid scanning. These rules are of the
+; form `nt ->', and there is one such rule for every non-terminal. Note
+; that these rules are special because they only apply when the corresponding
+; non-terminal is returned by the lexer.
+;
+; A configuration set is a configuration grouped with the set of input pointers
+; representing where the head non-terminal of the configuration was predicted.
+;
+; Here are the rules and configurations for the grammar given above:
+;
+; S -> . \
+; 0 |
+; x -> . |
+; 1 |
+; = -> . |
+; 2 |
+; E -> . |
+; 3 > special rules (for scanning)
+; + -> . |
+; 4 |
+; V -> . |
+; 5 |
+; y -> . |
+; 6 /
+; S -> . x . = . E .
+; 7 8 9 10
+; E -> . E . + . E .
+; 11 12 13 14
+; E -> . V .
+; 15 16
+; V -> . V . y .
+; 17 18 19
+; V -> .
+; 20
+;
+; Starters of the non-terminal `nt' are configurations that are leftmost
+; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
+; configurations that are rightmost in any rule for `nt'. Predictors of the
+; non-terminal `nt' are configurations that are directly to the left of `nt'
+; in any rule.
+;
+; For the grammar given above,
+;
+; Starters of V = (17 20)
+; Enders of V = (5 19 20)
+; Predictors of V = (15 17)
+
+(define (make-parser grammar lexer)
+
+ (define (non-terminals grammar) ; return vector of non-terminals in grammar
+
+ (define (add-nt nt nts)
+ (if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
+
+ (let def-loop ((defs grammar) (nts '()))
+ (if (pair? defs)
+ (let* ((def (car defs))
+ (head (car def)))
+ (let rule-loop ((rules (cdr def))
+ (nts (add-nt head nts)))
+ (if (pair? rules)
+ (let ((rule (car rules)))
+ (let loop ((l rule) (nts nts))
+ (if (pair? l)
+ (let ((nt (car l)))
+ (loop (cdr l) (add-nt nt nts)))
+ (rule-loop (cdr rules) nts))))
+ (def-loop (cdr defs) nts))))
+ (list->vector (reverse nts))))) ; goal non-terminal must be at index 0
+
+ (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
+ (let loop ((i (- (vector-length nts) 1)))
+ (if (>= i 0)
+ (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
+ #f)))
+
+ (define (nb-configurations grammar) ; return nb of configurations in grammar
+ (let def-loop ((defs grammar) (nb-confs 0))
+ (if (pair? defs)
+ (let ((def (car defs)))
+ (let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
+ (if (pair? rules)
+ (let ((rule (car rules)))
+ (let loop ((l rule) (nb-confs nb-confs))
+ (if (pair? l)
+ (loop (cdr l) (+ nb-confs 1))
+ (rule-loop (cdr rules) (+ nb-confs 1)))))
+ (def-loop (cdr defs) nb-confs))))
+ nb-confs)))
+
+; First, associate a numeric identifier to every non-terminal in the
+; grammar (with the goal non-terminal associated with 0).
+;
+; So, for the grammar given above we get:
+;
+; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
+
+ (let* ((nts (non-terminals grammar)) ; id map = list of non-terms
+ (nb-nts (vector-length nts)) ; the number of non-terms
+ (nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
+ (starters (make-vector nb-nts '())) ; starters for every non-term
+ (enders (make-vector nb-nts '())) ; enders for every non-term
+ (predictors (make-vector nb-nts '())) ; predictors for every non-term
+ (steps (make-vector nb-confs #f)) ; what to do in a given conf
+ (names (make-vector nb-confs #f))) ; name of rules
+
+ (define (setup-tables grammar nts starters enders predictors steps names)
+
+ (define (add-conf conf nt nts class)
+ (let ((i (ind nt nts)))
+ (vector-set! class i (cons conf (vector-ref class i)))))
+
+ (let ((nb-nts (vector-length nts)))
+
+ (let nt-loop ((i (- nb-nts 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! steps i (- i nb-nts))
+ (vector-set! names i (list (vector-ref nts i) 0))
+ (vector-set! enders i (list i))
+ (nt-loop (- i 1)))))
+
+ (let def-loop ((defs grammar) (conf (vector-length nts)))
+ (if (pair? defs)
+ (let* ((def (car defs))
+ (head (car def)))
+ (let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
+ (if (pair? rules)
+ (let ((rule (car rules)))
+ (vector-set! names conf (list head rule-num))
+ (add-conf conf head nts starters)
+ (let loop ((l rule) (conf conf))
+ (if (pair? l)
+ (let ((nt (car l)))
+ (vector-set! steps conf (ind nt nts))
+ (add-conf conf nt nts predictors)
+ (loop (cdr l) (+ conf 1)))
+ (begin
+ (vector-set! steps conf (- (ind head nts) nb-nts))
+ (add-conf conf head nts enders)
+ (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
+ (def-loop (cdr defs) conf))))))))
+
+; Now, for each non-terminal, compute the starters, enders and predictors and
+; the names and steps tables.
+
+ (setup-tables grammar nts starters enders predictors steps names)
+
+; Build the parser description
+
+ (let ((parser-descr (vector lexer
+ nts
+ starters
+ enders
+ predictors
+ steps
+ names)))
+ (lambda (input)
+
+ (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
+ (let loop ((i (- (vector-length nts) 1)))
+ (if (>= i 0)
+ (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
+ #f)))
+
+ (define (comp-tok tok nts) ; transform token to parsing format
+ (let loop ((l1 (cdr tok)) (l2 '()))
+ (if (pair? l1)
+ (let ((i (ind (car l1) nts)))
+ (if i
+ (loop (cdr l1) (cons i l2))
+ (loop (cdr l1) l2)))
+ (cons (car tok) (reverse l2)))))
+
+ (define (input->tokens input lexer nts)
+ (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
+
+ (define (make-states nb-toks nb-confs)
+ (let ((states (make-vector (+ nb-toks 1) #f)))
+ (let loop ((i nb-toks))
+ (if (>= i 0)
+ (let ((v (make-vector (+ nb-confs 1) #f)))
+ (vector-set! v 0 -1)
+ (vector-set! states i v)
+ (loop (- i 1)))
+ states))))
+
+ (define (conf-set-get state conf)
+ (vector-ref state (+ conf 1)))
+
+ (define (conf-set-get* state state-num conf)
+ (let ((conf-set (conf-set-get state conf)))
+ (if conf-set
+ conf-set
+ (let ((conf-set (make-vector (+ state-num 6) #f)))
+ (vector-set! conf-set 1 -3) ; old elems tail (points to head)
+ (vector-set! conf-set 2 -1) ; old elems head
+ (vector-set! conf-set 3 -1) ; new elems tail (points to head)
+ (vector-set! conf-set 4 -1) ; new elems head
+ (vector-set! state (+ conf 1) conf-set)
+ conf-set))))
+
+ (define (conf-set-merge-new! conf-set)
+ (vector-set! conf-set
+ (+ (vector-ref conf-set 1) 5)
+ (vector-ref conf-set 4))
+ (vector-set! conf-set 1 (vector-ref conf-set 3))
+ (vector-set! conf-set 3 -1)
+ (vector-set! conf-set 4 -1))
+
+ (define (conf-set-head conf-set)
+ (vector-ref conf-set 2))
+
+ (define (conf-set-next conf-set i)
+ (vector-ref conf-set (+ i 5)))
+
+ (define (conf-set-member? state conf i)
+ (let ((conf-set (vector-ref state (+ conf 1))))
+ (if conf-set
+ (conf-set-next conf-set i)
+ #f)))
+
+ (define (conf-set-adjoin state conf-set conf i)
+ (let ((tail (vector-ref conf-set 3))) ; put new element at tail
+ (vector-set! conf-set (+ i 5) -1)
+ (vector-set! conf-set (+ tail 5) i)
+ (vector-set! conf-set 3 i)
+ (if (< tail 0)
+ (begin
+ (vector-set! conf-set 0 (vector-ref state 0))
+ (vector-set! state 0 conf)))))
+
+ (define (conf-set-adjoin* states state-num l i)
+ (let ((state (vector-ref states state-num)))
+ (let loop ((l1 l))
+ (if (pair? l1)
+ (let* ((conf (car l1))
+ (conf-set (conf-set-get* state state-num conf)))
+ (if (not (conf-set-next conf-set i))
+ (begin
+ (conf-set-adjoin state conf-set conf i)
+ (loop (cdr l1)))
+ (loop (cdr l1))))))))
+
+ (define (conf-set-adjoin** states states* state-num conf i)
+ (let ((state (vector-ref states state-num)))
+ (if (conf-set-member? state conf i)
+ (let* ((state* (vector-ref states* state-num))
+ (conf-set* (conf-set-get* state* state-num conf)))
+ (if (not (conf-set-next conf-set* i))
+ (conf-set-adjoin state* conf-set* conf i))
+ #t)
+ #f)))
+
+ (define (conf-set-union state conf-set conf other-set)
+ (let loop ((i (conf-set-head other-set)))
+ (if (>= i 0)
+ (if (not (conf-set-next conf-set i))
+ (begin
+ (conf-set-adjoin state conf-set conf i)
+ (loop (conf-set-next other-set i)))
+ (loop (conf-set-next other-set i))))))
+
+ (define (forw states state-num starters enders predictors steps nts)
+
+ (define (predict state state-num conf-set conf nt starters enders)
+
+ ; add configurations which start the non-terminal `nt' to the
+ ; right of the dot
+
+ (let loop1 ((l (vector-ref starters nt)))
+ (if (pair? l)
+ (let* ((starter (car l))
+ (starter-set (conf-set-get* state state-num starter)))
+ (if (not (conf-set-next starter-set state-num))
+ (begin
+ (conf-set-adjoin state starter-set starter state-num)
+ (loop1 (cdr l)))
+ (loop1 (cdr l))))))
+
+ ; check for possible completion of the non-terminal `nt' to the
+ ; right of the dot
+
+ (let loop2 ((l (vector-ref enders nt)))
+ (if (pair? l)
+ (let ((ender (car l)))
+ (if (conf-set-member? state ender state-num)
+ (let* ((next (+ conf 1))
+ (next-set (conf-set-get* state state-num next)))
+ (conf-set-union state next-set next conf-set)
+ (loop2 (cdr l)))
+ (loop2 (cdr l)))))))
+
+ (define (reduce states state state-num conf-set head preds)
+
+ ; a non-terminal is now completed so check for reductions that
+ ; are now possible at the configurations `preds'
+
+ (let loop1 ((l preds))
+ (if (pair? l)
+ (let ((pred (car l)))
+ (let loop2 ((i head))
+ (if (>= i 0)
+ (let ((pred-set (conf-set-get (vector-ref states i) pred)))
+ (if pred-set
+ (let* ((next (+ pred 1))
+ (next-set (conf-set-get* state state-num next)))
+ (conf-set-union state next-set next pred-set)))
+ (loop2 (conf-set-next conf-set i)))
+ (loop1 (cdr l))))))))
+
+ (let ((state (vector-ref states state-num))
+ (nb-nts (vector-length nts)))
+ (let loop ()
+ (let ((conf (vector-ref state 0)))
+ (if (>= conf 0)
+ (let* ((step (vector-ref steps conf))
+ (conf-set (vector-ref state (+ conf 1)))
+ (head (vector-ref conf-set 4)))
+ (vector-set! state 0 (vector-ref conf-set 0))
+ (conf-set-merge-new! conf-set)
+ (if (>= step 0)
+ (predict state state-num conf-set conf step starters enders)
+ (let ((preds (vector-ref predictors (+ step nb-nts))))
+ (reduce states state state-num conf-set head preds)))
+ (loop)))))))
+
+ (define (forward starters enders predictors steps nts toks)
+ (let* ((nb-toks (vector-length toks))
+ (nb-confs (vector-length steps))
+ (states (make-states nb-toks nb-confs))
+ (goal-starters (vector-ref starters 0)))
+ (conf-set-adjoin* states 0 goal-starters 0) ; predict goal
+ (forw states 0 starters enders predictors steps nts)
+ (let loop ((i 0))
+ (if (< i nb-toks)
+ (let ((tok-nts (cdr (vector-ref toks i))))
+ (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
+ (forw states (+ i 1) starters enders predictors steps nts)
+ (loop (+ i 1)))))
+ states))
+
+ (define (produce conf i j enders steps toks states states* nb-nts)
+ (let ((prev (- conf 1)))
+ (if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
+ (let loop1 ((l (vector-ref enders (vector-ref steps prev))))
+ (if (pair? l)
+ (let* ((ender (car l))
+ (ender-set (conf-set-get (vector-ref states j)
+ ender)))
+ (if ender-set
+ (let loop2 ((k (conf-set-head ender-set)))
+ (if (>= k 0)
+ (begin
+ (and (>= k i)
+ (conf-set-adjoin** states states* k prev i)
+ (conf-set-adjoin** states states* j ender k))
+ (loop2 (conf-set-next ender-set k)))
+ (loop1 (cdr l))))
+ (loop1 (cdr l)))))))))
+
+ (define (back states states* state-num enders steps nb-nts toks)
+ (let ((state* (vector-ref states* state-num)))
+ (let loop1 ()
+ (let ((conf (vector-ref state* 0)))
+ (if (>= conf 0)
+ (let* ((conf-set (vector-ref state* (+ conf 1)))
+ (head (vector-ref conf-set 4)))
+ (vector-set! state* 0 (vector-ref conf-set 0))
+ (conf-set-merge-new! conf-set)
+ (let loop2 ((i head))
+ (if (>= i 0)
+ (begin
+ (produce conf i state-num enders steps
+ toks states states* nb-nts)
+ (loop2 (conf-set-next conf-set i)))
+ (loop1)))))))))
+
+ (define (backward states enders steps nts toks)
+ (let* ((nb-toks (vector-length toks))
+ (nb-confs (vector-length steps))
+ (nb-nts (vector-length nts))
+ (states* (make-states nb-toks nb-confs))
+ (goal-enders (vector-ref enders 0)))
+ (let loop1 ((l goal-enders))
+ (if (pair? l)
+ (let ((conf (car l)))
+ (conf-set-adjoin** states states* nb-toks conf 0)
+ (loop1 (cdr l)))))
+ (let loop2 ((i nb-toks))
+ (if (>= i 0)
+ (begin
+ (back states states* i enders steps nb-nts toks)
+ (loop2 (- i 1)))))
+ states*))
+
+ (define (parsed? nt i j nts enders states)
+ (let ((nt* (ind nt nts)))
+ (if nt*
+ (let ((nb-nts (vector-length nts)))
+ (let loop ((l (vector-ref enders nt*)))
+ (if (pair? l)
+ (let ((conf (car l)))
+ (if (conf-set-member? (vector-ref states j) conf i)
+ #t
+ (loop (cdr l))))
+ #f)))
+ #f)))
+
+ (define (deriv-trees conf i j enders steps names toks states nb-nts)
+ (let ((name (vector-ref names conf)))
+
+ (if name ; `conf' is at the start of a rule (either special or not)
+ (if (< conf nb-nts)
+ (list (list name (car (vector-ref toks i))))
+ (list (list name)))
+
+ (let ((prev (- conf 1)))
+ (let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
+ (l2 '()))
+ (if (pair? l1)
+ (let* ((ender (car l1))
+ (ender-set (conf-set-get (vector-ref states j)
+ ender)))
+ (if ender-set
+ (let loop2 ((k (conf-set-head ender-set)) (l2 l2))
+ (if (>= k 0)
+ (if (and (>= k i)
+ (conf-set-member? (vector-ref states k)
+ prev i))
+ (let ((prev-trees
+ (deriv-trees prev i k enders steps names
+ toks states nb-nts))
+ (ender-trees
+ (deriv-trees ender k j enders steps names
+ toks states nb-nts)))
+ (let loop3 ((l3 ender-trees) (l2 l2))
+ (if (pair? l3)
+ (let ((ender-tree (list (car l3))))
+ (let loop4 ((l4 prev-trees) (l2 l2))
+ (if (pair? l4)
+ (loop4 (cdr l4)
+ (cons (append (car l4)
+ ender-tree)
+ l2))
+ (loop3 (cdr l3) l2))))
+ (loop2 (conf-set-next ender-set k) l2))))
+ (loop2 (conf-set-next ender-set k) l2))
+ (loop1 (cdr l1) l2)))
+ (loop1 (cdr l1) l2)))
+ l2))))))
+
+ (define (deriv-trees* nt i j nts enders steps names toks states)
+ (let ((nt* (ind nt nts)))
+ (if nt*
+ (let ((nb-nts (vector-length nts)))
+ (let loop ((l (vector-ref enders nt*)) (trees '()))
+ (if (pair? l)
+ (let ((conf (car l)))
+ (if (conf-set-member? (vector-ref states j) conf i)
+ (loop (cdr l)
+ (append (deriv-trees conf i j enders steps names
+ toks states nb-nts)
+ trees))
+ (loop (cdr l) trees)))
+ trees)))
+ #f)))
+
+ (define (nb-deriv-trees conf i j enders steps toks states nb-nts)
+ (let ((prev (- conf 1)))
+ (if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
+ 1
+ (let loop1 ((l (vector-ref enders (vector-ref steps prev)))
+ (n 0))
+ (if (pair? l)
+ (let* ((ender (car l))
+ (ender-set (conf-set-get (vector-ref states j)
+ ender)))
+ (if ender-set
+ (let loop2 ((k (conf-set-head ender-set)) (n n))
+ (if (>= k 0)
+ (if (and (>= k i)
+ (conf-set-member? (vector-ref states k)
+ prev i))
+ (let ((nb-prev-trees
+ (nb-deriv-trees prev i k enders steps
+ toks states nb-nts))
+ (nb-ender-trees
+ (nb-deriv-trees ender k j enders steps
+ toks states nb-nts)))
+ (loop2 (conf-set-next ender-set k)
+ (+ n (* nb-prev-trees nb-ender-trees))))
+ (loop2 (conf-set-next ender-set k) n))
+ (loop1 (cdr l) n)))
+ (loop1 (cdr l) n)))
+ n)))))
+
+ (define (nb-deriv-trees* nt i j nts enders steps toks states)
+ (let ((nt* (ind nt nts)))
+ (if nt*
+ (let ((nb-nts (vector-length nts)))
+ (let loop ((l (vector-ref enders nt*)) (nb-trees 0))
+ (if (pair? l)
+ (let ((conf (car l)))
+ (if (conf-set-member? (vector-ref states j) conf i)
+ (loop (cdr l)
+ (+ (nb-deriv-trees conf i j enders steps
+ toks states nb-nts)
+ nb-trees))
+ (loop (cdr l) nb-trees)))
+ nb-trees)))
+ #f)))
+
+ (let* ((lexer (vector-ref parser-descr 0))
+ (nts (vector-ref parser-descr 1))
+ (starters (vector-ref parser-descr 2))
+ (enders (vector-ref parser-descr 3))
+ (predictors (vector-ref parser-descr 4))
+ (steps (vector-ref parser-descr 5))
+ (names (vector-ref parser-descr 6))
+ (toks (input->tokens input lexer nts)))
+
+ (vector nts
+ starters
+ enders
+ predictors
+ steps
+ names
+ toks
+ (backward (forward starters enders predictors steps nts toks)
+ enders steps nts toks)
+ parsed?
+ deriv-trees*
+ nb-deriv-trees*))))))
+
+(define (parse->parsed? parse nt i j)
+ (let* ((nts (vector-ref parse 0))
+ (enders (vector-ref parse 2))
+ (states (vector-ref parse 7))
+ (parsed? (vector-ref parse 8)))
+ (parsed? nt i j nts enders states)))
+
+(define (parse->trees parse nt i j)
+ (let* ((nts (vector-ref parse 0))
+ (enders (vector-ref parse 2))
+ (steps (vector-ref parse 4))
+ (names (vector-ref parse 5))
+ (toks (vector-ref parse 6))
+ (states (vector-ref parse 7))
+ (deriv-trees* (vector-ref parse 9)))
+ (deriv-trees* nt i j nts enders steps names toks states)))
+
+(define (parse->nb-trees parse nt i j)
+ (let* ((nts (vector-ref parse 0))
+ (enders (vector-ref parse 2))
+ (steps (vector-ref parse 4))
+ (toks (vector-ref parse 6))
+ (states (vector-ref parse 7))
+ (nb-deriv-trees* (vector-ref parse 10)))
+ (nb-deriv-trees* nt i j nts enders steps toks states)))
+
+(define (test k)
+ (let ((p (make-parser '( (s (a) (s s)) )
+ (lambda (l) (map (lambda (x) (list x x)) l)))))
+ (let ((x (p (vector->list (make-vector k 'a)))))
+ (length (parse->trees x 's 0 k)))))
+
+(define (earley-benchmark . args)
+ (let ((k (if (null? args) 9 (car args))))
+ (run-benchmark
+ "earley"
+ 1
+ (lambda () (test k))
+ (lambda (result)
+ (display result)
+ (newline)
+ #t))))
--- /dev/null
+; This is adapted from a benchmark written by John Ellis and Pete Kovac
+; of Post Communications.
+; It was modified by Hans Boehm of Silicon Graphics.
+; It was translated into Scheme by William D Clinger of Northeastern Univ;
+; the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
+; It was later hacked by Lars T Hansen of Northeastern University;
+; this version has a fixed tree height but accepts a number of
+; iterations to run.
+;
+; Modified 2000-02-15 / lth: changed gc-benchmark to only stretch once,
+; and to have a different interface (now accepts iteration numbers,
+; not tree height)
+; Last modified 2000-07-14 / lth -- fixed a buggy comment about storage
+; use in Larceny.
+;
+; This is no substitute for real applications. No actual application
+; is likely to behave in exactly this way. However, this benchmark was
+; designed to be more representative of real applications than other
+; Java GC benchmarks of which we are aware.
+; It attempts to model those properties of allocation requests that
+; are important to current GC techniques.
+; It is designed to be used either to obtain a single overall performance
+; number, or to give a more detailed estimate of how collector
+; performance varies with object lifetimes. It prints the time
+; required to allocate and collect balanced binary trees of various
+; sizes. Smaller trees result in shorter object lifetimes. Each cycle
+; allocates roughly the same amount of memory.
+; Two data structures are kept around during the entire process, so
+; that the measured performance is representative of applications
+; that maintain some live in-memory data. One of these is a tree
+; containing many pointers. The other is a large array containing
+; double precision floating point numbers. Both should be of comparable
+; size.
+;
+; The results are only really meaningful together with a specification
+; of how much memory was used. It is possible to trade memory for
+; better time performance. This benchmark should be run in a 32 MB
+; heap, though we don't currently know how to enforce that uniformly.
+
+; In the Java version, this routine prints the heap size and the amount
+; of free memory. There is no portable way to do this in Scheme; each
+; implementation needs its own version.
+
+(define (PrintDiagnostics)
+ (display " Total memory available= ???????? bytes")
+ (display " Free memory= ???????? bytes")
+ (newline))
+
+(define (yes answer) #t)
+
+; Should we implement a Java class as procedures or hygienic macros?
+; Take your pick.
+
+(define-syntax let-class
+ (syntax-rules
+ ()
+ ; Put this rule first to implement a class using hygienic macros.
+ ((let-class (((method . args) . method-body) ...) . body)
+ (letrec-syntax ((method (syntax-rules ()
+ ((method . args) (begin . method-body))))
+ ...)
+ . body))
+ ; Put this rule first to implement a class using procedures.
+ ((let-class (((method . args) . method-body) ...) . body)
+ (let () (define (method . args) . method-body) ... . body))
+ ))
+
+
+(define stretch #t) ; Controls whether stretching phase is run
+
+(define (gcbench kStretchTreeDepth)
+
+ ; Use for inner calls to reduce noise.
+
+ (define (run-benchmark name iters thunk test)
+ (do ((i 0 (+ i 1)))
+ ((= i iters))
+ (thunk)))
+
+ ; Nodes used by a tree of a given size
+ (define (TreeSize i)
+ (- (expt 2 (+ i 1)) 1))
+
+ ; Number of iterations to use for a given tree depth
+ (define (NumIters i)
+ (quotient (* 2 (TreeSize kStretchTreeDepth))
+ (TreeSize i)))
+
+ ; Parameters are determined by kStretchTreeDepth.
+ ; In Boehm's version the parameters were fixed as follows:
+ ; public static final int kStretchTreeDepth = 18; // about 16Mb
+ ; public static final int kLongLivedTreeDepth = 16; // about 4Mb
+ ; public static final int kArraySize = 500000; // about 4Mb
+ ; public static final int kMinTreeDepth = 4;
+ ; public static final int kMaxTreeDepth = 16;
+ ; wdc: In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
+ ; lth: No they would not. A flonum requires 16 bytes, so the size
+ ; of array + flonums would be 500,000*4 + 500,000*16=10 Mby.
+
+ (let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
+ (kArraySize (* 4 (TreeSize kLongLivedTreeDepth)))
+ (kMinTreeDepth 4)
+ (kMaxTreeDepth kLongLivedTreeDepth))
+
+ ; Elements 3 and 4 of the allocated vectors are useless.
+
+ (let-class (((make-node l r)
+ (let ((v (make-empty-node)))
+ (vector-set! v 0 l)
+ (vector-set! v 1 r)
+ v))
+ ((make-empty-node) (make-vector 4 0))
+ ((node.left node) (vector-ref node 0))
+ ((node.right node) (vector-ref node 1))
+ ((node.left-set! node x) (vector-set! node 0 x))
+ ((node.right-set! node x) (vector-set! node 1 x)))
+
+ ; Build tree top down, assigning to older objects.
+ (define (Populate iDepth thisNode)
+ (if (<= iDepth 0)
+ #f
+ (let ((iDepth (- iDepth 1)))
+ (node.left-set! thisNode (make-empty-node))
+ (node.right-set! thisNode (make-empty-node))
+ (Populate iDepth (node.left thisNode))
+ (Populate iDepth (node.right thisNode)))))
+
+ ; Build tree bottom-up
+ (define (MakeTree iDepth)
+ (if (<= iDepth 0)
+ (make-empty-node)
+ (make-node (MakeTree (- iDepth 1))
+ (MakeTree (- iDepth 1)))))
+
+ (define (TimeConstruction depth)
+ (let ((iNumIters (NumIters depth)))
+ (display (string-append "Creating "
+ (number->string iNumIters)
+ " trees of depth "
+ (number->string depth)))
+ (newline)
+ (run-benchmark "GCBench: Top down construction"
+ 1
+ (lambda ()
+ (do ((i 0 (+ i 1)))
+ ((>= i iNumIters))
+ (Populate depth (make-empty-node))))
+ yes)
+ (run-benchmark "GCBench: Bottom up construction"
+ 1
+ (lambda ()
+ (do ((i 0 (+ i 1)))
+ ((>= i iNumIters))
+ (MakeTree depth)))
+ yes)))
+
+ (define (main)
+ (display "Garbage Collector Test")
+ (newline)
+ (if stretch
+ (begin
+ (display (string-append
+ " Stretching memory with a binary tree of depth "
+ (number->string kStretchTreeDepth)))
+ (newline)))
+ (PrintDiagnostics)
+ (run-benchmark "GCBench: Main"
+ 1
+ (lambda ()
+ ; Stretch the memory space quickly
+ (if stretch
+ (MakeTree kStretchTreeDepth))
+
+ ; Create a long lived object
+ (display
+ (string-append
+ " Creating a long-lived binary tree of depth "
+ (number->string kLongLivedTreeDepth)))
+ (newline)
+ (let ((longLivedTree (make-empty-node)))
+ (Populate kLongLivedTreeDepth longLivedTree)
+
+ ; Create long-lived array, filling half of it
+ (display (string-append
+ " Creating a long-lived array of "
+ (number->string kArraySize)
+ " inexact reals"))
+ (newline)
+ (let ((array (make-vector kArraySize 0.0)))
+ (do ((i 0 (+ i 1)))
+ ((>= i (quotient kArraySize 2)))
+ (vector-set! array i
+ (/ 1.0 (exact->inexact i))))
+ (PrintDiagnostics)
+
+ (do ((d kMinTreeDepth (+ d 2)))
+ ((> d kMaxTreeDepth))
+ (TimeConstruction d))
+
+ (if (or (eq? longLivedTree '())
+ (let ((n (min 1000
+ (- (quotient (vector-length array)
+ 2)
+ 1))))
+ (not (= (vector-ref array n)
+ (/ 1.0 (exact->inexact n))))))
+ (begin (display "Failed") (newline)))
+ ; fake reference to LongLivedTree
+ ; and array
+ ; to keep them from being optimized away
+ )))
+ yes)
+ (PrintDiagnostics))
+
+ (main))))
+
+(define (gc-benchmark . rest)
+ (let ((k 18)
+ (n (if (null? rest) 1 (car rest))))
+ (display "The garbage collector should touch about ")
+ (display (expt 2 (- k 13)))
+ (display " megabytes of heap storage.")
+ (newline)
+ (display "The use of more or less memory will skew the results.")
+ (newline)
+ (set! stretch #t)
+ (run-benchmark (string-append "GCBench" (number->string k))
+ n
+ (lambda ()
+ (gcbench k)
+ (set! stretch #f))
+ yes)
+ (set! stretch #t)))
--- /dev/null
+; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
+; and to expand the four macros below.
+; Modified 11 June 1997 by Will Clinger to eliminate assertions
+; and to replace a use of "recur" with a named let.
+;
+; Performance note: (graphs-benchmark 7) allocates
+; 34509143 pairs
+; 389625 vectors with 2551590 elements
+; 56653504 closures (not counting top level and known procedures)
+
+(define (graphs-benchmark . rest)
+ (let ((N (if (null? rest) 7 (car rest))))
+ (run-benchmark (string-append "graphs" (number->string N))
+ (lambda ()
+ (fold-over-rdg N
+ 2
+ cons
+ '())))))
+
+; End of new code.
+
+;;; ==== std.ss ====
+
+; (define-syntax assert
+; (syntax-rules ()
+; ((assert test info-rest ...)
+; #F)))
+;
+; (define-syntax deny
+; (syntax-rules ()
+; ((deny test info-rest ...)
+; #F)))
+;
+; (define-syntax when
+; (syntax-rules ()
+; ((when test e-first e-rest ...)
+; (if test
+; (begin e-first
+; e-rest ...)))))
+;
+; (define-syntax unless
+; (syntax-rules ()
+; ((unless test e-first e-rest ...)
+; (if (not test)
+; (begin e-first
+; e-rest ...)))))
+
+(define assert
+ (lambda (test . info)
+ #f))
+
+;;; ==== util.ss ====
+
+
+; Fold over list elements, associating to the left.
+(define fold
+ (lambda (lst folder state)
+ '(assert (list? lst)
+ lst)
+ '(assert (procedure? folder)
+ folder)
+ (do ((lst lst
+ (cdr lst))
+ (state state
+ (folder (car lst)
+ state)))
+ ((null? lst)
+ state))))
+
+; Given the size of a vector and a procedure which
+; sends indicies to desired vector elements, create
+; and return the vector.
+(define proc->vector
+ (lambda (size f)
+ '(assert (and (integer? size)
+ (exact? size)
+ (>= size 0))
+ size)
+ '(assert (procedure? f)
+ f)
+ (if (zero? size)
+ (vector)
+ (let ((x (make-vector size (f 0))))
+ (let loop ((i 1))
+ (if (< i size) (begin ; [wdc - was when]
+ (vector-set! x i (f i))
+ (loop (+ i 1)))))
+ x))))
+
+(define vector-fold
+ (lambda (vec folder state)
+ '(assert (vector? vec)
+ vec)
+ '(assert (procedure? folder)
+ folder)
+ (let ((len
+ (vector-length vec)))
+ (do ((i 0
+ (+ i 1))
+ (state state
+ (folder (vector-ref vec i)
+ state)))
+ ((= i len)
+ state)))))
+
+(define vector-map
+ (lambda (vec proc)
+ (proc->vector (vector-length vec)
+ (lambda (i)
+ (proc (vector-ref vec i))))))
+
+; Given limit, return the list 0, 1, ..., limit-1.
+(define giota
+ (lambda (limit)
+ '(assert (and (integer? limit)
+ (exact? limit)
+ (>= limit 0))
+ limit)
+ (let -*-
+ ((limit
+ limit)
+ (res
+ '()))
+ (if (zero? limit)
+ res
+ (let ((limit
+ (- limit 1)))
+ (-*- limit
+ (cons limit res)))))))
+
+; Fold over the integers [0, limit).
+(define gnatural-fold
+ (lambda (limit folder state)
+ '(assert (and (integer? limit)
+ (exact? limit)
+ (>= limit 0))
+ limit)
+ '(assert (procedure? folder)
+ folder)
+ (do ((i 0
+ (+ i 1))
+ (state state
+ (folder i state)))
+ ((= i limit)
+ state))))
+
+; Iterate over the integers [0, limit).
+(define gnatural-for-each
+ (lambda (limit proc!)
+ '(assert (and (integer? limit)
+ (exact? limit)
+ (>= limit 0))
+ limit)
+ '(assert (procedure? proc!)
+ proc!)
+ (do ((i 0
+ (+ i 1)))
+ ((= i limit))
+ (proc! i))))
+
+(define natural-for-all?
+ (lambda (limit ok?)
+ '(assert (and (integer? limit)
+ (exact? limit)
+ (>= limit 0))
+ limit)
+ '(assert (procedure? ok?)
+ ok?)
+ (let -*-
+ ((i 0))
+ (or (= i limit)
+ (and (ok? i)
+ (-*- (+ i 1)))))))
+
+(define natural-there-exists?
+ (lambda (limit ok?)
+ '(assert (and (integer? limit)
+ (exact? limit)
+ (>= limit 0))
+ limit)
+ '(assert (procedure? ok?)
+ ok?)
+ (let -*-
+ ((i 0))
+ (and (not (= i limit))
+ (or (ok? i)
+ (-*- (+ i 1)))))))
+
+(define there-exists?
+ (lambda (lst ok?)
+ '(assert (list? lst)
+ lst)
+ '(assert (procedure? ok?)
+ ok?)
+ (let -*-
+ ((lst lst))
+ (and (not (null? lst))
+ (or (ok? (car lst))
+ (-*- (cdr lst)))))))
+
+
+;;; ==== ptfold.ss ====
+
+
+; Fold over the tree of permutations of a universe.
+; Each branch (from the root) is a permutation of universe.
+; Each node at depth d corresponds to all permutations which pick the
+; elements spelled out on the branch from the root to that node as
+; the first d elements.
+; Their are two components to the state:
+; The b-state is only a function of the branch from the root.
+; The t-state is a function of all nodes seen so far.
+; At each node, b-folder is called via
+; (b-folder elem b-state t-state deeper accross)
+; where elem is the next element of the universe picked.
+; If b-folder can determine the result of the total tree fold at this stage,
+; it should simply return the result.
+; If b-folder can determine the result of folding over the sub-tree
+; rooted at the resulting node, it should call accross via
+; (accross new-t-state)
+; where new-t-state is that result.
+; Otherwise, b-folder should call deeper via
+; (deeper new-b-state new-t-state)
+; where new-b-state is the b-state for the new node and new-t-state is
+; the new folded t-state.
+; At the leaves of the tree, t-folder is called via
+; (t-folder b-state t-state accross)
+; If t-folder can determine the result of the total tree fold at this stage,
+; it should simply return that result.
+; If not, it should call accross via
+; (accross new-t-state)
+; Note, fold-over-perm-tree always calls b-folder in depth-first order.
+; I.e., when b-folder is called at depth d, the branch leading to that
+; node is the most recent calls to b-folder at all the depths less than d.
+; This is a gross efficiency hack so that b-folder can use mutation to
+; keep the current branch.
+(define fold-over-perm-tree
+ (lambda (universe b-folder b-state t-folder t-state)
+ '(assert (list? universe)
+ universe)
+ '(assert (procedure? b-folder)
+ b-folder)
+ '(assert (procedure? t-folder)
+ t-folder)
+ (let -*-
+ ((universe
+ universe)
+ (b-state
+ b-state)
+ (t-state
+ t-state)
+ (accross
+ (lambda (final-t-state)
+ final-t-state)))
+ (if (null? universe)
+ (t-folder b-state t-state accross)
+ (let -**-
+ ((in
+ universe)
+ (out
+ '())
+ (t-state
+ t-state))
+ (let* ((first
+ (car in))
+ (rest
+ (cdr in))
+ (accross
+ (if (null? rest)
+ accross
+ (lambda (new-t-state)
+ (-**- rest
+ (cons first out)
+ new-t-state)))))
+ (b-folder first
+ b-state
+ t-state
+ (lambda (new-b-state new-t-state)
+ (-*- (fold out cons rest)
+ new-b-state
+ new-t-state
+ accross))
+ accross)))))))
+
+
+;;; ==== minimal.ss ====
+
+
+; A directed graph is stored as a connection matrix (vector-of-vectors)
+; where the first index is the `from' vertex and the second is the `to'
+; vertex. Each entry is a bool indicating if the edge exists.
+; The diagonal of the matrix is never examined.
+; Make-minimal? returns a procedure which tests if a labelling
+; of the verticies is such that the matrix is minimal.
+; If it is, then the procedure returns the result of folding over
+; the elements of the automoriphism group. If not, it returns #F.
+; The folding is done by calling folder via
+; (folder perm state accross)
+; If the folder wants to continue, it should call accross via
+; (accross new-state)
+; If it just wants the entire minimal? procedure to return something,
+; it should return that.
+; The ordering used is lexicographic (with #T > #F) and entries
+; are examined in the following order:
+; 1->0, 0->1
+;
+; 2->0, 0->2
+; 2->1, 1->2
+;
+; 3->0, 0->3
+; 3->1, 1->3
+; 3->2, 2->3
+; ...
+(define make-minimal?
+ (lambda (max-size)
+ '(assert (and (integer? max-size)
+ (exact? max-size)
+ (>= max-size 0))
+ max-size)
+ (let ((iotas
+ (proc->vector (+ max-size 1)
+ giota))
+ (perm
+ (make-vector max-size 0)))
+ (lambda (size graph folder state)
+ '(assert (and (integer? size)
+ (exact? size)
+ (<= 0 size max-size))
+ size
+ max-size)
+ '(assert (vector? graph)
+ graph)
+ '(assert (procedure? folder)
+ folder)
+ (fold-over-perm-tree (vector-ref iotas size)
+ (lambda (perm-x x state deeper accross)
+ (case (cmp-next-vertex graph perm x perm-x)
+ ((less)
+ #F)
+ ((equal)
+ (vector-set! perm x perm-x)
+ (deeper (+ x 1)
+ state))
+ ((more)
+ (accross state))
+ (else
+ (assert #F))))
+ 0
+ (lambda (leaf-depth state accross)
+ '(assert (eqv? leaf-depth size)
+ leaf-depth
+ size)
+ (folder perm state accross))
+ state)))))
+
+; Given a graph, a partial permutation vector, the next input and the next
+; output, return 'less, 'equal or 'more depending on the lexicographic
+; comparison between the permuted and un-permuted graph.
+(define cmp-next-vertex
+ (lambda (graph perm x perm-x)
+ (let ((from-x
+ (vector-ref graph x))
+ (from-perm-x
+ (vector-ref graph perm-x)))
+ (let -*-
+ ((y
+ 0))
+ (if (= x y)
+ 'equal
+ (let ((x->y?
+ (vector-ref from-x y))
+ (perm-y
+ (vector-ref perm y)))
+ (cond ((eq? x->y?
+ (vector-ref from-perm-x perm-y))
+ (let ((y->x?
+ (vector-ref (vector-ref graph y)
+ x)))
+ (cond ((eq? y->x?
+ (vector-ref (vector-ref graph perm-y)
+ perm-x))
+ (-*- (+ y 1)))
+ (y->x?
+ 'less)
+ (else
+ 'more))))
+ (x->y?
+ 'less)
+ (else
+ 'more))))))))
+
+
+;;; ==== rdg.ss ====
+
+
+; Fold over rooted directed graphs with bounded out-degree.
+; Size is the number of verticies (including the root). Max-out is the
+; maximum out-degree for any vertex. Folder is called via
+; (folder edges state)
+; where edges is a list of length size. The ith element of the list is
+; a list of the verticies j for which there is an edge from i to j.
+; The last vertex is the root.
+(define fold-over-rdg
+ (lambda (size max-out folder state)
+ '(assert (and (exact? size)
+ (integer? size)
+ (> size 0))
+ size)
+ '(assert (and (exact? max-out)
+ (integer? max-out)
+ (>= max-out 0))
+ max-out)
+ '(assert (procedure? folder)
+ folder)
+ (let* ((root
+ (- size 1))
+ (edge?
+ (proc->vector size
+ (lambda (from)
+ (make-vector size #F))))
+ (edges
+ (make-vector size '()))
+ (out-degrees
+ (make-vector size 0))
+ (minimal-folder
+ (make-minimal? root))
+ (non-root-minimal?
+ (let ((cont
+ (lambda (perm state accross)
+ '(assert (eq? state #T)
+ state)
+ (accross #T))))
+ (lambda (size)
+ (minimal-folder size
+ edge?
+ cont
+ #T))))
+ (root-minimal?
+ (let ((cont
+ (lambda (perm state accross)
+ '(assert (eq? state #T)
+ state)
+ (case (cmp-next-vertex edge? perm root root)
+ ((less)
+ #F)
+ ((equal more)
+ (accross #T))
+ (else
+ (assert #F))))))
+ (lambda ()
+ (minimal-folder root
+ edge?
+ cont
+ #T)))))
+ (let -*-
+ ((vertex
+ 0)
+ (state
+ state))
+ (cond ((not (non-root-minimal? vertex))
+ state)
+ ((= vertex root)
+ '(assert
+ (begin
+ (gnatural-for-each root
+ (lambda (v)
+ '(assert (= (vector-ref out-degrees v)
+ (length (vector-ref edges v)))
+ v
+ (vector-ref out-degrees v)
+ (vector-ref edges v))))
+ #T))
+ (let ((reach?
+ (make-reach? root edges))
+ (from-root
+ (vector-ref edge? root)))
+ (let -*-
+ ((v
+ 0)
+ (outs
+ 0)
+ (efr
+ '())
+ (efrr
+ '())
+ (state
+ state))
+ (cond ((not (or (= v root)
+ (= outs max-out)))
+ (vector-set! from-root v #T)
+ (let ((state
+ (-*- (+ v 1)
+ (+ outs 1)
+ (cons v efr)
+ (cons (vector-ref reach? v)
+ efrr)
+ state)))
+ (vector-set! from-root v #F)
+ (-*- (+ v 1)
+ outs
+ efr
+ efrr
+ state)))
+ ((and (natural-for-all? root
+ (lambda (v)
+ (there-exists? efrr
+ (lambda (r)
+ (vector-ref r v)))))
+ (root-minimal?))
+ (vector-set! edges root efr)
+ (folder
+ (proc->vector size
+ (lambda (i)
+ (vector-ref edges i)))
+ state))
+ (else
+ state)))))
+ (else
+ (let ((from-vertex
+ (vector-ref edge? vertex)))
+ (let -**-
+ ((sv
+ 0)
+ (outs
+ 0)
+ (state
+ state))
+ (if (= sv vertex)
+ (begin
+ (vector-set! out-degrees vertex outs)
+ (-*- (+ vertex 1)
+ state))
+ (let* ((state
+ ; no sv->vertex, no vertex->sv
+ (-**- (+ sv 1)
+ outs
+ state))
+ (from-sv
+ (vector-ref edge? sv))
+ (sv-out
+ (vector-ref out-degrees sv))
+ (state
+ (if (= sv-out max-out)
+ state
+ (begin
+ (vector-set! edges
+ sv
+ (cons vertex
+ (vector-ref edges sv)))
+ (vector-set! from-sv vertex #T)
+ (vector-set! out-degrees sv (+ sv-out 1))
+ (let* ((state
+ ; sv->vertex, no vertex->sv
+ (-**- (+ sv 1)
+ outs
+ state))
+ (state
+ (if (= outs max-out)
+ state
+ (begin
+ (vector-set! from-vertex sv #T)
+ (vector-set! edges
+ vertex
+ (cons sv
+ (vector-ref edges vertex)))
+ (let ((state
+ ; sv->vertex, vertex->sv
+ (-**- (+ sv 1)
+ (+ outs 1)
+ state)))
+ (vector-set! edges
+ vertex
+ (cdr (vector-ref edges vertex)))
+ (vector-set! from-vertex sv #F)
+ state)))))
+ (vector-set! out-degrees sv sv-out)
+ (vector-set! from-sv vertex #F)
+ (vector-set! edges
+ sv
+ (cdr (vector-ref edges sv)))
+ state)))))
+ (if (= outs max-out)
+ state
+ (begin
+ (vector-set! edges
+ vertex
+ (cons sv
+ (vector-ref edges vertex)))
+ (vector-set! from-vertex sv #T)
+ (let ((state
+ ; no sv->vertex, vertex->sv
+ (-**- (+ sv 1)
+ (+ outs 1)
+ state)))
+ (vector-set! from-vertex sv #F)
+ (vector-set! edges
+ vertex
+ (cdr (vector-ref edges vertex)))
+ state)))))))))))))
+
+; Given a vector which maps vertex to out-going-edge list,
+; return a vector which gives reachability.
+(define make-reach?
+ (lambda (size vertex->out)
+ (let ((res
+ (proc->vector size
+ (lambda (v)
+ (let ((from-v
+ (make-vector size #F)))
+ (vector-set! from-v v #T)
+ (for-each
+ (lambda (x)
+ (vector-set! from-v x #T))
+ (vector-ref vertex->out v))
+ from-v)))))
+ (gnatural-for-each size
+ (lambda (m)
+ (let ((from-m
+ (vector-ref res m)))
+ (gnatural-for-each size
+ (lambda (f)
+ (let ((from-f
+ (vector-ref res f)))
+ (if (vector-ref from-f m); [wdc - was when]
+ (begin
+ (gnatural-for-each size
+ (lambda (t)
+ (if (vector-ref from-m t)
+ (begin ; [wdc - was when]
+ (vector-set! from-f t #T)))))))))))))
+ res)))
+
+
+;;; ==== test input ====
+
+; Produces all directed graphs with N verticies, distinguished root,
+; and out-degree bounded by 2, upto isomorphism (there are 44).
+
+;(define go
+; (let ((N 7))
+; (fold-over-rdg N
+; 2
+; cons
+; '())))
--- /dev/null
+; This benchmark was obtained from Andrew Wright.
+; 970215 / wdc Added lattice-benchmark.
+
+; Given a comparison routine that returns one of
+; less
+; more
+; equal
+; uncomparable
+; return a new comparison routine that applies to sequences.
+(define lexico
+ (lambda (base)
+ (define lex-fixed
+ (lambda (fixed lhs rhs)
+ (define check
+ (lambda (lhs rhs)
+ (if (null? lhs)
+ fixed
+ (let ((probe
+ (base (car lhs)
+ (car rhs))))
+ (if (or (eq? probe 'equal)
+ (eq? probe fixed))
+ (check (cdr lhs)
+ (cdr rhs))
+ 'uncomparable)))))
+ (check lhs rhs)))
+ (define lex-first
+ (lambda (lhs rhs)
+ (if (null? lhs)
+ 'equal
+ (let ((probe
+ (base (car lhs)
+ (car rhs))))
+ (case probe
+ ((less more)
+ (lex-fixed probe
+ (cdr lhs)
+ (cdr rhs)))
+ ((equal)
+ (lex-first (cdr lhs)
+ (cdr rhs)))
+ ((uncomparable)
+ 'uncomparable))))))
+ lex-first))
+
+(define (make-lattice elem-list cmp-func)
+ (cons elem-list cmp-func))
+
+(define lattice->elements car)
+
+(define lattice->cmp cdr)
+
+; Select elements of a list which pass some test.
+(define zulu-select
+ (lambda (test lst)
+ (define select-a
+ (lambda (ac lst)
+ (if (null? lst)
+ (reverse! ac)
+ (select-a
+ (let ((head (car lst)))
+ (if (test head)
+ (cons head ac)
+ ac))
+ (cdr lst)))))
+ (select-a '() lst)))
+
+(define reverse!
+ (letrec ((rotate
+ (lambda (fo fum)
+ (let ((next (cdr fo)))
+ (set-cdr! fo fum)
+ (if (null? next)
+ fo
+ (rotate next fo))))))
+ (lambda (lst)
+ (if (null? lst)
+ '()
+ (rotate lst '())))))
+
+; Select elements of a list which pass some test and map a function
+; over the result. Note, only efficiency prevents this from being the
+; composition of select and map.
+(define select-map
+ (lambda (test func lst)
+ (define select-a
+ (lambda (ac lst)
+ (if (null? lst)
+ (reverse! ac)
+ (select-a
+ (let ((head (car lst)))
+ (if (test head)
+ (cons (func head)
+ ac)
+ ac))
+ (cdr lst)))))
+ (select-a '() lst)))
+
+
+
+; This version of map-and tail-recurses on the last test.
+(define map-and
+ (lambda (proc lst)
+ (if (null? lst)
+ #T
+ (letrec ((drudge
+ (lambda (lst)
+ (let ((rest (cdr lst)))
+ (if (null? rest)
+ (proc (car lst))
+ (and (proc (car lst))
+ (drudge rest)))))))
+ (drudge lst)))))
+
+(define (maps-1 source target pas new)
+ (let ((scmp (lattice->cmp source))
+ (tcmp (lattice->cmp target)))
+ (let ((less
+ (select-map
+ (lambda (p)
+ (eq? 'less
+ (scmp (car p) new)))
+ cdr
+ pas))
+ (more
+ (select-map
+ (lambda (p)
+ (eq? 'more
+ (scmp (car p) new)))
+ cdr
+ pas)))
+ (zulu-select
+ (lambda (t)
+ (and
+ (map-and
+ (lambda (t2)
+ (memq (tcmp t2 t) '(less equal)))
+ less)
+ (map-and
+ (lambda (t2)
+ (memq (tcmp t2 t) '(more equal)))
+ more)))
+ (lattice->elements target)))))
+
+(define (maps-rest source target pas rest to-1 to-collect)
+ (if (null? rest)
+ (to-1 pas)
+ (let ((next (car rest))
+ (rest (cdr rest)))
+ (to-collect
+ (map
+ (lambda (x)
+ (maps-rest source target
+ (cons
+ (cons next x)
+ pas)
+ rest
+ to-1
+ to-collect))
+ (maps-1 source target pas next))))))
+
+(define (maps source target)
+ (make-lattice
+ (maps-rest source
+ target
+ '()
+ (lattice->elements source)
+ (lambda (x) (list (map cdr x)))
+ (lambda (x) (apply append x)))
+ (lexico (lattice->cmp target))))
+
+(define print-frequency 10000)
+
+(define (count-maps source target)
+ (let ((count 0))
+ (maps-rest source
+ target
+ '()
+ (lattice->elements source)
+ (lambda (x)
+ (set! count (+ count 1))
+ (if (= 0 (remainder count print-frequency))
+ (begin #f))
+ 1)
+ (lambda (x) (apply + x)))))
+
+(define (lattice-benchmark)
+ (run-benchmark "Lattice"
+ (lambda ()
+ (let* ((l2
+ (make-lattice '(low high)
+ (lambda (lhs rhs)
+ (case lhs
+ ((low)
+ (case rhs
+ ((low)
+ 'equal)
+ ((high)
+ 'less)
+ (else
+ (error 'make-lattice "base" rhs))))
+ ((high)
+ (case rhs
+ ((low)
+ 'more)
+ ((high)
+ 'equal)
+ (else
+ (error 'make-lattice "base" rhs))))
+ (else
+ (error 'make-lattice "base" lhs))))))
+ (l3 (maps l2 l2))
+ (l4 (maps l3 l3)))
+ (count-maps l2 l2)
+ (count-maps l3 l3)
+ (count-maps l2 l3)
+ (count-maps l3 l2)
+ (count-maps l4 l4)))))
+
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: nboyer.sch
+; Description: The Boyer benchmark
+; Author: Bob Boyer
+; Created: 5-Apr-85
+; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
+; 22-Jul-87 (Will Clinger)
+; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
+; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
+; rewrote to eliminate property lists, and added
+; a scaling parameter suggested by Bob Boyer)
+; 19-Mar-99 (Will Clinger -- cleaned up comments)
+; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
+;;; Fairly CONS intensive.
+
+; Note: The version of this benchmark that appears in Dick Gabriel's book
+; contained several bugs that are corrected here. These bugs are discussed
+; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
+; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
+;
+; The benchmark now returns a boolean result.
+; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
+; in Common Lisp)
+; ONE-WAY-UNIFY1 now treats numbers correctly
+; ONE-WAY-UNIFY1-LST now treats empty lists correctly
+; Rule 19 has been corrected (this rule was not touched by the original
+; benchmark, but is used by this version)
+; Rules 84 and 101 have been corrected (but these rules are never touched
+; by the benchmark)
+;
+; According to Baker, these bug fixes make the benchmark 10-25% slower.
+; Please do not compare the timings from this benchmark against those of
+; the original benchmark.
+;
+; This version of the benchmark also prints the number of rewrites as a sanity
+; check, because it is too easy for a buggy version to return the correct
+; boolean result. The correct number of rewrites is
+;
+; n rewrites peak live storage (approximate, in bytes)
+; 0 95024 520,000
+; 1 591777 2,085,000
+; 2 1813975 5,175,000
+; 3 5375678
+; 4 16445406
+; 5 51507739
+
+; Nboyer is a 2-phase benchmark.
+; The first phase attaches lemmas to symbols. This phase is not timed,
+; but it accounts for very little of the runtime anyway.
+; The second phase creates the test problem, and tests to see
+; whether it is implied by the lemmas.
+
+(define (nboyer-benchmark . args)
+ (let ((n (if (null? args) 0 (car args))))
+ (setup-boyer)
+ (run-benchmark (string-append "nboyer"
+ (number->string n))
+ 1
+ (lambda () (test-boyer n))
+ (lambda (rewrites)
+ (and (number? rewrites)
+ (case n
+ ((0) (= rewrites 95024))
+ ((1) (= rewrites 591777))
+ ((2) (= rewrites 1813975))
+ ((3) (= rewrites 5375678))
+ ((4) (= rewrites 16445406))
+ ((5) (= rewrites 51507739))
+ ; If it works for n <= 5, assume it works.
+ (else #t)))))))
+
+(define (setup-boyer) #t) ; assigned below
+(define (test-boyer) #t) ; assigned below
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; The first phase.
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; In the original benchmark, it stored a list of lemmas on the
+; property lists of symbols.
+; In the new benchmark, it maintains an association list of
+; symbols and symbol-records, and stores the list of lemmas
+; within the symbol-records.
+
+(let ()
+
+ (define (setup)
+ (add-lemma-lst
+ (quote ((equal (compile form)
+ (reverse (codegen (optimize form)
+ (nil))))
+ (equal (eqp x y)
+ (equal (fix x)
+ (fix y)))
+ (equal (greaterp x y)
+ (lessp y x))
+ (equal (lesseqp x y)
+ (not (lessp y x)))
+ (equal (greatereqp x y)
+ (not (lessp x y)))
+ (equal (boolean x)
+ (or (equal x (t))
+ (equal x (f))))
+ (equal (iff x y)
+ (and (implies x y)
+ (implies y x)))
+ (equal (even1 x)
+ (if (zerop x)
+ (t)
+ (odd (sub1 x))))
+ (equal (countps- l pred)
+ (countps-loop l pred (zero)))
+ (equal (fact- i)
+ (fact-loop i 1))
+ (equal (reverse- x)
+ (reverse-loop x (nil)))
+ (equal (divides x y)
+ (zerop (remainder y x)))
+ (equal (assume-true var alist)
+ (cons (cons var (t))
+ alist))
+ (equal (assume-false var alist)
+ (cons (cons var (f))
+ alist))
+ (equal (tautology-checker x)
+ (tautologyp (normalize x)
+ (nil)))
+ (equal (falsify x)
+ (falsify1 (normalize x)
+ (nil)))
+ (equal (prime x)
+ (and (not (zerop x))
+ (not (equal x (add1 (zero))))
+ (prime1 x (sub1 x))))
+ (equal (and p q)
+ (if p (if q (t)
+ (f))
+ (f)))
+ (equal (or p q)
+ (if p (t)
+ (if q (t)
+ (f))))
+ (equal (not p)
+ (if p (f)
+ (t)))
+ (equal (implies p q)
+ (if p (if q (t)
+ (f))
+ (t)))
+ (equal (fix x)
+ (if (numberp x)
+ x
+ (zero)))
+ (equal (if (if a b c)
+ d e)
+ (if a (if b d e)
+ (if c d e)))
+ (equal (zerop x)
+ (or (equal x (zero))
+ (not (numberp x))))
+ (equal (plus (plus x y)
+ z)
+ (plus x (plus y z)))
+ (equal (equal (plus a b)
+ (zero))
+ (and (zerop a)
+ (zerop b)))
+ (equal (difference x x)
+ (zero))
+ (equal (equal (plus a b)
+ (plus a c))
+ (equal (fix b)
+ (fix c)))
+ (equal (equal (zero)
+ (difference x y))
+ (not (lessp y x)))
+ (equal (equal x (difference x y))
+ (and (numberp x)
+ (or (equal x (zero))
+ (zerop y))))
+ (equal (meaning (plus-tree (append x y))
+ a)
+ (plus (meaning (plus-tree x)
+ a)
+ (meaning (plus-tree y)
+ a)))
+ (equal (meaning (plus-tree (plus-fringe x))
+ a)
+ (fix (meaning x a)))
+ (equal (append (append x y)
+ z)
+ (append x (append y z)))
+ (equal (reverse (append a b))
+ (append (reverse b)
+ (reverse a)))
+ (equal (times x (plus y z))
+ (plus (times x y)
+ (times x z)))
+ (equal (times (times x y)
+ z)
+ (times x (times y z)))
+ (equal (equal (times x y)
+ (zero))
+ (or (zerop x)
+ (zerop y)))
+ (equal (exec (append x y)
+ pds envrn)
+ (exec y (exec x pds envrn)
+ envrn))
+ (equal (mc-flatten x y)
+ (append (flatten x)
+ y))
+ (equal (member x (append a b))
+ (or (member x a)
+ (member x b)))
+ (equal (member x (reverse y))
+ (member x y))
+ (equal (length (reverse x))
+ (length x))
+ (equal (member a (intersect b c))
+ (and (member a b)
+ (member a c)))
+ (equal (nth (zero)
+ i)
+ (zero))
+ (equal (exp i (plus j k))
+ (times (exp i j)
+ (exp i k)))
+ (equal (exp i (times j k))
+ (exp (exp i j)
+ k))
+ (equal (reverse-loop x y)
+ (append (reverse x)
+ y))
+ (equal (reverse-loop x (nil))
+ (reverse x))
+ (equal (count-list z (sort-lp x y))
+ (plus (count-list z x)
+ (count-list z y)))
+ (equal (equal (append a b)
+ (append a c))
+ (equal b c))
+ (equal (plus (remainder x y)
+ (times y (quotient x y)))
+ (fix x))
+ (equal (power-eval (big-plus1 l i base)
+ base)
+ (plus (power-eval l base)
+ i))
+ (equal (power-eval (big-plus x y i base)
+ base)
+ (plus i (plus (power-eval x base)
+ (power-eval y base))))
+ (equal (remainder y 1)
+ (zero))
+ (equal (lessp (remainder x y)
+ y)
+ (not (zerop y)))
+ (equal (remainder x x)
+ (zero))
+ (equal (lessp (quotient i j)
+ i)
+ (and (not (zerop i))
+ (or (zerop j)
+ (not (equal j 1)))))
+ (equal (lessp (remainder x y)
+ x)
+ (and (not (zerop y))
+ (not (zerop x))
+ (not (lessp x y))))
+ (equal (power-eval (power-rep i base)
+ base)
+ (fix i))
+ (equal (power-eval (big-plus (power-rep i base)
+ (power-rep j base)
+ (zero)
+ base)
+ base)
+ (plus i j))
+ (equal (gcd x y)
+ (gcd y x))
+ (equal (nth (append a b)
+ i)
+ (append (nth a i)
+ (nth b (difference i (length a)))))
+ (equal (difference (plus x y)
+ x)
+ (fix y))
+ (equal (difference (plus y x)
+ x)
+ (fix y))
+ (equal (difference (plus x y)
+ (plus x z))
+ (difference y z))
+ (equal (times x (difference c w))
+ (difference (times c x)
+ (times w x)))
+ (equal (remainder (times x z)
+ z)
+ (zero))
+ (equal (difference (plus b (plus a c))
+ a)
+ (plus b c))
+ (equal (difference (add1 (plus y z))
+ z)
+ (add1 y))
+ (equal (lessp (plus x y)
+ (plus x z))
+ (lessp y z))
+ (equal (lessp (times x z)
+ (times y z))
+ (and (not (zerop z))
+ (lessp x y)))
+ (equal (lessp y (plus x y))
+ (not (zerop x)))
+ (equal (gcd (times x z)
+ (times y z))
+ (times z (gcd x y)))
+ (equal (value (normalize x)
+ a)
+ (value x a))
+ (equal (equal (flatten x)
+ (cons y (nil)))
+ (and (nlistp x)
+ (equal x y)))
+ (equal (listp (gopher x))
+ (listp x))
+ (equal (samefringe x y)
+ (equal (flatten x)
+ (flatten y)))
+ (equal (equal (greatest-factor x y)
+ (zero))
+ (and (or (zerop y)
+ (equal y 1))
+ (equal x (zero))))
+ (equal (equal (greatest-factor x y)
+ 1)
+ (equal x 1))
+ (equal (numberp (greatest-factor x y))
+ (not (and (or (zerop y)
+ (equal y 1))
+ (not (numberp x)))))
+ (equal (times-list (append x y))
+ (times (times-list x)
+ (times-list y)))
+ (equal (prime-list (append x y))
+ (and (prime-list x)
+ (prime-list y)))
+ (equal (equal z (times w z))
+ (and (numberp z)
+ (or (equal z (zero))
+ (equal w 1))))
+ (equal (greatereqp x y)
+ (not (lessp x y)))
+ (equal (equal x (times x y))
+ (or (equal x (zero))
+ (and (numberp x)
+ (equal y 1))))
+ (equal (remainder (times y x)
+ y)
+ (zero))
+ (equal (equal (times a b)
+ 1)
+ (and (not (equal a (zero)))
+ (not (equal b (zero)))
+ (numberp a)
+ (numberp b)
+ (equal (sub1 a)
+ (zero))
+ (equal (sub1 b)
+ (zero))))
+ (equal (lessp (length (delete x l))
+ (length l))
+ (member x l))
+ (equal (sort2 (delete x l))
+ (delete x (sort2 l)))
+ (equal (dsort x)
+ (sort2 x))
+ (equal (length (cons x1
+ (cons x2
+ (cons x3 (cons x4
+ (cons x5
+ (cons x6 x7)))))))
+ (plus 6 (length x7)))
+ (equal (difference (add1 (add1 x))
+ 2)
+ (fix x))
+ (equal (quotient (plus x (plus x y))
+ 2)
+ (plus x (quotient y 2)))
+ (equal (sigma (zero)
+ i)
+ (quotient (times i (add1 i))
+ 2))
+ (equal (plus x (add1 y))
+ (if (numberp y)
+ (add1 (plus x y))
+ (add1 x)))
+ (equal (equal (difference x y)
+ (difference z y))
+ (if (lessp x y)
+ (not (lessp y z))
+ (if (lessp z y)
+ (not (lessp y x))
+ (equal (fix x)
+ (fix z)))))
+ (equal (meaning (plus-tree (delete x y))
+ a)
+ (if (member x y)
+ (difference (meaning (plus-tree y)
+ a)
+ (meaning x a))
+ (meaning (plus-tree y)
+ a)))
+ (equal (times x (add1 y))
+ (if (numberp y)
+ (plus x (times x y))
+ (fix x)))
+ (equal (nth (nil)
+ i)
+ (if (zerop i)
+ (nil)
+ (zero)))
+ (equal (last (append a b))
+ (if (listp b)
+ (last b)
+ (if (listp a)
+ (cons (car (last a))
+ b)
+ b)))
+ (equal (equal (lessp x y)
+ z)
+ (if (lessp x y)
+ (equal (t) z)
+ (equal (f) z)))
+ (equal (assignment x (append a b))
+ (if (assignedp x a)
+ (assignment x a)
+ (assignment x b)))
+ (equal (car (gopher x))
+ (if (listp x)
+ (car (flatten x))
+ (zero)))
+ (equal (flatten (cdr (gopher x)))
+ (if (listp x)
+ (cdr (flatten x))
+ (cons (zero)
+ (nil))))
+ (equal (quotient (times y x)
+ y)
+ (if (zerop y)
+ (zero)
+ (fix x)))
+ (equal (get j (set i val mem))
+ (if (eqp j i)
+ val
+ (get j mem)))))))
+
+ (define (add-lemma-lst lst)
+ (cond ((null? lst)
+ #t)
+ (else (add-lemma (car lst))
+ (add-lemma-lst (cdr lst)))))
+
+ (define (add-lemma term)
+ (cond ((and (pair? term)
+ (eq? (car term)
+ (quote equal))
+ (pair? (cadr term)))
+ (put (car (cadr term))
+ (quote lemmas)
+ (cons
+ (translate-term term)
+ (get (car (cadr term)) (quote lemmas)))))
+ (else (error "ADD-LEMMA did not like term: " term))))
+
+ ; Translates a term by replacing its constructor symbols by symbol-records.
+
+ (define (translate-term term)
+ (cond ((not (pair? term))
+ term)
+ (else (cons (symbol->symbol-record (car term))
+ (translate-args (cdr term))))))
+
+ (define (translate-args lst)
+ (cond ((null? lst)
+ '())
+ (else (cons (translate-term (car lst))
+ (translate-args (cdr lst))))))
+
+ ; For debugging only, so the use of MAP does not change
+ ; the first-order character of the benchmark.
+
+ (define (untranslate-term term)
+ (cond ((not (pair? term))
+ term)
+ (else (cons (get-name (car term))
+ (map untranslate-term (cdr term))))))
+
+ ; A symbol-record is represented as a vector with two fields:
+ ; the symbol (for debugging) and
+ ; the list of lemmas associated with the symbol.
+
+ (define (put sym property value)
+ (put-lemmas! (symbol->symbol-record sym) value))
+
+ (define (get sym property)
+ (get-lemmas (symbol->symbol-record sym)))
+
+ (define (symbol->symbol-record sym)
+ (let ((x (assq sym *symbol-records-alist*)))
+ (if x
+ (cdr x)
+ (let ((r (make-symbol-record sym)))
+ (set! *symbol-records-alist*
+ (cons (cons sym r)
+ *symbol-records-alist*))
+ r))))
+
+ ; Association list of symbols and symbol-records.
+
+ (define *symbol-records-alist* '())
+
+ ; A symbol-record is represented as a vector with two fields:
+ ; the symbol (for debugging) and
+ ; the list of lemmas associated with the symbol.
+
+ (define (make-symbol-record sym)
+ (vector sym '()))
+
+ (define (put-lemmas! symbol-record lemmas)
+ (vector-set! symbol-record 1 lemmas))
+
+ (define (get-lemmas symbol-record)
+ (vector-ref symbol-record 1))
+
+ (define (get-name symbol-record)
+ (vector-ref symbol-record 0))
+
+ (define (symbol-record-equal? r1 r2)
+ (eq? r1 r2))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ; The second phase.
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (test n)
+ (let ((term
+ (apply-subst
+ (translate-alist
+ (quote ((x f (plus (plus a b)
+ (plus c (zero))))
+ (y f (times (times a b)
+ (plus c d)))
+ (z f (reverse (append (append a b)
+ (nil))))
+ (u equal (plus a b)
+ (difference x y))
+ (w lessp (remainder a b)
+ (member a (length b))))))
+ (translate-term
+ (do ((term
+ (quote (implies (and (implies x y)
+ (and (implies y z)
+ (and (implies z u)
+ (implies u w))))
+ (implies x w)))
+ (list 'or term '(f)))
+ (n n (- n 1)))
+ ((zero? n) term))))))
+ (tautp term)))
+
+ (define (translate-alist alist)
+ (cond ((null? alist)
+ '())
+ (else (cons (cons (caar alist)
+ (translate-term (cdar alist)))
+ (translate-alist (cdr alist))))))
+
+ (define (apply-subst alist term)
+ (cond ((not (pair? term))
+ (let ((temp-temp (assq term alist)))
+ (if temp-temp
+ (cdr temp-temp)
+ term)))
+ (else (cons (car term)
+ (apply-subst-lst alist (cdr term))))))
+
+ (define (apply-subst-lst alist lst)
+ (cond ((null? lst)
+ '())
+ (else (cons (apply-subst alist (car lst))
+ (apply-subst-lst alist (cdr lst))))))
+
+ (define (tautp x)
+ (tautologyp (rewrite x)
+ '() '()))
+
+ (define (tautologyp x true-lst false-lst)
+ (cond ((truep x true-lst)
+ #t)
+ ((falsep x false-lst)
+ #f)
+ ((not (pair? x))
+ #f)
+ ((eq? (car x) if-constructor)
+ (cond ((truep (cadr x)
+ true-lst)
+ (tautologyp (caddr x)
+ true-lst false-lst))
+ ((falsep (cadr x)
+ false-lst)
+ (tautologyp (cadddr x)
+ true-lst false-lst))
+ (else (and (tautologyp (caddr x)
+ (cons (cadr x)
+ true-lst)
+ false-lst)
+ (tautologyp (cadddr x)
+ true-lst
+ (cons (cadr x)
+ false-lst))))))
+ (else #f)))
+
+ (define if-constructor '*) ; becomes (symbol->symbol-record 'if)
+
+ (define rewrite-count 0) ; sanity check
+
+ (define (rewrite term)
+ (set! rewrite-count (+ rewrite-count 1))
+ (cond ((not (pair? term))
+ term)
+ (else (rewrite-with-lemmas (cons (car term)
+ (rewrite-args (cdr term)))
+ (get-lemmas (car term))))))
+
+ (define (rewrite-args lst)
+ (cond ((null? lst)
+ '())
+ (else (cons (rewrite (car lst))
+ (rewrite-args (cdr lst))))))
+
+ (define (rewrite-with-lemmas term lst)
+ (cond ((null? lst)
+ term)
+ ((one-way-unify term (cadr (car lst)))
+ (rewrite (apply-subst unify-subst (caddr (car lst)))))
+ (else (rewrite-with-lemmas term (cdr lst)))))
+
+ (define unify-subst '*)
+
+ (define (one-way-unify term1 term2)
+ (begin (set! unify-subst '())
+ (one-way-unify1 term1 term2)))
+
+ (define (one-way-unify1 term1 term2)
+ (cond ((not (pair? term2))
+ (let ((temp-temp (assq term2 unify-subst)))
+ (cond (temp-temp
+ (term-equal? term1 (cdr temp-temp)))
+ ((number? term2) ; This bug fix makes
+ (equal? term1 term2)) ; nboyer 10-25% slower!
+ (else
+ (set! unify-subst (cons (cons term2 term1)
+ unify-subst))
+ #t))))
+ ((not (pair? term1))
+ #f)
+ ((eq? (car term1)
+ (car term2))
+ (one-way-unify1-lst (cdr term1)
+ (cdr term2)))
+ (else #f)))
+
+ (define (one-way-unify1-lst lst1 lst2)
+ (cond ((null? lst1)
+ (null? lst2))
+ ((null? lst2)
+ #f)
+ ((one-way-unify1 (car lst1)
+ (car lst2))
+ (one-way-unify1-lst (cdr lst1)
+ (cdr lst2)))
+ (else #f)))
+
+ (define (falsep x lst)
+ (or (term-equal? x false-term)
+ (term-member? x lst)))
+
+ (define (truep x lst)
+ (or (term-equal? x true-term)
+ (term-member? x lst)))
+
+ (define false-term '*) ; becomes (translate-term '(f))
+ (define true-term '*) ; becomes (translate-term '(t))
+
+ ; The next two procedures were in the original benchmark
+ ; but were never used.
+
+ (define (trans-of-implies n)
+ (translate-term
+ (list (quote implies)
+ (trans-of-implies1 n)
+ (list (quote implies)
+ 0 n))))
+
+ (define (trans-of-implies1 n)
+ (cond ((equal? n 1)
+ (list (quote implies)
+ 0 1))
+ (else (list (quote and)
+ (list (quote implies)
+ (- n 1)
+ n)
+ (trans-of-implies1 (- n 1))))))
+
+ ; Translated terms can be circular structures, which can't be
+ ; compared using Scheme's equal? and member procedures, so we
+ ; use these instead.
+
+ (define (term-equal? x y)
+ (cond ((pair? x)
+ (and (pair? y)
+ (symbol-record-equal? (car x) (car y))
+ (term-args-equal? (cdr x) (cdr y))))
+ (else (equal? x y))))
+
+ (define (term-args-equal? lst1 lst2)
+ (cond ((null? lst1)
+ (null? lst2))
+ ((null? lst2)
+ #f)
+ ((term-equal? (car lst1) (car lst2))
+ (term-args-equal? (cdr lst1) (cdr lst2)))
+ (else #f)))
+
+ (define (term-member? x lst)
+ (cond ((null? lst)
+ #f)
+ ((term-equal? x (car lst))
+ #t)
+ (else (term-member? x (cdr lst)))))
+
+ (set! setup-boyer
+ (lambda ()
+ (set! *symbol-records-alist* '())
+ (set! if-constructor (symbol->symbol-record 'if))
+ (set! false-term (translate-term '(f)))
+ (set! true-term (translate-term '(t)))
+ (setup)))
+
+ (set! test-boyer
+ (lambda (n)
+ (set! rewrite-count 0)
+ (let ((answer (test n)))
+ (write rewrite-count)
+ (display " rewrites")
+ (newline)
+ (if answer
+ rewrite-count
+ #f)))))
--- /dev/null
+; File: "nucleic2.scm"
+;
+; Author: Marc Feeley (feeley@iro.umontreal.ca)
+; Last modification by Feeley: June 6, 1994.
+; Modified for R5RS Scheme by William D Clinger: 22 October 1996.
+; Last modification by Clinger: 19 March 1999.
+;
+; This program is a modified version of the program described in
+;
+; M. Feeley, M. Turcotte, G. Lapalme. Using Multilisp for Solving
+; Constraint Satisfaction Problems: an Application to Nucleic Acid 3D
+; Structure Determination. Lisp and Symbolic Computation 7(2/3),
+; 231-246, 1994.
+;
+; The differences between this program and the original are described in
+;
+; P.H. Hartel, M. Feeley, et al. Benchmarking Implementations of
+; Functional Languages with "Pseudoknot", a Float-Intensive Benchmark.
+; Journal of Functional Programming 6(4), 621-655, 1996.
+
+; This procedure uses Marc Feeley's run-benchmark procedure to time
+; the benchmark.
+
+(define (nucleic2-benchmark . rest)
+ (let ((n (if (null? rest) 1 (car rest))))
+ (run-benchmark (string-append "nucleic2"
+ (if (> n 1)
+ (string-append " ("
+ (number->string n)
+ " iterations)")
+ ""))
+ n
+ run
+ (lambda (x)
+ (and (number? x)
+ (real? x)
+ (< (abs (- x 33.797594890762696)) 0.01))))))
+
+; PORTABILITY.
+;
+; This program should run in any R5RS-conforming implementation of Scheme.
+; To run this program in an implementation that does not support the R5RS
+; macro system, however, you will have to place a single quotation mark (')
+; on the following line and also modify the "SYSTEM DEPENDENT CODE" below.
+
+; ********** R5RS Scheme
+
+(begin
+
+(define-syntax FLOAT+ (syntax-rules () ((FLOAT+ x ...) (+ x ...))))
+(define-syntax FLOAT- (syntax-rules () ((FLOAT- x ...) (- x ...))))
+(define-syntax FLOAT* (syntax-rules () ((FLOAT* x ...) (* x ...))))
+(define-syntax FLOAT/ (syntax-rules () ((FLOAT/ x ...) (/ x ...))))
+(define-syntax FLOAT= (syntax-rules () ((FLOAT= x y) (= x y))))
+(define-syntax FLOAT< (syntax-rules () ((FLOAT< x y) (< x y))))
+(define-syntax FLOAT<= (syntax-rules () ((FLOAT<= x y) (<= x y))))
+(define-syntax FLOAT> (syntax-rules () ((FLOAT> x y) (> x y))))
+(define-syntax FLOAT>= (syntax-rules () ((FLOAT>= x y) (>= x y))))
+(define-syntax FLOATsin (syntax-rules () ((FLOATsin x) (sin x))))
+(define-syntax FLOATcos (syntax-rules () ((FLOATcos x) (cos x))))
+(define-syntax FLOATatan (syntax-rules () ((FLOATatan x) (atan x))))
+(define-syntax FLOATsqrt (syntax-rules () ((FLOATsqrt x) (sqrt x))))
+
+(define-syntax FUTURE (syntax-rules () ((FUTURE x) x)))
+(define-syntax TOUCH (syntax-rules () ((TOUCH x) x)))
+
+(define-syntax def-macro (syntax-rules () ((def-macro stuff ...) #t)))
+(define-syntax def-struct (syntax-rules () ((def-macro stuff ...) #t)))
+(define-syntax def-nuc (syntax-rules () ((def-nuc stuff ...) #t)))
+
+(define-syntax define-structure
+ (syntax-rules ()
+ ((define-structure #f
+ name make make-constant (select1 ...) (set1 ...))
+ (begin (define-syntax make
+ (syntax-rules ()
+ ((make select1 ...)
+ (vector select1 ...))))
+ (define-syntax make-constant
+ (syntax-rules ()
+ ; The vectors that are passed to make-constant aren't quoted.
+ ((make-constant . args)
+ (constant-maker make . args))))
+ (define-selectors (select1 ...)
+ (0 1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18 19
+ 20 21 22 23 24 25 26 27 28 29
+ 30 31 32 33 34 35 36 37 38 39
+ 40 41 42 43 44 45 46 47 48 49))
+ (define-setters (set1 ...)
+ (0 1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18 19
+ 20 21 22 23 24 25 26 27 28 29
+ 30 31 32 33 34 35 36 37 38 39
+ 40 41 42 43 44 45 46 47 48 49))))
+ ((define-structure pred?
+ name make make-constant (select1 ...) (set1 ...))
+ (begin (define-syntax pred?
+ (syntax-rules ()
+ ((pred? v)
+ (and (vector? v) (eq? (vector-ref v 0) 'name)))))
+ (define-syntax make
+ (syntax-rules ()
+ ((make select1 ...)
+ (vector 'name select1 ...))))
+ (define-syntax make-constant
+ (syntax-rules ()
+ ; The vectors that are passed to make-constant aren't quoted.
+ ((make-constant . args)
+ (constant-maker make . args))))
+ (define-selectors (select1 ...)
+ (1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18 19
+ 20 21 22 23 24 25 26 27 28 29
+ 30 31 32 33 34 35 36 37 38 39
+ 40 41 42 43 44 45 46 47 48 49))
+ (define-setters (set1 ...)
+ (1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18 19
+ 20 21 22 23 24 25 26 27 28 29
+ 30 31 32 33 34 35 36 37 38 39
+ 40 41 42 43 44 45 46 47 48 49))))))
+(define-syntax constant-maker
+ (syntax-rules ()
+ ; The quotation marks are added here.
+ ((constant-maker make arg ...)
+ (make 'arg ...))))
+(define-syntax define-selectors
+ (syntax-rules ()
+ ((define-selectors (select) (i i1 ...))
+ (define-syntax select
+ (syntax-rules ()
+ ((select v) (vector-ref v i)))))
+ ((define-selectors (select select1 ...) (i i1 ...))
+ (begin (define-syntax select
+ (syntax-rules ()
+ ((select v) (vector-ref v i))))
+ (define-selectors (select1 ...) (i1 ...))))))
+(define-syntax define-setters
+ (syntax-rules ()
+ ((define-setters (set) (i i1 ...))
+ (define-syntax set
+ (syntax-rules ()
+ ((set v x) (vector-set! v i x)))))
+ ((define-setters (set set1 ...) (i i1 ...))
+ (begin (define-syntax set
+ (syntax-rules ()
+ ((set v x) (vector-set! v i x))))
+ (define-setters (set1 ...) (i1 ...))))))
+
+(define-structure #f pt
+ make-pt make-constant-pt
+ (pt-x pt-y pt-z)
+ (pt-x-set! pt-y-set! pt-z-set!))
+
+(define-structure #f tfo
+ make-tfo make-constant-tfo
+ (tfo-a tfo-b tfo-c tfo-d tfo-e tfo-f tfo-g tfo-h tfo-i tfo-tx tfo-ty tfo-tz)
+ (tfo-a-set! tfo-b-set! tfo-c-set! tfo-d-set! tfo-e-set! tfo-f-set!
+ tfo-g-set! tfo-h-set! tfo-i-set! tfo-tx-set! tfo-ty-set! tfo-tz-set!))
+
+(define-structure nuc? nuc
+ make-nuc make-constant-nuc
+ (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+ nuc-P-O3*-180-tfo
+ nuc-P-O3*-60-tfo
+ nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+ nuc-H5* nuc-H5**
+ nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+ nuc-C2* nuc-H2**
+ nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+ nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6)
+ (nuc-dgf-base-tfo-set!
+ nuc-P-O3*-275-tfo-set!
+ nuc-P-O3*-180-tfo-set!
+ nuc-P-O3*-60-tfo-set!
+ nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+ nuc-H5*-set! nuc-H5**-set!
+ nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+ nuc-C2*-set! nuc-H2**-set!
+ nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+ nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!))
+
+(define-structure rA? rA
+ make-rA make-constant-rA
+ (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+ nuc-P-O3*-180-tfo
+ nuc-P-O3*-60-tfo
+ nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+ nuc-H5* nuc-H5**
+ nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+ nuc-C2* nuc-H2**
+ nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+ nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6
+ rA-N6 rA-N7 rA-N9 rA-C8
+ rA-H2 rA-H61 rA-H62 rA-H8)
+ (nuc-dgf-base-tfo-set!
+ nuc-P-O3*-275-tfo-set!
+ nuc-P-O3*-180-tfo-set!
+ nuc-P-O3*-60-tfo-set!
+ nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+ nuc-H5*-set! nuc-H5**-set!
+ nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+ nuc-C2*-set! nuc-H2**-set!
+ nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+ nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!
+ rA-N6-set! rA-N7-set! rA-N9-set! rA-C8-set!
+ rA-H2-set! rA-H61-set! rA-H62-set! rA-H8-set!))
+
+(define-structure rC? rC
+ make-rC make-constant-rC
+ (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+ nuc-P-O3*-180-tfo
+ nuc-P-O3*-60-tfo
+ nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+ nuc-H5* nuc-H5**
+ nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+ nuc-C2* nuc-H2**
+ nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+ nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6
+ rC-N4 rC-O2 rC-H41 rC-H42 rC-H5 rC-H6)
+ (nuc-dgf-base-tfo-set!
+ nuc-P-O3*-275-tfo-set!
+ nuc-P-O3*-180-tfo-set!
+ nuc-P-O3*-60-tfo-set!
+ nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+ nuc-H5*-set! nuc-H5**-set!
+ nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+ nuc-C2*-set! nuc-H2**-set!
+ nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+ nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!
+ rC-N4-set! rC-O2-set! rC-H41-set! rC-H42-set! rC-H5-set! rC-H6-set!))
+
+(define-structure rG? rG
+ make-rG make-constant-rG
+ (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+ nuc-P-O3*-180-tfo
+ nuc-P-O3*-60-tfo
+ nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+ nuc-H5* nuc-H5**
+ nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+ nuc-C2* nuc-H2**
+ nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+ nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6
+ rG-N2 rG-N7 rG-N9 rG-C8 rG-O6
+ rG-H1 rG-H21 rG-H22 rG-H8)
+ (nuc-dgf-base-tfo-set!
+ nuc-P-O3*-275-tfo-set!
+ nuc-P-O3*-180-tfo-set!
+ nuc-P-O3*-60-tfo-set!
+ nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+ nuc-H5*-set! nuc-H5**-set!
+ nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+ nuc-C2*-set! nuc-H2**-set!
+ nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+ nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!
+ rG-N2-set! rG-N7-set! rG-N9-set! rG-C8-set! rG-O6-set!
+ rG-H1-set! rG-H21-set! rG-H22-set! rG-H8-set!))
+
+(define-structure rU? rU
+ make-rU make-constant-rU
+ (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ nuc-P-O3*-275-tfo ; defines the standard position for the connect function
+ nuc-P-O3*-180-tfo
+ nuc-P-O3*-60-tfo
+ nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5*
+ nuc-H5* nuc-H5**
+ nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1*
+ nuc-C2* nuc-H2**
+ nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3*
+ nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6
+ rU-O2 rU-O4 rU-H3 rU-H5 rU-H6)
+ (nuc-dgf-base-tfo-set!
+ nuc-P-O3*-275-tfo-set!
+ nuc-P-O3*-180-tfo-set!
+ nuc-P-O3*-60-tfo-set!
+ nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set!
+ nuc-H5*-set! nuc-H5**-set!
+ nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set!
+ nuc-C2*-set! nuc-H2**-set!
+ nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set!
+ nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!
+ rU-O2-set! rU-O4-set! rU-H3-set! rU-H5-set! rU-H6-set!))
+
+(define-structure #f var
+ make-var make-constant-var
+ (var-id var-tfo var-nuc)
+ (var-id-set! var-tfo-set! var-nuc-set!))
+
+; Comment out the next three syntax definitions if you want
+; lazy computation.
+
+(define-syntax mk-var
+ (syntax-rules ()
+ ((mk-var i tfo nuc)
+ (make-var i tfo nuc))))
+
+(define-syntax absolute-pos
+ (syntax-rules ()
+ ((absolute-pos var p)
+ (tfo-apply (var-tfo var) p))))
+
+(define-syntax lazy-computation-of
+ (syntax-rules ()
+ ((lazy-computation-of expr)
+ expr)))
+
+; Uncomment the next three syntax definitions if you want
+; lazy computation.
+
+; (define-syntax mk-var
+; (syntax-rules ()
+; ((mk-var i tfo nuc)
+; (make-var i tfo (make-relative-nuc tfo nuc)))))
+;
+; (define-syntax absolute-pos
+; (syntax-rules ()
+; ((absolute-pos var p)
+; (force p))))
+;
+; (define-syntax lazy-computation-of
+; (syntax-rules ()
+; ((lazy-computation-of expr)
+; (delay expr))))
+
+(define-syntax atom-pos
+ (syntax-rules ()
+ ((atom-pos atom var)
+ (let ((v var))
+ (absolute-pos v (atom (var-nuc v)))))))
+
+)
+
+; -- SYSTEM DEPENDENT CODE ----------------------------------------------------
+
+; The code in this section is not portable. It must be adapted to
+; the Scheme system you are using.
+
+; ********** GAMBIT 2.2
+
+'; Add a single-quote at the start of this line if you are NOT using Gambit
+(begin
+
+(declare ; Compiler declarations for fast code:
+ (multilisp) ; - Enable the FUTURE special-form
+ (block) ; - Assume this file contains the entire program
+ (standard-bindings) ; - Assume standard bindings (this permits open-coding)
+ (extended-bindings) ; - Same for extensions (such as "##flonum.+")
+ (fixnum) ; - Use fixnum arithmetic by default
+ (not safe) ; - Remove all runtime type checks
+)
+
+(define-macro (def-macro form . body)
+ `(DEFINE-MACRO ,form (LET () ,@body)))
+
+(def-macro (FLOAT+ x . l) `(,(string->symbol "##flonum.+") ,x ,@l))
+(def-macro (FLOAT- x . l) `(,(string->symbol "##flonum.-") ,x ,@l))
+(def-macro (FLOAT* x . l) `(,(string->symbol "##flonum.*") ,x ,@l))
+(def-macro (FLOAT/ x . l) `(,(string->symbol "##flonum./") ,x ,@l))
+(def-macro (FLOAT= x y) `(,(string->symbol "##flonum.=") ,x ,y))
+(def-macro (FLOAT< x y) `(,(string->symbol "##flonum.<") ,x ,y))
+(def-macro (FLOAT<= x y) `(not (,(string->symbol "##flonum.<") ,y ,x)))
+(def-macro (FLOAT> x y) `(,(string->symbol "##flonum.<") ,y ,x))
+(def-macro (FLOAT>= x y) `(not (,(string->symbol "##flonum.<") ,x ,y)))
+(def-macro (FLOATsin x) `(,(string->symbol "##flonum.sin") ,x))
+(def-macro (FLOATcos x) `(,(string->symbol "##flonum.cos") ,x))
+(def-macro (FLOATatan x) `(,(string->symbol "##flonum.atan") ,x))
+(def-macro (FLOATsqrt x) `(,(string->symbol "##flonum.sqrt") ,x))
+)
+
+; ********** MIT-SCHEME
+
+'; Remove the single-quote from this line if you are using MIT-Scheme
+(begin
+
+(declare (usual-integrations))
+
+(define-macro (def-macro form . body)
+ `(DEFINE-MACRO ,form (LET () ,@body)))
+
+(def-macro (nary-function op1 op2 args)
+ (if (null? (cdr args))
+ `(,op1 ,@args)
+ (let loop ((args args))
+ (if (null? (cdr args))
+ (car args)
+ (loop (cons (list op2 (car args) (cadr args)) (cddr args)))))))
+
+(def-macro (FLOAT+ x . l) `(nary-function begin flo:+ ,(cons x l)))
+(def-macro (FLOAT- x . l) `(nary-function flo:negate flo:- ,(cons x l)))
+(def-macro (FLOAT* x . l) `(nary-function begin flo:* ,(cons x l)))
+(def-macro (FLOAT/ x . l) `(nary-function error flo:/ ,(cons x l)))
+(def-macro (FLOAT= x y) `(flo:= ,x ,y))
+(def-macro (FLOAT< x y) `(flo:< ,x ,y))
+(def-macro (FLOAT<= x y) `(not (flo:< ,y ,x)))
+(def-macro (FLOAT> x y) `(flo:< ,y ,x))
+(def-macro (FLOAT>= x y) `(not (flo:< ,x ,y)))
+(def-macro (FLOATsin x) `(flo:sin ,x))
+(def-macro (FLOATcos x) `(flo:cos ,x))
+(def-macro (FLOATatan x) `(flo:atan ,x))
+(def-macro (FLOATsqrt x) `(flo:sqrt ,x))
+
+(def-macro (FUTURE x) x)
+(def-macro (TOUCH x) x)
+)
+
+; ********** SCM
+
+'; Remove the single-quote from this line if you are using SCM
+(begin
+
+(defmacro def-macro (form . body)
+ `(DEFMACRO ,(car form) ,(cdr form) (LET () ,@body)))
+
+(def-macro (FLOAT+ x . l) `(+ ,x ,@l))
+(def-macro (FLOAT- x . l) `(- ,x ,@l))
+(def-macro (FLOAT* x . l) `(* ,x ,@l))
+(def-macro (FLOAT/ x . l) `(/ ,x ,@l))
+(def-macro (FLOAT= x y) `(= ,x ,y))
+(def-macro (FLOAT< x y) `(< ,x ,y))
+(def-macro (FLOAT<= x y) `(not (< ,y ,x)))
+(def-macro (FLOAT> x y) `(< ,y ,x))
+(def-macro (FLOAT>= x y) `(not (< ,x ,y)))
+(def-macro (FLOATsin x) `(sin ,x))
+(def-macro (FLOATcos x) `(cos ,x))
+(def-macro (FLOATatan x) `(atan ,x))
+(def-macro (FLOATsqrt x) `(sqrt ,x))
+
+(def-macro (FUTURE x) x)
+(def-macro (TOUCH x) x)
+)
+
+; -- STRUCTURE DEFINITION MACRO -----------------------------------------------
+
+; The macro "def-struct" provides a simple mechanism to define record
+; structures out of vectors. The first argument to "def-struct" is a boolean
+; indicating whether the vector should be tagged (to allow the type of the
+; structure to be tested). The second argument is the name of the structure.
+; The remaining arguments are the names of the structure's fields. A call
+; to "def-struct" defines macros to
+;
+; 1) construct a record object of this type
+; 2) fetch and store each field
+; 3) test a record to see if it is of this type (only if tags are used)
+; 4) define subclasses of this record with additional fields
+;
+; The call "(def-struct #t foo a b c)" will define the following macros:
+;
+; (make-foo x y) -- make a record
+; (make-constant-foo x y) -- make a record (args must be constants)
+; (foo? x) -- test a record
+; (foo-a x) -- get field "a"
+; (foo-b x) -- get field "b"
+; (foo-a-set! x y) -- mutate field "a"
+; (foo-b-set! x y) -- mutate field "b"
+; (def-foo tag? name fields...) -- define subclass of "foo"
+
+(def-macro (def-struct tag? name . fields)
+ `(DEF-SUBSTRUCT () () 0 ,tag? ,name ,@fields))
+
+(def-macro (def-substruct sup-fields sup-tags sup-length tag? name . fields)
+
+ (define (err)
+ (error "Ill-formed `def-substruct'") #f)
+
+ (define (sym . strings)
+ (string->symbol (apply string-append strings)))
+
+ (if (symbol? name)
+ (let* ((name-str (symbol->string name))
+ (tag (sym "." name-str "."))
+ (all-tags (append sup-tags
+ (if tag?
+ (list (cons tag sup-length))
+ '()))))
+ (let loop ((l1 fields)
+ (l2 '())
+ (l3 '())
+ (i (+ sup-length (if tag? 1 0))))
+ (if (pair? l1)
+ (let ((rest (cdr l1)) (field (car l1)))
+ (if (symbol? field)
+ (let* ((field-str (symbol->string field))
+ (field-ref (sym name-str "-" field-str))
+ (field-set! (sym name-str "-" field-str "-set!")))
+ (loop rest
+ (cons `(DEF-MACRO (,field-set! X Y)
+ `(VECTOR-SET! ,X ,,i ,Y))
+ (cons `(DEF-MACRO (,field-ref X)
+ `(VECTOR-REF ,X ,,i))
+ l2))
+ (cons (cons field i) l3)
+ (+ i 1)))
+ (err)))
+ (let ((all-fields (append sup-fields (reverse l3))))
+ `(BEGIN
+ ,@l2
+ (DEFINE ,(sym "fields-of-" name-str)
+ ',all-fields)
+ (DEF-MACRO (,(sym "def-" name-str) TAG? NAME . FIELDS)
+ `(DEF-SUBSTRUCT ,',all-fields ,',all-tags ,',i
+ ,TAG? ,NAME ,@FIELDS))
+ (DEF-MACRO (,(sym "make-constant-" name-str) . REST)
+ (DEFINE (ADD-TAGS I TAGS LST)
+ (COND ((NULL? TAGS)
+ LST)
+ ((= I (CDAR TAGS))
+ (CONS (CAAR TAGS)
+ (ADD-TAGS (+ I 1) (CDR TAGS) LST)))
+ (ELSE
+ (CONS (CAR LST)
+ (ADD-TAGS (+ I 1) TAGS (CDR LST))))))
+ `'#(,@(ADD-TAGS 0 ',all-tags REST)))
+ (DEF-MACRO (,(sym "make-" name-str) . REST)
+ (DEFINE (ADD-TAGS I TAGS LST)
+ (COND ((NULL? TAGS)
+ LST)
+ ((= I (CDAR TAGS))
+ (CONS `',(CAAR TAGS)
+ (ADD-TAGS (+ I 1) (CDR TAGS) LST)))
+ (ELSE
+ (CONS (CAR LST)
+ (ADD-TAGS (+ I 1) TAGS (CDR LST))))))
+ `(VECTOR ,@(ADD-TAGS 0 ',all-tags REST)))
+ ,@(if tag?
+ `((DEF-MACRO (,(sym name-str "?") X)
+ `(EQ? (VECTOR-REF ,X ,,sup-length) ',',tag)))
+ '())
+ ',name)))))
+ (err)))
+
+; -- MATH UTILITIES -----------------------------------------------------------
+
+(define constant-pi 3.14159265358979323846)
+(define constant-minus-pi -3.14159265358979323846)
+(define constant-pi/2 1.57079632679489661923)
+(define constant-minus-pi/2 -1.57079632679489661923)
+
+(define (math-atan2 y x)
+ (cond ((FLOAT> x 0.0)
+ (FLOATatan (FLOAT/ y x)))
+ ((FLOAT< y 0.0)
+ (if (FLOAT= x 0.0)
+ constant-minus-pi/2
+ (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-minus-pi)))
+ (else
+ (if (FLOAT= x 0.0)
+ constant-pi/2
+ (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-pi)))))
+
+; -- POINTS -------------------------------------------------------------------
+
+(def-struct #f pt x y z)
+
+(define (pt-sub p1 p2)
+ (make-pt (FLOAT- (pt-x p1) (pt-x p2))
+ (FLOAT- (pt-y p1) (pt-y p2))
+ (FLOAT- (pt-z p1) (pt-z p2))))
+
+(define (pt-dist p1 p2)
+ (let ((dx (FLOAT- (pt-x p1) (pt-x p2)))
+ (dy (FLOAT- (pt-y p1) (pt-y p2)))
+ (dz (FLOAT- (pt-z p1) (pt-z p2))))
+ (FLOATsqrt (FLOAT+ (FLOAT* dx dx) (FLOAT* dy dy) (FLOAT* dz dz)))))
+
+(define (pt-phi p)
+ (let* ((x (pt-x p))
+ (y (pt-y p))
+ (z (pt-z p))
+ (b (math-atan2 x z)))
+ (math-atan2 (FLOAT+ (FLOAT* (FLOATcos b) z) (FLOAT* (FLOATsin b) x)) y)))
+
+(define (pt-theta p)
+ (math-atan2 (pt-x p) (pt-z p)))
+
+; -- COORDINATE TRANSFORMATIONS -----------------------------------------------
+
+; The notation for the transformations follows "Paul, R.P. (1981) Robot
+; Manipulators. MIT Press." with the exception that our transformation
+; matrices don't have the perspective terms and are the transpose of
+; Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to
+; Solid Modeling, Computer Science Press" Appendix A.
+;
+; The components of a transformation matrix are named like this:
+;
+; a b c
+; d e f
+; g h i
+; tx ty tz
+;
+; The components tx, ty, and tz are the translation vector.
+
+(def-struct #f tfo a b c d e f g h i tx ty tz)
+
+(define tfo-id ; the identity transformation matrix
+ '#(1.0 0.0 0.0
+ 0.0 1.0 0.0
+ 0.0 0.0 1.0
+ 0.0 0.0 0.0))
+
+; The function "tfo-apply" multiplies a transformation matrix, tfo, by a
+; point vector, p. The result is a new point.
+
+(define (tfo-apply tfo p)
+ (let ((x (pt-x p))
+ (y (pt-y p))
+ (z (pt-z p)))
+ (make-pt
+ (FLOAT+ (FLOAT* x (tfo-a tfo))
+ (FLOAT* y (tfo-d tfo))
+ (FLOAT* z (tfo-g tfo))
+ (tfo-tx tfo))
+ (FLOAT+ (FLOAT* x (tfo-b tfo))
+ (FLOAT* y (tfo-e tfo))
+ (FLOAT* z (tfo-h tfo))
+ (tfo-ty tfo))
+ (FLOAT+ (FLOAT* x (tfo-c tfo))
+ (FLOAT* y (tfo-f tfo))
+ (FLOAT* z (tfo-i tfo))
+ (tfo-tz tfo)))))
+
+; The function "tfo-combine" multiplies two transformation matrices A and B.
+; The result is a new matrix which cumulates the transformations described
+; by A and B.
+
+(define (tfo-combine A B)
+ (make-tfo
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-a B))
+ (FLOAT* (tfo-b A) (tfo-d B))
+ (FLOAT* (tfo-c A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-b B))
+ (FLOAT* (tfo-b A) (tfo-e B))
+ (FLOAT* (tfo-c A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-c B))
+ (FLOAT* (tfo-b A) (tfo-f B))
+ (FLOAT* (tfo-c A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-a B))
+ (FLOAT* (tfo-e A) (tfo-d B))
+ (FLOAT* (tfo-f A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-b B))
+ (FLOAT* (tfo-e A) (tfo-e B))
+ (FLOAT* (tfo-f A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-c B))
+ (FLOAT* (tfo-e A) (tfo-f B))
+ (FLOAT* (tfo-f A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-a B))
+ (FLOAT* (tfo-h A) (tfo-d B))
+ (FLOAT* (tfo-i A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-b B))
+ (FLOAT* (tfo-h A) (tfo-e B))
+ (FLOAT* (tfo-i A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-c B))
+ (FLOAT* (tfo-h A) (tfo-f B))
+ (FLOAT* (tfo-i A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-a B))
+ (FLOAT* (tfo-ty A) (tfo-d B))
+ (FLOAT* (tfo-tz A) (tfo-g B))
+ (tfo-tx B))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-b B))
+ (FLOAT* (tfo-ty A) (tfo-e B))
+ (FLOAT* (tfo-tz A) (tfo-h B))
+ (tfo-ty B))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-c B))
+ (FLOAT* (tfo-ty A) (tfo-f B))
+ (FLOAT* (tfo-tz A) (tfo-i B))
+ (tfo-tz B))))
+
+; The function "tfo-inv-ortho" computes the inverse of a homogeneous
+; transformation matrix.
+
+(define (tfo-inv-ortho tfo)
+ (let* ((tx (tfo-tx tfo))
+ (ty (tfo-ty tfo))
+ (tz (tfo-tz tfo)))
+ (make-tfo
+ (tfo-a tfo) (tfo-d tfo) (tfo-g tfo)
+ (tfo-b tfo) (tfo-e tfo) (tfo-h tfo)
+ (tfo-c tfo) (tfo-f tfo) (tfo-i tfo)
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-a tfo) tx)
+ (FLOAT* (tfo-b tfo) ty)
+ (FLOAT* (tfo-c tfo) tz)))
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-d tfo) tx)
+ (FLOAT* (tfo-e tfo) ty)
+ (FLOAT* (tfo-f tfo) tz)))
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-g tfo) tx)
+ (FLOAT* (tfo-h tfo) ty)
+ (FLOAT* (tfo-i tfo) tz))))))
+
+; Given three points p1, p2, and p3, the function "tfo-align" computes
+; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
+; mapped to the Y axis and p3 gets mapped to the YZ plane.
+
+(define (tfo-align p1 p2 p3)
+ (let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1))
+ (x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3))
+ (x31 (FLOAT- x3 x1)) (y31 (FLOAT- y3 y1)) (z31 (FLOAT- z3 z1))
+ (rotpY (pt-sub p2 p1))
+ (Phi (pt-phi rotpY))
+ (Theta (pt-theta rotpY))
+ (sinP (FLOATsin Phi))
+ (sinT (FLOATsin Theta))
+ (cosP (FLOATcos Phi))
+ (cosT (FLOATcos Theta))
+ (sinPsinT (FLOAT* sinP sinT))
+ (sinPcosT (FLOAT* sinP cosT))
+ (cosPsinT (FLOAT* cosP sinT))
+ (cosPcosT (FLOAT* cosP cosT))
+ (rotpZ
+ (make-pt
+ (FLOAT- (FLOAT* cosT x31)
+ (FLOAT* sinT z31))
+ (FLOAT+ (FLOAT* sinPsinT x31)
+ (FLOAT* cosP y31)
+ (FLOAT* sinPcosT z31))
+ (FLOAT+ (FLOAT* cosPsinT x31)
+ (FLOAT- (FLOAT* sinP y31))
+ (FLOAT* cosPcosT z31))))
+ (Rho (pt-theta rotpZ))
+ (cosR (FLOATcos Rho))
+ (sinR (FLOATsin Rho))
+ (x (FLOAT+ (FLOAT- (FLOAT* x1 cosT))
+ (FLOAT* z1 sinT)))
+ (y (FLOAT- (FLOAT- (FLOAT- (FLOAT* x1 sinPsinT))
+ (FLOAT* y1 cosP))
+ (FLOAT* z1 sinPcosT)))
+ (z (FLOAT- (FLOAT+ (FLOAT- (FLOAT* x1 cosPsinT))
+ (FLOAT* y1 sinP))
+ (FLOAT* z1 cosPcosT))))
+ (make-tfo
+ (FLOAT- (FLOAT* cosT cosR) (FLOAT* cosPsinT sinR))
+ sinPsinT
+ (FLOAT+ (FLOAT* cosT sinR) (FLOAT* cosPsinT cosR))
+ (FLOAT* sinP sinR)
+ cosP
+ (FLOAT- (FLOAT* sinP cosR))
+ (FLOAT- (FLOAT- (FLOAT* sinT cosR)) (FLOAT* cosPcosT sinR))
+ sinPcosT
+ (FLOAT+ (FLOAT- (FLOAT* sinT sinR)) (FLOAT* cosPcosT cosR))
+ (FLOAT- (FLOAT* x cosR) (FLOAT* z sinR))
+ y
+ (FLOAT+ (FLOAT* x sinR) (FLOAT* z cosR)))))
+
+; -- NUCLEIC ACID CONFORMATIONS DATA BASE -------------------------------------
+
+; Numbering of atoms follows the paper:
+;
+; IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN)
+; (1983) Abbreviations and Symbols for the Description of
+; Conformations of Polynucleotide Chains. Eur. J. Biochem 131,
+; 9-15.
+;
+; In the atom names, we have used "*" instead of "'".
+
+; Define part common to all 4 nucleotide types.
+
+(def-struct #f nuc
+ dgf-base-tfo ; defines the standard position for wc and wc-dumas
+ P-O3*-275-tfo ; defines the standard position for the connect function
+ P-O3*-180-tfo
+ P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2* H2** O2* H2* C3*
+ H3* O3* N1 N3 C2 C4 C5 C6)
+
+; Define remaining atoms for each nucleotide type.
+
+(def-nuc #t rA N6 N7 N9 C8 H2 H61 H62 H8)
+(def-nuc #t rC N4 O2 H41 H42 H5 H6)
+(def-nuc #t rG N2 N7 N9 C8 O6 H1 H21 H22 H8)
+(def-nuc #t rU O2 O4 H3 H5 H6)
+
+; Database of nucleotide conformations:
+
+(define rA
+ (make-constant-rA
+ #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo
+ 0.2679 -0.5509 -0.7904
+ 0.9634 0.1517 0.2209
+ 0.0073 8.4030 0.6232)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4550 8.2120 -2.8810) ; C5*
+ #( 5.4546 8.8508 -1.9978) ; H5*
+ #( 5.7588 8.6625 -3.8259) ; H5**
+ #( 6.4970 7.1480 -2.5980) ; C4*
+ #( 7.4896 7.5919 -2.5214) ; H4*
+ #( 6.1630 6.4860 -1.3440) ; O4*
+ #( 6.5400 5.1200 -1.4190) ; C1*
+ #( 7.2763 4.9681 -0.6297) ; H1*
+ #( 7.1940 4.8830 -2.7770) ; C2*
+ #( 6.8667 3.9183 -3.1647) ; H2**
+ #( 8.5860 5.0910 -2.6140) ; O2*
+ #( 8.9510 4.7626 -1.7890) ; H2*
+ #( 6.5720 6.0040 -3.6090) ; C3*
+ #( 5.5636 5.7066 -3.8966) ; H3*
+ #( 7.3801 6.3562 -4.7350) ; O3*
+ #( 4.7150 0.4910 -0.1360) ; N1
+ #( 6.3490 2.1730 -0.6020) ; N3
+ #( 5.9530 0.9650 -0.2670) ; C2
+ #( 5.2900 2.9790 -0.8260) ; C4
+ #( 3.9720 2.6390 -0.7330) ; C5
+ #( 3.6770 1.3160 -0.3660) ; C6
+ #( 2.4280 0.8450 -0.2360) ; N6
+ #( 3.1660 3.7290 -1.0360) ; N7
+ #( 5.3170 4.2990 -1.1930) ; N9
+ #( 4.0100 4.6780 -1.2990) ; C8
+ #( 6.6890 0.1903 -0.0518) ; H2
+ #( 1.6470 1.4460 -0.4040) ; H61
+ #( 2.2780 -0.1080 -0.0280) ; H62
+ #( 3.4421 5.5744 -1.5482) ; H8
+ ))
+
+(define rA01
+ (make-constant-rA
+ #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo
+ 0.2617 -0.5567 -0.7884
+ 0.9651 0.1473 0.2164
+ 0.0359 8.3929 0.5532)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 4.7442 0.4514 -0.1390) ; N1
+ #( 6.3687 2.1459 -0.5926) ; N3
+ #( 5.9795 0.9335 -0.2657) ; C2
+ #( 5.3052 2.9471 -0.8125) ; C4
+ #( 3.9891 2.5987 -0.7230) ; C5
+ #( 3.7016 1.2717 -0.3647) ; C6
+ #( 2.4553 0.7925 -0.2390) ; N6
+ #( 3.1770 3.6859 -1.0198) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.0156 4.6415 -1.2759) ; C8
+ #( 6.7198 0.1618 -0.0547) ; H2
+ #( 1.6709 1.3900 -0.4039) ; H61
+ #( 2.3107 -0.1627 -0.0373) ; H62
+ #( 3.4426 5.5361 -1.5199) ; H8
+ ))
+
+(define rA02
+ (make-constant-rA
+ #( 0.5566 0.0449 0.8296 ; dgf-base-tfo
+ 0.5125 0.7673 -0.3854
+ -0.6538 0.6397 0.4041
+ -9.1161 -3.7679 -2.9968)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.3245 8.5459 1.5467) ; N1
+ #( 9.8051 6.9432 -0.1497) ; N3
+ #( 10.5175 7.4328 0.8408) ; C2
+ #( 8.7523 7.7422 -0.4228) ; C4
+ #( 8.4257 8.9060 0.2099) ; C5
+ #( 9.2665 9.3242 1.2540) ; C6
+ #( 9.0664 10.4462 1.9610) ; N6
+ #( 7.2750 9.4537 -0.3428) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9479 8.6157 -1.2771) ; C8
+ #( 11.4063 6.9047 1.1859) ; H2
+ #( 8.2845 11.0341 1.7552) ; H61
+ #( 9.6584 10.6647 2.7198) ; H62
+ #( 6.0430 8.9853 -1.7594) ; H8
+ ))
+
+(define rA03
+ (make-constant-rA
+ #( -0.5021 0.0731 0.8617 ; dgf-base-tfo
+ -0.8112 0.3054 -0.4986
+ -0.2996 -0.9494 -0.0940
+ 6.4273 -5.1944 -3.7807)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 9.6740 4.7656 -7.6614) ; N1
+ #( 9.0739 4.3013 -5.3941) ; N3
+ #( 9.8416 4.2192 -6.4581) ; C2
+ #( 7.9885 5.0632 -5.6446) ; C4
+ #( 7.6822 5.6856 -6.8194) ; C5
+ #( 8.5831 5.5215 -7.8840) ; C6
+ #( 8.4084 6.0747 -9.0933) ; N6
+ #( 6.4857 6.3816 -6.7035) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 6.1133 6.1613 -5.4808) ; C8
+ #( 10.7627 3.6375 -6.4220) ; H2
+ #( 7.6031 6.6390 -9.2733) ; H61
+ #( 9.1004 5.9708 -9.7893) ; H62
+ #( 5.1705 6.6830 -5.3167) ; H8
+ ))
+
+(define rA04
+ (make-constant-rA
+ #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo
+ 0.8304 -0.5567 -0.0237
+ 0.1267 0.1473 0.9809
+ -0.5075 8.3929 0.2229)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 3.6343 2.6680 2.0783) ; N1
+ #( 5.4505 3.9805 1.2446) ; N3
+ #( 4.7540 3.3816 2.1851) ; C2
+ #( 4.8805 3.7951 0.0354) ; C4
+ #( 3.7416 3.0925 -0.2305) ; C5
+ #( 3.0873 2.4980 0.8606) ; C6
+ #( 1.9600 1.7805 0.7462) ; N6
+ #( 3.4605 3.1184 -1.5906) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.4244 3.8244 -2.0953) ; C8
+ #( 5.0814 3.4352 3.2234) ; H2
+ #( 1.5423 1.6454 -0.1520) ; H61
+ #( 1.5716 1.3398 1.5392) ; H62
+ #( 4.2675 3.8876 -3.1721) ; H8
+ ))
+
+(define rA05
+ (make-constant-rA
+ #( -0.5891 0.0449 0.8068 ; dgf-base-tfo
+ 0.5375 0.7673 0.3498
+ -0.6034 0.6397 -0.4762
+ -0.3019 -3.7679 -9.5913)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.2594 10.6774 -1.0056) ; N1
+ #( 9.7528 8.7080 -2.2631) ; N3
+ #( 10.4471 9.7876 -1.9791) ; C2
+ #( 8.7271 8.5575 -1.3991) ; C4
+ #( 8.4100 9.3803 -0.3580) ; C5
+ #( 9.2294 10.5030 -0.1574) ; C6
+ #( 9.0349 11.3951 0.8250) ; N6
+ #( 7.2891 8.9068 0.3121) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9702 7.8292 -0.3353) ; C8
+ #( 11.3132 10.0537 -2.5851) ; H2
+ #( 8.2741 11.2784 1.4629) ; H61
+ #( 9.6733 12.1368 0.9529) ; H62
+ #( 6.0888 7.3990 0.1403) ; H8
+ ))
+
+(define rA06
+ (make-constant-rA
+ #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo
+ 0.1912 0.3054 -0.9328
+ -0.0141 -0.9494 -0.3137
+ 5.7506 -5.1944 4.7470)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 6.6624 3.5061 -8.2986) ; N1
+ #( 6.5810 3.2570 -5.9221) ; N3
+ #( 6.5151 2.8263 -7.1625) ; C2
+ #( 6.8364 4.5817 -5.8882) ; C4
+ #( 7.0116 5.4064 -6.9609) ; C5
+ #( 6.9173 4.8260 -8.2361) ; C6
+ #( 7.0668 5.5163 -9.3763) ; N6
+ #( 7.2573 6.7070 -6.5394) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 7.2238 6.6275 -5.2453) ; C8
+ #( 6.3146 1.7741 -7.3641) ; H2
+ #( 7.2568 6.4972 -9.3456) ; H61
+ #( 7.0437 5.0478 -10.2446) ; H62
+ #( 7.4108 7.6227 -4.8418) ; H8
+ ))
+
+(define rA07
+ (make-constant-rA
+ #( 0.2379 0.1310 -0.9624 ; dgf-base-tfo
+ -0.5876 -0.7696 -0.2499
+ -0.7734 0.6249 -0.1061
+ 30.9870 -26.9344 42.6416)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.3505 8.4697 42.6565) ; C5*
+ #( 39.1377 7.5433 42.1230) ; H5*
+ #( 39.7203 9.3119 42.0717) ; H5**
+ #( 38.0405 8.9195 43.2869) ; C4*
+ #( 37.3687 9.3036 42.5193) ; H4*
+ #( 37.4319 7.8146 43.9387) ; O4*
+ #( 37.1959 8.1354 45.3237) ; C1*
+ #( 36.1788 8.5202 45.3970) ; H1*
+ #( 38.1721 9.2328 45.6504) ; C2*
+ #( 39.1555 8.7939 45.8188) ; H2**
+ #( 37.7862 10.0617 46.7013) ; O2*
+ #( 37.3087 9.6229 47.4092) ; H2*
+ #( 38.1844 10.0268 44.3367) ; C3*
+ #( 39.1578 10.5054 44.2289) ; H3*
+ #( 37.0547 10.9127 44.3441) ; O3*
+ #( 34.8811 4.2072 47.5784) ; N1
+ #( 35.1084 6.1336 46.1818) ; N3
+ #( 34.4108 5.1360 46.7207) ; C2
+ #( 36.3908 6.1224 46.6053) ; C4
+ #( 36.9819 5.2334 47.4697) ; C5
+ #( 36.1786 4.1985 48.0035) ; C6
+ #( 36.6103 3.2749 48.8452) ; N6
+ #( 38.3236 5.5522 47.6595) ; N7
+ #( 37.3887 7.0024 46.2437) ; N9
+ #( 38.5055 6.6096 46.9057) ; C8
+ #( 33.3553 5.0152 46.4771) ; H2
+ #( 37.5730 3.2804 49.1507) ; H61
+ #( 35.9775 2.5638 49.1828) ; H62
+ #( 39.5461 6.9184 47.0041) ; H8
+ ))
+
+(define rA08
+ (make-constant-rA
+ #( 0.1084 -0.0895 -0.9901 ; dgf-base-tfo
+ 0.9789 -0.1638 0.1220
+ -0.1731 -0.9824 0.0698
+ -2.9039 47.2655 33.0094)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.4850 8.9301 44.6977) ; C5*
+ #( 39.0638 9.8199 44.2296) ; H5*
+ #( 40.0757 9.0713 45.6029) ; H5**
+ #( 38.3102 8.0414 45.0789) ; C4*
+ #( 37.7842 8.4637 45.9351) ; H4*
+ #( 37.4200 7.9453 43.9769) ; O4*
+ #( 37.2249 6.5609 43.6273) ; C1*
+ #( 36.3360 6.2168 44.1561) ; H1*
+ #( 38.4347 5.8414 44.1590) ; C2*
+ #( 39.2688 5.9974 43.4749) ; H2**
+ #( 38.2344 4.4907 44.4348) ; O2*
+ #( 37.6374 4.0386 43.8341) ; H2*
+ #( 38.6926 6.6079 45.4637) ; C3*
+ #( 39.7585 6.5640 45.6877) ; H3*
+ #( 37.8238 6.0705 46.4723) ; O3*
+ #( 33.9162 6.2598 39.7758) ; N1
+ #( 34.6709 6.5759 42.0215) ; N3
+ #( 33.7257 6.5186 41.0858) ; C2
+ #( 35.8935 6.3324 41.5018) ; C4
+ #( 36.2105 6.0601 40.1932) ; C5
+ #( 35.1538 6.0151 39.2537) ; C6
+ #( 35.3088 5.7642 37.9649) ; N6
+ #( 37.5818 5.8677 40.0507) ; N7
+ #( 37.0932 6.3197 42.1810) ; N9
+ #( 38.0509 6.0354 41.2635) ; C8
+ #( 32.6830 6.6898 41.3532) ; H2
+ #( 36.2305 5.5855 37.5925) ; H61
+ #( 34.5056 5.7512 37.3528) ; H62
+ #( 39.1318 5.8993 41.2285) ; H8
+ ))
+
+(define rA09
+ (make-constant-rA
+ #( 0.8467 0.4166 -0.3311 ; dgf-base-tfo
+ -0.3962 0.9089 0.1303
+ 0.3552 0.0209 0.9346
+ -42.7319 -26.6223 -29.8163)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.3505 8.4697 42.6565) ; C5*
+ #( 39.1377 7.5433 42.1230) ; H5*
+ #( 39.7203 9.3119 42.0717) ; H5**
+ #( 38.0405 8.9195 43.2869) ; C4*
+ #( 37.6479 8.1347 43.9335) ; H4*
+ #( 38.2691 10.0933 44.0524) ; O4*
+ #( 37.3999 11.1488 43.5973) ; C1*
+ #( 36.5061 11.1221 44.2206) ; H1*
+ #( 37.0364 10.7838 42.1836) ; C2*
+ #( 37.8636 11.0489 41.5252) ; H2**
+ #( 35.8275 11.3133 41.7379) ; O2*
+ #( 35.6214 12.1896 42.0714) ; H2*
+ #( 36.9316 9.2556 42.2837) ; C3*
+ #( 37.1778 8.8260 41.3127) ; H3*
+ #( 35.6285 8.9334 42.7926) ; O3*
+ #( 38.1482 15.2833 46.4641) ; N1
+ #( 37.3641 13.0968 45.9007) ; N3
+ #( 37.5032 14.1288 46.7300) ; C2
+ #( 37.9570 13.3377 44.7113) ; C4
+ #( 38.6397 14.4660 44.3267) ; C5
+ #( 38.7473 15.5229 45.2609) ; C6
+ #( 39.3720 16.6649 45.0297) ; N6
+ #( 39.1079 14.3351 43.0223) ; N7
+ #( 38.0132 12.4868 43.6280) ; N9
+ #( 38.7058 13.1402 42.6620) ; C8
+ #( 37.0731 14.0857 47.7306) ; H2
+ #( 39.8113 16.8281 44.1350) ; H61
+ #( 39.4100 17.3741 45.7478) ; H62
+ #( 39.0412 12.9660 41.6397) ; H8
+ ))
+
+(define rA10
+ (make-constant-rA
+ #( 0.7063 0.6317 -0.3196 ; dgf-base-tfo
+ -0.0403 -0.4149 -0.9090
+ -0.7068 0.6549 -0.2676
+ 6.4402 -52.1496 30.8246)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.4850 8.9301 44.6977) ; C5*
+ #( 39.0638 9.8199 44.2296) ; H5*
+ #( 40.0757 9.0713 45.6029) ; H5**
+ #( 38.3102 8.0414 45.0789) ; C4*
+ #( 37.7099 7.8166 44.1973) ; H4*
+ #( 38.8012 6.8321 45.6380) ; O4*
+ #( 38.2431 6.6413 46.9529) ; C1*
+ #( 37.3505 6.0262 46.8385) ; H1*
+ #( 37.8484 8.0156 47.4214) ; C2*
+ #( 38.7381 8.5406 47.7690) ; H2**
+ #( 36.8286 8.0368 48.3701) ; O2*
+ #( 36.8392 7.3063 48.9929) ; H2*
+ #( 37.3576 8.6512 46.1132) ; C3*
+ #( 37.5207 9.7275 46.1671) ; H3*
+ #( 35.9985 8.2392 45.9032) ; O3*
+ #( 39.9117 2.2278 48.8527) ; N1
+ #( 38.6207 3.6941 47.4757) ; N3
+ #( 38.9872 2.4888 47.9057) ; C2
+ #( 39.2961 4.6720 48.1174) ; C4
+ #( 40.2546 4.5307 49.0912) ; C5
+ #( 40.5932 3.2189 49.4985) ; C6
+ #( 41.4938 2.9317 50.4229) ; N6
+ #( 40.7195 5.7755 49.5060) ; N7
+ #( 39.1730 6.0305 47.9170) ; N9
+ #( 40.0413 6.6250 48.7728) ; C8
+ #( 38.5257 1.5960 47.4838) ; H2
+ #( 41.9907 3.6753 50.8921) ; H61
+ #( 41.6848 1.9687 50.6599) ; H62
+ #( 40.3571 7.6321 49.0452) ; H8
+ ))
+
+(define rAs
+ (list rA01 rA02 rA03 rA04 rA05 rA06 rA07 rA08 rA09 rA10))
+
+(define rC
+ (make-constant-rC
+ #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo
+ -0.2669 0.5761 0.7726
+ -0.9631 -0.1296 -0.2361
+ 0.1584 8.3434 0.5434)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 7.2954 -7.6762 2.4898) ; H4*
+ #( 6.0140 -6.5420 1.2890) ; O4*
+ #( 6.4190 -5.1840 1.3620) ; C1*
+ #( 7.1608 -5.0495 0.5747) ; H1*
+ #( 7.0760 -4.9560 2.7270) ; C2*
+ #( 6.7770 -3.9803 3.1099) ; H2**
+ #( 8.4500 -5.1930 2.5810) ; O2*
+ #( 8.8309 -4.8755 1.7590) ; H2*
+ #( 6.4060 -6.0590 3.5580) ; C3*
+ #( 5.4021 -5.7313 3.8281) ; H3*
+ #( 7.1570 -6.4240 4.7070) ; O3*
+ #( 5.2170 -4.3260 1.1690) ; N1
+ #( 4.2960 -2.2560 0.6290) ; N3
+ #( 5.4330 -3.0200 0.7990) ; C2
+ #( 2.9930 -2.6780 0.7940) ; C4
+ #( 2.8670 -4.0630 1.1830) ; C5
+ #( 3.9570 -4.8300 1.3550) ; C6
+ #( 2.0187 -1.8047 0.5874) ; N4
+ #( 6.5470 -2.5560 0.6290) ; O2
+ #( 1.0684 -2.1236 0.7109) ; H41
+ #( 2.2344 -0.8560 0.3162) ; H42
+ #( 1.8797 -4.4972 1.3404) ; H5
+ #( 3.8479 -5.8742 1.6480) ; H6
+ ))
+
+(define rC01
+ (make-constant-rC
+ #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo
+ -0.2523 0.5817 0.7733
+ -0.9675 -0.1404 -0.2101
+ 0.2031 8.3874 0.4228)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 4.3777 -2.2062 0.7229) ; N3
+ #( 5.5069 -2.9779 0.9088) ; C2
+ #( 3.0693 -2.6246 0.8500) ; C4
+ #( 2.9279 -4.0146 1.2149) ; C5
+ #( 4.0101 -4.7892 1.4017) ; C6
+ #( 2.1040 -1.7437 0.6331) ; N4
+ #( 6.6267 -2.5166 0.7728) ; O2
+ #( 1.1496 -2.0600 0.7287) ; H41
+ #( 2.3303 -0.7921 0.3815) ; H42
+ #( 1.9353 -4.4465 1.3419) ; H5
+ #( 3.8895 -5.8371 1.6762) ; H6
+ ))
+
+(define rC02
+ (make-constant-rC
+ #( 0.5141 0.0246 0.8574 ; dgf-base-tfo
+ -0.5547 -0.7529 0.3542
+ 0.6542 -0.6577 -0.3734
+ -9.1111 -3.4598 -3.2939)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.6945 -8.7046 -0.2857) ; N3
+ #( 8.6943 -7.6514 0.6066) ; C2
+ #( 7.7426 -9.6987 -0.3801) ; C4
+ #( 6.6642 -9.5742 0.5722) ; C5
+ #( 6.6391 -8.5592 1.4526) ; C6
+ #( 7.9033 -10.6371 -1.3010) ; N4
+ #( 9.5840 -6.8186 0.6136) ; O2
+ #( 7.2009 -11.3604 -1.3619) ; H41
+ #( 8.7058 -10.6168 -1.9140) ; H42
+ #( 5.8585 -10.3083 0.5822) ; H5
+ #( 5.8197 -8.4773 2.1667) ; H6
+ ))
+
+(define rC03
+ (make-constant-rC
+ #( -0.4993 0.0476 0.8651 ; dgf-base-tfo
+ 0.8078 -0.3353 0.4847
+ 0.3132 0.9409 0.1290
+ 6.2989 -5.2303 -3.8577)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 7.9218 -5.5700 6.8877) ; N3
+ #( 7.8908 -5.0886 5.5944) ; C2
+ #( 6.9789 -6.3827 7.4823) ; C4
+ #( 5.8742 -6.7319 6.6202) ; C5
+ #( 5.8182 -6.2769 5.3570) ; C6
+ #( 7.1702 -6.7511 8.7402) ; N4
+ #( 8.7747 -4.3728 5.1568) ; O2
+ #( 6.4741 -7.3461 9.1662) ; H41
+ #( 7.9889 -6.4396 9.2429) ; H42
+ #( 5.0736 -7.3713 6.9922) ; H5
+ #( 4.9784 -6.5473 4.7170) ; H6
+ ))
+
+(define rC04
+ (make-constant-rC
+ #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo
+ -0.8129 0.5817 0.0273
+ -0.1334 -0.1404 -0.9811
+ -0.3279 8.3874 0.3355)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 3.8961 -3.0896 -0.1893) ; N3
+ #( 5.0095 -3.8907 -0.0346) ; C2
+ #( 3.0480 -2.6632 0.8116) ; C4
+ #( 3.4093 -3.1310 2.1292) ; C5
+ #( 4.4878 -3.9124 2.3088) ; C6
+ #( 2.0216 -1.8941 0.4804) ; N4
+ #( 5.7005 -4.2164 -0.9842) ; O2
+ #( 1.4067 -1.5873 1.2205) ; H41
+ #( 1.8721 -1.6319 -0.4835) ; H42
+ #( 2.8048 -2.8507 2.9918) ; H5
+ #( 4.7491 -4.2593 3.3085) ; H6
+ ))
+
+(define rC05
+ (make-constant-rC
+ #( -0.6298 0.0246 0.7763 ; dgf-base-tfo
+ -0.5226 -0.7529 -0.4001
+ 0.5746 -0.6577 0.4870
+ -0.0208 -3.4598 -9.6882)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.5977 -9.5977 0.7329) ; N3
+ #( 8.5951 -8.5745 1.6594) ; C2
+ #( 7.7372 -9.7371 -0.3364) ; C4
+ #( 6.7596 -8.6801 -0.4476) ; C5
+ #( 6.7338 -7.6721 0.4408) ; C6
+ #( 7.8849 -10.7881 -1.1289) ; N4
+ #( 9.3993 -8.5377 2.5743) ; O2
+ #( 7.2499 -10.8809 -1.9088) ; H41
+ #( 8.6122 -11.4649 -0.9468) ; H42
+ #( 6.0317 -8.6941 -1.2588) ; H5
+ #( 5.9901 -6.8809 0.3459) ; H6
+ ))
+
+(define rC06
+ (make-constant-rC
+ #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo
+ -0.1792 -0.3353 0.9249
+ -0.0141 0.9409 0.3384
+ 5.7793 -5.2303 4.5997)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 6.6920 -5.0495 7.1354) ; N3
+ #( 6.6201 -4.5500 5.8506) ; C2
+ #( 6.9254 -6.3614 7.4926) ; C4
+ #( 7.1046 -7.2543 6.3718) ; C5
+ #( 7.0391 -6.7951 5.1106) ; C6
+ #( 6.9614 -6.6648 8.7815) ; N4
+ #( 6.4083 -3.3696 5.6340) ; O2
+ #( 7.1329 -7.6280 9.0324) ; H41
+ #( 6.8204 -5.9469 9.4777) ; H42
+ #( 7.2954 -8.3135 6.5440) ; H5
+ #( 7.1753 -7.4798 4.2735) ; H6
+ ))
+
+(define rC07
+ (make-constant-rC
+ #( 0.0033 0.2720 -0.9623 ; dgf-base-tfo
+ 0.3013 -0.9179 -0.2584
+ -0.9535 -0.2891 -0.0850
+ 43.0403 13.7233 34.5710)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 30.8152 11.1619 46.2003) ; C5*
+ #( 30.4519 10.9454 45.1957) ; H5*
+ #( 31.0379 12.2016 46.4400) ; H5**
+ #( 29.7081 10.7448 47.1428) ; C4*
+ #( 28.8710 11.4416 47.0982) ; H4*
+ #( 29.2550 9.4394 46.8162) ; O4*
+ #( 29.3907 8.5625 47.9460) ; C1*
+ #( 28.4416 8.5669 48.4819) ; H1*
+ #( 30.4468 9.2031 48.7952) ; C2*
+ #( 31.4222 8.9651 48.3709) ; H2**
+ #( 30.3701 8.9157 50.1624) ; O2*
+ #( 30.0652 8.0304 50.3740) ; H2*
+ #( 30.1622 10.6879 48.6120) ; C3*
+ #( 31.0952 11.2399 48.7254) ; H3*
+ #( 29.1076 11.1535 49.4702) ; O3*
+ #( 29.7883 7.2209 47.5235) ; N1
+ #( 29.1825 5.0438 46.8275) ; N3
+ #( 28.8008 6.2912 47.2263) ; C2
+ #( 30.4888 4.6890 46.7186) ; C4
+ #( 31.5034 5.6405 47.0249) ; C5
+ #( 31.1091 6.8691 47.4156) ; C6
+ #( 30.8109 3.4584 46.3336) ; N4
+ #( 27.6171 6.5989 47.3189) ; O2
+ #( 31.7923 3.2301 46.2638) ; H41
+ #( 30.0880 2.7857 46.1215) ; H42
+ #( 32.5542 5.3634 46.9395) ; H5
+ #( 31.8523 7.6279 47.6603) ; H6
+ ))
+
+(define rC08
+ (make-constant-rC
+ #( 0.0797 -0.6026 -0.7941 ; dgf-base-tfo
+ 0.7939 0.5201 -0.3150
+ 0.6028 -0.6054 0.5198
+ -36.8341 41.5293 1.6628)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 31.8779 9.9369 47.8760) ; C5*
+ #( 31.3239 10.6931 48.4322) ; H5*
+ #( 32.8647 9.6624 48.2489) ; H5**
+ #( 31.0429 8.6773 47.9401) ; C4*
+ #( 31.0779 8.2331 48.9349) ; H4*
+ #( 29.6956 8.9669 47.5983) ; O4*
+ #( 29.2784 8.1700 46.4782) ; C1*
+ #( 28.8006 7.2731 46.8722) ; H1*
+ #( 30.5544 7.7940 45.7875) ; C2*
+ #( 30.8837 8.6410 45.1856) ; H2**
+ #( 30.5100 6.6007 45.0582) ; O2*
+ #( 29.6694 6.4168 44.6326) ; H2*
+ #( 31.5146 7.5954 46.9527) ; C3*
+ #( 32.5255 7.8261 46.6166) ; H3*
+ #( 31.3876 6.2951 47.5516) ; O3*
+ #( 28.3976 8.9302 45.5933) ; N1
+ #( 26.2155 9.6135 44.9910) ; N3
+ #( 27.0281 8.8961 45.8192) ; C2
+ #( 26.7044 10.3489 43.9595) ; C4
+ #( 28.1088 10.3837 43.7247) ; C5
+ #( 28.8978 9.6708 44.5535) ; C6
+ #( 25.8715 11.0249 43.1749) ; N4
+ #( 26.5733 8.2371 46.7484) ; O2
+ #( 26.2707 11.5609 42.4177) ; H41
+ #( 24.8760 10.9939 43.3427) ; H42
+ #( 28.5089 10.9722 42.8990) ; H5
+ #( 29.9782 9.6687 44.4097) ; H6
+ ))
+
+(define rC09
+ (make-constant-rC
+ #( 0.8727 0.4760 -0.1091 ; dgf-base-tfo
+ -0.4188 0.6148 -0.6682
+ -0.2510 0.6289 0.7359
+ -8.1687 -52.0761 -25.0726)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 30.8152 11.1619 46.2003) ; C5*
+ #( 30.4519 10.9454 45.1957) ; H5*
+ #( 31.0379 12.2016 46.4400) ; H5**
+ #( 29.7081 10.7448 47.1428) ; C4*
+ #( 29.4506 9.6945 47.0059) ; H4*
+ #( 30.1045 10.9634 48.4885) ; O4*
+ #( 29.1794 11.8418 49.1490) ; C1*
+ #( 28.4388 11.2210 49.6533) ; H1*
+ #( 28.5211 12.6008 48.0367) ; C2*
+ #( 29.1947 13.3949 47.7147) ; H2**
+ #( 27.2316 13.0683 48.3134) ; O2*
+ #( 27.0851 13.3391 49.2227) ; H2*
+ #( 28.4131 11.5507 46.9391) ; C3*
+ #( 28.4451 12.0512 45.9713) ; H3*
+ #( 27.2707 10.6955 47.1097) ; O3*
+ #( 29.8751 12.7405 50.0682) ; N1
+ #( 30.7172 13.1841 52.2328) ; N3
+ #( 30.0617 12.3404 51.3847) ; C2
+ #( 31.1834 14.3941 51.8297) ; C4
+ #( 30.9913 14.8074 50.4803) ; C5
+ #( 30.3434 13.9610 49.6548) ; C6
+ #( 31.8090 15.1847 52.6957) ; N4
+ #( 29.6470 11.2494 51.7616) ; O2
+ #( 32.1422 16.0774 52.3606) ; H41
+ #( 31.9392 14.8893 53.6527) ; H42
+ #( 31.3632 15.7771 50.1491) ; H5
+ #( 30.1742 14.2374 48.6141) ; H6
+ ))
+
+(define rC10
+ (make-constant-rC
+ #( 0.1549 0.8710 -0.4663 ; dgf-base-tfo
+ 0.6768 -0.4374 -0.5921
+ -0.7197 -0.2239 -0.6572
+ 25.2447 -14.1920 50.3201)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 31.8779 9.9369 47.8760) ; C5*
+ #( 31.3239 10.6931 48.4322) ; H5*
+ #( 32.8647 9.6624 48.2489) ; H5**
+ #( 31.0429 8.6773 47.9401) ; C4*
+ #( 30.0440 8.8473 47.5383) ; H4*
+ #( 31.6749 7.6351 47.2119) ; O4*
+ #( 31.9159 6.5022 48.0616) ; C1*
+ #( 31.0691 5.8243 47.9544) ; H1*
+ #( 31.9300 7.0685 49.4493) ; C2*
+ #( 32.9024 7.5288 49.6245) ; H2**
+ #( 31.5672 6.1750 50.4632) ; O2*
+ #( 31.8416 5.2663 50.3200) ; H2*
+ #( 30.8618 8.1514 49.3749) ; C3*
+ #( 31.1122 8.9396 50.0850) ; H3*
+ #( 29.5351 7.6245 49.5409) ; O3*
+ #( 33.1890 5.8629 47.7343) ; N1
+ #( 34.4004 4.2636 46.4828) ; N3
+ #( 33.2062 4.8497 46.7851) ; C2
+ #( 35.5600 4.6374 47.0822) ; C4
+ #( 35.5444 5.6751 48.0577) ; C5
+ #( 34.3565 6.2450 48.3432) ; C6
+ #( 36.6977 4.0305 46.7598) ; N4
+ #( 32.1661 4.5034 46.2348) ; O2
+ #( 37.5405 4.3347 47.2259) ; H41
+ #( 36.7033 3.2923 46.0706) ; H42
+ #( 36.4713 5.9811 48.5428) ; H5
+ #( 34.2986 7.0426 49.0839) ; H6
+ ))
+
+(define rCs
+ (list rC01 rC02 rC03 rC04 rC05 rC06 rC07 rC08 rC09 rC10))
+
+(define rG
+ (make-constant-rG
+ #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo
+ 0.2679 -0.5509 -0.7904
+ 0.9634 0.1517 0.2209
+ 0.0073 8.4030 0.6232)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4550 8.2120 -2.8810) ; C5*
+ #( 5.4546 8.8508 -1.9978) ; H5*
+ #( 5.7588 8.6625 -3.8259) ; H5**
+ #( 6.4970 7.1480 -2.5980) ; C4*
+ #( 7.4896 7.5919 -2.5214) ; H4*
+ #( 6.1630 6.4860 -1.3440) ; O4*
+ #( 6.5400 5.1200 -1.4190) ; C1*
+ #( 7.2763 4.9681 -0.6297) ; H1*
+ #( 7.1940 4.8830 -2.7770) ; C2*
+ #( 6.8667 3.9183 -3.1647) ; H2**
+ #( 8.5860 5.0910 -2.6140) ; O2*
+ #( 8.9510 4.7626 -1.7890) ; H2*
+ #( 6.5720 6.0040 -3.6090) ; C3*
+ #( 5.5636 5.7066 -3.8966) ; H3*
+ #( 7.3801 6.3562 -4.7350) ; O3*
+ #( 4.7150 0.4910 -0.1360) ; N1
+ #( 6.3490 2.1730 -0.6020) ; N3
+ #( 5.9530 0.9650 -0.2670) ; C2
+ #( 5.2900 2.9790 -0.8260) ; C4
+ #( 3.9720 2.6390 -0.7330) ; C5
+ #( 3.6770 1.3160 -0.3660) ; C6
+ #( 6.8426 0.0056 -0.0019) ; N2
+ #( 3.1660 3.7290 -1.0360) ; N7
+ #( 5.3170 4.2990 -1.1930) ; N9
+ #( 4.0100 4.6780 -1.2990) ; C8
+ #( 2.4280 0.8450 -0.2360) ; O6
+ #( 4.6151 -0.4677 0.1305) ; H1
+ #( 6.6463 -0.9463 0.2729) ; H21
+ #( 7.8170 0.2642 -0.0640) ; H22
+ #( 3.4421 5.5744 -1.5482) ; H8
+ ))
+
+(define rG01
+ (make-constant-rG
+ #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo
+ 0.2617 -0.5567 -0.7884
+ 0.9651 0.1473 0.2164
+ 0.0359 8.3929 0.5532)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 4.7442 0.4514 -0.1390) ; N1
+ #( 6.3687 2.1459 -0.5926) ; N3
+ #( 5.9795 0.9335 -0.2657) ; C2
+ #( 5.3052 2.9471 -0.8125) ; C4
+ #( 3.9891 2.5987 -0.7230) ; C5
+ #( 3.7016 1.2717 -0.3647) ; C6
+ #( 6.8745 -0.0224 -0.0058) ; N2
+ #( 3.1770 3.6859 -1.0198) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.0156 4.6415 -1.2759) ; C8
+ #( 2.4553 0.7925 -0.2390) ; O6
+ #( 4.6497 -0.5095 0.1212) ; H1
+ #( 6.6836 -0.9771 0.2627) ; H21
+ #( 7.8474 0.2424 -0.0653) ; H22
+ #( 3.4426 5.5361 -1.5199) ; H8
+ ))
+
+(define rG02
+ (make-constant-rG
+ #( 0.5566 0.0449 0.8296 ; dgf-base-tfo
+ 0.5125 0.7673 -0.3854
+ -0.6538 0.6397 0.4041
+ -9.1161 -3.7679 -2.9968)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.3245 8.5459 1.5467) ; N1
+ #( 9.8051 6.9432 -0.1497) ; N3
+ #( 10.5175 7.4328 0.8408) ; C2
+ #( 8.7523 7.7422 -0.4228) ; C4
+ #( 8.4257 8.9060 0.2099) ; C5
+ #( 9.2665 9.3242 1.2540) ; C6
+ #( 11.6077 6.7966 1.2752) ; N2
+ #( 7.2750 9.4537 -0.3428) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9479 8.6157 -1.2771) ; C8
+ #( 9.0664 10.4462 1.9610) ; O6
+ #( 10.9838 8.7524 2.2697) ; H1
+ #( 12.2274 7.0896 2.0170) ; H21
+ #( 11.8502 5.9398 0.7984) ; H22
+ #( 6.0430 8.9853 -1.7594) ; H8
+ ))
+
+(define rG03
+ (make-constant-rG
+ #( -0.5021 0.0731 0.8617 ; dgf-base-tfo
+ -0.8112 0.3054 -0.4986
+ -0.2996 -0.9494 -0.0940
+ 6.4273 -5.1944 -3.7807)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 9.6740 4.7656 -7.6614) ; N1
+ #( 9.0739 4.3013 -5.3941) ; N3
+ #( 9.8416 4.2192 -6.4581) ; C2
+ #( 7.9885 5.0632 -5.6446) ; C4
+ #( 7.6822 5.6856 -6.8194) ; C5
+ #( 8.5831 5.5215 -7.8840) ; C6
+ #( 10.9733 3.5117 -6.4286) ; N2
+ #( 6.4857 6.3816 -6.7035) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 6.1133 6.1613 -5.4808) ; C8
+ #( 8.4084 6.0747 -9.0933) ; O6
+ #( 10.3759 4.5855 -8.3504) ; H1
+ #( 11.6254 3.3761 -7.1879) ; H21
+ #( 11.1917 3.0460 -5.5593) ; H22
+ #( 5.1705 6.6830 -5.3167) ; H8
+ ))
+
+(define rG04
+ (make-constant-rG
+ #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo
+ 0.8304 -0.5567 -0.0237
+ 0.1267 0.1473 0.9809
+ -0.5075 8.3929 0.2229)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 3.6343 2.6680 2.0783) ; N1
+ #( 5.4505 3.9805 1.2446) ; N3
+ #( 4.7540 3.3816 2.1851) ; C2
+ #( 4.8805 3.7951 0.0354) ; C4
+ #( 3.7416 3.0925 -0.2305) ; C5
+ #( 3.0873 2.4980 0.8606) ; C6
+ #( 5.1433 3.4373 3.4609) ; N2
+ #( 3.4605 3.1184 -1.5906) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.4244 3.8244 -2.0953) ; C8
+ #( 1.9600 1.7805 0.7462) ; O6
+ #( 3.2489 2.2879 2.9191) ; H1
+ #( 4.6785 3.0243 4.2568) ; H21
+ #( 5.9823 3.9654 3.6539) ; H22
+ #( 4.2675 3.8876 -3.1721) ; H8
+ ))
+
+(define rG05
+ (make-constant-rG
+ #( -0.5891 0.0449 0.8068 ; dgf-base-tfo
+ 0.5375 0.7673 0.3498
+ -0.6034 0.6397 -0.4762
+ -0.3019 -3.7679 -9.5913)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.2594 10.6774 -1.0056) ; N1
+ #( 9.7528 8.7080 -2.2631) ; N3
+ #( 10.4471 9.7876 -1.9791) ; C2
+ #( 8.7271 8.5575 -1.3991) ; C4
+ #( 8.4100 9.3803 -0.3580) ; C5
+ #( 9.2294 10.5030 -0.1574) ; C6
+ #( 11.5110 10.1256 -2.7114) ; N2
+ #( 7.2891 8.9068 0.3121) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9702 7.8292 -0.3353) ; C8
+ #( 9.0349 11.3951 0.8250) ; O6
+ #( 10.9013 11.4422 -0.9512) ; H1
+ #( 12.1031 10.9341 -2.5861) ; H21
+ #( 11.7369 9.5180 -3.4859) ; H22
+ #( 6.0888 7.3990 0.1403) ; H8
+ ))
+
+(define rG06
+ (make-constant-rG
+ #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo
+ 0.1912 0.3054 -0.9328
+ -0.0141 -0.9494 -0.3137
+ 5.7506 -5.1944 4.7470)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 6.6624 3.5061 -8.2986) ; N1
+ #( 6.5810 3.2570 -5.9221) ; N3
+ #( 6.5151 2.8263 -7.1625) ; C2
+ #( 6.8364 4.5817 -5.8882) ; C4
+ #( 7.0116 5.4064 -6.9609) ; C5
+ #( 6.9173 4.8260 -8.2361) ; C6
+ #( 6.2717 1.5402 -7.4250) ; N2
+ #( 7.2573 6.7070 -6.5394) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 7.2238 6.6275 -5.2453) ; C8
+ #( 7.0668 5.5163 -9.3763) ; O6
+ #( 6.5754 2.9964 -9.1545) ; H1
+ #( 6.1908 1.1105 -8.3354) ; H21
+ #( 6.1346 0.9352 -6.6280) ; H22
+ #( 7.4108 7.6227 -4.8418) ; H8
+ ))
+
+(define rG07
+ (make-constant-rG
+ #( 0.0894 -0.6059 0.7905 ; dgf-base-tfo
+ -0.6810 0.5420 0.4924
+ -0.7268 -0.5824 -0.3642
+ 34.1424 45.9610 -11.8600)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 33.8709 0.7918 47.2113) ; C5*
+ #( 34.1386 0.5870 46.1747) ; H5*
+ #( 34.0186 -0.0095 47.9353) ; H5**
+ #( 34.7297 1.9687 47.6685) ; C4*
+ #( 35.7723 1.6845 47.8113) ; H4*
+ #( 34.6455 2.9768 46.6660) ; O4*
+ #( 34.1690 4.1829 47.2627) ; C1*
+ #( 35.0437 4.7633 47.5560) ; H1*
+ #( 33.4145 3.7532 48.4954) ; C2*
+ #( 32.4340 3.3797 48.2001) ; H2**
+ #( 33.3209 4.6953 49.5217) ; O2*
+ #( 33.2374 5.6059 49.2295) ; H2*
+ #( 34.2724 2.5970 48.9773) ; C3*
+ #( 33.6373 1.8935 49.5157) ; H3*
+ #( 35.3453 3.1884 49.7285) ; O3*
+ #( 34.0511 7.8930 43.7791) ; N1
+ #( 34.9937 6.3369 45.3199) ; N3
+ #( 35.0882 7.3126 44.4200) ; C2
+ #( 33.7190 5.9650 45.5374) ; C4
+ #( 32.5845 6.4770 44.9458) ; C5
+ #( 32.7430 7.5179 43.9914) ; C6
+ #( 36.3030 7.7827 44.1036) ; N2
+ #( 31.4499 5.8335 45.4368) ; N7
+ #( 33.2760 4.9817 46.4043) ; N9
+ #( 31.9235 4.9639 46.2934) ; C8
+ #( 31.8602 8.1000 43.3695) ; O6
+ #( 34.2623 8.6223 43.1283) ; H1
+ #( 36.5188 8.5081 43.4347) ; H21
+ #( 37.0888 7.3524 44.5699) ; H22
+ #( 31.0815 4.4201 46.7218) ; H8
+ ))
+
+(define rG08
+ (make-constant-rG
+ #( 0.2224 0.6335 0.7411 ; dgf-base-tfo
+ -0.3644 -0.6510 0.6659
+ 0.9043 -0.4181 0.0861
+ -47.6824 -0.5823 -31.7554)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.5924 2.3488 48.2255) ; C5*
+ #( 33.3674 2.1246 48.9584) ; H5*
+ #( 31.5994 2.5917 48.6037) ; H5**
+ #( 33.0722 3.5577 47.4258) ; C4*
+ #( 33.0310 4.4778 48.0089) ; H4*
+ #( 34.4173 3.3055 47.0316) ; O4*
+ #( 34.5056 3.3910 45.6094) ; C1*
+ #( 34.7881 4.4152 45.3663) ; H1*
+ #( 33.1122 3.1198 45.1010) ; C2*
+ #( 32.9230 2.0469 45.1369) ; H2**
+ #( 32.7946 3.6590 43.8529) ; O2*
+ #( 33.5170 3.6707 43.2207) ; H2*
+ #( 32.2730 3.8173 46.1566) ; C3*
+ #( 31.3094 3.3123 46.2244) ; H3*
+ #( 32.2391 5.2039 45.7807) ; O3*
+ #( 39.3337 2.7157 44.1441) ; N1
+ #( 37.4430 3.8242 45.0824) ; N3
+ #( 38.7276 3.7646 44.7403) ; C2
+ #( 36.7791 2.6963 44.7704) ; C4
+ #( 37.2860 1.5653 44.1678) ; C5
+ #( 38.6647 1.5552 43.8235) ; C6
+ #( 39.5123 4.8216 44.9936) ; N2
+ #( 36.2829 0.6110 44.0078) ; N7
+ #( 35.4394 2.4314 44.9931) ; N9
+ #( 35.2180 1.1815 44.5128) ; C8
+ #( 39.2907 0.6514 43.2796) ; O6
+ #( 40.3076 2.8048 43.9352) ; H1
+ #( 40.4994 4.9066 44.7977) ; H21
+ #( 39.0738 5.6108 45.4464) ; H22
+ #( 34.3856 0.4842 44.4185) ; H8
+ ))
+
+(define rG09
+ (make-constant-rG
+ #( -0.9699 -0.1688 -0.1753 ; dgf-base-tfo
+ -0.1050 -0.3598 0.9271
+ -0.2196 0.9176 0.3312
+ 45.6217 -38.9484 -12.3208)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 33.8709 0.7918 47.2113) ; C5*
+ #( 34.1386 0.5870 46.1747) ; H5*
+ #( 34.0186 -0.0095 47.9353) ; H5**
+ #( 34.7297 1.9687 47.6685) ; C4*
+ #( 34.5880 2.8482 47.0404) ; H4*
+ #( 34.3575 2.2770 49.0081) ; O4*
+ #( 35.5157 2.1993 49.8389) ; C1*
+ #( 35.9424 3.2010 49.8893) ; H1*
+ #( 36.4701 1.2820 49.1169) ; C2*
+ #( 36.1545 0.2498 49.2683) ; H2**
+ #( 37.8262 1.4547 49.4008) ; O2*
+ #( 38.0227 1.6945 50.3094) ; H2*
+ #( 36.2242 1.6797 47.6725) ; C3*
+ #( 36.4297 0.8197 47.0351) ; H3*
+ #( 37.0289 2.8480 47.4426) ; O3*
+ #( 34.3005 3.5042 54.6070) ; N1
+ #( 34.7693 3.7936 52.2874) ; N3
+ #( 34.4484 4.2541 53.4939) ; C2
+ #( 34.9354 2.4584 52.2785) ; C4
+ #( 34.8092 1.5915 53.3422) ; C5
+ #( 34.4646 2.1367 54.6085) ; C6
+ #( 34.2514 5.5708 53.6503) ; N2
+ #( 35.0641 0.2835 52.9337) ; N7
+ #( 35.2669 1.6690 51.1915) ; N9
+ #( 35.3288 0.3954 51.6563) ; C8
+ #( 34.3151 1.5317 55.6650) ; O6
+ #( 34.0623 3.9797 55.4539) ; H1
+ #( 33.9950 6.0502 54.5016) ; H21
+ #( 34.3512 6.1432 52.8242) ; H22
+ #( 35.5414 -0.6006 51.2679) ; H8
+ ))
+
+(define rG10
+ (make-constant-rG
+ #( -0.0980 -0.9723 0.2122 ; dgf-base-tfo
+ -0.9731 0.1383 0.1841
+ -0.2083 -0.1885 -0.9597
+ 17.8469 38.8265 37.0475)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.5924 2.3488 48.2255) ; C5*
+ #( 33.3674 2.1246 48.9584) ; H5*
+ #( 31.5994 2.5917 48.6037) ; H5**
+ #( 33.0722 3.5577 47.4258) ; C4*
+ #( 34.0333 3.3761 46.9447) ; H4*
+ #( 32.0890 3.8338 46.4332) ; O4*
+ #( 31.6377 5.1787 46.5914) ; C1*
+ #( 32.2499 5.8016 45.9392) ; H1*
+ #( 31.9167 5.5319 48.0305) ; C2*
+ #( 31.1507 5.0820 48.6621) ; H2**
+ #( 32.0865 6.8890 48.3114) ; O2*
+ #( 31.5363 7.4819 47.7942) ; H2*
+ #( 33.2398 4.8224 48.2563) ; C3*
+ #( 33.3166 4.5570 49.3108) ; H3*
+ #( 34.2528 5.7056 47.7476) ; O3*
+ #( 28.2782 6.3049 42.9364) ; N1
+ #( 30.4001 5.8547 43.9258) ; N3
+ #( 29.6195 6.1568 42.8913) ; C2
+ #( 29.7005 5.7006 45.0649) ; C4
+ #( 28.3383 5.8221 45.2343) ; C5
+ #( 27.5519 6.1461 44.0958) ; C6
+ #( 30.1838 6.3385 41.6890) ; N2
+ #( 27.9936 5.5926 46.5651) ; N7
+ #( 30.2046 5.3825 46.3136) ; N9
+ #( 29.1371 5.3398 47.1506) ; C8
+ #( 26.3361 6.3024 44.0495) ; O6
+ #( 27.8122 6.5394 42.0833) ; H1
+ #( 29.7125 6.5595 40.8235) ; H21
+ #( 31.1859 6.2231 41.6389) ; H22
+ #( 28.9406 5.1504 48.2059) ; H8
+ ))
+
+(define rGs
+ (list rG01 rG02 rG03 rG04 rG05 rG06 rG07 rG08 rG09 rG10))
+
+(define rU
+ (make-constant-rU
+ #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo
+ -0.2669 0.5761 0.7726
+ -0.9631 -0.1296 -0.2361
+ 0.1584 8.3434 0.5434)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 7.2954 -7.6762 2.4898) ; H4*
+ #( 6.0140 -6.5420 1.2890) ; O4*
+ #( 6.4190 -5.1840 1.3620) ; C1*
+ #( 7.1608 -5.0495 0.5747) ; H1*
+ #( 7.0760 -4.9560 2.7270) ; C2*
+ #( 6.7770 -3.9803 3.1099) ; H2**
+ #( 8.4500 -5.1930 2.5810) ; O2*
+ #( 8.8309 -4.8755 1.7590) ; H2*
+ #( 6.4060 -6.0590 3.5580) ; C3*
+ #( 5.4021 -5.7313 3.8281) ; H3*
+ #( 7.1570 -6.4240 4.7070) ; O3*
+ #( 5.2170 -4.3260 1.1690) ; N1
+ #( 4.2960 -2.2560 0.6290) ; N3
+ #( 5.4330 -3.0200 0.7990) ; C2
+ #( 2.9930 -2.6780 0.7940) ; C4
+ #( 2.8670 -4.0630 1.1830) ; C5
+ #( 3.9570 -4.8300 1.3550) ; C6
+ #( 6.5470 -2.5560 0.6290) ; O2
+ #( 2.0540 -1.9000 0.6130) ; O4
+ #( 4.4300 -1.3020 0.3600) ; H3
+ #( 1.9590 -4.4570 1.3250) ; H5
+ #( 3.8460 -5.7860 1.6240) ; H6
+ ))
+
+(define rU01
+ (make-constant-rU
+ #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo
+ -0.2523 0.5817 0.7733
+ -0.9675 -0.1404 -0.2101
+ 0.2031 8.3874 0.4228)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 4.3777 -2.2062 0.7229) ; N3
+ #( 5.5069 -2.9779 0.9088) ; C2
+ #( 3.0693 -2.6246 0.8500) ; C4
+ #( 2.9279 -4.0146 1.2149) ; C5
+ #( 4.0101 -4.7892 1.4017) ; C6
+ #( 6.6267 -2.5166 0.7728) ; O2
+ #( 2.1383 -1.8396 0.6581) ; O4
+ #( 4.5223 -1.2489 0.4716) ; H3
+ #( 2.0151 -4.4065 1.3290) ; H5
+ #( 3.8886 -5.7486 1.6535) ; H6
+ ))
+
+(define rU02
+ (make-constant-rU
+ #( 0.5141 0.0246 0.8574 ; dgf-base-tfo
+ -0.5547 -0.7529 0.3542
+ 0.6542 -0.6577 -0.3734
+ -9.1111 -3.4598 -3.2939)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.6945 -8.7046 -0.2857) ; N3
+ #( 8.6943 -7.6514 0.6066) ; C2
+ #( 7.7426 -9.6987 -0.3801) ; C4
+ #( 6.6642 -9.5742 0.5722) ; C5
+ #( 6.6391 -8.5592 1.4526) ; C6
+ #( 9.5840 -6.8186 0.6136) ; O2
+ #( 7.8505 -10.5925 -1.2223) ; O4
+ #( 9.4601 -8.7514 -0.9277) ; H3
+ #( 5.9281 -10.2509 0.5782) ; H5
+ #( 5.8831 -8.4931 2.1028) ; H6
+ ))
+
+(define rU03
+ (make-constant-rU
+ #( -0.4993 0.0476 0.8651 ; dgf-base-tfo
+ 0.8078 -0.3353 0.4847
+ 0.3132 0.9409 0.1290
+ 6.2989 -5.2303 -3.8577)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 7.9218 -5.5700 6.8877) ; N3
+ #( 7.8908 -5.0886 5.5944) ; C2
+ #( 6.9789 -6.3827 7.4823) ; C4
+ #( 5.8742 -6.7319 6.6202) ; C5
+ #( 5.8182 -6.2769 5.3570) ; C6
+ #( 8.7747 -4.3728 5.1568) ; O2
+ #( 7.1154 -6.7509 8.6509) ; O4
+ #( 8.7055 -5.3037 7.4491) ; H3
+ #( 5.1416 -7.3178 6.9665) ; H5
+ #( 5.0441 -6.5310 4.7784) ; H6
+ ))
+
+(define rU04
+ (make-constant-rU
+ #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo
+ -0.8129 0.5817 0.0273
+ -0.1334 -0.1404 -0.9811
+ -0.3279 8.3874 0.3355)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 3.8961 -3.0896 -0.1893) ; N3
+ #( 5.0095 -3.8907 -0.0346) ; C2
+ #( 3.0480 -2.6632 0.8116) ; C4
+ #( 3.4093 -3.1310 2.1292) ; C5
+ #( 4.4878 -3.9124 2.3088) ; C6
+ #( 5.7005 -4.2164 -0.9842) ; O2
+ #( 2.0800 -1.9458 0.5503) ; O4
+ #( 3.6834 -2.7882 -1.1190) ; H3
+ #( 2.8508 -2.8721 2.9172) ; H5
+ #( 4.7188 -4.2247 3.2295) ; H6
+ ))
+
+(define rU05
+ (make-constant-rU
+ #( -0.6298 0.0246 0.7763 ; dgf-base-tfo
+ -0.5226 -0.7529 -0.4001
+ 0.5746 -0.6577 0.4870
+ -0.0208 -3.4598 -9.6882)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.5977 -9.5977 0.7329) ; N3
+ #( 8.5951 -8.5745 1.6594) ; C2
+ #( 7.7372 -9.7371 -0.3364) ; C4
+ #( 6.7596 -8.6801 -0.4476) ; C5
+ #( 6.7338 -7.6721 0.4408) ; C6
+ #( 9.3993 -8.5377 2.5743) ; O2
+ #( 7.8374 -10.6990 -1.1008) ; O4
+ #( 9.2924 -10.3081 0.8477) ; H3
+ #( 6.0932 -8.6982 -1.1929) ; H5
+ #( 6.0481 -6.9515 0.3446) ; H6
+ ))
+
+(define rU06
+ (make-constant-rU
+ #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo
+ -0.1792 -0.3353 0.9249
+ -0.0141 0.9409 0.3384
+ 5.7793 -5.2303 4.5997)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 6.6920 -5.0495 7.1354) ; N3
+ #( 6.6201 -4.5500 5.8506) ; C2
+ #( 6.9254 -6.3614 7.4926) ; C4
+ #( 7.1046 -7.2543 6.3718) ; C5
+ #( 7.0391 -6.7951 5.1106) ; C6
+ #( 6.4083 -3.3696 5.6340) ; O2
+ #( 6.9679 -6.6901 8.6800) ; O4
+ #( 6.5626 -4.3957 7.8812) ; H3
+ #( 7.2781 -8.2254 6.5350) ; H5
+ #( 7.1657 -7.4312 4.3503) ; H6
+ ))
+
+(define rU07
+ (make-constant-rU
+ #( -0.9434 0.3172 0.0971 ; dgf-base-tfo
+ 0.2294 0.4125 0.8816
+ 0.2396 0.8539 -0.4619
+ 8.3625 -52.7147 1.3745)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 21.5037 16.8594 43.7323) ; C5*
+ #( 20.8147 17.6663 43.9823) ; H5*
+ #( 21.1086 16.0230 43.1557) ; H5**
+ #( 22.5654 17.4874 42.8616) ; C4*
+ #( 22.1584 17.7243 41.8785) ; H4*
+ #( 23.0557 18.6826 43.4751) ; O4*
+ #( 24.4788 18.6151 43.6455) ; C1*
+ #( 24.9355 19.0840 42.7739) ; H1*
+ #( 24.7958 17.1427 43.6474) ; C2*
+ #( 24.5652 16.7400 44.6336) ; H2**
+ #( 26.1041 16.8773 43.2455) ; O2*
+ #( 26.7516 17.5328 43.5149) ; H2*
+ #( 23.8109 16.5979 42.6377) ; C3*
+ #( 23.5756 15.5686 42.9084) ; H3*
+ #( 24.2890 16.7447 41.2729) ; O3*
+ #( 24.9420 19.2174 44.8923) ; N1
+ #( 25.2655 20.5636 44.8883) ; N3
+ #( 25.1663 21.2219 43.8561) ; C2
+ #( 25.6911 21.1219 46.0494) ; C4
+ #( 25.8051 20.4068 47.2048) ; C5
+ #( 26.2093 20.9962 48.2534) ; C6
+ #( 25.4692 19.0221 47.2053) ; O2
+ #( 25.0502 18.4827 46.0370) ; O4
+ #( 25.9599 22.1772 46.0966) ; H3
+ #( 25.5545 18.4409 48.1234) ; H5
+ #( 24.7854 17.4265 45.9883) ; H6
+ ))
+
+(define rU08
+ (make-constant-rU
+ #( -0.0080 -0.7928 0.6094 ; dgf-base-tfo
+ -0.7512 0.4071 0.5197
+ -0.6601 -0.4536 -0.5988
+ 44.1482 30.7036 2.1088)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 23.5096 16.1227 44.5783) ; C5*
+ #( 23.5649 15.8588 43.5222) ; H5*
+ #( 23.9621 15.4341 45.2919) ; H5**
+ #( 24.2805 17.4138 44.7151) ; C4*
+ #( 25.3492 17.2309 44.6030) ; H4*
+ #( 23.8497 18.3471 43.7208) ; O4*
+ #( 23.4090 19.5681 44.3321) ; C1*
+ #( 24.2595 20.2496 44.3524) ; H1*
+ #( 23.0418 19.1813 45.7407) ; C2*
+ #( 22.0532 18.7224 45.7273) ; H2**
+ #( 23.1307 20.2521 46.6291) ; O2*
+ #( 22.8888 21.1051 46.2611) ; H2*
+ #( 24.0799 18.1326 46.0700) ; C3*
+ #( 23.6490 17.4370 46.7900) ; H3*
+ #( 25.3329 18.7227 46.5109) ; O3*
+ #( 22.2515 20.1624 43.6698) ; N1
+ #( 22.4760 21.0609 42.6406) ; N3
+ #( 23.6229 21.3462 42.3061) ; C2
+ #( 21.3986 21.6081 42.0236) ; C4
+ #( 20.1189 21.3012 42.3804) ; C5
+ #( 19.1599 21.8516 41.7578) ; C6
+ #( 19.8919 20.3745 43.4387) ; O2
+ #( 20.9790 19.8423 44.0440) ; O4
+ #( 21.5235 22.3222 41.2097) ; H3
+ #( 18.8732 20.1200 43.7312) ; H5
+ #( 20.8545 19.1313 44.8608) ; H6
+ ))
+
+(define rU09
+ (make-constant-rU
+ #( -0.0317 0.1374 0.9900 ; dgf-base-tfo
+ -0.3422 -0.9321 0.1184
+ 0.9391 -0.3351 0.0765
+ -32.1929 25.8198 -28.5088)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 21.5037 16.8594 43.7323) ; C5*
+ #( 20.8147 17.6663 43.9823) ; H5*
+ #( 21.1086 16.0230 43.1557) ; H5**
+ #( 22.5654 17.4874 42.8616) ; C4*
+ #( 23.0565 18.3036 43.3915) ; H4*
+ #( 23.5375 16.5054 42.4925) ; O4*
+ #( 23.6574 16.4257 41.0649) ; C1*
+ #( 24.4701 17.0882 40.7671) ; H1*
+ #( 22.3525 16.9643 40.5396) ; C2*
+ #( 21.5993 16.1799 40.6133) ; H2**
+ #( 22.4693 17.4849 39.2515) ; O2*
+ #( 23.0899 17.0235 38.6827) ; H2*
+ #( 22.0341 18.0633 41.5279) ; C3*
+ #( 20.9509 18.1709 41.5846) ; H3*
+ #( 22.7249 19.3020 41.2100) ; O3*
+ #( 23.8580 15.0648 40.5757) ; N1
+ #( 25.1556 14.5982 40.4523) ; N3
+ #( 26.1047 15.3210 40.7448) ; C2
+ #( 25.3391 13.3315 40.0020) ; C4
+ #( 24.2974 12.5148 39.6749) ; C5
+ #( 24.5450 11.3410 39.2610) ; C6
+ #( 22.9633 12.9979 39.8053) ; O2
+ #( 22.8009 14.2648 40.2524) ; O4
+ #( 26.3414 12.9194 39.8855) ; H3
+ #( 22.1227 12.3533 39.5486) ; H5
+ #( 21.7989 14.6788 40.3650) ; H6
+ ))
+
+(define rU10
+ (make-constant-rU
+ #( -0.9674 0.1021 -0.2318 ; dgf-base-tfo
+ -0.2514 -0.2766 0.9275
+ 0.0306 0.9555 0.2933
+ 27.8571 -42.1305 -24.4563)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 23.5096 16.1227 44.5783) ; C5*
+ #( 23.5649 15.8588 43.5222) ; H5*
+ #( 23.9621 15.4341 45.2919) ; H5**
+ #( 24.2805 17.4138 44.7151) ; C4*
+ #( 23.8509 18.1819 44.0720) ; H4*
+ #( 24.2506 17.8583 46.0741) ; O4*
+ #( 25.5830 18.0320 46.5775) ; C1*
+ #( 25.8569 19.0761 46.4256) ; H1*
+ #( 26.4410 17.1555 45.7033) ; C2*
+ #( 26.3459 16.1253 46.0462) ; H2**
+ #( 27.7649 17.5888 45.6478) ; O2*
+ #( 28.1004 17.9719 46.4616) ; H2*
+ #( 25.7796 17.2997 44.3513) ; C3*
+ #( 25.9478 16.3824 43.7871) ; H3*
+ #( 26.2154 18.4984 43.6541) ; O3*
+ #( 25.7321 17.6281 47.9726) ; N1
+ #( 25.5136 18.5779 48.9560) ; N3
+ #( 25.2079 19.7276 48.6503) ; C2
+ #( 25.6482 18.1987 50.2518) ; C4
+ #( 25.9847 16.9266 50.6092) ; C5
+ #( 26.0918 16.6439 51.8416) ; C6
+ #( 26.2067 15.9515 49.5943) ; O2
+ #( 26.0713 16.3497 48.3080) ; O4
+ #( 25.4890 18.9105 51.0618) ; H3
+ #( 26.4742 14.9310 49.8682) ; H5
+ #( 26.2346 15.6394 47.4975) ; H6
+ ))
+
+(define rUs
+ (list rU01 rU02 rU03 rU04 rU05 rU06 rU07 rU08 rU09 rU10))
+
+(define rG*
+ (make-constant-rG
+ #( -0.2067 -0.0264 0.9780 ; dgf-base-tfo
+ 0.9770 -0.0586 0.2049
+ 0.0519 0.9979 0.0379
+ 1.0331 -46.8078 -36.4742)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.1610 2.2370 46.2560) ; C5*
+ #( 31.2986 2.8190 46.5812) ; H5*
+ #( 32.0980 1.7468 45.2845) ; H5**
+ #( 33.3476 3.1959 46.1947) ; C4*
+ #( 33.2668 3.8958 45.3630) ; H4*
+ #( 33.3799 3.9183 47.4216) ; O4*
+ #( 34.6515 3.7222 48.0398) ; C1*
+ #( 35.2947 4.5412 47.7180) ; H1*
+ #( 35.1756 2.4228 47.4827) ; C2*
+ #( 34.6778 1.5937 47.9856) ; H2**
+ #( 36.5631 2.2672 47.4798) ; O2*
+ #( 37.0163 2.6579 48.2305) ; H2*
+ #( 34.6953 2.5043 46.0448) ; C3*
+ #( 34.5444 1.4917 45.6706) ; H3*
+ #( 35.6679 3.3009 45.3487) ; O3*
+ #( 37.4804 4.0914 52.2559) ; N1
+ #( 36.9670 4.1312 49.9281) ; N3
+ #( 37.8045 4.2519 50.9550) ; C2
+ #( 35.7171 3.8264 50.3222) ; C4
+ #( 35.2668 3.6420 51.6115) ; C5
+ #( 36.2037 3.7829 52.6706) ; C6
+ #( 39.0869 4.5552 50.7092) ; N2
+ #( 33.9075 3.3338 51.6102) ; N7
+ #( 34.6126 3.6358 49.5108) ; N9
+ #( 33.5805 3.3442 50.3425) ; C8
+ #( 35.9958 3.6512 53.8724) ; O6
+ #( 38.2106 4.2053 52.9295) ; H1
+ #( 39.8218 4.6863 51.3896) ; H21
+ #( 39.3420 4.6857 49.7407) ; H22
+ #( 32.5194 3.1070 50.2664) ; H8
+ ))
+
+(define rU*
+ (make-constant-rU
+ #( -0.0109 0.5907 0.8068 ; dgf-base-tfo
+ 0.2217 -0.7853 0.5780
+ 0.9751 0.1852 -0.1224
+ -1.4225 -11.0956 -2.5217)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 5.8744 -6.2116 2.4731) ; H4*
+ #( 7.2798 -7.2260 3.6420) ; O4*
+ #( 8.5733 -6.9410 3.1329) ; C1*
+ #( 8.9047 -6.0374 3.6446) ; H1*
+ #( 8.4429 -6.6596 1.6327) ; C2*
+ #( 9.2880 -7.1071 1.1096) ; H2**
+ #( 8.2502 -5.2799 1.4754) ; O2*
+ #( 8.7676 -4.7284 2.0667) ; H2*
+ #( 7.1642 -7.4416 1.3021) ; C3*
+ #( 7.4125 -8.5002 1.2260) ; H3*
+ #( 6.5160 -6.9772 0.1267) ; O3*
+ #( 9.4531 -8.1107 3.4087) ; N1
+ #( 11.5931 -9.0015 3.6357) ; N3
+ #( 10.8101 -7.8950 3.3748) ; C2
+ #( 11.1439 -10.2744 3.9206) ; C4
+ #( 9.7056 -10.4026 3.9332) ; C5
+ #( 8.9192 -9.3419 3.6833) ; C6
+ #( 11.3013 -6.8063 3.1326) ; O2
+ #( 11.9431 -11.1876 4.1375) ; O4
+ #( 12.5840 -8.8673 3.6158) ; H3
+ #( 9.2891 -11.2898 4.1313) ; H5
+ #( 7.9263 -9.4537 3.6977) ; H6
+ ))
+
+
+
+; -- PARTIAL INSTANTIATIONS ---------------------------------------------------
+
+(def-struct #f var id tfo nuc)
+
+; Add a single-quote at the start of this line if you want lazy computation
+(begin
+
+(def-macro (mk-var i tfo nuc)
+ `(make-var ,i ,tfo ,nuc))
+
+(def-macro (absolute-pos var p)
+ `(tfo-apply (var-tfo ,var) ,p))
+
+(def-macro (lazy-computation-of expr)
+ expr)
+)
+
+'; Remove the single-quote from this line if you want lazy computation
+(begin
+
+(def-macro (mk-var i tfo nuc)
+ `(make-var ,i ,tfo (make-relative-nuc ,tfo ,nuc)))
+
+(def-macro (absolute-pos var p)
+ `(force ,p))
+
+(def-macro (lazy-computation-of expr)
+ `(delay ,expr))
+)
+
+(def-macro (atom-pos atom var)
+ `(let ((v ,var))
+ (absolute-pos v (,atom (var-nuc v)))))
+
+(define (get-var id lst)
+ (let ((v (car lst)))
+ (if (= id (var-id v))
+ v
+ (get-var id (cdr lst)))))
+
+(define (make-relative-nuc tfo n)
+ (cond ((rA? n)
+ (make-rA
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (lazy-computation-of (tfo-apply tfo (nuc-P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O1P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N1 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N3 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C6 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-N6 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-N7 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-N9 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-C8 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-H2 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-H61 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-H62 n)))
+ (lazy-computation-of (tfo-apply tfo (rA-H8 n)))))
+ ((rC? n)
+ (make-rC
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (lazy-computation-of (tfo-apply tfo (nuc-P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O1P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N1 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N3 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C6 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-N4 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-O2 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-H41 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-H42 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-H5 n)))
+ (lazy-computation-of (tfo-apply tfo (rC-H6 n)))))
+ ((rG? n)
+ (make-rG
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (lazy-computation-of (tfo-apply tfo (nuc-P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O1P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N1 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N3 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C6 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-N2 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-N7 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-N9 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-C8 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-O6 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-H1 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-H21 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-H22 n)))
+ (lazy-computation-of (tfo-apply tfo (rG-H8 n)))))
+ (else
+ (make-rU
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (lazy-computation-of (tfo-apply tfo (nuc-P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O1P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2P n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H5** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O4* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H1* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2** n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H2* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-H3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-O3* n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N1 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-N3 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C2 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C4 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C5 n)))
+ (lazy-computation-of (tfo-apply tfo (nuc-C6 n)))
+ (lazy-computation-of (tfo-apply tfo (rU-O2 n)))
+ (lazy-computation-of (tfo-apply tfo (rU-O4 n)))
+ (lazy-computation-of (tfo-apply tfo (rU-H3 n)))
+ (lazy-computation-of (tfo-apply tfo (rU-H5 n)))
+ (lazy-computation-of (tfo-apply tfo (rU-H6 n)))))))
+
+; -- SEARCH -------------------------------------------------------------------
+
+; Sequential backtracking algorithm
+
+(define (search partial-inst domains constraint?)
+ (if (null? domains)
+ (list partial-inst)
+ (let ((remaining-domains (cdr domains)))
+
+ (define (try-assignments lst)
+ (if (null? lst)
+ '()
+ (let ((var (car lst)))
+ (if (constraint? var partial-inst)
+ (let* ((subsols1
+ (search
+ (cons var partial-inst)
+ remaining-domains
+ constraint?))
+ (subsols2
+ (try-assignments (cdr lst))))
+ (append subsols1 subsols2))
+ (try-assignments (cdr lst))))))
+
+ (try-assignments ((car domains) partial-inst)))))
+
+; -- DOMAINS ------------------------------------------------------------------
+
+; Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG
+;
+; Secondary structure: strand A CUGCCACGUCUG
+; ||||||||||||
+; GACGGUGCAGAC strand B
+;
+; Tertiary structure:
+;
+; 5' end of strand A C1----G12 3' end of strand B
+; U2-------A11
+; G3-------C10
+; C4-----G9
+; C5---G8
+; A6
+; G6-C7
+; C5----G8
+; A4-------U9
+; G3--------C10
+; A2-------U11
+; 5' end of strand B C1----G12 3' end of strand A
+;
+; "helix", "stacked" and "connected" describe the spatial relationship
+; between two consecutive nucleotides. E.g. the nucleotides C1 and U2
+; from the strand A.
+;
+; "wc" (stands for Watson-Crick and is a type of base-pairing),
+; and "wc-dumas" describe the spatial relationship between
+; nucleotides from two chains that are growing in opposite directions.
+; E.g. the nucleotides C1 from strand A and G12 from strand B.
+
+; Dynamic Domains
+
+; Given,
+; "ref" a nucleotide which is already positioned,
+; "nuc" the nucleotide to be placed,
+; and "tfo" a transformation matrix which expresses the desired
+; relationship between "ref" and "nuc",
+; the function "dgf-base" computes the transformation matrix that
+; places the nucleotide "nuc" in the given relationship to "ref".
+
+(define (dgf-base tfo ref nuc)
+ (let* ((ref-nuc (var-nuc ref))
+ (align
+ (tfo-inv-ortho
+ (cond ((rA? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos rA-N9 ref)
+ (atom-pos nuc-C4 ref)))
+ ((rC? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos nuc-N1 ref)
+ (atom-pos nuc-C2 ref)))
+ ((rG? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos rG-N9 ref)
+ (atom-pos nuc-C4 ref)))
+ (else
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos nuc-N1 ref)
+ (atom-pos nuc-C2 ref)))))))
+ (tfo-combine (nuc-dgf-base-tfo nuc)
+ (tfo-combine tfo align))))
+
+; Placement of first nucleotide.
+
+(define (reference nuc i)
+ (lambda (partial-inst)
+ (list (mk-var i tfo-id nuc))))
+
+; The transformation matrix for wc is from:
+;
+; Chandrasekaran R. et al (1989) A Re-Examination of the Crystal
+; Structure of A-DNA Using Fiber Diffraction Data. J. Biomol.
+; Struct. & Dynamics 6(6):1189-1202.
+
+(define wc-tfo
+ '#(-1.0000 0.0028 -0.0019
+ 0.0028 0.3468 -0.9379
+ -0.0019 -0.9379 -0.3468
+ -0.0080 6.0730 8.7208))
+
+(define (wc nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base wc-tfo ref nuc)))
+ (list (mk-var i tfo nuc)))))
+
+(define wc-Dumas-tfo
+ '#(-0.9737 -0.1834 0.1352
+ -0.1779 0.2417 -0.9539
+ 0.1422 -0.9529 -0.2679
+ 0.4837 6.2649 8.0285))
+
+(define (wc-Dumas nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base wc-Dumas-tfo ref nuc)))
+ (list (mk-var i tfo nuc)))))
+
+(define helix5*-tfo
+ '#( 0.9886 -0.0961 0.1156
+ 0.1424 0.8452 -0.5152
+ -0.0482 0.5258 0.8492
+ -3.8737 0.5480 3.8024))
+
+(define (helix5* nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base helix5*-tfo ref nuc)))
+ (list (mk-var i tfo nuc)))))
+
+(define helix3*-tfo
+ '#( 0.9886 0.1424 -0.0482
+ -0.0961 0.8452 0.5258
+ 0.1156 -0.5152 0.8492
+ 3.4426 2.0474 -3.7042))
+
+(define (helix3* nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base helix3*-tfo ref nuc)))
+ (list (mk-var i tfo nuc)))))
+
+(define G37-A38-tfo
+ '#( 0.9991 0.0164 -0.0387
+ -0.0375 0.7616 -0.6470
+ 0.0189 0.6478 0.7615
+ -3.3018 0.9975 2.5585))
+
+(define (G37-A38 nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base G37-A38-tfo ref nuc)))
+ (mk-var i tfo nuc))))
+
+(define (stacked5* nuc i j)
+ (lambda (partial-inst)
+ (cons ((G37-A38 nuc i j) partial-inst)
+ ((helix5* nuc i j) partial-inst))))
+
+(define A38-G37-tfo
+ '#( 0.9991 -0.0375 0.0189
+ 0.0164 0.7616 0.6478
+ -0.0387 -0.6470 0.7615
+ 3.3819 0.7718 -2.5321))
+
+(define (A38-G37 nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base A38-G37-tfo ref nuc)))
+ (mk-var i tfo nuc))))
+
+(define (stacked3* nuc i j)
+ (lambda (partial-inst)
+ (cons ((A38-G37 nuc i j) partial-inst)
+ ((helix3* nuc i j) partial-inst))))
+
+(define (P-O3* nucs i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (align
+ (tfo-inv-ortho
+ (tfo-align (atom-pos nuc-O3* ref)
+ (atom-pos nuc-C3* ref)
+ (atom-pos nuc-C4* ref)))))
+ (let loop ((lst nucs) (domains '()))
+ (if (null? lst)
+ domains
+ (let ((nuc (car lst)))
+ (let ((tfo-60 (tfo-combine (nuc-P-O3*-60-tfo nuc) align))
+ (tfo-180 (tfo-combine (nuc-P-O3*-180-tfo nuc) align))
+ (tfo-275 (tfo-combine (nuc-P-O3*-275-tfo nuc) align)))
+ (loop (cdr lst)
+ (cons (mk-var i tfo-60 nuc)
+ (cons (mk-var i tfo-180 nuc)
+ (cons (mk-var i tfo-275 nuc) domains)))))))))))
+
+; -- PROBLEM STATEMENT --------------------------------------------------------
+
+; Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c
+
+(define anticodon-domains
+ (list
+ (reference rC 27 )
+ (helix5* rC 28 27)
+ (helix5* rA 29 28)
+ (helix5* rG 30 29)
+ (helix5* rA 31 30)
+ (wc rU 39 31)
+ (helix5* rC 40 39)
+ (helix5* rU 41 40)
+ (helix5* rG 42 41)
+ (helix5* rG 43 42)
+ (stacked3* rA 38 39)
+ (stacked3* rG 37 38)
+ (stacked3* rA 36 37)
+ (stacked3* rA 35 36)
+ (stacked3* rG 34 35);<-. Distance
+ (P-O3* rCs 32 31); | Constraint
+ (P-O3* rUs 33 32);<-' 3.0 Angstroms
+ ))
+
+; Anticodon constraint
+
+(define (anticodon-constraint? v partial-inst)
+ (if (= (var-id v) 33)
+ (let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34
+ (o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33
+ (FLOAT<= (pt-dist p o3*) 3.0)) ; check distance
+ #t))
+
+(define (anticodon)
+ (search '() anticodon-domains anticodon-constraint?))
+
+; Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b
+
+(define pseudoknot-domains
+ (list
+ (reference rA 23 )
+ (wc-Dumas rU 8 23)
+ (helix3* rG 22 23)
+ (wc-Dumas rC 9 22)
+ (helix3* rG 21 22)
+ (wc-Dumas rC 10 21)
+ (helix3* rC 20 21)
+ (wc-Dumas rG 11 20)
+ (helix3* rU* 19 20);<-.
+ (wc-Dumas rA 12 19); | Distance
+; ; | Constraint
+; Helix 1 ; | 4.0 Angstroms
+ (helix3* rC 3 19); |
+ (wc-Dumas rG 13 3); |
+ (helix3* rC 2 3); |
+ (wc-Dumas rG 14 2); |
+ (helix3* rC 1 2); |
+ (wc-Dumas rG* 15 1); |
+; ; |
+; L2 LOOP ; |
+ (P-O3* rUs 16 15); |
+ (P-O3* rCs 17 16); |
+ (P-O3* rAs 18 17);<-'
+;
+; L1 LOOP
+ (helix3* rU 7 8);<-.
+ (P-O3* rCs 4 3); | Constraint
+ (stacked5* rU 5 4); | 4.5 Angstroms
+ (stacked5* rC 6 5);<-'
+ ))
+
+; Pseudoknot constraint
+
+(define (pseudoknot-constraint? v partial-inst)
+ (case (var-id v)
+ ((18)
+ (let ((p (atom-pos nuc-P (get-var 19 partial-inst)))
+ (o3* (atom-pos nuc-O3* v)))
+ (FLOAT<= (pt-dist p o3*) 4.0)))
+ ((6)
+ (let ((p (atom-pos nuc-P (get-var 7 partial-inst)))
+ (o3* (atom-pos nuc-O3* v)))
+ (FLOAT<= (pt-dist p o3*) 4.5)))
+ (else
+ #t)))
+
+(define (pseudoknot)
+ (search '() pseudoknot-domains pseudoknot-constraint?))
+
+; -- TESTING -----------------------------------------------------------------
+
+(define (list-of-atoms n)
+ (append (list-of-common-atoms n)
+ (list-of-specific-atoms n)))
+
+(define (list-of-common-atoms n)
+ (list
+ (nuc-P n)
+ (nuc-O1P n)
+ (nuc-O2P n)
+ (nuc-O5* n)
+ (nuc-C5* n)
+ (nuc-H5* n)
+ (nuc-H5** n)
+ (nuc-C4* n)
+ (nuc-H4* n)
+ (nuc-O4* n)
+ (nuc-C1* n)
+ (nuc-H1* n)
+ (nuc-C2* n)
+ (nuc-H2** n)
+ (nuc-O2* n)
+ (nuc-H2* n)
+ (nuc-C3* n)
+ (nuc-H3* n)
+ (nuc-O3* n)
+ (nuc-N1 n)
+ (nuc-N3 n)
+ (nuc-C2 n)
+ (nuc-C4 n)
+ (nuc-C5 n)
+ (nuc-C6 n)))
+
+(define (list-of-specific-atoms n)
+ (cond ((rA? n)
+ (list
+ (rA-N6 n)
+ (rA-N7 n)
+ (rA-N9 n)
+ (rA-C8 n)
+ (rA-H2 n)
+ (rA-H61 n)
+ (rA-H62 n)
+ (rA-H8 n)))
+ ((rC? n)
+ (list
+ (rC-N4 n)
+ (rC-O2 n)
+ (rC-H41 n)
+ (rC-H42 n)
+ (rC-H5 n)
+ (rC-H6 n)))
+ ((rG? n)
+ (list
+ (rG-N2 n)
+ (rG-N7 n)
+ (rG-N9 n)
+ (rG-C8 n)
+ (rG-O6 n)
+ (rG-H1 n)
+ (rG-H21 n)
+ (rG-H22 n)
+ (rG-H8 n)))
+ (else
+ (list
+ (rU-O2 n)
+ (rU-O4 n)
+ (rU-H3 n)
+ (rU-H5 n)
+ (rU-H6 n)))))
+
+(define (var-most-distant-atom v)
+
+ (define (distance pos)
+ (let ((abs-pos (absolute-pos v pos)))
+ (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos)))
+ (FLOATsqrt (FLOAT+ (FLOAT* x x) (FLOAT* y y) (FLOAT* z z))))))
+
+ (maximum (map distance (list-of-atoms (var-nuc v)))))
+
+(define (sol-most-distant-atom s)
+ (maximum (map var-most-distant-atom s)))
+
+(define (most-distant-atom sols)
+ (maximum (map sol-most-distant-atom sols)))
+
+(define (maximum lst)
+ (let loop ((m (car lst)) (l (cdr lst)))
+ (if (null? l)
+ m
+ (let ((x (car l)))
+ (loop (if (FLOAT> x m) x m) (cdr l))))))
+
+(define (check)
+ (length (pseudoknot)))
+
+(define (run)
+ (most-distant-atom (pseudoknot)))
+
+; To run program, evaluate: (run)
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: perm9.sch
+; Description: memory system benchmark using Zaks's permutation generator
+; Author: Lars Hansen, Will Clinger, and Gene Luks
+; Created: 18-Mar-94
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; 940720 / lth Added some more benchmarks for the thesis paper.
+; 970215 / wdc Increased problem size from 8 to 9; improved tenperm9-benchmark.
+; 970531 / wdc Cleaned up for public release.
+; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark.
+
+; This benchmark is in four parts. Each tests a different aspect of
+; the memory system.
+;
+; perm storage allocation
+; 10perm storage allocation and garbage collection
+; sumperms traversal of a large, linked, self-sharing structure
+; mergesort! side effects and write barrier
+;
+; The perm9 benchmark generates a list of all 362880 permutations of
+; the first 9 integers, allocating 1349288 pairs (typically 10,794,304
+; bytes), all of which goes into the generated list. (That is, the
+; perm9 benchmark generates absolutely no garbage.) This represents
+; a savings of about 63% over the storage that would be required by
+; an unshared list of permutations. The generated permutations are
+; in order of a grey code that bears no obvious relationship to a
+; lexicographic order.
+;
+; The 10perm9 benchmark repeats the perm9 benchmark 10 times, so it
+; allocates and reclaims 13492880 pairs (typically 107,943,040 bytes).
+; The live storage peaks at twice the storage that is allocated by the
+; perm9 benchmark. At the end of each iteration, the oldest half of
+; the live storage becomes garbage. Object lifetimes are distributed
+; uniformly between 10.3 and 20.6 megabytes.
+;
+; The 10perm9 benchmark is the 10perm9:2:1 special case of the
+; MpermNKL benchmark, which allocates a queue of size K and then
+; performs M iterations of the following operation: Fill the queue
+; with individually computed copies of all permutations of a list of
+; size N, and then remove the oldest L copies from the queue. At the
+; end of each iteration, the oldest L/K of the live storage becomes
+; garbage, and object lifetimes are distributed uniformly between two
+; volumes that depend upon N, K, and L.
+;
+; The sumperms benchmark computes the sum of the permuted integers
+; over all permutations.
+;
+; The mergesort! benchmark destructively sorts the generated permutations
+; into lexicographic order, allocating no storage whatsoever.
+;
+; The benchmarks are run by calling the following procedures:
+;
+; (perm-benchmark n)
+; (tenperm-benchmark n)
+; (sumperms-benchmark n)
+; (mergesort-benchmark n)
+;
+; The argument n may be omitted, in which case it defaults to 9.
+;
+; These benchmarks assume that
+;
+; (RUN-BENCHMARK <string> <thunk> <count>)
+; (RUN-BENCHMARK <string> <count> <thunk> <predicate>)
+;
+; reports the time required to call <thunk> the number of times
+; specified by <count>, and uses <predicate> to test whether the
+; result returned by <thunk> is correct.
+
+; Date: Thu, 17 Mar 94 19:43:32 -0800
+; From: luks@sisters.cs.uoregon.edu
+; To: will
+; Subject: Pancake flips
+;
+; Procedure P_n generates a grey code of all perms of n elements
+; on top of stack ending with reversal of starting sequence
+;
+; F_n is flip of top n elements.
+;
+;
+; procedure P_n
+;
+; if n>1 then
+; begin
+; repeat P_{n-1},F_n n-1 times;
+; P_{n-1}
+; end
+;
+
+(define (permutations x)
+ (let ((x x)
+ (perms (list x)))
+ (define (P n)
+ (if (> n 1)
+ (do ((j (- n 1) (- j 1)))
+ ((zero? j)
+ (P (- n 1)))
+ (P (- n 1))
+ (F n))))
+ (define (F n)
+ (set! x (revloop x n (list-tail x n)))
+ (set! perms (cons x perms)))
+ (define (revloop x n y)
+ (if (zero? n)
+ y
+ (revloop (cdr x)
+ (- n 1)
+ (cons (car x) y))))
+ (define (list-tail x n)
+ (if (zero? n)
+ x
+ (list-tail (cdr x) (- n 1))))
+ (P (length x))
+ perms))
+
+; Given a list of lists of numbers, returns the sum of the sums
+; of those lists.
+;
+; for (; x != NULL; x = x->rest)
+; for (y = x->first; y != NULL; y = y->rest)
+; sum = sum + y->first;
+
+(define (sumlists x)
+ (do ((x x (cdr x))
+ (sum 0 (do ((y (car x) (cdr y))
+ (sum sum (+ sum (car y))))
+ ((null? y) sum))))
+ ((null? x) sum)))
+
+; Destructive merge of two sorted lists.
+; From Hansen's MS thesis.
+
+(define (merge!! a b less?)
+
+ (define (loop r a b)
+ (if (less? (car b) (car a))
+ (begin (set-cdr! r b)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a (cdr b)) ))
+ ;; (car a) <= (car b)
+ (begin (set-cdr! r a)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) b)) )) )
+
+ (cond ((null? a) b)
+ ((null? b) a)
+ ((less? (car b) (car a))
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a (cdr b)))
+ b)
+ (else ; (car a) <= (car b)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) b))
+ a)))
+
+
+;; Stable sort procedure which copies the input list and then sorts
+;; the new list imperatively. On the systems we have benchmarked,
+;; this generic list sort has been at least as fast and usually much
+;; faster than the library's sort routine.
+;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren.
+
+(define (sort!! seq less?)
+
+ (define (step n)
+ (cond ((> n 2)
+ (let* ((j (quotient n 2))
+ (a (step j))
+ (k (- n j))
+ (b (step k)))
+ (merge!! a b less?)))
+ ((= n 2)
+ (let ((x (car seq))
+ (y (cadr seq))
+ (p seq))
+ (set! seq (cddr seq))
+ (if (less? y x)
+ (begin
+ (set-car! p y)
+ (set-car! (cdr p) x)))
+ (set-cdr! (cdr p) '())
+ p))
+ ((= n 1)
+ (let ((p seq))
+ (set! seq (cdr seq))
+ (set-cdr! p '())
+ p))
+ (else
+ '())))
+
+ (step (length seq)))
+
+(define lexicographically-less?
+ (lambda (x y)
+ (define (lexicographically-less? x y)
+ (cond ((null? x) (not (null? y)))
+ ((null? y) #f)
+ ((< (car x) (car y)) #t)
+ ((= (car x) (car y))
+ (lexicographically-less? (cdr x) (cdr y)))
+ (else #f)))
+ (lexicographically-less? x y)))
+
+; This procedure isn't used by the benchmarks,
+; but is provided as a public service.
+
+(define (internally-imperative-mergesort list less?)
+
+ (define (list-copy l)
+ (define (loop l prev)
+ (if (null? l)
+ #t
+ (let ((q (cons (car l) '())))
+ (set-cdr! prev q)
+ (loop (cdr l) q))))
+ (if (null? l)
+ l
+ (let ((first (cons (car l) '())))
+ (loop (cdr l) first)
+ first)))
+
+ (sort!! (list-copy list) less?))
+
+(define *perms* '())
+
+(define (one..n n)
+ (do ((n n (- n 1))
+ (p '() (cons n p)))
+ ((zero? n) p)))
+
+(define (perm-benchmark . rest)
+ (let ((n (if (null? rest) 9 (car rest))))
+ (set! *perms* '())
+ (run-benchmark (string-append "Perm" (number->string n))
+ 1
+ (lambda ()
+ (set! *perms* (permutations (one..n n)))
+ #t)
+ (lambda (x) #t))))
+
+(define (tenperm-benchmark . rest)
+ (let ((n (if (null? rest) 9 (car rest))))
+ (set! *perms* '())
+ (MpermNKL-benchmark 10 n 2 1)))
+
+(define (MpermNKL-benchmark m n k ell)
+ (if (and (<= 0 m)
+ (positive? n)
+ (positive? k)
+ (<= 0 ell k))
+ (let ((id (string-append (number->string m)
+ "perm"
+ (number->string n)
+ ":"
+ (number->string k)
+ ":"
+ (number->string ell)))
+ (queue (make-vector k '())))
+
+ ; Fills queue positions [i, j).
+
+ (define (fill-queue i j)
+ (if (< i j)
+ (begin (vector-set! queue i (permutations (one..n n)))
+ (fill-queue (+ i 1) j))))
+
+ ; Removes ell elements from queue.
+
+ (define (flush-queue)
+ (let loop ((i 0))
+ (if (< i k)
+ (begin (vector-set! queue
+ i
+ (let ((j (+ i ell)))
+ (if (< j k)
+ (vector-ref queue j)
+ '())))
+ (loop (+ i 1))))))
+
+ (fill-queue 0 (- k ell))
+ (run-benchmark id
+ m
+ (lambda ()
+ (fill-queue (- k ell) k)
+ (flush-queue)
+ queue)
+ (lambda (q)
+ (let ((q0 (vector-ref q 0))
+ (qi (vector-ref q (max 0 (- k ell 1)))))
+ (or (and (null? q0) (null? qi))
+ (and (pair? q0)
+ (pair? qi)
+ (equal? (car q0) (car qi))))))))
+ (begin (display "Incorrect arguments to MpermNKL-benchmark")
+ (newline))))
+
+(define (sumperms-benchmark . rest)
+ (let ((n (if (null? rest) 9 (car rest))))
+ (if (or (null? *perms*)
+ (not (= n (length (car *perms*)))))
+ (set! *perms* (permutations (one..n n))))
+ (run-benchmark (string-append "Sumperms" (number->string n))
+ 1
+ (lambda ()
+ (sumlists *perms*))
+ (lambda (x) #t))))
+
+(define (mergesort-benchmark . rest)
+ (let ((n (if (null? rest) 9 (car rest))))
+ (if (or (null? *perms*)
+ (not (= n (length (car *perms*)))))
+ (set! *perms* (permutations (one..n n))))
+ (run-benchmark (string-append "Mergesort!" (number->string n))
+ 1
+ (lambda ()
+ (sort!! *perms* lexicographically-less?)
+ #t)
+ (lambda (x) #t))))
--- /dev/null
+;;; Gambit-style run-benchmark.
+;;;
+;;; Invoke this procedure to run a benchmark.
+;;; The first argument is a string identifying the benchmark.
+;;; The second argument is the number of times to run the benchmark.
+;;; The third argument is a thunk that runs the benchmark.
+;;; The fourth argument is a unary predicate that warns if the result
+;;; returned by the benchmark is incorrect.
+;;;
+;;; Example:
+;;; (run-benchmark "make-vector"
+;;; 1
+;;; (lambda () (make-vector 1000000))
+;;; (lambda (v) (and (vector? v) (= (vector-length v) #e1e6))))
+
+;;; For backward compatibility, this procedure also works with the
+;;; arguments that we once used to run benchmarks in Larceny.
+
+(define (run-benchmark name arg2 . rest)
+ (let* ((old-style (procedure? arg2))
+ (thunk (if old-style arg2 (car rest)))
+ (n (if old-style
+ (if (null? rest) 1 (car rest))
+ arg2))
+ (ok? (if (or old-style (null? (cdr rest)))
+ (lambda (result) #t)
+ (cadr rest)))
+ (result '*))
+ (define (loop n)
+ (cond ((zero? n) #t)
+ ((= n 1)
+ (set! result (thunk)))
+ (else
+ (thunk)
+ (loop (- n 1)))))
+ (if old-style
+ (begin (newline)
+ (display "Warning: Using old-style run-benchmark")
+ (newline)))
+ (newline)
+ (display "--------------------------------------------------------")
+ (newline)
+ (display name)
+ (newline)
+ ; time is a macro supplied by Chez Scheme
+ (time (loop n))
+ (if (not (ok? result))
+ (begin (display "Error: Benchmark program returned wrong result: ")
+ (write result)
+ (newline)))))
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: sboyer.sch
+; Description: The Boyer benchmark
+; Author: Bob Boyer
+; Created: 5-Apr-85
+; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
+; 22-Jul-87 (Will Clinger)
+; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
+; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
+; rewrote to eliminate property lists, and added
+; a scaling parameter suggested by Bob Boyer)
+; 19-Mar-99 (Will Clinger -- cleaned up comments)
+; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
+;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
+;;; "sharing cons".
+
+; Note: The version of this benchmark that appears in Dick Gabriel's book
+; contained several bugs that are corrected here. These bugs are discussed
+; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
+; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
+;
+; The benchmark now returns a boolean result.
+; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
+; in Common Lisp)
+; ONE-WAY-UNIFY1 now treats numbers correctly
+; ONE-WAY-UNIFY1-LST now treats empty lists correctly
+; Rule 19 has been corrected (this rule was not touched by the original
+; benchmark, but is used by this version)
+; Rules 84 and 101 have been corrected (but these rules are never touched
+; by the benchmark)
+;
+; According to Baker, these bug fixes make the benchmark 10-25% slower.
+; Please do not compare the timings from this benchmark against those of
+; the original benchmark.
+;
+; This version of the benchmark also prints the number of rewrites as a sanity
+; check, because it is too easy for a buggy version to return the correct
+; boolean result. The correct number of rewrites is
+;
+; n rewrites peak live storage (approximate, in bytes)
+; 0 95024
+; 1 591777
+; 2 1813975
+; 3 5375678
+; 4 16445406
+; 5 51507739
+
+; Sboyer is a 2-phase benchmark.
+; The first phase attaches lemmas to symbols. This phase is not timed,
+; but it accounts for very little of the runtime anyway.
+; The second phase creates the test problem, and tests to see
+; whether it is implied by the lemmas.
+
+(define (sboyer-benchmark . args)
+ (let ((n (if (null? args) 0 (car args))))
+ (setup-boyer)
+ (run-benchmark (string-append "sboyer"
+ (number->string n))
+ 1
+ (lambda () (test-boyer n))
+ (lambda (rewrites)
+ (and (number? rewrites)
+ (case n
+ ((0) (= rewrites 95024))
+ ((1) (= rewrites 591777))
+ ((2) (= rewrites 1813975))
+ ((3) (= rewrites 5375678))
+ ((4) (= rewrites 16445406))
+ ((5) (= rewrites 51507739))
+ ; If it works for n <= 5, assume it works.
+ (else #t)))))))
+
+(define (setup-boyer) #t) ; assigned below
+(define (test-boyer) #t) ; assigned below
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; The first phase.
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; In the original benchmark, it stored a list of lemmas on the
+; property lists of symbols.
+; In the new benchmark, it maintains an association list of
+; symbols and symbol-records, and stores the list of lemmas
+; within the symbol-records.
+
+(let ()
+
+ (define (setup)
+ (add-lemma-lst
+ (quote ((equal (compile form)
+ (reverse (codegen (optimize form)
+ (nil))))
+ (equal (eqp x y)
+ (equal (fix x)
+ (fix y)))
+ (equal (greaterp x y)
+ (lessp y x))
+ (equal (lesseqp x y)
+ (not (lessp y x)))
+ (equal (greatereqp x y)
+ (not (lessp x y)))
+ (equal (boolean x)
+ (or (equal x (t))
+ (equal x (f))))
+ (equal (iff x y)
+ (and (implies x y)
+ (implies y x)))
+ (equal (even1 x)
+ (if (zerop x)
+ (t)
+ (odd (sub1 x))))
+ (equal (countps- l pred)
+ (countps-loop l pred (zero)))
+ (equal (fact- i)
+ (fact-loop i 1))
+ (equal (reverse- x)
+ (reverse-loop x (nil)))
+ (equal (divides x y)
+ (zerop (remainder y x)))
+ (equal (assume-true var alist)
+ (cons (cons var (t))
+ alist))
+ (equal (assume-false var alist)
+ (cons (cons var (f))
+ alist))
+ (equal (tautology-checker x)
+ (tautologyp (normalize x)
+ (nil)))
+ (equal (falsify x)
+ (falsify1 (normalize x)
+ (nil)))
+ (equal (prime x)
+ (and (not (zerop x))
+ (not (equal x (add1 (zero))))
+ (prime1 x (sub1 x))))
+ (equal (and p q)
+ (if p (if q (t)
+ (f))
+ (f)))
+ (equal (or p q)
+ (if p (t)
+ (if q (t)
+ (f))))
+ (equal (not p)
+ (if p (f)
+ (t)))
+ (equal (implies p q)
+ (if p (if q (t)
+ (f))
+ (t)))
+ (equal (fix x)
+ (if (numberp x)
+ x
+ (zero)))
+ (equal (if (if a b c)
+ d e)
+ (if a (if b d e)
+ (if c d e)))
+ (equal (zerop x)
+ (or (equal x (zero))
+ (not (numberp x))))
+ (equal (plus (plus x y)
+ z)
+ (plus x (plus y z)))
+ (equal (equal (plus a b)
+ (zero))
+ (and (zerop a)
+ (zerop b)))
+ (equal (difference x x)
+ (zero))
+ (equal (equal (plus a b)
+ (plus a c))
+ (equal (fix b)
+ (fix c)))
+ (equal (equal (zero)
+ (difference x y))
+ (not (lessp y x)))
+ (equal (equal x (difference x y))
+ (and (numberp x)
+ (or (equal x (zero))
+ (zerop y))))
+ (equal (meaning (plus-tree (append x y))
+ a)
+ (plus (meaning (plus-tree x)
+ a)
+ (meaning (plus-tree y)
+ a)))
+ (equal (meaning (plus-tree (plus-fringe x))
+ a)
+ (fix (meaning x a)))
+ (equal (append (append x y)
+ z)
+ (append x (append y z)))
+ (equal (reverse (append a b))
+ (append (reverse b)
+ (reverse a)))
+ (equal (times x (plus y z))
+ (plus (times x y)
+ (times x z)))
+ (equal (times (times x y)
+ z)
+ (times x (times y z)))
+ (equal (equal (times x y)
+ (zero))
+ (or (zerop x)
+ (zerop y)))
+ (equal (exec (append x y)
+ pds envrn)
+ (exec y (exec x pds envrn)
+ envrn))
+ (equal (mc-flatten x y)
+ (append (flatten x)
+ y))
+ (equal (member x (append a b))
+ (or (member x a)
+ (member x b)))
+ (equal (member x (reverse y))
+ (member x y))
+ (equal (length (reverse x))
+ (length x))
+ (equal (member a (intersect b c))
+ (and (member a b)
+ (member a c)))
+ (equal (nth (zero)
+ i)
+ (zero))
+ (equal (exp i (plus j k))
+ (times (exp i j)
+ (exp i k)))
+ (equal (exp i (times j k))
+ (exp (exp i j)
+ k))
+ (equal (reverse-loop x y)
+ (append (reverse x)
+ y))
+ (equal (reverse-loop x (nil))
+ (reverse x))
+ (equal (count-list z (sort-lp x y))
+ (plus (count-list z x)
+ (count-list z y)))
+ (equal (equal (append a b)
+ (append a c))
+ (equal b c))
+ (equal (plus (remainder x y)
+ (times y (quotient x y)))
+ (fix x))
+ (equal (power-eval (big-plus1 l i base)
+ base)
+ (plus (power-eval l base)
+ i))
+ (equal (power-eval (big-plus x y i base)
+ base)
+ (plus i (plus (power-eval x base)
+ (power-eval y base))))
+ (equal (remainder y 1)
+ (zero))
+ (equal (lessp (remainder x y)
+ y)
+ (not (zerop y)))
+ (equal (remainder x x)
+ (zero))
+ (equal (lessp (quotient i j)
+ i)
+ (and (not (zerop i))
+ (or (zerop j)
+ (not (equal j 1)))))
+ (equal (lessp (remainder x y)
+ x)
+ (and (not (zerop y))
+ (not (zerop x))
+ (not (lessp x y))))
+ (equal (power-eval (power-rep i base)
+ base)
+ (fix i))
+ (equal (power-eval (big-plus (power-rep i base)
+ (power-rep j base)
+ (zero)
+ base)
+ base)
+ (plus i j))
+ (equal (gcd x y)
+ (gcd y x))
+ (equal (nth (append a b)
+ i)
+ (append (nth a i)
+ (nth b (difference i (length a)))))
+ (equal (difference (plus x y)
+ x)
+ (fix y))
+ (equal (difference (plus y x)
+ x)
+ (fix y))
+ (equal (difference (plus x y)
+ (plus x z))
+ (difference y z))
+ (equal (times x (difference c w))
+ (difference (times c x)
+ (times w x)))
+ (equal (remainder (times x z)
+ z)
+ (zero))
+ (equal (difference (plus b (plus a c))
+ a)
+ (plus b c))
+ (equal (difference (add1 (plus y z))
+ z)
+ (add1 y))
+ (equal (lessp (plus x y)
+ (plus x z))
+ (lessp y z))
+ (equal (lessp (times x z)
+ (times y z))
+ (and (not (zerop z))
+ (lessp x y)))
+ (equal (lessp y (plus x y))
+ (not (zerop x)))
+ (equal (gcd (times x z)
+ (times y z))
+ (times z (gcd x y)))
+ (equal (value (normalize x)
+ a)
+ (value x a))
+ (equal (equal (flatten x)
+ (cons y (nil)))
+ (and (nlistp x)
+ (equal x y)))
+ (equal (listp (gopher x))
+ (listp x))
+ (equal (samefringe x y)
+ (equal (flatten x)
+ (flatten y)))
+ (equal (equal (greatest-factor x y)
+ (zero))
+ (and (or (zerop y)
+ (equal y 1))
+ (equal x (zero))))
+ (equal (equal (greatest-factor x y)
+ 1)
+ (equal x 1))
+ (equal (numberp (greatest-factor x y))
+ (not (and (or (zerop y)
+ (equal y 1))
+ (not (numberp x)))))
+ (equal (times-list (append x y))
+ (times (times-list x)
+ (times-list y)))
+ (equal (prime-list (append x y))
+ (and (prime-list x)
+ (prime-list y)))
+ (equal (equal z (times w z))
+ (and (numberp z)
+ (or (equal z (zero))
+ (equal w 1))))
+ (equal (greatereqp x y)
+ (not (lessp x y)))
+ (equal (equal x (times x y))
+ (or (equal x (zero))
+ (and (numberp x)
+ (equal y 1))))
+ (equal (remainder (times y x)
+ y)
+ (zero))
+ (equal (equal (times a b)
+ 1)
+ (and (not (equal a (zero)))
+ (not (equal b (zero)))
+ (numberp a)
+ (numberp b)
+ (equal (sub1 a)
+ (zero))
+ (equal (sub1 b)
+ (zero))))
+ (equal (lessp (length (delete x l))
+ (length l))
+ (member x l))
+ (equal (sort2 (delete x l))
+ (delete x (sort2 l)))
+ (equal (dsort x)
+ (sort2 x))
+ (equal (length (cons x1
+ (cons x2
+ (cons x3 (cons x4
+ (cons x5
+ (cons x6 x7)))))))
+ (plus 6 (length x7)))
+ (equal (difference (add1 (add1 x))
+ 2)
+ (fix x))
+ (equal (quotient (plus x (plus x y))
+ 2)
+ (plus x (quotient y 2)))
+ (equal (sigma (zero)
+ i)
+ (quotient (times i (add1 i))
+ 2))
+ (equal (plus x (add1 y))
+ (if (numberp y)
+ (add1 (plus x y))
+ (add1 x)))
+ (equal (equal (difference x y)
+ (difference z y))
+ (if (lessp x y)
+ (not (lessp y z))
+ (if (lessp z y)
+ (not (lessp y x))
+ (equal (fix x)
+ (fix z)))))
+ (equal (meaning (plus-tree (delete x y))
+ a)
+ (if (member x y)
+ (difference (meaning (plus-tree y)
+ a)
+ (meaning x a))
+ (meaning (plus-tree y)
+ a)))
+ (equal (times x (add1 y))
+ (if (numberp y)
+ (plus x (times x y))
+ (fix x)))
+ (equal (nth (nil)
+ i)
+ (if (zerop i)
+ (nil)
+ (zero)))
+ (equal (last (append a b))
+ (if (listp b)
+ (last b)
+ (if (listp a)
+ (cons (car (last a))
+ b)
+ b)))
+ (equal (equal (lessp x y)
+ z)
+ (if (lessp x y)
+ (equal (t) z)
+ (equal (f) z)))
+ (equal (assignment x (append a b))
+ (if (assignedp x a)
+ (assignment x a)
+ (assignment x b)))
+ (equal (car (gopher x))
+ (if (listp x)
+ (car (flatten x))
+ (zero)))
+ (equal (flatten (cdr (gopher x)))
+ (if (listp x)
+ (cdr (flatten x))
+ (cons (zero)
+ (nil))))
+ (equal (quotient (times y x)
+ y)
+ (if (zerop y)
+ (zero)
+ (fix x)))
+ (equal (get j (set i val mem))
+ (if (eqp j i)
+ val
+ (get j mem)))))))
+
+ (define (add-lemma-lst lst)
+ (cond ((null? lst)
+ #t)
+ (else (add-lemma (car lst))
+ (add-lemma-lst (cdr lst)))))
+
+ (define (add-lemma term)
+ (cond ((and (pair? term)
+ (eq? (car term)
+ (quote equal))
+ (pair? (cadr term)))
+ (put (car (cadr term))
+ (quote lemmas)
+ (cons
+ (translate-term term)
+ (get (car (cadr term)) (quote lemmas)))))
+ (else (error "ADD-LEMMA did not like term: " term))))
+
+ ; Translates a term by replacing its constructor symbols by symbol-records.
+
+ (define (translate-term term)
+ (cond ((not (pair? term))
+ term)
+ (else (cons (symbol->symbol-record (car term))
+ (translate-args (cdr term))))))
+
+ (define (translate-args lst)
+ (cond ((null? lst)
+ '())
+ (else (cons (translate-term (car lst))
+ (translate-args (cdr lst))))))
+
+ ; For debugging only, so the use of MAP does not change
+ ; the first-order character of the benchmark.
+
+ (define (untranslate-term term)
+ (cond ((not (pair? term))
+ term)
+ (else (cons (get-name (car term))
+ (map untranslate-term (cdr term))))))
+
+ ; A symbol-record is represented as a vector with two fields:
+ ; the symbol (for debugging) and
+ ; the list of lemmas associated with the symbol.
+
+ (define (put sym property value)
+ (put-lemmas! (symbol->symbol-record sym) value))
+
+ (define (get sym property)
+ (get-lemmas (symbol->symbol-record sym)))
+
+ (define (symbol->symbol-record sym)
+ (let ((x (assq sym *symbol-records-alist*)))
+ (if x
+ (cdr x)
+ (let ((r (make-symbol-record sym)))
+ (set! *symbol-records-alist*
+ (cons (cons sym r)
+ *symbol-records-alist*))
+ r))))
+
+ ; Association list of symbols and symbol-records.
+
+ (define *symbol-records-alist* '())
+
+ ; A symbol-record is represented as a vector with two fields:
+ ; the symbol (for debugging) and
+ ; the list of lemmas associated with the symbol.
+
+ (define (make-symbol-record sym)
+ (vector sym '()))
+
+ (define (put-lemmas! symbol-record lemmas)
+ (vector-set! symbol-record 1 lemmas))
+
+ (define (get-lemmas symbol-record)
+ (vector-ref symbol-record 1))
+
+ (define (get-name symbol-record)
+ (vector-ref symbol-record 0))
+
+ (define (symbol-record-equal? r1 r2)
+ (eq? r1 r2))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ; The second phase.
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (test n)
+ (let ((term
+ (apply-subst
+ (translate-alist
+ (quote ((x f (plus (plus a b)
+ (plus c (zero))))
+ (y f (times (times a b)
+ (plus c d)))
+ (z f (reverse (append (append a b)
+ (nil))))
+ (u equal (plus a b)
+ (difference x y))
+ (w lessp (remainder a b)
+ (member a (length b))))))
+ (translate-term
+ (do ((term
+ (quote (implies (and (implies x y)
+ (and (implies y z)
+ (and (implies z u)
+ (implies u w))))
+ (implies x w)))
+ (list 'or term '(f)))
+ (n n (- n 1)))
+ ((zero? n) term))))))
+ (tautp term)))
+
+ (define (translate-alist alist)
+ (cond ((null? alist)
+ '())
+ (else (cons (cons (caar alist)
+ (translate-term (cdar alist)))
+ (translate-alist (cdr alist))))))
+
+ (define (apply-subst alist term)
+ (cond ((not (pair? term))
+ (let ((temp-temp (assq term alist)))
+ (if temp-temp
+ (cdr temp-temp)
+ term)))
+ (else (cons (car term)
+ (apply-subst-lst alist (cdr term))))))
+
+ (define (apply-subst-lst alist lst)
+ (cond ((null? lst)
+ '())
+ (else (cons (apply-subst alist (car lst))
+ (apply-subst-lst alist (cdr lst))))))
+
+ (define (tautp x)
+ (tautologyp (rewrite x)
+ '() '()))
+
+ (define (tautologyp x true-lst false-lst)
+ (cond ((truep x true-lst)
+ #t)
+ ((falsep x false-lst)
+ #f)
+ ((not (pair? x))
+ #f)
+ ((eq? (car x) if-constructor)
+ (cond ((truep (cadr x)
+ true-lst)
+ (tautologyp (caddr x)
+ true-lst false-lst))
+ ((falsep (cadr x)
+ false-lst)
+ (tautologyp (cadddr x)
+ true-lst false-lst))
+ (else (and (tautologyp (caddr x)
+ (cons (cadr x)
+ true-lst)
+ false-lst)
+ (tautologyp (cadddr x)
+ true-lst
+ (cons (cadr x)
+ false-lst))))))
+ (else #f)))
+
+ (define if-constructor '*) ; becomes (symbol->symbol-record 'if)
+
+ (define rewrite-count 0) ; sanity check
+
+ ; The next procedure is Henry Baker's sharing CONS, which avoids
+ ; allocation if the result is already in hand.
+ ; The REWRITE and REWRITE-ARGS procedures have been modified to
+ ; use SCONS instead of CONS.
+
+ (define (scons x y original)
+ (if (and (eq? x (car original))
+ (eq? y (cdr original)))
+ original
+ (cons x y)))
+
+ (define (rewrite term)
+ (set! rewrite-count (+ rewrite-count 1))
+ (cond ((not (pair? term))
+ term)
+ (else (rewrite-with-lemmas (scons (car term)
+ (rewrite-args (cdr term))
+ term)
+ (get-lemmas (car term))))))
+
+ (define (rewrite-args lst)
+ (cond ((null? lst)
+ '())
+ (else (scons (rewrite (car lst))
+ (rewrite-args (cdr lst))
+ lst))))
+
+ (define (rewrite-with-lemmas term lst)
+ (cond ((null? lst)
+ term)
+ ((one-way-unify term (cadr (car lst)))
+ (rewrite (apply-subst unify-subst (caddr (car lst)))))
+ (else (rewrite-with-lemmas term (cdr lst)))))
+
+ (define unify-subst '*)
+
+ (define (one-way-unify term1 term2)
+ (begin (set! unify-subst '())
+ (one-way-unify1 term1 term2)))
+
+ (define (one-way-unify1 term1 term2)
+ (cond ((not (pair? term2))
+ (let ((temp-temp (assq term2 unify-subst)))
+ (cond (temp-temp
+ (term-equal? term1 (cdr temp-temp)))
+ ((number? term2) ; This bug fix makes
+ (equal? term1 term2)) ; nboyer 10-25% slower!
+ (else
+ (set! unify-subst (cons (cons term2 term1)
+ unify-subst))
+ #t))))
+ ((not (pair? term1))
+ #f)
+ ((eq? (car term1)
+ (car term2))
+ (one-way-unify1-lst (cdr term1)
+ (cdr term2)))
+ (else #f)))
+
+ (define (one-way-unify1-lst lst1 lst2)
+ (cond ((null? lst1)
+ (null? lst2))
+ ((null? lst2)
+ #f)
+ ((one-way-unify1 (car lst1)
+ (car lst2))
+ (one-way-unify1-lst (cdr lst1)
+ (cdr lst2)))
+ (else #f)))
+
+ (define (falsep x lst)
+ (or (term-equal? x false-term)
+ (term-member? x lst)))
+
+ (define (truep x lst)
+ (or (term-equal? x true-term)
+ (term-member? x lst)))
+
+ (define false-term '*) ; becomes (translate-term '(f))
+ (define true-term '*) ; becomes (translate-term '(t))
+
+ ; The next two procedures were in the original benchmark
+ ; but were never used.
+
+ (define (trans-of-implies n)
+ (translate-term
+ (list (quote implies)
+ (trans-of-implies1 n)
+ (list (quote implies)
+ 0 n))))
+
+ (define (trans-of-implies1 n)
+ (cond ((equal? n 1)
+ (list (quote implies)
+ 0 1))
+ (else (list (quote and)
+ (list (quote implies)
+ (- n 1)
+ n)
+ (trans-of-implies1 (- n 1))))))
+
+ ; Translated terms can be circular structures, which can't be
+ ; compared using Scheme's equal? and member procedures, so we
+ ; use these instead.
+
+ (define (term-equal? x y)
+ (cond ((pair? x)
+ (and (pair? y)
+ (symbol-record-equal? (car x) (car y))
+ (term-args-equal? (cdr x) (cdr y))))
+ (else (equal? x y))))
+
+ (define (term-args-equal? lst1 lst2)
+ (cond ((null? lst1)
+ (null? lst2))
+ ((null? lst2)
+ #f)
+ ((term-equal? (car lst1) (car lst2))
+ (term-args-equal? (cdr lst1) (cdr lst2)))
+ (else #f)))
+
+ (define (term-member? x lst)
+ (cond ((null? lst)
+ #f)
+ ((term-equal? x (car lst))
+ #t)
+ (else (term-member? x (cdr lst)))))
+
+ (set! setup-boyer
+ (lambda ()
+ (set! *symbol-records-alist* '())
+ (set! if-constructor (symbol->symbol-record 'if))
+ (set! false-term (translate-term '(f)))
+ (set! true-term (translate-term '(t)))
+ (setup)))
+
+ (set! test-boyer
+ (lambda (n)
+ (set! rewrite-count 0)
+ (let ((answer (test n)))
+ (write rewrite-count)
+ (display " rewrites")
+ (newline)
+ (if answer
+ rewrite-count
+ #f)))))
--- /dev/null
+; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;
+; Packaged as a single file for Larceny by Lars T Hansen.
+; Modified 2000-02-15 by lth.
+;
+; Compilation notes.
+;
+; The macro definitions for MATCH in this file depend on the presence of
+; certain helper functions in the compilation environment, eg. match:andmap.
+; (That is not a problem when loading this file, but it is an issue when
+; compiling it.) The easiest way to provide the helper functions during
+; compilation is to load match.sch into the compilation environment before
+; compiling.
+;
+; Once compiled, this program is self-contained.
+
+; The SoftScheme benchmark performs soft typing on a program and prints
+; a diagnostic report. All screen output is captured in an output
+; string port, which is subsequently discarded. (There is a moderate
+; amount of output). No file I/O occurs while the program is running.
+
+(define (softscheme-benchmark)
+ (let ((expr `(begin ,@(readfile "ss-input.scm")))
+ (out (open-output-string)))
+ (run-benchmark "softscheme"
+ (lambda ()
+ (with-output-to-port out
+ (lambda ()
+ (soft-def expr #f)))))
+ (newline)
+ (display (string-length (get-output-string out)))
+ (display " characters of output written.")
+ (newline)))
+
+;;; Define defmacro, macro?, and macroexpand-1.
+
+(define *macros* '())
+
+(define-syntax
+ defmacro
+ (transformer
+ (lambda (exp rename compare)
+ (define (arglist? x)
+ (or (symbol? x)
+ (null? x)
+ (and (pair? x)
+ (symbol? (car x))
+ (arglist? (cdr x)))))
+ (if (not (and (list? exp)
+ (>= (length exp) 4)
+ (symbol? (cadr exp))
+ (arglist? (caddr exp))))
+ (error "Bad macro definition: " exp))
+ (let ((name (cadr exp))
+ (args (caddr exp))
+ (body (cdddr exp)))
+ `(begin
+ (define-syntax
+ ,name
+ (transformer
+ (lambda (_defmacro_exp
+ _defmacro_rename
+ _defmacro_compare)
+ (apply (lambda ,args ,@body) (cdr _defmacro_exp)))))
+ (set! *macros*
+ (cons (cons ',name
+ (lambda (_exp)
+ (apply (lambda ,args ,@body) (cdr _exp))))
+ *macros*))
+ )))))
+
+(define (macroexpand-1 exp)
+ (cond ((pair? exp)
+ (let ((probe (assq (car exp) *macros*)))
+ (if probe ((cdr probe) exp) exp)))
+ (else exp)))
+
+(define (macro? keyword)
+ (and (symbol? keyword) (assq keyword *macros*)))
+
+;;; Other compatibility hacks
+
+(define slib:error error)
+
+(define force-output flush-output-port)
+
+(define format
+ (let ((format format))
+ (lambda (port . rest)
+ (if (not port)
+ (let ((s (open-output-string)))
+ (apply format s rest)
+ (get-output-string s))
+ (apply format port rest)))))
+
+(define gentemp
+ (let ((gensym gensym)) (lambda () (gensym "G"))))
+
+(define getenv
+ (let ((getenv getenv))
+ (lambda (x)
+ (or (getenv x)
+ (if (string=? x "HOME")
+ "Ertevann:Desktop folder:"
+ #f)))))
+
+;;; The rest of the file should be more or less portable.
+
+(define match-file #f)
+(define installation-directory #f)
+(define customization-file #f)
+(define fastlibrary-file #f)
+(define st:version
+ "Larceny Version 0.18, April 21, 1995")
+(define match:version
+ "Version 1.18, July 17, 1995")
+(define match:error
+ (lambda (val . args)
+ (for-each pretty-print args)
+ (slib:error "no matching clause for " val)))
+(define match:andmap
+ (lambda (f l)
+ (if (null? l)
+ (and)
+ (and (f (car l)) (match:andmap f (cdr l))))))
+(define match:syntax-err
+ (lambda (obj msg) (slib:error msg obj)))
+(define match:disjoint-structure-tags '())
+(define match:make-structure-tag
+ (lambda (name)
+ (if (or (eq? match:structure-control 'disjoint)
+ match:runtime-structures)
+ (let ((tag (gentemp)))
+ (set! match:disjoint-structure-tags
+ (cons tag match:disjoint-structure-tags))
+ tag)
+ (string->symbol
+ (string-append "<" (symbol->string name) ">")))))
+(define match:structure?
+ (lambda (tag)
+ (memq tag match:disjoint-structure-tags)))
+(define match:structure-control 'vector)
+(define match:set-structure-control
+ (lambda (v) (set! match:structure-control v)))
+(define match:set-error
+ (lambda (v) (set! match:error v)))
+(define match:error-control 'error)
+(define match:set-error-control
+ (lambda (v) (set! match:error-control v)))
+(define match:disjoint-predicates
+ (cons 'null
+ '(pair? symbol?
+ boolean?
+ number?
+ string?
+ char?
+ procedure?
+ vector?)))
+(define match:vector-structures '())
+(define match:expanders
+ (letrec ((genmatch
+ (lambda (x clauses match-expr)
+ (let* ((length>= (gentemp))
+ (eb-errf (error-maker match-expr))
+ (blist (car eb-errf))
+ (plist (map (lambda (c)
+ (let* ((x (bound (validate-pattern
+ (car c))))
+ (p (car x))
+ (bv (cadr x))
+ (bindings (caddr x))
+ (code (gentemp))
+ (fail (and (pair? (cdr c))
+ (pair? (cadr c))
+ (eq? (caadr c) '=>)
+ (symbol? (cadadr c))
+ (pair? (cdadr c))
+ (null? (cddadr c))
+ (pair? (cddr c))
+ (cadadr c)))
+ (bv2 (if fail (cons fail bv) bv))
+ (body (if fail (cddr c) (cdr c))))
+ (set! blist
+ (cons `(,code (lambda ,bv2 ,@body))
+ (append bindings blist)))
+ (list p
+ code
+ bv
+ (and fail (gentemp))
+ #f)))
+ clauses))
+ (code (gen x
+ '()
+ plist
+ (cdr eb-errf)
+ length>=
+ (gentemp))))
+ (unreachable plist match-expr)
+ (inline-let
+ `(let ((,length>=
+ (lambda (n) (lambda (l) (>= (length l) n))))
+ ,@blist)
+ ,code)))))
+ (genletrec
+ (lambda (pat exp body match-expr)
+ (let* ((length>= (gentemp))
+ (eb-errf (error-maker match-expr))
+ (x (bound (validate-pattern pat)))
+ (p (car x))
+ (bv (cadr x))
+ (bindings (caddr x))
+ (code (gentemp))
+ (plist (list (list p code bv #f #f)))
+ (x (gentemp))
+ (m (gen x
+ '()
+ plist
+ (cdr eb-errf)
+ length>=
+ (gentemp)))
+ (gs (map (lambda (_) (gentemp)) bv)))
+ (unreachable plist match-expr)
+ `(letrec ((,length>=
+ (lambda (n) (lambda (l) (>= (length l) n))))
+ ,@(map (lambda (v) `(,v #f)) bv)
+ (,x ,exp)
+ (,code
+ (lambda ,gs
+ ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+ ,@body))
+ ,@bindings
+ ,@(car eb-errf))
+ ,m))))
+ (gendefine
+ (lambda (pat exp match-expr)
+ (let* ((length>= (gentemp))
+ (eb-errf (error-maker match-expr))
+ (x (bound (validate-pattern pat)))
+ (p (car x))
+ (bv (cadr x))
+ (bindings (caddr x))
+ (code (gentemp))
+ (plist (list (list p code bv #f #f)))
+ (x (gentemp))
+ (m (gen x
+ '()
+ plist
+ (cdr eb-errf)
+ length>=
+ (gentemp)))
+ (gs (map (lambda (_) (gentemp)) bv)))
+ (unreachable plist match-expr)
+ `(begin
+ ,@(map (lambda (v) `(define ,v #f)) bv)
+ ,(inline-let
+ `(let ((,length>=
+ (lambda (n) (lambda (l) (>= (length l) n))))
+ (,x ,exp)
+ (,code
+ (lambda ,gs
+ ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
+ (cond (#f #f))))
+ ,@bindings
+ ,@(car eb-errf))
+ ,m))))))
+ (pattern-var?
+ (lambda (x)
+ (and (symbol? x)
+ (not (dot-dot-k? x))
+ (not (memq x
+ '(quasiquote
+ quote
+ unquote
+ unquote-splicing
+ ?
+ _
+ $
+ =
+ and
+ or
+ not
+ set!
+ get!
+ ...
+ ___))))))
+ (dot-dot-k?
+ (lambda (s)
+ (and (symbol? s)
+ (if (memq s '(... ___))
+ 0
+ (let* ((s (symbol->string s)) (n (string-length s)))
+ (and (<= 3 n)
+ (memq (string-ref s 0) '(#\. #\_))
+ (memq (string-ref s 1) '(#\. #\_))
+ (match:andmap
+ char-numeric?
+ (string->list (substring s 2 n)))
+ (string->number (substring s 2 n))))))))
+ (error-maker
+ (lambda (match-expr)
+ (cond ((eq? match:error-control 'unspecified)
+ (cons '() (lambda (x) `(cond (#f #f)))))
+ ((memq match:error-control '(error fail))
+ (cons '() (lambda (x) `(match:error ,x))))
+ ((eq? match:error-control 'match)
+ (let ((errf (gentemp)) (arg (gentemp)))
+ (cons `((,errf
+ (lambda (,arg)
+ (match:error ,arg ',match-expr))))
+ (lambda (x) `(,errf ,x)))))
+ (else
+ (match:syntax-err
+ '(unspecified error fail match)
+ "invalid value for match:error-control, legal values are")))))
+ (unreachable
+ (lambda (plist match-expr)
+ (for-each
+ (lambda (x)
+ (if (not (car (cddddr x)))
+ (begin
+ (display "Warning: unreachable pattern ")
+ (display (car x))
+ (display " in ")
+ (display match-expr)
+ (newline))))
+ plist)))
+ (validate-pattern
+ (lambda (pattern)
+ (letrec ((simple?
+ (lambda (x)
+ (or (string? x)
+ (boolean? x)
+ (char? x)
+ (number? x)
+ (null? x))))
+ (ordinary
+ (lambda (p)
+ (let ((g88 (lambda (x y)
+ (cons (ordinary x) (ordinary y)))))
+ (if (simple? p)
+ ((lambda (p) p) p)
+ (if (equal? p '_)
+ ((lambda () '_))
+ (if (pattern-var? p)
+ ((lambda (p) p) p)
+ (if (pair? p)
+ (if (equal? (car p) 'quasiquote)
+ (if (and (pair? (cdr p))
+ (null? (cddr p)))
+ ((lambda (p) (quasi p)) (cadr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) 'quote)
+ (if (and (pair? (cdr p))
+ (null? (cddr p)))
+ ((lambda (p) p) p)
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) '?)
+ (if (and (pair? (cdr p))
+ (list? (cddr p)))
+ ((lambda (pred ps)
+ `(? ,pred
+ ,@(map ordinary ps)))
+ (cadr p)
+ (cddr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) '=)
+ (if (and (pair? (cdr p))
+ (pair? (cddr p))
+ (null? (cdddr p)))
+ ((lambda (sel p)
+ `(= ,sel ,(ordinary p)))
+ (cadr p)
+ (caddr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) 'and)
+ (if (and (list? (cdr p))
+ (pair? (cdr p)))
+ ((lambda (ps)
+ `(and ,@(map ordinary
+ ps)))
+ (cdr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) 'or)
+ (if (and (list? (cdr p))
+ (pair? (cdr p)))
+ ((lambda (ps)
+ `(or ,@(map ordinary
+ ps)))
+ (cdr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) 'not)
+ (if (and (list? (cdr p))
+ (pair? (cdr p)))
+ ((lambda (ps)
+ `(not ,@(map ordinary
+ ps)))
+ (cdr p))
+ (g88 (car p) (cdr p)))
+ (if (equal? (car p) '$)
+ (if (and (pair? (cdr p))
+ (symbol?
+ (cadr p))
+ (list? (cddr p)))
+ ((lambda (r ps)
+ `($ ,r
+ ,@(map ordinary
+ ps)))
+ (cadr p)
+ (cddr p))
+ (g88 (car p) (cdr p)))
+ (if (equal?
+ (car p)
+ 'set!)
+ (if (and (pair? (cdr p))
+ (pattern-var?
+ (cadr p))
+ (null? (cddr p)))
+ ((lambda (p) p) p)
+ (g88 (car p)
+ (cdr p)))
+ (if (equal?
+ (car p)
+ 'get!)
+ (if (and (pair? (cdr p))
+ (pattern-var?
+ (cadr p))
+ (null? (cddr p)))
+ ((lambda (p) p) p)
+ (g88 (car p)
+ (cdr p)))
+ (if (equal?
+ (car p)
+ 'unquote)
+ (g88 (car p)
+ (cdr p))
+ (if (equal?
+ (car p)
+ 'unquote-splicing)
+ (g88 (car p)
+ (cdr p))
+ (if (and (pair? (cdr p))
+ (dot-dot-k?
+ (cadr p))
+ (null? (cddr p)))
+ ((lambda (p
+ ddk)
+ `(,(ordinary
+ p)
+ ,ddk))
+ (car p)
+ (cadr p))
+ (g88 (car p)
+ (cdr p)))))))))))))))
+ (if (vector? p)
+ ((lambda (p)
+ (let* ((pl (vector->list p))
+ (rpl (reverse pl)))
+ (apply vector
+ (if (and (not (null? rpl))
+ (dot-dot-k?
+ (car rpl)))
+ (reverse
+ (cons (car rpl)
+ (map ordinary
+ (cdr rpl))))
+ (map ordinary pl)))))
+ p)
+ ((lambda ()
+ (match:syntax-err
+ pattern
+ "syntax error in pattern")))))))))))
+ (quasi (lambda (p)
+ (let ((g109 (lambda (x y)
+ (cons (quasi x) (quasi y)))))
+ (if (simple? p)
+ ((lambda (p) p) p)
+ (if (symbol? p)
+ ((lambda (p) `',p) p)
+ (if (pair? p)
+ (if (equal? (car p) 'unquote)
+ (if (and (pair? (cdr p))
+ (null? (cddr p)))
+ ((lambda (p) (ordinary p))
+ (cadr p))
+ (g109 (car p) (cdr p)))
+ (if (and (pair? (car p))
+ (equal?
+ (caar p)
+ 'unquote-splicing)
+ (pair? (cdar p))
+ (null? (cddar p)))
+ (if (null? (cdr p))
+ ((lambda (p) (ordinary p))
+ (cadar p))
+ ((lambda (p y)
+ (append
+ (ordlist p)
+ (quasi y)))
+ (cadar p)
+ (cdr p)))
+ (if (and (pair? (cdr p))
+ (dot-dot-k? (cadr p))
+ (null? (cddr p)))
+ ((lambda (p ddk)
+ `(,(quasi p) ,ddk))
+ (car p)
+ (cadr p))
+ (g109 (car p) (cdr p)))))
+ (if (vector? p)
+ ((lambda (p)
+ (let* ((pl (vector->list p))
+ (rpl (reverse pl)))
+ (apply vector
+ (if (dot-dot-k?
+ (car rpl))
+ (reverse
+ (cons (car rpl)
+ (map quasi
+ (cdr rpl))))
+ (map ordinary pl)))))
+ p)
+ ((lambda ()
+ (match:syntax-err
+ pattern
+ "syntax error in pattern"))))))))))
+ (ordlist
+ (lambda (p)
+ (cond ((null? p) '())
+ ((pair? p)
+ (cons (ordinary (car p)) (ordlist (cdr p))))
+ (else
+ (match:syntax-err
+ pattern
+ "invalid use of unquote-splicing in pattern"))))))
+ (ordinary pattern))))
+ (bound (lambda (pattern)
+ (letrec ((pred-bodies '())
+ (bound (lambda (p a k)
+ (cond ((eq? '_ p) (k p a))
+ ((symbol? p)
+ (if (memq p a)
+ (match:syntax-err
+ pattern
+ "duplicate variable in pattern"))
+ (k p (cons p a)))
+ ((and (pair? p)
+ (eq? 'quote (car p)))
+ (k p a))
+ ((and (pair? p) (eq? '? (car p)))
+ (cond ((not (null? (cddr p)))
+ (bound `(and (? ,(cadr p))
+ ,@(cddr p))
+ a
+ k))
+ ((or (not (symbol?
+ (cadr p)))
+ (memq (cadr p) a))
+ (let ((g (gentemp)))
+ (set! pred-bodies
+ (cons `(,g ,(cadr p))
+ pred-bodies))
+ (k `(? ,g) a)))
+ (else (k p a))))
+ ((and (pair? p) (eq? '= (car p)))
+ (cond ((or (not (symbol?
+ (cadr p)))
+ (memq (cadr p) a))
+ (let ((g (gentemp)))
+ (set! pred-bodies
+ (cons `(,g ,(cadr p))
+ pred-bodies))
+ (bound `(= ,g ,(caddr p))
+ a
+ k)))
+ (else
+ (bound (caddr p)
+ a
+ (lambda (p2 a)
+ (k `(= ,(cadr p)
+ ,p2)
+ a))))))
+ ((and (pair? p) (eq? 'and (car p)))
+ (bound*
+ (cdr p)
+ a
+ (lambda (p a)
+ (k `(and ,@p) a))))
+ ((and (pair? p) (eq? 'or (car p)))
+ (bound (cadr p)
+ a
+ (lambda (first-p first-a)
+ (let or* ((plist (cddr p))
+ (k (lambda (plist)
+ (k `(or ,first-p
+ ,@plist)
+ first-a))))
+ (if (null? plist)
+ (k plist)
+ (bound (car plist)
+ a
+ (lambda (car-p
+ car-a)
+ (if (not (permutation
+ car-a
+ first-a))
+ (match:syntax-err
+ pattern
+ "variables of or-pattern differ in"))
+ (or* (cdr plist)
+ (lambda (cdr-p)
+ (k (cons car-p
+ cdr-p)))))))))))
+ ((and (pair? p) (eq? 'not (car p)))
+ (cond ((not (null? (cddr p)))
+ (bound `(not (or ,@(cdr p)))
+ a
+ k))
+ (else
+ (bound (cadr p)
+ a
+ (lambda (p2 a2)
+ (if (not (permutation
+ a
+ a2))
+ (match:syntax-err
+ p
+ "no variables allowed in"))
+ (k `(not ,p2)
+ a))))))
+ ((and (pair? p)
+ (pair? (cdr p))
+ (dot-dot-k? (cadr p)))
+ (bound (car p)
+ a
+ (lambda (q b)
+ (let ((bvars (find-prefix
+ b
+ a)))
+ (k `(,q
+ ,(cadr p)
+ ,bvars
+ ,(gentemp)
+ ,(gentemp)
+ ,(map (lambda (_)
+ (gentemp))
+ bvars))
+ b)))))
+ ((and (pair? p) (eq? '$ (car p)))
+ (bound*
+ (cddr p)
+ a
+ (lambda (p1 a)
+ (k `($ ,(cadr p) ,@p1) a))))
+ ((and (pair? p)
+ (eq? 'set! (car p)))
+ (if (memq (cadr p) a)
+ (k p a)
+ (k p (cons (cadr p) a))))
+ ((and (pair? p)
+ (eq? 'get! (car p)))
+ (if (memq (cadr p) a)
+ (k p a)
+ (k p (cons (cadr p) a))))
+ ((pair? p)
+ (bound (car p)
+ a
+ (lambda (car-p a)
+ (bound (cdr p)
+ a
+ (lambda (cdr-p a)
+ (k (cons car-p
+ cdr-p)
+ a))))))
+ ((vector? p)
+ (boundv
+ (vector->list p)
+ a
+ (lambda (pl a)
+ (k (list->vector pl) a))))
+ (else (k p a)))))
+ (boundv
+ (lambda (plist a k)
+ (let ((g115 (lambda () (k plist a))))
+ (if (pair? plist)
+ (if (and (pair? (cdr plist))
+ (dot-dot-k? (cadr plist))
+ (null? (cddr plist)))
+ ((lambda () (bound plist a k)))
+ (if (null? plist)
+ (g115)
+ ((lambda (x y)
+ (bound x
+ a
+ (lambda (car-p a)
+ (boundv
+ y
+ a
+ (lambda (cdr-p a)
+ (k (cons car-p cdr-p)
+ a))))))
+ (car plist)
+ (cdr plist))))
+ (if (null? plist)
+ (g115)
+ (match:error plist))))))
+ (bound*
+ (lambda (plist a k)
+ (if (null? plist)
+ (k plist a)
+ (bound (car plist)
+ a
+ (lambda (car-p a)
+ (bound*
+ (cdr plist)
+ a
+ (lambda (cdr-p a)
+ (k (cons car-p cdr-p) a))))))))
+ (find-prefix
+ (lambda (b a)
+ (if (eq? b a)
+ '()
+ (cons (car b) (find-prefix (cdr b) a)))))
+ (permutation
+ (lambda (p1 p2)
+ (and (= (length p1) (length p2))
+ (match:andmap
+ (lambda (x1) (memq x1 p2))
+ p1)))))
+ (bound pattern
+ '()
+ (lambda (p a)
+ (list p (reverse a) pred-bodies))))))
+ (inline-let
+ (lambda (let-exp)
+ (letrec ((occ (lambda (x e)
+ (let loop ((e e))
+ (cond ((pair? e)
+ (+ (loop (car e)) (loop (cdr e))))
+ ((eq? x e) 1)
+ (else 0)))))
+ (subst (lambda (e old new)
+ (let loop ((e e))
+ (cond ((pair? e)
+ (cons (loop (car e)) (loop (cdr e))))
+ ((eq? old e) new)
+ (else e)))))
+ (const?
+ (lambda (sexp)
+ (or (symbol? sexp)
+ (boolean? sexp)
+ (string? sexp)
+ (char? sexp)
+ (number? sexp)
+ (null? sexp)
+ (and (pair? sexp)
+ (eq? (car sexp) 'quote)
+ (pair? (cdr sexp))
+ (symbol? (cadr sexp))
+ (null? (cddr sexp))))))
+ (isval?
+ (lambda (sexp)
+ (or (const? sexp)
+ (and (pair? sexp)
+ (memq (car sexp)
+ '(lambda quote
+ match-lambda
+ match-lambda*))))))
+ (small?
+ (lambda (sexp)
+ (or (const? sexp)
+ (and (pair? sexp)
+ (eq? (car sexp) 'lambda)
+ (pair? (cdr sexp))
+ (pair? (cddr sexp))
+ (const? (caddr sexp))
+ (null? (cdddr sexp)))))))
+ (let loop ((b (cadr let-exp))
+ (new-b '())
+ (e (caddr let-exp)))
+ (cond ((null? b)
+ (if (null? new-b) e `(let ,(reverse new-b) ,e)))
+ ((isval? (cadr (car b)))
+ (let* ((x (caar b)) (n (occ x e)))
+ (cond ((= 0 n) (loop (cdr b) new-b e))
+ ((or (= 1 n) (small? (cadr (car b))))
+ (loop (cdr b)
+ new-b
+ (subst e x (cadr (car b)))))
+ (else
+ (loop (cdr b) (cons (car b) new-b) e)))))
+ (else (loop (cdr b) (cons (car b) new-b) e)))))))
+ (gen (lambda (x sf plist erract length>= eta)
+ (if (null? plist)
+ (erract x)
+ (let* ((v '())
+ (val (lambda (x) (cdr (assq x v))))
+ (fail (lambda (sf)
+ (gen x sf (cdr plist) erract length>= eta)))
+ (success
+ (lambda (sf)
+ (set-car! (cddddr (car plist)) #t)
+ (let* ((code (cadr (car plist)))
+ (bv (caddr (car plist)))
+ (fail-sym (cadddr (car plist))))
+ (if fail-sym
+ (let ((ap `(,code
+ ,fail-sym
+ ,@(map val bv))))
+ `(call-with-current-continuation
+ (lambda (,fail-sym)
+ (let ((,fail-sym
+ (lambda ()
+ (,fail-sym ,(fail sf)))))
+ ,ap))))
+ `(,code ,@(map val bv)))))))
+ (let next ((p (caar plist))
+ (e x)
+ (sf sf)
+ (kf fail)
+ (ks success))
+ (cond ((eq? '_ p) (ks sf))
+ ((symbol? p)
+ (set! v (cons (cons p e) v))
+ (ks sf))
+ ((null? p) (emit `(null? ,e) sf kf ks))
+ ((equal? p ''()) (emit `(null? ,e) sf kf ks))
+ ((string? p) (emit `(equal? ,e ,p) sf kf ks))
+ ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
+ ((char? p) (emit `(equal? ,e ,p) sf kf ks))
+ ((number? p) (emit `(equal? ,e ,p) sf kf ks))
+ ((and (pair? p) (eq? 'quote (car p)))
+ (emit `(equal? ,e ,p) sf kf ks))
+ ((and (pair? p) (eq? '? (car p)))
+ (let ((tst `(,(cadr p) ,e)))
+ (emit tst sf kf ks)))
+ ((and (pair? p) (eq? '= (car p)))
+ (next (caddr p) `(,(cadr p) ,e) sf kf ks))
+ ((and (pair? p) (eq? 'and (car p)))
+ (let loop ((p (cdr p)) (sf sf))
+ (if (null? p)
+ (ks sf)
+ (next (car p)
+ e
+ sf
+ kf
+ (lambda (sf) (loop (cdr p) sf))))))
+ ((and (pair? p) (eq? 'or (car p)))
+ (let ((or-v v))
+ (let loop ((p (cdr p)) (sf sf))
+ (if (null? p)
+ (kf sf)
+ (begin
+ (set! v or-v)
+ (next (car p)
+ e
+ sf
+ (lambda (sf) (loop (cdr p) sf))
+ ks))))))
+ ((and (pair? p) (eq? 'not (car p)))
+ (next (cadr p) e sf ks kf))
+ ((and (pair? p) (eq? '$ (car p)))
+ (let* ((tag (cadr p))
+ (fields (cdr p))
+ (rlen (length fields))
+ (tst `(,(symbol-append tag '?) ,e)))
+ (emit tst
+ sf
+ kf
+ (let rloop ((n 1))
+ (lambda (sf)
+ (if (= n rlen)
+ (ks sf)
+ (next (list-ref fields n)
+ `(,(symbol-append tag '- n)
+ ,e)
+ sf
+ kf
+ (rloop (+ 1 n)))))))))
+ ((and (pair? p) (eq? 'set! (car p)))
+ (set! v (cons (cons (cadr p) (setter e p)) v))
+ (ks sf))
+ ((and (pair? p) (eq? 'get! (car p)))
+ (set! v (cons (cons (cadr p) (getter e p)) v))
+ (ks sf))
+ ((and (pair? p)
+ (pair? (cdr p))
+ (dot-dot-k? (cadr p)))
+ (emit `(list? ,e)
+ sf
+ kf
+ (lambda (sf)
+ (let* ((k (dot-dot-k? (cadr p)))
+ (ks (lambda (sf)
+ (let ((bound (list-ref
+ p
+ 2)))
+ (cond ((eq? (car p) '_)
+ (ks sf))
+ ((null? bound)
+ (let* ((ptst (next (car p)
+ eta
+ sf
+ (lambda (sf)
+ #f)
+ (lambda (sf)
+ #t)))
+ (tst (if (and (pair? ptst)
+ (symbol?
+ (car ptst))
+ (pair? (cdr ptst))
+ (eq? eta
+ (cadr ptst))
+ (null? (cddr ptst)))
+ (car ptst)
+ `(lambda (,eta)
+ ,ptst))))
+ (assm `(match:andmap
+ ,tst
+ ,e)
+ (kf sf)
+ (ks sf))))
+ ((and (symbol?
+ (car p))
+ (equal?
+ (list (car p))
+ bound))
+ (next (car p)
+ e
+ sf
+ kf
+ ks))
+ (else
+ (let* ((gloop (list-ref
+ p
+ 3))
+ (ge (list-ref
+ p
+ 4))
+ (fresh (list-ref
+ p
+ 5))
+ (p1 (next (car p)
+ `(car ,ge)
+ sf
+ kf
+ (lambda (sf)
+ `(,gloop
+ (cdr ,ge)
+ ,@(map (lambda (b
+ f)
+ `(cons ,(val b)
+ ,f))
+ bound
+ fresh))))))
+ (set! v
+ (append
+ (map cons
+ bound
+ (map (lambda (x)
+ `(reverse
+ ,x))
+ fresh))
+ v))
+ `(let ,gloop
+ ((,ge ,e)
+ ,@(map (lambda (x)
+ `(,x
+ '()))
+ fresh))
+ (if (null? ,ge)
+ ,(ks sf)
+ ,p1)))))))))
+ (case k
+ ((0) (ks sf))
+ ((1) (emit `(pair? ,e) sf kf ks))
+ (else
+ (emit `((,length>= ,k) ,e)
+ sf
+ kf
+ ks)))))))
+ ((pair? p)
+ (emit `(pair? ,e)
+ sf
+ kf
+ (lambda (sf)
+ (next (car p)
+ (add-a e)
+ sf
+ kf
+ (lambda (sf)
+ (next (cdr p)
+ (add-d e)
+ sf
+ kf
+ ks))))))
+ ((and (vector? p)
+ (>= (vector-length p) 6)
+ (dot-dot-k?
+ (vector-ref p (- (vector-length p) 5))))
+ (let* ((vlen (- (vector-length p) 6))
+ (k (dot-dot-k?
+ (vector-ref p (+ vlen 1))))
+ (minlen (+ vlen k))
+ (bound (vector-ref p (+ vlen 2))))
+ (emit `(vector? ,e)
+ sf
+ kf
+ (lambda (sf)
+ (assm `(>= (vector-length ,e) ,minlen)
+ (kf sf)
+ ((let vloop ((n 0))
+ (lambda (sf)
+ (cond ((not (= n vlen))
+ (next (vector-ref
+ p
+ n)
+ `(vector-ref
+ ,e
+ ,n)
+ sf
+ kf
+ (vloop (+ 1
+ n))))
+ ((eq? (vector-ref
+ p
+ vlen)
+ '_)
+ (ks sf))
+ (else
+ (let* ((gloop (vector-ref
+ p
+ (+ vlen
+ 3)))
+ (ind (vector-ref
+ p
+ (+ vlen
+ 4)))
+ (fresh (vector-ref
+ p
+ (+ vlen
+ 5)))
+ (p1 (next (vector-ref
+ p
+ vlen)
+ `(vector-ref
+ ,e
+ ,ind)
+ sf
+ kf
+ (lambda (sf)
+ `(,gloop
+ (- ,ind
+ 1)
+ ,@(map (lambda (b
+ f)
+ `(cons ,(val b)
+ ,f))
+ bound
+ fresh))))))
+ (set! v
+ (append
+ (map cons
+ bound
+ fresh)
+ v))
+ `(let ,gloop
+ ((,ind
+ (- (vector-length
+ ,e)
+ 1))
+ ,@(map (lambda (x)
+ `(,x
+ '()))
+ fresh))
+ (if (> ,minlen
+ ,ind)
+ ,(ks sf)
+ ,p1)))))))
+ sf))))))
+ ((vector? p)
+ (let ((vlen (vector-length p)))
+ (emit `(vector? ,e)
+ sf
+ kf
+ (lambda (sf)
+ (emit `(equal?
+ (vector-length ,e)
+ ,vlen)
+ sf
+ kf
+ (let vloop ((n 0))
+ (lambda (sf)
+ (if (= n vlen)
+ (ks sf)
+ (next (vector-ref p n)
+ `(vector-ref ,e ,n)
+ sf
+ kf
+ (vloop (+ 1
+ n)))))))))))
+ (else
+ (display "FATAL ERROR IN PATTERN MATCHER")
+ (newline)
+ (error #f "THIS NEVER HAPPENS"))))))))
+ (emit (lambda (tst sf kf ks)
+ (cond ((in tst sf) (ks sf))
+ ((in `(not ,tst) sf) (kf sf))
+ (else
+ (let* ((e (cadr tst))
+ (implied
+ (cond ((eq? (car tst) 'equal?)
+ (let ((p (caddr tst)))
+ (cond ((string? p) `((string? ,e)))
+ ((boolean? p)
+ `((boolean? ,e)))
+ ((char? p) `((char? ,e)))
+ ((number? p) `((number? ,e)))
+ ((and (pair? p)
+ (eq? 'quote (car p)))
+ `((symbol? ,e)))
+ (else '()))))
+ ((eq? (car tst) 'null?) `((list? ,e)))
+ ((vec-structure? tst) `((vector? ,e)))
+ (else '())))
+ (not-imp
+ (case (car tst)
+ ((list?) `((not (null? ,e))))
+ (else '())))
+ (s (ks (cons tst (append implied sf))))
+ (k (kf (cons `(not ,tst)
+ (append not-imp sf)))))
+ (assm tst k s))))))
+ (assm (lambda (tst f s)
+ (cond ((equal? s f) s)
+ ((and (eq? s #t) (eq? f #f)) tst)
+ ((and (eq? (car tst) 'pair?)
+ (memq match:error-control '(unspecified fail))
+ (memq (car f) '(cond match:error))
+ (guarantees s (cadr tst)))
+ s)
+ ((and (pair? s)
+ (eq? (car s) 'if)
+ (equal? (cadddr s) f))
+ (if (eq? (car (cadr s)) 'and)
+ `(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f)
+ `(if (and ,tst ,(cadr s)) ,(caddr s) ,f)))
+ ((and (pair? s)
+ (equal? (car s) 'call-with-current-continuation)
+ (pair? (cdr s))
+ (pair? (cadr s))
+ (equal? (caadr s) 'lambda)
+ (pair? (cdadr s))
+ (pair? (cadadr s))
+ (null? (cdr (cadadr s)))
+ (pair? (cddadr s))
+ (pair? (car (cddadr s)))
+ (equal? (caar (cddadr s)) 'let)
+ (pair? (cdar (cddadr s)))
+ (pair? (cadar (cddadr s)))
+ (pair? (caadar (cddadr s)))
+ (pair? (cdr (caadar (cddadr s))))
+ (pair? (cadr (caadar (cddadr s))))
+ (equal? (caadr (caadar (cddadr s))) 'lambda)
+ (pair? (cdadr (caadar (cddadr s))))
+ (null? (cadadr (caadar (cddadr s))))
+ (pair? (cddadr (caadar (cddadr s))))
+ (pair? (car (cddadr (caadar (cddadr s)))))
+ (pair? (cdar (cddadr (caadar (cddadr s)))))
+ (null? (cddar (cddadr (caadar (cddadr s)))))
+ (null? (cdr (cddadr (caadar (cddadr s)))))
+ (null? (cddr (caadar (cddadr s))))
+ (null? (cdadar (cddadr s)))
+ (pair? (cddar (cddadr s)))
+ (null? (cdddar (cddadr s)))
+ (null? (cdr (cddadr s)))
+ (null? (cddr s))
+ (equal? f (cadar (cddadr (caadar (cddadr s))))))
+ (let ((k (car (cadadr s)))
+ (fail (car (caadar (cddadr s))))
+ (s2 (caddar (cddadr s))))
+ `(call-with-current-continuation
+ (lambda (,k)
+ (let ((,fail (lambda () (,k ,f))))
+ ,(assm tst `(,fail) s2))))))
+ ((and #f
+ (pair? s)
+ (equal? (car s) 'let)
+ (pair? (cdr s))
+ (pair? (cadr s))
+ (pair? (caadr s))
+ (pair? (cdaadr s))
+ (pair? (car (cdaadr s)))
+ (equal? (caar (cdaadr s)) 'lambda)
+ (pair? (cdar (cdaadr s)))
+ (null? (cadar (cdaadr s)))
+ (pair? (cddar (cdaadr s)))
+ (null? (cdddar (cdaadr s)))
+ (null? (cdr (cdaadr s)))
+ (null? (cdadr s))
+ (pair? (cddr s))
+ (null? (cdddr s))
+ (equal? (caddar (cdaadr s)) f))
+ (let ((fail (caaadr s)) (s2 (caddr s)))
+ `(let ((,fail (lambda () ,f)))
+ ,(assm tst `(,fail) s2))))
+ (else `(if ,tst ,s ,f)))))
+ (guarantees
+ (lambda (code x)
+ (let ((a (add-a x)) (d (add-d x)))
+ (let loop ((code code))
+ (cond ((not (pair? code)) #f)
+ ((memq (car code) '(cond match:error)) #t)
+ ((or (equal? code a) (equal? code d)) #t)
+ ((eq? (car code) 'if)
+ (or (loop (cadr code))
+ (and (loop (caddr code)) (loop (cadddr code)))))
+ ((eq? (car code) 'lambda) #f)
+ ((and (eq? (car code) 'let) (symbol? (cadr code)))
+ #f)
+ (else (or (loop (car code)) (loop (cdr code)))))))))
+ (in (lambda (e l)
+ (or (member e l)
+ (and (eq? (car e) 'list?)
+ (or (member `(null? ,(cadr e)) l)
+ (member `(pair? ,(cadr e)) l)))
+ (and (eq? (car e) 'not)
+ (let* ((srch (cadr e))
+ (const-class (equal-test? srch)))
+ (cond (const-class
+ (let mem ((l l))
+ (if (null? l)
+ #f
+ (let ((x (car l)))
+ (or (and (equal? (cadr x) (cadr srch))
+ (disjoint? x)
+ (not (equal?
+ const-class
+ (car x))))
+ (equal?
+ x
+ `(not (,const-class
+ ,(cadr srch))))
+ (and (equal? (cadr x) (cadr srch))
+ (equal-test? x)
+ (not (equal?
+ (caddr srch)
+ (caddr x))))
+ (mem (cdr l)))))))
+ ((disjoint? srch)
+ (let mem ((l l))
+ (if (null? l)
+ #f
+ (let ((x (car l)))
+ (or (and (equal? (cadr x) (cadr srch))
+ (disjoint? x)
+ (not (equal?
+ (car x)
+ (car srch))))
+ (mem (cdr l)))))))
+ ((eq? (car srch) 'list?)
+ (let mem ((l l))
+ (if (null? l)
+ #f
+ (let ((x (car l)))
+ (or (and (equal? (cadr x) (cadr srch))
+ (disjoint? x)
+ (not (memq (car x)
+ '(list? pair?
+ null?))))
+ (mem (cdr l)))))))
+ ((vec-structure? srch)
+ (let mem ((l l))
+ (if (null? l)
+ #f
+ (let ((x (car l)))
+ (or (and (equal? (cadr x) (cadr srch))
+ (or (disjoint? x)
+ (vec-structure? x))
+ (not (equal?
+ (car x)
+ 'vector?))
+ (not (equal?
+ (car x)
+ (car srch))))
+ (equal?
+ x
+ `(not (vector? ,(cadr srch))))
+ (mem (cdr l)))))))
+ (else #f)))))))
+ (equal-test?
+ (lambda (tst)
+ (and (eq? (car tst) 'equal?)
+ (let ((p (caddr tst)))
+ (cond ((string? p) 'string?)
+ ((boolean? p) 'boolean?)
+ ((char? p) 'char?)
+ ((number? p) 'number?)
+ ((and (pair? p)
+ (pair? (cdr p))
+ (null? (cddr p))
+ (eq? 'quote (car p))
+ (symbol? (cadr p)))
+ 'symbol?)
+ (else #f))))))
+ (disjoint?
+ (lambda (tst)
+ (memq (car tst) match:disjoint-predicates)))
+ (vec-structure?
+ (lambda (tst)
+ (memq (car tst) match:vector-structures)))
+ (add-a (lambda (a)
+ (let ((new (and (pair? a) (assq (car a) c---rs))))
+ (if new (cons (cadr new) (cdr a)) `(car ,a)))))
+ (add-d (lambda (a)
+ (let ((new (and (pair? a) (assq (car a) c---rs))))
+ (if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
+ (c---rs
+ '((car caar . cdar)
+ (cdr cadr . cddr)
+ (caar caaar . cdaar)
+ (cadr caadr . cdadr)
+ (cdar cadar . cddar)
+ (cddr caddr . cdddr)
+ (caaar caaaar . cdaaar)
+ (caadr caaadr . cdaadr)
+ (cadar caadar . cdadar)
+ (caddr caaddr . cdaddr)
+ (cdaar cadaar . cddaar)
+ (cdadr cadadr . cddadr)
+ (cddar caddar . cdddar)
+ (cdddr cadddr . cddddr)))
+ (setter
+ (lambda (e p)
+ (let ((mk-setter
+ (lambda (s) (symbol-append 'set- s '!))))
+ (cond ((not (pair? e))
+ (match:syntax-err p "unnested set! pattern"))
+ ((eq? (car e) 'vector-ref)
+ `(let ((x ,(cadr e)))
+ (lambda (y) (vector-set! x ,(caddr e) y))))
+ ((eq? (car e) 'unbox)
+ `(let ((x ,(cadr e))) (lambda (y) (set-box! x y))))
+ ((eq? (car e) 'car)
+ `(let ((x ,(cadr e))) (lambda (y) (set-car! x y))))
+ ((eq? (car e) 'cdr)
+ `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y))))
+ ((let ((a (assq (car e) get-c---rs)))
+ (and a
+ `(let ((x (,(cadr a) ,(cadr e))))
+ (lambda (y) (,(mk-setter (cddr a)) x y))))))
+ (else
+ `(let ((x ,(cadr e)))
+ (lambda (y) (,(mk-setter (car e)) x y))))))))
+ (getter
+ (lambda (e p)
+ (cond ((not (pair? e))
+ (match:syntax-err p "unnested get! pattern"))
+ ((eq? (car e) 'vector-ref)
+ `(let ((x ,(cadr e)))
+ (lambda () (vector-ref x ,(caddr e)))))
+ ((eq? (car e) 'unbox)
+ `(let ((x ,(cadr e))) (lambda () (unbox x))))
+ ((eq? (car e) 'car)
+ `(let ((x ,(cadr e))) (lambda () (car x))))
+ ((eq? (car e) 'cdr)
+ `(let ((x ,(cadr e))) (lambda () (cdr x))))
+ ((let ((a (assq (car e) get-c---rs)))
+ (and a
+ `(let ((x (,(cadr a) ,(cadr e))))
+ (lambda () (,(cddr a) x))))))
+ (else
+ `(let ((x ,(cadr e))) (lambda () (,(car e) x)))))))
+ (get-c---rs
+ '((caar car . car)
+ (cadr cdr . car)
+ (cdar car . cdr)
+ (cddr cdr . cdr)
+ (caaar caar . car)
+ (caadr cadr . car)
+ (cadar cdar . car)
+ (caddr cddr . car)
+ (cdaar caar . cdr)
+ (cdadr cadr . cdr)
+ (cddar cdar . cdr)
+ (cdddr cddr . cdr)
+ (caaaar caaar . car)
+ (caaadr caadr . car)
+ (caadar cadar . car)
+ (caaddr caddr . car)
+ (cadaar cdaar . car)
+ (cadadr cdadr . car)
+ (caddar cddar . car)
+ (cadddr cdddr . car)
+ (cdaaar caaar . cdr)
+ (cdaadr caadr . cdr)
+ (cdadar cadar . cdr)
+ (cdaddr caddr . cdr)
+ (cddaar cdaar . cdr)
+ (cddadr cdadr . cdr)
+ (cdddar cddar . cdr)
+ (cddddr cdddr . cdr)))
+ (symbol-append
+ (lambda l
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (cond ((symbol? x) (symbol->string x))
+ ((number? x) (number->string x))
+ (else x)))
+ l)))))
+ (rac (lambda (l)
+ (if (null? (cdr l)) (car l) (rac (cdr l)))))
+ (rdc (lambda (l)
+ (if (null? (cdr l))
+ '()
+ (cons (car l) (rdc (cdr l)))))))
+ (list genmatch genletrec gendefine pattern-var?)))
+(defmacro
+ match
+ args
+ (cond ((and (list? args)
+ (<= 1 (length args))
+ (match:andmap
+ (lambda (y) (and (list? y) (<= 2 (length y))))
+ (cdr args)))
+ (let* ((exp (car args))
+ (clauses (cdr args))
+ (e (if (symbol? exp) exp (gentemp))))
+ (if (symbol? exp)
+ ((car match:expanders) e clauses `(match ,@args))
+ `(let ((,e ,exp))
+ ,((car match:expanders) e clauses `(match ,@args))))))
+ (else
+ (match:syntax-err
+ `(match ,@args)
+ "syntax error in"))))
+(defmacro
+ match-lambda
+ args
+ (if (and (list? args)
+ (match:andmap
+ (lambda (g126)
+ (if (and (pair? g126) (list? (cdr g126)))
+ (pair? (cdr g126))
+ #f))
+ args))
+ ((lambda ()
+ (let ((e (gentemp)))
+ `(lambda (,e) (match ,e ,@args)))))
+ ((lambda ()
+ (match:syntax-err
+ `(match-lambda ,@args)
+ "syntax error in")))))
+(defmacro
+ match-lambda*
+ args
+ (if (and (list? args)
+ (match:andmap
+ (lambda (g134)
+ (if (and (pair? g134) (list? (cdr g134)))
+ (pair? (cdr g134))
+ #f))
+ args))
+ ((lambda ()
+ (let ((e (gentemp)))
+ `(lambda ,e (match ,e ,@args)))))
+ ((lambda ()
+ (match:syntax-err
+ `(match-lambda* ,@args)
+ "syntax error in")))))
+(defmacro
+ match-let
+ args
+ (let ((g158 (lambda (pat exp body)
+ `(match ,exp (,pat ,@body))))
+ (g154 (lambda (pat exp body)
+ (let ((g (map (lambda (x) (gentemp)) pat))
+ (vpattern (list->vector pat)))
+ `(let ,(map list g exp)
+ (match (vector ,@g) (,vpattern ,@body))))))
+ (g146 (lambda ()
+ (match:syntax-err
+ `(match-let ,@args)
+ "syntax error in")))
+ (g145 (lambda (p1 e1 p2 e2 body)
+ (let ((g1 (gentemp)) (g2 (gentemp)))
+ `(let ((,g1 ,e1) (,g2 ,e2))
+ (match (cons ,g1 ,g2) ((,p1 unquote p2) ,@body))))))
+ (g136 (cadddr match:expanders)))
+ (if (pair? args)
+ (if (symbol? (car args))
+ (if (and (pair? (cdr args)) (list? (cadr args)))
+ (let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
+ (if (null? g162)
+ (if (and (list? (cddr args)) (pair? (cddr args)))
+ ((lambda (name pat exp body)
+ (if (match:andmap (cadddr match:expanders) pat)
+ `(let ,@args)
+ `(letrec ((,name (match-lambda* (,pat ,@body))))
+ (,name ,@exp))))
+ (car args)
+ (reverse g159)
+ (reverse g160)
+ (cddr args))
+ (g146))
+ (if (and (pair? (car g162))
+ (pair? (cdar g162))
+ (null? (cddar g162)))
+ (g161 (cdr g162)
+ (cons (cadar g162) g160)
+ (cons (caar g162) g159))
+ (g146))))
+ (g146))
+ (if (list? (car args))
+ (if (match:andmap
+ (lambda (g167)
+ (if (and (pair? g167)
+ (g136 (car g167))
+ (pair? (cdr g167)))
+ (null? (cddr g167))
+ #f))
+ (car args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ ((lambda () `(let ,@args)))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (g146)
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (if (and (pair? (car args))
+ (pair? (caar args))
+ (pair? (cdaar args))
+ (null? (cddaar args)))
+ (if (null? (cdar args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g158 (caaar args) (cadaar args) (cdr args))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (g146)
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (if (and (pair? (cdar args))
+ (pair? (cadar args))
+ (pair? (cdadar args))
+ (null? (cdr (cdadar args)))
+ (null? (cddar args)))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g145 (caaar args)
+ (cadaar args)
+ (caadar args)
+ (car (cdadar args))
+ (cdr args))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (g146)
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g154 (reverse g147) (reverse g148) (cdr args))
+ (g146))
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146))))))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g154 (reverse g147) (reverse g148) (cdr args))
+ (g146))
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146))))))
+ (if (pair? (car args))
+ (if (and (pair? (caar args))
+ (pair? (cdaar args))
+ (null? (cddaar args)))
+ (if (null? (cdar args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g158 (caaar args) (cadaar args) (cdr args))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (g146)
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (if (and (pair? (cdar args))
+ (pair? (cadar args))
+ (pair? (cdadar args))
+ (null? (cdr (cdadar args)))
+ (null? (cddar args)))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g145 (caaar args)
+ (cadaar args)
+ (caadar args)
+ (car (cdadar args))
+ (cdr args))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (g146)
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g154 (reverse g147) (reverse g148) (cdr args))
+ (g146))
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146))))))
+ (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
+ (if (null? g150)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g154 (reverse g147) (reverse g148) (cdr args))
+ (g146))
+ (if (and (pair? (car g150))
+ (pair? (cdar g150))
+ (null? (cddar g150)))
+ (g149 (cdr g150)
+ (cons (cadar g150) g148)
+ (cons (caar g150) g147))
+ (g146)))))
+ (g146))))
+ (g146))))
+(defmacro
+ match-let*
+ args
+ (let ((g176 (lambda ()
+ (match:syntax-err
+ `(match-let* ,@args)
+ "syntax error in"))))
+ (if (pair? args)
+ (if (null? (car args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ ((lambda (body) `(let* ,@args)) (cdr args))
+ (g176))
+ (if (and (pair? (car args))
+ (pair? (caar args))
+ (pair? (cdaar args))
+ (null? (cddaar args))
+ (list? (cdar args))
+ (list? (cdr args))
+ (pair? (cdr args)))
+ ((lambda (pat exp rest body)
+ (if ((cadddr match:expanders) pat)
+ `(let ((,pat ,exp)) (match-let* ,rest ,@body))
+ `(match ,exp (,pat (match-let* ,rest ,@body)))))
+ (caaar args)
+ (cadaar args)
+ (cdar args)
+ (cdr args))
+ (g176)))
+ (g176))))
+(defmacro
+ match-letrec
+ args
+ (let ((g200 (cadddr match:expanders))
+ (g199 (lambda (p1 e1 p2 e2 body)
+ `(match-letrec
+ (((,p1 unquote p2) (cons ,e1 ,e2)))
+ ,@body)))
+ (g195 (lambda ()
+ (match:syntax-err
+ `(match-letrec ,@args)
+ "syntax error in")))
+ (g194 (lambda (pat exp body)
+ `(match-letrec
+ ((,(list->vector pat) (vector ,@exp)))
+ ,@body)))
+ (g186 (lambda (pat exp body)
+ ((cadr match:expanders)
+ pat
+ exp
+ body
+ `(match-letrec ((,pat ,exp)) ,@body)))))
+ (if (pair? args)
+ (if (list? (car args))
+ (if (match:andmap
+ (lambda (g206)
+ (if (and (pair? g206)
+ (g200 (car g206))
+ (pair? (cdr g206)))
+ (null? (cddr g206))
+ #f))
+ (car args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ ((lambda () `(letrec ,@args)))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (g195)
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (if (and (pair? (car args))
+ (pair? (caar args))
+ (pair? (cdaar args))
+ (null? (cddaar args)))
+ (if (null? (cdar args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g186 (caaar args) (cadaar args) (cdr args))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (g195)
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (if (and (pair? (cdar args))
+ (pair? (cadar args))
+ (pair? (cdadar args))
+ (null? (cdr (cdadar args)))
+ (null? (cddar args)))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g199 (caaar args)
+ (cadaar args)
+ (caadar args)
+ (car (cdadar args))
+ (cdr args))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (g195)
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g194 (reverse g187) (reverse g188) (cdr args))
+ (g195))
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195))))))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g194 (reverse g187) (reverse g188) (cdr args))
+ (g195))
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195))))))
+ (if (pair? (car args))
+ (if (and (pair? (caar args))
+ (pair? (cdaar args))
+ (null? (cddaar args)))
+ (if (null? (cdar args))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g186 (caaar args) (cadaar args) (cdr args))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (g195)
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (if (and (pair? (cdar args))
+ (pair? (cadar args))
+ (pair? (cdadar args))
+ (null? (cdr (cdadar args)))
+ (null? (cddar args)))
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g199 (caaar args)
+ (cadaar args)
+ (caadar args)
+ (car (cdadar args))
+ (cdr args))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (g195)
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g194 (reverse g187) (reverse g188) (cdr args))
+ (g195))
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195))))))
+ (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
+ (if (null? g190)
+ (if (and (list? (cdr args)) (pair? (cdr args)))
+ (g194 (reverse g187) (reverse g188) (cdr args))
+ (g195))
+ (if (and (pair? (car g190))
+ (pair? (cdar g190))
+ (null? (cddar g190)))
+ (g189 (cdr g190)
+ (cons (cadar g190) g188)
+ (cons (caar g190) g187))
+ (g195)))))
+ (g195)))
+ (g195))))
+(defmacro
+ match-define
+ args
+ (let ((g210 (cadddr match:expanders))
+ (g209 (lambda ()
+ (match:syntax-err
+ `(match-define ,@args)
+ "syntax error in"))))
+ (if (pair? args)
+ (if (g210 (car args))
+ (if (and (pair? (cdr args)) (null? (cddr args)))
+ ((lambda () `(begin (define ,@args))))
+ (g209))
+ (if (and (pair? (cdr args)) (null? (cddr args)))
+ ((lambda (pat exp)
+ ((caddr match:expanders)
+ pat
+ exp
+ `(match-define ,@args)))
+ (car args)
+ (cadr args))
+ (g209)))
+ (g209))))
+(define match:runtime-structures #f)
+(define match:set-runtime-structures
+ (lambda (v) (set! match:runtime-structures v)))
+(define match:primitive-vector? vector?)
+(defmacro
+ defstruct
+ args
+ (let ((field?
+ (lambda (x)
+ (if (symbol? x)
+ ((lambda () #t))
+ (if (and (pair? x)
+ (symbol? (car x))
+ (pair? (cdr x))
+ (symbol? (cadr x))
+ (null? (cddr x)))
+ ((lambda () #t))
+ ((lambda () #f))))))
+ (selector-name
+ (lambda (x)
+ (if (symbol? x)
+ ((lambda () x))
+ (if (and (pair? x)
+ (symbol? (car x))
+ (pair? (cdr x))
+ (null? (cddr x)))
+ ((lambda (s) s) (car x))
+ (match:error x)))))
+ (mutator-name
+ (lambda (x)
+ (if (symbol? x)
+ ((lambda () #f))
+ (if (and (pair? x)
+ (pair? (cdr x))
+ (symbol? (cadr x))
+ (null? (cddr x)))
+ ((lambda (s) s) (cadr x))
+ (match:error x)))))
+ (filter-map-with-index
+ (lambda (f l)
+ (letrec ((mapi (lambda (l i)
+ (cond ((null? l) '())
+ ((f (car l) i)
+ =>
+ (lambda (x)
+ (cons x (mapi (cdr l) (+ 1 i)))))
+ (else (mapi (cdr l) (+ 1 i)))))))
+ (mapi l 1)))))
+ (let ((g227 (lambda ()
+ (match:syntax-err
+ `(defstruct ,@args)
+ "syntax error in"))))
+ (if (and (pair? args)
+ (symbol? (car args))
+ (pair? (cdr args))
+ (symbol? (cadr args))
+ (pair? (cddr args))
+ (symbol? (caddr args))
+ (list? (cdddr args)))
+ (let g229 ((g230 (cdddr args)) (g228 '()))
+ (if (null? g230)
+ ((lambda (name constructor predicate fields)
+ (let* ((selectors (map selector-name fields))
+ (mutators (map mutator-name fields))
+ (tag (if match:runtime-structures
+ (gentemp)
+ `',(match:make-structure-tag name)))
+ (vectorp
+ (cond ((eq? match:structure-control 'disjoint)
+ 'match:primitive-vector?)
+ ((eq? match:structure-control 'vector)
+ 'vector?))))
+ (cond ((eq? match:structure-control 'disjoint)
+ (if (eq? vector? match:primitive-vector?)
+ (set! vector?
+ (lambda (v)
+ (and (match:primitive-vector? v)
+ (or (zero? (vector-length v))
+ (not (symbol? (vector-ref v 0)))
+ (not (match:structure?
+ (vector-ref v 0))))))))
+ (if (not (memq predicate match:disjoint-predicates))
+ (set! match:disjoint-predicates
+ (cons predicate match:disjoint-predicates))))
+ ((eq? match:structure-control 'vector)
+ (if (not (memq predicate match:vector-structures))
+ (set! match:vector-structures
+ (cons predicate match:vector-structures))))
+ (else
+ (match:syntax-err
+ '(vector disjoint)
+ "invalid value for match:structure-control, legal values are")))
+ `(begin
+ ,@(if match:runtime-structures
+ `((define ,tag (match:make-structure-tag ',name)))
+ '())
+ (define ,constructor
+ (lambda ,selectors (vector ,tag ,@selectors)))
+ (define ,predicate
+ (lambda (obj)
+ (and (,vectorp obj)
+ (= (vector-length obj) ,(+ 1 (length selectors)))
+ (eq? (vector-ref obj 0) ,tag))))
+ ,@(filter-map-with-index
+ (lambda (n i)
+ `(define ,n (lambda (obj) (vector-ref obj ,i))))
+ selectors)
+ ,@(filter-map-with-index
+ (lambda (n i)
+ (and n
+ `(define ,n
+ (lambda (obj newval)
+ (vector-set! obj ,i newval)))))
+ mutators))))
+ (car args)
+ (cadr args)
+ (caddr args)
+ (reverse g228))
+ (if (field? (car g230))
+ (g229 (cdr g230) (cons (car g230) g228))
+ (g227))))
+ (g227)))))
+(defmacro
+ define-structure
+ args
+ (let ((g242 (lambda ()
+ (match:syntax-err
+ `(define-structure ,@args)
+ "syntax error in"))))
+ (if (and (pair? args)
+ (pair? (car args))
+ (list? (cdar args)))
+ (if (null? (cdr args))
+ ((lambda (name id1)
+ `(define-structure (,name ,@id1) ()))
+ (caar args)
+ (cdar args))
+ (if (and (pair? (cdr args)) (list? (cadr args)))
+ (let g239 ((g240 (cadr args)) (g238 '()) (g237 '()))
+ (if (null? g240)
+ (if (null? (cddr args))
+ ((lambda (name id1 id2 val)
+ (let ((mk-id (lambda (id)
+ (if (and (pair? id)
+ (equal? (car id) '@)
+ (pair? (cdr id))
+ (symbol? (cadr id))
+ (null? (cddr id)))
+ ((lambda (x) x) (cadr id))
+ ((lambda () `(! ,id)))))))
+ `(define-const-structure
+ (,name ,@(map mk-id id1))
+ ,(map (lambda (id v) `(,(mk-id id) ,v)) id2 val))))
+ (caar args)
+ (cdar args)
+ (reverse g237)
+ (reverse g238))
+ (g242))
+ (if (and (pair? (car g240))
+ (pair? (cdar g240))
+ (null? (cddar g240)))
+ (g239 (cdr g240)
+ (cons (cadar g240) g238)
+ (cons (caar g240) g237))
+ (g242))))
+ (g242)))
+ (g242))))
+(defmacro
+ define-const-structure
+ args
+ (let ((field?
+ (lambda (id)
+ (if (symbol? id)
+ ((lambda () #t))
+ (if (and (pair? id)
+ (equal? (car id) '!)
+ (pair? (cdr id))
+ (symbol? (cadr id))
+ (null? (cddr id)))
+ ((lambda () #t))
+ ((lambda () #f))))))
+ (field-name
+ (lambda (x) (if (symbol? x) x (cadr x))))
+ (has-mutator? (lambda (x) (not (symbol? x))))
+ (filter-map-with-index
+ (lambda (f l)
+ (letrec ((mapi (lambda (l i)
+ (cond ((null? l) '())
+ ((f (car l) i)
+ =>
+ (lambda (x)
+ (cons x (mapi (cdr l) (+ 1 i)))))
+ (else (mapi (cdr l) (+ 1 i)))))))
+ (mapi l 1))))
+ (symbol-append
+ (lambda l
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (cond ((symbol? x) (symbol->string x))
+ ((number? x) (number->string x))
+ (else x)))
+ l))))))
+ (let ((g266 (lambda ()
+ (match:syntax-err
+ `(define-const-structure ,@args)
+ "syntax error in"))))
+ (if (and (pair? args)
+ (pair? (car args))
+ (list? (cdar args)))
+ (if (null? (cdr args))
+ ((lambda (name id1)
+ `(define-const-structure (,name ,@id1) ()))
+ (caar args)
+ (cdar args))
+ (if (symbol? (caar args))
+ (let g259 ((g260 (cdar args)) (g258 '()))
+ (if (null? g260)
+ (if (and (pair? (cdr args)) (list? (cadr args)))
+ (let g263 ((g264 (cadr args)) (g262 '()) (g261 '()))
+ (if (null? g264)
+ (if (null? (cddr args))
+ ((lambda (name id1 id2 val)
+ (let* ((id1id2 (append id1 id2))
+ (raw-constructor
+ (symbol-append 'make-raw- name))
+ (constructor (symbol-append 'make- name))
+ (predicate (symbol-append name '?)))
+ `(begin
+ (defstruct
+ ,name
+ ,raw-constructor
+ ,predicate
+ ,@(filter-map-with-index
+ (lambda (arg i)
+ (if (has-mutator? arg)
+ `(,(symbol-append name '- i)
+ ,(symbol-append
+ 'set-
+ name
+ '-
+ i
+ '!))
+ (symbol-append name '- i)))
+ id1id2))
+ ,(let* ((make-fresh
+ (lambda (x)
+ (if (eq? '_ x) (gentemp) x)))
+ (names1
+ (map make-fresh
+ (map field-name id1)))
+ (names2
+ (map make-fresh
+ (map field-name id2))))
+ `(define ,constructor
+ (lambda ,names1
+ (let* ,(map list names2 val)
+ (,raw-constructor
+ ,@names1
+ ,@names2)))))
+ ,@(filter-map-with-index
+ (lambda (field i)
+ (if (eq? (field-name field) '_)
+ #f
+ `(define (unquote
+ (symbol-append
+ name
+ '-
+ (field-name field)))
+ ,(symbol-append name '- i))))
+ id1id2)
+ ,@(filter-map-with-index
+ (lambda (field i)
+ (if (or (eq? (field-name field) '_)
+ (not (has-mutator? field)))
+ #f
+ `(define (unquote
+ (symbol-append
+ 'set-
+ name
+ '-
+ (field-name field)
+ '!))
+ ,(symbol-append
+ 'set-
+ name
+ '-
+ i
+ '!))))
+ id1id2))))
+ (caar args)
+ (reverse g258)
+ (reverse g261)
+ (reverse g262))
+ (g266))
+ (if (and (pair? (car g264))
+ (field? (caar g264))
+ (pair? (cdar g264))
+ (null? (cddar g264)))
+ (g263 (cdr g264)
+ (cons (cadar g264) g262)
+ (cons (caar g264) g261))
+ (g266))))
+ (g266))
+ (if (field? (car g260))
+ (g259 (cdr g260) (cons (car g260) g258))
+ (g266))))
+ (g266)))
+ (g266)))))
+(define home-directory
+ (or (getenv "HOME")
+ (error "environment variable HOME is not defined")))
+(defmacro recur args `(let ,@args))
+(defmacro
+ rec
+ args
+ (match args
+ (((? symbol? x) v) `(letrec ((,x ,v)) ,x))))
+(defmacro
+ parameterize
+ args
+ (match args ((bindings exp ...) `(begin ,@exp))))
+(define gensym gentemp)
+(define expand-once macroexpand-1)
+(defmacro check-increment-counter args #f)
+(define symbol-append
+ (lambda l
+ (string->symbol
+ (apply string-append
+ (map (lambda (x) (format #f "~a" x)) l)))))
+(define gensym gentemp)
+(define andmap
+ (lambda (f . lists)
+ (cond ((null? (car lists)) (and))
+ ((null? (cdr (car lists)))
+ (apply f (map car lists)))
+ (else
+ (and (apply f (map car lists))
+ (apply andmap f (map cdr lists)))))))
+(define true-object? (lambda (x) (eq? #t x)))
+(define false-object? (lambda (x) (eq? #f x)))
+(define void (lambda () (cond (#f #f))))
+(defmacro
+ when
+ args
+ (match args
+ ((tst body __1)
+ `(if ,tst (begin ,@body (void)) (void)))))
+(defmacro
+ unless
+ args
+ (match args
+ ((tst body __1)
+ `(if ,tst (void) (begin ,@body (void))))))
+(define should-never-reach
+ (lambda (form)
+ (slib:error "fell off end of " form)))
+(define make-cvector make-vector)
+(define cvector vector)
+(define cvector-length vector-length)
+(define cvector-ref vector-ref)
+(define cvector->list vector->list)
+(define list->cvector list->vector)
+(define-const-structure (record _))
+(defmacro
+ record
+ args
+ (match args
+ ((((? symbol? id) exp) ...)
+ `(make-record
+ (list ,@(map (lambda (i x) `(cons ',i ,x)) id exp))))
+ (_ (slib:error "syntax error at " `(record ,@args)))))
+(defmacro
+ field
+ args
+ (match args
+ (((? symbol? id) exp)
+ `(match ,exp
+ (($ record x)
+ (match (assq ',id x)
+ (#f
+ (slib:error
+ "no field "
+ ,id
+ 'in
+ (cons 'record (map car x))))
+ ((_ . x) x)))
+ (_ (slib:error "not a record: " '(field ,id _)))))
+ (_ (slib:error "syntax error at " `(field ,@args)))))
+(define-const-structure (module _))
+(defmacro
+ module
+ args
+ (match args
+ (((i ...) defs ...)
+ `(let ()
+ ,@defs
+ (make-module
+ (record ,@(map (lambda (x) (list x x)) i)))))
+ (_ (slib:error "syntax error at " `(module ,@args)))))
+(defmacro
+ import
+ args
+ (match args
+ ((((mod defs ...) ...) body __1)
+ (let* ((m (map (lambda (_) (gentemp)) mod))
+ (newdefs
+ (let loop ((mod-names m) (l-defs defs))
+ (if (null? mod-names)
+ '()
+ (append
+ (let ((m (car mod-names)))
+ (map (match-lambda
+ ((? symbol? x) `(,x (field ,x ,m)))
+ (((? symbol? i) (? symbol? e))
+ `(,i (field ,e ,m)))
+ (x (slib:error "ill-formed definition: " x)))
+ (car l-defs)))
+ (loop (cdr mod-names) (cdr l-defs)))))))
+ `(let (unquote
+ (map (lambda (m mod)
+ `(,m (match ,mod (($ module x) x))))
+ m
+ mod))
+ (let ,newdefs body ...))))))
+(define raise
+ (lambda vals
+ (slib:error "Unhandled exception " vals)))
+(defmacro
+ fluid-let
+ args
+ (match args
+ ((((x val) ...) body __1)
+ (let ((old-x (map (lambda (_) (gentemp)) x))
+ (swap-x (map (lambda (_) (gentemp)) x))
+ (swap (gentemp)))
+ `(let ,(map list old-x val)
+ (let ((,swap
+ (lambda ()
+ (let ,(map list swap-x old-x)
+ ,@(map (lambda (old x) `(set! ,old ,x)) old-x x)
+ ,@(map (lambda (x swap) `(set! ,x ,swap))
+ x
+ swap-x)))))
+ (dynamic-wind ,swap (lambda () ,@body) ,swap)))))
+ (_ (slib:error
+ "syntax error at "
+ `(fluid-let ,@args)))))
+(defmacro
+ handle
+ args
+ (match args
+ ((e h)
+ (let ((k (gentemp)) (exn (gentemp)))
+ `((call-with-current-continuation
+ (lambda (k)
+ (fluid-let
+ ((raise (lambda ,exn (k (lambda () (apply ,h ,exn))))))
+ (let ((v ,e)) (lambda () v))))))))
+ (_ (slib:error "syntax error in " `(handle ,@args)))))
+(defmacro
+ :
+ args
+ (match args ((typeexp exp) exp)))
+(defmacro
+ module:
+ args
+ (match args
+ ((((i type) ...) defs ...)
+ `(let ()
+ ,@defs
+ (make-module
+ (record
+ ,@(map (lambda (i type) `(,i (: ,type ,i))) i type)))))))
+(defmacro
+ define:
+ args
+ (match args
+ ((name type exp) `(define ,name (: ,type ,exp)))))
+(define st:failure
+ (lambda (chk fmt . args)
+ (slib:error
+ (apply format
+ #f
+ (string-append "~a : " fmt)
+ chk
+ args))))
+(defmacro
+ check-bound
+ args
+ (match args
+ ((var) var)
+ (x (st:failure `(check-bound ,@x) "syntax-error"))))
+(defmacro
+ clash
+ args
+ (match args
+ ((name info ...) name)
+ (x (st:failure `(clash ,@x) "syntax error"))))
+(defmacro
+ check-lambda
+ args
+ (match args
+ (((id info ...) (? symbol? args) body __1)
+ `(lambda ,args
+ (check-increment-counter ,id)
+ ,@body))
+ (((id info ...) args body __1)
+ (let* ((n 0)
+ (chk (let loop ((a args) (nargs 0))
+ (cond ((pair? a) (loop (cdr a) (+ 1 nargs)))
+ ((null? a)
+ (set! n nargs)
+ `(= ,nargs (length args)))
+ (else
+ (set! n nargs)
+ `(<= ,nargs (length args))))))
+ (incr (if (number? id)
+ `(check-increment-counter ,id)
+ #f)))
+ `(let ((lam (lambda ,args ,@body)))
+ (lambda args
+ ,incr
+ (if ,chk
+ (apply lam args)
+ ,(if (eq? '= (car chk))
+ `(st:failure
+ '(check-lambda ,id ,@info)
+ "requires ~a arguments, passed: ~a"
+ ,n
+ args)
+ `(st:failure
+ '(check-lambda ,id ,@info)
+ "requires >= ~a arguments, passed: ~a"
+ ,n
+ args)))))))
+ (x (st:failure `(check-lambda ,@x) "syntax error"))))
+(defmacro
+ check-ap
+ args
+ (match args
+ (((id info ...) (? symbol? f) args ...)
+ `(begin
+ (check-increment-counter ,id)
+ (if (procedure? ,f)
+ (,f ,@args)
+ (st:failure
+ '(check-ap ,id ,@info)
+ "not a procedure: ~a"
+ ,f))))
+ (((id info ...) f args ...)
+ `((lambda (proc . args)
+ (check-increment-counter ,id)
+ (if (procedure? proc)
+ (apply proc args)
+ (st:failure
+ '(check-ap ,id ,@info)
+ "not a procedure: ~a"
+ proc)))
+ ,f
+ ,@args))
+ (x (st:failure `(check-ap ,@x) "syntax error"))))
+(defmacro
+ check-field
+ args
+ (match args
+ (((id info ...) (? symbol? f) exp)
+ `(match ,exp
+ (($ record x)
+ (match (assq ',f x)
+ (#f
+ (st:failure
+ '(check-field ,id ,@info)
+ "no ~a field in (record ~a)"
+ ',f
+ (map car x)))
+ ((_ . x) x)))
+ (v (st:failure
+ '(check-field ,id ,@info)
+ "not a record: ~a"
+ v))))
+ (x (st:failure `(check-field ,@x) "syntax error"))))
+(defmacro
+ check-match
+ args
+ (match args
+ (((id info ...) exp (and clause (pat _ __1)) ...)
+ (letrec ((last (lambda (pl)
+ (if (null? (cdr pl)) (car pl) (last (cdr pl))))))
+ (if (match (last pat)
+ ((? symbol?) #t)
+ (('and subp ...) (andmap symbol? subp))
+ (_ #f))
+ `(begin
+ (check-increment-counter ,id)
+ (match ,exp ,@clause))
+ `(begin
+ (check-increment-counter ,id)
+ (match ,exp
+ ,@clause
+ (x (st:failure
+ '(check-match ,id ,@info)
+ "no matching clause for ~a"
+ x)))))))
+ (x (st:failure `(check-match ,@x) "syntax error"))))
+(defmacro
+ check-:
+ args
+ (match args
+ (((id info ...) typeexp exp)
+ `(st:failure
+ '(check-: ,id ,@info)
+ "static type annotation reached"))
+ (x (st:failure `(check-: ,@x) "syntax error"))))
+(defmacro
+ make-check-typed
+ args
+ (match args
+ ((prim)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (null? a)
+ (,prim)
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim '_)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (= 1 (length a))
+ (,prim (car a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim type1)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (and (= 1 (length a)) (,type1 (car a)))
+ (,prim (car a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim '_ '_)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (= 2 (length a))
+ (,prim (car a) (cadr a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim '_ type2)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (and (= 2 (length a)) (,type2 (cadr a)))
+ (,prim (car a) (cadr a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim type1 '_)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (and (= 2 (length a)) (,type1 (car a)))
+ (,prim (car a) (cadr a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim type1 type2)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (and (= 2 (length a))
+ (,type1 (car a))
+ (,type2 (cadr a)))
+ (,prim (car a) (cadr a))
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))
+ ((prim types ...)
+ (let ((nargs (length types))
+ (chkprim (symbol-append 'check- prim))
+ (types (map (match-lambda ('_ '(lambda (_) #t)) (x x))
+ types)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (and (= ,nargs (length a))
+ (andmap
+ (lambda (f a) (f a))
+ (list ,@types)
+ a))
+ (apply ,prim a)
+ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a)))))))))
+(defmacro
+ make-check-selector
+ args
+ (match args
+ ((prim pat)
+ (let ((chkprim (symbol-append 'check- prim)))
+ (list 'defmacro
+ chkprim
+ 'id
+ (list 'quasiquote
+ `(lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (match a
+ ((,pat) x)
+ (_ (st:failure
+ (cons ',chkprim '(,'unquote id))
+ "invalid arguments: ~a"
+ a))))))))))
+(make-check-typed number? _)
+(make-check-typed null? _)
+(make-check-typed char? _)
+(make-check-typed symbol? _)
+(make-check-typed string? _)
+(make-check-typed vector? _)
+(make-check-typed box? _)
+(make-check-typed pair? _)
+(make-check-typed procedure? _)
+(make-check-typed eof-object? _)
+(make-check-typed input-port? _)
+(make-check-typed output-port? _)
+(make-check-typed true-object? _)
+(make-check-typed false-object? _)
+(make-check-typed boolean? _)
+(make-check-typed list? _)
+(make-check-typed not _)
+(make-check-typed eqv? _ _)
+(make-check-typed eq? _ _)
+(make-check-typed equal? _ _)
+(make-check-typed cons _ _)
+(make-check-selector car (x . _))
+(make-check-selector cdr (_ . x))
+(make-check-selector caar ((x . _) . _))
+(make-check-selector cadr (_ x . _))
+(make-check-selector cdar ((_ . x) . _))
+(make-check-selector cddr (_ _ . x))
+(make-check-selector caaar (((x . _) . _) . _))
+(make-check-selector caadr (_ (x . _) . _))
+(make-check-selector cadar ((_ x . _) . _))
+(make-check-selector caddr (_ _ x . _))
+(make-check-selector cdaar (((_ . x) . _) . _))
+(make-check-selector cdadr (_ (_ . x) . _))
+(make-check-selector cddar ((_ _ . x) . _))
+(make-check-selector cdddr (_ _ _ . x))
+(make-check-selector
+ caaaar
+ ((((x . _) . _) . _) . _))
+(make-check-selector
+ caaadr
+ (_ ((x . _) . _) . _))
+(make-check-selector
+ caadar
+ ((_ (x . _) . _) . _))
+(make-check-selector caaddr (_ _ (x . _) . _))
+(make-check-selector
+ cadaar
+ (((_ x . _) . _) . _))
+(make-check-selector cadadr (_ (_ x . _) . _))
+(make-check-selector caddar ((_ _ x . _) . _))
+(make-check-selector cadddr (_ _ _ x . _))
+(make-check-selector
+ cdaaar
+ ((((_ . x) . _) . _) . _))
+(make-check-selector
+ cdaadr
+ (_ ((_ . x) . _) . _))
+(make-check-selector
+ cdadar
+ ((_ (_ . x) . _) . _))
+(make-check-selector cdaddr (_ _ (_ . x) . _))
+(make-check-selector
+ cddaar
+ (((_ _ . x) . _) . _))
+(make-check-selector cddadr (_ (_ _ . x) . _))
+(make-check-selector cdddar ((_ _ _ . x) . _))
+(make-check-selector cddddr (_ _ _ _ . x))
+(make-check-typed set-car! pair? _)
+(make-check-typed set-cdr! pair? _)
+(defmacro
+ check-list
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (apply list a)))
+(make-check-typed length list?)
+(defmacro
+ check-append
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (let loop ((b a))
+ (match b
+ (() #t)
+ ((l) #t)
+ (((? list?) . y) (loop y))
+ (_ (st:failure
+ (cons 'check-append ',id)
+ "invalid arguments: ~a"
+ a))))
+ (apply append a)))
+(make-check-typed reverse list?)
+(make-check-typed list-tail list? number?)
+(make-check-typed list-ref list? number?)
+(make-check-typed memq _ list?)
+(make-check-typed memv _ list?)
+(make-check-typed member _ list?)
+(defmacro
+ check-assq
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (= 2 (length a))
+ (list? (cadr a))
+ (andmap pair? (cadr a)))
+ (assq (car a) (cadr a))
+ (st:failure
+ (cons 'check-assq ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-assv
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (= 2 (length a))
+ (list? (cadr a))
+ (andmap pair? (cadr a)))
+ (assv (car a) (cadr a))
+ (st:failure
+ (cons 'check-assv ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-assoc
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (= 2 (length a))
+ (list? (cadr a))
+ (andmap pair? (cadr a)))
+ (assoc (car a) (cadr a))
+ (st:failure
+ (cons 'check-assoc ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed symbol->string symbol?)
+(make-check-typed string->symbol string?)
+(make-check-typed complex? _)
+(make-check-typed real? _)
+(make-check-typed rational? _)
+(make-check-typed integer? _)
+(make-check-typed exact? number?)
+(make-check-typed inexact? number?)
+(defmacro
+ check-=
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a)) (andmap number? a))
+ (apply = a)
+ (st:failure
+ (cons 'check-= ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-<
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a)) (andmap number? a))
+ (apply < a)
+ (st:failure
+ (cons 'check-< ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check->
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a)) (andmap number? a))
+ (apply > a)
+ (st:failure
+ (cons 'check-> ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-<=
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a)) (andmap number? a))
+ (apply <= a)
+ (st:failure
+ (cons 'check-<= ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check->=
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a)) (andmap number? a))
+ (apply >= a)
+ (st:failure
+ (cons 'check->= ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed zero? number?)
+(make-check-typed positive? number?)
+(make-check-typed negative? number?)
+(make-check-typed odd? number?)
+(make-check-typed even? number?)
+(defmacro
+ check-max
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 1 (length a)) (andmap number? a))
+ (apply max a)
+ (st:failure
+ (cons 'check-max ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-min
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 1 (length a)) (andmap number? a))
+ (apply min a)
+ (st:failure
+ (cons 'check-min ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-+
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap number? a)
+ (apply + a)
+ (st:failure
+ (cons 'check-+ ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-*
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap number? a)
+ (apply * a)
+ (st:failure
+ (cons 'check-* ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check--
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 1 (length a)) (andmap number? a))
+ (apply - a)
+ (st:failure
+ (cons 'check-- ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-/
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 1 (length a)) (andmap number? a))
+ (apply / a)
+ (st:failure
+ (cons 'check-/ ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed abs number?)
+(make-check-typed quotient number? number?)
+(make-check-typed remainder number? number?)
+(make-check-typed modulo number? number?)
+(defmacro
+ check-gcd
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap number? a)
+ (apply gcd a)
+ (st:failure
+ (cons 'check-gcd ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-lcm
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap number? a)
+ (apply lcm a)
+ (st:failure
+ (cons 'check-lcm ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed numerator number?)
+(make-check-typed denominator number?)
+(make-check-typed floor number?)
+(make-check-typed ceiling number?)
+(make-check-typed truncate number?)
+(make-check-typed round number?)
+(make-check-typed rationalize number? number?)
+(make-check-typed exp number?)
+(make-check-typed log number?)
+(make-check-typed sin number?)
+(make-check-typed cos number?)
+(make-check-typed tan number?)
+(make-check-typed asin number?)
+(make-check-typed acos number?)
+(defmacro
+ check-atan
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (andmap number? a)
+ (pair? a)
+ (>= 2 (length a)))
+ (apply atan a)
+ (st:failure
+ (cons 'check-atan ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed sqrt number?)
+(make-check-typed expt number? number?)
+(make-check-typed
+ make-rectangular
+ number?
+ number?)
+(make-check-typed make-polar number? number?)
+(make-check-typed real-part number?)
+(make-check-typed imag-part number?)
+(make-check-typed magnitude number?)
+(make-check-typed angle number?)
+(make-check-typed exact->inexact number?)
+(make-check-typed inexact->exact number?)
+(defmacro
+ check-number->string
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (andmap number? a)
+ (pair? a)
+ (>= 2 (length a)))
+ (apply number->string a)
+ (st:failure
+ (cons 'check-number->string ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-string->number
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (string? (car a))
+ (>= 2 (length a))
+ (or (null? (cdr a)) (number? (cadr a))))
+ (apply string->number a)
+ (st:failure
+ (cons 'check-string->number ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed char=? char? char?)
+(make-check-typed char<? char? char?)
+(make-check-typed char>? char? char?)
+(make-check-typed char<=? char? char?)
+(make-check-typed char>=? char? char?)
+(make-check-typed char-ci=? char? char?)
+(make-check-typed char-ci<? char? char?)
+(make-check-typed char-ci>? char? char?)
+(make-check-typed char-ci<=? char? char?)
+(make-check-typed char-ci>=? char? char?)
+(make-check-typed char-alphabetic? char?)
+(make-check-typed char-numeric? char?)
+(make-check-typed char-whitespace? char?)
+(make-check-typed char-upper-case? char?)
+(make-check-typed char-lower-case? char?)
+(make-check-typed char->integer char?)
+(make-check-typed integer->char number?)
+(make-check-typed char-upcase char?)
+(make-check-typed char-downcase char?)
+(defmacro
+ check-make-string
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (number? (car a))
+ (>= 2 (length a))
+ (or (null? (cdr a)) (char? (cadr a))))
+ (apply make-string a)
+ (st:failure
+ (cons 'check-make-string ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-string
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap char? a)
+ (apply string a)
+ (st:failure
+ (cons 'check-string ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed string-length string?)
+(make-check-typed string-ref string? number?)
+(make-check-typed
+ string-set!
+ string?
+ number?
+ char?)
+(make-check-typed string=? string? string?)
+(make-check-typed string<? string? string?)
+(make-check-typed string>? string? string?)
+(make-check-typed string<=? string? string?)
+(make-check-typed string>=? string? string?)
+(make-check-typed string-ci=? string? string?)
+(make-check-typed string-ci<? string? string?)
+(make-check-typed string-ci>? string? string?)
+(make-check-typed string-ci<=? string? string?)
+(make-check-typed string-ci>=? string? string?)
+(make-check-typed
+ substring
+ string?
+ number?
+ number?)
+(defmacro
+ check-string-append
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (andmap string? a)
+ (apply string-append a)
+ (st:failure
+ (cons 'check-string-append ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed string->list string?)
+(defmacro
+ check-list->string
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (= 1 (length a))
+ (list? (car a))
+ (andmap char? (car a)))
+ (list->string (car a))
+ (st:failure
+ (cons 'check-list->string ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed string-copy string?)
+(make-check-typed string-fill! string? char?)
+(make-check-typed make-vector number? _)
+(defmacro
+ check-vector
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (apply vector a)))
+(make-check-typed vector-length vector?)
+(make-check-typed vector-ref vector? number?)
+(make-check-typed vector-set! vector? number? _)
+(make-check-typed vector->list vector?)
+(make-check-typed list->vector list?)
+(make-check-typed vector-fill! vector? _)
+(defmacro
+ check-apply
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (pair? a)
+ (let loop ((arg (cdr a)))
+ (match arg
+ (((? list?)) (apply apply a))
+ ((_ . y) (loop y))
+ (_ (st:failure
+ (cons 'check-apply ',id)
+ "invalid arguments: ~a"
+ a))))
+ (st:failure
+ `(check-apply ,@id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-map
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a))
+ (procedure? (car a))
+ (andmap list? (cdr a)))
+ (apply map a)
+ (st:failure
+ (cons 'check-map ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-for-each
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (<= 2 (length a))
+ (procedure? (car a))
+ (andmap list? (cdr a)))
+ (apply for-each a)
+ (st:failure
+ (cons 'check-for-each ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed force procedure?)
+(defmacro
+ check-call-with-current-continuation
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (= 1 (length a)) (procedure? (car a)))
+ (call-with-current-continuation
+ (lambda (k)
+ ((car a) (check-lambda (continuation) (x) (k x)))))
+ (st:failure
+ (cons 'check-call-with-current-continuation ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed
+ call-with-input-file
+ string?
+ procedure?)
+(make-check-typed
+ call-with-output-file
+ string?
+ procedure?)
+(make-check-typed input-port? _)
+(make-check-typed output-port? _)
+(make-check-typed current-input-port)
+(make-check-typed current-output-port)
+(make-check-typed
+ with-input-from-file
+ string?
+ procedure?)
+(make-check-typed
+ with-output-to-file
+ string?
+ procedure?)
+(make-check-typed open-input-file string?)
+(make-check-typed open-output-file string?)
+(make-check-typed close-input-port input-port?)
+(make-check-typed close-output-port output-port?)
+(defmacro
+ check-read
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (or (null? a)
+ (and (= 1 (length a)) (input-port? (car a))))
+ (apply read a)
+ (st:failure
+ (cons 'check-read ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-read-char
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (or (null? a)
+ (and (= 1 (length a)) (input-port? (car a))))
+ (apply read-char a)
+ (st:failure
+ (cons 'check-read-char ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-peek-char
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (or (null? a)
+ (and (= 1 (length a)) (input-port? (car a))))
+ (apply peek-char a)
+ (st:failure
+ (cons 'check-peek-char ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-char-ready?
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (or (null? a)
+ (and (= 1 (length a)) (input-port? (car a))))
+ (apply char-ready? a)
+ (st:failure
+ (cons 'check-char-ready? ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-write
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (or (null? (cdr a)) (output-port? (cadr a))))
+ (apply write a)
+ (st:failure
+ (cons 'check-write ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-display
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (or (null? (cdr a)) (output-port? (cadr a))))
+ (apply display a)
+ (st:failure
+ (cons 'check-display ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-newline
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (or (null? a) (output-port? (car a)))
+ (apply newline a)
+ (st:failure
+ (cons 'check-newline ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-write-char
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (char? (car a))
+ (or (null? (cdr a)) (output-port? (cadr a))))
+ (apply write-char a)
+ (st:failure
+ (cons 'check-write-char ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed load string?)
+(make-check-typed transcript-on string?)
+(make-check-typed transcript-off)
+(defmacro
+ check-symbol-append
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (apply symbol-append a)))
+(make-check-typed box _)
+(make-check-typed unbox box?)
+(make-check-typed set-box! box? _)
+(make-check-typed void)
+(make-check-typed make-module _)
+(defmacro
+ check-match:error
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (pair? a)
+ (apply match:error a)
+ (st:failure
+ (cons 'check-match:error ',id)
+ "invalid arguments: ~a"
+ a))))
+(make-check-typed should-never-reach symbol?)
+(defmacro
+ check-make-cvector
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (if (and (pair? a)
+ (number? (car a))
+ (= 2 (length a)))
+ (apply make-cvector a)
+ (st:failure
+ (cons 'check-make-cvector ',id)
+ "invalid arguments: ~a"
+ a))))
+(defmacro
+ check-cvector
+ id
+ `(lambda a
+ (check-increment-counter ,(car id))
+ (apply cvector a)))
+(make-check-typed cvector-length cvector?)
+(make-check-typed cvector-ref cvector? number?)
+(make-check-typed cvector->list cvector?)
+(make-check-typed list->cvector list?)
+(defmacro
+ check-define-const-structure
+ args
+ (let ((field?
+ (lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (equal? (car x) '!)
+ (pair? (cdr x))
+ (symbol? (cadr x))
+ (null? (cddr x))))))
+ (arg-name
+ (lambda (x) (if (symbol? x) x (cadr x))))
+ (with-mutator? (lambda (x) (not (symbol? x)))))
+ (match args
+ ((((? symbol? name) (? field? id1) ...))
+ (let ((constructor (symbol-append 'make- name))
+ (check-constructor
+ (symbol-append 'check-make- name))
+ (predicate (symbol-append name '?))
+ (access
+ (let loop ((l id1))
+ (cond ((null? l) '())
+ ((eq? '_ (arg-name (car l))) (loop (cdr l)))
+ (else
+ (cons (symbol-append name '- (arg-name (car l)))
+ (loop (cdr l)))))))
+ (assign
+ (let loop ((l id1))
+ (cond ((null? l) '())
+ ((eq? '_ (arg-name (car l))) (loop (cdr l)))
+ ((not (with-mutator? (car l))) (loop (cdr l)))
+ (else
+ (cons (symbol-append
+ 'set-
+ name
+ '-
+ (arg-name (car l))
+ '!)
+ (loop (cdr l)))))))
+ (nargs (length id1)))
+ `(begin
+ (define-const-structure (,name ,@id1) ())
+ (defmacro
+ ,check-constructor
+ id
+ (lambda a
+ (check-increment-counter (,'unquote (car id)))
+ (if (= ,nargs (length a))
+ (apply ,constructor a)
+ (st:failure
+ (cons ',check-constructor '(,'unquote id))
+ "invalid arguments: ~a"
+ a))))
+ (make-check-typed ,predicate _)
+ ,@(map (lambda (a) `(make-check-typed ,a ,predicate))
+ access)
+ ,@(map (lambda (a) `(make-check-typed ,a ,predicate _))
+ assign))))
+ (x (st:failure
+ `(check-define-const-structure ,@x)
+ "syntax error")))))
+(if (equal? '(match 1) (macroexpand-1 '(match 1)))
+ (load "/home/wright/scheme/match/match-slib.scm"))
+(define sprintf
+ (lambda args (apply format #f args)))
+(define printf
+ (lambda args (apply format #t args)))
+(define disaster
+ (lambda (context fmt . args)
+ (slib:error
+ (apply sprintf
+ (string-append "in ~a: " fmt)
+ context
+ args))))
+(define use-error
+ (lambda (fmt . args)
+ (slib:error (apply sprintf fmt args))))
+(define syntax-err
+ (lambda (context fmt . args)
+ (newline)
+ (if context (pretty-print context))
+ (slib:error
+ (apply sprintf
+ (string-append "in syntax: " fmt)
+ args))))
+(define flush-output force-output)
+(define print-context
+ (lambda (obj depth)
+ (pretty-print
+ (recur loop
+ ((obj obj) (n 0))
+ (if (pair? obj)
+ (if (< n depth)
+ (cons (loop (car obj) (+ 1 n))
+ (loop (cdr obj) n))
+ '(...))
+ obj)))))
+(define *box-tag* (gensym))
+(define box (lambda (a) (cons *box-tag* a)))
+(define box?
+ (lambda (b)
+ (and (pair? b) (eq? (car b) *box-tag*))))
+(define unbox cdr)
+(define box-1 cdr)
+(define set-box! set-cdr!)
+(define sort-list sort)
+(define expand-once-if-macro
+ (lambda (e)
+ (and (macro? (car e)) (macroexpand-1 e))))
+(define ormap
+ (lambda (f . lists)
+ (if (null? (car lists))
+ (or)
+ (or (apply f (map car lists))
+ (apply ormap f (map cdr lists))))))
+(define call/cc call-with-current-continuation)
+(define (cpu-time) 0)
+(define (pretty-print x) (display x) (newline))
+(define clock-granularity 1.0e-3)
+(define set-vector! vector-set!)
+(define set-string! string-set!)
+(define maplr
+ (lambda (f l)
+ (match l
+ (() '())
+ ((x . y) (let ((v (f x))) (cons v (maplr f y)))))))
+(define maprl
+ (lambda (f l)
+ (match l
+ (() '())
+ ((x . y) (let ((v (maprl f y))) (cons (f x) v))))))
+(define foldl
+ (lambda (f i l)
+ (recur loop
+ ((l l) (acc i))
+ (match l (() acc) ((x . y) (loop y (f x acc)))))))
+(define foldr
+ (lambda (f i l)
+ (recur loop
+ ((l l))
+ (match l (() i) ((x . y) (f x (loop y)))))))
+(define filter
+ (lambda (p l)
+ (match l
+ (() '())
+ ((x . y)
+ (if (p x) (cons x (filter p y)) (filter p y))))))
+(define filter-map
+ (lambda (p l)
+ (match l
+ (() '())
+ ((x . y)
+ (match (p x)
+ (#f (filter-map p y))
+ (x (cons x (filter-map p y))))))))
+(define rac
+ (lambda (l)
+ (match l ((last) last) ((_ . rest) (rac rest)))))
+(define rdc
+ (lambda (l)
+ (match l
+ ((_) '())
+ ((x . rest) (cons x (rdc rest))))))
+(define map-with-n
+ (lambda (f l)
+ (recur loop
+ ((l l) (n 0))
+ (match l
+ (() '())
+ ((x . y)
+ (let ((v (f x n))) (cons v (loop y (+ 1 n)))))))))
+(define readfile
+ (lambda (f)
+ (with-input-from-file
+ f
+ (letrec ((rf (lambda ()
+ (match (read)
+ ((? eof-object?) '())
+ (sexp (cons sexp (rf)))))))
+ rf))))
+(define map2
+ (lambda (f a b)
+ (match (cons a b)
+ ((()) '())
+ (((ax . ay) bx . by)
+ (let ((v (f ax bx))) (cons v (map2 f ay by))))
+ (else (error 'map2 "lists differ in length")))))
+(define for-each2
+ (lambda (f a b)
+ (match (cons a b)
+ ((()) (void))
+ (((ax . ay) bx . by)
+ (f ax bx)
+ (for-each2 f ay by))
+ (else (error 'for-each2 "lists differ in length")))))
+(define andmap2
+ (lambda (f a b)
+ (match (cons a b)
+ ((()) (and))
+ (((ax) bx) (f ax bx))
+ (((ax . ay) bx . by)
+ (and (f ax bx) (andmap2 f ay by)))
+ (else (error 'andmap2 "lists differ in length")))))
+(define ormap2
+ (lambda (f a b)
+ (match (cons a b)
+ ((()) (or))
+ (((ax) bx) (f ax bx))
+ (((ax . ay) bx . by)
+ (or (f ax bx) (ormap2 f ay by)))
+ (else (error 'ormap2 "lists differ in length")))))
+(define empty-set '())
+(define empty-set? null?)
+(define set (lambda l (list->set l)))
+(define list->set
+ (match-lambda
+ (() '())
+ ((x . y)
+ (if (memq x y)
+ (list->set y)
+ (cons x (list->set y))))))
+(define element-of?
+ (lambda (x set) (and (memq x set) #t)))
+(define cardinality length)
+(define set<=
+ (lambda (a b)
+ (foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t))
+ (and)
+ a)))
+(define set-eq?
+ (lambda (a b)
+ (and (= (cardinality a) (cardinality b))
+ (set<= a b))))
+(define union2
+ (lambda (a b)
+ (if (null? b)
+ a
+ (foldr (lambda (x b) (if (memq x b) b (cons x b)))
+ b
+ a))))
+(define union (lambda l (foldr union2 '() l)))
+(define setdiff2
+ (lambda (a b)
+ (if (null? b)
+ a
+ (foldr (lambda (x c) (if (memq x b) c (cons x c)))
+ '()
+ a))))
+(define setdiff
+ (lambda l
+ (if (null? l)
+ '()
+ (setdiff2 (car l) (foldr union2 '() (cdr l))))))
+(define intersect2
+ (lambda (a b)
+ (if (null? b)
+ a
+ (foldr (lambda (x c) (if (memq x b) (cons x c) c))
+ '()
+ a))))
+(define intersect
+ (lambda l
+ (if (null? l) '() (foldl intersect2 (car l) l))))
+(define-const-structure (some _))
+(define-const-structure (none))
+(define none (make-none))
+(define some make-some)
+(define-const-structure (and exps))
+(define-const-structure (app exp exps))
+(define-const-structure (begin exps))
+(define-const-structure (const val pred))
+(define-const-structure (if exp1 exp2 exp3))
+(define-const-structure (lam names body))
+(define-const-structure (let binds body))
+(define-const-structure (let* binds body))
+(define-const-structure (letr binds body))
+(define-const-structure (or exps))
+(define-const-structure (prim name))
+(define-const-structure (delay exp))
+(define-const-structure (set! (! name) exp))
+(define-const-structure (var (! name)))
+(define-const-structure (vlam names name body))
+(define-const-structure (match exp mclauses))
+(define-const-structure (record binds))
+(define-const-structure (field name exp))
+(define-const-structure (cast type exp))
+(define-const-structure (body defs exps))
+(define-const-structure (bind name exp))
+(define-const-structure (mclause pat body fail))
+(define-const-structure (pvar name))
+(define-const-structure (pany))
+(define-const-structure (pelse))
+(define-const-structure (pconst name pred))
+(define-const-structure (pobj name pats))
+(define-const-structure (ppred name))
+(define-const-structure (pand pats))
+(define-const-structure (pnot pat))
+(define-const-structure (define name (! exp)))
+(define-const-structure
+ (defstruct
+ tag
+ args
+ make
+ pred
+ get
+ set
+ getn
+ setn
+ mutable))
+(define-const-structure (datatype _))
+(define-const-structure
+ (variant con pred arg-types))
+(define-structure
+ (name name
+ ty
+ timestamp
+ occ
+ mutated
+ gdef
+ primitive
+ struct
+ pure
+ predicate
+ variant
+ selector))
+(define-structure (type ty exp))
+(define-const-structure (shape _ _))
+(define-const-structure (check _ _))
+(define parse-def
+ (lambda (def)
+ (let ((parse-name
+ (match-lambda
+ ((? symbol? s)
+ (if (keyword? s)
+ (syntax-err def "invalid use of keyword ~a" s)
+ s))
+ (n (syntax-err def "invalid variable at ~a" n)))))
+ (match def
+ (('extend-syntax ((? symbol? name) . _) . _)
+ (printf
+ "Note: installing but _not_ checking (extend-syntax (~a) ...)~%"
+ name)
+ (eval def)
+ '())
+ (('extend-syntax . _)
+ (syntax-err def "invalid syntax"))
+ (('defmacro (? symbol? name) . _)
+ (printf
+ "Note: installing but _not_ checking (defmacro ~a ...)~%"
+ name)
+ (eval def)
+ '())
+ (('defmacro . _)
+ (syntax-err def "invalid syntax"))
+ (('define (? symbol? n) e)
+ (list (make-define (parse-name n) (parse-exp e))))
+ (('define (n . args) . body)
+ (list (make-define
+ (parse-name n)
+ (parse-exp `(lambda ,args ,@body)))))
+ (('define . _) (syntax-err def "at define"))
+ (('begin . defs)
+ (foldr append '() (smap parse-def defs)))
+ (('define-structure (n . args))
+ (parse-def `(define-structure (,n ,@args) ())))
+ (('define-structure (n . args) inits)
+ (let ((m-args (smap (lambda (x) `(! ,x)) args))
+ (m-inits
+ (smap (match-lambda
+ ((x e) `((! ,x) ,e))
+ (_ (syntax-err
+ def
+ "invalid structure initializer")))
+ inits)))
+ (parse-def
+ `(define-const-structure (,n ,@m-args) ,m-inits))))
+ (('define-const-structure ((? symbol? n) . args))
+ (parse-def
+ `(define-const-structure (,n ,@args) ())))
+ (('define-const-structure
+ ((? symbol? n) . args)
+ ())
+ (letrec ((smap-with-n
+ (lambda (f l)
+ (recur loop
+ ((l l) (n 0))
+ (match l
+ (() '())
+ ((x . y)
+ (let ((v (f x n)))
+ (cons v (loop y (+ 1 n)))))
+ (_ (syntax-err l "invalid list"))))))
+ (parse-arg
+ (lambda (a index)
+ (match a
+ (('! '_)
+ (list none
+ none
+ (some (symbol-append
+ n
+ '-
+ (+ index 1)))
+ (some (symbol-append
+ 'set-
+ n
+ '-
+ (+ index 1)
+ '!))
+ #t))
+ (('! a)
+ (let ((a (parse-name a)))
+ (list (some (symbol-append n '- a))
+ (some (symbol-append
+ 'set-
+ n
+ '-
+ a
+ '!))
+ (some (symbol-append
+ n
+ '-
+ (+ index 1)))
+ (some (symbol-append
+ 'set-
+ n
+ '-
+ (+ index 1)
+ '!))
+ #t)))
+ ('_
+ (list none
+ none
+ (some (symbol-append
+ n
+ '-
+ (+ index 1)))
+ none
+ #f))
+ (a (let ((a (parse-name a)))
+ (list (some (symbol-append n '- a))
+ none
+ (some (symbol-append
+ n
+ '-
+ (+ index 1)))
+ none
+ #f)))))))
+ (let* ((arg-info (smap-with-n parse-arg args))
+ (get (map car arg-info))
+ (set (map cadr arg-info))
+ (getn (map caddr arg-info))
+ (setn (map cadddr arg-info))
+ (mutable
+ (map (lambda (x) (car (cddddr x))) arg-info)))
+ (list (make-defstruct
+ n
+ (cons n args)
+ (symbol-append 'make- n)
+ (symbol-append n '?)
+ get
+ set
+ getn
+ setn
+ mutable)))))
+ (('define-const-structure
+ ((? symbol? n) . args)
+ inits)
+ (syntax-err
+ def
+ "sorry, structure initializers are not supported"))
+ (('datatype . d)
+ (let* ((parse-variant
+ (match-lambda
+ (((? symbol? con) ? list? args)
+ (let ((n (parse-name con)))
+ (make-variant
+ (symbol-append 'make- n)
+ (symbol-append n '?)
+ (cons con args))))
+ (_ (syntax-err def "invalid datatype syntax"))))
+ (parse-dt
+ (match-lambda
+ (((? symbol? type) . variants)
+ (cons (list (parse-name type))
+ (smap parse-variant variants)))
+ ((((? symbol? type) ? list? targs) . variants)
+ (cons (cons (parse-name type)
+ (smap parse-name targs))
+ (smap parse-variant variants)))
+ (_ (syntax-err def "invalid datatype syntax")))))
+ (list (make-datatype (smap parse-dt d)))))
+ (((? symbol? k) . _)
+ (cond ((and (not (keyword? k))
+ (expand-once-if-macro def))
+ =>
+ parse-def)
+ (else (list (make-define #f (parse-exp def))))))
+ (_ (list (make-define #f (parse-exp def))))))))
+(define keep-match #t)
+(define parse-exp
+ (lambda (expression)
+ (letrec ((n-primitive (string->symbol "#primitive"))
+ (parse-exp
+ (match-lambda
+ (('quote (? symbol? s)) (make-const s 'symbol?))
+ ((and m ('quote _)) (parse-exp (quote-tf m)))
+ ((and m ('quasiquote _))
+ (parse-exp (quasiquote-tf m)))
+ ((and m (? box?)) (parse-exp (quote-tf m)))
+ ((and m (? vector?)) (parse-exp (quote-tf m)))
+ ((and m ('cond . _)) (parse-exp (cond-tf m)))
+ ((and m ('case . _)) (parse-exp (case-tf m)))
+ ((and m ('do . _)) (parse-exp (do-tf m)))
+ ((? symbol? s) (make-var (parse-name s)))
+ (#t (make-const #t 'true-object?))
+ (#f (make-const #f 'false-object?))
+ ((? null? c) (make-const c 'null?))
+ ((? number? c) (make-const c 'number?))
+ ((? char? c) (make-const c 'char?))
+ ((? string? c) (make-const c 'string?))
+ ((': ty e1) (make-cast ty (parse-exp e1)))
+ ((and exp ('record . bind))
+ (let ((bindings (smap parse-bind bind)))
+ (no-repeats (map bind-name bindings) exp)
+ (make-record bindings)))
+ ((and exp ('field name e1))
+ (make-field (parse-name name) (parse-exp e1)))
+ ((and exp ('match e clause0 . clauses))
+ (=> fail)
+ (if keep-match
+ (let* ((e2 (parse-exp e))
+ (parse-clause
+ (match-lambda
+ ((p ('=> (? symbol? failsym)) . body)
+ (make-mclause
+ (parse-pat p expression)
+ (parse-body
+ `((let ((,failsym (lambda () (,failsym))))
+ ,@body)))
+ failsym))
+ ((p . body)
+ (make-mclause
+ (parse-pat p expression)
+ (parse-body body)
+ #f))
+ (_ (syntax-err exp "invalid match clause")))))
+ (make-match
+ e2
+ (smap parse-clause (cons clause0 clauses))))
+ (fail)))
+ ((and exp ('lambda bind . body))
+ (recur loop
+ ((b bind) (names '()))
+ (match b
+ ((? symbol? n)
+ (let ((rest (parse-name n)))
+ (no-repeats (cons rest names) exp)
+ (make-vlam
+ (reverse names)
+ rest
+ (parse-body body))))
+ (()
+ (no-repeats names exp)
+ (make-lam (reverse names) (parse-body body)))
+ ((n . x) (loop x (cons (parse-name n) names)))
+ (_ (syntax-err
+ exp
+ "invalid lambda expression")))))
+ (('if e1 e2 e3)
+ (make-if
+ (parse-exp e1)
+ (parse-exp e2)
+ (parse-exp e3)))
+ ((and if-expr ('if e1 e2))
+ (printf "Note: one-armed if: ")
+ (print-context if-expr 2)
+ (make-if
+ (parse-exp e1)
+ (parse-exp e2)
+ (parse-exp '(void))))
+ (('delay e) (make-delay (parse-exp e)))
+ (('set! n e)
+ (make-set! (parse-name n) (parse-exp e)))
+ (('and . args) (make-and (smap parse-exp args)))
+ (('or . args) (make-or (smap parse-exp args)))
+ ((and exp ('let (? symbol? n) bind . body))
+ (let* ((nb (parse-name n))
+ (bindings (smap parse-bind bind)))
+ (no-repeats (map bind-name bindings) exp)
+ (make-app
+ (make-letr
+ (list (make-bind
+ nb
+ (make-lam
+ (map bind-name bindings)
+ (parse-body body))))
+ (make-body '() (list (make-var nb))))
+ (map bind-exp bindings))))
+ ((and exp ('let bind . body))
+ (let ((bindings (smap parse-bind bind)))
+ (no-repeats (map bind-name bindings) exp)
+ (make-let bindings (parse-body body))))
+ (('let* bind . body)
+ (make-let*
+ (smap parse-bind bind)
+ (parse-body body)))
+ ((and exp ('letrec bind . body))
+ (let ((bindings (smap parse-bind bind)))
+ (no-repeats (map bind-name bindings) exp)
+ (make-letr bindings (parse-body body))))
+ (('begin e1 . rest)
+ (make-begin (smap parse-exp (cons e1 rest))))
+ (('define . _)
+ (syntax-err
+ expression
+ "invalid context for internal define"))
+ (('define-structure . _)
+ (syntax-err
+ expression
+ "invalid context for internal define-structure"))
+ (('define-const-structure . _)
+ (syntax-err
+ expression
+ "invalid context for internal define-const-structure"))
+ ((and m (f . args))
+ (cond ((and (eq? f n-primitive)
+ (match args
+ (((? symbol? p)) (make-prim p))
+ (_ #f))))
+ ((and (symbol? f)
+ (not (keyword? f))
+ (expand-once-if-macro m))
+ =>
+ parse-exp)
+ (else
+ (make-app (parse-exp f) (smap parse-exp args)))))
+ (x (syntax-err
+ expression
+ "invalid expression at ~a"
+ x))))
+ (parse-name
+ (match-lambda
+ ((? symbol? s)
+ (when (keyword? s)
+ (syntax-err
+ expression
+ "invalid use of keyword ~a"
+ s))
+ s)
+ (n (syntax-err
+ expression
+ "invalid variable at ~a"
+ n))))
+ (parse-bind
+ (match-lambda
+ ((x e) (make-bind (parse-name x) (parse-exp e)))
+ (b (syntax-err expression "invalid binding at ~a" b))))
+ (parse-body
+ (lambda (body)
+ (recur loop
+ ((b body) (defs '()))
+ (match b
+ (((and d ('define . _)) . rest)
+ (loop rest (append defs (parse-def d))))
+ (((and d ('define-structure . _)) . rest)
+ (loop rest (append defs (parse-def d))))
+ (((and d ('define-const-structure . _)) . rest)
+ (loop rest (append defs (parse-def d))))
+ ((('begin) . rest) (loop rest defs))
+ (((and beg ('begin ('define . _) . _)) . rest)
+ (loop rest (append defs (parse-def beg))))
+ (((and beg ('begin ('define-structure . _) . _))
+ .
+ rest)
+ (loop rest (append defs (parse-def beg))))
+ (((and beg
+ ('begin
+ ('define-const-structure . _)
+ .
+ _))
+ .
+ rest)
+ (loop rest (append defs (parse-def beg))))
+ ((_ . _) (make-body defs (smap parse-exp b)))
+ (_ (syntax-err
+ expression
+ "invalid body at ~a"
+ b))))))
+ (no-repeats
+ (lambda (l exp)
+ (match l
+ (() #f)
+ ((_) #f)
+ ((x . l)
+ (if (memq x l)
+ (syntax-err exp "name ~a repeated" x)
+ (no-repeats l exp)))))))
+ (parse-exp expression))))
+(define parse-pat
+ (lambda (pat expression)
+ (letrec ((parse-pat
+ (match-lambda
+ (#f (make-ppred 'false-object?))
+ (#t (make-ppred 'true-object?))
+ (() (make-ppred 'null?))
+ ((? number? c) (make-pconst c 'number?))
+ ((? char? c) (make-pconst c 'char?))
+ ((? string? c) (make-pconst c 'string?))
+ (('quote x) (parse-quote x))
+ ('_ (make-pany))
+ ('else (make-pelse))
+ ((? symbol? n) (make-pvar (parse-pname n)))
+ (('not . pats)
+ (syntax-err
+ expression
+ "not patterns are not supported"))
+ (('or . pats)
+ (syntax-err
+ expression
+ "or patterns are not supported"))
+ (('get! . pats)
+ (syntax-err
+ expression
+ "get! patterns are not supported"))
+ (('set! . pats)
+ (syntax-err
+ expression
+ "set! patterns are not supported"))
+ (('and . pats)
+ (let* ((pats (smap parse-pat pats))
+ (p (make-flat-pand pats))
+ (non-var?
+ (match-lambda
+ ((? pvar?) #f)
+ ((? pany?) #f)
+ (_ #t))))
+ (match p
+ (($ pand pats)
+ (when (< 1 (length (filter non-var? pats)))
+ (syntax-err
+ expression
+ "~a has conflicting subpatterns"
+ (ppat p))))
+ (_ #f))
+ p))
+ (('? (? symbol? pred) p)
+ (parse-pat `(and (? ,pred) ,p)))
+ (('? (? symbol? pred))
+ (if (keyword? pred)
+ (syntax-err
+ expression
+ "invalid use of keyword ~a"
+ pred)
+ (make-ppred pred)))
+ (('$ (? symbol? c) . args)
+ (if (memq c '(? _ $))
+ (syntax-err
+ expression
+ "invalid use of pattern keyword ~a"
+ c)
+ (make-pobj
+ (symbol-append c '?)
+ (smap parse-pat args))))
+ ((? box? cb)
+ (make-pobj 'box? (list (parse-pat (unbox cb)))))
+ ((x . y)
+ (make-pobj
+ 'pair?
+ (list (parse-pat x) (parse-pat y))))
+ ((? vector? v)
+ (make-pobj
+ 'vector?
+ (map parse-pat (vector->list v))))
+ (m (syntax-err expression "invalid pattern at ~a" m))))
+ (parse-quote
+ (match-lambda
+ (#f (make-pobj 'false-object? '()))
+ (#t (make-pobj 'true-object? '()))
+ (() (make-pobj 'null? '()))
+ ((? number? c) (make-pconst c 'number?))
+ ((? char? c) (make-pconst c 'char?))
+ ((? string? c) (make-pconst c 'string?))
+ ((? symbol? s) (make-pconst s 'symbol?))
+ ((? box? cb)
+ (make-pobj 'box? (list (parse-quote (unbox cb)))))
+ ((x . y)
+ (make-pobj
+ 'pair?
+ (list (parse-quote x) (parse-quote y))))
+ ((? vector? v)
+ (make-pobj
+ 'vector?
+ (map parse-quote (vector->list v))))
+ (m (syntax-err expression "invalid pattern at ~a" m))))
+ (parse-pname
+ (match-lambda
+ ((? symbol? s)
+ (cond ((keyword? s)
+ (syntax-err
+ expression
+ "invalid use of keyword ~a"
+ s))
+ ((memq s '(? _ else $ and or not set! get! ...))
+ (syntax-err
+ expression
+ "invalid use of pattern keyword ~a"
+ s))
+ (else s)))
+ (n (syntax-err
+ expression
+ "invalid pattern variable at ~a"
+ n)))))
+ (parse-pat pat))))
+(define smap
+ (lambda (f l)
+ (match l
+ (() '())
+ ((x . r) (let ((v (f x))) (cons v (smap f r))))
+ (_ (syntax-err l "invalid list")))))
+(define primitive
+ (lambda (p)
+ (list (string->symbol "#primitive") p)))
+(define keyword?
+ (lambda (s)
+ (or (memq s
+ '(=> and
+ begin
+ case
+ cond
+ do
+ define
+ delay
+ if
+ lambda
+ let
+ let*
+ letrec
+ or
+ quasiquote
+ quote
+ set!
+ unquote
+ unquote-splicing
+ define-structure
+ define-const-structure
+ record
+ field
+ :
+ datatype))
+ (and keep-match (eq? s 'match)))))
+(define make-flat-pand
+ (lambda (pats)
+ (let* ((l (foldr (lambda (p plist)
+ (match p
+ (($ pand pats) (append pats plist))
+ (_ (cons p plist))))
+ '()
+ pats))
+ (concrete?
+ (match-lambda
+ ((? pconst?) #t)
+ ((? pobj?) #t)
+ ((? ppred?) #t)
+ (_ #f)))
+ (sorted
+ (append
+ (filter concrete? l)
+ (filter (lambda (x) (not (concrete? x))) l))))
+ (match sorted ((p) p) (_ (make-pand sorted))))))
+(define never-counter 0)
+(define reinit-macros!
+ (lambda () (set! never-counter 0)))
+(define cond-tf
+ (lambda (cond-expr)
+ (recur loop
+ ((e (cdr cond-expr)))
+ (match e
+ (()
+ (begin
+ (set! never-counter (+ 1 never-counter))
+ `(,(primitive 'should-never-reach)
+ '(cond ,never-counter))))
+ ((('else b1 . body)) `(begin ,b1 ,@body))
+ ((('else . _) . _)
+ (syntax-err cond-expr "invalid cond expression"))
+ (((test '=> proc) . rest)
+ (let ((g (gensym)))
+ `(let ((,g ,test))
+ (if ,g (,proc ,g) ,(loop rest)))))
+ (((#t b1 . body)) `(begin ,b1 ,@body))
+ (((test) . rest) `(or ,test ,(loop rest)))
+ (((test . body) . rest)
+ `(if ,test (begin ,@body) ,(loop rest)))
+ (_ (syntax-err cond-expr "invalid cond expression"))))))
+(define scheme-cond-tf
+ (lambda (cond-expr)
+ (recur loop
+ ((e (cdr cond-expr)))
+ (match e
+ (() `(,(primitive 'void)))
+ ((('else b1 . body)) `(begin ,b1 ,@body))
+ ((('else . _) . _)
+ (syntax-err cond-expr "invalid cond expression"))
+ (((test '=> proc) . rest)
+ (let ((g (gensym)))
+ `(let ((,g ,test))
+ (if ,g (,proc ,g) ,(loop rest)))))
+ (((#t b1 . body)) `(begin ,b1 ,@body))
+ (((test) . rest) `(or ,test ,(loop rest)))
+ (((test . body) . rest)
+ `(if ,test (begin ,@body) ,(loop rest)))
+ (_ (syntax-err cond-expr "invalid cond expression"))))))
+(define case-tf
+ (lambda (case-expr)
+ (recur loop
+ ((e (cdr case-expr)))
+ (match e
+ ((exp) `(begin ,exp (,(primitive 'void))))
+ ((exp ('else b1 . body)) `(begin ,b1 ,@body))
+ ((exp ('else . _) . _)
+ (syntax-err case-expr "invalid case expression"))
+ (((? symbol? exp)
+ ((? list? test) b1 . body)
+ .
+ rest)
+ `(if (,(primitive 'memv) ,exp ',test)
+ (begin ,b1 ,@body)
+ ,(loop (cons exp rest))))
+ (((? symbol? exp) (test b1 . body) . rest)
+ `(if (,(primitive 'memv) ,exp '(,test))
+ (begin ,b1 ,@body)
+ ,(loop (cons exp rest))))
+ ((exp . rest)
+ (if (not (symbol? exp))
+ (let ((g (gensym)))
+ `(let ((,g ,exp)) ,(loop (cons g rest))))
+ (syntax-err case-expr "invalid case expression")))
+ (_ (syntax-err case-expr "invalid case expression"))))))
+(define conslimit 8)
+(define quote-tf
+ (lambda (exp)
+ (letrec ((qloop (match-lambda
+ ((? box? q)
+ `(,(primitive qbox) ,(qloop (unbox q))))
+ ((? symbol? q) `',q)
+ ((? null? q) q)
+ ((? list? q)
+ (if (< (length q) conslimit)
+ `(,(primitive qcons)
+ ,(qloop (car q))
+ ,(qloop (cdr q)))
+ `(,(primitive qlist) ,@(map qloop q))))
+ ((x . y)
+ `(,(primitive qcons) ,(qloop x) ,(qloop y)))
+ ((? vector? q)
+ `(,(primitive qvector)
+ ,@(map qloop (vector->list q))))
+ ((? boolean? q) q)
+ ((? number? q) q)
+ ((? char? q) q)
+ ((? string? q) q)
+ (q (syntax-err
+ exp
+ "invalid quote expression at ~a"
+ q)))))
+ (match exp
+ (('quote q) (qloop q))
+ ((? vector? q) (qloop q))
+ ((? box? q) (qloop q))))))
+(define quasiquote-tf
+ (lambda (exp)
+ (letrec ((make-cons
+ (lambda (x y)
+ (cond ((null? y) `(,(primitive 'list) ,x))
+ ((and (pair? y)
+ (equal? (car y) (primitive 'list)))
+ (cons (car y) (cons x (cdr y))))
+ (else `(,(primitive 'cons) ,x ,y)))))
+ (qloop (lambda (e n)
+ (match e
+ (('quasiquote e)
+ (make-cons 'quasiquote (qloop `(,e) (+ 1 n))))
+ (('unquote e)
+ (if (zero? n)
+ e
+ (make-cons 'unquote (qloop `(,e) (- n 1)))))
+ (('unquote-splicing e)
+ (if (zero? n)
+ e
+ (make-cons
+ 'unquote-splicing
+ (qloop `(,e) (- n 1)))))
+ ((('unquote-splicing e) . y)
+ (=> fail)
+ (if (zero? n)
+ (if (null? y)
+ e
+ `(,(primitive 'append) ,e ,(qloop y n)))
+ (fail)))
+ ((? box? q)
+ `(,(primitive 'box) ,(qloop (unbox q) n)))
+ ((? symbol? q)
+ (if (memq q
+ '(quasiquote unquote unquote-splicing))
+ (syntax-err
+ exp
+ "invalid use of ~a inside quasiquote"
+ q)
+ `',q))
+ ((? null? q) q)
+ ((x . y) (make-cons (qloop x n) (qloop y n)))
+ ((? vector? q)
+ `(,(primitive 'vector)
+ ,@(map (lambda (z) (qloop z n))
+ (vector->list q))))
+ ((? boolean? q) q)
+ ((? number? q) q)
+ ((? char? q) q)
+ ((? string? q) q)
+ (q (syntax-err
+ exp
+ "invalid quasiquote expression at ~a"
+ q))))))
+ (match exp (('quasiquote q) (qloop q 0))))))
+(define do-tf
+ (lambda (do-expr)
+ (recur loop
+ ((e (cdr do-expr)))
+ (match e
+ (((? list? vis) (e0 ? list? e1) ? list? c)
+ (if (andmap (match-lambda ((_ _ . _) #t) (_ #f)) vis)
+ (let* ((var (map car vis))
+ (init (map cadr vis))
+ (step (map cddr vis))
+ (step (map (lambda (v s)
+ (match s
+ (() v)
+ ((e) e)
+ (_ (syntax-err
+ do-expr
+ "invalid do expression"))))
+ var
+ step)))
+ (let ((doloop (gensym)))
+ (match e1
+ (()
+ `(let ,doloop
+ ,(map list var init)
+ (if (not ,e0)
+ (begin ,@c (,doloop ,@step) (void))
+ (void))))
+ ((body0 ? list? body)
+ `(let ,doloop
+ ,(map list var init)
+ (if ,e0
+ (begin ,body0 ,@body)
+ (begin ,@c (,doloop ,@step)))))
+ (_ (syntax-err
+ do-expr
+ "invalid do expression")))))
+ (syntax-err do-expr "invalid do expression")))
+ (_ (syntax-err do-expr "invalid do expression"))))))
+(define empty-env '())
+(define lookup
+ (lambda (env x)
+ (match (assq x env)
+ (#f (disaster 'lookup "no binding for ~a" x))
+ ((_ . b) b))))
+(define lookup?
+ (lambda (env x)
+ (match (assq x env) (#f #f) ((_ . b) b))))
+(define bound?
+ (lambda (env x)
+ (match (assq x env) (#f #f) (_ #t))))
+(define extend-env
+ (lambda (env x v) (cons (cons x v) env)))
+(define extend-env*
+ (lambda (env xs vs)
+ (append (map2 cons xs vs) env)))
+(define join-env
+ (lambda (env newenv) (append newenv env)))
+(define populated #t)
+(define pseudo #f)
+(define global-error #f)
+(define share #f)
+(define matchst #f)
+(define fullsharing #t)
+(define dump-depths #f)
+(define flags #t)
+(define-structure
+ (c depth kind fsym pres args next))
+(define-structure
+ (v depth kind name vis split inst))
+(define-structure (ts type n-gen))
+(define-structure (k name order args))
+(define top (box 'top))
+(define bot (box 'bot))
+(define generic? (lambda (d) (< d 0)))
+(define new-type
+ (lambda (s d)
+ (let ((t (box s)))
+ (vector-set!
+ types
+ d
+ (cons t (vector-ref types d)))
+ t)))
+(define generate-counter
+ (lambda ()
+ (let ((n 0)) (lambda () (set! n (+ 1 n)) n))))
+(define var-counter (generate-counter))
+(define make-raw-tvar
+ (lambda (d k) (make-v d k var-counter #t #f #f)))
+(define make-tvar
+ (lambda (d k) (new-type (make-raw-tvar d k) d)))
+(define ord? (lambda (k) (eq? 'ord k)))
+(define abs? (lambda (k) (eq? 'abs k)))
+(define pre? (lambda (k) (eq? 'pre k)))
+(define ord-depth 2)
+(define depth ord-depth)
+(define types (make-vector 16 '()))
+(define reset-types!
+ (lambda ()
+ (set! depth ord-depth)
+ (set! types (make-vector 16 '()))))
+(define push-level
+ (lambda ()
+ (set! depth (+ depth 1))
+ (when (< (vector-length types) (+ 1 depth))
+ (set! types
+ (let ((l (vector->list types)))
+ (list->vector
+ (append l (map (lambda (_) '()) l))))))))
+(define pop-level
+ (lambda ()
+ (vector-set! types depth '())
+ (set! depth (- depth 1))))
+(define v-ord (lambda () (make-tvar depth 'ord)))
+(define v-abs (lambda () (make-tvar depth 'abs)))
+(define v-pre (lambda () (make-tvar depth 'pre)))
+(define tvar v-ord)
+(define out1tvar
+ (lambda () (make-tvar (- depth 1) 'ord)))
+(define monotvar
+ (lambda () (make-tvar ord-depth 'ord)))
+(define pvar
+ (match-lambda
+ (($ box (and x ($ v d k _ vis _ _)))
+ (unless
+ (number? (v-name x))
+ (set-v-name! x ((v-name x))))
+ (string->symbol
+ (sprintf
+ "~a~a~a"
+ (match k
+ ('ord
+ (if (generic? d)
+ (if vis "X" "x")
+ (if vis "Z" "z")))
+ ('abs (if vis "A" "a"))
+ ('pre (if vis "P" "p")))
+ (v-name x)
+ (if dump-depths (sprintf ".~a" d) ""))))))
+(define make-tvar-like
+ (match-lambda
+ (($ box ($ v d k _ _ _ _)) (make-tvar d k))))
+(define ind*
+ (lambda (t)
+ (match (unbox t)
+ ((? box? u)
+ (let ((v (ind* u))) (set-box! t v) v))
+ (_ t))))
+(define type-check?
+ (match-lambda
+ ((abs def inexhaust once _)
+ (cond (((if once check-abs1? check-abs?) abs)
+ (if (and def (definite? def)) 'def #t))
+ (inexhaust 'inexhaust)
+ (else #f)))))
+(define type-check1?
+ (match-lambda
+ ((abs def inexhaust _ _)
+ (cond ((check-abs1? abs)
+ (if (and def (definite? def)) 'def #t))
+ (inexhaust 'inexhaust)
+ (else #f)))))
+(define check-abs?
+ (lambda (vlist)
+ (letrec ((seen '())
+ (labs? (lambda (t)
+ (match t
+ (($ box ($ v _ _ _ _ _ inst))
+ (and inst
+ (not (memq t seen))
+ (begin
+ (set! seen (cons t seen))
+ (ormap (match-lambda ((t . _) (labs? t)))
+ inst))))
+ (($ box ($ c _ _ _ p _ n))
+ (or (labs? p) (labs? n)))
+ (($ box (? symbol?)) #t)
+ (($ box i) (labs? i))))))
+ (ormap labs? vlist))))
+(define check-abs1?
+ (lambda (vlist)
+ (letrec ((labs1?
+ (lambda (t)
+ (match t
+ (($ box (? v?)) #f)
+ (($ box ($ c _ _ _ p _ n))
+ (or (labs1? p) (labs1? n)))
+ (($ box (? symbol?)) #t)
+ (($ box i) (labs1? i))))))
+ (ormap labs1? vlist))))
+(define check-sources
+ (lambda (info)
+ (letrec ((seen '())
+ (lsrcs (lambda (t source)
+ (match t
+ (($ box ($ v _ k _ _ _ inst))
+ (union (if (and inst (not (memq t seen)))
+ (begin
+ (set! seen (cons t seen))
+ (foldr union
+ empty-set
+ (map (match-lambda
+ ((t . s) (lsrcs t s)))
+ inst)))
+ empty-set)))
+ (($ box ($ c _ _ _ p _ n))
+ (union (lsrcs p source) (lsrcs n source)))
+ (($ box (? symbol?))
+ (if source (set source) empty-set))
+ (($ box i) (lsrcs i source))))))
+ (match-let
+ (((abs _ _ _ _) info))
+ (if (eq? #t abs)
+ empty-set
+ (foldr union
+ empty-set
+ (map (lambda (t) (lsrcs t #f)) abs)))))))
+(define check-local-sources
+ (match-lambda ((_ _ _ _ component) component)))
+(define mk-definite-prim
+ (match-lambda
+ (($ box ($ c _ _ x p a n))
+ (if (eq? (k-name x) '?->)
+ (let ((seen '()))
+ (recur lprim
+ ((t (car a)))
+ (match t
+ (($ box ($ c _ _ x p a n))
+ (if (memq t seen)
+ '()
+ (begin
+ (set! seen (cons t seen))
+ (match (k-name x)
+ ('noarg (cons p (lprim n)))
+ ('arg
+ (let ((args (recur argloop
+ ((a (car a)))
+ (match a
+ (($ box
+ ($ c
+ _
+ _
+ _
+ p
+ _
+ n))
+ (cons p
+ (argloop
+ n)))
+ (($ box
+ ($ v
+ _
+ k
+ _
+ _
+ _
+ _))
+ (if (ord? k)
+ (list a)
+ '()))
+ (($ box
+ (? symbol?))
+ '())
+ (($ box i)
+ (argloop i))))))
+ (cons (list p args (lprim (cadr a)))
+ (lprim n))))))))
+ (($ box ($ v _ k _ _ _ _))
+ (if (ord? k) (list t) '()))
+ (($ box (? symbol?)) '())
+ (($ box i) (lprim i)))))
+ (mk-definite-prim n)))
+ (($ box (? v?)) '())
+ (($ box (? symbol?)) '())
+ (($ box i) (mk-definite-prim i))))
+(define mk-definite-app
+ (match-lambda
+ (($ box ($ c _ _ _ p _ _)) (list p))))
+(define mk-definite-lam
+ (match-lambda
+ (($ box ($ c _ _ x p a n))
+ (if (eq? (k-name x) '?->)
+ (let ((seen '()))
+ (recur llam
+ ((t (car a)))
+ (match t
+ (($ box ($ c _ _ x p a n))
+ (if (memq t seen)
+ '()
+ (begin
+ (set! seen (cons t seen))
+ (match (k-name x)
+ ('noarg (cons p (llam n)))
+ ('arg
+ (let ((args (list top)))
+ (cons (list p args (llam (cadr a)))
+ (llam n))))))))
+ (($ box ($ v _ k _ _ _ _))
+ (if (ord? k) (list t) '()))
+ (($ box (? symbol?)) '())
+ (($ box i) (llam i)))))
+ (mk-definite-lam n)))
+ (($ box (? v?)) '())
+ (($ box (? symbol?)) '())
+ (($ box i) (mk-definite-lam i))))
+(define definite?
+ (lambda (def-info)
+ (letrec ((non-empty?
+ (lambda (t)
+ (let ((seen '()))
+ (recur ldef
+ ((t t))
+ (match t
+ (($ box ($ c _ _ _ p _ n))
+ (or (ldef p) (ldef n)))
+ (($ box ($ v d k _ _ _ inst))
+ (if (or global-error (abs? k))
+ (and inst
+ (generic? d)
+ (not (memq t seen))
+ (begin
+ (set! seen (cons t seen))
+ (ormap (match-lambda
+ ((t . _) (ldef t)))
+ inst)))
+ (generic? d)))
+ (($ box 'top) #t)
+ (($ box 'bot) #f)
+ (($ box i) (ldef i)))))))
+ (ok (lambda (l)
+ (ormap (match-lambda
+ ((? box? t) (non-empty? t))
+ ((p arg rest)
+ (and (non-empty? p)
+ (ormap non-empty? arg)
+ (ok rest))))
+ l))))
+ (not (ok def-info)))))
+(define close
+ (lambda (t-list) (close-type t-list #f)))
+(define closeall
+ (lambda (t) (car (close-type (list t) #t))))
+(define for
+ (lambda (from to f)
+ (cond ((= from to) (f from))
+ ((< from to)
+ (begin (f from) (for (+ from 1) to f)))
+ (else #f))))
+(define close-type
+ (lambda (t-list all?)
+ (let* ((sorted (make-vector (+ depth 1) '()))
+ (sort (lambda (t)
+ (match t
+ (($ box ($ c d _ _ _ _ _))
+ (vector-set!
+ sorted
+ d
+ (cons t (vector-ref sorted d))))
+ (($ box ($ v d _ _ _ _ _))
+ (vector-set!
+ sorted
+ d
+ (cons t (vector-ref sorted d))))
+ (_ #f))))
+ (prop-d
+ (lambda (down)
+ (letrec ((pr (match-lambda
+ (($ box (and x ($ v d _ _ _ _ _)))
+ (when (< down d) (set-v-depth! x down)))
+ (($ box (and x ($ c d _ _ p a n)))
+ (when (< down d)
+ (set-c-depth! x down)
+ (pr p)
+ (for-each pr a)
+ (pr n)))
+ (($ box (? symbol?)) #f)
+ (z (pr (ind* z))))))
+ (match-lambda
+ (($ box (and x ($ c d _ _ p a n)))
+ (when (<= down d) (pr p) (for-each pr a) (pr n)))
+ (_ #f)))))
+ (prop-k
+ (lambda (t)
+ (let ((pk (lambda (kind)
+ (rec pr
+ (match-lambda
+ (($ box (and x ($ v _ k _ _ _ _)))
+ (when (kind< kind k) (set-v-kind! x kind)))
+ (($ box (and x ($ c _ k _ p a n)))
+ (when (kind< kind k)
+ (set-c-kind! x kind)
+ (pr p)
+ (unless populated (for-each pr a))
+ (pr n)))
+ (($ box (? symbol?)) #f)
+ (z (pr (ind* z))))))))
+ (match t
+ (($ box (and x ($ c _ k _ p a n)))
+ (when (not (ord? k))
+ (let ((prop (pk k)))
+ (prop p)
+ (unless populated (for-each prop a))
+ (prop n))))
+ (_ #f)))))
+ (might-be-generalized?
+ (match-lambda
+ (($ box ($ v d k _ _ _ _))
+ (and (<= depth d) (or populated (ord? k) all?)))
+ (($ box ($ c d k _ _ _ _))
+ (and (<= depth d) (or populated (ord? k) all?)))
+ (($ box (? symbol?)) #f)))
+ (leaves '())
+ (depth-of
+ (match-lambda
+ (($ box ($ v d _ _ _ _ _)) d)
+ (($ box ($ c d _ _ _ _ _)) d)))
+ (vector-grow
+ (lambda (v)
+ (let* ((n (vector-length v))
+ (v2 (make-vector (* n 2) '())))
+ (recur loop
+ ((i 0))
+ (when (< i n)
+ (vector-set! v2 i (vector-ref v i))
+ (loop (+ 1 i))))
+ v2)))
+ (parents (make-vector 64 '()))
+ (parent-index 0)
+ (parents-of
+ (lambda (t)
+ (let ((d (depth-of t)))
+ (if (< depth d)
+ (vector-ref parents (- (- d depth) 1))
+ '()))))
+ (xtnd-parents!
+ (lambda (t parent)
+ (match t
+ (($ box (and x ($ v d _ _ _ _ _)))
+ (when (= d depth)
+ (set! parent-index (+ 1 parent-index))
+ (set-v-depth! x (+ depth parent-index))
+ (when (< (vector-length parents) parent-index)
+ (set! parents (vector-grow parents)))
+ (set! d (+ depth parent-index)))
+ (vector-set!
+ parents
+ (- (- d depth) 1)
+ (cons parent
+ (vector-ref parents (- (- d depth) 1)))))
+ (($ box (and x ($ c d _ _ _ _ _)))
+ (when (= d depth)
+ (set! parent-index (+ 1 parent-index))
+ (set-c-depth! x (+ depth parent-index))
+ (when (< (vector-length parents) parent-index)
+ (set! parents (vector-grow parents)))
+ (set! d (+ depth parent-index)))
+ (vector-set!
+ parents
+ (- (- d depth) 1)
+ (cons parent
+ (vector-ref parents (- (- d depth) 1))))))))
+ (needs-cleanup '())
+ (revtype
+ (rec revtype
+ (lambda (parent t)
+ (let ((t (ind* t)))
+ (cond ((not (might-be-generalized? t)) #f)
+ ((null? (parents-of t))
+ (xtnd-parents! t parent)
+ (set! needs-cleanup (cons t needs-cleanup))
+ (match t
+ (($ box (? v?))
+ (set! leaves (cons t leaves)))
+ (($ box ($ c _ _ _ p a n))
+ (let ((rev (lambda (q) (revtype t q))))
+ (rev p)
+ (for-each rev a)
+ (rev n)))))
+ ((not (memq parent (parents-of t)))
+ (xtnd-parents! t parent))
+ (else #f))))))
+ (generic-index 0)
+ (gen (rec gen
+ (lambda (t)
+ (let ((t (ind* t)))
+ (when (might-be-generalized? t)
+ (set! generic-index (- generic-index 1))
+ (let ((parents (parents-of t)))
+ (match t
+ (($ box (and x ($ v _ k _ _ _ _)))
+ (set-v-depth! x generic-index)
+ (when (and populated
+ (or global-error
+ (abs? k)
+ (pre? k))
+ (not all?))
+ (set-v-inst! x '())))
+ (($ box (? c? x))
+ (set-c-depth! x generic-index)))
+ (for-each gen parents)))))))
+ (cleanup
+ (match-lambda
+ (($ box (and x ($ v d _ _ _ _ _)))
+ (unless (< d 0) (set-v-depth! x (- depth 1))))
+ (($ box (and x ($ c d _ _ _ _ _)))
+ (unless (< d 0) (set-c-depth! x (- depth 1))))))
+ (gen2 (rec gen
+ (lambda (t)
+ (let ((t (ind* t)))
+ (when (might-be-generalized? t)
+ (set! generic-index (- generic-index 1))
+ (match t
+ (($ box (and x ($ v _ k _ _ _ _)))
+ (set-v-depth! x generic-index)
+ (when (and populated
+ (or global-error
+ (abs? k)
+ (pre? k))
+ (not all?))
+ (set-v-inst! x '())))
+ (($ box (and x ($ c _ _ _ p a n)))
+ (set-c-depth! x generic-index)
+ (gen p)
+ (for-each gen a)
+ (gen n))))))))
+ (upd (lambda (t)
+ (let ((d (depth-of t)))
+ (when (< 0 d)
+ (vector-set!
+ types
+ d
+ (cons t (vector-ref types d))))))))
+ (for-each sort (vector-ref types depth))
+ (for 0
+ (- depth 1)
+ (lambda (i)
+ (for-each (prop-d i) (vector-ref sorted i))))
+ (for-each prop-k (vector-ref types depth))
+ (vector-set! types depth '())
+ (if fullsharing
+ (begin
+ (for-each (lambda (t) (revtype t t)) t-list)
+ (for-each gen leaves)
+ (for-each cleanup needs-cleanup))
+ (for-each gen2 t-list))
+ (for 0
+ depth
+ (lambda (i) (for-each upd (vector-ref sorted i))))
+ (if (null? t-list)
+ '()
+ (match-let*
+ ((n-gen (- generic-index))
+ ((t-list n-gen)
+ (if (and pseudo flags (not all?))
+ (pseudo t-list n-gen)
+ (list t-list n-gen))))
+ (visible t-list n-gen)
+ (map (lambda (t) (make-ts t n-gen)) t-list))))))
+(define visible-time 0)
+(define visible
+ (lambda (t-list n-gen)
+ (let* ((before (cpu-time))
+ (valences (make-vector n-gen '()))
+ (namer (generate-counter))
+ (lvis (rec lvis
+ (lambda (t pos rcd)
+ (match t
+ (($ box ($ c d _ x p a n))
+ (when (and (generic? d)
+ (not (element-of?
+ pos
+ (vector-ref
+ valences
+ (- (- d) 1)))))
+ (let ((u (union (vector-ref
+ valences
+ (- (- d) 1))
+ (set pos))))
+ (vector-set! valences (- (- d) 1) u))
+ (lvis p pos rcd)
+ (match (k-name x)
+ ('?->
+ (lvis (car a) (not pos) #f)
+ (lvis (cadr a) pos #f))
+ ('record (lvis (car a) pos #t))
+ (_ (for-each
+ (lambda (x) (lvis x pos #f))
+ a)))
+ (lvis n pos rcd)))
+ (($ box (and x ($ v d k _ _ _ _)))
+ (when (and (generic? d)
+ (not (element-of?
+ pos
+ (vector-ref
+ valences
+ (- (- d) 1)))))
+ (let ((u (union (vector-ref
+ valences
+ (- (- d) 1))
+ (set pos))))
+ (vector-set! valences (- (- d) 1) u)
+ (set-v-name! x namer)
+ (cond ((abs? k) #f)
+ ((= 2 (cardinality u))
+ (set-v-split! x #t)
+ (set-v-vis! x #t))
+ ((eq? pos rcd) (set-v-vis! x #t))
+ (else (set-v-vis! x #f))))))
+ (($ box (? symbol?)) #f)
+ (($ box i) (lvis i pos rcd)))))))
+ (for-each (lambda (t) (lvis t #t #f)) t-list)
+ (set! visible-time
+ (+ visible-time (- (cpu-time) before))))))
+(define visible?
+ (match-lambda
+ (($ box ($ v _ k _ vis _ _))
+ (or (pre? k) (and vis (not (abs? k)))))
+ (($ box 'top) #t)
+ (($ box 'bot) #f)
+ (($ box i) (visible? i))))
+(define instantiate
+ (lambda (ts syntax)
+ (match ts
+ (($ ts t n-gen)
+ (let* ((absv '())
+ (seen (make-vector n-gen #f))
+ (t2 (recur linst
+ ((t t))
+ (match t
+ (($ box (and y ($ v d k _ _ _ inst)))
+ (cond ((not (generic? d)) t)
+ ((vector-ref seen (- (- d) 1)))
+ (else
+ (let ((u (make-tvar depth k)))
+ (vector-set! seen (- (- d) 1) u)
+ (when inst
+ (set-v-inst!
+ y
+ (cons (cons u syntax)
+ inst)))
+ (when (or (abs? k) (pre? k))
+ (set! absv (cons u absv)))
+ u))))
+ (($ box ($ c d _ x p a n))
+ (cond ((not (generic? d)) t)
+ ((vector-ref seen (- (- d) 1)))
+ (else
+ (let ((u (new-type
+ '**fix**
+ depth)))
+ (vector-set! seen (- (- d) 1) u)
+ (set-box!
+ u
+ (make-c
+ depth
+ 'ord
+ x
+ (if flags (linst p) top)
+ (map linst a)
+ (linst n)))
+ u))))
+ (($ box (? symbol?)) t)
+ (($ box i) (linst i))))))
+ (list t2 absv))))))
+(define pseudo-subtype
+ (lambda (t-list n-gen)
+ (let* ((valences (make-vector n-gen '()))
+ (valence-of
+ (lambda (d) (vector-ref valences (- (- d) 1))))
+ (set-valence
+ (lambda (d v)
+ (vector-set! valences (- (- d) 1) v)))
+ (find (rec find
+ (lambda (t pos mutable)
+ (match t
+ (($ box ($ v d _ _ _ _ _))
+ (when (generic? d)
+ (cond (mutable
+ (set-valence d (set #t #f)))
+ ((not (element-of?
+ pos
+ (valence-of d)))
+ (set-valence
+ d
+ (union (valence-of d)
+ (set pos))))
+ (else #f))))
+ (($ box ($ c d _ x p a n))
+ (when (generic? d)
+ (cond ((= 2 (cardinality (valence-of d)))
+ #f)
+ (mutable
+ (set-valence d (set #t #f))
+ (for-each2
+ (lambda (t m)
+ (find t pos mutable))
+ a
+ (k-args x))
+ (find n pos mutable))
+ ((not (element-of?
+ pos
+ (valence-of d)))
+ (set-valence
+ d
+ (union (valence-of d)
+ (set pos)))
+ (if (eq? '?-> (k-name x))
+ (begin
+ (find (car a)
+ (not pos)
+ mutable)
+ (find (cadr a) pos mutable))
+ (for-each2
+ (lambda (t m)
+ (find t pos (or m mutable)))
+ a
+ (k-args x)))
+ (find n pos mutable))
+ (else #f))))
+ (($ box (? symbol?)) #f)
+ (($ box i) (find i pos mutable))))))
+ (seen (make-vector n-gen #f))
+ (new-generic-var
+ (lambda ()
+ (set! n-gen (+ 1 n-gen))
+ (box (make-raw-tvar (- n-gen) 'ord))))
+ (copy (rec copy
+ (lambda (t)
+ (match t
+ (($ box ($ v d k _ _ _ _))
+ (if (generic? d)
+ (or (vector-ref seen (- (- d) 1))
+ (let ((u (if (and (abs? k)
+ (equal?
+ (valence-of d)
+ '(#t)))
+ (new-generic-var)
+ t)))
+ (vector-set! seen (- (- d) 1) u)
+ u))
+ t))
+ (($ box ($ c d k x p a n))
+ (if (generic? d)
+ (or (vector-ref seen (- (- d) 1))
+ (let* ((u (box '**fix**))
+ (_ (vector-set!
+ seen
+ (- (- d) 1)
+ u))
+ (new-p (if (and (eq? (ind* p) top)
+ (equal?
+ (valence-of d)
+ '(#f)))
+ (new-generic-var)
+ (copy p)))
+ (new-a (map copy a))
+ (new-n (copy n)))
+ (set-box!
+ u
+ (make-c d 'ord x new-p new-a new-n))
+ u))
+ t))
+ (($ box (? symbol?)) t)
+ (($ box i) (copy i))))))
+ (t-list
+ (map (lambda (t) (find t #t #f) (copy t)) t-list)))
+ (list t-list n-gen))))
+(set! pseudo pseudo-subtype)
+(define unify
+ (letrec ((uni (lambda (u v)
+ (unless
+ (eq? u v)
+ (match (cons u v)
+ ((($ box (and us ($ c ud uk ux up ua un)))
+ $
+ box
+ (and vs ($ c vd vk vx vp va vn)))
+ (if (eq? ux vx)
+ (begin
+ (if (< ud vd)
+ (begin
+ (set-box! v u)
+ (when (kind< vk uk) (set-c-kind! us vk)))
+ (begin
+ (set-box! u v)
+ (when (kind< uk vk) (set-c-kind! vs uk))))
+ (uni un vn)
+ (for-each2 uni ua va)
+ (uni up vp))
+ (let* ((next (tvar))
+ (k (if (kind< uk vk) uk vk)))
+ (if (< ud vd)
+ (begin
+ (when (< vd ud) (set-c-depth! us vd))
+ (when (kind< vk uk) (set-c-kind! us vk))
+ (set-box! v u))
+ (begin
+ (when (< ud vd) (set-c-depth! vs ud))
+ (when (kind< uk vk) (set-c-kind! vs uk))
+ (set-box! u v)))
+ (uni (new-type
+ (make-c depth k ux up ua next)
+ depth)
+ vn)
+ (uni un
+ (new-type
+ (make-c depth k vx vp va next)
+ depth)))))
+ ((($ box (and x ($ v ud uk _ _ _ _)))
+ $
+ box
+ ($ v vd vk _ _ _ _))
+ (set-v-depth! x (min ud vd))
+ (set-v-kind! x (if (kind< uk vk) uk vk))
+ (set-box! v u))
+ ((($ box ($ v ud uk _ _ _ _))
+ $
+ box
+ (and x ($ c vd vk _ _ _ _)))
+ (when (< ud vd) (set-c-depth! x ud))
+ (when (kind< uk vk) (set-c-kind! x uk))
+ (set-box! u v))
+ ((($ box (and x ($ c ud uk _ _ _ _)))
+ $
+ box
+ ($ v vd vk _ _ _ _))
+ (when (< vd ud) (set-c-depth! x vd))
+ (when (kind< vk uk) (set-c-kind! x vk))
+ (set-box! v u))
+ ((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?))
+ (set-box! u v))
+ ((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _))
+ (set-box! v u))
+ ((($ box 'bot) $ box ($ c _ _ _ p _ n))
+ (set-box! v u)
+ (uni u p)
+ (uni u n))
+ ((($ box ($ c _ _ _ p _ n)) $ box 'bot)
+ (set-box! u v)
+ (uni v p)
+ (uni v n))
+ (_ (uni (ind* u) (ind* v))))))))
+ uni))
+(define kind<
+ (lambda (k1 k2) (and (ord? k2) (not (ord? k1)))))
+(define r+-
+ (lambda (flag+ flag- tail+- absent- pos env type)
+ (letrec ((absent+ v-ord)
+ (tvars '())
+ (fvars '())
+ (absv '())
+ (make-flag
+ (lambda (pos)
+ (cond ((not flags) top)
+ (pos (flag+))
+ (else (flag-)))))
+ (typevar?
+ (lambda (v)
+ (and (symbol? v)
+ (not (bound? env v))
+ (not (memq v
+ '(_ bool
+ mu
+ list
+ &list
+ &optional
+ &rest
+ arglist
+ +
+ not
+ rec
+ *tidy))))))
+ (parse-type
+ (lambda (t pos)
+ (match t
+ (('mu a t)
+ (unless
+ (typevar? a)
+ (raise 'type "invalid type syntax at ~a" t))
+ (when (assq a tvars)
+ (raise 'type "~a is defined more than once" a))
+ (let* ((fix (new-type '**fix** depth))
+ (_ (set! tvars (cons (list a fix '()) tvars)))
+ (t (parse-type t pos)))
+ (when (eq? t fix)
+ (raise 'type
+ "recursive type is not contractive"))
+ (set-box! fix t)
+ (ind* t)))
+ (('rec (? list? bind) t2)
+ (for-each
+ (match-lambda
+ ((a _)
+ (unless
+ (typevar? a)
+ (raise 'type "invalid type syntax at ~a" t))
+ (when (assq a tvars)
+ (raise 'type
+ "~a is defined more than once"
+ a))
+ (set! tvars
+ (cons (list a (new-type '**fix** depth) '())
+ tvars)))
+ (_ (raise 'type "invalid type syntax at ~a" t)))
+ bind)
+ (for-each
+ (match-lambda
+ ((a t)
+ (match (assq a tvars)
+ ((_ fix _)
+ (let ((t (parse-type t '?)))
+ (when (eq? t fix)
+ (raise 'type
+ "type is not contractive"))
+ (set-box! fix t))))))
+ bind)
+ (parse-type t2 pos))
+ ('bool (parse-type '(+ false true) pos))
+ ('s-exp
+ (let ((v (gensym)))
+ (parse-type
+ `(mu ,v
+ (+ num
+ nil
+ false
+ true
+ char
+ sym
+ str
+ (vec ,v)
+ (box ,v)
+ (cons ,v ,v)))
+ pos)))
+ (('list t)
+ (let ((u (gensym)))
+ (parse-type `(mu ,u (+ nil (cons ,t ,u))) pos)))
+ (('arglist t)
+ (let ((u (gensym)))
+ (parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos)))
+ (('+ ? list? union) (parse-union union pos))
+ (t (parse-union (list t) pos)))))
+ (parse-union
+ (lambda (t pos)
+ (letrec ((sort-cs
+ (lambda (cs)
+ (sort-list
+ cs
+ (lambda (x y) (k< (c-fsym x) (c-fsym y))))))
+ (link (lambda (c t)
+ (set-c-next! c t)
+ (new-type c depth))))
+ (recur loop
+ ((t t) (cs '()))
+ (match t
+ (()
+ (foldr link
+ (if pos
+ (absent+)
+ (let ((v (absent-)))
+ (set! absv (cons v absv))
+ v))
+ (sort-cs cs)))
+ (((? box? t)) (foldr link t (sort-cs cs)))
+ (('_) (foldr link (tail+-) (sort-cs cs)))
+ (((? symbol? a))
+ (=> fail)
+ (unless (typevar? a) (fail))
+ (let* ((cs (sort-cs cs))
+ (ks (map c-fsym cs)))
+ (foldr link
+ (match (assq a tvars)
+ ((_ f aks)
+ (unless
+ (equal? ks aks)
+ (raise 'type
+ "variable ~a is not tidy"
+ a))
+ f)
+ (#f
+ (let ((v (tail+-)))
+ (set! tvars
+ (cons (list a v ks)
+ tvars))
+ v)))
+ cs)))
+ ((k . rest)
+ (loop rest (cons (parse-k k pos) cs))))))))
+ (parse-k
+ (lambda (k pos)
+ (cond ((and (list? k)
+ (let ((n (length k)))
+ (and (<= 2 n) (eq? '-> (list-ref k (- n 2))))))
+ (let* ((rk (reverse k))
+ (arg (reverse (cddr rk)))
+ (res (car rk)))
+ (letrec ((mkargs
+ (match-lambda
+ (() 'noarg)
+ ((('&rest x)) x)
+ ((('&list x))
+ (let ((u (gensym)))
+ `(mu ,u (+ noarg (arg ,x ,u)))))
+ ((('&optional x))
+ `(+ noarg (arg ,x noarg)))
+ ((x . y) `(arg ,x ,(mkargs y)))
+ (_ (raise 'type
+ "invalid type syntax")))))
+ (make-c
+ depth
+ 'ord
+ (lookup env '?->)
+ (make-flag pos)
+ (let ((a (parse-type (mkargs arg) (flip pos)))
+ (r (parse-type res pos)))
+ (list a r))
+ '**fix**))))
+ (else
+ (match k
+ ((arg '?-> res)
+ (make-c
+ depth
+ 'ord
+ (lookup env '?->)
+ (make-flag pos)
+ (let ((a (parse-type arg (flip pos)))
+ (r (parse-type res pos)))
+ (list a r))
+ '**fix**))
+ (('record ? list? fields)
+ (make-c
+ depth
+ 'ord
+ (lookup env 'record)
+ (make-flag pos)
+ (list (recur loop
+ ((fields fields))
+ (match fields
+ (() (if pos bot (v-ord)))
+ ((((? symbol? f) ftype)
+ .
+ rest)
+ (new-type
+ (make-c
+ depth
+ 'ord
+ (new-field! f)
+ (if pos
+ (v-ord)
+ (let ((v (v-pre)))
+ (set! absv
+ (cons v absv))
+ v))
+ (list (parse-type
+ ftype
+ pos))
+ (loop rest))
+ depth)))))
+ '**fix**))
+ (('not (? k? k))
+ (make-c
+ depth
+ 'ord
+ k
+ (if pos
+ (absent+)
+ (let ((v (absent-)))
+ (set! absv (cons v absv))
+ v))
+ (map (lambda (x) (tail+-)) (k-args k))
+ '**fix**))
+ (('not c)
+ (unless
+ (bound? env c)
+ (raise 'type "invalid type syntax at ~a" k))
+ (let ((k (lookup env c)))
+ (make-c
+ depth
+ 'ord
+ k
+ (if pos
+ (absent+)
+ (let ((v (absent-)))
+ (set! absv (cons v absv))
+ v))
+ (map (lambda (x) (tail+-)) (k-args k))
+ '**fix**)))
+ (('*tidy c (? symbol? f))
+ (unless
+ (bound? env c)
+ (raise 'type "invalid type syntax at ~a" k))
+ (let ((k (lookup env c)))
+ (make-c
+ depth
+ 'ord
+ k
+ (match (assq f fvars)
+ ((_ . f) f)
+ (#f
+ (let ((v (tail+-)))
+ (set! fvars
+ (cons (cons f v) fvars))
+ v)))
+ (map (lambda (x) (parse-type '(+) pos))
+ (k-args k))
+ '**fix**)))
+ (((? k? k) ? list? arg)
+ (unless
+ (= (length arg) (length (k-args k)))
+ (raise 'type
+ "~a requires ~a arguments"
+ (k-name k)
+ (length (k-args k))))
+ (make-c
+ depth
+ 'ord
+ k
+ (make-flag pos)
+ (smap (lambda (x) (parse-type x pos)) arg)
+ '**fix**))
+ ((c ? list? arg)
+ (unless
+ (bound? env c)
+ (raise 'type "invalid type syntax at ~a" k))
+ (let ((k (lookup env c)))
+ (unless
+ (= (length arg) (length (k-args k)))
+ (raise 'type
+ "~a requires ~a arguments"
+ c
+ (length (k-args k))))
+ (make-c
+ depth
+ 'ord
+ k
+ (make-flag pos)
+ (smap (lambda (x) (parse-type x pos)) arg)
+ '**fix**)))
+ (c (unless
+ (bound? env c)
+ (raise 'type
+ "invalid type syntax at ~a"
+ k))
+ (let ((k (lookup env c)))
+ (unless
+ (= 0 (length (k-args k)))
+ (raise 'type
+ "~a requires ~a arguments"
+ c
+ (length (k-args k))))
+ (make-c
+ depth
+ 'ord
+ k
+ (make-flag pos)
+ '()
+ '**fix**))))))))
+ (flip (match-lambda ('? '?) (#t #f) (#f #t))))
+ (let ((t (parse-type type pos))) (list t absv)))))
+(define v-top (lambda () top))
+(define r+
+ (lambda (env t)
+ (car (r+- v-top v-ord v-ord v-abs #t env t))))
+(define r-
+ (lambda (env t)
+ (car (r+- v-top v-ord v-ord v-abs #f env t))))
+(define r++
+ (lambda (env t)
+ (car (r+- v-top v-ord v-ord v-ord #t env t))))
+(define r+collect
+ (lambda (env t)
+ (r+- v-top v-ord v-ord v-abs #t env t)))
+(define r-collect
+ (lambda (env t)
+ (r+- v-top v-ord v-ord v-abs #f env t)))
+(define r (lambda (t) (r+ initial-type-env t)))
+(define r-match
+ (lambda (t)
+ (close '())
+ '(pretty-print `(fixing ,(ptype t)))
+ (fix-pat-abs! t)
+ (list t (collect-abs t))))
+(define collect-abs
+ (lambda (t)
+ (let ((seen '()))
+ (recur loop
+ ((t t))
+ (match t
+ (($ box ($ v _ k _ _ _ _))
+ (if (abs? k) (set t) empty-set))
+ (($ box ($ c _ _ _ p a n))
+ (if (memq t seen)
+ empty-set
+ (begin
+ (set! seen (cons t seen))
+ (foldr union
+ (union (loop p) (loop n))
+ (map loop a)))))
+ (($ box (? symbol?)) empty-set)
+ (($ box i) (loop i)))))))
+(define fix-pat-abs!
+ (lambda (t)
+ (let ((seen '()))
+ (recur loop
+ ((t t))
+ (match t
+ (($ box (and x ($ v d _ _ _ _ _)))
+ (when (= d depth) (set-v-kind! x 'abs)))
+ (($ box (and c ($ c _ _ _ p a n)))
+ (unless
+ (memq t seen)
+ (set! seen (cons t seen))
+ (loop p)
+ (when (and matchst flags (eq? (ind* p) top))
+ (set-c-pres! c (v-ord)))
+ (for-each loop a)
+ (loop n)))
+ (($ box (? symbol?)) t)
+ (($ box i) (loop i)))))))
+(define pat-var-bind
+ (lambda (t)
+ (let ((seen '()))
+ (recur loop
+ ((t t))
+ (match t
+ (($ box ($ v d _ _ _ _ _))
+ (if (< d depth)
+ t
+ (match (assq t seen)
+ ((_ . new) new)
+ (#f
+ (let* ((new (v-ord)))
+ (set! seen (cons (cons t new) seen))
+ new)))))
+ (($ box ($ c d k x p a n))
+ (match (assq t seen)
+ ((_ . new) new)
+ (#f
+ (let* ((fix (new-type '**fix** depth))
+ (fixbox (box fix))
+ (_ (set! seen (cons (cons t fixbox) seen)))
+ (new-p (if flags (loop p) top))
+ (new-a (map2 (lambda (mutable a)
+ (if mutable a (loop a)))
+ (k-args x)
+ a))
+ (new-n (loop n)))
+ (if (and (eq? new-p p)
+ (eq? new-n n)
+ (andmap eq? new-a a))
+ (begin (set-box! fixbox t) t)
+ (begin
+ (set-box!
+ fix
+ (make-c d k x new-p new-a new-n))
+ fix))))))
+ (($ box (? symbol?)) t)
+ (($ box i) (loop i)))))))
+(define fields '())
+(define new-field!
+ (lambda (x)
+ (match (assq x fields)
+ (#f
+ (let ((k (make-k x (+ 1 (length fields)) '(#f))))
+ (set! fields (cons (cons x k) fields))
+ k))
+ ((_ . k) k))))
+(define k<
+ (lambda (x y) (< (k-order x) (k-order y))))
+(define k-counter 0)
+(define bind-tycon
+ (lambda (x args covers fail-thunk)
+ (when (memq x
+ '(_ bool
+ mu
+ list
+ &list
+ &optional
+ &rest
+ arglist
+ +
+ not
+ rec
+ *tidy))
+ (fail-thunk "invalid type constructor ~a" x))
+ (set! k-counter (+ 1 k-counter))
+ (make-k
+ (if covers
+ (symbol-append x "." (- k-counter 100))
+ x)
+ k-counter
+ args)))
+(define initial-type-env '())
+(define init-types!
+ (lambda ()
+ (set! k-counter 0)
+ (set! var-counter (generate-counter))
+ (set! initial-type-env
+ (foldl (lambda (l env)
+ (extend-env
+ env
+ (car l)
+ (bind-tycon
+ (car l)
+ (cdr l)
+ #f
+ (lambda x (apply disaster 'init x)))))
+ empty-env
+ initial-type-info))
+ (set! k-counter 100)
+ (reset-types!)))
+(define reinit-types!
+ (lambda ()
+ (set! var-counter (generate-counter))
+ (set! k-counter 100)
+ (set! fields '())
+ (set-cons-mutability! #t)
+ (reset-types!)))
+(define deftype
+ (lambda (tag mutability)
+ (set! initial-type-env
+ (extend-env
+ initial-type-env
+ tag
+ (make-k
+ tag
+ (+ 1 (length initial-type-env))
+ mutability)))))
+(define initial-type-info
+ '((?-> #f #f)
+ (arg #f #f)
+ (noarg)
+ (num)
+ (nil)
+ (false)
+ (true)
+ (char)
+ (sym)
+ (str)
+ (void)
+ (iport)
+ (oport)
+ (eof)
+ (vec #t)
+ (box #t)
+ (cons #t #t)
+ (cvec #f)
+ (promise #t)
+ (record #f)
+ (module #f)))
+(define cons-is-mutable #f)
+(define set-cons-mutability!
+ (lambda (m)
+ (set! cons-is-mutable m)
+ (set-k-args!
+ (lookup initial-type-env 'cons)
+ (list m m))))
+(define tidy?
+ (lambda (t)
+ (let ((seen '()))
+ (recur loop
+ ((t t) (label '()))
+ (match t
+ (($ box (? v?))
+ (match (assq t seen)
+ (#f (set! seen (cons (cons t label) seen)) #t)
+ ((_ . l2) (equal? label l2))))
+ (($ box ($ c _ _ x _ a n))
+ (match (assq t seen)
+ ((_ . l2) (equal? label l2))
+ (#f
+ (set! seen (cons (cons t label) seen))
+ (and (loop n (sort-list (cons x label) k<))
+ (andmap (lambda (t) (loop t '())) a)))))
+ (($ box (? symbol?)) #t)
+ (($ box i) (loop i label)))))))
+(define tidy
+ (match-lambda
+ (($ ts t _)
+ (tidy-print t print-union assemble-union #f))
+ (t (tidy-print t print-union assemble-union #f))))
+(define ptype
+ (match-lambda
+ (($ ts t _)
+ (tidy-print
+ t
+ print-raw-union
+ assemble-raw-union
+ #t))
+ (t (tidy-print
+ t
+ print-raw-union
+ assemble-raw-union
+ #t))))
+(define tidy-print
+ (lambda (t print assemble top)
+ (let* ((share (shared-unions t top))
+ (bindings
+ (map-with-n
+ (lambda (t n)
+ (list t
+ (box #f)
+ (box #f)
+ (symbol-append "Y" (+ 1 n))))
+ share))
+ (body (print t (print-binding bindings)))
+ (let-bindings
+ (filter-map
+ (match-lambda
+ ((_ _ ($ box #f) _) #f)
+ ((_ ($ box t) ($ box x) _) (list x t)))
+ bindings)))
+ (assemble let-bindings body))))
+(define print-binding
+ (lambda (bindings)
+ (lambda (ty share-wrapper var-wrapper render)
+ (match (assq ty bindings)
+ (#f (render))
+ ((_ box-tprint box-name nprint)
+ (var-wrapper
+ (or (unbox box-name)
+ (begin
+ (set-box! box-name nprint)
+ (set-box! box-tprint (share-wrapper (render)))
+ nprint))))))))
+(define shared-unions
+ (lambda (t all)
+ (let ((seen '()))
+ (recur loop
+ ((t t) (top #t))
+ (match t
+ (($ box (? v?)) #f)
+ (($ box ($ c _ _ _ _ a n))
+ (match (and top (assq t seen))
+ (#f
+ (set! seen (cons (cons t (box 1)) seen))
+ (for-each (lambda (x) (loop x #t)) a)
+ (loop n all))
+ ((_ . b) (set-box! b (+ 1 (unbox b))))))
+ (($ box (? symbol?)) #f)
+ (($ box i) (loop i top))))
+ (reverse
+ (filter-map
+ (match-lambda ((_ $ box 1) #f) ((t . _) t))
+ seen)))))
+(define print-raw-union
+ (lambda (t print-share)
+ (recur loop
+ ((t t))
+ (match t
+ (($ box ($ v _ _ _ _ split _))
+ (if (and share split)
+ (string->symbol (sprintf "~a#" (pvar t)))
+ (pvar t)))
+ (($ box ($ c d k x p a n))
+ (print-share
+ t
+ (lambda (x) x)
+ (lambda (x) x)
+ (lambda ()
+ (let* ((name (if (abs? k)
+ (symbol-append '~ (k-name x))
+ (k-name x)))
+ (name (if dump-depths
+ (symbol-append d '! name)
+ name))
+ (pr-x `(,name ,@(maplr loop (cons p a)))))
+ (cons pr-x (loop n))))))
+ (($ box 'top) '+)
+ (($ box 'bot) '-)
+ (($ box i) (loop i))))))
+(define assemble-raw-union
+ (lambda (bindings body)
+ (if (null? bindings) body `(rec ,bindings ,body))))
+(define print-union
+ (lambda (t print-share)
+ (add-+ (recur loop
+ ((t t) (tailvis (visible? (tailvar t))))
+ (match t
+ (($ box (? v?))
+ (if (visible? t) (list (pvar t)) '()))
+ (($ box ($ c _ _ x p a n))
+ (print-share
+ t
+ add-+
+ list
+ (lambda ()
+ (cond ((visible? p)
+ (let* ((split-flag
+ (and share
+ (match (ind* p)
+ (($ box
+ ($ v
+ _
+ _
+ _
+ _
+ split
+ _))
+ split)
+ (_ #f))))
+ (kname (if split-flag
+ (string->symbol
+ (sprintf
+ "~a#~a"
+ (k-name x)
+ (pvar p)))
+ (k-name x))))
+ (cons (cond ((null? a) kname)
+ ((eq? '?-> (k-name x))
+ (let ((arg (add-+ (loop (car a)
+ (visible?
+ (tailvar
+ (car a))))))
+ (res (add-+ (loop (cadr a)
+ (visible?
+ (tailvar
+ (cadr a)))))))
+ (decode-arrow
+ kname
+ (lambda ()
+ (if split-flag
+ (string->symbol
+ (sprintf
+ "->#~a"
+ (pvar p)))
+ '->))
+ arg
+ res)))
+ ((eq? 'record (k-name x))
+ `(,kname
+ ,@(loop (car a) #f)))
+ (else
+ `(,kname
+ ,@(maplr (lambda (x)
+ (add-+ (loop x
+ (visible?
+ (tailvar
+ x)))))
+ a))))
+ (loop n tailvis))))
+ ((not tailvis) (loop n tailvis))
+ (else
+ (cons `(not ,(k-name x))
+ (loop n tailvis)))))))
+ (($ box 'bot) '())
+ (($ box i) (loop i tailvis)))))))
+(define assemble-union
+ (lambda (bindings body)
+ (subst-small-type
+ (map clean-binding bindings)
+ body)))
+(define add-+
+ (match-lambda
+ (() 'empty)
+ ((t) t)
+ (x (cons '+ x))))
+(define tailvar
+ (lambda (t)
+ (match t
+ (($ box (? v?)) t)
+ (($ box ($ c _ _ _ _ _ n)) (tailvar n))
+ (($ box 'bot) t)
+ (($ box i) (tailvar i)))))
+(define decode-arrow
+ (lambda (kname thunk-> arg res)
+ (let ((args (recur loop
+ ((l arg))
+ (match l
+ ('noarg '())
+ (('arg a b) `(,a ,@(loop b)))
+ (('+ ('arg a b) 'noarg . _)
+ `((&optional ,a) ,@(loop b)))
+ (('+ 'noarg ('arg a b) . _)
+ `((&optional ,a) ,@(loop b)))
+ ((? symbol? z)
+ (if (rectypevar? z) `(,z) `((&rest ,z))))
+ (('+ 'noarg z) (loop z))
+ (('+ ('arg a b) z)
+ (loop `(+ (arg ,a ,b) noarg ,z)))))))
+ `(,@args ,(thunk->) ,res))))
+(define rectypevar?
+ (lambda (s)
+ (memq (string-ref (symbol->string s) 0) '(#\Y))))
+(define typevar?
+ (lambda (s)
+ (memq (string-ref (symbol->string s) 0)
+ '(#\X #\Z))))
+(define clean-binding
+ (lambda (binding)
+ (match binding
+ ((u ('+ 'nil ('cons a v)))
+ (if (and (equal? u v) (not (memq* u a)))
+ (list u `(list ,a))
+ binding))
+ ((u ('+ ('cons a v) 'nil))
+ (if (and (equal? u v) (not (memq* u a)))
+ (list u `(list ,a))
+ binding))
+ ((u ('+ 'nil ('cons a v) (? symbol? z)))
+ (if (and (equal? u v) (not (memq* u a)) (typevar? z))
+ (list u `(list* ,a ,z))
+ binding))
+ ((u ('+ ('cons a v) 'nil (? symbol? z)))
+ (if (and (equal? u v) (not (memq* u a)) (typevar? z))
+ (list u `(list* ,a ,z))
+ binding))
+ ((u ('+ 'noarg ('arg a v)))
+ (if (and (equal? u v) (not (memq* u a)))
+ (list u `(&list ,a))
+ binding))
+ ((u ('+ ('arg a v) 'noarg))
+ (if (and (equal? u v) (not (memq* u a)))
+ (list u `(&list ,a))
+ binding))
+ (x x))))
+(define memq*
+ (lambda (v t)
+ (recur loop
+ ((t t))
+ (match t
+ ((x . y) (or (loop x) (loop y)))
+ (_ (eq? v t))))))
+(define subst-type
+ (lambda (new old t)
+ (match new
+ (('list elem) (subst-list elem old t))
+ (_ (subst* new old t)))))
+(define subst-list
+ (lambda (elem old t)
+ (match t
+ ((? symbol?) (if (eq? old t) `(list ,elem) t))
+ (('+ 'nil ('cons a (? symbol? b)))
+ (if (and (eq? b old) (equal? elem a))
+ `(list ,elem)
+ `(+ nil (cons ,(subst-list elem old a) ,b))))
+ (('+ ('cons a (? symbol? b)) 'nil)
+ (if (and (eq? b old) (equal? elem a))
+ `(list ,elem)
+ `(+ nil (cons ,(subst-list elem old a) ,b))))
+ ((a . b)
+ (cons (subst-list elem old a)
+ (subst-list elem old b)))
+ (z z))))
+(define subst*
+ (lambda (new old t)
+ (cond ((eq? old t) new)
+ ((pair? t)
+ (cons (subst* new old (car t))
+ (subst* new old (cdr t))))
+ (else t))))
+(define subst-small-type
+ (lambda (bindings body)
+ (recur loop
+ ((bindings bindings) (newb '()) (body body))
+ (match bindings
+ (()
+ (let ((newb (filter
+ (match-lambda
+ ((name type) (not (equal? name type))))
+ newb)))
+ (if (null? newb)
+ body
+ `(rec ,(reverse newb) ,body))))
+ (((and b (name type)) . rest)
+ (if (and (not (memq* name type)) (small-type? type))
+ (loop (subst-type type name rest)
+ (subst-type type name newb)
+ (subst-type type name body))
+ (loop rest (cons b newb) body)))))))
+(define small-type?
+ (lambda (t)
+ (>= 8
+ (recur loop
+ ((t t))
+ (match t
+ ('+ 0)
+ ((? symbol? s) 1)
+ ((? number? n) 0)
+ ((x . y) (+ (loop x) (loop y)))
+ (() 0))))))
+(define qop
+ (lambda (s)
+ (string->symbol (string-append "# " s))))
+(define qcons (qop "cons"))
+(define qbox (qop "box"))
+(define qlist (qop "list"))
+(define qvector (qop "vector"))
+(define initial-info
+ `((not (a -> bool))
+ (eqv? (a a -> bool))
+ (eq? (a a -> bool))
+ (equal? (a a -> bool))
+ (cons (a b -> (cons a b)) (ic))
+ (car ((cons a b) -> a) (s (x . _)))
+ (cdr ((cons b a) -> a) (s (_ . x)))
+ (caar ((cons (cons a b) c) -> a)
+ (s ((x . _) . _)))
+ (cadr ((cons c (cons a b)) -> a) (s (_ x . _)))
+ (cdar ((cons (cons b a) c) -> a)
+ (s ((_ . x) . _)))
+ (cddr ((cons c (cons b a)) -> a) (s (_ _ . x)))
+ (caaar ((cons (cons (cons a b) c) d) -> a)
+ (s (((x . _) . _) . _)))
+ (caadr ((cons d (cons (cons a b) c)) -> a)
+ (s (_ (x . _) . _)))
+ (cadar ((cons (cons c (cons a b)) d) -> a)
+ (s ((_ x . _) . _)))
+ (caddr ((cons d (cons c (cons a b))) -> a)
+ (s (_ _ x . _)))
+ (cdaar ((cons (cons (cons b a) c) d) -> a)
+ (s (((_ . x) . _) . _)))
+ (cdadr ((cons d (cons (cons b a) c)) -> a)
+ (s (_ (_ . x) . _)))
+ (cddar ((cons (cons c (cons b a)) d) -> a)
+ (s ((_ _ . x) . _)))
+ (cdddr ((cons d (cons c (cons b a))) -> a)
+ (s (_ _ _ . x)))
+ (caaaar
+ ((cons (cons (cons (cons a b) c) d) e) -> a)
+ (s ((((x . _) . _) . _) . _)))
+ (caaadr
+ ((cons e (cons (cons (cons a b) c) d)) -> a)
+ (s (_ ((x . _) . _) . _)))
+ (caadar
+ ((cons (cons d (cons (cons a b) c)) e) -> a)
+ (s ((_ (x . _) . _) . _)))
+ (caaddr
+ ((cons e (cons d (cons (cons a b) c))) -> a)
+ (s (_ _ (x . _) . _)))
+ (cadaar
+ ((cons (cons (cons c (cons a b)) d) e) -> a)
+ (s (((_ x . _) . _) . _)))
+ (cadadr
+ ((cons e (cons (cons c (cons a b)) d)) -> a)
+ (s (_ (_ x . _) . _)))
+ (caddar
+ ((cons (cons d (cons c (cons a b))) e) -> a)
+ (s ((_ _ x . _) . _)))
+ (cadddr
+ ((cons e (cons d (cons c (cons a b)))) -> a)
+ (s (_ _ _ x . _)))
+ (cdaaar
+ ((cons (cons (cons (cons b a) c) d) e) -> a)
+ (s ((((_ . x) . _) . _) . _)))
+ (cdaadr
+ ((cons e (cons (cons (cons b a) c) d)) -> a)
+ (s (_ ((_ . x) . _) . _)))
+ (cdadar
+ ((cons (cons d (cons (cons b a) c)) e) -> a)
+ (s ((_ (_ . x) . _) . _)))
+ (cdaddr
+ ((cons e (cons d (cons (cons b a) c))) -> a)
+ (s (_ _ (_ . x) . _)))
+ (cddaar
+ ((cons (cons (cons c (cons b a)) d) e) -> a)
+ (s (((_ _ . x) . _) . _)))
+ (cddadr
+ ((cons e (cons (cons c (cons b a)) d)) -> a)
+ (s (_ (_ _ . x) . _)))
+ (cdddar
+ ((cons (cons d (cons c (cons b a))) e) -> a)
+ (s ((_ _ _ . x) . _)))
+ (cddddr
+ ((cons e (cons d (cons c (cons b a)))) -> a)
+ (s (_ _ _ _ . x)))
+ (set-car! ((cons a b) a -> void))
+ (set-cdr! ((cons a b) b -> void))
+ (list ((&list a) -> (list a)) (ic))
+ (length ((list a) -> num))
+ (append ((&list (list a)) -> (list a)) (ic) (d))
+ (reverse ((list a) -> (list a)) (ic))
+ (list-tail ((list a) num -> (list a)) (c))
+ (list-ref ((list a) num -> a) (c))
+ (memq (a (list a) -> (+ false (cons a (list a)))))
+ (memv (a (list a) -> (+ false (cons a (list a)))))
+ (member
+ (a (list a) -> (+ false (cons a (list a)))))
+ (assq (a (list (cons a c)) -> (+ false (cons a c))))
+ (assv (a (list (cons a c)) -> (+ false (cons a c))))
+ (assoc (a (list (cons a c)) -> (+ false (cons a c))))
+ (symbol->string (sym -> str))
+ (string->symbol (str -> sym))
+ (complex? (a -> bool))
+ (real? (a -> bool))
+ (rational? (a -> bool))
+ (integer? (a -> bool))
+ (exact? (num -> bool))
+ (inexact? (num -> bool))
+ (= (num num (&list num) -> bool))
+ (< (num num (&list num) -> bool))
+ (> (num num (&list num) -> bool))
+ (<= (num num (&list num) -> bool))
+ (>= (num num (&list num) -> bool))
+ (zero? (num -> bool))
+ (positive? (num -> bool))
+ (negative? (num -> bool))
+ (odd? (num -> bool))
+ (even? (num -> bool))
+ (max (num (&list num) -> num))
+ (min (num (&list num) -> num))
+ (+ ((&list num) -> num))
+ (* ((&list num) -> num))
+ (- (num (&list num) -> num))
+ (/ (num (&list num) -> num))
+ (abs (num -> num))
+ (quotient (num num -> num))
+ (remainder (num num -> num))
+ (modulo (num num -> num))
+ (gcd ((&list num) -> num))
+ (lcm ((&list num) -> num))
+ (numerator (num -> num))
+ (denominator (num -> num))
+ (floor (num -> num))
+ (ceiling (num -> num))
+ (truncate (num -> num))
+ (round (num -> num))
+ (rationalize (num num -> num))
+ (exp (num -> num))
+ (log (num -> num))
+ (sin (num -> num))
+ (cos (num -> num))
+ (tan (num -> num))
+ (asin (num -> num))
+ (acos (num -> num))
+ (atan (num (&optional num) -> num))
+ (sqrt (num -> num))
+ (expt (num num -> num))
+ (make-rectangular (num num -> num))
+ (make-polar (num num -> num))
+ (real-part (num -> num))
+ (imag-part (num -> num))
+ (magnitude (num -> num))
+ (angle (num -> num))
+ (exact->inexact (num -> num))
+ (inexact->exact (num -> num))
+ (number->string (num (&optional num) -> str))
+ (string->number (str (&optional num) -> num))
+ (char=? (char char -> bool))
+ (char<? (char char -> bool))
+ (char>? (char char -> bool))
+ (char<=? (char char -> bool))
+ (char>=? (char char -> bool))
+ (char-ci=? (char char -> bool))
+ (char-ci<? (char char -> bool))
+ (char-ci>? (char char -> bool))
+ (char-ci<=? (char char -> bool))
+ (char-ci>=? (char char -> bool))
+ (char-alphabetic? (char -> bool))
+ (char-numeric? (char -> bool))
+ (char-whitespace? (char -> bool))
+ (char-upper-case? (char -> bool))
+ (char-lower-case? (char -> bool))
+ (char->integer (char -> num))
+ (integer->char (num -> char))
+ (char-upcase (char -> char))
+ (char-downcase (char -> char))
+ (make-string (num (&optional char) -> str))
+ (string ((&list char) -> str))
+ (string-length (str -> num))
+ (string-ref (str num -> char))
+ (string-set! (str num char -> void))
+ (string=? (str str -> bool))
+ (string<? (str str -> bool))
+ (string>? (str str -> bool))
+ (string<=? (str str -> bool))
+ (string>=? (str str -> bool))
+ (string-ci=? (str str -> bool))
+ (string-ci<? (str str -> bool))
+ (string-ci>? (str str -> bool))
+ (string-ci<=? (str str -> bool))
+ (string-ci>=? (str str -> bool))
+ (substring (str num num -> str))
+ (string-append ((&list str) -> str))
+ (string->list (str -> (list char)) (ic))
+ (list->string ((list char) -> str))
+ (string-copy (str -> str))
+ (string-fill! (str char -> void))
+ (make-vector (num a -> (vec a)) (i))
+ (vector ((&list a) -> (vec a)) (i))
+ (vector-length ((vec a) -> num))
+ (vector-ref ((vec a) num -> a))
+ (vector-set! ((vec a) num a -> void))
+ (vector->list ((vec a) -> (list a)) (ic))
+ (list->vector ((list a) -> (vec a)) (i))
+ (vector-fill! ((vec a) a -> void))
+ (apply (((&list a) -> b) (list a) -> b) (i) (d))
+ (map ((a -> b) (list a) -> (list b)) (i) (d))
+ (for-each ((a -> b) (list a) -> void) (i) (d))
+ (force ((promise a) -> a) (i))
+ (call-with-current-continuation
+ (((a -> b) -> a) -> a)
+ (i))
+ (call-with-input-file
+ (str (iport -> a) -> a)
+ (i))
+ (call-with-output-file
+ (str (oport -> a) -> a)
+ (i))
+ (input-port? (a -> bool))
+ (output-port? (a -> bool))
+ (current-input-port (-> iport))
+ (current-output-port (-> oport))
+ (with-input-from-file (str (-> a) -> a) (i))
+ (with-output-to-file (str (-> a) -> a) (i))
+ (open-input-file (str -> iport))
+ (open-output-file (str -> oport))
+ (close-input-port (iport -> void))
+ (close-output-port (oport -> void))
+ (read ((&optional iport)
+ ->
+ (+ eof
+ num
+ nil
+ false
+ true
+ char
+ sym
+ str
+ (box (mu sexp
+ (+ num
+ nil
+ false
+ true
+ char
+ sym
+ str
+ (vec sexp)
+ (cons sexp sexp)
+ (box sexp))))
+ (cons sexp sexp)
+ (vec sexp)))
+ (i))
+ (read-char
+ ((&optional iport) -> (+ char eof))
+ (i))
+ (peek-char
+ ((&optional iport) -> (+ char eof))
+ (i))
+ (char-ready? ((&optional iport) -> bool) (i))
+ (write (a (&optional oport) -> void) (i))
+ (display (a (&optional oport) -> void) (i))
+ (newline ((&optional oport) -> void) (i))
+ (write-char (char (&optional oport) -> void) (i))
+ (load (str -> void))
+ (transcript-on (str -> void))
+ (transcript-off (-> void))
+ (symbol-append ((&rest a) -> sym))
+ (box (a -> (box a)) (i))
+ (unbox ((box a) -> a) (s boxx))
+ (set-box! ((box a) a -> void))
+ (void (-> void))
+ (make-module (a -> (module a)))
+ (raise ((&rest a) -> b))
+ (match:error (a (&rest b) -> c))
+ (should-never-reach (a -> b))
+ (make-cvector (num a -> (cvec a)))
+ (cvector ((&list a) -> (cvec a)))
+ (cvector-length ((cvec a) -> num))
+ (cvector-ref ((cvec a) num -> a))
+ (cvector->list ((cvec a) -> (list a)) (ic))
+ (list->cvector ((list a) -> (cvec a)))
+ (,qcons (a b -> (cons a b)) (ic) (n))
+ (,qvector ((&list a) -> (vec a)) (i) (n))
+ (,qbox (a -> (box a)) (i) (n))
+ (,qlist ((&list a) -> (list a)) (ic) (n))
+ (number? ((+ num x) -> bool) (p (num)))
+ (null? ((+ nil x) -> bool) (p (nil)))
+ (char? ((+ char x) -> bool) (p (char)))
+ (symbol? ((+ sym x) -> bool) (p (sym)))
+ (string? ((+ str x) -> bool) (p (str)))
+ (vector? ((+ (vec a) x) -> bool) (p (vec a)))
+ (cvector? ((+ (cvec a) x) -> bool) (p (cvec a)))
+ (box? ((+ (box a) x) -> bool) (p (box a)))
+ (pair? ((+ (cons a b) x) -> bool) (p (cons a b)))
+ (procedure?
+ ((+ ((&rest a) -> b) x) -> bool)
+ (p (?-> a b)))
+ (eof-object? ((+ eof x) -> bool) (p (eof)))
+ (input-port? ((+ iport x) -> bool) (p (iport)))
+ (output-port? ((+ oport x) -> bool) (p (oport)))
+ (true-object? ((+ true x) -> bool) (p (true)))
+ (false-object? ((+ false x) -> bool) (p (false)))
+ (module?
+ ((+ (module a) x) -> bool)
+ (p (module a)))
+ (boolean? ((+ true false x) -> bool) (p #t))
+ (list? ((mu u (+ nil (cons y u) x)) -> bool)
+ (p #t))))
+(define initial-env '())
+(define init-env!
+ (lambda ()
+ (set! initial-env
+ (foldr init-prim empty-env initial-info))))
+(define init-prim
+ (lambda (l env)
+ (letrec ((build-selector
+ (match-lambda
+ ('x (lambda (x) x))
+ ('_ (lambda (x) (make-pany)))
+ ('boxx
+ (let ((c (lookup env 'box?)))
+ (lambda (x) (make-pobj c (list x)))))
+ ((x . y)
+ (let ((c (lookup env 'pair?))
+ (lx (build-selector x))
+ (ly (build-selector y)))
+ (lambda (x) (make-pobj c (list (lx x) (ly x)))))))))
+ (match l
+ ((name type . attr)
+ (let* ((pure (cond ((assq 'i attr) #f)
+ ((assq 'ic attr) 'cons)
+ (else #t)))
+ (def (assq 'd attr))
+ (check (assq 'c attr))
+ (nocheck (assq 'n attr))
+ (pred (match (assq 'p attr)
+ (#f #f)
+ ((_ #t) #t)
+ ((_ (tag . args))
+ (cons (lookup initial-type-env tag) args))))
+ (sel (match (assq 's attr)
+ (#f #f)
+ ((_ s) (build-selector s))))
+ (env1 (extend-env
+ env
+ name
+ (make-name
+ name
+ (closeall (r+ initial-type-env type))
+ #f
+ 0
+ #f
+ #f
+ (cond (nocheck 'nocheck)
+ (check 'check)
+ (def 'imprecise)
+ (else #t))
+ #f
+ pure
+ pred
+ #f
+ sel)))
+ (env2 (extend-env
+ env1
+ (symbol-append 'check- name)
+ (make-name
+ (symbol-append 'check- name)
+ (closeall (r++ initial-type-env type))
+ #f
+ 0
+ #f
+ #f
+ #t
+ #f
+ pure
+ pred
+ #f
+ sel))))
+ env2))))))
+(define defprim
+ (lambda (name type mode)
+ (handle
+ (r+ initial-type-env type)
+ (match-lambda*
+ (('type . args) (apply syntax-err type args))
+ (x (apply raise x))))
+ (let* ((attr (match mode
+ ('impure '((i)))
+ ('pure '())
+ ('pure-if-cons-is '((ic)))
+ ('mutates-cons
+ (set! cons-mutators (cons name cons-mutators))
+ '())
+ (x (use-error
+ "invalid attribute ~a for st:defprim"
+ x))))
+ (info `(,name ,type ,@attr)))
+ (unless
+ (equal? info (assq name initial-info))
+ (set! initial-info (cons info initial-info))
+ (set! initial-env (init-prim info initial-env))))))
+(init-types!)
+(init-env!)
+(define %not (lookup initial-env 'not))
+(define %list (lookup initial-env 'list))
+(define %cons (lookup initial-env 'cons))
+(define %should-never-reach
+ (lookup initial-env 'should-never-reach))
+(define %false-object?
+ (lookup initial-env 'false-object?))
+(define %eq? (lookup initial-env 'eq?))
+(define %eqv? (lookup initial-env 'eqv?))
+(define %equal? (lookup initial-env 'equal?))
+(define %null? (lookup initial-env 'null?))
+(define %vector? (lookup initial-env 'vector?))
+(define %cvector? (lookup initial-env 'cvector?))
+(define %list? (lookup initial-env 'list?))
+(define %boolean? (lookup initial-env 'boolean?))
+(define %procedure?
+ (lookup initial-env 'procedure?))
+(define n-unbound 0)
+(define bind-defs
+ (lambda (defs env0 tenv0 old-unbound timestamp)
+ (letrec ((cons-mutable #f)
+ (unbound '())
+ (use-var
+ (lambda (x env context mk-node)
+ (match (lookup? env x)
+ (#f
+ (let* ((b (bind-var x)) (n (mk-node b)))
+ (set-name-timestamp! b context)
+ (set! unbound (cons n unbound))
+ n))
+ (b (when (and (name-primitive b)
+ (memq x cons-mutators))
+ (set! cons-mutable #t))
+ (set-name-occ! b (+ 1 (name-occ b)))
+ (mk-node b)))))
+ (bind-var
+ (lambda (x)
+ (make-name
+ x
+ #f
+ timestamp
+ 0
+ #f
+ #f
+ #f
+ #f
+ #f
+ #f
+ #f
+ #f)))
+ (bind (lambda (e env tenv context)
+ (let ((bind-cur (lambda (x) (bind x env tenv context))))
+ (match e
+ (($ var x) (use-var x env context make-var))
+ (($ prim x)
+ (use-var x initial-env context make-var))
+ (($ const c pred)
+ (use-var
+ pred
+ initial-env
+ context
+ (lambda (p) (make-const c p))))
+ (($ lam args e2)
+ (let* ((b-args (map bind-var args))
+ (newenv (extend-env* env args b-args)))
+ (make-lam
+ b-args
+ (bind e2 newenv tenv context))))
+ (($ vlam args rest e2)
+ (let* ((b-args (map bind-var args))
+ (b-rest (bind-var rest))
+ (newenv
+ (extend-env*
+ env
+ (cons rest args)
+ (cons b-rest b-args))))
+ (make-vlam
+ b-args
+ b-rest
+ (bind e2 newenv tenv context))))
+ (($ match e1 clauses)
+ (make-match
+ (bind-cur e1)
+ (map (lambda (x)
+ (bind-mclause x env tenv context))
+ clauses)))
+ (($ app e1 args)
+ (make-app (bind-cur e1) (map bind-cur args)))
+ (($ begin exps) (make-begin (map bind-cur exps)))
+ (($ and exps) (make-and (map bind-cur exps)))
+ (($ or exps) (make-or (map bind-cur exps)))
+ (($ if test then els)
+ (make-if
+ (bind-cur test)
+ (bind-cur then)
+ (bind-cur els)))
+ (($ delay e2) (make-delay (bind-cur e2)))
+ (($ set! x e2)
+ (use-var
+ x
+ env
+ context
+ (lambda (b)
+ (when (name-struct b)
+ (syntax-err
+ (pexpr e)
+ "define-structure identifier ~a may not be assigned"
+ x))
+ (when (name-primitive b)
+ (syntax-err
+ (pexpr e)
+ "(set! ~a ...) requires (define ~a ...)"
+ x
+ x))
+ (when (and (not (name-mutated b))
+ (not (= (name-timestamp b)
+ timestamp)))
+ (syntax-err
+ (pexpr e)
+ "(set! ~a ...) missing from compilation unit defining ~a"
+ x
+ x))
+ (set-name-mutated! b #t)
+ (make-set! b (bind-cur e2)))))
+ (($ let args e2)
+ (let* ((b-args
+ (map (match-lambda
+ (($ bind x e)
+ (make-bind
+ (bind-var x)
+ (bind-cur e))))
+ args))
+ (newenv
+ (extend-env*
+ env
+ (map bind-name args)
+ (map bind-name b-args))))
+ (make-let
+ b-args
+ (bind e2 newenv tenv context))))
+ (($ let* args e2)
+ (recur loop
+ ((args args) (b-args '()) (env env))
+ (match args
+ ((($ bind x e) . rest)
+ (let ((b (bind-var x)))
+ (loop rest
+ (cons (make-bind
+ b
+ (bind e
+ env
+ tenv
+ context))
+ b-args)
+ (extend-env env x b))))
+ (()
+ (make-let*
+ (reverse b-args)
+ (bind e2 env tenv context))))))
+ (($ letr args e2)
+ (let* ((b-args
+ (map (match-lambda
+ (($ bind x e)
+ (make-bind (bind-var x) e)))
+ args))
+ (newenv
+ (extend-env*
+ env
+ (map bind-name args)
+ (map bind-name b-args)))
+ (b-args
+ (map (match-lambda
+ (($ bind b e)
+ (let* ((n (name-occ b))
+ (e2 (bind e
+ newenv
+ tenv
+ context)))
+ (set-name-occ! b n)
+ (make-bind b e2))))
+ b-args)))
+ (make-letr
+ b-args
+ (bind e2 newenv tenv context))))
+ (($ body defs exps)
+ (match-let*
+ (((defs newenv newtenv)
+ (bind-defn defs env tenv #f)))
+ (make-body
+ defs
+ (map (lambda (x)
+ (bind x newenv newtenv context))
+ exps))))
+ (($ record args)
+ (make-record
+ (map (match-lambda
+ (($ bind x e)
+ (new-field! x)
+ (make-bind x (bind-cur e))))
+ args)))
+ (($ field x e2)
+ (new-field! x)
+ (make-field x (bind-cur e2)))
+ (($ cast ty e2)
+ (match-let
+ (((t absv)
+ (handle
+ (r+collect
+ tenv
+ (match ty
+ (('rec bind ty2)
+ `(rec ,bind (,ty2 -> ,ty2)))
+ (_ `(,ty -> ,ty))))
+ (match-lambda*
+ (('type . args)
+ (apply syntax-err ty args))
+ (x (apply raise x))))))
+ (make-cast
+ (list ty t absv)
+ (bind-cur e2))))))))
+ (bind-mclause
+ (lambda (clause env tenv context)
+ (match-let*
+ ((($ mclause pattern body failsym) clause)
+ (patenv empty-env)
+ (bp (recur loop
+ ((p pattern))
+ (match p
+ (($ pvar x)
+ (when (bound? patenv x)
+ (syntax-err
+ (ppat pattern)
+ "pattern variable ~a repeated"
+ x))
+ (let ((b (bind-var x)))
+ (set! patenv (extend-env patenv x b))
+ (make-pvar b)))
+ (($ pobj c args)
+ (use-var
+ c
+ env
+ context
+ (lambda (b)
+ (cond ((boolean? (name-predicate b))
+ (syntax-err
+ (ppat pattern)
+ "~a is not a predicate"
+ c))
+ ((and (not (eq? b %vector?))
+ (not (eq? b %cvector?))
+ (not (= (length
+ (cdr (name-predicate
+ b)))
+ (length args))))
+ (syntax-err
+ (ppat pattern)
+ "~a requires ~a sub-patterns"
+ c
+ (length
+ (cdr (name-predicate
+ b)))))
+ (else
+ (make-pobj
+ b
+ (map loop args)))))))
+ (($ pand pats)
+ (make-pand (map loop pats)))
+ (($ pnot pat) (make-pnot (loop pat)))
+ (($ ppred pred)
+ (use-var
+ pred
+ env
+ context
+ (lambda (b)
+ (unless
+ (name-predicate b)
+ (syntax-err
+ (ppat pattern)
+ "~a is not a predicate"
+ pred))
+ (make-ppred b))))
+ (($ pany) p)
+ (($ pelse) p)
+ (($ pconst c pred)
+ (use-var
+ pred
+ initial-env
+ context
+ (lambda (p) (make-pconst c p))))))))
+ (if failsym
+ (let ((b (bind-var failsym)))
+ (when (bound? patenv failsym)
+ (syntax-err
+ (ppat pattern)
+ "fail symbol ~a repeated"
+ failsym))
+ (set! patenv (extend-env patenv failsym b))
+ (make-mclause
+ bp
+ (bind body (join-env env patenv) tenv context)
+ b))
+ (make-mclause
+ bp
+ (bind body (join-env env patenv) tenv context)
+ #f)))))
+ (bind-defn
+ (lambda (defs env tenv glob)
+ (let* ((newenv empty-env)
+ (newtenv empty-env)
+ (struct-def
+ (lambda (x pure)
+ (when (or (bound? newenv x)
+ (and glob (bound? initial-env x)))
+ (syntax-err
+ #f
+ "~a defined more than once"
+ x))
+ (let ((b (bind-var x)))
+ (set-name-primitive! b #t)
+ (set-name-struct! b #t)
+ (set-name-pure! b pure)
+ (set! newenv (extend-env newenv x b))
+ b)))
+ (bind1 (match-lambda
+ ((and z ($ define x e))
+ (cond ((not x) z)
+ ((bound? newenv x)
+ (if glob
+ (make-define #f (make-set! x e))
+ (syntax-err
+ #f
+ "~a defined more than once"
+ x)))
+ (else
+ (let ((b (bind-var x)))
+ (set-name-gdef! b glob)
+ (set! newenv
+ (extend-env newenv x b))
+ (make-define b e)))))
+ ((and d
+ ($ defstruct
+ tag
+ args
+ make
+ pred
+ get
+ set
+ getn
+ setn
+ mutable))
+ (let* ((make (struct-def
+ make
+ (map not mutable)))
+ (pred (struct-def pred #t))
+ (bind-get
+ (lambda (name n)
+ (match name
+ (($ some x)
+ (let ((b (struct-def
+ x
+ #t)))
+ (set-name-selector!
+ b
+ (lambda (x)
+ (make-pobj
+ pred
+ (map-with-n
+ (lambda (_ m)
+ (if (= m n)
+ x
+ (make-pany)))
+ get))))
+ (some b)))
+ (none none))))
+ (bind-set
+ (match-lambda
+ (($ some x)
+ (some (struct-def x #t)))
+ (none none)))
+ (get (map-with-n bind-get get))
+ (getn (map-with-n bind-get getn))
+ (set (map bind-set set))
+ (setn (map bind-set setn))
+ (_ (when (bound? newtenv tag)
+ (syntax-err
+ (pdef d)
+ "type constructor ~a defined more than once"
+ tag)))
+ (tc (bind-tycon
+ tag
+ mutable
+ (bound? tenv tag)
+ (lambda args
+ (apply syntax-err
+ (cons (pdef d)
+ args))))))
+ (set! newtenv (extend-env newtenv tag tc))
+ (set-name-predicate!
+ pred
+ `(,tc ,@(map (lambda (_) (gensym)) get)))
+ (make-defstruct
+ tc
+ args
+ make
+ pred
+ get
+ set
+ getn
+ setn
+ mutable)))
+ ((and d ($ datatype dt))
+ (make-datatype
+ (maplr (match-lambda
+ (((tag . args) . bindings)
+ (when (bound? newtenv tag)
+ (syntax-err
+ (pdef d)
+ "type constructor ~a defined more than once"
+ tag))
+ (let ((tc (bind-tycon
+ tag
+ (map (lambda (_) #f)
+ args)
+ (bound? tenv tag)
+ (lambda args
+ (apply syntax-err
+ (cons (pdef d)
+ args))))))
+ (set! newtenv
+ (extend-env newtenv tag tc))
+ (cons (cons tc args)
+ (maplr (match-lambda
+ (($ variant
+ con
+ pred
+ arg-types)
+ (let ((make (struct-def
+ con
+ #t))
+ (pred (struct-def
+ pred
+ #t)))
+ (set-name-predicate!
+ pred
+ (cons tc
+ args))
+ (set-name-variant!
+ pred
+ arg-types)
+ (make-variant
+ make
+ pred
+ arg-types))))
+ bindings)))))
+ dt)))))
+ (defs2 (maplr bind1 defs))
+ (newenv2 (join-env env newenv))
+ (newtenv2 (join-env tenv newtenv))
+ (bind2 (match-lambda
+ ((and ($ define (? name? x) ($ var y)))
+ (=> fail)
+ (if (eq? (name-name x) y)
+ (if (bound? initial-env y)
+ (make-define
+ x
+ (make-var (lookup initial-env y)))
+ (begin
+ (printf
+ "Warning: (define ~a ~a) but ~a is not a primitive~%"
+ y
+ y
+ y)
+ (fail)))
+ (fail)))
+ ((and ($ define x e2) context)
+ (when (and glob
+ (name? x)
+ (bound?
+ initial-env
+ (name-name x)))
+ (printf
+ "Note: (define ~a ...) hides primitive ~a~%"
+ (name-name x)
+ (name-name x)))
+ (make-define
+ (or x
+ (let ((b (bind-var x)))
+ (set-name-gdef! b glob)
+ b))
+ (bind e2 newenv2 newtenv2 context)))
+ (d d))))
+ (list (maplr bind2 defs2) newenv2 newtenv2))))
+ (bind-old
+ (lambda (e env)
+ (match e
+ (($ var x)
+ (match (lookup? env (name-name x))
+ (#f (set! unbound (cons e unbound)))
+ (b (when (and (name-primitive b)
+ (memq x cons-mutators))
+ (set! cons-mutable #t))
+ (set-name-occ! b (+ 1 (name-occ b)))
+ (set-var-name! e b))))
+ (($ set! x _)
+ (match (lookup? env (name-name x))
+ (#f (set! unbound (cons e unbound)))
+ (b (when (name-struct b)
+ (syntax-err
+ (pexpr e)
+ "define-structure identifier ~a may not be assigned"
+ x))
+ (when (name-primitive b)
+ (syntax-err
+ (pexpr e)
+ "(set! ~a ...) requires (define ~a ...)"
+ x
+ x))
+ (when (and (not (name-mutated b))
+ (not (= (name-timestamp b)
+ timestamp)))
+ (syntax-err
+ (pexpr e)
+ "(set! ~a ...) missing from compilation unit defining ~a"
+ x
+ x))
+ (set-name-mutated! b #t)
+ (set-name-occ! b (+ 1 (name-occ b)))
+ (set-set!-name! e b))))))))
+ (match-let
+ (((defs env tenv) (bind-defn defs env0 tenv0 #t)))
+ (for-each
+ (lambda (x) (bind-old x env))
+ old-unbound)
+ (set-cons-mutability! cons-mutable)
+ (set! n-unbound (length unbound))
+ (list defs env tenv unbound)))))
+(define rebind-var
+ (lambda (b)
+ (make-name
+ (name-name b)
+ (name-ty b)
+ (name-timestamp b)
+ (name-occ b)
+ (name-mutated b)
+ #f
+ #f
+ #f
+ #f
+ #f
+ #f
+ #f)))
+(define warn-unbound
+ (lambda (l)
+ (let* ((names '())
+ (node->name
+ (match-lambda
+ (($ var x) x)
+ (($ set! x _) x)
+ (($ pobj x _) x)
+ (($ ppred x) x)))
+ (warn (lambda (b)
+ (unless
+ (memq (name-name b) names)
+ (set! names (cons (name-name b) names))
+ (printf
+ "Warning: ~a is unbound in "
+ (name-name b))
+ (print-context (pexpr (name-timestamp b)) 2)))))
+ (for-each (lambda (x) (warn (node->name x))) l))))
+(define name-unbound?
+ (lambda (x) (not (number? (name-timestamp x)))))
+(define improve-defs
+ (lambda (defs)
+ (map (match-lambda
+ (($ define x e2) (make-define x (improve e2)))
+ (x x))
+ defs)))
+(define improve
+ (match-lambda
+ (($ match e clauses) (improve-match e clauses))
+ (($ if tst thn els) (improve-if tst thn els))
+ ((? var? e) e)
+ ((? const? e) e)
+ (($ lam args e2) (make-lam args (improve e2)))
+ (($ vlam args rest e2)
+ (make-vlam args rest (improve e2)))
+ (($ app (and e1 ($ var x)) args)
+ (let ((args (map improve args)))
+ (if (and (eq? x %list) (< (length args) conslimit))
+ (foldr (lambda (a rest)
+ (make-app (make-var %cons) (list a rest)))
+ (make-const '() %null?)
+ args)
+ (make-app e1 args))))
+ (($ app e1 args)
+ (make-app (improve e1) (map improve args)))
+ (($ begin exps) (make-begin (map improve exps)))
+ (($ and exps) (make-and (map improve exps)))
+ (($ or exps) (make-or (map improve exps)))
+ (($ delay e2) (make-delay (improve e2)))
+ (($ set! x e2) (make-set! x (improve e2)))
+ (($ let args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (improve e))))
+ args)))
+ (make-let args (improve e2))))
+ (($ let* args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (improve e))))
+ args)))
+ (make-let* args (improve e2))))
+ (($ letr args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (improve e))))
+ args)))
+ (make-letr args (improve e2))))
+ (($ body defs exps)
+ (let ((defs (improve-defs defs)))
+ (make-body defs (map improve exps))))
+ (($ record args)
+ (make-record
+ (map (match-lambda
+ (($ bind x e) (make-bind x (improve e))))
+ args)))
+ (($ field x e2) (make-field x (improve e2)))
+ (($ cast ty e2) (make-cast ty (improve e2)))))
+(define improve-if
+ (lambda (tst thn els)
+ (let ((if->match
+ (lambda (x p mk-s thn els)
+ (let ((else-pat
+ (match els
+ (($ app ($ var q) _)
+ (if (eq? q %should-never-reach)
+ (make-pelse)
+ (make-pany)))
+ (_ (make-pany)))))
+ (make-match
+ (make-var x)
+ (list (make-mclause
+ (mk-s (make-ppred p))
+ (make-body '() (list thn))
+ #f)
+ (make-mclause
+ (mk-s else-pat)
+ (make-body '() (list els))
+ #f)))))))
+ (match tst
+ (($ app ($ var v) (e))
+ (=> fail)
+ (if (eq? v %not) (improve-if e els thn) (fail)))
+ (($ app ($ var eq) (($ const #f _) val))
+ (=> fail)
+ (if (or (eq? eq %eq?)
+ (eq? eq %eqv?)
+ (eq? eq %equal?))
+ (improve-if val els thn)
+ (fail)))
+ (($ app ($ var eq) (val ($ const #f _)))
+ (=> fail)
+ (if (or (eq? eq %eq?)
+ (eq? eq %eqv?)
+ (eq? eq %equal?))
+ (improve-if val els thn)
+ (fail)))
+ (($ app ($ var v) (($ var x)))
+ (=> fail)
+ (if (and (name-predicate v) (not (name-mutated x)))
+ (improve (if->match x v (lambda (x) x) thn els))
+ (fail)))
+ (($ app ($ var v) (($ app ($ var s) (($ var x)))))
+ (=> fail)
+ (if (and (name-predicate v)
+ (name-selector s)
+ (not (name-mutated x)))
+ (improve
+ (if->match x v (name-selector s) thn els))
+ (fail)))
+ (($ app ($ var v) (($ var x)))
+ (=> fail)
+ (if (and (name-selector v) (not (name-mutated x)))
+ (improve
+ (if->match
+ x
+ %false-object?
+ (name-selector v)
+ els
+ thn))
+ (fail)))
+ (($ var v)
+ (=> fail)
+ (if (not (name-mutated v))
+ (improve
+ (if->match
+ v
+ %false-object?
+ (lambda (x) x)
+ els
+ thn))
+ (fail)))
+ (_ (make-if
+ (improve tst)
+ (improve thn)
+ (improve els)))))))
+(define improve-match
+ (lambda (e clauses)
+ (let ((clauses
+ (map (match-lambda
+ (($ mclause p body fail)
+ (make-mclause p (improve body) fail)))
+ clauses)))
+ (match e
+ (($ var x)
+ (if (not (name-mutated x))
+ (let ((fix-clause
+ (match-lambda
+ ((and c ($ mclause p e fail))
+ (if (not (uses-x? e x))
+ c
+ (let ((y (rebind-var x)))
+ (make-mclause
+ (make-flat-pand (list p (make-pvar y)))
+ (sub e x y)
+ fail)))))))
+ (make-match e (map fix-clause clauses)))
+ (make-match e clauses)))
+ (_ (make-match (improve e) clauses))))))
+(define uses-x?
+ (lambda (e x)
+ (recur loop
+ ((e e))
+ (match e
+ (($ and exps) (ormap loop exps))
+ (($ app fun args)
+ (or (loop fun) (ormap loop args)))
+ (($ begin exps) (ormap loop exps))
+ (($ if e1 e2 e3)
+ (or (loop e1) (loop e2) (loop e3)))
+ (($ lam names body) (loop body))
+ (($ let bindings body)
+ (or (ormap (match-lambda (($ bind _ b) (loop b)))
+ bindings)
+ (loop body)))
+ (($ let* bindings body)
+ (or (ormap (match-lambda (($ bind _ b) (loop b)))
+ bindings)
+ (loop body)))
+ (($ letr bindings body)
+ (or (ormap (match-lambda (($ bind _ b) (loop b)))
+ bindings)
+ (loop body)))
+ (($ or exps) (ormap loop exps))
+ (($ delay e2) (loop e2))
+ (($ set! name exp) (or (eq? x name) (loop exp)))
+ (($ var name) (eq? x name))
+ (($ vlam names name body) (loop body))
+ (($ match exp clauses)
+ (or (loop exp)
+ (ormap (match-lambda
+ (($ mclause p b _) (or (loop p) (loop b))))
+ clauses)))
+ (($ body defs exps)
+ (or (ormap loop defs) (ormap loop exps)))
+ (($ record bindings)
+ (ormap (match-lambda (($ bind _ b) (loop b)))
+ bindings))
+ (($ field _ e) (loop e))
+ (($ cast _ e) (loop e))
+ (($ define _ e) (loop e))
+ ((? defstruct?) #f)
+ ((? datatype?) #f)
+ (($ pand pats) (ormap loop pats))
+ (($ pnot pat) (loop pat))
+ (($ pobj c args) (ormap loop args))
+ (($ ppred pred) (eq? x pred))
+ (_ #f)))))
+(define sub
+ (lambda (e x to)
+ (let ((dos (lambda (y) (if (eq? x y) to y))))
+ (recur sub
+ ((e e))
+ (match e
+ (($ define x e) (make-define x (sub e)))
+ ((? defstruct?) e)
+ ((? datatype?) e)
+ (($ match e clauses)
+ (let ((clauses
+ (map (match-lambda
+ (($ mclause p e fail)
+ (make-mclause p (sub e) fail)))
+ clauses)))
+ (make-match (sub e) clauses)))
+ (($ if tst thn els)
+ (make-if (sub tst) (sub thn) (sub els)))
+ (($ var x) (make-var (dos x)))
+ ((? const? e) e)
+ (($ lam args e2) (make-lam args (sub e2)))
+ (($ vlam args rest e2)
+ (make-vlam args rest (sub e2)))
+ (($ app e1 args)
+ (make-app (sub e1) (map sub args)))
+ (($ begin exps) (make-begin (map sub exps)))
+ (($ and exps) (make-and (map sub exps)))
+ (($ or exps) (make-or (map sub exps)))
+ (($ delay e2) (make-delay (sub e2)))
+ (($ set! x e2) (make-set! (dos x) (sub e2)))
+ (($ let args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (sub e))))
+ args)))
+ (make-let args (sub e2))))
+ (($ let* args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (sub e))))
+ args)))
+ (make-let* args (sub e2))))
+ (($ letr args e2)
+ (let ((args (map (match-lambda
+ (($ bind x e) (make-bind x (sub e))))
+ args)))
+ (make-letr args (sub e2))))
+ (($ body defs exps)
+ (make-body (map sub defs) (map sub exps)))
+ (($ record args)
+ (make-record
+ (map (match-lambda
+ (($ bind x e) (make-bind x (sub e))))
+ args)))
+ (($ field x e) (make-field x (sub e)))
+ (($ cast ty e) (make-cast ty (sub e))))))))
+(define improve-clauses
+ (lambda (clauses)
+ (recur loop
+ ((clauses clauses))
+ (match clauses
+ (() '())
+ ((_) clauses)
+ (((and m1 ($ mclause p _ fail)) . rest)
+ (cons m1
+ (if fail
+ (loop rest)
+ (recur loop2
+ ((clauses (loop rest)))
+ (match clauses
+ (() '())
+ (((and m ($ mclause p2 body2 fail2))
+ .
+ r)
+ (match (improve-by-pattern p2 p)
+ (('stop . p)
+ (cons (make-mclause
+ p
+ body2
+ fail2)
+ r))
+ (('redundant . p)
+ (unless
+ (null? r)
+ (printf
+ "Warning: redundant pattern ~a~%"
+ (ppat p2)))
+ (cons (make-mclause
+ p
+ body2
+ fail2)
+ r))
+ (('continue . p)
+ (cons (make-mclause
+ p
+ body2
+ fail2)
+ (loop2 r))))))))))))))
+(define improve-by-pattern
+ (lambda (p2 p1)
+ (call-with-current-continuation
+ (lambda (k)
+ (let* ((reject (lambda () (k (cons 'continue p2))))
+ (p1covers #t)
+ (p2covers #t)
+ (p3 (recur m
+ ((p1 p1) (p2 p2))
+ '(printf "(M ~a ~a)~%" (ppat p1) (ppat p2))
+ (match (cons p1 p2)
+ ((($ pand (a . _)) . p2) (m a p2))
+ ((p1 $ pand (a . b))
+ (make-flat-pand (cons (m p1 a) b)))
+ ((($ pvar _) . _)
+ (unless
+ (or (pvar? p2) (pany? p2))
+ (set! p2covers #f))
+ p2)
+ ((($ pany) . _)
+ (unless
+ (or (pvar? p2) (pany? p2))
+ (set! p2covers #f))
+ p2)
+ ((($ pelse) . _)
+ '(unless
+ (or (pvar? p2) (pany? p2))
+ (set! p2covers #f))
+ p2)
+ ((_ $ pvar _)
+ (unless p1covers (reject))
+ (set! p1covers #f)
+ (make-flat-pand (list p2 (make-pnot p1))))
+ ((_ $ pany)
+ (unless p1covers (reject))
+ (set! p1covers #f)
+ (make-flat-pand (list p2 (make-pnot p1))))
+ ((_ $ pelse)
+ (unless p1covers (reject))
+ (set! p1covers #f)
+ (make-flat-pand (list p2 (make-pnot p1))))
+ ((($ pconst a _) $ pconst b _)
+ (unless (equal? a b) (reject))
+ p2)
+ ((($ pobj tag1 a) $ pobj tag2 b)
+ (unless (eq? tag1 tag2) (reject))
+ (make-pobj tag1 (map2 m a b)))
+ ((($ ppred tag1) $ ppred tag2)
+ (unless (eq? tag1 tag2) (reject))
+ p2)
+ ((($ ppred tag1) $ pobj tag2 _)
+ (unless (eq? tag1 tag2) (reject))
+ (set! p2covers #f)
+ p2)
+ ((($ ppred tag1) $ pconst c tag2)
+ (unless (eq? tag1 tag2) (reject))
+ (set! p2covers #f)
+ p2)
+ (_ (reject))))))
+ (cond (p1covers (cons 'redundant p2))
+ (p2covers (cons 'stop p3))
+ (else (cons 'continue p3))))))))
+(define improve-by-noisily
+ (lambda (p2 p1)
+ (let ((r (improve-by-pattern p2 p1)))
+ (printf
+ "~a by ~a returns ~a ~a~%"
+ (ppat p2)
+ (ppat p1)
+ (car r)
+ (ppat (cdr r))))))
+(define make-components
+ (lambda (d)
+ (let* ((structs
+ (filter-map
+ (match-lambda ((? define?) #f) (x x))
+ d))
+ (defs (filter-map
+ (match-lambda ((? define? x) x) (_ #f))
+ d))
+ (name-of (match-lambda (($ define x _) x)))
+ (ref-of
+ (match-lambda
+ (($ define _ e) (references e name-gdef))))
+ (comp (top-sort defs name-of ref-of)))
+ (when #f
+ (printf "Components:~%")
+ (pretty-print
+ (map (lambda (c)
+ (map (match-lambda
+ (($ define x _) (and x (name-name x))))
+ c))
+ comp)))
+ (append structs comp))))
+(define make-body-components
+ (lambda (d)
+ (let* ((structs
+ (filter-map
+ (match-lambda ((? define?) #f) (x x))
+ d))
+ (defs (filter-map
+ (match-lambda ((? define? x) x) (_ #f))
+ d))
+ (name-of (match-lambda (($ define x _) x)))
+ (bound (map name-of defs))
+ (ref-of
+ (match-lambda
+ (($ define _ e)
+ (references e (lambda (x) (memq x bound))))))
+ (comp (top-sort defs name-of ref-of)))
+ (when #f
+ (printf "Components:~%")
+ (pretty-print
+ (map (lambda (c)
+ (map (match-lambda
+ (($ define x _) (and x (name-name x))))
+ c))
+ comp)))
+ (append structs comp))))
+(define make-letrec-components
+ (lambda (bindings)
+ (let* ((name-of bind-name)
+ (bound (map name-of bindings))
+ (ref-of
+ (match-lambda
+ (($ bind _ e)
+ (references e (lambda (x) (memq x bound))))))
+ (comp (top-sort bindings name-of ref-of)))
+ (when #f
+ (printf "Letrec Components:~%")
+ (pretty-print
+ (map (lambda (c)
+ (map (match-lambda (($ bind x _) (pname x))) c))
+ comp)))
+ comp)))
+(define references
+ (lambda (e ref?)
+ (recur loop
+ ((e e))
+ (match e
+ (($ define x e)
+ (if (and x (name-mutated x))
+ (union (set x) (loop e))
+ (loop e)))
+ ((? defstruct?) empty-set)
+ ((? datatype?) empty-set)
+ ((? const?) empty-set)
+ (($ var x) (if (ref? x) (set x) empty-set))
+ (($ lam _ e1) (loop e1))
+ (($ vlam _ _ e1) (loop e1))
+ (($ app e0 args)
+ (foldr union2 (loop e0) (map loop args)))
+ (($ let b e2)
+ (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
+ (foldr union2 (loop e2) (map do-bind b))))
+ (($ let* b e2)
+ (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
+ (foldr union2 (loop e2) (map do-bind b))))
+ (($ letr b e2)
+ (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
+ (foldr union2 (loop e2) (map do-bind b))))
+ (($ body defs exps)
+ (foldr union2
+ empty-set
+ (map loop (append defs exps))))
+ (($ record b)
+ (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
+ (foldr union2 empty-set (map do-bind b))))
+ (($ field _ e) (loop e))
+ (($ cast _ e) (loop e))
+ (($ and exps)
+ (foldr union2 empty-set (map loop exps)))
+ (($ or exps)
+ (foldr union2 empty-set (map loop exps)))
+ (($ begin exps)
+ (foldr union2 empty-set (map loop exps)))
+ (($ if test then els)
+ (union (loop test) (loop then) (loop els)))
+ (($ delay e) (loop e))
+ (($ set! x body)
+ (union (if (ref? x) (set x) empty-set)
+ (loop body)))
+ (($ match exp clauses)
+ (foldr union2
+ (loop exp)
+ (map (match-lambda (($ mclause _ exp _) (loop exp)))
+ clauses)))))))
+(define top-sort
+ (lambda (graph name-of references-of)
+ (let* ((adj assq)
+ (g (map (lambda (x)
+ (list (name-of x)
+ (box (references-of x))
+ (box #f)
+ x))
+ graph))
+ (gt (let ((gt (map (match-lambda
+ ((n _ _ name)
+ (list n (box empty-set) (box #f) n)))
+ g)))
+ (for-each
+ (match-lambda
+ ((n nay _ _)
+ (for-each
+ (lambda (v)
+ (match (adj v gt)
+ (#f #f)
+ ((_ b _ _) (set-box! b (cons n (unbox b))))))
+ (unbox nay))))
+ g)
+ gt))
+ (visit (lambda (vg)
+ (letrec ((visit (lambda (g l)
+ (match g
+ (#f l)
+ ((n nay mark name)
+ (if (unbox mark)
+ l
+ (begin
+ (set-box! mark #t)
+ (cons name
+ (foldr (lambda (v l)
+ (visit (adj v
+ vg)
+ l))
+ l
+ (unbox nay))))))))))
+ visit)))
+ (visit-gt (visit gt))
+ (visit-g (visit g))
+ (post (foldr visit-gt '() gt))
+ (pre (foldl (lambda (gg l)
+ (match (visit-g (adj gg g) '())
+ (() l)
+ (c (cons c l))))
+ '()
+ post)))
+ (reverse pre))))
+(define genlet #t)
+(define genmatch #t)
+(define letonce #f)
+(define type-defs
+ (lambda (d)
+ (for-each
+ (match-lambda
+ ((? defstruct? b) (type-structure b))
+ ((? datatype? b) (type-structure b))
+ (c (type-component c #t)))
+ (make-components d))
+ (close '())))
+(define type-structure
+ (match-lambda
+ (($ defstruct
+ x
+ _
+ make
+ pred
+ get
+ set
+ getn
+ setn
+ mutable)
+ (let* ((vars (map (lambda (_) (gensym)) get))
+ (make-get-type
+ (lambda (getter v)
+ (match getter
+ (($ some b)
+ (set-name-ty!
+ b
+ (closeall
+ (r+ initial-type-env `((,x ,@vars) -> ,v)))))
+ (_ #f))))
+ (make-set-type
+ (lambda (setter v)
+ (match setter
+ (($ some b)
+ (set-name-ty!
+ b
+ (closeall
+ (r+ initial-type-env `((,x ,@vars) ,v -> void)))))
+ (_ #f)))))
+ (set-name-ty!
+ make
+ (closeall
+ (r+ initial-type-env `(,@vars -> (,x ,@vars)))))
+ (set-name-ty!
+ pred
+ (closeall
+ (r+ initial-type-env
+ `((+ (,x ,@vars) y) -> bool))))
+ (for-each2 make-get-type get vars)
+ (for-each2 make-set-type set vars)
+ (for-each2 make-get-type getn vars)
+ (for-each2 make-set-type setn vars)))
+ (($ datatype dt)
+ (for-each
+ (match-lambda
+ ((type . variants)
+ (for-each
+ (match-lambda
+ (($ variant con pred arg-types)
+ (set-name-ty!
+ con
+ (closeall
+ (r+ initial-type-env
+ `(,@(cdr arg-types) -> ,type))))
+ (set-name-ty!
+ pred
+ (closeall
+ (r+ initial-type-env
+ `((+ ,(name-predicate pred) x) -> bool))))))
+ variants)))
+ dt))))
+(define type-component
+ (lambda (component top)
+ (when verbose
+ (let ((cnames
+ (filter-map
+ (match-lambda (($ define b _) (name-name b)))
+ component)))
+ (unless
+ (null? cnames)
+ (printf "Typing ~a~%" cnames))))
+ (let* ((f (match-lambda (($ define b e) (make-bind b e))))
+ (bindings (map f component))
+ (names (map (match-lambda (($ define b _) (pname b)))
+ component))
+ (f1 (match-lambda
+ (($ define b _) (set-name-ty! b (tvar)))))
+ (f2 (match-lambda
+ ((and d ($ define b e))
+ (set-define-exp! d (w e names)))))
+ (f3 (match-lambda
+ (($ define b e) (unify (name-ty b) (typeof e)))))
+ (f4 (match-lambda (($ define b _) (name-ty b))))
+ (f5 (lambda (d ts)
+ (match d (($ define b _) (set-name-ty! b ts))))))
+ (push-level)
+ (for-each f1 component)
+ (for-each f2 component)
+ (for-each f3 component)
+ (for-each limit-expansive component)
+ (for-each
+ f5
+ component
+ (close (map f4 component)))
+ (pop-level))))
+(define w
+ (lambda (e component)
+ (match e
+ (($ const _ pred)
+ (make-type
+ (r+ initial-type-env (name-predicate pred))
+ e))
+ (($ var x)
+ (unless
+ (name-ty x)
+ (set-name-ty!
+ x
+ (if (name-mutated x)
+ (monotvar)
+ (let* ((_1 (push-level))
+ (t (closeall (tvar)))
+ (_2 (pop-level)))
+ t))))
+ (if (ts? (name-ty x))
+ (match-let*
+ ((tynode (make-type #f #f))
+ ((t absv) (instantiate (name-ty x) tynode)))
+ (set-type-ty! tynode t)
+ (set-type-exp!
+ tynode
+ (match (name-primitive x)
+ ('imprecise
+ (make-check (list absv #f #f #f component) e))
+ ('check
+ (make-check
+ (list (cons top absv) #f #f #f component)
+ e))
+ ('nocheck e)
+ (#t
+ (make-check
+ (list absv (mk-definite-prim t) #f #f component)
+ e))
+ (#f
+ (make-check (list absv #f #f #t component) e))))
+ tynode)
+ e))
+ (($ lam x e1)
+ (for-each (lambda (b) (set-name-ty! b (tvar))) x)
+ (match-let*
+ ((body (w e1 component))
+ ((t absv)
+ (r+collect
+ initial-type-env
+ `(,@(map name-ty x) -> ,(typeof body)))))
+ (make-type
+ t
+ (make-check
+ (list absv (mk-definite-lam t) #f #f component)
+ (make-lam x body)))))
+ (($ vlam x rest e1)
+ (for-each (lambda (b) (set-name-ty! b (tvar))) x)
+ (match-let*
+ ((z (tvar))
+ (_ (set-name-ty!
+ rest
+ (r+ initial-type-env `(list ,z))))
+ (body (w e1 component))
+ ((t absv)
+ (r+collect
+ initial-type-env
+ `(,@(map name-ty x) (&list ,z) -> ,(typeof body)))))
+ (make-type
+ t
+ (make-check
+ (list absv (mk-definite-lam t) #f #f component)
+ (make-vlam x rest body)))))
+ (($ app e0 args)
+ (match-let*
+ ((t0 (w e0 component))
+ (targs (maplr (lambda (e) (w e component)) args))
+ (a* (map (lambda (_) (tvar)) args))
+ (b (tvar))
+ ((t absv)
+ (r-collect initial-type-env `(,@a* -> ,b)))
+ (definf (mk-definite-app t)))
+ (unify (typeof t0) t)
+ (for-each2 unify (map typeof targs) a*)
+ (if (syntactically-a-procedure? t0)
+ (make-type b (make-app t0 targs))
+ (make-type
+ b
+ (make-check
+ (list absv definf #f #f component)
+ (make-app t0 targs))))))
+ (($ let b e2)
+ (let* ((do-bind
+ (match-lambda
+ (($ bind b e)
+ (if genlet
+ (let* ((_ (push-level))
+ (e (w e (list (pname b))))
+ (bind (make-bind b e)))
+ (limit-expansive bind)
+ (set-name-ty! b (car (close (list (typeof e)))))
+ (pop-level)
+ bind)
+ (let ((e (w e component)))
+ (set-name-ty! b (typeof e))
+ (make-bind b e))))))
+ (tb (map do-bind b))
+ (body (w e2 component)))
+ (make-let tb body)))
+ (($ let* b e2)
+ (let* ((do-bind
+ (match-lambda
+ (($ bind b e)
+ (if genlet
+ (let* ((_ (push-level))
+ (e (w e (list (pname b))))
+ (bind (make-bind b e)))
+ (limit-expansive bind)
+ (set-name-ty! b (car (close (list (typeof e)))))
+ (pop-level)
+ bind)
+ (let ((e (w e component)))
+ (set-name-ty! b (typeof e))
+ (make-bind b e))))))
+ (tb (maplr do-bind b))
+ (body (w e2 component)))
+ (make-let* tb body)))
+ (($ letr b e2)
+ (let* ((do-comp
+ (lambda (b)
+ (if genlet
+ (let* ((f1 (match-lambda
+ (($ bind b _) (set-name-ty! b (tvar)))))
+ (names (map (match-lambda
+ (($ bind b _) (pname b)))
+ b))
+ (f2 (match-lambda
+ (($ bind b e)
+ (make-bind b (w e names)))))
+ (f3 (match-lambda
+ (($ bind b e)
+ (unify (name-ty b) (typeof e))
+ (name-ty b))))
+ (f4 (lambda (bind ts)
+ (match bind
+ (($ bind b _)
+ (set-name-ty! b ts)))))
+ (_1 (push-level))
+ (_2 (for-each f1 b))
+ (tb (maplr f2 b))
+ (_3 (for-each limit-expansive tb))
+ (ts-list (close (maplr f3 tb))))
+ (pop-level)
+ (for-each2 f4 tb ts-list)
+ tb)
+ (let* ((f1 (match-lambda
+ (($ bind b _) (set-name-ty! b (tvar)))))
+ (f2 (match-lambda
+ (($ bind b e)
+ (make-bind b (w e component)))))
+ (f3 (match-lambda
+ (($ bind b e)
+ (unify (name-ty b) (typeof e)))))
+ (_1 (for-each f1 b))
+ (tb (maplr f2 b)))
+ (for-each f3 tb)
+ tb))))
+ (comps (make-letrec-components b))
+ (tb (foldr append '() (maplr do-comp comps))))
+ (make-letr tb (w e2 component))))
+ (($ body defs exps)
+ (for-each
+ (match-lambda
+ ((? defstruct? b) (type-structure b))
+ ((? datatype? b) (type-structure b))
+ (c (type-component c #f)))
+ (make-body-components defs))
+ (let ((texps (maplr (lambda (x) (w x component)) exps)))
+ (make-body defs texps)))
+ (($ and exps)
+ (let* ((texps (maplr (lambda (x) (w x component)) exps))
+ (t (match texps
+ (() (r+ initial-type-env 'true))
+ ((e) (typeof e))
+ (_ (let ((a (r+ initial-type-env 'false)))
+ (unify (typeof (rac texps)) a)
+ a)))))
+ (make-type t (make-and texps))))
+ (($ or exps)
+ (let* ((texps (maplr (lambda (x) (w x component)) exps))
+ (t (match texps
+ (() (r+ initial-type-env 'false))
+ ((e) (typeof e))
+ (_ (let* ((t-last (typeof (rac texps)))
+ (but-last (rdc texps))
+ (a (tvar)))
+ (for-each
+ (lambda (e)
+ (unify (typeof e)
+ (r+ initial-type-env
+ `(+ (not false) ,a))))
+ but-last)
+ (unify t-last
+ (r+ initial-type-env
+ `(+ (not false) ,a)))
+ t-last)))))
+ (make-type t (make-or texps))))
+ (($ begin exps)
+ (let ((texps (maplr (lambda (x) (w x component)) exps)))
+ (make-begin texps)))
+ (($ if test then els)
+ (let ((ttest (w test component))
+ (tthen (w then component))
+ (tels (w els component))
+ (a (tvar)))
+ (unify (typeof tthen) a)
+ (unify (typeof tels) a)
+ (make-type a (make-if ttest tthen tels))))
+ (($ delay e2)
+ (let ((texp (w e2 component)))
+ (make-type
+ (r+ initial-type-env `(promise ,(typeof texp)))
+ (make-delay texp))))
+ (($ set! x body)
+ (unless (name-ty x) (set-name-ty! x (monotvar)))
+ (let* ((body (w body component))
+ (t (if (ts? (name-ty x))
+ (car (instantiate (name-ty x) #f))
+ (name-ty x))))
+ (unify t (typeof body))
+ (make-type
+ (r+ initial-type-env 'void)
+ (make-set! x body))))
+ (($ record bind)
+ (let* ((tbind (map (match-lambda
+ (($ bind name exp)
+ (make-bind name (w exp component))))
+ bind))
+ (t (r+ initial-type-env
+ `(record
+ ,@(map (match-lambda
+ (($ bind name exp)
+ (list name (typeof exp))))
+ tbind)))))
+ (make-type t (make-record tbind))))
+ (($ field name exp)
+ (match-let*
+ ((texp (w exp component))
+ (a (tvar))
+ ((t absv)
+ (r-collect initial-type-env `(record (,name ,a)))))
+ (unify (typeof texp) t)
+ (make-type
+ a
+ (make-check
+ (list absv #f #f #f component)
+ (make-field name texp)))))
+ (($ cast (ty t absv) exp)
+ (let ((texp (w exp component)) (a (tvar)))
+ (unify (r+ initial-type-env `(,(typeof texp) -> ,a))
+ t)
+ (make-type
+ a
+ (make-check
+ (list absv #f #f #f component)
+ (make-cast (list ty t absv) texp)))))
+ (($ match exp clauses)
+ (for-each
+ (match-lambda
+ (($ mclause p _ (? name? fail))
+ (set-name-ty!
+ fail
+ (r+ initial-type-env '(a ?-> b))))
+ (_ #f))
+ clauses)
+ (match-let*
+ ((iclauses
+ (improve-clauses
+ (append
+ clauses
+ (list (make-mclause (make-pelse) #f #f)))))
+ ((tmatch absv precise)
+ (w-match (rdc iclauses) (rac iclauses)))
+ (texp (w exp component))
+ (_ (unify (typeof texp) tmatch))
+ (tclauses
+ (maplr (match-lambda
+ (($ mclause p e fail)
+ (make-mclause p (w e component) fail)))
+ clauses))
+ (a (tvar)))
+ (for-each
+ (match-lambda
+ (($ mclause _ e _) (unify (typeof e) a)))
+ tclauses)
+ (make-type
+ a
+ (make-check
+ (list absv #f (not precise) #f component)
+ (make-match texp tclauses))))))))
+(define w-match
+ (lambda (clauses last)
+ (letrec ((bindings '())
+ (encode
+ (match-lambda
+ (($ pand pats) (encode* pats))
+ (x (encode* (list x)))))
+ (encode*
+ (lambda (pats)
+ (let* ((concrete?
+ (lambda (p)
+ (or (pconst? p) (pobj? p) (ppred? p) (pelse? p))))
+ (var? (lambda (p) (or (pvar? p) (pany? p))))
+ (not-var?
+ (lambda (p)
+ (and (not (pvar? p)) (not (pany? p)))))
+ (t (match (filter concrete? pats)
+ ((p)
+ (r+ initial-type-env
+ (match (template p)
+ ((x) x)
+ (x `(+ ,@x)))))
+ (()
+ (r+ initial-type-env
+ `(+ ,@(apply append
+ (map template
+ (filter
+ not-var?
+ pats)))
+ ,@(if (null? (filter var? pats))
+ '()
+ (list (out1tvar)))))))))
+ (for-each
+ (match-lambda
+ (($ pvar b)
+ (set! bindings (cons b bindings))
+ (set-name-ty! b (pat-var-bind t))))
+ (filter pvar? pats))
+ t)))
+ (template
+ (match-lambda
+ ((? pelse?) '())
+ (($ pconst _ pred) (list (name-predicate pred)))
+ ((and pat ($ pobj c args))
+ (list (cond ((or (eq? %vector? c) (eq? %cvector? c))
+ (cons (if (eq? %vector? c) 'vec 'cvec)
+ (match (maplr encode args)
+ (() (list (out1tvar)))
+ ((first . rest)
+ (list (foldr (lambda (x y)
+ (unify x y)
+ y)
+ first
+ rest))))))
+ (else
+ (cons (car (name-predicate c))
+ (maplr encode args))))))
+ (($ ppred pred)
+ (cond ((eq? pred %boolean?) (list 'true 'false))
+ ((eq? pred %list?) (list `(list ,(out1tvar))))
+ (else
+ (list (cons (car (name-predicate pred))
+ (maplr (lambda (_) (out1tvar))
+ (cdr (name-predicate pred))))))))
+ (($ pnot (? pconst?)) '())
+ (($ pnot ($ ppred pred))
+ (cond ((eq? pred %boolean?) '((not true) (not false)))
+ ((eq? pred %procedure?) '((not ?->)))
+ ((eq? pred %list?) '())
+ (else `((not ,(car (name-predicate pred)))))))
+ (($ pnot ($ pobj pred pats))
+ (let ((m (foldr + 0 (map non-triv pats))))
+ (case m
+ ((0) `((not ,(car (name-predicate pred)))))
+ ((1)
+ `((,(car (name-predicate pred))
+ ,@(map (match-lambda
+ (($ pobj pred _)
+ `(+ (not ,(car (name-predicate pred)))
+ ,(out1tvar)))
+ (($ ppred pred)
+ `(+ (not ,(car (name-predicate pred)))
+ ,(out1tvar)))
+ (_ (out1tvar)))
+ pats))))
+ (else '()))))))
+ (non-triv
+ (match-lambda
+ ((? pvar?) 0)
+ ((? pany?) 0)
+ ((? pelse?) 0)
+ ((? pconst?) 2)
+ (($ pobj _ pats) (foldr + 1 (map non-triv pats)))
+ (_ 1)))
+ (precise
+ (match-lambda
+ ((? pconst?) #f)
+ (($ pand pats) (andmap precise pats))
+ (($ pnot pat) (precise pat))
+ (($ pobj pred pats)
+ (let ((m (foldr + 0 (map non-triv pats))))
+ (case m
+ ((0) #t)
+ ((1) (andmap precise pats))
+ (else #f))))
+ (($ ppred pred) (not (eq? pred %list?)))
+ (_ #t))))
+ (push-level)
+ (match-let*
+ ((precise-match
+ (and (andmap
+ (match-lambda (($ mclause _ _ fail) (not fail)))
+ clauses)
+ (match last (($ mclause p _ _) (precise p)))))
+ (types (maplr (match-lambda (($ mclause p _ _) (encode p)))
+ clauses))
+ ((t absv)
+ (r-match
+ (foldr (lambda (x y) (unify x y) y) (tvar) types))))
+ (unify (out1tvar) t)
+ (for-each limit-name bindings)
+ (for-each2
+ set-name-ty!
+ bindings
+ (close (map name-ty bindings)))
+ (pop-level)
+ '(pretty-print
+ `(match-input
+ ,@(map (match-lambda (($ mclause p _ _) (ppat p)))
+ clauses)))
+ '(pretty-print
+ `(match-type
+ ,(ptype t)
+ ,@(map (lambda (b) (list (pname b) (ptype (name-ty b))))
+ bindings)))
+ (list t absv precise-match)))))
+(define syntactically-a-procedure?
+ (match-lambda
+ (($ type _ e) (syntactically-a-procedure? e))
+ (($ check _ e) (syntactically-a-procedure? e))
+ (($ var x) (name-primitive x))
+ ((? lam?) #t)
+ ((? vlam?) #t)
+ (($ let _ body)
+ (syntactically-a-procedure? body))
+ (($ let* _ body)
+ (syntactically-a-procedure? body))
+ (($ letr _ body)
+ (syntactically-a-procedure? body))
+ (($ if _ e2 e3)
+ (and (syntactically-a-procedure? e2)
+ (syntactically-a-procedure? e3)))
+ (($ begin exps)
+ (syntactically-a-procedure? (rac exps)))
+ (($ body _ exps)
+ (syntactically-a-procedure? (rac exps)))
+ (_ #f)))
+(define typeof
+ (match-lambda
+ (($ type t _) t)
+ (($ check _ e) (typeof e))
+ (($ let _ body) (typeof body))
+ (($ let* _ body) (typeof body))
+ (($ letr _ body) (typeof body))
+ (($ body _ exps) (typeof (rac exps)))
+ (($ begin exps) (typeof (rac exps)))
+ (($ var x) (name-ty x))))
+(define limit-name
+ (lambda (n)
+ (when (name-mutated n)
+ (unify (name-ty n) (out1tvar)))))
+(define limit-expansive
+ (letrec ((limit! (lambda (t) (unify t (out1tvar))))
+ (expansive-pattern?
+ (match-lambda
+ ((? pconst?) #f)
+ (($ pvar x) (name-mutated x))
+ (($ pobj _ pats) (ormap expansive-pattern? pats))
+ ((? pany?) #f)
+ ((? pelse?) #f)
+ (($ pand pats) (ormap expansive-pattern? pats))
+ (($ ppred x) (name-mutated x))
+ (($ pnot pat) (expansive-pattern? pat))))
+ (limit-expr
+ (match-lambda
+ (($ bind b e)
+ (if (name-mutated b)
+ (limit! (typeof e))
+ (limit-expr e)))
+ ((? defstruct?) #f)
+ ((? datatype?) #f)
+ (($ define x e)
+ (if (and x (name-mutated x))
+ (limit! (typeof e))
+ (limit-expr e)))
+ (($ type
+ t
+ ($ app ($ type _ ($ check _ ($ var x))) exps))
+ (cond ((list? (name-pure x))
+ (if (= (length (name-pure x)) (length exps))
+ (for-each2
+ (lambda (pure e)
+ (if pure (limit-expr e) (limit! (typeof e))))
+ (name-pure x)
+ exps)
+ (limit! t)))
+ ((or (eq? #t (name-pure x))
+ (and (eq? 'cons (name-pure x))
+ (not cons-is-mutable)))
+ (for-each limit-expr exps))
+ (else (limit! t))))
+ (($ type t ($ app _ _)) (limit! t))
+ (($ type t ($ check _ ($ app _ _))) (limit! t))
+ (($ delay _) #f)
+ (($ type t ($ set! _ _)) (limit! t))
+ (($ var _) #f)
+ ((? const?) #f)
+ (($ lam _ _) #f)
+ (($ vlam _ _ _) #f)
+ (($ let bind body)
+ (limit-expr body)
+ (for-each limit-expr bind))
+ (($ let* bind body)
+ (limit-expr body)
+ (for-each limit-expr bind))
+ (($ letr bind body)
+ (limit-expr body)
+ (for-each limit-expr bind))
+ (($ body defs exps)
+ (for-each limit-expr defs)
+ (for-each limit-expr exps))
+ (($ and exps) (for-each limit-expr exps))
+ (($ or exps) (for-each limit-expr exps))
+ (($ begin exps) (for-each limit-expr exps))
+ (($ if e1 e2 e3)
+ (limit-expr e1)
+ (limit-expr e2)
+ (limit-expr e3))
+ (($ record bind)
+ (for-each
+ (match-lambda (($ bind _ e) (limit-expr e)))
+ bind))
+ (($ field _ exp) (limit-expr exp))
+ (($ cast _ exp) (limit-expr exp))
+ (($ match exp clauses)
+ (limit-expr exp)
+ (for-each
+ (match-lambda
+ (($ mclause pat body fail)
+ (if (or (and fail (name-mutated fail))
+ (expansive-pattern? pat))
+ (limit! (typeof body))
+ (limit-expr body))))
+ clauses))
+ (($ type _ e1) (limit-expr e1))
+ (($ check _ e1) (limit-expr e1)))))
+ limit-expr))
+(define unparse
+ (lambda (e check-action)
+ (letrec ((pbind (match-lambda
+ (($ bind n e) (list (pname n) (pexpr e)))))
+ (pexpr (match-lambda
+ ((and x ($ type _ (? check?)))
+ (check-action x pexpr))
+ (($ type _ exp) (pexpr exp))
+ (($ shape t exp) (pexpr exp))
+ (($ define x e)
+ (if (or (not x) (and (name? x) (not (name-name x))))
+ (pexpr e)
+ `(define ,(pname x) ,(pexpr e))))
+ (($ defstruct _ args _ _ _ _ _ _ _)
+ `(check-define-const-structure ,args))
+ (($ datatype d)
+ `(datatype
+ ,@(map (match-lambda
+ (((tag . args) . bindings)
+ (cons (cons (ptag tag) args)
+ (map (match-lambda
+ (($ variant _ _ types) types))
+ bindings))))
+ d)))
+ (($ and exps) `(and ,@(maplr pexpr exps)))
+ (($ or exps) `(or ,@(maplr pexpr exps)))
+ (($ begin exps) `(begin ,@(maplr pexpr exps)))
+ (($ var x) (pname x))
+ (($ prim x) (pname x))
+ (($ const x _) (pconst x))
+ (($ lam x e1)
+ `(lambda ,(maplr pname x) ,@(pexpr e1)))
+ (($ vlam x rest e1)
+ `(lambda ,(append (maplr pname x) (pname rest))
+ ,@(pexpr e1)))
+ (($ match e1 clauses)
+ (let* ((pclause
+ (match-lambda
+ (($ mclause p #f #f)
+ `(,(ppat p) <last clause>))
+ (($ mclause p exp fail)
+ (if fail
+ `(,(ppat p)
+ (=> ,(pname fail))
+ ,@(pexpr exp))
+ `(,(ppat p) ,@(pexpr exp))))))
+ (p1 (pexpr e1)))
+ `(match ,p1 ,@(maplr pclause clauses))))
+ (($ app e1 args)
+ (let* ((p1 (pexpr e1))
+ (pargs (maplr pexpr args))
+ (unkwote
+ (match-lambda
+ (('quote x) x)
+ ((? boolean? x) x)
+ ((? number? x) x)
+ ((? char? x) x)
+ ((? string? x) x)
+ ((? null? x) x)
+ ((? box? x) x)
+ ((? vector? x) x))))
+ (cond ((eq? p1 qlist) `',(maplr unkwote pargs))
+ ((eq? p1 qcons)
+ (let ((unq (maplr unkwote pargs)))
+ `',(cons (car unq) (cadr unq))))
+ ((eq? p1 qbox) (box (unkwote (car pargs))))
+ ((eq? p1 qvector)
+ (list->vector (maplr unkwote pargs)))
+ (else (cons p1 pargs)))))
+ (($ let b e2)
+ (let ((pb (maplr pbind b)))
+ `(let ,pb ,@(pexpr e2))))
+ (($ let* b e2)
+ (let ((pb (maplr pbind b)))
+ `(let* ,pb ,@(pexpr e2))))
+ (($ letr b e2)
+ (let ((pb (maplr pbind b)))
+ `(letrec ,pb ,@(pexpr e2))))
+ (($ body defs exps)
+ (let ((pdefs (maplr pexpr defs)))
+ (append pdefs (maplr pexpr exps))))
+ (($ if e1 e2 e3)
+ (let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3)))
+ `(if ,p1 ,p2 ,p3)))
+ (($ record bindings)
+ `(record ,@(maplr pbind bindings)))
+ (($ field x e2) `(field ,x ,(pexpr e2)))
+ (($ cast (ty . _) e2) `(: ,ty ,(pexpr e2)))
+ (($ delay e) `(delay ,(pexpr e)))
+ (($ set! x e) `(set! ,(pname x) ,(pexpr e))))))
+ (pexpr e))))
+(define pexpr
+ (lambda (ex)
+ (unparse
+ ex
+ (lambda (e pexpr)
+ (match e
+ (($ type _ ($ check _ exp)) (pexpr exp)))))))
+(define pdef pexpr)
+(define ppat
+ (match-lambda
+ (($ pconst x _) (pconst x))
+ (($ pvar x) (pname x))
+ (($ pany) '_)
+ (($ pelse) 'else)
+ (($ pnot pat) `(not ,(ppat pat)))
+ (($ pand pats) `(and ,@(maplr ppat pats)))
+ (($ ppred pred)
+ (match (pname pred)
+ ('false-object? #f)
+ ('true-object? #t)
+ ('null? '())
+ (x `(? ,x))))
+ (($ pobj tag args)
+ (match (cons (pname tag) args)
+ (('box? x) (box (ppat x)))
+ (('pair? x y) (cons (ppat x) (ppat y)))
+ (('vector? . x) (list->vector (maplr ppat x)))
+ ((tg . _) `($ ,(strip-? tg) ,@(maplr ppat args)))))))
+(define strip-?
+ (lambda (s)
+ (let* ((str (symbol->string s))
+ (n (string-length str)))
+ (if (or (zero? n)
+ (not (char=? #\? (string-ref str (- n 1)))))
+ s
+ (string->symbol (substring str 0 (- n 1)))))))
+(define pname
+ (match-lambda
+ ((? name? x) (or (name-name x) '<expr>))
+ ((? symbol? x) x)))
+(define ptag
+ (match-lambda
+ ((? k? k) (k-name k))
+ ((? symbol? x) x)))
+(define pconst
+ (match-lambda
+ ((? symbol? x) `',x)
+ ((? boolean? x) x)
+ ((? number? x) x)
+ ((? char? x) x)
+ ((? string? x) x)
+ ((? null? x) `',x)))
+(define check
+ (lambda (file)
+ (output-checked file '() type-check?)))
+(define profcheck
+ (lambda (file)
+ (output-checked #f '() type-check?)
+ (output-checked
+ #f
+ (make-counters total-possible)
+ type-check?)))
+(define fullcheck
+ (lambda (file)
+ (let ((check? (lambda (_) #t)))
+ (output-checked #f '() check?)
+ (output-checked
+ #f
+ (make-counters total-possible)
+ check?))))
+(define make-counters
+ (lambda (n)
+ (let* ((init `(define check-counters (make-vector ,n 0)))
+ (sum '(define check-total
+ (lambda ()
+ (let ((foldr (lambda (f i l)
+ (recur loop
+ ((l l))
+ (match l
+ (() i)
+ ((x . y) (f x (loop y))))))))
+ (foldr + 0 (vector->list check-counters))))))
+ (incr '(extend-syntax
+ (check-increment-counter)
+ ((check-increment-counter c)
+ (vector-set!
+ check-counters
+ c
+ (+ 1 (vector-ref check-counters c)))))))
+ (list init sum incr))))
+(define output-checked
+ (lambda (file header check-test)
+ (set! summary '())
+ (set! total-possible 0)
+ (set! total-cast 0)
+ (set! total-err 0)
+ (set! total-any 0)
+ (let ((doit (lambda ()
+ (when (string? file)
+ (printf
+ ";; Generated by Soft Scheme ~a~%"
+ st:version)
+ (printf ";; (st:control")
+ (for-each
+ (lambda (x) (printf " '~a" x))
+ (show-controls))
+ (printf ")~%")
+ (unless
+ (= 0 n-unbound)
+ (printf
+ ";; CAUTION: ~a unbound references, this code is not safe~%"
+ n-unbound))
+ (printf "~%")
+ (for-each pretty-print header))
+ (for-each
+ (lambda (exp)
+ (match exp
+ (($ define x _)
+ (set! n-possible 0)
+ (set! n-clash 0)
+ (set! n-err 0)
+ (set! n-match 0)
+ (set! n-inexhaust 0)
+ (set! n-prim 0)
+ (set! n-lam 0)
+ (set! n-app 0)
+ (set! n-field 0)
+ (set! n-cast 0)
+ (if file
+ (pretty-print (pcheck exp check-test))
+ (pcheck exp check-test))
+ (make-summary-line x)
+ (set! total-possible
+ (+ total-possible n-possible))
+ (set! total-cast (+ total-cast n-cast))
+ (set! total-err (+ total-err n-err))
+ (set! total-any
+ (+ total-any
+ n-match
+ n-inexhaust
+ n-prim
+ n-lam
+ n-app
+ n-field
+ n-cast)))
+ (_ (when file
+ (pretty-print
+ (pcheck exp check-test))))))
+ tree)
+ (when (string? file)
+ (newline)
+ (newline)
+ (print-summary "; ")))))
+ (if (string? file)
+ (begin
+ (delete-file file)
+ (with-output-to-file file doit))
+ (doit)))))
+(define total-possible 0)
+(define total-err 0)
+(define total-cast 0)
+(define total-any 0)
+(define n-possible 0)
+(define n-clash 0)
+(define n-err 0)
+(define n-match 0)
+(define n-inexhaust 0)
+(define n-prim 0)
+(define n-lam 0)
+(define n-app 0)
+(define n-field 0)
+(define n-cast 0)
+(define summary '())
+(define make-summary-line
+ (lambda (x)
+ (let ((total (+ n-match
+ n-inexhaust
+ n-prim
+ n-lam
+ n-app
+ n-field
+ n-cast)))
+ (unless
+ (= 0 total)
+ (let* ((s (sprintf
+ "~a~a "
+ (padr (pname x) 16)
+ (padl total 2)))
+ (s (cond ((< 0 n-inexhaust)
+ (sprintf
+ "~a (~a match ~a inexhaust)"
+ s
+ n-match
+ n-inexhaust))
+ ((< 0 n-match)
+ (sprintf "~a (~a match)" s n-match))
+ (else s)))
+ (s (if (< 0 n-prim)
+ (sprintf "~a (~a prim)" s n-prim)
+ s))
+ (s (if (< 0 n-field)
+ (sprintf "~a (~a field)" s n-field)
+ s))
+ (s (if (< 0 n-lam)
+ (sprintf "~a (~a lambda)" s n-lam)
+ s))
+ (s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s))
+ (s (if (< 0 n-err)
+ (sprintf "~a (~a ERROR)" s n-err)
+ s))
+ (s (if (< 0 n-cast)
+ (sprintf "~a (~a TYPE)" s n-cast)
+ s)))
+ (set! summary (cons s summary)))))))
+(define print-summary
+ (lambda (hdr)
+ (for-each
+ (lambda (s) (printf "~a~a~%" hdr s))
+ (reverse summary))
+ (printf
+ "~a~a~a "
+ hdr
+ (padr "TOTAL CHECKS" 16)
+ (padl total-any 2))
+ (printf
+ " (of ~s is ~s%)"
+ total-possible
+ (if (= 0 total-possible)
+ 0
+ (string->number
+ (chop-number
+ (exact->inexact
+ (* (/ total-any total-possible) 100))
+ 4))))
+ (when (< 0 total-err)
+ (printf " (~s ERROR)" total-err))
+ (when (< 0 total-cast)
+ (printf " (~s TYPE)" total-cast))
+ (printf "~%")))
+(define padl
+ (lambda (arg n)
+ (let ((s (sprintf "~a" arg)))
+ (recur loop
+ ((s s))
+ (if (< (string-length s) n)
+ (loop (string-append " " s))
+ s)))))
+(define padr
+ (lambda (arg n)
+ (let ((s (sprintf "~a" arg)))
+ (recur loop
+ ((s s))
+ (if (< (string-length s) n)
+ (loop (string-append s " "))
+ s)))))
+(define chop-number
+ (lambda (x n)
+ (substring
+ (sprintf "~s00000000000000000000" x)
+ 0
+ (- n 1))))
+(define pcheck
+ (lambda (ex check-test)
+ (unparse
+ ex
+ (lambda (e pexpr)
+ (match e
+ ((and z ($ type _ ($ check inf ($ var x))))
+ (cond ((name-primitive x)
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pname x))
+ ('def
+ (set! n-err (+ 1 n-err))
+ (set! n-prim (+ 1 n-prim))
+ `(,(symbol-append "CHECK-" (pname x))
+ ,(tree-index z)
+ ',(string->symbol "ERROR")))
+ (_ (set! n-prim (+ 1 n-prim))
+ `(,(symbol-append "CHECK-" (pname x))
+ ,(tree-index z)))))
+ ((name-unbound? x) `(check-bound ,(pname x)))
+ (else
+ (if (check-test inf)
+ (begin
+ (set! n-clash (+ 1 n-clash))
+ `(,(string->symbol "CLASH")
+ ,(pname x)
+ ,(tree-index z)))
+ (pname x)))))
+ ((and z
+ ($ type _ ($ check inf (and m ($ lam x e1)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ ('def
+ (set! n-err (+ 1 n-err))
+ (set! n-lam (+ 1 n-lam))
+ `(,(string->symbol "CHECK-lambda")
+ (,(tree-index z) ',(string->symbol "ERROR"))
+ ,(map pname x)
+ ,@(pexpr e1)))
+ (_ (set! n-lam (+ 1 n-lam))
+ `(,(string->symbol "CHECK-lambda")
+ (,(tree-index z))
+ ,(map pname x)
+ ,@(pexpr e1)))))
+ ((and z
+ ($ type
+ _
+ ($ check inf (and m ($ vlam x rest e1)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ ('def
+ (set! n-err (+ 1 n-err))
+ (set! n-lam (+ 1 n-lam))
+ `(,(string->symbol "CHECK-lambda")
+ (,(tree-index z) ',(string->symbol "ERROR"))
+ ,(append (map pname x) (pname rest))
+ ,@(pexpr e1)))
+ (_ (set! n-lam (+ 1 n-lam))
+ `(,(string->symbol "CHECK-lambda")
+ (,(tree-index z))
+ ,(append (map pname x) (pname rest))
+ ,@(pexpr e1)))))
+ ((and z
+ ($ type _ ($ check inf (and m ($ app e1 args)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ ('def
+ (set! n-err (+ 1 n-err))
+ (set! n-app (+ 1 n-app))
+ `(,(string->symbol "CHECK-ap")
+ (,(tree-index z) ',(string->symbol "ERROR"))
+ ,(pexpr e1)
+ ,@(map pexpr args)))
+ (_ (set! n-app (+ 1 n-app))
+ (let ((p1 (pexpr e1)))
+ `(,(string->symbol "CHECK-ap")
+ (,(tree-index z))
+ ,p1
+ ,@(map pexpr args))))))
+ ((and z
+ ($ type _ ($ check inf (and m ($ field x e1)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ ('def
+ (set! n-err (+ 1 n-err))
+ (set! n-field (+ 1 n-field))
+ `(,(string->symbol "CHECK-field")
+ (,(tree-index z) ',(string->symbol "ERROR"))
+ ,x
+ ,(pexpr e1)))
+ (_ (set! n-field (+ 1 n-field))
+ `(,(string->symbol "CHECK-field")
+ (,(tree-index z))
+ ,x
+ ,(pexpr e1)))))
+ ((and z
+ ($ type
+ _
+ ($ check inf (and m ($ cast (x . _) e1)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ (_ (set! n-cast (+ 1 n-cast))
+ `(,(string->symbol "CHECK-:")
+ (,(tree-index z))
+ ,x
+ ,(pexpr e1)))))
+ ((and z
+ ($ type
+ _
+ ($ check inf (and m ($ match e1 clauses)))))
+ (set! n-possible (+ 1 n-possible))
+ (match (check-test inf)
+ (#f (pexpr m))
+ (inx (let* ((pclause
+ (match-lambda
+ (($ mclause p exp fail)
+ (if fail
+ `(,(ppat p)
+ (=> ,(pname fail))
+ ,@(pexpr exp))
+ `(,(ppat p) ,@(pexpr exp))))))
+ (p1 (pexpr e1)))
+ (if (eq? 'inexhaust inx)
+ (begin
+ (set! n-inexhaust (+ 1 n-inexhaust))
+ `(,(string->symbol "CHECK-match")
+ (,(tree-index z)
+ ,(string->symbol "INEXHAUST"))
+ ,p1
+ ,@(maplr pclause clauses)))
+ (begin
+ (set! n-match (+ 1 n-match))
+ `(,(string->symbol "CHECK-match")
+ (,(tree-index z))
+ ,p1
+ ,@(maplr pclause clauses)))))))))))))
+(define tree-index-list '())
+(define reinit-output!
+ (lambda () (set! tree-index-list '())))
+(define tree-index
+ (lambda (syntax)
+ (match (assq syntax tree-index-list)
+ (#f
+ (let ((n (length tree-index-list)))
+ (set! tree-index-list
+ (cons (cons syntax n) tree-index-list))
+ n))
+ ((_ . n) n))))
+(define tree-unindex
+ (lambda (n)
+ (let ((max (length tree-index-list)))
+ (when (<= max n)
+ (use-error "Invalid CHECK number ~a" n))
+ (car (list-ref tree-index-list (- (- max 1) n))))))
+(define cause
+ (lambda ()
+ (for-each
+ (lambda (def)
+ (for-each pretty-print (exp-cause def)))
+ tree)))
+(define cause*
+ (lambda names
+ (if (null? names)
+ (for-each
+ (lambda (def)
+ (for-each pretty-print (exp-cause def)))
+ tree)
+ (for-each
+ (match-lambda
+ ((? symbol? dname)
+ (for-each
+ pretty-print
+ (exp-cause (find-global dname)))))
+ names))))
+(define exp-cause
+ (let ((sum (lambda (exps)
+ (foldr (lambda (x y) (append (exp-cause x) y))
+ '()
+ exps)))
+ (src (lambda (inf)
+ (let ((nonlocal (map tree-index (check-sources inf))))
+ (if (type-check1? inf)
+ (cons (check-local-sources inf) nonlocal)
+ nonlocal)))))
+ (match-lambda
+ ((and z ($ type ty ($ check inf ($ var x))))
+ (if (name-primitive x)
+ (if (type-check? inf)
+ (list `((,(symbol-append 'check- (pname x))
+ ,(tree-index z))
+ ,@(src inf)))
+ '())
+ (if (type-check1? inf)
+ (list `((clash ,(pname x) ,(tree-index z)) ,@(src inf)))
+ '())))
+ ((and z ($ type ty ($ check inf ($ lam x e1))))
+ (append
+ (if (type-check? inf)
+ (list `((check-lambda ,(tree-index z) ,(map pname x) ...)
+ ,@(src inf)))
+ '())
+ (exp-cause e1)))
+ ((and z
+ ($ type ty ($ check inf ($ vlam x rest e1))))
+ (append
+ (if (type-check? inf)
+ (list `((check-lambda
+ ,(tree-index z)
+ ,(append (map pname x) (pname rest))
+ ...)
+ ,@(src inf)))
+ '())
+ (exp-cause e1)))
+ ((and z ($ type _ ($ check inf ($ app e1 args))))
+ (append
+ (if (type-check? inf)
+ (list `((check-ap ,(tree-index z)) ,@(src inf)))
+ '())
+ (exp-cause e1)
+ (sum args)))
+ ((and z ($ type _ ($ check inf ($ field x e1))))
+ (append
+ (if (type-check? inf)
+ (list `((check-field ,(tree-index z) ,x ...)
+ ,@(src inf)))
+ '())
+ (exp-cause e1)))
+ ((and z
+ ($ type _ ($ check inf ($ cast (x . _) e1))))
+ (append
+ (if (type-check? inf)
+ (list `((check-: ,(tree-index z) ,x ...) ,@(src inf)))
+ '())
+ (exp-cause e1)))
+ ((and z
+ ($ type
+ _
+ ($ check inf (and m ($ match e1 clauses)))))
+ (append
+ (if (type-check? inf)
+ (list `((check-match ,(tree-index z) ...) ,@(src inf)))
+ '())
+ (exp-cause m)))
+ (($ define _ e) (exp-cause e))
+ ((? defstruct?) '())
+ ((? datatype?) '())
+ (($ app e1 args) (sum (cons e1 args)))
+ (($ match exp clauses)
+ (foldr (lambda (x y)
+ (append
+ (match x (($ mclause _ e _) (exp-cause e)))
+ y))
+ (exp-cause exp)
+ clauses))
+ (($ var _) '())
+ (($ and exps) (sum exps))
+ (($ begin exps) (sum exps))
+ ((? const?) '())
+ (($ if test then els)
+ (append
+ (exp-cause test)
+ (exp-cause then)
+ (exp-cause els)))
+ (($ let bindings body)
+ (foldr (lambda (x y)
+ (append (match x (($ bind _ e) (exp-cause e))) y))
+ (exp-cause body)
+ bindings))
+ (($ let* bindings body)
+ (foldr (lambda (x y)
+ (append (match x (($ bind _ e) (exp-cause e))) y))
+ (exp-cause body)
+ bindings))
+ (($ letr bindings body)
+ (foldr (lambda (x y)
+ (append (match x (($ bind _ e) (exp-cause e))) y))
+ (exp-cause body)
+ bindings))
+ (($ body defs exps) (sum (append defs exps)))
+ (($ or exps) (sum exps))
+ (($ delay e) (exp-cause e))
+ (($ set! var body) (exp-cause body))
+ (($ record bindings)
+ (foldr (lambda (x y)
+ (append (match x (($ bind _ e) (exp-cause e))) y))
+ '()
+ bindings))
+ (($ type _ exp) (exp-cause exp)))))
+(define display-type tidy)
+(define type
+ (lambda names
+ (if (null? names)
+ (for-each globaldef tree)
+ (for-each
+ (match-lambda
+ ((? symbol? x)
+ (match (lookup? global-env x)
+ (#f (use-error "~a is not defined" x))
+ (ty (pretty-print
+ `(,x : ,(display-type (name-ty ty)))))))
+ ((? number? n)
+ (let* ((ty (check-type (tree-unindex n)))
+ (type (display-type ty)))
+ (pretty-print `(,n : ,type))))
+ (_ (use-error
+ "arguments must be identifiers or CHECK numbers")))
+ names))))
+(define localtype
+ (lambda names
+ (if (null? names)
+ (for-each localdef tree)
+ (for-each
+ (lambda (x) (localdef (find-global x)))
+ names))))
+(define find-global
+ (lambda (name)
+ (let ((d (ormap (match-lambda
+ ((and d ($ define x _))
+ (and (eq? name (name-name x)) d))
+ (_ #f))
+ tree)))
+ (unless d (use-error "~a is not defined" name))
+ d)))
+(define globaldef
+ (lambda (e)
+ (match e
+ (($ define x _)
+ (let ((type (display-type (name-ty x))))
+ (pretty-print `(,(pname x) : ,type))))
+ (_ #f))))
+(define localdef
+ (lambda (e) (pretty-print (expdef e))))
+(define expdef
+ (let* ((show (lambda (x)
+ `(,(pname x) : ,(display-type (name-ty x)))))
+ (pbind (match-lambda
+ (($ bind x e) `(,(show x) ,(expdef e))))))
+ (match-lambda
+ (($ define x e)
+ (if (or (not x) (and (name? x) (not (name-name x))))
+ (expdef e)
+ `(define ,(show x) ,(expdef e))))
+ ((? defstruct? d) (pdef d))
+ ((? datatype? d) (pdef d))
+ (($ and exps) `(and ,@(maplr expdef exps)))
+ (($ app fun args)
+ `(,(expdef fun) ,@(maplr expdef args)))
+ (($ begin exps) `(begin ,@(maplr expdef exps)))
+ (($ const c _) (pconst c))
+ (($ if test then els)
+ `(if ,(expdef test) ,(expdef then) ,(expdef els)))
+ (($ lam params body)
+ `(lambda ,(map show params) ,@(expdef body)))
+ (($ vlam params rest body)
+ `(lambda ,(append (map show params) (show rest))
+ ,@(expdef body)))
+ (($ let bindings body)
+ `(let ,(map pbind bindings) ,@(expdef body)))
+ (($ let* bindings body)
+ `(let* ,(map pbind bindings) ,@(expdef body)))
+ (($ letr bindings body)
+ `(letrec ,(map pbind bindings) ,@(expdef body)))
+ (($ body defs exps)
+ (let ((pdefs (maplr expdef defs)))
+ (append pdefs (maplr expdef exps))))
+ (($ record bindings)
+ `(record ,@(maplr pbind bindings)))
+ (($ field x e) `(field ,x ,(expdef e)))
+ (($ cast (ty . _) e) `(: ,ty ,(expdef e)))
+ (($ or exps) `(or ,@(maplr expdef exps)))
+ (($ delay e) `(delay ,(expdef e)))
+ (($ set! x body)
+ `(set! ,(pname x) ,(expdef body)))
+ (($ var x) (pname x))
+ (($ match e1 clauses)
+ (let* ((pclause
+ (match-lambda
+ (($ mclause p exp fail)
+ (if fail
+ `(,(expdef p) (=> ,(pname fail)) ,@(expdef exp))
+ `(,(expdef p) ,@(expdef exp))))))
+ (p1 (expdef e1)))
+ `(match ,p1 ,@(maplr pclause clauses))))
+ (($ pconst x _) (pconst x))
+ (($ pvar x) (show x))
+ (($ pany) '_)
+ (($ pelse) 'else)
+ (($ pnot pat) `(not ,(expdef pat)))
+ (($ pand pats) `(and ,@(maplr expdef pats)))
+ (($ ppred pred)
+ (match (pname pred)
+ ('false-object? #f)
+ ('true-object? #t)
+ ('null? '())
+ (x `(? ,x))))
+ (($ pobj tag args)
+ (match (cons (pname tag) args)
+ (('pair? x y) (cons (expdef x) (expdef y)))
+ (('box? x) (box (expdef x)))
+ (('vector? . x) (list->vector (maplr expdef x)))
+ ((tg . _)
+ `($ ,(strip-? tg) ,@(maplr expdef args)))))
+ (($ type _ exp) (expdef exp))
+ (($ check _ exp) (expdef exp)))))
+(define check-type
+ (match-lambda
+ (($ type ty ($ check inf ($ var x))) ty)
+ (($ type ty ($ check inf ($ lam x e1))) ty)
+ (($ type ty ($ check inf ($ vlam x rest e1))) ty)
+ (($ type _ ($ check inf ($ app e1 args)))
+ (typeof e1))
+ (($ type _ ($ check inf ($ field x e1)))
+ (typeof e1))
+ (($ type _ ($ check inf ($ cast (x . _) e1)))
+ (typeof e1))
+ (($ type _ ($ check inf ($ match e1 clauses)))
+ (typeof e1))))
+(define tree '())
+(define global-env empty-env)
+(define verbose #f)
+(define times #t)
+(define benchmarking #f)
+(define cons-mutators '(set-car! set-cdr!))
+(define st:check
+ (lambda args
+ (parameterize
+ ((print-level #f)
+ (print-length #f)
+ (pretty-maximum-lines #f))
+ (let ((output (apply do-soft args)))
+ (when output
+ (printf
+ "Typed program written to file ~a~%"
+ output))))))
+(define st:run
+ (lambda (file)
+ (parameterize
+ ((optimize-level 3))
+ (when benchmarking
+ (printf "Reloading slow CHECKs...~%")
+ (load (string-append
+ installation-directory
+ "checklib.scm"))
+ (set! benchmarking #f))
+ (load file))))
+(define st:bench
+ (lambda (file)
+ (parameterize
+ ((optimize-level 3))
+ (unless
+ benchmarking
+ (unless
+ fastlibrary-file
+ (use-error
+ "No benchmarking mode in this version"))
+ (printf "Reloading fast CHECKs...~%")
+ (load (string-append
+ installation-directory
+ fastlibrary-file))
+ (set! benchmarking #t))
+ (load file))))
+(define st:
+ (lambda args
+ (parameterize
+ ((print-level #f)
+ (print-length #f)
+ (pretty-maximum-lines #f))
+ (let ((output (apply do-soft args)))
+ (cond ((not output)
+ (use-error "Output file name required to run"))
+ ((= 0 n-unbound)
+ (printf
+ "Typed program written to file ~a, executing ...~%"
+ output)
+ (flush-output)
+ (st:run output))
+ (else
+ (printf
+ "Typed program written to file ~a, not executing (unbound refs)~%"
+ output)))))))
+(define do-soft
+ (match-lambda*
+ ((input (? string? output))
+ (when (strip-suffix output)
+ (use-error
+ "output file name cannot end in .ss or .scm"))
+ (cond ((string? input)
+ (soft-files (list input) output)
+ output)
+ ((and (list? input) (andmap string? input))
+ (soft-files input output)
+ output)
+ (else (soft-def input output) output)))
+ ((input #f)
+ (cond ((string? input) (soft-files (list input) #f) #f)
+ ((and (list? input) (andmap string? input))
+ (soft-files input #f)
+ #f)
+ (else (soft-def input #f) #f)))
+ ((input)
+ (cond ((string? input)
+ (let ((o (string-append
+ (or (strip-suffix input) input)
+ ".soft")))
+ (soft-files (list input) o)
+ o))
+ ((and (list? input) (andmap string? input))
+ (use-error "Output file name required"))
+ (else (soft-def input #t) #f)))
+ (else (use-error
+ "Input must be a file name or list of file names"))))
+(define rawmode #f)
+(define st:control
+ (lambda args
+ (let ((dbg (match-lambda
+ ('raw
+ (set! display-type ptype)
+ (set! rawmode #t))
+ ('!raw
+ (set! display-type tidy)
+ (set! rawmode #f))
+ ('verbose (set! verbose #t))
+ ('!verbose (set! verbose #f))
+ ('times (set! times #t))
+ ('!times (set! times #f))
+ ('partial (set! fullsharing #f))
+ ('!partial (set! fullsharing #t))
+ ('pseudo (set! pseudo pseudo-subtype))
+ ('!pseudo (set! pseudo #f))
+ ('populated (set! populated #t))
+ ('!populated (set! populated #f))
+ ('matchst (set! matchst #t))
+ ('!matchst (set! matchst #f))
+ ('genmatch (set! genmatch #t))
+ ('!genmatch (set! genmatch #f))
+ ('letonce (set! letonce #t))
+ ('!letonce (set! letonce #f))
+ ('global-error (set! global-error #t))
+ ('!global-error (set! global-error #f))
+ ('share (set! share #t))
+ ('!share (set! share #f))
+ ('flags (set! flags #t))
+ ('!flags (set! flags #f))
+ ('depths (set! dump-depths #t))
+ ('!depths (set! dump-depths #f))
+ ('match (set! keep-match #t))
+ ('!match (set! keep-match #f))
+ (x (printf "Error: unknown debug switch ~a~%" x)
+ (st:control)))))
+ (if (null? args)
+ (begin
+ (printf "Current values:")
+ (for-each
+ (lambda (x) (printf " ~a" x))
+ (show-controls))
+ (printf "~%"))
+ (for-each dbg args)))))
+(define show-controls
+ (lambda ()
+ (list (if rawmode 'raw '!raw)
+ (if verbose 'verbose '!verbose)
+ (if times 'times '!times)
+ (if share 'share '!share)
+ (if flags 'flags '!flags)
+ (if dump-depths 'depths '!depths)
+ (if fullsharing '!partial 'partial)
+ (if pseudo 'pseudo '!pseudo)
+ (if populated 'populated '!populated)
+ (if letonce 'letonce '!letonce)
+ (if matchst 'matchst '!matchst)
+ (if genmatch 'genmatch '!genmatch)
+ (if global-error 'global-error '!global-error)
+ (if keep-match 'match '!match))))
+(define soft-def
+ (lambda (exp output)
+ (reinit-macros!)
+ (reinit-types!)
+ (reinit-output!)
+ (set! visible-time 0)
+ (match-let*
+ ((before-parse (cpu-time))
+ (defs (parse-def exp))
+ (before-bind (cpu-time))
+ ((defs env tenv unbound)
+ (bind-defs
+ defs
+ initial-env
+ initial-type-env
+ '()
+ 0))
+ (_ (warn-unbound unbound))
+ (_ (if cons-is-mutable
+ (printf
+ "Note: use of ~a, treating cons as MUTABLE~%"
+ cons-mutators)
+ (printf
+ "Note: no use of ~a, treating cons as immutable~%"
+ cons-mutators)))
+ (before-improve (cpu-time))
+ (defs (improve-defs defs))
+ (before-typecheck (cpu-time))
+ (_ (type-check defs))
+ (_ (set! global-env env))
+ (before-output (cpu-time))
+ (_ (check output))
+ (_ (print-summary ""))
+ (before-end (cpu-time)))
+ (when times
+ (printf
+ "~a seconds parsing,~%"
+ (exact->inexact
+ (* (- before-bind before-parse)
+ clock-granularity)))
+ (printf
+ "~a seconds binding,~%"
+ (exact->inexact
+ (* (- before-improve before-bind)
+ clock-granularity)))
+ (printf
+ "~a seconds improving,~%"
+ (exact->inexact
+ (* (- before-typecheck before-improve)
+ clock-granularity)))
+ (printf
+ "~a seconds type checking,~%"
+ (exact->inexact
+ (* (- (- before-output before-typecheck)
+ visible-time)
+ clock-granularity)))
+ (printf
+ "~a seconds setting visibility,~%"
+ (exact->inexact
+ (* visible-time clock-granularity)))
+ (printf
+ "~a seconds writing output,~%"
+ (exact->inexact
+ (* (- before-end before-output)
+ clock-granularity)))
+ (printf
+ "~a seconds in total.~%"
+ (exact->inexact
+ (* (- before-end before-parse) clock-granularity)))))))
+(define type-check
+ (lambda (defs)
+ (set! tree defs)
+ (type-defs defs)
+ defs))
+(define soft-files
+ (lambda (files output)
+ (let ((contents
+ (map (lambda (f) `(begin ,@(readfile f))) files)))
+ (soft-def `(begin ,@contents) output))))
+(define strip-suffix
+ (lambda (name)
+ (let ((n (string-length name)))
+ (or (and (<= 3 n)
+ (equal? ".ss" (substring name (- n 3) n))
+ (substring name 0 (- n 3)))
+ (and (<= 4 n)
+ (equal? ".scm" (substring name (- n 4) n))
+ (substring name 0 (- n 4)))))))
+(define st:deftype
+ (match-lambda*
+ (((? symbol? x) ? list? mutability)
+ (=> fail)
+ (if (andmap boolean? mutability)
+ (deftype x mutability)
+ (fail)))
+ (args (use-error
+ "Invalid command ~a"
+ `(st:deftype ,@args)))))
+(define st:defprim
+ (match-lambda*
+ (((? symbol? x) type) (defprim x type 'impure))
+ (((? symbol? x) type (? symbol? mode))
+ (defprim x type mode))
+ (args (use-error
+ "Invalid command ~a"
+ `(st:defprim ,@args)))))
+(define st:help
+ (lambda ()
+ (printf
+ "Commands for Soft Scheme (~a)~%"
+ st:version)
+ (printf
+ " (st: file (output)) type check file and execute~%")
+ (printf
+ " (st:type (name)) print types of global defs~%")
+ (printf
+ " (st:check file (output)) type check file~%")
+ (printf
+ " (st:run file) execute type checked file~%")
+ (printf
+ " (st:bench file) execute type checked file fast~%")
+ (printf
+ " (st:ltype (name)) print types of local defs~%")
+ (printf
+ " (st:cause) print cause of CHECKs~%")
+ (printf
+ " (st:summary) print summary of CHECKs~%")
+ (printf
+ " (st:help) prints this message~%")
+ (printf
+ " (st:defprim name type (mode)) define a new primitive~%")
+ (printf
+ " (st:deftype name bool ...) define a new type constructor~%")
+ (printf
+ " (st:control flag ...) set internal flags~%")
+ (printf
+ "For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%")
+ (printf
+ "Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%")
+ (printf
+ "terms of the Gnu Public License. No warranties of any kind apply.~%")))
+(define st:type type)
+(define st:ltype localtype)
+(define st:cause cause)
+(define st:summary
+ (lambda () (print-summary "")))
+(define init!
+ (lambda ()
+ (when customization-file
+ (load (string-append
+ installation-directory
+ customization-file)))
+ (let ((softrc
+ (string-append home-directory "/.softschemerc")))
+ (when (file-exists? softrc) (load softrc)))
+ (set! global-env initial-env)
+ (st:help)))
+(init!)
--- /dev/null
+; Complete source for Twobit and Sparc assembler in one file.
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; See 'twobit-benchmark', at end.
+
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Completely fundamental pathname manipulation.
+
+; This takes zero or more directory components and a file name and
+; constructs a filename relative to the current directory.
+
+(define (make-relative-filename . components)
+
+ (define (construct l)
+ (if (null? (cdr l))
+ l
+ (cons (car l)
+ (cons "/" (construct (cdr l))))))
+
+ (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components))))
+
+; This takes one or more directory components and constructs a
+; directory name with proper termination (a crock -- we can finess
+; this later).
+
+(define (pathname-append . components)
+
+ (define (construct l)
+ (cond ((null? (cdr l))
+ l)
+ ((string=? (car l) "")
+ (construct (cdr l)))
+ ((char=? #\/ (string-ref (car l) (- (string-length (car l)) 1)))
+ (cons (car l) (construct (cdr l))))
+ (else
+ (cons (car l)
+ (cons "/" (construct (cdr l)))))))
+
+ (let ((n (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components)))))
+ (if (not (char=? #\/ (string-ref n (- (string-length n) 1))))
+ (string-append n "/")
+ n)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Nbuild parameters for SPARC Larceny.
+
+(define (make-nbuild-parameter dir source? verbose? hostdir hostname)
+ (let ((parameters
+ `((compiler . ,(pathname-append dir "Compiler"))
+ (util . ,(pathname-append dir "Util"))
+ (build . ,(pathname-append dir "Rts" "Build"))
+ (source . ,(pathname-append dir "Lib"))
+ (common-source . ,(pathname-append dir "Lib" "Common"))
+ (repl-source . ,(pathname-append dir "Repl"))
+ (interp-source . ,(pathname-append dir "Eval"))
+ (machine-source . ,(pathname-append dir "Lib" "Sparc"))
+ (common-asm . ,(pathname-append dir "Asm" "Common"))
+ (sparc-asm . ,(pathname-append dir "Asm" "Sparc"))
+ (target-machine . SPARC)
+ (endianness . big)
+ (word-size . 32)
+ (always-source? . ,source?)
+ (verbose-load? . ,verbose?)
+ (compatibility . ,(pathname-append dir "Compat" hostdir))
+ (host-system . ,hostname)
+ )))
+ (lambda (key)
+ (let ((probe (assq key parameters)))
+ (if probe
+ (cdr probe)
+ #f)))))
+
+(define nbuild-parameter
+ (make-nbuild-parameter "" #f #f "Larceny" "Larceny"))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Useful list functions.
+;
+; Notes:
+; * Reduce, reduce-right, fold-right, fold-left are compatible with MIT Scheme.
+; * Make-list is compatible with MIT Scheme and Chez Scheme.
+; * These are not (yet) compatible with Shivers's proposed list functions.
+; * remq, remv, remove, remq!, remv!, remov!, every?, and some? are in the
+; basic library.
+
+; Destructively remove all associations whose key matches `key' from `alist'.
+
+(define (aremq! key alist)
+ (cond ((null? alist) alist)
+ ((eq? key (caar alist))
+ (aremq! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremq! key (cdr alist)))
+ alist)))
+
+(define (aremv! key alist)
+ (cond ((null? alist) alist)
+ ((eqv? key (caar alist))
+ (aremv! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremv! key (cdr alist)))
+ alist)))
+
+(define (aremove! key alist)
+ (cond ((null? alist) alist)
+ ((equal? key (caar alist))
+ (aremove! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremove! key (cdr alist)))
+ alist)))
+
+; Return a list of elements of `list' selected by the predicate.
+
+(define (filter select? list)
+ (cond ((null? list) list)
+ ((select? (car list))
+ (cons (car list) (filter select? (cdr list))))
+ (else
+ (filter select? (cdr list)))))
+
+; Return the first element of `list' selected by the predicate.
+
+(define (find selected? list)
+ (cond ((null? list) #f)
+ ((selected? (car list)) (car list))
+ (else (find selected? (cdr list)))))
+
+; Return a list with all duplicates (according to predicate) removed.
+
+(define (remove-duplicates list same?)
+
+ (define (member? x list)
+ (cond ((null? list) #f)
+ ((same? x (car list)) #t)
+ (else (member? x (cdr list)))))
+
+ (cond ((null? list) list)
+ ((member? (car list) (cdr list))
+ (remove-duplicates (cdr list) same?))
+ (else
+ (cons (car list) (remove-duplicates (cdr list) same?)))))
+
+; Return the least element of `list' according to some total order.
+
+(define (least less? list)
+ (reduce (lambda (a b) (if (less? a b) a b)) #f list))
+
+; Return the greatest element of `list' according to some total order.
+
+(define (greatest greater? list)
+ (reduce (lambda (a b) (if (greater? a b) a b)) #f list))
+
+; (mappend p l) = (apply append (map p l))
+
+(define (mappend proc l)
+ (apply append (map proc l)))
+
+; (make-list n) => (a1 ... an) for some ai
+; (make-list n x) => (a1 ... an) where ai = x
+
+(define (make-list nelem . rest)
+ (let ((val (if (null? rest) #f (car rest))))
+ (define (loop n l)
+ (if (zero? n)
+ l
+ (loop (- n 1) (cons val l))))
+ (loop nelem '())))
+
+; (reduce p x ()) => x
+; (reduce p x (a)) => a
+; (reduce p x (a b ...)) => (p (p a b) ...))
+
+(define (reduce proc initial l)
+
+ (define (loop val l)
+ (if (null? l)
+ val
+ (loop (proc val (car l)) (cdr l))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop (car l) (cdr l)))))
+
+; (reduce-right p x ()) => x
+; (reduce-right p x (a)) => a
+; (reduce-right p x (a b ...)) => (p a (p b ...))
+
+(define (reduce-right proc initial l)
+
+ (define (loop l)
+ (if (null? (cdr l))
+ (car l)
+ (proc (car l) (loop (cdr l)))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop l))))
+
+; (fold-left p x (a b ...)) => (p (p (p x a) b) ...)
+
+(define (fold-left proc initial l)
+ (if (null? l)
+ initial
+ (fold-left proc (proc initial (car l)) (cdr l))))
+
+; (fold-right p x (a b ...)) => (p a (p b (p ... x)))
+
+(define (fold-right proc initial l)
+ (if (null? l)
+ initial
+ (proc (car l) (fold-right proc initial (cdr l)))))
+
+; (iota n) => (0 1 2 ... n-1)
+
+(define (iota n)
+ (let loop ((n (- n 1)) (r '()))
+ (let ((r (cons n r)))
+ (if (= n 0)
+ r
+ (loop (- n 1) r)))))
+
+; (list-head (a1 ... an) m) => (a1 ... am) for m <= n
+
+(define (list-head l n)
+ (if (zero? n)
+ '()
+ (cons (car l) (list-head (cdr l) (- n 1)))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- compatibility library for Twobit running under Larceny.
+
+(define ($$trace x) #t)
+
+(define host-system 'larceny)
+
+; Temporary?
+
+(define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+
+; The compatibility library loads Auxlib if compat:initialize is called
+; without arguments. Compat:load will load fasl files when appropriate.
+
+(define (compat:initialize . rest)
+ (if (null? rest)
+ (let ((dir (nbuild-parameter 'compatibility)))
+ (compat:load (string-append dir "compat2.sch"))
+ (compat:load (string-append dir "../../Auxlib/list.sch"))
+ (compat:load (string-append dir "../../Auxlib/pp.sch")))))
+
+(define (with-optimization level thunk)
+ (thunk))
+
+; Calls thunk1, and if thunk1 causes an error to be signalled, calls thunk2.
+
+(define (call-with-error-control thunk1 thunk2)
+ (let ((eh (error-handler)))
+ (error-handler (lambda args
+ (error-handler eh)
+ (thunk2)
+ (apply eh args)))
+ (thunk1)
+ (error-handler eh)))
+
+(define (larc-new-extension fn ext)
+ (let* ((l (string-length fn))
+ (x (let loop ((i (- l 1)))
+ (cond ((< i 0) #f)
+ ((char=? (string-ref fn i) #\.) (+ i 1))
+ (else (loop (- i 1)))))))
+ (if (not x)
+ (string-append fn "." ext)
+ (string-append (substring fn 0 x) ext))))
+
+(define (compat:load filename)
+ (define (loadit fn)
+ (if (nbuild-parameter 'verbose-load?)
+ (format #t "~a~%" fn))
+ (load fn))
+ (if (nbuild-parameter 'always-source?)
+ (loadit filename)
+ (let ((fn (larc-new-extension filename "fasl")))
+ (if (and (file-exists? fn)
+ (compat:file-newer? fn filename))
+ (loadit fn)
+ (loadit filename)))))
+
+(define (compat:file-newer? a b)
+ (let* ((ta (file-modification-time a))
+ (tb (file-modification-time b))
+ (limit (vector-length ta)))
+ (let loop ((i 0))
+ (cond ((= i limit)
+ #f)
+ ((= (vector-ref ta i) (vector-ref tb i))
+ (loop (+ i 1)))
+ (else
+ (> (vector-ref ta i) (vector-ref tb i)))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- second part of compatibility code
+; This file ought to be compiled, but doesn't have to be.
+;
+; 12 April 1999
+
+(define host-system 'larceny) ; Don't remove this!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; A well-defined sorting procedure.
+
+(define compat:sort (lambda (list less?) (sort list less?)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Well-defined character codes.
+; Returns the UCS-2 code for a character.
+
+(define compat:char->integer char->integer)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Input and output
+
+(define (write-lop item port)
+ (lowlevel-write item port)
+ (newline port)
+ (newline port))
+
+(define write-fasl-datum lowlevel-write)
+
+; The power of self-hosting ;-)
+
+(define (misc->bytevector x)
+ (let ((bv (bytevector-like-copy x)))
+ (typetag-set! bv $tag.bytevector-typetag)
+ bv))
+
+(define string->bytevector misc->bytevector)
+
+(define bignum->bytevector misc->bytevector)
+
+(define (flonum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+(define (compnum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+; Clears garbage word of compnum/flonum; makes regression testing much
+; easier.
+
+(define (clear-first-word bv)
+ (bytevector-like-set! bv 0 0)
+ (bytevector-like-set! bv 1 0)
+ (bytevector-like-set! bv 2 0)
+ (bytevector-like-set! bv 3 0)
+ bv)
+
+(define (list->bytevector l)
+ (let ((b (make-bytevector (length l))))
+ (do ((i 0 (+ i 1))
+ (l l (cdr l)))
+ ((null? l) b)
+ (bytevector-set! b i (car l)))))
+
+(define bytevector-word-ref
+ (let ((two^8 (expt 2 8))
+ (two^16 (expt 2 16))
+ (two^24 (expt 2 24)))
+ (lambda (bv i)
+ (+ (* (bytevector-ref bv i) two^24)
+ (* (bytevector-ref bv (+ i 1)) two^16)
+ (* (bytevector-ref bv (+ i 2)) two^8)
+ (bytevector-ref bv (+ i 3))))))
+
+(define (twobit-format fmt . rest)
+ (let ((out (open-output-string)))
+ (apply format out fmt rest)
+ (get-output-string out)))
+
+; This needs to be a random number in both a weaker and stronger sense
+; than `random': it doesn't need to be a truly random number, so a sequence
+; of calls can return a non-random sequence, but if two processes generate
+; two sequences, then those sequences should not be the same.
+;
+; Gross, huh?
+
+(define (an-arbitrary-number)
+ (system "echo \\\"`date`\\\" > a-random-number")
+ (let ((x (string-hash (call-with-input-file "a-random-number" read))))
+ (delete-file "a-random-number")
+ x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Miscellaneous
+
+(define cerror error)
+
+; eof
+; Copyright 1991 Wiliam Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Sets represented as lists.
+;
+; 5 April 1999.
+
+(define (empty-set) '())
+
+(define (empty-set? x) (null? x))
+
+(define (make-set x)
+ (define (loop x y)
+ (cond ((null? x) y)
+ ((member (car x) y) (loop (cdr x) y))
+ (else (loop (cdr x) (cons (car x) y)))))
+ (loop x '()))
+
+(define (set-equal? x y)
+ (and (subset? x y) (subset? y x)))
+
+(define (subset? x y)
+ (every? (lambda (x) (member x y))
+ x))
+
+; To get around MacScheme's limit on the number of arguments.
+
+(define apply-union)
+
+(define union
+ (letrec ((union2
+ (lambda (x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))))
+
+ (set! apply-union
+ (lambda (sets)
+ (do ((sets sets (cdr sets))
+ (result '() (union2 (car sets) result)))
+ ((null? sets)
+ result))))
+
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (union2 (car args) (cadr args)))
+ (else (union2 (union2 (car args)
+ (cadr args))
+ (apply union (cddr args))))))))
+
+(define intersection
+ (letrec ((intersection2
+ (lambda (x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (cons (car x) (intersection2 (cdr x) y)))
+ (else (intersection2 (cdr x) y))))))
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (intersection2 (car args) (cadr args)))
+ (else (intersection2 (intersection2 (car args)
+ (cadr args))
+ (apply intersection (cddr args))))))))
+
+(define (difference x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (difference (cdr x) y))
+ (else (cons (car x) (difference (cdr x) y)))))
+; Reasonably portable hashing on EQ?, EQV?, EQUAL?.
+; Requires bignums, SYMBOL-HASH.
+;
+; Given any Scheme object, returns a non-negative exact integer
+; less than 2^24.
+
+(define object-hash (lambda (x) 0)) ; hash on EQ?, EQV?
+(define equal-hash (lambda (x) 0)) ; hash on EQUAL?
+
+(let ((n 16777216)
+ (n-1 16777215)
+ (adj:fixnum 9000000)
+ (adj:negative 8000000)
+ (adj:large 7900000)
+ (adj:ratnum 7800000)
+ (adj:complex 7700000)
+ (adj:flonum 7000000)
+ (adj:compnum 6900000)
+ (adj:char 6111000)
+ (adj:string 5022200)
+ (adj:vector 4003330)
+ (adj:misc 3000444)
+ (adj:pair 2555000)
+ (adj:proc 2321001)
+ (adj:iport 2321002)
+ (adj:oport 2321003)
+ (adj:weird 2321004)
+ (budget0 32))
+
+ (define (combine hash adjustment)
+ (modulo (+ hash hash hash adjustment) 16777216))
+
+ (define (hash-on-equal x budget)
+ (if (> budget 0)
+ (cond ((string? x)
+ (string-hash x))
+ ((pair? x)
+ (let ((budget (quotient budget 2)))
+ (combine (hash-on-equal (car x) budget)
+ (hash-on-equal (cdr x) budget))))
+ ((vector? x)
+ (let ((n (vector-length x))
+ (budget (quotient budget 4)))
+ (if (> n 0)
+ (combine
+ (combine (hash-on-equal (vector-ref x 0) budget)
+ (hash-on-equal (vector-ref x (- n 1)) budget))
+ (hash-on-equal (vector-ref x (quotient n 2))
+ (+ budget budget)))
+ adj:vector)))
+ (else
+ (object-hash x)))
+ adj:weird))
+
+ (set! object-hash
+ (lambda (x)
+ (cond ((symbol? x)
+ (symbol-hash x))
+ ((number? x)
+ (if (exact? x)
+ (cond ((integer? x)
+ (cond ((negative? x)
+ (combine (object-hash (- x)) adj:negative))
+ ((< x n)
+ (combine x adj:fixnum))
+ (else
+ (combine (modulo x n) adj:large))))
+ ((rational? x)
+ (combine (combine (object-hash (numerator x))
+ adj:ratnum)
+ (object-hash (denominator x))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:complex)
+ (object-hash (imag-part x))))
+ (else
+ adj:weird))
+ (cond (#t
+ ; We can't really do anything with inexact numbers
+ ; unless infinities and NaNs behave reasonably.
+ adj:flonum)
+ ((rational? x)
+ (combine
+ (combine (object-hash
+ (inexact->exact (numerator x)))
+ adj:flonum)
+ (object-hash (inexact->exact (denominator x)))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:compnum)
+ (object-hash (imag-part x))))
+ (else adj:weird))))
+ ((char? x)
+ (combine (char->integer x) adj:char))
+ ((string? x)
+ (combine (string-length x) adj:string))
+ ((vector? x)
+ (combine (vector-length x) adj:vector))
+ ((eq? x #t)
+ (combine 1 adj:misc))
+ ((eq? x #f)
+ (combine 2 adj:misc))
+ ((null? x)
+ (combine 3 adj:misc))
+ ((pair? x)
+ adj:pair)
+ ((procedure? x)
+ adj:proc)
+ ((input-port? x)
+ adj:iport)
+ ((output-port? x)
+ adj:oport)
+ (else
+ adj:weird))))
+
+ (set! equal-hash
+ (lambda (x)
+ (hash-on-equal x budget0)))); Hash tables.
+; Requires CALL-WITHOUT-INTERRUPTS.
+; This code should be thread-safe provided VECTOR-REF is atomic.
+;
+; (make-hashtable <hash-function> <bucket-searcher> <size>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket
+; with <size> buckets at first, expanding the number of buckets as needed.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtable <hash-function> <bucket-searcher>)
+;
+; Equivalent to (make-hashtable <hash-function> <bucket-searcher> n)
+; for some value of n chosen by the implementation.
+;
+; (make-hashtable <hash-function>)
+;
+; Equivalent to (make-hashtable <hash-function> assv).
+;
+; (make-hashtable)
+;
+; Equivalent to (make-hashtable object-hash assv).
+;
+; (hashtable-contains? <hashtable> <key>)
+;
+; Returns true iff the <hashtable> contains an entry for <key>.
+;
+; (hashtable-fetch <hashtable> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtable> if the
+; <hashtable> contains <key>; otherwise returns <flag>.
+;
+; (hashtable-get <hashtable> <key>)
+;
+; Equivalent to (hashtable-fetch <hashtable> <key> #f)
+;
+; (hashtable-put! <hashtable> <key> <value>)
+;
+; Changes the <hashtable> to associate <key> with <value>, replacing
+; any existing association for <key>.
+;
+; (hashtable-remove! <hashtable> <key>)
+;
+; Removes any association for <key> within the <hashtable>.
+;
+; (hashtable-clear! <hashtable>)
+;
+; Removes all associations from the <hashtable>.
+;
+; (hashtable-size <hashtable>)
+;
+; Returns the number of keys contained within the <hashtable>.
+;
+; (hashtable-for-each <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtable-map <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+;
+; (hashtable-copy <hashtable>)
+;
+; Returns a copy of the <hashtable>.
+
+; These global variables are assigned new values later.
+
+(define make-hashtable (lambda args '*))
+(define hashtable-contains? (lambda (ht key) #f))
+(define hashtable-fetch (lambda (ht key flag) flag))
+(define hashtable-get (lambda (ht key) (hashtable-fetch ht key #f)))
+(define hashtable-put! (lambda (ht key val) '*))
+(define hashtable-remove! (lambda (ht key) '*))
+(define hashtable-clear! (lambda (ht) '*))
+(define hashtable-size (lambda (ht) 0))
+(define hashtable-for-each (lambda (ht proc) '*))
+(define hashtable-map (lambda (ht proc) '()))
+(define hashtable-copy (lambda (ht) ht))
+
+; Implementation.
+; A hashtable is represented as a vector of the form
+;
+; #(("HASHTABLE") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtable,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is a vector of buckets.
+;
+; The <hasher> and <searcher> fields are constant, but
+; the <count> and <buckets> fields are mutable.
+;
+; For thread-safe operation, the mutators must modify both
+; as an atomic operation. Other operations do not require
+; critical sections provided VECTOR-REF is an atomic operation
+; and the operation does not modify the hashtable, does not
+; reference the <count> field, and fetches the <buckets>
+; field exactly once.
+
+(let ((doc (list "HASHTABLE"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (count! (lambda (ht n) (vector-set! ht 1 n)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+ (buckets! (lambda (ht v) (vector-set! ht 4 v)))
+ (defaultn 10))
+ (let ((hashtable? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtable-error (lambda (x)
+ (display "ERROR: Bad hash table: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht hashfun searcher size)
+ (vector doc 0 hashfun searcher (make-vector size '())))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ (define (resize ht0)
+ (call-without-interrupts
+ (lambda ()
+ (let ((ht (make-ht (hasher ht0)
+ (searcher ht0)
+ (+ 1 (* 2 (count ht0))))))
+ (ht-for-each (lambda (key val)
+ (put! ht key val))
+ ht0)
+ (buckets! ht0 (buckets ht))))))
+
+ ; Returns the contents of the hashtable as a vector of pairs.
+
+ (define (contents ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (z (make-vector (count ht) '())))
+ (define (loop i bucket j)
+ (if (null? bucket)
+ (if (= i n)
+ (if (= j (vector-length z))
+ z
+ (begin (display "BUG in hashtable")
+ (newline)
+ '#()))
+ (loop (+ i 1)
+ (vector-ref v i)
+ j))
+ (let ((entry (car bucket)))
+ (vector-set! z j (cons (car entry) (cdr entry)))
+ (loop i
+ (cdr bucket)
+ (+ j 1)))))
+ (loop 0 '() 0)))
+
+ (define (contains? ht key)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h)))
+ (if ((searcher ht) key b)
+ #t
+ #f))
+ (hashtable-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtable-error ht)))
+
+ (define (put! ht key val)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ ; Using SET-CDR! on the probe would make it necessary
+ ; to synchronize the CONTENTS routine.
+ (vector-set! v h (substitute1 (cons key val) probe b))
+ (begin (count! ht (+ (count ht) 1))
+ (vector-set! v h (cons (cons key val) b))
+ (if (> (count ht) n)
+ (resize ht)))))
+ #f))
+ (hashtable-error ht)))
+
+ (define (remove! ht key)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (begin (count! ht (- (count ht) 1))
+ (vector-set! v h (remq1 probe b))
+ (if (< (* 2 (+ defaultn (count ht))) n)
+ (resize ht))))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (clear! ht)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (begin (count! ht 0)
+ (buckets! ht (make-vector defaultn '()))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (size ht)
+ (if (hashtable? ht)
+ (count ht)
+ (hashtable-error ht)))
+
+ ; This code must be written so that the procedure can modify the
+ ; hashtable without breaking any invariants.
+
+ (define (ht-for-each f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (let ((x (vector-ref v j)))
+ (f (car x) (cdr x)))))
+ (hashtable-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1))
+ (results '() (let ((x (vector-ref v j)))
+ (cons (f (car x) (cdr x))
+ results))))
+ ((= j n)
+ (reverse results))))
+ (hashtable-error ht)))
+
+ (define (ht-copy ht)
+ (if (hashtable? ht)
+ (let* ((newtable (make-hashtable (hasher ht) (searcher ht) 0))
+ (v (buckets ht))
+ (n (vector-length v))
+ (newvector (make-vector n '())))
+ (count! newtable (count ht))
+ (buckets! newtable newvector)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! newvector i (append (vector-ref v i) '())))
+ newtable)
+ (hashtable-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtable
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args)))
+ (size (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+ defaultn
+ (caddr args))))
+ (make-ht hashfun searcher size))))
+
+ (set! hashtable-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtable-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtable-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtable-put! (lambda (ht key val) (put! ht key val)))
+ (set! hashtable-remove! (lambda (ht key) (remove! ht key)))
+ (set! hashtable-clear! (lambda (ht) (clear! ht)))
+ (set! hashtable-size (lambda (ht) (size ht)))
+ (set! hashtable-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtable-map (lambda (ht proc) (ht-map ht proc)))
+ (set! hashtable-copy (lambda (ht) (ht-copy ht)))
+ #f))
+; Hash trees: a functional data structure analogous to hash tables.
+;
+; (make-hashtree <hash-function> <bucket-searcher>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtree <hash-function>)
+;
+; Equivalent to (make-hashtree <hash-function> assv).
+;
+; (make-hashtree)
+;
+; Equivalent to (make-hashtree object-hash assv).
+;
+; (hashtree-contains? <hashtree> <key>)
+;
+; Returns true iff the <hashtree> contains an entry for <key>.
+;
+; (hashtree-fetch <hashtree> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtree> if the
+; <hashtree> contains <key>; otherwise returns <flag>.
+;
+; (hashtree-get <hashtree> <key>)
+;
+; Equivalent to (hashtree-fetch <hashtree> <key> #f)
+;
+; (hashtree-put <hashtree> <key> <value>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is associated with <value>.
+;
+; (hashtree-remove <hashtree> <key>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is not associated with any value.
+;
+; (hashtree-size <hashtree>)
+;
+; Returns the number of keys contained within the <hashtree>.
+;
+; (hashtree-for-each <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtree-map <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+
+; These global variables are assigned new values later.
+
+(define make-hashtree (lambda args '*))
+(define hashtree-contains? (lambda (ht key) #f))
+(define hashtree-fetch (lambda (ht key flag) flag))
+(define hashtree-get (lambda (ht key) (hashtree-fetch ht key #f)))
+(define hashtree-put (lambda (ht key val) '*))
+(define hashtree-remove (lambda (ht key) '*))
+(define hashtree-size (lambda (ht) 0))
+(define hashtree-for-each (lambda (ht proc) '*))
+(define hashtree-map (lambda (ht proc) '()))
+
+; Implementation.
+; A hashtree is represented as a vector of the form
+;
+; #(("hashtree") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtree,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is generated by the following grammar:
+;
+; <buckets> ::= ()
+; | (<fixnum> <associations> <buckets> <buckets>)
+; <alist> ::= (<associations>)
+; <associations> ::=
+; | <association> <associations>
+; <association> ::= (<key> . <value>)
+;
+; If <buckets> is of the form (n alist buckets1 buckets2),
+; then n is the hash code of all keys in alist, all keys in buckets1
+; have a hash code less than n, and all keys in buckets2 have a hash
+; code greater than n.
+
+(let ((doc (list "hashtree"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+
+ (make-empty-buckets (lambda () '()))
+
+ (make-buckets
+ (lambda (h alist buckets1 buckets2)
+ (list h alist buckets1 buckets2)))
+
+ (buckets-empty? (lambda (buckets) (null? buckets)))
+
+ (buckets-n (lambda (buckets) (car buckets)))
+ (buckets-alist (lambda (buckets) (cadr buckets)))
+ (buckets-left (lambda (buckets) (caddr buckets)))
+ (buckets-right (lambda (buckets) (cadddr buckets))))
+
+ (let ((hashtree? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtree-error (lambda (x)
+ (display "ERROR: Bad hash tree: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht count hashfun searcher buckets)
+ (vector doc count hashfun searcher buckets))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ ; Returns the contents of the hashtree as a list of pairs.
+
+ (define (contents ht)
+ (let* ((t (buckets ht)))
+
+ (define (contents t alist)
+ (if (buckets-empty? t)
+ alist
+ (contents (buckets-left t)
+ (contents (buckets-right t)
+ (append-reverse (buckets-alist t)
+ alist)))))
+
+ (define (append-reverse x y)
+ (if (null? x)
+ y
+ (append-reverse (cdr x)
+ (cons (car x) y))))
+
+ ; Creating a new hashtree from a list that is almost sorted
+ ; in hash code order would create an extremely unbalanced
+ ; hashtree, so this routine randomizes the order a bit.
+
+ (define (randomize1 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize2 (cdr alist)
+ (cons (car alist) alist1)
+ alist2
+ alist3)))
+
+ (define (randomize2 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize3 (cdr alist)
+ alist1
+ (cons (car alist) alist2)
+ alist3)))
+
+ (define (randomize3 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize1 (cdr alist)
+ alist1
+ alist2
+ (cons (car alist) alist3))))
+
+ (define (randomize-combine alist1 alist2 alist3)
+ (cond ((null? alist2)
+ alist1)
+ ((null? alist3)
+ (append-reverse alist2 alist1))
+ (else
+ (append-reverse
+ (randomize1 alist3 '() '() '())
+ (append-reverse
+ (randomize1 alist1 '() '() '())
+ (randomize1 alist2 '() '() '()))))))
+
+ (randomize1 (contents t '()) '() '() '())))
+
+ (define (contains? ht key)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key)))
+ (if ((searcher ht) key (find-bucket t h))
+ #t
+ #f))
+ (hashtree-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key))
+ (probe ((searcher ht) key (find-bucket t h))))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtree-error ht)))
+
+ ; Given a <buckets> t and a hash code h, returns the alist for h.
+
+ (define (find-bucket t h)
+ (if (buckets-empty? t)
+ '()
+ (let ((n (buckets-n t)))
+ (cond ((< h n)
+ (find-bucket (buckets-left t) h))
+ ((< n h)
+ (find-bucket (buckets-right t) h))
+ (else
+ (buckets-alist t))))))
+
+ (define (put ht key val)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (association (cons key val))
+ (c (count ht)))
+ (define (put t h)
+ (if (buckets-empty? t)
+ (begin (set! c (+ c 1))
+ (make-buckets h (list association) t t))
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (put (buckets-left t) h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (put (buckets-right t) h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (make-buckets n
+ (substitute1 association
+ probe
+ alist)
+ left
+ right)
+ (begin
+ (set! c (+ c 1))
+ (make-buckets n
+ (cons association alist)
+ left
+ right)))))))))
+ (let ((buckets (put t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (remove ht key)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (c (count ht)))
+ (define (remove t h)
+ (if (buckets-empty? t)
+ t
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (remove left h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (remove right h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (begin (set! c (- c 1))
+ (make-buckets n
+ (remq1 probe alist)
+ left
+ right))
+ t)))))))
+ (let ((buckets (remove t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (size ht)
+ (if (hashtree? ht)
+ (count ht)
+ (hashtree-error ht)))
+
+ (define (ht-for-each f ht)
+ (if (hashtree? ht)
+ (for-each (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtree? ht)
+ (map (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtree
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args))))
+ (make-ht 0 hashfun searcher (make-empty-buckets)))))
+
+ (set! hashtree-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtree-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtree-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtree-put (lambda (ht key val) (put ht key val)))
+ (set! hashtree-remove (lambda (ht key) (remove ht key)))
+ (set! hashtree-size (lambda (ht) (size ht)))
+ (set! hashtree-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtree-map (lambda (ht proc) (ht-map ht proc)))
+ #f))
+; Copyright 1994 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 24 April 1999
+;
+; Compiler switches needed by Twobit.
+
+(define make-twobit-flag)
+(define display-twobit-flag)
+
+(define make-twobit-flag
+ (lambda (name)
+
+ (define (twobit-warning)
+ (display "Error: incorrect arguments to ")
+ (write name)
+ (newline)
+ (reset))
+
+ (define (display-flag state)
+ (display (if state " + " " - "))
+ (display name)
+ (display " is ")
+ (display (if state "on" "off"))
+ (newline))
+
+ (let ((state #t))
+ (lambda args
+ (cond ((null? args) state)
+ ((and (null? (cdr args))
+ (boolean? (car args)))
+ (set! state (car args))
+ state)
+ ((and (null? (cdr args))
+ (eq? (car args) 'display))
+ (display-flag state))
+ (else (twobit-warning)))))))
+
+(define (display-twobit-flag flag)
+ (flag 'display))
+
+; Debugging and convenience.
+
+(define issue-warnings
+ (make-twobit-flag 'issue-warnings))
+
+(define include-source-code
+ (make-twobit-flag 'include-source-code))
+
+(define include-variable-names
+ (make-twobit-flag 'include-variable-names))
+
+(define include-procedure-names
+ (make-twobit-flag 'include-procedure-names))
+
+; Space efficiency.
+; This switch isn't fully implemented yet. If it is true, then
+; Twobit will generate flat closures and will go to some trouble
+; to zero stale registers and stack slots.
+; Don't turn this switch off unless space is more important than speed.
+
+(define avoid-space-leaks
+ (make-twobit-flag 'avoid-space-leaks))
+
+; Major optimizations.
+
+(define integrate-usual-procedures
+ (make-twobit-flag 'integrate-usual-procedures))
+
+(define control-optimization
+ (make-twobit-flag 'control-optimization))
+
+(define parallel-assignment-optimization
+ (make-twobit-flag 'parallel-assignment-optimization))
+
+(define lambda-optimization
+ (make-twobit-flag 'lambda-optimization))
+
+(define benchmark-mode
+ (make-twobit-flag 'benchmark-mode))
+
+(define benchmark-block-mode
+ (make-twobit-flag 'benchmark-block-mode))
+
+(define global-optimization
+ (make-twobit-flag 'global-optimization))
+
+(define interprocedural-inlining
+ (make-twobit-flag 'interprocedural-inlining))
+
+(define interprocedural-constant-propagation
+ (make-twobit-flag 'interprocedural-constant-propagation))
+
+(define common-subexpression-elimination
+ (make-twobit-flag 'common-subexpression-elimination))
+
+(define representation-inference
+ (make-twobit-flag 'representation-inference))
+
+(define local-optimization
+ (make-twobit-flag 'local-optimization))
+
+; For backwards compatibility, until I can change the code.
+
+(define (ignore-space-leaks . args)
+ (if (null? args)
+ (not (avoid-space-leaks))
+ (avoid-space-leaks (not (car args)))))
+
+(define lambda-optimizations lambda-optimization)
+(define local-optimizations local-optimization)
+
+(define (set-compiler-flags! how)
+ (case how
+ ((no-optimization)
+ (set-compiler-flags! 'standard)
+ (avoid-space-leaks #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #f)
+ (parallel-assignment-optimization #f)
+ (lambda-optimization #f)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #f)
+ (interprocedural-inlining #f)
+ (interprocedural-constant-propagation #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f)
+ (local-optimization #f))
+ ((standard)
+ (issue-warnings #t)
+ (include-source-code #f)
+ (include-procedure-names #t)
+ (include-variable-names #t)
+ (avoid-space-leaks #f)
+ (runtime-safety-checking #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #t)
+ (parallel-assignment-optimization #t)
+ (lambda-optimization #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #t)
+ (interprocedural-inlining #t)
+ (interprocedural-constant-propagation #t)
+ (common-subexpression-elimination #t)
+ (representation-inference #t)
+ (local-optimization #t))
+ ((fast-safe)
+ (let ((bbmode (benchmark-block-mode)))
+ (set-compiler-flags! 'standard)
+ (integrate-usual-procedures #t)
+ (benchmark-mode #t)
+ (benchmark-block-mode bbmode)))
+ ((fast-unsafe)
+ (set-compiler-flags! 'fast-safe)
+ (runtime-safety-checking #f))
+ (else
+ (error "set-compiler-flags!: unknown mode " how))))
+
+(define (display-twobit-flags which)
+ (case which
+ ((debugging)
+ (display-twobit-flag issue-warnings)
+ (display-twobit-flag include-procedure-names)
+ (display-twobit-flag include-variable-names)
+ (display-twobit-flag include-source-code))
+ ((safety)
+ (display-twobit-flag avoid-space-leaks))
+ ((optimization)
+ (display-twobit-flag integrate-usual-procedures)
+ (display-twobit-flag control-optimization)
+ (display-twobit-flag parallel-assignment-optimization)
+ (display-twobit-flag lambda-optimization)
+ (display-twobit-flag benchmark-mode)
+ (display-twobit-flag benchmark-block-mode)
+ (display-twobit-flag global-optimization)
+ (if (global-optimization)
+ (begin (display " ")
+ (display-twobit-flag interprocedural-inlining)
+ (display " ")
+ (display-twobit-flag interprocedural-constant-propagation)
+ (display " ")
+ (display-twobit-flag common-subexpression-elimination)
+ (display " ")
+ (display-twobit-flag representation-inference)))
+ (display-twobit-flag local-optimization))
+ (else
+ ; The switch might mean something to the assembler, but not to Twobit
+ #t)))
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 14 April 1999 / wdc
+
+($$trace "pass1.aux")
+
+;***************************************************************
+;
+; Each definition in this section should be overridden by an assignment
+; in a target-specific file.
+;
+; If a lambda expression has more than @maxargs-with-rest-arg@ required
+; arguments followed by a rest argument, then the macro expander will
+; rewrite the lambda expression as a lambda expression with only one
+; argument (a rest argument) whose body is a LET that binds the arguments
+; of the original lambda expression.
+
+(define @maxargs-with-rest-arg@
+ 1000000) ; infinity
+
+(define (prim-entry name) #f) ; no integrable procedures
+(define (prim-arity name) 0) ; all of which take 0 arguments
+(define (prim-opcodename name) name) ; and go by their source names
+
+; End of definitions to be overridden by target-specific assignments.
+;
+;***************************************************************
+
+; Miscellaneous routines.
+
+(define (m-warn msg . more)
+ (if (issue-warnings)
+ (begin
+ (display "WARNING from macro expander:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more))))
+
+(define (m-error msg . more)
+ (display "ERROR detected during macro expansion:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+(define (m-bug msg . more)
+ (display "BUG in macro expander: ")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+; Given a <formals>, returns a list of bound variables.
+
+'
+(define (make-null-terminated x)
+ (cond ((null? x) '())
+ ((pair? x)
+ (cons (car x) (make-null-terminated (cdr x))))
+ (else (list x))))
+
+; Returns the length of the given list, or -1 if the argument
+; is not a list. Does not check for circular lists.
+
+(define (safe-length x)
+ (define (loop x n)
+ (cond ((null? x) n)
+ ((pair? x) (loop (cdr x) (+ n 1)))
+ (else -1)))
+ (loop x 0))
+
+; Given a unary predicate and a list, returns a list of those
+; elements for which the predicate is true.
+
+(define (filter1 p x)
+ (cond ((null? x) '())
+ ((p (car x)) (cons (car x) (filter1 p (cdr x))))
+ (else (filter1 p (cdr x)))))
+
+; Given a unary predicate and a list, returns #t if the
+; predicate is true of every element of the list.
+
+(define (every1? p x)
+ (cond ((null? x) #t)
+ ((p (car x)) (every1? p (cdr x)))
+ (else #f)))
+
+; Binary union of two sets represented as lists, using equal?.
+
+(define (union2 x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))
+
+; Given an association list, copies the association pairs.
+
+(define (copy-alist alist)
+ (map (lambda (x) (cons (car x) (cdr x)))
+ alist))
+
+; Removes a value from a list. May destroy the list.
+
+'
+(define remq!
+ (letrec ((loop (lambda (x y prev)
+ (cond ((null? y) #t)
+ ((eq? x (car y))
+ (set-cdr! prev (cdr y))
+ (loop x (cdr prev) prev))
+ (else
+ (loop x (cdr y) y))))))
+ (lambda (x y)
+ (cond ((null? y) '())
+ ((eq? x (car y))
+ (remq! x (cdr y)))
+ (else
+ (loop x (cdr y) y)
+ y)))))
+
+; Procedure-specific source code transformations.
+; The transformer is passed a source code expression and a predicate
+; and returns one of:
+;
+; the original source code expression
+; a new source code expression to use in place of the original
+; #f to indicate that the procedure is being called
+; with an incorrect number of arguments or
+; with an incorrect operand
+;
+; The original source code expression is guaranteed to be a list whose
+; car is the name associated with the transformer.
+; The predicate takes an identifier (a symbol) and returns true iff
+; that identifier is bound to something other than its global binding.
+;
+; Since the procedures and their transformations are target-specific,
+; they are defined in another file, in the Target subdirectory.
+
+; FIXME:
+; I think this is now used in only one place, in simplify-if.
+
+(define (integrable? name)
+ (and (integrate-usual-procedures)
+ (prim-entry name)))
+
+; MAKE-READABLE strips the referencing information
+; and replaces (begin I) by I.
+; If the optional argument is true, then it also reconstructs LET.
+
+(define (make-readable exp . rest)
+ (let ((fancy? (and (not (null? rest))
+ (car rest))))
+ (define (make-readable exp)
+ (case (car exp)
+ ((quote) (make-readable-quote exp))
+ ((lambda) `(lambda ,(lambda.args exp)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs exp))
+ ,(make-readable (lambda.body exp))))
+ ((set!) `(set! ,(assignment.lhs exp)
+ ,(make-readable (assignment.rhs exp))))
+ ((if) `(if ,(make-readable (if.test exp))
+ ,(make-readable (if.then exp))
+ ,(make-readable (if.else exp))))
+ ((begin) (if (variable? exp)
+ (variable.name exp)
+ `(begin ,@(map make-readable (begin.exprs exp)))))
+ (else (make-readable-call exp))))
+ (define (make-readable-quote exp)
+ (let ((x (constant.value exp)))
+ (if (and fancy?
+ (or (boolean? x)
+ (number? x)
+ (char? x)
+ (string? x)))
+ x
+ exp)))
+ (define (make-readable-call exp)
+ (let ((proc (call.proc exp)))
+ (if (and fancy?
+ (lambda? proc)
+ (list? (lambda.args proc)))
+ ;(make-readable-let* exp '() '() '())
+ (make-readable-let exp)
+ `(,(make-readable (call.proc exp))
+ ,@(map make-readable (call.args exp))))))
+ (define (make-readable-let exp)
+ (let* ((L (call.proc exp))
+ (formals (lambda.args L))
+ (args (map make-readable (call.args exp)))
+ (body (make-readable (lambda.body L))))
+ (if (and (null? (lambda.defs L))
+ (= (length args) 1)
+ (pair? body)
+ (or (and (eq? (car body) 'let)
+ (= (length (cadr body)) 1))
+ (eq? (car body) 'let*)))
+ `(let* ((,(car formals) ,(car args))
+ ,@(cadr body))
+ ,@(cddr body))
+ `(let ,(map list
+ (lambda.args L)
+ args)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs L))
+ ,body))))
+ (define (make-readable-let* exp vars inits defs)
+ (if (and (null? defs)
+ (call? exp)
+ (lambda? (call.proc exp))
+ (= 1 (length (lambda.args (call.proc exp)))))
+ (let ((proc (call.proc exp))
+ (arg (car (call.args exp))))
+ (if (and (call? arg)
+ (lambda? (call.proc arg))
+ (= 1 (length (lambda.args (call.proc arg))))
+ (null? (lambda.defs (call.proc arg))))
+ (make-readable-let*
+ (make-call proc (list (lambda.body (call.proc arg))))
+ (cons (car (lambda.args (call.proc arg))) vars)
+ (cons (make-readable (car (call.args arg))) inits)
+ '())
+ (make-readable-let* (lambda.body proc)
+ (cons (car (lambda.args proc)) vars)
+ (cons (make-readable (car (call.args exp)))
+ inits)
+ (map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (reverse (lambda.defs proc))))))
+ (cond ((or (not (null? vars))
+ (not (null? defs)))
+ `(let* ,(map list
+ (reverse vars)
+ (reverse inits))
+ ,@defs
+ ,(make-readable exp)))
+ ((and (call? exp)
+ (lambda? (call.proc exp)))
+ (let ((proc (call.proc exp)))
+ `(let ,(map list
+ (lambda.args proc)
+ (map make-readable (call.args exp)))
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs proc))
+ ,(make-readable (lambda.body proc)))))
+ (else
+ (make-readable exp)))))
+ (make-readable exp)))
+
+; For testing.
+
+; MAKE-UNREADABLE does the reverse.
+; It assumes there are no internal definitions.
+
+(define (make-unreadable exp)
+ (cond ((symbol? exp) (list 'begin exp))
+ ((pair? exp)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (list 'lambda
+ (cadr exp)
+ '(begin)
+ (list '() '() '() '())
+ (make-unreadable (cons 'begin (cddr exp)))))
+ ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
+ ((if) (list 'if
+ (make-unreadable (cadr exp))
+ (make-unreadable (caddr exp))
+ (if (= (length exp) 3)
+ '(unspecified)
+ (make-unreadable (cadddr exp)))))
+ ((begin) (if (= (length exp) 2)
+ (make-unreadable (cadr exp))
+ (cons 'begin (map make-unreadable (cdr exp)))))
+ (else (map make-unreadable exp))))
+ (else (list 'quote exp))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 12 April 1999.
+;
+; Procedures for fetching and clobbering parts of expressions.
+
+($$trace "pass2.aux")
+
+(define (constant? exp) (eq? (car exp) 'quote))
+(define (variable? exp)
+ (and (eq? (car exp) 'begin)
+ (null? (cddr exp))))
+(define (lambda? exp) (eq? (car exp) 'lambda))
+(define (call? exp) (pair? (car exp)))
+(define (assignment? exp) (eq? (car exp) 'set!))
+(define (conditional? exp) (eq? (car exp) 'if))
+(define (begin? exp)
+ (and (eq? (car exp) 'begin)
+ (not (null? (cddr exp)))))
+
+(define (make-constant value) (list 'quote value))
+(define (make-variable name) (list 'begin name))
+(define (make-lambda formals defs R F G decls doc body)
+ (list 'lambda
+ formals
+ (cons 'begin defs)
+ (list 'quote (list R F G decls doc))
+ body))
+(define (make-call proc args) (cons proc (append args '())))
+(define (make-assignment lhs rhs) (list 'set! lhs rhs))
+(define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
+(define (make-begin exprs)
+ (if (null? (cdr exprs))
+ (car exprs)
+ (cons 'begin (append exprs '()))))
+(define (make-definition lhs rhs) (list 'define lhs rhs))
+
+(define (constant.value exp) (cadr exp))
+(define (variable.name exp) (cadr exp))
+(define (lambda.args exp) (cadr exp))
+(define (lambda.defs exp) (cdr (caddr exp)))
+(define (lambda.R exp) (car (cadr (cadddr exp))))
+(define (lambda.F exp) (cadr (cadr (cadddr exp))))
+(define (lambda.G exp) (caddr (cadr (cadddr exp))))
+(define (lambda.decls exp) (cadddr (cadr (cadddr exp))))
+(define (lambda.doc exp) (car (cddddr (cadr (cadddr exp)))))
+(define (lambda.body exp) (car (cddddr exp)))
+(define (call.proc exp) (car exp))
+(define (call.args exp) (cdr exp))
+(define (assignment.lhs exp) (cadr exp))
+(define (assignment.rhs exp) (caddr exp))
+(define (if.test exp) (cadr exp))
+(define (if.then exp) (caddr exp))
+(define (if.else exp) (cadddr exp))
+(define (begin.exprs exp) (cdr exp))
+(define (def.lhs exp) (cadr exp))
+(define (def.rhs exp) (caddr exp))
+
+(define (variable-set! exp newexp)
+ (set-car! exp (car newexp))
+ (set-cdr! exp (append (cdr newexp) '())))
+(define (lambda.args-set! exp args) (set-car! (cdr exp) args))
+(define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
+(define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
+(define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
+(define (lambda.G-set! exp G) (set-car! (cddr (cadr (cadddr exp))) G))
+(define (lambda.decls-set! exp decls) (set-car! (cdddr (cadr (cadddr exp))) decls))
+(define (lambda.doc-set! exp doc) (set-car! (cddddr (cadr (cadddr exp))) doc))
+(define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
+(define (call.proc-set! exp exp0) (set-car! exp exp0))
+(define (call.args-set! exp exprs) (set-cdr! exp exprs))
+(define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
+(define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
+(define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))
+
+(define expression-set! variable-set!) ; used only by pass 3
+
+; FIXME: This duplicates information in Lib/procinfo.sch.
+
+(define (make-doc name arity formals source-code filename filepos)
+ (vector name source-code arity filename filepos formals))
+(define (doc.name d) (vector-ref d 0))
+(define (doc.code d) (vector-ref d 1))
+(define (doc.arity d) (vector-ref d 2))
+(define (doc.file d) (vector-ref d 3))
+(define (doc.filepos d) (vector-ref d 4))
+(define (doc.formals d) (vector-ref d 5))
+(define (doc.name-set! d x) (if d (vector-set! d 0 x)))
+(define (doc.code-set! d x) (if d (vector-set! d 1 x)))
+(define (doc.arity-set! d x) (if d (vector-set! d 2 x)))
+(define (doc.file-set! d x) (if d (vector-set! d 3 x)))
+(define (doc.filepos-set! d x) (if d (vector-set! d 4 x)))
+(define (doc.formals-set! d x) (if d (vector-set! d 5 x)))
+(define (doc-copy d) (list->vector (vector->list d)))
+
+(define (ignored? name) (eq? name name:IGNORED))
+
+; Fairly harmless bug: rest arguments aren't getting flagged.
+
+(define (flag-as-ignored name L)
+ (define (loop name formals)
+ (cond ((null? formals)
+ ;(pass2-error p2error:violation-of-invariant name formals)
+ #t)
+ ((symbol? formals) #t)
+ ((eq? name (car formals))
+ (set-car! formals name:IGNORED)
+ (if (not (local? (lambda.R L) name:IGNORED))
+ (lambda.R-set! L
+ (cons (make-R-entry name:IGNORED '() '() '())
+ (lambda.R L)))))
+ (else (loop name (cdr formals)))))
+ (loop name (lambda.args L)))
+
+(define (make-null-terminated formals)
+ (cond ((null? formals) '())
+ ((symbol? formals) (list formals))
+ (else (cons (car formals)
+ (make-null-terminated (cdr formals))))))
+
+(define (list-head x n)
+ (cond ((zero? n) '())
+ (else (cons (car x) (list-head (cdr x) (- n 1))))))
+
+(define (remq x y)
+ (cond ((null? y) '())
+ ((eq? x (car y)) (remq x (cdr y)))
+ (else (cons (car y) (remq x (cdr y))))))
+
+(define (make-call-to-LIST args)
+ (cond ((null? args) (make-constant '()))
+ ((null? (cdr args))
+ (make-call (make-variable name:CONS)
+ (list (car args) (make-constant '()))))
+ (else (make-call (make-variable name:LIST) args))))
+
+(define (pass2-error i . etc)
+ (apply cerror (cons (vector-ref pass2-error-messages i) etc)))
+
+(define pass2-error-messages
+ '#("System error: violation of an invariant in pass 2"
+ "Wrong number of arguments to known procedure"))
+
+(define p2error:violation-of-invariant 0)
+(define p2error:wna 1)
+
+; Procedures for fetching referencing information from R-tables.
+
+(define (make-R-entry name refs assigns calls)
+ (list name refs assigns calls))
+
+(define (R-entry.name x) (car x))
+(define (R-entry.references x) (cadr x))
+(define (R-entry.assignments x) (caddr x))
+(define (R-entry.calls x) (cadddr x))
+
+(define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
+(define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
+(define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))
+
+(define (local? R I)
+ (assq I R))
+
+(define (R-entry R I)
+ (assq I R))
+
+(define (R-lookup R I)
+ (or (assq I R)
+ (pass2-error p2error:violation-of-invariant R I)))
+
+(define (references R I)
+ (cadr (R-lookup R I)))
+
+(define (assignments R I)
+ (caddr (R-lookup R I)))
+
+(define (calls R I)
+ (cadddr (R-lookup R I)))
+
+(define (references-set! R I X)
+ (set-car! (cdr (R-lookup R I)) X))
+
+(define (assignments-set! R I X)
+ (set-car! (cddr (R-lookup R I)) X))
+
+(define (calls-set! R I X)
+ (set-car! (cdddr (R-lookup R I)) X))
+
+; A notepad is a vector of the form #(L0 (L1 ...) (L2 ...) (I ...)),
+; where the components are:
+; element 0: a parent lambda expression (or #f if there is no enclosing
+; parent, or we want to pretend that there isn't).
+; element 1: a list of lambda expressions that the parent lambda
+; expression encloses immediately.
+; element 2: a subset of that list that does not escape.
+; element 3: a list of free variables.
+
+(define (make-notepad L)
+ (vector L '() '() '()))
+
+(define (notepad.parent np) (vector-ref np 0))
+(define (notepad.lambdas np) (vector-ref np 1))
+(define (notepad.nonescaping np) (vector-ref np 2))
+(define (notepad.vars np) (vector-ref np 3))
+
+(define (notepad.lambdas-set! np x) (vector-set! np 1 x))
+(define (notepad.nonescaping-set! np x) (vector-set! np 2 x))
+(define (notepad.vars-set! np x) (vector-set! np 3 x))
+
+(define (notepad-lambda-add! np L)
+ (notepad.lambdas-set! np (cons L (notepad.lambdas np))))
+
+(define (notepad-nonescaping-add! np L)
+ (notepad.nonescaping-set! np (cons L (notepad.nonescaping np))))
+
+(define (notepad-var-add! np I)
+ (let ((vars (notepad.vars np)))
+ (if (not (memq I vars))
+ (notepad.vars-set! np (cons I vars)))))
+
+; Given a notepad, returns the list of variables that are closed
+; over by some nested lambda expression that escapes.
+
+(define (notepad-captured-variables np)
+ (let ((nonescaping (notepad.nonescaping np)))
+ (apply-union
+ (map (lambda (L)
+ (if (memq L nonescaping)
+ (lambda.G L)
+ (lambda.F L)))
+ (notepad.lambdas np)))))
+
+; Given a notepad, returns a list of free variables computed
+; as the union of the immediate free variables with the free
+; variables of nested lambda expressions.
+
+(define (notepad-free-variables np)
+ (do ((lambdas (notepad.lambdas np) (cdr lambdas))
+ (fv (notepad.vars np)
+ (let ((L (car lambdas)))
+ (union (difference (lambda.F L)
+ (make-null-terminated (lambda.args L)))
+ fv))))
+ ((null? lambdas) fv)))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 13 December 1998
+\f; Implementation-dependent parameters and preferences that determine
+; how identifiers are represented in the output of the macro expander.
+;
+; The basic problem is that there are no reserved words, so the
+; syntactic keywords of core Scheme that are used to express the
+; output need to be represented by data that cannot appear in the
+; input. This file defines those data.
+
+($$trace "prefs")
+
+; FIXME: The following definitions are currently ignored.
+
+; The following definitions assume that identifiers of mixed case
+; cannot appear in the input.
+
+(define begin1 (string->symbol "Begin"))
+(define define1 (string->symbol "Define"))
+(define quote1 (string->symbol "Quote"))
+(define lambda1 (string->symbol "Lambda"))
+(define if1 (string->symbol "If"))
+(define set!1 (string->symbol "Set!"))
+
+; The following defines an implementation-dependent expression
+; that evaluates to an undefined (not unspecified!) value, for
+; use in expanding the (define x) syntax.
+
+(define undefined1 (list (string->symbol "Undefined")))
+
+; End of FIXME.
+
+; A variable is renamed by suffixing a vertical bar followed by a unique
+; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
+; of an identifier, but presumably this is enforced by the reader and not
+; by the compiler. Any other character that cannot appear as part of an
+; identifier may be used instead of the vertical bar.
+
+(define renaming-prefix-character #\.)
+(define renaming-suffix-character #\|)
+
+(define renaming-prefix (string renaming-prefix-character))
+(define renaming-suffix (string renaming-suffix-character))
+
+; Patches for Twobit. Here temporarily.
+
+(define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+
+(define (make-undefined)
+ (make-call (make-variable 'undefined) '()))
+
+(define (make-unspecified)
+ (make-call (make-variable 'unspecified) '()))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 December 1998
+\f; Syntactic environments.
+;
+; A syntactic environment maps identifiers to denotations,
+; where a denotation is one of
+;
+; (special <special>)
+; (macro <rules> <env>)
+; (inline <rules> <env>)
+; (identifier <id> <references> <assignments> <calls>)
+;
+; and where <special> is one of
+;
+; quote
+; lambda
+; if
+; set!
+; begin
+; define
+; define-syntax
+; let-syntax
+; letrec-syntax
+; syntax-rules
+;
+; and where <rules> is a compiled <transformer spec> (see R4RS),
+; <env> is a syntactic environment, and <id> is an identifier.
+;
+; An inline denotation is like a macro denotation, except that it
+; is not an error when none of the rules match the use. Inline
+; denotations are created by DEFINE-INLINE.
+; The standard syntactic environment should not include any
+; identifier denotations; space leaks will result if it does.
+
+($$trace "syntaxenv")
+
+(define standard-syntactic-environment
+ `((quote . (special quote))
+ (lambda . (special lambda))
+ (if . (special if))
+ (set! . (special set!))
+ (begin . (special begin))
+ (define . (special define))
+ (define-inline . (special define-inline))
+ (define-syntax . (special define-syntax))
+ (let-syntax . (special let-syntax))
+ (letrec-syntax . (special letrec-syntax))
+ (syntax-rules . (special syntax-rules))
+ ))
+
+; Unforgeable synonyms for lambda and set!, used to expand definitions.
+
+(define lambda0 (string->symbol " lambda "))
+(define set!0 (string->symbol " set! "))
+
+(define (syntactic-copy env)
+ (copy-alist env))
+
+(define (make-basic-syntactic-environment)
+ (cons (cons lambda0
+ (cdr (assq 'lambda standard-syntactic-environment)))
+ (cons (cons set!0
+ (cdr (assq 'set! standard-syntactic-environment)))
+ (syntactic-copy standard-syntactic-environment))))
+
+; The global-syntactic-environment will always be a nonempty
+; association list since there is no way to remove the entry
+; for lambda0. That entry is used as a header by destructive
+; operations.
+
+(define global-syntactic-environment
+ (make-basic-syntactic-environment))
+
+(define (global-syntactic-environment-set! env)
+ (set-cdr! global-syntactic-environment env)
+ #t)
+
+(define (syntactic-bind-globally! id denotation)
+ (if (and (identifier-denotation? denotation)
+ (eq? id (identifier-name denotation)))
+ (letrec ((remove-bindings-for-id
+ (lambda (bindings)
+ (cond ((null? bindings) '())
+ ((eq? (caar bindings) id)
+ (remove-bindings-for-id (cdr bindings)))
+ (else (cons (car bindings)
+ (remove-bindings-for-id (cdr bindings))))))))
+ (global-syntactic-environment-set!
+ (remove-bindings-for-id (cdr global-syntactic-environment))))
+ (let ((x (assq id global-syntactic-environment)))
+ (if x
+ (begin (set-cdr! x denotation) #t)
+ (global-syntactic-environment-set!
+ (cons (cons id denotation)
+ (cdr global-syntactic-environment)))))))
+
+(define (syntactic-divert env1 env2)
+ (append env2 env1))
+
+(define (syntactic-extend env ids denotations)
+ (syntactic-divert env (map cons ids denotations)))
+
+(define (syntactic-lookup env id)
+ (let ((entry (assq id env)))
+ (if entry
+ (cdr entry)
+ (make-identifier-denotation id))))
+
+(define (syntactic-assign! env id denotation)
+ (let ((entry (assq id env)))
+ (if entry
+ (set-cdr! entry denotation)
+ (m-bug "Bug detected in syntactic-assign!" env id denotation))))
+
+; Denotations.
+
+(define denotation-class car)
+
+(define (special-denotation? denotation)
+ (eq? (denotation-class denotation) 'special))
+
+(define (macro-denotation? denotation)
+ (eq? (denotation-class denotation) 'macro))
+
+(define (inline-denotation? denotation)
+ (eq? (denotation-class denotation) 'inline))
+
+(define (identifier-denotation? denotation)
+ (eq? (denotation-class denotation) 'identifier))
+
+(define (make-macro-denotation rules env)
+ (list 'macro rules env))
+
+(define (make-inline-denotation id rules env)
+ (list 'inline rules env id))
+
+(define (make-identifier-denotation id)
+ (list 'identifier id '() '() '()))
+
+(define macro-rules cadr)
+(define macro-env caddr)
+
+(define inline-rules macro-rules)
+(define inline-env macro-env)
+(define inline-name cadddr)
+
+(define identifier-name cadr)
+(define identifier-R-entry cdr)
+
+(define (same-denotation? d1 d2)
+ (or (eq? d1 d2)
+ (and (identifier-denotation? d1)
+ (identifier-denotation? d2)
+ (eq? (identifier-name d1)
+ (identifier-name d2)))))
+
+(define denotation-of-quote
+ (syntactic-lookup standard-syntactic-environment 'quote))
+
+(define denotation-of-lambda
+ (syntactic-lookup standard-syntactic-environment 'lambda))
+
+(define denotation-of-if
+ (syntactic-lookup standard-syntactic-environment 'if))
+
+(define denotation-of-set!
+ (syntactic-lookup standard-syntactic-environment 'set!))
+
+(define denotation-of-begin
+ (syntactic-lookup standard-syntactic-environment 'begin))
+
+(define denotation-of-define
+ (syntactic-lookup standard-syntactic-environment 'define))
+
+(define denotation-of-define-inline
+ (syntactic-lookup standard-syntactic-environment 'define-inline))
+
+(define denotation-of-define-syntax
+ (syntactic-lookup standard-syntactic-environment 'define-syntax))
+
+(define denotation-of-let-syntax
+ (syntactic-lookup standard-syntactic-environment 'let-syntax))
+
+(define denotation-of-letrec-syntax
+ (syntactic-lookup standard-syntactic-environment 'letrec-syntax))
+
+(define denotation-of-syntax-rules
+ (syntactic-lookup standard-syntactic-environment 'syntax-rules))
+
+(define denotation-of-...
+ (syntactic-lookup standard-syntactic-environment '...))
+
+(define denotation-of-transformer
+ (syntactic-lookup standard-syntactic-environment 'transformer))
+
+; Given a syntactic environment env to be extended, an alist returned
+; by rename-vars, and a syntactic environment env2, extends env by
+; binding the fresh identifiers to the denotations of the original
+; identifiers in env2.
+
+(define (syntactic-alias env alist env2)
+ (syntactic-divert
+ env
+ (map (lambda (name-pair)
+ (let ((old-name (car name-pair))
+ (new-name (cdr name-pair)))
+ (cons new-name
+ (syntactic-lookup env2 old-name))))
+ alist)))
+
+; Given a syntactic environment and an alist returned by rename-vars,
+; extends the environment by binding the old identifiers to the fresh
+; identifiers.
+; For Twobit, it also binds the fresh identifiers to their denotations.
+; This is ok so long as the fresh identifiers are not legal Scheme
+; identifiers.
+
+(define (syntactic-rename env alist)
+ (if (null? alist)
+ env
+ (let* ((old (caar alist))
+ (new (cdar alist))
+ (denotation (make-identifier-denotation new)))
+ (syntactic-rename
+ (cons (cons old denotation)
+ (cons (cons new denotation)
+ env))
+ (cdr alist)))))
+
+; Renaming of variables.
+
+(define renaming-counter 0)
+
+(define (make-rename-procedure)
+ (set! renaming-counter (+ renaming-counter 1))
+ (let ((suffix (string-append renaming-suffix (number->string renaming-counter))))
+ (lambda (sym)
+ (if (symbol? sym)
+ (let ((s (symbol->string sym)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (string->symbol (string-append s suffix))
+ (string->symbol (string-append renaming-prefix s suffix))))
+ (m-warn "Illegal use of rename procedure" 'ok:FIXME sym)))))
+
+; Given a datum, strips the suffixes from any symbols that appear within
+; the datum, trying not to copy any more of the datum than necessary.
+
+(define (m-strip x)
+ (define (original-symbol x)
+ (define (loop sym s i n)
+ (cond ((= i n) sym)
+ ((char=? (string-ref s i)
+ renaming-suffix-character)
+ (string->symbol (substring s 1 i)))
+ (else
+ (loop sym s (+ i 1) n))))
+ (let ((s (symbol->string x)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (loop x s 0 (string-length s))
+ x)))
+ (cond ((symbol? x)
+ (original-symbol x))
+ ((pair? x)
+ (let ((a (m-strip (car x)))
+ (b (m-strip (cdr x))))
+ (if (and (eq? a (car x))
+ (eq? b (cdr x)))
+ x
+ (cons a b))))
+ ((vector? x)
+ (let* ((v (vector->list x))
+ (v2 (map m-strip v)))
+ (if (equal? v v2)
+ x
+ (list->vector v2))))
+ (else x)))
+
+; Given a list of identifiers, or a formal parameter "list",
+; returns an alist that associates each identifier with a fresh identifier.
+
+(define (rename-vars original-vars)
+ (let ((rename (make-rename-procedure)))
+ (define (loop vars newvars)
+ (cond ((null? vars) (reverse newvars))
+ ((pair? vars)
+ (let ((var (car vars)))
+ (if (symbol? var)
+ (loop (cdr vars)
+ (cons (cons var (rename var))
+ newvars))
+ (m-error "Illegal variable" var))))
+ ((symbol? vars)
+ (loop (list vars) newvars))
+ (else (m-error "Malformed parameter list" original-vars))))
+ (loop original-vars '())))
+
+; Given a <formals> and an alist returned by rename-vars that contains
+; a new name for each formal identifier in <formals>, renames the
+; formal identifiers.
+
+(define (rename-formals formals alist)
+ (cond ((null? formals) '())
+ ((pair? formals)
+ (cons (cdr (assq (car formals) alist))
+ (rename-formals (cdr formals) alist)))
+ (else (cdr (assq formals alist)))))
+; Copyright 1992 William Clinger
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful purpose, and to redistribute this software
+; is granted subject to the restriction that all copies made of this
+; software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 23 November 1998
+\f; Compiler for a <transformer spec>.
+;
+; References:
+;
+; The Revised^4 Report on the Algorithmic Language Scheme.
+; Clinger and Rees [editors]. To appear in Lisp Pointers.
+; Also available as a technical report from U of Oregon,
+; MIT AI Lab, and Cornell.
+;
+; Macros That Work. Clinger and Rees. POPL '91.
+;
+; The input is a <transformer spec> and a syntactic environment.
+; Syntactic environments are described in another file.
+;
+; The supported syntax differs from the R4RS in that vectors are
+; allowed as patterns and as templates and are not allowed as
+; pattern or template data.
+;
+; <transformer spec> --> (syntax-rules <literals> <rules>)
+; <rules> --> () | (<rule> . <rules>)
+; <rule> --> (<pattern> <template>)
+; <pattern> --> <pattern_var> ; a <symbol> not in <literals>
+; | <symbol> ; a <symbol> in <literals>
+; | ()
+; | (<pattern> . <pattern>)
+; | (<ellipsis_pattern>)
+; | #(<pattern>*) ; extends R4RS
+; | #(<pattern>* <ellipsis_pattern>) ; extends R4RS
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<template>*) ; extends R4RS
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string> ; no <vector>
+; | <character>
+; | <boolean>
+; | <number>
+; <ellipsis_pattern> --> <pattern> ...
+; <ellipsis_template> --> <template> ...
+; <pattern_var> --> <symbol> ; not in <literals>
+; <literals> --> () | (<symbol> . <literals>)
+;
+; Definitions.
+;
+; scope of an ellipsis
+;
+; Within a pattern or template, the scope of an ellipsis
+; (...) is the pattern or template that appears to its left.
+;
+; rank of a pattern variable
+;
+; The rank of a pattern variable is the number of ellipses
+; within whose scope it appears in the pattern.
+;
+; rank of a subtemplate
+;
+; The rank of a subtemplate is the number of ellipses within
+; whose scope it appears in the template.
+;
+; template rank of an occurrence of a pattern variable
+;
+; The template rank of an occurrence of a pattern variable
+; within a template is the rank of that occurrence, viewed
+; as a subtemplate.
+;
+; variables bound by a pattern
+;
+; The variables bound by a pattern are the pattern variables
+; that appear within it.
+;
+; referenced variables of a subtemplate
+;
+; The referenced variables of a subtemplate are the pattern
+; variables that appear within it.
+;
+; variables opened by an ellipsis template
+;
+; The variables opened by an ellipsis template are the
+; referenced pattern variables whose rank is greater than
+; the rank of the ellipsis template.
+;
+;
+; Restrictions.
+;
+; No pattern variable appears more than once within a pattern.
+;
+; For every occurrence of a pattern variable within a template,
+; the template rank of the occurrence must be greater than or
+; equal to the pattern variable's rank.
+;
+; Every ellipsis template must open at least one variable.
+;
+; For every ellipsis template, the variables opened by an
+; ellipsis template must all be bound to sequences of the
+; same length.
+;
+;
+; The compiled form of a <rule> is
+;
+; <rule> --> (<pattern> <template> <inserted>)
+; <pattern> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<pattern> . <pattern>)
+; | <ellipsis_pattern>
+; | #(<pattern>)
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<pattern>)
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string>
+; | <character>
+; | <boolean>
+; | <number>
+; <pattern_var> --> #(<V> <symbol> <rank>)
+; <ellipsis_pattern> --> #(<E> <pattern> <pattern_vars>)
+; <ellipsis_template> --> #(<E> <template> <pattern_vars>)
+; <inserted> --> () | (<symbol> . <inserted>)
+; <pattern_vars> --> () | (<pattern_var> . <pattern_vars>)
+; <rank> --> <exact non-negative integer>
+;
+; where <V> and <E> are unforgeable values.
+; The pattern variables associated with an ellipsis pattern
+; are the variables bound by the pattern, and the pattern
+; variables associated with an ellipsis template are the
+; variables opened by the ellipsis template.
+;
+;
+; What's wrong with the above?
+; If the template contains a big chunk that contains no pattern variables
+; or inserted identifiers, then the big chunk will be copied unnecessarily.
+; That shouldn't matter very often.
+
+($$trace "syntaxrules")
+
+(define pattern-variable-flag (list 'v))
+(define ellipsis-pattern-flag (list 'e))
+(define ellipsis-template-flag ellipsis-pattern-flag)
+
+(define (make-patternvar v rank)
+ (vector pattern-variable-flag v rank))
+(define (make-ellipsis-pattern P vars)
+ (vector ellipsis-pattern-flag P vars))
+(define (make-ellipsis-template T vars)
+ (vector ellipsis-template-flag T vars))
+
+(define (patternvar? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) pattern-variable-flag)))
+
+(define (ellipsis-pattern? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-pattern-flag)))
+
+(define (ellipsis-template? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-template-flag)))
+
+(define (patternvar-name V) (vector-ref V 1))
+(define (patternvar-rank V) (vector-ref V 2))
+(define (ellipsis-pattern P) (vector-ref P 1))
+(define (ellipsis-pattern-vars P) (vector-ref P 2))
+(define (ellipsis-template T) (vector-ref T 1))
+(define (ellipsis-template-vars T) (vector-ref T 2))
+
+(define (pattern-variable v vars)
+ (cond ((null? vars) #f)
+ ((eq? v (patternvar-name (car vars)))
+ (car vars))
+ (else (pattern-variable v (cdr vars)))))
+
+; Given a <transformer spec> and a syntactic environment,
+; returns a macro denotation.
+;
+; A macro denotation is of the form
+;
+; (macro (<rule> ...) env)
+;
+; where each <rule> has been compiled as described above.
+
+(define (m-compile-transformer-spec spec env)
+ (if (and (> (safe-length spec) 1)
+ (eq? (syntactic-lookup env (car spec))
+ denotation-of-syntax-rules))
+ (let ((literals (cadr spec))
+ (rules (cddr spec)))
+ (if (or (not (list? literals))
+ (not (every1? (lambda (rule)
+ (and (= (safe-length rule) 2)
+ (pair? (car rule))))
+ rules)))
+ (m-error "Malformed syntax-rules" spec))
+ (list 'macro
+ (map (lambda (rule)
+ (m-compile-rule rule literals env))
+ rules)
+ env))
+ (m-error "Malformed syntax-rules" spec)))
+
+(define (m-compile-rule rule literals env)
+ (m-compile-pattern (cdr (car rule))
+ literals
+ env
+ (lambda (compiled-rule patternvars)
+ ; FIXME
+ ; should check uniqueness of pattern variables here
+ (cons compiled-rule
+ (m-compile-template
+ (cadr rule)
+ patternvars
+ env)))))
+
+(define (m-compile-pattern P literals env k)
+ (define (loop P vars rank k)
+ (cond ((symbol? P)
+ (if (memq P literals)
+ (k P vars)
+ (let ((var (make-patternvar P rank)))
+ (k var (cons var vars)))))
+ ((null? P) (k '() vars))
+ ((pair? P)
+ (if (and (pair? (cdr P))
+ (symbol? (cadr P))
+ (same-denotation? (syntactic-lookup env (cadr P))
+ denotation-of-...))
+ (if (null? (cddr P))
+ (loop (car P)
+ '()
+ (+ rank 1)
+ (lambda (P vars1)
+ (k (make-ellipsis-pattern P vars1)
+ (union2 vars1 vars))))
+ (m-error "Malformed pattern" P))
+ (loop (car P)
+ vars
+ rank
+ (lambda (P1 vars)
+ (loop (cdr P)
+ vars
+ rank
+ (lambda (P2 vars)
+ (k (cons P1 P2) vars)))))))
+ ((vector? P)
+ (loop (vector->list P)
+ vars
+ rank
+ (lambda (P vars)
+ (k (vector P) vars))))
+ (else (k P vars))))
+ (loop P '() 0 k))
+
+(define (m-compile-template T vars env)
+
+ (define (loop T inserted referenced rank escaped? k)
+ (cond ((symbol? T)
+ (let ((x (pattern-variable T vars)))
+ (if x
+ (if (>= rank (patternvar-rank x))
+ (k x inserted (cons x referenced))
+ (m-error
+ "Too few ellipses follow pattern variable in template"
+ (patternvar-name x)))
+ (k T (cons T inserted) referenced))))
+ ((null? T) (k '() inserted referenced))
+ ((pair? T)
+ (cond ((and (not escaped?)
+ (symbol? (car T))
+ (same-denotation? (syntactic-lookup env (car T))
+ denotation-of-...)
+ (pair? (cdr T))
+ (null? (cddr T)))
+ (loop (cadr T) inserted referenced rank #t k))
+ ((and (not escaped?)
+ (pair? (cdr T))
+ (symbol? (cadr T))
+ (same-denotation? (syntactic-lookup env (cadr T))
+ denotation-of-...))
+ (loop1 T inserted referenced rank escaped? k))
+ (else
+ (loop (car T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T1 inserted referenced)
+ (loop (cdr T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons T1 T2) inserted referenced))))))))
+ ((vector? T)
+ (loop (vector->list T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T inserted referenced)
+ (k (vector T) inserted referenced))))
+ (else (k T inserted referenced))))
+
+ (define (loop1 T inserted referenced rank escaped? k)
+ (loop (car T)
+ inserted
+ '()
+ (+ rank 1)
+ escaped?
+ (lambda (T1 inserted referenced1)
+ (loop (cddr T)
+ inserted
+ (append referenced1 referenced)
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons (make-ellipsis-template
+ T1
+ (filter1 (lambda (var)
+ (> (patternvar-rank var)
+ rank))
+ referenced1))
+ T2)
+ inserted
+ referenced))))))
+
+ (loop T
+ '()
+ '()
+ 0
+ #f
+ (lambda (T inserted referenced)
+ (list T inserted))))
+
+; The pattern matcher.
+;
+; Given an input, a pattern, and two syntactic environments,
+; returns a pattern variable environment (represented as an alist)
+; if the input matches the pattern, otherwise returns #f.
+
+(define empty-pattern-variable-environment
+ (list (make-patternvar (string->symbol "") 0)))
+
+(define (m-match F P env-def env-use)
+
+ (define (match F P answer rank)
+ (cond ((null? P)
+ (and (null? F) answer))
+ ((pair? P)
+ (and (pair? F)
+ (let ((answer (match (car F) (car P) answer rank)))
+ (and answer (match (cdr F) (cdr P) answer rank)))))
+ ((symbol? P)
+ (and (symbol? F)
+ (same-denotation? (syntactic-lookup env-def P)
+ (syntactic-lookup env-use F))
+ answer))
+ ((patternvar? P)
+ (cons (cons P F) answer))
+ ((ellipsis-pattern? P)
+ (match1 F P answer (+ rank 1)))
+ ((vector? P)
+ (and (vector? F)
+ (match (vector->list F) (vector-ref P 0) answer rank)))
+ (else (and (equal? F P) answer))))
+
+ (define (match1 F P answer rank)
+ (cond ((not (list? F)) #f)
+ ((null? F)
+ (append (map (lambda (var) (cons var '()))
+ (ellipsis-pattern-vars P))
+ answer))
+ (else
+ (let* ((P1 (ellipsis-pattern P))
+ (answers (map (lambda (F) (match F P1 answer rank))
+ F)))
+ (if (every1? (lambda (answer) answer) answers)
+ (append (map (lambda (var)
+ (cons var
+ (map (lambda (answer)
+ (cdr (assq var answer)))
+ answers)))
+ (ellipsis-pattern-vars P))
+ answer)
+ #f)))))
+
+ (match F P empty-pattern-variable-environment 0))
+
+(define (m-rewrite T alist)
+
+ (define (rewrite T alist rank)
+ (cond ((null? T) '())
+ ((pair? T)
+ ((if (ellipsis-pattern? (car T))
+ append
+ cons)
+ (rewrite (car T) alist rank)
+ (rewrite (cdr T) alist rank)))
+ ((symbol? T) (cdr (assq T alist)))
+ ((patternvar? T) (cdr (assq T alist)))
+ ((ellipsis-template? T)
+ (rewrite1 T alist (+ rank 1)))
+ ((vector? T)
+ (list->vector (rewrite (vector-ref T 0) alist rank)))
+ (else T)))
+
+ (define (rewrite1 T alist rank)
+ (let* ((T1 (ellipsis-template T))
+ (vars (ellipsis-template-vars T))
+ (rows (map (lambda (var) (cdr (assq var alist)))
+ vars)))
+ (map (lambda (alist) (rewrite T1 alist rank))
+ (make-columns vars rows alist))))
+
+ (define (make-columns vars rows alist)
+ (define (loop rows)
+ (if (null? (car rows))
+ '()
+ (cons (append (map (lambda (var row)
+ (cons var (car row)))
+ vars
+ rows)
+ alist)
+ (loop (map cdr rows)))))
+ (if (or (null? (cdr rows))
+ (apply = (map length rows)))
+ (loop rows)
+ (m-error "Use of macro is not consistent with definition"
+ vars
+ rows)))
+
+ (rewrite T alist 0))
+
+; Given a use of a macro, the syntactic environment of the use,
+; a continuation that expects a transcribed expression and
+; a new environment in which to continue expansion, and a boolean
+; that is true if this transcription is for an inline procedure,
+; does the right thing.
+
+(define (m-transcribe0 exp env-use k inline?)
+ (let* ((m (syntactic-lookup env-use (car exp)))
+ (rules (macro-rules m))
+ (env-def (macro-env m))
+ (F (cdr exp)))
+ (define (loop rules)
+ (if (null? rules)
+ (if inline?
+ (k exp env-use)
+ (m-error "Use of macro does not match definition" exp))
+ (let* ((rule (car rules))
+ (pattern (car rule))
+ (alist (m-match F pattern env-def env-use)))
+ (if alist
+ (let* ((template (cadr rule))
+ (inserted (caddr rule))
+ (alist2 (rename-vars inserted))
+ (newexp (m-rewrite template (append alist2 alist))))
+ (k newexp
+ (syntactic-alias env-use alist2 env-def)))
+ (loop (cdr rules))))))
+ (if (procedure? rules)
+ (m-transcribe-low-level exp env-use k rules env-def)
+ (loop rules))))
+
+(define (m-transcribe exp env-use k)
+ (m-transcribe0 exp env-use k #f))
+
+(define (m-transcribe-inline exp env-use k)
+ (m-transcribe0 exp env-use k #t))
+
+; Copyright 1998 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Low-level macro facility based on explicit renaming. See
+; William D Clinger. Hygienic macros through explicit renaming.
+; In Lisp Pointers IV(4), 25-28, December 1991.
+
+($$trace "lowlevel")
+
+(define (m-transcribe-low-level exp env-use k transformer env-def)
+ (let ((rename0 (make-rename-procedure))
+ (renamed '())
+ (ok #t))
+ (define (lookup sym)
+ (let loop ((alist renamed))
+ (cond ((null? alist)
+ (syntactic-lookup env-use sym))
+ ((eq? sym (cdr (car alist)))
+ (syntactic-lookup env-def (car (car alist))))
+ (else
+ (loop (cdr alist))))))
+ (let ((rename
+ (lambda (sym)
+ (if ok
+ (let ((probe (assq sym renamed)))
+ (if probe
+ (cdr probe)
+ (let ((sym2 (rename0 sym)))
+ (set! renamed (cons (cons sym sym2) renamed))
+ sym2)))
+ (m-error "Illegal use of a rename procedure" sym))))
+ (compare
+ (lambda (sym1 sym2)
+ (same-denotation? (lookup sym1) (lookup sym2)))))
+ (let ((exp2 (transformer exp rename compare)))
+ (set! ok #f)
+ (k exp2
+ (syntactic-alias env-use renamed env-def))))))
+
+(define identifier? symbol?)
+
+(define (identifier->symbol id)
+ (m-strip id))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 22 April 1999
+
+($$trace "expand")
+
+; This procedure sets the default scope of global macro definitions.
+
+(define define-syntax-scope
+ (let ((flag 'letrec))
+ (lambda args
+ (cond ((null? args) flag)
+ ((not (null? (cdr args)))
+ (apply m-warn
+ "Too many arguments passed to define-syntax-scope"
+ args))
+ ((memq (car args) '(letrec letrec* let*))
+ (set! flag (car args)))
+ (else (m-warn "Unrecognized argument to define-syntax-scope"
+ (car args)))))))
+
+; The main entry point.
+; The outermost lambda allows known procedures to be lifted outside
+; all local variables.
+
+(define (macro-expand def-or-exp)
+ (call-with-current-continuation
+ (lambda (k)
+ (set! m-quit k)
+ (set! renaming-counter 0)
+ (make-call
+ (make-lambda '() ; formals
+ '() ; definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; declarations
+ #f ; documentation
+ (desugar-definitions def-or-exp
+ global-syntactic-environment
+ make-toplevel-definition))
+ '()))))
+
+(define (desugar-definitions exp env make-toplevel-definition)
+ (letrec
+
+ ((define-loop
+ (lambda (exp rest first env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-loop (cadr exp) (append (cddr exp) rest) first env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (let ((exp (desugar-define exp env)))
+ (cond ((and (null? first) (null? rest))
+ exp)
+ ((null? rest)
+ (make-begin (reverse (cons exp first))))
+ (else (define-loop (car rest)
+ (cdr rest)
+ (cons exp first)
+ env)))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (or (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax)
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (null? first))
+ (define-syntax-loop exp rest env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-loop exp rest first env))))
+ ((and (null? first) (null? rest))
+ (m-expand exp env))
+ ((null? rest)
+ (make-begin (reverse (cons (m-expand exp env) first))))
+ (else (make-begin
+ (append (reverse first)
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest))))))))
+
+ (define-syntax-loop
+ (lambda (exp rest env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-syntax-loop (cadr exp) (append (cddr exp) rest) env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-syntax exp env)
+ (begin (m-define-syntax exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-inline exp env)
+ (begin (m-define-inline exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-syntax-loop exp rest env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (define-loop exp rest '() env))
+ ((null? rest)
+ (m-expand exp env))
+ (else (make-begin
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest)))))))
+
+ (desugar-define
+ (lambda (exp env)
+ (cond
+ ((null? (cdr exp)) (m-error "Malformed definition" exp))
+ ; (define foo) syntax is transformed into (define foo (undefined)).
+ ((null? (cddr exp))
+ (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (make-undefined))))
+ ((pair? (cadr exp))
+ (desugar-define
+ (let* ((def (car exp))
+ (pattern (cadr exp))
+ (f (car pattern))
+ (args (cdr pattern))
+ (body (cddr exp)))
+ (if (and (symbol? (car (cadr exp)))
+ (benchmark-mode)
+ (list? (cadr exp)))
+ `(,def ,f
+ (,lambda0 ,args
+ ((,lambda0 (,f)
+ (,set!0 ,f (,lambda0 ,args ,@body))
+ ,pattern)
+ 0)))
+ `(,def ,f (,lambda0 ,args ,@body))))
+ env))
+ ((> (length exp) 3) (m-error "Malformed definition" exp))
+ (else (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (m-expand (caddr exp) env)))))))
+
+ (redefinition
+ (lambda (id)
+ (if (symbol? id)
+ (if (not (identifier-denotation?
+ (syntactic-lookup global-syntactic-environment id)))
+ (if (issue-warnings)
+ (m-warn "Redefining " id)))
+ (m-error "Malformed variable or keyword" id)))))
+
+ ; body of letrec
+
+ (define-loop exp '() '() env)))
+
+; Given an expression and a syntactic environment,
+; returns an expression in core Scheme.
+
+(define (m-expand exp env)
+ (cond ((not (pair? exp))
+ (m-atom exp env))
+ ((not (symbol? (car exp)))
+ (m-application exp env))
+ (else
+ (let ((keyword (syntactic-lookup env (car exp))))
+ (case (denotation-class keyword)
+ ((special)
+ (cond
+ ((eq? keyword denotation-of-quote) (m-quote exp))
+ ((eq? keyword denotation-of-lambda) (m-lambda exp env))
+ ((eq? keyword denotation-of-if) (m-if exp env))
+ ((eq? keyword denotation-of-set!) (m-set exp env))
+ ((eq? keyword denotation-of-begin) (m-begin exp env))
+ ((eq? keyword denotation-of-let-syntax)
+ (m-let-syntax exp env))
+ ((eq? keyword denotation-of-letrec-syntax)
+ (m-letrec-syntax exp env))
+ ((or (eq? keyword denotation-of-define)
+ (eq? keyword denotation-of-define-syntax)
+ (eq? keyword denotation-of-define-inline))
+ (m-error "Definition out of context" exp))
+ (else (m-bug "Bug detected in m-expand" exp env))))
+ ((macro) (m-macro exp env))
+ ((inline) (m-inline exp env))
+ ((identifier) (m-application exp env))
+ (else (m-bug "Bug detected in m-expand" exp env)))))))
+
+(define (m-atom exp env)
+ (cond ((not (symbol? exp))
+ ; Here exp ought to be a boolean, number, character, or string.
+ ; I'll warn about other things but treat them as if quoted.
+ ;
+ ; I'm turning off some of the warnings because notably procedures
+ ; and #!unspecified can occur in loaded files and it's a major
+ ; pain if a warning is printed for each. --lars
+ (if (and (not (boolean? exp))
+ (not (number? exp))
+ (not (char? exp))
+ (not (string? exp))
+ (not (procedure? exp))
+ (not (eq? exp (unspecified))))
+ (m-warn "Malformed constant -- should be quoted" exp))
+ (make-constant exp))
+ (else (let ((denotation (syntactic-lookup env exp)))
+ (case (denotation-class denotation)
+ ((special macro)
+ (m-warn "Syntactic keyword used as a variable" exp)
+ ; Syntactic keywords used as variables are treated as #t.
+ (make-constant #t))
+ ((inline)
+ (make-variable (inline-name denotation)))
+ ((identifier)
+ (let ((var (make-variable (identifier-name denotation)))
+ (R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (cons var (R-entry.references R-entry)))
+ var))
+ (else (m-bug "Bug detected by m-atom" exp env)))))))
+
+(define (m-quote exp)
+ (if (and (pair? (cdr exp))
+ (null? (cddr exp)))
+ (make-constant (m-strip (cadr exp)))
+ (m-error "Malformed quoted constant" exp)))
+
+(define (m-lambda exp env)
+ (if (> (safe-length exp) 2)
+
+ (let* ((formals (cadr exp))
+ (alist (rename-vars formals))
+ (env (syntactic-rename env alist))
+ (body (cddr exp)))
+
+ (do ((alist alist (cdr alist)))
+ ((null? alist))
+ (if (assq (caar alist) (cdr alist))
+ (m-error "Malformed parameter list" formals)))
+
+ ; To simplify the run-time system, there's a limit on how many
+ ; fixed arguments can be followed by a rest argument.
+ ; That limit is removed here.
+ ; Bug: documentation slot isn't right when this happens.
+ ; Bug: this generates extremely inefficient code.
+
+ (if (and (not (list? formals))
+ (> (length alist) @maxargs-with-rest-arg@))
+ (let ((TEMP (car (rename-vars '(temp)))))
+ (m-lambda
+ `(,lambda0 ,TEMP
+ ((,lambda0 ,(map car alist)
+ ,@(cddr exp))
+ ,@(do ((actuals '() (cons (list name:CAR path)
+ actuals))
+ (path TEMP (list name:CDR path))
+ (formals formals (cdr formals)))
+ ((symbol? formals)
+ (append (reverse actuals) (list path))))))
+ env))
+ (make-lambda (rename-formals formals alist)
+ '() ; no definitions yet
+ (map (lambda (entry)
+ (cdr (syntactic-lookup env (cdr entry))))
+ alist) ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (make-doc #f
+ (if (list? formals)
+ (length alist)
+ (exact->inexact (- (length alist) 1)))
+ (if (include-variable-names)
+ formals
+ #f)
+ (if (include-source-code)
+ exp
+ #f)
+ source-file-name
+ source-file-position)
+ (m-body body env))))
+
+ (m-error "Malformed lambda expression" exp)))
+
+(define (m-body body env)
+ (define (loop body env defs)
+ (if (null? body)
+ (m-error "Empty body"))
+ (let ((exp (car body)))
+ (if (and (pair? exp)
+ (symbol? (car exp)))
+ (let ((denotation (syntactic-lookup env (car exp))))
+ (case (denotation-class denotation)
+ ((special)
+ (cond ((eq? denotation denotation-of-begin)
+ (loop (append (cdr exp) (cdr body)) env defs))
+ ((eq? denotation denotation-of-define)
+ (loop (cdr body) env (cons exp defs)))
+ (else (finalize-body body env defs))))
+ ((macro)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (loop (cons exp (cdr body))
+ env
+ defs))))
+ ((inline identifier)
+ (finalize-body body env defs))
+ (else (m-bug "Bug detected in m-body" body env))))
+ (finalize-body body env defs))))
+ (loop body env '()))
+
+(define (finalize-body body env defs)
+ (if (null? defs)
+ (let ((body (map (lambda (exp) (m-expand exp env))
+ body)))
+ (if (null? (cdr body))
+ (car body)
+ (make-begin body)))
+ (let ()
+ (define (sort-defs defs)
+ (let* ((augmented
+ (map (lambda (def)
+ (let ((rhs (cadr def)))
+ (if (not (pair? rhs))
+ (cons 'trivial def)
+ (let ((denotation
+ (syntactic-lookup env (car rhs))))
+ (cond ((eq? denotation
+ denotation-of-lambda)
+ (cons 'procedure def))
+ ((eq? denotation
+ denotation-of-quote)
+ (cons 'trivial def))
+ (else
+ (cons 'miscellaneous def)))))))
+ defs))
+ (sorted (twobit-sort (lambda (x y)
+ (or (eq? (car x) 'procedure)
+ (eq? (car y) 'miscellaneous)))
+ augmented)))
+ (map cdr sorted)))
+ (define (desugar-definition def)
+ (if (> (safe-length def) 2)
+ (cond ((pair? (cadr def))
+ (desugar-definition
+ `(,(car def)
+ ,(car (cadr def))
+ (,lambda0
+ ,(cdr (cadr def))
+ ,@(cddr def)))))
+ ((and (= (length def) 3)
+ (symbol? (cadr def)))
+ (cdr def))
+ (else (m-error "Malformed definition" def)))
+ (m-error "Malformed definition" def)))
+ (define (expand-letrec bindings body)
+ (make-call
+ (m-expand
+ `(,lambda0 ,(map car bindings)
+ ,@(map (lambda (binding)
+ `(,set!0 ,(car binding)
+ ,(cadr binding)))
+ bindings)
+ ,@body)
+ env)
+ (map (lambda (binding) (make-unspecified)) bindings)))
+ (expand-letrec (sort-defs (map desugar-definition
+ (reverse defs)))
+ body))))
+
+(define (m-if exp env)
+ (let ((n (safe-length exp)))
+ (if (or (= n 3) (= n 4))
+ (make-conditional (m-expand (cadr exp) env)
+ (m-expand (caddr exp) env)
+ (if (= n 3)
+ (make-unspecified)
+ (m-expand (cadddr exp) env)))
+ (m-error "Malformed if expression" exp))))
+
+(define (m-set exp env)
+ (if (= (safe-length exp) 3)
+ (let ((lhs (m-expand (cadr exp) env))
+ (rhs (m-expand (caddr exp) env)))
+ (if (variable? lhs)
+ (let* ((x (variable.name lhs))
+ (assignment (make-assignment x rhs))
+ (denotation (syntactic-lookup env x)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (remq lhs (R-entry.references R-entry)))
+ (R-entry.assignments-set!
+ R-entry
+ (cons assignment (R-entry.assignments R-entry)))))
+ (if (and (lambda? rhs)
+ (include-procedure-names))
+ (let ((doc (lambda.doc rhs)))
+ (doc.name-set! doc x)))
+ (if pass1-block-compiling?
+ (set! pass1-block-assignments
+ (cons x pass1-block-assignments)))
+ assignment)
+ (m-error "Malformed assignment" exp)))
+ (m-error "Malformed assignment" exp)))
+
+(define (m-begin exp env)
+ (cond ((> (safe-length exp) 1)
+ (make-begin (map (lambda (exp) (m-expand exp env)) (cdr exp))))
+ ((= (safe-length exp) 1)
+ (m-warn "Non-standard begin expression" exp)
+ (make-unspecified))
+ (else
+ (m-error "Malformed begin expression" exp))))
+
+(define (m-application exp env)
+ (if (> (safe-length exp) 0)
+ (let* ((proc (m-expand (car exp) env))
+ (args (map (lambda (exp) (m-expand exp env))
+ (cdr exp)))
+ (call (make-call proc args)))
+ (if (variable? proc)
+ (let* ((procname (variable.name proc))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every1? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ (let ((denotation (syntactic-lookup env procname)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.calls-set!
+ R-entry
+ (cons call (R-entry.calls R-entry)))))
+ call)))
+ call))
+ (m-error "Malformed application" exp)))
+
+; The environment argument should always be global here.
+
+(define (m-define-inline exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (let ((name (cadr exp)))
+ (m-define-syntax1 name
+ (caddr exp)
+ env
+ (define-syntax-scope))
+ (let ((denotation
+ (syntactic-lookup global-syntactic-environment name)))
+ (syntactic-bind-globally!
+ name
+ (make-inline-denotation name
+ (macro-rules denotation)
+ (macro-env denotation))))
+ (make-constant name)))
+ (else
+ (m-error "Malformed define-inline" exp))))
+
+; The environment argument should always be global here.
+
+(define (m-define-syntax exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (m-define-syntax1 (cadr exp)
+ (caddr exp)
+ env
+ (define-syntax-scope)))
+ ((and (= (safe-length exp) 4)
+ (symbol? (cadr exp))
+ ; FIXME: should use denotations here
+ (memq (caddr exp) '(letrec letrec* let*)))
+ (m-define-syntax1 (cadr exp)
+ (cadddr exp)
+ env
+ (caddr exp)))
+ (else (m-error "Malformed define-syntax" exp))))
+
+(define (m-define-syntax1 keyword spec env scope)
+ (if (and (pair? spec)
+ (symbol? (car spec)))
+ (let* ((transformer-keyword (car spec))
+ (denotation (syntactic-lookup env transformer-keyword)))
+ (cond ((eq? denotation denotation-of-syntax-rules)
+ (case scope
+ ((letrec) (m-define-syntax-letrec keyword spec env))
+ ((letrec*) (m-define-syntax-letrec* keyword spec env))
+ ((let*) (m-define-syntax-let* keyword spec env))
+ (else (m-bug "Weird scope" scope))))
+ ((same-denotation? denotation denotation-of-transformer)
+ ; FIXME: no error checking here
+ (syntactic-bind-globally!
+ keyword
+ (make-macro-denotation (eval (cadr spec)) env)))
+ (else
+ (m-error "Malformed syntax transformer" spec))))
+ (m-error "Malformed syntax transformer" spec))
+ (make-constant keyword))
+
+(define (m-define-syntax-letrec keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec env)))
+
+(define (m-define-syntax-letrec* keyword spec env)
+ (let* ((env (syntactic-extend (syntactic-copy env)
+ (list keyword)
+ '((fake denotation))))
+ (transformer (m-compile-transformer-spec spec env)))
+ (syntactic-assign! env keyword transformer)
+ (syntactic-bind-globally! keyword transformer)))
+
+(define (m-define-syntax-let* keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec (syntactic-copy env))))
+
+(define (m-let-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (m-body (cddr exp)
+ (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (spec)
+ (m-compile-transformer-spec
+ spec
+ env))
+ (map cadr (cadr exp)))))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-letrec-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (let ((env (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (id)
+ '(fake denotation))
+ (cadr exp)))))
+ (for-each (lambda (id spec)
+ (syntactic-assign!
+ env
+ id
+ (m-compile-transformer-spec spec env)))
+ (map car (cadr exp))
+ (map cadr (cadr exp)))
+ (m-body (cddr exp) env))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-macro exp env)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (m-expand exp env))))
+
+(define (m-inline exp env)
+ (if (integrate-usual-procedures)
+ (m-transcribe-inline exp
+ env
+ (lambda (newexp env)
+ (if (eq? exp newexp)
+ (m-application exp env)
+ (m-expand newexp env))))
+ (m-application exp env)))
+
+(define m-quit ; assigned by macro-expand
+ (lambda (v) v))
+
+; To do:
+; Clean up alist hacking et cetera.
+; Declarations.
+; Integrable procedures.
+; New semantics for body of LET-SYNTAX and LETREC-SYNTAX.
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 5 April 1999.
+
+($$trace "usual")
+
+; The usual macros, adapted from Jonathan's Version 2 implementation.
+; DEFINE is handled primitively, since top-level DEFINE has a side
+; effect on the global syntactic environment, and internal definitions
+; have to be handled specially anyway.
+;
+; Some extensions are noted, as are some optimizations.
+;
+; The LETREC* scope rule is used here to protect these macros against
+; redefinition of LAMBDA etc. The scope rule is changed to LETREC at
+; the end of this file.
+
+(define-syntax-scope 'letrec*)
+
+(for-each (lambda (form)
+ (macro-expand form))
+ '(
+
+; Named LET is defined later, after LETREC has been defined.
+
+(define-syntax let
+ (syntax-rules ()
+ ((let ((?name ?val) ...) ?body ?body1 ...)
+ ((lambda (?name ...) ?body ?body1 ...) ?val ...))))
+
+(define-syntax let*
+ (syntax-rules ()
+ ((let* () ?body ?body1 ...)
+ (let () ?body ?body1 ...))
+ ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...)
+ (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...)))))
+
+; Internal definitions have to be handled specially anyway,
+; so we might as well rely on them here.
+
+(define-syntax letrec
+ (syntax-rules (lambda quote)
+ ((letrec ((?name ?val) ...) ?body ?body2 ...)
+ ((lambda ()
+ (define ?name ?val) ...
+ ?body ?body2 ...)))))
+
+; This definition of named LET extends the prior definition of LET.
+; The first rule is non-circular, thanks to the LET* scope that is
+; specified for this use of DEFINE-SYNTAX.
+
+(define-syntax let let*
+ (syntax-rules ()
+ ((let (?bindings ...) . ?body)
+ (let (?bindings ...) . ?body))
+ ((let ?tag ((?name ?val) ...) ?body ?body1 ...)
+ (let ((?name ?val) ...)
+ (letrec ((?tag (lambda (?name ...) ?body ?body1 ...)))
+ (?tag ?name ...))))))
+
+(define-syntax and
+ (syntax-rules ()
+ ((and) #t)
+ ((and ?e) ?e)
+ ((and ?e1 ?e2 ?e3 ...)
+ (if ?e1 (and ?e2 ?e3 ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((or) #f)
+ ((or ?e) ?e)
+ ((or ?e1 ?e2 ?e3 ...)
+ (let ((temp ?e1))
+ (if temp temp (or ?e2 ?e3 ...))))))
+
+(define-syntax cond
+ (syntax-rules (else =>)
+ ((cond (else ?result ?result2 ...))
+ (begin ?result ?result2 ...))
+
+ ((cond (?test => ?result))
+ (let ((temp ?test))
+ (if temp (?result temp))))
+
+ ((cond (?test)) ?test)
+
+ ((cond (?test ?result ?result2 ...))
+ (if ?test (begin ?result ?result2 ...)))
+
+ ((cond (?test => ?result) ?clause ?clause2 ...)
+ (let ((temp ?test))
+ (if temp (?result temp) (cond ?clause ?clause2 ...))))
+
+ ((cond (?test) ?clause ?clause2 ...)
+ (or ?test (cond ?clause ?clause2 ...)))
+
+ ((cond (?test ?result ?result2 ...)
+ ?clause ?clause2 ...)
+ (if ?test
+ (begin ?result ?result2 ...)
+ (cond ?clause ?clause2 ...)))))
+
+; The R4RS says a <step> may be omitted.
+; That's a good excuse for a macro-defining macro that uses LETREC-SYNTAX
+; and the ... escape.
+
+(define-syntax do
+ (syntax-rules ()
+ ((do (?bindings0 ...) (?test) ?body0 ...)
+ (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...))
+ ((do (?bindings0 ...) ?clause0 ?body0 ...)
+ (letrec-syntax
+ ((do-aux
+ (... (syntax-rules ()
+ ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...)
+ (letrec ((loop (lambda (?name ...)
+ (cond ?clause
+ (else
+ (begin #t ?body ...)
+ (loop ?step ...))))))
+ (loop ?init ...)))
+ ((do-aux ((?name ?init ?step) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?step))
+ ?clause
+ ?body ...))
+ ((do-aux ((?name ?init) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?name))
+ ?clause
+ ?body ...))))))
+ (do-aux (?bindings0 ...) () ?clause0 ?body0 ...)))))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((delay ?e) (.make-promise (lambda () ?e)))))
+
+; Another use of LETREC-SYNTAX and the escape extension.
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case ?e1 (else ?body ?body2 ...))
+ (begin ?e1 ?body ?body2 ...))
+ ((case ?e1 (?z ?body ?body2 ...))
+ (if (memv ?e1 '?z) (begin ?body ?body2 ...)))
+ ((case ?e1 ?clause1 ?clause2 ?clause3 ...)
+ (letrec-syntax
+ ((case-aux
+ (... (syntax-rules (else)
+ ((case-aux ?temp (else ?body ?body2 ...))
+ (begin ?body ?body2 ...))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...))
+ (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...)))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...)
+ (if (memv ?temp '(?z ...))
+ (begin ?body ?body2 ...)
+ (case-aux ?temp ?c1 ?c2 ...)))
+ ; a popular extension
+ ((case-aux ?temp (?z ?body ...) ?c1 ...)
+ (case-aux ?temp ((?z) ?body ...) ?c1 ...))))))
+ (let ((temp ?e1))
+ (case-aux temp ?clause1 ?clause2 ?clause3 ...))))))
+
+; A complete implementation of quasiquote, obtained by translating
+; Jonathan Rees's implementation that was posted to RRRS-AUTHORS
+; on 22 December 1986.
+; Unfortunately, the use of LETREC scope means that it is vulnerable
+; to top-level redefinitions of QUOTE etc. That could be fixed, but
+; it has hair enough already.
+
+(begin
+
+ (define-syntax .finalize-quasiquote letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.finalize-quasiquote quote ?arg ?return)
+ (.interpret-continuation ?return (quote ?arg)))
+ ((.finalize-quasiquote unquote ?arg ?return)
+ (.interpret-continuation ?return ?arg))
+ ((.finalize-quasiquote unquote-splicing ?arg ?return)
+ (syntax-error ",@ in illegal context" ?arg))
+ ((.finalize-quasiquote ?mode ?arg ?return)
+ (.interpret-continuation ?return (?mode . ?arg)))))
+
+ ; The first two "arguments" to .descend-quasiquote and to
+ ; .descend-quasiquote-pair are always identical.
+
+ (define-syntax .descend-quasiquote letrec
+ (syntax-rules (quasiquote unquote unquote-splicing)
+ ((.descend-quasiquote `?y ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x (?level) ?return))
+ ((.descend-quasiquote ,?y ?x () ?return)
+ (.interpret-continuation ?return unquote ?y))
+ ((.descend-quasiquote ,?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote ,@?y ?x () ?return)
+ (.interpret-continuation ?return unquote-splicing ?y))
+ ((.descend-quasiquote ,@?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote (?y . ?z) ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote-vector ?x ?x ?level ?return))
+ ((.descend-quasiquote ?y ?x ?level ?return)
+ (.interpret-continuation ?return quote ?x))))
+
+ (define-syntax .descend-quasiquote-pair letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return)
+ (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return)))))
+
+ (define-syntax .descend-quasiquote-vector letrec
+ (syntax-rules (quote)
+ ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return)))))
+
+ ; Representations for continuations used here.
+ ; Continuation types 0, 1, 2, and 6 take a mode and an expression.
+ ; Continuation types -1, 3, 4, 5, and 7 take just an expression.
+ ;
+ ; (-1)
+ ; means no continuation
+ ; (0)
+ ; means to call .finalize-quasiquote with no further continuation
+ ; (1 ?cdrx ?x ?level ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-pair
+ ; (2 ?car-mode ?car-arg ?x ?return)
+ ; means a return from the second call to .descend-quasiquote in
+ ; in Jonathan's code for .descend-quasiquote-pair
+ ; (3 ?car-arg ?return)
+ ; means take the result and return an append of ?car-arg with it
+ ; (4 ?cdr-mode ?cdr-arg ?return)
+ ; means take the result and call .finalize-quasiquote on ?cdr-mode
+ ; and ?cdr-arg with a continuation of type 5
+ ; (5 ?car-result ?return)
+ ; means take the result and return a cons of ?car-result onto it
+ ; (6 ?x ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-vector
+ ; (7 ?return)
+ ; means take the result and return a call of list->vector on it
+
+ (define-syntax .interpret-continuation letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.interpret-continuation (-1) ?e) ?e)
+ ((.interpret-continuation (0) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (-1)))
+ ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg)
+ (.descend-quasiquote ?cdrx
+ ?cdrx
+ ?level
+ (2 ?car-mode ?car-arg ?x ?return)))
+ ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ())
+ (.interpret-continuation ?return unquote ?car-arg))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return)))
+ ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return)))
+
+ ((.interpret-continuation (3 ?car-arg ?return) ?e)
+ (.interpret-continuation ?return append (?car-arg ?e)))
+ ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return)))
+ ((.interpret-continuation (5 ?e1 ?return) ?e2)
+ (.interpret-continuation ?return .cons (?e1 ?e2)))
+ ((.interpret-continuation (6 ?x ?return) quote ?arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (6 ?x ?return) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (7 ?return)))
+ ((.interpret-continuation (7 ?return) ?e)
+ (.interpret-continuation ?return .list->vector (?e)))))
+
+ (define-syntax quasiquote letrec
+ (syntax-rules ()
+ ((quasiquote ?x)
+ (.descend-quasiquote ?x ?x () (0)))))
+ )
+
+(define-syntax let*-syntax
+ (syntax-rules ()
+ ((let*-syntax () ?body)
+ (let-syntax () ?body))
+ ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body)
+ (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))
+
+
+ ))
+
+(define-syntax-scope 'letrec)
+
+(define standard-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-standard-syntactic-environment)
+ (syntactic-copy standard-syntactic-environment))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 25 April 1999
+;
+; Given an expression in the subset of Scheme used as an intermediate language
+; by Twobit, returns a newly allocated copy of the expression in which the
+; local variables have been renamed and the referencing information has been
+; recomputed.
+
+(define (copy-exp exp)
+
+ (define special-names (cons name:IGNORED argument-registers))
+
+ (define original-names (make-hashtable symbol-hash assq))
+
+ (define renaming-counter 0)
+
+ (define (rename-vars vars)
+ (let ((rename (make-rename-procedure)))
+ (map (lambda (var)
+ (cond ((memq var special-names)
+ var)
+ ((hashtable-get original-names var)
+ (rename var))
+ (else
+ (hashtable-put! original-names var #t)
+ var)))
+ vars)))
+
+ (define (rename-formals formals newnames)
+ (cond ((null? formals) '())
+ ((symbol? formals) (car newnames))
+ ((memq (car formals) special-names)
+ (cons (car formals)
+ (rename-formals (cdr formals)
+ (cdr newnames))))
+ (else (cons (car newnames)
+ (rename-formals (cdr formals)
+ (cdr newnames))))))
+
+ ; Environments that map symbols to arbitrary information.
+ ; This data type is mutable, and uses the shallow binding technique.
+
+ (define (make-env) (make-hashtable symbol-hash assq))
+
+ (define (env-bind! env sym info)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cons info stack))))
+
+ (define (env-unbind! env sym)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cdr stack))))
+
+ (define (env-lookup env sym default)
+ (let ((stack (hashtable-get env sym)))
+ (if stack
+ (car stack)
+ default)))
+
+ (define (env-bind-multiple! env symbols infos)
+ (for-each (lambda (sym info) (env-bind! env sym info))
+ symbols
+ infos))
+
+ (define (env-unbind-multiple! env symbols)
+ (for-each (lambda (sym) (env-unbind! env sym))
+ symbols))
+
+ ;
+
+ (define (lexical-lookup R-table name)
+ (assq name R-table))
+
+ (define (copy exp env notepad R-table)
+ (cond ((constant? exp) exp)
+ ((lambda? exp)
+ (let* ((bvl (make-null-terminated (lambda.args exp)))
+ (newnames (rename-vars bvl))
+ (procnames (map def.lhs (lambda.defs exp)))
+ (newprocnames (rename-vars procnames))
+ (refinfo (map (lambda (var)
+ (make-R-entry var '() '() '()))
+ (append newnames newprocnames)))
+ (newexp
+ (make-lambda
+ (rename-formals (lambda.args exp) newnames)
+ '()
+ refinfo
+ '()
+ '()
+ (lambda.decls exp)
+ (lambda.doc exp)
+ (lambda.body exp))))
+ (env-bind-multiple! env procnames newprocnames)
+ (env-bind-multiple! env bvl newnames)
+ (for-each (lambda (entry)
+ (env-bind! R-table (R-entry.name entry) entry))
+ refinfo)
+ (notepad-lambda-add! notepad newexp)
+ (let ((newnotepad (make-notepad notepad)))
+ (for-each (lambda (name rhs)
+ (lambda.defs-set!
+ newexp
+ (cons (make-definition
+ name
+ (copy rhs env newnotepad R-table))
+ (lambda.defs newexp))))
+ (reverse newprocnames)
+ (map def.rhs
+ (reverse (lambda.defs exp))))
+ (lambda.body-set!
+ newexp
+ (copy (lambda.body exp) env newnotepad R-table))
+ (lambda.F-set! newexp (notepad-free-variables newnotepad))
+ (lambda.G-set! newexp (notepad-captured-variables newnotepad)))
+ (env-unbind-multiple! env procnames)
+ (env-unbind-multiple! env bvl)
+ (for-each (lambda (entry)
+ (env-unbind! R-table (R-entry.name entry)))
+ refinfo)
+ newexp))
+ ((assignment? exp)
+ (let* ((oldname (assignment.lhs exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp
+ (make-assignment name
+ (copy (assignment.rhs exp) env notepad R-table))))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.assignments-set!
+ varinfo
+ (cons newexp (R-entry.assignments varinfo))))
+ newexp))
+ ((conditional? exp)
+ (make-conditional (copy (if.test exp) env notepad R-table)
+ (copy (if.then exp) env notepad R-table)
+ (copy (if.else exp) env notepad R-table)))
+ ((begin? exp)
+ (make-begin (map (lambda (exp) (copy exp env notepad R-table))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (let* ((oldname (variable.name exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp (make-variable name)))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.references-set!
+ varinfo
+ (cons newexp (R-entry.references varinfo))))
+ newexp))
+ ((call? exp)
+ (let ((newexp (make-call (copy (call.proc exp) env notepad R-table)
+ (map (lambda (exp)
+ (copy exp env notepad R-table))
+ (call.args exp)))))
+ (if (variable? (call.proc newexp))
+ (let ((varinfo
+ (env-lookup R-table
+ (variable.name
+ (call.proc newexp))
+ #f)))
+ (if varinfo
+ (R-entry.calls-set!
+ varinfo
+ (cons newexp (R-entry.calls varinfo))))))
+ (if (lambda? (call.proc newexp))
+ (notepad-nonescaping-add! notepad (call.proc newexp)))
+ newexp))
+ (else ???)))
+
+ (copy exp (make-env) (make-notepad #f) (make-env)))
+
+; For debugging.
+; Given an expression, traverses the expression to confirm
+; that the referencing invariants are correct.
+
+(define (check-referencing-invariants exp . flags)
+
+ (let ((check-free-variables? (memq 'free flags))
+ (check-referencing? (memq 'reference flags))
+ (first-violation? #t))
+
+ ; env is the list of enclosing lambda expressions,
+ ; beginning with the innermost.
+
+ (define (check exp env)
+ (cond ((constant? exp) (return exp #t))
+ ((lambda? exp)
+ (let ((env (cons exp env)))
+ (return exp
+ (and (every? (lambda (exp)
+ (check exp env))
+ (map def.rhs (lambda.defs exp)))
+ (check (lambda.body exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (subset? (difference
+ (lambda.F exp)
+ (make-null-terminated
+ (lambda.args exp)))
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((env (cons exp env))
+ (R (lambda.R exp)))
+ (every? (lambda (formal)
+ (or (ignored? formal)
+ (R-entry R formal)))
+ (make-null-terminated
+ (lambda.args exp))))
+ #t)))))
+ ((variable? exp)
+ (return exp
+ (and (if (and check-free-variables?
+ (not (null? env)))
+ (memq (variable.name exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (variable.name exp))))
+ (if Rinfo
+ (memq exp (R-entry.references Rinfo))
+ #t))
+ #t))))
+ ((assignment? exp)
+ (return exp
+ (and (check (assignment.rhs exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (memq (assignment.lhs exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (assignment.lhs exp))))
+ (if Rinfo
+ (memq exp (R-entry.assignments Rinfo))
+ #t))
+ #t))))
+ ((conditional? exp)
+ (return exp
+ (and (check (if.test exp) env)
+ (check (if.then exp) env)
+ (check (if.else exp) env))))
+ ((begin? exp)
+ (return exp
+ (every? (lambda (exp) (check exp env))
+ (begin.exprs exp))))
+ ((call? exp)
+ (return exp
+ (and (check (call.proc exp) env)
+ (every? (lambda (exp) (check exp env))
+ (call.args exp))
+ (if (and check-referencing?
+ (variable? (call.proc exp)))
+ (let ((Rinfo (lookup env
+ (variable.name
+ (call.proc exp)))))
+ (if Rinfo
+ (memq exp (R-entry.calls Rinfo))
+ #t))
+ #t))))
+ (else ???)))
+
+ (define (return exp flag)
+ (cond (flag
+ #t)
+ (first-violation?
+ (set! first-violation? #f)
+ (display "Violation of referencing invariants")
+ (newline)
+ (pretty-print (make-readable exp))
+ #f)
+ (else (pretty-print (make-readable exp))
+ #f)))
+
+ (define (lookup env I)
+ (if (null? env)
+ #f
+ (let ((Rinfo (R-entry (lambda.R (car env)) I)))
+ (or Rinfo
+ (lookup (cdr env) I)))))
+
+ (if (null? flags)
+ (begin (set! check-free-variables? #t)
+ (set! check-referencing? #t)))
+
+ (check exp '())))
+
+
+; Calculating the free variable information for an expression
+; as output by pass 2. This should be faster than computing both
+; the free variables and the referencing information.
+
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-set '()))
+
+ (define (singleton x) (list x))
+
+ (define (union2 x y) (union x y))
+ (define (union3 x y z) (union x y z))
+
+ (define (set->list set) set)
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (free exp))
+
+; As above, but representing sets as hashtrees.
+; This is commented out because it is much slower than the implementation
+; above. Because the set of free variables is represented as a list
+; within a lambda expression, this implementation must convert the
+; representation for every lambda expression, which is quite expensive
+; for A-normal form.
+
+(begin
+'
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-hashtree symbol-hash assq))
+
+ (define (singleton x)
+ (hashtree-put empty-set x #t))
+
+ (define (make-set values)
+ (if (null? values)
+ empty-set
+ (hashtree-put (make-set (cdr values))
+ (car values)
+ #t)))
+
+ (define (union2 x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-put x key #t)))
+ y)
+ x)
+
+ (define (union3 x y z)
+ (union2 (union2 x y) z))
+
+ (define (apply-union sets)
+ (cond ((null? sets)
+ (make-set '()))
+ ((null? (cdr sets))
+ (car sets))
+ (else
+ (union2 (car sets)
+ (apply-union (cdr sets))))))
+
+ (define (difference x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-remove x key)))
+ y)
+ x)
+
+ (define (set->list set)
+ (hashtree-map (lambda (sym val) sym) set))
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (hashtree-map (lambda (sym val) sym)
+ (free exp)))
+#t); Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 24 April 1999
+;
+; First pass of the Twobit compiler:
+; macro expansion, syntax checking, alpha conversion,
+; preliminary annotation.
+;
+; The input to this pass is a Scheme definition or expression.
+; The output is an expression in the subset of Scheme described
+; by the following grammar, where the output satisfies certain
+; additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the output:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+; * F and G are garbage.
+
+($$trace "pass1")
+
+(define source-file-name #f)
+(define source-file-position #f)
+
+(define pass1-block-compiling? #f)
+(define pass1-block-assignments '())
+(define pass1-block-inlines '())
+
+(define (pass1 def-or-exp . rest)
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (set! renaming-counter 0)
+ (macro-expand def-or-exp))
+
+; Compiles a whole sequence of top-level forms on the assumption
+; that no variable that is defined by a form in the sequence is
+; ever defined or assigned outside of the sequence.
+;
+; This is a crock in three parts:
+;
+; 1. Macro-expand each form and record assignments.
+; 2. Find the top-level variables that are defined but not
+; assigned, give them local names, generate a DEFINE-INLINE
+; for each of the top-level procedures, and macro-expand
+; each form again.
+; 3. Wrap the whole mess in an appropriate LET and recompute
+; the referencing information by copying it.
+;
+; Note that macros get expanded twice, and that all DEFINE-SYNTAX
+; macros are considered local to the forms.
+
+; FIXME: Need to turn off warning messages.
+
+(define (pass1-block forms . rest)
+
+ (define (part1)
+ (set! pass1-block-compiling? #t)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings))
+ (defined '()))
+ (define (make-toplevel-definition id exp)
+ (cond ((memq id defined)
+ (set! pass1-block-assignments
+ (cons id pass1-block-assignments)))
+ ((or (constant? exp)
+ (and (lambda? exp)
+ (list? (lambda.args exp))))
+ (set! defined (cons id defined))))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+ (benchmark-mode #f)
+ (issue-warnings #f)
+ (for-each (lambda (form)
+ (desugar-definitions form
+ global-syntactic-environment
+ make-toplevel-definition))
+ forms)
+ (set! global-syntactic-environment env0)
+ (benchmark-mode bmode)
+ (issue-warnings wmode)
+ (part2 (filter (lambda (id)
+ (not (memq id pass1-block-assignments)))
+ (reverse defined)))))
+
+ (define (part2 defined)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let* ((rename (make-rename-procedure))
+ (alist (map (lambda (id)
+ (cons id (rename id)))
+ defined))
+ (definitions0 '()) ; for constants
+ (definitions1 '())) ; for lambda expressions
+ (define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (let ((probe (assq id alist)))
+ (if probe
+ (let ((id1 (cdr probe)))
+ (cond ((constant? exp)
+ (set! definitions0
+ (cons (make-assignment id exp)
+ definitions0))
+ (make-constant id))
+ ((lambda? exp)
+ (set! definitions1
+ (cons (make-assignment id1 exp)
+ definitions1))
+ (make-assignment
+ id
+ (make-lambda (lambda.args exp)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (lambda.doc exp)
+ (make-call
+ (make-variable id1)
+ (map make-variable
+ (lambda.args exp))))))
+ (else
+ (m-error "Inconsistent macro expansion"
+ (make-readable exp)))))
+ (make-assignment id exp))))
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings)))
+ (issue-warnings #f)
+ (for-each (lambda (pair)
+ (let ((id0 (car pair))
+ (id1 (cdr pair)))
+ (syntactic-bind-globally!
+ id0
+ (make-inline-denotation
+ id0
+ (lambda (exp rename compare)
+ ; Deliberately non-hygienic!
+ (cons id1 (cdr exp)))
+ global-syntactic-environment))
+ (set! pass1-block-inlines
+ (cons id0 pass1-block-inlines))))
+ alist)
+ (benchmark-mode #f)
+ (issue-warnings wmode)
+ (let ((forms
+ (do ((forms forms (cdr forms))
+ (newforms '()
+ (cons (desugar-definitions
+ (car forms)
+ global-syntactic-environment
+ make-toplevel-definition)
+ newforms)))
+ ((null? forms)
+ (reverse newforms)))))
+ (benchmark-mode bmode)
+ (set! global-syntactic-environment env0)
+ (part3 alist definitions0 definitions1 forms)))))
+
+ (define (part3 alist definitions0 definitions1 forms)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (let* ((constnames0 (map assignment.lhs definitions0))
+ (constnames1 (map (lambda (id0)
+ (cdr (assq id0 alist)))
+ constnames0))
+ (procnames1 (map assignment.lhs definitions1)))
+ (copy-exp
+ (make-call
+ (make-lambda
+ constnames1
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin
+ (list
+ (make-begin
+ (cons (make-constant #f)
+ (reverse
+ (map (lambda (id)
+ (make-assignment id (make-variable (cdr (assq id alist)))))
+ constnames0))))
+ (make-call
+ (make-lambda
+ constnames0
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-call
+ (make-lambda
+ (map assignment.lhs definitions1)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin (cons (make-constant #f)
+ (append definitions1 forms))))
+ (map (lambda (ignored) (make-unspecified))
+ definitions1)))
+ (map make-variable constnames1))
+ )))
+ (map assignment.rhs definitions0)))))
+
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (part1))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Support for intraprocedural value numbering:
+; set of available expressions
+; miscellaneous
+;
+; The set of available expressions is represented as a
+; mutable abstract data type Available with these operations:
+;
+; make-available-table: -> Available
+; copy-available-table: Available -> Available
+; available-expression: Available x Expr -> (symbol + {#f})
+; available-variable: Available x symbol -> Expr
+; available-extend!: Available x symbol x Expr x Killer ->
+; available-kill!: Available x Killer ->
+;
+; where Expr is of the form
+;
+; Expr --> W
+; | (W_0 W_1 ...)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; and Killer is a fixnum, as defined later in this file.
+;
+; (make-available-table)
+; returns an empty table of available expressions.
+; (copy-available-table available)
+; copies the given table.
+; (available-expression available E)
+; returns the name of E if it is available in the table, else #f.
+; (available-variable available T)
+; returns a constant or variable to use in place of T, else #f.
+; (available-extend! available T E K)
+; adds the binding (T E) to the table, with Killer K.
+; If E is a variable and this binding is never killed, then copy
+; propagation will replace uses of T by uses of E; otherwise
+; commoning will replace uses of E by uses of T, until the
+; binding is killed.
+; (available-kill! available K)
+; removes all bindings whose Killer intersects K.
+;
+; (available-extend! available T E K) is very fast if the previous
+; operation on the table was (available-expression available E).
+
+; Implementation.
+;
+; Quick and dirty.
+; The available expressions are represented as a vector of 2 association
+; lists. The first list is used for common subexpression elimination,
+; and the second is used for copy and constant propagation.
+;
+; Each element of the first list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (E T K).
+;
+; Each element of the second list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (T E K).
+; The expression E will be a constant or variable.
+
+(define (make-available-table)
+ (vector '() '()))
+
+(define (copy-available-table available)
+ (vector (vector-ref available 0)
+ (vector-ref available 1)))
+
+(define (available-expression available E)
+ (let ((binding (assoc E (vector-ref available 0))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-variable available T)
+ (let ((binding (assq T (vector-ref available 1))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-extend! available T E K)
+ (cond ((constant? E)
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ ((and (variable? E)
+ (eq? K available:killer:none))
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ (else
+ (vector-set! available
+ 0
+ (cons (list E T K)
+ (vector-ref available 0))))))
+
+(define (available-kill! available K)
+ (vector-set! available
+ 0
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 0)))
+ (vector-set! available
+ 1
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 1))))
+
+(define (available-intersect! available0 available1 available2)
+ (vector-set! available0
+ 0
+ (intersection (vector-ref available1 0)
+ (vector-ref available2 0)))
+ (vector-set! available0
+ 1
+ (intersection (vector-ref available1 1)
+ (vector-ref available2 1))))
+
+; The Killer concrete data type, represented as a fixnum.
+;
+; The set of side effects that can kill an available expression
+; are a subset of
+;
+; assignments to global variables
+; uses of SET-CAR!
+; uses of SET-CDR!
+; uses of STRING-SET!
+; uses of VECTOR-SET!
+;
+; This list is not complete. If we were trying to perform common
+; subexpression elimination on calls to PEEK-CHAR, for example,
+; then those calls would be killed by reads.
+
+(define available:killer:globals 2)
+(define available:killer:car 4)
+(define available:killer:cdr 8)
+(define available:killer:string 16) ; also bytevectors etc
+(define available:killer:vector 32) ; also structures etc
+(define available:killer:cell 64)
+(define available:killer:io 128)
+(define available:killer:none 0) ; none of the above
+(define available:killer:all 1022) ; all of the above
+
+(define available:killer:immortal 0) ; never killed
+(define available:killer:dead 1023) ; never available
+
+
+
+(define (available:killer-combine k1 k2)
+ (logior k1 k2))
+
+; Miscellaneous.
+
+; A simple lambda expression has no internal definitions at its head
+; and no declarations aside from A-normal form.
+
+(define (simple-lambda? L)
+ (and (null? (lambda.defs L))
+ (every? (lambda (decl)
+ (eq? decl A-normal-form-declaration))
+ (lambda.decls L))))
+
+; A real call is a call whose procedure expression is
+; neither a lambda expression nor a primop.
+
+(define (real-call? E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (not (lambda? proc))
+ (or (not (variable? proc))
+ (let ((f (variable.name proc)))
+ (or (not (integrate-usual-procedures))
+ (not (prim-entry f)))))))))
+
+(define (prim-call E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc))))))
+
+(define (no-side-effects? E)
+ (or (constant? E)
+ (variable? E)
+ (lambda? E)
+ (and (conditional? E)
+ (no-side-effects? (if.test E))
+ (no-side-effects? (if.then E))
+ (no-side-effects? (if.else E)))
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (let ((entry (prim-entry (variable.name proc))))
+ (and entry
+ (not (eq? available:killer:dead
+ (prim-lives-until entry))))))))))
+
+; Given a local variable, the expression within its scope, and
+; a list of local variables that are known to be used only once,
+; returns #t if the variable is used only once.
+;
+; The purpose of this routine is to recognize temporaries that
+; may once have had two or more uses because of CSE, but now have
+; only one use because of further CSE followed by dead code elimination.
+
+(define (temporary-used-once? T E used-once)
+ (cond ((call? E)
+ (let ((proc (call.proc E))
+ (args (call.args E)))
+ (or (and (lambda? proc)
+ (not (memq T (lambda.F proc)))
+ (and (pair? args)
+ (null? (cdr args))
+ (temporary-used-once? T (car args) used-once)))
+ (do ((exprs (cons proc (call.args E))
+ (cdr exprs))
+ (n 0
+ (let ((exp (car exprs)))
+ (cond ((constant? exp)
+ n)
+ ((variable? exp)
+ (if (eq? T (variable.name exp))
+ (+ n 1)
+ n))
+ (else
+ ; Terminate the loop and return #f.
+ 2)))))
+ ((or (null? exprs)
+ (> n 1))
+ (= n 1))))))
+ (else
+ (memq T used-once))))
+
+; Register bindings.
+
+(define (make-regbinding lhs rhs use)
+ (list lhs rhs use))
+
+(define (regbinding.lhs x) (car x))
+(define (regbinding.rhs x) (cadr x))
+(define (regbinding.use x) (caddr x))
+
+; Given a list of register bindings, an expression E and its free variables F,
+; returns two values:
+; E with the register bindings wrapped around it
+; the free variables of the wrapped expression
+
+(define (wrap-with-register-bindings regbindings E F)
+ (if (null? regbindings)
+ (values E F)
+ (let* ((regbinding (car regbindings))
+ (R (regbinding.lhs regbinding))
+ (x (regbinding.rhs regbinding)))
+ (wrap-with-register-bindings
+ (cdr regbindings)
+ (make-call (make-lambda (list R)
+ '()
+ '()
+ F
+ F
+ (list A-normal-form-declaration)
+ #f
+ E)
+ (list (make-variable x)))
+ (union (list x)
+ (difference F (list R)))))))
+
+; Returns two values:
+; the subset of regbindings that have x as their right hand side
+; the rest of regbindings
+
+(define (register-bindings regbindings x)
+ (define (loop regbindings to-x others)
+ (cond ((null? regbindings)
+ (values to-x others))
+ ((eq? x (regbinding.rhs (car regbindings)))
+ (loop (cdr regbindings)
+ (cons (car regbindings) to-x)
+ others))
+ (else
+ (loop (cdr regbindings)
+ to-x
+ (cons (car regbindings) others)))))
+ (loop regbindings '() '()))
+
+; This procedure is called when the compiler can tell that an assertion
+; is never true.
+
+(define (declaration-error E)
+ (if (issue-warnings)
+ (begin (display "WARNING: Assertion is false: ")
+ (write (make-readable E #t))
+ (newline))))
+; Representations, which form a subtype hierarchy.
+;
+; <rep> ::= <fixnum> | (<fixnum> <datum> ...)
+;
+; (<rep> <datum> ...) is a subtype of <rep>, but the non-fixnum
+; representations are otherwise interpreted by arbitrary code.
+
+(define *nreps* 0)
+(define *rep-encodings* '())
+(define *rep-decodings* '())
+(define *rep-subtypes* '())
+(define *rep-joins* (make-bytevector 0))
+(define *rep-meets* (make-bytevector 0))
+(define *rep-joins-special* '#())
+(define *rep-meets-special* '#())
+
+(define (representation-error msg . stuff)
+ (apply error
+ (if (string? msg)
+ (string-append "Bug in flow analysis: " msg)
+ msg)
+ stuff))
+
+(define (symbol->rep sym)
+ (let ((probe (assq sym *rep-encodings*)))
+ (if probe
+ (cdr probe)
+ (let ((rep *nreps*))
+ (set! *nreps* (+ *nreps* 1))
+ (if (> *nreps* 255)
+ (representation-error "Too many representation types"))
+ (set! *rep-encodings*
+ (cons (cons sym rep)
+ *rep-encodings*))
+ (set! *rep-decodings*
+ (cons (cons rep sym)
+ *rep-decodings*))
+ rep))))
+
+(define (rep->symbol rep)
+ (if (pair? rep)
+ (cons (rep->symbol (car rep)) (cdr rep))
+ (let ((probe (assv rep *rep-decodings*)))
+ (if probe
+ (cdr probe)
+ 'unknown))))
+
+(define (representation-table table)
+ (map (lambda (row)
+ (map (lambda (x)
+ (if (list? x)
+ (map symbol->rep x)
+ x))
+ row))
+ table))
+
+; DEFINE-SUBTYPE is how representation types are defined.
+
+(define (define-subtype sym1 sym2)
+ (let* ((rep2 (symbol->rep sym2))
+ (rep1 (symbol->rep sym1)))
+ (set! *rep-subtypes*
+ (cons (cons rep1 rep2)
+ *rep-subtypes*))
+ sym1))
+
+; COMPUTE-TYPE-STRUCTURE! must be called before DEFINE-INTERSECTION.
+
+(define (define-intersection sym1 sym2 sym3)
+ (let ((rep1 (symbol->rep sym1))
+ (rep2 (symbol->rep sym2))
+ (rep3 (symbol->rep sym3)))
+ (representation-aset! *rep-meets* rep1 rep2 rep3)
+ (representation-aset! *rep-meets* rep2 rep1 rep3)))
+
+;
+
+(define (representation-aref bv i j)
+ (bytevector-ref bv (+ (* *nreps* i) j)))
+
+(define (representation-aset! bv i j x)
+ (bytevector-set! bv (+ (* *nreps* i) j) x))
+
+(define (compute-unions!)
+
+ ; Always define a bottom element.
+
+ (for-each (lambda (sym)
+ (define-subtype 'bottom sym))
+ (map car *rep-encodings*))
+
+ (let* ((debugging? #f)
+ (n *nreps*)
+ (n^2 (* n n))
+ (matrix (make-bytevector n^2)))
+
+ ; This code assumes there will always be a top element.
+
+ (define (lub rep1 rep2 subtype?)
+ (do ((i 0 (+ i 1))
+ (bounds '()
+ (if (and (subtype? rep1 i)
+ (subtype? rep2 i))
+ (cons i bounds)
+ bounds)))
+ ((= i n)
+ (car (twobit-sort subtype? bounds)))))
+
+ (define (join i j)
+ (lub i j (lambda (rep1 rep2)
+ (= 1 (representation-aref matrix rep1 rep2)))))
+
+ (define (compute-transitive-closure!)
+ (let ((changed? #f))
+ (define (loop)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((k 0 (+ k 1)))
+ ((= k n))
+ (do ((j 0 (+ j 1))
+ (sum 0
+ (logior sum
+ (logand
+ (representation-aref matrix i j)
+ (representation-aref matrix j k)))))
+ ((= j n)
+ (if (> sum 0)
+ (let ((x (representation-aref matrix i k)))
+ (if (zero? x)
+ (begin
+ (set! changed? #t)
+ (representation-aset! matrix i k 1)))))))))
+ (if changed?
+ (begin (set! changed? #f)
+ (loop))))
+ (loop)))
+
+ (define (compute-joins!)
+ (let ((default (lambda (x y)
+ (error "Compiler bug: special meet or join" x y))))
+ (set! *rep-joins-special* (make-vector n default))
+ (set! *rep-meets-special* (make-vector n default)))
+ (set! *rep-joins* (make-bytevector n^2))
+ (set! *rep-meets* (make-bytevector n^2))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-joins*
+ i
+ j
+ (join i j)))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! matrix i j 0))
+ (representation-aset! matrix i i 1))
+ (for-each (lambda (subtype)
+ (let ((rep1 (car subtype))
+ (rep2 (cdr subtype)))
+ (representation-aset! matrix rep1 rep2 1)))
+ *rep-subtypes*)
+ (compute-transitive-closure!)
+ (if debugging?
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (write-char #\space)
+ (write (representation-aref matrix i j)))
+ (newline)))
+ (compute-joins!)
+ (set! *rep-subtypes* '())))
+
+; Intersections are not dual to unions because a conservative analysis
+; must always err on the side of the larger subtype.
+; COMPUTE-UNIONS! must be called before COMPUTE-INTERSECTIONS!.
+
+(define (compute-intersections!)
+ (let ((n *nreps*))
+
+ (define (meet i j)
+ (let ((k (representation-union i j)))
+ (if (= i k)
+ j
+ i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-meets*
+ i
+ j
+ (meet i j))))))
+
+(define (compute-type-structure!)
+ (compute-unions!)
+ (compute-intersections!))
+
+(define (representation-subtype? rep1 rep2)
+ (equal? rep2 (representation-union rep1 rep2)))
+
+(define (representation-union rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-joins* rep1 rep2)
+ (representation-union rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-union (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-joins-special* r1) rep1 rep2)
+ (representation-union r1 r2))))))
+
+(define (representation-intersection rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-meets* rep1 rep2)
+ (representation-intersection rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-intersection (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-meets-special* r1) rep1 rep2)
+ (representation-intersection r1 r2))))))
+
+; For debugging.
+
+(define (display-unions-and-intersections)
+ (let* ((column-width 10)
+ (columns/row (quotient 80 column-width)))
+
+ (define (display-symbol sym)
+ (let* ((s (symbol->string sym))
+ (n (string-length s)))
+ (if (< n column-width)
+ (begin (display s)
+ (display (make-string (- column-width n) #\space)))
+ (begin (display (substring s 0 (- column-width 1)))
+ (write-char #\space)))))
+
+ ; Display columns i to n.
+
+ (define (display-matrix f i n)
+ (display (make-string column-width #\space))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol i)))
+ (newline)
+ (newline)
+ (do ((k 0 (+ k 1)))
+ ((= k *nreps*))
+ (display-symbol (rep->symbol k))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol (f k i))))
+ (newline))
+ (newline)
+ (newline))
+
+ (display "Unions:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-union
+ i
+ (min *nreps* (+ i columns/row))))
+
+ (display "Intersections:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-intersection
+ i
+ (min *nreps* (+ i columns/row))))))
+
+; Operations that can be specialized.
+;
+; Format: (<name> (<arg-rep> ...) <specific-name>)
+
+(define (rep-specific? f rs)
+ (rep-match f rs rep-specific caddr))
+
+; Operations whose result has some specific representation.
+;
+; Format: (<name> (<arg-rep> ...) (<result-rep>))
+
+(define (rep-result? f rs)
+ (rep-match f rs rep-result caaddr))
+
+; Unary predicates that give information about representation.
+;
+; Format: (<name> <rep-if-true> <rep-if-false>)
+
+(define (rep-if-true f rs)
+ (rep-match f rs rep-informing caddr))
+
+(define (rep-if-false f rs)
+ (rep-match f rs rep-informing cadddr))
+
+; Given the name of an integrable primitive,
+; the representations of its arguments,
+; a representation table, and a selector function
+; finds the most type-specific row of the table that matches both
+; the name of the primitive and the representations of its arguments,
+; and returns the result of applying the selector to that row.
+; If no row matches, then REP-MATCH returns #f.
+;
+; FIXME: This should be more efficient, and should prefer the most
+; specific matches.
+
+(define (rep-match f rs table selector)
+ (let ((n (length rs)))
+ (let loop ((entries table))
+ (cond ((null? entries)
+ #f)
+ ((eq? f (car (car entries)))
+ (let ((rs0 (cadr (car entries))))
+ (if (and (= n (length rs0))
+ (every? (lambda (r1+r2)
+ (let ((r1 (car r1+r2))
+ (r2 (cdr r1+r2)))
+ (representation-subtype? r1 r2)))
+ (map cons rs rs0)))
+ (selector (car entries))
+ (loop (cdr entries)))))
+ (else
+ (loop (cdr entries)))))))
+
+; Abstract interpretation with respect to types and constraints.
+; Returns a representation type.
+
+(define (aeval E types constraints)
+ (cond ((call? E)
+ (let ((proc (call.proc E)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (argtypes (map (lambda (E)
+ (aeval E types constraints))
+ (call.args E)))
+ (type (rep-result? op argtypes)))
+ (if type
+ type
+ rep:object))
+ rep:object)))
+ ((variable? E)
+ (representation-typeof (variable.name E) types constraints))
+ ((constant? E)
+ (representation-of-value (constant.value E)))
+ (else
+ rep:object)))
+
+; If x has representation type t0 in the hash table,
+; and some further constraints
+;
+; x = (op y1 ... yn)
+; x : t1
+; ...
+; x : tk
+;
+; then
+;
+; typeof (x) = op (typeof (y1), ..., typeof (yn))
+; & t0 & t1 & ... & tk
+;
+; where & means intersection and op is the abstraction of op.
+;
+; Also if T : true and T = E then E may give information about
+; the types of other variables. Similarly for T : false.
+
+(define (representation-typeof name types constraints)
+ (let ((t0 (hashtable-fetch types name rep:object))
+ (cs (hashtable-fetch (constraints.table constraints) name '())))
+ (define (loop type cs)
+ (if (null? cs)
+ type
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E (constraint.rhs c)))
+ (cond ((constant? E)
+ (loop (representation-intersection type
+ (constant.value E))
+ cs))
+ ((call? E)
+ (loop (representation-intersection
+ type (aeval E types constraints))
+ cs))
+ (else
+ (loop type cs))))))
+ (loop t0 cs)))
+
+; Constraints.
+;
+; The constraints used by this analysis consist of type constraints
+; together with the available expressions used for commoning.
+;
+; (T E K) T = E until killed by an effect in K
+; (T '<rep> K) T : <rep> until killed by an effect in K
+
+(define (make-constraint T E K)
+ (list T E K))
+
+(define (constraint.lhs c)
+ (car c))
+
+(define (constraint.rhs c)
+ (cadr c))
+
+(define (constraint.killer c)
+ (caddr c))
+
+(define (make-type-constraint T type K)
+ (make-constraint T
+ (make-constant type)
+ K))
+
+; If the new constraint is of the form T = E until killed by K,
+; then there shouldn't be any prior constraints.
+;
+; Otherwise the new constraint is of the form T : t until killed by K.
+; Suppose the prior constraints are
+; T = E until killed by K
+; T : t1 until killed by K1
+; ...
+; T : tn until killed by Kn
+;
+; If there exists i such that ti is a subtype of t and Ki a subset of K,
+; then the new constraint adds no new information and should be ignored.
+; Otherwise compute t' = t1 & ... & tn and K' = K1 | ... | Kn, where
+; & indicates intersection and | indicates union.
+; If K = K' then add the new constraint T : t' until killed by K;
+; otherwise add two new constraints:
+; T : t' until killed by K'
+; T : t until killed by K
+
+(define (constraints-add! types constraints new)
+ (let* ((debugging? #f)
+ (T (constraint.lhs new))
+ (E (constraint.rhs new))
+ (K (constraint.killer new))
+ (cs (constraints-for-variable constraints T)))
+
+ (define (loop type K cs newcs)
+ (if (null? cs)
+ (cons (make-type-constraint T type K) newcs)
+ (let* ((c2 (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c2))
+ (K2 (constraint.killer c2)))
+ (if (constant? E2)
+ (let* ((type2 (constant.value E2))
+ (type3 (representation-intersection type type2)))
+ (cond ((eq? type2 type3)
+ (if (= K2 (logand K K2))
+ (append newcs cs)
+ (loop (representation-intersection type type2)
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs))))
+ ((representation-subtype? type type3)
+ (if (= K (logand K K2))
+ (loop type K cs newcs)
+ (loop type K cs (cons c2 newcs))))
+ (else
+ (loop type3
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs)))))
+ (let* ((op (variable.name (call.proc E2)))
+ (args (call.args E2))
+ (argtypes (map (lambda (exp)
+ (aeval exp types constraints))
+ args)))
+ (cond ((representation-subtype? type rep:true)
+ (let ((reps (rep-if-true op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2))))
+ ((representation-subtype? type rep:false)
+ (let ((reps (rep-if-false op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2)))))
+ (loop type K cs (cons c2 newcs)))))))
+
+ (define (record-new-reps! args argtypes reps K2)
+ (if debugging?
+ (begin (write (list (map make-readable args)
+ (map rep->symbol argtypes)
+ (map rep->symbol reps)))
+ (newline)))
+ (for-each (lambda (arg type0 type1)
+ (if (not (representation-subtype? type0 type1))
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ ; FIXME: In this context, a variable
+ ; should always be local so the hashtable
+ ; operation isn't necessary.
+ (if (hashtable-get types name)
+ (constraints-add!
+ types
+ constraints
+ (make-type-constraint
+ name
+ type1
+ (available:killer-combine K K2)))
+ (cerror
+ "Compiler bug: unexpected global: "
+ name))))))
+ args argtypes reps))
+
+ (if (not (zero? K))
+ (constraints-add-killedby! constraints T K))
+
+ (let* ((table (constraints.table constraints))
+ (cs (hashtable-fetch table T '())))
+ (cond ((constant? E)
+ ; It's a type constraint.
+ (let ((type (constant.value E)))
+ (if debugging?
+ (begin (display T)
+ (display " : ")
+ (display (rep->symbol type))
+ (newline)))
+ (let ((cs (loop type K cs '())))
+ (hashtable-put! table T cs)
+ constraints)))
+ (else
+ (if debugging?
+ (begin (display T)
+ (display " = ")
+ (display (make-readable E #t))
+ (newline)))
+ (if (not (null? cs))
+ (begin
+ (display "Compiler bug: ")
+ (write T)
+ (display " has unexpectedly nonempty constraints")
+ (newline)))
+ (hashtable-put! table T (list (list T E K)))
+ constraints)))))
+
+; Sets of constraints.
+;
+; The set of constraints is represented as (<hashtable> <killedby>),
+; where <hashtable> is a hashtable mapping variables to lists of
+; constraints as above, and <killedby> is a vector mapping basic killers
+; to lists of variables that need to be examined for constraints that
+; are killed by that basic killer.
+
+(define number-of-basic-killers
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((> k available:killer:dead)
+ i)))
+
+(define (constraints.table constraints) (car constraints))
+(define (constraints.killed constraints) (cadr constraints))
+
+(define (make-constraints-table)
+ (list (make-hashtable symbol-hash assq)
+ (make-vector number-of-basic-killers '())))
+
+(define (copy-constraints-table constraints)
+ (list (hashtable-copy (constraints.table constraints))
+ (list->vector (vector->list (constraints.killed constraints)))))
+
+(define (constraints-for-variable constraints T)
+ (hashtable-fetch (constraints.table constraints) T '()))
+
+(define (constraints-add-killedby! constraints T K0)
+ (if (not (zero? K0))
+ (let ((v (constraints.killed constraints)))
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand k K0)))
+ (vector-set! v i (cons T (vector-ref v i))))))))
+
+(define (constraints-kill! constraints K)
+ (if (not (zero? K))
+ (let ((table (constraints.table constraints))
+ (killed (constraints.killed constraints)))
+ (define (examine! T)
+ (let ((cs (filter (lambda (c)
+ (zero? (logand (constraint.killer c) K)))
+ (hashtable-fetch table T '()))))
+ (if (null? cs)
+ (hashtable-remove! table T)
+ (hashtable-put! table T cs))))
+ (do ((i 0 (+ i 1))
+ (j 1 (+ j j)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand j K)))
+ (begin (for-each examine! (vector-ref killed i))
+ (vector-set! killed i '())))))))
+
+(define (constraints-intersect! constraints0 constraints1 constraints2)
+ (let ((table0 (constraints.table constraints0))
+ (table1 (constraints.table constraints1))
+ (table2 (constraints.table constraints2)))
+ (if (eq? table0 table1)
+ ; FIXME: Which is more efficient: to update the killed vector,
+ ; or not to update it? Both are safe.
+ (hashtable-for-each (lambda (T cs)
+ (if (not (null? cs))
+ (hashtable-put!
+ table0
+ T
+ (cs-intersect
+ (hashtable-fetch table2 T '())
+ cs))))
+ table1)
+ ; This case shouldn't ever happen, so it can be slow.
+ (begin
+ (constraints-intersect! constraints0 constraints0 constraints1)
+ (constraints-intersect! constraints0 constraints0 constraints2)))))
+
+(define (cs-intersect cs1 cs2)
+ (define (loop cs init rep Krep)
+ (if (null? cs)
+ (values init rep Krep)
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c))
+ (K2 (constraint.killer c)))
+ (cond ((constant? E2)
+ (loop cs
+ init
+ (representation-intersection rep (constant.value E2))
+ (available:killer-combine Krep K2)))
+ ((call? E2)
+ (if init
+ (begin (display "Compiler bug in cs-intersect")
+ (break))
+ (loop cs c rep Krep)))
+ (else
+ (error "Compiler bug in cs-intersect"))))))
+ (call-with-values
+ (lambda ()
+ (loop cs1 #f rep:object available:killer:none))
+ (lambda (c1 rep1 Krep1)
+ (call-with-values
+ (lambda ()
+ (loop cs2 #f rep:object available:killer:none))
+ (lambda (c2 rep2 Krep2)
+ (let ((c (if (equal? c1 c2) c1 #f))
+ (rep (representation-union rep1 rep2))
+ (Krep (available:killer-combine Krep1 Krep2)))
+ (if (eq? rep rep:object)
+ (if c (list c) '())
+ (let ((T (constraint.lhs (car cs1))))
+ (if c
+ (list c (make-type-constraint T rep Krep))
+ (list (make-type-constraint T rep Krep)))))))))))
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $gc.ephemeral 0)
+(define $gc.tenuring 1)
+(define $gc.full 2)
+(define $mstat.wallocated-hi 0)
+(define $mstat.wallocated-lo 1)
+(define $mstat.wcollected-hi 2)
+(define $mstat.wcollected-lo 3)
+(define $mstat.wcopied-hi 4)
+(define $mstat.wcopied-lo 5)
+(define $mstat.gctime 6)
+(define $mstat.wlive 7)
+(define $mstat.gc-last-gen 8)
+(define $mstat.gc-last-type 9)
+(define $mstat.generations 10)
+(define $mstat.g-gc-count 0)
+(define $mstat.g-prom-count 1)
+(define $mstat.g-gctime 2)
+(define $mstat.g-wlive 3)
+(define $mstat.g-np-youngp 4)
+(define $mstat.g-np-oldp 5)
+(define $mstat.g-np-j 6)
+(define $mstat.g-np-k 7)
+(define $mstat.g-alloc 8)
+(define $mstat.g-target 9)
+(define $mstat.g-promtime 10)
+(define $mstat.remsets 11)
+(define $mstat.r-apool 0)
+(define $mstat.r-upool 1)
+(define $mstat.r-ahash 2)
+(define $mstat.r-uhash 3)
+(define $mstat.r-hrec-hi 4)
+(define $mstat.r-hrec-lo 5)
+(define $mstat.r-hrem-hi 6)
+(define $mstat.r-hrem-lo 7)
+(define $mstat.r-hscan-hi 8)
+(define $mstat.r-hscan-lo 9)
+(define $mstat.r-wscan-hi 10)
+(define $mstat.r-wscan-lo 11)
+(define $mstat.r-ssbrec-hi 12)
+(define $mstat.r-ssbrec-lo 13)
+(define $mstat.r-np-p 14)
+(define $mstat.fflushed-hi 12)
+(define $mstat.fflushed-lo 13)
+(define $mstat.wflushed-hi 14)
+(define $mstat.wflushed-lo 15)
+(define $mstat.stk-created 16)
+(define $mstat.frestored-hi 17)
+(define $mstat.frestored-lo 18)
+(define $mstat.words-heap 19)
+(define $mstat.words-remset 20)
+(define $mstat.words-rts 21)
+(define $mstat.swb-assign 22)
+(define $mstat.swb-lhs-ok 23)
+(define $mstat.swb-rhs-const 24)
+(define $mstat.swb-not-xgen 25)
+(define $mstat.swb-trans 26)
+(define $mstat.rtime 27)
+(define $mstat.stime 28)
+(define $mstat.utime 29)
+(define $mstat.minfaults 30)
+(define $mstat.majfaults 31)
+(define $mstat.np-remsetp 32)
+(define $mstat.max-heap 33)
+(define $mstat.promtime 34)
+(define $mstat.wmoved-hi 35)
+(define $mstat.wmoved-lo 36)
+(define $mstat.vsize 37)
+(define $g.reg0 12)
+(define $r.reg8 44)
+(define $r.reg9 48)
+(define $r.reg10 52)
+(define $r.reg11 56)
+(define $r.reg12 60)
+(define $r.reg13 64)
+(define $r.reg14 68)
+(define $r.reg15 72)
+(define $r.reg16 76)
+(define $r.reg17 80)
+(define $r.reg18 84)
+(define $r.reg19 88)
+(define $r.reg20 92)
+(define $r.reg21 96)
+(define $r.reg22 100)
+(define $r.reg23 104)
+(define $r.reg24 108)
+(define $r.reg25 112)
+(define $r.reg26 116)
+(define $r.reg27 120)
+(define $r.reg28 124)
+(define $r.reg29 128)
+(define $r.reg30 132)
+(define $r.reg31 136)
+(define $g.stkbot 180)
+(define $g.gccnt 420)
+(define $m.alloc 1024)
+(define $m.alloci 1032)
+(define $m.gc 1040)
+(define $m.addtrans 1048)
+(define $m.stkoflow 1056)
+(define $m.stkuflow 1072)
+(define $m.creg 1080)
+(define $m.creg-set! 1088)
+(define $m.add 1096)
+(define $m.subtract 1104)
+(define $m.multiply 1112)
+(define $m.quotient 1120)
+(define $m.remainder 1128)
+(define $m.divide 1136)
+(define $m.modulo 1144)
+(define $m.negate 1152)
+(define $m.numeq 1160)
+(define $m.numlt 1168)
+(define $m.numle 1176)
+(define $m.numgt 1184)
+(define $m.numge 1192)
+(define $m.zerop 1200)
+(define $m.complexp 1208)
+(define $m.realp 1216)
+(define $m.rationalp 1224)
+(define $m.integerp 1232)
+(define $m.exactp 1240)
+(define $m.inexactp 1248)
+(define $m.exact->inexact 1256)
+(define $m.inexact->exact 1264)
+(define $m.make-rectangular 1272)
+(define $m.real-part 1280)
+(define $m.imag-part 1288)
+(define $m.sqrt 1296)
+(define $m.round 1304)
+(define $m.truncate 1312)
+(define $m.apply 1320)
+(define $m.varargs 1328)
+(define $m.typetag 1336)
+(define $m.typetag-set 1344)
+(define $m.break 1352)
+(define $m.eqv 1360)
+(define $m.partial-list->vector 1368)
+(define $m.timer-exception 1376)
+(define $m.exception 1384)
+(define $m.singlestep 1392)
+(define $m.syscall 1400)
+(define $m.bvlcmp 1408)
+(define $m.enable-interrupts 1416)
+(define $m.disable-interrupts 1424)
+(define $m.alloc-bv 1432)
+(define $m.global-ex 1440)
+(define $m.invoke-ex 1448)
+(define $m.global-invoke-ex 1456)
+(define $m.argc-ex 1464)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $r.g0 0)
+(define $r.g1 1)
+(define $r.g2 2)
+(define $r.g3 3)
+(define $r.g4 4)
+(define $r.g5 5)
+(define $r.g6 6)
+(define $r.g7 7)
+(define $r.o0 8)
+(define $r.o1 9)
+(define $r.o2 10)
+(define $r.o3 11)
+(define $r.o4 12)
+(define $r.o5 13)
+(define $r.o6 14)
+(define $r.o7 15)
+(define $r.l0 16)
+(define $r.l1 17)
+(define $r.l2 18)
+(define $r.l3 19)
+(define $r.l4 20)
+(define $r.l5 21)
+(define $r.l6 22)
+(define $r.l7 23)
+(define $r.i0 24)
+(define $r.i1 25)
+(define $r.i2 26)
+(define $r.i3 27)
+(define $r.i4 28)
+(define $r.i5 29)
+(define $r.i6 30)
+(define $r.i7 31)
+(define $r.result $r.o0)
+(define $r.argreg2 $r.o1)
+(define $r.argreg3 $r.o2)
+(define $r.stkp $r.o3)
+(define $r.stklim $r.i0)
+(define $r.tmp1 $r.o4)
+(define $r.tmp2 $r.o5)
+(define $r.tmp0 $r.g1)
+(define $r.e-top $r.i0)
+(define $r.e-limit $r.o3)
+(define $r.timer $r.i4)
+(define $r.millicode $r.i7)
+(define $r.globals $r.i7)
+(define $r.reg0 $r.l0)
+(define $r.reg1 $r.l1)
+(define $r.reg2 $r.l2)
+(define $r.reg3 $r.l3)
+(define $r.reg4 $r.l4)
+(define $r.reg5 $r.l5)
+(define $r.reg6 $r.l6)
+(define $r.reg7 $r.l7)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $ex.car 0)
+(define $ex.cdr 1)
+(define $ex.setcar 2)
+(define $ex.setcdr 3)
+(define $ex.add 10)
+(define $ex.sub 11)
+(define $ex.mul 12)
+(define $ex.div 13)
+(define $ex.lessp 14)
+(define $ex.lesseqp 15)
+(define $ex.equalp 16)
+(define $ex.greatereqp 17)
+(define $ex.greaterp 18)
+(define $ex.quotient 19)
+(define $ex.remainder 20)
+(define $ex.modulo 21)
+(define $ex.logior 22)
+(define $ex.logand 23)
+(define $ex.logxor 24)
+(define $ex.lognot 25)
+(define $ex.lsh 26)
+(define $ex.rsha 27)
+(define $ex.rshl 28)
+(define $ex.e2i 29)
+(define $ex.i2e 30)
+(define $ex.exactp 31)
+(define $ex.inexactp 32)
+(define $ex.round 33)
+(define $ex.trunc 34)
+(define $ex.zerop 35)
+(define $ex.neg 36)
+(define $ex.abs 37)
+(define $ex.realpart 38)
+(define $ex.imagpart 39)
+(define $ex.vref 40)
+(define $ex.vset 41)
+(define $ex.vlen 42)
+(define $ex.pref 50)
+(define $ex.pset 51)
+(define $ex.plen 52)
+(define $ex.sref 60)
+(define $ex.sset 61)
+(define $ex.slen 62)
+(define $ex.bvref 70)
+(define $ex.bvset 71)
+(define $ex.bvlen 72)
+(define $ex.bvlref 80)
+(define $ex.bvlset 81)
+(define $ex.bvllen 82)
+(define $ex.vlref 90)
+(define $ex.vlset 91)
+(define $ex.vllen 92)
+(define $ex.typetag 100)
+(define $ex.typetagset 101)
+(define $ex.apply 102)
+(define $ex.argc 103)
+(define $ex.vargc 104)
+(define $ex.nonproc 105)
+(define $ex.undef-global 106)
+(define $ex.dump 107)
+(define $ex.dumpfail 108)
+(define $ex.timer 109)
+(define $ex.unsupported 110)
+(define $ex.int2char 111)
+(define $ex.char2int 112)
+(define $ex.mkbvl 113)
+(define $ex.mkvl 114)
+(define $ex.char<? 115)
+(define $ex.char<=? 116)
+(define $ex.char=? 117)
+(define $ex.char>? 118)
+(define $ex.char>=? 119)
+(define $ex.bvfill 120)
+(define $ex.enable-interrupts 121)
+(define $ex.keyboard-interrupt 122)
+(define $ex.arithmetic-exception 123)
+(define $ex.global-invoke 124)
+(define $ex.fx+ 140)
+(define $ex.fx- 141)
+(define $ex.fx-- 142)
+(define $ex.fx= 143)
+(define $ex.fx< 144)
+(define $ex.fx<= 145)
+(define $ex.fx> 146)
+(define $ex.fx>= 147)
+(define $ex.fxpositive? 148)
+(define $ex.fxnegative? 149)
+(define $ex.fxzero? 150)
+(define $ex.fx* 151)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $tag.tagmask 7)
+(define $tag.pair-tag 1)
+(define $tag.vector-tag 3)
+(define $tag.bytevector-tag 5)
+(define $tag.procedure-tag 7)
+(define $imm.vector-header 162)
+(define $imm.bytevector-header 194)
+(define $imm.procedure-header 254)
+(define $imm.true 6)
+(define $imm.false 2)
+(define $imm.null 10)
+(define $imm.unspecified 278)
+(define $imm.eof 534)
+(define $imm.undefined 790)
+(define $imm.character 38)
+(define $tag.vector-typetag 0)
+(define $tag.rectnum-typetag 4)
+(define $tag.ratnum-typetag 8)
+(define $tag.symbol-typetag 12)
+(define $tag.port-typetag 16)
+(define $tag.structure-typetag 20)
+(define $tag.bytevector-typetag 0)
+(define $tag.string-typetag 4)
+(define $tag.flonum-typetag 8)
+(define $tag.compnum-typetag 12)
+(define $tag.bignum-typetag 16)
+(define $hdr.port 178)
+(define $hdr.struct 182)
+(define $p.codevector -3)
+(define $p.constvector 1)
+(define $p.linkoffset 5)
+(define $p.reg0 5)
+(define $p.codeoffset -1)
+; Copyright 1991 William Clinger
+;
+; Relatively target-independent information for Twobit's backend.
+;
+; 24 April 1999 / wdc
+;
+; Most of the definitions in this file can be extended or overridden by
+; target-specific definitions.
+
+(define twobit-sort
+ (lambda (less? list) (compat:sort list less?)))
+
+(define renaming-prefix ".")
+
+; The prefix used for cells introduced by the compiler.
+
+(define cell-prefix (string-append renaming-prefix "CELL:"))
+
+; Names of global procedures that cannot be redefined or assigned
+; by ordinary code.
+; The expansion of quasiquote uses .cons and .list directly, so these
+; should not be changed willy-nilly.
+; Others may be used directly by a DEFINE-INLINE.
+
+(define name:CHECK! '.check!)
+(define name:CONS '.cons)
+(define name:LIST '.list)
+(define name:MAKE-CELL '.make-cell)
+(define name:CELL-REF '.cell-ref)
+(define name:CELL-SET! '.cell-set!)
+(define name:IGNORED (string->symbol "IGNORED"))
+(define name:CAR '.car)
+(define name:CDR '.cdr)
+
+;(begin (eval `(define ,name:CONS cons))
+; (eval `(define ,name:LIST list))
+; (eval `(define ,name:MAKE-CELL list))
+; (eval `(define ,name:CELL-REF car))
+; (eval `(define ,name:CELL-SET! set-car!)))
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures.
+
+(define name:NOT 'not)
+(define name:MEMQ 'memq)
+(define name:MEMV 'memv)
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures and also creates calls to them.
+
+(define name:EQ? 'eq?)
+(define name:EQV? 'eqv?)
+
+; Control optimization creates calls to these procedures,
+; which do not need to check their arguments.
+
+(define name:FIXNUM? 'fixnum?)
+(define name:CHAR? 'char?)
+(define name:SYMBOL? 'symbol?)
+(define name:FX< '<:fix:fix)
+(define name:FX- 'fx-) ; non-checking version
+(define name:CHAR->INTEGER 'char->integer) ; non-checking version
+(define name:VECTOR-REF 'vector-ref:trusted)
+
+
+; Constant folding.
+; Prototype, will probably change in the future.
+
+(define (constant-folding-entry name)
+ (assq name $usual-constant-folding-procedures$))
+
+(define constant-folding-predicates cadr)
+(define constant-folding-folder caddr)
+
+(define $usual-constant-folding-procedures$
+ (let ((always? (lambda (x) #t))
+ (charcode? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (<= 0 n)
+ (< n 128))))
+ (ratnum? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (rational? n))))
+ ; smallint? is defined later.
+ (smallint? (lambda (n) (smallint? n))))
+ `(
+ ; This makes some assumptions about the host system.
+
+ (integer->char (,charcode?) ,integer->char)
+ (char->integer (,char?) ,char->integer)
+ (zero? (,ratnum?) ,zero?)
+ (< (,ratnum? ,ratnum?) ,<)
+ (<= (,ratnum? ,ratnum?) ,<=)
+ (= (,ratnum? ,ratnum?) ,=)
+ (>= (,ratnum? ,ratnum?) ,>=)
+ (> (,ratnum? ,ratnum?) ,>)
+ (+ (,ratnum? ,ratnum?) ,+)
+ (- (,ratnum? ,ratnum?) ,-)
+ (* (,ratnum? ,ratnum?) ,*)
+ (-- (,ratnum?) ,(lambda (x) (- 0 x)))
+ (eq? (,always? ,always?) ,eq?)
+ (eqv? (,always? ,always?) ,eqv?)
+ (equal? (,always? ,always?) ,equal?)
+ (memq (,always? ,list?) ,memq)
+ (memv (,always? ,list?) ,memv)
+ (member (,always? ,list?) ,member)
+ (assq (,always? ,list?) ,assq)
+ (assv (,always? ,list?) ,assv)
+ (assoc (,always? ,list?) ,assoc)
+ (length (,list?) ,length)
+ (fixnum? (,smallint?) ,smallint?)
+ (=:fix:fix (,smallint? ,smallint?) ,=)
+ (<:fix:fix (,smallint? ,smallint?) ,<)
+ (<=:fix:fix (,smallint? ,smallint?) ,<=)
+ (>:fix:fix (,smallint? ,smallint?) ,>)
+ (>=:fix:fix (,smallint? ,smallint?) ,>=)
+ )))
+
+(begin '
+ (define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+ #t)
+
+; Order matters. If f and g are both inlined, and the definition of g
+; uses f, then f should be defined before g.
+
+(for-each pass1
+ `(
+
+(define-inline car
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.car x)
+ (car:pair x)))))
+
+(define-inline cdr
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.cdr x)
+ (cdr:pair x)))))
+
+(define-inline vector-length
+ (syntax-rules ()
+ ((vector-length v0)
+ (let ((v v0))
+ (.check! (vector? v) ,$ex.vlen v)
+ (vector-length:vec v)))))
+
+(define-inline vector-ref
+ (syntax-rules ()
+ ((vector-ref v0 i0)
+ (let ((v v0)
+ (i i0))
+ (.check! (fixnum? i) ,$ex.vref v i)
+ (.check! (vector? v) ,$ex.vref v i)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vref v i)
+ (.check! (>=:fix:fix i 0) ,$ex.vref v i)
+ (vector-ref:trusted v i)))))
+
+(define-inline vector-set!
+ (syntax-rules ()
+ ((vector-set! v0 i0 x0)
+ (let ((v v0)
+ (i i0)
+ (x x0))
+ (.check! (fixnum? i) ,$ex.vset v i x)
+ (.check! (vector? v) ,$ex.vset v i x)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vset v i x)
+ (.check! (>=:fix:fix i 0) ,$ex.vset v i x)
+ (vector-set!:trusted v i x)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to LIST returns more than once.
+
+(define-inline list
+ (syntax-rules ()
+ ((list)
+ '())
+ ((list ?e)
+ (cons ?e '()))
+ ((list ?e1 ?e2 ...)
+ (let* ((t1 ?e1)
+ (t2 (list ?e2 ...)))
+ (cons t1 t2)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to VECTOR returns more than once.
+
+(define-inline vector
+ (syntax-rules ()
+ ((vector)
+ '#())
+ ((vector ?e)
+ (make-vector 1 ?e))
+ ((vector ?e1 ?e2 ...)
+ (letrec-syntax
+ ((vector-aux1
+ (... (syntax-rules ()
+ ((vector-aux1 () ?n ?exps ?indexes ?temps)
+ (vector-aux2 ?n ?exps ?indexes ?temps))
+ ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps)
+ (vector-aux1 (?exp2 ...)
+ (+ ?n 1)
+ (?exp1 . ?exps)
+ (?n . ?indexes)
+ (t . ?temps))))))
+ (vector-aux2
+ (... (syntax-rules ()
+ ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...))
+ (let* ((?t1 ?exp1)
+ (?t2 ?exp2)
+ ...
+ (v (make-vector ?n ?t1)))
+ (vector-set! v ?n2 ?t2)
+ ...
+ v))))))
+ (vector-aux1 (?e1 ?e2 ...) 0 () () ())))))
+
+(define-inline cadddr
+ (syntax-rules ()
+ ((cadddr ?e)
+ (car (cdr (cdr (cdr ?e)))))))
+
+(define-inline cddddr
+ (syntax-rules ()
+ ((cddddr ?e)
+ (cdr (cdr (cdr (cdr ?e)))))))
+
+(define-inline cdddr
+ (syntax-rules ()
+ ((cdddr ?e)
+ (cdr (cdr (cdr ?e))))))
+
+(define-inline caddr
+ (syntax-rules ()
+ ((caddr ?e)
+ (car (cdr (cdr ?e))))))
+
+(define-inline cddr
+ (syntax-rules ()
+ ((cddr ?e)
+ (cdr (cdr ?e)))))
+
+(define-inline cdar
+ (syntax-rules ()
+ ((cdar ?e)
+ (cdr (car ?e)))))
+
+(define-inline cadr
+ (syntax-rules ()
+ ((cadr ?e)
+ (car (cdr ?e)))))
+
+(define-inline caar
+ (syntax-rules ()
+ ((caar ?e)
+ (car (car ?e)))))
+
+(define-inline make-vector
+ (syntax-rules ()
+ ((make-vector ?n)
+ (make-vector ?n '()))))
+
+(define-inline make-string
+ (syntax-rules ()
+ ((make-string ?n)
+ (make-string ?n #\space))))
+
+(define-inline =
+ (syntax-rules ()
+ ((= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (= ?e1 t)
+ (= t ?e3 ?e4 ...))))))
+
+(define-inline <
+ (syntax-rules ()
+ ((< ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (< ?e1 t)
+ (< t ?e3 ?e4 ...))))))
+
+(define-inline >
+ (syntax-rules ()
+ ((> ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (> ?e1 t)
+ (> t ?e3 ?e4 ...))))))
+
+(define-inline <=
+ (syntax-rules ()
+ ((<= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (<= ?e1 t)
+ (<= t ?e3 ?e4 ...))))))
+
+(define-inline >=
+ (syntax-rules ()
+ ((>= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (>= ?e1 t)
+ (>= t ?e3 ?e4 ...))))))
+
+(define-inline +
+ (syntax-rules ()
+ ((+)
+ 0)
+ ((+ ?e)
+ ?e)
+ ((+ ?e1 ?e2 ?e3 ?e4 ...)
+ (+ (+ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline *
+ (syntax-rules ()
+ ((*)
+ 1)
+ ((* ?e)
+ ?e)
+ ((* ?e1 ?e2 ?e3 ?e4 ...)
+ (* (* ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline -
+ (syntax-rules ()
+ ((- ?e)
+ (- 0 ?e))
+ ((- ?e1 ?e2 ?e3 ?e4 ...)
+ (- (- ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline /
+ (syntax-rules ()
+ ((/ ?e)
+ (/ 1 ?e))
+ ((/ ?e1 ?e2 ?e3 ?e4 ...)
+ (/ (/ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline abs
+ (syntax-rules ()
+ ((abs ?z)
+ (let ((temp ?z))
+ (if (< temp 0)
+ (-- temp)
+ temp)))))
+
+(define-inline negative?
+ (syntax-rules ()
+ ((negative? ?x)
+ (< ?x 0))))
+
+(define-inline positive?
+ (syntax-rules ()
+ ((positive? ?x)
+ (> ?x 0))))
+
+(define-inline eqv?
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (define (constant? exp)
+ (or (boolean? exp)
+ (char? exp)
+ (and (pair? exp)
+ (= (length exp) 2)
+ (identifier? (car exp))
+ (compare (car exp) (rename 'quote))
+ (symbol? (cadr exp)))))
+ (if (or (constant? arg1)
+ (constant? arg2))
+ (cons (rename 'eq?) (cdr exp))
+ exp)))))
+
+(define-inline memq
+ (syntax-rules (quote)
+ ((memq ?expr '(?datum ...))
+ (letrec-syntax
+ ((memq0
+ (... (syntax-rules (quote)
+ ((memq0 '?xx '(?d ...))
+ (let ((t1 '(?d ...)))
+ (memq1 '?xx t1 (?d ...))))
+ ((memq0 ?e '(?d ...))
+ (let ((t0 ?e)
+ (t1 '(?d ...)))
+ (memq1 t0 t1 (?d ...)))))))
+ (memq1
+ (... (syntax-rules ()
+ ((memq1 ?t0 ?t1 ())
+ #f)
+ ((memq1 ?t0 ?t1 (?d1 ?d2 ...))
+ (if (eq? ?t0 '?d1)
+ ?t1
+ (let ((?t1 (cdr ?t1)))
+ (memq1 ?t0 ?t1 (?d2 ...)))))))))
+ (memq0 ?expr '(?datum ...))))))
+
+(define-inline memv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (fixnum? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (x)
+ (or (boolean? x)
+ (fixnum? x)
+ (char? x)
+ (symbol? x)))
+ (cadr arg2))))
+ (cons (rename 'memq) (cdr exp))
+ exp)))))
+
+(define-inline assv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (y)
+ (and (pair? y)
+ (let ((x (car y)))
+ (or (boolean? x)
+ (char? x)
+ (symbol? x)))))
+ (cadr arg2))))
+ (cons (rename 'assq) (cdr exp))
+ exp)))))
+
+(define-inline map
+ (syntax-rules (lambda)
+ ((map ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...
+ (results '() (cons (?f (car ?y1) (car ?y2) ...)
+ results)))
+ ((or (null? ?y1) (null? ?y2) ...)
+ (reverse results))))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+(define-inline for-each
+ (syntax-rules (lambda)
+ ((for-each ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...)
+ ((or (null? ?y1) (null? ?y2) ...)
+ (if #f #f))
+ (?f (car ?y1) (car ?y2) ...)))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+))
+
+(define extended-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-extended-syntactic-environment)
+ (syntactic-copy extended-syntactic-environment))
+
+; MacScheme machine assembly instructions.
+
+(define instruction.op car)
+(define instruction.arg1 cadr)
+(define instruction.arg2 caddr)
+(define instruction.arg3 cadddr)
+
+; Opcode table.
+
+(define *mnemonic-names* '()) ; For readify-lap
+(begin
+ '
+ (define *last-reserved-mnemonic* 32767) ; For consistency check
+ '
+ (define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (if (= count *last-reserved-mnemonic*)
+ (error "Error in make-mnemonic: conflict: " name))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+ '
+ (define (reserved-mnemonic name value)
+ (if (and (> value 0) (< value *last-reserved-mnemonic*))
+ (set! *last-reserved-mnemonic* value))
+ (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*))
+ value)
+ #t)
+
+(define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+
+(define (reserved-mnemonic name ignored)
+ (make-mnemonic name))
+
+(define $.linearize (reserved-mnemonic '.linearize -1)) ; unused?
+(define $.label (reserved-mnemonic '.label 63))
+(define $.proc (reserved-mnemonic '.proc 62)) ; proc entry point
+(define $.cont (reserved-mnemonic '.cont 61)) ; return point
+(define $.align (reserved-mnemonic '.align 60)) ; align code stream
+(define $.asm (reserved-mnemonic '.asm 59)) ; in-line native code
+(define $.proc-doc ; internal def proc info
+ (reserved-mnemonic '.proc-doc 58))
+(define $.end ; end of code vector
+ (reserved-mnemonic '.end 57)) ; (asm internal)
+(define $.singlestep ; insert singlestep point
+ (reserved-mnemonic '.singlestep 56)) ; (asm internal)
+(define $.entry (reserved-mnemonic '.entry 55)) ; procedure entry point
+ ; (asm internal)
+
+(define $op1 (make-mnemonic 'op1)) ; op prim
+(define $op2 (make-mnemonic 'op2)) ; op2 prim,k
+(define $op3 (make-mnemonic 'op3)) ; op3 prim,k1,k2
+(define $op2imm (make-mnemonic 'op2imm)) ; op2imm prim,x
+(define $const (make-mnemonic 'const)) ; const x
+(define $global (make-mnemonic 'global)) ; global x
+(define $setglbl (make-mnemonic 'setglbl)) ; setglbl x
+(define $lexical (make-mnemonic 'lexical)) ; lexical m,n
+(define $setlex (make-mnemonic 'setlex)) ; setlex m,n
+(define $stack (make-mnemonic 'stack)) ; stack n
+(define $setstk (make-mnemonic 'setstk)) ; setstk n
+(define $load (make-mnemonic 'load)) ; load k,n
+(define $store (make-mnemonic 'store)) ; store k,n
+(define $reg (make-mnemonic 'reg)) ; reg k
+(define $setreg (make-mnemonic 'setreg)) ; setreg k
+(define $movereg (make-mnemonic 'movereg)) ; movereg k1,k2
+(define $lambda (make-mnemonic 'lambda)) ; lambda x,n,doc
+(define $lexes (make-mnemonic 'lexes)) ; lexes n,doc
+(define $args= (make-mnemonic 'args=)) ; args= k
+(define $args>= (make-mnemonic 'args>=)) ; args>= k
+(define $invoke (make-mnemonic 'invoke)) ; invoke k
+(define $save (make-mnemonic 'save)) ; save L,k
+(define $setrtn (make-mnemonic 'setrtn)) ; setrtn L
+(define $restore (make-mnemonic 'restore)) ; restore n ; deprecated
+(define $pop (make-mnemonic 'pop)) ; pop k
+(define $popstk (make-mnemonic 'popstk)) ; popstk ; for students
+(define $return (make-mnemonic 'return)) ; return
+(define $mvrtn (make-mnemonic 'mvrtn)) ; mvrtn ; NYI
+(define $apply (make-mnemonic 'apply)) ; apply
+(define $nop (make-mnemonic 'nop)) ; nop
+(define $jump (make-mnemonic 'jump)) ; jump m,o
+(define $skip (make-mnemonic 'skip)) ; skip L ; forward
+(define $branch (make-mnemonic 'branch)) ; branch L
+(define $branchf (make-mnemonic 'branchf)) ; branchf L
+(define $check (make-mnemonic 'check)) ; check k1,k2,k3,L
+(define $trap (make-mnemonic 'trap)) ; trap k1,k2,k3,exn
+
+; A peephole optimizer may define more instructions in some
+; target-specific file.
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- target-specific information for Twobit's SPARC backend.
+;
+; 11 June 1999 / wdc
+
+; The maximum number of fixed arguments that may be followed by a rest
+; argument. This limitation is removed by the macro expander.
+
+(define @maxargs-with-rest-arg@ 30)
+
+; The number of MacScheme machine registers.
+; (They do not necessarily correspond to hardware registers.)
+
+(define *nregs* 32)
+(define *lastreg* (- *nregs* 1))
+(define *fullregs* (quotient *nregs* 2))
+
+; The number of argument registers that are represented by hardware
+; registers.
+
+(define *nhwregs* 8)
+
+; Variable names that indicate register targets.
+
+(define *regnames*
+ (do ((alist '() (cons (cons (string->symbol
+ (string-append ".REG" (number->string r)))
+ r)
+ alist))
+ (r (- *nhwregs* 1) (- r 1)))
+ ((<= r 0)
+ alist)))
+
+; A non-inclusive upper bound for the instruction encodings.
+
+(define *number-of-mnemonics* 72)
+
+; Integrable procedures and procedure-specific source code transformations.
+; Every integrable procedure that takes a varying number of arguments must
+; supply a transformation procedure to map calls into the fixed arity
+; required by the MacScheme machine instructions.
+
+; The table of integrable procedures.
+; Each entry is a list of the following items:
+;
+; procedure name
+; arity (or -1 for special primops like .check!)
+; procedure name to be used by the disassembler
+; predicate for immediate operands (or #f)
+; primop code in the MacScheme machine (not used by Larceny)
+; the effects that kill this primop's result
+; the effects of this primop that kill available expressions
+
+(define (prim-entry name)
+ (assq name $usual-integrable-procedures$))
+
+(define prim-arity cadr)
+(define prim-opcodename caddr)
+(define prim-immediate? cadddr)
+(define (prim-primcode entry)
+ (car (cddddr entry)))
+
+; This predicate returns #t iff its argument will be represented
+; as a fixnum on the target machine.
+
+(define smallint?
+ (let* ((least (- (expt 2 29)))
+ (greatest (- (- least) 1)))
+ (lambda (x)
+ (and (number? x)
+ (exact? x)
+ (integer? x)
+ (<= least x greatest)))))
+
+(define (sparc-imm? x)
+ (and (fixnum? x)
+ (<= -1024 x 1023)))
+
+(define (sparc-eq-imm? x)
+ (or (sparc-imm? x)
+ (eq? x #t)
+ (eq? x #f)
+ (eq? x '())))
+
+(define (valid-typetag? x)
+ (and (fixnum? x)
+ (<= 0 x 7)))
+
+(define (fixnum-primitives) #t)
+(define (flonum-primitives) #t)
+
+; The table of primitives has been extended with
+; kill information used for commoning.
+
+(define (prim-lives-until entry)
+ (list-ref entry 5))
+
+(define (prim-kills entry)
+ (list-ref entry 6))
+
+(define $usual-integrable-procedures$
+ (let ((:globals available:killer:globals)
+ (:car available:killer:car)
+ (:cdr available:killer:cdr)
+ (:string available:killer:string)
+ (:vector available:killer:vector)
+ (:cell available:killer:cell)
+ (:io available:killer:io)
+ (:none available:killer:none) ; none of the above
+ (:all available:killer:all) ; all of the above
+ (:immortal available:killer:immortal) ; never killed
+ (:dead available:killer:dead) ; never available
+ )
+
+; external arity internal immediate ignored killed kills
+; name name predicate by what
+; kind of
+; effect
+
+ `((break 0 break #f 3 ,:dead ,:all)
+ (creg 0 creg #f 7 ,:dead ,:all)
+ (unspecified 0 unspecified #f -1 ,:dead ,:none)
+ (undefined 0 undefined #f 8 ,:dead ,:none)
+ (eof-object 0 eof-object #f -1 ,:dead ,:none)
+ (enable-interrupts 1 enable-interrupts #f -1 ,:dead ,:all)
+ (disable-interrupts 0 disable-interrupts #f -1 ,:dead ,:all)
+
+ (typetag 1 typetag #f #x11 ,:dead ,:none)
+ (not 1 not #f #x18 ,:immortal ,:none)
+ (null? 1 null? #f #x19 ,:immortal ,:none)
+ (pair? 1 pair? #f #x1a ,:immortal ,:none)
+ (eof-object? 1 eof-object? #f -1 ,:immortal ,:none)
+ (port? 1 port? #f -1 ,:dead ,:none)
+ (structure? 1 structure? #f -1 ,:dead ,:none)
+ (car 1 car #f #x1b ,:car ,:none)
+ (,name:CAR 1 car #f #x1b ,:car ,:none)
+ (cdr 1 cdr #f #x1c ,:cdr ,:none)
+ (,name:CDR 1 cdr #f #x1c ,:cdr ,:none)
+ (symbol? 1 symbol? #f #x1f ,:immortal ,:none)
+ (number? 1 complex? #f #x20 ,:immortal ,:none)
+ (complex? 1 complex? #f #x20 ,:immortal ,:none)
+ (real? 1 rational? #f #x21 ,:immortal ,:none)
+ (rational? 1 rational? #f #x21 ,:immortal ,:none)
+ (integer? 1 integer? #f #x22 ,:immortal ,:none)
+ (fixnum? 1 fixnum? #f #x23 ,:immortal ,:none)
+ (flonum? 1 flonum? #f -1 ,:immortal ,:none)
+ (compnum? 1 compnum? #f -1 ,:immortal ,:none)
+ (exact? 1 exact? #f #x24 ,:immortal ,:none)
+ (inexact? 1 inexact? #f #x25 ,:immortal ,:none)
+ (exact->inexact 1 exact->inexact #f #x26 ,:immortal ,:none)
+ (inexact->exact 1 inexact->exact #f #x27 ,:immortal ,:none)
+ (round 1 round #f #x28 ,:immortal ,:none)
+ (truncate 1 truncate #f #x29 ,:immortal ,:none)
+ (zero? 1 zero? #f #x2c ,:immortal ,:none)
+ (-- 1 -- #f #x2d ,:immortal ,:none)
+ (lognot 1 lognot #f #x2f ,:immortal ,:none)
+ (real-part 1 real-part #f #x3e ,:immortal ,:none)
+ (imag-part 1 imag-part #f #x3f ,:immortal ,:none)
+ (char? 1 char? #f #x40 ,:immortal ,:none)
+ (char->integer 1 char->integer #f #x41 ,:immortal ,:none)
+ (integer->char 1 integer->char #f #x42 ,:immortal ,:none)
+ (string? 1 string? #f #x50 ,:immortal ,:none)
+ (string-length 1 string-length #f #x51 ,:immortal ,:none)
+ (vector? 1 vector? #f #x52 ,:immortal ,:none)
+ (vector-length 1 vector-length #f #x53 ,:immortal ,:none)
+ (bytevector? 1 bytevector? #f #x54 ,:immortal ,:none)
+ (bytevector-length 1 bytevector-length #f #x55 ,:immortal ,:none)
+ (bytevector-fill! 2 bytevector-fill! #f -1 ,:dead ,:string)
+ (make-bytevector 1 make-bytevector #f #x56 ,:dead ,:none)
+ (procedure? 1 procedure? #f #x58 ,:immortal ,:none)
+ (procedure-length 1 procedure-length #f #x59 ,:dead ,:none)
+ (make-procedure 1 make-procedure #f #x5a ,:dead ,:none)
+ (creg-set! 1 creg-set! #f #x71 ,:dead ,:none)
+ (,name:MAKE-CELL 1 make-cell #f #x7e ,:dead ,:none)
+ (,name:CELL-REF 1 cell-ref #f #x7f ,:cell ,:none)
+ (,name:CELL-SET! 2 cell-set! #f #xdf ,:dead ,:cell)
+ (typetag-set! 2 typetag-set! ,valid-typetag? #xa0 ,:dead ,:all)
+ (eq? 2 eq? ,sparc-eq-imm? #xa1 ,:immortal ,:none)
+ (eqv? 2 eqv? #f #xa2 ,:immortal ,:none)
+ (cons 2 cons #f #xa8 ,:dead ,:none)
+ (,name:CONS 2 cons #f #xa8 ,:dead ,:none)
+ (set-car! 2 set-car! #f #xa9 ,:dead ,:car)
+ (set-cdr! 2 set-cdr! #f #xaa ,:dead ,:cdr)
+ (+ 2 + ,sparc-imm? #xb0 ,:immortal ,:none)
+ (- 2 - ,sparc-imm? #xb1 ,:immortal ,:none)
+ (* 2 * ,sparc-imm? #xb2 ,:immortal ,:none)
+ (/ 2 / #f #xb3 ,:immortal ,:none)
+ (quotient 2 quotient #f #xb4 ,:immortal ,:none)
+ (< 2 < ,sparc-imm? #xb5 ,:immortal ,:none)
+ (<= 2 <= ,sparc-imm? #xb6 ,:immortal ,:none)
+ (= 2 = ,sparc-imm? #xb7 ,:immortal ,:none)
+ (> 2 > ,sparc-imm? #xb8 ,:immortal ,:none)
+ (>= 2 >= ,sparc-imm? #xb9 ,:immortal ,:none)
+ (logand 2 logand #f #xc0 ,:immortal ,:none)
+ (logior 2 logior #f #xc1 ,:immortal ,:none)
+ (logxor 2 logxor #f #xc2 ,:immortal ,:none)
+ (lsh 2 lsh #f #xc3 ,:immortal ,:none)
+ (rsha 2 rsha #f -1 ,:immortal ,:none)
+ (rshl 2 rshl #f -1 ,:immortal ,:none)
+ (rot 2 rot #f #xc4 ,:immortal ,:none)
+ (make-string 2 make-string #f -1 ,:dead ,:none)
+ (string-ref 2 string-ref ,sparc-imm? #xd1 ,:string ,:none)
+ (string-set! 3 string-set! ,sparc-imm? -1 ,:dead ,:string)
+ (make-vector 2 make-vector #f #xd2 ,:dead ,:none)
+ (vector-ref 2 vector-ref ,sparc-imm? #xd3 ,:vector ,:none)
+ (bytevector-ref 2 bytevector-ref ,sparc-imm? #xd5 ,:string ,:none)
+ (procedure-ref 2 procedure-ref #f #xd7 ,:dead ,:none)
+ (char<? 2 char<? ,char? #xe0 ,:immortal ,:none)
+ (char<=? 2 char<=? ,char? #xe1 ,:immortal ,:none)
+ (char=? 2 char=? ,char? #xe2 ,:immortal ,:none)
+ (char>? 2 char>? ,char? #xe3 ,:immortal ,:none)
+ (char>=? 2 char>=? ,char? #xe4 ,:immortal ,:none)
+
+ (sys$partial-list->vector 2 sys$partial-list->vector #f -1 ,:dead ,:all)
+ (vector-set! 3 vector-set! #f #xf1 ,:dead ,:vector)
+ (bytevector-set! 3 bytevector-set! #f #xf2 ,:dead ,:string)
+ (procedure-set! 3 procedure-set! #f #xf3 ,:dead ,:all)
+ (bytevector-like? 1 bytevector-like? #f -1 ,:immortal ,:none)
+ (vector-like? 1 vector-like? #f -1 ,:immortal ,:none)
+ (bytevector-like-ref 2 bytevector-like-ref #f -1 ,:string ,:none)
+ (bytevector-like-set! 3 bytevector-like-set! #f -1 ,:dead ,:string)
+ (sys$bvlcmp 2 sys$bvlcmp #f -1 ,:dead ,:all)
+ (vector-like-ref 2 vector-like-ref #f -1 ,:vector ,:none)
+ (vector-like-set! 3 vector-like-set! #f -1 ,:dead ,:vector)
+ (vector-like-length 1 vector-like-length #f -1 ,:immortal ,:none)
+ (bytevector-like-length 1 bytevector-like-length #f -1 ,:immortal ,:none)
+ (remainder 2 remainder #f -1 ,:immortal ,:none)
+ (sys$read-char 1 sys$read-char #f -1 ,:dead ,:io)
+ (gc-counter 0 gc-counter #f -1 ,:dead ,:none)
+ ,@(if (fixnum-primitives)
+ `((most-positive-fixnum
+ 0 most-positive-fixnum
+ #f -1 ,:immortal ,:none)
+ (most-negative-fixnum
+ 0 most-negative-fixnum
+ #f -1 ,:immortal ,:none)
+ (fx+ 2 fx+ ,sparc-imm? -1 ,:immortal ,:none)
+ (fx- 2 fx- ,sparc-imm? -1 ,:immortal ,:none)
+ (fx-- 1 fx-- #f -1 ,:immortal ,:none)
+ (fx* 2 fx* #f -1 ,:immortal ,:none)
+ (fx= 2 fx= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx< 2 fx< ,sparc-imm? -1 ,:immortal ,:none)
+ (fx<= 2 fx<= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx> 2 fx> ,sparc-imm? -1 ,:immortal ,:none)
+ (fx>= 2 fx>= ,sparc-imm? -1 ,:immortal ,:none)
+ (fxzero? 1 fxzero? #f -1 ,:immortal ,:none)
+ (fxpositive? 1 fxpositive? #f -1 ,:immortal ,:none)
+ (fxnegative? 1 fxnegative? #f -1 ,:immortal ,:none))
+ '())
+ ,@(if (flonum-primitives)
+ `((fl+ 2 + #f -1 ,:immortal ,:none)
+ (fl- 2 - #f -1 ,:immortal ,:none)
+ (fl-- 1 -- #f -1 ,:immortal ,:none)
+ (fl* 2 * #f -1 ,:immortal ,:none)
+ (fl= 2 = #f -1 ,:immortal ,:none)
+ (fl< 2 < #f -1 ,:immortal ,:none)
+ (fl<= 2 <= #f -1 ,:immortal ,:none)
+ (fl> 2 > #f -1 ,:immortal ,:none)
+ (fl>= 2 >= #f -1 ,:immortal ,:none))
+ '())
+
+ ; Added for CSE, representation analysis.
+
+ (,name:CHECK! -1 check! #f -1 ,:dead ,:none)
+ (vector-length:vec 1 vector-length:vec #f -1 ,:immortal ,:none)
+ (vector-ref:trusted 2 vector-ref:trusted ,sparc-imm? -1 ,:vector ,:none)
+ (vector-set!:trusted 3 vector-set!:trusted #f -1 ,:dead ,:vector)
+ (car:pair 1 car:pair #f -1 ,:car ,:none)
+ (cdr:pair 1 cdr:pair #f -1 ,:cdr ,:none)
+ (=:fix:fix 2 =:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<:fix:fix 2 <:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<=:fix:fix 2 <=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>=:fix:fix 2 >=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>:fix:fix 2 >:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+
+ ; Not yet implemented.
+
+ (+:idx:idx 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:fix:fix 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:exi:exi 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:flo:flo 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (=:flo:flo 2 =:flo:flo #f -1 ,:immortal ,:none)
+ (=:obj:flo 2 =:obj:flo #f -1 ,:immortal ,:none)
+ (=:flo:obj 2 =:flo:obj #f -1 ,:immortal ,:none)
+ )))
+
+; Not used by the Sparc assembler; for information only.
+
+(define $immediate-primops$
+ '((typetag-set! #x80)
+ (eq? #x81)
+ (+ #x82)
+ (- #x83)
+ (< #x84)
+ (<= #x85)
+ (= #x86)
+ (> #x87)
+ (>= #x88)
+ (char<? #x89)
+ (char<=? #x8a)
+ (char=? #x8b)
+ (char>? #x8c)
+ (char>=? #x8d)
+ (string-ref #x90)
+ (vector-ref #x91)
+ (bytevector-ref #x92)
+ (bytevector-like-ref -1)
+ (vector-like-ref -1)
+ (fx+ -1)
+ (fx- -1)
+ (fx-- -1)
+ (fx= -1)
+ (fx< -1)
+ (fx<= -1)
+ (fx> -1)
+ (fx>= -1)))
+
+; Operations introduced by peephole optimizer.
+
+(define $reg/op1/branchf ; reg/op1/branchf prim,k1,L
+ (make-mnemonic 'reg/op1/branchf))
+(define $reg/op2/branchf ; reg/op2/branchf prim,k1,k2,L
+ (make-mnemonic 'reg/op2/branchf))
+(define $reg/op2imm/branchf ; reg/op2imm/branchf prim,k1,x,L
+ (make-mnemonic 'reg/op2imm/branchf))
+(define $reg/op1/check ; reg/op1/check prim,k1,k2,k3,k4,exn
+ (make-mnemonic 'reg/op1/check))
+(define $reg/op2/check ; reg/op2/check prim,k1,k2,k3,k4,k5,exn
+ (make-mnemonic 'reg/op2/check))
+(define $reg/op2imm/check ; reg/op2imm/check prim,k1,x,k2,k3,k4,exn
+ (make-mnemonic 'reg/op2imm/check))
+(define $reg/op1/setreg ; reg/op1/setreg prim,k1,kr
+ (make-mnemonic 'reg/op1/setreg))
+(define $reg/op2/setreg ; reg/op2/setreg prim,k1,k2,kr
+ (make-mnemonic 'reg/op2/setreg))
+(define $reg/op2imm/setreg ; reg/op2imm/setreg prim,k1,x,kr
+ (make-mnemonic 'reg/op2imm/setreg))
+(define $reg/branchf ; reg/branchf k, L
+ (make-mnemonic 'reg/branchf))
+(define $reg/return ; reg/return k
+ (make-mnemonic 'reg/return))
+(define $reg/setglbl ; reg/setglbl k,x
+ (make-mnemonic 'reg/setglbl))
+(define $reg/op3 ; reg/op3 prim,k1,k2,k3
+ (make-mnemonic 'reg/op3))
+(define $const/setreg ; const/setreg const,k
+ (make-mnemonic 'const/setreg))
+(define $const/return ; const/return const
+ (make-mnemonic 'const/return))
+(define $global/setreg ; global/setreg x,k
+ (make-mnemonic 'global/setreg))
+(define $setrtn/branch ; setrtn/branch L,doc
+ (make-mnemonic 'setrtn/branch))
+(define $setrtn/invoke ; setrtn/invoke L
+ (make-mnemonic 'setrtn/invoke))
+(define $global/invoke ; global/invoke global,n
+ (make-mnemonic 'global/invoke))
+
+; misc
+
+(define $cons 'cons)
+(define $car:pair 'car)
+(define $cdr:pair 'cdr)
+
+; eof
+; Target-specific representations.
+;
+; A few of these representation types must be specified for every target:
+; rep:object
+; rep:procedure
+; rep:true
+; rep:false
+; rep:bottom
+
+(define-subtype 'true 'object) ; values that count as true
+(define-subtype 'eqtype 'object) ; can use EQ? instead of EQV?
+(define-subtype 'nonpointer 'eqtype) ; can omit write barrier
+(define-subtype 'eqtype1 'eqtype) ; eqtypes excluding #f
+(define-subtype 'boolean 'nonpointer)
+(define-subtype 'truth 'eqtype1) ; { #t }
+(define-subtype 'truth 'boolean)
+(define-subtype 'false 'boolean) ; { #f }
+(define-subtype 'eqtype1 'true)
+(define-subtype 'procedure 'true)
+(define-subtype 'vector 'true)
+(define-subtype 'bytevector 'true)
+(define-subtype 'string 'true)
+(define-subtype 'pair 'true)
+(define-subtype 'emptylist 'eqtype1)
+(define-subtype 'emptylist 'nonpointer)
+(define-subtype 'symbol 'eqtype1)
+(define-subtype 'char 'eqtype1)
+(define-subtype 'char 'nonpointer)
+(define-subtype 'number 'true)
+(define-subtype 'inexact 'number)
+(define-subtype 'flonum 'inexact)
+(define-subtype 'integer 'number)
+(define-subtype 'exact 'number)
+(define-subtype 'exactint 'integer)
+(define-subtype 'exactint 'exact)
+(define-subtype 'fixnum 'exactint)
+(define-subtype '!fixnum 'fixnum) ; 0 <= n
+(define-subtype 'fixnum! 'fixnum) ; n <= largest index
+(define-subtype 'index '!fixnum)
+(define-subtype 'index 'fixnum!)
+(define-subtype 'zero 'index)
+(define-subtype 'fixnum 'eqtype1)
+(define-subtype 'fixnum 'nonpointer)
+
+(compute-type-structure!)
+
+; If the intersection of rep1 and rep2 is known precisely,
+; but neither is a subtype of the other, then their intersection
+; should be declared explicitly.
+; Otherwise a conservative approximation will be used.
+
+(define-intersection 'true 'eqtype 'eqtype1)
+(define-intersection 'true 'boolean 'truth)
+(define-intersection 'exact 'integer 'exactint)
+(define-intersection '!fixnum 'fixnum! 'index)
+
+;(display-unions-and-intersections)
+
+; Parameters.
+
+(define rep:min_fixnum (- (expt 2 29)))
+(define rep:max_fixnum (- (expt 2 29) 1))
+(define rep:max_index (- (expt 2 24) 1))
+
+; The representations we'll recognize for now.
+
+(define rep:object (symbol->rep 'object))
+(define rep:true (symbol->rep 'true))
+(define rep:truth (symbol->rep 'truth))
+(define rep:false (symbol->rep 'false))
+(define rep:boolean (symbol->rep 'boolean))
+(define rep:pair (symbol->rep 'pair))
+(define rep:symbol (symbol->rep 'symbol))
+(define rep:number (symbol->rep 'number))
+(define rep:zero (symbol->rep 'zero))
+(define rep:index (symbol->rep 'index))
+(define rep:fixnum (symbol->rep 'fixnum))
+(define rep:exactint (symbol->rep 'exactint))
+(define rep:flonum (symbol->rep 'flonum))
+(define rep:exact (symbol->rep 'exact))
+(define rep:inexact (symbol->rep 'inexact))
+(define rep:integer (symbol->rep 'integer))
+;(define rep:real (symbol->rep 'real))
+(define rep:char (symbol->rep 'char))
+(define rep:string (symbol->rep 'string))
+(define rep:vector (symbol->rep 'vector))
+(define rep:procedure (symbol->rep 'procedure))
+(define rep:bottom (symbol->rep 'bottom))
+
+; Given the value of a quoted constant, return its representation.
+
+(define (representation-of-value x)
+ (cond ((boolean? x)
+ (if x
+ rep:truth
+ rep:false))
+ ((pair? x)
+ rep:pair)
+ ((symbol? x)
+ rep:symbol)
+ ((number? x)
+ (cond ((and (exact? x)
+ (integer? x))
+ (cond ((zero? x)
+ rep:zero)
+ ((<= 0 x rep:max_index)
+ rep:index)
+ ((<= rep:min_fixnum
+ x
+ rep:max_fixnum)
+ rep:fixnum)
+ (else
+ rep:exactint)))
+ ((and (inexact? x)
+ (real? x))
+ rep:flonum)
+ (else
+ ; We're not tracking other numbers yet.
+ rep:number)))
+ ((char? x)
+ rep:char)
+ ((string? x)
+ rep:string)
+ ((vector? x)
+ rep:vector)
+ ; Everything counts as true except for #f.
+ (else
+ rep:true)))
+
+; Tables that express the representation-specific operations,
+; and the information about representations that are implied
+; by certain operations.
+; FIXME: Currently way incomplete, but good enough for testing.
+
+(define rep-specific
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the procedure
+ ; in the last column can be called instead.
+
+ '(
+ ;(+ (index index) +:idx:idx)
+ ;(+ (fixnum fixnum) +:fix:fix)
+ ;(- (index index) -:idx:idx)
+ ;(- (fixnum fixnum) -:fix:fix)
+
+ (= (fixnum fixnum) =:fix:fix)
+ (< (fixnum fixnum) <:fix:fix)
+ (<= (fixnum fixnum) <=:fix:fix)
+ (> (fixnum fixnum) >:fix:fix)
+ (>= (fixnum fixnum) >=:fix:fix)
+
+ ;(+ (flonum flonum) +:flo:flo)
+ ;(- (flonum flonum) -:flo:flo)
+ ;(= (flonum flonum) =:flo:flo)
+ ;(< (flonum flonum) <:flo:flo)
+ ;(<= (flonum flonum) <=:flo:flo)
+ ;(> (flonum flonum) >:flo:flo)
+ ;(>= (flonum flonum) >=:flo:flo)
+
+ ;(vector-set!:trusted (vector fixnum nonpointer) vector-set!:trusted:imm)
+ )))
+
+(define rep-result
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the result
+ ; is described by the last column.
+
+ '((fixnum? (fixnum) (truth))
+ (vector? (vector) (truth))
+ (<= (zero !fixnum) (truth))
+ (>= (!fixnum zero) (truth))
+ (<=:fix:fix (zero !fixnum) (truth))
+ (>=:fix:fix (!fixnum zero) (truth))
+
+ (+ (index index) (!fixnum))
+ (+ (fixnum fixnum) (exactint))
+ (- (index index) (fixnum!))
+ (- (fixnum fixnum) (exactint))
+
+ (+ (flonum flonum) (flonum))
+ (- (flonum flonum) (flonum))
+
+ ;(+:idx:idx (index index) (!fixnum))
+ ;(-:idx:idx (index index) (fixnum!))
+ ;(+:fix:fix (index index) (exactint))
+ ;(+:fix:fix (fixnum fixnum) (exactint))
+ ;(-:idx:idx (index index) (fixnum))
+ ;(-:fix:fix (fixnum fixnum) (exactint))
+
+ (make-vector (object object) (vector))
+ (vector-length:vec (vector) (index))
+ (cons (object object) (pair))
+
+ ; Is it really all that useful to know that the result
+ ; of these comparisons is a boolean?
+
+ (= (number number) (boolean))
+ (< (number number) (boolean))
+ (<= (number number) (boolean))
+ (> (number number) (boolean))
+ (>= (number number) (boolean))
+
+ (=:fix:fix (fixnum fixnum) (boolean))
+ (<:fix:fix (fixnum fixnum) (boolean))
+ (<=:fix:fix (fixnum fixnum) (boolean))
+ (>:fix:fix (fixnum fixnum) (boolean))
+ (>=:fix:fix (fixnum fixnum) (boolean))
+ )))
+
+(define rep-informing
+
+ (representation-table
+
+ ; When the predicate in the first column is called in the test position
+ ; of a conditional expression, on arguments described by the second
+ ; column, then the arguments are described by the third column if the
+ ; predicate returns true, and by the fourth column if the predicate
+ ; returns false.
+
+ '(
+ (fixnum? (object) (fixnum) (object))
+ (flonum? (object) (flonum) (object))
+ (vector? (object) (vector) (object))
+ (pair? (object) (pair) (object))
+
+ (= (exactint index) (index index) (exactint index))
+ (= (index exactint) (index index) (index exactint))
+ (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (< (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+ (< (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+
+ (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (> (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (> (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (=:fix:fix (exactint index) (index index) (exactint index))
+ (=:fix:fix (index exactint) (index index) (index exactint))
+ (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+ )))
+; Copyright 1991 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 25 April 1999.
+;
+; Second pass of the Twobit compiler:
+; single assignment analysis, local source transformations,
+; assignment elimination, and lambda lifting.
+; The code for assignment elimination and lambda lifting
+; are in a separate file.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+
+(define (pass2 exp)
+ (simplify exp (make-notepad #f)))
+
+; Given an expression and a "notepad" data structure that conveys
+; inherited attributes, performs the appropriate optimizations and
+; destructively modifies the notepad to record various attributes
+; that it synthesizes while traversing the expression. In particular,
+; any nested lambda expressions and any variable references will be
+; noted in the notepad.
+
+(define (simplify exp notepad)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (simplify-lambda exp notepad))
+ ((set!) (simplify-assignment exp notepad))
+ ((if) (simplify-conditional exp notepad))
+ ((begin) (if (variable? exp)
+ (begin (notepad-var-add! notepad (variable.name exp))
+ exp)
+ (simplify-sequential exp notepad)))
+ (else (simplify-call exp notepad))))
+
+; Most optimization occurs here.
+; The right hand sides of internal definitions are simplified,
+; as is the body.
+; Internal definitions of enclosed lambda expressions may
+; then be lifted to this one.
+; Single assignment analysis creates internal definitions.
+; Single assignment elimination converts single assignments
+; to bindings where possible, and renames arguments whose value
+; is ignored.
+; Assignment elimination then replaces all remaining assigned
+; variables by heap-allocated cells.
+
+(define (simplify-lambda exp notepad)
+ (notepad-lambda-add! notepad exp)
+ (let ((defs (lambda.defs exp))
+ (body (lambda.body exp))
+ (newnotepad (make-notepad exp)))
+ (for-each (lambda (def)
+ (simplify-lambda (def.rhs def) newnotepad))
+ defs)
+ (lambda.body-set! exp (simplify body newnotepad))
+ (lambda.F-set! exp (notepad-free-variables newnotepad))
+ (lambda.G-set! exp (notepad-captured-variables newnotepad))
+ (single-assignment-analysis exp newnotepad)
+ (let ((known-lambdas (notepad.nonescaping newnotepad)))
+ (for-each (lambda (L)
+ (if (memq L known-lambdas)
+ (lambda-lifting L exp)
+ (lambda-lifting L L)))
+ (notepad.lambdas newnotepad))))
+ (single-assignment-elimination exp notepad)
+ (assignment-elimination exp)
+ (if (not (notepad.parent notepad))
+ ; This is an outermost lambda expression.
+ (lambda-lifting exp exp))
+ exp)
+
+; SIMPLIFY-ASSIGNMENT performs this transformation:
+;
+; (set! I (begin ... E))
+; -> (begin ... (set! I E))
+
+(define (simplify-assignment exp notepad)
+ (notepad-var-add! notepad (assignment.lhs exp))
+ (let ((rhs (simplify (assignment.rhs exp) notepad)))
+ (cond ((begin? rhs)
+ (let ((exprs (reverse (begin.exprs rhs))))
+ (assignment.rhs-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons exp (cdr exprs))))
+ notepad)))
+ (else (assignment.rhs-set! exp rhs) exp))))
+
+(define (simplify-sequential exp notepad)
+ (let ((exprs (map (lambda (exp) (simplify exp notepad))
+ (begin.exprs exp))))
+ (begin.exprs-set! exp exprs)
+ (post-simplify-begin exp notepad)))
+
+; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
+; flattens any nested BEGINs and removes trivial expressions that
+; don't appear in the last position. The second argument is used only
+; if a lambda expression is removed.
+; This procedure is careful to return E instead of (BEGIN E).
+; Fairly harmless bug: a variable reference removed by this procedure
+; may remain on the notepad when it shouldn't.
+
+(define (post-simplify-begin exp notepad)
+ (let ((unspecified-expression (make-unspecified)))
+ ; (flatten exprs '()) returns the flattened exprs in reverse order.
+ (define (flatten exprs flattened)
+ (cond ((null? exprs) flattened)
+ ((begin? (car exprs))
+ (flatten (cdr exprs)
+ (flatten (begin.exprs (car exprs)) flattened)))
+ (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
+ (define (filter exprs filtered)
+ (if (null? exprs)
+ filtered
+ (let ((exp (car exprs)))
+ (cond ((constant? exp) (filter (cdr exprs) filtered))
+ ((variable? exp) (filter (cdr exprs) filtered))
+ ((lambda? exp)
+ (notepad.lambdas-set!
+ notepad
+ (remq exp (notepad.lambdas notepad)))
+ (filter (cdr exprs) filtered))
+ ((equal? exp unspecified-expression)
+ (filter (cdr exprs) filtered))
+ (else (filter (cdr exprs) (cons exp filtered)))))))
+ (let ((exprs (flatten (begin.exprs exp) '())))
+ (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
+ (if (null? (cdr (begin.exprs exp)))
+ (car (begin.exprs exp))
+ exp))))
+
+; SIMPLIFY-CALL performs this transformation:
+;
+; (... (begin ... E) ...)
+; -> (begin ... (... E ...))
+;
+; It also takes care of LET transformations.
+
+(define (simplify-call exp notepad)
+ (define (loop args newargs exprs)
+ (cond ((null? args)
+ (finish newargs exprs))
+ ((begin? (car args))
+ (let ((newexprs (reverse (begin.exprs (car args)))))
+ (loop (cdr args)
+ (cons (car newexprs) newargs)
+ (append (cdr newexprs) exprs))))
+ (else (loop (cdr args) (cons (car args) newargs) exprs))))
+ (define (finish newargs exprs)
+ (call.args-set! exp (reverse newargs))
+ (let* ((newexp
+ (if (lambda? (call.proc exp))
+ (simplify-let exp notepad)
+ (begin
+ (call.proc-set! exp
+ (simplify (call.proc exp) notepad))
+ exp)))
+ (newexp
+ (if (and (call? newexp)
+ (variable? (call.proc newexp)))
+ (let* ((procname (variable.name (call.proc newexp)))
+ (args (call.args newexp))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value
+ (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ newexp))
+ newexp)))
+ (cond ((and (call? newexp)
+ (begin? (call.proc newexp)))
+ (let ((exprs0 (reverse (begin.exprs (call.proc newexp)))))
+ (call.proc-set! newexp (car exprs0))
+ (post-simplify-begin
+ (make-begin (reverse
+ (cons newexp
+ (append (cdr exprs0) exprs))))
+ notepad)))
+ ((null? exprs)
+ newexp)
+ (else
+ (post-simplify-begin
+ (make-begin (reverse (cons newexp exprs)))
+ notepad)))))
+ (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
+ (call.args exp)))
+ (loop (call.args exp) '() '()))
+
+; SIMPLIFY-LET performs these transformations:
+;
+; ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
+; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (LIST Ek+1 ...))
+;
+; ((lambda (I1 I2 ...) (begin D ...) (quote ...) E) L ...)
+; -> ((lambda (I2 ...) (begin (define I1 L) D ...) (quote ...) E) ...)
+;
+; provided I1 is not assigned and each reference to I1 is in call position.
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (begin I1))
+; E1)
+;
+; -> E1
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (if (begin I1) E2 E3))
+; E1)
+;
+; -> (if E1 E2 E3)
+;
+; (Together with SIMPLIFY-CONDITIONAL, this cleans up the output of the OR
+; macro and enables certain control optimizations.)
+;
+; ((lambda (I1 I2 ...)
+; (begin D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; E)
+; K ...)
+; -> ((lambda (I2 ...)
+; (begin D' ...)
+; (quote (... ...) ...)
+; E')
+; ...)
+;
+; where D' ... and E' ... are obtained from D ... and E ...
+; by replacing all references to I1 by K. This transformation
+; applies if K is a constant that can be duplicated without changing
+; its EQV? behavior.
+;
+; ((lambda () (begin) (quote ...) E)) -> E
+;
+; ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
+; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
+;
+; (Single assignment analysis, performed by the simplifier for lambda
+; expressions, detects unused arguments and replaces them in the argument
+; list by the special identifier IGNORED.)
+
+(define (simplify-let exp notepad)
+ (define proc (call.proc exp))
+
+ ; Loop1 operates before simplification of the lambda body.
+
+ (define (loop1 formals actuals processed-formals processed-actuals)
+ (cond ((null? formals)
+ (if (not (null? actuals))
+ (pass2-error p2error:wna exp))
+ (return1 processed-formals processed-actuals))
+ ((symbol? formals)
+ (return1 (cons formals processed-formals)
+ (cons (make-call-to-LIST actuals) processed-actuals)))
+ ((null? actuals)
+ (pass2-error p2error:wna exp)
+ (return1 processed-formals
+ processed-actuals))
+ ((and (lambda? (car actuals))
+ (let ((Rinfo (R-lookup (lambda.R proc) (car formals))))
+ (and (null? (R-entry.assignments Rinfo))
+ (= (length (R-entry.references Rinfo))
+ (length (R-entry.calls Rinfo))))))
+ (let ((I (car formals))
+ (L (car actuals)))
+ (notepad-nonescaping-add! notepad L)
+ (lambda.defs-set! proc
+ (cons (make-definition I L)
+ (lambda.defs proc)))
+ (standardize-known-calls L
+ (R-entry.calls
+ (R-lookup (lambda.R proc) I)))
+ (lambda.F-set! proc (union (lambda.F proc)
+ (free-variables L)))
+ (lambda.G-set! proc (union (lambda.G proc) (lambda.G L))))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ ((and (constant? (car actuals))
+ (let ((x (constant.value (car actuals))))
+ (or (boolean? x)
+ (number? x)
+ (symbol? x)
+ (char? x))))
+ (let* ((I (car formals))
+ (Rinfo (R-lookup (lambda.R proc) I)))
+ (if (null? (R-entry.assignments Rinfo))
+ (begin
+ (for-each (lambda (ref)
+ (variable-set! ref (car actuals)))
+ (R-entry.references Rinfo))
+ (lambda.R-set! proc (remq Rinfo (lambda.R proc)))
+ (lambda.F-set! proc (remq I (lambda.F proc)))
+ (lambda.G-set! proc (remq I (lambda.G proc)))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+ (else (if (null? actuals)
+ (pass2-error p2error:wna exp))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+
+ (define (return1 rev-formals rev-actuals)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals)))
+ (lambda.args-set! proc formals)
+ (if (and (not (null? formals))
+ (null? (cdr formals))
+ (let* ((x (car formals))
+ (R (lambda.R proc))
+ (refs (references R x)))
+ (and (= 1 (length refs))
+ (null? (assignments R x)))))
+ (let ((x (car formals))
+ (body (lambda.body proc)))
+ (cond ((and (variable? body)
+ (eq? x (variable.name body)))
+ (simplify (car actuals) notepad))
+ ((and (conditional? body)
+ (let ((B0 (if.test body)))
+ (variable? B0)
+ (eq? x (variable.name B0))))
+ (if.test-set! body (car actuals))
+ (simplify body notepad))
+ (else
+ (return1-finish formals actuals))))
+ (return1-finish formals actuals))))
+
+ (define (return1-finish formals actuals)
+ (simplify-lambda proc notepad)
+ (loop2 formals actuals '() '() '()))
+
+ ; Loop2 operates after simplification of the lambda body.
+
+ (define (loop2 formals actuals processed-formals processed-actuals for-effect)
+ (cond ((null? formals)
+ (return2 processed-formals processed-actuals for-effect))
+ ((ignored? (car formals))
+ (loop2 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else (loop2 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect))))
+
+ (define (return2 rev-formals rev-actuals rev-for-effect)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals))
+ (for-effect (reverse rev-for-effect)))
+ (lambda.args-set! proc formals)
+ (call.args-set! exp actuals)
+ (let ((exp (if (and (null? actuals)
+ (or (null? (lambda.defs proc))
+ (and (notepad.parent notepad)
+ (POLICY:LIFT? proc
+ (notepad.parent notepad)
+ (map (lambda (def) '())
+ (lambda.defs proc))))))
+ (begin (for-each (lambda (I)
+ (notepad-var-add! notepad I))
+ (lambda.F proc))
+ (if (not (null? (lambda.defs proc)))
+ (let ((parent (notepad.parent notepad))
+ (defs (lambda.defs proc))
+ (R (lambda.R proc)))
+ (lambda.defs-set!
+ parent
+ (append defs (lambda.defs parent)))
+ (lambda.defs-set! proc '())
+ (lambda.R-set!
+ parent
+ (append (map (lambda (def)
+ (R-lookup R (def.lhs def)))
+ defs)
+ (lambda.R parent)))))
+ (lambda.body proc))
+ exp)))
+ (if (null? for-effect)
+ exp
+ (post-simplify-begin (make-begin (append for-effect (list exp)))
+ notepad)))))
+
+ (notepad-nonescaping-add! notepad proc)
+ (loop1 (lambda.args proc) (call.args exp) '() '()))
+
+; Single assignment analysis performs the transformation
+;
+; (lambda (... I ...)
+; (begin D ...)
+; (quote (... (I <references> ((set! I L)) <calls>) ...) ...)
+; (begin (set! I L) E1 ...))
+; -> (lambda (... IGNORED ...)
+; (begin (define I L) D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; (begin E1 ...))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs so
+; that procedure definitions/bindings come first.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-analysis L notepad)
+ (let ((formals (lambda.args L))
+ (defs (lambda.defs L))
+ (R (lambda.R L))
+ (body (lambda.body L)))
+ (define (finish! exprs escapees)
+ (begin.exprs-set! body
+ (append (reverse escapees)
+ exprs))
+ (lambda.body-set! L (post-simplify-begin body '())))
+ (if (begin? body)
+ (let loop ((exprs (begin.exprs body))
+ (escapees '()))
+ (let ((first (car exprs)))
+ (if (and (assignment? first)
+ (not (null? (cdr exprs))))
+ (let ((I (assignment.lhs first))
+ (rhs (assignment.rhs first)))
+ (if (and (lambda? rhs)
+ (local? R I)
+ (= 1 (length (assignments R I))))
+ (if (= (length (calls R I))
+ (length (references R I)))
+ (begin (notepad-nonescaping-add! notepad rhs)
+ (flag-as-ignored I L)
+ (lambda.defs-set! L
+ (cons (make-definition I rhs)
+ (lambda.defs L)))
+ (assignments-set! R I '())
+ (standardize-known-calls
+ rhs
+ (R-entry.calls (R-lookup R I)))
+ (loop (cdr exprs) escapees))
+ (loop (cdr exprs)
+ (cons (car exprs) escapees)))
+ (finish! exprs escapees)))
+ (finish! exprs escapees)))))))
+
+(define (standardize-known-calls L calls)
+ (let ((formals (lambda.args L)))
+ (cond ((not (list? formals))
+ (let* ((newformals (make-null-terminated formals))
+ (n (- (length newformals) 1)))
+ (lambda.args-set! L newformals)
+ (for-each (lambda (call)
+ (if (>= (length (call.args call)) n)
+ (call.args-set!
+ call
+ (append (list-head (call.args call) n)
+ (list
+ (make-call-to-LIST
+ (list-tail (call.args call) n)))))
+ (pass2-error p2error:wna call)))
+ calls)))
+ (else (let ((n (length formals)))
+ (for-each (lambda (call)
+ (if (not (= (length (call.args call)) n))
+ (pass2-error p2error:wna call)))
+ calls))))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 13 November 1998
+;
+; Second pass of the Twobit compiler, part 2:
+; single assignment elimination, assignment elimination,
+; and lambda lifting.
+;
+; See part 1 for further documentation.
+
+; Single assignment elimination performs the transformation
+;
+; (lambda (... I1 ... In ...)
+; (begin D ...)
+; (begin (set! I1 E1)
+; ...
+; (set! In En)
+; E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (let* ((I1 E1) ... (In En))
+; (begin D ...)
+; (begin E ...)))
+;
+; provided for each k:
+;
+; 1. Ik does not occur in E1, ..., Ek.
+; 2. Either E1 through Ek contain no procedure calls
+; or Ik is not referenced by an escaping lambda expression.
+; 3. Ik is assigned only once.
+;
+; I doubt whether the third condition is really necessary, but
+; dropping it would involve a more complex calculation of the
+; revised referencing information.
+;
+; A more precise description of the transformation:
+;
+; (lambda (... I1 ... In ...)
+; (begin (define F1 L1) ...)
+; (quote (... (I1 <references> ((set! I1 E1)) <calls>) ...
+; (In <references> ((set! In En)) <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin (set! I1 E1) ... (set! In En) E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (begin)
+; (quote (...) ...)
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 <references> () <calls>)) ...)
+; ...
+; ((lambda (In)
+; (begin (define F1 L1) ...)
+; (quote (... (In <references> () <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin E ...))
+; En)
+; ...)
+; E1))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs
+; so that procedure definitions/bindings come first, followed by
+; definitions/bindings whose right hand side contains no calls,
+; followed by definitions/bindings of variables that do not escape,
+; followed by all other definitions/bindings.
+;
+; Pass 1 can't tell which variables escape, however. Pass 2 can't tell
+; which variables escape either until all enclosed lambda expressions
+; have been simplified and the first transformation above has been
+; performed. That is why single assignment analysis precedes single
+; assignment elimination. As implemented here, an assignment that does
+; not satisfy the conditions above will prevent the transformation from
+; being applied to any subsequent assignments.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-elimination L notepad)
+
+ (if (begin? (lambda.body L))
+
+ (let* ((formals (make-null-terminated (lambda.args L)))
+ (defined (map def.lhs (lambda.defs L)))
+ (escaping (intersection formals
+ (notepad-captured-variables notepad)))
+ (R (lambda.R L)))
+
+ ; Given:
+ ; exprs that remain in the body;
+ ; assigns that will be replaced by let* variables;
+ ; call-has-occurred?, a boolean;
+ ; free variables of the assigns;
+ ; Performs the transformation described above.
+
+ (define (loop exprs assigns call-has-occurred? free)
+ (cond ((null? (cdr exprs))
+ (return exprs assigns))
+ ((assignment? (car exprs))
+ (let ((I1 (assignment.lhs (car exprs)))
+ (E1 (assignment.rhs (car exprs))))
+ (if (and (memq I1 formals)
+ (= (length (assignments R I1)) 1)
+ (not (and call-has-occurred?
+ (memq I1 escaping))))
+ (let* ((free-in-E1 (free-variables E1))
+ (newfree (union free-in-E1 free)))
+ (if (or (memq I1 newfree)
+ (not
+ (empty-set?
+ (intersection free-in-E1 defined))))
+ (return exprs assigns)
+ (loop (cdr exprs)
+ (cons (car exprs) assigns)
+ (or call-has-occurred?
+ (might-return-twice? E1))
+ newfree)))
+ (return exprs assigns))))
+ (else (return exprs assigns))))
+
+ (define (return exprs assigns)
+ (if (not (null? assigns))
+ (let ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (defs (lambda.defs L))
+ (F (lambda.F L))
+ (G (lambda.G L)))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ defs
+ (cons (R-entry R I)
+ (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ (make-begin exprs))))
+ (lambda.defs-set! L '())
+ (for-each (lambda (entry)
+ (lambda.R-set! L (remq entry R)))
+ (lambda.R L2))
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (define (return-loop assigns body)
+ (if (null? assigns)
+ (let ((L3 (call.proc body)))
+ (lambda.body-set! L body)
+ (lambda-lifting L3 L))
+ (let* ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (L3 (call.proc body))
+ (F (remq I (lambda.F L3)))
+ (G (remq I (lambda.G L3))))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ '()
+ (list (R-entry R I))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ body)))
+ (lambda.R-set! L (remq (R-entry R I) R))
+ (lambda-lifting L3 L2)
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (loop (begin.exprs (lambda.body L)) '() #f '())))
+
+ L)
+
+; Temporary definitions.
+
+(define (free-variables exp)
+ (case (car exp)
+ ((quote) '())
+ ((lambda) (difference (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ ((set!) (union (list (assignment.lhs exp))
+ (free-variables (assignment.rhs exp))))
+ ((if) (union (free-variables (if.test exp))
+ (free-variables (if.then exp))
+ (free-variables (if.else exp))))
+ ((begin) (if (variable? exp)
+ (list (variable.name exp))
+ (apply union (map free-variables (begin.exprs exp)))))
+ (else (apply union (map free-variables exp)))))
+
+(define (might-return-twice? exp)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (might-return-twice? (assignment.rhs exp)))
+ ((if) (or (might-return-twice? (if.test exp))
+ (might-return-twice? (if.then exp))
+ (might-return-twice? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? might-return-twice? (begin.exprs exp))))
+ (else #t)))
+
+
+; Assignment elimination replaces variables that appear on the left
+; hand side of an assignment by data structures. This is necessary
+; to avoid some nasty complications with lambda lifting.
+;
+; This procedure operates by side effect.
+
+(define (assignment-elimination L)
+ (let ((R (lambda.R L)))
+
+ ; Given a list of entries, return those for assigned variables.
+
+ (define (loop entries assigned)
+ (cond ((null? entries)
+ (if (not (null? assigned))
+ (eliminate assigned)))
+ ((not (null? (R-entry.assignments (car entries))))
+ (loop (cdr entries) (cons (car entries) assigned)))
+ ((null? (R-entry.references (car entries)))
+ (flag-as-ignored (R-entry.name (car entries)) L)
+ (loop (cdr entries) assigned))
+ (else (loop (cdr entries) assigned))))
+
+ ; Given a list of entries for assigned variables I1 ...,
+ ; remove the assignments by replacing the body by a LET of the form
+ ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
+ ; by calls to CELL-REF, and by replacing assignments by calls to
+ ; CELL-SET!.
+
+ (define (eliminate assigned)
+ (let* ((oldnames (map R-entry.name assigned))
+ (newnames (map generate-new-name oldnames)))
+ (let ((augmented-entries (map list newnames assigned))
+ (renaming-alist (map cons oldnames newnames))
+ (defs (lambda.defs L)))
+ (for-each cellify! augmented-entries)
+ (for-each (lambda (def)
+ (do ((free (lambda.F (def.rhs def)) (cdr free)))
+ ((null? free))
+ (let ((z (assq (car free) renaming-alist)))
+ (if z
+ (set-car! free (cdr z))))))
+ defs)
+ (let ((newbody
+ (make-call
+ (make-lambda (map car augmented-entries)
+ defs
+ (union (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs)
+ (map new-reference-info augmented-entries))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.F L) oldnames))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.G L) oldnames))
+ (lambda.decls L)
+ (lambda.doc L)
+ (lambda.body L))
+ (map (lambda (name)
+ (make-call (make-variable name:MAKE-CELL)
+ (list (make-variable name))))
+ (map R-entry.name assigned)))))
+ (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
+ (difference (lambda.F L)
+ (map def.lhs (lambda.defs L)))))
+ (lambda.defs-set! L '())
+ (for-each update-old-reference-info!
+ (map (lambda (arg)
+ (car (call.args arg)))
+ (call.args newbody)))
+ (lambda.body-set! L newbody)
+ (lambda-lifting (call.proc newbody) L)))))
+
+ (define (generate-new-name name)
+ (string->symbol (string-append cell-prefix (symbol->string name))))
+
+ ; In addition to replacing references and assignments involving the
+ ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
+ ; uses the old entry to collect the referencing information for the
+ ; new variable.
+
+ (define (cellify! augmented-entry)
+ (let ((newname (car augmented-entry))
+ (entry (cadr augmented-entry)))
+ (do ((refs (R-entry.references entry)
+ (cdr refs)))
+ ((null? refs))
+ (let* ((reference (car refs))
+ (newref (make-variable newname)))
+ (set-car! reference (make-variable name:CELL-REF))
+ (set-car! (cdr reference) newref)
+ (set-car! refs newref)))
+ (do ((assigns (R-entry.assignments entry)
+ (cdr assigns)))
+ ((null? assigns))
+ (let* ((assignment (car assigns))
+ (newref (make-variable newname)))
+ (set-car! assignment (make-variable name:CELL-SET!))
+ (set-car! (cdr assignment) newref)
+ (R-entry.references-set! entry
+ (cons newref
+ (R-entry.references entry)))))
+ (R-entry.assignments-set! entry '())))
+
+ ; This procedure creates a brand new entry for a new variable, extracting
+ ; the references stored in the old entry by CELLIFY!.
+
+ (define (new-reference-info augmented-entry)
+ (make-R-entry (car augmented-entry)
+ (R-entry.references (cadr augmented-entry))
+ '()
+ '()))
+
+ ; This procedure updates the old entry to reflect the fact that it is
+ ; now referenced once and never assigned.
+
+ (define (update-old-reference-info! ref)
+ (references-set! R (variable.name ref) (list ref))
+ (assignments-set! R (variable.name ref) '())
+ (calls-set! R (variable.name ref) '()))
+
+ (loop R '())))
+
+; Lambda lifting raises internal definitions to outer scopes to avoid
+; having to choose between creating a closure or losing tail recursion.
+; If L is not #f, then L2 is a lambda expression nested within L.
+; Any internal definitions that occur within L2 may be lifted to L
+; by adding extra arguments to the defined procedure and to all calls to it.
+; Lambda lifting is not a clear win, because the extra arguments could
+; easily become more expensive than creating a closure and referring
+; to the non-local arguments through the closure. The heuristics used
+; to decide whether to lift a group of internal definitions are isolated
+; within the POLICY:LIFT? procedure.
+
+; L2 can be the same as L, so the order of side effects is critical.
+
+(define (lambda-lifting L2 L)
+
+ ; The call to sort is optional. It gets the added arguments into
+ ; the same order they appear in the formals list, which is an
+ ; advantage for register targeting.
+
+ (define (lift L2 L args-to-add)
+ (let ((formals (make-null-terminated (lambda.args L2))))
+ (do ((defs (lambda.defs L2) (cdr defs))
+ (args-to-add args-to-add (cdr args-to-add)))
+ ((null? defs))
+ (let* ((def (car defs))
+ (entry (R-lookup (lambda.R L2) (def.lhs def)))
+ (calls (R-entry.calls entry))
+ (added (twobit-sort (lambda (x y)
+ (let ((xx (memq x formals))
+ (yy (memq y formals)))
+ (if (and xx yy)
+ (> (length xx) (length yy))
+ #t)))
+ (car args-to-add)))
+ (L3 (def.rhs def)))
+ ; The flow equation guarantees that these added arguments
+ ; will occur free by the time this round of lifting is done.
+ (lambda.F-set! L3 (union added (lambda.F L3)))
+ (lambda.args-set! L3 (append added (lambda.args L3)))
+ (for-each (lambda (call)
+ (let ((newargs (map make-variable added)))
+ ; The referencing information is made obsolete here!
+ (call.args-set! call
+ (append newargs (call.args call)))))
+ calls)
+ (lambda.R-set! L2 (remq entry (lambda.R L2)))
+ (lambda.R-set! L (cons entry (lambda.R L)))
+ ))
+ (if (not (eq? L2 L))
+ (begin
+ (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
+ (lambda.defs-set! L2 '())))))
+
+ (if L
+ (if (not (null? (lambda.defs L2)))
+ (let ((args-to-add (compute-added-arguments
+ (lambda.defs L2)
+ (make-null-terminated (lambda.args L2)))))
+ (if (POLICY:LIFT? L2 L args-to-add)
+ (lift L2 L args-to-add))))))
+
+; Given a list of definitions ((define f1 ...) ...) and a set of formals
+; N over which the definitions may be lifted, returns a list of the
+; subsets of N that need to be added to each procedure definition
+; as new arguments.
+;
+; Algorithm: Let F_i be the variables that occur free in the body of
+; the lambda expression associated with f_i. Construct the call graph.
+; Solve the flow equations
+;
+; A_i = (F_i /\ N) \/ (\/ {A_j | A_i calls A_j})
+;
+; where /\ is intersection and \/ is union.
+
+(define (compute-added-arguments defs formals)
+ (let ((procs (map def.lhs defs))
+ (freevars (map lambda.F (map def.rhs defs))))
+ (let ((callgraph (map (lambda (names)
+ (map (lambda (name)
+ (position name procs))
+ (intersection names procs)))
+ freevars))
+ (added_0 (map (lambda (names)
+ (intersection names formals))
+ freevars)))
+ (vector->list
+ (compute-fixedpoint
+ (make-vector (length procs) '())
+ (list->vector (map (lambda (term0 indexes)
+ (lambda (approximations)
+ (union term0
+ (apply union
+ (map (lambda (i)
+ (vector-ref approximations i))
+ indexes)))))
+ added_0
+ callgraph))
+ set-equal?)))))
+
+(define (position x l)
+ (cond ((eq? x (car l)) 0)
+ (else (+ 1 (position x (cdr l))))))
+
+; Given a vector of starting approximations,
+; a vector of functions that compute a next approximation
+; as a function of the vector of approximations,
+; and an equality predicate,
+; returns a vector of fixed points.
+
+(define (compute-fixedpoint v functions equiv?)
+ (define (loop i flag)
+ (if (negative? i)
+ (if flag
+ (loop (- (vector-length v) 1) #f)
+ v)
+ (let ((next_i ((vector-ref functions i) v)))
+ (if (equiv? next_i (vector-ref v i))
+ (loop (- i 1) flag)
+ (begin (vector-set! v i next_i)
+ (loop (- i 1) #t))))))
+ (loop (- (vector-length v) 1) #f))
+
+
+; Given a lambda expression L2, its parent lambda expression
+; L (which may be the same as L2, or #f), and a list of the
+; lists of arguments that would need to be added to known
+; local procedures, returns #t iff lambda lifting should be done.
+;
+; Here are some heuristics:
+;
+; Don't lift if it means adding too many arguments.
+; Don't lift large groups of definitions.
+; In questionable cases it is better to lift to an outer
+; lambda expression that already contains internal
+; definitions than to one that doesn't.
+; It is better not to lift if the body contains a lambda
+; expression that has to be closed anyway.
+
+(define (POLICY:LIFT? L2 L args-to-add)
+ (and (lambda-optimizations)
+ (not (lambda? (lambda.body L2)))
+ (every? (lambda (addlist)
+ (< (length addlist) 6))
+ args-to-add)))
+; Copyright 1991 William D Clinger (for SIMPLIFY-CONDITIONAL)
+; Copyright 1999 William D Clinger (for everything else)
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 April 1999.
+;
+; Some source transformations on IF expressions:
+;
+; (if '#f E1 E2) E2
+; (if 'K E1 E2) E1 K != #f
+; (if (if B0 '#f '#f) E1 E2) (begin B0 E2)
+; (if (if B0 '#f 'K ) E1 E2) (if B0 E2 E1) K != #f
+; (if (if B0 'K '#f) E1 E2) (if B0 E1 E2) K != #f
+; (if (if B0 'K1 'K2) E1 E2) (begin B0 E1) K1, K2 != #f
+; (if (if B0 (if B1 #t #f) B2) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if B0 B1 (if B2 #t #f)) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if X X B0 ) E1 E2) (if (if X #t B0) E1 E2) X a variable
+; (if (if X B0 X ) E1 E2) (if (if X B0 #f) E1 E2) X a variable
+; (if ((lambda (X) (if ((lambda (X)
+; (if X X B2)) B0) (if X #t (if B2 #t #f))) B0)
+; E1 E2) E1 E2)
+; (if (begin ... B0) E1 E2) (begin ... (if B0 E1 E2))
+; (if (not E0) E1 E2) (if E0 E2 E1) not is integrable
+;
+; FIXME: Three of the transformations above are intended to clean up
+; the output of the OR macro. It isn't yet clear how well this works.
+
+(define (simplify-conditional exp notepad)
+ (define (coercion-to-boolean? exp)
+ (and (conditional? exp)
+ (let ((E1 (if.then exp))
+ (E2 (if.else exp)))
+ (and (constant? E1)
+ (eq? #t (constant.value E1))
+ (constant? E2)
+ (eq? #f (constant.value E2))))))
+ (if (not (control-optimization))
+ (begin (if.test-set! exp (simplify (if.test exp) notepad))
+ (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp)
+ (let* ((test (if.test exp)))
+ (if (and (call? test)
+ (lambda? (call.proc test))
+ (let* ((L (call.proc test))
+ (body (lambda.body L)))
+ (and (conditional? body)
+ (let ((R (lambda.R L))
+ (B0 (if.test body))
+ (B1 (if.then body)))
+ (and (variable? B0)
+ (variable? B1)
+ (let ((x (variable.name B0)))
+ (and (eq? x (variable.name B1))
+ (local? R x)
+ (= 1 (length R))
+ (= 1 (length (call.args test))))))))))
+ (let* ((L (call.proc test))
+ (R (lambda.R L))
+ (body (lambda.body L))
+ (ref (if.then body))
+ (x (variable.name ref))
+ (entry (R-entry R x)))
+ (if.then-set! body (make-constant #t))
+ (if.else-set! body
+ (make-conditional (if.else body)
+ (make-constant #t)
+ (make-constant #f)))
+ (R-entry.references-set! entry
+ (remq ref
+ (R-entry.references entry)))
+ (simplify-conditional exp notepad))
+ (let loop ((test (simplify (if.test exp) notepad)))
+ (if.test-set! exp test)
+ (cond ((constant? test)
+ (simplify (if (constant.value test)
+ (if.then exp)
+ (if.else exp))
+ notepad))
+ ((and (conditional? test)
+ (constant? (if.then test))
+ (constant? (if.else test)))
+ (cond ((and (constant.value (if.then test))
+ (constant.value (if.else test)))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.then exp)
+ notepad)))
+ notepad))
+ ((and (not (constant.value (if.then test)))
+ (not (constant.value (if.else test))))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.else exp)
+ notepad)))
+ notepad))
+ (else (if (not (constant.value (if.then test)))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp)))
+ (if.test-set! exp (if.test test))
+ (loop (if.test exp)))))
+ ((and (conditional? test)
+ (or (coercion-to-boolean? (if.then test))
+ (coercion-to-boolean? (if.else test))))
+ (if (coercion-to-boolean? (if.then test))
+ (if.then-set! test (if.test (if.then test)))
+ (if.else-set! test (if.test (if.else test))))
+ (loop test))
+ ((and (conditional? test)
+ (variable? (if.test test))
+ (let ((x (variable.name (if.test test))))
+ (or (and (variable? (if.then test))
+ (eq? x (variable.name (if.then test)))
+ 1)
+ (and (variable? (if.else test))
+ (eq? x (variable.name (if.else test)))
+ 2))))
+ =>
+ (lambda (n)
+ (case n
+ ((1) (if.then-set! test (make-constant #t)))
+ ((2) (if.else-set! test (make-constant #f))))
+ (loop test)))
+ ((begin? test)
+ (let ((exprs (reverse (begin.exprs test))))
+ (if.test-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons (loop (car exprs))
+ (cdr exprs))))
+ notepad)))
+ ((and (call? test)
+ (variable? (call.proc test))
+ (eq? (variable.name (call.proc test)) name:NOT)
+ (integrable? name:NOT)
+ (integrate-usual-procedures)
+ (= (length (call.args test)) 1))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp))
+ (loop (car (call.args test))))
+ (else
+ (simplify-case exp notepad))))))))
+
+; Given a conditional expression whose test has been simplified,
+; simplifies the then and else parts while applying optimizations
+; for CASE expressions.
+; Precondition: (control-optimization) is true.
+
+(define (simplify-case exp notepad)
+ (let ((E0 (if.test exp)))
+ (if (and (call? E0)
+ (variable? (call.proc E0))
+ (let ((name (variable.name (call.proc E0))))
+ ; FIXME: Should ensure that the name is integrable,
+ ; but MEMQ and MEMV probably aren't according to the
+ ; INTEGRABLE? predicate.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (integrate-usual-procedures)
+ (= (length (call.args E0)) 2)
+ (variable? (car (call.args E0)))
+ (constant? (cadr (call.args E0))))
+ (simplify-case-clauses (variable.name (car (call.args E0)))
+ exp
+ notepad)
+ (begin (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp))))
+
+; Code generation for case expressions.
+;
+; A case expression turns into a conditional expression
+; of the form
+;
+; CASE{I} ::= E | (if (PRED I K) E CASE{I})
+; PRED ::= memv | memq | eqv? | eq?
+;
+; The memq and eq? predicates are used when the constant
+; is a (list of) boolean, fixnum, char, empty list, or symbol.
+; The constants will almost always be of these types.
+;
+; The first step is to remove duplicated constants and to
+; collect all the case clauses, sorting them into the following
+; categories based on their simplified list of constants:
+; constants are fixnums
+; constants are characters
+; constants are symbols
+; constants are of mixed or other type
+; After duplicated constants have been removed, the predicates
+; for these clauses can be tested in any order.
+
+; Given the name of an arbitrary variable, an expression that
+; has not yet been simplified or can safely be simplified again,
+; and a notepad, returns the expression after simplification.
+; If the expression is equivalent to a case expression that dispatches
+; on the given variable, then case-optimization will be applied.
+
+(define (simplify-case-clauses var0 E notepad)
+
+ (define notepad2 (make-notepad (notepad.parent notepad)))
+
+ (define (collect-clauses E fix chr sym other constants)
+ (if (not (conditional? E))
+ (analyze (simplify E notepad2)
+ fix chr sym other constants)
+ (let ((test (simplify (if.test E) notepad2))
+ (code (simplify (if.then E) notepad2)))
+ (if.test-set! E test)
+ (if.then-set! E code)
+ (if (not (call? test))
+ (finish E fix chr sym other constants)
+ (let ((proc (call.proc test))
+ (args (call.args test)))
+ (if (not (and (variable? proc)
+ (let ((name (variable.name proc)))
+ ; FIXME: See note above.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (= (length args) 2)
+ (variable? (car args))
+ (eq? (variable.name (car args)) var0)
+ (constant? (cadr args))))
+ (finish E fix chr sym other constants)
+ (let ((pred (variable.name proc))
+ (datum (constant.value (cadr args))))
+ ; FIXME
+ (if (or (and (or (eq? pred name:MEMV)
+ (eq? pred name:MEMQ))
+ (not (list? datum)))
+ (and (eq? pred name:EQ?)
+ (not (eqv-is-ok? datum)))
+ (and (eq? pred name:MEMQ)
+ (not (every? (lambda (datum)
+ (eqv-is-ok? datum))
+ datum))))
+ (finish E fix chr sym other constants)
+ (call-with-values
+ (lambda ()
+ (remove-duplicates (if (or (eq? pred name:EQV?)
+ (eq? pred name:EQ?))
+ (list datum)
+ datum)
+ constants))
+ (lambda (data constants)
+ (let ((clause (list data code))
+ (E2 (if.else E)))
+ (cond ((every? smallint? data)
+ (collect-clauses E2
+ (cons clause fix)
+ chr
+ sym
+ other
+ constants))
+ ((every? char? data)
+ (collect-clauses E2
+ fix
+ (cons clause chr)
+ sym
+ other
+ constants))
+ ((every? symbol? data)
+ (collect-clauses E2
+ fix
+ chr
+ (cons clause sym)
+ other
+ constants))
+ (else
+ (collect-clauses E2
+ fix
+ chr
+ sym
+ (cons clause other)
+ constants))))))))))))))
+
+ (define (remove-duplicates data set)
+ (let loop ((originals data)
+ (data '())
+ (set set))
+ (if (null? originals)
+ (values data set)
+ (let ((x (car originals))
+ (originals (cdr originals)))
+ (if (memv x set)
+ (loop originals data set)
+ (loop originals (cons x data) (cons x set)))))))
+
+ (define (finish E fix chr sym other constants)
+ (if.else-set! E (simplify (if.else E) notepad2))
+ (analyze E fix chr sym other constants))
+
+ (define (analyze default fix chr sym other constants)
+ (notepad-var-add! notepad2 var0)
+ (for-each (lambda (L)
+ (notepad-lambda-add! notepad L))
+ (notepad.lambdas notepad2))
+ (for-each (lambda (L)
+ (notepad-nonescaping-add! notepad L))
+ (notepad.nonescaping notepad2))
+ (for-each (lambda (var)
+ (notepad-var-add! notepad var))
+ (append (list name:FIXNUM?
+ name:CHAR?
+ name:SYMBOL?
+ name:FX<
+ name:FX-
+ name:CHAR->INTEGER
+ name:VECTOR-REF)
+ (notepad.vars notepad2)))
+ (analyze-clauses (notepad.vars notepad2)
+ var0
+ default
+ (reverse fix)
+ (reverse chr)
+ (reverse sym)
+ (reverse other)
+ constants))
+
+ (collect-clauses E '() '() '() '() '()))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eqv-is-ok? x)
+ (or (smallint? x)
+ (char? x)
+ (symbol? x)
+ (boolean? x)))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eq-is-ok? x)
+ (eqv-is-ok? x))
+
+; Any case expression that dispatches on a variable var0 and whose
+; constants are disjoint can be compiled as
+;
+; (let ((n (cond ((eq? var0 'K1) ...) ; miscellaneous constants
+; ...
+; ((fixnum? var0)
+; <dispatch-on-fixnum>)
+; ((char? var0)
+; <dispatch-on-char>)
+; ((symbol? var0)
+; <dispatch-on-symbols>)
+; (else 0))))
+; <dispatch-on-case-number>)
+;
+; where the <dispatch-on-case-number> uses binary search within
+; the interval [0, p+1), where p is the number of non-default cases.
+;
+; On the SPARC, sequential search is faster if there are fewer than
+; 8 constants, and sequential search uses less than half the space
+; if there are fewer than 10 constants. Most target machines should
+; similar, so I'm hard-wiring this constant.
+; FIXME: The hardwired constant is annoying.
+
+(define (analyze-clauses F var0 default fix chr sym other constants)
+ (cond ((or (and (null? fix)
+ (null? chr))
+ (< (length constants) 12))
+ (implement-clauses-by-sequential-search var0
+ default
+ (append fix chr sym other)))
+ (else
+ (implement-clauses F var0 default fix chr sym other constants))))
+
+; Implements the general technique described above.
+
+(define (implement-clauses F var0 default fix chr sym other constants)
+ (let* ((name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ (entry (make-R-entry name:n '() '() '()))
+ (F (union (make-set (list name:n)) F))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-case-dispatch
+ name:n
+ (cons default
+ (map cadr
+ ; The order here must match the order
+ ; used by IMPLEMENT-DISPATCH.
+ (append other fix chr sym)))))))
+ (make-call L
+ (list (implement-dispatch 0
+ var0
+ (map car other)
+ (map car fix)
+ (map car chr)
+ (map car sym))))))
+
+(define (implement-case-dispatch var0 exprs)
+ (implement-intervals var0
+ (map (lambda (n code)
+ (list n (+ n 1) code))
+ (iota (length exprs))
+ exprs)))
+
+; Given the number of prior clauses,
+; the variable on which to dispatch,
+; a list of constant lists for mixed or miscellaneous clauses,
+; a list of constant lists for the fixnum clauses,
+; a list of constant lists for the character clauses, and
+; a list of constant lists for the symbol clauses,
+; returns code that computes the index of the selected clause.
+; The mixed/miscellaneous clauses must be tested first because
+; Twobit's SMALLINT? predicate might not be true of all fixnums
+; on the target machine, which means that Twobit might classify
+; some fixnums as miscellaneous.
+
+(define (implement-dispatch prior var0 other fix chr sym)
+ (cond ((not (null? other))
+ (implement-dispatch-other
+ (implement-dispatch (+ prior (length other))
+ var0 fix chr sym '())
+ prior var other))
+ ((not (null? fix))
+ (make-conditional (make-call (make-variable name:FIXNUM?)
+ (list (make-variable var0)))
+ (implement-dispatch-fixnum prior var0 fix)
+ (implement-dispatch (+ prior (length fix))
+ var0 '() chr sym other)))
+ ((not (null? chr))
+ (make-conditional (make-call (make-variable name:CHAR?)
+ (list (make-variable var0)))
+ (implement-dispatch-char prior var0 chr)
+ (implement-dispatch (+ prior (length chr))
+ var0 fix '() sym other)))
+ ((not (null? sym))
+ (make-conditional (make-call (make-variable name:SYMBOL?)
+ (list (make-variable var0)))
+ (implement-dispatch-symbol prior var0 sym)
+ (implement-dispatch (+ prior (length sym))
+ var0 fix chr '() other)))
+ (else
+ (make-constant 0))))
+
+; The value of var0 will be known to be a fixnum.
+; Can use table lookup, binary search, or sequential search.
+; FIXME: Never uses sequential search, which is best when
+; there are only a few constants, with gaps between them.
+
+(define (implement-dispatch-fixnum prior var0 lists)
+
+ (define (calculate-intervals n lists)
+ (define (loop n lists intervals)
+ (if (null? lists)
+ (twobit-sort (lambda (interval1 interval2)
+ (< (car interval1) (car interval2)))
+ intervals)
+ (let ((constants (twobit-sort < (car lists))))
+ (loop (+ n 1)
+ (cdr lists)
+ (append (extract-intervals n constants)
+ intervals)))))
+ (loop n lists '()))
+
+ (define (extract-intervals n constants)
+ (if (null? constants)
+ '()
+ (let ((k0 (car constants)))
+ (do ((constants (cdr constants) (cdr constants))
+ (k1 (+ k0 1) (+ k1 1)))
+ ((or (null? constants)
+ (not (= k1 (car constants))))
+ (cons (list k0 k1 (make-constant n))
+ (extract-intervals n constants)))))))
+
+ (define (complete-intervals intervals)
+ (cond ((null? intervals)
+ intervals)
+ ((null? (cdr intervals))
+ intervals)
+ (else
+ (let* ((i1 (car intervals))
+ (i2 (cadr intervals))
+ (end1 (cadr i1))
+ (start2 (car i2))
+ (intervals (complete-intervals (cdr intervals))))
+ (if (= end1 start2)
+ (cons i1 intervals)
+ (cons i1
+ (cons (list end1 start2 (make-constant 0))
+ intervals)))))))
+
+ (let* ((intervals (complete-intervals
+ (calculate-intervals (+ prior 1) lists)))
+ (lo (car (car intervals)))
+ (hi (car (car (reverse intervals))))
+ (p (length intervals)))
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant lo)))
+ (make-constant 0)
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant (+ hi 1))))
+ ; The static cost of table lookup is about hi - lo words.
+ ; The static cost of binary search is about 5 SPARC instructions
+ ; per interval.
+ (if (< (- hi lo) (* 5 p))
+ (implement-table-lookup var0 (+ prior 1) lists lo hi)
+ (implement-intervals var0 intervals))
+ (make-constant 0)))))
+
+(define (implement-dispatch-char prior var0 lists)
+ (let* ((lists (map (lambda (constants)
+ (map compat:char->integer constants))
+ lists))
+ (name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ ;(entry (make-R-entry name:n '() '() '()))
+ (F (list name:n name:EQ? name:FX< name:FX- name:VECTOR-REF))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-dispatch-fixnum prior name:n lists))))
+ (make-call L
+ (make-call (make-variable name:CHAR->INTEGER)
+ (list (make-variable var0))))))
+
+(define (implement-dispatch-symbol prior var0 lists)
+ (implement-dispatch-other (make-constant 0) prior var0 lists))
+
+(define (implement-dispatch-other default prior var0 lists)
+ (if (null? lists)
+ default
+ (let* ((constants (car lists))
+ (lists (cdr lists))
+ (n (+ prior 1)))
+ (make-conditional (make-call-to-memv var0 constants)
+ (make-constant n)
+ (implement-dispatch-other default n var0 lists)))))
+
+(define (make-call-to-memv var0 constants)
+ (cond ((null? constants)
+ (make-constant #f))
+ ((null? (cdr constants))
+ (make-call-to-eqv var0 (car constants)))
+ (else
+ (make-conditional (make-call-to-eqv var0 (car constants))
+ (make-constant #t)
+ (make-call-to-memv var0 (cdr constants))))))
+
+(define (make-call-to-eqv var0 constant)
+ (make-call (make-variable
+ (if (eq-is-ok? constant)
+ name:EQ?
+ name:EQV?))
+ (list (make-variable var0)
+ (make-constant constant))))
+
+; Given a variable whose value is known to be a fixnum,
+; the clause index for the first fixnum clause,
+; an ordered list of lists of constants for fixnum-only clauses,
+; and the least and greatest constants in those lists,
+; returns code for a table lookup.
+
+(define (implement-table-lookup var0 index lists lo hi)
+ (let ((v (make-vector (+ 1 (- hi lo)) 0)))
+ (do ((index index (+ index 1))
+ (lists lists (cdr lists)))
+ ((null? lists))
+ (for-each (lambda (k)
+ (vector-set! v (- k lo) index))
+ (car lists)))
+ (make-call (make-variable name:VECTOR-REF)
+ (list (make-constant v)
+ (make-call (make-variable name:FX-)
+ (list (make-variable var0)
+ (make-constant lo)))))))
+
+; Given a variable whose value is known to lie within the
+; half-open interval [m0, mk), and an ordered complete
+; list of intervals of the form
+;
+; ((m0 m1 code0)
+; (m1 m2 code1)
+; ...
+; (m{k-1} mk code{k-1})
+; )
+;
+; returns an expression that finds the unique i such that
+; var0 lies within [mi, m{i+1}), and then executes code{i}.
+
+(define (implement-intervals var0 intervals)
+ (if (null? (cdr intervals))
+ (caddr (car intervals))
+ (let ((n (quotient (length intervals) 2)))
+ (do ((n n (- n 1))
+ (intervals1 '() (cons (car intervals2) intervals1))
+ (intervals2 intervals (cdr intervals2)))
+ ((zero? n)
+ (let ((intervals1 (reverse intervals1))
+ (m (car (car intervals2))))
+ (make-conditional (make-call (make-variable name:FX<)
+ (list
+ (make-variable var0)
+ (make-constant m)))
+ (implement-intervals var0 intervals1)
+ (implement-intervals var0 intervals2))))))))
+
+; The brute force approach.
+; Given the variable on which the dispatch is being performed, and
+; actual (simplified) code for the default clause and
+; for all other clauses,
+; returns code to perform the dispatch by sequential search.
+
+(define *memq-threshold* 20)
+(define *memv-threshold* 4)
+
+(define (implement-clauses-by-sequential-search var0 default clauses)
+ (if (null? clauses)
+ default
+ (let* ((case1 (car clauses))
+ (clauses (cdr clauses))
+ (constants1 (car case1))
+ (code1 (cadr case1)))
+ (make-conditional (make-call-to-memv var0 constants1)
+ code1
+ (implement-clauses-by-sequential-search
+ var0 default clauses)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 13 April 1999.
+;
+; The tail and non-tail call graphs of known and unknown procedures.
+;
+; Given an expression E returned by pass 2 of Twobit,
+; returns a list of the following form:
+;
+; ((#t L () <tailcalls> <nontailcalls> <size> #f)
+; (<name> L <vars> <tailcalls> <nontailcalls> <size> #f)
+; ...)
+;
+; where
+;
+; Each L is a lambda expression that occurs within E
+; as either an escaping lambda expression or as a known
+; procedure. If L is a known procedure, then <name> is
+; its name; otherwise <name> is #f.
+;
+; <vars> is a list of the non-global variables within whose
+; scope L occurs.
+;
+; <tailcalls> is a complete list of names of known local procedures
+; that L calls tail-recursively, disregarding calls from other known
+; procedures or escaping lambda expressions that occur within L.
+;
+; <nontailcalls> is a complete list of names of known local procedures
+; that L calls non-tail-recursively, disregarding calls from other
+; known procedures or escaping lambda expressions that occur within L.
+;
+; <size> is a measure of the size of L, including known procedures
+; and escaping lambda expressions that occur within L.
+
+(define (callgraphnode.name x) (car x))
+(define (callgraphnode.code x) (cadr x))
+(define (callgraphnode.vars x) (caddr x))
+(define (callgraphnode.tailcalls x) (cadddr x))
+(define (callgraphnode.nontailcalls x) (car (cddddr x)))
+(define (callgraphnode.size x) (cadr (cddddr x)))
+(define (callgraphnode.info x) (caddr (cddddr x)))
+
+(define (callgraphnode.size! x v) (set-car! (cdr (cddddr x)) v) #f)
+(define (callgraphnode.info! x v) (set-car! (cddr (cddddr x)) v) #f)
+
+(define (callgraph exp)
+
+ ; Returns (union (list x) z).
+
+ (define (adjoin x z)
+ (if (memq x z)
+ z
+ (cons x z)))
+
+ (let ((result '()))
+
+ ; Given a <name> as described above, a lambda expression, a list
+ ; of variables that are in scope, and a list of names of known
+ ; local procedure that are in scope, computes an entry for L and
+ ; entries for any nested known procedures or escaping lambda
+ ; expressions, and adds them to the result.
+
+ (define (add-vertex! name L vars known)
+
+ (let ((tailcalls '())
+ (nontailcalls '())
+ (size 0))
+
+ ; Given an expression, a list of variables that are in scope,
+ ; a list of names of known local procedures that are in scope,
+ ; and a boolean indicating whether the expression occurs in a
+ ; tail context, adds any tail or non-tail calls to known
+ ; procedures that occur within the expression to the list
+ ; variables declared above.
+
+ (define (graph! exp vars known tail?)
+ (set! size (+ size 1))
+ (case (car exp)
+
+ ((quote) #f)
+
+ ((lambda) (add-vertex! #f exp vars known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+
+ ((set!) (graph! (assignment.rhs exp) vars known #f))
+
+ ((if) (graph! (if.test exp) vars known #f)
+ (graph! (if.then exp) vars known tail?)
+ (graph! (if.else exp) vars known tail?))
+
+ ((begin) (if (not (variable? exp))
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (graph! (car exprs) vars known tail?))
+ (graph! (car exprs) vars known #f))))
+
+ (else (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let ((name (variable.name proc)))
+ (if (memq name known)
+ (if tail?
+ (set! tailcalls
+ (adjoin name tailcalls))
+ (set! nontailcalls
+ (adjoin name nontailcalls))))))
+ ((lambda? proc)
+ (graph-lambda! proc vars known tail?))
+ (else
+ (graph! proc vars known #f)))
+ (for-each (lambda (exp)
+ (graph! exp vars known #f))
+ (call.args exp))))))
+
+ (define (graph-lambda! L vars known tail?)
+ (let* ((defs (lambda.defs L))
+ (newknown (map def.lhs defs))
+ (vars (append newknown
+ (make-null-terminated
+ (lambda.args L))
+ vars))
+ (known (append newknown known)))
+ (for-each (lambda (def)
+ (add-vertex! (def.lhs def)
+ (def.rhs def)
+ vars
+ known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+ defs)
+ (graph! (lambda.body L) vars known tail?)))
+
+ (graph-lambda! L vars known #t)
+
+ (set! result
+ (cons (list name L vars tailcalls nontailcalls size #f)
+ result))))
+
+ (add-vertex! #t
+ (make-lambda '() '() '() '() '() '() '() exp)
+ '()
+ '())
+ result))
+
+; Displays the callgraph, for debugging.
+
+(define (view-callgraph g)
+ (for-each (lambda (entry)
+ (let ((name (callgraphnode.name entry))
+ (exp (callgraphnode.code entry))
+ (vars (callgraphnode.vars entry))
+ (tail (callgraphnode.tailcalls entry))
+ (nt (callgraphnode.nontailcalls entry))
+ (size (callgraphnode.size entry)))
+ (cond ((symbol? name)
+ (write name))
+ (name
+ (display "TOP LEVEL EXPRESSION"))
+ (else
+ (display "ESCAPING LAMBDA EXPRESSION")))
+ (display ":")
+ (newline)
+ (display "Size: ")
+ (write size)
+ (newline)
+ ;(newline)
+ ;(display "Variables in scope: ")
+ ;(write vars)
+ ;(newline)
+ (display "Tail calls: ")
+ (write tail)
+ (newline)
+ (display "Non-tail calls: ")
+ (write nt)
+ (newline)
+ ;(newline)
+ ;(pretty-print (make-readable exp))
+ ;(newline)
+ ;(newline)
+ (newline)))
+ g))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Inlining of known local procedures.
+;
+; First find the known and escaping procedures and compute the call graph.
+;
+; If a known local procedure is not called at all, then delete its code.
+;
+; If a known local procedure is called exactly once,
+; then inline its code at the call site and delete the
+; known local procedure. Change the size of the code
+; at the call site by adding the size of the inlined code.
+;
+; Divide the remaining known and escaping procedures into categories:
+; 1. makes no calls to known local procedures
+; 2. known procedures that call known procedures;
+; within this category, try to sort so that procedures do not
+; call procedures that come later in the sequence; or sort by
+; number of calls and/or size
+; 3. escaping procedures that call known procedures
+;
+; Approve each procedure in category 1 for inlining if its code size
+; is less than some threshold.
+;
+; For each procedure in categories 2 and 3, traverse its code, inlining
+; where it seems like a good idea. The compiler should be more aggressive
+; about inlining non-tail calls than tail calls because:
+;
+; Inlining a non-tail call can eliminate a stack frame
+; or expose the inlined code to loop optimizations.
+;
+; The main reason for inlining a tail call is to enable
+; intraprocedural optimizations or to unroll a loop.
+;
+; After inlining has been performed on a known local procedure,
+; then approve it for inlining if its size is less than some threshold.
+;
+; FIXME:
+; This strategy avoids infinite unrolling, but it also avoids finite
+; unrolling of loops.
+
+; Parameters to control inlining.
+; These can be tuned later.
+
+(define *tail-threshold* 10)
+(define *nontail-threshold* 20)
+(define *multiplier* 300)
+
+; Given a callgraph, performs inlining of known local procedures
+; by side effect. The original expression must then be copied to
+; reinstate Twobit's invariants.
+
+; FIXME: This code doesn't yet do the right thing with known local
+; procedures that aren't called or are called in exactly one place.
+
+(define (inline-using-callgraph! g)
+ (let ((known (make-hashtable))
+ (category2 '())
+ (category3 '()))
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (tcalls (callgraphnode.tailcalls node))
+ (ncalls (callgraphnode.nontailcalls node)))
+ (if (symbol? name)
+ (hashtable-put! known name node))
+ (if (and (null? tcalls)
+ (null? ncalls))
+ (if (< (callgraphnode.size node)
+ *nontail-threshold*)
+ (callgraphnode.info! node #t))
+ (if (symbol? name)
+ (set! category2 (cons node category2))
+ (set! category3 (cons node category3))))))
+ g)
+ (set! category2 (twobit-sort (lambda (x y)
+ (< (callgraphnode.size x)
+ (callgraphnode.size y)))
+ category2))
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category2)
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category3)
+ ; FIXME:
+ ; Inlining destroys the callgraph, so maybe this cleanup is useless.
+ (hashtable-for-each (lambda (name node) (callgraphnode.info! node #f))
+ known)))
+
+; Given a node of the callgraph and a hash table of nodes for
+; known local procedures, performs inlining by side effect.
+
+(define (inline-node! node known)
+ (let* ((debugging? #f)
+ (name (callgraphnode.name node))
+ (exp (callgraphnode.code node))
+ (size0 (callgraphnode.size node))
+ (budget (quotient (* (- *multiplier* 100) size0) 100))
+ (tail-threshold *tail-threshold*)
+ (nontail-threshold *nontail-threshold*))
+
+ ; Given an expression,
+ ; a boolean indicating whether the expression is in a tail context,
+ ; a list of procedures that should not be inlined,
+ ; and a size budget,
+ ; performs inlining by side effect and returns the unused budget.
+
+ (define (inline exp tail? budget)
+ (if (positive? budget)
+
+ (case (car exp)
+
+ ((quote lambda)
+ budget)
+
+ ((set!)
+ (inline (assignment.rhs exp) #f budget))
+
+ ((if)
+ (let* ((budget (inline (if.test exp) #f budget))
+ (budget (inline (if.then exp) tail? budget))
+ (budget (inline (if.else exp) tail? budget)))
+ budget))
+
+ ((begin)
+ (if (variable? exp)
+ budget
+ (do ((exprs (begin.exprs exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? (cdr exprs))
+ (inline (car exprs) tail? budget)))))
+
+ (else
+ (let ((budget (do ((exprs (call.args exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? exprs)
+ budget))))
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname)))
+ (if procnode
+ (let ((size (callgraphnode.size procnode))
+ (info (callgraphnode.info procnode)))
+ (if (and info
+ (<= size budget)
+ (<= size
+ (if tail?
+ tail-threshold
+ nontail-threshold)))
+ (begin
+ (if debugging?
+ (begin
+ (display " Inlining ")
+ (write (variable.name proc))
+ (newline)))
+ (call.proc-set!
+ exp
+ (copy-exp
+ (callgraphnode.code procnode)))
+ (callgraphnode.size!
+ node
+ (+ (callgraphnode.size node) size))
+ (- budget size))
+ (begin
+ (if (and #f debugging?)
+ (begin
+ (display " Declining to inline ")
+ (write (variable.name proc))
+ (newline)))
+ budget)))
+ budget)))
+ ((lambda? proc)
+ (inline (lambda.body proc) tail? budget))
+ (else
+ (inline proc #f budget)))))))
+ -1))
+
+ (if (and #f debugging?)
+ (begin
+ (display "Processing ")
+ (write name)
+ (newline)))
+
+ (let ((budget (inline (if (lambda? exp)
+ (lambda.body exp)
+ exp)
+ #t
+ budget)))
+ (if (and (negative? budget)
+ debugging?)
+ ; This shouldn't happen very often.
+ (begin (display "Ran out of inlining budget for ")
+ (write (callgraphnode.name node))
+ (newline)))
+ (if (<= (callgraphnode.size node) nontail-threshold)
+ (callgraphnode.info! node #t))
+ #f)))
+
+; For testing.
+
+(define (test-inlining test0)
+ (begin (define exp0 (begin (display "Compiling...")
+ (newline)
+ (pass2 (pass1 test0))))
+ (define g0 (begin (display "Computing call graph...")
+ (newline)
+ (callgraph exp0))))
+ (display "Inlining...")
+ (newline)
+ (inline-using-callgraph! g0)
+ (pretty-print (make-readable (copy-exp exp0))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Interprocedural constant propagation and folding.
+;
+; Constant propagation must converge before constant folding can be
+; performed. Constant folding creates more constants that can be
+; propagated, so these two optimizations must be iterated, but it
+; is safe to stop at any time.
+;
+; Abstract interpretation for constant folding.
+;
+; The abstract values are
+; bottom (represented here by #f)
+; constants (represented by quoted literals)
+; top (represented here by #t)
+;
+; Let [[ E ]] be the abstract interpretation of E over that domain
+; of abstract values, with respect to some arbitrary set of abstract
+; values for local variables.
+;
+; If a is a global variable or a formal parameter of an escaping
+; lambda expression, then [[ a ]] = #t.
+;
+; If x is the ith formal parameter of a known local procedure f,
+; then [[ x ]] = \join_{(f E1 ... En)} [[ Ei ]].
+;
+; [[ K ]] = K
+; [[ L ]] = #t
+; [[ (begin E1 ... En) ]] = [[ En ]]
+; [[ (set! I E) ]] = #f
+;
+; If [[ E0 ]] = #t, then [[ (if E0 E1 E2) ]] = [[ E1 ]] \join [[ E2 ]]
+; else if [[ E0 ]] = K, then [[ (if E0 E1 E2) ]] = [[ E1 ]]
+; or [[ (if E0 E1 E2) ]] = [[ E2 ]]
+; depending upon K
+; else [[ (if E0 E1 E2) ]] = #f
+;
+; If f is a known local procedure with body E,
+; then [[ (f E1 ... En) ]] = [[ E ]]
+;
+; If g is a foldable integrable procedure, then:
+; if there is some i for which [[ Ei ]] = #t,
+; then [[ (g E1 ... En) ]] = #t
+; else if [[ E1 ]] = K1, ..., [[ En ]] = Kn,
+; then [[ (g E1 ... En) ]] = (g K1 ... Kn)
+; else [[ (g E1 ... En) ]] = #f
+;
+; Symbolic representations of abstract values.
+; (Can be thought of as mappings from abstract environments to
+; abstract values.)
+;
+; <symbolic> ::= #t | ( <expressions> )
+; <expressions> ::= <empty> | <expression> <expressions>
+
+; Parameter to limit constant propagation and folding.
+; This parameter can be tuned later.
+
+(define *constant-propagation-limit* 5)
+
+; Given an expression as output by pass 2, performs constant
+; propagation and folding.
+
+(define (constant-propagation exp)
+ (define (constant-propagation exp i)
+ (if (< i *constant-propagation-limit*)
+ (begin
+ ;(display "Performing constant propagation and folding...")
+ ;(newline)
+ (let* ((g (callgraph exp))
+ (L (callgraphnode.code (car g)))
+ (variables (constant-propagation-using-callgraph g))
+ (changed? (constant-folding! L variables)))
+ (if changed?
+ (constant-propagation (lambda.body L) (+ i 1))
+ (lambda.body L))))))
+ (constant-propagation exp 0))
+
+; Given a callgraph, returns a hashtable of abstract values for
+; all local variables.
+
+(define (constant-propagation-using-callgraph g)
+ (let ((debugging? #f)
+ (folding? (integrate-usual-procedures))
+ (known (make-hashtable))
+ (variables (make-hashtable))
+ (counter 0))
+
+ ; Computes joins of abstract values.
+
+ (define (join x y)
+ (cond ((boolean? x)
+ (if x #t y))
+ ((boolean? y)
+ (join y x))
+ ((equal? x y)
+ x)
+ (else #t)))
+
+ ; Given a <symbolic> and a vector of abstract values,
+ ; evaluates the <symbolic> and returns its abstract value.
+
+ (define (aeval rep env)
+ (cond ((eq? rep #t)
+ #t)
+ ((null? rep)
+ #f)
+ ((null? (cdr rep))
+ (aeval1 (car rep) env))
+ (else
+ (join (aeval1 (car rep) env)
+ (aeval (cdr rep) env)))))
+
+ (define (aeval1 exp env)
+
+ (case (car exp)
+
+ ((quote)
+ exp)
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ #f)
+
+ ((begin)
+ (if (variable? exp)
+ (let* ((name (variable.name exp))
+ (i (hashtable-get variables name)))
+ (if i
+ (vector-ref env i)
+ #t))
+ (aeval1-error)))
+
+ ((if)
+ (let* ((val0 (aeval1 (if.test exp) env))
+ (val1 (aeval1 (if.then exp) env))
+ (val2 (aeval1 (if.else exp) env)))
+ (cond ((eq? val0 #t)
+ (join val1 val2))
+ ((pair? val0)
+ (if (constant.value val0)
+ val1
+ val2))
+ (else
+ #f))))
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (vals '() (cons (aeval1 (car exprs) env) vals)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (vector-ref env
+ (hashtable-get variables
+ procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else (aeval1-error)))))
+ (else
+ (aeval1-error)))))))))
+
+ (define (aeval1-error)
+ (error "Compiler bug: constant propagation (aeval1)"))
+
+ ; Combines two <symbolic>s.
+
+ (define (combine-symbolic rep1 rep2)
+ (cond ((eq? rep1 #t) #t)
+ ((eq? rep2 #t) #t)
+ (else
+ (append rep1 rep2))))
+
+ ; Given an expression, returns a <symbolic> that represents
+ ; a list of expressions whose abstract values can be joined
+ ; to obtain the abstract value of the given expression.
+ ; As a side effect, enters local variables into variables.
+
+ (define (collect! exp)
+
+ (case (car exp)
+
+ ((quote)
+ (list exp))
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ (collect! (assignment.rhs exp))
+ '())
+
+ ((begin)
+ (if (variable? exp)
+ (list exp)
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (collect! (car exprs)))
+ (collect! (car exprs)))))
+
+ ((if)
+ (collect! (if.test exp))
+ (collect! (if.then exp))
+ (collect! (if.else exp))
+ #t)
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (reps '() (cons (collect! (car exprs)) reps)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (define (put-args! args reps)
+ (cond ((pair? args)
+ (let ((v (car args))
+ (rep (car reps)))
+ (hashtable-put! variables v rep)
+ (put-args! (cdr args) (cdr reps))))
+ ((symbol? args)
+ (hashtable-put! variables args #t))
+ (else #f)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (for-each (lambda (v rep)
+ (hashtable-put!
+ variables
+ v
+ (combine-symbolic
+ rep (hashtable-get variables v))))
+ (lambda.args
+ (callgraphnode.code procnode))
+ reps)
+ (list (make-variable procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else #t))))
+ ((lambda? proc)
+ (put-args! (lambda.args proc) reps)
+ (collect! (lambda.body proc)))
+ (else
+ (collect! proc)
+ #t))))))))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (known? (symbol? name))
+ (rep (if known? '() #t)))
+ (if known?
+ (hashtable-put! known name node))
+ (if (lambda? code)
+ (for-each (lambda (var)
+ (hashtable-put! variables var rep))
+ (make-null-terminated (lambda.args code))))))
+ g)
+
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (code (callgraphnode.code node)))
+ (cond ((symbol? name)
+ (hashtable-put! variables
+ name
+ (collect! (lambda.body code))))
+ (else
+ (collect! (lambda.body code))))))
+ g)
+
+ (if (and #f debugging?)
+ (begin
+ (hashtable-for-each (lambda (v rep)
+ (write v)
+ (display ": ")
+ (write rep)
+ (newline))
+ variables)
+
+ (display "----------------------------------------")
+ (newline)))
+
+ ;(trace aeval aeval1)
+
+ (let* ((n (hashtable-size variables))
+ (vars (hashtable-map (lambda (v rep) v) variables))
+ (reps (map (lambda (v) (hashtable-get variables v)) vars))
+ (init (make-vector n #f))
+ (next (make-vector n)))
+ (do ((i 0 (+ i 1))
+ (vars vars (cdr vars))
+ (reps reps (cdr reps)))
+ ((= i n))
+ (hashtable-put! variables (car vars) i)
+ (vector-set! next
+ i
+ (let ((rep (car reps)))
+ (lambda (env)
+ (aeval rep env)))))
+ (compute-fixedpoint init next equal?)
+ (for-each (lambda (v)
+ (let* ((i (hashtable-get variables v))
+ (aval (vector-ref init i)))
+ (hashtable-put! variables v aval)
+ (if (and debugging?
+ (not (eq? aval #t)))
+ (begin (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))
+ vars)
+ variables)))
+
+; Given a lambda expression, performs constant propagation, folding,
+; and simplifications by side effect, using the abstract values in the
+; hash table of variables.
+; Returns #t if any new constants were created by constant folding,
+; otherwise returns #f.
+
+(define (constant-folding! L variables)
+ (let ((debugging? #f)
+ (msg1 " Propagating constant value for ")
+ (msg2 " Folding: ")
+ (msg3 " ==> ")
+ (folding? (integrate-usual-procedures))
+ (changed? #f))
+
+ ; Given a known lambda expression L, its original formal parameters,
+ ; and a list of all calls to L, deletes arguments that are now
+ ; ignored because of constant propagation.
+
+ (define (delete-ignored-args! L formals0 calls)
+ (let ((formals1 (lambda.args L)))
+ (for-each (lambda (call)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (args (call.args call)
+ (cdr args))
+ (newargs '()
+ (if (and (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ newargs
+ (cons (car args) newargs))))
+ ((null? formals0)
+ (call.args-set! call (reverse newargs)))))
+ calls)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (formals2 '()
+ (if (and (not (eq? (car formals0)
+ (car formals1)))
+ (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ formals2
+ (cons (car formals1) formals2))))
+ ((null? formals0)
+ (lambda.args-set! L (reverse formals2))))))
+
+ (define (fold! exp)
+
+ (case (car exp)
+
+ ((quote) exp)
+
+ ((lambda)
+ (let ((Rinfo (lambda.R exp))
+ (known (map def.lhs (lambda.defs exp))))
+ (for-each (lambda (entry)
+ (let* ((v (R-entry.name entry))
+ (aval (hashtable-fetch variables v #t)))
+ (if (and (pair? aval)
+ (not (memq v known)))
+ (let ((x (constant.value aval)))
+ (if (or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (number? x)
+ (char? x)
+ (and (vector? x)
+ (zero? (vector-length x))))
+ (let ((refs (R-entry.references entry)))
+ (for-each (lambda (ref)
+ (variable-set! ref aval))
+ refs)
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp)))
+ (flag-as-ignored v exp)
+ (if debugging?
+ (begin (display msg1)
+ (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))))))
+ Rinfo)
+ (for-each (lambda (def)
+ (let* ((name (def.lhs def))
+ (rhs (def.rhs def))
+ (entry (R-lookup Rinfo name))
+ (calls (R-entry.calls entry)))
+ (if (null? calls)
+ (begin (lambda.defs-set!
+ exp
+ (remq def (lambda.defs exp)))
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp))))
+ (let* ((formals0 (append (lambda.args rhs) '()))
+ (L (fold! rhs))
+ (formals1 (lambda.args L)))
+ (if (not (equal? formals0 formals1))
+ (delete-ignored-args! L formals0 calls))))))
+ (lambda.defs exp))
+ (lambda.body-set!
+ exp
+ (fold! (lambda.body exp)))
+ exp))
+
+ ((set!)
+ (assignment.rhs-set! exp (fold! (assignment.rhs exp)))
+ exp)
+
+ ((begin)
+ (if (variable? exp)
+ exp
+ (post-simplify-begin (make-begin (map fold! (begin.exprs exp)))
+ (make-notepad #f))))
+
+ ((if)
+ (let ((exp0 (fold! (if.test exp)))
+ (exp1 (fold! (if.then exp)))
+ (exp2 (fold! (if.else exp))))
+ (if (constant? exp0)
+ (let ((newexp (if (constant.value exp0)
+ exp1
+ exp2)))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable exp))
+ (display msg3)
+ (write (make-readable newexp))
+ (newline)))
+ (set! changed? #t)
+ newexp)
+ (make-conditional exp0 exp1 exp2))))
+
+ (else
+ (let ((args (map fold! (call.args exp)))
+ (proc (fold! (call.proc exp))))
+ (cond ((and folding?
+ (variable? proc)
+ (every? constant? args)
+ (let ((entry
+ (constant-folding-entry (variable.name proc))))
+ (and entry
+ (let ((preds
+ (constant-folding-predicates entry)))
+ (and (= (length args) (length preds))
+ (every?
+ (lambda (x) x)
+ (map (lambda (f v) (f v))
+ (constant-folding-predicates entry)
+ (map constant.value args))))))))
+ (set! changed? #t)
+ (let ((result
+ (make-constant
+ (apply (constant-folding-folder
+ (constant-folding-entry
+ (variable.name proc)))
+ (map constant.value args)))))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable (make-call proc args)))
+ (display msg3)
+ (write result)
+ (newline)))
+ result))
+ ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ ; FIXME: Folding should be done even if there is
+ ; a rest argument.
+ (let loop ((formals (reverse (lambda.args proc)))
+ (actuals (reverse args))
+ (processed-formals '())
+ (processed-actuals '())
+ (for-effect '()))
+ (cond ((null? formals)
+ (lambda.args-set! proc processed-formals)
+ (call.args-set! exp processed-actuals)
+ (let ((call (if (and (null? processed-formals)
+ (null? (lambda.defs proc)))
+ (lambda.body proc)
+ exp)))
+ (if (null? for-effect)
+ call
+ (post-simplify-begin
+ (make-begin
+ (reverse (cons call for-effect)))
+ (make-notepad #f)))))
+ ((ignored? (car formals))
+ (loop (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else
+ (loop (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect)))))
+ (else
+ (call.proc-set! exp proc)
+ (call.args-set! exp args)
+ exp))))))
+
+ (fold! L)
+ changed?))
+; Copyright 1998 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Conversion to A-normal form, with heuristics for
+; choosing a good order of evaluation.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * There are no sequential expressions.
+; * The output is an expression E with syntax
+;
+; E --> A
+; | (L)
+; | (L A)
+;
+; A --> W
+; | L
+; | (W_0 W_1 ...)
+; | (set! I W)
+; | (if W E1 E2)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; In other words:
+; An expression is a LET* such that the rhs of every binding is
+; a conditional with the test already evaluated, or
+; an expression that can be evaluated in one step
+; (treating function calls as a single step)
+;
+; A-normal form corresponds to the control flow graph for a lambda
+; expression.
+
+; Algorithm: repeated use of these rules:
+;
+; (E0 E1 ...) ((lambda (T0 T1 ...) (T0 T1 ...))
+; E0 E1 ...)
+; (set! I E) ((lambda (T) (set! I T)) E)
+; (if E0 E1 E2) ((lambda (T) (if T E1 E2)) E0)
+; (begin E0 E1 E2 ...) ((lambda (T) (begin E1 E2 ...)) E0)
+;
+; ((lambda (I1 I2 I3 ...) E) ((lambda (I1)
+; E1 E2 E3) ((lambda (I2 I3 ...) E)
+; E2 E3))
+; E1)
+;
+; ((lambda (I2) E) ((lambda (I1)
+; ((lambda (I1) E2) ((lambda (I2) E)
+; E1)) E2)
+; E1)
+;
+; In other words:
+; Introduce a temporary name for every expression except:
+; tail expressions
+; the alternatives of a non-tail conditional
+; Convert every LET into a LET*.
+; Get rid of LET* on the right hand side of a binding.
+
+; Given an expression E in the representation output by pass 2,
+; returns an A-normal form for E in that representation.
+; Except for quoted values, the A-normal form does not share
+; mutable structure with the original expression E.
+;
+; KNOWN BUG:
+;
+; If you call A-normal on a form that has already been converted
+; to A-normal form, then the same temporaries will be generated
+; twice. An optional argument lets you specify a different prefix
+; for temporaries the second time around. Example:
+;
+; (A-normal-form (A-normal-form E ".T")
+; ".U")
+
+; This is the declaration that is used to indicate A-normal form.
+
+(define A-normal-form-declaration (list 'anf))
+
+(define (A-normal-form E . rest)
+
+ (define (A-normal-form E)
+ (anf-make-let* (anf E '() '())))
+
+ ; New temporaries.
+
+ (define temp-counter 0)
+
+ (define temp-prefix
+ (if (or (null? rest)
+ (not (string? (car rest))))
+ (string-append renaming-prefix "T")
+ (car rest)))
+
+ (define (newtemp)
+ (set! temp-counter (+ temp-counter 1))
+ (string->symbol
+ (string-append temp-prefix
+ (number->string temp-counter))))
+
+ ; Given an expression E as output by pass 2,
+ ; a list of surrounding LET* bindings,
+ ; and an ordered list of likely register variables,
+ ; return a non-empty list of LET* bindings
+ ; whose first binding associates a dummy variable
+ ; with an A-expression giving the value for E.
+
+ (define (anf E bindings regvars)
+ (case (car E)
+ ((quote) (anf-bind-dummy E bindings))
+ ((begin) (if (variable? E)
+ (anf-bind-dummy E bindings)
+ (anf-sequential E bindings regvars)))
+ ((lambda) (anf-lambda E bindings regvars))
+ ((set!) (anf-assignment E bindings regvars))
+ ((if) (anf-conditional E bindings regvars))
+ (else (anf-call E bindings regvars))))
+
+ (define anf:dummy (string->symbol "RESULT"))
+
+ (define (anf-bind-dummy E bindings)
+ (cons (list anf:dummy E)
+ bindings))
+
+ ; Unlike anf-bind-dummy, anf-bind-name and anf-bind convert
+ ; their expression argument to A-normal form.
+ ; Don't change anf-bind to call anf-bind-name, because that
+ ; would name the temporaries in an aesthetically bad order.
+
+ (define (anf-bind-name name E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list name (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-bind E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list (newtemp) (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-result bindings)
+ (make-variable (car (car bindings))))
+
+ (define (anf-make-let* bindings)
+ (define (loop bindings body)
+ (if (null? bindings)
+ body
+ (let ((T1 (car (car bindings)))
+ (E1 (cadr (car bindings))))
+ (loop (cdr bindings)
+ (make-call (make-lambda (list T1)
+ '()
+ '()
+ '()
+ '()
+ (list A-normal-form-declaration)
+ '()
+ body)
+ (list E1))))))
+ (loop (cdr bindings)
+ (cadr (car bindings))))
+
+ (define (anf-sequential E bindings regvars)
+ (do ((bindings bindings
+ (anf-bind (car exprs) bindings regvars))
+ (exprs (begin.exprs E)
+ (cdr exprs)))
+ ((null? (cdr exprs))
+ (anf (car exprs) bindings regvars))))
+
+ ; Heuristic: the formal parameters of an escaping lambda or
+ ; known local procedure are kept in REG1, REG2, et cetera.
+
+ (define (anf-lambda L bindings regvars)
+ (anf-bind-dummy
+ (make-lambda (lambda.args L)
+ (map (lambda (def)
+ (make-definition
+ (def.lhs def)
+ (A-normal-form (def.rhs def))))
+ (lambda.defs L))
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls L))
+ (lambda.doc L)
+ (anf-make-let*
+ (anf (lambda.body L)
+ '()
+ (make-null-terminated (lambda.args L)))))
+ bindings))
+
+ (define (anf-assignment E bindings regvars)
+ (let ((I (assignment.lhs E))
+ (E1 (assignment.rhs E)))
+ (if (variable? E1)
+ (anf-bind-dummy E bindings)
+ (let* ((bindings (anf-bind E1 bindings regvars))
+ (T1 (anf-result bindings)))
+ (anf-bind-dummy (make-assignment I T1) bindings)))))
+
+ (define (anf-conditional E bindings regvars)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (variable? E0)
+ (let ((E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional E0 E1 E2)
+ bindings))
+ (let* ((bindings (anf-bind E0 bindings regvars))
+ (E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional (anf-result bindings) E1 E2)
+ bindings)))))
+
+ (define (anf-call E bindings regvars)
+ (let* ((proc (call.proc E))
+ (args (call.args E)))
+
+ ; Evaluates the exprs and returns both a list of bindings and
+ ; a list of the temporaries that name the results of the exprs.
+ ; If rename-always? is true, then temporaries are generated even
+ ; for constants and temporaries.
+
+ (define (loop exprs bindings names rename-always?)
+ (if (null? exprs)
+ (values bindings (reverse names))
+ (let ((E (car exprs)))
+ (if (or rename-always?
+ (not (or (constant? E)
+ (variable? E))))
+ (let* ((bindings
+ (anf-bind (car exprs) bindings regvars)))
+ (loop (cdr exprs)
+ bindings
+ (cons (anf-result bindings) names)
+ rename-always?))
+ (loop (cdr exprs)
+ bindings
+ (cons E names)
+ rename-always?)))))
+
+ ; Evaluates the exprs, binding them to the vars, and returns
+ ; a list of bindings.
+ ;
+ ; Although LET variables are likely to be kept in registers,
+ ; trying to guess which register will be allocated is likely
+ ; to do more harm than good.
+
+ (define (let-loop exprs bindings regvars vars)
+ (if (null? exprs)
+ (if (null? (lambda.defs proc))
+ (anf (lambda.body proc)
+ bindings
+ regvars)
+ (let ((bindings
+ (anf-bind
+ (make-lambda '()
+ (lambda.defs proc)
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls proc))
+ (lambda.doc proc)
+ (lambda.body proc))
+ bindings
+ '())))
+ (anf-bind-dummy
+ (make-call (anf-result bindings) '())
+ bindings)))
+ (let-loop (cdr exprs)
+ (anf-bind-name (car vars)
+ (car exprs)
+ bindings
+ regvars)
+ regvars
+ (cdr vars))))
+
+ (cond ((lambda? proc)
+ (let ((formals (lambda.args proc)))
+ (if (list? formals)
+ (let* ((pi (anf-order-of-evaluation args regvars #f))
+ (exprs (permute args pi))
+ (names (permute (lambda.args proc) pi)))
+ (let-loop (reverse exprs) bindings regvars (reverse names)))
+ (anf-call (normalize-let E) bindings regvars))))
+
+ ((not (variable? proc))
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((bindings (anf-bind proc bindings regvars)))
+ (anf-bind-dummy
+ (make-call (anf-result bindings)
+ (unpermute names pi))
+ bindings))))))
+
+ ((and (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (let ((pi (anf-order-of-evaluation args regvars #t)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings)))))
+
+ ((memq (variable.name proc) regvars)
+ (let* ((exprs (cons proc args))
+ (pi (anf-order-of-evaluation
+ exprs
+ (cons name:IGNORED regvars)
+ #f)))
+ (call-with-values
+ (lambda () (loop (permute exprs pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((names (unpermute names pi)))
+ (anf-bind-dummy
+ (make-call (car names) (cdr names))
+ bindings))))))
+
+ (else
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings))))))))
+
+ ; Given a list of expressions, a list of likely register contents,
+ ; and a switch telling whether these are arguments for a primop
+ ; or something else (such as the arguments for a real call),
+ ; try to choose a good order in which to evaluate the expressions.
+ ;
+ ; Heuristic: If none of the expressions is a call to a non-primop,
+ ; then parallel assignment optimization gives a good order if the
+ ; regvars are right, and should do no worse than a random order if
+ ; the regvars are wrong.
+ ;
+ ; Heuristic: If the expressions are arguments to a primop, and
+ ; none are a call to a non-primop, then the register contents
+ ; are irrelevant, and the first argument should be evaluated last.
+ ;
+ ; Heuristic: If one or more of the expressions is a call to a
+ ; non-primop, then the following should be a good order:
+ ;
+ ; expressions that are neither a constant, variable, or a call
+ ; calls to non-primops
+ ; constants and variables
+
+ (define (anf-order-of-evaluation exprs regvars for-primop?)
+ (define (ordering targets exprs alist)
+ (let ((para
+ (parallel-assignment targets alist exprs)))
+ (or para
+ ; Evaluate left to right until a parallel assignment is found.
+ (cons (car targets)
+ (ordering (cdr targets)
+ (cdr exprs)
+ alist)))))
+ (if (parallel-assignment-optimization)
+ (cond ((null? exprs) '())
+ ((null? (cdr exprs)) '(0))
+ (else
+ (let* ((contains-call? #f)
+ (vexprs (list->vector exprs))
+ (vindexes (list->vector
+ (iota (vector-length vexprs))))
+ (contains-call? #f)
+ (categories
+ (list->vector
+ (map (lambda (E)
+ (cond ((constant? E)
+ 2)
+ ((variable? E)
+ 2)
+ ((complicated? E)
+ (set! contains-call? #t)
+ 1)
+ (else
+ 0)))
+ exprs))))
+ (cond (contains-call?
+ (twobit-sort (lambda (i j)
+ (< (vector-ref categories i)
+ (vector-ref categories j)))
+ (iota (length exprs))))
+ (for-primop?
+ (reverse (iota (length exprs))))
+ (else
+ (let ((targets (iota (length exprs))))
+ (define (pairup regvars targets)
+ (if (or (null? targets)
+ (null? regvars))
+ '()
+ (cons (cons (car regvars)
+ (car targets))
+ (pairup (cdr regvars)
+ (cdr targets)))))
+ (ordering targets
+ exprs
+ (pairup regvars targets))))))))
+ (iota (length exprs))))
+
+ (define (permute things pi)
+ (let ((v (list->vector things)))
+ (map (lambda (i) (vector-ref v i))
+ pi)))
+
+ (define (unpermute things pi)
+ (let* ((v0 (list->vector things))
+ (v1 (make-vector (vector-length v0))))
+ (do ((pi pi (cdr pi))
+ (k 0 (+ k 1)))
+ ((null? pi)
+ (vector->list v1))
+ (vector-set! v1 (car pi) (vector-ref v0 k)))))
+
+ ; Given a call whose procedure is a lambda expression that has
+ ; a rest argument, return a genuine let expression.
+
+ (define (normalize-let-error exp)
+ (if (issue-warnings)
+ (begin (display "WARNING from compiler: ")
+ (display "Wrong number of arguments ")
+ (display "to lambda expression")
+ (newline)
+ (pretty-print (make-readable exp) #t)
+ (newline))))
+
+ (define (normalize-let exp)
+ (let* ((L (call.proc exp)))
+ (let loop ((formals (lambda.args L))
+ (args (call.args exp))
+ (newformals '())
+ (newargs '()))
+ (cond ((null? formals)
+ (if (null? args)
+ (begin (lambda.args-set! L (reverse newformals))
+ (call.args-set! exp (reverse newargs)))
+ (begin (normalize-let-error exp)
+ (loop (list (newtemp))
+ args
+ newformals
+ newargs))))
+ ((pair? formals)
+ (if (pair? args)
+ (loop (cdr formals)
+ (cdr args)
+ (cons (car formals) newformals)
+ (cons (car args) newargs))
+ (begin (normalize-let-error exp)
+ (loop formals
+ (cons (make-constant 0)
+ args)
+ newformals
+ newargs))))
+ (else
+ (loop (list formals)
+ (list (make-call-to-list args))
+ newformals
+ newargs))))))
+
+ ; For heuristic use only.
+ ; An expression is complicated unless it can probably be evaluated
+ ; without saving and restoring any registers, even if it occurs in
+ ; a non-tail position.
+
+ (define (complicated? exp)
+ ; Let's not spend all day on this.
+ (let ((budget 10))
+ (define (complicated? exp)
+ (set! budget (- budget 1))
+ (if (zero? budget)
+ #t
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (complicated? (assignment.rhs exp)))
+ ((if) (or (complicated? (if.test exp))
+ (complicated? (if.then exp))
+ (complicated? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? complicated?
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (some? complicated?
+ (call.args exp))
+ #t))))))
+ (complicated? exp)))
+
+ (A-normal-form E))
+(define (post-simplify-anf L0 T1 E0 E1 free regbindings L2)
+
+ (define (return-normally)
+ (values (make-call L0 (list E1))
+ free
+ regbindings))
+
+ (return-normally))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Intraprocedural common subexpression elimination, constant propagation,
+; copy propagation, dead code elimination, and register targeting.
+;
+; (intraprocedural-commoning E 'commoning)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an optimized
+; A-normal form with correct free variables but incorrect referencing
+; information.
+;
+; (intraprocedural-commoning E 'target-registers)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an A-normal form
+; with correct free variables but incorrect referencing information,
+; and in which MacScheme machine register names are used as temporary
+; variables. The result is alpha-converted except for register names.
+;
+; (intraprocedural-commoning E 'commoning 'target-registers)
+; (intraprocedural-commoning E)
+;
+; Given an A-normal form as described above, returns an optimized
+; form in which register names are used as temporary variables.
+
+; Semantics of .check!:
+;
+; (.check! b exn x ...) faults with code exn and arguments x ...
+; if b is #f.
+
+; The list of argument registers.
+; This can't go in pass3commoning.aux.sch because that file must be
+; loaded before the target-specific file that defines *nregs*.
+
+(define argument-registers
+ (do ((n (- *nregs* 2) (- n 1))
+ (regs '()
+ (cons (string->symbol
+ (string-append ".REG" (number->string n)))
+ regs)))
+ ((zero? n)
+ regs)))
+
+(define (intraprocedural-commoning E . flags)
+
+ (define target-registers? (or (null? flags) (memq 'target-registers flags)))
+ (define commoning? (or (null? flags) (memq 'commoning flags)))
+
+ (define debugging? #f)
+
+ (call-with-current-continuation
+ (lambda (return)
+
+ (define (error . stuff)
+ (display "Bug detected during intraprocedural optimization")
+ (newline)
+ (for-each (lambda (s)
+ (display s) (newline))
+ stuff)
+ (return (make-constant #f)))
+
+ ; Given an expression, an environment, the available expressions,
+ ; and an ordered list of likely register variables (used heuristically),
+ ; returns the transformed expression and its set of free variables.
+
+ (define (scan-body E env available regvars)
+
+ ; The local variables are those that are bound by a LET within
+ ; this procedure. The formals of a lambda expression and the
+ ; known local procedures are counted as non-global, not local,
+ ; because there is no let-binding for a formal that can be
+ ; renamed during register targeting.
+ ; For each local variable, we keep track of how many times it
+ ; is referenced. This information is not accurate until we
+ ; are backing out of the recursion, and does not have to be.
+
+ (define local-variables (make-hashtable symbol-hash assq))
+
+ (define (local-variable? sym)
+ (hashtable-get local-variables sym))
+
+ (define (local-variable-not-used? sym)
+ (= 0 (hashtable-fetch local-variables sym -1)))
+
+ (define (local-variable-used-once? sym)
+ (= 1 (hashtable-fetch local-variables sym 0)))
+
+ (define (record-local-variable! sym)
+ (hashtable-put! local-variables sym 0))
+
+ (define (used-local-variable! sym)
+ (adjust-local-variable! sym 1))
+
+ (define (adjust-local-variable! sym n)
+ (let ((m (hashtable-get local-variables sym)))
+ (if debugging?
+ (if (and m (> m 0))
+ (begin (write (list sym (+ m n)))
+ (newline))))
+ (if m
+ (hashtable-put! local-variables
+ sym
+ (+ m n)))))
+
+ (define (closed-over-local-variable! sym)
+ ; Set its reference count to infinity so it won't be optimized away.
+ ; FIXME: One million isn't infinity.
+ (hashtable-put! local-variables sym 1000000))
+
+ (define (used-variable! sym)
+ (used-local-variable! sym))
+
+ (define (abandon-expression! E)
+ (cond ((variable? E)
+ (adjust-local-variable! (variable.name E) -1))
+ ((conditional? E)
+ (abandon-expression! (if.test E))
+ (abandon-expression! (if.then E))
+ (abandon-expression! (if.else E)))
+ ((call? E)
+ (for-each (lambda (exp)
+ (if (variable? exp)
+ (let ((name (variable.name exp)))
+ (if (local-variable? name)
+ (adjust-local-variable! name -1)))))
+ (cons (call.proc E)
+ (call.args E))))))
+
+ ; Environments are represented as hashtrees.
+
+ (define (make-empty-environment)
+ (make-hashtree symbol-hash assq))
+
+ (define (environment-extend env sym)
+ (hashtree-put env sym #t))
+
+ (define (environment-extend* env symbols)
+ (if (null? symbols)
+ env
+ (environment-extend* (hashtree-put env (car symbols) #t)
+ (cdr symbols))))
+
+ (define (environment-lookup env sym)
+ (hashtree-get env sym))
+
+ (define (global? x)
+ (cond ((local-variable? x)
+ #f)
+ ((environment-lookup env x)
+ #f)
+ (else
+ #t)))
+
+ ;
+
+ (define (available-add! available T E)
+ (cond ((constant? E)
+ (available-extend! available T E available:killer:immortal))
+ ((variable? E)
+ (available-extend! available
+ T
+ E
+ (if (global? (variable.name E))
+ available:killer:globals
+ available:killer:immortal)))
+ (else
+ (let ((entry (prim-call E)))
+ (if entry
+ (let ((killer (prim-lives-until entry)))
+ (if (not (eq? killer available:killer:dead))
+ (do ((args (call.args E) (cdr args))
+ (k killer
+ (let ((arg (car args)))
+ (if (and (variable? arg)
+ (global? (variable.name arg)))
+ available:killer:globals
+ k))))
+ ((null? args)
+ (available-extend!
+ available
+ T
+ E
+ (logior killer k)))))))))))
+
+ ; Given an expression E,
+ ; an environment containing all variables that are in scope,
+ ; and a table of available expressions,
+ ; returns multiple values:
+ ; the transformed E
+ ; the free variables of E
+ ; the register bindings to be inserted; each binding has the form
+ ; (R x (begin R)), where (begin R) is a reference to R.
+ ;
+ ; Side effects E.
+
+ (define (scan E env available)
+ (if (not (call? E))
+ (scan-rhs E env available)
+ (let ((proc (call.proc E)))
+ (if (not (lambda? proc))
+ (scan-rhs E env available)
+ (let ((vars (lambda.args proc)))
+ (cond ((null? vars)
+ (scan-let0 E env available))
+ ((null? (cdr vars))
+ (scan-binding E env available))
+ (else
+ (error (make-readable E)))))))))
+
+ ; E has the form of (let ((T1 E1)) E0).
+
+ (define (scan-binding E env available)
+ (let* ((L (call.proc E))
+ (T1 (car (lambda.args L)))
+ (E1 (car (call.args E)))
+ (E0 (lambda.body L)))
+ (record-local-variable! T1)
+ (call-with-values
+ (lambda () (scan-rhs E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (available-add! available T1 E1)
+ (let* ((env (let ((formals
+ (make-null-terminated (lambda.args L))))
+ (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs L)))))
+ (Fdefs (scan-defs L env available)))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (lambda.body-set! L E0)
+ (if target-registers?
+ (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+ (scan-binding-phase3
+ L E0 E1 (union F0 Fdefs)
+ F1 regbindings0 regbindings1)))))))))
+
+ ; Given the lambda expression for a let expression that binds
+ ; a single variable T1, the transformed body E0 and right hand side E1,
+ ; their sets of free variables F0 and F1, the set of free variables
+ ; for the internal definitions of L, and the sets of register
+ ; bindings that need to be wrapped around E0 and E1, returns the
+ ; transformed let expression, its free variables, and register
+ ; bindings.
+ ;
+ ; This phase is concerned exclusively with register bindings,
+ ; and is bypassed unless the target-registers flag is specified.
+
+ (define (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+
+ ; T1 can't be a register because we haven't
+ ; yet inserted register bindings that high up.
+
+ ; Classify the register bindings that need to wrapped around E0:
+ ; 1. those that have T1 as their rhs
+ ; 2. those whose lhs is a register that is likely to hold
+ ; a variable that occurs free in E1
+ ; 3. all others
+
+ (define (phase2a)
+ (do ((rvars regvars (cdr rvars))
+ (regs argument-registers (cdr regs))
+ (regs1 '() (if (memq (car rvars) F1)
+ (cons (car regs) regs1)
+ regs1)))
+ ((or (null? rvars)
+ (null? regs))
+ ; regs1 is the set of registers that are live for E1
+
+ (let loop ((regbindings regbindings0)
+ (rb1 '())
+ (rb2 '())
+ (rb3 '()))
+ (if (null? regbindings)
+ (phase2b rb1 rb2 rb3)
+ (let* ((binding (car regbindings))
+ (regbindings (cdr regbindings))
+ (lhs (regbinding.lhs binding))
+ (rhs (regbinding.rhs binding)))
+ (cond ((eq? rhs T1)
+ (loop regbindings
+ (cons binding rb1)
+ rb2
+ rb3))
+ ((memq lhs regs1)
+ (loop regbindings
+ rb1
+ (cons binding rb2)
+ rb3))
+ (else
+ (loop regbindings
+ rb1
+ rb2
+ (cons binding rb3))))))))))
+
+ ; Determine which categories of register bindings should be
+ ; wrapped around E0.
+ ; Always wrap the register bindings in category 2.
+ ; If E1 is a conditional or a real call, then wrap category 3.
+ ; If T1 might be used more than once, then wrap category 1.
+
+ (define (phase2b rb1 rb2 rb3)
+ (if (or (conditional? E1)
+ (real-call? E1))
+ (phase2c (append rb2 rb3) rb1 '())
+ (phase2c rb2 rb1 rb3)))
+
+ (define (phase2c towrap rb1 regbindings0)
+ (cond ((and (not (null? rb1))
+ (local-variable-used-once? T1))
+ (phase2d towrap rb1 regbindings0))
+ (else
+ (phase2e (append rb1 towrap) regbindings0))))
+
+ ; T1 is used only once, and there is a register binding (R T1).
+ ; Change T1 to R.
+
+ (define (phase2d towrap regbindings-T1 regbindings0)
+ (if (not (null? (cdr regbindings-T1)))
+ (error "incorrect number of uses" T1))
+ (let* ((regbinding (car regbindings-T1))
+ (R (regbinding.lhs regbinding)))
+ (lambda.args-set! L (list R))
+ (phase2e towrap regbindings0)))
+
+ ; Wrap the selected register bindings around E0.
+
+ (define (phase2e towrap regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings towrap E0 F0))
+ (lambda (E0 F0)
+ (let ((F (union Fdefs F0)))
+ (scan-binding-phase3
+ L E0 E1 F F1 regbindings0 regbindings1)))))
+
+ (phase2a))
+
+ ; This phase, with arguments as above, constructs the result.
+
+ (define (scan-binding-phase3 L E0 E1 F F1 regbindings0 regbindings1)
+ (let* ((args (lambda.args L))
+ (T1 (car args))
+ (free (union F1 (difference F args)))
+ (simple-let? (simple-lambda? L))
+ (regbindings
+
+ ; At least one of regbindings0 and regbindings1
+ ; is the empty list.
+
+ (cond ((null? regbindings0)
+ regbindings1)
+ ((null? regbindings1)
+ regbindings0)
+ (else
+ (error 'scan-binding 'regbindings)))))
+ (lambda.body-set! L E0)
+ (lambda.F-set! L F)
+ (lambda.G-set! L F)
+ (cond ((and simple-let?
+ (not (memq T1 F))
+ (no-side-effects? E1))
+ (abandon-expression! E1)
+ (values E0 F regbindings0))
+ ((and target-registers?
+ simple-let?
+ (local-variable-used-once? T1))
+ (post-simplify-anf L T1 E0 E1 free regbindings #f))
+ (else
+ (values (make-call L (list E1))
+ free
+ regbindings)))))
+
+ (define (scan-let0 E env available)
+ (let ((L (call.proc E)))
+ (if (simple-lambda? L)
+ (scan (lambda.body L) env available)
+ (let ((T1 (make-variable name:IGNORED)))
+ (lambda.args-set! L (list T1))
+ (call-with-values
+ (lambda () (scan (make-call L (list (make-constant 0)))
+ env
+ available))
+ (lambda (E F regbindings)
+ (lambda.args-set! L '())
+ (values (make-call L '())
+ F
+ regbindings)))))))
+
+ ; Optimizes the internal definitions of L and returns their
+ ; free variables.
+
+ (define (scan-defs L env available)
+ (let loop ((defs (lambda.defs L))
+ (newdefs '())
+ (Fdefs '()))
+ (if (null? defs)
+ (begin (lambda.defs-set! L (reverse newdefs))
+ Fdefs)
+ (let ((def (car defs)))
+ (call-with-values
+ (lambda ()
+ (let* ((Ldef (def.rhs def))
+ (Lformals (make-null-terminated (lambda.args Ldef)))
+ (Lenv (environment-extend*
+ (environment-extend* env Lformals)
+ (map def.lhs (lambda.defs Ldef)))))
+ (scan Ldef Lenv available)))
+ (lambda (rhs Frhs empty)
+ (if (not (null? empty))
+ (error 'scan-binding 'def))
+ (loop (cdr defs)
+ (cons (make-definition (def.lhs def) rhs)
+ newdefs)
+ (union Frhs Fdefs))))))))
+
+ ; Given the right-hand side of a let-binding, an environment,
+ ; and a table of available expressions, returns the transformed
+ ; expression, its free variables, and the register bindings that
+ ; need to be wrapped around it.
+
+ (define (scan-rhs E env available)
+
+ (cond
+ ((constant? E)
+ (values E (empty-set) '()))
+
+ ((variable? E)
+ (let* ((name (variable.name E))
+ (Enew (and commoning?
+ (if (global? name)
+ (let ((T (available-expression
+ available E)))
+ (if T
+ (make-variable T)
+ #f))
+ (available-variable available name)))))
+ (if Enew
+ (scan-rhs Enew env available)
+ (begin (used-variable! name)
+ (values E (list name) '())))))
+
+ ((lambda? E)
+ (let* ((formals (make-null-terminated (lambda.args E)))
+ (env (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs E))))
+ (Fdefs (scan-defs E env available)))
+ (call-with-values
+ (lambda ()
+ (let ((available (copy-available-table available)))
+ (available-kill! available available:killer:all)
+ (scan-body (lambda.body E)
+ env
+ available
+ formals)))
+ (lambda (E0 F0 regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings regbindings0 E0 F0))
+ (lambda (E0 F0)
+ (lambda.body-set! E E0)
+ (let ((F (union Fdefs F0)))
+ (for-each (lambda (x)
+ (closed-over-local-variable! x))
+ F)
+ (lambda.F-set! E F)
+ (lambda.G-set! E F)
+ (values E
+ (difference F
+ (make-null-terminated
+ (lambda.args E)))
+ '()))))))))
+
+ ((conditional? E)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (constant? E0)
+ ; FIXME: E1 and E2 might not be a legal rhs,
+ ; so we can't just return the simplified E1 or E2.
+ (let ((E1 (if (constant.value E0) E1 E2)))
+ (call-with-values
+ (lambda () (scan E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (cond ((or (not (call? E1))
+ (not (lambda? (call.proc E1))))
+ (values E1 F1 regbindings1))
+ (else
+ ; FIXME: Must return a valid rhs.
+ (values (make-conditional
+ (make-constant #t)
+ E1
+ (make-constant 0))
+ F1
+ regbindings1))))))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (if (not (null? regbindings0))
+ (error 'scan-rhs 'if))
+ (if (not (eq? E0 (if.test E)))
+ (scan-rhs (make-conditional E0 E1 E2)
+ env available)
+ (let ((available1
+ (copy-available-table available))
+ (available2
+ (copy-available-table available)))
+ (if (variable? E0)
+ (let ((T0 (variable.name E0)))
+ (available-add!
+ available2 T0 (make-constant #f)))
+ (error (make-readable E #t)))
+ (call-with-values
+ (lambda () (scan E1 env available1))
+ (lambda (E1 F1 regbindings1)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings1 E1 F1))
+ (lambda (E1 F1)
+ (call-with-values
+ (lambda () (scan E2 env available2))
+ (lambda (E2 F2 regbindings2)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings2 E2 F2))
+ (lambda (E2 F2)
+ (let ((E (make-conditional
+ E0 E1 E2))
+ (F (union F0 F1 F2)))
+ (available-intersect!
+ available
+ available1
+ available2)
+ (values E F '())))))))))))))))))
+
+
+ ((assignment? E)
+ (call-with-values
+ (lambda () (scan-rhs (assignment.rhs E) env available))
+ (lambda (E1 F1 regbindings1)
+ (if (not (null? regbindings1))
+ (error 'scan-rhs 'set!))
+ (available-kill! available available:killer:globals)
+ (values (make-assignment (assignment.lhs E) E1)
+ (union (list (assignment.lhs E)) F1)
+ '()))))
+
+ ((begin? E)
+ ; Shouldn't occur in A-normal form.
+ (error 'scan-rhs 'begin))
+
+ ((real-call? E)
+ (let* ((E0 (call.proc E))
+ (args (call.args E))
+ (regcontents (append regvars
+ (map (lambda (x) #f) args))))
+ (let loop ((args args)
+ (regs argument-registers)
+ (regcontents regcontents)
+ (newargs '())
+ (regbindings '())
+ (F (if (variable? E0)
+ (let ((f (variable.name E0)))
+ (used-variable! f)
+ (list f))
+ (empty-set))))
+ (cond ((null? args)
+ (available-kill! available available:killer:all)
+ (values (make-call E0 (reverse newargs))
+ F
+ regbindings))
+ ((null? regs)
+ (let ((arg (car args)))
+ (loop (cdr args)
+ '()
+ (cdr regcontents)
+ (cons arg newargs)
+ regbindings
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))
+ ((and commoning?
+ (variable? (car args))
+ (available-variable
+ available
+ (variable.name (car args))))
+ (let* ((name (variable.name (car args)))
+ (Enew (available-variable available name)))
+ (loop (cons Enew (cdr args))
+ regs regcontents newargs regbindings F)))
+ ((and target-registers?
+ (variable? (car args))
+ (let ((x (variable.name (car args))))
+ ; We haven't yet recorded this use.
+ (or (local-variable-not-used? x)
+ (and (memq x regvars)
+ (not (eq? x (car regcontents)))))))
+ (let* ((x (variable.name (car args)))
+ (R (car regs))
+ (newarg (make-variable R)))
+ (used-variable! x)
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons newarg newargs)
+ (cons (make-regbinding R x newarg)
+ regbindings)
+ (union (list R) F))))
+ (else
+ (let ((E1 (car args)))
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons E1 newargs)
+ regbindings
+ (if (variable? E1)
+ (let ((name (variable.name E1)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))))))
+
+ ((call? E)
+ ; Must be a call to a primop.
+ (let* ((E0 (call.proc E))
+ (f0 (variable.name E0)))
+ (let loop ((args (call.args E))
+ (newargs '())
+ (F (list f0)))
+ (cond ((null? args)
+ (let* ((E (make-call E0 (reverse newargs)))
+ (T (and commoning?
+ (available-expression
+ available E))))
+ (if T
+ (begin (abandon-expression! E)
+ (scan-rhs (make-variable T) env available))
+ (begin
+ (available-kill!
+ available
+ (prim-kills (prim-entry f0)))
+ (cond ((eq? f0 name:check!)
+ (let ((x (car (call.args E))))
+ (cond ((not (runtime-safety-checking))
+ (abandon-expression! E)
+ ;(values x '() '())
+ (scan-rhs x env available))
+ ((variable? x)
+ (available-add!
+ available
+ (variable.name x)
+ (make-constant #t))
+ (values E F '()))
+ ((constant.value x)
+ (abandon-expression! E)
+ (values x '() '()))
+ (else
+ (declaration-error E)
+ (values E F '())))))
+ (else
+ (values E F '())))))))
+ ((variable? (car args))
+ (let* ((E1 (car args))
+ (x (variable.name E1))
+ (Enew
+ (and commoning?
+ (available-variable available x))))
+ (if Enew
+ ; All of the arguments are constants or
+ ; variables, so if the variable is replaced
+ ; here it will be replaced throughout the call.
+ (loop (cons Enew (cdr args))
+ newargs
+ (remq x F))
+ (begin
+ (used-variable! x)
+ (loop (cdr args)
+ (cons (car args) newargs)
+ (union (list x) F))))))
+ (else
+ (loop (cdr args)
+ (cons (car args) newargs)
+ F))))))
+
+ (else
+ (error 'scan-rhs (make-readable E)))))
+
+ (call-with-values
+ (lambda () (scan E env available))
+ (lambda (E F regbindings)
+ (call-with-values
+ (lambda () (wrap-with-register-bindings regbindings E F))
+ (lambda (E F)
+ (values E F '()))))))
+
+ (call-with-values
+ (lambda ()
+ (scan-body E
+ (make-hashtree symbol-hash assq)
+ (make-available-table)
+ '()))
+ (lambda (E F regbindings)
+ (if (not (null? regbindings))
+ (error 'scan-body))
+ E)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 16 June 1999.
+;
+; Intraprocedural representation inference.
+
+(define (representation-analysis exp)
+ (let* ((debugging? #f)
+ (integrate-usual? (integrate-usual-procedures))
+ (known (make-hashtable symbol-hash assq))
+ (types (make-hashtable symbol-hash assq))
+ (g (callgraph exp))
+ (schedule (list (callgraphnode.code (car g))))
+ (changed? #f)
+ (mutate? #f))
+
+ ; known is a hashtable that maps the name of a known local procedure
+ ; to a list of the form (tv1 ... tvN), where tv1, ..., tvN
+ ; are type variables that stand for the representation types of its
+ ; arguments. The type variable that stands for the representation
+ ; type of the result of the procedure has the same name as the
+ ; procedure itself.
+
+ ; types is a hashtable that maps local variables and the names
+ ; of known local procedures to an approximation of their
+ ; representation type.
+ ; For a known local procedure, the representation type is for the
+ ; result of the procedure, not the procedure itself.
+
+ ; schedule is a stack of work that needs to be done.
+ ; Each entry in the stack is either an escaping lambda expression
+ ; or the name of a known local procedure.
+
+ (define (schedule! job)
+ (if (not (memq job schedule))
+ (begin (set! schedule (cons job schedule))
+ (if (not (symbol? job))
+ (callgraphnode.info! (lookup-node job) #t)))))
+
+ ; Schedules a known local procedure.
+
+ (define (schedule-known-procedure! name)
+ ; Mark every known procedure that can actually be called.
+ (callgraphnode.info! (assq name g) #t)
+ (schedule! name))
+
+ ; Schedule all code that calls the given known local procedure.
+
+ (define (schedule-callers! name)
+ (for-each (lambda (node)
+ (if (and (callgraphnode.info node)
+ (or (memq name (callgraphnode.tailcalls node))
+ (memq name (callgraphnode.nontailcalls node))))
+ (let ((caller (callgraphnode.name node)))
+ (if caller
+ (schedule! caller)
+ (schedule! (callgraphnode.code node))))))
+ g))
+
+ ; Schedules local procedures of a lambda expression.
+
+ (define (schedule-local-procedures! L)
+ (for-each (lambda (def)
+ (let ((name (def.lhs def)))
+ (if (known-procedure-is-callable? name)
+ (schedule! name))))
+ (lambda.defs L)))
+
+ ; Returns true iff the given known procedure is known to be callable.
+
+ (define (known-procedure-is-callable? name)
+ (callgraphnode.info (assq name g)))
+
+ ; Sets CHANGED? to #t and returns #t if the type variable's
+ ; approximation has changed; otherwise returns #f.
+
+ (define (update-typevar! tv type)
+ (let* ((type0 (hashtable-get types tv))
+ (type0 (or type0
+ (begin (hashtable-put! types tv rep:bottom)
+ rep:bottom)))
+ (type1 (representation-union type0 type)))
+ (if (eq? type0 type1)
+ #f
+ (begin (hashtable-put! types tv type1)
+ (set! changed? #t)
+ (if (and debugging? mutate?)
+ (begin (display "******** Changing type of ")
+ (display tv)
+ (display " from ")
+ (display (rep->symbol type0))
+ (display " to ")
+ (display (rep->symbol type1))
+ (newline)))
+ #t))))
+
+ ; GIven the name of a known local procedure, returns its code.
+
+ (define (lookup-code name)
+ (callgraphnode.code (assq name g)))
+
+ ; Given a lambda expression, either escaping or the code for
+ ; a known local procedure, returns its node in the call graph.
+
+ (define (lookup-node L)
+ (let loop ((g g))
+ (cond ((null? g)
+ (error "Unknown lambda expression" (make-readable L #t)))
+ ((eq? L (callgraphnode.code (car g)))
+ (car g))
+ (else
+ (loop (cdr g))))))
+
+ ; Given: a type variable, expression, and a set of constraints.
+ ; Side effects:
+ ; Update the representation types of all variables that are
+ ; bound within the expression.
+ ; Update the representation types of all arguments to known
+ ; local procedures that are called within the expression.
+ ; If the representation type of an argument to a known local
+ ; procedure changes, then schedule that procedure's code
+ ; for analysis.
+ ; Update the constraint set to reflect the constraints that
+ ; hold following execution of the expression.
+ ; If mutate? is true, then transform the expression to rely
+ ; on the representation types that have been inferred.
+ ; Return: type of the expression under the current assumptions
+ ; and constraints.
+
+ (define (analyze exp constraints)
+
+ (if (and #f debugging?)
+ (begin (display "Analyzing: ")
+ (newline)
+ (pretty-print (make-readable exp #t))
+ (newline)))
+
+ (case (car exp)
+
+ ((quote)
+ (representation-of-value (constant.value exp)))
+
+ ((begin)
+ (let* ((name (variable.name exp)))
+ (representation-typeof name types constraints)))
+
+ ((lambda)
+ (schedule! exp)
+ rep:procedure)
+
+ ((set!)
+ (analyze (assignment.rhs exp) constraints)
+ (constraints-kill! constraints available:killer:globals)
+ rep:object)
+
+ ((if)
+ (let* ((E0 (if.test exp))
+ (E1 (if.then exp))
+ (E2 (if.else exp))
+ (type0 (analyze E0 constraints)))
+ (if mutate?
+ (cond ((representation-subtype? type0 rep:true)
+ (if.test-set! exp (make-constant #t)))
+ ((representation-subtype? type0 rep:false)
+ (if.test-set! exp (make-constant #f)))))
+ (cond ((representation-subtype? type0 rep:true)
+ (analyze E1 constraints))
+ ((representation-subtype? type0 rep:false)
+ (analyze E2 constraints))
+ ((variable? E0)
+ (let* ((T0 (variable.name E0))
+ (ignored (analyze E0 constraints))
+ (constraints1 (copy-constraints-table constraints))
+ (constraints2 (copy-constraints-table constraints)))
+ (constraints-add! types
+ constraints1
+ (make-type-constraint
+ T0 rep:true available:killer:immortal))
+ (constraints-add! types
+ constraints2
+ (make-type-constraint
+ T0 rep:false available:killer:immortal))
+ (let* ((type1 (analyze E1 constraints1))
+ (type2 (analyze E2 constraints2))
+ (type (representation-union type1 type2)))
+ (constraints-intersect! constraints
+ constraints1
+ constraints2)
+ type)))
+ (else
+ (representation-error "Bad ANF" (make-readable exp #t))))))
+
+ (else
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((lambda? proc)
+ (cond ((null? args)
+ (analyze-let0 exp constraints))
+ ((null? (cdr args))
+ (analyze-let1 exp constraints))
+ (else
+ (error "Compiler bug: pass3rep"))))
+ ((variable? proc)
+ (let* ((procname (variable.name proc)))
+ (cond ((hashtable-get known procname)
+ =>
+ (lambda (vars)
+ (analyze-known-call exp constraints vars)))
+ (integrate-usual?
+ (let ((entry (prim-entry procname)))
+ (if entry
+ (analyze-primop-call exp constraints entry)
+ (analyze-unknown-call exp constraints))))
+ (else
+ (analyze-unknown-call exp constraints)))))
+ (else
+ (analyze-unknown-call exp constraints)))))))
+
+ (define (analyze-let0 exp constraints)
+ (let ((proc (call.proc exp)))
+ (schedule-local-procedures! proc)
+ (if (null? (lambda.args proc))
+ (analyze (lambda.body exp) constraints)
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-let1 exp constraints)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc)))
+ (schedule-local-procedures! proc)
+ (if (and (pair? vars)
+ (null? (cdr vars)))
+ (let* ((T1 (car vars))
+ (E1 (car (call.args exp))))
+ (if (and integrate-usual? (call? E1))
+ (let ((proc (call.proc E1))
+ (args (call.args E1)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (entry (prim-entry op))
+ (K1 (if entry
+ (prim-lives-until entry)
+ available:killer:dead)))
+ (if (not (= K1 available:killer:dead))
+ ; Must copy the call to avoid problems
+ ; with side effects when mutate? is true.
+ (constraints-add!
+ types
+ constraints
+ (make-constraint T1
+ (make-call proc args)
+ K1)))))))
+ (update-typevar! T1 (analyze E1 constraints))
+ (analyze (lambda.body proc) constraints))
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-primop-call exp constraints entry)
+ (let* ((op (prim-opcodename entry))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args))
+ (type (rep-result? op argtypes)))
+ (constraints-kill! constraints (prim-kills entry))
+ (cond ((and (eq? op 'check!)
+ (variable? (car args)))
+ (let ((varname (variable.name (car args))))
+ (if (and mutate?
+ (representation-subtype? (car argtypes) rep:true))
+ (call.args-set! exp
+ (cons (make-constant #t) (cdr args))))
+ (constraints-add! types
+ constraints
+ (make-type-constraint
+ varname
+ rep:true
+ available:killer:immortal))))
+ ((and mutate? (rep-specific? op argtypes))
+ =>
+ (lambda (newop)
+ (call.proc-set! exp (make-variable newop)))))
+ (or type rep:object)))
+
+ (define (analyze-known-call exp constraints vars)
+ (let* ((procname (variable.name (call.proc exp)))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args)))
+ (if (not (known-procedure-is-callable? procname))
+ (schedule-known-procedure! procname))
+ (for-each (lambda (var type)
+ (if (update-typevar! var type)
+ (schedule-known-procedure! procname)))
+ vars
+ argtypes)
+ ; FIXME: We aren't analyzing the effects of known local procedures.
+ (constraints-kill! constraints available:killer:all)
+ (hashtable-get types procname)))
+
+ (define (analyze-unknown-call exp constraints)
+ (analyze (call.proc exp) constraints)
+ (for-each (lambda (arg) (analyze arg constraints))
+ (call.args exp))
+ (constraints-kill! constraints available:killer:all)
+ rep:object)
+
+ (define (analyze-known-local-procedure name)
+ (if debugging?
+ (begin (display "Analyzing ")
+ (display name)
+ (newline)))
+ (let ((L (lookup-code name))
+ (constraints (make-constraints-table)))
+ (schedule-local-procedures! L)
+ (let ((type (analyze (lambda.body L) constraints)))
+ (if (update-typevar! name type)
+ (schedule-callers! name))
+ type)))
+
+ (define (analyze-unknown-lambda L)
+ (if debugging?
+ (begin (display "Analyzing escaping lambda expression")
+ (newline)))
+ (schedule-local-procedures! L)
+ (let ((vars (make-null-terminated (lambda.args L))))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep:object))
+ vars)
+ (analyze (lambda.body L)
+ (make-constraints-table))))
+
+ ; For debugging.
+
+ (define (display-types)
+ (hashtable-for-each (lambda (f vars)
+ (write f)
+ (display " : returns ")
+ (write (rep->symbol (hashtable-get types f)))
+ (newline)
+ (for-each (lambda (x)
+ (display " ")
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars))
+ known))
+
+ (define (display-all-types)
+ (let* ((vars (hashtable-map (lambda (x type) x) types))
+ (vars (twobit-sort (lambda (var1 var2)
+ (string<=? (symbol->string var1)
+ (symbol->string var2)))
+ vars)))
+ (for-each (lambda (x)
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars)))
+ '
+ (if debugging?
+ (begin (pretty-print (make-readable (car schedule) #t))
+ (newline)))
+ (if debugging?
+ (view-callgraph g))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (vars (make-null-terminated (lambda.args code)))
+ (known? (symbol? name))
+ (rep (if known? rep:bottom rep:object)))
+ (callgraphnode.info! node #f)
+ (if known?
+ (begin (hashtable-put! known name vars)
+ (hashtable-put! types name rep)))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep))
+ vars)))
+ g)
+
+ (let loop ()
+ (cond ((not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop)))
+ (changed?
+ (set! changed? #f)
+ (set! schedule (list (callgraphnode.code (car g))))
+ (if debugging?
+ (begin (display-all-types) (newline)))
+ (loop))))
+
+ (if debugging?
+ (display-types))
+
+ (set! mutate? #t)
+
+ ; We don't want to analyze known procedures that are never called.
+
+ (set! schedule
+ (cons (callgraphnode.code (car g))
+ (map callgraphnode.name
+ (filter (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (known? (symbol? name))
+ (marked?
+ (known-procedure-is-callable? name)))
+ (callgraphnode.info! node #f)
+ (and known? marked?)))
+ g))))
+ (let loop ()
+ (if (not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop))))
+
+ (if changed?
+ (error "Compiler bug in representation inference"))
+
+ (if debugging?
+ (pretty-print (make-readable (callgraphnode.code (car g)) #t)))
+
+ exp))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 June 1999.
+;
+; The third "pass" of the Twobit compiler actually consists of several
+; passes, which are related by the common theme of flow analysis:
+; interprocedural inlining of known local procedures
+; interprocedural constant propagation and folding
+; intraprocedural commoning, copy propagation, and dead code elimination
+; representation inference (not yet implemented)
+; register targeting
+;
+; This pass operates as source-to-source transformations on
+; expressions written in the subset of Scheme described by the
+; following grammar:
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * Variables named IGNORED are neither referenced nor assigned.
+; * The expression does not share structure with the original input,
+; but might share structure with itself.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R is garbage.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * If a lambda expression is declared to be in A-normal form (see
+; pass3anormal.sch), then it really is in A-normal form.
+;
+; The phases of pass 3 interact with the referencing information R
+; and the free variables F as follows:
+;
+; Inlining ignores R, ignores F, destroys R, destroys F.
+; Constant propagation uses R, ignores F, preserves R, preserves F.
+; Conversion to ANF ignores R, ignores F, destroys R, destroys F.
+; Commoning ignores R, ignores F, destroys R, computes F.
+; Register targeting ignores R, ignores F, destroys R, computes F.
+
+(define (pass3 exp)
+
+ (define (phase1 exp)
+ (if (interprocedural-inlining)
+ (let ((g (callgraph exp)))
+ (inline-using-callgraph! g)
+ exp)
+ exp))
+
+ (define (phase2 exp)
+ (if (interprocedural-constant-propagation)
+ (constant-propagation (copy-exp exp))
+ exp))
+
+ (define (phase3 exp)
+ (if (common-subexpression-elimination)
+ (let* ((exp (if (interprocedural-constant-propagation)
+ exp
+ ; alpha-conversion
+ (copy-exp exp)))
+ (exp (a-normal-form exp)))
+ (if (representation-inference)
+ (intraprocedural-commoning exp 'commoning)
+ (intraprocedural-commoning exp)))
+ exp))
+
+ (define (phase4 exp)
+ (if (representation-inference)
+ (let ((exp (cond ((common-subexpression-elimination)
+ exp)
+ ((interprocedural-constant-propagation)
+ (a-normal-form exp))
+ (else
+ ; alpha-conversion
+ (a-normal-form (copy-exp exp))))))
+ (intraprocedural-commoning
+ (representation-analysis exp)))
+ exp))
+
+ (define (finish exp)
+ (if (and (not (interprocedural-constant-propagation))
+ (not (common-subexpression-elimination)))
+ (begin (compute-free-variables! exp)
+ exp)
+ ;(make-begin (list (make-constant 'anf) exp))))
+ exp))
+
+ (define (verify exp)
+ (check-referencing-invariants exp 'free)
+ exp)
+
+ (if (global-optimization)
+ (verify (finish (phase4 (phase3 (phase2 (phase1 exp))))))
+ (begin (compute-free-variables! exp)
+ (verify exp))))
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 4 June 1999
+
+; Implements the following abstract data types.
+;
+; labels
+; (init-labels)
+; (make-label)
+; cg-label-counter
+;
+; assembly streams
+; (make-assembly-stream)
+; (assembly-stream-code as)
+; (gen! as . instruction)
+; (gen-instruction! as instruction)
+; (gen-save! as frame)
+; (gen-restore! as frame)
+; (gen-pop! as frame)
+; (gen-setstk! as frame v)
+; (gen-store! as frame r v)
+; (gen-load! as frame r v)
+; (gen-stack! as frame v)
+;
+; temporaries
+; (init-temps)
+; (newtemp)
+; (newtemps)
+; newtemp-counter
+;
+; register environments
+; (cgreg-initial)
+; (cgreg-copy regs)
+; (cgreg-tos regs)
+; (cgreg-liveregs regs)
+; (cgreg-live regs r)
+; (cgreg-vars regs)
+; (cgreg-bind! regs r v)
+; (cgreg-bindregs! regs vars)
+; (cgreg-rename! regs alist)
+; (cgreg-release! regs r)
+; (cgreg-clear! regs)
+; (cgreg-lookup regs var)
+; (cgreg-lookup-reg regs r)
+; (cgreg-join! regs1 regs2)
+;
+; stack frame environments
+; (cgframe-initial)
+; (cgframe-size-cell frame)
+; (cgframe-size frame)
+; (cgframe-copy frame)
+; (cgframe-join! frame1 frame2)
+; (cgframe-update-stale! frame)
+; (cgframe-used! frame)
+; (cgframe-bind! frame n v instruction)
+; (cgframe-touch! frame v)
+; (cgframe-rename! frame alist)
+; (cgframe-release! frame v)
+; (cgframe-lookup frame v)
+; (cgframe-spilled? frame v)
+;
+; environments
+; (entry.name entry)
+; (entry.kind entry)
+; (entry.rib entry)
+; (entry.offset entry)
+; (entry.label entry)
+; (entry.regnum entry)
+; (entry.arity entry)
+; (entry.op entry)
+; (entry.imm entry)
+; (cgenv-initial)
+; (cgenv-lookup env id)
+; (cgenv-extend env vars procs)
+; (cgenv-bindprocs env procs)
+; (var-lookup var regs frame env)
+
+; Labels.
+
+(define (init-labels)
+ (set! cg-label-counter 1000))
+
+(define (make-label)
+ (set! cg-label-counter (+ cg-label-counter 1))
+ cg-label-counter)
+
+(define cg-label-counter 1000)
+
+; an assembly stream into which instructions should be emitted
+; an expression
+; the desired target register ('result, a register number, or '#f)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; contains size of frame, current top of frame
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+
+; Assembly streams, into which instructions are emitted by side effect.
+; Represented as a list of two things:
+;
+; Assembly code, represented as a pair whose car is a nonempty list
+; whose cdr is a possibly empty list of MacScheme machine assembly
+; instructions, and whose cdr is the last pair of the car.
+;
+; Any Scheme object that the code generator wants to associate with
+; this code.
+
+(define (make-assembly-stream)
+ (let ((code (list (list 0))))
+ (set-cdr! code (car code))
+ (list code #f)))
+
+(define (assembly-stream-code output)
+ (if (local-optimizations)
+ (filter-basic-blocks (cdar (car output)))
+ (cdar (car output))))
+
+(define (assembly-stream-info output)
+ (cadr output))
+
+(define (assembly-stream-info! output x)
+ (set-car! (cdr output) x)
+ #f)
+
+(define (gen-instruction! output instruction)
+ (let ((pair (list instruction))
+ (code (car output)))
+ (set-cdr! (cdr code) pair)
+ (set-cdr! code pair)
+ output))
+
+;
+
+(define (gen! output . instruction)
+ (gen-instruction! output instruction))
+
+(define (gen-save! output frame t0)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $save size))
+ (gen-store! output frame 0 t0)
+ (cgframe:stale-set! frame '())))
+
+(define (gen-restore! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $restore size))))
+
+(define (gen-pop! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $pop size))))
+
+(define (gen-setstk! output frame tempname)
+ (let ((instruction (list $nop $setstk -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-store! output frame r tempname)
+ (let ((instruction (list $nop $store r -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-load! output frame r tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $load r n)))
+
+(define (gen-stack! output frame tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $stack n)))
+
+; Returns a temporary name.
+; Temporaries are compared using EQ?, so the use of small
+; exact integers as temporary names is implementation-dependent.
+
+(define (init-temps)
+ (set! newtemp-counter 5000))
+
+(define (newtemp)
+ (set! newtemp-counter
+ (+ newtemp-counter 1))
+ newtemp-counter)
+
+(define newtemp-counter 5000)
+
+(define (newtemps n)
+ (if (zero? n)
+ '()
+ (cons (newtemp)
+ (newtemps (- n 1)))))
+
+; New representation of
+; Register environments.
+; Represented as a list of three items:
+; an exact integer, one more than the highest index of a live register
+; a mutable vector with *nregs* elements of the form
+; #f (the register is dead)
+; #t (the register is live)
+; v (the register contains variable v)
+; t (the register contains temporary variable t)
+; a mutable vector of booleans: true if the register might be stale
+
+(define (cgreg-makeregs n v1 v2) (list n v1 v2))
+
+(define (cgreg-liveregs regs)
+ (car regs))
+
+(define (cgreg-contents regs)
+ (cadr regs))
+
+(define (cgreg-stale regs)
+ (caddr regs))
+
+(define (cgreg-liveregs-set! regs n)
+ (set-car! regs n)
+ regs)
+
+(define (cgreg-initial)
+ (let ((v1 (make-vector *nregs* #f))
+ (v2 (make-vector *nregs* #f)))
+ (cgreg-makeregs 0 v1 v2)))
+
+(define (cgreg-copy regs)
+ (let* ((newregs (cgreg-initial))
+ (v1a (cgreg-contents regs))
+ (v2a (cgreg-stale regs))
+ (v1 (cgreg-contents newregs))
+ (v2 (cgreg-stale newregs))
+ (n (vector-length v1a)))
+ (cgreg-liveregs-set! newregs (cgreg-liveregs regs))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ newregs)
+ (vector-set! v1 i (vector-ref v1a i))
+ (vector-set! v2 i (vector-ref v2a i)))))
+
+(define (cgreg-tos regs)
+ (- (cgreg-liveregs regs) 1))
+
+(define (cgreg-live regs r)
+ (if (eq? r 'result)
+ (cgreg-tos regs)
+ (max r (cgreg-tos regs))))
+
+(define (cgreg-vars regs)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (do ((i (- m 1) (- i 1))
+ (vars '()
+ (cons (vector-ref v i)
+ vars)))
+ ((< i 0)
+ vars))))
+
+(define (cgreg-bind! regs r t)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r t)
+ (if (>= r m)
+ (cgreg-liveregs-set! regs (+ r 1)))))
+
+(define (cgreg-bindregs! regs vars)
+ (do ((m (cgreg-liveregs regs) (+ m 1))
+ (v (cgreg-contents regs))
+ (vars vars (cdr vars)))
+ ((null? vars)
+ (cgreg-liveregs-set! regs m)
+ regs)
+ (vector-set! v m (car vars))))
+
+(define (cgreg-rename! regs alist)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if var
+ (let ((probe (assv var alist)))
+ (if probe
+ (vector-set! v i (cdr probe))))))))
+
+(define (cgreg-release! regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r #f)
+ (vector-set! (cgreg-stale regs) r #t)
+ (if (= r (- m 1))
+ (do ((m r (- m 1)))
+ ((or (negative? m)
+ (vector-ref v m))
+ (cgreg-liveregs-set! regs (+ m 1)))))))
+
+(define (cgreg-release-except! regs vars)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if (and var (not (memq var vars)))
+ (cgreg-release! regs i)))))
+
+(define (cgreg-clear! regs)
+ (let ((m (cgreg-liveregs regs))
+ (v1 (cgreg-contents regs))
+ (v2 (cgreg-stale regs)))
+ (do ((r 0 (+ r 1)))
+ ((= r m)
+ (cgreg-liveregs-set! regs 0))
+ (vector-set! v1 r #f)
+ (vector-set! v2 r #t))))
+
+(define (cgreg-lookup regs var)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (define (loop i)
+ (cond ((< i 0)
+ #f)
+ ((eq? var (vector-ref v i))
+ (list var 'register i '(object)))
+ (else
+ (loop (- i 1)))))
+ (loop (- m 1))))
+
+(define (cgreg-lookup-reg regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (if (<= m r)
+ #f
+ (vector-ref v r))))
+
+(define (cgreg-join! regs1 regs2)
+ (let ((m1 (cgreg-liveregs regs1))
+ (m2 (cgreg-liveregs regs2))
+ (v1 (cgreg-contents regs1))
+ (v2 (cgreg-contents regs2))
+ (stale1 (cgreg-stale regs1)))
+ (do ((i (- (max m1 m2) 1) (- i 1)))
+ ((< i 0)
+ (cgreg-liveregs-set! regs1 (min m1 m2)))
+ (let ((x1 (vector-ref v1 i))
+ (x2 (vector-ref v2 i)))
+ (cond ((eq? x1 x2)
+ #t)
+ ((not x1)
+ (if x2
+ (vector-set! stale1 i #t)))
+ (else
+ (vector-set! v1 i #f)
+ (vector-set! stale1 i #t)))))))
+
+; New representation of
+; Stack-frame environments.
+; Represented as a three-element list.
+;
+; Its car is a list whose car is a list of slot entries, each
+; of the form
+; (v n instruction stale)
+; where
+; v is the name of a variable or temporary,
+; n is #f or a slot number,
+; instruction is a possibly phantom store or setstk instruction
+; that stores v into slot n, and
+; stale is a list of stale slot entries, each of the form
+; (#t . n)
+; or (#f . -1)
+; where slot n had been allocated, initialized, and released
+; before the store or setstk instruction was generated.
+; Slot entries are updated by side effect.
+;
+; Its cadr is the list of currently stale slots.
+;
+; Its caddr is a list of variables that are free in the continuation,
+; or #f if that information is unknown.
+; This information allows a direct-style code generator to know when
+; a slot becomes stale.
+;
+; Its cadddr is the size of the stack frame, which can be
+; increased but not decreased. The cdddr of the stack frame
+; environment is shared with the save instruction that
+; created the frame. What a horrible crock!
+
+; This stuff is private to the implementation of stack-frame
+; environments.
+
+(define cgframe:slots car)
+(define cgframe:stale cadr)
+(define cgframe:livevars caddr)
+(define cgframe:slot.name car)
+(define cgframe:slot.offset cadr)
+(define cgframe:slot.instruction caddr)
+(define cgframe:slot.stale cadddr)
+
+(define cgframe:slots-set! set-car!)
+(define (cgframe:stale-set! frame stale)
+ (set-car! (cdr frame) stale))
+(define (cgframe:livevars-set! frame vars)
+ (set-car! (cddr frame) vars))
+
+(define cgframe:slot.name-set! set-car!)
+
+(define (cgframe:slot.offset-set! entry n)
+ (let ((instruction (caddr entry)))
+ (if (or (not (eq? #f (cadr entry)))
+ (not (eq? $nop (car instruction))))
+ (error "Compiler bug: cgframe" entry)
+ (begin
+ (set-car! (cdr entry) n)
+ (set-car! instruction (cadr instruction))
+ (set-cdr! instruction (cddr instruction))
+ (if (eq? $setstk (car instruction))
+ (set-car! (cdr instruction) n)
+ (set-car! (cddr instruction) n))))))
+
+; Reserves a slot offset that was unused where the instruction
+; of the slot entry was generated, and returns that offset.
+
+(define (cgframe:unused-slot frame entry)
+ (let* ((stale (cgframe:slot.stale entry))
+ (probe (assq #t stale)))
+ (if probe
+ (let ((n (cdr probe)))
+ (if (zero? n)
+ (cgframe-used! frame))
+ (set-car! probe #f)
+ n)
+ (let* ((cell (cgframe-size-cell frame))
+ (n (+ 1 (car cell))))
+ (set-car! cell n)
+ (if (zero? n)
+ (cgframe:unused-slot frame entry)
+ n)))))
+
+; Public entry points.
+
+; The runtime system requires slot 0 of a frame to contain
+; a closure whose code pointer contains the return address
+; of the frame.
+; To prevent slot 0 from being used for some other purpose,
+; we rely on a complex trick: Slot 0 is initially stale.
+; Gen-save! generates a store instruction for register 0,
+; with slot 0 as the only stale slot for that instruction;
+; then gen-save! clears the frame's set of stale slots, which
+; prevents other store instructions from using slot 0.
+
+(define (cgframe-initial)
+ (list '()
+ (list (cons #t 0))
+ '#f
+ -1))
+
+(define cgframe-livevars cgframe:livevars)
+(define cgframe-livevars-set! cgframe:livevars-set!)
+
+(define (cgframe-size-cell frame)
+ (cdddr frame))
+
+(define (cgframe-size frame)
+ (car (cgframe-size-cell frame)))
+
+(define (cgframe-used! frame)
+ (if (negative? (cgframe-size frame))
+ (set-car! (cgframe-size-cell frame) 0)))
+
+; Called only by gen-store!, gen-setstk!
+
+(define (cgframe-bind! frame var instruction)
+ (cgframe:slots-set! frame
+ (cons (list var #f instruction (cgframe:stale frame))
+ (cgframe:slots frame))))
+
+; Called only by gen-load!, gen-stack!
+
+(define (cgframe-touch! frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (let ((n (cgframe:unused-slot frame entry)))
+ (cgframe:slot.offset-set! entry n))))
+ (error "Compiler bug: cgframe-touch!" frame var))))
+
+(define (cgframe-rename! frame alist)
+ (for-each (lambda (entry)
+ (let ((probe (assq (cgframe:slot.name entry) alist)))
+ (if probe
+ (cgframe:slot.name-set! entry (cdr probe)))))
+ (cgframe:slots frame)))
+
+(define (cgframe-release! frame var)
+ (let* ((slots (cgframe:slots frame))
+ (entry (assq var slots)))
+ (if entry
+ (begin (cgframe:slots-set! frame (remq entry slots))
+ (let ((n (cgframe:slot.offset entry)))
+ (if (and (not (eq? #f n))
+ (not (zero? n)))
+ (cgframe:stale-set!
+ frame
+ (cons (cons #t n)
+ (cgframe:stale frame)))))))))
+
+(define (cgframe-release-except! frame vars)
+ (let loop ((slots (reverse (cgframe:slots frame)))
+ (newslots '())
+ (stale (cgframe:stale frame)))
+ (if (null? slots)
+ (begin (cgframe:slots-set! frame newslots)
+ (cgframe:stale-set! frame stale))
+ (let ((slot (car slots)))
+ (if (memq (cgframe:slot.name slot) vars)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale)
+ (let ((n (cgframe:slot.offset slot)))
+ (cond ((eq? n #f)
+ (loop (cdr slots)
+ newslots
+ stale))
+ ((zero? n)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale))
+ (else
+ (loop (cdr slots)
+ newslots
+ (cons (cons #t n) stale))))))))))
+
+(define (cgframe-lookup frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (cgframe-touch! frame var))
+ (list var 'frame (cgframe:slot.offset entry) '(object)))
+ #f)))
+
+(define (cgframe-spilled? frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (not (eq? #f n)))
+ #f)))
+
+; For a conditional expression, the then and else parts must be
+; evaluated using separate copies of the frame environment,
+; and those copies must be resolved at the join point. The
+; nature of the resolution depends upon whether the conditional
+; expression is in a tail position.
+;
+; Critical invariant:
+; Any store instructions that are generated within either arm of the
+; conditional involve variables and temporaries that are local to the
+; conditional.
+;
+; If the conditional expression is in a tail position, then a slot
+; that is stale after the test can be allocated independently by the
+; two arms of the conditional. If the conditional expression is in a
+; non-tail position, then the slot can be allocated independently
+; provided it is not a candidate destination for any previous emitted
+; store instruction.
+
+(define (cgframe-copy frame)
+ (cons (car frame)
+ (cons (cadr frame)
+ (cons (caddr frame)
+ (cdddr frame)))))
+
+(define (cgframe-update-stale! frame)
+ (let* ((n (cgframe-size frame))
+ (v (make-vector (+ 1 n) #t))
+ (stale (cgframe:stale frame)))
+ (for-each (lambda (x)
+ (if (car x)
+ (let ((i (cdr x)))
+ (if (<= i n)
+ (vector-set! v i #f)))))
+ stale)
+ (for-each (lambda (slot)
+ (let ((offset (cgframe:slot.offset slot)))
+ (if offset
+ (vector-set! v offset #f)
+ (for-each (lambda (stale)
+ (if (car stale)
+ (let ((i (cdr stale)))
+ (if (< i n)
+ (vector-set! v i #f)))))
+ (cgframe:slot.stale slot)))))
+ (cgframe:slots frame))
+ (do ((i n (- i 1))
+ (stale (filter car stale)
+ (if (vector-ref v i)
+ (cons (cons #t i) stale)
+ stale)))
+ ((<= i 0)
+ (cgframe:stale-set! frame stale)))))
+
+(define (cgframe-join! frame1 frame2)
+ (let* ((slots1 (cgframe:slots frame1))
+ (slots2 (cgframe:slots frame2))
+ (slots (intersection slots1 slots2))
+ (deadslots (append (difference slots1 slots)
+ (difference slots2 slots)))
+ (deadoffsets (make-set
+ (filter (lambda (x) (not (eq? x #f)))
+ (map cgframe:slot.offset deadslots))))
+ (stale1 (cgframe:stale frame1))
+ (stale2 (cgframe:stale frame2))
+ (stale (intersection stale1 stale2))
+ (stale (append (map (lambda (n) (cons #t n))
+ deadoffsets)
+ stale)))
+ (cgframe:slots-set! frame1 slots)
+ (cgframe:stale-set! frame1 stale)))
+
+; Environments.
+;
+; Each identifier has one of the following kinds of entry.
+;
+; (<name> register <number> (object))
+; (<name> frame <slot> (object))
+; (<name> lexical <rib> <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+; (<name> global (object))
+;
+; Implementation.
+;
+; An environment is represented as a list of the form
+;
+; ((<entry> ...) ; lexical rib
+; ...)
+;
+; where each <entry> has one of the forms
+;
+; (<name> lexical <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+
+(define entry.name car)
+(define entry.kind cadr)
+(define entry.rib caddr)
+(define entry.offset cadddr)
+(define entry.label cadddr)
+(define entry.regnum caddr)
+(define entry.slotnum caddr)
+(define entry.arity caddr)
+(define entry.op cadddr)
+(define (entry.imm entry) (car (cddddr entry)))
+
+(define (cgenv-initial integrable)
+ (list (map (lambda (x)
+ (list (car x)
+ 'integrable
+ (cadr x)
+ (caddr x)
+ (cadddr x)
+ '(object)))
+ integrable)))
+
+(define (cgenv-lookup env id)
+ (define (loop ribs m)
+ (if (null? ribs)
+ (cons id '(global (object)))
+ (let ((x (assq id (car ribs))))
+ (if x
+ (case (cadr x)
+ ((lexical)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((procedure)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((integrable)
+ (if (integrate-usual-procedures)
+ x
+ (loop '() m)))
+ (else ???))
+ (loop (cdr ribs) (+ m 1))))))
+ (loop env 0))
+
+(define (cgenv-extend env vars procs)
+ (cons (do ((n 0 (+ n 1))
+ (vars vars (cdr vars))
+ (rib (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (cons (list (car vars) 'lexical n '(object)) rib)))
+ ((null? vars) rib))
+ env))
+
+(define (cgenv-bindprocs env procs)
+ (cons (append (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (car env))
+ (cdr env)))
+
+(define (var-lookup var regs frame env)
+ (or (cgreg-lookup regs var)
+ (cgframe-lookup frame var)
+ (cgenv-lookup env var)))
+
+; Compositions.
+
+(define compile
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1 x))) $usual-integrable-procedures$)))
+
+(define compile-block
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1-block x))) $usual-integrable-procedures$)))
+
+; For testing.
+
+(define foo
+ (lambda (x)
+ (pretty-print (compile x))))
+
+; Find the smallest number of registers such that
+; adding more registers does not affect the code
+; generated for x (from 4 to 32 registers).
+
+(define (minregs x)
+ (define (defregs R)
+ (set! *nregs* R)
+ (set! *lastreg* (- *nregs* 1))
+ (set! *fullregs* (quotient *nregs* 2)))
+ (defregs 32)
+ (let ((code (assemble (compile x))))
+ (define (binary-search m1 m2)
+ (if (= (+ m1 1) m2)
+ m2
+ (let ((midpt (quotient (+ m1 m2) 2)))
+ (defregs midpt)
+ (if (equal? code (assemble (compile x)))
+ (binary-search m1 midpt)
+ (binary-search midpt m2)))))
+ (defregs 4)
+ (let ((newcode (assemble (compile x))))
+ (if (equal? code newcode)
+ 4
+ (binary-search 4 32)))))
+
+; Minimums:
+; browse 10
+; triangle 5
+; traverse 10
+; destruct 6
+; puzzle 8,8,10,7
+; tak 6
+; fft 28 (changing the named lets to macros didn't matter)
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 7 June 1999.
+;
+; Fourth pass of the Twobit compiler:
+; code generation for the MacScheme machine.
+;
+; This pass operates on input expressions described by the
+; following grammar and the invariants that follow it.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Every procedure defined by an internal definition takes a
+; fixed number of arguments.
+; * Every call to a procedure defined by an internal definition
+; passes the correct number of arguments.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Any lambda expression that is declared to be in A-normal form
+; really is in A-normal form.
+;
+;
+; Stack frames are created by "save" instructions.
+; A save instruction is generated
+;
+; * at the beginning of each lambda body
+; * at the beginning of the code for each arm of a conditional,
+; provided:
+; the conditional is in a tail position
+; the frames that were allocated by the save instructions
+; that dominate the arms of the conditional have not been
+; used (those save instructions will be eliminated during
+; assembly)
+;
+; The operand of a save instruction, and of its matching pop instructions,
+; increases automatically as frame slots are allocated.
+;
+; The code generated to return from a procedure is
+;
+; pop n
+; return
+;
+; The code generated for a tail call is
+;
+; pop n
+; invoke ...
+;
+; Invariant: When the code generator reserves an argument register
+; to hold a value, that value is named, and is stored into the current
+; stack frame. These store instructions are eliminated during assembly
+; unless there is a matching load instruction. If all of the instructions
+; that store into a stack frame are eliminated, then the stack frame
+; itself is eliminated.
+; Exception: An argument register may be used without naming or storing
+; its value provided the register is not in use and no expressions are
+; evaluated while it contains the unnamed and unstored value.
+
+
+(define (pass4 exp integrable)
+ (init-labels)
+ (init-temps)
+ (let ((output (make-assembly-stream))
+ (frame (cgframe-initial))
+ (regs (cgreg-initial))
+ (t0 (newtemp)))
+ (assembly-stream-info! output (make-hashtable equal-hash assoc))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (cg0 output
+ exp
+ 'result
+ regs
+ frame
+ (cgenv-initial integrable)
+ #t)
+ (pass4-code output)))
+
+(define (pass4-code output)
+ (hashtable-for-each (lambda (situation label)
+ (cg-trap output situation label))
+ (assembly-stream-info output))
+ (assembly-stream-code output))
+
+; Given:
+; an assembly stream into which instructions should be emitted
+; an expression
+; the target register
+; ('result, a register number, or '#f; tail position implies 'result)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+; Returns:
+; the target register ('result or a register number)
+; Side effects:
+; may change the register and stack-frame environments
+; may increase the size of the stack frame, which changes previously
+; emitted instructions
+; writes instructions to the assembly stream
+
+(define (cg0 output exp target regs frame env tail?)
+ (case (car exp)
+ ((quote) (gen! output $const (constant.value exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((lambda) (cg-lambda output exp regs frame env)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((set!) (cg0 output (assignment.rhs exp) 'result regs frame env #f)
+ (cg-assignment-result output exp target regs frame env tail?))
+ ((if) (cg-if output exp target regs frame env tail?))
+ ((begin) (if (variable? exp)
+ (cg-variable output exp target regs frame env tail?)
+ (cg-sequential output exp target regs frame env tail?)))
+ (else (cg-call output exp target regs frame env tail?))))
+
+; Lambda expressions that evaluate to closures.
+; This is hard because the MacScheme machine's lambda instruction
+; closes over the values that are in argument registers 0 through r
+; (where r can be larger than *nregs*).
+; The set of free variables is calculated and then sorted to minimize
+; register shuffling.
+;
+; Returns: nothing.
+
+(define (cg-lambda output exp regs frame env)
+ (let* ((args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (free (difference (lambda.F exp) vars))
+ (free (cg-sort-vars free regs frame env))
+ (newenv (cgenv-extend env (cons #t free) '()))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv)
+ (cg-eval-vars output free regs frame env)
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this the right constant?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: This load forces a stack frame to be allocated.
+ (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))
+
+; Given a list of free variables, filters out the ones that
+; need to be copied into a closure, and sorts them into an order
+; that reduces register shuffling. Returns a sorted version of
+; the list in which the first element (element 0) should go
+; into register 1, the second into register 2, and so on.
+
+(define (cg-sort-vars free regs frame env)
+ (let* ((free (filter (lambda (var)
+ (case (entry.kind
+ (var-lookup var regs frame env))
+ ((register frame)
+ #t)
+ ((lexical)
+ (not (ignore-space-leaks)))
+ (else #f)))
+ free))
+ (n (length free))
+ (m (min n (- *nregs* 1)))
+ (vec (make-vector m #f)))
+ (define (loop1 free free-notregister)
+ (if (null? free)
+ (loop2 0 free-notregister)
+ (let* ((var (car free))
+ (entry (cgreg-lookup regs var)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (<= r n)
+ (begin (vector-set! vec (- r 1) var)
+ (loop1 (cdr free)
+ free-notregister))
+ (loop1 (cdr free)
+ (cons var free-notregister))))
+ (loop1 (cdr free)
+ (cons var free-notregister))))))
+ (define (loop2 i free)
+ (cond ((null? free)
+ (vector->list vec))
+ ((= i m)
+ (append (vector->list vec) free))
+ ((vector-ref vec i)
+ (loop2 (+ i 1) free))
+ (else
+ (vector-set! vec i (car free))
+ (loop2 (+ i 1) (cdr free)))))
+ (loop1 free '())))
+
+; Fetches the given list of free variables into the corresponding
+; registers in preparation for a $lambda or $lexes instruction.
+
+(define (cg-eval-vars output free regs frame env)
+ (let ((n (length free))
+ (R-1 (- *nregs* 1)))
+ (if (>= n R-1)
+ (begin (gen! output $const '())
+ (gen! output $setreg R-1)
+ (cgreg-release! regs R-1)))
+ (do ((r n (- r 1))
+ (vars (reverse free) (cdr vars)))
+ ((zero? r))
+ (let* ((v (car vars))
+ (entry (var-lookup v regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (let ((r1 (entry.regnum entry)))
+ (if (not (eqv? r r1))
+ (if (< r R-1)
+ (begin (gen! output $movereg r1 r)
+ (cgreg-bind! regs r v))
+ (gen! output $reg r1 v)))))
+ ((frame)
+ (if (< r R-1)
+ (begin (gen-load! output frame r v)
+ (cgreg-bind! regs r v))
+ (gen-stack! output frame v)))
+ ((lexical)
+ (gen! output $lexical
+ (entry.rib entry)
+ (entry.offset entry)
+ v)
+ (if (< r R-1)
+ (begin (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v))))
+ (else
+ (error "Bug in cg-close-lambda")))
+ (if (>= r R-1)
+ (begin (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1)))))))
+
+; Lambda expressions that appear on the rhs of a definition are
+; compiled here. They don't need an args= instruction at their head.
+;
+; Returns: nothing.
+
+(define (cg-known-lambda output exp env)
+ (let* ((vars (make-null-terminated (lambda.args exp)))
+ (regs (cgreg-initial))
+ (frame (cgframe-initial))
+ (t0 (newtemp)))
+ (if (member A-normal-form-declaration (lambda.decls exp))
+ (cgframe-livevars-set! frame '()))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (do ((r 1 (+ r 1))
+ (vars vars (cdr vars)))
+ ((or (null? vars)
+ (= r *lastreg*))
+ (if (not (null? vars))
+ (begin (gen! output $movereg *lastreg* 1)
+ (cgreg-release! regs 1)
+ (do ((vars vars (cdr vars)))
+ ((null? vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $car:pair)
+ (gen-setstk! output frame (car vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $cdr:pair)
+ (gen! output $setreg 1)))))
+ (cgreg-bind! regs r (car vars))
+ (gen-store! output frame r (car vars)))
+ (cg-body output
+ exp
+ 'result
+ regs
+ frame
+ env
+ #t)))
+
+; Compiles a let or lambda body.
+; The arguments of the lambda expression L are already in
+; registers or the stack frame, as specified by regs and frame.
+;
+; The problem here is that the free variables of an internal
+; definition must be in a heap-allocated environment, so any
+; such variables in registers must be copied to the heap.
+;
+; Returns: destination register.
+
+(define (cg-body output L target regs frame env tail?)
+ (let* ((exp (lambda.body L))
+ (defs (lambda.defs L))
+ (free (apply-union
+ (map (lambda (def)
+ (let ((L (def.rhs def)))
+ (difference (lambda.F L)
+ (lambda.args L))))
+ defs))))
+ (cond ((or (null? defs) (constant? exp) (variable? exp))
+ (cg0 output exp target regs frame env tail?))
+ ((lambda? exp)
+ (let* ((free (cg-sort-vars
+ (union free
+ (difference
+ (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ regs frame env))
+ (newenv1 (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv1)
+ (cg-defs newoutput defs newenv1)
+ (cg-eval-vars output free regs frame env)
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target))))
+ ((every? (lambda (def)
+ (every? (lambda (v)
+ (case (entry.kind
+ (var-lookup v regs frame env))
+ ((register frame) #f)
+ (else #t)))
+ (let ((Ldef (def.rhs def)))
+ (difference (lambda.F Ldef)
+ (lambda.args Ldef)))))
+ defs)
+ (let* ((newenv (cgenv-bindprocs env (map def.lhs defs)))
+ (L (make-label))
+ (r (cg0 output exp target regs frame newenv tail?)))
+ (if (not tail?)
+ (gen! output $skip L (cgreg-live regs r)))
+ (cg-defs output defs newenv)
+ (if (not tail?)
+ (gen! output $.label L))
+ r))
+ (else
+ (let ((free (cg-sort-vars free regs frame env)))
+ (cg-eval-vars output free regs frame env)
+ ; FIXME: Have to restore it too!
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this constant the right one?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (let ((t0 (cgreg-lookup-reg regs 0))
+ (t1 (newtemp))
+ (newenv (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (L (make-label)))
+ (gen! output $lexes (length free) free)
+ (gen! output $setreg 0)
+ (cgreg-bind! regs 0 t1)
+ (if tail?
+ (begin (cgframe-release! frame t0)
+ (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #t)
+ (cg-defs output defs newenv)
+ 'result)
+ (begin (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #f)
+ (gen! output $skip L (cgreg-tos regs))
+ (cg-defs output defs newenv)
+ (gen! output $.label L)
+ (gen-load! output frame 0 t0)
+ (cgreg-bind! regs 0 t0)
+ (cgframe-release! frame t1)
+ (cg-move output frame regs 'result target)))))))))
+
+(define (cg-defs output defs env)
+ (for-each (lambda (def)
+ (gen! output $.align 4)
+ (gen! output $.label
+ (entry.label
+ (cgenv-lookup env (def.lhs def))))
+ (gen! output $.proc)
+ (gen! output $.proc-doc (lambda.doc (def.rhs def)))
+ (cg-known-lambda output
+ (def.rhs def)
+ env))
+ defs))
+
+; The right hand side has already been evaluated into the result register.
+
+(define (cg-assignment-result output exp target regs frame env tail?)
+ (gen! output $setglbl (assignment.lhs exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+
+(define (cg-if output exp target regs frame env tail?)
+ ; The test can be a constant, because it is awkward
+ ; to remove constant tests from an A-normal form.
+ (if (constant? (if.test exp))
+ (cg0 output
+ (if (constant.value (if.test exp))
+ (if.then exp)
+ (if.else exp))
+ target regs frame env tail?)
+ (begin
+ (cg0 output (if.test exp) 'result regs frame env #f)
+ (cg-if-result output exp target regs frame env tail?))))
+
+; The test expression has already been evaluated into the result register.
+
+(define (cg-if-result output exp target regs frame env tail?)
+ (let ((L1 (make-label))
+ (L2 (make-label)))
+ (gen! output $branchf L1 (cgreg-tos regs))
+ (let* ((regs2 (cgreg-copy regs))
+ (frame1 (if (and tail?
+ (negative? (cgframe-size frame)))
+ (cgframe-initial)
+ frame))
+ (frame2 (if (eq? frame frame1)
+ (cgframe-copy frame1)
+ (cgframe-initial)))
+ (t0 (cgreg-lookup-reg regs 0)))
+ (if (not (eq? frame frame1))
+ (let ((live (cgframe-livevars frame)))
+ (cgframe-livevars-set! frame1 live)
+ (cgframe-livevars-set! frame2 live)
+ (gen-save! output frame1 t0)
+ (cg-saveregs output regs frame1)))
+ (let ((r (cg0 output (if.then exp) target regs frame1 env tail?)))
+ (if (not tail?)
+ (gen! output $skip L2 (cgreg-live regs r)))
+ (gen! output $.label L1)
+ (if (not (eq? frame frame1))
+ (begin (gen-save! output frame2 t0)
+ (cg-saveregs output regs2 frame2))
+ (cgframe-update-stale! frame2))
+ (cg0 output (if.else exp) r regs2 frame2 env tail?)
+ (if (not tail?)
+ (begin (gen! output $.label L2)
+ (cgreg-join! regs regs2)
+ (cgframe-join! frame1 frame2)))
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r)))))
+
+(define (cg-variable output exp target regs frame env tail?)
+ (define (return id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ (gen-store! output frame target id)
+ target)
+ 'result)))
+ ; Same as return, but doesn't emit a store instruction.
+ (define (return-nostore id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ target)
+ 'result)))
+ (let* ((id (variable.name exp))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (gen! output $global id)
+ (return (newtemp)))
+ ((lexical)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry)))
+ (gen! output $lexical m n id)
+ (if (or (zero? m)
+ (negative? (cgframe-size frame)))
+ (return-nostore id)
+ (return id))))
+ ((procedure) (error "Bug in cg-variable" exp))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (if (or tail?
+ (and target (not (eqv? target r))))
+ (begin (gen! output $reg (entry.regnum entry) id)
+ (return-nostore id))
+ r)))
+ ((frame)
+ (cond ((eq? target 'result)
+ (gen-stack! output frame id)
+ (return id))
+ (target
+ ; Must be non-tail.
+ (gen-load! output frame target id)
+ (cgreg-bind! regs target id)
+ target)
+ (else
+ ; Must be non-tail.
+ (let ((r (choose-register regs frame)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ r))))
+ (else (error "Bug in cg-variable" exp)))))
+
+(define (cg-sequential output exp target regs frame env tail?)
+ (cg-sequential-loop output (begin.exprs exp) target regs frame env tail?))
+
+(define (cg-sequential-loop output exprs target regs frame env tail?)
+ (cond ((null? exprs)
+ (gen! output $const unspecified)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((null? (cdr exprs))
+ (cg0 output (car exprs) target regs frame env tail?))
+ (else (cg0 output (car exprs) #f regs frame env #f)
+ (cg-sequential-loop output
+ (cdr exprs)
+ target regs frame env tail?))))
+
+(define (cg-saveregs output regs frame)
+ (do ((i 1 (+ i 1))
+ (vars (cdr (cgreg-vars regs)) (cdr vars)))
+ ((null? vars))
+ (let ((t (car vars)))
+ (if t
+ (gen-store! output frame i t)))))
+
+(define (cg-move output frame regs src dst)
+ (define (bind dst)
+ (let ((temp (newtemp)))
+ (cgreg-bind! regs dst temp)
+ (gen-store! output frame dst temp)
+ dst))
+ (cond ((not dst)
+ src)
+ ((eqv? src dst)
+ dst)
+ ((eq? dst 'result)
+ (gen! output $reg src)
+ dst)
+ ((eq? src 'result)
+ (gen! output $setreg dst)
+ (bind dst))
+ ((and (not (zero? src))
+ (not (zero? dst)))
+ (gen! output $movereg src dst)
+ (bind dst))
+ (else
+ (gen! output $reg src)
+ (gen! output $setreg dst)
+ (bind dst))))
+
+; On-the-fly register allocator.
+; Tries to allocate:
+; a hardware register that isn't being used
+; a hardware register whose contents have already been spilled
+; a software register that isn't being used, unless a stack
+; frame has already been created, in which case it is better to use
+; a hardware register that is in use and hasn't yet been spilled
+;
+; All else equal, it is better to allocate a higher-numbered register
+; because the lower-numbered registers are targets when arguments
+; are being evaluated.
+;
+; Invariant: Every register that is returned by this allocator
+; is either not in use or has been spilled.
+
+(define (choose-register regs frame)
+ (car (choose-registers regs frame 1)))
+
+(define (choose-registers regs frame n)
+
+ ; Find unused hardware registers.
+ (define (loop1 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (if (negative? (cgframe-size frame))
+ (hardcase)
+ (loop2 (- *nhwregs* 1) n good)))
+ (else
+ (if (cgreg-lookup-reg regs i)
+ (loop1 (- i 1) n good)
+ (loop1 (- i 1)
+ (- n 1)
+ (cons i good))))))
+
+ ; Find already spilled hardware registers.
+ (define (loop2 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (hardcase))
+ (else
+ (let ((t (cgreg-lookup-reg regs i)))
+ (if (and t (cgframe-spilled? frame t))
+ (loop2 (- i 1)
+ (- n 1)
+ (cons i good))
+ (loop2 (- i 1) n good))))))
+
+ ; This is ridiculous.
+ ; Fortunately the correctness of the compiler is independent
+ ; of the predicate used for this sort.
+
+ (define (hardcase)
+ (let* ((frame-exists? (not (negative? (cgframe-size frame))))
+ (stufftosort
+ (map (lambda (r)
+ (let* ((t (cgreg-lookup-reg regs r))
+ (spilled?
+ (and t
+ (cgframe-spilled? frame t))))
+ (list r t spilled?)))
+ (cdr (iota *nregs*))))
+ (registers
+ (twobit-sort
+ (lambda (x1 x2)
+ (let ((r1 (car x1))
+ (r2 (car x2))
+ (t1 (cadr x1))
+ (t2 (cadr x2)))
+ (cond ((< r1 *nhwregs*)
+ (cond ((not t1) #t)
+ ((< r2 *nhwregs*)
+ (cond ((not t2) #f)
+ ((caddr x1) #t)
+ ((caddr x2) #f)
+ (else #t)))
+ (frame-exists? #t)
+ (t2 #t)
+ (else #f)))
+ ((< r2 *nhwregs*)
+ (cond (frame-exists? #f)
+ (t1 #f)
+ (t2 #t)
+ (else #f)))
+ (t1
+ (if (and (caddr x1)
+ t2
+ (not (caddr x2)))
+ #t
+ #f))
+ (else #t))))
+ stufftosort)))
+ ; FIXME: What was this for?
+ '
+ (for-each (lambda (register)
+ (let ((t (cadr register))
+ (spilled? (caddr register)))
+ (if (and t (not spilled?))
+ (cgframe-touch! frame t))))
+ registers)
+ (do ((sorted (map car registers) (cdr sorted))
+ (rs '() (cons (car sorted) rs))
+ (n n (- n 1)))
+ ((zero? n)
+ (reverse rs)))))
+
+ (if (< n *nregs*)
+ (loop1 (- *nhwregs* 1) n '())
+ (error (string-append "Compiler bug: can't allocate "
+ (number->string n)
+ " registers on this target."))))
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 21 May 1999.
+
+; Procedure calls.
+
+(define (cg-call output exp target regs frame env tail?)
+ (let ((proc (call.proc exp)))
+ (cond ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ (cg-let output exp target regs frame env tail?))
+ ((not (variable? proc))
+ (cg-unknown-call output exp target regs frame env tail?))
+ (else (let ((entry
+ (var-lookup (variable.name proc) regs frame env)))
+ (case (entry.kind entry)
+ ((global lexical frame register)
+ (cg-unknown-call output
+ exp
+ target regs frame env tail?))
+ ((integrable)
+ (cg-integrable-call output
+ exp
+ target regs frame env tail?))
+ ((procedure)
+ (cg-known-call output
+ exp
+ target regs frame env tail?))
+ (else (error "Bug in cg-call" exp))))))))
+
+(define (cg-unknown-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (if (variable? proc)
+ (let ((entry (cgreg-lookup regs (variable.name proc))))
+ (if (and entry
+ (<= (entry.regnum entry) n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1)))
+ (begin (cg-arguments output
+ (iota1 n)
+ args
+ regs frame env)
+ (cg0 output proc 'result regs frame env #f)))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+(define (cg-known-call output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (cg-arguments output (iota1 n) args regs frame env)
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (let* ((entry (cgenv-lookup env (variable.name (call.proc exp))))
+ (label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+; Any call can be compiled as follows, even if there are no free registers.
+;
+; Let T0, T1, ..., Tn be newly allocated stack temporaries.
+;
+; <arg0>
+; setstk T0
+; <arg1> -|
+; setstk T1 |
+; ... |- evaluate args into stack frame
+; <argn> |
+; setstk Tn -|
+; const ()
+; setreg R-1
+; stack Tn -|
+; op2 cons,R-1 |
+; setreg R-1 |
+; ... |- cons up overflow args
+; stack T_{R-1} |
+; op2 cons,R-1 |
+; setreg R-1 -|
+; stack T_{R-2} -|
+; setreg R-2 |
+; ... |- pop remaining args into registers
+; stack T1 |
+; setreg 1 -|
+; stack T0
+; invoke n
+
+(define (cg-big-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (argslots (newtemps n))
+ (procslot (newtemp))
+ (r0 (cgreg-lookup-reg regs 0))
+ (R-1 (- *nregs* 1))
+ (entry (if (variable? proc)
+ (let ((entry
+ (var-lookup (variable.name proc)
+ regs frame env)))
+ (if (eq? (entry.kind entry) 'procedure)
+ entry
+ #f))
+ #f))
+ (L (make-label)))
+ (if (not entry)
+ (begin
+ (cg0 output proc 'result regs frame env #f)
+ (gen-setstk! output frame procslot)))
+ (for-each (lambda (arg argslot)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame argslot))
+ args
+ argslots)
+ (cgreg-clear! regs)
+ (gen! output $const '())
+ (gen! output $setreg R-1)
+ (do ((i n (- i 1))
+ (slots (reverse argslots) (cdr slots)))
+ ((zero? i))
+ (if (< i R-1)
+ (gen-load! output frame i (car slots))
+ (begin (gen-stack! output frame (car slots))
+ (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1))))
+ (if (not entry)
+ (gen-stack! output frame procslot))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (if entry
+ (let ((label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (gen! output $invoke n))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs) ; redundant, see above
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target)))))
+
+(define (cg-integrable-call output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op1 (entry.op entry)))
+ ((2) (cg-integrable-call2 output
+ entry
+ args
+ regs frame env))
+ ((3) (cg-integrable-call3 output
+ entry
+ args
+ regs frame env))
+ (else (error "Bug detected by cg-integrable-call"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-integrable-call2 output entry args regs frame env)
+ (let ((op (entry.op entry)))
+ (if (and (entry.imm entry)
+ (constant? (cadr args))
+ ((entry.imm entry) (constant.value (cadr args))))
+ (begin (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op2imm
+ op
+ (constant.value (cadr args))))
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (choose-register regs frame)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2))))
+ (gen! output $op2 (entry.op entry) r2)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))))))
+ 'result)
+
+(define (cg-integrable-call3 output entry args regs frame env)
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2)))
+ (reg3 (cg0 output (caddr args) #f regs frame env #f))
+ (spillregs (choose-registers regs frame 2))
+ (t3 (if (eq? reg3 'result)
+ (let ((t3 (newtemp))
+ (r3 (if (eq? t2 (cgreg-lookup-reg
+ regs (car spillregs)))
+ (cadr spillregs)
+ (car spillregs))))
+ (gen! output $setreg r3)
+ (cgreg-bind! regs r3 t3)
+ (gen-store! output frame r3 t3)
+ t3)
+ (cgreg-lookup-reg regs reg3))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((spillregs (choose-registers regs frame 2))
+ (r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (car spillregs)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2)))
+ (r3 (or (let ((entry (cgreg-lookup regs t3)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r3 (if (eq? r2 (car spillregs))
+ (cadr spillregs)
+ (car spillregs))))
+ (cgreg-bind! regs r3 t3)
+ (gen-load! output frame r3 t3)
+ r3))))
+ (gen! output $op3 (entry.op entry) r2 r3)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))
+ (if (eq? reg3 'result)
+ (begin (cgreg-release! regs r3)
+ (cgframe-release! frame t3)))))
+ 'result)
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+(define (cg-primop-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+
+
+; Parallel assignment.
+
+; Given a list of target registers, a list of expressions, and a
+; compile-time environment, generates code to evaluate the expressions
+; into the registers.
+;
+; Argument evaluation proceeds as follows:
+;
+; 1. Evaluate all but one of the complicated arguments.
+; 2. Evaluate remaining arguments.
+; 3. Load spilled arguments from stack.
+
+(define (cg-arguments output targets args regs frame env)
+
+ ; Sorts the args and their targets into complicated and
+ ; uncomplicated args and targets.
+ ; Then it calls evalargs.
+
+ (define (sortargs targets args targets1 args1 targets2 args2)
+ (if (null? args)
+ (evalargs targets1 args1 targets2 args2)
+ (let ((target (car targets))
+ (arg (car args))
+ (targets (cdr targets))
+ (args (cdr args)))
+ (if (complicated? arg env)
+ (sortargs targets
+ args
+ (cons target targets1)
+ (cons arg args1)
+ targets2
+ args2)
+ (sortargs targets
+ args
+ targets1
+ args1
+ (cons target targets2)
+ (cons arg args2))))))
+
+ ; Given the complicated args1 and their targets1,
+ ; and the uncomplicated args2 and their targets2,
+ ; evaluates all the arguments into their target registers.
+
+ (define (evalargs targets1 args1 targets2 args2)
+ (let* ((temps1 (newtemps (length targets1)))
+ (temps2 (newtemps (length targets2))))
+ (if (not (null? args1))
+ (for-each (lambda (arg temp)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame temp))
+ (cdr args1)
+ (cdr temps1)))
+ (if (not (null? args1))
+ (evalargs0 (cons (car targets1) targets2)
+ (cons (car args1) args2)
+ (cons (car temps1) temps2))
+ (evalargs0 targets2 args2 temps2))
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (let ((entry (var-lookup t regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (gen! output $movereg (entry.regnum entry) r))
+ ((frame)
+ (gen-load! output frame r t)))
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ (append targets1 targets2)
+ (append temps1 temps2))))
+
+ (define (evalargs0 targets args temps)
+ (if (not (null? targets))
+ (let ((para (let* ((regvars (map (lambda (reg)
+ (cgreg-lookup-reg regs reg))
+ targets)))
+ (parallel-assignment targets
+ (map cons regvars targets)
+ args))))
+ (if para
+ (let ((targets para)
+ (args (cg-permute args targets para))
+ (temps (cg-permute temps targets para)))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ para
+ temps))
+ (let ((r (choose-register regs frame))
+ (t (car temps)))
+ (cg0 output (car args) r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (evalargs0 (cdr targets)
+ (cdr args)
+ (cdr temps)))))))
+
+ (if (parallel-assignment-optimization)
+ (sortargs (reverse targets) (reverse args) '() '() '() '())
+ (cg-evalargs output targets args regs frame env)))
+
+; Left-to-right evaluation of arguments directly into targets.
+
+(define (cg-evalargs output targets args regs frame env)
+ (let ((temps (newtemps (length targets))))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ targets
+ temps)
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ targets
+ temps)))
+
+; For heuristic use only.
+; An expression is complicated unless it can probably be evaluated
+; without saving and restoring any registers, even if it occurs in
+; a non-tail position.
+
+(define (complicated? exp env)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #t)
+ ((set!) (complicated? (assignment.rhs exp) env))
+ ((if) (or (complicated? (if.test exp) env)
+ (complicated? (if.then exp) env)
+ (complicated? (if.else exp) env)))
+ ((begin) (if (variable? exp)
+ #f
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (let ((entry
+ (cgenv-lookup env (variable.name proc))))
+ (eq? (entry.kind entry) 'integrable)))
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (call.args exp))
+ #t)))))
+
+; Returns a permutation of the src list, permuted the same way the
+; key list was permuted to obtain newkey.
+
+(define (cg-permute src key newkey)
+ (let ((alist (map cons key (iota (length key)))))
+ (do ((newkey newkey (cdr newkey))
+ (dest '()
+ (cons (list-ref src (cdr (assq (car newkey) alist)))
+ dest)))
+ ((null? newkey) (reverse dest)))))
+
+; Given a list of register numbers,
+; an association list with entries of the form (name . regnum) giving
+; the variable names by which those registers are known in code,
+; and a list of expressions giving new values for those registers,
+; returns an ordering of the register assignments that implements a
+; parallel assignment if one can be found, otherwise returns #f.
+
+(define parallel-assignment
+ (lambda (regnums alist exps)
+ (if (null? regnums)
+ #t
+ (let ((x (toposort (dependency-graph regnums alist exps))))
+ (if x (reverse x) #f)))))
+
+(define dependency-graph
+ (lambda (regnums alist exps)
+ (let ((names (map car alist)))
+ (do ((regnums regnums (cdr regnums))
+ (exps exps (cdr exps))
+ (l '() (cons (cons (car regnums)
+ (map (lambda (var) (cdr (assq var alist)))
+ (intersection (freevariables (car exps))
+ names)))
+ l)))
+ ((null? regnums) l)))))
+
+; Given a nonempty graph represented as a list of the form
+; ((node1 . <list of nodes that node1 is less than or equal to>)
+; (node2 . <list of nodes that node2 is less than or equal to>)
+; ...)
+; returns a topological sort of the nodes if one can be found,
+; otherwise returns #f.
+
+(define toposort
+ (lambda (graph)
+ (cond ((null? (cdr graph)) (list (caar graph)))
+ (else (toposort2 graph '())))))
+
+(define toposort2
+ (lambda (totry tried)
+ (cond ((null? totry) #f)
+ ((or (null? (cdr (car totry)))
+ (and (null? (cddr (car totry)))
+ (eq? (cadr (car totry))
+ (car (car totry)))))
+ (if (and (null? (cdr totry)) (null? tried))
+ (list (caar totry))
+ (let* ((node (caar totry))
+ (x (toposort2 (map (lambda (y)
+ (cons (car y) (remove node (cdr y))))
+ (append (cdr totry) tried))
+ '())))
+ (if x
+ (cons node x)
+ #f))))
+ (else (toposort2 (cdr totry) (cons (car totry) tried))))))
+
+(define iota (lambda (n) (iota2 n '())))
+
+(define iota1 (lambda (n) (cdr (iota2 (+ n 1) '()))))
+
+(define iota2
+ (lambda (n l)
+ (if (zero? n)
+ l
+ (let ((n (- n 1)))
+ (iota2 n (cons n l))))))
+
+(define (freevariables exp)
+ (freevars2 exp '()))
+
+(define (freevars2 exp env)
+ (cond ((symbol? exp)
+ (if (memq exp env) '() (list exp)))
+ ((not (pair? exp)) '())
+ (else (let ((keyword (car exp)))
+ (cond ((eq? keyword 'quote) '())
+ ((eq? keyword 'lambda)
+ (let ((env (append (make-null-terminated (cadr exp))
+ env)))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cddr exp)))))
+ ((memq keyword '(if set! begin))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cdr exp))))
+ (else (apply-union
+ (map (lambda (x) (freevars2 x env))
+ exp))))))))
+; Copyright 1991 William Clinger (cg-let and cg-let-body)
+; Copyright 1999 William Clinger (everything else)
+;
+; 10 June 1999.
+
+; Generates code for a let expression.
+
+(define (cg-let output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc))
+ (n (length vars))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame)))
+ (if (and (null? (lambda.defs proc))
+ (= n 1))
+ (cg-let1 output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (temps (newtemps n))
+ (alist (map cons temps vars)))
+ (for-each (lambda (arg t)
+ (let ((r (choose-register regs frame)))
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)))
+ args
+ temps)
+ (cgreg-rename! regs alist)
+ (cgframe-rename! frame alist)
+ (cg-let-release! free live regs frame tail?)
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given the free variables of a let body, and the variables that are
+; live after the let expression, and the usual regs, frame, and tail?
+; arguments, releases any registers and frame slots that don't need
+; to be preserved across the body of the let.
+
+(define (cg-let-release! free live regs frame tail?)
+ ; The tail case is easy because there are no live temporaries,
+ ; and there are no free variables in the context.
+ ; The non-tail case assumes A-normal form.
+ (cond (tail?
+ (let ((keepers (cons (cgreg-lookup-reg regs 0) free)))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))
+ (live
+ (let ((keepers (cons (cgreg-lookup-reg regs 0)
+ (union live free))))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))))
+
+; Generates code for the body of a let.
+
+(define (cg-let-body output L target regs frame env tail?)
+ (let ((vars (lambda.args L))
+ (free (lambda.F L))
+ (live (cgframe-livevars frame)))
+ (let ((r (cg-body output L target regs frame env tail?)))
+ (for-each (lambda (v)
+ (let ((entry (cgreg-lookup regs v)))
+ (if entry
+ (cgreg-release! regs (entry.regnum entry)))
+ (cgframe-release! frame v)))
+ vars)
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r))))
+
+; Generates code for a let expression that binds exactly one variable
+; and has no internal definitions. These let expressions are very
+; common in A-normal form, and there are many special cases with
+; respect to register allocation and order of evaluation.
+
+(define (cg-let1 output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (arg (car (call.args exp)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc)))
+
+ (define (evaluate-into-register r)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ (define (finish)
+ (release-registers!)
+ (cg-let-body output proc target regs frame env tail?))
+
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+
+ (cond ((assq v *regnames*)
+ (evaluate-into-register (cdr (assq v *regnames*)))
+ (finish))
+ ((not (memq v free))
+ (cg0 output arg #f regs frame env #f)
+ (finish))
+ (live
+ (cg0 output arg 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output exp target regs frame env tail?))
+ (else
+ (evaluate-into-register (choose-register regs frame))
+ (finish)))))
+
+; Given a let expression that binds one variable whose value has already
+; been evaluated into the result register, generates code for the rest
+; of the let expression.
+; The main difficulty is an unfortunate interaction between A-normal
+; form and the MacScheme machine architecture: We don't want to move
+; a value from the result register into a general register if it has
+; only one use and can remain in the result register until that use.
+
+(define (cg-let1-result output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc))
+ (pattern (cg-let-used-once v body)))
+
+ (define (move-to-register r)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ ; FIXME: The live variables must be correct in the frame.
+
+ (case pattern
+ ((if)
+ (cg-if-result output body target regs frame env tail?))
+ ((let-if)
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+ (cg-if-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output body target regs frame env tail?))
+ ((set!)
+ (cg-assignment-result output
+ body target regs frame env tail?))
+ ((let-set!)
+ (cg-assignment-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ((primop)
+ (cg-primop-result output body target regs frame env tail?))
+ ((let-primop)
+ (cg-primop-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ; FIXME
+ ((_called)
+ (cg-call-result output body target regs frame env tail?))
+ ; FIXME
+ ((_let-called)
+ (cg-call-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ (else
+ ; FIXME: The first case was handled by cg-let1.
+ (cond ((assq v *regnames*)
+ (move-to-register (cdr (assq v *regnames*))))
+ ((memq v free)
+ (move-to-register (choose-register regs frame))))
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given a call to a primop whose first argument has already been
+; evaluated into the result register and whose remaining arguments
+; consist of constants and variable references, generates code for
+; the call.
+
+(define (cg-primop-result output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (gen! output $op1 (entry.op entry)))
+ ((2) (cg-primop2-result! output entry args regs frame env))
+ ((3) (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output
+ $op3 (entry.op entry) (car rs) (cadr rs))))
+ (else (error "Bug detected by cg-primop-result"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special-result output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-primop2-result! output entry args regs frame env)
+ (let ((op (entry.op entry))
+ (arg2 (cadr args)))
+ (if (and (constant? arg2)
+ (entry.imm entry)
+ ((entry.imm entry) (constant.value arg2)))
+ (gen! output $op2imm op (constant.value arg2))
+ (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output $op2 op (car rs))))))
+
+; Given a short list of constants and variable references to be evaluated
+; into arbitrary general registers, evaluates them into registers without
+; disturbing the result register and returns a list of the registers into
+; which they are evaluated. Before returning, any registers that were
+; allocated by this routine are released.
+
+(define (cg-result-args output args regs frame env)
+
+ ; Given a list of unevaluated arguments,
+ ; a longer list of disjoint general registers,
+ ; the register that holds the first evaluated argument,
+ ; a list of registers in reverse order that hold other arguments,
+ ; and a list of registers to be released afterwards,
+ ; generates code to evaluate the arguments,
+ ; deallocates any registers that were evaluated to hold the arguments,
+ ; and returns the list of registers that contain the arguments.
+
+ (define (loop args registers rr rs temps)
+ (if (null? args)
+ (begin (if (not (eq? rr 'result))
+ (gen! output $reg rr))
+ (for-each (lambda (r) (cgreg-release! regs r))
+ temps)
+ (reverse rs))
+ (let ((arg (car args)))
+ (cond ((constant? arg)
+ (let ((r (car registers)))
+ (gen! output $const/setreg (constant.value arg) r)
+ (cgreg-bind! regs r #t)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ ((variable? arg)
+ (let* ((id (variable.name arg))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $global id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((lexical)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry))
+ (r (car registers)))
+ (gen! output $lexical m n id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((procedure) (error "Bug in cg-variable" arg))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (loop (cdr args)
+ registers
+ rr
+ (cons r rs)
+ temps)))
+ ((frame)
+ (let ((r (car registers)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ (else (error "Bug in cg-result-args" arg)))))
+ (else
+ (error "Bug in cg-result-args"))))))
+
+ (define (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $setreg r)
+ (loop args
+ (cdr registers)
+ r
+ rs
+ temps)))
+
+ (loop (cdr args)
+ (choose-registers regs frame (length args))
+ 'result '() '()))
+
+; Given a local variable T1 and an expression in A-normal form,
+; cg-let-used-once returns a symbol if the local variable is used
+; exactly once in the expression and the expression matches one of
+; the patterns below. Otherwise returns #f. The symbol that is
+; returned is the name of the pattern that is matched.
+;
+; pattern symbol returned
+;
+; (if T1 ... ...) if
+;
+; (<primop> T1 ...) primop
+;
+; (T1 ...) called
+;
+; (set! ... T1) set!
+;
+; (let ((T2 (if T1 ... ...))) let-if
+; E3)
+;
+; (let ((T2 (<primop> T1 ...))) let-primop
+; E3)
+;
+; (let ((T2 (T1 ...))) let-called
+; E3)
+;
+; (let ((T2 (set! ... T1))) let-set!
+; E3)
+;
+; This implementation sometimes returns #f incorrectly, but it always
+; returns an answer in constant time (assuming A-normal form).
+
+(define (cg-let-used-once T1 exp)
+ (define budget 20)
+ (define (cg-let-used-once T1 exp)
+ (define (used? T1 exp)
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #t)
+ ((constant? exp) #f)
+ ((variable? exp)
+ (eq? T1 (variable.name exp)))
+ ((lambda? exp)
+ (memq T1 (lambda.F exp)))
+ ((assignment? exp)
+ (used? T1 (assignment.rhs exp)))
+ ((call? exp)
+ (or (used? T1 (call.proc exp))
+ (used-in-args? T1 (call.args exp))))
+ ((conditional? exp)
+ (or (used? T1 (if.test exp))
+ (used? T1 (if.then exp))
+ (used? T1 (if.else exp))))
+ (else #t)))
+ (define (used-in-args? T1 args)
+ (if (null? args)
+ #f
+ (or (used? T1 (car args))
+ (used-in-args? T1 (cdr args)))))
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #f)
+ ((call? exp)
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((variable? proc)
+ (let ((f (variable.name proc)))
+ (cond ((eq? f T1)
+ (and (not (used-in-args? T1 args))
+ 'called))
+ ((and (integrable? f)
+ (not (null? args))
+ (variable? (car args))
+ (eq? T1 (variable.name (car args))))
+ (and (not (used-in-args? T1 (cdr args)))
+ 'primop))
+ (else #f))))
+ ((lambda? proc)
+ (and (not (memq T1 (lambda.F proc)))
+ (not (null? args))
+ (null? (cdr args))
+ (case (cg-let-used-once T1 (car args))
+ ((if) 'let-if)
+ ((primop) 'let-primop)
+ ((called) 'let-called)
+ ((set!) 'let-set!)
+ (else #f))))
+ (else #f))))
+ ((conditional? exp)
+ (let ((E0 (if.test exp)))
+ (and (variable? E0)
+ (eq? T1 (variable.name E0))
+ (not (used? T1 (if.then exp)))
+ (not (used? T1 (if.else exp)))
+ 'if)))
+ ((assignment? exp)
+ (let ((rhs (assignment.rhs exp)))
+ (and (variable? rhs)
+ (eq? T1 (variable.name rhs))
+ 'set!)))
+ (else #f)))
+ (cg-let-used-once T1 exp))
+
+; Given the name of a let-body pattern, an expression that matches that
+; pattern, and an expression to be substituted for the let variable,
+; returns the transformed expression.
+
+; FIXME: No longer used.
+
+(define (cg-let-transform pattern exp E1)
+ (case pattern
+ ((if)
+ (make-conditional E1 (if.then exp) (if.else exp)))
+ ((primop)
+ (make-call (call.proc exp)
+ (cons E1 (cdr (call.args exp)))))
+ ((called)
+ (make-call E1 (call.args exp)))
+ ((set!)
+ (make-assignment (assignment.lhs exp) E1))
+ ((let-if let-primop let-called let-set!)
+ (make-call (call.proc exp)
+ (list (cg-let-transform (case pattern
+ ((let-if) 'if)
+ ((let-primop) 'primop)
+ ((let-called) 'called)
+ ((let-set!) 'set!))
+ (car (call.args exp))
+ E1))))
+ (else
+ (error "Unrecognized pattern in cg-let-transform" pattern)))); Copyright 1999 William Clinger
+;
+; Code for special primitives, used to generate runtime safety checks,
+; efficient code for call-with-values, and other weird things.
+;
+; 4 June 1999.
+
+(define (cg-special output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-special-result output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check-result output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-check output exp target regs frame env tail?)
+ (cg0 output (car (call.args exp)) 'result regs frame env #f)
+ (cg-check-result output exp target regs frame env tail?))
+
+(define (cg-check-result output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (nargs (length args))
+ (valexps (cddr args)))
+ (if (and (<= 2 nargs 5)
+ (constant? (cadr args))
+ (every? (lambda (exp)
+ (or (constant? exp)
+ (variable? exp)))
+ valexps))
+ (let* ((exn (constant.value (cadr args)))
+ (vars (filter variable? valexps))
+ (rs (cg-result-args output
+ (cons (car args) vars)
+ regs frame env)))
+
+ ; Construct the trap situation:
+ ; the exception number followed by an ordered list of
+ ; register numbers and constant expressions.
+
+ (let loop ((registers rs)
+ (exps valexps)
+ (operands '()))
+ (cond ((null? exps)
+ (let* ((situation (cons exn (reverse operands)))
+ (ht (assembly-stream-info output))
+ (L1 (or (hashtable-get ht situation)
+ (let ((L1 (make-label)))
+ (hashtable-put! ht situation L1)
+ L1))))
+ (define (translate r)
+ (if (number? r) r 0))
+ (case (length operands)
+ ((0) (gen! output $check 0 0 0 L1))
+ ((1) (gen! output $check
+ (translate (car operands))
+ 0 0 L1))
+ ((2) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ 0 L1))
+ ((3) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ (translate (caddr operands))
+ L1)))))
+ ((constant? (car exps))
+ (loop registers
+ (cdr exps)
+ (cons (car exps) operands)))
+ (else
+ (loop (cdr registers)
+ (cdr exps)
+ (cons (car registers) operands))))))
+ (error "Compiler bug: runtime check" (make-readable exp)))))
+
+; Given an assembly stream and the description of a trap as recorded
+; by cg-check above, generates a non-continuable trap at that label for
+; that trap, passing the operands to the exception handler.
+
+(define (cg-trap output situation L1)
+ (let* ((exn (car situation))
+ (operands (cdr situation)))
+ (gen! output $.label L1)
+ (let ((liveregs (filter number? operands)))
+ (define (loop operands registers r)
+ (cond ((null? operands)
+ (case (length registers)
+ ((0) (gen! output $trap 0 0 0 exn))
+ ((1) (gen! output $trap (car registers) 0 0 exn))
+ ((2) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ 0
+ exn))
+ ((3) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ (caddr registers)
+ exn))
+ (else "Compiler bug: trap")))
+ ((number? (car operands))
+ (loop (cdr operands)
+ (cons (car operands) registers)
+ r))
+ ((memv r liveregs)
+ (loop operands registers (+ r 1)))
+ (else
+ (gen! output $const (constant.value (car operands)))
+ (gen! output $setreg r)
+ (loop (cdr operands)
+ (cons r registers)
+ (+ r 1)))))
+ (loop (reverse operands) '() 1))))
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+; FIXME: No longer used.
+
+(define (cg-check-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 5 June 1999.
+;
+; Local optimizations for MacScheme machine assembly code.
+;
+; Branch tensioning.
+; Suppress nop instructions.
+; Suppress save, restore, and pop instructions whose operand is -1.
+; Suppress redundant stores.
+; Suppress definitions (primarily loads) of dead registers.
+;
+; Note: Twobit never generates a locally redundant load or store,
+; so this code must be tested with a different code generator.
+;
+; To perform these optimizations, the basic block must be traversed
+; both forwards and backwards.
+; The forward traversal keeps track of registers that were defined
+; by a load.
+; The backward traversal keeps track of live registers.
+
+(define filter-basic-blocks
+
+ (let* ((suppression-message
+ "Local optimization detected a useless instruction.")
+
+ ; Each instruction is mapping to an encoding of the actions
+ ; to be performed when it is encountered during the forward
+ ; or backward traversal.
+
+ (forward:normal 0)
+ (forward:nop 1)
+ (forward:ends-block 2)
+ (forward:interesting 3)
+ (forward:kills-all-registers 4)
+ (forward:nop-if-arg1-is-negative 5)
+
+ (backward:normal 0)
+ (backward:ends-block 1)
+ (backward:begins-block 2)
+ (backward:uses-arg1 4)
+ (backward:uses-arg2 8)
+ (backward:uses-arg3 16)
+ (backward:kills-arg1 32)
+ (backward:kills-arg2 64)
+ (backward:uses-many 128)
+
+ ; largest mnemonic + 1
+
+ (dispatch-table-size *number-of-mnemonics*)
+
+ ; Dispatch table for the forwards traversal.
+
+ (forward-table (make-bytevector dispatch-table-size))
+
+ ; Dispatch table for the backwards traversal.
+
+ (backward-table (make-bytevector dispatch-table-size)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i dispatch-table-size))
+ (bytevector-set! forward-table i forward:normal)
+ (bytevector-set! backward-table i backward:normal))
+
+ (bytevector-set! forward-table $nop forward:nop)
+
+ (bytevector-set! forward-table $invoke forward:ends-block)
+ (bytevector-set! forward-table $return forward:ends-block)
+ (bytevector-set! forward-table $skip forward:ends-block)
+ (bytevector-set! forward-table $branch forward:ends-block)
+ (bytevector-set! forward-table $branchf forward:ends-block)
+ (bytevector-set! forward-table $jump forward:ends-block)
+ (bytevector-set! forward-table $.align forward:ends-block)
+ (bytevector-set! forward-table $.proc forward:ends-block)
+ (bytevector-set! forward-table $.cont forward:ends-block)
+ (bytevector-set! forward-table $.label forward:ends-block)
+
+ (bytevector-set! forward-table $store forward:interesting)
+ (bytevector-set! forward-table $load forward:interesting)
+ (bytevector-set! forward-table $setstk forward:interesting)
+ (bytevector-set! forward-table $setreg forward:interesting)
+ (bytevector-set! forward-table $movereg forward:interesting)
+ (bytevector-set! forward-table $const/setreg
+ forward:interesting)
+
+ (bytevector-set! forward-table $args>= forward:kills-all-registers)
+ (bytevector-set! forward-table $popstk forward:kills-all-registers)
+
+ ; These instructions also kill all registers.
+
+ (bytevector-set! forward-table $save forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $restore forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $pop forward:nop-if-arg1-is-negative)
+
+ (bytevector-set! backward-table $invoke backward:ends-block)
+ (bytevector-set! backward-table $return backward:ends-block)
+ (bytevector-set! backward-table $skip backward:ends-block)
+ (bytevector-set! backward-table $branch backward:ends-block)
+ (bytevector-set! backward-table $branchf backward:ends-block)
+
+ (bytevector-set! backward-table $jump backward:begins-block) ; [sic]
+ (bytevector-set! backward-table $.align backward:begins-block)
+ (bytevector-set! backward-table $.proc backward:begins-block)
+ (bytevector-set! backward-table $.cont backward:begins-block)
+ (bytevector-set! backward-table $.label backward:begins-block)
+
+ (bytevector-set! backward-table $op2 backward:uses-arg2)
+ (bytevector-set! backward-table $op3 (logior backward:uses-arg2
+ backward:uses-arg3))
+ (bytevector-set! backward-table $check (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $trap (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $store backward:uses-arg1)
+ (bytevector-set! backward-table $reg backward:uses-arg1)
+ (bytevector-set! backward-table $load backward:kills-arg1)
+ (bytevector-set! backward-table $setreg backward:kills-arg1)
+ (bytevector-set! backward-table $movereg (logior backward:uses-arg1
+ backward:kills-arg2))
+ (bytevector-set! backward-table $const/setreg
+ backward:kills-arg2)
+ (bytevector-set! backward-table $lambda backward:uses-many)
+ (bytevector-set! backward-table $lexes backward:uses-many)
+ (bytevector-set! backward-table $args>= backward:uses-many)
+
+ (lambda (instructions)
+
+ (let* ((*nregs* *nregs*) ; locals might be faster than globals
+
+ ; During the forwards traversal:
+ ; (vector-ref registers i) = #f
+ ; means the content of register i is unknown
+ ; (vector-ref registers i) = j
+ ; means register was defined by load i,j
+ ;
+ ; During the backwards traversal:
+ ; (vector-ref registers i) = #f means register i is dead
+ ; (vector-ref registers i) = #t means register i is live
+
+ (registers (make-vector *nregs* #f))
+
+ ; During the forwards traversal, the label of a block that
+ ; falls through into another block or consists of a skip
+ ; to another block is mapped to another label.
+ ; This mapping is implemented by a hash table.
+ ; Before the backwards traversal, the transitive closure
+ ; is computed. The graph has no cycles, and the maximum
+ ; out-degree is 1, so this is easy.
+
+ (label-table (make-hashtable (lambda (n) n) assv)))
+
+ (define (compute-transitive-closure!)
+ (define (lookup x)
+ (let ((y (hashtable-get label-table x)))
+ (if y
+ (lookup y)
+ x)))
+ (hashtable-for-each (lambda (x y)
+ (hashtable-put! label-table x (lookup y)))
+ label-table))
+
+ ; Don't use this procedure until the preceding procedure
+ ; has been called.
+
+ (define (lookup-label x)
+ (hashtable-fetch label-table x x))
+
+ (define (vector-fill! v x)
+ (subvector-fill! v 0 (vector-length v) x))
+
+ (define (subvector-fill! v i j x)
+ (if (< i j)
+ (begin (vector-set! v i x)
+ (subvector-fill! v (+ i 1) j x))))
+
+ (define (kill-stack! j)
+ (do ((i 0 (+ i 1)))
+ ((= i *nregs*))
+ (let ((x (vector-ref registers i)))
+ (if (and x (= x j))
+ (vector-set! registers i #f)))))
+
+ ; Dispatch procedure for the forwards traversal.
+
+ (define (forwards instructions filtered)
+ (if (null? instructions)
+ (begin (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (compute-transitive-closure!)
+ (backwards0 filtered '()))
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:normal)
+ (forwards instructions (cons instruction filtered)))
+ ((eqv? flags forward:nop)
+ (forwards instructions filtered))
+ ((eqv? flags forward:nop-if-arg1-is-negative)
+ (if (negative? (instruction.arg1 instruction))
+ (forwards instructions filtered)
+ (begin (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))))
+ ((eqv? flags forward:kills-all-registers)
+ (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? flags forward:ends-block)
+ (vector-fill! registers #f)
+ (if (eqv? op $.label)
+ (forwards-label instruction
+ instructions
+ filtered)
+ (forwards instructions
+ (cons instruction filtered))))
+ ((eqv? flags forward:interesting)
+ (cond ((eqv? op $setreg)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $const/setreg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $movereg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $setstk)
+ (kill-stack! (instruction.arg1 instruction))
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $load)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant load.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (vector-set! registers i j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ ((eqv? op $store)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant store.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (kill-stack! j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ (else
+ (local-optimization-error op))))
+ (else
+ (local-optimization-error op))))))
+
+ ; Enters labels into a table for branch tensioning.
+
+ (define (forwards-label instruction1 instructions filtered)
+ (let ((label1 (instruction.arg1 instruction1)))
+ (if (null? instructions)
+ ; This is ok provided the label is unreachable.
+ (forwards instructions (cdr filtered))
+ (let loop ((instructions instructions)
+ (filtered (cons instruction1 filtered)))
+ (let* ((instruction (car instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:nop)
+ (loop (cdr instructions) filtered))
+ ((and (eqv? flags forward:nop-if-arg1-is-negative)
+ (negative? (instruction.arg1 instruction)))
+ (loop (cdr instructions) filtered))
+ ((eqv? op $.label)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ (forwards-label instruction
+ (cdr instructions)
+ (cdr filtered))))
+ ((eqv? op $skip)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ ; We can't get rid of the skip instruction
+ ; because control might fall into this block,
+ ; but we can get rid of the label.
+ (forwards instructions (cdr filtered))))
+ (else
+ (forwards instructions filtered))))))))
+
+ ; Dispatch procedure for the backwards traversal.
+
+ (define (backwards instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref backward-table op)))
+ (cond ((eqv? flags backward:normal)
+ (backwards instructions (cons instruction filtered)))
+ ((eqv? flags backward:ends-block)
+ (backwards0 (cons instruction instructions)
+ filtered))
+ ((eqv? flags backward:begins-block)
+ (backwards0 instructions
+ (cons instruction filtered)))
+ ((eqv? flags backward:uses-many)
+ (cond ((or (eqv? op $lambda)
+ (eqv? op $lexes))
+ (let ((live
+ (if (eqv? op $lexes)
+ (instruction.arg1 instruction)
+ (instruction.arg2 instruction))))
+ (subvector-fill! registers
+ 0
+ (min *nregs* (+ 1 live))
+ #t)
+ (backwards instructions
+ (cons instruction filtered))))
+ ((eqv? op $args>=)
+ (vector-fill! registers #t)
+ (backwards instructions
+ (cons instruction filtered)))
+ (else
+ (local-optimization-error op))))
+ ((and (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (not (vector-ref registers
+ (instruction.arg1 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (not (vector-ref registers
+ (instruction.arg2 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? op $movereg)
+ (= (instruction.arg1 instruction)
+ (instruction.arg2 instruction)))
+ (backwards instructions filtered))
+ (else
+ (let ((filtered (cons instruction filtered)))
+ (if (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f))
+ (if (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f))
+ (if (eqv? (logand flags backward:uses-arg1)
+ backward:uses-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg2)
+ backward:uses-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg3)
+ backward:uses-arg3)
+ (vector-set! registers
+ (instruction.arg3 instruction)
+ #t))
+ (backwards instructions filtered)))))))
+
+ ; Given a list of instructions in reverse order, whose first
+ ; element is the last instruction of a basic block,
+ ; and a filtered list of instructions in forward order,
+ ; returns a filtered list of instructions in the correct order.
+
+ (define (backwards0 instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (mnemonic (instruction.op instruction)))
+ (cond ((or (eqv? mnemonic $.label)
+ (eqv? mnemonic $.proc)
+ (eqv? mnemonic $.cont)
+ (eqv? mnemonic $.align))
+ (backwards0 (cdr instructions)
+ (cons instruction filtered)))
+ ; all registers are dead at a $return
+ ((eqv? mnemonic $return)
+ (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (backwards (cdr instructions)
+ (cons instruction filtered)))
+ ; all but the argument registers are dead at an $invoke
+ ((eqv? mnemonic $invoke)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg1 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the compiler says which registers are live at the
+ ; target of $skip, $branch, $branchf, or $jump
+ ((or (eqv? mnemonic $skip)
+ (eqv? mnemonic $branch))
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ ((eqv? mnemonic $jump)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg3 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the live registers at the target of a $branchf must be
+ ; combined with the live registers at the $branchf
+ ((eqv? mnemonic $branchf)
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ (else (backwards instructions filtered))))))
+
+ (define (suppress-forwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (forwards instructions filtered))
+
+ (define (suppress-backwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (backwards instructions filtered))
+
+ (define (local-optimization-error op)
+ (error "Compiler bug: local optimization" op))
+
+ (vector-fill! registers #f)
+ (forwards instructions '())))))
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 28 April 1999
+;
+; compile313 -- compilation parameters and driver procedures.
+
+
+; File types -- these may differ between operating systems.
+
+(define *scheme-file-types* '(".sch" ".scm"))
+(define *lap-file-type* ".lap")
+(define *mal-file-type* ".mal")
+(define *lop-file-type* ".lop")
+(define *fasl-file-type* ".fasl")
+
+; Compile and assemble a scheme source file and produce a fastload file.
+
+(define (compile-file infilename . rest)
+
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *fasl-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (and (not (integrate-usual-procedures))
+ (issue-warnings))
+ (begin
+ (display "WARNING from compiler: ")
+ (display "integrate-usual-procedures is turned off")
+ (newline)
+ (display "Performance is likely to be poor.")
+ (newline)))
+ (if (benchmark-block-mode)
+ (process-file-block infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (forms)
+ (assemble (compile-block forms) user)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (expr)
+ (assemble (compile expr) user))))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Compile-file not supported on this target architecture.")
+ (doit)))
+
+
+; Assemble a MAL or LOP file and produce a FASL file.
+
+(define (assemble-file infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ (list *lap-file-type* *mal-file-type*)
+ *fasl-file-type*)))
+ (malfile?
+ (file-type=? infilename *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Assemble-file not supported on this target architecture.")
+ (doit)))
+
+
+; Compile and assemble a single expression; return the LOP segment.
+
+(define compile-expression
+ (let ()
+
+ (define (compile-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (assemble (compile expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ compile-expression))
+
+
+(define macro-expand-expression
+ (let ()
+
+ (define (macro-expand-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (make-readable
+ (macro-expand expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ macro-expand-expression))
+
+
+; Compile a scheme source file to a LAP file.
+
+(define (compile313 infilename . rest)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *lap-file-type*)))
+ (write-lap
+ (lambda (item port)
+ (write item port)
+ (newline port)
+ (newline port))))
+ (if (benchmark-block-mode)
+ (process-file-block infilename outfilename write-lap compile-block)
+ (process-file infilename outfilename write-lap compile))
+ (unspecified)))
+
+
+; Assemble a LAP or MAL file to a LOP file.
+
+(define (assemble313 file . rest)
+ (let ((outputfile
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type file
+ (list *lap-file-type* *mal-file-type*)
+ *lop-file-type*)))
+ (malfile?
+ (file-type=? file *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file file
+ outputfile
+ write-lop
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+
+; Compile and assemble a Scheme source file to a LOP file.
+
+(define (compile-and-assemble313 input-file . rest)
+ (let ((output-file
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type input-file
+ *scheme-file-types*
+ *lop-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (benchmark-block-mode)
+ (process-file-block input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile-block x) user)))
+ (process-file input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile x) user))))
+ (unspecified)))
+
+
+; Convert a LOP file to a FASL file.
+
+(define (make-fasl infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *lop-file-type*
+ *fasl-file-type*))))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) x))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Make-fasl not supported on this target architecture.")
+ (doit)))
+
+
+; Disassemble a procedure's code vector.
+
+(define (disassemble item . rest)
+ (let ((output-port (if (null? rest)
+ (current-output-port)
+ (car rest))))
+ (disassemble-item item #f output-port)
+ (unspecified)))
+
+
+; The item can be either a procedure or a pair (assumed to be a segment).
+
+(define (disassemble-item item segment-no port)
+
+ (define (print . rest)
+ (for-each (lambda (x) (display x port)) rest)
+ (newline port))
+
+ (define (print-constvector cv)
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length cv)))
+ (print "------------------------------------------")
+ (print "Constant vector element # " i)
+ (case (car (vector-ref cv i))
+ ((codevector)
+ (print "Code vector")
+ (print-instructions (disassemble-codevector
+ (cadr (vector-ref cv i)))
+ port))
+ ((constantvector)
+ (print "Constant vector")
+ (print-constvector (cadr (vector-ref cv i))))
+ ((global)
+ (print "Global: " (cadr (vector-ref cv i))))
+ ((data)
+ (print "Data: " (cadr (vector-ref cv i)))))))
+
+ (define (print-segment segment)
+ (print "Segment # " segment-no)
+ (print-instructions (disassemble-codevector (car segment)) port)
+ (print-constvector (cdr segment))
+ (print "========================================"))
+
+ (cond ((procedure? item)
+ (print-instructions (disassemble-codevector (procedure-ref item 0))
+ port))
+ ((and (pair? item)
+ (bytevector? (car item))
+ (vector? (cdr item)))
+ (print-segment item))
+ (else
+ (error "disassemble-item: " item " is not disassemblable."))))
+
+
+; Disassemble a ".lop" or ".fasl" file; dump output to screen or
+; other (optional) file.
+
+(define (disassemble-file file . rest)
+
+ (define (doit input-port output-port)
+ (display "; From " output-port)
+ (display file output-port)
+ (newline output-port)
+ (do ((segment-no 0 (+ segment-no 1))
+ (segment (read input-port) (read input-port)))
+ ((eof-object? segment))
+ (disassemble-item segment segment-no output-port)))
+
+ ; disassemble313
+
+ (call-with-input-file
+ file
+ (lambda (input-port)
+ (if (null? rest)
+ (doit input-port (current-output-port))
+ (begin
+ (delete-file (car rest))
+ (call-with-output-file
+ (car rest)
+ (lambda (output-port) (doit input-port output-port)))))))
+ (unspecified))
+
+
+; Display and manipulate the compiler switches.
+
+(define (compiler-switches . rest)
+
+ (define (slow-code)
+ (set-compiler-flags! 'no-optimization)
+ (set-assembler-flags! 'no-optimization))
+
+ (define (standard-code)
+ (set-compiler-flags! 'standard)
+ (set-assembler-flags! 'standard))
+
+ (define (fast-safe-code)
+ (set-compiler-flags! 'fast-safe)
+ (set-assembler-flags! 'fast-safe))
+
+ (define (fast-unsafe-code)
+ (set-compiler-flags! 'fast-unsafe)
+ (set-assembler-flags! 'fast-unsafe))
+
+ (cond ((null? rest)
+ (display "Debugging:")
+ (newline)
+ (display-twobit-flags 'debugging)
+ (display-assembler-flags 'debugging)
+ (newline)
+ (display "Safety:")
+ (newline)
+ (display-twobit-flags 'safety)
+ (display-assembler-flags 'safety)
+ (newline)
+ (display "Speed:")
+ (newline)
+ (display-twobit-flags 'optimization)
+ (display-assembler-flags 'optimization)
+ (if #f #f))
+ ((null? (cdr rest))
+ (case (car rest)
+ ((0 slow) (slow-code))
+ ((1 standard) (standard-code))
+ ((2 fast-safe) (fast-safe-code))
+ ((3 fast-unsafe) (fast-unsafe-code))
+ ((default
+ factory-settings) (fast-safe-code)
+ (include-source-code #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f))
+ (else
+ (error "Unrecognized flag " (car rest) " to compiler-switches.")))
+ (unspecified))
+ (else
+ (error "Too many arguments to compiler-switches."))))
+
+; Read and process one file, producing another.
+; Preserves the global syntactic environment.
+
+(define (process-file infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (let loop ((x (read inport)))
+ (if (eof-object? x)
+ #t
+ (begin (writer (processer x) outport)
+ (loop (read inport))))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+; Same as above, but passes a list of the entire file's contents
+; to the processer.
+; FIXME: Both versions of PROCESS-FILE always delete the output file.
+; Shouldn't it be left alone if the input file can't be opened?
+
+(define (process-file-block infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (do ((x (read inport) (read inport))
+ (forms '() (cons x forms)))
+ ((eof-object? x)
+ (writer (processer (reverse forms)) outport))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+
+; Given a file name with some type, produce another with some other type.
+
+(define (rewrite-file-type filename matches new)
+ (if (not (pair? matches))
+ (rewrite-file-type filename (list matches) new)
+ (let ((j (string-length filename)))
+ (let loop ((m matches))
+ (cond ((null? m)
+ (string-append filename new))
+ (else
+ (let* ((n (car m))
+ (l (string-length n)))
+ (if (file-type=? filename n)
+ (string-append (substring filename 0 (- j l)) new)
+ (loop (cdr m))))))))))
+
+(define (file-type=? file-name type-name)
+ (let ((fl (string-length file-name))
+ (tl (string-length type-name)))
+ (and (>= fl tl)
+ (string-ci=? type-name
+ (substring file-name (- fl tl) fl)))))
+
+; eof
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Procedures that make .LAP structures human-readable
+
+(define (readify-lap code)
+ (map (lambda (x)
+ (let ((iname (cdr (assv (car x) *mnemonic-names*))))
+ (if (not (= (car x) $lambda))
+ (cons iname (cdr x))
+ (list iname (readify-lap (cadr x)) (caddr x)))))
+ code))
+
+(define (readify-file f . o)
+
+ (define (doit)
+ (let ((i (open-input-file f)))
+ (let loop ((x (read i)))
+ (if (not (eof-object? x))
+ (begin (pretty-print (readify-lap x))
+ (loop (read i)))))))
+
+ (if (null? o)
+ (doit)
+ (begin (delete-file (car o))
+ (with-output-to-file (car o) doit))))
+
+; eof
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Target-independent part of the assembler.
+;
+; This is a simple, table-driven, one-pass assembler.
+; Part of it assumes a big-endian target machine.
+;
+; The input to this pass is a list of symbolic MacScheme machine
+; instructions and pseudo-instructions. Each symbolic MacScheme
+; machine instruction or pseudo-instruction is a list whose car
+; is a small non-negative fixnum that acts as the mnemonic for the
+; instruction. The rest of the list is interpreted as indicated
+; by the mnemonic.
+;
+; The output is a pair consisting of machine code (a bytevector or
+; string) and a constant vector.
+;
+; This assembler is table-driven, and may be customized to emit
+; machine code for different target machines. The table consists
+; of a vector of procedures indexed by mnemonics. Each procedure
+; in the table should take two arguments: an assembly structure
+; and a source instruction. The procedure should just assemble
+; the instruction using the operations defined below.
+;
+; The table and target can be changed by redefining the following
+; five procedures.
+
+(define (assembly-table) (error "No assembly table defined."))
+(define (assembly-start as) #t)
+(define (assembly-end as segment) segment)
+(define (assembly-user-data) #f)
+
+; The main entry point.
+
+(define (assemble source . rest)
+ (let* ((user (if (null? rest) (assembly-user-data) (car rest)))
+ (as (make-assembly-structure source (assembly-table) user)))
+ (assembly-start as)
+ (assemble1 as
+ (lambda (as)
+ (let ((segment (assemble-pasteup as)))
+ (assemble-finalize! as)
+ (assembly-end as segment)))
+ #f)))
+
+; The following procedures are to be called by table routines.
+;
+; The assembly source for nested lambda expressions should be
+; assembled by calling this procedure. This allows an inner
+; lambda to refer to labels defined by outer lambdas.
+;
+; We delay the assembly of the nested lambda until after the outer lambda
+; has been finalized so that all labels in the outer lambda are known
+; to the inner lambda.
+;
+; The continuation procedure k is called to backpatch the constant
+; vector of the outer lambda after the inner lambda has been
+; finalized. This is necessary because of the delayed evaluation: the
+; outer lambda holds code and constants for the inner lambda in its
+; constant vector.
+
+(define (assemble-nested-lambda as source doc k . rest)
+ (let* ((user (if (null? rest) #f (car rest)))
+ (nested-as (make-assembly-structure source (as-table as) user)))
+ (as-parent! nested-as as)
+ (as-nested! as (cons (lambda ()
+ (assemble1 nested-as
+ (lambda (nested-as)
+ (let ((segment
+ (assemble-pasteup nested-as)))
+ (assemble-finalize! nested-as)
+ (k nested-as segment)))
+ doc))
+ (as-nested as)))))
+
+(define operand0 car) ; the mnemonic
+(define operand1 cadr)
+(define operand2 caddr)
+(define operand3 cadddr)
+(define (operand4 i) (car (cddddr i)))
+
+; Emits the bits contained in the bytevector bv.
+
+(define (emit! as bv)
+ (as-code! as (cons bv (as-code as)))
+ (as-lc! as (+ (as-lc as) (bytevector-length bv))))
+
+; Emits the characters contained in the string s as code (for C generation).
+
+(define (emit-string! as s)
+ (as-code! as (cons s (as-code as)))
+ (as-lc! as (+ (as-lc as) (string-length s))))
+
+; Given any Scheme object that may legally be quoted, returns an
+; index into the constant vector for that constant.
+
+(define (emit-constant as x)
+ (do ((i 0 (+ i 1))
+ (y (as-constants as) (cdr y)))
+ ((or (null? y) (equal? x (car y)))
+ (if (null? y)
+ (as-constants! as (append! (as-constants as) (list x))))
+ i)))
+
+(define (emit-datum as x)
+ (emit-constant as (list 'data x)))
+
+(define (emit-global as x)
+ (emit-constant as (list 'global x)))
+
+(define (emit-codevector as x)
+ (emit-constants as (list 'codevector x)))
+
+(define (emit-constantvector as x)
+ (emit-constants as (list 'constantvector x)))
+
+; Set-constant changes the datum stored, without affecting the tag.
+; It can operate on the list form because the pair stored in the list
+; is shared between the list and any vector created from the list.
+
+(define (set-constant! as n datum)
+ (let ((pair (list-ref (as-constants as) n)))
+ (set-car! (cdr pair) datum)))
+
+; Guarantees that the constants will not share structure
+; with any others, and will occupy consecutive positions
+; in the constant vector. Returns the index of the first
+; constant.
+
+(define (emit-constants as x . rest)
+ (let* ((constants (as-constants as))
+ (i (length constants)))
+ (as-constants! as (append! constants (cons x rest)))
+ i))
+
+; Defines the given label using the current location counter.
+
+(define (emit-label! as L)
+ (set-cdr! L (as-lc as)))
+
+; Adds the integer n to the size code bytes beginning at the
+; given byte offset from the current value of the location counter.
+
+(define (emit-fixup! as offset size n)
+ (as-fixups! as (cons (list (+ offset (as-lc as)) size n)
+ (as-fixups as))))
+
+; Adds the value of the label L to the size code bytes beginning
+; at the given byte offset from the current location counter.
+
+(define (emit-fixup-label! as offset size L)
+ (as-fixups! as (cons (list (+ offset (as-lc as)) size (list L))
+ (as-fixups as))))
+
+; Allows the procedure proc of two arguments (code vector and current
+; location counter) to modify the code vector at will, at fixup time.
+
+(define (emit-fixup-proc! as proc)
+ (as-fixups! as (cons (list (as-lc as) 0 proc)
+ (as-fixups as))))
+
+; Labels.
+
+; The current value of the location counter.
+
+(define (here as) (as-lc as))
+
+; Given a MAL label (a number), create an assembler label.
+
+(define (make-asm-label as label)
+ (let ((probe (find-label as label)))
+ (if probe
+ probe
+ (let ((l (cons label #f)))
+ (as-labels! as (cons l (as-labels as)))
+ l))))
+
+; This can use hashed lookup.
+
+(define (find-label as L)
+
+ (define (lookup-label-loop x labels parent)
+ (let ((entry (assq x labels)))
+ (cond (entry)
+ ((not parent) #f)
+ (else
+ (lookup-label-loop x (as-labels parent) (as-parent parent))))))
+
+ (lookup-label-loop L (as-labels as) (as-parent as)))
+
+; Create a new assembler label, distinguishable from a MAL label.
+
+(define new-label
+ (let ((n 0))
+ (lambda ()
+ (set! n (- n 1))
+ (cons n #f))))
+
+; Given a value name (a number), return the label value or #f.
+
+(define (label-value as L) (cdr L))
+
+; For peephole optimization.
+
+(define (next-instruction as)
+ (let ((source (as-source as)))
+ (if (null? source)
+ '(-1)
+ (car source))))
+
+(define (consume-next-instruction! as)
+ (as-source! as (cdr (as-source as))))
+
+(define (push-instruction as instruction)
+ (as-source! as (cons instruction (as-source as))))
+
+; For use by the machine assembler: assoc lists connected to as structure.
+
+(define (assembler-value as key)
+ (let ((probe (assq key (as-values as))))
+ (if probe
+ (cdr probe)
+ #f)))
+
+(define (assembler-value! as key value)
+ (let ((probe (assq key (as-values as))))
+ (if probe
+ (set-cdr! probe value)
+ (as-values! as (cons (cons key value) (as-values as))))))
+
+; For documentation.
+;
+; The value must be a documentation structure (a vector).
+
+(define (add-documentation as doc)
+ (let* ((existing-constants (cadr (car (as-constants as))))
+ (new-constants
+ (twobit-sort (lambda (a b)
+ (< (car a) (car b)))
+ (cond ((not existing-constants)
+ (list (cons (here as) doc)))
+ ((pair? existing-constants)
+ (cons (cons (here as) doc)
+ existing-constants))
+ (else
+ (list (cons (here as) doc)
+ (cons 0 existing-constants)))))))
+ (set-car! (cdar (as-constants as)) new-constants)))
+
+; This is called when a value is too large to be handled by the assembler.
+; Info is a string, expr an assembler expression, and val the resulting
+; value. The default behavior is to signal an error.
+
+(define (asm-value-too-large as info expr val)
+ (if (as-retry as)
+ ((as-retry as))
+ (asm-error info ": Value too large: " expr " = " val)))
+
+; The implementations of asm-error and disasm-error depend on the host
+; system. Sigh.
+
+(define (asm-error msg . rest)
+ (cond ((eq? host-system 'chez)
+ (error 'assembler "~a" (list msg rest)))
+ (else
+ (apply error msg rest))))
+
+(define (disasm-error msg . rest)
+ (cond ((eq? host-system 'chez)
+ (error 'disassembler "~a" (list msg rest)))
+ (else
+ (apply error msg rest))))
+
+\f; The remaining procedures in this file are local to the assembler.
+
+; An assembly structure is a vector consisting of
+;
+; table (a table of assembly routines)
+; source (a list of symbolic instructions)
+; lc (location counter; an integer)
+; code (a list of bytevectors)
+; constants (a list)
+; labels (an alist of labels and values)
+; fixups (an alist of locations, sizes, and labels or fixnums)
+; nested (a list of assembly procedures for nested lambdas)
+; values (an assoc list)
+; parent (an assembly structure or #f)
+; retry (a thunk or #f)
+; user-data (anything)
+;
+; In fixups, labels are of the form (<L>) to distinguish them from fixnums.
+
+(define (label? x) (and (pair? x) (fixnum? (car x))))
+(define label.ident car)
+
+(define (make-assembly-structure source table user-data)
+ (vector table
+ source
+ 0
+ '()
+ '()
+ '()
+ '()
+ '()
+ '()
+ #f
+ #f
+ user-data))
+
+(define (as-reset! as source)
+ (as-source! as source)
+ (as-lc! as 0)
+ (as-code! as '())
+ (as-constants! as '())
+ (as-labels! as '())
+ (as-fixups! as '())
+ (as-nested! as '())
+ (as-values! as '())
+ (as-retry! as #f))
+
+(define (as-table as) (vector-ref as 0))
+(define (as-source as) (vector-ref as 1))
+(define (as-lc as) (vector-ref as 2))
+(define (as-code as) (vector-ref as 3))
+(define (as-constants as) (vector-ref as 4))
+(define (as-labels as) (vector-ref as 5))
+(define (as-fixups as) (vector-ref as 6))
+(define (as-nested as) (vector-ref as 7))
+(define (as-values as) (vector-ref as 8))
+(define (as-parent as) (vector-ref as 9))
+(define (as-retry as) (vector-ref as 10))
+(define (as-user as) (vector-ref as 11))
+
+(define (as-source! as x) (vector-set! as 1 x))
+(define (as-lc! as x) (vector-set! as 2 x))
+(define (as-code! as x) (vector-set! as 3 x))
+(define (as-constants! as x) (vector-set! as 4 x))
+(define (as-labels! as x) (vector-set! as 5 x))
+(define (as-fixups! as x) (vector-set! as 6 x))
+(define (as-nested! as x) (vector-set! as 7 x))
+(define (as-values! as x) (vector-set! as 8 x))
+(define (as-parent! as x) (vector-set! as 9 x))
+(define (as-retry! as x) (vector-set! as 10 x))
+(define (as-user! as x) (vector-set! as 11 x))
+
+; The guts of the assembler.
+
+(define (assemble1 as finalize doc)
+ (let ((assembly-table (as-table as))
+ (peep? (peephole-optimization))
+ (step? (single-stepping))
+ (step-instr (list $.singlestep))
+ (end-instr (list $.end)))
+
+ (define (loop)
+ (let ((source (as-source as)))
+ (if (null? source)
+ (begin ((vector-ref assembly-table $.end) end-instr as)
+ (finalize as))
+ (begin (if step?
+ ((vector-ref assembly-table $.singlestep)
+ step-instr
+ as))
+ (if peep?
+ (let peeploop ((src1 source))
+ (peep as)
+ (let ((src2 (as-source as)))
+ (if (not (eq? src1 src2))
+ (peeploop src2)))))
+ (let ((source (as-source as)))
+ (as-source! as (cdr source))
+ ((vector-ref assembly-table (caar source))
+ (car source)
+ as)
+ (loop))))))
+
+ (define (doit)
+ (emit-datum as doc)
+ (loop))
+
+ (let* ((source (as-source as))
+ (r (call-with-current-continuation
+ (lambda (k)
+ (as-retry! as (lambda () (k 'retry)))
+ (doit)))))
+ (if (eq? r 'retry)
+ (let ((old (short-effective-addresses)))
+ (as-reset! as source)
+ (dynamic-wind
+ (lambda ()
+ (short-effective-addresses #f))
+ doit
+ (lambda ()
+ (short-effective-addresses old))))
+ r))))
+
+(define (assemble-pasteup as)
+
+ (define (pasteup-code)
+ (let ((code (make-bytevector (as-lc as)))
+ (constants (list->vector (as-constants as))))
+
+ ; The bytevectors: byte 0 is most significant.
+
+ (define (paste-code! bvs i)
+ (if (not (null? bvs))
+ (let* ((bv (car bvs))
+ (n (bytevector-length bv)))
+ (do ((i i (- i 1))
+ (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
+ ((< j 0) ; (= j n)
+ (paste-code! (cdr bvs) i))
+ (bytevector-set! code i (bytevector-ref bv j))))))
+
+ (paste-code! (as-code as) (- (as-lc as) 1))
+ (as-code! as (list code))
+ (cons code constants)))
+
+ (define (pasteup-strings)
+ (let ((code (make-string (as-lc as)))
+ (constants (list->vector (as-constants as))))
+
+ (define (paste-code! strs i)
+ (if (not (null? strs))
+ (let* ((s (car strs))
+ (n (string-length s)))
+ (do ((i i (- i 1))
+ (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
+ ((< j 0) ; (= j n)
+ (paste-code! (cdr strs) i))
+ (string-set! code i (string-ref s j))))))
+
+ (paste-code! (as-code as) (- (as-lc as) 1))
+ (as-code! as (list code))
+ (cons code constants)))
+
+ (if (bytevector? (car (as-code as)))
+ (pasteup-code)
+ (pasteup-strings)))
+
+(define (assemble-finalize! as)
+ (let ((code (car (as-code as))))
+
+ (define (apply-fixups! fixups)
+ (if (not (null? fixups))
+ (let* ((fixup (car fixups))
+ (i (car fixup))
+ (size (cadr fixup))
+ (adjustment (caddr fixup)) ; may be procedure
+ (n (if (label? adjustment)
+ (lookup-label adjustment)
+ adjustment)))
+ (case size
+ ((0) (fixup-proc code i n))
+ ((1) (fixup1 code i n))
+ ((2) (fixup2 code i n))
+ ((3) (fixup3 code i n))
+ ((4) (fixup4 code i n))
+ (else ???))
+ (apply-fixups! (cdr fixups)))))
+
+ (define (lookup-label L)
+ (or (label-value as (label.ident L))
+ (asm-error "Assembler error -- undefined label " L)))
+
+ (apply-fixups! (reverse! (as-fixups as)))
+
+ (for-each (lambda (nested-as-proc)
+ (nested-as-proc))
+ (as-nested as))))
+
+
+; These fixup routines assume a big-endian target machine.
+
+(define (fixup1 code i n)
+ (bytevector-set! code i (+ n (bytevector-ref code i))))
+
+(define (fixup2 code i n)
+ (let* ((x (+ (* 256 (bytevector-ref code i))
+ (bytevector-ref code (+ i 1))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256)))
+ (bytevector-set! code i y1)
+ (bytevector-set! code (+ i 1) y0)))
+
+(define (fixup3 code i n)
+ (let* ((x (+ (* 65536 (bytevector-ref code i))
+ (* 256 (bytevector-ref code (+ i 1)))
+ (bytevector-ref code (+ i 2))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256))
+ (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256)))
+ (bytevector-set! code i y2)
+ (bytevector-set! code (+ i 1) y1)
+ (bytevector-set! code (+ i 2) y0)))
+
+(define (fixup4 code i n)
+ (let* ((x (+ (* 16777216 (bytevector-ref code i))
+ (* 65536 (bytevector-ref code (+ i 1)))
+ (* 256 (bytevector-ref code (+ i 2)))
+ (bytevector-ref code (+ i 3))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256))
+ (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256))
+ (y3 (modulo (quotient (- y (* 65536 y2)
+ (* 256 y1)
+ y0)
+ 256)
+ 256)))
+ (bytevector-set! code i y3)
+ (bytevector-set! code (+ i 1) y2)
+ (bytevector-set! code (+ i 2) y1)
+ (bytevector-set! code (+ i 3) y0)))
+
+(define (fixup-proc code i p)
+ (p code i))
+
+\f; For testing.
+
+(define (view-segment segment)
+ (define (display-bytevector bv)
+ (let ((n (bytevector-length bv)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (if (zero? (remainder i 4))
+ (write-char #\space))
+ (if (zero? (remainder i 8))
+ (write-char #\space))
+ (if (zero? (remainder i 32))
+ (newline))
+ (let ((byte (bytevector-ref bv i)))
+ (write-char
+ (string-ref (number->string (quotient byte 16) 16) 0))
+ (write-char
+ (string-ref (number->string (remainder byte 16) 16) 0))))))
+ (if (and (pair? segment)
+ (bytevector? (car segment))
+ (vector? (cdr segment)))
+ (begin (display-bytevector (car segment))
+ (newline)
+ (write (cdr segment))
+ (newline)
+ (do ((constants (vector->list (cdr segment))
+ (cdr constants)))
+ ((or (null? constants)
+ (null? (cdr constants))))
+ (if (and (bytevector? (car constants))
+ (vector? (cadr constants)))
+ (view-segment (cons (car constants)
+ (cadr constants))))))))
+
+; emit is a procedure that takes an as and emits instructions into it.
+
+(define (test-asm emit)
+ (let ((as (make-assembly-structure #f #f #f)))
+ (emit as)
+ (let ((segment (assemble-pasteup as)))
+ (assemble-finalize! as)
+ (disassemble segment))))
+
+(define (compile&assemble x)
+ (view-segment (assemble (compile x))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Common assembler -- miscellaneous utility procedures.
+
+; Given any Scheme object, return its printable representation as a string.
+; This code is largely portable (see comments).
+
+(define (format-object x)
+
+ (define (format-list x)
+ (define (loop x)
+ (cond ((null? x)
+ '(")"))
+ ((null? (cdr x))
+ (list (format-object (car x)) ")"))
+ (else
+ (cons (format-object (car x))
+ (cons " "
+ (loop (cdr x)))))))
+ (apply string-append (cons "(" (loop x))))
+
+ (define (format-improper-list x)
+ (define (loop x)
+ (if (pair? (cdr x))
+ (cons (format-object (car x))
+ (cons " "
+ (loop (cdr x))))
+ (list (format-object (car x))
+ " . "
+ (format-object (cdr x))
+ ")")))
+ (apply string-append (cons "(" (loop x))))
+
+ (cond ((null? x) "()")
+ ((not x) "#f")
+ ((eq? x #t) "#t")
+ ((symbol? x) (symbol->string x))
+ ((number? x) (number->string x))
+ ((char? x) (string x))
+ ((string? x) x)
+ ((procedure? x) "#<procedure>")
+ ((bytevector? x) "#<bytevector>") ; Larceny
+ ((eof-object? x) "#<eof>")
+ ((port? x) "#<port>")
+ ((eq? x (unspecified)) "#!unspecified") ; Larceny
+ ((eq? x (undefined)) "#!undefined") ; Larceny
+ ((vector? x)
+ (string-append "#" (format-list (vector->list x))))
+ ((list? x)
+ (format-list x))
+ ((pair? x)
+ (format-improper-list x))
+ (else "#<weird>")))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny assembler -- 32-bit big-endian utility procedures.
+;
+; 32-bit numbers are represented as 4-byte bytevectors where byte 3
+; is the least significant and byte 0 is the most significant.
+;
+; Logically, the 'big' end is on the left and the 'little' end
+; is on the right, so a left shift shifts towards the 'big' end.
+;
+; Performance: poor, for good reasons. See asmutil32.sch.
+
+; Identifies the code loaded.
+
+(define asm:endianness 'big)
+
+
+; Given four bytes, create a length-4 bytevector.
+; N1 is the most significant byte, n4 the least significant.
+
+(define (asm:bv n1 n2 n3 n4)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-set! bv 0 n1)
+ (bytevector-set! bv 1 n2)
+ (bytevector-set! bv 2 n3)
+ (bytevector-set! bv 3 n4)
+ bv))
+
+
+; Given a length-4 bytevector, convert it to an integer.
+
+(define (asm:bv->int bv)
+ (let ((i (+ (* (+ (* (+ (* (bytevector-ref bv 0) 256)
+ (bytevector-ref bv 1))
+ 256)
+ (bytevector-ref bv 2))
+ 256)
+ (bytevector-ref bv 3))))
+ (if (> (bytevector-ref bv 0) 127)
+ (- i)
+ i)))
+
+
+; Shift the bits of m left by n bits, shifting in zeroes at the right end.
+; Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define (asm:lsh m n)
+ (if (not (bytevector? m))
+ (asm:lsh (asm:int->bv m) n)
+ (let ((m (bytevector-copy m))
+ (n (remainder n 33)))
+ (if (>= n 8)
+ (let ((k (quotient n 8)))
+ (do ((i 0 (+ i 1)))
+ ((= (+ i k) 4)
+ (do ((i i (+ i 1)))
+ ((= i 4))
+ (bytevector-set! m i 0)))
+ (bytevector-set! m i (bytevector-ref m (+ i k))))))
+ (let* ((d0 (bytevector-ref m 0))
+ (d1 (bytevector-ref m 1))
+ (d2 (bytevector-ref m 2))
+ (d3 (bytevector-ref m 3))
+ (n (remainder n 8))
+ (n- (- 8 n)))
+ (asm:bv (logand (logior (lsh d0 n) (rshl d1 n-)) 255)
+ (logand (logior (lsh d1 n) (rshl d2 n-)) 255)
+ (logand (logior (lsh d2 n) (rshl d3 n-)) 255)
+ (logand (lsh d3 n) 255))))))
+
+
+; Shift the bits of m right by n bits, shifting in zeroes at the high end.
+; Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define (asm:rshl m n)
+ (if (not (bytevector? m))
+ (asm:rshl (asm:int->bv m) n)
+ (let ((m (bytevector-copy m))
+ (n (remainder n 33)))
+ (if (>= n 8)
+ (let ((k (quotient n 8)))
+ (do ((i 3 (- i 1)))
+ ((< (- i k) 0)
+ (do ((i i (- i 1)))
+ ((< i 0))
+ (bytevector-set! m i 0)))
+ (bytevector-set! m i (bytevector-ref m (- i k))))))
+ (let* ((d0 (bytevector-ref m 0))
+ (d1 (bytevector-ref m 1))
+ (d2 (bytevector-ref m 2))
+ (d3 (bytevector-ref m 3))
+ (n (remainder n 8))
+ (n- (- 8 n)))
+ (asm:bv (rshl d0 n)
+ (logand (logior (rshl d1 n) (lsh d0 n-)) 255)
+ (logand (logior (rshl d2 n) (lsh d1 n-)) 255)
+ (logand (logior (rshl d3 n) (lsh d2 n-)) 255))))))
+
+
+; Shift the bits of m right by n bits, shifting in the sign bit at the
+; high end. Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define asm:rsha
+ (let ((ones (asm:bv #xff #xff #xff #xff)))
+ (lambda (m n)
+ (let* ((m (if (bytevector? m) m (asm:int->bv m)))
+ (n (remainder n 33))
+ (h (rshl (bytevector-ref m 0) 7))
+ (k (asm:rshl m n)))
+; (format #t "~a ~a ~a~%" h (bytevector-ref m 0) n)
+; (prnx (asm:lsh ones (- 32 n))) (newline)
+ (if (zero? h)
+ k
+ (asm:logior k (asm:lsh ones (- 32 n))))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny assembler -- 32-bit endianness-independent utility procedures.
+;
+; 32-bit numbers are represented as 4-byte bytevectors where the
+; exact layout depends on whether the little-endian or big-endian
+; module has been loaded. One of them must be loaded prior to loading
+; this module.
+;
+; Logically, the 'big' end is on the left and the 'little' end
+; is on the right, so a left shift shifts towards the big end.
+;
+; Generally, performance is not a major issue in this module. The
+; assemblers should use more specialized code for truly good performance.
+; These procedures are mainly suitable for one-time construction of
+; instruction templates, and during development.
+;
+; Endian-ness specific operations are in asmutil32be.sch and asmutil32le.sch:
+;
+; (asm:bv n0 n1 n2 n3) ; Construct bytevector
+; (asm:bv->int bv) ; Convert bytevector to integer
+; (asm:lsh m k) ; Shift left logical k bits
+; (asm:rshl m k) ; Shift right logical k bits
+; (asm:rsha m k) ; Shirt right arithmetic k bits
+
+
+; Convert an integer to a length-4 bytevector using two's complement
+; representation for negative numbers.
+; Returns length-4 bytevector.
+;
+; The procedure handles numbers in the range -2^31..2^32-1 [sic].
+; It is an error for the number to be outside this range.
+;
+; FIXME: quotient/remainder may be slow; we could have special fixnum
+; case that uses shifts (that could be in-lined as macro). It could
+; work for negative numbers too.
+; FIXME: should probably check that the number is within range.
+
+(define asm:int->bv
+ (let ((two^32 (expt 2 32)))
+ (lambda (m)
+ (let* ((m (if (< m 0) (+ two^32 m) m))
+ (b0 (remainder m 256))
+ (m (quotient m 256))
+ (b1 (remainder m 256))
+ (m (quotient m 256))
+ (b2 (remainder m 256))
+ (m (quotient m 256))
+ (b3 (remainder m 256)))
+ (asm:bv b3 b2 b1 b0)))))
+
+
+; `Or' the bits of multiple operands together.
+; Each operand may be an exact integer or a length-4 bytevector.
+; Returns a length-4 bytevector.
+
+(define (asm:logior . ops)
+ (let ((r (asm:bv 0 0 0 0)))
+ (do ((ops ops (cdr ops)))
+ ((null? ops) r)
+ (let* ((op (car ops))
+ (op (if (bytevector? op) op (asm:int->bv op))))
+ (bytevector-set! r 0 (logior (bytevector-ref r 0)
+ (bytevector-ref op 0)))
+ (bytevector-set! r 1 (logior (bytevector-ref r 1)
+ (bytevector-ref op 1)))
+ (bytevector-set! r 2 (logior (bytevector-ref r 2)
+ (bytevector-ref op 2)))
+ (bytevector-set! r 3 (logior (bytevector-ref r 3)
+ (bytevector-ref op 3)))))))
+
+
+; `And' the bits of two operands together.
+; Either may be an exact integer or length-4 bytevector.
+; Returns length-4 bytevector.
+
+(define (asm:logand op1 op2)
+ (let ((op1 (if (bytevector? op1) op1 (asm:int->bv op1)))
+ (op2 (if (bytevector? op2) op2 (asm:int->bv op2)))
+ (bv (make-bytevector 4)))
+ (bytevector-set! bv 0 (logand (bytevector-ref op1 0)
+ (bytevector-ref op2 0)))
+ (bytevector-set! bv 1 (logand (bytevector-ref op1 1)
+ (bytevector-ref op2 1)))
+ (bytevector-set! bv 2 (logand (bytevector-ref op1 2)
+ (bytevector-ref op2 2)))
+ (bytevector-set! bv 3 (logand (bytevector-ref op1 3)
+ (bytevector-ref op2 3)))
+ bv))
+
+
+; Extract the n low-order bits of m.
+; m may be an exact integer or a length-4 bytevector.
+; n must be an exact nonnegative integer, interpreted modulo 32.
+; Returns length-4 bytevector.
+;
+; Does not depend on endian-ness.
+
+(define asm:lobits
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (asm:int->bv (- (expt 2 i) 1))))
+ (lambda (m n)
+ (asm:logand m (vector-ref v (remainder n 33))))))
+
+; Extract the n high-order bits of m.
+; m may be an exact integer or a length-4 bytevector.
+; n must be an exact nonnegative integer, interpreted modulo 33.
+; Returns length-4 bytevector with the high-order bits of m at low end.
+;
+; Does not depend on endian-ness.
+
+(define (asm:hibits m n)
+ (asm:rshl m (- 32 (remainder n 33))))
+
+; Test that the given number (not! bytevector) m fits in an n-bit
+; signed slot.
+;
+; Does not depend on endian-ness.
+
+(define asm:fits?
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (expt 2 i)))
+ (lambda (m n)
+ (<= (- (vector-ref v (- n 1))) m (- (vector-ref v (- n 1)) 1)))))
+
+; Test that the given number (not! bytevector) m fits in an n-bit
+; unsigned slot.
+;
+; Does not depend on endian-ness.
+
+(define asm:fits-unsigned?
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (expt 2 i)))
+ (lambda (m n)
+ (<= 0 m (- (vector-ref v n) 1)))))
+
+; Add two operands (numbers or bytevectors).
+;
+; Does not depend on endian-ness.
+
+(define (asm:add a b)
+ (asm:int->bv (+ (if (bytevector? a) (asm:bv->int a) a)
+ (if (bytevector? b) (asm:bv->int b) b))))
+
+; Given an unsigned 32-bit number, return it as a signed number
+; as appropriate.
+;
+; Does not depend on endian-ness.
+
+(define (asm:signed n)
+ (if (< n 2147483647)
+ n
+ (- n 4294967296)))
+
+
+(define (asm:print-bv bv)
+
+ (define hex "0123456789abcdef")
+
+ (define (pdig k)
+ (display (string-ref hex (quotient k 16)))
+ (display (string-ref hex (remainder k 16)))
+ (display " "))
+
+ (if (eq? asm:endianness 'little)
+ (do ((i 3 (- i 1)))
+ ((< i 0))
+ (pdig (bytevector-ref bv i)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (pdig (bytevector-ref bv i)))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Procedure that writes fastload segment.
+;
+; The procedure 'dump-fasl-segment-to-port' takes a segment and an output
+; port as arguments and dumps the segment in fastload format on that port.
+; The port must be a binary (untranslated) port.
+;
+; A fastload segment looks like a Scheme expression, and in fact,
+; fastload files can mix compiled and uncompiled expressions. A compiled
+; expression (as created by dump-fasl-segment-to-port) is a list with
+; a literal procedure in the operator position and no arguments.
+;
+; A literal procedure is a three-element list prefixed by #^P. The three
+; elements are code (a bytevector), constants (a regular vector), and
+; R0/static link slot (always #f).
+;
+; A bytevector is a string prefixed by #^B. The string may contain
+; control characters; \ and " must be quoted as usual.
+;
+; A global variable reference in the constant vector is a symbol prefixed
+; by #^G. On reading, the reference is replaced by (a pointer to) the
+; actual cell.
+;
+; This code is highly bummed. The procedure write-bytevector-like has the
+; same meaning as display, but in Larceny, the former is currently much
+; faster than the latter.
+
+(define (dump-fasl-segment-to-port segment outp . rest)
+ (let* ((omit-code? (not (null? rest)))
+ (controllify
+ (lambda (char)
+ (integer->char (- (char->integer char) (char->integer #\@)))))
+ (CTRLP (controllify #\P))
+ (CTRLB (controllify #\B))
+ (CTRLG (controllify #\G))
+ (DOUBLEQUOTE (char->integer #\"))
+ (BACKSLASH (char->integer #\\))
+ (len 1024))
+
+ (define buffer (make-string len #\&))
+ (define ptr 0)
+
+ (define (flush)
+ (if (< ptr len)
+ (write-bytevector-like (substring buffer 0 ptr) outp)
+ (write-bytevector-like buffer outp))
+ (set! ptr 0))
+
+ (define (putc c)
+ (if (= ptr len) (flush))
+ (string-set! buffer ptr c)
+ (set! ptr (+ ptr 1)))
+
+ (define (putb b)
+ (if (= ptr len) (flush))
+ (string-set! buffer ptr (integer->char b))
+ (set! ptr (+ ptr 1)))
+
+ (define (puts s)
+ (let ((ls (string-length s)))
+ (if (>= (+ ptr ls) len)
+ (begin (flush)
+ (write-bytevector-like s outp))
+ (do ((i (- ls 1) (- i 1))
+ (p (+ ptr ls -1) (- p 1)))
+ ((< i 0)
+ (set! ptr (+ ptr ls)))
+ (string-set! buffer p (string-ref s i))))))
+
+ (define (putd d)
+ (flush)
+ (write-fasl-datum d outp))
+
+ (define (dump-codevec bv)
+ (if omit-code?
+ (puts "#f")
+ (begin
+ (putc #\#)
+ (putc CTRLB)
+ (putc #\")
+ (let ((limit (bytevector-length bv)))
+ (do ((i 0 (+ i 1)))
+ ((= i limit) (putc #\")
+ (putc #\newline))
+ (let ((c (bytevector-ref bv i)))
+ (cond ((= c DOUBLEQUOTE) (putc #\\))
+ ((= c BACKSLASH) (putc #\\)))
+ (putb c)))))))
+
+ (define (dump-constvec cv)
+ (puts "#(")
+ (for-each (lambda (const)
+ (putc #\space)
+ (case (car const)
+ ((data)
+ (putd (cadr const)))
+ ((constantvector)
+ (dump-constvec (cadr const)))
+ ((codevector)
+ (dump-codevec (cadr const)))
+ ((global)
+ (putc #\#)
+ (putc CTRLG)
+ (putd (cadr const)))
+ ((bits)
+ (error "BITS attribute is not supported in fasl files."))
+ (else
+ (error "Faulty .lop file."))))
+ (vector->list cv))
+ (puts ")")
+ (putc #\newline))
+
+ (define (dump-fasl-segment segment)
+ (if (not omit-code?) (putc #\())
+ (putc #\#)
+ (putc CTRLP)
+ (putc #\()
+ (dump-codevec (car segment))
+ (putc #\space)
+ (dump-constvec (cdr segment))
+ (puts " #f)")
+ (if (not omit-code?) (putc #\)))
+ (putc #\newline))
+
+ (dump-fasl-segment segment)
+ (flush)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Bootstrap heap dumper.
+;
+; Usage: (build-heap-image outputfile inputfile-list)
+;
+; Each input file is a sequence of segments, the structure of which
+; depends on the target architecture, but at least segment.code and
+; segment.constants exist as accessors.
+;
+; The code is a bytevector. The constant vector contains tagged
+; entries (represented using length-2 lists), where the tags are
+; `data', `codevector', `constantvector', `global', or `bits'.
+;
+; `build-heap-image' reads its file arguments into the heap, creates
+; thunks from the segments, and creates a list of the thunks. It also
+; creates a list of all symbols present in the loaded files. Finally,
+; it generates an initialization procedure (the LAP of which is hardcoded
+; into this file; see below). A pointer to this procedure is installed
+; in the SCHEME_ENTRY root pointer; hence, this procedure (a thunk, as
+; it were) is called when the heap image is loaded.
+;
+; The initialization procedure calls each procedure in the thunk list in
+; order. It then invokes the procedure `go', which takes one argument:
+; the list of symbols. Typically, `go' will initialize the symbol table
+; and other system tables and then call `main', but this is by no means
+; required.
+;
+; The Scheme assembler must be co-resident, since it is used by
+; `build-heap-image' procedure to assemble the final startup code. This
+; could be avoided by pre-assembling the code and patching it here, but
+; the way it is now, this procedure is entirely portable -- no target
+; dependencies.
+;
+; The code is structured to allow most procedures to be overridden for
+; target architectures with more complex needs (notably the C backend).
+
+(define generate-global-symbols
+ (make-twobit-flag 'generate-global-symbols))
+(generate-global-symbols #t)
+
+(define heap.version-number 9) ; Heap version number
+
+(define heap.root-names ; Roots in heap version 9
+ '(result argreg2 argreg3
+ reg0 reg1 reg2 reg3 reg3 reg5 reg6 reg7 reg8 reg9 reg10 reg11 reg12
+ reg13 reg14 reg15 reg16 reg17 reg18 reg19 reg20 reg21 reg22 reg23
+ reg24 reg25 reg26 reg27 reg28 reg29 reg30 reg31
+ cont startup callouts schcall-arg4 alloci-tmp))
+
+(define (build-heap-image output-file input-files)
+
+ (define tmp-file "HEAPDATA.dat")
+
+ (define (process-input-files heap)
+ (let loop ((files input-files) (inits '()))
+ (cond ((null? files)
+ (heap.thunks! heap (apply append inits)))
+ (else
+ (let ((filename (car files)))
+ (display "Loading ")
+ (display filename)
+ (newline)
+ (loop (cdr files)
+ (append inits (list (dump-file! heap filename)))))))))
+
+ (delete-file tmp-file)
+ (let ((heap (make-heap #f (open-output-file tmp-file))))
+ (before-all-files heap output-file input-files)
+ (process-input-files heap)
+ (heap.set-root! heap
+ 'startup
+ (dump-startup-procedure! heap))
+ (heap.set-root! heap
+ 'callouts
+ (dump-global! heap 'millicode-support))
+ (write-header heap output-file)
+ (after-all-files heap output-file input-files)
+ (close-output-port (heap.output-port heap))
+ (append-file-shell-command tmp-file output-file)
+ (load-map heap)
+ (unspecified)))
+
+(define (before-all-files heap output-file-name input-file-names) #t)
+(define (after-all-files heap output-file-name input-file-names) #t)
+
+; Public
+;
+; A 'heap' is a data structure with the following public fields; none
+; of them are constant unless so annotated:
+;
+; version a fixnum (constant) - heap type version number
+; roots an assoc list that maps root names to values
+; top an exact nonnegative integer: the address of the
+; next byte to be emitted
+; symbol-table a symbol table abstract data type
+; extra any value - a client-extension field
+; output-port an output port (for the data stream)
+; thunks a list of codevector addresses
+;
+; Bytes are emitted with the heap.byte! and heap.word! procedures,
+; which emit a byte and a 4-byte word respectively. These update
+; the top field.
+
+(define (make-heap extra output-port)
+ (vector heap.version-number ; version
+ '() ; roots
+ 0 ; top
+ (make-heap-symbol-table) ; symtab
+ extra ; extra
+ output-port ; output port
+ '() ; thunks
+ ))
+
+(define (heap.version h) (vector-ref h 0))
+(define (heap.roots h) (vector-ref h 1))
+(define (heap.top h) (vector-ref h 2))
+(define (heap.symbol-table h) (vector-ref h 3))
+(define (heap.extra h) (vector-ref h 4))
+(define (heap.output-port h) (vector-ref h 5))
+(define (heap.thunks h) (vector-ref h 6))
+
+(define (heap.roots! h x) (vector-set! h 1 x))
+(define (heap.top! h x) (vector-set! h 2 x))
+(define (heap.thunks! h x) (vector-set! h 6 x))
+
+
+; Symbol table.
+;
+; The symbol table maps names to symbol structures, and a symbol
+; structure contains information about that symbol.
+;
+; The structure has four fields:
+; name a symbol - the print name
+; symloc a fixnum or null - if fixnum, the location in the
+; heap of the symbol structure.
+; valloc a fixnum or null - if fixnum, the location in the
+; heap of the global variable cell that has this
+; symbol for its name.
+; valno a fixnum or null - if fixnum, the serial number of
+; the global variable cell (largely obsolete).
+;
+; Note therefore that the symbol table maintains information about
+; whether the symbol is used as a symbol (in a datum), as a global
+; variable, or both.
+
+(define (make-heap-symbol-table)
+ (vector '() 0))
+
+(define (symtab.symbols st) (vector-ref st 0))
+(define (symtab.cell-no st) (vector-ref st 1))
+
+(define (symtab.symbols! st x) (vector-set! st 0 x))
+(define (symtab.cell-no! st x) (vector-set! st 1 x))
+
+(define (make-symcell name)
+ (vector name '() '() '()))
+
+(define (symcell.name sc) (vector-ref sc 0)) ; name
+(define (symcell.symloc sc) (vector-ref sc 1)) ; symbol location (if any)
+(define (symcell.valloc sc) (vector-ref sc 2)) ; value cell location (ditto)
+(define (symcell.valno sc) (vector-ref sc 3)) ; value cell number (ditto)
+
+(define (symcell.symloc! sc x) (vector-set! sc 1 x))
+(define (symcell.valloc! sc x) (vector-set! sc 2 x))
+(define (symcell.valno! sc x) (vector-set! sc 3 x))
+
+; Find a symcell in the table, or make a new one if there's none.
+
+(define (symbol-cell h name)
+ (let ((symtab (heap.symbol-table h)))
+ (let loop ((symbols (symtab.symbols symtab)))
+ (cond ((null? symbols)
+ (let ((new-sym (make-symcell name)))
+ (symtab.symbols! symtab (cons new-sym
+ (symtab.symbols symtab)))
+ new-sym))
+ ((eq? name (symcell.name (car symbols)))
+ (car symbols))
+ (else
+ (loop (cdr symbols)))))))
+
+
+; Fundamental data emitters
+
+(define twofiftysix^3 (* 256 256 256))
+(define twofiftysix^2 (* 256 256))
+(define twofiftysix 256)
+
+(define (heap.word-be! h w)
+ (heap.byte! h (quotient w twofiftysix^3))
+ (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
+ (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
+ (heap.byte! h (remainder w twofiftysix)))
+
+(define (heap.word-el! h w)
+ (heap.byte! h (remainder w twofiftysix))
+ (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
+ (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
+ (heap.byte! h (quotient w twofiftysix^3)))
+
+(define heap.word! heap.word-be!)
+
+(define (dumpheap.set-endianness! which)
+ (case which
+ ((big) (set! heap.word! heap.word-be!))
+ ((little) (set! heap.word! heap.word-el!))
+ (else ???)))
+
+(define (heap.byte! h b)
+ (write-char (integer->char b) (heap.output-port h))
+ (heap.top! h (+ 1 (heap.top h))))
+
+
+; Useful abstractions and constants.
+
+(define (heap.header-word! h immediate length)
+ (heap.word! h (+ (* length 256) immediate)))
+
+(define (heap.adjust! h)
+ (let ((p (heap.top h)))
+ (let loop ((i (- (* 8 (quotient (+ p 7) 8)) p)))
+ (if (zero? i)
+ '()
+ (begin (heap.byte! h 0)
+ (loop (- i 1)))))))
+
+(define heap.largest-fixnum (- (expt 2 29) 1))
+(define heap.smallest-fixnum (- (expt 2 29)))
+
+(define (heap.set-root! h name value)
+ (heap.roots! h (cons (cons name value) (heap.roots h))))
+
+
+;;; The segment.* procedures may be overridden by custom code.
+
+(define segment.code car)
+(define segment.constants cdr)
+
+;;; The dump-*! procedures may be overridden by custom code.
+
+; Load a LOP file into the heap, create a thunk in the heap to hold the
+; code and constant vector, and return the list of thunk addresses in
+; the order dumped.
+
+(define (dump-file! h filename)
+ (before-dump-file h filename)
+ (call-with-input-file filename
+ (lambda (in)
+ (do ((segment (read in) (read in))
+ (thunks '() (cons (dump-segment! h segment) thunks)))
+ ((eof-object? segment)
+ (after-dump-file h filename)
+ (reverse thunks))))))
+
+(define (before-dump-file h filename) #t)
+(define (after-dump-file h filename) #t)
+
+; Dump a segment and return the heap address of the resulting thunk.
+
+(define (dump-segment! h segment)
+ (let* ((the-code (dump-codevector! h (segment.code segment)))
+ (the-consts (dump-constantvector! h (segment.constants segment))))
+ (dump-thunk! h the-code the-consts)))
+
+(define (dump-tagged-item! h item)
+ (case (car item)
+ ((codevector)
+ (dump-codevector! h (cadr item)))
+ ((constantvector)
+ (dump-constantvector! h (cadr item)))
+ ((data)
+ (dump-datum! h (cadr item)))
+ ((global)
+ (dump-global! h (cadr item)))
+ ((bits)
+ (cadr item))
+ (else
+ (error 'dump-tagged-item! "Unknown item ~a" item))))
+
+(define (dump-datum! h datum)
+
+ (define (fixnum? x)
+ (and (integer? x)
+ (exact? x)
+ (<= heap.smallest-fixnum x heap.largest-fixnum)))
+
+ (define (bignum? x)
+ (and (integer? x)
+ (exact? x)
+ (or (> x heap.largest-fixnum)
+ (< x heap.smallest-fixnum))))
+
+ (define (ratnum? x)
+ (and (rational? x) (exact? x) (not (integer? x))))
+
+ (define (flonum? x)
+ (and (real? x) (inexact? x)))
+
+ (define (compnum? x)
+ (and (complex? x) (inexact? x) (not (real? x))))
+
+ (define (rectnum? x)
+ (and (complex? x) (exact? x) (not (real? x))))
+
+ (cond ((fixnum? datum)
+ (dump-fixnum! h datum))
+ ((bignum? datum)
+ (dump-bignum! h datum))
+ ((ratnum? datum)
+ (dump-ratnum! h datum))
+ ((flonum? datum)
+ (dump-flonum! h datum))
+ ((compnum? datum)
+ (dump-compnum! h datum))
+ ((rectnum? datum)
+ (dump-rectnum! h datum))
+ ((char? datum)
+ (dump-char! h datum))
+ ((null? datum)
+ $imm.null)
+ ((eq? datum #t)
+ $imm.true)
+ ((eq? datum #f)
+ $imm.false)
+ ((equal? datum (unspecified))
+ $imm.unspecified)
+ ((equal? datum (undefined))
+ $imm.undefined)
+ ((vector? datum)
+ (dump-vector! h datum $tag.vector-typetag))
+ ((bytevector? datum)
+ (dump-bytevector! h datum $tag.bytevector-typetag))
+ ((pair? datum)
+ (dump-pair! h datum))
+ ((string? datum)
+ (dump-string! h datum))
+ ((symbol? datum)
+ (dump-symbol! h datum))
+ (else
+ (error 'dump-datum! "Unsupported type of datum ~a" datum))))
+
+; Returns the two's complement representation as a positive number.
+
+(define (dump-fixnum! h f)
+ (if (negative? f)
+ (- #x100000000 (* (abs f) 4))
+ (* 4 f)))
+
+(define (dump-char! h c)
+ (+ (* (char->integer c) twofiftysix^2) $imm.character))
+
+(define (dump-bignum! h b)
+ (dump-bytevector! h (bignum->bytevector b) $tag.bignum-typetag))
+
+(define (dump-ratnum! h r)
+ (dump-vector! h
+ (vector (numerator r) (denominator r))
+ $tag.ratnum-typetag))
+
+(define (dump-flonum! h f)
+ (dump-bytevector! h (flonum->bytevector f) $tag.flonum-typetag))
+
+(define (dump-compnum! h c)
+ (dump-bytevector! h (compnum->bytevector c) $tag.compnum-typetag))
+
+(define (dump-rectnum! h r)
+ (dump-vector! h
+ (vector (real-part r) (imag-part r))
+ $tag.rectnum-typetag))
+
+(define (dump-string! h s)
+ (dump-bytevector! h (string->bytevector s) $tag.string-typetag))
+
+(define (dump-pair! h p)
+ (let ((the-car (dump-datum! h (car p)))
+ (the-cdr (dump-datum! h (cdr p))))
+ (let ((base (heap.top h)))
+ (heap.word! h the-car)
+ (heap.word! h the-cdr)
+ (+ base $tag.pair-tag))))
+
+(define (dump-bytevector! h bv variation)
+ (let ((base (heap.top h))
+ (l (bytevector-length bv)))
+ (heap.header-word! h (+ $imm.bytevector-header variation) l)
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (heap.byte! h (bytevector-ref bv i))
+ (loop (+ i 1)))
+ (begin (heap.adjust! h)
+ (+ base $tag.bytevector-tag))))))
+
+(define (dump-vector! h v variation)
+ (dump-vector-like! h v dump-datum! variation))
+
+(define (dump-vector-like! h cv recur! variation)
+ (let* ((l (vector-length cv))
+ (v (make-vector l '())))
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (vector-set! v i (recur! h (vector-ref cv i)))
+ (loop (+ i 1)))
+ (let ((base (heap.top h)))
+ (heap.header-word! h (+ $imm.vector-header variation) (* l 4))
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (heap.word! h (vector-ref v i))
+ (loop (+ i 1)))
+ (begin (heap.adjust! h)
+ (+ base $tag.vector-tag)))))))))
+
+(define (dump-codevector! h cv)
+ (dump-bytevector! h cv $tag.bytevector-typetag))
+
+(define (dump-constantvector! h cv)
+ (dump-vector-like! h cv dump-tagged-item! $tag.vector-typetag))
+
+(define (dump-symbol! h s)
+ (let ((x (symbol-cell h s)))
+ (if (null? (symcell.symloc x))
+ (symcell.symloc! x (create-symbol! h s)))
+ (symcell.symloc x)))
+
+(define (dump-global! h g)
+ (let ((x (symbol-cell h g)))
+ (if (null? (symcell.valloc x))
+ (let ((cell (create-cell! h g)))
+ (symcell.valloc! x (car cell))
+ (symcell.valno! x (cdr cell))))
+ (symcell.valloc x)))
+
+(define (dump-thunk! h code constants)
+ (let ((base (heap.top h)))
+ (heap.header-word! h $imm.procedure-header 8)
+ (heap.word! h code)
+ (heap.word! h constants)
+ (heap.adjust! h)
+ (+ base $tag.procedure-tag)))
+
+; The car's are all heap pointers, so they should not be messed with.
+; The cdr must be dumped, and then the pair.
+
+(define (dump-list-spine! h l)
+ (if (null? l)
+ $imm.null
+ (let ((the-car (car l))
+ (the-cdr (dump-list-spine! h (cdr l))))
+ (let ((base (heap.top h)))
+ (heap.word! h the-car)
+ (heap.word! h the-cdr)
+ (+ base $tag.pair-tag)))))
+
+(define (dump-startup-procedure! h)
+ (let ((thunks (dump-list-spine! h (heap.thunks h)))
+ (symbols (dump-list-spine! h (symbol-locations h))))
+ (dump-segment! h (construct-startup-procedure symbols thunks))))
+
+; The initialization procedure. The lists are magically patched into
+; the constant vector after the procedure has been assembled but before
+; it is dumped into the heap. See below.
+;
+; (define (init-proc argv)
+; (let loop ((l <list-of-thunks>))
+; (if (null? l)
+; (go <list-of-symbols> argv)
+; (begin ((car l))
+; (loop (cdr l))))))
+
+(define init-proc
+ `((,$.proc)
+ (,$args= 1)
+ (,$reg 1) ; argv into
+ (,$setreg 2) ; register 2
+ (,$const (thunks)) ; dummy list of thunks.
+ (,$setreg 1)
+ (,$.label 0)
+ (,$reg 1)
+ (,$op1 null?) ; (null? l)
+ (,$branchf 2)
+ (,$const (symbols)) ; dummy list of symbols
+ (,$setreg 1)
+ (,$global go)
+ ;(,$op1 break)
+ (,$invoke 2) ; (go <list of symbols> argv)
+ (,$.label 2)
+ (,$save 2)
+ (,$store 0 0)
+ (,$store 1 1)
+ (,$store 2 2)
+ (,$setrtn 3)
+ (,$reg 1)
+ (,$op1 car)
+ (,$invoke 0) ; ((car l))
+ (,$.label 3)
+ (,$.cont)
+ (,$restore 2)
+ (,$pop 2)
+ (,$reg 1)
+ (,$op1 cdr)
+ (,$setreg 1)
+ (,$branch 0))) ; (loop (cdr l))
+
+
+;;; Non-overridable code beyond this point
+
+; Stuff a new symbol into the heap, return its location.
+
+(define (create-symbol! h s)
+ (dump-vector-like!
+ h
+ (vector `(bits ,(dump-string! h (symbol->string s)))
+ '(data 0)
+ '(data ()))
+ dump-tagged-item!
+ $tag.symbol-typetag))
+
+
+; Stuff a value cell into the heap, return a pair of its location
+; and its cell number.
+
+(define (create-cell! h s)
+ (let* ((symtab (heap.symbol-table h))
+ (n (symtab.cell-no symtab))
+ (p (dump-pair! h (cons (undefined)
+ (if (generate-global-symbols)
+ s
+ n)))))
+ (symtab.cell-no! symtab (+ n 1))
+ (cons p n)))
+
+
+(define (construct-startup-procedure symbol-list-addr init-list-addr)
+
+ ; Given some value which might appear in the constant vector,
+ ; replace the entries matching that value with a new value.
+
+ (define (patch-constant-vector! v old new)
+ (let loop ((i (- (vector-length v) 1)))
+ (if (>= i 0)
+ (begin (if (equal? (vector-ref v i) old)
+ (vector-set! v i new))
+ (loop (- i 1))))))
+
+ ; Assemble the startup thunk, patch it, and return it.
+
+ (display "Assembling final procedure") (newline)
+ (let ((e (single-stepping)))
+ (single-stepping #f)
+ (let ((segment (assemble init-proc)))
+ (single-stepping e)
+ (patch-constant-vector! (segment.constants segment)
+ '(data (thunks))
+ `(bits ,init-list-addr))
+ (patch-constant-vector! (segment.constants segment)
+ '(data (symbols))
+ `(bits ,symbol-list-addr))
+ segment)))
+
+
+; Return a list of symbol locations for symbols in the heap, in order.
+
+(define (symbol-locations h)
+ (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
+ (cond ((null? symbols)
+ (reverse res))
+ ((not (null? (symcell.symloc (car symbols))))
+ (loop (cdr symbols)
+ (cons (symcell.symloc (car symbols)) res)))
+ (else
+ (loop (cdr symbols) res)))))
+
+; Return list of variable name to cell number mappings for global vars.
+
+(define (load-map h)
+ (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
+ (cond ((null? symbols)
+ (reverse res))
+ ((not (null? (symcell.valloc (car symbols))))
+ (loop (cdr symbols)
+ (cons (cons (symcell.name (car symbols))
+ (symcell.valno (car symbols)))
+ res)))
+ (else
+ (loop (cdr symbols) res)))))
+
+
+(define (write-header h output-file)
+ (delete-file output-file)
+ (call-with-output-file output-file
+ (lambda (out)
+
+ (define (write-word w)
+ (display (integer->char (quotient w twofiftysix^3)) out)
+ (display (integer->char (quotient (remainder w twofiftysix^3)
+ twofiftysix^2))
+ out)
+ (display (integer->char (quotient (remainder w twofiftysix^2)
+ twofiftysix))
+ out)
+ (display (integer->char (remainder w twofiftysix)) out))
+
+ (define (write-roots)
+ (let ((assigned-roots (heap.roots h)))
+ (for-each (lambda (root-name)
+ (let ((probe (assq root-name assigned-roots)))
+ (if probe
+ (write-word (cdr probe))
+ (write-word $imm.false))))
+ heap.root-names)))
+
+ (write-word heap.version-number)
+ (write-roots)
+ (write-word (quotient (heap.top h) 4)))))
+
+
+; This is a gross hack that happens to work very well.
+
+(define (append-file-shell-command file-to-append file-to-append-to)
+
+ (define (message)
+ (display "You must execute the command") (newline)
+ (display " cat ") (display file-to-append)
+ (display " >> ") (display file-to-append-to) (newline)
+ (display "to create the final heap image.") (newline))
+
+ (case host-system
+ ((chez larceny)
+ (display "Creating final image in \"")
+ (display file-to-append-to) (display "\"...") (newline)
+ (if (zero? (system (string-append "cat " file-to-append " >> "
+ file-to-append-to)))
+ (delete-file file-to-append)
+ (begin (display "Failed to create image!")
+ (newline))))
+ (else
+ (message))))
+
+; eof
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 11 June 1999 / wdc
+;
+; Asm/Sparc/pass5p2.sch -- Sparc machine assembler, top level
+
+; Overrides the procedure of the same name in Asm/Common/pass5p1.sch.
+
+(define (assembly-table) $sparc-assembly-table$)
+
+; Controls listing of instructions during assembly.
+
+(define listify? #f)
+
+; Table of assembler procedures.
+
+(define $sparc-assembly-table$
+ (make-vector
+ *number-of-mnemonics*
+ (lambda (instruction as)
+ (asm-error "Unrecognized mnemonic " instruction))))
+
+(define (define-instruction i proc)
+ (vector-set! $sparc-assembly-table$ i proc)
+ #t)
+
+(define (list-instruction name instruction)
+ (if listify?
+ (begin (display list-indentation)
+ (display " ")
+ (display name)
+ (display (make-string (max (- 12 (string-length name)) 1)
+ #\space))
+ (if (not (null? (cdr instruction)))
+ (begin (write (cadr instruction))
+ (do ((operands (cddr instruction)
+ (cdr operands)))
+ ((null? operands))
+ (write-char #\,)
+ (write (car operands)))))
+ (newline)
+ (flush-output-port))))
+
+(define (list-label instruction)
+ (if listify?
+ (begin (display list-indentation)
+ (write-char #\L)
+ (write (cadr instruction))
+ (newline))))
+
+(define (list-lambda-start instruction)
+ (list-instruction "lambda" (list $lambda '* (operand2 instruction)))
+ (set! list-indentation (string-append list-indentation "| ")))
+
+(define (list-lambda-end)
+ (set! list-indentation
+ (substring list-indentation
+ 0
+ (- (string-length list-indentation) 4))))
+
+(define list-indentation "")
+
+; Utilities
+
+; Pseudo-instructions.
+
+(define-instruction $.label
+ (lambda (instruction as)
+ (list-label instruction)
+ (sparc.label as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $.proc
+ (lambda (instruction as)
+ (list-instruction ".proc" instruction)
+ #t))
+
+(define-instruction $.proc-doc
+ (lambda (instruction as)
+ (list-instruction ".proc-doc" instruction)
+ (add-documentation as (operand1 instruction))
+ #t))
+
+(define-instruction $.cont
+ (lambda (instruction as)
+ (list-instruction ".cont" instruction)
+ #t))
+
+(define-instruction $.align
+ (lambda (instruction as)
+ (list-instruction ".align" instruction)
+ #t))
+
+(define-instruction $.end
+ (lambda (instruction as)
+ #t))
+
+(define-instruction $.singlestep
+ (lambda (instruction as)
+ (let ((instr (car (as-source as))))
+
+ (define (special?)
+ (let ((op (operand0 instr)))
+ (or (= op $.label)
+ (= op $.proc)
+ (= op $.cont)
+ (= op $.align)
+ (and (= op $load) (= 0 (operand1 instr))))))
+
+ (define (readify-instr)
+ (if (= (operand0 instr) $lambda)
+ (list 'lambda '(...) (caddr instr) (cadddr instr))
+ (car (readify-lap (list instr)))))
+
+ (if (not (special?))
+ (let ((repr (format-object (readify-instr)))
+ (funky? (= (operand0 instr) $restore)))
+ (let ((o (emit-datum as repr)))
+ (emit-singlestep-instr! as funky? 0 o)))))))
+
+
+; Instructions.
+
+(define-instruction $op1
+ (lambda (instruction as)
+ (list-instruction "op1" instruction)
+ (emit-primop.1arg! as (operand1 instruction))))
+
+(define-instruction $op2
+ (lambda (instruction as)
+ (list-instruction "op2" instruction)
+ (emit-primop.2arg! as
+ (operand1 instruction)
+ (regname (operand2 instruction)))))
+
+(define-instruction $op3
+ (lambda (instruction as)
+ (list-instruction "op3" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (regname (operand2 instruction))
+ (regname (operand3 instruction)))))
+
+(define-instruction $op2imm
+ (lambda (instruction as)
+ (list-instruction "op2imm" instruction)
+ (let ((op (case (operand1 instruction)
+ ((+) 'internal:+/imm)
+ ((-) 'internal:-/imm)
+ ((fx+) 'internal:fx+/imm)
+ ((fx-) 'internal:fx-/imm)
+ ((fx=) 'internal:fx=/imm)
+ ((fx<) 'internal:fx</imm)
+ ((fx<=) 'internal:fx<=/imm)
+ ((fx>) 'internal:fx>/imm)
+ ((fx>=) 'internal:fx>=/imm)
+ ((=:fix:fix) 'internal:=:fix:fix/imm)
+ ((<:fix:fix) 'internal:<:fix:fix/imm)
+ ((<=:fix:fix) 'internal:<=:fix:fix/imm)
+ ((>:fix:fix) 'internal:>:fix:fix/imm)
+ ((>=:fix:fix) 'internal:>=:fix:fix/imm)
+ (else #f))))
+ (if op
+ (emit-primop.4arg! as op $r.result (operand2 instruction) $r.result)
+ (begin
+ (emit-constant->register as (operand2 instruction) $r.argreg2)
+ (emit-primop.2arg! as
+ (operand1 instruction)
+ $r.argreg2))))))
+
+(define-instruction $const
+ (lambda (instruction as)
+ (list-instruction "const" instruction)
+ (emit-constant->register as (operand1 instruction) $r.result)))
+
+(define-instruction $global
+ (lambda (instruction as)
+ (list-instruction "global" instruction)
+ (emit-global->register! as
+ (emit-global as (operand1 instruction))
+ $r.result)))
+
+(define-instruction $setglbl
+ (lambda (instruction as)
+ (list-instruction "setglbl" instruction)
+ (emit-register->global! as
+ $r.result
+ (emit-global as (operand1 instruction)))))
+
+; FIXME: A problem is that the listing is messed up because of the delayed
+; assembly; somehow we should fix this by putting an identifying label
+; in the listing and emitting this label later, with the code.
+
+(define-instruction $lambda
+ (lambda (instruction as)
+ (let ((code-offset #f)
+ (const-offset #f))
+ (list-lambda-start instruction)
+ (assemble-nested-lambda as
+ (operand1 instruction)
+ (operand3 instruction) ; documentation
+ (lambda (nested-as segment)
+ (set-constant! as code-offset (car segment))
+ (set-constant! as const-offset (cdr segment))))
+ (list-lambda-end)
+ (set! code-offset (emit-codevector as 0))
+ (set! const-offset (emit-constantvector as 0))
+ (emit-lambda! as
+ code-offset
+ const-offset
+ (operand2 instruction)))))
+
+(define-instruction $lexes
+ (lambda (instruction as)
+ (list-instruction "lexes" instruction)
+ (emit-lexes! as (operand1 instruction))))
+
+(define-instruction $args=
+ (lambda (instruction as)
+ (list-instruction "args=" instruction)
+ (emit-args=! as (operand1 instruction))))
+
+(define-instruction $args>=
+ (lambda (instruction as)
+ (list-instruction "args>=" instruction)
+ (emit-args>=! as (operand1 instruction))))
+
+(define-instruction $invoke
+ (lambda (instruction as)
+ (list-instruction "invoke" instruction)
+ (emit-invoke as (operand1 instruction) #f $m.invoke-ex)))
+
+(define-instruction $restore
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "restore" instruction)
+ (emit-restore! as (operand1 instruction))))))
+
+(define-instruction $pop
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "pop" instruction)
+ (let ((next (next-instruction as)))
+ (if (and (peephole-optimization)
+ (eqv? $return (operand0 next)))
+ (begin (list-instruction "return" next)
+ (consume-next-instruction! as)
+ (emit-pop! as (operand1 instruction) #t))
+ (emit-pop! as (operand1 instruction) #f)))))))
+
+(define-instruction $stack
+ (lambda (instruction as)
+ (list-instruction "stack" instruction)
+ (emit-load! as (operand1 instruction) $r.result)))
+
+(define-instruction $setstk
+ (lambda (instruction as)
+ (list-instruction "setstk" instruction)
+ (emit-store! as $r.result (operand1 instruction))))
+
+(define-instruction $load
+ (lambda (instruction as)
+ (list-instruction "load" instruction)
+ (emit-load! as (operand2 instruction) (regname (operand1 instruction)))))
+
+(define-instruction $store
+ (lambda (instruction as)
+ (list-instruction "store" instruction)
+ (emit-store! as (regname (operand1 instruction)) (operand2 instruction))))
+
+(define-instruction $lexical
+ (lambda (instruction as)
+ (list-instruction "lexical" instruction)
+ (emit-lexical! as (operand1 instruction) (operand2 instruction))))
+
+(define-instruction $setlex
+ (lambda (instruction as)
+ (list-instruction "setlex" instruction)
+ (emit-setlex! as (operand1 instruction) (operand2 instruction))))
+
+(define-instruction $reg
+ (lambda (instruction as)
+ (list-instruction "reg" instruction)
+ (emit-register->register! as (regname (operand1 instruction)) $r.result)))
+
+(define-instruction $setreg
+ (lambda (instruction as)
+ (list-instruction "setreg" instruction)
+ (emit-register->register! as $r.result (regname (operand1 instruction)))))
+
+(define-instruction $movereg
+ (lambda (instruction as)
+ (list-instruction "movereg" instruction)
+ (emit-register->register! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $return
+ (lambda (instruction as)
+ (list-instruction "return" instruction)
+ (emit-return! as)))
+
+(define-instruction $reg/return
+ (lambda (instruction as)
+ (list-instruction "reg/return" instruction)
+ (emit-return-reg! as (regname (operand1 instruction)))))
+
+(define-instruction $const/return
+ (lambda (instruction as)
+ (list-instruction "const/return" instruction)
+ (emit-return-const! as (operand1 instruction))))
+
+(define-instruction $nop
+ (lambda (instruction as)
+ (list-instruction "nop" instruction)))
+
+(define-instruction $save
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "save" instruction)
+ (let* ((n (operand1 instruction))
+ (v (make-vector (+ n 1) #t)))
+ (emit-save0! as n)
+ (if (peephole-optimization)
+ (let loop ((instruction (next-instruction as)))
+ (if (eqv? $store (operand0 instruction))
+ (begin (list-instruction "store" instruction)
+ (emit-store! as
+ (regname (operand1 instruction))
+ (operand2 instruction))
+ (consume-next-instruction! as)
+ (vector-set! v (operand2 instruction) #f)
+ (loop (next-instruction as))))))
+ (emit-save1! as v))))))
+
+(define-instruction $setrtn
+ (lambda (instruction as)
+ (list-instruction "setrtn" instruction)
+ (emit-setrtn! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $apply
+ (lambda (instruction as)
+ (list-instruction "apply" instruction)
+ (emit-apply! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $jump
+ (lambda (instruction as)
+ (list-instruction "jump" instruction)
+ (emit-jump! as
+ (operand1 instruction)
+ (make-asm-label as (operand2 instruction)))))
+
+(define-instruction $skip
+ (lambda (instruction as)
+ (list-instruction "skip" instruction)
+ (emit-branch! as #f (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $branch
+ (lambda (instruction as)
+ (list-instruction "branch" instruction)
+ (emit-branch! as #t (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $branchf
+ (lambda (instruction as)
+ (list-instruction "branchf" instruction)
+ (emit-branchf! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $check
+ (lambda (instruction as)
+ (list-instruction "check" instruction)
+ (if (not (unsafe-code))
+ (emit-check! as $r.result
+ (make-asm-label as (operand4 instruction))
+ (list (regname (operand1 instruction))
+ (regname (operand2 instruction))
+ (regname (operand3 instruction)))))))
+
+(define-instruction $trap
+ (lambda (instruction as)
+ (list-instruction "trap" instruction)
+ (emit-trap! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction))
+ (regname (operand3 instruction))
+ (operand4 instruction))))
+
+(define-instruction $const/setreg
+ (lambda (instruction as)
+ (list-instruction "const/setreg" instruction)
+ (let ((x (operand1 instruction))
+ (r (operand2 instruction)))
+ (if (hwreg? r)
+ (emit-constant->register as x (regname r))
+ (begin (emit-constant->register as x $r.tmp0)
+ (emit-register->register! as $r.tmp0 (regname r)))))))
+
+; Operations introduced by the peephole optimizer.
+
+(define (peep-regname r)
+ (if (eq? r 'RESULT) $r.result (regname r)))
+
+(define-instruction $reg/op1/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op1/branchf" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (make-asm-label as (operand3 instruction)))))
+
+(define-instruction $reg/op2/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op2/branchf" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (make-asm-label as (operand4 instruction)))))
+
+(define-instruction $reg/op2imm/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/branchf" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (make-asm-label as (operand4 instruction)))))
+
+; These three are like the corresponding branchf sequences except that
+; there is a strong prediction that the branch will not be taken.
+
+(define-instruction $reg/op1/check
+ (lambda (instruction as)
+ (list-instruction "reg/op1/check" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (make-asm-label as (operand3 instruction))
+ (map peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op2/check
+ (lambda (instruction as)
+ (list-instruction "reg/op2/check" instruction)
+ (emit-primop.5arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (make-asm-label as (operand4 instruction))
+ (map peep-regname (operand5 instruction)))))
+
+(define-instruction $reg/op2imm/check
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/check" instruction)
+ (emit-primop.5arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (make-asm-label as (operand4 instruction))
+ (map peep-regname (operand5 instruction)))))
+
+;
+
+(define-instruction $reg/op1/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op1/setreg" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction)))))
+
+(define-instruction $reg/op2/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op2/setreg" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op2imm/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/setreg" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op3
+ (lambda (instruction as)
+ (list-instruction "reg/op3" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/branchf" instruction)
+ (emit-branchfreg! as
+ (regname (operand1 instruction))
+ (make-asm-label as (operand2 instruction)))))
+
+(define-instruction $setrtn/branch
+ (lambda (instruction as)
+ (list-instruction "setrtn/branch" instruction)
+ (emit-branch-with-setrtn! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $setrtn/invoke
+ (lambda (instruction as)
+ (list-instruction "setrtn/invoke" instruction)
+ (emit-invoke as (operand1 instruction) #t $m.invoke-ex)))
+
+(define-instruction $global/setreg
+ (lambda (instruction as)
+ (list-instruction "global/setreg" instruction)
+ (emit-global->register! as
+ (emit-global as (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $global/invoke
+ (lambda (instruction as)
+ (list-instruction "global/invoke" instruction)
+ (emit-load-global as
+ (emit-global as (operand1 instruction))
+ $r.result
+ #f)
+ (emit-invoke as (operand2 instruction) #f $m.global-invoke-ex)))
+
+(define-instruction $reg/setglbl
+ (lambda (instruction as)
+ (list-instruction "reg/setglbl" instruction)
+ (emit-register->global! as
+ (regname (operand1 instruction))
+ (emit-global as (operand2 instruction)))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999.
+;
+; Asm/Sparc/peepopt.sch -- MAL peephole optimizer, for the SPARC assembler.
+;
+; The procedure `peep' is called on the as structure before every
+; instruction is assembled. It may replace the prefix of the instruction
+; stream by some other instruction sequence.
+;
+; Invariant: if the peephole optimizer doesn't change anything, then
+;
+; (let ((x (as-source as)))
+; (peep as)
+; (eq? x (as-source as))) => #t
+;
+; Note this still isn't right -- it should be integrated with pass5p2 --
+; but it's a step in the right direction.
+
+(define *peephole-table* (make-vector *number-of-mnemonics* #f))
+
+(define (define-peephole n p)
+ (vector-set! *peephole-table* n p)
+ (unspecified))
+
+(define (peep as)
+ (let ((t0 (as-source as)))
+ (if (not (null? t0))
+ (let ((i1 (car t0)))
+ (let ((p (vector-ref *peephole-table* (car i1))))
+ (if p
+ (let* ((t1 (if (null? t0) t0 (cdr t0)))
+ (i2 (if (null? t1) '(-1 0 0 0) (car t1)))
+ (t2 (if (null? t1) t1 (cdr t1)))
+ (i3 (if (null? t2) '(-1 0 0 0) (car t2)))
+ (t3 (if (null? t2) t2 (cdr t2))))
+ (p as i1 i2 i3 t1 t2 t3))))))))
+
+(define-peephole $reg
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $return)
+ (reg-return as i1 i2 t2))
+ ((= (car i2) $setglbl)
+ (reg-setglbl as i1 i2 t2))
+ ((= (car i2) $op1)
+ (cond ((= (car i3) $setreg)
+ (reg-op1-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op1-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op1-check as i1 i2 i3 t3))
+ (else
+ (reg-op1 as i1 i2 t2))))
+ ((= (car i2) $op2)
+ (cond ((= (car i3) $setreg)
+ (reg-op2-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op2-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op2-check as i1 i2 i3 t3))
+ (else
+ (reg-op2 as i1 i2 t2))))
+ ((= (car i2) $op2imm)
+ (cond ((= (car i3) $setreg)
+ (reg-op2imm-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op2imm-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op2imm-check as i1 i2 i3 t3))
+ (else
+ (reg-op2imm as i1 i2 t2))))
+ ((= (car i2) $op3)
+ (reg-op3 as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (reg-setreg as i1 i2 t2))
+ ((= (car i2) $branchf)
+ (reg-branchf as i1 i2 t2)))))
+
+(define-peephole $op1
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op1-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op1-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op1-check as i1 i2 t2)))))
+
+(define-peephole $op2
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op2-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op2-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op2-check as i1 i2 t2)))))
+
+(define-peephole $op2imm
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op2imm-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op2imm-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op2imm-check as i1 i2 t2)))))
+
+(define-peephole $const
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $setreg)
+ (const-setreg as i1 i2 t2))
+ ((= (car i2) $op2)
+ (const-op2 as i1 i2 t2))
+ ((= (car i2) $return)
+ (const-return as i1 i2 t2)))))
+
+(define-peephole $setrtn
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branch)
+ (cond ((= (car i3) $.align)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $.label)
+ (setrtn-branch as i1 i2 i3 i4 t4))))))))
+ ((= (car i2) $invoke)
+ (cond ((= (car i3) $.align)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $.label)
+ (setrtn-invoke as i1 i2 i3 i4 t4)))))))))))
+
+(define-peephole $branch
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $.align)
+ (cond ((= (car i3) $.label)
+ (branch-and-label as i1 i2 i3 t3)))))))
+
+(define-peephole $global
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $setreg)
+ (global-setreg as i1 i2 t2))
+ ((= (car i2) $invoke)
+ (global-invoke as i1 i2 t2))
+ ((= (car i2) $setrtn)
+ (cond ((= (car i3) $invoke)
+ (global-setrtn-invoke as i1 i2 i3 t3)))))))
+
+(define-peephole $reg/op1/check
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $reg)
+ (cond ((= (car i3) $op1)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $setreg)
+ (reg/op1/check-reg-op1-setreg
+ as i1 i2 i3 i4 t4)))))))))))
+
+(define-peephole $reg/op2/check
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $reg)
+ (cond ((= (car i3) $op2imm)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $check)
+ (reg/op2/check-reg-op2imm-check
+ as i1 i2 i3 i4 t4)))))))))))
+
+; Worker procedures.
+
+(define (reg-return as i:reg i:return tail)
+ (let ((rs (operand1 i:reg)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/return rs) tail)))))
+
+(define (reg-op1-setreg as i:reg i:op1 i:setreg tail-1 tail)
+ (let ((rs (operand1 i:reg))
+ (rd (operand1 i:setreg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (if (hwreg? rd)
+ (peep-reg/op1/setreg as op rs rd tail)
+ (peep-reg/op1/setreg as op rs 'RESULT tail-1)))))
+
+(define (reg-op1 as i:reg i:op1 tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (peep-reg/op1/setreg as op rs 'RESULT tail))))
+
+(define (op1-setreg as i:op1 i:setreg tail)
+ (let ((op (operand1 i:op1))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op1/setreg as op 'RESULT rd tail))))
+
+(define (peep-reg/op1/setreg as op rs rd tail)
+ (let ((op (case op
+ ((car) 'internal:car)
+ ((cdr) 'internal:cdr)
+ ((car:pair) 'internal:car:pair)
+ ((cdr:pair) 'internal:cdr:pair)
+ ((cell-ref) 'internal:cell-ref)
+ ((vector-length) 'internal:vector-length)
+ ((vector-length:vec) 'internal:vector-length:vec)
+ ((string-length) 'internal:string-length)
+ ((--) 'internal:--)
+ ((fx--) 'internal:fx--)
+ ((fxpositive?) 'internal:fxpositive?)
+ ((fxnegative?) 'internal:fxnegative?)
+ ((fxzero?) 'internal:fxzero?)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op1/setreg op rs rd) tail)))))
+
+(define (reg-op2-setreg as i:reg i:op2 i:setreg tail-1 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rs1)
+ (if (hwreg? rd)
+ (peep-reg/op2/setreg as op rs1 rs2 rd tail)
+ (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail-1)))))
+
+(define (reg-op2 as i:reg i:op2 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail))))
+
+(define (op2-setreg as i:op2 i:setreg tail)
+ (let ((op (operand1 i:op2))
+ (rs2 (operand2 i:op2))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op2/setreg as op 'RESULT rs2 rd tail))))
+
+(define (peep-reg/op2/setreg as op rs1 rs2 rd tail)
+ (let ((op (case op
+ ((+) 'internal:+)
+ ((-) 'internal:-)
+ ((fx+) 'internal:fx+)
+ ((fx-) 'internal:fx-)
+ ((fx=) 'internal:fx=)
+ ((fx>) 'internal:fx>)
+ ((fx>=) 'internal:fx>=)
+ ((fx<) 'internal:fx<)
+ ((fx<=) 'internal:fx<=)
+ ((eq?) 'internal:eq?)
+ ((cons) 'internal:cons)
+ ((vector-ref) 'internal:vector-ref)
+ ((vector-ref:trusted) 'internal:vector-ref:trusted)
+ ((string-ref) 'internal:string-ref)
+ ((set-car!) 'internal:set-car!)
+ ((set-cdr!) 'internal:set-cdr!)
+ ((cell-set!) 'internal:cell-set!)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op2/setreg op rs1 rs2 rd) tail)))))
+
+(define (reg-op2imm-setreg as i:reg i:op2imm i:setreg tail-1 tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rs)
+ (if (hwreg? rd)
+ (peep-reg/op2imm/setreg as op rs imm rd tail)
+ (peep-reg/op2imm/setreg as op rs imm 'RESULT tail-1)))))
+
+(define (reg-op2imm as i:reg i:op2imm tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm)))
+ (if (hwreg? rs)
+ (peep-reg/op2imm/setreg as op rs imm 'RESULT tail))))
+
+(define (op2imm-setreg as i:op2imm i:setreg tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op2imm/setreg as op 'RESULT imm rd tail))))
+
+(define (peep-reg/op2imm/setreg as op rs imm rd tail)
+ (let ((op (case op
+ ((+) 'internal:+/imm)
+ ((-) 'internal:-/imm)
+ ((fx+) 'internal:fx+/imm)
+ ((fx-) 'internal:fx-/imm)
+ ((fx=) 'internal:fx=/imm)
+ ((fx<) 'internal:fx</imm)
+ ((fx<=) 'internal:fx<=/imm)
+ ((fx>) 'internal:fx>/imm)
+ ((fx>=) 'internal:fx>=/imm)
+ ((eq?) 'internal:eq?/imm)
+ ((vector-ref) 'internal:vector-ref/imm)
+ ((string-ref) 'internal:string-ref/imm)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op2imm/setreg op rs imm rd) tail)))))
+
+(define (reg-op1-branchf as i:reg i:op1 i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (peep-reg/op1/branchf as op rs L tail))))
+
+(define (op1-branchf as i:op1 i:branchf tail)
+ (let ((op (operand1 i:op1))
+ (L (operand1 i:branchf)))
+ (peep-reg/op1/branchf as op 'RESULT L tail)))
+
+(define (peep-reg/op1/branchf as op rs L tail)
+ (let ((op (case op
+ ((null?) 'internal:branchf-null?)
+ ((pair?) 'internal:branchf-pair?)
+ ((zero?) 'internal:branchf-zero?)
+ ((eof-object?) 'internal:branchf-eof-object?)
+ ((fixnum?) 'internal:branchf-fixnum?)
+ ((char?) 'internal:branchf-char?)
+ ((fxzero?) 'internal:branchf-fxzero?)
+ ((fxnegative?) 'internal:branchf-fxnegative?)
+ ((fxpositive?) 'internal:branchf-fxpositive?)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op1/branchf op rs L) tail)))))
+
+(define (reg-op2-branchf as i:reg i:op2 i:branchf tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/branchf as op rs1 rs2 L tail))))
+
+(define (op2-branchf as i:op2 i:branchf tail)
+ (let ((op (operand1 i:op2))
+ (rs2 (operand2 i:op2))
+ (L (operand1 i:branchf)))
+ (peep-reg/op2/branchf as op 'RESULT rs2 L tail)))
+
+(define (peep-reg/op2/branchf as op rs1 rs2 L tail)
+ (let ((op (case op
+ ((<) 'internal:branchf-<)
+ ((>) 'internal:branchf->)
+ ((>=) 'internal:branchf->=)
+ ((<=) 'internal:branchf-<=)
+ ((=) 'internal:branchf-=)
+ ((eq?) 'internal:branchf-eq?)
+ ((char=?) 'internal:branchf-char=?)
+ ((char>=?) 'internal:branchf-char>=?)
+ ((char>?) 'internal:branchf-char>?)
+ ((char<=?) 'internal:branchf-char<=?)
+ ((char<?) 'internal:branchf-char<?)
+ ((fx=) 'internal:branchf-fx=)
+ ((fx>) 'internal:branchf-fx>)
+ ((fx>=) 'internal:branchf-fx>=)
+ ((fx<) 'internal:branchf-fx<)
+ ((fx<=) 'internal:branchf-fx<=)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2/branchf op rs1 rs2 L)
+ tail)))))
+
+(define (reg-op2imm-branchf as i:reg i:op2imm i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (peep-reg/op2imm/branchf as op rs imm L tail))))
+
+(define (op2imm-branchf as i:op2imm i:branchf tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm))
+ (L (operand1 i:branchf)))
+ (peep-reg/op2imm/branchf as op 'RESULT imm L tail)))
+
+(define (peep-reg/op2imm/branchf as op rs imm L tail)
+ (let ((op (case op
+ ((<) 'internal:branchf-</imm)
+ ((>) 'internal:branchf->/imm)
+ ((>=) 'internal:branchf->=/imm)
+ ((<=) 'internal:branchf-<=/imm)
+ ((=) 'internal:branchf-=/imm)
+ ((eq?) 'internal:branchf-eq?/imm)
+ ((char=?) 'internal:branchf-char=?/imm)
+ ((char>=?) 'internal:branchf-char>=?/imm)
+ ((char>?) 'internal:branchf-char>?/imm)
+ ((char<=?) 'internal:branchf-char<=?/imm)
+ ((char<?) 'internal:branchf-char<?/imm)
+ ((fx=) 'internal:branchf-fx=/imm)
+ ((fx>) 'internal:branchf-fx>/imm)
+ ((fx>=) 'internal:branchf-fx>=/imm)
+ ((fx<) 'internal:branchf-fx</imm)
+ ((fx<=) 'internal:branchf-fx<=/imm)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2imm/branchf op rs imm L)
+ tail)))))
+
+; Check optimization.
+
+(define (reg-op1-check as i:reg i:op1 i:check tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (peep-reg/op1/check as
+ op
+ rs
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op1-check as i:op1 i:check tail)
+ (let ((op (operand1 i:op1)))
+ (peep-reg/op1/check as
+ op
+ 'RESULT
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op1/check as op rs L1 liveregs tail)
+ (let ((op (case op
+ ((fixnum?) 'internal:check-fixnum?)
+ ((pair?) 'internal:check-pair?)
+ ((vector?) 'internal:check-vector?)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op1/check op rs L1 liveregs)
+ tail)))))
+
+(define (reg-op2-check as i:reg i:op2 i:check tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/check as
+ op
+ rs1
+ rs2
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op2-check as i:op2 i:check tail)
+ (let ((rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (peep-reg/op2/check as
+ op
+ 'RESULT
+ rs2
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op2/check as op rs1 rs2 L1 liveregs tail)
+ (let ((op (case op
+ ((<:fix:fix) 'internal:check-<:fix:fix)
+ ((<=:fix:fix) 'internal:check-<=:fix:fix)
+ ((>=:fix:fix) 'internal:check->=:fix:fix)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2/check op rs1 rs2 L1 liveregs)
+ tail)))))
+
+(define (reg-op2imm-check as i:reg i:op2imm i:check tail)
+ (let ((rs1 (operand1 i:reg))
+ (op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm)))
+ (if (hwreg? rs1)
+ (peep-reg/op2imm/check as
+ op
+ rs1
+ imm
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op2imm-check as i:op2imm i:check tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm)))
+ (peep-reg/op2imm/check as
+ op
+ 'RESULT
+ imm
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op2imm/check as op rs1 imm L1 liveregs tail)
+ (let ((op (case op
+ ((<:fix:fix) 'internal:check-<:fix:fix/imm)
+ ((<=:fix:fix) 'internal:check-<=:fix:fix/imm)
+ ((>=:fix:fix) 'internal:check->=:fix:fix/imm)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2imm/check op rs1 imm L1 liveregs)
+ tail)))))
+
+(define (reg/op1/check-reg-op1-setreg as i:ro1check i:reg i:op1 i:setreg tail)
+ (let ((o1 (operand1 i:ro1check))
+ (r1 (operand2 i:ro1check))
+ (r2 (operand1 i:reg))
+ (o2 (operand1 i:op1))
+ (r3 (operand1 i:setreg)))
+ (if (and (eq? o1 'internal:check-vector?)
+ (eq? r1 r2)
+ (eq? o2 'vector-length:vec)
+ (hwreg? r1)
+ (hwreg? r3))
+ (as-source! as
+ (cons (list $reg/op2/check
+ 'internal:check-vector?/vector-length:vec
+ r1
+ r3
+ (operand3 i:ro1check)
+ (operand4 i:ro1check))
+ tail)))))
+
+; Range checks of the form 0 <= i < n can be performed by a single check.
+; This peephole optimization recognizes
+; reg rs1
+; op2 <:fix:fix,rs2
+; check r1,r2,r3,L
+; reg rs1 ; must match earlier reg
+; op2imm >=:fix:fix,0
+; check r1,r2,r3,L ; label must match earlier check
+
+(define (reg/op2/check-reg-op2imm-check
+ as i:ro2check i:reg i:op2imm i:check tail)
+ (let ((o1 (operand1 i:ro2check))
+ (rs1 (operand2 i:ro2check))
+ (rs2 (operand3 i:ro2check))
+ (L1 (operand4 i:ro2check))
+ (live (operand5 i:ro2check))
+ (rs3 (operand1 i:reg))
+ (o2 (operand1 i:op2imm))
+ (x (operand2 i:op2imm))
+ (L2 (operand4 i:check)))
+ (if (and (eq? o1 'internal:check-<:fix:fix)
+ (eq? o2 '>=:fix:fix)
+ (eq? rs1 rs3)
+ (eq? x 0)
+ (eq? L1 L2))
+ (as-source! as
+ (cons (list $reg/op2/check 'internal:check-range
+ rs1 rs2 L1 live)
+ tail)))))
+
+; End of check optimization.
+
+(define (reg-op3 as i:reg i:op3 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op3))
+ (rs3 (operand3 i:op3))
+ (op (operand1 i:op3)))
+ (if (hwreg? rs1)
+ (let ((op (case op
+ ((vector-set!) 'internal:vector-set!)
+ ((string-set!) 'internal:string-set!)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op3 op rs1 rs2 rs3) tail)))))))
+
+; Reg-setreg is not restricted to hardware registers, as $movereg is
+; a standard instruction.
+
+(define (reg-setreg as i:reg i:setreg tail)
+ (let ((rs (operand1 i:reg))
+ (rd (operand1 i:setreg)))
+ (if (= rs rd)
+ (as-source! as tail)
+ (as-source! as (cons (list $movereg rs rd) tail)))))
+
+(define (reg-branchf as i:reg i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/branchf rs L) tail)))))
+
+(define (const-setreg as i:const i:setreg tail)
+ (let ((c (operand1 i:const))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (as-source! as (cons (list $const/setreg c rd) tail)))))
+
+; Make-vector on vectors of known short length.
+
+(define (const-op2 as i:const i:op2 tail)
+ (let ((vn '#(make-vector:0 make-vector:1 make-vector:2 make-vector:3
+ make-vector:4 make-vector:5 make-vector:6 make-vector:7
+ make-vector:8 make-vector:9))
+ (c (operand1 i:const))
+ (op (operand1 i:op2))
+ (r (operand2 i:op2)))
+ (if (and (eq? op 'make-vector)
+ (fixnum? c)
+ (<= 0 c 9))
+ (as-source! as (cons (list $op2 (vector-ref vn c) r) tail)))))
+
+; Constants that can be synthesized in a single instruction can be
+; moved into RESULT in the delay slot of the return instruction.
+
+(define (const-return as i:const i:return tail)
+ (let ((c (operand1 i:const)))
+ (if (or (and (number? c) (immediate-int? c))
+ (null? c)
+ (boolean? c))
+ (as-source! as (cons (list $const/return c) tail)))))
+
+; This allows the use of hardware 'call' instructions.
+; (setrtn Lx)
+; (branch Ly k)
+; (.align k) Ignored on SPARC
+; (.label Lx)
+; => (setrtn/branch Ly k)
+; (.label Lx)
+
+(define (setrtn-branch as i:setrtn i:branch i:align i:label tail)
+ (let ((return-label (operand1 i:setrtn))
+ (branch-ops (cdr i:branch))
+ (label (operand1 i:label)))
+ (if (= return-label label)
+ (as-source! as (cons (cons $setrtn/branch branch-ops)
+ (cons i:label
+ tail))))))
+
+; Ditto for 'invoke'.
+;
+; Disabled because it does _not_ pay off on the SPARC currently --
+; probably, the dependency created between 'jmpl' and 'st' is not
+; handled well on the test machine (an Ultrasparc). Might work
+; better if the return address were to be kept in a register always.
+
+(define (setrtn-invoke as i:setrtn i:invoke i:align i:label tail)
+ (let ((return-label (operand1 i:setrtn))
+ (invoke-ops (operand1 i:invoke))
+ (label (operand1 i:label)))
+ (if (and #f ; DISABLED
+ (= return-label label))
+ (as-source! as (cons (cons $setrtn/invoke invoke-ops)
+ (cons i:label
+ tail))))))
+
+; Gets rid of spurious branch-to-next-instruction
+; (branch Lx k)
+; (.align y)
+; (.label Lx)
+; => (.align y)
+; (.label Lx)
+
+(define (branch-and-label as i:branch i:align i:label tail)
+ (let ((branch-label (operand1 i:branch))
+ (label (operand1 i:label)))
+ (if (= branch-label label)
+ (as-source! as (cons i:align (cons i:label tail))))))
+
+(define (global-setreg as i:global i:setreg tail)
+ (let ((global (operand1 i:global))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (as-source! as (cons (list $global/setreg global rd) tail)))))
+
+; Obscure guard: unsafe-code = #t implies that global/invoke will not
+; check the value of the global variable, yet unsafe-code and
+; catch-undefined-globals are supposed to be independent.
+
+(define (global-invoke as i:global i:invoke tail)
+ (let ((global (operand1 i:global))
+ (argc (operand1 i:invoke)))
+ (if (not (and (unsafe-code) (catch-undefined-globals)))
+ (as-source! as (cons (list $global/invoke global argc) tail)))))
+
+; Obscure guard: see comment for previous procedure.
+; FIXME! This implementation is temporary until setrtn-invoke is enabled.
+
+(define (global-setrtn-invoke as i:global i:setrtn i:invoke tail)
+ (let ((global (operand1 i:global))
+ (argc (operand1 i:invoke)))
+ (if (not (and (unsafe-code) (catch-undefined-globals)))
+ (as-source! as (cons i:setrtn
+ (cons (list $global/invoke global argc)
+ tail))))))
+
+(define (reg-setglbl as i:reg i:setglbl tail)
+ (let ((rs (operand1 i:reg))
+ (global (operand1 i:setglbl)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/setglbl rs global) tail)))))
+
+
+
+; Test code
+
+(define (peeptest istream)
+ (let ((as (make-assembly-structure istream)))
+ (let loop ((l '()))
+ (if (null? (as-source as))
+ (reverse l)
+ (begin (peep as)
+ (let ((a (car (as-source as))))
+ (as-source! as (cdr (as-source as)))
+ (loop (cons a l))))))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC assembler machine parameters & utility procedures.
+;
+; 13 May 1999 / wdc
+
+; Round up to nearest 8.
+
+(define (roundup8 n)
+ (* (quotient (+ n 7) 8) 8))
+
+; Given an integer code for a register, return its register label.
+; This register label is the register number for a h.w. register and the
+; offsets from GLOBALS[ r0 ] for a s.w. register.
+
+(define regname
+ (let ((v (vector $r.reg0 $r.reg1 $r.reg2 $r.reg3 $r.reg4 $r.reg5
+ $r.reg6 $r.reg7 $r.reg8 $r.reg9 $r.reg10 $r.reg11
+ $r.reg12 $r.reg13 $r.reg14 $r.reg15 $r.reg16 $r.reg17
+ $r.reg18 $r.reg19 $r.reg20 $r.reg21 $r.reg22 $r.reg23
+ $r.reg24 $r.reg25 $r.reg26 $r.reg27 $r.reg28 $r.reg29
+ $r.reg30 $r.reg31)))
+ (lambda (r)
+ (vector-ref v r))))
+
+; Is a general-purpose register mapped to a hardware register?
+; This is fragile! FIXME.
+
+(define (hardware-mapped? r)
+ (or (and (>= r $r.reg0) (<= r $r.reg7))
+ (= r $r.argreg2)
+ (= r $r.argreg3)
+ (= r $r.result)
+ (= r $r.g0)
+ (= r $r.tmp0)
+ (= r $r.tmp1)
+ (= r $r.tmp2)))
+
+; Used by peephole optimizer
+
+(define (hwreg? x)
+ (<= 0 x 7))
+
+(define (immediate-int? x)
+ (and (exact? x)
+ (integer? x)
+ (<= -1024 x 1023)))
+
+; Given an exact integer, can it be represented as a fixnum?
+
+(define fixnum-range?
+ (let ((-two^29 (- (expt 2 29)))
+ (two^29-1 (- (expt 2 29) 1)))
+ (lambda (x)
+ (<= -two^29 x two^29-1))))
+
+; Does the integer x fit in the immediate field of an instruction?
+
+(define (immediate-literal? x)
+ (<= -4096 x 4095))
+
+; Return the offset in the %GLOBALS table of the given memory-mapped
+; register. A memory-mapped register is represented by an integer which
+; is its offet, so just return the value.
+
+(define (swreg-global-offset r) r)
+
+; Return a bit representation of a character constant.
+
+(define (char->immediate c)
+ (+ (* (char->integer c) 65536) $imm.character))
+
+; Convert an integer to a fixnum.
+
+(define (thefixnum x) (* x 4))
+
+; The offset of data slot 'n' within a procedure structure, not adjusting
+; for tag. The proc is a header followed by code, const, and then data.
+
+(define (procedure-slot-offset n)
+ (+ 12 (* n 4)))
+
+; Src is a register, hwreg is a hardware register. If src is a
+; hardware register, return src. Otherwise, emit an instruction to load
+; src into hwreg and return hwreg.
+
+(define (force-hwreg! as src hwreg)
+ (if (hardware-mapped? src)
+ src
+ (emit-load-reg! as src hwreg)))
+
+; Given an arbitrary constant opd, generate code to load it into a
+; register r.
+
+(define (emit-constant->register as opd r)
+ (cond ((and (integer? opd) (exact? opd))
+ (if (fixnum-range? opd)
+ (emit-immediate->register! as (thefixnum opd) r)
+ (emit-const->register! as (emit-datum as opd) r)))
+ ((boolean? opd)
+ (emit-immediate->register! as
+ (if (eq? opd #t)
+ $imm.true
+ $imm.false)
+ r))
+ ((equal? opd (eof-object))
+ (emit-immediate->register! as $imm.eof r))
+ ((equal? opd (unspecified))
+ (emit-immediate->register! as $imm.unspecified r))
+ ((equal? opd (undefined))
+ (emit-immediate->register! as $imm.undefined r))
+ ((null? opd)
+ (emit-immediate->register! as $imm.null r))
+ ((char? opd)
+ (emit-immediate->register! as (char->immediate opd) r))
+ (else
+ (emit-const->register! as (emit-datum as opd) r))))
+
+
+; Stuff a bitpattern or symbolic expression into a register.
+; (CONST, for immediate constants.)
+;
+; FIXME(?): if this had access to eval-expr (currently hidden inside the
+; sparc assembler) it could attempt to evaluate symbolic expressions,
+; thereby selecting better code sequences when possible.
+
+(define (emit-immediate->register! as i r)
+ (let ((dest (if (not (hardware-mapped? r)) $r.tmp0 r)))
+ (cond ((and (number? i) (immediate-literal? i))
+ (sparc.set as i dest))
+ ((and (number? i) (zero? (remainder (abs i) 1024)))
+ (sparc.sethi as `(hi ,i) dest))
+ (else
+ (sparc.sethi as `(hi ,i) dest)
+ (sparc.ori as dest `(lo ,i) dest)))
+ (if (not (hardware-mapped? r))
+ (emit-store-reg! as r dest))))
+
+
+; Reference the constants vector and put the constant reference in a register.
+; `offset' is an integer offset into the constants vector (a constant) for
+; the current procedure.
+; Destroys $r.tmp0 and $r.tmp1, but either can be the destination register.
+; (CONST, for structured constants, GLOBAL, SETGLBL, LAMBDA).
+
+(define (emit-const->register! as offset r)
+ (let ((cvlabel (+ 4 (- (* offset 4) $tag.vector-tag))))
+ (cond ((hardware-mapped? r)
+ (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (if (asm:fits? cvlabel 13)
+ (sparc.ldi as $r.tmp0 cvlabel r)
+ (begin (sparc.sethi as `(hi ,cvlabel) $r.tmp1)
+ (sparc.addr as $r.tmp0 $r.tmp1 $r.tmp0)
+ (sparc.ldi as $r.tmp0 `(lo ,cvlabel) r))))
+ (else
+ (emit-const->register! as offset $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)))))
+
+
+
+; Emit single instruction to load sw-mapped reg into another reg, and return
+; the destination reg.
+
+(define (emit-load-reg! as from to)
+ (if (or (hardware-mapped? from) (not (hardware-mapped? to)))
+ (asm-error "emit-load-reg: " from to)
+ (begin (sparc.ldi as $r.globals (swreg-global-offset from) to)
+ to)))
+
+(define (emit-store-reg! as from to)
+ (if (or (not (hardware-mapped? from)) (hardware-mapped? to))
+ (asm-error "emit-store-reg: " from to)
+ (begin (sparc.sti as from (swreg-global-offset to) $r.globals)
+ to)))
+
+; Generic move-reg-to-HW-reg
+
+(define (emit-move2hwreg! as from to)
+ (if (hardware-mapped? from)
+ (sparc.move as from to)
+ (emit-load-reg! as from to))
+ to)
+
+; Evaluation of condition code for value or control.
+;
+; branchf.a is an annulled conditional branch that tests the condition codes
+; and branches if some condition is false.
+; rd is #f or a hardware register.
+; target is #f or a label.
+; Exactly one of rd and target must be #f.
+;
+; (Why isn't this split into two separate procedures? Because dozens of
+; this procedure's callers have the value/control duality, and it saves
+; space to put the test here instead of putting it in each caller.)
+
+(define (emit-evaluate-cc! as branchf.a rd target)
+ (if target
+ (begin (branchf.a as target)
+ (sparc.slot as))
+ (let ((target (new-label)))
+ (branchf.a as target)
+ (sparc.set as $imm.false rd)
+ (sparc.set as $imm.true rd)
+ (sparc.label as target))))
+
+; Code for runtime safety checking.
+
+(define (emit-check! as rs0 L1 liveregs)
+ (sparc.cmpi as rs0 $imm.false)
+ (emit-checkcc! as sparc.be L1 liveregs))
+
+; FIXME: This should call the exception handler for non-continuable exceptions.
+
+(define (emit-trap! as rs1 rs2 rs3 exn)
+ (if (not (= rs3 $r.reg0))
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ (if (not (= rs2 $r.reg0))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (if (not (= rs1 $r.reg0))
+ (emit-move2hwreg! as rs1 $r.result))
+ (millicode-call/numarg-in-reg as $m.exception (thefixnum exn) $r.tmp0))
+
+; Given:
+; an annulled conditional branch that branches
+; if the check is ok
+; a non-annulled conditional branch that branches
+; if the check is not ok
+; #f, or a procedure that takes an assembly segment as
+; argument and emits an instruction that goes into
+; the delay slot of either branch
+; three registers whose contents should be passed to the
+; exception handler if the check is not ok
+; the exception code
+; Emits code to call the millicode exception routine with
+; the given exception code if the condition is false.
+;
+; FIXME: The nop can often be replaced by the instruction that
+; follows it.
+
+(begin
+ '
+(define (emit-checkcc-and-fill-slot!
+ as branch-ok.a branch-bad slot-filler L1)
+ (let* ((situation (list exn rs1 rs2 rs3))
+ (L1 (exception-label as situation)))
+ (if L1
+ (begin (branch-bad as L1)
+ (if slot-filler
+ (slot-filler as)
+ (sparc.nop as)))
+ (let* ((L1 (new-label))
+ (L2 (new-label)))
+ (exception-label-set! as situation L1)
+ (branch-ok.a as L2)
+ (if slot-filler
+ (slot-filler as)
+ (sparc.slot as))
+ (sparc.label as L1)
+ (cond ((= rs3 $r.reg0)
+ #f)
+ ((hardware-mapped? $r.argreg3)
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ ((hardware-mapped? rs3)
+ (emit-store-reg! as rs3 $r.argreg3))
+ (else
+ (emit-move2hwreg! as rs3 $r.tmp0)
+ (emit-store-reg! as $r.tmp0 $r.argreg3)))
+ (if (not (= rs2 $r.reg0))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (if (not (= rs1 $r.reg0))
+ (emit-move2hwreg! as rs1 $r.result))
+ ; FIXME: This should be a non-continuable exception.
+ (sparc.jmpli as $r.millicode $m.exception $r.o7)
+ (emit-immediate->register! as (thefixnum exn) $r.tmp0)
+ (sparc.label as L2)))))
+#f
+)
+
+(define (emit-checkcc! as branch-bad L1 liveregs)
+ (branch-bad as L1)
+ (apply sparc.slot2 as liveregs))
+
+; Generation of millicode calls for non-continuable exceptions.
+
+(begin
+ '
+; To create only one millicode call per code segment per non-continuable
+; exception situation, we use the "as-user" feature of assembly segments.
+; Could use a hash table here.
+
+(define (exception-label as situation)
+ (let ((user-data (as-user as)))
+ (if user-data
+ (let ((exception-labels (assq 'exception-labels user-data)))
+ (if exception-labels
+ (let ((probe (assoc situation (cdr exception-labels))))
+ (if probe
+ (cdr probe)
+ #f))
+ #f))
+ #f)))
+'
+(define (exception-label-set! as situation label)
+ (let ((user-data (as-user as)))
+ (if user-data
+ (let ((exception-labels (assq 'exception-labels user-data)))
+ (if exception-labels
+ (let ((probe (assoc situation (cdr exception-labels))))
+ (if probe
+ (error "COMPILER BUG: Exception situation defined twice")
+ (set-cdr! exception-labels
+ (cons (cons situation label)
+ (cdr exception-labels)))))
+ (begin (as-user! as
+ (cons (list 'exception-labels)
+ user-data))
+ (exception-label-set! as situation label))))
+ (begin (as-user! as '())
+ (exception-label-set! as situation label)))))
+#f
+)
+
+; Millicode calling
+
+(define (millicode-call/0arg as mproc)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.nop as))
+
+(define (millicode-call/1arg as mproc r)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as r $r.argreg2))
+
+(define (millicode-call/1arg-in-result as mproc r)
+ (millicode-call/1arg-in-reg as mproc r $r.result))
+
+(define (millicode-call/1arg-in-reg as mproc rs rd)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as rs rd))
+
+(define (millicode-call/numarg-in-result as mproc num)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.set as num $r.result))
+
+(define (millicode-call/numarg-in-reg as mproc num reg)
+ (if (not (hardware-mapped? reg))
+ (asm-error "millicode-call/numarg-in-reg requires HW register: " reg))
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.set as num reg))
+
+(define (millicode-call/2arg as mproc r1 r2)
+ (emit-move2hwreg! as r1 $r.argreg2)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as r2 $r.argreg3))
+
+; NOTE: Don't use TMP0 since TMP0 is sometimes a millicode argument
+; register (for example to m_exception).
+;
+; NOTE: Don't use sparc.set rather than sethi/ori; we need to know that
+; two instructions get generated.
+;
+; FIXME: Should calculate the value if possible to get better precision
+; and to avoid generating a fixup. See emit-return-address! in gen-msi.sch.
+
+(define (millicode-call/ret as mproc label)
+ (cond ((short-effective-addresses)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.addi as $r.o7 `(- ,label (- ,(here as) 4) 8) $r.o7))
+ (else
+ (let ((val `(- ,label (+ ,(here as) 8) 8)))
+ (sparc.sethi as `(hi ,val) $r.tmp1)
+ (sparc.ori as $r.tmp1 `(lo ,val) $r.tmp1)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.addr as $r.o7 $r.tmp1 $r.o7)))))
+
+(define (check-timer as DESTINATION RETRY)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as DESTINATION)
+ (sparc.slot as)
+ (millicode-call/ret as $m.timer-exception RETRY))
+
+; When the destination and retry labels are the same, and follow the
+; timer check immediately, then this code saves two static instructions.
+
+(define (check-timer0 as)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as (+ (here as) 16))
+ (sparc.slot as)
+ (sparc.jmpli as $r.millicode $m.timer-exception $r.o7)
+ (sparc.nop as))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC machine assembler.
+;
+; The procedure `sparc-instruction' takes an instruction class keyword and
+; some operands and returns an assembler procedure for the instruction
+; denoted by the class and the operands.
+;
+; All assembler procedures for SPARC mnemonics are defined in sparcasm2.sch.
+;
+; The SPARC has 32-bit, big-endian words. All instructions are 1 word.
+; This assembler currently accepts a subset of the SPARC v8 instruction set.
+;
+; Each assembler procedure takes an `as' assembly structure (see
+; Asm/Common/pass5p1.sch) and operands relevant to the instruction, and
+; side-effects the assembly structure by emitting bits for the instruction
+; and any necessary fixups. There are separate instruction mnemonics and
+; assembler procedures for instructions which in the SPARC instruction set
+; are normally considered the "same". For example, the `add' instruction is
+; split into two operations here: `sparc.addr' takes a register as operand2,
+; and `sparc.addi' takes an immediate. We could remove this restriction
+; by using objects with identity rather than numbers for registers, but it
+; does not seem to be an important problem.
+;
+; Operands that denote values (addresses, immediates, offsets) may be
+; expressed using symbolic expressions. These expressions must conform
+; to the following grammar:
+;
+; <expr> --> ( <number> . <obj> ) ; label
+; | <number> ; literal value (exact integer)
+; | (+ <expr> ... ) ; sum
+; | (- <expr> ... ) ; difference
+; | (hi <expr>) ; high 22 bits
+; | (lo <expr>) ; low 10 bits
+;
+; Each assembler procedure will check that its value operand(s) fit in
+; their instruction fields. It is a fatal error for an operand not
+; to fit, and the assembler calls `asm-error' to signal this error.
+; However, in some cases the assembler will instead call the error
+; procedure `asm-value-too-large', which allows the higher-level assembler
+; to retry the assembly with different settings (typically, by splitting
+; a jump instruction into an offset calculation and a jump).
+;
+; Note: the idiom that is seen in this file,
+; (emit-fixup-proc! as (lambda (b l) (fixup b l)))
+; when `fixup' is a local procedure, avoids allocation of the closure
+; except in the cases where the fixup is in fact needed, for gains in
+; speed and reduction in allocation. (Ask me if you want numbers.)
+;
+; If FILL-DELAY-SLOTS returns true, then this assembler supports two
+; distinct mechanisms for filling branch delay slots.
+;
+; An annulled conditional branch or an un-annulled unconditional branch
+; may be followed by the strange instruction SPARC.SLOT, which turns into
+; a nop in the delay slot that may be replaced by copying the instruction
+; at the target of the branch into the delay slot and increasing the branch
+; offset by 4.
+;
+; An un-annulled conditional branch whose target depends upon a known set
+; of general registers, and does not depend upon the condition codes, may
+; be followed by the strange instruction SPARC.SLOT2, which takes any
+; number of registers as operands. This strange instruction turns into
+; nothing at all if the following instruction has no side effects except
+; to the condition codes and/or to a destination register that is distinct
+; from the specified registers plus the stack pointer and %o7; otherwise
+; the SPARC.SLOT2 instruction becomes a nop in the delay slot. The
+; implementation of this uses a buffer that must be cleared when a label
+; is emitted or when the current offset is obtained.
+
+(define sparc-instruction)
+
+(let ((original-emit-label! emit-label!)
+ (original-here here))
+ (set! emit-label!
+ (lambda (as L)
+ (assembler-value! as 'slot2-info #f)
+ (original-emit-label! as L)))
+ (set! here
+ (lambda (as)
+ (assembler-value! as 'slot2-info #f)
+ (original-here as)))
+ 'emit-label!)
+
+(let ((emit! (lambda (as bits)
+ (assembler-value! as 'slot2-info #f)
+ (emit! as bits)))
+ (emit-fixup-proc! (lambda (as proc)
+ (assembler-value! as 'slot2-info #f)
+ (emit-fixup-proc! as proc)))
+ (goes-in-delay-slot2? (lambda (as rd)
+ (let ((regs (assembler-value as 'slot2-info)))
+ (and regs
+ (fill-delay-slots)
+ (not (= rd $r.stkp))
+ (not (= rd $r.o7))
+ (not (memv rd regs)))))))
+
+ (define ibit (asm:bv 0 0 #x20 0)) ; immediate bit: 2^13
+ (define abit (asm:bv #x20 0 0 0)) ; annul bit: 2^29
+ (define zero (asm:bv 0 0 0 0)) ; all zero bits
+
+ (define two^32 (expt 2 32))
+
+ ; Constant expression evaluation. If the expression cannot be
+ ; evaluated, eval-expr returns #f, otherwise a number.
+ ; The symbol table lookup must fail by returning #f.
+
+ (define (eval-expr as e)
+
+ (define (complement x)
+ (modulo (+ two^32 x) two^32))
+
+ (define (hibits e)
+ (cond ((not e) e)
+ ((< e 0)
+ (complement (quotient (complement e) 1024)))
+ (else
+ (quotient e 1024))))
+
+ (define (lobits e)
+ (cond ((not e) e)
+ ((< e 0)
+ (remainder (complement e) 1024))
+ (else
+ (remainder e 1024))))
+
+ (define (evaluate e)
+ (cond ((integer? e) e)
+ ((label? e) (label-value as e))
+ ((eq? 'hi (car e)) (hibits (evaluate (cadr e))))
+ ((eq? 'lo (car e)) (lobits (evaluate (cadr e))))
+ ((eq? '+ (car e))
+ (let loop ((e (cdr e)) (s 0))
+ (if (null? e) s
+ (let ((op (evaluate (car e))))
+ (if (not op) op
+ (loop (cdr e) (+ s op)))))))
+ ((eq? '- (car e))
+ (let loop ((e (cdr e)) (d #f))
+ (if (null? e) d
+ (let ((op (evaluate (car e))))
+ (if (not op) op
+ (loop (cdr e) (if d (- d op) op)))))))
+ (else
+ (signal-error 'badexpr e))))
+
+ (evaluate e))
+
+ ; Common error handling.
+
+ (define (signal-error code . rest)
+ (define msg "SPARC assembler: ")
+ (case code
+ ((badexpr)
+ (asm-error msg "invalid expression " (car rest)))
+ ((toolarge)
+ (asm-error msg "value too large in " (car rest) ": "
+ (cadr rest) " = " (caddr rest)))
+ ((fixup)
+ (asm-error msg "fixup failed in " (car rest) " for " (cadr rest)))
+ ((unaligned)
+ (asm-error msg "unaligned target in " (car rest) ": " (cadr rest)))
+ (else
+ (error "Invalid error code in assembler: " code))))
+
+ ; The following procedures construct instructions by depositing field
+ ; values directly into bytevectors; the location parameter in the dep-*!
+ ; procedures is the address in the bytevector of the most significant byte.
+
+ (define (copy! bv k bits)
+ (bytevector-set! bv k (bytevector-ref bits 0))
+ (bytevector-set! bv (+ k 1) (bytevector-ref bits 1))
+ (bytevector-set! bv (+ k 2) (bytevector-ref bits 2))
+ (bytevector-set! bv (+ k 3) (bytevector-ref bits 3))
+ bv)
+
+ (define (copy bits)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-set! bv 0 (bytevector-ref bits 0))
+ (bytevector-set! bv 1 (bytevector-ref bits 1))
+ (bytevector-set! bv 2 (bytevector-ref bits 2))
+ (bytevector-set! bv 3 (bytevector-ref bits 3))
+ bv))
+
+ (define (copy-instr bv from to)
+ (bytevector-set! bv to (bytevector-ref bv from))
+ (bytevector-set! bv (+ to 1) (bytevector-ref bv (+ from 1)))
+ (bytevector-set! bv (+ to 2) (bytevector-ref bv (+ from 2)))
+ (bytevector-set! bv (+ to 3) (bytevector-ref bv (+ from 3))))
+
+ (define (dep-rs1! bits k rs1)
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (rshl rs1 2)))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (lsh (logand rs1 3) 6))))
+
+ (define (dep-rs2! bits k rs2)
+ (bytevector-set! bits (+ k 3)
+ (logior (bytevector-ref bits (+ k 3)) rs2)))
+
+ (define (dep-rd! bits k rd)
+ (bytevector-set! bits k
+ (logior (bytevector-ref bits k) (lsh rd 1))))
+
+ (define (dep-imm! bits k imm)
+ (cond ((fixnum? imm)
+ (bytevector-set! bits (+ k 3) (logand imm 255))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (logand (rsha imm 8) 31))))
+ ((bytevector? imm)
+ (bytevector-set! bits (+ k 3) (bytevector-ref imm 0))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (logand (bytevector-ref imm 1)
+ 31))))
+ (else
+ (dep-imm! bits k (asm:int->bv imm)))))
+
+ (define (dep-branch-offset! bits k offs)
+ (cond ((fixnum? offs)
+ (if (not (= (logand offs 3) 0))
+ (signal-error 'unaligned "branch" offs))
+ (dep-imm22! bits k (rsha offs 2)))
+ ((bytevector? offs)
+ (if (not (= (logand (bytevector-ref offs 3) 3) 0))
+ (signal-error 'unaligned "branch" (asm:bv->int offs)))
+ (dep-imm22! bits k (asm:rsha offs 2)))
+ (else
+ (dep-branch-offset! bits k (asm:int->bv offs)))))
+
+ (define (dep-imm22! bits k imm)
+ (cond ((fixnum? imm)
+ (bytevector-set! bits (+ k 3) (logand imm 255))
+ (bytevector-set! bits (+ k 2)
+ (logand (rsha imm 8) 255))
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (logand (rsha imm 16) 63))))
+ ((bytevector? imm)
+ (bytevector-set! bits (+ k 3) (bytevector-ref imm 3))
+ (bytevector-set! bits (+ k 2) (bytevector-ref imm 2))
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (logand (bytevector-ref imm 1)
+ 63))))
+ (else
+ (dep-imm22! bits k (asm:int->bv imm)))))
+
+ (define (dep-call-offset! bits k offs)
+ (cond ((fixnum? offs)
+ (if (not (= (logand offs 3) 0))
+ (signal-error 'unaligned "call" offs))
+ (bytevector-set! bits (+ k 3) (logand (rsha offs 2) 255))
+ (bytevector-set! bits (+ k 2) (logand (rsha offs 10) 255))
+ (bytevector-set! bits (+ k 1) (logand (rsha offs 18) 255))
+ (bytevector-set! bits k (logior (bytevector-ref bits k)
+ (logand (rsha offs 26) 63))))
+ ((bytevector? offs)
+ (if (not (= (logand (bytevector-ref offs 3) 3) 0))
+ (signal-error 'unaligned "call" (asm:bv->int offs)))
+ (let ((offs (asm:rsha offs 2)))
+ (bytevector-set! bits (+ k 3) (bytevector-ref offs 3))
+ (bytevector-set! bits (+ k 2) (bytevector-ref offs 2))
+ (bytevector-set! bits (+ k 1) (bytevector-ref offs 1))
+ (bytevector-set! bits k (logior (bytevector-ref bits k)
+ (logand (bytevector-ref offs 0)
+ 63)))))
+ (else
+ (dep-call-offset! bits k (asm:int->bv offs)))))
+
+ ; Add 1 to an instruction (to bump a branch offset by 4).
+ ; FIXME: should check for field overflow.
+
+ (define (add1 bv loc)
+ (let* ((r0 (+ (bytevector-ref bv (+ loc 3)) 1))
+ (d0 (logand r0 255))
+ (c0 (rshl r0 8)))
+ (bytevector-set! bv (+ loc 3) d0)
+ (let* ((r1 (+ (bytevector-ref bv (+ loc 2)) c0))
+ (d1 (logand r1 255))
+ (c1 (rshl r1 8)))
+ (bytevector-set! bv (+ loc 2) d1)
+ (let* ((r2 (+ (bytevector-ref bv (+ loc 1)) c1))
+ (d2 (logand r2 255)))
+ (bytevector-set! bv (+ loc 1) d2)))))
+
+ ; For delay slot filling -- uses the assembler value scratchpad in
+ ; the as structure. Delay slot filling is discussed in the comments
+ ; for `branch' and `class-slot', below.
+
+ (define (remember-branch-target as obj)
+ (assembler-value! as 'branch-target obj))
+
+ (define (recover-branch-target as)
+ (assembler-value as 'branch-target))
+
+ ; Mark the instruction at the current address as not being eligible
+ ; for being lifted into a branch delay slot.
+ ;
+ ; FIXME: should perhaps be a hash table; see BOOT-STATUS file for details.
+
+ (define (not-a-delay-slot-instruction as)
+ (assembler-value! as 'not-dsi
+ (cons (here as)
+ (or (assembler-value as 'not-dsi) '()))))
+
+ (define (is-a-delay-slot-instruction? as bv addr)
+ (and (not (memv addr (or (assembler-value as 'not-dsi) '())))
+ (< addr (bytevector-length bv))))
+
+ ; SETHI, etc.
+
+ (define (class-sethi bits)
+ (let ((bits (asm:lsh bits 22)))
+ (lambda (as val rd)
+
+ (define (fixup bv loc)
+ (dep-imm22! bv loc
+ (or (eval-expr as val)
+ (signal-error 'fixup "sethi" val))))
+
+ (define (fixup2 bv loc)
+ (copy! bv loc bits)
+ (dep-rd! bv loc rd)
+ (fixup bv loc))
+
+ (if (goes-in-delay-slot2? as rd)
+ (emit-fixup-proc! as
+ (lambda (b l)
+ (fixup2 b (- l 4))))
+
+ (let ((bits (copy bits))
+ (e (eval-expr as val)))
+ (if e
+ (dep-imm22! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (dep-rd! bits 0 rd)
+ (emit! as bits))))))
+
+ ; NOP is a peculiar sethi
+
+ (define (class-nop i)
+ (let ((instr (class-sethi i)))
+ (lambda (as)
+ (instr as 0 $r.g0))))
+
+
+ ; Branches
+
+ (define (class00b i) (branch #b010 i zero)) ; Un-annulled IU branches.
+ (define (class00a i) (branch #b010 i abit)) ; Annulled IU branches.
+ (define (classf00b i) (branch #b110 i zero)) ; Un-annulled FP branches.
+ (define (classf00a i) (branch #b110 i abit)) ; Annulled FP branches.
+
+ ; The `type' parameter is #b010 for IU branches, #b110 for FP branches.
+ ; The `bits' parameter is the bits for the cond field.
+ ; The `annul' parameter is either `zero' or `abit' (see top of file).
+ ;
+ ; Annuled branches require special treatement for delay slot
+ ; filling based on the `slot' pseudo-instruction.
+ ;
+ ; Strategy: when a branch with the annul bit set is assembled, remember
+ ; its target in a one-element cache in the AS structure. When a slot
+ ; instruction is found (it has its own class) then the cached
+ ; value (possibly a delayed expression) is gotten, and a fixup for the
+ ; slot is registered. When the fixup is later evaluated, the branch
+ ; target instruction can be found, examined, and evaluated.
+ ;
+ ; The cached value is always valid when the slot instruction is assembled,
+ ; because a slot instruction is always directly preceded by an annulled
+ ; branch (which will always set the cache).
+
+ (define (branch type bits annul)
+ ; The delay slot should be filled if this is an annulled branch
+ ; or an unconditional branch.
+ (let ((fill-delay-slot? (or (not (eq? annul zero))
+ (eq? bits #b1000)))
+ (bits (asm:logior (asm:lsh bits 25) (asm:lsh type 22) annul)))
+ (lambda (as target0)
+ (let ((target `(- ,target0 ,(here as))))
+
+ (define (expr)
+ (let ((e (eval-expr as target)))
+ (cond ((not e)
+ e)
+ ((not (zero? (logand e 3)))
+ (signal-error 'unaligned "branch" target0))
+ ((asm:fits? e 24)
+ e)
+ (else
+ (asm-value-too-large as "branch" target e)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-branch-offset! bv loc e)
+ (signal-error 'fixup "branch" target0))))
+
+ (if fill-delay-slot?
+ (remember-branch-target as target0)
+ (remember-branch-target as #f)) ; Clears the cache.
+ (not-a-delay-slot-instruction as)
+ (let ((bits (copy bits))
+ (e (expr)))
+ (if e
+ (dep-branch-offset! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits))))))
+
+ ; Branch delay slot pseudo-instruction.
+ ;
+ ; Get the branch target expression from the cache in the AS structure,
+ ; and if it is not #f, register a fixup procedure for the delay slot that
+ ; will copy the target instruction to the slot and add 4 to the branch
+ ; offset (unless that will overflow the offset or the instruction at the
+ ; target is not suitable for lifting).
+ ;
+ ; It's important that this fixup run _after_ any fixups for the branch
+ ; instruction itself!
+
+ (define (class-slot)
+ (let ((nop-instr (class-nop #b100)))
+ (lambda (as)
+
+ ; The branch target is the expression denoting the target location.
+
+ (define branch-target (recover-branch-target as))
+
+ (define (fixup bv loc)
+ (let ((bt (or (eval-expr as branch-target)
+ (asm-error "Branch fixup: can't happen: "
+ branch-target))))
+ (if (is-a-delay-slot-instruction? as bv bt)
+ (begin
+ (copy-instr bv bt loc)
+ (add1 bv (- loc 4))))))
+
+ (if (and branch-target (fill-delay-slots))
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (nop-instr as))))
+
+ ; Branch delay slot pseudo-instruction 2.
+ ;
+ ; Emit a nop, but record the information that will allow this nop to be
+ ; replaced by a sufficiently harmless ALU instruction.
+
+ (define (class-slot2)
+ (let ((nop-instr (class-nop #b100)))
+ (lambda (as . regs)
+ (nop-instr as)
+ (assembler-value! as 'slot2-info regs))))
+
+ ; ALU stuff, register operand, rdy, wryr. Also: jump.
+
+ (define (class10r bits . extra)
+ (cond ((and (not (null? extra)) (eq? (car extra) 'rdy))
+ (let ((op (class10r bits)))
+ (lambda (as rd)
+ (op as 0 0 rd))))
+ ((and (not (null? extra)) (eq? (car extra) 'wry))
+ (let ((op (class10r bits)))
+ (lambda (as rs)
+ (op as rs 0 0))))
+ (else
+ (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19)))
+ (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (cond (jump?
+ (not-a-delay-slot-instruction as)
+ (emit! as bits))
+ ((goes-in-delay-slot2? as rd)
+ (emit-fixup-proc!
+ as
+ (lambda (bv loc)
+ (copy! bv (- loc 4) bits))))
+ (else
+ (emit! as bits)))))))))
+
+
+ ; ALU stuff, immediate operand, wryi. Also: jump.
+
+ (define (class10i bits . extra)
+ (if (and (not (null? extra)) (eq? (car extra) 'wry))
+ (let ((op (class10i bits)))
+ (lambda (as src)
+ (op as 0 src 0)))
+ (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19) ibit))
+ (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
+ (lambda (as rs1 e rd)
+
+ (define (expr)
+ (let ((imm (eval-expr as e)))
+ (cond ((not imm)
+ imm)
+ ((asm:fits? imm 13)
+ imm)
+ (jump?
+ (asm-value-too-large as "`jmpli'" e imm))
+ (else
+ (asm-value-too-large as "ALU instruction" e imm)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-imm! bv loc e)
+ (signal-error 'fixup "ALU instruction" e))))
+
+ (let ((bits (copy bits))
+ (e (expr)))
+ (if e
+ (dep-imm! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (dep-rs1! bits 0 rs1)
+ (dep-rd! bits 0 rd)
+ (cond (jump?
+ (not-a-delay-slot-instruction as)
+ (emit! as bits))
+ ((goes-in-delay-slot2? as rd)
+ (emit-fixup-proc!
+ as
+ (lambda (bv loc)
+ (copy! bv (- loc 4) bits))))
+ (else
+ (emit! as bits))))))))
+
+ ; Memory stuff, register operand.
+
+ (define (class11r bits)
+ (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (emit! as bits)))))
+
+ ; Memory stuff, immediate operand.
+
+ (define (class11i bits)
+ (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19) ibit)))
+ (lambda (as rs1 e rd)
+
+ (define (expr)
+ (let ((imm (eval-expr as e)))
+ (cond ((not imm) imm)
+ ((asm:fits? imm 13) imm)
+ (else
+ (signal-error 'toolarge "Memory instruction" e imm)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-imm! bv loc e)
+ (signal-error 'fixup "Memory instruction" e))))
+
+ (let ((bits (copy bits))
+ (e (expr)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rd! bits 0 rd)
+ (if e
+ (dep-imm! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits)))))
+
+ ; For store instructions. The syntax is (st a b c) meaning m[ b+c ] <- a.
+ ; However, on the Sparc, the destination (rd) field is the source of
+ ; a store, so we transform the instruction into (st c b a) and pass it
+ ; to the real store procedure.
+
+ (define (class11sr bits)
+ (let ((store-instr (class11r bits)))
+ (lambda (as a b c)
+ (store-instr as c b a))))
+
+ (define (class11si bits)
+ (let ((store-instr (class11i bits)))
+ (lambda (as a b c)
+ (store-instr as c b a))))
+
+ ; Call is a class all by itself.
+
+ (define (class-call)
+ (let ((code (asm:lsh #b01 30)))
+ (lambda (as target0)
+ (let ((target `(- ,target0 ,(here as))))
+
+ (define (fixup bv loc)
+ (let ((e (eval-expr as target)))
+ (if e
+ (dep-call-offset! bv loc e)
+ (signal-error 'fixup "call" target0))))
+
+ (let ((bits (copy code))
+ (e (eval-expr as target)))
+ (not-a-delay-slot-instruction as)
+ (if e
+ (dep-call-offset! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits))))))
+
+ (define (class-label)
+ (lambda (as label)
+ (emit-label! as label)))
+
+ ; FP operation, don't set CC.
+
+ (define (class-fpop1 i) (fpop #b110100 i))
+
+ ; FP operation, set CC
+
+ (define (class-fpop2 i) (fpop #b110101 i))
+
+ (define (fpop type opf)
+ (let ((bits (asm:logior (asm:lsh #b10 30)
+ (asm:lsh type 19)
+ (asm:lsh opf 5))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (emit! as bits)))))
+
+ (set! sparc-instruction
+ (lambda (kwd . ops)
+ (case kwd
+ ((i11) (apply class11i ops))
+ ((r11) (apply class11r ops))
+ ((si11) (apply class11si ops))
+ ((sr11) (apply class11sr ops))
+ ((sethi) (apply class-sethi ops))
+ ((r10) (apply class10r ops))
+ ((i10) (apply class10i ops))
+ ((b00) (apply class00b ops))
+ ((a00) (apply class00a ops))
+ ((call) (apply class-call ops))
+ ((label) (apply class-label ops))
+ ((nop) (apply class-nop ops))
+ ((slot) (apply class-slot ops))
+ ((slot2) (apply class-slot2 ops))
+ ((fb00) (apply classf00b ops))
+ ((fa00) (apply classf00a ops))
+ ((fp) (apply class-fpop1 ops))
+ ((fpcc) (apply class-fpop2 ops))
+ (else
+ (asm-error "sparc-instruction: unrecognized class: " kwd)))))
+ 'sparc-instruction)
+
+; eof
+; Instruction mnemonics
+
+(define sparc.lddi (sparc-instruction 'i11 #b000011))
+(define sparc.lddr (sparc-instruction 'r11 #b000011))
+(define sparc.ldi (sparc-instruction 'i11 #b000000))
+(define sparc.ldr (sparc-instruction 'r11 #b000000))
+(define sparc.ldhi (sparc-instruction 'i11 #b000010))
+(define sparc.ldhr (sparc-instruction 'r11 #b000010))
+(define sparc.ldbi (sparc-instruction 'i11 #b000001))
+(define sparc.ldbr (sparc-instruction 'r11 #b000001))
+(define sparc.lddfi (sparc-instruction 'i11 #b100011))
+(define sparc.lddfr (sparc-instruction 'r11 #b100011))
+(define sparc.stdi (sparc-instruction 'si11 #b000111))
+(define sparc.stdr (sparc-instruction 'sr11 #b000111))
+(define sparc.sti (sparc-instruction 'si11 #b000100))
+(define sparc.str (sparc-instruction 'sr11 #b000100))
+(define sparc.sthi (sparc-instruction 'si11 #b000110))
+(define sparc.sthr (sparc-instruction 'sr11 #b000110))
+(define sparc.stbi (sparc-instruction 'si11 #b000101))
+(define sparc.stbr (sparc-instruction 'sr11 #b000101))
+(define sparc.stdfi (sparc-instruction 'si11 #b100111))
+(define sparc.stdfr (sparc-instruction 'sr11 #b100111))
+(define sparc.sethi (sparc-instruction 'sethi #b100))
+(define sparc.andr (sparc-instruction 'r10 #b000001))
+(define sparc.andrcc (sparc-instruction 'r10 #b010001))
+(define sparc.andi (sparc-instruction 'i10 #b000001))
+(define sparc.andicc (sparc-instruction 'i10 #b010001))
+(define sparc.orr (sparc-instruction 'r10 #b000010))
+(define sparc.orrcc (sparc-instruction 'r10 #b010010))
+(define sparc.ori (sparc-instruction 'i10 #b000010))
+(define sparc.oricc (sparc-instruction 'i10 #b010010))
+(define sparc.xorr (sparc-instruction 'r10 #b000011))
+(define sparc.xorrcc (sparc-instruction 'r10 #b010011))
+(define sparc.xori (sparc-instruction 'i10 #b000011))
+(define sparc.xoricc (sparc-instruction 'i10 #b010011))
+(define sparc.sllr (sparc-instruction 'r10 #b100101))
+(define sparc.slli (sparc-instruction 'i10 #b100101))
+(define sparc.srlr (sparc-instruction 'r10 #b100110))
+(define sparc.srli (sparc-instruction 'i10 #b100110))
+(define sparc.srar (sparc-instruction 'r10 #b100111))
+(define sparc.srai (sparc-instruction 'i10 #b100111))
+(define sparc.addr (sparc-instruction 'r10 #b000000))
+(define sparc.addrcc (sparc-instruction 'r10 #b010000))
+(define sparc.addi (sparc-instruction 'i10 #b000000))
+(define sparc.addicc (sparc-instruction 'i10 #b010000))
+(define sparc.taddrcc (sparc-instruction 'r10 #b100000))
+(define sparc.taddicc (sparc-instruction 'i10 #b100000))
+(define sparc.subr (sparc-instruction 'r10 #b000100))
+(define sparc.subrcc (sparc-instruction 'r10 #b010100))
+(define sparc.subi (sparc-instruction 'i10 #b000100))
+(define sparc.subicc (sparc-instruction 'i10 #b010100))
+(define sparc.tsubrcc (sparc-instruction 'r10 #b100001))
+(define sparc.tsubicc (sparc-instruction 'i10 #b100001))
+(define sparc.smulr (sparc-instruction 'r10 #b001011))
+(define sparc.smulrcc (sparc-instruction 'r10 #b011011))
+(define sparc.smuli (sparc-instruction 'i10 #b001011))
+(define sparc.smulicc (sparc-instruction 'i10 #b011011))
+(define sparc.sdivr (sparc-instruction 'r10 #b001111))
+(define sparc.sdivrcc (sparc-instruction 'r10 #b011111))
+(define sparc.sdivi (sparc-instruction 'i10 #b001111))
+(define sparc.sdivicc (sparc-instruction 'i10 #b011111))
+(define sparc.b (sparc-instruction 'b00 #b1000))
+(define sparc.b.a (sparc-instruction 'a00 #b1000))
+(define sparc.bne (sparc-instruction 'b00 #b1001))
+(define sparc.bne.a (sparc-instruction 'a00 #b1001))
+(define sparc.be (sparc-instruction 'b00 #b0001))
+(define sparc.be.a (sparc-instruction 'a00 #b0001))
+(define sparc.bg (sparc-instruction 'b00 #b1010))
+(define sparc.bg.a (sparc-instruction 'a00 #b1010))
+(define sparc.ble (sparc-instruction 'b00 #b0010))
+(define sparc.ble.a (sparc-instruction 'a00 #b0010))
+(define sparc.bge (sparc-instruction 'b00 #b1011))
+(define sparc.bge.a (sparc-instruction 'a00 #b1011))
+(define sparc.bl (sparc-instruction 'b00 #b0011))
+(define sparc.bl.a (sparc-instruction 'a00 #b0011))
+(define sparc.bgu (sparc-instruction 'b00 #b1100))
+(define sparc.bgu.a (sparc-instruction 'a00 #b1100))
+(define sparc.bleu (sparc-instruction 'b00 #b0100))
+(define sparc.bleu.a (sparc-instruction 'a00 #b0100))
+(define sparc.bcc (sparc-instruction 'b00 #b1101))
+(define sparc.bcc.a (sparc-instruction 'a00 #b1101))
+(define sparc.bcs (sparc-instruction 'b00 #b0101))
+(define sparc.bcs.a (sparc-instruction 'a00 #b0101))
+(define sparc.bpos (sparc-instruction 'b00 #b1110))
+(define sparc.bpos.a (sparc-instruction 'a00 #b1110))
+(define sparc.bneg (sparc-instruction 'b00 #b0110))
+(define sparc.bneg.a (sparc-instruction 'a00 #b0110))
+(define sparc.bvc (sparc-instruction 'b00 #b1111))
+(define sparc.bvc.a (sparc-instruction 'a00 #b1111))
+(define sparc.bvs (sparc-instruction 'b00 #b0111))
+(define sparc.bvs.a (sparc-instruction 'a00 #b0111))
+(define sparc.call (sparc-instruction 'call))
+(define sparc.jmplr (sparc-instruction 'r10 #b111000 'jump))
+(define sparc.jmpli (sparc-instruction 'i10 #b111000 'jump))
+(define sparc.nop (sparc-instruction 'nop #b100))
+(define sparc.ornr (sparc-instruction 'r10 #b000110))
+(define sparc.orni (sparc-instruction 'i10 #b000110))
+(define sparc.ornrcc (sparc-instruction 'r10 #b010110))
+(define sparc.ornicc (sparc-instruction 'i10 #b010110))
+(define sparc.andni (sparc-instruction 'i10 #b000101))
+(define sparc.andnr (sparc-instruction 'r10 #b000101))
+(define sparc.andnicc (sparc-instruction 'i10 #b010101))
+(define sparc.andnrcc (sparc-instruction 'r10 #b010101))
+(define sparc.rdy (sparc-instruction 'r10 #b101000 'rdy))
+(define sparc.wryr (sparc-instruction 'r10 #b110000 'wry))
+(define sparc.wryi (sparc-instruction 'i10 #b110000 'wry))
+(define sparc.fb (sparc-instruction 'fb00 #b1000))
+(define sparc.fb.a (sparc-instruction 'fa00 #b1000))
+(define sparc.fbn (sparc-instruction 'fb00 #b0000))
+(define sparc.fbn.a (sparc-instruction 'fa00 #b0000))
+(define sparc.fbu (sparc-instruction 'fb00 #b0111))
+(define sparc.fbu.a (sparc-instruction 'fa00 #b0111))
+(define sparc.fbg (sparc-instruction 'fb00 #b0110))
+(define sparc.fbg.a (sparc-instruction 'fa00 #b0110))
+(define sparc.fbug (sparc-instruction 'fb00 #b0101))
+(define sparc.fbug.a (sparc-instruction 'fa00 #b0101))
+(define sparc.fbl (sparc-instruction 'fb00 #b0100))
+(define sparc.fbl.a (sparc-instruction 'fa00 #b0100))
+(define sparc.fbul (sparc-instruction 'fb00 #b0011))
+(define sparc.fbul.a (sparc-instruction 'fa00 #b0011))
+(define sparc.fblg (sparc-instruction 'fb00 #b0010))
+(define sparc.fblg.a (sparc-instruction 'fa00 #b0010))
+(define sparc.fbne (sparc-instruction 'fb00 #b0001))
+(define sparc.fbne.a (sparc-instruction 'fa00 #b0001))
+(define sparc.fbe (sparc-instruction 'fb00 #b1001))
+(define sparc.fbe.a (sparc-instruction 'fa00 #b1001))
+(define sparc.fbue (sparc-instruction 'fb00 #b1010))
+(define sparc.fbue.a (sparc-instruction 'fa00 #b1010))
+(define sparc.fbge (sparc-instruction 'fb00 #b1011))
+(define sparc.fbge.a (sparc-instruction 'fa00 #b1011))
+(define sparc.fbuge (sparc-instruction 'fb00 #b1100))
+(define sparc.fbuge.a (sparc-instruction 'fa00 #b1100))
+(define sparc.fble (sparc-instruction 'fb00 #b1101))
+(define sparc.fble.a (sparc-instruction 'fa00 #b1101))
+(define sparc.fbule (sparc-instruction 'fb00 #b1110))
+(define sparc.fbule.a (sparc-instruction 'fa00 #b1110))
+(define sparc.fbo (sparc-instruction 'fb00 #b1111))
+(define sparc.fbo.a (sparc-instruction 'fa00 #b1111))
+(define sparc.faddd (sparc-instruction 'fp #b001000010))
+(define sparc.fsubd (sparc-instruction 'fp #b001000110))
+(define sparc.fmuld (sparc-instruction 'fp #b001001010))
+(define sparc.fdivd (sparc-instruction 'fp #b001001110))
+(define sparc%fnegs (sparc-instruction 'fp #b000000101)) ; See below
+(define sparc%fmovs (sparc-instruction 'fp #b000000001)) ; See below
+(define sparc%fabss (sparc-instruction 'fp #b000001001)) ; See below
+(define sparc%fcmpdcc (sparc-instruction 'fpcc #b001010010)) ; See below
+
+; Strange instructions.
+
+(define sparc.slot (sparc-instruction 'slot))
+(define sparc.slot2 (sparc-instruction 'slot2))
+(define sparc.label (sparc-instruction 'label))
+
+; Aliases.
+
+(define sparc.bnz sparc.bne)
+(define sparc.bnz.a sparc.bne.a)
+(define sparc.bz sparc.be)
+(define sparc.bz.a sparc.be.a)
+(define sparc.bgeu sparc.bcc)
+(define sparc.bgeu.a sparc.bcc.a)
+(define sparc.blu sparc.bcs)
+(define sparc.blu.a sparc.bcs.a)
+
+; Abstractions.
+
+(define (sparc.cmpr as r1 r2) (sparc.subrcc as r1 r2 $r.g0))
+(define (sparc.cmpi as r imm) (sparc.subicc as r imm $r.g0))
+(define (sparc.move as rs rd) (sparc.orr as $r.g0 rs rd))
+(define (sparc.set as imm rd) (sparc.ori as $r.g0 imm rd))
+(define (sparc.btsti as rs imm) (sparc.andicc as rs imm $r.g0))
+(define (sparc.clr as rd) (sparc.move as $r.g0 rd))
+
+(define (sparc.deccc as rs . rest)
+ (let ((k (cond ((null? rest) 1)
+ ((null? (cdr rest)) (car rest))
+ (else (asm-error "sparc.deccc: too many operands: " rest)))))
+ (sparc.subicc as rs k rs)))
+
+; Floating-point abstractions
+;
+; For fmovd, fnegd, and fabsd, we must synthesize the instruction from
+; fmovs, fnegs, and fabss -- SPARC V8 has only the latter. (SPARC V9 add
+; the former.)
+
+(define (sparc.fmovd as rs rd)
+ (sparc%fmovs as rs 0 rd)
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1)))
+
+(define (sparc.fnegd as rs rd)
+ (sparc%fnegs as rs 0 rd)
+ (if (not (= rs rd))
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
+
+(define (sparc.fabsd as rs rd)
+ (sparc%fabss as rs 0 rd)
+ (if (not (= rs rd))
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
+
+(define (sparc.fcmpd as rs1 rs2)
+ (sparc%fcmpdcc as rs1 rs2 0))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Asm/Sparc/gen-msi.sch -- SPARC assembler code emitters for
+; core MacScheme instructions
+;
+; 9 May 1999 / wdc
+
+
+; SETGLBL
+;
+; RS must be a hardware register.
+;
+; A global cell is a pair, where the car holds the value.
+
+(define (emit-register->global! as rs offset)
+ (cond ((= rs $r.result)
+ (sparc.move as $r.result $r.argreg2)
+ (emit-const->register! as offset $r.result)
+ (if (write-barrier)
+ (sparc.jmpli as $r.millicode $m.addtrans $r.o7))
+ (sparc.sti as $r.argreg2 (- $tag.pair-tag) $r.result))
+ (else
+ (emit-const->register! as offset $r.result)
+ (sparc.sti as rs (- $tag.pair-tag) $r.result)
+ (if (write-barrier)
+ (millicode-call/1arg as $m.addtrans rs)))))
+
+
+; GLOBAL
+;
+; A global cell is a pair, where the car holds the value.
+; If (catch-undefined-globals) is true, then code will be emitted to
+; check whether the global is #!undefined when loaded. If it is,
+; an exception will be taken, with the global in question in $r.result.
+
+(define (emit-global->register! as offset r)
+ (emit-load-global as offset r (catch-undefined-globals)))
+
+; This leaves the cell in ARGREG2. That fact is utilized by global/invoke
+; to signal an appropriate error message.
+
+(define (emit-load-global as offset r check?)
+
+ (define (emit-undef-check! as r)
+ (if check?
+ (let ((GLOBAL-OK (new-label)))
+ (sparc.cmpi as r $imm.undefined)
+ (sparc.bne.a as GLOBAL-OK)
+ (sparc.slot as)
+ (millicode-call/0arg as $m.global-ex) ; Cell in ARGREG2.
+ (sparc.label as GLOBAL-OK))))
+
+ (emit-const->register! as offset $r.argreg2) ; Load cell.
+ (if (hardware-mapped? r)
+ (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) r)
+ (emit-undef-check! as r))
+ (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)
+ (emit-undef-check! as $r.tmp0))))
+
+
+; MOVEREG
+
+(define (emit-register->register! as from to)
+ (if (not (= from to))
+ (cond ((and (hardware-mapped? from) (hardware-mapped? to))
+ (sparc.move as from to))
+ ((hardware-mapped? from)
+ (emit-store-reg! as from to))
+ ((hardware-mapped? to)
+ (emit-load-reg! as from to))
+ (else
+ (emit-load-reg! as from $r.tmp0)
+ (emit-store-reg! as $r.tmp0 to)))))
+
+
+; ARGS=
+
+(define (emit-args=! as n)
+ (if (not (unsafe-code))
+ (let ((L2 (new-label)))
+ (sparc.cmpi as $r.result (thefixnum n)) ; FIXME: limit 1023 args
+ (sparc.be.a as L2)
+ (sparc.slot as)
+ (millicode-call/numarg-in-reg as $m.argc-ex (thefixnum n) $r.argreg2)
+ (sparc.label as L2))))
+
+
+; ARGS>=
+;
+; The cases for 0 and 1 rest arguments are handled in-line; all other
+; cases, including too few, are handled in millicode (really: a C call-out).
+;
+; The fast path only applies when we don't have to mess with the last
+; register, hence the test.
+
+(define (emit-args>=! as n)
+ (let ((L0 (new-label))
+ (L99 (new-label))
+ (L98 (new-label)))
+ (if (< n (- *lastreg* 1))
+ (let ((dest (regname (+ n 1))))
+ (sparc.cmpi as $r.result (thefixnum n)) ; n args
+ (if (hardware-mapped? dest)
+ (begin
+ (sparc.be.a as L99)
+ (sparc.set as $imm.null dest))
+ (begin
+ (sparc.set as $imm.null $r.tmp0)
+ (sparc.be.a as L99)
+ (sparc.sti as $r.tmp0 (swreg-global-offset dest) $r.globals)))
+ (sparc.cmpi as $r.result (thefixnum (+ n 1))) ; n+1 args
+ (sparc.bne.a as L98)
+ (sparc.nop as)
+ (millicode-call/numarg-in-result as $m.alloc 8)
+ (let ((src1 (force-hwreg! as dest $r.tmp1)))
+ (sparc.set as $imm.null $r.tmp0)
+ (sparc.sti as src1 0 $r.result)
+ (sparc.sti as $r.tmp0 4 $r.result)
+ (sparc.addi as $r.result $tag.pair-tag $r.result)
+ (sparc.b as L99)
+ (if (hardware-mapped? dest)
+ (sparc.move as $r.result dest)
+ (sparc.sti as $r.result (swreg-global-offset dest)
+ $r.globals)))))
+ ; General case
+ (sparc.label as L98)
+ (sparc.move as $r.reg0 $r.argreg3) ; FIXME in Sparc/mcode.s
+ (millicode-call/numarg-in-reg as $m.varargs (thefixnum n) $r.argreg2)
+ (sparc.label as L99)))
+
+
+; INVOKE
+; SETRTN/INVOKE
+;
+; Bummed. Can still do better when the procedure to call is in a general
+; register (avoids the redundant move to RESULT preceding INVOKE).
+;
+; Note we must set up the argument count even in unsafe mode, because we
+; may be calling code that was not compiled unsafe.
+
+(define (emit-invoke as n setrtn? mc-exception)
+ (let ((START (new-label))
+ (TIMER-OK (new-label))
+ (PROC-OK (new-label)))
+ (cond ((not (unsafe-code))
+ (sparc.label as START)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne as TIMER-OK)
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (millicode-call/ret as $m.timer-exception START)
+ (sparc.label as TIMER-OK)
+ (sparc.cmpi as $r.tmp0 $tag.procedure-tag)
+ (sparc.be.a as PROC-OK)
+ (sparc.ldi as $r.result $p.codevector $r.tmp0)
+ (millicode-call/ret as mc-exception START)
+ (sparc.label as PROC-OK))
+ (else
+ (sparc.label as START)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as TIMER-OK)
+ (sparc.ldi as $r.result $p.codevector $r.tmp0)
+ (millicode-call/ret as $m.timer-exception START)
+ (sparc.label as TIMER-OK)))
+ (sparc.move as $r.result $r.reg0)
+ ;; FIXME: limit 1023 args
+ (cond (setrtn?
+ (sparc.set as (thefixnum n) $r.result)
+ (sparc.jmpli as $r.tmp0 $p.codeoffset $r.o7)
+ (sparc.sti as $r.o7 4 $r.stkp))
+ (else
+ (sparc.jmpli as $r.tmp0 $p.codeoffset $r.g0)
+ (sparc.set as (thefixnum n) $r.result)))))
+
+; SAVE -- for new compiler
+;
+; Create stack frame. To avoid confusing the garbage collector, the
+; slots must be initialized to something definite unless they will
+; immediately be initialized by a MacScheme machine store instruction.
+; The creation is done by emit-save0!, and the initialization is done
+; by emit-save1!.
+
+(define (emit-save0! as n)
+ (let* ((L1 (new-label))
+ (L0 (new-label))
+ (framesize (+ 8 (* (+ n 1) 4)))
+ (realsize (roundup8 (+ framesize 4))))
+ (sparc.label as L0)
+ (sparc.subi as $r.stkp realsize $r.stkp)
+ (sparc.cmpr as $r.stklim $r.stkp)
+ (sparc.ble.a as L1)
+ (sparc.set as framesize $r.tmp0)
+ (sparc.addi as $r.stkp realsize $r.stkp)
+ (millicode-call/ret as $m.stkoflow L0)
+ (sparc.label as L1)
+ ; initialize size and return fields of stack frame
+ (sparc.sti as $r.tmp0 0 $r.stkp)
+ (sparc.sti as $r.g0 4 $r.stkp)))
+
+; Given a vector v of booleans, initializes slot i of the stack frame
+; if and only if (vector-ref v i).
+
+(define (emit-save1! as v)
+ (let ((n (vector-length v)))
+ (let loop ((i 0) (offset 12))
+ (cond ((= i n)
+ #t)
+ ((vector-ref v i)
+ (sparc.sti as $r.g0 offset $r.stkp)
+ (loop (+ i 1) (+ offset 4)))
+ (else
+ (loop (+ i 1) (+ offset 4)))))))
+
+
+; RESTORE
+;
+; Restore registers from stack frame
+; FIXME: Use ldd/std here; see comments for emit-save!, above.
+; We pop only actual registers.
+
+(define (emit-restore! as n)
+ (let ((n (min n 31)))
+ (do ((i 0 (+ i 1))
+ (offset 12 (+ offset 4)))
+ ((> i n))
+ (let ((r (regname i)))
+ (if (hardware-mapped? r)
+ (sparc.ldi as $r.stkp offset r)
+ (begin (sparc.ldi as $r.stkp offset $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)))))))
+
+; POP -- for new compiler
+;
+; Pop frame.
+; If returning?, then emit the return as well and put the pop
+; in its delay slot.
+
+(define (emit-pop! as n returning?)
+ (let* ((framesize (+ 8 (* (+ n 1) 4)))
+ (realsize (roundup8 (+ framesize 4))))
+ (if returning?
+ (begin (sparc.ldi as $r.stkp (+ realsize 4) $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.addi as $r.stkp realsize $r.stkp))
+ (sparc.addi as $r.stkp realsize $r.stkp))))
+
+
+; SETRTN
+;
+; Change the return address in the stack frame.
+
+(define (emit-setrtn! as label)
+ (emit-return-address! as label)
+ (sparc.sti as $r.o7 4 $r.stkp))
+
+
+; APPLY
+;
+; `apply' falls into millicode.
+;
+; The timer check is performed here because it is not very easy for the
+; millicode to do this.
+
+(define (emit-apply! as r1 r2)
+ (let ((L0 (new-label)))
+ (check-timer0 as)
+ (sparc.label as L0)
+ (emit-move2hwreg! as r1 $r.argreg2)
+ (emit-move2hwreg! as r2 $r.argreg3)
+ (millicode-call/0arg as $m.apply)))
+
+
+; LOAD
+
+(define (emit-load! as slot dest-reg)
+ (if (hardware-mapped? dest-reg)
+ (sparc.ldi as $r.stkp (+ 12 (* slot 4)) dest-reg)
+ (begin (sparc.ldi as $r.stkp (+ 12 (* slot 4)) $r.tmp0)
+ (emit-store-reg! as $r.tmp0 dest-reg))))
+
+
+; STORE
+
+(define (emit-store! as k n)
+ (if (hardware-mapped? k)
+ (sparc.sti as k (+ 12 (* n 4)) $r.stkp)
+ (begin (emit-load-reg! as k $r.tmp0)
+ (sparc.sti as $r.tmp0 (+ 12 (* n 4)) $r.stkp))))
+
+
+; LEXICAL
+
+(define (emit-lexical! as m n)
+ (let ((base (emit-follow-chain! as m)))
+ (sparc.ldi as base (- (procedure-slot-offset n) $tag.procedure-tag)
+ $r.result)))
+
+
+; SETLEX
+; FIXME: should allow an in-line barrier
+
+(define (emit-setlex! as m n)
+ (let ((base (emit-follow-chain! as m)))
+ (sparc.sti as $r.result (- (procedure-slot-offset n) $tag.procedure-tag)
+ base)
+ (if (write-barrier)
+ (begin
+ (sparc.move as $r.result $r.argreg2)
+ (millicode-call/1arg-in-result as $m.addtrans base)))))
+
+
+; Follow static links.
+;
+; By using and leaving the result in ARGREG3 rather than in RESULT,
+; we save a temporary register.
+
+(define (emit-follow-chain! as m)
+ (let loop ((q m))
+ (cond ((not (zero? q))
+ (sparc.ldi as
+ (if (= q m) $r.reg0 $r.argreg3)
+ $p.linkoffset
+ $r.argreg3)
+ (loop (- q 1)))
+ ((zero? m)
+ $r.reg0)
+ (else
+ $r.argreg3))))
+
+; RETURN
+
+(define (emit-return! as)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.nop as))
+
+
+; RETURN-REG k
+
+(define (emit-return-reg! as r)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.move as r $r.result))
+
+
+; RETURN-CONST k
+;
+; The constant c must be synthesizable in a single instruction.
+
+(define (emit-return-const! as c)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (emit-constant->register as c $r.result))
+
+
+; MVRTN
+
+(define (emit-mvrtn! as)
+ (asm-error "multiple-value return has not been implemented (yet)."))
+
+
+; LEXES
+
+(define (emit-lexes! as n-slots)
+ (emit-alloc-proc! as n-slots)
+ (sparc.ldi as $r.reg0 $p.codevector $r.tmp0)
+ (sparc.ldi as $r.reg0 $p.constvector $r.tmp1)
+ (sparc.sti as $r.tmp0 $p.codevector $r.result)
+ (sparc.sti as $r.tmp1 $p.constvector $r.result)
+ (emit-init-proc-slots! as n-slots))
+
+
+; LAMBDA
+
+(define (emit-lambda! as code-offs0 const-offs0 n-slots)
+ (let* ((code-offs (+ 4 (- (* 4 code-offs0) $tag.vector-tag)))
+ (const-offs (+ 4 (- (* 4 const-offs0) $tag.vector-tag)))
+ (fits? (asm:fits? const-offs 13)))
+ (emit-alloc-proc! as n-slots)
+ (if fits?
+ (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (sparc.ldi as $r.tmp0 code-offs $r.tmp1))
+ (emit-const->register! as code-offs0 $r.tmp1))
+ (sparc.sti as $r.tmp1 $p.codevector $r.result)
+ (if fits?
+ (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (sparc.ldi as $r.tmp0 const-offs $r.tmp1))
+ (emit-const->register! as const-offs0 $r.tmp1))
+ (sparc.sti as $r.tmp1 $p.constvector $r.result)
+ (emit-init-proc-slots! as n-slots)))
+
+; Allocate procedure with room for n register slots; return tagged pointer.
+
+(define emit-alloc-proc!
+ (let ((two^12 (expt 2 12)))
+ (lambda (as n)
+ (millicode-call/numarg-in-result as $m.alloc (* (+ n 4) 4))
+ (let ((header (+ (* (* (+ n 3) 4) 256) $imm.procedure-header)))
+ (emit-immediate->register! as header $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (sparc.addi as $r.result $tag.procedure-tag $r.result)))))
+
+; Initialize data slots in procedure from current registers as specified for
+; `lamba' and `lexes'. If there are more data slots than registers, then
+; we must generate code to cdr down the list in the last register to obtain
+; the rest of the data. The list is expected to have at least the minimal
+; length.
+;
+; The tagged pointer to the procedure is in $r.result.
+
+(define (emit-init-proc-slots! as n)
+
+ (define (save-registers lo hi offset)
+ (do ((lo lo (+ lo 1))
+ (offset offset (+ offset 4)))
+ ((> lo hi))
+ (let ((r (force-hwreg! as (regname lo) $r.tmp0)))
+ (sparc.sti as r offset $r.result))))
+
+ (define (save-list lo hi offset)
+ (emit-load-reg! as $r.reg31 $r.tmp0)
+ (do ((lo lo (+ lo 1))
+ (offset offset (+ offset 4)))
+ ((> lo hi))
+ (sparc.ldi as $r.tmp0 (- $tag.pair-tag) $r.tmp1)
+ (sparc.sti as $r.tmp1 offset $r.result)
+ (if (< lo hi)
+ (begin
+ (sparc.ldi as $r.tmp0 (+ (- $tag.pair-tag) 4) $r.tmp0)))))
+
+ (cond ((< n *lastreg*)
+ (save-registers 0 n $p.reg0))
+ (else
+ (save-registers 0 (- *lastreg* 1) $p.reg0)
+ (save-list *lastreg* n (+ $p.reg0 (* *lastreg* 4))))))
+
+; BRANCH
+
+(define (emit-branch! as check-timer? label)
+ (if check-timer?
+ (check-timer as label label)
+ (begin (sparc.b as label)
+ (sparc.slot as))))
+
+
+; BRANCHF
+
+(define (emit-branchf! as label)
+ (emit-branchfreg! as $r.result label))
+
+
+; BRANCHFREG -- introduced by peephole optimization.
+
+(define (emit-branchfreg! as hwreg label)
+ (sparc.cmpi as hwreg $imm.false)
+ (sparc.be.a as label)
+ (sparc.slot as))
+
+
+; BRANCH-WITH-SETRTN -- introduced by peephole optimization
+
+(define (emit-branch-with-setrtn! as label)
+ (check-timer0 as)
+ (sparc.call as label)
+ (sparc.sti as $r.o7 4 $r.stkp))
+
+; JUMP
+;
+; Given the finalization order (outer is finalized before inner is assembled)
+; the label value will always be available when a jump is assembled. The
+; only exception is when m = 0, but does this ever happen? This code handles
+; the case anyway.
+
+(define (emit-jump! as m label)
+ (let* ((r (emit-follow-chain! as m))
+ (labelv (label-value as label))
+ (v (if (number? labelv)
+ (+ labelv $p.codeoffset)
+ (list '+ label $p.codeoffset))))
+ (sparc.ldi as r $p.codevector $r.tmp0)
+ (if (and (number? v) (immediate-literal? v))
+ (sparc.jmpli as $r.tmp0 v $r.g0)
+ (begin (emit-immediate->register! as v $r.tmp1)
+ (sparc.jmplr as $r.tmp0 $r.tmp1 $r.g0)))
+ (sparc.move as r $r.reg0)))
+
+
+; .SINGLESTEP
+;
+; Single step: jump to millicode; pass index of documentation string in
+; %TMP0. Some instructions execute when reg0 is not a valid pointer to
+; the current procedure (because this is just after returning); in this
+; case we restore reg0 from the stack location given by 'funkyloc'.
+
+(define (emit-singlestep-instr! as funky? funkyloc cvlabel)
+ (if funky?
+ (sparc.ldi as $r.stkp (+ (thefixnum funkyloc) 12) $r.reg0))
+ (millicode-call/numarg-in-reg as $m.singlestep
+ (thefixnum cvlabel)
+ $r.argreg2))
+
+
+; Emit the effective address of a label-8 into %o7.
+;
+; There are multiple ways to do this. If the call causes an expensive
+; bubble in the pipeline it is probably much less expensive to grub
+; the code vector address out of the procedure in REG0 and calculate it
+; that way. FIXME: We need to benchmark these options.
+;
+; In general the point is moot as the common-case sequence
+; setrtn L1
+; invoke n
+; L1:
+; should be peephole-optimized into the obvious fast code.
+
+(define (emit-return-address! as label)
+ (let* ((loc (here as))
+ (lloc (label-value as label)))
+
+ (define (emit-short val)
+ (sparc.call as (+ loc 8))
+ (sparc.addi as $r.o7 val $r.o7))
+
+ (define (emit-long val)
+ ; Don't use sparc.set: we need to know that two instructions get
+ ; generated.
+ (sparc.sethi as `(hi ,val) $r.tmp0)
+ (sparc.ori as $r.tmp0 `(lo ,val) $r.tmp0)
+ (sparc.call as (+ loc 16))
+ (sparc.addr as $r.o7 $r.tmp0 $r.o7))
+
+ (cond (lloc
+ (let ((target-rel-addr (- lloc loc 8)))
+ (if (immediate-literal? target-rel-addr)
+ (emit-short target-rel-addr)
+ (emit-long (- target-rel-addr 8)))))
+ ((short-effective-addresses)
+ (emit-short `(- ,label ,loc 8)))
+ (else
+ (emit-long `(- ,label ,loc 16))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 22 April 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 1:
+; primitives defined in Compiler/sparc.imp.sch.
+
+; These extend Asm/Common/pass5p1.sch.
+
+(define (operand5 instruction)
+ (car (cddddr (cdr instruction))))
+
+(define (operand6 instruction)
+ (cadr (cddddr (cdr instruction))))
+
+(define (operand7 instruction)
+ (caddr (cddddr (cdr instruction))))
+
+
+; Primop emitters.
+
+(define (emit-primop.1arg! as op)
+ ((find-primop op) as))
+
+(define (emit-primop.2arg! as op r)
+ ((find-primop op) as r))
+
+(define (emit-primop.3arg! as a1 a2 a3)
+ ((find-primop a1) as a2 a3))
+
+(define (emit-primop.4arg! as a1 a2 a3 a4)
+ ((find-primop a1) as a2 a3 a4))
+
+(define (emit-primop.5arg! as a1 a2 a3 a4 a5)
+ ((find-primop a1) as a2 a3 a4 a5))
+
+(define (emit-primop.6arg! as a1 a2 a3 a4 a5 a6)
+ ((find-primop a1) as a2 a3 a4 a5 a6))
+
+(define (emit-primop.7arg! as a1 a2 a3 a4 a5 a6 a7)
+ ((find-primop a1) as a2 a3 a4 a5 a6 a7))
+
+
+; Hash table of primops
+
+(define primop-vector (make-vector 256 '()))
+
+(define (define-primop name proc)
+ (let ((h (logand (symbol-hash name) 255)))
+ (vector-set! primop-vector h (cons (cons name proc)
+ (vector-ref primop-vector h)))
+ name))
+
+(define (find-primop name)
+ (let ((h (logand (symbol-hash name) 255)))
+ (cdr (assq name (vector-ref primop-vector h)))))
+
+(define (for-each-primop proc)
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length primop-vector)))
+ (for-each (lambda (p)
+ (proc (cdr p)))
+ (vector-ref primop-vector i))))
+
+; Primops
+
+(define-primop 'unspecified
+ (lambda (as)
+ (emit-immediate->register! as $imm.unspecified $r.result)))
+
+(define-primop 'undefined
+ (lambda (as)
+ (emit-immediate->register! as $imm.undefined $r.result)))
+
+(define-primop 'eof-object
+ (lambda (as)
+ (emit-immediate->register! as $imm.eof $r.result)))
+
+(define-primop 'enable-interrupts
+ (lambda (as)
+ (millicode-call/0arg as $m.enable-interrupts)))
+
+(define-primop 'disable-interrupts
+ (lambda (as)
+ (millicode-call/0arg as $m.disable-interrupts)))
+
+(define-primop 'gc-counter
+ (lambda (as)
+ (sparc.ldi as $r.globals $g.gccnt $r.result)))
+
+(define-primop 'zero?
+ (lambda (as)
+ (emit-cmp-primop! as sparc.be.a $m.zerop $r.g0)))
+
+(define-primop '=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.be.a $m.numeq r)))
+
+(define-primop '<
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bl.a $m.numlt r)))
+
+(define-primop '<=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.ble.a $m.numle r)))
+
+(define-primop '>
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bg.a $m.numgt r)))
+
+(define-primop '>=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bge.a $m.numge r)))
+
+(define-primop 'complex?
+ (lambda (as)
+ (millicode-call/0arg as $m.complexp)))
+
+(define-primop 'real?
+ (lambda (as)
+ (millicode-call/0arg as $m.realp)))
+
+(define-primop 'rational?
+ (lambda (as)
+ (millicode-call/0arg as $m.rationalp)))
+
+(define-primop 'integer?
+ (lambda (as)
+ (millicode-call/0arg as $m.integerp)))
+
+(define-primop 'exact?
+ (lambda (as)
+ (millicode-call/0arg as $m.exactp)))
+
+(define-primop 'inexact?
+ (lambda (as)
+ (millicode-call/0arg as $m.inexactp)))
+
+(define-primop 'fixnum?
+ (lambda (as)
+ (sparc.btsti as $r.result 3)
+ (emit-set-boolean! as)))
+
+(define-primop '+
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:+ $r.result r $r.result)))
+
+(define-primop '-
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:- $r.result r $r.result)))
+
+(define-primop '*
+ (lambda (as rs2)
+ (emit-multiply-code as rs2 #f)))
+
+(define (emit-multiply-code as rs2 fixnum-arithmetic?)
+ (if (and (unsafe-code) fixnum-arithmetic?)
+ (begin
+ (sparc.srai as $r.result 2 $r.tmp0)
+ (sparc.smulr as $r.tmp0 rs2 $r.result))
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (Lstart (new-label))
+ (Ltagok (new-label))
+ (Loflo (new-label))
+ (Ldone (new-label)))
+ (sparc.label as Lstart)
+ (sparc.orr as $r.result rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.be.a as Ltagok)
+ (sparc.srai as $r.result 2 $r.tmp0)
+ (sparc.label as Loflo)
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (if (not fixnum-arithmetic?)
+ (begin
+ (millicode-call/ret as $m.multiply Ldone))
+ (begin
+ (sparc.set as (thefixnum $ex.fx*) $r.tmp0)
+ (millicode-call/ret as $m.exception Lstart)))
+ (sparc.label as Ltagok)
+ (sparc.smulr as $r.tmp0 rs2 $r.tmp0)
+ (sparc.rdy as $r.tmp1)
+ (sparc.srai as $r.tmp0 31 $r.tmp2)
+ (sparc.cmpr as $r.tmp1 $r.tmp2)
+ (sparc.bne.a as Loflo)
+ (sparc.slot as)
+ (sparc.move as $r.tmp0 $r.result)
+ (sparc.label as Ldone))))
+
+(define-primop '/
+ (lambda (as r)
+ (millicode-call/1arg as $m.divide r)))
+
+(define-primop 'quotient
+ (lambda (as r)
+ (millicode-call/1arg as $m.quotient r)))
+
+(define-primop 'remainder
+ (lambda (as r)
+ (millicode-call/1arg as $m.remainder r)))
+
+(define-primop '--
+ (lambda (as)
+ (emit-negate as $r.result $r.result)))
+
+(define-primop 'round
+ (lambda (as)
+ (millicode-call/0arg as $m.round)))
+
+(define-primop 'truncate
+ (lambda (as)
+ (millicode-call/0arg as $m.truncate)))
+
+(define-primop 'lognot
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-fixnum! as $r.result $ex.lognot))
+ (sparc.ornr as $r.g0 $r.result $r.result) ; argument order matters
+ (sparc.xori as $r.result 3 $r.result)))
+
+(define-primop 'logand
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.andr $ex.logand)))
+
+(define-primop 'logior
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.orr $ex.logior)))
+
+(define-primop 'logxor
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.xorr $ex.logxor)))
+
+; Fixnum shifts.
+;
+; Only positive shifts are meaningful.
+; FIXME: These are incompatible with MacScheme and MIT Scheme.
+; FIXME: need to return to start of sequence after fault.
+
+(define-primop 'lsh
+ (lambda (as x)
+ (emit-shift-operation as $ex.lsh $r.result x $r.result)))
+
+(define-primop 'rshl
+ (lambda (as x)
+ (emit-shift-operation as $ex.rshl $r.result x $r.result)))
+
+(define-primop 'rsha
+ (lambda (as x)
+ (emit-shift-operation as $ex.rsha $r.result x $r.result)))
+
+
+; fixnums only.
+; FIXME: for symmetry with shifts there should be rotl and rotr (?)
+; or perhaps rot should only ever rotate one way.
+; FIXME: implement.
+
+(define-primop 'rot
+ (lambda (as x)
+ (asm-error "Sparcasm: ROT primop is not implemented.")))
+
+(define-primop 'null?
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.null)
+ (emit-set-boolean! as)))
+
+(define-primop 'pair?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.pair-tag)))
+
+(define-primop 'eof-object?
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.eof)
+ (emit-set-boolean! as)))
+
+; Tests the specific representation, not 'flonum or compnum with 0i'.
+
+(define-primop 'flonum?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.flonum-typetag))))
+
+(define-primop 'compnum?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.compnum-typetag))))
+
+(define-primop 'symbol?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.symbol-typetag))))
+
+(define-primop 'port?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.port-typetag))))
+
+(define-primop 'structure?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.structure-typetag))))
+
+(define-primop 'char?
+ (lambda (as)
+ (sparc.andi as $r.result #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (emit-set-boolean! as)))
+
+(define-primop 'string?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.string-typetag))))
+
+(define-primop 'bytevector?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag))))
+
+(define-primop 'bytevector-like?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.bytevector-tag)))
+
+(define-primop 'vector?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.vector-typetag))))
+
+(define-primop 'vector-like?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.vector-tag)))
+
+(define-primop 'procedure?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.procedure-tag)))
+
+(define-primop 'cons
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:cons $r.result r $r.result)))
+
+(define-primop 'car
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:car $r.result $r.result)))
+
+(define-primop 'cdr
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:cdr $r.result $r.result)))
+
+(define-primop 'car:pair
+ (lambda (as)
+ (sparc.ldi as $r.result (- $tag.pair-tag) $r.result)))
+
+(define-primop 'cdr:pair
+ (lambda (as)
+ (sparc.ldi as $r.result (- 4 $tag.pair-tag) $r.result)))
+
+(define-primop 'set-car!
+ (lambda (as x)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as $tag.pair-tag $ex.car #f))
+ (emit-setcar/setcdr! as $r.result x 0)))
+
+(define-primop 'set-cdr!
+ (lambda (as x)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as $tag.pair-tag $ex.cdr #f))
+ (emit-setcar/setcdr! as $r.result x 4)))
+
+; Cells are internal data structures, represented using pairs.
+; No error checking is done on cell references.
+
+(define-primop 'make-cell
+ (lambda (as)
+ (emit-primop.4arg! as 'internal:cons $r.result $r.g0 $r.result)))
+
+(define-primop 'cell-ref
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:cell-ref $r.result $r.result)))
+
+(define-primop 'cell-set!
+ (lambda (as r)
+ (emit-setcar/setcdr! as $r.result r 0)))
+
+(define-primop 'syscall
+ (lambda (as)
+ (millicode-call/0arg as $m.syscall)))
+
+(define-primop 'break
+ (lambda (as)
+ (millicode-call/0arg as $m.break)))
+
+(define-primop 'creg
+ (lambda (as)
+ (millicode-call/0arg as $m.creg)))
+
+(define-primop 'creg-set!
+ (lambda (as)
+ (millicode-call/0arg as $m.creg-set!)))
+
+(define-primop 'typetag
+ (lambda (as)
+ (millicode-call/0arg as $m.typetag)))
+
+(define-primop 'typetag-set!
+ (lambda (as r)
+ (millicode-call/1arg as $m.typetag-set r)))
+
+(define-primop 'exact->inexact
+ (lambda (as)
+ (millicode-call/0arg as $m.exact->inexact)))
+
+(define-primop 'inexact->exact
+ (lambda (as)
+ (millicode-call/0arg as $m.inexact->exact)))
+
+(define-primop 'real-part
+ (lambda (as)
+ (millicode-call/0arg as $m.real-part)))
+
+(define-primop 'imag-part
+ (lambda (as)
+ (millicode-call/0arg as $m.imag-part)))
+
+(define-primop 'char->integer
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-char! as $ex.char2int #f))
+ (sparc.srli as $r.result 14 $r.result)))
+
+(define-primop 'integer->char
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-fixnum! as $r.result $ex.int2char))
+ (sparc.andi as $r.result #x3FF $r.result)
+ (sparc.slli as $r.result 14 $r.result)
+ (sparc.ori as $r.result $imm.character $r.result)))
+
+(define-primop 'not
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.false)
+ (emit-set-boolean! as)))
+
+(define-primop 'eq?
+ (lambda (as x)
+ (emit-primop.4arg! as 'internal:eq? $r.result x $r.result)))
+
+(define-primop 'eqv?
+ (lambda (as x)
+ (let ((tmp (force-hwreg! as x $r.tmp0))
+ (L1 (new-label)))
+ (sparc.cmpr as $r.result tmp)
+ (sparc.be.a as L1)
+ (sparc.set as $imm.true $r.result)
+ (millicode-call/1arg as $m.eqv tmp)
+ (sparc.label as L1))))
+
+(define-primop 'make-bytevector
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-positive-fixnum! as $r.result $ex.mkbvl))
+ (emit-allocate-bytevector as
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag)
+ #f)
+ (sparc.addi as $r.result $tag.bytevector-tag $r.result)))
+
+(define-primop 'bytevector-fill!
+ (lambda (as rs2)
+ (let* ((fault (emit-double-tagcheck-assert! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag)
+ $ex.bvfill
+ rs2))
+ (rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (sparc.srai as rs2 2 $r.tmp2)
+ (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0)
+ (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.tmp1)
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (emit-bytevector-fill as $r.tmp0 $r.tmp1 $r.tmp2))))
+
+(define-primop 'bytevector-length
+ (lambda (as)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvlen
+ $r.result
+ $r.result)))
+
+(define-primop 'bytevector-like-length
+ (lambda (as)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ #f
+ $ex.bvllen
+ $r.result
+ $r.result)))
+
+(define-primop 'bytevector-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvref
+ r)
+ #f)))
+ (emit-bytevector-like-ref! as $r.result r $r.result fault #f #t))))
+
+(define-primop 'bytevector-like-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.bytevector-tag
+ $ex.bvlref
+ r)
+ #f)))
+ (emit-bytevector-like-ref! as $r.result r $r.result fault #f #f))))
+
+(define-primop 'bytevector-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvset
+ r1)
+ #f)))
+ (emit-bytevector-like-set! as r1 r2 fault #t))))
+
+(define-primop 'bytevector-like-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.bytevector-tag
+ $ex.bvlset
+ r1)
+ #f)))
+ (emit-bytevector-like-set! as r1 r2 fault #f))))
+
+(define-primop 'sys$bvlcmp
+ (lambda (as x)
+ (millicode-call/1arg as $m.bvlcmp x)))
+
+; Strings
+
+; RESULT must have nonnegative fixnum.
+; RS2 must have character.
+
+(define-primop 'make-string
+ (lambda (as rs2)
+ (let ((FAULT (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (let ((L1 (new-label))
+ (L2 (new-label)))
+ (sparc.tsubrcc as $r.result $r.g0 $r.g0)
+ (sparc.bvc.a as L1)
+ (sparc.andi as rs2 255 $r.tmp0)
+ (sparc.label as FAULT)
+ (if (not (= rs2 $r.argreg2))
+ (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum $ex.mkbvl) $r.tmp0) ; Wrong code.
+ (millicode-call/ret as $m.exception START)
+ (sparc.label as L1)
+ (sparc.bl as FAULT)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne as FAULT)
+ (sparc.move as $r.result $r.argreg3))
+ (begin
+ (sparc.move as $r.result $r.argreg3)))
+ (emit-allocate-bytevector as
+ (+ $imm.bytevector-header
+ $tag.string-typetag)
+ $r.argreg3)
+ (sparc.srai as rs2 16 $r.tmp1)
+ (sparc.addi as $r.result 4 $r.result)
+ (sparc.srai as $r.argreg3 2 $r.tmp0)
+ (emit-bytevector-fill as $r.tmp0 $r.result $r.tmp1)
+ (sparc.addi as $r.result (- $tag.bytevector-tag 4) $r.result)))))
+
+(define-primop 'string-length
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:string-length $r.result $r.result)))
+
+(define-primop 'string-ref
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:string-ref $r.result r $r.result)))
+
+(define-primop 'string-set!
+ (lambda (as r1 r2)
+ (emit-string-set! as $r.result r1 r2)))
+
+(define-primop 'sys$partial-list->vector
+ (lambda (as r)
+ (millicode-call/1arg as $m.partial-list->vector r)))
+
+(define-primop 'make-procedure
+ (lambda (as)
+ (emit-make-vector-like! as
+ '()
+ $imm.procedure-header
+ $tag.procedure-tag)))
+
+(define-primop 'make-vector
+ (lambda (as r)
+ (emit-make-vector-like! as
+ r
+ (+ $imm.vector-header $tag.vector-typetag)
+ $tag.vector-tag)))
+
+(define-primop 'make-vector:0
+ (lambda (as r) (make-vector-n as 0 r)))
+
+(define-primop 'make-vector:1
+ (lambda (as r) (make-vector-n as 1 r)))
+
+(define-primop 'make-vector:2
+ (lambda (as r) (make-vector-n as 2 r)))
+
+(define-primop 'make-vector:3
+ (lambda (as r) (make-vector-n as 3 r)))
+
+(define-primop 'make-vector:4
+ (lambda (as r) (make-vector-n as 4 r)))
+
+(define-primop 'make-vector:5
+ (lambda (as r) (make-vector-n as 5 r)))
+
+(define-primop 'make-vector:6
+ (lambda (as r) (make-vector-n as 6 r)))
+
+(define-primop 'make-vector:7
+ (lambda (as r) (make-vector-n as 7 r)))
+
+(define-primop 'make-vector:8
+ (lambda (as r) (make-vector-n as 8 r)))
+
+(define-primop 'make-vector:9
+ (lambda (as r) (make-vector-n as 9 r)))
+
+(define-primop 'vector-length
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:vector-length $r.result $r.result)))
+
+(define-primop 'vector-like-length
+ (lambda (as)
+ (emit-get-length! as $tag.vector-tag #f $ex.vllen $r.result $r.result)))
+
+(define-primop 'vector-length:vec
+ (lambda (as)
+ (emit-get-length-trusted! as $tag.vector-tag $r.result $r.result)))
+
+(define-primop 'procedure-length
+ (lambda (as)
+ (emit-get-length! as $tag.procedure-tag #f $ex.plen $r.result $r.result)))
+
+(define-primop 'vector-ref
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:vector-ref $r.result r $r.result)))
+
+(define-primop 'vector-like-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.vector-tag
+ $ex.vlref
+ r)
+ #f)))
+ (emit-vector-like-ref!
+ as $r.result r $r.result fault $tag.vector-tag #f))))
+
+(define-primop 'vector-ref:trusted
+ (lambda (as rs2)
+ (emit-vector-like-ref-trusted!
+ as $r.result rs2 $r.result $tag.vector-tag)))
+
+(define-primop 'procedure-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.procedure-tag
+ $ex.pref
+ r)
+ #f)))
+ (emit-vector-like-ref!
+ as $r.result r $r.result fault $tag.procedure-tag #f))))
+
+(define-primop 'vector-set!
+ (lambda (as r1 r2)
+ (emit-primop.4arg! as 'internal:vector-set! $r.result r1 r2)))
+
+(define-primop 'vector-like-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.vector-tag
+ $ex.vlset
+ r1)
+ #f)))
+ (emit-vector-like-set! as $r.result r1 r2 fault $tag.vector-tag #f))))
+
+(define-primop 'vector-set!:trusted
+ (lambda (as rs2 rs3)
+ (emit-vector-like-set-trusted! as $r.result rs2 rs3 $tag.vector-tag)))
+
+(define-primop 'procedure-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.procedure-tag
+ $ex.pset
+ r1)
+ #f)))
+ (emit-vector-like-set! as $r.result r1 r2 fault $tag.procedure-tag #f))))
+
+(define-primop 'char<?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bl.a $ex.char<?)))
+
+(define-primop 'char<=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.ble.a $ex.char<=?)))
+
+(define-primop 'char=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.be.a $ex.char=?)))
+
+(define-primop 'char>?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bg.a $ex.char>?)))
+
+(define-primop 'char>=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bge.a $ex.char>=?)))
+
+; Experimental (for performance).
+; This makes massive assumptions about the layout of the port structure:
+; A port is a vector-like where
+; #0 = port.input?
+; #4 = port.buffer
+; #7 = port.rd-lim
+; #8 = port.rd-ptr
+; See Lib/iosys.sch for more information.
+
+(define-primop 'sys$read-char
+ (lambda (as)
+ (let ((Lfinish (new-label))
+ (Lend (new-label)))
+ (if (not (unsafe-code))
+ (begin
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0) ; mask argument tag
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag); vector-like?
+ (sparc.bne as Lfinish) ; skip if not vector-like
+ (sparc.nop as)
+ (sparc.ldbi as $r.RESULT 0 $r.tmp1))) ; header byte
+ (sparc.ldi as $r.RESULT 1 $r.tmp2) ; port.input? or garbage
+ (if (not (unsafe-code))
+ (begin
+ (sparc.cmpi as $r.tmp1 $hdr.port) ; port?
+ (sparc.bne as Lfinish))) ; skip if not port
+ (sparc.cmpi as $r.tmp2 $imm.false) ; [slot] input port?
+ (sparc.be as Lfinish) ; skip if not active port
+ (sparc.ldi as $r.RESULT (+ 1 32) $r.tmp1) ; [slot] port.rd-ptr
+ (sparc.ldi as $r.RESULT (+ 1 28) $r.tmp2) ; port.rd-lim
+ (sparc.ldi as $r.RESULT (+ 1 16) $r.tmp0) ; port.buffer
+ (sparc.cmpr as $r.tmp1 $r.tmp2) ; rd-ptr < rd-lim?
+ (sparc.bge as Lfinish) ; skip if rd-ptr >= rd-lim
+ (sparc.subi as $r.tmp0 1 $r.tmp0) ; [slot] addr of string@0
+ (sparc.srai as $r.tmp1 2 $r.tmp2) ; rd-ptr as native int
+ (sparc.ldbr as $r.tmp0 $r.tmp2 $r.tmp2) ; get byte from string
+ (sparc.addi as $r.tmp1 4 $r.tmp1) ; bump rd-ptr
+ (sparc.sti as $r.tmp1 (+ 1 32) $r.RESULT) ; store rd-ptr in port
+ (sparc.slli as $r.tmp2 16 $r.tmp2) ; convert to char #1
+ (sparc.b as Lend)
+ (sparc.ori as $r.tmp2 $imm.character $r.RESULT) ; [slot] convert to char
+ (sparc.label as Lfinish)
+ (sparc.set as $imm.false $r.RESULT) ; failed
+ (sparc.label as Lend))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 2:
+; primitives introduced by peephole optimization.
+
+(define-primop 'internal:car
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:car src1 dest)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as
+ $tag.pair-tag src1 #f $ex.car))
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:cdr
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cdr src1 dest)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as
+ $tag.pair-tag src1 #f $ex.cdr))
+ (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
+
+(define-primop 'internal:cell-ref
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cell-ref src1 dest)
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:set-car!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:set-car! rs1 dest-ignored)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.car))
+ (emit-setcar/setcdr! as rs1 rs2 0)))
+
+(define-primop 'internal:set-cdr!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:set-cdr! rs1 dest-ignored)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.cdr))
+ (emit-setcar/setcdr! as rs1 rs2 4)))
+
+(define-primop 'internal:cell-set!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:cell-set! rs1 dest-ignored)
+ (emit-setcar/setcdr! as rs1 rs2 0)))
+
+; CONS
+;
+; One instruction reduced here translates into about 2.5KB reduction in the
+; size of the basic heap image. :-)
+;
+; In the out-of-line case, if rd != RESULT then a garbage value is left
+; in RESULT, but it always looks like a fixnum, so it's OK.
+
+(define-primop 'internal:cons
+ (lambda (as rs1 rs2 rd)
+ (if (inline-allocation)
+ (let ((ENOUGH-MEMORY (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (sparc.addi as $r.e-top 8 $r.e-top)
+ (sparc.cmpr as $r.e-top $r.e-limit)
+ (sparc.ble.a as ENOUGH-MEMORY)
+ (sparc.sti as rs1 -8 $r.e-top)
+ (millicode-call/ret as $m.gc START)
+ (sparc.label as ENOUGH-MEMORY)
+ (sparc.sti as (force-hwreg! as rs2 $r.tmp0) -4 $r.e-top)
+ (sparc.subi as $r.e-top (- 8 $tag.pair-tag) rd))
+ (begin
+ (if (= rs1 $r.result)
+ (sparc.move as $r.result $r.argreg2))
+ (millicode-call/numarg-in-result as $m.alloc 8)
+ (if (= rs1 $r.result)
+ (sparc.sti as $r.argreg2 0 $r.result)
+ (sparc.sti as rs1 0 $r.result))
+ (sparc.sti as (force-hwreg! as rs2 $r.tmp1) 4 $r.result)
+ (sparc.addi as $r.result $tag.pair-tag rd)))))
+
+(define-primop 'internal:car:pair
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:car src1 dest)
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:cdr:pair
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cdr src1 dest)
+ (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
+
+; Vector operations.
+
+(define-primop 'internal:vector-length
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:vector-length rs rd)
+ (emit-get-length! as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ $ex.vlen
+ rs
+ rd)))
+
+(define-primop 'internal:vector-ref
+ (lambda (as rs1 rs2 rd)
+ (internal-primop-invariant2 'internal:vector-ref rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ rs2
+ $ex.vref))))
+ (emit-vector-like-ref! as rs1 rs2 rd fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-ref/imm
+ (lambda (as rs1 imm rd)
+ (internal-primop-invariant2 'internal:vector-ref/imm rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/imm!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ imm
+ $ex.vref))))
+ (emit-vector-like-ref/imm! as rs1 imm rd fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-set!
+ (lambda (as rs1 rs2 rs3)
+ (internal-primop-invariant1 'internal:vector-set! rs1)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ rs2
+ $ex.vset))))
+ (emit-vector-like-set! as rs1 rs2 rs3 fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-length:vec
+ (lambda (as rs1 dst)
+ (internal-primop-invariant2 'internal:vector-length:vec rs1 dst)
+ (emit-get-length-trusted! as $tag.vector-tag rs1 dst)))
+
+(define-primop 'internal:vector-ref:trusted
+ (lambda (as rs1 rs2 dst)
+ (emit-vector-like-ref-trusted! as rs1 rs2 dst $tag.vector-tag)))
+
+(define-primop 'internal:vector-set!:trusted
+ (lambda (as rs1 rs2 rs3)
+ (emit-vector-like-ref-trusted! as rs1 rs2 rs3 $tag.vector-tag)))
+
+; Strings.
+
+(define-primop 'internal:string-length
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:string-length rs rd)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ $ex.slen
+ rs
+ rd)))
+
+(define-primop 'internal:string-ref
+ (lambda (as rs1 rs2 rd)
+ (internal-primop-invariant2 'internal:string-ref rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1
+ rs2
+ $ex.sref))))
+ (emit-bytevector-like-ref! as rs1 rs2 rd fault #t #t))))
+
+(define-primop 'internal:string-ref/imm
+ (lambda (as rs1 imm rd)
+ (internal-primop-invariant2 'internal:string-ref/imm rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/imm!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1
+ imm
+ $ex.sref))))
+ (emit-bytevector-like-ref/imm! as rs1 imm rd fault #t #t))))
+
+(define-primop 'internal:string-set!
+ (lambda (as rs1 rs2 rs3)
+ (internal-primop-invariant1 'internal:string-set! rs1)
+ (emit-string-set! as rs1 rs2 rs3)))
+
+(define-primop 'internal:+
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:+ src1 dest)
+ (emit-arith-primop! as sparc.taddrcc sparc.subr $m.add src1 src2 dest #t)))
+
+(define-primop 'internal:+/imm
+ (lambda (as src1 imm dest)
+ (internal-primop-invariant2 'internal:+/imm src1 dest)
+ (emit-arith-primop! as sparc.taddicc sparc.subi $m.add src1 imm dest #f)))
+
+(define-primop 'internal:-
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:- src1 dest)
+ (emit-arith-primop! as sparc.tsubrcc sparc.addr $m.subtract
+ src1 src2 dest #t)))
+
+(define-primop 'internal:-/imm
+ (lambda (as src1 imm dest)
+ (internal-primop-invariant2 'internal:-/imm src1 dest)
+ (emit-arith-primop! as sparc.tsubicc sparc.addi $m.subtract
+ src1 imm dest #f)))
+
+(define-primop 'internal:--
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:-- rs rd)
+ (emit-negate as rs rd)))
+
+(define-primop 'internal:branchf-null?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:branchf-null? reg)
+ (sparc.cmpi as reg $imm.null)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-pair?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:branchf-pair? reg)
+ (sparc.andi as reg $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.pair-tag)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-zero?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:brancf-zero? reg)
+ (emit-bcmp-primop! as sparc.bne.a reg $r.g0 label $m.zerop #t)))
+
+(define-primop 'internal:branchf-eof-object?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-eof-object? rs)
+ (sparc.cmpi as rs $imm.eof)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-fixnum?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-fixnum? rs)
+ (sparc.btsti as rs 3)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-char?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-char? rs)
+ (sparc.andi as rs 255 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-= src1)
+ (emit-bcmp-primop! as sparc.bne.a src1 src2 label $m.numeq #t)))
+
+(define-primop 'internal:branchf-<
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-< src1)
+ (emit-bcmp-primop! as sparc.bge.a src1 src2 label $m.numlt #t)))
+
+(define-primop 'internal:branchf-<=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-<= src1)
+ (emit-bcmp-primop! as sparc.bg.a src1 src2 label $m.numle #t)))
+
+(define-primop 'internal:branchf->
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-> src1)
+ (emit-bcmp-primop! as sparc.ble.a src1 src2 label $m.numgt #t)))
+
+(define-primop 'internal:branchf->=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf->= src1)
+ (emit-bcmp-primop! as sparc.bl.a src1 src2 label $m.numge #t)))
+
+(define-primop 'internal:branchf-=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-=/imm src1)
+ (emit-bcmp-primop! as sparc.bne.a src1 imm label $m.numeq #f)))
+
+(define-primop 'internal:branchf-</imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-</imm src1)
+ (emit-bcmp-primop! as sparc.bge.a src1 imm label $m.numlt #f)))
+
+(define-primop 'internal:branchf-<=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-<=/imm src1)
+ (emit-bcmp-primop! as sparc.bg.a src1 imm label $m.numle #f)))
+
+(define-primop 'internal:branchf->/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf->/imm src1)
+ (emit-bcmp-primop! as sparc.ble.a src1 imm label $m.numgt #f)))
+
+(define-primop 'internal:branchf->=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf->=/imm src1)
+ (emit-bcmp-primop! as sparc.bl.a src1 imm label $m.numge #f)))
+
+(define-primop 'internal:branchf-char=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char=? src1)
+ (emit-char-bcmp-primop! as sparc.bne.a src1 src2 label $ex.char=?)))
+
+(define-primop 'internal:branchf-char<=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char<=? src1)
+ (emit-char-bcmp-primop! as sparc.bg.a src1 src2 label $ex.char<=?)))
+
+(define-primop 'internal:branchf-char<?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char<? src1)
+ (emit-char-bcmp-primop! as sparc.bge.a src1 src2 label $ex.char<?)))
+
+(define-primop 'internal:branchf-char>=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char>=? src1)
+ (emit-char-bcmp-primop! as sparc.bl.a src1 src2 label $ex.char>=?)))
+
+(define-primop 'internal:branchf-char>?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char>=? src1)
+ (emit-char-bcmp-primop! as sparc.ble.a src1 src2 label $ex.char>?)))
+
+(define-primop 'internal:branchf-char=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bne.a src imm label $ex.char=?)))
+
+(define-primop 'internal:branchf-char>=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char>=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bl.a src imm label $ex.char>=?)))
+
+(define-primop 'internal:branchf-char>?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char>?/imm src)
+ (emit-char-bcmp-primop! as sparc.ble.a src imm label $ex.char>?)))
+
+(define-primop 'internal:branchf-char<=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char<=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bg.a src imm label $ex.char<=?)))
+
+(define-primop 'internal:branchf-char<?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char<?/imm src)
+ (emit-char-bcmp-primop! as sparc.bge.a src imm label $ex.char<?)))
+
+(define-primop 'internal:eq?
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:eq? src1 dest)
+ (let ((tmp (force-hwreg! as src2 $r.tmp0)))
+ (sparc.cmpr as src1 tmp)
+ (emit-set-boolean-reg! as dest))))
+
+(define-primop 'internal:eq?/imm
+ (lambda (as rs imm rd)
+ (internal-primop-invariant2 'internal:eq?/imm rs rd)
+ (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
+ ((eq? imm #t) (sparc.cmpi as rs $imm.true))
+ ((eq? imm #f) (sparc.cmpi as rs $imm.false))
+ ((null? imm) (sparc.cmpi as rs $imm.null))
+ (else ???))
+ (emit-set-boolean-reg! as rd)))
+
+(define-primop 'internal:branchf-eq?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-eq? src1)
+ (let ((src2 (force-hwreg! as src2 $r.tmp0)))
+ (sparc.cmpr as src1 src2)
+ (sparc.bne.a as label)
+ (sparc.slot as))))
+
+(define-primop 'internal:branchf-eq?/imm
+ (lambda (as rs imm label)
+ (internal-primop-invariant1 'internal:branchf-eq?/imm rs)
+ (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
+ ((eq? imm #t) (sparc.cmpi as rs $imm.true))
+ ((eq? imm #f) (sparc.cmpi as rs $imm.false))
+ ((null? imm) (sparc.cmpi as rs $imm.null))
+ (else ???))
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+; Unary predicates followed by a check.
+
+(define-primop 'internal:check-fixnum?
+ (lambda (as src L1 liveregs)
+ (sparc.btsti as src 3)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-pair?
+ (lambda (as src L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.pair-tag)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-vector?
+ (lambda (as src L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag)
+ (sparc.bne as L1)
+ (sparc.nop as)
+ (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 $imm.vector-header)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-vector?/vector-length:vec
+ (lambda (as src dst L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag)
+ (sparc.bne as L1)
+ (sparc.nop as)
+ (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 $imm.vector-header)
+ (sparc.bne as L1)
+ (apply sparc.slot2 as liveregs)
+ (sparc.srli as $r.tmp0 8 dst)))
+
+(define (internal-primop-invariant2 name a b)
+ (if (not (and (hardware-mapped? a) (hardware-mapped? b)))
+ (asm-error "SPARC assembler internal invariant violated by " name
+ " on operands " a " and " b)))
+
+(define (internal-primop-invariant1 name a)
+ (if (not (hardware-mapped? a))
+ (asm-error "SPARC assembler internal invariant violated by " name
+ " on operand " a)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC code generation macros for primitives, part 3a:
+; helper procedures for scalars.
+
+
+; LOGAND, LOGIOR, LOGXOR: logical operations on fixnums.
+;
+; Input: Registers rs1 and rs2, both of which can be general registers.
+; In addition, rs1 can be RESULT, and rs2 can be ARGREG2.
+; Output: Register dest, which can be a general register or RESULT.
+
+(define (logical-op as rs1 rs2 dest op excode)
+
+ (define (fail rs1 rs2 L0)
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0))
+
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (let ((rs1 (force-hwreg! as rs1 $r.result))
+ (rs2 (force-hwreg! as rs2 $r.argreg2))
+ (u (unsafe-code))
+ (d (hardware-mapped? dest)))
+ (cond ((and u d)
+ (op as rs1 rs2 dest))
+ ((and u (not d))
+ (op as rs1 rs2 $r.tmp0)
+ (emit-store-reg! as $r.tmp0 dest))
+ ((and (not u) d)
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.bz.a as L1)
+ (op as rs1 rs2 dest)
+ (fail rs1 rs2 L0)
+ (sparc.label as L1))
+ (else
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.bz.a as L1)
+ (op as rs1 rs2 $r.tmp0)
+ (fail rs1 rs2 L0)
+ (sparc.label as L1)
+ (emit-store-reg! as $r.tmp0 dest))))))
+
+
+; LSH, RSHA, RSHL: Bitwise shifts on fixnums.
+;
+; Notes for future contemplation:
+; - The semantics do not match those of MIT Scheme or MacScheme: only
+; positive shifts are allowed.
+; - The names do not match the fixnum-specific procedures of Chez Scheme
+; that have the same semantics: fxsll, fxsra, fxsrl.
+; - This code checks that the second argument is in range; if it did
+; not, then we could get a MOD for free. Probably too hardware-dependent
+; to worry about.
+; - The range 0..31 for the shift count is curious given that the fixnum
+; is 30-bit.
+
+(define (emit-shift-operation as exn rs1 rs2 rd)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (let ((L0 (new-label))
+ (FAULT (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (sparc.btsti as rs1 3) ; RS1 fixnum?
+ (sparc.be.a as L0)
+ (sparc.andi as rs2 #x7c $r.g0) ; RS2 fixnum and 0 <= RS2 < 32?
+ (sparc.label as FAULT)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception START)
+ (sparc.label as L0)
+ (sparc.bne as FAULT)
+ (sparc.srai as rs2 2 $r.tmp1))
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ (cond ((= exn $ex.lsh)
+ (sparc.sllr as rs1 $r.tmp1 rd))
+ ((= exn $ex.rshl)
+ (sparc.srlr as rs1 $r.tmp1 rd)
+ (sparc.andni as rd 3 rd))
+ ((= exn $ex.rsha)
+ (sparc.srar as rs1 $r.tmp1 rd)
+ (sparc.andni as rd 3 rd))
+ (else ???))))
+
+
+; Set result on condition code.
+;
+; The processor's zero bit has been affected by a previous instruction.
+; If the bit is set, store #t in RESULT, otherwise store #f in RESULT.
+
+(define (emit-set-boolean! as)
+ (emit-set-boolean-reg! as $r.result))
+
+
+; Set on condition code.
+;
+; The processor's zero bit has been affected by a previous instruction.
+; If the bit is set, store #t in the processor register 'dest', otherwise
+; store #f in 'dest'.
+
+(define (emit-set-boolean-reg! as dest)
+ (let ((L1 (new-label)))
+ (sparc.set as $imm.true dest)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false dest)
+ (sparc.label as L1)))
+
+
+; Representation predicate.
+
+(define (emit-single-tagcheck->bool! as tag)
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag)
+ (emit-set-boolean! as))
+
+(define (emit-single-tagcheck-assert! as tag1 excode reg2)
+ (emit-single-tagcheck-assert-reg! as tag1 $r.result reg2 excode))
+
+(define (emit-single-tagcheck-assert-reg! as tag1 reg reg2 excode)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as reg $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (fault-if-ne as excode #f #f reg reg2 L0)))
+
+; Assert that a machine register has a fixnum in it.
+; Returns the label of the fault code.
+
+(define (emit-assert-fixnum! as reg excode)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.btsti as reg 3)
+ (fault-if-ne as excode #f #f reg #f L0)))
+
+; Assert that RESULT has a character in it.
+; Returns the label of the fault code.
+
+(define (emit-assert-char! as excode fault-label)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as $r.result #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (fault-if-ne as excode #f fault-label #f #f L0)))
+
+; Generate code for fault handling if the zero flag is not set.
+; - excode is the nativeint exception code.
+; - cont-label, if not #f, is the label to go to if there is no fault.
+; - fault-label, if not #f, is the label of an existing fault handler.
+; - reg1, if not #f, is the number of a register which must be
+; moved into RESULT before the fault handler is called.
+; - reg2, if not #f, is the number of a register which must be moved
+; into ARGREG2 before the fault handler is called.
+; - ret-label, if not #f, is the return address to be set up before calling
+; the fault handler.
+;
+; Ret-label and fault-label cannot simultaneously be non-#f; in this case
+; the ret-label is ignored (since the existing fault handler most likely
+; sets up the return in the desired manner).
+
+(define (fault-if-ne as excode cont-label fault-label reg1 reg2 ret-label)
+ (if fault-label
+ (begin
+ (if (and reg2 (not (= reg2 $r.argreg2)))
+ (emit-move2hwreg! as reg2 $r.argreg2))
+ (sparc.bne as fault-label)
+ (if (and reg1 (not (= reg1 $r.result)))
+ (sparc.move as reg1 $r.result)
+ (sparc.nop as))
+ fault-label)
+ (let ((FAULT (new-label))
+ (L1 (new-label)))
+ (sparc.be.a as (or cont-label L1))
+ (sparc.slot as)
+ (sparc.label as FAULT)
+ (if (and reg1 (not (= reg1 $r.result)))
+ (sparc.move as reg1 $r.result))
+ (if (and reg2 (not (= reg2 $r.argreg2)))
+ (emit-move2hwreg! as reg2 $r.argreg2))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception (or ret-label L1))
+ (if (or (not cont-label) (not ret-label))
+ (sparc.label as L1))
+ FAULT)))
+
+; This is more expensive than what is good for it (5 cycles in the usual case),
+; but there does not seem to be a better way.
+
+(define (emit-assert-positive-fixnum! as reg excode)
+ (let ((L1 (new-label))
+ (L2 (new-label))
+ (L3 (new-label)))
+ (sparc.label as L2)
+ (sparc.tsubrcc as reg $r.g0 $r.g0)
+ (sparc.bvc as L1)
+ (sparc.nop as)
+ (sparc.label as L3)
+ (if (not (= reg $r.result))
+ (sparc.move as reg $r.result))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception l2)
+ (sparc.label as L1)
+ (sparc.bl as L3)
+ (sparc.nop as)
+ L3))
+
+
+; Arithmetic comparison with boolean result.
+
+(define (emit-cmp-primop! as branch_t.a generic r)
+ (let ((Ltagok (new-label))
+ (Lcont (new-label))
+ (r (force-hwreg! as r $r.argreg2)))
+ (sparc.tsubrcc as $r.result r $r.g0)
+ (sparc.bvc.a as Ltagok)
+ (sparc.set as $imm.false $r.result)
+ (if (not (= r $r.argreg2))
+ (sparc.move as r $r.argreg2))
+ (millicode-call/ret as generic Lcont)
+ (sparc.label as Ltagok)
+ (branch_t.a as Lcont)
+ (sparc.set as $imm.true $r.result)
+ (sparc.label as Lcont)))
+
+
+; Arithmetic comparison and branch.
+;
+; This code does not use the chained branch trick (DCTI) that was documented
+; in the Sparc v8 manual and deprecated in the v9 manual. This code executes
+; _much_ faster on the Ultra than the code using DCTI, even though it executes
+; the same instructions.
+;
+; Parameters and preconditions.
+; Src1 is a general register, RESULT, ARGREG2, or ARGREG3.
+; Src2 is a general register, RESULT, ARGREG2, ARGREG3, or an immediate.
+; Src2 is an immediate iff src2isreg = #f.
+; Branch_f.a is a branch on condition code that branches if the condition
+; is not true.
+; Generic is the millicode table offset of the generic procedure.
+
+(define (emit-bcmp-primop! as branch_f.a src1 src2 Lfalse generic src2isreg)
+ (let ((Ltagok (new-label))
+ (Ltrue (new-label))
+ (op2 (if src2isreg
+ (force-hwreg! as src2 $r.tmp1)
+ (thefixnum src2)))
+ (sub (if src2isreg sparc.tsubrcc sparc.tsubicc))
+ (mov (if src2isreg sparc.move sparc.set)))
+ (sub as src1 op2 $r.g0)
+ (sparc.bvc.a as Ltagok)
+ (sparc.slot as)
+
+ ; Not both fixnums.
+ ; Must move src1 to result if src1 is not result.
+ ; Must move src2 to argreg2 if src2 is not argreg2.
+
+ (let ((move-res (not (= src1 $r.result)))
+ (move-arg2 (or (not src2isreg) (not (= op2 $r.argreg2)))))
+ (if (and move-arg2 move-res)
+ (mov as op2 $r.argreg2))
+ (sparc.jmpli as $r.millicode generic $r.o7)
+ (cond (move-res (sparc.move as src1 $r.result))
+ (move-arg2 (mov as op2 $r.argreg2))
+ (else (sparc.nop as)))
+ (sparc.cmpi as $r.result $imm.false)
+ (sparc.bne.a as Ltrue)
+ (sparc.slot as)
+ (sparc.b as Lfalse)
+ (sparc.slot as))
+
+ (sparc.label as Ltagok)
+ (branch_f.a as Lfalse)
+ (sparc.slot as)
+ (sparc.label as Ltrue)))
+
+
+; Generic arithmetic for + and -.
+; Some rules:
+; We have two HW registers src1 and dest.
+; If src2isreg is #t then src2 may be a HW reg or a SW reg
+; If src2isreg is #f then src2 is an immediate fixnum, not shifted.
+; Src1 and dest may be RESULT, but src2 may not.
+; Src2 may be ARGREG2, the others may not.
+;
+; FIXME! This is incomprehensible.
+
+; New code below.
+
+'(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg)
+ (let ((L1 (new-label))
+ (op2 (if src2isreg
+ (force-hwreg! as src2 $r.tmp1)
+ (thefixnum src2))))
+ (if (and src2isreg (= op2 dest))
+ (begin (op as src1 op2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 dest))
+ (begin (op as src1 op2 dest)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as dest op2 dest)))
+ (let ((n (+ (if (not (= src1 $r.result)) 1 0)
+ (if (or (not src2isreg) (not (= op2 $r.argreg2))) 1 0)))
+ (mov2 (if src2isreg sparc.move sparc.set)))
+ (if (= n 2)
+ (mov2 as op2 $r.argreg2))
+ (sparc.jmpli as $r.millicode generic $r.o7)
+ (cond ((= n 0) (sparc.nop as))
+ ((= n 1) (mov2 as op2 $r.argreg2))
+ (else (sparc.move as src1 $r.result)))
+ ; Generic arithmetic leaves stuff in RESULT, must move to dest if
+ ; dest is not RESULT.
+ (if (not (= dest $r.result))
+ (sparc.move as $r.result dest))
+ (sparc.label as L1))))
+
+; Comprehensible, but longer.
+;
+; Important to be careful not to clobber arguments, and not to leave garbage
+; in rd, if millicode is called.
+;
+; op is the appropriate operation.
+; invop is the appropriate inverse operation.
+; RS1 can be any general hw register or RESULT.
+; RS2/IMM can be any general register or ARGREG2 (op2isreg=#t), or
+; an immediate (op2isreg=#f)
+; RD can be any general hw register or RESULT.
+;
+; FIXME: split this into two procedures.
+
+(define (emit-arith-primop! as op invop generic rs1 rs2/imm rd op2isreg)
+ (let ((L1 (new-label)))
+ (if op2isreg
+ (let ((rs2 (force-hwreg! as rs2/imm $r.argreg2)))
+ (cond ((or (= rs1 rs2 rd)
+ (and (= rs2 rd)
+ (= generic $m.subtract)))
+ (op as rs1 rs2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd))
+ ((= rs1 rd)
+ (op as rs1 rs2 rs1)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rs1 rs2 rs1))
+ ((= rs2 rd)
+ (op as rs1 rs2 rs2)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rs2 rs1 rs2))
+ (else
+ (op as rs1 rs2 rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (if (and (not (= rd $r.result)) (not (= rd $r.argreg2)))
+ (sparc.clr as rd))))
+ (cond ((and (= rs1 $r.result) (= rs2 $r.argreg2))
+ ;; Could peephole the INVOP or CLR into the slot here.
+ (millicode-call/0arg as generic))
+ ((= rs1 $r.result)
+ (millicode-call/1arg as generic rs2))
+ ((= rs2 $r.argreg2)
+ (millicode-call/1arg-in-result as generic rs1))
+ (else
+ (sparc.move as rs2 $r.argreg2)
+ (millicode-call/1arg-in-result as generic rs1))))
+ (let ((imm (thefixnum rs2/imm)))
+ (op as rs1 imm rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rd imm rd)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (millicode-call/numarg-in-reg as generic imm $r.argreg2)))
+ (if (not (= rd $r.result))
+ (sparc.move as $r.result rd))
+ (sparc.label as L1)))
+
+
+; Important to be careful not to leave garbage in rd if millicode is called.
+
+(define (emit-negate as rs rd)
+ (let ((L1 (new-label)))
+ (cond ((= rs rd)
+ (sparc.tsubrcc as $r.g0 rs rs)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (if (= rs $r.result)
+ (begin
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.subr as $r.g0 $r.result $r.result))
+ (begin
+ (sparc.subr as $r.g0 rs rs)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result))))
+ (else
+ (sparc.tsubrcc as $r.g0 rs rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (cond ((= rs $r.result)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.clr as rd))
+ ((= rd $r.result)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result))
+ (else
+ (sparc.clr as rd)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result)))))
+ (if (not (= rd $r.result))
+ (sparc.move as $r.result rd))
+ (sparc.label as L1)))
+
+; Character comparison.
+
+; r is a register or a character constant.
+
+(define (emit-char-cmp as r btrue.a excode)
+ (emit-charcmp! as (lambda ()
+ (let ((l2 (new-label)))
+ (sparc.set as $imm.false $r.result)
+ (btrue.a as L2)
+ (sparc.set as $imm.true $r.result)
+ (sparc.label as L2)))
+ $r.result
+ r
+ excode))
+
+; op1 is a hw register
+; op2 is a register or a character constant
+
+(define (emit-char-bcmp-primop! as bfalse.a op1 op2 L0 excode)
+ (emit-charcmp! as (lambda ()
+ (bfalse.a as L0)
+ (sparc.slot as))
+ op1
+ op2
+ excode))
+
+; We check the tags of both by xoring them and seeing if the low byte is 0.
+; If so, then we can subtract one from the other (tag and all) and check the
+; condition codes.
+;
+; The branch-on-true instruction must have the annull bit set. (???)
+;
+; op1 is a hw register
+; op2 is a register or a character constant.
+
+(define (emit-charcmp! as tail op1 op2 excode)
+ (let ((op2 (if (char? op2)
+ op2
+ (force-hwreg! as op2 $r.argreg2))))
+ (cond ((not (unsafe-code))
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (cond ((char? op2)
+ (sparc.xori as op1 $imm.character $r.tmp0)
+ (sparc.btsti as $r.tmp0 #xFF)
+ (sparc.srli as op1 16 $r.tmp0)
+ (sparc.be.a as L1)
+ (sparc.cmpi as $r.tmp0 (char->integer op2)))
+ (else
+ (sparc.andi as op1 #xFF $r.tmp0)
+ (sparc.andi as op2 #xFF $r.tmp1)
+ (sparc.cmpr as $r.tmp0 $r.tmp1)
+ (sparc.bne as FAULT)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.be.a as L1)
+ (sparc.cmpr as op1 op2)))
+ (sparc.label as FAULT)
+ (if (not (eqv? op1 $r.result))
+ (sparc.move as op1 $r.result))
+ (cond ((char? op2)
+ (emit-immediate->register! as
+ (char->immediate op2)
+ $r.argreg2))
+ ((not (eqv? op2 $r.argreg2))
+ (sparc.move as op2 $r.argreg2)))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)))
+ ((not (char? op2))
+ (sparc.cmpr as op1 op2))
+ (else
+ (sparc.srli as op1 16 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 (char->integer op2))))
+ (tail)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC code generation macros for primitives, part 3b:
+; helper procedures for data structures.
+
+
+; SET-CAR!, SET-CDR!, CELL-SET!
+;
+; Input: RS1: a hardware register; has pair pointer (tag check must be
+; performed by the caller).
+; RS2: any register; has value to store.
+; Output: None.
+;
+; Having rs1 != RESULT is pretty silly with the current write barrier
+; but will be less silly with the new barrier.
+
+(define (emit-setcar/setcdr! as rs1 rs2 offs)
+ (cond ((and (write-barrier) (hardware-mapped? rs2))
+ (sparc.sti as rs2 (- offs $tag.pair-tag) rs1)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (millicode-call/1arg as $m.addtrans rs2))
+ ((write-barrier)
+ (emit-move2hwreg! as rs2 $r.argreg2)
+ (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1)
+ (millicode-call/1arg-in-result as $m.addtrans rs1))
+ ((hardware-mapped? rs2)
+ (sparc.sti as rs2 (- offs $tag.pair-tag) rs1))
+ (else
+ (emit-move2hwreg! as rs2 $r.argreg2)
+ (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1))))
+
+
+
+
+; Representation predicate.
+;
+; RESULT has an object. If the tag of RESULT is 'tag1' and the
+; header byte of the object is 'tag2' then set RESULT to #t, else
+; set it to #f.
+
+(define (emit-double-tagcheck->bool! as tag1 tag2)
+ (let ((L1 (new-label)))
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false $r.result)
+ (sparc.ldbi as $r.result (+ (- tag1) 3) $r.tmp0)
+ (sparc.set as $imm.true $r.result)
+ (sparc.cmpi as $r.tmp0 tag2)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false $r.result)
+ (sparc.label as L1)))
+
+
+; Check structure tag.
+;
+; RS1 has an object. If the tag of RS1 is not 'tag1', or if the tag is
+; 'tag1' but the header byte of the object header is not 'tag2', then an
+; exception with code 'excode' is signalled. The exception call is set
+; up to return to the first instruction of the emitted code.
+;
+; If RS1 is not RESULT then it is moved to RESULT before the exception
+; is signalled.
+;
+; If RS2/IMM is not #f, then it is a register or immediate that is moved
+; to ARGREG2 before the exception is signalled; it is an immediate iff
+; imm? = #t.
+;
+; RS1 must be a hardware register.
+; RS2/IMM is a general register, ARGREG2, an immediate, or #f.
+; RS3 is a general register, ARGREG3, or #f.
+;
+; The procedure returns the label of the fault address. If the execution
+; falls off the end of the emitted instruction sequence, then the following
+; are true:
+; - the tag of the object in RS1 was 'tag1' and its header byte was 'tag2'
+; - the object header word is in TMP0.
+
+(define (double-tagcheck-assert as tag1 tag2 rs1 rs2/imm rs3 excode imm?)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as rs1 $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (sparc.be.a as L1)
+ (sparc.ldi as rs1 (- tag1) $r.tmp0)
+ (sparc.label as FAULT)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (if rs2/imm
+ (cond (imm?
+ (sparc.set as (thefixnum rs2/imm) $r.argreg2))
+ ((= rs2/imm $r.argreg2))
+ (else
+ (emit-move2hwreg! as rs2/imm $r.argreg2))))
+ (if (and rs3 (not (= rs3 $r.argreg3)))
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 tag2)
+ (sparc.bne.a as FAULT)
+ (sparc.slot as)
+ FAULT))
+
+(define (emit-double-tagcheck-assert! as tag1 tag2 excode reg2)
+ (double-tagcheck-assert as tag1 tag2 $r.result reg2 #f excode #f))
+
+(define (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs1 rs2 excode)
+ (double-tagcheck-assert as tag1 tag2 rs1 rs2 #f excode #f))
+
+(define (emit-double-tagcheck-assert-reg/imm! as tag1 tag2 rs1 imm excode)
+ (double-tagcheck-assert as tag1 tag2 rs1 imm #f excode #t))
+
+
+
+
+; Get the length of a vector or bytevector structure, with tag checking
+; included.
+;
+; Input: RS and RD are both hardware registers.
+
+(define (emit-get-length! as tag1 tag2 excode rs rd)
+ (if (not (unsafe-code))
+ (if tag2
+ (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs rd excode)
+ (emit-single-tagcheck-assert-reg! as tag1 rs rd excode)))
+ (emit-get-length-trusted! as tag1 rs rd))
+
+; Get the length of a vector or bytevector structure, without tag checking.
+;
+; Input: RS and RD are both hardware registers.
+
+(define (emit-get-length-trusted! as tag1 rs rd)
+ (sparc.ldi as rs (- tag1) $r.tmp0)
+ (sparc.srli as $r.tmp0 8 rd)
+ (if (= tag1 $tag.bytevector-tag)
+ (sparc.slli as rd 2 rd)))
+
+
+; Allocate a bytevector, leave untagged pointer in RESULT.
+
+(define (emit-allocate-bytevector as hdr preserved-result)
+
+ ; Preserve the length field, then calculate the number of words
+ ; to allocate. The value `28' is an adjustment of 3 (for rounding
+ ; up) plus another 4 bytes for the header, all represented as a fixnum.
+
+ (if (not preserved-result)
+ (sparc.move as $r.result $r.argreg2))
+ (sparc.addi as $r.result 28 $r.result)
+ (sparc.andi as $r.result (asm:signed #xFFFFFFF0) $r.result)
+
+ ; Allocate space
+
+ (sparc.jmpli as $r.millicode $m.alloc-bv $r.o7)
+ (sparc.srai as $r.result 2 $r.result)
+
+ ; Setup the header.
+
+ (if (not preserved-result)
+ (sparc.slli as $r.argreg2 6 $r.tmp0)
+ (sparc.slli as preserved-result 6 $r.tmp0))
+ (sparc.addi as $r.tmp0 hdr $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result))
+
+
+; Given a nativeint count, a pointer to the first element of a
+; bytevector-like structure, and a byte value, fill the bytevector
+; with the byte value.
+
+(define (emit-bytevector-fill as r-bytecount r-pointer r-value)
+ (let ((L2 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L2)
+ (sparc.deccc as r-bytecount)
+ (sparc.bge.a as L2)
+ (sparc.stbr as r-value r-bytecount r-pointer)
+ (sparc.label as L1)))
+
+
+; BYTEVECTOR-REF, BYTEVECTOR-LIKE-REF, STRING-REF.
+;
+; The pointer in RS1 is known to be bytevector-like. RS2 is the fixnum
+; index into the structure. Get the RS2'th element and place it in RD.
+;
+; RS1 and RD are hardware registers.
+; RS2 is a general register or ARGREG2.
+; 'fault' is defined iff (unsafe-code) = #f
+; header is in TMP0 iff (unsafe-code) = #f and 'header-loaded?' = #t
+; if 'charize?' is #t then store result as char, otherwise as fixnum.
+
+(define (emit-bytevector-like-ref! as rs1 rs2 rd fault charize? header-loaded?)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ ; check that index is fixnum
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
+ ; check length
+ (sparc.srai as rs2 2 $r.tmp1)
+ (sparc.srli as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 $r.tmp1)
+ (sparc.bleu as fault)
+ ; No NOP or SLOT -- the SUBI below goes into the slot.
+ )
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ ; Pointer is in RS1.
+ ; Shifted index is in TMP1.
+ (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
+ (sparc.ldbr as $r.tmp0 $r.tmp1 $r.tmp0)
+ (if (not charize?)
+ (sparc.slli as $r.tmp0 2 rd)
+ (begin (sparc.slli as $r.tmp0 16 rd)
+ (sparc.ori as rd $imm.character rd)))))
+
+; As above, but RS2 is replaced by an immediate, IMM.
+;
+; The immediate, represented as a fixnum, is guaranteed fit in the
+; instruction's immediate field.
+
+(define (emit-bytevector-like-ref/imm! as rs1 imm rd fault charize?
+ header-loaded?)
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
+ ; Range check.
+ (sparc.srli as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 imm)
+ (sparc.bleu.a as fault)
+ (sparc.slot as)))
+
+ ; Pointer is in RS1.
+
+ (let ((adjusted-offset (+ (- 4 $tag.bytevector-tag) imm)))
+ (if (immediate-literal? adjusted-offset)
+ (begin
+ (sparc.ldbi as rs1 adjusted-offset $r.tmp0))
+ (begin
+ (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
+ (sparc.ldbr as $r.tmp0 imm $r.tmp0)))
+ (if (not charize?)
+ (sparc.slli as $r.tmp0 2 rd)
+ (begin (sparc.slli as $r.tmp0 16 rd)
+ (sparc.ori as rd $imm.character rd)))))
+
+
+; BYTEVECTOR-SET!, BYTEVECTOR-LIKE-SET!
+;
+; Input: RESULT -- a pointer to a bytevector-like structure.
+; TMP0 -- the header iff (unsafe-code) = #f and header-loaded? = #t
+; IDX -- a register that holds the second argument
+; BYTE -- a register that holds the third argument
+; Output: Nothing.
+;
+; 'Fault' is the address of the error code iff (unsafe-code) = #f
+;
+; FIXME:
+; - Argument values passed to error handler appear to be bogus
+; (error message is very strange).
+; - There's no check that the value actually fits in a byte.
+; - Uses ARGREG3 and and TMP2.
+
+(define (emit-bytevector-like-set! as idx byte fault header-loaded?)
+ (let ((r1 (force-hwreg! as idx $r.tmp1))
+ (r2 (force-hwreg! as byte $r.argreg3)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0))
+ ; Both index and byte must be fixnums.
+ ; Can't use tsubcc because the computation may really overflow.
+ (sparc.orr as r1 r2 $r.tmp2)
+ (sparc.btsti as $r.tmp2 3)
+ (sparc.bnz as fault)
+ ; No NOP -- next instruction is OK in slot.
+ ; Index must be in range.
+ (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit - in slot
+ (sparc.srai as r1 2 $r.tmp1) ; index
+ (sparc.cmpr as $r.tmp1 $r.tmp0)
+ (sparc.bgeu as fault)
+ ; No NOP -- next instruction is OK in slot.
+ )
+ (begin
+ (sparc.srai as r1 2 $r.tmp1)))
+ (sparc.srli as r2 2 $r.tmp0)
+ ; Using ARGREG2 as the destination is OK because the resulting pointer
+ ; value always looks like a fixnum. By doing so, we avoid needing TMP2.
+ (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.argreg2)
+ (sparc.stbr as $r.tmp0 $r.tmp1 $r.argreg2)))
+
+
+; STRING-SET!
+
+(define (emit-string-set! as rs1 rs2 rs3)
+ (let* ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (rs3 (force-hwreg! as rs3 $r.argreg3))
+ (FAULT (if (not (unsafe-code))
+ (double-tagcheck-assert
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1 rs2 rs3
+ $ex.sset
+ #f))))
+ ; Header is in TMP0; TMP1 and TMP2 are free.
+ (if (not (unsafe-code))
+ (begin
+ ; RS2 must be a fixnum.
+ (sparc.btsti as rs2 3)
+ (sparc.bne as FAULT)
+ ; Index (in RS2) must be valid; header is in tmp0.
+ (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit
+ (sparc.srai as rs2 2 $r.tmp1) ; index
+ (sparc.cmpr as $r.tmp1 $r.tmp0)
+ (sparc.bgeu as FAULT)
+ ; RS3 must be a character.
+ (sparc.andi as rs3 #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne as FAULT)
+ ; No NOP -- the SRLI below goes in the slot
+ )
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ ; tmp1 has nativeint index.
+ ; rs3/argreg3 has character.
+ ; tmp0 is garbage.
+ (sparc.subi as $r.tmp1 (- $tag.bytevector-tag 4) $r.tmp1)
+ (sparc.srli as rs3 16 $r.tmp0)
+ (sparc.stbr as $r.tmp0 rs1 $r.tmp1)))
+
+
+; VECTORS and PROCEDURES
+
+; Allocate short vectors of known length; faster than the general case.
+; FIXME: can also allocate in-line.
+
+(define (make-vector-n as length r)
+ (sparc.jmpli as $r.millicode $m.alloc $r.o7)
+ (sparc.set as (thefixnum (+ length 1)) $r.result)
+ (emit-immediate->register! as (+ (* 256 (thefixnum length))
+ $imm.vector-header
+ $tag.vector-typetag)
+ $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (let ((dest (force-hwreg! as r $r.argreg2)))
+ (do ((i 0 (+ i 1)))
+ ((= i length))
+ (sparc.sti as dest (* (+ i 1) 4) $r.result)))
+ (sparc.addi as $r.result $tag.vector-tag $r.result))
+
+
+; emit-make-vector-like! assumes argreg3 is not destroyed by alloci.
+; FIXME: bug: $ex.mkvl is not right if the operation is make-procedure
+; or make-vector.
+
+(define (emit-make-vector-like! as r hdr ptrtag)
+ (let ((FAULT (emit-assert-positive-fixnum! as $r.result $ex.mkvl)))
+ (sparc.move as $r.result $r.argreg3)
+ (sparc.addi as $r.result 4 $r.result)
+ (sparc.jmpli as $r.millicode $m.alloci $r.o7)
+ (if (null? r)
+ (sparc.set as $imm.null $r.argreg2)
+ (emit-move2hwreg! as r $r.argreg2))
+ (sparc.slli as $r.argreg3 8 $r.tmp0)
+ (sparc.addi as $r.tmp0 hdr $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (sparc.addi as $r.result ptrtag $r.result)))
+
+
+; VECTOR-REF, VECTOR-LIKE-REF, PROCEDURE-REF
+;
+; FAULT is valid iff (unsafe-code) = #f
+; Header is in TMP0 iff (unsafe-code) = #f and header-loaded? = #t.
+
+(define (emit-vector-like-ref! as rs1 rs2 rd FAULT tag header-loaded?)
+ (let ((index (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- tag) $r.tmp0))
+ ; Index must be fixnum.
+ (sparc.btsti as index 3)
+ (sparc.bne as FAULT)
+ ; Index must be within bounds.
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 index)
+ (sparc.bleu as FAULT)
+ ; No NOP; the following instruction is valid in the slot.
+ ))
+ (emit-vector-like-ref-trusted! as rs1 index rd tag)))
+
+(define (emit-vector-like-ref-trusted! as rs1 rs2 rd tag)
+ (let ((index (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.addi as rs1 (- 4 tag) $r.tmp0)
+ (sparc.ldr as $r.tmp0 index rd)))
+
+
+; VECTOR-REF/IMM, VECTOR-LIKE-REF/IMM, PROCEDURE-REF/IMM
+;
+; 'rs1' is a hardware register containing a vectorish pointer (to a
+; vector-like or procedure).
+; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
+; 'rd' is a hardware register.
+; 'FAULT' is the label of the error code iff (unsafe-code) => #f
+; 'tag' is the tag of the pointer in rs1.
+; 'header-loaded?' is #t iff the structure header word is in $r.tmp0.
+
+(define (emit-vector-like-ref/imm! as rs1 imm rd FAULT tag header-loaded?)
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?) (sparc.ldi as rs1 (- tag) $r.tmp0))
+ ; Check bounds.
+ (sparc.srai as $r.tmp0 10 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 imm)
+ (sparc.bleu as FAULT)
+ (sparc.nop as)))
+ (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag))
+
+; 'rs1' is a hardware register containing a vectorish pointer (to a
+; vector-like or procedure).
+; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
+; 'rd' is a hardware register.
+; 'tag' is the tag of the pointer in rs1.
+
+(define (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag)
+ (let* ((offset (* imm 4)) ; words->bytes
+ (adjusted-offset (+ (- 4 tag) offset)))
+ (if (immediate-literal? adjusted-offset)
+ (begin
+ (sparc.ldi as rs1 adjusted-offset rd))
+ (begin
+ (sparc.addi as rs1 (- 4 tag) $r.tmp0)
+ (sparc.ldi as $r.tmp0 offset rd)))))
+
+
+
+; VECTOR-SET!, VECTOR-LIKE-SET!, PROCEDURE-SET!
+;
+; It is assumed that the pointer in RESULT is valid. We must check the index
+; in register x for validity and then perform the side effect (by calling
+; millicode). The tag is the pointer tag to be adjusted for.
+;
+; The use of vector-set is ok even if it is a procedure.
+
+; fault is valid iff (unsafe-code) = #f
+; header is in tmp0 iff (unsafe-code) = #f and header-loaded? = #t
+
+(define (emit-vector-like-set! as rs1 rs2 rs3 fault tag header-loaded?)
+ (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
+ (rs3 (force-hwreg! as rs3 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as $r.result (- tag) $r.tmp0))
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 rs2)
+ (sparc.bleu as fault)))
+ (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)))
+
+; rs1 must be a hardware register.
+; tag is the pointer tag to be adjusted for.
+
+(define (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)
+ (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
+ (rs3 (force-hwreg! as rs3 $r.argreg2)))
+ ;; The ADDR can go in the delay slot of a preceding BLEU.
+ (sparc.addr as rs1 rs2 $r.tmp0)
+ (cond ((not (write-barrier))
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0))
+ ((= rs1 $r.result)
+ (cond ((= rs3 $r.argreg2)
+ (sparc.jmpli as $r.millicode $m.addtrans $r.o7)
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0))
+ (else
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (millicode-call/1arg as $m.addtrans rs3))))
+ (else
+ (cond ((= rs3 $r.argreg2)
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (millicode-call/1arg-in-result as $m.addtrans rs1))
+ (else
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (sparc.move as rs1 $r.result)
+ (millicode-call/1arg as $m.addtrans rs3)))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 3:
+; fixnum-specific operations.
+;
+; Constraints for all the primops.
+;
+; RS1 is a general hardware register or RESULT.
+; RS2 is a general register or ARGREG2.
+; IMM is an exact integer in the range -1024 .. 1023.
+; RD is a general hardware register or RESULT.
+
+; FIXME
+; Missing fxquotient, fxremainder
+; When new pass1 in place:
+; Must add code to pass1 to allow n-ary calls to be rewritten as binary
+; Must add compiler macro for fxabs.
+
+
+; most-negative-fixnum, most-positive-fixnum.
+
+(define-primop 'most-negative-fixnum
+ (lambda (as)
+ (emit-immediate->register! as (asm:signed #x80000000) $r.result)))
+
+(define-primop 'most-positive-fixnum
+ (lambda (as)
+ (emit-immediate->register! as (asm:signed #x7FFFFFFC) $r.result)))
+
+
+; fx+, fx- w/o immediates
+
+(define-primop 'fx+
+ (lambda (as rs2)
+ (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr $r.result rs2 $r.result
+ $ex.fx+)))
+
+(define-primop 'internal:fx+
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr rs1 rs2 rd $ex.fx+)))
+
+(define-primop 'fx-
+ (lambda (as rs2)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.result rs2 $r.result
+ $ex.fx-)))
+
+(define-primop 'internal:fx-
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr rs1 rs2 rd $ex.fx-)))
+
+(define-primop 'fx--
+ (lambda (as)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr
+ $r.g0 $r.result $r.result $ex.fx--)))
+
+(define-primop 'internal:fx--
+ (lambda (as rs rd)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.g0 rs rd $ex.fx--)))
+
+(define (emit-fixnum-arithmetic as op-check op-nocheck rs1 rs2 rd exn)
+ (if (unsafe-code)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (op-nocheck as rs1 rs2 rd))
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (op-check as rs1 rs2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd)
+ (if (not (= exn $ex.fx--))
+ (begin
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2)))
+ (begin
+ (if (not (= rs2 $r.result)) (sparc.move as rs2 $r.result))))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1))))
+
+; fx* w/o immediate
+
+(define-primop 'fx*
+ (lambda (as rs2)
+ (emit-multiply-code as rs2 #t)))
+
+; fx+, fx- w/immediates
+
+(define-primop 'internal:fx+/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-arithmetic/imm as sparc.taddicc sparc.addi
+ rs imm rd $ex.fx+)))
+
+(define-primop 'internal:fx-/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-arithmetic/imm as sparc.tsubicc sparc.subi
+ rs imm rd $ex.fx-)))
+
+(define (emit-fixnum-arithmetic/imm as op-check op-nocheck rs imm rd exn)
+ (if (unsafe-code)
+ (op-nocheck as rs (thefixnum imm) rd)
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (op-check as rs (thefixnum imm) $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd)
+ (if (not (= rs $r.result)) (sparc.move as rs $r.result))
+ (sparc.set as (thefixnum imm) $r.argreg2)
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1))))
+
+
+; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
+
+(define-primop 'fx=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bne.a $r.result rs2 $r.result $ex.fx= #f)))
+
+(define-primop 'fx<
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bge.a $r.result rs2 $r.result $ex.fx< #f)))
+
+(define-primop 'fx<=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bg.a $r.result rs2 $r.result $ex.fx<= #f)))
+
+(define-primop 'fx>
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.ble.a $r.result rs2 $r.result $ex.fx> #f)))
+
+(define-primop 'fx>=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bl.a $r.result rs2 $r.result $ex.fx>= #f)))
+
+(define-primop 'internal:fx=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bne.a rs1 rs2 rd $ex.fx= #f)))
+
+(define-primop 'internal:fx<
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bge.a rs1 rs2 rd $ex.fx< #f)))
+
+(define-primop 'internal:fx<=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bg.a rs1 rs2 rd $ex.fx<= #f)))
+
+(define-primop 'internal:fx>
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.ble.a rs1 rs2 rd $ex.fx> #f)))
+
+(define-primop 'internal:fx>=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bl.a rs1 rs2 rd $ex.fx>= #f)))
+
+
+; Use '/imm' code for these because the generated code is better.
+
+(define-primop 'fxpositive?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.ble.a $r.result 0 $r.result
+ $ex.fxpositive? #f)))
+
+(define-primop 'fxnegative?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.bge.a $r.result 0 $r.result
+ $ex.fxnegative? #f)))
+
+(define-primop 'fxzero?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.bne.a $r.result 0 $r.result
+ $ex.fxzero? #f)))
+
+(define-primop 'internal:fxpositive?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.ble.a rs 0 rd $ex.fxpositive? #f)))
+
+(define-primop 'internal:fxnegative?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.bge.a rs 0 rd $ex.fxnegative? #f)))
+
+(define-primop 'internal:fxzero?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.bne.a rs 0 rd $ex.fxzero? #f)))
+
+
+; fx=, fx<, fx<=, fx>, fx>= w/immediates
+
+(define-primop 'internal:fx=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bne.a rs imm rd $ex.fx= #f)))
+
+(define-primop 'internal:fx</imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bge.a rs imm rd $ex.fx< #f)))
+
+(define-primop 'internal:fx<=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bg.a rs imm rd $ex.fx<= #f)))
+
+(define-primop 'internal:fx>/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.ble.a rs imm rd $ex.fx> #f)))
+
+(define-primop 'internal:fx>=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bl.a rs imm rd $ex.fx>= #f)))
+
+; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
+; for control.
+
+(define-primop 'internal:branchf-fx=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bne.a rs1 rs2 #f $ex.fx= L)))
+
+(define-primop 'internal:branchf-fx<
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bge.a rs1 rs2 #f $ex.fx< L)))
+
+(define-primop 'internal:branchf-fx<=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bg.a rs1 rs2 #f $ex.fx<= L)))
+
+(define-primop 'internal:branchf-fx>
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.ble.a rs1 rs2 #f $ex.fx> L)))
+
+(define-primop 'internal:branchf-fx>=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bl.a rs1 rs2 #f $ex.fx>= L)))
+
+(define-primop 'internal:branchf-fxpositive?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.ble.a rs1 0 #f $ex.fxpositive? L)))
+
+(define-primop 'internal:branchf-fxnegative?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.bge.a rs1 0 #f $ex.fxnegative? L)))
+
+(define-primop 'internal:branchf-fxzero?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.bne.a rs1 0 #f $ex.fxzero? L)))
+
+
+; fx=, fx<, fx<=, fx>, fx>= w/immediates for control.
+
+(define-primop 'internal:branchf-fx=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bne.a rs imm #f $ex.fx= L)))
+
+(define-primop 'internal:branchf-fx</imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bge.a rs imm #f $ex.fx< L)))
+
+(define-primop 'internal:branchf-fx<=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bg.a rs imm #f $ex.fx<= L)))
+
+(define-primop 'internal:branchf-fx>/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.ble.a rs imm #f $ex.fx> L)))
+
+(define-primop 'internal:branchf-fx>=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bl.a rs imm #f $ex.fx>= L)))
+
+
+; Trusted fixnum comparisons.
+
+(define-primop '=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bne.a $r.result rs2 $r.result #f)))
+
+(define-primop '<:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bge.a $r.result rs2 $r.result #f)))
+
+(define-primop '<=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bg.a $r.result rs2 $r.result #f)))
+
+(define-primop '>:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.ble.a $r.result rs2 $r.result #f)))
+
+(define-primop '>=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bl.a $r.result rs2 $r.result #f)))
+
+(define-primop 'internal:=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:<:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:<=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:>:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:>=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 rd #f)))
+
+; With immediates.
+
+(define-primop 'internal:=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm rd #f)))
+
+(define-primop 'internal:<:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm rd #f)))
+
+(define-primop 'internal:<=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm rd #f)))
+
+(define-primop 'internal:>:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm rd #f)))
+
+(define-primop 'internal:>=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm rd #f)))
+
+; Without immediates, for control.
+
+(define-primop 'internal:branchf-=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf-<:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf-<=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf->:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf->=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 #f L)))
+
+; With immediates, for control.
+
+(define-primop 'internal:branchf-=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm #f L)))
+
+(define-primop 'internal:branchf-<:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm #f L)))
+
+(define-primop 'internal:branchf-<=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm #f L)))
+
+(define-primop 'internal:branchf->:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm #f L)))
+
+(define-primop 'internal:branchf->=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm #f L)))
+
+; Range check: 0 <= src1 < src2
+
+(define-primop 'internal:check-range
+ (lambda (as src1 src2 L1 livregs)
+ (let ((src2 (force-hwreg! as src2 $r.argreg2)))
+ (emit-fixnum-compare-check
+ as src2 src1 sparc.bleu L1 livregs))))
+
+; Trusted fixnum comparisons followed by a check.
+
+(define-primop 'internal:check-=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-<:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bge L1 liveregs)))
+
+(define-primop 'internal:check-<=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bg L1 liveregs)))
+
+(define-primop 'internal:check->:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.ble L1 liveregs)))
+
+(define-primop 'internal:check->=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bl L1 liveregs)))
+
+(define-primop 'internal:check-=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-<:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bge L1 liveregs)))
+
+(define-primop 'internal:check-<=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bg L1 liveregs)))
+
+(define-primop 'internal:check->:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.ble L1 liveregs)))
+
+(define-primop 'internal:check->=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bl L1 liveregs)))
+
+; Below, 'target' is a label or #f. If #f, RD must be a general hardware
+; register or RESULT, and a boolean result is generated in RD.
+
+(define (emit-fixnum-compare as branchf.a rs1 rs2 rd exn target)
+ (if (unsafe-code)
+ (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.be.a as L1)
+ (sparc.cmpr as rs1 rs2)
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)
+ (emit-evaluate-cc! as branchf.a rd target))))
+
+; Below, 'target' is a label or #f. If #f, RD must be a general hardware
+; register or RESULT, and a boolean result is generated in RD.
+
+(define (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.cmpr as rs1 rs2)
+ (emit-evaluate-cc! as branchf.a rd target)))
+
+; rs must be a hardware register.
+
+(define (emit-fixnum-compare/imm as branchf.a rs imm rd exn target)
+ (if (unsafe-code)
+ (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (sparc.btsti as rs 3)
+ (sparc.be.a as L1)
+ (sparc.cmpi as rs (thefixnum imm))
+ (if (not (= rs $r.result)) (sparc.move as rs $r.result))
+ (sparc.set as (thefixnum imm) $r.argreg2)
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)))
+ (emit-evaluate-cc! as branchf.a rd target))
+
+; rs must be a hardware register.
+
+(define (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
+ (sparc.cmpi as rs (thefixnum imm))
+ (emit-evaluate-cc! as branchf.a rd target))
+
+; Range checks.
+
+(define (emit-fixnum-compare-check
+ as src1 src2 branch-bad L1 liveregs)
+ (internal-primop-invariant1 'emit-fixnum-compare-check src1)
+ (let ((src2 (force-hwreg! as src2 $r.argreg2)))
+ (sparc.cmpr as src1 src2)
+ (emit-checkcc! as branch-bad L1 liveregs)))
+
+(define (emit-fixnum-compare/imm-check
+ as src1 imm branch-bad L1 liveregs)
+ (internal-primop-invariant1 'emit-fixnum-compare/imm-check src1)
+ (sparc.cmpi as src1 imm)
+ (emit-checkcc! as branch-bad L1 liveregs))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC machine assembler flags.
+;
+; 12 April 1999
+
+
+; INTERNAL!
+(define short-effective-addresses
+ (make-twobit-flag 'short-effective-addresses))
+
+(define runtime-safety-checking
+ (make-twobit-flag 'runtime-safety-checking))
+
+(define catch-undefined-globals
+ (make-twobit-flag 'catch-undefined-globals))
+
+(define inline-allocation
+ (make-twobit-flag 'inline-allocation))
+
+;(define inline-assignment
+; (make-twobit-flag 'inline-assignment))
+
+(define write-barrier
+ (make-twobit-flag 'write-barrier))
+
+(define peephole-optimization
+ (make-twobit-flag 'peephole-optimization))
+
+(define single-stepping
+ (make-twobit-flag 'single-stepping))
+
+(define fill-delay-slots
+ (make-twobit-flag 'fill-delay-slots))
+
+; For backward compatibility.
+
+;(define unsafe-code
+; (make-twobit-flag 'unsafe-code))
+
+(define (unsafe-code . args)
+ (if (null? args)
+ (not (runtime-safety-checking))
+ (runtime-safety-checking (not (car args)))))
+
+(define (display-assembler-flags which)
+ (case which
+ ((debugging)
+ (display-twobit-flag single-stepping))
+ ((safety)
+ (display-twobit-flag write-barrier)
+ ;(display-twobit-flag unsafe-code)
+ (display-twobit-flag runtime-safety-checking)
+ (if (runtime-safety-checking)
+ (begin (display " ")
+ (display-twobit-flag catch-undefined-globals))))
+ ((optimization)
+ (display-twobit-flag peephole-optimization)
+ (display-twobit-flag inline-allocation)
+ ; (display-twobit-flag inline-assignment)
+ (display-twobit-flag fill-delay-slots))
+ (else #t)))
+
+(define (set-assembler-flags! mode)
+ (case mode
+ ((no-optimization)
+ (set-assembler-flags! 'standard)
+ (peephole-optimization #f)
+ (fill-delay-slots #f))
+ ((standard)
+ (short-effective-addresses #t)
+ (catch-undefined-globals #t)
+ (inline-allocation #f)
+ ; (inline-assignment #f)
+ (peephole-optimization #t)
+ (runtime-safety-checking #t)
+ (write-barrier #t)
+ (single-stepping #f)
+ (fill-delay-slots #t))
+ ((fast-safe default)
+ (set-assembler-flags! 'standard)
+ ; (inline-assignment #t)
+ (inline-allocation #t))
+ ((fast-unsafe)
+ (set-assembler-flags! 'fast-safe)
+ (catch-undefined-globals #f)
+ (runtime-safety-checking #f))
+ (else
+ (error "set-assembler-flags!: unknown mode " mode))))
+
+(set-assembler-flags! 'default)
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC disassembler.
+;
+; (disassemble-instruction instruction address)
+; => decoded-instruction
+;
+; (disassemble-codevector codevector)
+; => decoded-instruction-list
+;
+; (print-instructions decoded-instruction-list)
+; => unspecified
+; Also takes an optional port and optionally the symbol "native-names".
+;
+; (format-instruction decoded-instruction address larceny-names?)
+; => string
+;
+; A `decoded-instruction' is a list where the car is a mnemonic and
+; the operands are appropriate for that mnemonic.
+;
+; A `mnemonic' is an exact nonnegative integer. It encodes the name of
+; the instruction as well as its attributes (operand pattern and instruction
+; type). See below for specific operations on mnemonics.
+
+(define (disassemble-codevector cv)
+ (define (loop addr ilist)
+ (if (< addr 0)
+ ilist
+ (loop (- addr 4)
+ (cons (disassemble-instruction (bytevector-word-ref cv addr)
+ addr)
+ ilist))))
+ (loop (- (bytevector-length cv) 4) '()))
+
+(define disassemble-instruction) ; Defined below.
+
+\f; Mnemonics
+
+(define *asm-annul* 1)
+(define *asm-immed* 2)
+(define *asm-store* 4)
+(define *asm-load* 8)
+(define *asm-branch* 16)
+(define *asm-freg* 32)
+(define *asm-fpop* 64)
+(define *asm-no-op2* 128)
+(define *asm-no-op3* 256)
+
+(define *asm-bits*
+ `((a . ,*asm-annul*) (i . ,*asm-immed*) (s . ,*asm-store*)
+ (l . ,*asm-load*) (b . ,*asm-branch*) (f . ,*asm-freg*)
+ (fpop . ,*asm-fpop*) (no-op2 . ,*asm-no-op2*) (no-op3 . ,*asm-no-op3*)))
+
+(define *asm-mnemonic-table* '())
+
+(define mnemonic
+ (let ((n 0))
+ (lambda (name . rest)
+ (let* ((probe (assq name *asm-mnemonic-table*))
+ (code (* 1024
+ (if probe
+ (cdr probe)
+ (let ((code n))
+ (set! n (+ n 1))
+ (set! *asm-mnemonic-table*
+ (cons (cons name code)
+ *asm-mnemonic-table*))
+ code)))))
+ (for-each (lambda (x)
+ (set! code (+ code (cdr (assq x *asm-bits*)))))
+ rest)
+ code))))
+
+(define (mnemonic:name mnemonic)
+ (let ((mnemonic (quotient mnemonic 1024)))
+ (let loop ((t *asm-mnemonic-table*))
+ (cond ((null? t) #f)
+ ((= (cdar t) mnemonic) (caar t))
+ (else (loop (cdr t)))))))
+
+(define (mnemonic=? m name)
+ (= (quotient m 1024) (quotient (mnemonic name) 1024)))
+
+(define (mnemonic:test bit)
+ (lambda (mnemonic)
+ (not (zero? (logand mnemonic bit)))))
+
+(define (mnemonic:test-not bit)
+ (lambda (mnemonic)
+ (zero? (logand mnemonic bit))))
+
+(define mnemonic:annul? (mnemonic:test *asm-annul*))
+(define mnemonic:immediate? (mnemonic:test *asm-immed*))
+(define mnemonic:store? (mnemonic:test *asm-store*))
+(define mnemonic:load? (mnemonic:test *asm-load*))
+(define mnemonic:branch? (mnemonic:test *asm-branch*))
+(define mnemonic:freg? (mnemonic:test *asm-freg*))
+(define mnemonic:fpop? (mnemonic:test *asm-fpop*))
+(define mnemonic:op2? (mnemonic:test-not *asm-no-op2*))
+(define mnemonic:op3? (mnemonic:test-not *asm-no-op3*))
+
+\f; Instruction disassembler.
+
+(let ()
+
+ ;; Useful constants
+
+ (define two^3 (expt 2 3))
+ (define two^5 (expt 2 5))
+ (define two^6 (expt 2 6))
+ (define two^8 (expt 2 8))
+ (define two^9 (expt 2 9))
+ (define two^12 (expt 2 12))
+ (define two^13 (expt 2 13))
+ (define two^14 (expt 2 14))
+ (define two^16 (expt 2 16))
+ (define two^19 (expt 2 19))
+ (define two^21 (expt 2 21))
+ (define two^22 (expt 2 22))
+ (define two^24 (expt 2 24))
+ (define two^25 (expt 2 25))
+ (define two^29 (expt 2 29))
+ (define two^30 (expt 2 30))
+ (define two^32 (expt 2 32))
+
+ ;; Class 0 has branches and weirdness, like sethi and nop.
+ ;; We dispatch first on the op2 field and then on the op3 field.
+
+ (define class00
+ (let ((b-table
+ (vector (mnemonic 'bn 'b)
+ (mnemonic 'be 'b)
+ (mnemonic 'ble 'b)
+ (mnemonic 'bl 'b)
+ (mnemonic 'bleu 'b)
+ (mnemonic 'bcs 'b)
+ (mnemonic 'bneg 'b)
+ (mnemonic 'bvs 'b)
+ (mnemonic 'ba 'b)
+ (mnemonic 'bne 'b)
+ (mnemonic 'bg 'b)
+ (mnemonic 'bge 'b)
+ (mnemonic 'bgu 'b)
+ (mnemonic 'bcc 'b)
+ (mnemonic 'bpos 'b)
+ (mnemonic 'bvc 'b)
+ (mnemonic 'bn 'a 'b)
+ (mnemonic 'be 'a 'b)
+ (mnemonic 'ble 'a 'b)
+ (mnemonic 'bl 'a 'b)
+ (mnemonic 'bleu 'a 'b)
+ (mnemonic 'bcs 'a 'b)
+ (mnemonic 'bneg 'a 'b)
+ (mnemonic 'bvs 'a 'b)
+ (mnemonic 'ba 'a 'b)
+ (mnemonic 'bne 'a 'b)
+ (mnemonic 'bg 'a 'b)
+ (mnemonic 'bge 'a 'b)
+ (mnemonic 'bgu 'a 'b)
+ (mnemonic 'bcc 'a 'b)
+ (mnemonic 'bpos 'a 'b)
+ (mnemonic 'bvc 'a 'b)))
+ (fb-table
+ (vector (mnemonic 'fbn 'b)
+ (mnemonic 'fbne 'b)
+ (mnemonic 'fblg 'b)
+ (mnemonic 'fbul 'b)
+ (mnemonic 'fbl 'b)
+ (mnemonic 'fbug 'b)
+ (mnemonic 'fbg 'b)
+ (mnemonic 'fbu 'b)
+ (mnemonic 'fba 'b)
+ (mnemonic 'fbe 'b)
+ (mnemonic 'fbue 'b)
+ (mnemonic 'fbge 'b)
+ (mnemonic 'fbuge 'b)
+ (mnemonic 'fble 'b)
+ (mnemonic 'fbule 'b)
+ (mnemonic 'fbo 'b)
+ (mnemonic 'fbn 'a 'b)
+ (mnemonic 'fbne 'a 'b)
+ (mnemonic 'fblg 'a 'b)
+ (mnemonic 'fbul 'a 'b)
+ (mnemonic 'fbl 'a 'b)
+ (mnemonic 'fbug 'a 'b)
+ (mnemonic 'fbg 'a 'b)
+ (mnemonic 'fbu 'a 'b)
+ (mnemonic 'fba 'a 'b)
+ (mnemonic 'fbe 'a 'b)
+ (mnemonic 'fbue 'a 'b)
+ (mnemonic 'fbge 'a 'b)
+ (mnemonic 'fbuge 'a 'b)
+ (mnemonic 'fble 'a 'b)
+ (mnemonic 'fbule 'a 'b)
+ (mnemonic 'fbo 'a 'b)))
+ (nop (mnemonic 'nop))
+ (sethi (mnemonic 'sethi)))
+
+ (lambda (ip instr)
+ (let ((op2 (op2field instr)))
+ (cond ((= op2 #b100)
+ (if (zero? (rdfield instr))
+ `(,nop)
+ `(,sethi ,(imm22field instr) ,(rdfield instr))))
+ ((= op2 #b010)
+ `(,(vector-ref b-table (rdfield instr))
+ ,(* 4 (imm22field instr))))
+ ((= op2 #b110)
+ `(,(vector-ref fb-table (rdfield instr))
+ ,(* 4 (imm22field instr))))
+ (else
+ (disasm-error "Can't disassemble " (number->string instr 16)
+ " at ip=" ip
+ " with op2=" op2)))))))
+
+ ;; Class 1 is the call instruction; there's no choice.
+
+ (define (class01 ip instr)
+ `(,(mnemonic 'call) ,(* 4 (imm30field instr))))
+
+ ;; Class 2 is for the ALU. Dispatch on op3 field.
+
+ (define class10
+ (let ((op3-table
+ `#((,(mnemonic 'add) ,(mnemonic 'add 'i))
+ (,(mnemonic 'and) ,(mnemonic 'and 'i))
+ (,(mnemonic 'or) ,(mnemonic 'or 'i))
+ (,(mnemonic 'xor) ,(mnemonic 'xor 'i))
+ (,(mnemonic 'sub) ,(mnemonic 'sub 'i))
+ (,(mnemonic 'andn) ,(mnemonic 'andn 'i))
+ (,(mnemonic 'orn) ,(mnemonic 'orn 'i))
+ (,(mnemonic 'xnor) ,(mnemonic 'xnor 'i))
+ (0 0)
+ (0 0)
+ (0 0) ; 10
+ (,(mnemonic 'smul) ,(mnemonic 'smul 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'sdiv) ,(mnemonic 'sdiv 'i))
+ (,(mnemonic 'addcc) ,(mnemonic 'addcc 'i))
+ (,(mnemonic 'andcc) ,(mnemonic 'andcc 'i))
+ (,(mnemonic 'orcc) ,(mnemonic 'orcc 'i))
+ (,(mnemonic 'xorcc) ,(mnemonic 'xorcc 'i))
+ (,(mnemonic 'subcc) ,(mnemonic 'subcc 'i)) ; 20
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'smulcc) ,(mnemonic 'smulcc 'i))
+ (0 0)
+ (0 0)
+ (0 0) ; 30
+ (,(mnemonic 'sdivcc) ,(mnemonic 'sdivcc 'i))
+ (,(mnemonic 'taddcc) ,(mnemonic 'taddcc 'i))
+ (,(mnemonic 'tsubcc) ,(mnemonic 'tsubcc 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'sll) ,(mnemonic 'sll 'i))
+ (,(mnemonic 'srl) ,(mnemonic 'srl 'i))
+ (,(mnemonic 'sra) ,(mnemonic 'sra 'i))
+ (,(mnemonic 'rd) 0) ; 40
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'wr) ,(mnemonic 'wr 'i))
+ (0 0)
+ (0 0) ; 50
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'jmpl) ,(mnemonic 'jmpl 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'save) ,(mnemonic 'save 'i)) ; 60
+ (,(mnemonic 'restore) ,(mnemonic 'restore 'i))
+ (0 0)
+ (0 0))))
+
+ (lambda (ip instr)
+ (let ((op3 (op3field instr)))
+ (if (or (= op3 #b110100) (= op3 #b110101))
+ (fpop-instruction ip instr)
+ (nice-instruction op3-table ip instr))))))
+
+
+ ;; Class 3 is memory stuff.
+
+ (define class11
+ (let ((op3-table
+ `#((,(mnemonic 'ld 'l) ,(mnemonic 'ld 'i 'l))
+ (,(mnemonic 'ldb 'l) ,(mnemonic 'ldb 'i 'l))
+ (,(mnemonic 'ldh 'l) ,(mnemonic 'ldh 'i 'l))
+ (,(mnemonic 'ldd 'l) ,(mnemonic 'ldd 'i 'l))
+ (,(mnemonic 'st 's) ,(mnemonic 'st 'i 's))
+ (,(mnemonic 'stb 's) ,(mnemonic 'stb 'i 's))
+ (,(mnemonic 'sth 's) ,(mnemonic 'sth 'i 's))
+ (,(mnemonic 'std 's) ,(mnemonic 'std 'i 's))
+ (0 0)
+ (0 0)
+ (0 0) ; 10
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 20
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 30
+ (0 0)
+ (,(mnemonic 'ldf 'f 'l) ,(mnemonic 'ldf 'i 'f 'l))
+ (0 0)
+ (0 0)
+ (,(mnemonic 'lddf 'f 'l) ,(mnemonic 'lddf 'i 'f 'l))
+ (,(mnemonic 'stf 'f 's) ,(mnemonic 'stf 'i 'f 's))
+ (0 0)
+ (0 0)
+ (,(mnemonic 'stdf 'f 's) ,(mnemonic 'stdf 'i 'f 's))
+ (0 0) ; 40
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 50
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 60
+ (0 0)
+ (0 0)
+ (0 0))))
+
+ (lambda (ip instr)
+ (nice-instruction op3-table ip instr))))
+
+ ;; For classes 2 and 3
+
+ (define (nice-instruction op3-table ip instr)
+ (let* ((op3 (op3field instr))
+ (imm (ifield instr))
+ (rd (rdfield instr))
+ (rs1 (rs1field instr))
+ (src2 (if (zero? imm)
+ (rs2field instr)
+ (imm13field instr))))
+ (let ((op ((if (zero? imm) car cadr) (vector-ref op3-table op3))))
+ `(,op ,rs1 ,src2 ,rd))))
+
+ ;; Floating-point operate instructions
+
+ (define (fpop-instruction ip instr)
+ (let ((rd (rdfield instr))
+ (rs1 (rs1field instr))
+ (rs2 (rs2field instr))
+ (fpop (fpop-field instr)))
+ `(,(cdr (assv fpop fpop-names)) ,rs1 ,rs2 ,rd)))
+
+ (define fpop-names
+ `((#b000000001 . ,(mnemonic 'fmovs 'fpop 'no-op2))
+ (#b000000101 . ,(mnemonic 'fnegs 'fpop 'no-op2))
+ (#b000001001 . ,(mnemonic 'fabss 'fpop 'no-op2))
+ (#b001000010 . ,(mnemonic 'faddd 'fpop))
+ (#b001000110 . ,(mnemonic 'fsubd 'fpop))
+ (#b001001010 . ,(mnemonic 'fmuld 'fpop))
+ (#b001001110 . ,(mnemonic 'fdivd 'fpop))
+ (#b001010010 . ,(mnemonic 'fcmpd 'fpop 'no-op3))))
+
+
+ ;; The following procedures pick apart an instruction
+
+ (define (op2field instr)
+ (remainder (quotient instr two^22) two^3))
+
+ (define (op3field instr)
+ (remainder (quotient instr two^19) two^6))
+
+ (define (ifield instr)
+ (remainder (quotient instr two^13) 2))
+
+ (define (rs2field instr)
+ (remainder instr two^5))
+
+ (define (rs1field instr)
+ (remainder (quotient instr two^14) two^5))
+
+ (define (rdfield instr)
+ (remainder (quotient instr two^25) two^5))
+
+ (define (imm13field instr)
+ (let ((x (remainder instr two^13)))
+ (if (not (zero? (quotient x two^12)))
+ (- x two^13)
+ x)))
+
+ (define (imm22field instr)
+ (let ((x (remainder instr two^22)))
+ (if (not (zero? (quotient x two^21)))
+ (- x two^22)
+ x)))
+
+ (define (imm30field instr)
+ (let ((x (remainder instr two^30)))
+ (if (not (zero? (quotient x two^29)))
+ (- x two^30)
+ x)))
+
+ (define (fpop-field instr)
+ (remainder (quotient instr two^5) two^9))
+
+ (set! disassemble-instruction
+ (let ((class-table (vector class00 class01 class10 class11)))
+ (lambda (instr addr)
+ ((vector-ref class-table (quotient instr two^30)) addr instr))))
+
+ 'disassemble-instruction)
+
+
+\f; Instruction printer
+;
+; It assumes that the first instruction comes from address 0, and prints
+; addresses (and relative addresses) based on that assumption.
+;
+; If the optional symbol native-names is supplied, then SPARC register
+; names is used, and millicode calls are not annotated with millicode names.
+
+(define (print-instructions ilist . rest)
+
+ (define port (current-output-port))
+ (define larceny-names? #t)
+
+ (define (print-ilist ilist a)
+ (if (null? ilist)
+ '()
+ (begin (display (format-instruction (car ilist) a larceny-names?)
+ port)
+ (newline port)
+ (print-ilist (cdr ilist) (+ a 4)))))
+
+ (do ((rest rest (cdr rest)))
+ ((null? rest))
+ (cond ((port? (car rest))
+ (set! port (car rest)))
+ ((eq? (car rest) 'native-names)
+ (set! larceny-names? #f))))
+
+ (print-ilist ilist 0))
+
+(define format-instruction) ; Defined below
+
+(define *format-instructions-pretty* #t)
+
+; Instruction formatter.
+
+(let ()
+
+ (define use-larceny-registers #t)
+
+ (define sparc-register-table
+ (vector "%g0" "%g1" "%g2" "%g3" "%g4" "%g5" "%g6" "%g7"
+ "%o0" "%o1" "%o2" "%o3" "%o4" "%o5" "%o6" "%o7"
+ "%l0" "%l1" "%l2" "%l3" "%l4" "%l5" "%l6" "%l7"
+ "%i0" "%i1" "%i2" "%i3" "%i4" "%i5" "%i6" "%i7"))
+
+ (define larceny-register-table
+ (make-vector 32 #f))
+
+ (define (larceny-register-name reg . rest)
+ (if (null? rest)
+ (or (and use-larceny-registers
+ (vector-ref larceny-register-table reg))
+ (vector-ref sparc-register-table reg))
+ (vector-set! larceny-register-table reg (car rest))))
+
+ (define millicode-procs '())
+
+ (define (float-register-name reg)
+ (string-append "%f" (number->string reg)))
+
+ (define op car)
+ (define op1 cadr)
+ (define op2 caddr)
+ (define op3 cadddr)
+ (define tabstring (string #\tab))
+
+ (define (heximm n)
+ (if (>= n 16)
+ (string-append tabstring "! 0x" (number->string n 16))
+ ""))
+
+ (define (millicode-name offset . rest)
+ (if (null? rest)
+ (let ((probe (assv offset millicode-procs)))
+ (if probe
+ (cdr probe)
+ "[unknown]"))
+ (set! millicode-procs
+ (cons (cons offset (car rest)) millicode-procs))))
+
+ (define (millicode-call offset)
+ (string-append tabstring "! " (millicode-name offset)))
+
+ (define (plus/minus n)
+ (cond ((< n 0)
+ (string-append " - " (number->string (abs n))))
+ ((and (= n 0) *format-instructions-pretty*) "")
+ (else
+ (string-append " + " (number->string n)))))
+
+ (define (srcreg instr extractor)
+ (if (mnemonic:freg? (op instr))
+ (float-register-name (extractor instr))
+ (larceny-register-name (extractor instr))))
+
+ (define (sethi instr)
+ (string-append (number->string (* (op1 instr) 1024)) ", "
+ (larceny-register-name (op2 instr))
+ (heximm (* (op1 instr) 1024))))
+
+ (define (rrr instr)
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (larceny-register-name (op2 instr)) ", "
+ (larceny-register-name (op3 instr))))
+
+ (define (rir instr)
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (number->string (op2 instr)) ", "
+ (larceny-register-name (op3 instr))
+ (heximm (op2 instr))))
+
+ (define (sir instr)
+ (string-append (srcreg instr op3) ", [ "
+ (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) " ]"))
+
+ (define (srr instr)
+ (string-append (srcreg instr op3) ", [ "
+ (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) " ]"))
+
+ (define (lir instr)
+ (string-append "[ " (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) " ], "
+ (srcreg instr op3)))
+
+ (define (lrr instr)
+ (string-append "[ " (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) " ], "
+ (srcreg instr op3)))
+
+ (define (bimm instr addr)
+ (string-append "#" (number->string (+ (op1 instr) addr))))
+
+ (define (jmpli instr)
+ (string-append (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) ", "
+ (larceny-register-name (op3 instr))
+ (if (and (= (op1 instr) $r.globals)
+ use-larceny-registers)
+ (millicode-call (op2 instr))
+ (heximm (op2 instr)))))
+
+ (define (jmplr instr)
+ (string-append (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) ", "
+ (larceny-register-name (op3 instr))))
+
+ (define (call instr addr)
+ (string-append "#" (number->string (+ (op1 instr) addr))))
+
+ (define (rd instr)
+ (string-append "%y, " (srcreg instr op3)))
+
+ (define (wr instr imm?)
+ (if imm?
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (number->string (op2 instr)) ", %y"
+ (larceny-register-name (op3 instr)))
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (larceny-register-name (op2 instr)) ", %y")))
+
+ (define (fpop instr op2-used? op3-used?)
+ (string-append (float-register-name (op1 instr)) ", "
+ (cond ((and op2-used? op3-used?)
+ (string-append
+ (float-register-name (op2 instr)) ", "
+ (float-register-name (op3 instr))))
+ (op2-used?
+ (float-register-name (op2 instr)))
+ (else
+ (float-register-name (op3 instr))))))
+
+ ;; If we want to handle instruction aliases (clr, mov, etc) then
+ ;; the structure of this procedure must change, because as it is,
+ ;; the printing of the name is independent of the operand values.
+
+ (define (format-instr i a larceny-names?)
+ (set! use-larceny-registers larceny-names?)
+ (let ((m (car i)))
+ (string-append (number->string a)
+ tabstring
+ (symbol->string (mnemonic:name m))
+ (if (mnemonic:annul? m) ",a" "")
+ tabstring
+ (cond ((mnemonic:store? m)
+ (if (mnemonic:immediate? m) (sir i) (srr i)))
+ ((mnemonic:load? m)
+ (if (mnemonic:immediate? m) (lir i) (lrr i)))
+ ((mnemonic:fpop? m)
+ (fpop i (mnemonic:op2? m) (mnemonic:op3? m)))
+ ((mnemonic:branch? m) (bimm i a))
+ ((mnemonic=? m 'sethi) (sethi i))
+ ((mnemonic=? m 'nop) "")
+ ((mnemonic=? m 'jmpl)
+ (if (mnemonic:immediate? m) (jmpli i) (jmplr i)))
+ ((mnemonic=? m 'call) (call i a))
+ ((mnemonic=? m 'rd) (rd i))
+ ((mnemonic=? m 'wr) (wr i (mnemonic:immediate? m)))
+ ((mnemonic:immediate? m) (rir i))
+ (else (rrr i))))))
+
+ (larceny-register-name $r.tmp0 "%tmp0")
+ (larceny-register-name $r.result "%result")
+ (larceny-register-name $r.argreg2 "%argreg2")
+ (larceny-register-name $r.argreg3 "%argreg3")
+ (larceny-register-name $r.tmp1 "%tmp1")
+ (larceny-register-name $r.tmp2 "%tmp2")
+ (larceny-register-name $r.reg0 "%r0")
+ (larceny-register-name $r.reg1 "%r1")
+ (larceny-register-name $r.reg2 "%r2")
+ (larceny-register-name $r.reg3 "%r3")
+ (larceny-register-name $r.reg4 "%r4")
+ (larceny-register-name $r.reg5 "%r5")
+ (larceny-register-name $r.reg6 "%r6")
+ (larceny-register-name $r.reg7 "%r7")
+ (larceny-register-name $r.e-top "%etop")
+ (larceny-register-name $r.e-limit "%elim")
+ (larceny-register-name $r.timer "%timer")
+ (larceny-register-name $r.millicode "%millicode")
+ (larceny-register-name $r.globals "%globals")
+ (larceny-register-name $r.stkp "%stkp") ; note: after elim
+
+ (millicode-name $m.alloc "alloc")
+ (millicode-name $m.alloci "alloci")
+ (millicode-name $m.gc "gc")
+ (millicode-name $m.addtrans "addtrans")
+ (millicode-name $m.stkoflow "stkoflow")
+ (millicode-name $m.stkuflow "stkuflow")
+ (millicode-name $m.creg "creg")
+ (millicode-name $m.creg-set! "creg-set!")
+ (millicode-name $m.add "+")
+ (millicode-name $m.subtract "- (binary)")
+ (millicode-name $m.multiply "*")
+ (millicode-name $m.quotient "quotient")
+ (millicode-name $m.remainder "remainder")
+ (millicode-name $m.divide "/")
+ (millicode-name $m.modulo "modulo")
+ (millicode-name $m.negate "- (unary)")
+ (millicode-name $m.numeq "=")
+ (millicode-name $m.numlt "<")
+ (millicode-name $m.numle "<=")
+ (millicode-name $m.numgt ">")
+ (millicode-name $m.numge ">=")
+ (millicode-name $m.zerop "zero?")
+ (millicode-name $m.complexp "complex?")
+ (millicode-name $m.realp "real?")
+ (millicode-name $m.rationalp "rational?")
+ (millicode-name $m.integerp "integer?")
+ (millicode-name $m.exactp "exact?")
+ (millicode-name $m.inexactp "inexact?")
+ (millicode-name $m.exact->inexact "exact->inexact")
+ (millicode-name $m.inexact->exact "inexact->exact")
+ (millicode-name $m.make-rectangular "make-rectangular")
+ (millicode-name $m.real-part "real-part")
+ (millicode-name $m.imag-part "imag-part")
+ (millicode-name $m.sqrt "sqrt")
+ (millicode-name $m.round "round")
+ (millicode-name $m.truncate "truncate")
+ (millicode-name $m.apply "apply")
+ (millicode-name $m.varargs "varargs")
+ (millicode-name $m.typetag "typetag")
+ (millicode-name $m.typetag-set "typetag-set")
+ (millicode-name $m.break "break")
+ (millicode-name $m.eqv "eqv?")
+ (millicode-name $m.partial-list->vector "partial-list->vector")
+ (millicode-name $m.timer-exception "timer-exception")
+ (millicode-name $m.exception "exception")
+ (millicode-name $m.singlestep "singlestep")
+ (millicode-name $m.syscall "syscall")
+ (millicode-name $m.bvlcmp "bvlcmp")
+ (millicode-name $m.enable-interrupts "enable-interrupts")
+ (millicode-name $m.disable-interrupts "disable-interrupts")
+ (millicode-name $m.alloc-bv "alloc-bv")
+ (millicode-name $m.global-ex "global-exception")
+ (millicode-name $m.invoke-ex "invoke-exception")
+ (millicode-name $m.global-invoke-ex "global-invoke-exception")
+ (millicode-name $m.argc-ex "argc-exception")
+
+ (set! format-instruction format-instr)
+ 'format-instruction)
+
+
+; eof
+
+
+; ----------------------------------------------------------------------
+
+(define (twobit-benchmark type . rest)
+ (let ((k (if (null? rest) 1 (car rest))))
+ (run-benchmark
+ "twobit"
+ k
+ (lambda ()
+ (case type
+ ((long)
+ (compiler-switches 'fast-safe)
+ (benchmark-block-mode #f)
+ (compile-file "benchmarks/twobit-input-long.sch"))
+ ((short)
+ (compiler-switches 'fast-safe)
+ (benchmark-block-mode #t)
+ (compile-file "benchmarks/twobit-input-short.sch"))
+ (else
+ (error "Benchmark type must be `long' or `short': " type))))
+ (lambda (result)
+ #t))))
+
+; eof
--- /dev/null
+;;; NUCLEIC -- 3D structure determination of a nucleic acid.
+
+; Author: Marc Feeley (feeley@iro.umontreal.ca)
+;
+; Last modified: January 27, 1996
+;
+; This program is a modified version of the program described in the paper:
+;
+; M. Feeley, M. Turcotte, G. Lapalme, "Using Multilisp for Solving
+; Constraint Satisfaction Problems: an Application to Nucleic Acid 3D
+; Structure Determination" published in the journal "Lisp and Symbolic
+; Computation".
+;
+; The differences between this program and the original are described in
+; the paper:
+;
+; "???" published in the "Journal of Functional Programming".
+
+(define fatal-error error)
+
+; Macros...
+
+; Flonum arithmetic.
+
+(define-syntax FLOATvector-const
+ (syntax-rules ()
+ ((FLOATvector-const x ...) '#(x ...))))
+
+(define-syntax FLOATvector?
+ (syntax-rules ()
+ ((FLOATvector? x) (vector? x))))
+
+(define-syntax FLOATvector
+ (syntax-rules ()
+ ((FLOATvector x ...) (vector x ...))))
+
+(define-syntax FLOATmake-vector
+ (syntax-rules ()
+ ((FLOATmake-vector n) (make-vector n 0.0))
+ ((FLOATmake-vector n init) (make-vector n init))))
+
+(define-syntax FLOATvector-ref
+ (syntax-rules ()
+ ((FLOATvector-ref v i) (vector-ref v i))))
+
+(define-syntax FLOATvector-set!
+ (syntax-rules ()
+ ((FLOATvector-set! v i x) (vector-set! v i x))))
+
+(define-syntax FLOATvector-length
+ (syntax-rules ()
+ ((FLOATvector-length v) (vector-length v))))
+
+(define-syntax nuc-const
+ (syntax-rules ()
+ ((FLOATnuc-const x ...) '#(x ...))))
+
+(define-syntax FLOAT+
+ (syntax-rules ()
+ ((FLOAT+) 0.0)
+ ((FLOAT+ x) x)
+ ((FLOAT+ x y ...) (+ x (FLOAT+ y ...)))))
+
+(define-syntax FLOAT-
+ (syntax-rules ()
+ ((FLOAT- x) (- x))
+ ((FLOAT- x y ...) (- x (FLOAT+ y ...)))))
+
+(define-syntax FLOAT*
+ (syntax-rules ()
+ ((FLOAT*) 1.0)
+ ((FLOAT* x) x)
+ ((FLOAT* x y ...) (* x (FLOAT* y ...)))))
+
+(define-syntax FLOAT/
+ (syntax-rules ()
+ ((FLOAT/ x) (/ x))
+ ((FLOAT/ x y ...) (/ x (FLOAT* y ...)))))
+
+(define-syntax FLOAT=
+ (syntax-rules ()
+ ((FLOAT= x y) (= x y))))
+
+(define-syntax FLOAT<
+ (syntax-rules ()
+ ((FLOAT< x y) (< x y))))
+
+(define-syntax FLOAT<=
+ (syntax-rules ()
+ ((FLOAT<= x y) (<= x y))))
+
+(define-syntax FLOAT>
+ (syntax-rules ()
+ ((FLOAT> x y) (> x y))))
+
+(define-syntax FLOAT>=
+ (syntax-rules ()
+ ((FLOAT>= x y) (>= x y))))
+
+(define-syntax FLOATnegative?
+ (syntax-rules ()
+ ((FLOATnegative? x) (< x 0.0))))
+
+(define-syntax FLOATpositive?
+ (syntax-rules ()
+ ((FLOATpositive? x) (> x 0.0))))
+
+(define-syntax FLOATzero?
+ (syntax-rules ()
+ ((FLOATzero? x) (= x 0.0))))
+
+(define-syntax FLOATabs
+ (syntax-rules ()
+ ((FLOATabs x) (abs x))))
+
+(define-syntax FLOATsin
+ (syntax-rules ()
+ ((FLOATsin x) (sin x))))
+
+(define-syntax FLOATcos
+ (syntax-rules ()
+ ((FLOATcos x) (cos x))))
+
+(define-syntax FLOATatan
+ (syntax-rules ()
+ ((FLOATatan x) (atan x))))
+
+(define-syntax FLOATsqrt
+ (syntax-rules ()
+ ((FLOATsqrt x) (sqrt x))))
+
+(define-syntax FLOATmin
+ (syntax-rules ()
+ ((FLOATmin x y) (min x y))))
+
+(define-syntax FLOATmax
+ (syntax-rules ()
+ ((FLOATmax x y) (max x y))))
+
+(define-syntax FLOATround
+ (syntax-rules ()
+ ((FLOATround x) (round x))))
+
+(define-syntax FLOATinexact->exact
+ (syntax-rules ()
+ ((FLOATinexact->exact x) (inexact->exact x))))
+
+; Fixnum arithmetic everywhere else.
+; More fixnum macros can be found in prefix-chez.scm.
+
+(define-syntax bitwise-or
+ (syntax-rules ()
+ ((bitwise-or x y) (logior x y))))
+
+(define-syntax bitwise-and
+ (syntax-rules ()
+ ((bitwise-and x y) (logand x y))))
+
+(define-syntax bitwise-not
+ (syntax-rules ()
+ ((bitwise-not x) (lognot x))))
+
+
+; -- MATH UTILITIES -----------------------------------------------------------
+
+(define constant-pi 3.14159265358979323846)
+(define constant-minus-pi -3.14159265358979323846)
+(define constant-pi/2 1.57079632679489661923)
+(define constant-minus-pi/2 -1.57079632679489661923)
+
+(define (math-atan2 y x)
+ (cond ((FLOAT> x 0.0)
+ (FLOATatan (FLOAT/ y x)))
+ ((FLOAT< y 0.0)
+ (if (FLOAT= x 0.0)
+ constant-minus-pi/2
+ (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-minus-pi)))
+ (else
+ (if (FLOAT= x 0.0)
+ constant-pi/2
+ (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-pi)))))
+
+; -- POINTS -------------------------------------------------------------------
+
+(define (make-pt x y z)
+ (FLOATvector x y z))
+
+(define (pt-x pt) (FLOATvector-ref pt 0))
+(define (pt-x-set! pt val) (FLOATvector-set! pt 0 val))
+(define (pt-y pt) (FLOATvector-ref pt 1))
+(define (pt-y-set! pt val) (FLOATvector-set! pt 1 val))
+(define (pt-z pt) (FLOATvector-ref pt 2))
+(define (pt-z-set! pt val) (FLOATvector-set! pt 2 val))
+
+(define (pt-sub p1 p2)
+ (make-pt (FLOAT- (pt-x p1) (pt-x p2))
+ (FLOAT- (pt-y p1) (pt-y p2))
+ (FLOAT- (pt-z p1) (pt-z p2))))
+
+(define (pt-dist p1 p2)
+ (let ((dx (FLOAT- (pt-x p1) (pt-x p2)))
+ (dy (FLOAT- (pt-y p1) (pt-y p2)))
+ (dz (FLOAT- (pt-z p1) (pt-z p2))))
+ (FLOATsqrt (FLOAT+ (FLOAT* dx dx) (FLOAT* dy dy) (FLOAT* dz dz)))))
+
+(define (pt-phi p)
+ (let* ((x (pt-x p))
+ (y (pt-y p))
+ (z (pt-z p))
+ (b (math-atan2 x z)))
+ (math-atan2 (FLOAT+ (FLOAT* (FLOATcos b) z) (FLOAT* (FLOATsin b) x)) y)))
+
+(define (pt-theta p)
+ (math-atan2 (pt-x p) (pt-z p)))
+
+; -- COORDINATE TRANSFORMATIONS -----------------------------------------------
+
+; The notation for the transformations follows "Paul, R.P. (1981) Robot
+; Manipulators. MIT Press." with the exception that our transformation
+; matrices don't have the perspective terms and are the transpose of
+; Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to
+; Solid Modeling, Computer Science Press" Appendix A.
+;
+; The components of a transformation matrix are named like this:
+;
+; a b c
+; d e f
+; g h i
+; tx ty tz
+;
+; The components tx, ty, and tz are the translation vector.
+
+(define (make-tfo a b c d e f g h i tx ty tz)
+ (FLOATvector a b c d e f g h i tx ty tz))
+
+(define (tfo-a tfo) (FLOATvector-ref tfo 0))
+(define (tfo-a-set! tfo val) (FLOATvector-set! tfo 0 val))
+(define (tfo-b tfo) (FLOATvector-ref tfo 1))
+(define (tfo-b-set! tfo val) (FLOATvector-set! tfo 1 val))
+(define (tfo-c tfo) (FLOATvector-ref tfo 2))
+(define (tfo-c-set! tfo val) (FLOATvector-set! tfo 2 val))
+(define (tfo-d tfo) (FLOATvector-ref tfo 3))
+(define (tfo-d-set! tfo val) (FLOATvector-set! tfo 3 val))
+(define (tfo-e tfo) (FLOATvector-ref tfo 4))
+(define (tfo-e-set! tfo val) (FLOATvector-set! tfo 4 val))
+(define (tfo-f tfo) (FLOATvector-ref tfo 5))
+(define (tfo-f-set! tfo val) (FLOATvector-set! tfo 5 val))
+(define (tfo-g tfo) (FLOATvector-ref tfo 6))
+(define (tfo-g-set! tfo val) (FLOATvector-set! tfo 6 val))
+(define (tfo-h tfo) (FLOATvector-ref tfo 7))
+(define (tfo-h-set! tfo val) (FLOATvector-set! tfo 7 val))
+(define (tfo-i tfo) (FLOATvector-ref tfo 8))
+(define (tfo-i-set! tfo val) (FLOATvector-set! tfo 8 val))
+(define (tfo-tx tfo) (FLOATvector-ref tfo 9))
+(define (tfo-tx-set! tfo val) (FLOATvector-set! tfo 9 val))
+(define (tfo-ty tfo) (FLOATvector-ref tfo 10))
+(define (tfo-ty-set! tfo val) (FLOATvector-set! tfo 10 val))
+(define (tfo-tz tfo) (FLOATvector-ref tfo 11))
+(define (tfo-tz-set! tfo val) (FLOATvector-set! tfo 11 val))
+
+(define tfo-id ; the identity transformation matrix
+ (FLOATvector-const
+ 1.0 0.0 0.0
+ 0.0 1.0 0.0
+ 0.0 0.0 1.0
+ 0.0 0.0 0.0))
+
+; The function "tfo-apply" multiplies a transformation matrix, tfo, by a
+; point vector, p. The result is a new point.
+
+(define (tfo-apply tfo p)
+ (let ((x (pt-x p))
+ (y (pt-y p))
+ (z (pt-z p)))
+ (make-pt
+ (FLOAT+ (FLOAT* x (tfo-a tfo))
+ (FLOAT* y (tfo-d tfo))
+ (FLOAT* z (tfo-g tfo))
+ (tfo-tx tfo))
+ (FLOAT+ (FLOAT* x (tfo-b tfo))
+ (FLOAT* y (tfo-e tfo))
+ (FLOAT* z (tfo-h tfo))
+ (tfo-ty tfo))
+ (FLOAT+ (FLOAT* x (tfo-c tfo))
+ (FLOAT* y (tfo-f tfo))
+ (FLOAT* z (tfo-i tfo))
+ (tfo-tz tfo)))))
+
+; The function "tfo-combine" multiplies two transformation matrices A and B.
+; The result is a new matrix which cumulates the transformations described
+; by A and B.
+
+(define (tfo-combine A B)
+ (make-tfo
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-a B))
+ (FLOAT* (tfo-b A) (tfo-d B))
+ (FLOAT* (tfo-c A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-b B))
+ (FLOAT* (tfo-b A) (tfo-e B))
+ (FLOAT* (tfo-c A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-a A) (tfo-c B))
+ (FLOAT* (tfo-b A) (tfo-f B))
+ (FLOAT* (tfo-c A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-a B))
+ (FLOAT* (tfo-e A) (tfo-d B))
+ (FLOAT* (tfo-f A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-b B))
+ (FLOAT* (tfo-e A) (tfo-e B))
+ (FLOAT* (tfo-f A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-d A) (tfo-c B))
+ (FLOAT* (tfo-e A) (tfo-f B))
+ (FLOAT* (tfo-f A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-a B))
+ (FLOAT* (tfo-h A) (tfo-d B))
+ (FLOAT* (tfo-i A) (tfo-g B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-b B))
+ (FLOAT* (tfo-h A) (tfo-e B))
+ (FLOAT* (tfo-i A) (tfo-h B)))
+ (FLOAT+ (FLOAT* (tfo-g A) (tfo-c B))
+ (FLOAT* (tfo-h A) (tfo-f B))
+ (FLOAT* (tfo-i A) (tfo-i B)))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-a B))
+ (FLOAT* (tfo-ty A) (tfo-d B))
+ (FLOAT* (tfo-tz A) (tfo-g B))
+ (tfo-tx B))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-b B))
+ (FLOAT* (tfo-ty A) (tfo-e B))
+ (FLOAT* (tfo-tz A) (tfo-h B))
+ (tfo-ty B))
+ (FLOAT+ (FLOAT* (tfo-tx A) (tfo-c B))
+ (FLOAT* (tfo-ty A) (tfo-f B))
+ (FLOAT* (tfo-tz A) (tfo-i B))
+ (tfo-tz B))))
+
+; The function "tfo-inv-ortho" computes the inverse of a homogeneous
+; transformation matrix.
+
+(define (tfo-inv-ortho tfo)
+ (let* ((tx (tfo-tx tfo))
+ (ty (tfo-ty tfo))
+ (tz (tfo-tz tfo)))
+ (make-tfo
+ (tfo-a tfo) (tfo-d tfo) (tfo-g tfo)
+ (tfo-b tfo) (tfo-e tfo) (tfo-h tfo)
+ (tfo-c tfo) (tfo-f tfo) (tfo-i tfo)
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-a tfo) tx)
+ (FLOAT* (tfo-b tfo) ty)
+ (FLOAT* (tfo-c tfo) tz)))
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-d tfo) tx)
+ (FLOAT* (tfo-e tfo) ty)
+ (FLOAT* (tfo-f tfo) tz)))
+ (FLOAT- (FLOAT+ (FLOAT* (tfo-g tfo) tx)
+ (FLOAT* (tfo-h tfo) ty)
+ (FLOAT* (tfo-i tfo) tz))))))
+
+; Given three points p1, p2, and p3, the function "tfo-align" computes
+; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
+; mapped to the Y axis and p3 gets mapped to the YZ plane.
+
+(define (tfo-align p1 p2 p3)
+ (let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1))
+ (x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3))
+ (x31 (FLOAT- x3 x1)) (y31 (FLOAT- y3 y1)) (z31 (FLOAT- z3 z1))
+ (rotpY (pt-sub p2 p1))
+ (Phi (pt-phi rotpY))
+ (Theta (pt-theta rotpY))
+ (sinP (FLOATsin Phi))
+ (sinT (FLOATsin Theta))
+ (cosP (FLOATcos Phi))
+ (cosT (FLOATcos Theta))
+ (sinPsinT (FLOAT* sinP sinT))
+ (sinPcosT (FLOAT* sinP cosT))
+ (cosPsinT (FLOAT* cosP sinT))
+ (cosPcosT (FLOAT* cosP cosT))
+ (rotpZ
+ (make-pt
+ (FLOAT- (FLOAT* cosT x31)
+ (FLOAT* sinT z31))
+ (FLOAT+ (FLOAT* sinPsinT x31)
+ (FLOAT* cosP y31)
+ (FLOAT* sinPcosT z31))
+ (FLOAT+ (FLOAT* cosPsinT x31)
+ (FLOAT- (FLOAT* sinP y31))
+ (FLOAT* cosPcosT z31))))
+ (Rho (pt-theta rotpZ))
+ (cosR (FLOATcos Rho))
+ (sinR (FLOATsin Rho))
+ (x (FLOAT+ (FLOAT- (FLOAT* x1 cosT))
+ (FLOAT* z1 sinT)))
+ (y (FLOAT- (FLOAT- (FLOAT- (FLOAT* x1 sinPsinT))
+ (FLOAT* y1 cosP))
+ (FLOAT* z1 sinPcosT)))
+ (z (FLOAT- (FLOAT+ (FLOAT- (FLOAT* x1 cosPsinT))
+ (FLOAT* y1 sinP))
+ (FLOAT* z1 cosPcosT))))
+ (make-tfo
+ (FLOAT- (FLOAT* cosT cosR) (FLOAT* cosPsinT sinR))
+ sinPsinT
+ (FLOAT+ (FLOAT* cosT sinR) (FLOAT* cosPsinT cosR))
+ (FLOAT* sinP sinR)
+ cosP
+ (FLOAT- (FLOAT* sinP cosR))
+ (FLOAT- (FLOAT- (FLOAT* sinT cosR)) (FLOAT* cosPcosT sinR))
+ sinPcosT
+ (FLOAT+ (FLOAT- (FLOAT* sinT sinR)) (FLOAT* cosPcosT cosR))
+ (FLOAT- (FLOAT* x cosR) (FLOAT* z sinR))
+ y
+ (FLOAT+ (FLOAT* x sinR) (FLOAT* z cosR)))))
+
+; -- NUCLEIC ACID CONFORMATIONS DATA BASE -------------------------------------
+
+; Numbering of atoms follows the paper:
+;
+; IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN)
+; (1983) Abbreviations and Symbols for the Description of
+; Conformations of Polynucleotide Chains. Eur. J. Biochem 131,
+; 9-15.
+;
+; In the atom names, we have used "*" instead of "'".
+
+; Define part common to all 4 nucleotide types.
+
+(define (nuc-dgf-base-tfo nuc) (vector-ref nuc 0))
+(define (nuc-dgf-base-tfo-set! nuc val) (vector-set! nuc 0 val))
+(define (nuc-P-O3*-275-tfo nuc) (vector-ref nuc 1))
+(define (nuc-P-O3*-275-tfo-set! nuc val) (vector-set! nuc 1 val))
+(define (nuc-P-O3*-180-tfo nuc) (vector-ref nuc 2))
+(define (nuc-P-O3*-180-tfo-set! nuc val) (vector-set! nuc 2 val))
+(define (nuc-P-O3*-60-tfo nuc) (vector-ref nuc 3))
+(define (nuc-P-O3*-60-tfo-set! nuc val) (vector-set! nuc 3 val))
+(define (nuc-P nuc) (vector-ref nuc 4))
+(define (nuc-P-set! nuc val) (vector-set! nuc 4 val))
+(define (nuc-O1P nuc) (vector-ref nuc 5))
+(define (nuc-O1P-set! nuc val) (vector-set! nuc 5 val))
+(define (nuc-O2P nuc) (vector-ref nuc 6))
+(define (nuc-O2P-set! nuc val) (vector-set! nuc 6 val))
+(define (nuc-O5* nuc) (vector-ref nuc 7))
+(define (nuc-O5*-set! nuc val) (vector-set! nuc 7 val))
+(define (nuc-C5* nuc) (vector-ref nuc 8))
+(define (nuc-C5*-set! nuc val) (vector-set! nuc 8 val))
+(define (nuc-H5* nuc) (vector-ref nuc 9))
+(define (nuc-H5*-set! nuc val) (vector-set! nuc 9 val))
+(define (nuc-H5** nuc) (vector-ref nuc 10))
+(define (nuc-H5**-set! nuc val) (vector-set! nuc 10 val))
+(define (nuc-C4* nuc) (vector-ref nuc 11))
+(define (nuc-C4*-set! nuc val) (vector-set! nuc 11 val))
+(define (nuc-H4* nuc) (vector-ref nuc 12))
+(define (nuc-H4*-set! nuc val) (vector-set! nuc 12 val))
+(define (nuc-O4* nuc) (vector-ref nuc 13))
+(define (nuc-O4*-set! nuc val) (vector-set! nuc 13 val))
+(define (nuc-C1* nuc) (vector-ref nuc 14))
+(define (nuc-C1*-set! nuc val) (vector-set! nuc 14 val))
+(define (nuc-H1* nuc) (vector-ref nuc 15))
+(define (nuc-H1*-set! nuc val) (vector-set! nuc 15 val))
+(define (nuc-C2* nuc) (vector-ref nuc 16))
+(define (nuc-C2*-set! nuc val) (vector-set! nuc 16 val))
+(define (nuc-H2** nuc) (vector-ref nuc 17))
+(define (nuc-H2**-set! nuc val) (vector-set! nuc 17 val))
+(define (nuc-O2* nuc) (vector-ref nuc 18))
+(define (nuc-O2*-set! nuc val) (vector-set! nuc 18 val))
+(define (nuc-H2* nuc) (vector-ref nuc 19))
+(define (nuc-H2*-set! nuc val) (vector-set! nuc 19 val))
+(define (nuc-C3* nuc) (vector-ref nuc 20))
+(define (nuc-C3*-set! nuc val) (vector-set! nuc 20 val))
+(define (nuc-H3* nuc) (vector-ref nuc 21))
+(define (nuc-H3*-set! nuc val) (vector-set! nuc 21 val))
+(define (nuc-O3* nuc) (vector-ref nuc 22))
+(define (nuc-O3*-set! nuc val) (vector-set! nuc 22 val))
+(define (nuc-N1 nuc) (vector-ref nuc 23))
+(define (nuc-N1-set! nuc val) (vector-set! nuc 23 val))
+(define (nuc-N3 nuc) (vector-ref nuc 24))
+(define (nuc-N3-set! nuc val) (vector-set! nuc 24 val))
+(define (nuc-C2 nuc) (vector-ref nuc 25))
+(define (nuc-C2-set! nuc val) (vector-set! nuc 25 val))
+(define (nuc-C4 nuc) (vector-ref nuc 26))
+(define (nuc-C4-set! nuc val) (vector-set! nuc 26 val))
+(define (nuc-C5 nuc) (vector-ref nuc 27))
+(define (nuc-C5-set! nuc val) (vector-set! nuc 27 val))
+(define (nuc-C6 nuc) (vector-ref nuc 28))
+(define (nuc-C6-set! nuc val) (vector-set! nuc 28 val))
+
+; Define remaining atoms for each nucleotide type.
+
+(define (make-rA dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ N6 N7 N9 C8 H2 H61 H62 H8)
+ (vector dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ 'rA N6 N7 N9 C8 H2 H61 H62 H8))
+
+(define (rA? nuc) (eq? (vector-ref nuc 29) 'rA))
+
+(define (rA-N6 nuc) (vector-ref nuc 30))
+(define (rA-N6-set! nuc val) (vector-set! nuc 30 val))
+(define (rA-N7 nuc) (vector-ref nuc 31))
+(define (rA-N7-set! nuc val) (vector-set! nuc 31 val))
+(define (rA-N9 nuc) (vector-ref nuc 32))
+(define (rA-N9-set! nuc val) (vector-set! nuc 32 val))
+(define (rA-C8 nuc) (vector-ref nuc 33))
+(define (rA-C8-set! nuc val) (vector-set! nuc 33 val))
+(define (rA-H2 nuc) (vector-ref nuc 34))
+(define (rA-H2-set! nuc val) (vector-set! nuc 34 val))
+(define (rA-H61 nuc) (vector-ref nuc 35))
+(define (rA-H61-set! nuc val) (vector-set! nuc 35 val))
+(define (rA-H62 nuc) (vector-ref nuc 36))
+(define (rA-H62-set! nuc val) (vector-set! nuc 36 val))
+(define (rA-H8 nuc) (vector-ref nuc 37))
+(define (rA-H8-set! nuc val) (vector-set! nuc 37 val))
+
+(define (make-rC dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ N4 O2 H41 H42 H5 H6)
+ (vector dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ 'rC N4 O2 H41 H42 H5 H6))
+
+(define (rC? nuc) (eq? (vector-ref nuc 29) 'rC))
+
+(define (rC-N4 nuc) (vector-ref nuc 30))
+(define (rC-N4-set! nuc val) (vector-set! nuc 30 val))
+(define (rC-O2 nuc) (vector-ref nuc 31))
+(define (rC-O2-set! nuc val) (vector-set! nuc 31 val))
+(define (rC-H41 nuc) (vector-ref nuc 32))
+(define (rC-H41-set! nuc val) (vector-set! nuc 32 val))
+(define (rC-H42 nuc) (vector-ref nuc 33))
+(define (rC-H42-set! nuc val) (vector-set! nuc 33 val))
+(define (rC-H5 nuc) (vector-ref nuc 34))
+(define (rC-H5-set! nuc val) (vector-set! nuc 34 val))
+(define (rC-H6 nuc) (vector-ref nuc 35))
+(define (rC-H6-set! nuc val) (vector-set! nuc 35 val))
+
+(define (make-rG dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ N2 N7 N9 C8 O6 H1 H21 H22 H8)
+ (vector dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ 'rG N2 N7 N9 C8 O6 H1 H21 H22 H8))
+
+(define (rG? nuc) (eq? (vector-ref nuc 29) 'rG))
+
+(define (rG-N2 nuc) (vector-ref nuc 30))
+(define (rG-N2-set! nuc val) (vector-set! nuc 30 val))
+(define (rG-N7 nuc) (vector-ref nuc 31))
+(define (rG-N7-set! nuc val) (vector-set! nuc 31 val))
+(define (rG-N9 nuc) (vector-ref nuc 32))
+(define (rG-N9-set! nuc val) (vector-set! nuc 32 val))
+(define (rG-C8 nuc) (vector-ref nuc 33))
+(define (rG-C8-set! nuc val) (vector-set! nuc 33 val))
+(define (rG-O6 nuc) (vector-ref nuc 34))
+(define (rG-O6-set! nuc val) (vector-set! nuc 34 val))
+(define (rG-H1 nuc) (vector-ref nuc 35))
+(define (rG-H1-set! nuc val) (vector-set! nuc 35 val))
+(define (rG-H21 nuc) (vector-ref nuc 36))
+(define (rG-H21-set! nuc val) (vector-set! nuc 36 val))
+(define (rG-H22 nuc) (vector-ref nuc 37))
+(define (rG-H22-set! nuc val) (vector-set! nuc 37 val))
+(define (rG-H8 nuc) (vector-ref nuc 38))
+(define (rG-H8-set! nuc val) (vector-set! nuc 38 val))
+
+(define (make-rU dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ O2 O4 H3 H5 H6)
+ (vector dgf-base-tfo P-O3*-275-tfo P-O3*-180-tfo P-O3*-60-tfo
+ P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2*
+ H2** O2* H2* C3* H3* O3* N1 N3 C2 C4 C5 C6
+ 'rU O2 O4 H3 H5 H6))
+
+(define (rU? nuc) (eq? (vector-ref nuc 29) 'rU))
+
+(define (rU-O2 nuc) (vector-ref nuc 30))
+(define (rU-O2-set! nuc val) (vector-set! nuc 30 val))
+(define (rU-O4 nuc) (vector-ref nuc 31))
+(define (rU-O4-set! nuc val) (vector-set! nuc 31 val))
+(define (rU-H3 nuc) (vector-ref nuc 32))
+(define (rU-H3-set! nuc val) (vector-set! nuc 32 val))
+(define (rU-H5 nuc) (vector-ref nuc 33))
+(define (rU-H5-set! nuc val) (vector-set! nuc 33 val))
+(define (rU-H6 nuc) (vector-ref nuc 34))
+(define (rU-H6-set! nuc val) (vector-set! nuc 34 val))
+
+; Database of nucleotide conformations:
+
+(define rA
+ (nuc-const
+ #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo
+ 0.2679 -0.5509 -0.7904
+ 0.9634 0.1517 0.2209
+ 0.0073 8.4030 0.6232)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4550 8.2120 -2.8810) ; C5*
+ #( 5.4546 8.8508 -1.9978) ; H5*
+ #( 5.7588 8.6625 -3.8259) ; H5**
+ #( 6.4970 7.1480 -2.5980) ; C4*
+ #( 7.4896 7.5919 -2.5214) ; H4*
+ #( 6.1630 6.4860 -1.3440) ; O4*
+ #( 6.5400 5.1200 -1.4190) ; C1*
+ #( 7.2763 4.9681 -0.6297) ; H1*
+ #( 7.1940 4.8830 -2.7770) ; C2*
+ #( 6.8667 3.9183 -3.1647) ; H2**
+ #( 8.5860 5.0910 -2.6140) ; O2*
+ #( 8.9510 4.7626 -1.7890) ; H2*
+ #( 6.5720 6.0040 -3.6090) ; C3*
+ #( 5.5636 5.7066 -3.8966) ; H3*
+ #( 7.3801 6.3562 -4.7350) ; O3*
+ #( 4.7150 0.4910 -0.1360) ; N1
+ #( 6.3490 2.1730 -0.6020) ; N3
+ #( 5.9530 0.9650 -0.2670) ; C2
+ #( 5.2900 2.9790 -0.8260) ; C4
+ #( 3.9720 2.6390 -0.7330) ; C5
+ #( 3.6770 1.3160 -0.3660) ; C6
+ rA
+ #( 2.4280 0.8450 -0.2360) ; N6
+ #( 3.1660 3.7290 -1.0360) ; N7
+ #( 5.3170 4.2990 -1.1930) ; N9
+ #( 4.0100 4.6780 -1.2990) ; C8
+ #( 6.6890 0.1903 -0.0518) ; H2
+ #( 1.6470 1.4460 -0.4040) ; H61
+ #( 2.2780 -0.1080 -0.0280) ; H62
+ #( 3.4421 5.5744 -1.5482) ; H8
+ ))
+
+(define rA01
+ (nuc-const
+ #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo
+ 0.2617 -0.5567 -0.7884
+ 0.9651 0.1473 0.2164
+ 0.0359 8.3929 0.5532)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 4.7442 0.4514 -0.1390) ; N1
+ #( 6.3687 2.1459 -0.5926) ; N3
+ #( 5.9795 0.9335 -0.2657) ; C2
+ #( 5.3052 2.9471 -0.8125) ; C4
+ #( 3.9891 2.5987 -0.7230) ; C5
+ #( 3.7016 1.2717 -0.3647) ; C6
+ rA
+ #( 2.4553 0.7925 -0.2390) ; N6
+ #( 3.1770 3.6859 -1.0198) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.0156 4.6415 -1.2759) ; C8
+ #( 6.7198 0.1618 -0.0547) ; H2
+ #( 1.6709 1.3900 -0.4039) ; H61
+ #( 2.3107 -0.1627 -0.0373) ; H62
+ #( 3.4426 5.5361 -1.5199) ; H8
+ ))
+
+(define rA02
+ (nuc-const
+ #( 0.5566 0.0449 0.8296 ; dgf-base-tfo
+ 0.5125 0.7673 -0.3854
+ -0.6538 0.6397 0.4041
+ -9.1161 -3.7679 -2.9968)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.3245 8.5459 1.5467) ; N1
+ #( 9.8051 6.9432 -0.1497) ; N3
+ #( 10.5175 7.4328 0.8408) ; C2
+ #( 8.7523 7.7422 -0.4228) ; C4
+ #( 8.4257 8.9060 0.2099) ; C5
+ #( 9.2665 9.3242 1.2540) ; C6
+ rA
+ #( 9.0664 10.4462 1.9610) ; N6
+ #( 7.2750 9.4537 -0.3428) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9479 8.6157 -1.2771) ; C8
+ #( 11.4063 6.9047 1.1859) ; H2
+ #( 8.2845 11.0341 1.7552) ; H61
+ #( 9.6584 10.6647 2.7198) ; H62
+ #( 6.0430 8.9853 -1.7594) ; H8
+ ))
+
+(define rA03
+ (nuc-const
+ #( -0.5021 0.0731 0.8617 ; dgf-base-tfo
+ -0.8112 0.3054 -0.4986
+ -0.2996 -0.9494 -0.0940
+ 6.4273 -5.1944 -3.7807)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 9.6740 4.7656 -7.6614) ; N1
+ #( 9.0739 4.3013 -5.3941) ; N3
+ #( 9.8416 4.2192 -6.4581) ; C2
+ #( 7.9885 5.0632 -5.6446) ; C4
+ #( 7.6822 5.6856 -6.8194) ; C5
+ #( 8.5831 5.5215 -7.8840) ; C6
+ rA
+ #( 8.4084 6.0747 -9.0933) ; N6
+ #( 6.4857 6.3816 -6.7035) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 6.1133 6.1613 -5.4808) ; C8
+ #( 10.7627 3.6375 -6.4220) ; H2
+ #( 7.6031 6.6390 -9.2733) ; H61
+ #( 9.1004 5.9708 -9.7893) ; H62
+ #( 5.1705 6.6830 -5.3167) ; H8
+ ))
+
+(define rA04
+ (nuc-const
+ #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo
+ 0.8304 -0.5567 -0.0237
+ 0.1267 0.1473 0.9809
+ -0.5075 8.3929 0.2229)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 3.6343 2.6680 2.0783) ; N1
+ #( 5.4505 3.9805 1.2446) ; N3
+ #( 4.7540 3.3816 2.1851) ; C2
+ #( 4.8805 3.7951 0.0354) ; C4
+ #( 3.7416 3.0925 -0.2305) ; C5
+ #( 3.0873 2.4980 0.8606) ; C6
+ rA
+ #( 1.9600 1.7805 0.7462) ; N6
+ #( 3.4605 3.1184 -1.5906) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.4244 3.8244 -2.0953) ; C8
+ #( 5.0814 3.4352 3.2234) ; H2
+ #( 1.5423 1.6454 -0.1520) ; H61
+ #( 1.5716 1.3398 1.5392) ; H62
+ #( 4.2675 3.8876 -3.1721) ; H8
+ ))
+
+(define rA05
+ (nuc-const
+ #( -0.5891 0.0449 0.8068 ; dgf-base-tfo
+ 0.5375 0.7673 0.3498
+ -0.6034 0.6397 -0.4762
+ -0.3019 -3.7679 -9.5913)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.2594 10.6774 -1.0056) ; N1
+ #( 9.7528 8.7080 -2.2631) ; N3
+ #( 10.4471 9.7876 -1.9791) ; C2
+ #( 8.7271 8.5575 -1.3991) ; C4
+ #( 8.4100 9.3803 -0.3580) ; C5
+ #( 9.2294 10.5030 -0.1574) ; C6
+ rA
+ #( 9.0349 11.3951 0.8250) ; N6
+ #( 7.2891 8.9068 0.3121) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9702 7.8292 -0.3353) ; C8
+ #( 11.3132 10.0537 -2.5851) ; H2
+ #( 8.2741 11.2784 1.4629) ; H61
+ #( 9.6733 12.1368 0.9529) ; H62
+ #( 6.0888 7.3990 0.1403) ; H8
+ ))
+
+(define rA06
+ (nuc-const
+ #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo
+ 0.1912 0.3054 -0.9328
+ -0.0141 -0.9494 -0.3137
+ 5.7506 -5.1944 4.7470)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 6.6624 3.5061 -8.2986) ; N1
+ #( 6.5810 3.2570 -5.9221) ; N3
+ #( 6.5151 2.8263 -7.1625) ; C2
+ #( 6.8364 4.5817 -5.8882) ; C4
+ #( 7.0116 5.4064 -6.9609) ; C5
+ #( 6.9173 4.8260 -8.2361) ; C6
+ rA
+ #( 7.0668 5.5163 -9.3763) ; N6
+ #( 7.2573 6.7070 -6.5394) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 7.2238 6.6275 -5.2453) ; C8
+ #( 6.3146 1.7741 -7.3641) ; H2
+ #( 7.2568 6.4972 -9.3456) ; H61
+ #( 7.0437 5.0478 -10.2446) ; H62
+ #( 7.4108 7.6227 -4.8418) ; H8
+ ))
+
+(define rA07
+ (nuc-const
+ #( 0.2379 0.1310 -0.9624 ; dgf-base-tfo
+ -0.5876 -0.7696 -0.2499
+ -0.7734 0.6249 -0.1061
+ 30.9870 -26.9344 42.6416)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.3505 8.4697 42.6565) ; C5*
+ #( 39.1377 7.5433 42.1230) ; H5*
+ #( 39.7203 9.3119 42.0717) ; H5**
+ #( 38.0405 8.9195 43.2869) ; C4*
+ #( 37.3687 9.3036 42.5193) ; H4*
+ #( 37.4319 7.8146 43.9387) ; O4*
+ #( 37.1959 8.1354 45.3237) ; C1*
+ #( 36.1788 8.5202 45.3970) ; H1*
+ #( 38.1721 9.2328 45.6504) ; C2*
+ #( 39.1555 8.7939 45.8188) ; H2**
+ #( 37.7862 10.0617 46.7013) ; O2*
+ #( 37.3087 9.6229 47.4092) ; H2*
+ #( 38.1844 10.0268 44.3367) ; C3*
+ #( 39.1578 10.5054 44.2289) ; H3*
+ #( 37.0547 10.9127 44.3441) ; O3*
+ #( 34.8811 4.2072 47.5784) ; N1
+ #( 35.1084 6.1336 46.1818) ; N3
+ #( 34.4108 5.1360 46.7207) ; C2
+ #( 36.3908 6.1224 46.6053) ; C4
+ #( 36.9819 5.2334 47.4697) ; C5
+ #( 36.1786 4.1985 48.0035) ; C6
+ rA
+ #( 36.6103 3.2749 48.8452) ; N6
+ #( 38.3236 5.5522 47.6595) ; N7
+ #( 37.3887 7.0024 46.2437) ; N9
+ #( 38.5055 6.6096 46.9057) ; C8
+ #( 33.3553 5.0152 46.4771) ; H2
+ #( 37.5730 3.2804 49.1507) ; H61
+ #( 35.9775 2.5638 49.1828) ; H62
+ #( 39.5461 6.9184 47.0041) ; H8
+ ))
+
+(define rA08
+ (nuc-const
+ #( 0.1084 -0.0895 -0.9901 ; dgf-base-tfo
+ 0.9789 -0.1638 0.1220
+ -0.1731 -0.9824 0.0698
+ -2.9039 47.2655 33.0094)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.4850 8.9301 44.6977) ; C5*
+ #( 39.0638 9.8199 44.2296) ; H5*
+ #( 40.0757 9.0713 45.6029) ; H5**
+ #( 38.3102 8.0414 45.0789) ; C4*
+ #( 37.7842 8.4637 45.9351) ; H4*
+ #( 37.4200 7.9453 43.9769) ; O4*
+ #( 37.2249 6.5609 43.6273) ; C1*
+ #( 36.3360 6.2168 44.1561) ; H1*
+ #( 38.4347 5.8414 44.1590) ; C2*
+ #( 39.2688 5.9974 43.4749) ; H2**
+ #( 38.2344 4.4907 44.4348) ; O2*
+ #( 37.6374 4.0386 43.8341) ; H2*
+ #( 38.6926 6.6079 45.4637) ; C3*
+ #( 39.7585 6.5640 45.6877) ; H3*
+ #( 37.8238 6.0705 46.4723) ; O3*
+ #( 33.9162 6.2598 39.7758) ; N1
+ #( 34.6709 6.5759 42.0215) ; N3
+ #( 33.7257 6.5186 41.0858) ; C2
+ #( 35.8935 6.3324 41.5018) ; C4
+ #( 36.2105 6.0601 40.1932) ; C5
+ #( 35.1538 6.0151 39.2537) ; C6
+ rA
+ #( 35.3088 5.7642 37.9649) ; N6
+ #( 37.5818 5.8677 40.0507) ; N7
+ #( 37.0932 6.3197 42.1810) ; N9
+ #( 38.0509 6.0354 41.2635) ; C8
+ #( 32.6830 6.6898 41.3532) ; H2
+ #( 36.2305 5.5855 37.5925) ; H61
+ #( 34.5056 5.7512 37.3528) ; H62
+ #( 39.1318 5.8993 41.2285) ; H8
+ ))
+
+(define rA09
+ (nuc-const
+ #( 0.8467 0.4166 -0.3311 ; dgf-base-tfo
+ -0.3962 0.9089 0.1303
+ 0.3552 0.0209 0.9346
+ -42.7319 -26.6223 -29.8163)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.3505 8.4697 42.6565) ; C5*
+ #( 39.1377 7.5433 42.1230) ; H5*
+ #( 39.7203 9.3119 42.0717) ; H5**
+ #( 38.0405 8.9195 43.2869) ; C4*
+ #( 37.6479 8.1347 43.9335) ; H4*
+ #( 38.2691 10.0933 44.0524) ; O4*
+ #( 37.3999 11.1488 43.5973) ; C1*
+ #( 36.5061 11.1221 44.2206) ; H1*
+ #( 37.0364 10.7838 42.1836) ; C2*
+ #( 37.8636 11.0489 41.5252) ; H2**
+ #( 35.8275 11.3133 41.7379) ; O2*
+ #( 35.6214 12.1896 42.0714) ; H2*
+ #( 36.9316 9.2556 42.2837) ; C3*
+ #( 37.1778 8.8260 41.3127) ; H3*
+ #( 35.6285 8.9334 42.7926) ; O3*
+ #( 38.1482 15.2833 46.4641) ; N1
+ #( 37.3641 13.0968 45.9007) ; N3
+ #( 37.5032 14.1288 46.7300) ; C2
+ #( 37.9570 13.3377 44.7113) ; C4
+ #( 38.6397 14.4660 44.3267) ; C5
+ #( 38.7473 15.5229 45.2609) ; C6
+ rA
+ #( 39.3720 16.6649 45.0297) ; N6
+ #( 39.1079 14.3351 43.0223) ; N7
+ #( 38.0132 12.4868 43.6280) ; N9
+ #( 38.7058 13.1402 42.6620) ; C8
+ #( 37.0731 14.0857 47.7306) ; H2
+ #( 39.8113 16.8281 44.1350) ; H61
+ #( 39.4100 17.3741 45.7478) ; H62
+ #( 39.0412 12.9660 41.6397) ; H8
+ ))
+
+(define rA10
+ (nuc-const
+ #( 0.7063 0.6317 -0.3196 ; dgf-base-tfo
+ -0.0403 -0.4149 -0.9090
+ -0.7068 0.6549 -0.2676
+ 6.4402 -52.1496 30.8246)
+ #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo
+ 0.2952 -0.9481 -0.1180
+ 0.5882 0.2777 -0.7595
+ -58.8919 -11.3095 6.0866)
+ #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo
+ 0.9731 -0.0359 -0.2275
+ -0.2290 -0.2532 -0.9399
+ 3.5401 -29.7913 52.2796)
+ #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo
+ -0.1183 0.1805 -0.9764
+ 0.4380 -0.8730 -0.2145
+ 19.9023 54.8054 15.2799)
+ #( 41.8210 8.3880 43.5890) ; P
+ #( 42.5400 8.0450 44.8330) ; O1P
+ #( 42.2470 9.6920 42.9910) ; O2P
+ #( 40.2550 8.2030 43.7340) ; O5*
+ #( 39.4850 8.9301 44.6977) ; C5*
+ #( 39.0638 9.8199 44.2296) ; H5*
+ #( 40.0757 9.0713 45.6029) ; H5**
+ #( 38.3102 8.0414 45.0789) ; C4*
+ #( 37.7099 7.8166 44.1973) ; H4*
+ #( 38.8012 6.8321 45.6380) ; O4*
+ #( 38.2431 6.6413 46.9529) ; C1*
+ #( 37.3505 6.0262 46.8385) ; H1*
+ #( 37.8484 8.0156 47.4214) ; C2*
+ #( 38.7381 8.5406 47.7690) ; H2**
+ #( 36.8286 8.0368 48.3701) ; O2*
+ #( 36.8392 7.3063 48.9929) ; H2*
+ #( 37.3576 8.6512 46.1132) ; C3*
+ #( 37.5207 9.7275 46.1671) ; H3*
+ #( 35.9985 8.2392 45.9032) ; O3*
+ #( 39.9117 2.2278 48.8527) ; N1
+ #( 38.6207 3.6941 47.4757) ; N3
+ #( 38.9872 2.4888 47.9057) ; C2
+ #( 39.2961 4.6720 48.1174) ; C4
+ #( 40.2546 4.5307 49.0912) ; C5
+ #( 40.5932 3.2189 49.4985) ; C6
+ rA
+ #( 41.4938 2.9317 50.4229) ; N6
+ #( 40.7195 5.7755 49.5060) ; N7
+ #( 39.1730 6.0305 47.9170) ; N9
+ #( 40.0413 6.6250 48.7728) ; C8
+ #( 38.5257 1.5960 47.4838) ; H2
+ #( 41.9907 3.6753 50.8921) ; H61
+ #( 41.6848 1.9687 50.6599) ; H62
+ #( 40.3571 7.6321 49.0452) ; H8
+ ))
+
+(define rAs
+ (list rA01 rA02 rA03 rA04 rA05 rA06 rA07 rA08 rA09 rA10))
+
+(define rC
+ (nuc-const
+ #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo
+ -0.2669 0.5761 0.7726
+ -0.9631 -0.1296 -0.2361
+ 0.1584 8.3434 0.5434)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 7.2954 -7.6762 2.4898) ; H4*
+ #( 6.0140 -6.5420 1.2890) ; O4*
+ #( 6.4190 -5.1840 1.3620) ; C1*
+ #( 7.1608 -5.0495 0.5747) ; H1*
+ #( 7.0760 -4.9560 2.7270) ; C2*
+ #( 6.7770 -3.9803 3.1099) ; H2**
+ #( 8.4500 -5.1930 2.5810) ; O2*
+ #( 8.8309 -4.8755 1.7590) ; H2*
+ #( 6.4060 -6.0590 3.5580) ; C3*
+ #( 5.4021 -5.7313 3.8281) ; H3*
+ #( 7.1570 -6.4240 4.7070) ; O3*
+ #( 5.2170 -4.3260 1.1690) ; N1
+ #( 4.2960 -2.2560 0.6290) ; N3
+ #( 5.4330 -3.0200 0.7990) ; C2
+ #( 2.9930 -2.6780 0.7940) ; C4
+ #( 2.8670 -4.0630 1.1830) ; C5
+ #( 3.9570 -4.8300 1.3550) ; C6
+ rC
+ #( 2.0187 -1.8047 0.5874) ; N4
+ #( 6.5470 -2.5560 0.6290) ; O2
+ #( 1.0684 -2.1236 0.7109) ; H41
+ #( 2.2344 -0.8560 0.3162) ; H42
+ #( 1.8797 -4.4972 1.3404) ; H5
+ #( 3.8479 -5.8742 1.6480) ; H6
+ ))
+
+(define rC01
+ (nuc-const
+ #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo
+ -0.2523 0.5817 0.7733
+ -0.9675 -0.1404 -0.2101
+ 0.2031 8.3874 0.4228)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 4.3777 -2.2062 0.7229) ; N3
+ #( 5.5069 -2.9779 0.9088) ; C2
+ #( 3.0693 -2.6246 0.8500) ; C4
+ #( 2.9279 -4.0146 1.2149) ; C5
+ #( 4.0101 -4.7892 1.4017) ; C6
+ rC
+ #( 2.1040 -1.7437 0.6331) ; N4
+ #( 6.6267 -2.5166 0.7728) ; O2
+ #( 1.1496 -2.0600 0.7287) ; H41
+ #( 2.3303 -0.7921 0.3815) ; H42
+ #( 1.9353 -4.4465 1.3419) ; H5
+ #( 3.8895 -5.8371 1.6762) ; H6
+ ))
+
+(define rC02
+ (nuc-const
+ #( 0.5141 0.0246 0.8574 ; dgf-base-tfo
+ -0.5547 -0.7529 0.3542
+ 0.6542 -0.6577 -0.3734
+ -9.1111 -3.4598 -3.2939)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.6945 -8.7046 -0.2857) ; N3
+ #( 8.6943 -7.6514 0.6066) ; C2
+ #( 7.7426 -9.6987 -0.3801) ; C4
+ #( 6.6642 -9.5742 0.5722) ; C5
+ #( 6.6391 -8.5592 1.4526) ; C6
+ rC
+ #( 7.9033 -10.6371 -1.3010) ; N4
+ #( 9.5840 -6.8186 0.6136) ; O2
+ #( 7.2009 -11.3604 -1.3619) ; H41
+ #( 8.7058 -10.6168 -1.9140) ; H42
+ #( 5.8585 -10.3083 0.5822) ; H5
+ #( 5.8197 -8.4773 2.1667) ; H6
+ ))
+
+(define rC03
+ (nuc-const
+ #( -0.4993 0.0476 0.8651 ; dgf-base-tfo
+ 0.8078 -0.3353 0.4847
+ 0.3132 0.9409 0.1290
+ 6.2989 -5.2303 -3.8577)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 7.9218 -5.5700 6.8877) ; N3
+ #( 7.8908 -5.0886 5.5944) ; C2
+ #( 6.9789 -6.3827 7.4823) ; C4
+ #( 5.8742 -6.7319 6.6202) ; C5
+ #( 5.8182 -6.2769 5.3570) ; C6
+ rC
+ #( 7.1702 -6.7511 8.7402) ; N4
+ #( 8.7747 -4.3728 5.1568) ; O2
+ #( 6.4741 -7.3461 9.1662) ; H41
+ #( 7.9889 -6.4396 9.2429) ; H42
+ #( 5.0736 -7.3713 6.9922) ; H5
+ #( 4.9784 -6.5473 4.7170) ; H6
+ ))
+
+(define rC04
+ (nuc-const
+ #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo
+ -0.8129 0.5817 0.0273
+ -0.1334 -0.1404 -0.9811
+ -0.3279 8.3874 0.3355)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 3.8961 -3.0896 -0.1893) ; N3
+ #( 5.0095 -3.8907 -0.0346) ; C2
+ #( 3.0480 -2.6632 0.8116) ; C4
+ #( 3.4093 -3.1310 2.1292) ; C5
+ #( 4.4878 -3.9124 2.3088) ; C6
+ rC
+ #( 2.0216 -1.8941 0.4804) ; N4
+ #( 5.7005 -4.2164 -0.9842) ; O2
+ #( 1.4067 -1.5873 1.2205) ; H41
+ #( 1.8721 -1.6319 -0.4835) ; H42
+ #( 2.8048 -2.8507 2.9918) ; H5
+ #( 4.7491 -4.2593 3.3085) ; H6
+ ))
+
+(define rC05
+ (nuc-const
+ #( -0.6298 0.0246 0.7763 ; dgf-base-tfo
+ -0.5226 -0.7529 -0.4001
+ 0.5746 -0.6577 0.4870
+ -0.0208 -3.4598 -9.6882)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.5977 -9.5977 0.7329) ; N3
+ #( 8.5951 -8.5745 1.6594) ; C2
+ #( 7.7372 -9.7371 -0.3364) ; C4
+ #( 6.7596 -8.6801 -0.4476) ; C5
+ #( 6.7338 -7.6721 0.4408) ; C6
+ rC
+ #( 7.8849 -10.7881 -1.1289) ; N4
+ #( 9.3993 -8.5377 2.5743) ; O2
+ #( 7.2499 -10.8809 -1.9088) ; H41
+ #( 8.6122 -11.4649 -0.9468) ; H42
+ #( 6.0317 -8.6941 -1.2588) ; H5
+ #( 5.9901 -6.8809 0.3459) ; H6
+ ))
+
+(define rC06
+ (nuc-const
+ #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo
+ -0.1792 -0.3353 0.9249
+ -0.0141 0.9409 0.3384
+ 5.7793 -5.2303 4.5997)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 6.6920 -5.0495 7.1354) ; N3
+ #( 6.6201 -4.5500 5.8506) ; C2
+ #( 6.9254 -6.3614 7.4926) ; C4
+ #( 7.1046 -7.2543 6.3718) ; C5
+ #( 7.0391 -6.7951 5.1106) ; C6
+ rC
+ #( 6.9614 -6.6648 8.7815) ; N4
+ #( 6.4083 -3.3696 5.6340) ; O2
+ #( 7.1329 -7.6280 9.0324) ; H41
+ #( 6.8204 -5.9469 9.4777) ; H42
+ #( 7.2954 -8.3135 6.5440) ; H5
+ #( 7.1753 -7.4798 4.2735) ; H6
+ ))
+
+(define rC07
+ (nuc-const
+ #( 0.0033 0.2720 -0.9623 ; dgf-base-tfo
+ 0.3013 -0.9179 -0.2584
+ -0.9535 -0.2891 -0.0850
+ 43.0403 13.7233 34.5710)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 30.8152 11.1619 46.2003) ; C5*
+ #( 30.4519 10.9454 45.1957) ; H5*
+ #( 31.0379 12.2016 46.4400) ; H5**
+ #( 29.7081 10.7448 47.1428) ; C4*
+ #( 28.8710 11.4416 47.0982) ; H4*
+ #( 29.2550 9.4394 46.8162) ; O4*
+ #( 29.3907 8.5625 47.9460) ; C1*
+ #( 28.4416 8.5669 48.4819) ; H1*
+ #( 30.4468 9.2031 48.7952) ; C2*
+ #( 31.4222 8.9651 48.3709) ; H2**
+ #( 30.3701 8.9157 50.1624) ; O2*
+ #( 30.0652 8.0304 50.3740) ; H2*
+ #( 30.1622 10.6879 48.6120) ; C3*
+ #( 31.0952 11.2399 48.7254) ; H3*
+ #( 29.1076 11.1535 49.4702) ; O3*
+ #( 29.7883 7.2209 47.5235) ; N1
+ #( 29.1825 5.0438 46.8275) ; N3
+ #( 28.8008 6.2912 47.2263) ; C2
+ #( 30.4888 4.6890 46.7186) ; C4
+ #( 31.5034 5.6405 47.0249) ; C5
+ #( 31.1091 6.8691 47.4156) ; C6
+ rC
+ #( 30.8109 3.4584 46.3336) ; N4
+ #( 27.6171 6.5989 47.3189) ; O2
+ #( 31.7923 3.2301 46.2638) ; H41
+ #( 30.0880 2.7857 46.1215) ; H42
+ #( 32.5542 5.3634 46.9395) ; H5
+ #( 31.8523 7.6279 47.6603) ; H6
+ ))
+
+(define rC08
+ (nuc-const
+ #( 0.0797 -0.6026 -0.7941 ; dgf-base-tfo
+ 0.7939 0.5201 -0.3150
+ 0.6028 -0.6054 0.5198
+ -36.8341 41.5293 1.6628)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 31.8779 9.9369 47.8760) ; C5*
+ #( 31.3239 10.6931 48.4322) ; H5*
+ #( 32.8647 9.6624 48.2489) ; H5**
+ #( 31.0429 8.6773 47.9401) ; C4*
+ #( 31.0779 8.2331 48.9349) ; H4*
+ #( 29.6956 8.9669 47.5983) ; O4*
+ #( 29.2784 8.1700 46.4782) ; C1*
+ #( 28.8006 7.2731 46.8722) ; H1*
+ #( 30.5544 7.7940 45.7875) ; C2*
+ #( 30.8837 8.6410 45.1856) ; H2**
+ #( 30.5100 6.6007 45.0582) ; O2*
+ #( 29.6694 6.4168 44.6326) ; H2*
+ #( 31.5146 7.5954 46.9527) ; C3*
+ #( 32.5255 7.8261 46.6166) ; H3*
+ #( 31.3876 6.2951 47.5516) ; O3*
+ #( 28.3976 8.9302 45.5933) ; N1
+ #( 26.2155 9.6135 44.9910) ; N3
+ #( 27.0281 8.8961 45.8192) ; C2
+ #( 26.7044 10.3489 43.9595) ; C4
+ #( 28.1088 10.3837 43.7247) ; C5
+ #( 28.8978 9.6708 44.5535) ; C6
+ rC
+ #( 25.8715 11.0249 43.1749) ; N4
+ #( 26.5733 8.2371 46.7484) ; O2
+ #( 26.2707 11.5609 42.4177) ; H41
+ #( 24.8760 10.9939 43.3427) ; H42
+ #( 28.5089 10.9722 42.8990) ; H5
+ #( 29.9782 9.6687 44.4097) ; H6
+ ))
+
+(define rC09
+ (nuc-const
+ #( 0.8727 0.4760 -0.1091 ; dgf-base-tfo
+ -0.4188 0.6148 -0.6682
+ -0.2510 0.6289 0.7359
+ -8.1687 -52.0761 -25.0726)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 30.8152 11.1619 46.2003) ; C5*
+ #( 30.4519 10.9454 45.1957) ; H5*
+ #( 31.0379 12.2016 46.4400) ; H5**
+ #( 29.7081 10.7448 47.1428) ; C4*
+ #( 29.4506 9.6945 47.0059) ; H4*
+ #( 30.1045 10.9634 48.4885) ; O4*
+ #( 29.1794 11.8418 49.1490) ; C1*
+ #( 28.4388 11.2210 49.6533) ; H1*
+ #( 28.5211 12.6008 48.0367) ; C2*
+ #( 29.1947 13.3949 47.7147) ; H2**
+ #( 27.2316 13.0683 48.3134) ; O2*
+ #( 27.0851 13.3391 49.2227) ; H2*
+ #( 28.4131 11.5507 46.9391) ; C3*
+ #( 28.4451 12.0512 45.9713) ; H3*
+ #( 27.2707 10.6955 47.1097) ; O3*
+ #( 29.8751 12.7405 50.0682) ; N1
+ #( 30.7172 13.1841 52.2328) ; N3
+ #( 30.0617 12.3404 51.3847) ; C2
+ #( 31.1834 14.3941 51.8297) ; C4
+ #( 30.9913 14.8074 50.4803) ; C5
+ #( 30.3434 13.9610 49.6548) ; C6
+ rC
+ #( 31.8090 15.1847 52.6957) ; N4
+ #( 29.6470 11.2494 51.7616) ; O2
+ #( 32.1422 16.0774 52.3606) ; H41
+ #( 31.9392 14.8893 53.6527) ; H42
+ #( 31.3632 15.7771 50.1491) ; H5
+ #( 30.1742 14.2374 48.6141) ; H6
+ ))
+
+(define rC10
+ (nuc-const
+ #( 0.1549 0.8710 -0.4663 ; dgf-base-tfo
+ 0.6768 -0.4374 -0.5921
+ -0.7197 -0.2239 -0.6572
+ 25.2447 -14.1920 50.3201)
+ #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo
+ 0.0302 -0.7316 0.6811
+ 0.3938 -0.6176 -0.6808
+ -48.4330 26.3254 13.6383)
+ #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo
+ 0.7581 0.4893 0.4311
+ 0.6345 -0.4010 -0.6607
+ -31.9784 -13.4285 44.9650)
+ #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo
+ -0.6890 0.5694 -0.4484
+ 0.3694 -0.2564 -0.8932
+ 12.1105 30.8774 46.0946)
+ #( 33.3400 11.0980 46.1750) ; P
+ #( 34.5130 10.2320 46.4660) ; O1P
+ #( 33.4130 12.3960 46.9340) ; O2P
+ #( 31.9810 10.3390 46.4820) ; O5*
+ #( 31.8779 9.9369 47.8760) ; C5*
+ #( 31.3239 10.6931 48.4322) ; H5*
+ #( 32.8647 9.6624 48.2489) ; H5**
+ #( 31.0429 8.6773 47.9401) ; C4*
+ #( 30.0440 8.8473 47.5383) ; H4*
+ #( 31.6749 7.6351 47.2119) ; O4*
+ #( 31.9159 6.5022 48.0616) ; C1*
+ #( 31.0691 5.8243 47.9544) ; H1*
+ #( 31.9300 7.0685 49.4493) ; C2*
+ #( 32.9024 7.5288 49.6245) ; H2**
+ #( 31.5672 6.1750 50.4632) ; O2*
+ #( 31.8416 5.2663 50.3200) ; H2*
+ #( 30.8618 8.1514 49.3749) ; C3*
+ #( 31.1122 8.9396 50.0850) ; H3*
+ #( 29.5351 7.6245 49.5409) ; O3*
+ #( 33.1890 5.8629 47.7343) ; N1
+ #( 34.4004 4.2636 46.4828) ; N3
+ #( 33.2062 4.8497 46.7851) ; C2
+ #( 35.5600 4.6374 47.0822) ; C4
+ #( 35.5444 5.6751 48.0577) ; C5
+ #( 34.3565 6.2450 48.3432) ; C6
+ rC
+ #( 36.6977 4.0305 46.7598) ; N4
+ #( 32.1661 4.5034 46.2348) ; O2
+ #( 37.5405 4.3347 47.2259) ; H41
+ #( 36.7033 3.2923 46.0706) ; H42
+ #( 36.4713 5.9811 48.5428) ; H5
+ #( 34.2986 7.0426 49.0839) ; H6
+ ))
+
+(define rCs
+ (list rC01 rC02 rC03 rC04 rC05 rC06 rC07 rC08 rC09 rC10))
+
+(define rG
+ (nuc-const
+ #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo
+ 0.2679 -0.5509 -0.7904
+ 0.9634 0.1517 0.2209
+ 0.0073 8.4030 0.6232)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4550 8.2120 -2.8810) ; C5*
+ #( 5.4546 8.8508 -1.9978) ; H5*
+ #( 5.7588 8.6625 -3.8259) ; H5**
+ #( 6.4970 7.1480 -2.5980) ; C4*
+ #( 7.4896 7.5919 -2.5214) ; H4*
+ #( 6.1630 6.4860 -1.3440) ; O4*
+ #( 6.5400 5.1200 -1.4190) ; C1*
+ #( 7.2763 4.9681 -0.6297) ; H1*
+ #( 7.1940 4.8830 -2.7770) ; C2*
+ #( 6.8667 3.9183 -3.1647) ; H2**
+ #( 8.5860 5.0910 -2.6140) ; O2*
+ #( 8.9510 4.7626 -1.7890) ; H2*
+ #( 6.5720 6.0040 -3.6090) ; C3*
+ #( 5.5636 5.7066 -3.8966) ; H3*
+ #( 7.3801 6.3562 -4.7350) ; O3*
+ #( 4.7150 0.4910 -0.1360) ; N1
+ #( 6.3490 2.1730 -0.6020) ; N3
+ #( 5.9530 0.9650 -0.2670) ; C2
+ #( 5.2900 2.9790 -0.8260) ; C4
+ #( 3.9720 2.6390 -0.7330) ; C5
+ #( 3.6770 1.3160 -0.3660) ; C6
+ rG
+ #( 6.8426 0.0056 -0.0019) ; N2
+ #( 3.1660 3.7290 -1.0360) ; N7
+ #( 5.3170 4.2990 -1.1930) ; N9
+ #( 4.0100 4.6780 -1.2990) ; C8
+ #( 2.4280 0.8450 -0.2360) ; O6
+ #( 4.6151 -0.4677 0.1305) ; H1
+ #( 6.6463 -0.9463 0.2729) ; H21
+ #( 7.8170 0.2642 -0.0640) ; H22
+ #( 3.4421 5.5744 -1.5482) ; H8
+ ))
+
+(define rG01
+ (nuc-const
+ #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo
+ 0.2617 -0.5567 -0.7884
+ 0.9651 0.1473 0.2164
+ 0.0359 8.3929 0.5532)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 4.7442 0.4514 -0.1390) ; N1
+ #( 6.3687 2.1459 -0.5926) ; N3
+ #( 5.9795 0.9335 -0.2657) ; C2
+ #( 5.3052 2.9471 -0.8125) ; C4
+ #( 3.9891 2.5987 -0.7230) ; C5
+ #( 3.7016 1.2717 -0.3647) ; C6
+ rG
+ #( 6.8745 -0.0224 -0.0058) ; N2
+ #( 3.1770 3.6859 -1.0198) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.0156 4.6415 -1.2759) ; C8
+ #( 2.4553 0.7925 -0.2390) ; O6
+ #( 4.6497 -0.5095 0.1212) ; H1
+ #( 6.6836 -0.9771 0.2627) ; H21
+ #( 7.8474 0.2424 -0.0653) ; H22
+ #( 3.4426 5.5361 -1.5199) ; H8
+ ))
+
+(define rG02
+ (nuc-const
+ #( 0.5566 0.0449 0.8296 ; dgf-base-tfo
+ 0.5125 0.7673 -0.3854
+ -0.6538 0.6397 0.4041
+ -9.1161 -3.7679 -2.9968)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.3245 8.5459 1.5467) ; N1
+ #( 9.8051 6.9432 -0.1497) ; N3
+ #( 10.5175 7.4328 0.8408) ; C2
+ #( 8.7523 7.7422 -0.4228) ; C4
+ #( 8.4257 8.9060 0.2099) ; C5
+ #( 9.2665 9.3242 1.2540) ; C6
+ rG
+ #( 11.6077 6.7966 1.2752) ; N2
+ #( 7.2750 9.4537 -0.3428) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9479 8.6157 -1.2771) ; C8
+ #( 9.0664 10.4462 1.9610) ; O6
+ #( 10.9838 8.7524 2.2697) ; H1
+ #( 12.2274 7.0896 2.0170) ; H21
+ #( 11.8502 5.9398 0.7984) ; H22
+ #( 6.0430 8.9853 -1.7594) ; H8
+ ))
+
+(define rG03
+ (nuc-const
+ #( -0.5021 0.0731 0.8617 ; dgf-base-tfo
+ -0.8112 0.3054 -0.4986
+ -0.2996 -0.9494 -0.0940
+ 6.4273 -5.1944 -3.7807)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 9.6740 4.7656 -7.6614) ; N1
+ #( 9.0739 4.3013 -5.3941) ; N3
+ #( 9.8416 4.2192 -6.4581) ; C2
+ #( 7.9885 5.0632 -5.6446) ; C4
+ #( 7.6822 5.6856 -6.8194) ; C5
+ #( 8.5831 5.5215 -7.8840) ; C6
+ rG
+ #( 10.9733 3.5117 -6.4286) ; N2
+ #( 6.4857 6.3816 -6.7035) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 6.1133 6.1613 -5.4808) ; C8
+ #( 8.4084 6.0747 -9.0933) ; O6
+ #( 10.3759 4.5855 -8.3504) ; H1
+ #( 11.6254 3.3761 -7.1879) ; H21
+ #( 11.1917 3.0460 -5.5593) ; H22
+ #( 5.1705 6.6830 -5.3167) ; H8
+ ))
+
+(define rG04
+ (nuc-const
+ #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo
+ 0.8304 -0.5567 -0.0237
+ 0.1267 0.1473 0.9809
+ -0.5075 8.3929 0.2229)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 5.4352 8.2183 -2.7757) ; C5*
+ #( 5.3830 8.7883 -1.8481) ; H5*
+ #( 5.7729 8.7436 -3.6691) ; H5**
+ #( 6.4830 7.1518 -2.5252) ; C4*
+ #( 7.4749 7.5972 -2.4482) ; H4*
+ #( 6.1626 6.4620 -1.2827) ; O4*
+ #( 6.5431 5.0992 -1.3905) ; C1*
+ #( 7.2871 4.9328 -0.6114) ; H1*
+ #( 7.1852 4.8935 -2.7592) ; C2*
+ #( 6.8573 3.9363 -3.1645) ; H2**
+ #( 8.5780 5.1025 -2.6046) ; O2*
+ #( 8.9516 4.7577 -1.7902) ; H2*
+ #( 6.5522 6.0300 -3.5612) ; C3*
+ #( 5.5420 5.7356 -3.8459) ; H3*
+ #( 7.3487 6.4089 -4.6867) ; O3*
+ #( 3.6343 2.6680 2.0783) ; N1
+ #( 5.4505 3.9805 1.2446) ; N3
+ #( 4.7540 3.3816 2.1851) ; C2
+ #( 4.8805 3.7951 0.0354) ; C4
+ #( 3.7416 3.0925 -0.2305) ; C5
+ #( 3.0873 2.4980 0.8606) ; C6
+ rG
+ #( 5.1433 3.4373 3.4609) ; N2
+ #( 3.4605 3.1184 -1.5906) ; N7
+ #( 5.3247 4.2695 -1.1710) ; N9
+ #( 4.4244 3.8244 -2.0953) ; C8
+ #( 1.9600 1.7805 0.7462) ; O6
+ #( 3.2489 2.2879 2.9191) ; H1
+ #( 4.6785 3.0243 4.2568) ; H21
+ #( 5.9823 3.9654 3.6539) ; H22
+ #( 4.2675 3.8876 -3.1721) ; H8
+ ))
+
+(define rG05
+ (nuc-const
+ #( -0.5891 0.0449 0.8068 ; dgf-base-tfo
+ 0.5375 0.7673 0.3498
+ -0.6034 0.6397 -0.4762
+ -0.3019 -3.7679 -9.5913)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.5778 6.6594 -4.0364) ; C5*
+ #( 4.9220 7.1963 -4.9204) ; H5*
+ #( 3.7996 5.9091 -4.1764) ; H5**
+ #( 5.7873 5.8869 -3.5482) ; C4*
+ #( 6.0405 5.0875 -4.2446) ; H4*
+ #( 6.9135 6.8036 -3.4310) ; O4*
+ #( 7.7293 6.4084 -2.3392) ; C1*
+ #( 8.7078 6.1815 -2.7624) ; H1*
+ #( 7.1305 5.1418 -1.7347) ; C2*
+ #( 7.2040 5.1982 -0.6486) ; H2**
+ #( 7.7417 4.0392 -2.3813) ; O2*
+ #( 8.6785 4.1443 -2.5630) ; H2*
+ #( 5.6666 5.2728 -2.1536) ; C3*
+ #( 5.1747 5.9805 -1.4863) ; H3*
+ #( 4.9997 4.0086 -2.1973) ; O3*
+ #( 10.2594 10.6774 -1.0056) ; N1
+ #( 9.7528 8.7080 -2.2631) ; N3
+ #( 10.4471 9.7876 -1.9791) ; C2
+ #( 8.7271 8.5575 -1.3991) ; C4
+ #( 8.4100 9.3803 -0.3580) ; C5
+ #( 9.2294 10.5030 -0.1574) ; C6
+ rG
+ #( 11.5110 10.1256 -2.7114) ; N2
+ #( 7.2891 8.9068 0.3121) ; N7
+ #( 7.7962 7.5519 -1.3859) ; N9
+ #( 6.9702 7.8292 -0.3353) ; C8
+ #( 9.0349 11.3951 0.8250) ; O6
+ #( 10.9013 11.4422 -0.9512) ; H1
+ #( 12.1031 10.9341 -2.5861) ; H21
+ #( 11.7369 9.5180 -3.4859) ; H22
+ #( 6.0888 7.3990 0.1403) ; H8
+ ))
+
+(define rG06
+ (nuc-const
+ #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo
+ 0.1912 0.3054 -0.9328
+ -0.0141 -0.9494 -0.3137
+ 5.7506 -5.1944 4.7470)
+ #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo
+ -0.0433 -0.4257 0.9038
+ -0.5788 0.7480 0.3246
+ 1.5227 6.9114 -7.0765)
+ #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo
+ 0.4552 0.6637 0.5935
+ -0.8042 0.0203 0.5941
+ -6.9472 -4.1186 -5.9108)
+ #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo
+ -0.8247 0.5587 -0.0878
+ 0.0426 0.2162 0.9754
+ 6.2694 -7.0540 3.3316)
+ #( 2.8930 8.5380 -3.3280) ; P
+ #( 1.6980 7.6960 -3.5570) ; O1P
+ #( 3.2260 9.5010 -4.4020) ; O2P
+ #( 4.1590 7.6040 -3.0340) ; O5*
+ #( 4.1214 6.7116 -1.9049) ; C5*
+ #( 3.3465 5.9610 -2.0607) ; H5*
+ #( 4.0789 7.2928 -0.9837) ; H5**
+ #( 5.4170 5.9293 -1.8186) ; C4*
+ #( 5.4506 5.3400 -0.9023) ; H4*
+ #( 5.5067 5.0417 -2.9703) ; O4*
+ #( 6.8650 4.9152 -3.3612) ; C1*
+ #( 7.1090 3.8577 -3.2603) ; H1*
+ #( 7.7152 5.7282 -2.3894) ; C2*
+ #( 8.5029 6.2356 -2.9463) ; H2**
+ #( 8.1036 4.8568 -1.3419) ; O2*
+ #( 8.3270 3.9651 -1.6184) ; H2*
+ #( 6.7003 6.7565 -1.8911) ; C3*
+ #( 6.5898 7.5329 -2.6482) ; H3*
+ #( 7.0505 7.2878 -0.6105) ; O3*
+ #( 6.6624 3.5061 -8.2986) ; N1
+ #( 6.5810 3.2570 -5.9221) ; N3
+ #( 6.5151 2.8263 -7.1625) ; C2
+ #( 6.8364 4.5817 -5.8882) ; C4
+ #( 7.0116 5.4064 -6.9609) ; C5
+ #( 6.9173 4.8260 -8.2361) ; C6
+ rG
+ #( 6.2717 1.5402 -7.4250) ; N2
+ #( 7.2573 6.7070 -6.5394) ; N7
+ #( 6.9740 5.3703 -4.7760) ; N9
+ #( 7.2238 6.6275 -5.2453) ; C8
+ #( 7.0668 5.5163 -9.3763) ; O6
+ #( 6.5754 2.9964 -9.1545) ; H1
+ #( 6.1908 1.1105 -8.3354) ; H21
+ #( 6.1346 0.9352 -6.6280) ; H22
+ #( 7.4108 7.6227 -4.8418) ; H8
+ ))
+
+(define rG07
+ (nuc-const
+ #( 0.0894 -0.6059 0.7905 ; dgf-base-tfo
+ -0.6810 0.5420 0.4924
+ -0.7268 -0.5824 -0.3642
+ 34.1424 45.9610 -11.8600)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 33.8709 0.7918 47.2113) ; C5*
+ #( 34.1386 0.5870 46.1747) ; H5*
+ #( 34.0186 -0.0095 47.9353) ; H5**
+ #( 34.7297 1.9687 47.6685) ; C4*
+ #( 35.7723 1.6845 47.8113) ; H4*
+ #( 34.6455 2.9768 46.6660) ; O4*
+ #( 34.1690 4.1829 47.2627) ; C1*
+ #( 35.0437 4.7633 47.5560) ; H1*
+ #( 33.4145 3.7532 48.4954) ; C2*
+ #( 32.4340 3.3797 48.2001) ; H2**
+ #( 33.3209 4.6953 49.5217) ; O2*
+ #( 33.2374 5.6059 49.2295) ; H2*
+ #( 34.2724 2.5970 48.9773) ; C3*
+ #( 33.6373 1.8935 49.5157) ; H3*
+ #( 35.3453 3.1884 49.7285) ; O3*
+ #( 34.0511 7.8930 43.7791) ; N1
+ #( 34.9937 6.3369 45.3199) ; N3
+ #( 35.0882 7.3126 44.4200) ; C2
+ #( 33.7190 5.9650 45.5374) ; C4
+ #( 32.5845 6.4770 44.9458) ; C5
+ #( 32.7430 7.5179 43.9914) ; C6
+ rG
+ #( 36.3030 7.7827 44.1036) ; N2
+ #( 31.4499 5.8335 45.4368) ; N7
+ #( 33.2760 4.9817 46.4043) ; N9
+ #( 31.9235 4.9639 46.2934) ; C8
+ #( 31.8602 8.1000 43.3695) ; O6
+ #( 34.2623 8.6223 43.1283) ; H1
+ #( 36.5188 8.5081 43.4347) ; H21
+ #( 37.0888 7.3524 44.5699) ; H22
+ #( 31.0815 4.4201 46.7218) ; H8
+ ))
+
+(define rG08
+ (nuc-const
+ #( 0.2224 0.6335 0.7411 ; dgf-base-tfo
+ -0.3644 -0.6510 0.6659
+ 0.9043 -0.4181 0.0861
+ -47.6824 -0.5823 -31.7554)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.5924 2.3488 48.2255) ; C5*
+ #( 33.3674 2.1246 48.9584) ; H5*
+ #( 31.5994 2.5917 48.6037) ; H5**
+ #( 33.0722 3.5577 47.4258) ; C4*
+ #( 33.0310 4.4778 48.0089) ; H4*
+ #( 34.4173 3.3055 47.0316) ; O4*
+ #( 34.5056 3.3910 45.6094) ; C1*
+ #( 34.7881 4.4152 45.3663) ; H1*
+ #( 33.1122 3.1198 45.1010) ; C2*
+ #( 32.9230 2.0469 45.1369) ; H2**
+ #( 32.7946 3.6590 43.8529) ; O2*
+ #( 33.5170 3.6707 43.2207) ; H2*
+ #( 32.2730 3.8173 46.1566) ; C3*
+ #( 31.3094 3.3123 46.2244) ; H3*
+ #( 32.2391 5.2039 45.7807) ; O3*
+ #( 39.3337 2.7157 44.1441) ; N1
+ #( 37.4430 3.8242 45.0824) ; N3
+ #( 38.7276 3.7646 44.7403) ; C2
+ #( 36.7791 2.6963 44.7704) ; C4
+ #( 37.2860 1.5653 44.1678) ; C5
+ #( 38.6647 1.5552 43.8235) ; C6
+ rG
+ #( 39.5123 4.8216 44.9936) ; N2
+ #( 36.2829 0.6110 44.0078) ; N7
+ #( 35.4394 2.4314 44.9931) ; N9
+ #( 35.2180 1.1815 44.5128) ; C8
+ #( 39.2907 0.6514 43.2796) ; O6
+ #( 40.3076 2.8048 43.9352) ; H1
+ #( 40.4994 4.9066 44.7977) ; H21
+ #( 39.0738 5.6108 45.4464) ; H22
+ #( 34.3856 0.4842 44.4185) ; H8
+ ))
+
+(define rG09
+ (nuc-const
+ #( -0.9699 -0.1688 -0.1753 ; dgf-base-tfo
+ -0.1050 -0.3598 0.9271
+ -0.2196 0.9176 0.3312
+ 45.6217 -38.9484 -12.3208)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 33.8709 0.7918 47.2113) ; C5*
+ #( 34.1386 0.5870 46.1747) ; H5*
+ #( 34.0186 -0.0095 47.9353) ; H5**
+ #( 34.7297 1.9687 47.6685) ; C4*
+ #( 34.5880 2.8482 47.0404) ; H4*
+ #( 34.3575 2.2770 49.0081) ; O4*
+ #( 35.5157 2.1993 49.8389) ; C1*
+ #( 35.9424 3.2010 49.8893) ; H1*
+ #( 36.4701 1.2820 49.1169) ; C2*
+ #( 36.1545 0.2498 49.2683) ; H2**
+ #( 37.8262 1.4547 49.4008) ; O2*
+ #( 38.0227 1.6945 50.3094) ; H2*
+ #( 36.2242 1.6797 47.6725) ; C3*
+ #( 36.4297 0.8197 47.0351) ; H3*
+ #( 37.0289 2.8480 47.4426) ; O3*
+ #( 34.3005 3.5042 54.6070) ; N1
+ #( 34.7693 3.7936 52.2874) ; N3
+ #( 34.4484 4.2541 53.4939) ; C2
+ #( 34.9354 2.4584 52.2785) ; C4
+ #( 34.8092 1.5915 53.3422) ; C5
+ #( 34.4646 2.1367 54.6085) ; C6
+ rG
+ #( 34.2514 5.5708 53.6503) ; N2
+ #( 35.0641 0.2835 52.9337) ; N7
+ #( 35.2669 1.6690 51.1915) ; N9
+ #( 35.3288 0.3954 51.6563) ; C8
+ #( 34.3151 1.5317 55.6650) ; O6
+ #( 34.0623 3.9797 55.4539) ; H1
+ #( 33.9950 6.0502 54.5016) ; H21
+ #( 34.3512 6.1432 52.8242) ; H22
+ #( 35.5414 -0.6006 51.2679) ; H8
+ ))
+
+(define rG10
+ (nuc-const
+ #( -0.0980 -0.9723 0.2122 ; dgf-base-tfo
+ -0.9731 0.1383 0.1841
+ -0.2083 -0.1885 -0.9597
+ 17.8469 38.8265 37.0475)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.5924 2.3488 48.2255) ; C5*
+ #( 33.3674 2.1246 48.9584) ; H5*
+ #( 31.5994 2.5917 48.6037) ; H5**
+ #( 33.0722 3.5577 47.4258) ; C4*
+ #( 34.0333 3.3761 46.9447) ; H4*
+ #( 32.0890 3.8338 46.4332) ; O4*
+ #( 31.6377 5.1787 46.5914) ; C1*
+ #( 32.2499 5.8016 45.9392) ; H1*
+ #( 31.9167 5.5319 48.0305) ; C2*
+ #( 31.1507 5.0820 48.6621) ; H2**
+ #( 32.0865 6.8890 48.3114) ; O2*
+ #( 31.5363 7.4819 47.7942) ; H2*
+ #( 33.2398 4.8224 48.2563) ; C3*
+ #( 33.3166 4.5570 49.3108) ; H3*
+ #( 34.2528 5.7056 47.7476) ; O3*
+ #( 28.2782 6.3049 42.9364) ; N1
+ #( 30.4001 5.8547 43.9258) ; N3
+ #( 29.6195 6.1568 42.8913) ; C2
+ #( 29.7005 5.7006 45.0649) ; C4
+ #( 28.3383 5.8221 45.2343) ; C5
+ #( 27.5519 6.1461 44.0958) ; C6
+ rG
+ #( 30.1838 6.3385 41.6890) ; N2
+ #( 27.9936 5.5926 46.5651) ; N7
+ #( 30.2046 5.3825 46.3136) ; N9
+ #( 29.1371 5.3398 47.1506) ; C8
+ #( 26.3361 6.3024 44.0495) ; O6
+ #( 27.8122 6.5394 42.0833) ; H1
+ #( 29.7125 6.5595 40.8235) ; H21
+ #( 31.1859 6.2231 41.6389) ; H22
+ #( 28.9406 5.1504 48.2059) ; H8
+ ))
+
+(define rGs
+ (list rG01 rG02 rG03 rG04 rG05 rG06 rG07 rG08 rG09 rG10))
+
+(define rU
+ (nuc-const
+ #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo
+ -0.2669 0.5761 0.7726
+ -0.9631 -0.1296 -0.2361
+ 0.1584 8.3434 0.5434)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 7.2954 -7.6762 2.4898) ; H4*
+ #( 6.0140 -6.5420 1.2890) ; O4*
+ #( 6.4190 -5.1840 1.3620) ; C1*
+ #( 7.1608 -5.0495 0.5747) ; H1*
+ #( 7.0760 -4.9560 2.7270) ; C2*
+ #( 6.7770 -3.9803 3.1099) ; H2**
+ #( 8.4500 -5.1930 2.5810) ; O2*
+ #( 8.8309 -4.8755 1.7590) ; H2*
+ #( 6.4060 -6.0590 3.5580) ; C3*
+ #( 5.4021 -5.7313 3.8281) ; H3*
+ #( 7.1570 -6.4240 4.7070) ; O3*
+ #( 5.2170 -4.3260 1.1690) ; N1
+ #( 4.2960 -2.2560 0.6290) ; N3
+ #( 5.4330 -3.0200 0.7990) ; C2
+ #( 2.9930 -2.6780 0.7940) ; C4
+ #( 2.8670 -4.0630 1.1830) ; C5
+ #( 3.9570 -4.8300 1.3550) ; C6
+ rU
+ #( 6.5470 -2.5560 0.6290) ; O2
+ #( 2.0540 -1.9000 0.6130) ; O4
+ #( 4.4300 -1.3020 0.3600) ; H3
+ #( 1.9590 -4.4570 1.3250) ; H5
+ #( 3.8460 -5.7860 1.6240) ; H6
+ ))
+
+(define rU01
+ (nuc-const
+ #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo
+ -0.2523 0.5817 0.7733
+ -0.9675 -0.1404 -0.2101
+ 0.2031 8.3874 0.4228)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 4.3777 -2.2062 0.7229) ; N3
+ #( 5.5069 -2.9779 0.9088) ; C2
+ #( 3.0693 -2.6246 0.8500) ; C4
+ #( 2.9279 -4.0146 1.2149) ; C5
+ #( 4.0101 -4.7892 1.4017) ; C6
+ rU
+ #( 6.6267 -2.5166 0.7728) ; O2
+ #( 2.1383 -1.8396 0.6581) ; O4
+ #( 4.5223 -1.2489 0.4716) ; H3
+ #( 2.0151 -4.4065 1.3290) ; H5
+ #( 3.8886 -5.7486 1.6535) ; H6
+ ))
+
+(define rU02
+ (nuc-const
+ #( 0.5141 0.0246 0.8574 ; dgf-base-tfo
+ -0.5547 -0.7529 0.3542
+ 0.6542 -0.6577 -0.3734
+ -9.1111 -3.4598 -3.2939)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.6945 -8.7046 -0.2857) ; N3
+ #( 8.6943 -7.6514 0.6066) ; C2
+ #( 7.7426 -9.6987 -0.3801) ; C4
+ #( 6.6642 -9.5742 0.5722) ; C5
+ #( 6.6391 -8.5592 1.4526) ; C6
+ rU
+ #( 9.5840 -6.8186 0.6136) ; O2
+ #( 7.8505 -10.5925 -1.2223) ; O4
+ #( 9.4601 -8.7514 -0.9277) ; H3
+ #( 5.9281 -10.2509 0.5782) ; H5
+ #( 5.8831 -8.4931 2.1028) ; H6
+ ))
+
+(define rU03
+ (nuc-const
+ #( -0.4993 0.0476 0.8651 ; dgf-base-tfo
+ 0.8078 -0.3353 0.4847
+ 0.3132 0.9409 0.1290
+ 6.2989 -5.2303 -3.8577)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 7.9218 -5.5700 6.8877) ; N3
+ #( 7.8908 -5.0886 5.5944) ; C2
+ #( 6.9789 -6.3827 7.4823) ; C4
+ #( 5.8742 -6.7319 6.6202) ; C5
+ #( 5.8182 -6.2769 5.3570) ; C6
+ rU
+ #( 8.7747 -4.3728 5.1568) ; O2
+ #( 7.1154 -6.7509 8.6509) ; O4
+ #( 8.7055 -5.3037 7.4491) ; H3
+ #( 5.1416 -7.3178 6.9665) ; H5
+ #( 5.0441 -6.5310 4.7784) ; H6
+ ))
+
+(define rU04
+ (nuc-const
+ #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo
+ -0.8129 0.5817 0.0273
+ -0.1334 -0.1404 -0.9811
+ -0.3279 8.3874 0.3355)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2416 -8.2422 2.8181) ; C5*
+ #( 5.2050 -8.8128 1.8901) ; H5*
+ #( 5.5368 -8.7738 3.7227) ; H5**
+ #( 6.3232 -7.2037 2.6002) ; C4*
+ #( 7.3048 -7.6757 2.5577) ; H4*
+ #( 6.0635 -6.5092 1.3456) ; O4*
+ #( 6.4697 -5.1547 1.4629) ; C1*
+ #( 7.2354 -5.0043 0.7018) ; H1*
+ #( 7.0856 -4.9610 2.8521) ; C2*
+ #( 6.7777 -3.9935 3.2487) ; H2**
+ #( 8.4627 -5.1992 2.7423) ; O2*
+ #( 8.8693 -4.8638 1.9399) ; H2*
+ #( 6.3877 -6.0809 3.6362) ; C3*
+ #( 5.3770 -5.7562 3.8834) ; H3*
+ #( 7.1024 -6.4754 4.7985) ; O3*
+ #( 5.2764 -4.2883 1.2538) ; N1
+ #( 3.8961 -3.0896 -0.1893) ; N3
+ #( 5.0095 -3.8907 -0.0346) ; C2
+ #( 3.0480 -2.6632 0.8116) ; C4
+ #( 3.4093 -3.1310 2.1292) ; C5
+ #( 4.4878 -3.9124 2.3088) ; C6
+ rU
+ #( 5.7005 -4.2164 -0.9842) ; O2
+ #( 2.0800 -1.9458 0.5503) ; O4
+ #( 3.6834 -2.7882 -1.1190) ; H3
+ #( 2.8508 -2.8721 2.9172) ; H5
+ #( 4.7188 -4.2247 3.2295) ; H6
+ ))
+
+(define rU05
+ (nuc-const
+ #( -0.6298 0.0246 0.7763 ; dgf-base-tfo
+ -0.5226 -0.7529 -0.4001
+ 0.5746 -0.6577 0.4870
+ -0.0208 -3.4598 -9.6882)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 4.3825 -6.6585 4.0489) ; C5*
+ #( 4.6841 -7.2019 4.9443) ; H5*
+ #( 3.6189 -5.8889 4.1625) ; H5**
+ #( 5.6255 -5.9175 3.5998) ; C4*
+ #( 5.8732 -5.1228 4.3034) ; H4*
+ #( 6.7337 -6.8605 3.5222) ; O4*
+ #( 7.5932 -6.4923 2.4548) ; C1*
+ #( 8.5661 -6.2983 2.9064) ; H1*
+ #( 7.0527 -5.2012 1.8322) ; C2*
+ #( 7.1627 -5.2525 0.7490) ; H2**
+ #( 7.6666 -4.1249 2.4880) ; O2*
+ #( 8.5944 -4.2543 2.6981) ; H2*
+ #( 5.5661 -5.3029 2.2009) ; C3*
+ #( 5.0841 -6.0018 1.5172) ; H3*
+ #( 4.9062 -4.0452 2.2042) ; O3*
+ #( 7.6298 -7.6136 1.4752) ; N1
+ #( 8.5977 -9.5977 0.7329) ; N3
+ #( 8.5951 -8.5745 1.6594) ; C2
+ #( 7.7372 -9.7371 -0.3364) ; C4
+ #( 6.7596 -8.6801 -0.4476) ; C5
+ #( 6.7338 -7.6721 0.4408) ; C6
+ rU
+ #( 9.3993 -8.5377 2.5743) ; O2
+ #( 7.8374 -10.6990 -1.1008) ; O4
+ #( 9.2924 -10.3081 0.8477) ; H3
+ #( 6.0932 -8.6982 -1.1929) ; H5
+ #( 6.0481 -6.9515 0.3446) ; H6
+ ))
+
+(define rU06
+ (nuc-const
+ #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo
+ -0.1792 -0.3353 0.9249
+ -0.0141 0.9409 0.3384
+ 5.7793 -5.2303 4.5997)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 3.9938 -6.7042 1.9023) ; C5*
+ #( 3.2332 -5.9343 2.0319) ; H5*
+ #( 3.9666 -7.2863 0.9812) ; H5**
+ #( 5.3098 -5.9546 1.8564) ; C4*
+ #( 5.3863 -5.3702 0.9395) ; H4*
+ #( 5.3851 -5.0642 3.0076) ; O4*
+ #( 6.7315 -4.9724 3.4462) ; C1*
+ #( 7.0033 -3.9202 3.3619) ; H1*
+ #( 7.5997 -5.8018 2.4948) ; C2*
+ #( 8.3627 -6.3254 3.0707) ; H2**
+ #( 8.0410 -4.9501 1.4724) ; O2*
+ #( 8.2781 -4.0644 1.7570) ; H2*
+ #( 6.5701 -6.8129 1.9714) ; C3*
+ #( 6.4186 -7.5809 2.7299) ; H3*
+ #( 6.9357 -7.3841 0.7235) ; O3*
+ #( 6.8024 -5.4718 4.8475) ; N1
+ #( 6.6920 -5.0495 7.1354) ; N3
+ #( 6.6201 -4.5500 5.8506) ; C2
+ #( 6.9254 -6.3614 7.4926) ; C4
+ #( 7.1046 -7.2543 6.3718) ; C5
+ #( 7.0391 -6.7951 5.1106) ; C6
+ rU
+ #( 6.4083 -3.3696 5.6340) ; O2
+ #( 6.9679 -6.6901 8.6800) ; O4
+ #( 6.5626 -4.3957 7.8812) ; H3
+ #( 7.2781 -8.2254 6.5350) ; H5
+ #( 7.1657 -7.4312 4.3503) ; H6
+ ))
+
+(define rU07
+ (nuc-const
+ #( -0.9434 0.3172 0.0971 ; dgf-base-tfo
+ 0.2294 0.4125 0.8816
+ 0.2396 0.8539 -0.4619
+ 8.3625 -52.7147 1.3745)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 21.5037 16.8594 43.7323) ; C5*
+ #( 20.8147 17.6663 43.9823) ; H5*
+ #( 21.1086 16.0230 43.1557) ; H5**
+ #( 22.5654 17.4874 42.8616) ; C4*
+ #( 22.1584 17.7243 41.8785) ; H4*
+ #( 23.0557 18.6826 43.4751) ; O4*
+ #( 24.4788 18.6151 43.6455) ; C1*
+ #( 24.9355 19.0840 42.7739) ; H1*
+ #( 24.7958 17.1427 43.6474) ; C2*
+ #( 24.5652 16.7400 44.6336) ; H2**
+ #( 26.1041 16.8773 43.2455) ; O2*
+ #( 26.7516 17.5328 43.5149) ; H2*
+ #( 23.8109 16.5979 42.6377) ; C3*
+ #( 23.5756 15.5686 42.9084) ; H3*
+ #( 24.2890 16.7447 41.2729) ; O3*
+ #( 24.9420 19.2174 44.8923) ; N1
+ #( 25.2655 20.5636 44.8883) ; N3
+ #( 25.1663 21.2219 43.8561) ; C2
+ #( 25.6911 21.1219 46.0494) ; C4
+ #( 25.8051 20.4068 47.2048) ; C5
+ #( 26.2093 20.9962 48.2534) ; C6
+ rU
+ #( 25.4692 19.0221 47.2053) ; O2
+ #( 25.0502 18.4827 46.0370) ; O4
+ #( 25.9599 22.1772 46.0966) ; H3
+ #( 25.5545 18.4409 48.1234) ; H5
+ #( 24.7854 17.4265 45.9883) ; H6
+ ))
+
+(define rU08
+ (nuc-const
+ #( -0.0080 -0.7928 0.6094 ; dgf-base-tfo
+ -0.7512 0.4071 0.5197
+ -0.6601 -0.4536 -0.5988
+ 44.1482 30.7036 2.1088)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 23.5096 16.1227 44.5783) ; C5*
+ #( 23.5649 15.8588 43.5222) ; H5*
+ #( 23.9621 15.4341 45.2919) ; H5**
+ #( 24.2805 17.4138 44.7151) ; C4*
+ #( 25.3492 17.2309 44.6030) ; H4*
+ #( 23.8497 18.3471 43.7208) ; O4*
+ #( 23.4090 19.5681 44.3321) ; C1*
+ #( 24.2595 20.2496 44.3524) ; H1*
+ #( 23.0418 19.1813 45.7407) ; C2*
+ #( 22.0532 18.7224 45.7273) ; H2**
+ #( 23.1307 20.2521 46.6291) ; O2*
+ #( 22.8888 21.1051 46.2611) ; H2*
+ #( 24.0799 18.1326 46.0700) ; C3*
+ #( 23.6490 17.4370 46.7900) ; H3*
+ #( 25.3329 18.7227 46.5109) ; O3*
+ #( 22.2515 20.1624 43.6698) ; N1
+ #( 22.4760 21.0609 42.6406) ; N3
+ #( 23.6229 21.3462 42.3061) ; C2
+ #( 21.3986 21.6081 42.0236) ; C4
+ #( 20.1189 21.3012 42.3804) ; C5
+ #( 19.1599 21.8516 41.7578) ; C6
+ rU
+ #( 19.8919 20.3745 43.4387) ; O2
+ #( 20.9790 19.8423 44.0440) ; O4
+ #( 21.5235 22.3222 41.2097) ; H3
+ #( 18.8732 20.1200 43.7312) ; H5
+ #( 20.8545 19.1313 44.8608) ; H6
+ ))
+
+(define rU09
+ (nuc-const
+ #( -0.0317 0.1374 0.9900 ; dgf-base-tfo
+ -0.3422 -0.9321 0.1184
+ 0.9391 -0.3351 0.0765
+ -32.1929 25.8198 -28.5088)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 21.5037 16.8594 43.7323) ; C5*
+ #( 20.8147 17.6663 43.9823) ; H5*
+ #( 21.1086 16.0230 43.1557) ; H5**
+ #( 22.5654 17.4874 42.8616) ; C4*
+ #( 23.0565 18.3036 43.3915) ; H4*
+ #( 23.5375 16.5054 42.4925) ; O4*
+ #( 23.6574 16.4257 41.0649) ; C1*
+ #( 24.4701 17.0882 40.7671) ; H1*
+ #( 22.3525 16.9643 40.5396) ; C2*
+ #( 21.5993 16.1799 40.6133) ; H2**
+ #( 22.4693 17.4849 39.2515) ; O2*
+ #( 23.0899 17.0235 38.6827) ; H2*
+ #( 22.0341 18.0633 41.5279) ; C3*
+ #( 20.9509 18.1709 41.5846) ; H3*
+ #( 22.7249 19.3020 41.2100) ; O3*
+ #( 23.8580 15.0648 40.5757) ; N1
+ #( 25.1556 14.5982 40.4523) ; N3
+ #( 26.1047 15.3210 40.7448) ; C2
+ #( 25.3391 13.3315 40.0020) ; C4
+ #( 24.2974 12.5148 39.6749) ; C5
+ #( 24.5450 11.3410 39.2610) ; C6
+ rU
+ #( 22.9633 12.9979 39.8053) ; O2
+ #( 22.8009 14.2648 40.2524) ; O4
+ #( 26.3414 12.9194 39.8855) ; H3
+ #( 22.1227 12.3533 39.5486) ; H5
+ #( 21.7989 14.6788 40.3650) ; H6
+ ))
+
+(define rU10
+ (nuc-const
+ #( -0.9674 0.1021 -0.2318 ; dgf-base-tfo
+ -0.2514 -0.2766 0.9275
+ 0.0306 0.9555 0.2933
+ 27.8571 -42.1305 -24.4563)
+ #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo
+ -0.8297 0.4733 -0.2959
+ 0.4850 0.8737 0.0379
+ -14.7774 -45.2464 21.9088)
+ #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo
+ -0.5932 -0.6591 0.4624
+ -0.7980 0.4055 -0.4458
+ 43.7634 4.3296 28.4890)
+ #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo
+ 0.6803 0.3317 0.6536
+ -0.1673 -0.7979 0.5791
+ -17.1858 41.4390 -27.0751)
+ #( 21.3880 15.0780 45.5770) ; P
+ #( 21.9980 14.5500 46.8210) ; O1P
+ #( 21.1450 14.0270 44.5420) ; O2P
+ #( 22.1250 16.3600 44.9460) ; O5*
+ #( 23.5096 16.1227 44.5783) ; C5*
+ #( 23.5649 15.8588 43.5222) ; H5*
+ #( 23.9621 15.4341 45.2919) ; H5**
+ #( 24.2805 17.4138 44.7151) ; C4*
+ #( 23.8509 18.1819 44.0720) ; H4*
+ #( 24.2506 17.8583 46.0741) ; O4*
+ #( 25.5830 18.0320 46.5775) ; C1*
+ #( 25.8569 19.0761 46.4256) ; H1*
+ #( 26.4410 17.1555 45.7033) ; C2*
+ #( 26.3459 16.1253 46.0462) ; H2**
+ #( 27.7649 17.5888 45.6478) ; O2*
+ #( 28.1004 17.9719 46.4616) ; H2*
+ #( 25.7796 17.2997 44.3513) ; C3*
+ #( 25.9478 16.3824 43.7871) ; H3*
+ #( 26.2154 18.4984 43.6541) ; O3*
+ #( 25.7321 17.6281 47.9726) ; N1
+ #( 25.5136 18.5779 48.9560) ; N3
+ #( 25.2079 19.7276 48.6503) ; C2
+ #( 25.6482 18.1987 50.2518) ; C4
+ #( 25.9847 16.9266 50.6092) ; C5
+ #( 26.0918 16.6439 51.8416) ; C6
+ rU
+ #( 26.2067 15.9515 49.5943) ; O2
+ #( 26.0713 16.3497 48.3080) ; O4
+ #( 25.4890 18.9105 51.0618) ; H3
+ #( 26.4742 14.9310 49.8682) ; H5
+ #( 26.2346 15.6394 47.4975) ; H6
+ ))
+
+(define rUs
+ (list rU01 rU02 rU03 rU04 rU05 rU06 rU07 rU08 rU09 rU10))
+
+(define rG*
+ (nuc-const
+ #( -0.2067 -0.0264 0.9780 ; dgf-base-tfo
+ 0.9770 -0.0586 0.2049
+ 0.0519 0.9979 0.0379
+ 1.0331 -46.8078 -36.4742)
+ #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo
+ -0.0427 0.2409 -0.9696
+ 0.5010 -0.8345 -0.2294
+ 4.0167 54.5377 12.4779)
+ #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo
+ -0.2867 -0.7872 -0.5460
+ 0.8834 0.0032 -0.4686
+ -52.9020 18.6313 -0.6709)
+ #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo
+ 0.9040 -0.4236 -0.0582
+ -0.1007 -0.0786 -0.9918
+ -7.6624 -25.2080 49.5181)
+ #( 31.3810 0.1400 47.5810) ; P
+ #( 29.9860 0.6630 47.6290) ; O1P
+ #( 31.7210 -0.6460 48.8090) ; O2P
+ #( 32.4940 1.2540 47.2740) ; O5*
+ #( 32.1610 2.2370 46.2560) ; C5*
+ #( 31.2986 2.8190 46.5812) ; H5*
+ #( 32.0980 1.7468 45.2845) ; H5**
+ #( 33.3476 3.1959 46.1947) ; C4*
+ #( 33.2668 3.8958 45.3630) ; H4*
+ #( 33.3799 3.9183 47.4216) ; O4*
+ #( 34.6515 3.7222 48.0398) ; C1*
+ #( 35.2947 4.5412 47.7180) ; H1*
+ #( 35.1756 2.4228 47.4827) ; C2*
+ #( 34.6778 1.5937 47.9856) ; H2**
+ #( 36.5631 2.2672 47.4798) ; O2*
+ #( 37.0163 2.6579 48.2305) ; H2*
+ #( 34.6953 2.5043 46.0448) ; C3*
+ #( 34.5444 1.4917 45.6706) ; H3*
+ #( 35.6679 3.3009 45.3487) ; O3*
+ #( 37.4804 4.0914 52.2559) ; N1
+ #( 36.9670 4.1312 49.9281) ; N3
+ #( 37.8045 4.2519 50.9550) ; C2
+ #( 35.7171 3.8264 50.3222) ; C4
+ #( 35.2668 3.6420 51.6115) ; C5
+ #( 36.2037 3.7829 52.6706) ; C6
+ rG
+ #( 39.0869 4.5552 50.7092) ; N2
+ #( 33.9075 3.3338 51.6102) ; N7
+ #( 34.6126 3.6358 49.5108) ; N9
+ #( 33.5805 3.3442 50.3425) ; C8
+ #( 35.9958 3.6512 53.8724) ; O6
+ #( 38.2106 4.2053 52.9295) ; H1
+ #( 39.8218 4.6863 51.3896) ; H21
+ #( 39.3420 4.6857 49.7407) ; H22
+ #( 32.5194 3.1070 50.2664) ; H8
+ ))
+
+(define rU*
+ (nuc-const
+ #( -0.0109 0.5907 0.8068 ; dgf-base-tfo
+ 0.2217 -0.7853 0.5780
+ 0.9751 0.1852 -0.1224
+ -1.4225 -11.0956 -2.5217)
+ #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo
+ 0.0649 0.4366 -0.8973
+ 0.5521 -0.7648 -0.3322
+ 1.6833 6.8060 -7.0011)
+ #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo
+ -0.4628 -0.6450 -0.6082
+ 0.8168 -0.0436 -0.5753
+ -6.8179 -3.9778 -5.9887)
+ #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo
+ 0.8103 -0.5790 0.0906
+ -0.0255 -0.1894 -0.9816
+ 6.1203 -7.1051 3.1984)
+ #( 2.6760 -8.4960 3.2880) ; P
+ #( 1.4950 -7.6230 3.4770) ; O1P
+ #( 2.9490 -9.4640 4.3740) ; O2P
+ #( 3.9730 -7.5950 3.0340) ; O5*
+ #( 5.2430 -8.2420 2.8260) ; C5*
+ #( 5.1974 -8.8497 1.9223) ; H5*
+ #( 5.5548 -8.7348 3.7469) ; H5**
+ #( 6.3140 -7.2060 2.5510) ; C4*
+ #( 5.8744 -6.2116 2.4731) ; H4*
+ #( 7.2798 -7.2260 3.6420) ; O4*
+ #( 8.5733 -6.9410 3.1329) ; C1*
+ #( 8.9047 -6.0374 3.6446) ; H1*
+ #( 8.4429 -6.6596 1.6327) ; C2*
+ #( 9.2880 -7.1071 1.1096) ; H2**
+ #( 8.2502 -5.2799 1.4754) ; O2*
+ #( 8.7676 -4.7284 2.0667) ; H2*
+ #( 7.1642 -7.4416 1.3021) ; C3*
+ #( 7.4125 -8.5002 1.2260) ; H3*
+ #( 6.5160 -6.9772 0.1267) ; O3*
+ #( 9.4531 -8.1107 3.4087) ; N1
+ #( 11.5931 -9.0015 3.6357) ; N3
+ #( 10.8101 -7.8950 3.3748) ; C2
+ #( 11.1439 -10.2744 3.9206) ; C4
+ #( 9.7056 -10.4026 3.9332) ; C5
+ #( 8.9192 -9.3419 3.6833) ; C6
+ rU
+ #( 11.3013 -6.8063 3.1326) ; O2
+ #( 11.9431 -11.1876 4.1375) ; O4
+ #( 12.5840 -8.8673 3.6158) ; H3
+ #( 9.2891 -11.2898 4.1313) ; H5
+ #( 7.9263 -9.4537 3.6977) ; H6
+ ))
+
+
+
+; -- PARTIAL INSTANTIATIONS ---------------------------------------------------
+
+(define (make-var id tfo nuc)
+ (vector id tfo nuc))
+
+(define (var-id var) (vector-ref var 0))
+(define (var-id-set! var val) (vector-set! var 0 val))
+(define (var-tfo var) (vector-ref var 1))
+(define (var-tfo-set! var val) (vector-set! var 1 val))
+(define (var-nuc var) (vector-ref var 2))
+(define (var-nuc-set! var val) (vector-set! var 2 val))
+
+(define (atom-pos atom var)
+ (tfo-apply (var-tfo var) (atom (var-nuc var))))
+
+(define (get-var id lst)
+ (let ((v (car lst)))
+ (if (= id (var-id v))
+ v
+ (get-var id (cdr lst)))))
+
+(define (make-relative-nuc tfo n)
+ (cond ((rA? n)
+ (make-rA
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (tfo-apply tfo (nuc-P n))
+ (tfo-apply tfo (nuc-O1P n))
+ (tfo-apply tfo (nuc-O2P n))
+ (tfo-apply tfo (nuc-O5* n))
+ (tfo-apply tfo (nuc-C5* n))
+ (tfo-apply tfo (nuc-H5* n))
+ (tfo-apply tfo (nuc-H5** n))
+ (tfo-apply tfo (nuc-C4* n))
+ (tfo-apply tfo (nuc-H4* n))
+ (tfo-apply tfo (nuc-O4* n))
+ (tfo-apply tfo (nuc-C1* n))
+ (tfo-apply tfo (nuc-H1* n))
+ (tfo-apply tfo (nuc-C2* n))
+ (tfo-apply tfo (nuc-H2** n))
+ (tfo-apply tfo (nuc-O2* n))
+ (tfo-apply tfo (nuc-H2* n))
+ (tfo-apply tfo (nuc-C3* n))
+ (tfo-apply tfo (nuc-H3* n))
+ (tfo-apply tfo (nuc-O3* n))
+ (tfo-apply tfo (nuc-N1 n))
+ (tfo-apply tfo (nuc-N3 n))
+ (tfo-apply tfo (nuc-C2 n))
+ (tfo-apply tfo (nuc-C4 n))
+ (tfo-apply tfo (nuc-C5 n))
+ (tfo-apply tfo (nuc-C6 n))
+ (tfo-apply tfo (rA-N6 n))
+ (tfo-apply tfo (rA-N7 n))
+ (tfo-apply tfo (rA-N9 n))
+ (tfo-apply tfo (rA-C8 n))
+ (tfo-apply tfo (rA-H2 n))
+ (tfo-apply tfo (rA-H61 n))
+ (tfo-apply tfo (rA-H62 n))
+ (tfo-apply tfo (rA-H8 n))))
+ ((rC? n)
+ (make-rC
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (tfo-apply tfo (nuc-P n))
+ (tfo-apply tfo (nuc-O1P n))
+ (tfo-apply tfo (nuc-O2P n))
+ (tfo-apply tfo (nuc-O5* n))
+ (tfo-apply tfo (nuc-C5* n))
+ (tfo-apply tfo (nuc-H5* n))
+ (tfo-apply tfo (nuc-H5** n))
+ (tfo-apply tfo (nuc-C4* n))
+ (tfo-apply tfo (nuc-H4* n))
+ (tfo-apply tfo (nuc-O4* n))
+ (tfo-apply tfo (nuc-C1* n))
+ (tfo-apply tfo (nuc-H1* n))
+ (tfo-apply tfo (nuc-C2* n))
+ (tfo-apply tfo (nuc-H2** n))
+ (tfo-apply tfo (nuc-O2* n))
+ (tfo-apply tfo (nuc-H2* n))
+ (tfo-apply tfo (nuc-C3* n))
+ (tfo-apply tfo (nuc-H3* n))
+ (tfo-apply tfo (nuc-O3* n))
+ (tfo-apply tfo (nuc-N1 n))
+ (tfo-apply tfo (nuc-N3 n))
+ (tfo-apply tfo (nuc-C2 n))
+ (tfo-apply tfo (nuc-C4 n))
+ (tfo-apply tfo (nuc-C5 n))
+ (tfo-apply tfo (nuc-C6 n))
+ (tfo-apply tfo (rC-N4 n))
+ (tfo-apply tfo (rC-O2 n))
+ (tfo-apply tfo (rC-H41 n))
+ (tfo-apply tfo (rC-H42 n))
+ (tfo-apply tfo (rC-H5 n))
+ (tfo-apply tfo (rC-H6 n))))
+ ((rG? n)
+ (make-rG
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (tfo-apply tfo (nuc-P n))
+ (tfo-apply tfo (nuc-O1P n))
+ (tfo-apply tfo (nuc-O2P n))
+ (tfo-apply tfo (nuc-O5* n))
+ (tfo-apply tfo (nuc-C5* n))
+ (tfo-apply tfo (nuc-H5* n))
+ (tfo-apply tfo (nuc-H5** n))
+ (tfo-apply tfo (nuc-C4* n))
+ (tfo-apply tfo (nuc-H4* n))
+ (tfo-apply tfo (nuc-O4* n))
+ (tfo-apply tfo (nuc-C1* n))
+ (tfo-apply tfo (nuc-H1* n))
+ (tfo-apply tfo (nuc-C2* n))
+ (tfo-apply tfo (nuc-H2** n))
+ (tfo-apply tfo (nuc-O2* n))
+ (tfo-apply tfo (nuc-H2* n))
+ (tfo-apply tfo (nuc-C3* n))
+ (tfo-apply tfo (nuc-H3* n))
+ (tfo-apply tfo (nuc-O3* n))
+ (tfo-apply tfo (nuc-N1 n))
+ (tfo-apply tfo (nuc-N3 n))
+ (tfo-apply tfo (nuc-C2 n))
+ (tfo-apply tfo (nuc-C4 n))
+ (tfo-apply tfo (nuc-C5 n))
+ (tfo-apply tfo (nuc-C6 n))
+ (tfo-apply tfo (rG-N2 n))
+ (tfo-apply tfo (rG-N7 n))
+ (tfo-apply tfo (rG-N9 n))
+ (tfo-apply tfo (rG-C8 n))
+ (tfo-apply tfo (rG-O6 n))
+ (tfo-apply tfo (rG-H1 n))
+ (tfo-apply tfo (rG-H21 n))
+ (tfo-apply tfo (rG-H22 n))
+ (tfo-apply tfo (rG-H8 n))))
+ (else
+ (make-rU
+ (nuc-dgf-base-tfo n)
+ (nuc-P-O3*-275-tfo n)
+ (nuc-P-O3*-180-tfo n)
+ (nuc-P-O3*-60-tfo n)
+ (tfo-apply tfo (nuc-P n))
+ (tfo-apply tfo (nuc-O1P n))
+ (tfo-apply tfo (nuc-O2P n))
+ (tfo-apply tfo (nuc-O5* n))
+ (tfo-apply tfo (nuc-C5* n))
+ (tfo-apply tfo (nuc-H5* n))
+ (tfo-apply tfo (nuc-H5** n))
+ (tfo-apply tfo (nuc-C4* n))
+ (tfo-apply tfo (nuc-H4* n))
+ (tfo-apply tfo (nuc-O4* n))
+ (tfo-apply tfo (nuc-C1* n))
+ (tfo-apply tfo (nuc-H1* n))
+ (tfo-apply tfo (nuc-C2* n))
+ (tfo-apply tfo (nuc-H2** n))
+ (tfo-apply tfo (nuc-O2* n))
+ (tfo-apply tfo (nuc-H2* n))
+ (tfo-apply tfo (nuc-C3* n))
+ (tfo-apply tfo (nuc-H3* n))
+ (tfo-apply tfo (nuc-O3* n))
+ (tfo-apply tfo (nuc-N1 n))
+ (tfo-apply tfo (nuc-N3 n))
+ (tfo-apply tfo (nuc-C2 n))
+ (tfo-apply tfo (nuc-C4 n))
+ (tfo-apply tfo (nuc-C5 n))
+ (tfo-apply tfo (nuc-C6 n))
+ (tfo-apply tfo (rU-O2 n))
+ (tfo-apply tfo (rU-O4 n))
+ (tfo-apply tfo (rU-H3 n))
+ (tfo-apply tfo (rU-H5 n))
+ (tfo-apply tfo (rU-H6 n))))))
+
+; -- SEARCH -------------------------------------------------------------------
+
+; Sequential backtracking algorithm
+
+(define (search partial-inst domains constraint?)
+ (if (null? domains)
+ (list partial-inst)
+ (let ((remaining-domains (cdr domains)))
+
+ (define (try-assignments lst)
+ (if (null? lst)
+ '()
+ (let ((var (car lst)))
+ (if (constraint? var partial-inst)
+ (let* ((subsols1
+ (search
+ (cons var partial-inst)
+ remaining-domains
+ constraint?))
+ (subsols2
+ (try-assignments (cdr lst))))
+ (append subsols1 subsols2))
+ (try-assignments (cdr lst))))))
+
+ (try-assignments ((car domains) partial-inst)))))
+
+; -- DOMAINS ------------------------------------------------------------------
+
+; Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG
+;
+; Secondary structure: strand A CUGCCACGUCUG
+; ||||||||||||
+; GACGGUGCAGAC strand B
+;
+; Tertiary structure:
+;
+; 5' end of strand A C1----G12 3' end of strand B
+; U2-------A11
+; G3-------C10
+; C4-----G9
+; C5---G8
+; A6
+; G6-C7
+; C5----G8
+; A4-------U9
+; G3--------C10
+; A2-------U11
+; 5' end of strand B C1----G12 3' end of strand A
+;
+; "helix", "stacked" and "connected" describe the spatial relationship
+; between two consecutive nucleotides. E.g. the nucleotides C1 and U2
+; from the strand A.
+;
+; "wc" (stands for Watson-Crick and is a type of base-pairing),
+; and "wc-dumas" describe the spatial relationship between
+; nucleotides from two chains that are growing in opposite directions.
+; E.g. the nucleotides C1 from strand A and G12 from strand B.
+
+; Dynamic Domains
+
+; Given,
+; "ref" a nucleotide which is already positioned,
+; "nuc" the nucleotide to be placed,
+; and "tfo" a transformation matrix which expresses the desired
+; relationship between "ref" and "nuc",
+; the function "dgf-base" computes the transformation matrix that
+; places the nucleotide "nuc" in the given relationship to "ref".
+
+(define (dgf-base tfo ref nuc)
+ (let* ((ref-nuc (var-nuc ref))
+ (align
+ (tfo-inv-ortho
+ (cond ((rA? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos rA-N9 ref)
+ (atom-pos nuc-C4 ref)))
+ ((rC? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos nuc-N1 ref)
+ (atom-pos nuc-C2 ref)))
+ ((rG? ref-nuc)
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos rG-N9 ref)
+ (atom-pos nuc-C4 ref)))
+ (else
+ (tfo-align (atom-pos nuc-C1* ref)
+ (atom-pos nuc-N1 ref)
+ (atom-pos nuc-C2 ref)))))))
+ (tfo-combine (nuc-dgf-base-tfo nuc)
+ (tfo-combine tfo align))))
+
+; Placement of first nucleotide.
+
+(define (reference nuc i)
+ (lambda (partial-inst)
+ (list (make-var i tfo-id nuc))))
+
+; The transformation matrix for wc is from:
+;
+; Chandrasekaran R. et al (1989) A Re-Examination of the Crystal
+; Structure of A-DNA Using Fiber Diffraction Data. J. Biomol.
+; Struct. & Dynamics 6(6):1189-1202.
+
+(define wc-tfo
+ (FLOATvector-const
+ -1.0000 0.0028 -0.0019
+ 0.0028 0.3468 -0.9379
+ -0.0019 -0.9379 -0.3468
+ -0.0080 6.0730 8.7208))
+
+(define (wc nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base wc-tfo ref nuc)))
+ (list (make-var i tfo nuc)))))
+
+(define wc-Dumas-tfo
+ (FLOATvector-const
+ -0.9737 -0.1834 0.1352
+ -0.1779 0.2417 -0.9539
+ 0.1422 -0.9529 -0.2679
+ 0.4837 6.2649 8.0285))
+
+(define (wc-Dumas nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base wc-Dumas-tfo ref nuc)))
+ (list (make-var i tfo nuc)))))
+
+(define helix5*-tfo
+ (FLOATvector-const
+ 0.9886 -0.0961 0.1156
+ 0.1424 0.8452 -0.5152
+ -0.0482 0.5258 0.8492
+ -3.8737 0.5480 3.8024))
+
+(define (helix5* nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base helix5*-tfo ref nuc)))
+ (list (make-var i tfo nuc)))))
+
+(define helix3*-tfo
+ (FLOATvector-const
+ 0.9886 0.1424 -0.0482
+ -0.0961 0.8452 0.5258
+ 0.1156 -0.5152 0.8492
+ 3.4426 2.0474 -3.7042))
+
+(define (helix3* nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base helix3*-tfo ref nuc)))
+ (list (make-var i tfo nuc)))))
+
+(define G37-A38-tfo
+ (FLOATvector-const
+ 0.9991 0.0164 -0.0387
+ -0.0375 0.7616 -0.6470
+ 0.0189 0.6478 0.7615
+ -3.3018 0.9975 2.5585))
+
+(define (G37-A38 nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base G37-A38-tfo ref nuc)))
+ (make-var i tfo nuc))))
+
+(define (stacked5* nuc i j)
+ (lambda (partial-inst)
+ (cons ((G37-A38 nuc i j) partial-inst)
+ ((helix5* nuc i j) partial-inst))))
+
+(define A38-G37-tfo
+ (FLOATvector-const
+ 0.9991 -0.0375 0.0189
+ 0.0164 0.7616 0.6478
+ -0.0387 -0.6470 0.7615
+ 3.3819 0.7718 -2.5321))
+
+(define (A38-G37 nuc i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (tfo (dgf-base A38-G37-tfo ref nuc)))
+ (make-var i tfo nuc))))
+
+(define (stacked3* nuc i j)
+ (lambda (partial-inst)
+ (cons ((A38-G37 nuc i j) partial-inst)
+ ((helix3* nuc i j) partial-inst))))
+
+(define (P-O3* nucs i j)
+ (lambda (partial-inst)
+ (let* ((ref (get-var j partial-inst))
+ (align
+ (tfo-inv-ortho
+ (tfo-align (atom-pos nuc-O3* ref)
+ (atom-pos nuc-C3* ref)
+ (atom-pos nuc-C4* ref)))))
+ (let loop ((lst nucs) (domains '()))
+ (if (null? lst)
+ domains
+ (let ((nuc (car lst)))
+ (let ((tfo-60 (tfo-combine (nuc-P-O3*-60-tfo nuc) align))
+ (tfo-180 (tfo-combine (nuc-P-O3*-180-tfo nuc) align))
+ (tfo-275 (tfo-combine (nuc-P-O3*-275-tfo nuc) align)))
+ (loop (cdr lst)
+ (cons (make-var i tfo-60 nuc)
+ (cons (make-var i tfo-180 nuc)
+ (cons (make-var i tfo-275 nuc) domains)))))))))))
+
+; -- PROBLEM STATEMENT --------------------------------------------------------
+
+; Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c
+
+(define anticodon-domains
+ (list
+ (reference rC 27 )
+ (helix5* rC 28 27)
+ (helix5* rA 29 28)
+ (helix5* rG 30 29)
+ (helix5* rA 31 30)
+ (wc rU 39 31)
+ (helix5* rC 40 39)
+ (helix5* rU 41 40)
+ (helix5* rG 42 41)
+ (helix5* rG 43 42)
+ (stacked3* rA 38 39)
+ (stacked3* rG 37 38)
+ (stacked3* rA 36 37)
+ (stacked3* rA 35 36)
+ (stacked3* rG 34 35);<-. Distance
+ (P-O3* rCs 32 31); | Constraint
+ (P-O3* rUs 33 32);<-' 3.0 Angstroms
+ ))
+
+; Anticodon constraint
+
+(define (anticodon-constraint? v partial-inst)
+ (if (= (var-id v) 33)
+ (let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34
+ (o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33
+ (FLOAT<= (pt-dist p o3*) 3.0)) ; check distance
+ #t))
+
+(define (anticodon)
+ (search '() anticodon-domains anticodon-constraint?))
+
+; Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b
+
+(define pseudoknot-domains
+ (list
+ (reference rA 23 )
+ (wc-Dumas rU 8 23)
+ (helix3* rG 22 23)
+ (wc-Dumas rC 9 22)
+ (helix3* rG 21 22)
+ (wc-Dumas rC 10 21)
+ (helix3* rC 20 21)
+ (wc-Dumas rG 11 20)
+ (helix3* rU* 19 20);<-.
+ (wc-Dumas rA 12 19); | Distance
+; ; | Constraint
+; Helix 1 ; | 4.0 Angstroms
+ (helix3* rC 3 19); |
+ (wc-Dumas rG 13 3); |
+ (helix3* rC 2 3); |
+ (wc-Dumas rG 14 2); |
+ (helix3* rC 1 2); |
+ (wc-Dumas rG* 15 1); |
+; ; |
+; L2 LOOP ; |
+ (P-O3* rUs 16 15); |
+ (P-O3* rCs 17 16); |
+ (P-O3* rAs 18 17);<-'
+;
+; L1 LOOP
+ (helix3* rU 7 8);<-.
+ (P-O3* rCs 4 3); | Constraint
+ (stacked5* rU 5 4); | 4.5 Angstroms
+ (stacked5* rC 6 5);<-'
+ ))
+
+; Pseudoknot constraint
+
+(define (pseudoknot-constraint? v partial-inst)
+ (case (var-id v)
+ ((18)
+ (let ((p (atom-pos nuc-P (get-var 19 partial-inst)))
+ (o3* (atom-pos nuc-O3* v)))
+ (FLOAT<= (pt-dist p o3*) 4.0)))
+ ((6)
+ (let ((p (atom-pos nuc-P (get-var 7 partial-inst)))
+ (o3* (atom-pos nuc-O3* v)))
+ (FLOAT<= (pt-dist p o3*) 4.5)))
+ (else
+ #t)))
+
+(define (pseudoknot)
+ (search '() pseudoknot-domains pseudoknot-constraint?))
+
+; -- TESTING -----------------------------------------------------------------
+
+(define (list-of-atoms n)
+ (append (list-of-common-atoms n)
+ (list-of-specific-atoms n)))
+
+(define (list-of-common-atoms n)
+ (list
+ (nuc-P n)
+ (nuc-O1P n)
+ (nuc-O2P n)
+ (nuc-O5* n)
+ (nuc-C5* n)
+ (nuc-H5* n)
+ (nuc-H5** n)
+ (nuc-C4* n)
+ (nuc-H4* n)
+ (nuc-O4* n)
+ (nuc-C1* n)
+ (nuc-H1* n)
+ (nuc-C2* n)
+ (nuc-H2** n)
+ (nuc-O2* n)
+ (nuc-H2* n)
+ (nuc-C3* n)
+ (nuc-H3* n)
+ (nuc-O3* n)
+ (nuc-N1 n)
+ (nuc-N3 n)
+ (nuc-C2 n)
+ (nuc-C4 n)
+ (nuc-C5 n)
+ (nuc-C6 n)))
+
+(define (list-of-specific-atoms n)
+ (cond ((rA? n)
+ (list
+ (rA-N6 n)
+ (rA-N7 n)
+ (rA-N9 n)
+ (rA-C8 n)
+ (rA-H2 n)
+ (rA-H61 n)
+ (rA-H62 n)
+ (rA-H8 n)))
+ ((rC? n)
+ (list
+ (rC-N4 n)
+ (rC-O2 n)
+ (rC-H41 n)
+ (rC-H42 n)
+ (rC-H5 n)
+ (rC-H6 n)))
+ ((rG? n)
+ (list
+ (rG-N2 n)
+ (rG-N7 n)
+ (rG-N9 n)
+ (rG-C8 n)
+ (rG-O6 n)
+ (rG-H1 n)
+ (rG-H21 n)
+ (rG-H22 n)
+ (rG-H8 n)))
+ (else
+ (list
+ (rU-O2 n)
+ (rU-O4 n)
+ (rU-H3 n)
+ (rU-H5 n)
+ (rU-H6 n)))))
+
+(define (var-most-distant-atom v)
+
+ (define (distance pos)
+ (let ((abs-pos (tfo-apply (var-tfo v) pos)))
+ (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos)))
+ (FLOATsqrt (FLOAT+ (FLOAT* x x) (FLOAT* y y) (FLOAT* z z))))))
+
+ (maximum (map distance (list-of-atoms (var-nuc v)))))
+
+(define (sol-most-distant-atom s)
+ (maximum (map var-most-distant-atom s)))
+
+(define (most-distant-atom sols)
+ (maximum (map sol-most-distant-atom sols)))
+
+(define (maximum lst)
+ (let loop ((m (car lst)) (l (cdr lst)))
+ (if (null? l)
+ m
+ (let ((x (car l)))
+ (loop (if (FLOAT> x m) x m) (cdr l))))))
+
+(define (run)
+ (most-distant-atom (pseudoknot)))
+
+(define (main . args)
+ (run-benchmark
+ "nucleic"
+ nucleic-iters
+ (lambda () (run))
+ (lambda (result)
+ (and (number? result)
+ (let ((x (FLOAT/ result 33.797594890762724)))
+ (and (FLOAT> x 0.999999) (FLOAT< x 1.000001)))))))
--- /dev/null
+; Complete source for Twobit and Sparc assembler in one file.
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; See 'twobit-benchmark', at end.
+
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Completely fundamental pathname manipulation.
+
+; This takes zero or more directory components and a file name and
+; constructs a filename relative to the current directory.
+
+(define (make-relative-filename . components)
+
+ (define (construct l)
+ (if (null? (cdr l))
+ l
+ (cons (car l)
+ (cons "/" (construct (cdr l))))))
+
+ (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components))))
+
+; This takes one or more directory components and constructs a
+; directory name with proper termination (a crock -- we can finess
+; this later).
+
+(define (pathname-append . components)
+
+ (define (construct l)
+ (cond ((null? (cdr l))
+ l)
+ ((string=? (car l) "")
+ (construct (cdr l)))
+ ((char=? #\/ (string-ref (car l) (- (string-length (car l)) 1)))
+ (cons (car l) (construct (cdr l))))
+ (else
+ (cons (car l)
+ (cons "/" (construct (cdr l)))))))
+
+ (let ((n (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components)))))
+ (if (not (char=? #\/ (string-ref n (- (string-length n) 1))))
+ (string-append n "/")
+ n)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Nbuild parameters for SPARC Larceny.
+
+(define (make-nbuild-parameter dir source? verbose? hostdir hostname)
+ (let ((parameters
+ `((compiler . ,(pathname-append dir "Compiler"))
+ (util . ,(pathname-append dir "Util"))
+ (build . ,(pathname-append dir "Rts" "Build"))
+ (source . ,(pathname-append dir "Lib"))
+ (common-source . ,(pathname-append dir "Lib" "Common"))
+ (repl-source . ,(pathname-append dir "Repl"))
+ (interp-source . ,(pathname-append dir "Eval"))
+ (machine-source . ,(pathname-append dir "Lib" "Sparc"))
+ (common-asm . ,(pathname-append dir "Asm" "Common"))
+ (sparc-asm . ,(pathname-append dir "Asm" "Sparc"))
+ (target-machine . SPARC)
+ (endianness . big)
+ (word-size . 32)
+ (always-source? . ,source?)
+ (verbose-load? . ,verbose?)
+ (compatibility . ,(pathname-append dir "Compat" hostdir))
+ (host-system . ,hostname)
+ )))
+ (lambda (key)
+ (let ((probe (assq key parameters)))
+ (if probe
+ (cdr probe)
+ #f)))))
+
+(define nbuild-parameter
+ (make-nbuild-parameter "" #f #f "Larceny" "Larceny"))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Useful list functions.
+;
+; Notes:
+; * Reduce, reduce-right, fold-right, fold-left are compatible with MIT Scheme.
+; * Make-list is compatible with MIT Scheme and Chez Scheme.
+; * These are not (yet) compatible with Shivers's proposed list functions.
+; * remq, remv, remove, remq!, remv!, remov!, every?, and some? are in the
+; basic library.
+
+; Destructively remove all associations whose key matches `key' from `alist'.
+
+(define (aremq! key alist)
+ (cond ((null? alist) alist)
+ ((eq? key (caar alist))
+ (aremq! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremq! key (cdr alist)))
+ alist)))
+
+(define (aremv! key alist)
+ (cond ((null? alist) alist)
+ ((eqv? key (caar alist))
+ (aremv! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremv! key (cdr alist)))
+ alist)))
+
+(define (aremove! key alist)
+ (cond ((null? alist) alist)
+ ((equal? key (caar alist))
+ (aremove! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremove! key (cdr alist)))
+ alist)))
+
+; Return a list of elements of `list' selected by the predicate.
+
+(define (filter select? list)
+ (cond ((null? list) list)
+ ((select? (car list))
+ (cons (car list) (filter select? (cdr list))))
+ (else
+ (filter select? (cdr list)))))
+
+; Return the first element of `list' selected by the predicate.
+
+(define (find selected? list)
+ (cond ((null? list) #f)
+ ((selected? (car list)) (car list))
+ (else (find selected? (cdr list)))))
+
+; Return a list with all duplicates (according to predicate) removed.
+
+(define (remove-duplicates list same?)
+
+ (define (member? x list)
+ (cond ((null? list) #f)
+ ((same? x (car list)) #t)
+ (else (member? x (cdr list)))))
+
+ (cond ((null? list) list)
+ ((member? (car list) (cdr list))
+ (remove-duplicates (cdr list) same?))
+ (else
+ (cons (car list) (remove-duplicates (cdr list) same?)))))
+
+; Return the least element of `list' according to some total order.
+
+(define (least less? list)
+ (reduce (lambda (a b) (if (less? a b) a b)) #f list))
+
+; Return the greatest element of `list' according to some total order.
+
+(define (greatest greater? list)
+ (reduce (lambda (a b) (if (greater? a b) a b)) #f list))
+
+; (mappend p l) = (apply append (map p l))
+
+(define (mappend proc l)
+ (apply append (map proc l)))
+
+; (make-list n) => (a1 ... an) for some ai
+; (make-list n x) => (a1 ... an) where ai = x
+
+(define (make-list nelem . rest)
+ (let ((val (if (null? rest) #f (car rest))))
+ (define (loop n l)
+ (if (zero? n)
+ l
+ (loop (- n 1) (cons val l))))
+ (loop nelem '())))
+
+; (reduce p x ()) => x
+; (reduce p x (a)) => a
+; (reduce p x (a b ...)) => (p (p a b) ...))
+
+(define (reduce proc initial l)
+
+ (define (loop val l)
+ (if (null? l)
+ val
+ (loop (proc val (car l)) (cdr l))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop (car l) (cdr l)))))
+
+; (reduce-right p x ()) => x
+; (reduce-right p x (a)) => a
+; (reduce-right p x (a b ...)) => (p a (p b ...))
+
+(define (reduce-right proc initial l)
+
+ (define (loop l)
+ (if (null? (cdr l))
+ (car l)
+ (proc (car l) (loop (cdr l)))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop l))))
+
+; (fold-left p x (a b ...)) => (p (p (p x a) b) ...)
+
+(define (fold-left proc initial l)
+ (if (null? l)
+ initial
+ (fold-left proc (proc initial (car l)) (cdr l))))
+
+; (fold-right p x (a b ...)) => (p a (p b (p ... x)))
+
+(define (fold-right proc initial l)
+ (if (null? l)
+ initial
+ (proc (car l) (fold-right proc initial (cdr l)))))
+
+; (iota n) => (0 1 2 ... n-1)
+
+(define (iota n)
+ (let loop ((n (- n 1)) (r '()))
+ (let ((r (cons n r)))
+ (if (= n 0)
+ r
+ (loop (- n 1) r)))))
+
+; (list-head (a1 ... an) m) => (a1 ... am) for m <= n
+
+(define (list-head l n)
+ (if (zero? n)
+ '()
+ (cons (car l) (list-head (cdr l) (- n 1)))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Larceny -- compatibility library for Twobit running under Larceny.
+
+(define ($$trace x) #t)
+
+(define host-system 'larceny)
+
+; Temporary?
+
+(define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+
+; The compatibility library loads Auxlib if compat:initialize is called
+; without arguments. Compat:load will load fasl files when appropriate.
+
+(define (compat:initialize . rest)
+ (if (null? rest)
+ (let ((dir (nbuild-parameter 'compatibility)))
+ (compat:load (string-append dir "compat2.sch"))
+ (compat:load (string-append dir "../../Auxlib/list.sch"))
+ (compat:load (string-append dir "../../Auxlib/pp.sch")))))
+
+(define (with-optimization level thunk)
+ (thunk))
+
+; Calls thunk1, and if thunk1 causes an error to be signalled, calls thunk2.
+
+(define (call-with-error-control thunk1 thunk2)
+ (let ((eh (error-handler)))
+ (error-handler (lambda args
+ (error-handler eh)
+ (thunk2)
+ (apply eh args)))
+ (thunk1)
+ (error-handler eh)))
+
+(define (larc-new-extension fn ext)
+ (let* ((l (string-length fn))
+ (x (let loop ((i (- l 1)))
+ (cond ((< i 0) #f)
+ ((char=? (string-ref fn i) #\.) (+ i 1))
+ (else (loop (- i 1)))))))
+ (if (not x)
+ (string-append fn "." ext)
+ (string-append (substring fn 0 x) ext))))
+
+(define (compat:load filename)
+ (define (loadit fn)
+ (if (nbuild-parameter 'verbose-load?)
+ (format #t "~a~%" fn))
+ (load fn))
+ (if (nbuild-parameter 'always-source?)
+ (loadit filename)
+ (let ((fn (larc-new-extension filename "fasl")))
+ (if (and (file-exists? fn)
+ (compat:file-newer? fn filename))
+ (loadit fn)
+ (loadit filename)))))
+
+(define (compat:file-newer? a b)
+ (let* ((ta (file-modification-time a))
+ (tb (file-modification-time b))
+ (limit (vector-length ta)))
+ (let loop ((i 0))
+ (cond ((= i limit)
+ #f)
+ ((= (vector-ref ta i) (vector-ref tb i))
+ (loop (+ i 1)))
+ (else
+ (> (vector-ref ta i) (vector-ref tb i)))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Larceny -- second part of compatibility code
+; This file ought to be compiled, but doesn't have to be.
+;
+; 12 April 1999
+
+(define host-system 'larceny) ; Don't remove this!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; A well-defined sorting procedure.
+
+(define compat:sort (lambda (list less?) (sort list less?)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Well-defined character codes.
+; Returns the UCS-2 code for a character.
+
+(define compat:char->integer char->integer)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Input and output
+
+(define (write-lop item port)
+ (lowlevel-write item port)
+ (newline port)
+ (newline port))
+
+(define write-fasl-datum lowlevel-write)
+
+; The power of self-hosting ;-)
+
+(define (misc->bytevector x)
+ (let ((bv (bytevector-like-copy x)))
+ (typetag-set! bv $tag.bytevector-typetag)
+ bv))
+
+(define string->bytevector misc->bytevector)
+
+(define bignum->bytevector misc->bytevector)
+
+(define (flonum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+(define (compnum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+; Clears garbage word of compnum/flonum; makes regression testing much
+; easier.
+
+(define (clear-first-word bv)
+ (bytevector-like-set! bv 0 0)
+ (bytevector-like-set! bv 1 0)
+ (bytevector-like-set! bv 2 0)
+ (bytevector-like-set! bv 3 0)
+ bv)
+
+(define (list->bytevector l)
+ (let ((b (make-bytevector (length l))))
+ (do ((i 0 (+ i 1))
+ (l l (cdr l)))
+ ((null? l) b)
+ (bytevector-set! b i (car l)))))
+
+(define bytevector-word-ref
+ (let ((two^8 (expt 2 8))
+ (two^16 (expt 2 16))
+ (two^24 (expt 2 24)))
+ (lambda (bv i)
+ (+ (* (bytevector-ref bv i) two^24)
+ (* (bytevector-ref bv (+ i 1)) two^16)
+ (* (bytevector-ref bv (+ i 2)) two^8)
+ (bytevector-ref bv (+ i 3))))))
+
+(define (twobit-format fmt . rest)
+ (let ((out (open-output-string)))
+ (apply format out fmt rest)
+ (get-output-string out)))
+
+; This needs to be a random number in both a weaker and stronger sense
+; than `random': it doesn't need to be a truly random number, so a sequence
+; of calls can return a non-random sequence, but if two processes generate
+; two sequences, then those sequences should not be the same.
+;
+; Gross, huh?
+
+(define (an-arbitrary-number)
+ (system "echo \\\"`date`\\\" > a-random-number")
+ (let ((x (string-hash (call-with-input-file "a-random-number" read))))
+ (delete-file "a-random-number")
+ x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Miscellaneous
+
+(define cerror error)
+
+; eof
+; Copyright 1991 Wiliam Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Sets represented as lists.
+;
+; 5 April 1999.
+
+(define (empty-set) '())
+
+(define (empty-set? x) (null? x))
+
+(define (make-set x)
+ (define (loop x y)
+ (cond ((null? x) y)
+ ((member (car x) y) (loop (cdr x) y))
+ (else (loop (cdr x) (cons (car x) y)))))
+ (loop x '()))
+
+(define (set-equal? x y)
+ (and (subset? x y) (subset? y x)))
+
+(define (subset? x y)
+ (every? (lambda (x) (member x y))
+ x))
+
+; To get around MacScheme's limit on the number of arguments.
+
+(define apply-union)
+
+(define union
+ (letrec ((union2
+ (lambda (x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))))
+
+ (set! apply-union
+ (lambda (sets)
+ (do ((sets sets (cdr sets))
+ (result '() (union2 (car sets) result)))
+ ((null? sets)
+ result))))
+
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (union2 (car args) (cadr args)))
+ (else (union2 (union2 (car args)
+ (cadr args))
+ (apply union (cddr args))))))))
+
+(define intersection
+ (letrec ((intersection2
+ (lambda (x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (cons (car x) (intersection2 (cdr x) y)))
+ (else (intersection2 (cdr x) y))))))
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (intersection2 (car args) (cadr args)))
+ (else (intersection2 (intersection2 (car args)
+ (cadr args))
+ (apply intersection (cddr args))))))))
+
+(define (difference x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (difference (cdr x) y))
+ (else (cons (car x) (difference (cdr x) y)))))
+; Reasonably portable hashing on EQ?, EQV?, EQUAL?.
+; Requires bignums, SYMBOL-HASH.
+;
+; Given any Scheme object, returns a non-negative exact integer
+; less than 2^24.
+
+(define object-hash (lambda (x) 0)) ; hash on EQ?, EQV?
+(define equal-hash (lambda (x) 0)) ; hash on EQUAL?
+
+(let ((n 16777216)
+ (n-1 16777215)
+ (adj:fixnum 9000000)
+ (adj:negative 8000000)
+ (adj:large 7900000)
+ (adj:ratnum 7800000)
+ (adj:complex 7700000)
+ (adj:flonum 7000000)
+ (adj:compnum 6900000)
+ (adj:char 6111000)
+ (adj:string 5022200)
+ (adj:vector 4003330)
+ (adj:misc 3000444)
+ (adj:pair 2555000)
+ (adj:proc 2321001)
+ (adj:iport 2321002)
+ (adj:oport 2321003)
+ (adj:weird 2321004)
+ (budget0 32))
+
+ (define (combine hash adjustment)
+ (modulo (+ hash hash hash adjustment) 16777216))
+
+ (define (hash-on-equal x budget)
+ (if (> budget 0)
+ (cond ((string? x)
+ (string-hash x))
+ ((pair? x)
+ (let ((budget (quotient budget 2)))
+ (combine (hash-on-equal (car x) budget)
+ (hash-on-equal (cdr x) budget))))
+ ((vector? x)
+ (let ((n (vector-length x))
+ (budget (quotient budget 4)))
+ (if (> n 0)
+ (combine
+ (combine (hash-on-equal (vector-ref x 0) budget)
+ (hash-on-equal (vector-ref x (- n 1)) budget))
+ (hash-on-equal (vector-ref x (quotient n 2))
+ (+ budget budget)))
+ adj:vector)))
+ (else
+ (object-hash x)))
+ adj:weird))
+
+ (set! object-hash
+ (lambda (x)
+ (cond ((symbol? x)
+ (symbol-hash x))
+ ((number? x)
+ (if (exact? x)
+ (cond ((integer? x)
+ (cond ((negative? x)
+ (combine (object-hash (- x)) adj:negative))
+ ((< x n)
+ (combine x adj:fixnum))
+ (else
+ (combine (modulo x n) adj:large))))
+ ((rational? x)
+ (combine (combine (object-hash (numerator x))
+ adj:ratnum)
+ (object-hash (denominator x))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:complex)
+ (object-hash (imag-part x))))
+ (else
+ adj:weird))
+ (cond (#t
+ ; We can't really do anything with inexact numbers
+ ; unless infinities and NaNs behave reasonably.
+ adj:flonum)
+ ((rational? x)
+ (combine
+ (combine (object-hash
+ (inexact->exact (numerator x)))
+ adj:flonum)
+ (object-hash (inexact->exact (denominator x)))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:compnum)
+ (object-hash (imag-part x))))
+ (else adj:weird))))
+ ((char? x)
+ (combine (char->integer x) adj:char))
+ ((string? x)
+ (combine (string-length x) adj:string))
+ ((vector? x)
+ (combine (vector-length x) adj:vector))
+ ((eq? x #t)
+ (combine 1 adj:misc))
+ ((eq? x #f)
+ (combine 2 adj:misc))
+ ((null? x)
+ (combine 3 adj:misc))
+ ((pair? x)
+ adj:pair)
+ ((procedure? x)
+ adj:proc)
+ ((input-port? x)
+ adj:iport)
+ ((output-port? x)
+ adj:oport)
+ (else
+ adj:weird))))
+
+ (set! equal-hash
+ (lambda (x)
+ (hash-on-equal x budget0)))); Hash tables.
+; Requires CALL-WITHOUT-INTERRUPTS.
+; This code should be thread-safe provided VECTOR-REF is atomic.
+;
+; (make-hashtable <hash-function> <bucket-searcher> <size>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket
+; with <size> buckets at first, expanding the number of buckets as needed.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtable <hash-function> <bucket-searcher>)
+;
+; Equivalent to (make-hashtable <hash-function> <bucket-searcher> n)
+; for some value of n chosen by the implementation.
+;
+; (make-hashtable <hash-function>)
+;
+; Equivalent to (make-hashtable <hash-function> assv).
+;
+; (make-hashtable)
+;
+; Equivalent to (make-hashtable object-hash assv).
+;
+; (hashtable-contains? <hashtable> <key>)
+;
+; Returns true iff the <hashtable> contains an entry for <key>.
+;
+; (hashtable-fetch <hashtable> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtable> if the
+; <hashtable> contains <key>; otherwise returns <flag>.
+;
+; (hashtable-get <hashtable> <key>)
+;
+; Equivalent to (hashtable-fetch <hashtable> <key> #f)
+;
+; (hashtable-put! <hashtable> <key> <value>)
+;
+; Changes the <hashtable> to associate <key> with <value>, replacing
+; any existing association for <key>.
+;
+; (hashtable-remove! <hashtable> <key>)
+;
+; Removes any association for <key> within the <hashtable>.
+;
+; (hashtable-clear! <hashtable>)
+;
+; Removes all associations from the <hashtable>.
+;
+; (hashtable-size <hashtable>)
+;
+; Returns the number of keys contained within the <hashtable>.
+;
+; (hashtable-for-each <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtable-map <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+;
+; (hashtable-copy <hashtable>)
+;
+; Returns a copy of the <hashtable>.
+
+; These global variables are assigned new values later.
+
+(define make-hashtable (lambda args '*))
+(define hashtable-contains? (lambda (ht key) #f))
+(define hashtable-fetch (lambda (ht key flag) flag))
+(define hashtable-get (lambda (ht key) (hashtable-fetch ht key #f)))
+(define hashtable-put! (lambda (ht key val) '*))
+(define hashtable-remove! (lambda (ht key) '*))
+(define hashtable-clear! (lambda (ht) '*))
+(define hashtable-size (lambda (ht) 0))
+(define hashtable-for-each (lambda (ht proc) '*))
+(define hashtable-map (lambda (ht proc) '()))
+(define hashtable-copy (lambda (ht) ht))
+
+; Implementation.
+; A hashtable is represented as a vector of the form
+;
+; #(("HASHTABLE") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtable,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is a vector of buckets.
+;
+; The <hasher> and <searcher> fields are constant, but
+; the <count> and <buckets> fields are mutable.
+;
+; For thread-safe operation, the mutators must modify both
+; as an atomic operation. Other operations do not require
+; critical sections provided VECTOR-REF is an atomic operation
+; and the operation does not modify the hashtable, does not
+; reference the <count> field, and fetches the <buckets>
+; field exactly once.
+
+(let ((doc (list "HASHTABLE"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (count! (lambda (ht n) (vector-set! ht 1 n)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+ (buckets! (lambda (ht v) (vector-set! ht 4 v)))
+ (defaultn 10))
+ (let ((hashtable? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtable-error (lambda (x)
+ (display "ERROR: Bad hash table: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht hashfun searcher size)
+ (vector doc 0 hashfun searcher (make-vector size '())))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ (define (resize ht0)
+ (call-without-interrupts
+ (lambda ()
+ (let ((ht (make-ht (hasher ht0)
+ (searcher ht0)
+ (+ 1 (* 2 (count ht0))))))
+ (ht-for-each (lambda (key val)
+ (put! ht key val))
+ ht0)
+ (buckets! ht0 (buckets ht))))))
+
+ ; Returns the contents of the hashtable as a vector of pairs.
+
+ (define (contents ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (z (make-vector (count ht) '())))
+ (define (loop i bucket j)
+ (if (null? bucket)
+ (if (= i n)
+ (if (= j (vector-length z))
+ z
+ (begin (display "BUG in hashtable")
+ (newline)
+ '#()))
+ (loop (+ i 1)
+ (vector-ref v i)
+ j))
+ (let ((entry (car bucket)))
+ (vector-set! z j (cons (car entry) (cdr entry)))
+ (loop i
+ (cdr bucket)
+ (+ j 1)))))
+ (loop 0 '() 0)))
+
+ (define (contains? ht key)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h)))
+ (if ((searcher ht) key b)
+ #t
+ #f))
+ (hashtable-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtable-error ht)))
+
+ (define (put! ht key val)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ ; Using SET-CDR! on the probe would make it necessary
+ ; to synchronize the CONTENTS routine.
+ (vector-set! v h (substitute1 (cons key val) probe b))
+ (begin (count! ht (+ (count ht) 1))
+ (vector-set! v h (cons (cons key val) b))
+ (if (> (count ht) n)
+ (resize ht)))))
+ #f))
+ (hashtable-error ht)))
+
+ (define (remove! ht key)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (begin (count! ht (- (count ht) 1))
+ (vector-set! v h (remq1 probe b))
+ (if (< (* 2 (+ defaultn (count ht))) n)
+ (resize ht))))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (clear! ht)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (begin (count! ht 0)
+ (buckets! ht (make-vector defaultn '()))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (size ht)
+ (if (hashtable? ht)
+ (count ht)
+ (hashtable-error ht)))
+
+ ; This code must be written so that the procedure can modify the
+ ; hashtable without breaking any invariants.
+
+ (define (ht-for-each f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (let ((x (vector-ref v j)))
+ (f (car x) (cdr x)))))
+ (hashtable-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1))
+ (results '() (let ((x (vector-ref v j)))
+ (cons (f (car x) (cdr x))
+ results))))
+ ((= j n)
+ (reverse results))))
+ (hashtable-error ht)))
+
+ (define (ht-copy ht)
+ (if (hashtable? ht)
+ (let* ((newtable (make-hashtable (hasher ht) (searcher ht) 0))
+ (v (buckets ht))
+ (n (vector-length v))
+ (newvector (make-vector n '())))
+ (count! newtable (count ht))
+ (buckets! newtable newvector)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! newvector i (append (vector-ref v i) '())))
+ newtable)
+ (hashtable-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtable
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args)))
+ (size (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+ defaultn
+ (caddr args))))
+ (make-ht hashfun searcher size))))
+
+ (set! hashtable-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtable-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtable-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtable-put! (lambda (ht key val) (put! ht key val)))
+ (set! hashtable-remove! (lambda (ht key) (remove! ht key)))
+ (set! hashtable-clear! (lambda (ht) (clear! ht)))
+ (set! hashtable-size (lambda (ht) (size ht)))
+ (set! hashtable-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtable-map (lambda (ht proc) (ht-map ht proc)))
+ (set! hashtable-copy (lambda (ht) (ht-copy ht)))
+ #f))
+; Hash trees: a functional data structure analogous to hash tables.
+;
+; (make-hashtree <hash-function> <bucket-searcher>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtree <hash-function>)
+;
+; Equivalent to (make-hashtree <hash-function> assv).
+;
+; (make-hashtree)
+;
+; Equivalent to (make-hashtree object-hash assv).
+;
+; (hashtree-contains? <hashtree> <key>)
+;
+; Returns true iff the <hashtree> contains an entry for <key>.
+;
+; (hashtree-fetch <hashtree> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtree> if the
+; <hashtree> contains <key>; otherwise returns <flag>.
+;
+; (hashtree-get <hashtree> <key>)
+;
+; Equivalent to (hashtree-fetch <hashtree> <key> #f)
+;
+; (hashtree-put <hashtree> <key> <value>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is associated with <value>.
+;
+; (hashtree-remove <hashtree> <key>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is not associated with any value.
+;
+; (hashtree-size <hashtree>)
+;
+; Returns the number of keys contained within the <hashtree>.
+;
+; (hashtree-for-each <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtree-map <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+
+; These global variables are assigned new values later.
+
+(define make-hashtree (lambda args '*))
+(define hashtree-contains? (lambda (ht key) #f))
+(define hashtree-fetch (lambda (ht key flag) flag))
+(define hashtree-get (lambda (ht key) (hashtree-fetch ht key #f)))
+(define hashtree-put (lambda (ht key val) '*))
+(define hashtree-remove (lambda (ht key) '*))
+(define hashtree-size (lambda (ht) 0))
+(define hashtree-for-each (lambda (ht proc) '*))
+(define hashtree-map (lambda (ht proc) '()))
+
+; Implementation.
+; A hashtree is represented as a vector of the form
+;
+; #(("hashtree") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtree,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is generated by the following grammar:
+;
+; <buckets> ::= ()
+; | (<fixnum> <associations> <buckets> <buckets>)
+; <alist> ::= (<associations>)
+; <associations> ::=
+; | <association> <associations>
+; <association> ::= (<key> . <value>)
+;
+; If <buckets> is of the form (n alist buckets1 buckets2),
+; then n is the hash code of all keys in alist, all keys in buckets1
+; have a hash code less than n, and all keys in buckets2 have a hash
+; code greater than n.
+
+(let ((doc (list "hashtree"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+
+ (make-empty-buckets (lambda () '()))
+
+ (make-buckets
+ (lambda (h alist buckets1 buckets2)
+ (list h alist buckets1 buckets2)))
+
+ (buckets-empty? (lambda (buckets) (null? buckets)))
+
+ (buckets-n (lambda (buckets) (car buckets)))
+ (buckets-alist (lambda (buckets) (cadr buckets)))
+ (buckets-left (lambda (buckets) (caddr buckets)))
+ (buckets-right (lambda (buckets) (cadddr buckets))))
+
+ (let ((hashtree? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtree-error (lambda (x)
+ (display "ERROR: Bad hash tree: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht count hashfun searcher buckets)
+ (vector doc count hashfun searcher buckets))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ ; Returns the contents of the hashtree as a list of pairs.
+
+ (define (contents ht)
+ (let* ((t (buckets ht)))
+
+ (define (contents t alist)
+ (if (buckets-empty? t)
+ alist
+ (contents (buckets-left t)
+ (contents (buckets-right t)
+ (append-reverse (buckets-alist t)
+ alist)))))
+
+ (define (append-reverse x y)
+ (if (null? x)
+ y
+ (append-reverse (cdr x)
+ (cons (car x) y))))
+
+ ; Creating a new hashtree from a list that is almost sorted
+ ; in hash code order would create an extremely unbalanced
+ ; hashtree, so this routine randomizes the order a bit.
+
+ (define (randomize1 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize2 (cdr alist)
+ (cons (car alist) alist1)
+ alist2
+ alist3)))
+
+ (define (randomize2 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize3 (cdr alist)
+ alist1
+ (cons (car alist) alist2)
+ alist3)))
+
+ (define (randomize3 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize1 (cdr alist)
+ alist1
+ alist2
+ (cons (car alist) alist3))))
+
+ (define (randomize-combine alist1 alist2 alist3)
+ (cond ((null? alist2)
+ alist1)
+ ((null? alist3)
+ (append-reverse alist2 alist1))
+ (else
+ (append-reverse
+ (randomize1 alist3 '() '() '())
+ (append-reverse
+ (randomize1 alist1 '() '() '())
+ (randomize1 alist2 '() '() '()))))))
+
+ (randomize1 (contents t '()) '() '() '())))
+
+ (define (contains? ht key)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key)))
+ (if ((searcher ht) key (find-bucket t h))
+ #t
+ #f))
+ (hashtree-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key))
+ (probe ((searcher ht) key (find-bucket t h))))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtree-error ht)))
+
+ ; Given a <buckets> t and a hash code h, returns the alist for h.
+
+ (define (find-bucket t h)
+ (if (buckets-empty? t)
+ '()
+ (let ((n (buckets-n t)))
+ (cond ((< h n)
+ (find-bucket (buckets-left t) h))
+ ((< n h)
+ (find-bucket (buckets-right t) h))
+ (else
+ (buckets-alist t))))))
+
+ (define (put ht key val)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (association (cons key val))
+ (c (count ht)))
+ (define (put t h)
+ (if (buckets-empty? t)
+ (begin (set! c (+ c 1))
+ (make-buckets h (list association) t t))
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (put (buckets-left t) h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (put (buckets-right t) h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (make-buckets n
+ (substitute1 association
+ probe
+ alist)
+ left
+ right)
+ (begin
+ (set! c (+ c 1))
+ (make-buckets n
+ (cons association alist)
+ left
+ right)))))))))
+ (let ((buckets (put t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (remove ht key)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (c (count ht)))
+ (define (remove t h)
+ (if (buckets-empty? t)
+ t
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (remove left h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (remove right h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (begin (set! c (- c 1))
+ (make-buckets n
+ (remq1 probe alist)
+ left
+ right))
+ t)))))))
+ (let ((buckets (remove t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (size ht)
+ (if (hashtree? ht)
+ (count ht)
+ (hashtree-error ht)))
+
+ (define (ht-for-each f ht)
+ (if (hashtree? ht)
+ (for-each (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtree? ht)
+ (map (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtree
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args))))
+ (make-ht 0 hashfun searcher (make-empty-buckets)))))
+
+ (set! hashtree-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtree-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtree-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtree-put (lambda (ht key val) (put ht key val)))
+ (set! hashtree-remove (lambda (ht key) (remove ht key)))
+ (set! hashtree-size (lambda (ht) (size ht)))
+ (set! hashtree-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtree-map (lambda (ht proc) (ht-map ht proc)))
+ #f))
+; Copyright 1994 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 24 April 1999
+;
+; Compiler switches needed by Twobit.
+
+(define make-twobit-flag)
+(define display-twobit-flag)
+
+(define make-twobit-flag
+ (lambda (name)
+
+ (define (twobit-warning)
+ (display "Error: incorrect arguments to ")
+ (write name)
+ (newline)
+ (reset))
+
+ (define (display-flag state)
+ (display (if state " + " " - "))
+ (display name)
+ (display " is ")
+ (display (if state "on" "off"))
+ (newline))
+
+ (let ((state #t))
+ (lambda args
+ (cond ((null? args) state)
+ ((and (null? (cdr args))
+ (boolean? (car args)))
+ (set! state (car args))
+ state)
+ ((and (null? (cdr args))
+ (eq? (car args) 'display))
+ (display-flag state))
+ (else (twobit-warning)))))))
+
+(define (display-twobit-flag flag)
+ (flag 'display))
+
+; Debugging and convenience.
+
+(define issue-warnings
+ (make-twobit-flag 'issue-warnings))
+
+(define include-source-code
+ (make-twobit-flag 'include-source-code))
+
+(define include-variable-names
+ (make-twobit-flag 'include-variable-names))
+
+(define include-procedure-names
+ (make-twobit-flag 'include-procedure-names))
+
+; Space efficiency.
+; This switch isn't fully implemented yet. If it is true, then
+; Twobit will generate flat closures and will go to some trouble
+; to zero stale registers and stack slots.
+; Don't turn this switch off unless space is more important than speed.
+
+(define avoid-space-leaks
+ (make-twobit-flag 'avoid-space-leaks))
+
+; Major optimizations.
+
+(define integrate-usual-procedures
+ (make-twobit-flag 'integrate-usual-procedures))
+
+(define control-optimization
+ (make-twobit-flag 'control-optimization))
+
+(define parallel-assignment-optimization
+ (make-twobit-flag 'parallel-assignment-optimization))
+
+(define lambda-optimization
+ (make-twobit-flag 'lambda-optimization))
+
+(define benchmark-mode
+ (make-twobit-flag 'benchmark-mode))
+
+(define benchmark-block-mode
+ (make-twobit-flag 'benchmark-block-mode))
+
+(define global-optimization
+ (make-twobit-flag 'global-optimization))
+
+(define interprocedural-inlining
+ (make-twobit-flag 'interprocedural-inlining))
+
+(define interprocedural-constant-propagation
+ (make-twobit-flag 'interprocedural-constant-propagation))
+
+(define common-subexpression-elimination
+ (make-twobit-flag 'common-subexpression-elimination))
+
+(define representation-inference
+ (make-twobit-flag 'representation-inference))
+
+(define local-optimization
+ (make-twobit-flag 'local-optimization))
+
+; For backwards compatibility, until I can change the code.
+
+(define (ignore-space-leaks . args)
+ (if (null? args)
+ (not (avoid-space-leaks))
+ (avoid-space-leaks (not (car args)))))
+
+(define lambda-optimizations lambda-optimization)
+(define local-optimizations local-optimization)
+
+(define (set-compiler-flags! how)
+ (case how
+ ((no-optimization)
+ (set-compiler-flags! 'standard)
+ (avoid-space-leaks #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #f)
+ (parallel-assignment-optimization #f)
+ (lambda-optimization #f)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #f)
+ (interprocedural-inlining #f)
+ (interprocedural-constant-propagation #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f)
+ (local-optimization #f))
+ ((standard)
+ (issue-warnings #t)
+ (include-source-code #f)
+ (include-procedure-names #t)
+ (include-variable-names #t)
+ (avoid-space-leaks #f)
+ (runtime-safety-checking #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #t)
+ (parallel-assignment-optimization #t)
+ (lambda-optimization #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #t)
+ (interprocedural-inlining #t)
+ (interprocedural-constant-propagation #t)
+ (common-subexpression-elimination #t)
+ (representation-inference #t)
+ (local-optimization #t))
+ ((fast-safe)
+ (let ((bbmode (benchmark-block-mode)))
+ (set-compiler-flags! 'standard)
+ (integrate-usual-procedures #t)
+ (benchmark-mode #t)
+ (benchmark-block-mode bbmode)))
+ ((fast-unsafe)
+ (set-compiler-flags! 'fast-safe)
+ (runtime-safety-checking #f))
+ (else
+ (error "set-compiler-flags!: unknown mode " how))))
+
+(define (display-twobit-flags which)
+ (case which
+ ((debugging)
+ (display-twobit-flag issue-warnings)
+ (display-twobit-flag include-procedure-names)
+ (display-twobit-flag include-variable-names)
+ (display-twobit-flag include-source-code))
+ ((safety)
+ (display-twobit-flag avoid-space-leaks))
+ ((optimization)
+ (display-twobit-flag integrate-usual-procedures)
+ (display-twobit-flag control-optimization)
+ (display-twobit-flag parallel-assignment-optimization)
+ (display-twobit-flag lambda-optimization)
+ (display-twobit-flag benchmark-mode)
+ (display-twobit-flag benchmark-block-mode)
+ (display-twobit-flag global-optimization)
+ (if (global-optimization)
+ (begin (display " ")
+ (display-twobit-flag interprocedural-inlining)
+ (display " ")
+ (display-twobit-flag interprocedural-constant-propagation)
+ (display " ")
+ (display-twobit-flag common-subexpression-elimination)
+ (display " ")
+ (display-twobit-flag representation-inference)))
+ (display-twobit-flag local-optimization))
+ (else
+ ; The switch might mean something to the assembler, but not to Twobit
+ #t)))
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 14 April 1999 / wdc
+
+($$trace "pass1.aux")
+
+;***************************************************************
+;
+; Each definition in this section should be overridden by an assignment
+; in a target-specific file.
+;
+; If a lambda expression has more than @maxargs-with-rest-arg@ required
+; arguments followed by a rest argument, then the macro expander will
+; rewrite the lambda expression as a lambda expression with only one
+; argument (a rest argument) whose body is a LET that binds the arguments
+; of the original lambda expression.
+
+(define @maxargs-with-rest-arg@
+ 1000000) ; infinity
+
+(define (prim-entry name) #f) ; no integrable procedures
+(define (prim-arity name) 0) ; all of which take 0 arguments
+(define (prim-opcodename name) name) ; and go by their source names
+
+; End of definitions to be overridden by target-specific assignments.
+;
+;***************************************************************
+
+; Miscellaneous routines.
+
+(define (m-warn msg . more)
+ (if (issue-warnings)
+ (begin
+ (display "WARNING from macro expander:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more))))
+
+(define (m-error msg . more)
+ (display "ERROR detected during macro expansion:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+(define (m-bug msg . more)
+ (display "BUG in macro expander: ")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+; Given a <formals>, returns a list of bound variables.
+
+'
+(define (make-null-terminated x)
+ (cond ((null? x) '())
+ ((pair? x)
+ (cons (car x) (make-null-terminated (cdr x))))
+ (else (list x))))
+
+; Returns the length of the given list, or -1 if the argument
+; is not a list. Does not check for circular lists.
+
+(define (safe-length x)
+ (define (loop x n)
+ (cond ((null? x) n)
+ ((pair? x) (loop (cdr x) (+ n 1)))
+ (else -1)))
+ (loop x 0))
+
+; Given a unary predicate and a list, returns a list of those
+; elements for which the predicate is true.
+
+(define (filter1 p x)
+ (cond ((null? x) '())
+ ((p (car x)) (cons (car x) (filter1 p (cdr x))))
+ (else (filter1 p (cdr x)))))
+
+; Given a unary predicate and a list, returns #t if the
+; predicate is true of every element of the list.
+
+(define (every1? p x)
+ (cond ((null? x) #t)
+ ((p (car x)) (every1? p (cdr x)))
+ (else #f)))
+
+; Binary union of two sets represented as lists, using equal?.
+
+(define (union2 x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))
+
+; Given an association list, copies the association pairs.
+
+(define (copy-alist alist)
+ (map (lambda (x) (cons (car x) (cdr x)))
+ alist))
+
+; Removes a value from a list. May destroy the list.
+
+'
+(define remq!
+ (letrec ((loop (lambda (x y prev)
+ (cond ((null? y) #t)
+ ((eq? x (car y))
+ (set-cdr! prev (cdr y))
+ (loop x (cdr prev) prev))
+ (else
+ (loop x (cdr y) y))))))
+ (lambda (x y)
+ (cond ((null? y) '())
+ ((eq? x (car y))
+ (remq! x (cdr y)))
+ (else
+ (loop x (cdr y) y)
+ y)))))
+
+; Procedure-specific source code transformations.
+; The transformer is passed a source code expression and a predicate
+; and returns one of:
+;
+; the original source code expression
+; a new source code expression to use in place of the original
+; #f to indicate that the procedure is being called
+; with an incorrect number of arguments or
+; with an incorrect operand
+;
+; The original source code expression is guaranteed to be a list whose
+; car is the name associated with the transformer.
+; The predicate takes an identifier (a symbol) and returns true iff
+; that identifier is bound to something other than its global binding.
+;
+; Since the procedures and their transformations are target-specific,
+; they are defined in another file, in the Target subdirectory.
+
+; FIXME:
+; I think this is now used in only one place, in simplify-if.
+
+(define (integrable? name)
+ (and (integrate-usual-procedures)
+ (prim-entry name)))
+
+; MAKE-READABLE strips the referencing information
+; and replaces (begin I) by I.
+; If the optional argument is true, then it also reconstructs LET.
+
+(define (make-readable exp . rest)
+ (let ((fancy? (and (not (null? rest))
+ (car rest))))
+ (define (make-readable exp)
+ (case (car exp)
+ ((quote) (make-readable-quote exp))
+ ((lambda) `(lambda ,(lambda.args exp)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs exp))
+ ,(make-readable (lambda.body exp))))
+ ((set!) `(set! ,(assignment.lhs exp)
+ ,(make-readable (assignment.rhs exp))))
+ ((if) `(if ,(make-readable (if.test exp))
+ ,(make-readable (if.then exp))
+ ,(make-readable (if.else exp))))
+ ((begin) (if (variable? exp)
+ (variable.name exp)
+ `(begin ,@(map make-readable (begin.exprs exp)))))
+ (else (make-readable-call exp))))
+ (define (make-readable-quote exp)
+ (let ((x (constant.value exp)))
+ (if (and fancy?
+ (or (boolean? x)
+ (number? x)
+ (char? x)
+ (string? x)))
+ x
+ exp)))
+ (define (make-readable-call exp)
+ (let ((proc (call.proc exp)))
+ (if (and fancy?
+ (lambda? proc)
+ (list? (lambda.args proc)))
+ ;(make-readable-let* exp '() '() '())
+ (make-readable-let exp)
+ `(,(make-readable (call.proc exp))
+ ,@(map make-readable (call.args exp))))))
+ (define (make-readable-let exp)
+ (let* ((L (call.proc exp))
+ (formals (lambda.args L))
+ (args (map make-readable (call.args exp)))
+ (body (make-readable (lambda.body L))))
+ (if (and (null? (lambda.defs L))
+ (= (length args) 1)
+ (pair? body)
+ (or (and (eq? (car body) 'let)
+ (= (length (cadr body)) 1))
+ (eq? (car body) 'let*)))
+ `(let* ((,(car formals) ,(car args))
+ ,@(cadr body))
+ ,@(cddr body))
+ `(let ,(map list
+ (lambda.args L)
+ args)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs L))
+ ,body))))
+ (define (make-readable-let* exp vars inits defs)
+ (if (and (null? defs)
+ (call? exp)
+ (lambda? (call.proc exp))
+ (= 1 (length (lambda.args (call.proc exp)))))
+ (let ((proc (call.proc exp))
+ (arg (car (call.args exp))))
+ (if (and (call? arg)
+ (lambda? (call.proc arg))
+ (= 1 (length (lambda.args (call.proc arg))))
+ (null? (lambda.defs (call.proc arg))))
+ (make-readable-let*
+ (make-call proc (list (lambda.body (call.proc arg))))
+ (cons (car (lambda.args (call.proc arg))) vars)
+ (cons (make-readable (car (call.args arg))) inits)
+ '())
+ (make-readable-let* (lambda.body proc)
+ (cons (car (lambda.args proc)) vars)
+ (cons (make-readable (car (call.args exp)))
+ inits)
+ (map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (reverse (lambda.defs proc))))))
+ (cond ((or (not (null? vars))
+ (not (null? defs)))
+ `(let* ,(map list
+ (reverse vars)
+ (reverse inits))
+ ,@defs
+ ,(make-readable exp)))
+ ((and (call? exp)
+ (lambda? (call.proc exp)))
+ (let ((proc (call.proc exp)))
+ `(let ,(map list
+ (lambda.args proc)
+ (map make-readable (call.args exp)))
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs proc))
+ ,(make-readable (lambda.body proc)))))
+ (else
+ (make-readable exp)))))
+ (make-readable exp)))
+
+; For testing.
+
+; MAKE-UNREADABLE does the reverse.
+; It assumes there are no internal definitions.
+
+(define (make-unreadable exp)
+ (cond ((symbol? exp) (list 'begin exp))
+ ((pair? exp)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (list 'lambda
+ (cadr exp)
+ '(begin)
+ (list '() '() '() '())
+ (make-unreadable (cons 'begin (cddr exp)))))
+ ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
+ ((if) (list 'if
+ (make-unreadable (cadr exp))
+ (make-unreadable (caddr exp))
+ (if (= (length exp) 3)
+ '(unspecified)
+ (make-unreadable (cadddr exp)))))
+ ((begin) (if (= (length exp) 2)
+ (make-unreadable (cadr exp))
+ (cons 'begin (map make-unreadable (cdr exp)))))
+ (else (map make-unreadable exp))))
+ (else (list 'quote exp))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 12 April 1999.
+;
+; Procedures for fetching and clobbering parts of expressions.
+
+($$trace "pass2.aux")
+
+(define (constant? exp) (eq? (car exp) 'quote))
+(define (variable? exp)
+ (and (eq? (car exp) 'begin)
+ (null? (cddr exp))))
+(define (lambda? exp) (eq? (car exp) 'lambda))
+(define (call? exp) (pair? (car exp)))
+(define (assignment? exp) (eq? (car exp) 'set!))
+(define (conditional? exp) (eq? (car exp) 'if))
+(define (begin? exp)
+ (and (eq? (car exp) 'begin)
+ (not (null? (cddr exp)))))
+
+(define (make-constant value) (list 'quote value))
+(define (make-variable name) (list 'begin name))
+(define (make-lambda formals defs R F G decls doc body)
+ (list 'lambda
+ formals
+ (cons 'begin defs)
+ (list 'quote (list R F G decls doc))
+ body))
+(define (make-call proc args) (cons proc (append args '())))
+(define (make-assignment lhs rhs) (list 'set! lhs rhs))
+(define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
+(define (make-begin exprs)
+ (if (null? (cdr exprs))
+ (car exprs)
+ (cons 'begin (append exprs '()))))
+(define (make-definition lhs rhs) (list 'define lhs rhs))
+
+(define (constant.value exp) (cadr exp))
+(define (variable.name exp) (cadr exp))
+(define (lambda.args exp) (cadr exp))
+(define (lambda.defs exp) (cdr (caddr exp)))
+(define (lambda.R exp) (car (cadr (cadddr exp))))
+(define (lambda.F exp) (cadr (cadr (cadddr exp))))
+(define (lambda.G exp) (caddr (cadr (cadddr exp))))
+(define (lambda.decls exp) (cadddr (cadr (cadddr exp))))
+(define (lambda.doc exp) (car (cddddr (cadr (cadddr exp)))))
+(define (lambda.body exp) (car (cddddr exp)))
+(define (call.proc exp) (car exp))
+(define (call.args exp) (cdr exp))
+(define (assignment.lhs exp) (cadr exp))
+(define (assignment.rhs exp) (caddr exp))
+(define (if.test exp) (cadr exp))
+(define (if.then exp) (caddr exp))
+(define (if.else exp) (cadddr exp))
+(define (begin.exprs exp) (cdr exp))
+(define (def.lhs exp) (cadr exp))
+(define (def.rhs exp) (caddr exp))
+
+(define (variable-set! exp newexp)
+ (set-car! exp (car newexp))
+ (set-cdr! exp (append (cdr newexp) '())))
+(define (lambda.args-set! exp args) (set-car! (cdr exp) args))
+(define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
+(define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
+(define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
+(define (lambda.G-set! exp G) (set-car! (cddr (cadr (cadddr exp))) G))
+(define (lambda.decls-set! exp decls) (set-car! (cdddr (cadr (cadddr exp))) decls))
+(define (lambda.doc-set! exp doc) (set-car! (cddddr (cadr (cadddr exp))) doc))
+(define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
+(define (call.proc-set! exp exp0) (set-car! exp exp0))
+(define (call.args-set! exp exprs) (set-cdr! exp exprs))
+(define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
+(define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
+(define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))
+
+(define expression-set! variable-set!) ; used only by pass 3
+
+; FIXME: This duplicates information in Lib/procinfo.sch.
+
+(define (make-doc name arity formals source-code filename filepos)
+ (vector name source-code arity filename filepos formals))
+(define (doc.name d) (vector-ref d 0))
+(define (doc.code d) (vector-ref d 1))
+(define (doc.arity d) (vector-ref d 2))
+(define (doc.file d) (vector-ref d 3))
+(define (doc.filepos d) (vector-ref d 4))
+(define (doc.formals d) (vector-ref d 5))
+(define (doc.name-set! d x) (if d (vector-set! d 0 x)))
+(define (doc.code-set! d x) (if d (vector-set! d 1 x)))
+(define (doc.arity-set! d x) (if d (vector-set! d 2 x)))
+(define (doc.file-set! d x) (if d (vector-set! d 3 x)))
+(define (doc.filepos-set! d x) (if d (vector-set! d 4 x)))
+(define (doc.formals-set! d x) (if d (vector-set! d 5 x)))
+(define (doc-copy d) (list->vector (vector->list d)))
+
+(define (ignored? name) (eq? name name:IGNORED))
+
+; Fairly harmless bug: rest arguments aren't getting flagged.
+
+(define (flag-as-ignored name L)
+ (define (loop name formals)
+ (cond ((null? formals)
+ ;(pass2-error p2error:violation-of-invariant name formals)
+ #t)
+ ((symbol? formals) #t)
+ ((eq? name (car formals))
+ (set-car! formals name:IGNORED)
+ (if (not (local? (lambda.R L) name:IGNORED))
+ (lambda.R-set! L
+ (cons (make-R-entry name:IGNORED '() '() '())
+ (lambda.R L)))))
+ (else (loop name (cdr formals)))))
+ (loop name (lambda.args L)))
+
+(define (make-null-terminated formals)
+ (cond ((null? formals) '())
+ ((symbol? formals) (list formals))
+ (else (cons (car formals)
+ (make-null-terminated (cdr formals))))))
+
+(define (list-head x n)
+ (cond ((zero? n) '())
+ (else (cons (car x) (list-head (cdr x) (- n 1))))))
+
+(define (remq x y)
+ (cond ((null? y) '())
+ ((eq? x (car y)) (remq x (cdr y)))
+ (else (cons (car y) (remq x (cdr y))))))
+
+(define (make-call-to-LIST args)
+ (cond ((null? args) (make-constant '()))
+ ((null? (cdr args))
+ (make-call (make-variable name:CONS)
+ (list (car args) (make-constant '()))))
+ (else (make-call (make-variable name:LIST) args))))
+
+(define (pass2-error i . etc)
+ (apply cerror (cons (vector-ref pass2-error-messages i) etc)))
+
+(define pass2-error-messages
+ '#("System error: violation of an invariant in pass 2"
+ "Wrong number of arguments to known procedure"))
+
+(define p2error:violation-of-invariant 0)
+(define p2error:wna 1)
+
+; Procedures for fetching referencing information from R-tables.
+
+(define (make-R-entry name refs assigns calls)
+ (list name refs assigns calls))
+
+(define (R-entry.name x) (car x))
+(define (R-entry.references x) (cadr x))
+(define (R-entry.assignments x) (caddr x))
+(define (R-entry.calls x) (cadddr x))
+
+(define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
+(define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
+(define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))
+
+(define (local? R I)
+ (assq I R))
+
+(define (R-entry R I)
+ (assq I R))
+
+(define (R-lookup R I)
+ (or (assq I R)
+ (pass2-error p2error:violation-of-invariant R I)))
+
+(define (references R I)
+ (cadr (R-lookup R I)))
+
+(define (assignments R I)
+ (caddr (R-lookup R I)))
+
+(define (calls R I)
+ (cadddr (R-lookup R I)))
+
+(define (references-set! R I X)
+ (set-car! (cdr (R-lookup R I)) X))
+
+(define (assignments-set! R I X)
+ (set-car! (cddr (R-lookup R I)) X))
+
+(define (calls-set! R I X)
+ (set-car! (cdddr (R-lookup R I)) X))
+
+; A notepad is a vector of the form #(L0 (L1 ...) (L2 ...) (I ...)),
+; where the components are:
+; element 0: a parent lambda expression (or #f if there is no enclosing
+; parent, or we want to pretend that there isn't).
+; element 1: a list of lambda expressions that the parent lambda
+; expression encloses immediately.
+; element 2: a subset of that list that does not escape.
+; element 3: a list of free variables.
+
+(define (make-notepad L)
+ (vector L '() '() '()))
+
+(define (notepad.parent np) (vector-ref np 0))
+(define (notepad.lambdas np) (vector-ref np 1))
+(define (notepad.nonescaping np) (vector-ref np 2))
+(define (notepad.vars np) (vector-ref np 3))
+
+(define (notepad.lambdas-set! np x) (vector-set! np 1 x))
+(define (notepad.nonescaping-set! np x) (vector-set! np 2 x))
+(define (notepad.vars-set! np x) (vector-set! np 3 x))
+
+(define (notepad-lambda-add! np L)
+ (notepad.lambdas-set! np (cons L (notepad.lambdas np))))
+
+(define (notepad-nonescaping-add! np L)
+ (notepad.nonescaping-set! np (cons L (notepad.nonescaping np))))
+
+(define (notepad-var-add! np I)
+ (let ((vars (notepad.vars np)))
+ (if (not (memq I vars))
+ (notepad.vars-set! np (cons I vars)))))
+
+; Given a notepad, returns the list of variables that are closed
+; over by some nested lambda expression that escapes.
+
+(define (notepad-captured-variables np)
+ (let ((nonescaping (notepad.nonescaping np)))
+ (apply-union
+ (map (lambda (L)
+ (if (memq L nonescaping)
+ (lambda.G L)
+ (lambda.F L)))
+ (notepad.lambdas np)))))
+
+; Given a notepad, returns a list of free variables computed
+; as the union of the immediate free variables with the free
+; variables of nested lambda expressions.
+
+(define (notepad-free-variables np)
+ (do ((lambdas (notepad.lambdas np) (cdr lambdas))
+ (fv (notepad.vars np)
+ (let ((L (car lambdas)))
+ (union (difference (lambda.F L)
+ (make-null-terminated (lambda.args L)))
+ fv))))
+ ((null? lambdas) fv)))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 13 December 1998
+\f; Implementation-dependent parameters and preferences that determine
+; how identifiers are represented in the output of the macro expander.
+;
+; The basic problem is that there are no reserved words, so the
+; syntactic keywords of core Scheme that are used to express the
+; output need to be represented by data that cannot appear in the
+; input. This file defines those data.
+
+($$trace "prefs")
+
+; FIXME: The following definitions are currently ignored.
+
+; The following definitions assume that identifiers of mixed case
+; cannot appear in the input.
+
+(define begin1 (string->symbol "Begin"))
+(define define1 (string->symbol "Define"))
+(define quote1 (string->symbol "Quote"))
+(define lambda1 (string->symbol "Lambda"))
+(define if1 (string->symbol "If"))
+(define set!1 (string->symbol "Set!"))
+
+; The following defines an implementation-dependent expression
+; that evaluates to an undefined (not unspecified!) value, for
+; use in expanding the (define x) syntax.
+
+(define undefined1 (list (string->symbol "Undefined")))
+
+; End of FIXME.
+
+; A variable is renamed by suffixing a vertical bar followed by a unique
+; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
+; of an identifier, but presumably this is enforced by the reader and not
+; by the compiler. Any other character that cannot appear as part of an
+; identifier may be used instead of the vertical bar.
+
+(define renaming-prefix-character #\.)
+(define renaming-suffix-character #\|)
+
+(define renaming-prefix (string renaming-prefix-character))
+(define renaming-suffix (string renaming-suffix-character))
+
+; Patches for Twobit. Here temporarily.
+
+(define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+
+(define (make-undefined)
+ (make-call (make-variable 'undefined) '()))
+
+(define (make-unspecified)
+ (make-call (make-variable 'unspecified) '()))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 9 December 1998
+\f; Syntactic environments.
+;
+; A syntactic environment maps identifiers to denotations,
+; where a denotation is one of
+;
+; (special <special>)
+; (macro <rules> <env>)
+; (inline <rules> <env>)
+; (identifier <id> <references> <assignments> <calls>)
+;
+; and where <special> is one of
+;
+; quote
+; lambda
+; if
+; set!
+; begin
+; define
+; define-syntax
+; let-syntax
+; letrec-syntax
+; syntax-rules
+;
+; and where <rules> is a compiled <transformer spec> (see R4RS),
+; <env> is a syntactic environment, and <id> is an identifier.
+;
+; An inline denotation is like a macro denotation, except that it
+; is not an error when none of the rules match the use. Inline
+; denotations are created by DEFINE-INLINE.
+; The standard syntactic environment should not include any
+; identifier denotations; space leaks will result if it does.
+
+($$trace "syntaxenv")
+
+(define standard-syntactic-environment
+ `((quote . (special quote))
+ (lambda . (special lambda))
+ (if . (special if))
+ (set! . (special set!))
+ (begin . (special begin))
+ (define . (special define))
+ (define-inline . (special define-inline))
+ (define-syntax . (special define-syntax))
+ (let-syntax . (special let-syntax))
+ (letrec-syntax . (special letrec-syntax))
+ (syntax-rules . (special syntax-rules))
+ ))
+
+; Unforgeable synonyms for lambda and set!, used to expand definitions.
+
+(define lambda0 (string->symbol " lambda "))
+(define set!0 (string->symbol " set! "))
+
+(define (syntactic-copy env)
+ (copy-alist env))
+
+(define (make-basic-syntactic-environment)
+ (cons (cons lambda0
+ (cdr (assq 'lambda standard-syntactic-environment)))
+ (cons (cons set!0
+ (cdr (assq 'set! standard-syntactic-environment)))
+ (syntactic-copy standard-syntactic-environment))))
+
+; The global-syntactic-environment will always be a nonempty
+; association list since there is no way to remove the entry
+; for lambda0. That entry is used as a header by destructive
+; operations.
+
+(define global-syntactic-environment
+ (make-basic-syntactic-environment))
+
+(define (global-syntactic-environment-set! env)
+ (set-cdr! global-syntactic-environment env)
+ #t)
+
+(define (syntactic-bind-globally! id denotation)
+ (if (and (identifier-denotation? denotation)
+ (eq? id (identifier-name denotation)))
+ (letrec ((remove-bindings-for-id
+ (lambda (bindings)
+ (cond ((null? bindings) '())
+ ((eq? (caar bindings) id)
+ (remove-bindings-for-id (cdr bindings)))
+ (else (cons (car bindings)
+ (remove-bindings-for-id (cdr bindings))))))))
+ (global-syntactic-environment-set!
+ (remove-bindings-for-id (cdr global-syntactic-environment))))
+ (let ((x (assq id global-syntactic-environment)))
+ (if x
+ (begin (set-cdr! x denotation) #t)
+ (global-syntactic-environment-set!
+ (cons (cons id denotation)
+ (cdr global-syntactic-environment)))))))
+
+(define (syntactic-divert env1 env2)
+ (append env2 env1))
+
+(define (syntactic-extend env ids denotations)
+ (syntactic-divert env (map cons ids denotations)))
+
+(define (syntactic-lookup env id)
+ (let ((entry (assq id env)))
+ (if entry
+ (cdr entry)
+ (make-identifier-denotation id))))
+
+(define (syntactic-assign! env id denotation)
+ (let ((entry (assq id env)))
+ (if entry
+ (set-cdr! entry denotation)
+ (m-bug "Bug detected in syntactic-assign!" env id denotation))))
+
+; Denotations.
+
+(define denotation-class car)
+
+(define (special-denotation? denotation)
+ (eq? (denotation-class denotation) 'special))
+
+(define (macro-denotation? denotation)
+ (eq? (denotation-class denotation) 'macro))
+
+(define (inline-denotation? denotation)
+ (eq? (denotation-class denotation) 'inline))
+
+(define (identifier-denotation? denotation)
+ (eq? (denotation-class denotation) 'identifier))
+
+(define (make-macro-denotation rules env)
+ (list 'macro rules env))
+
+(define (make-inline-denotation id rules env)
+ (list 'inline rules env id))
+
+(define (make-identifier-denotation id)
+ (list 'identifier id '() '() '()))
+
+(define macro-rules cadr)
+(define macro-env caddr)
+
+(define inline-rules macro-rules)
+(define inline-env macro-env)
+(define inline-name cadddr)
+
+(define identifier-name cadr)
+(define identifier-R-entry cdr)
+
+(define (same-denotation? d1 d2)
+ (or (eq? d1 d2)
+ (and (identifier-denotation? d1)
+ (identifier-denotation? d2)
+ (eq? (identifier-name d1)
+ (identifier-name d2)))))
+
+(define denotation-of-quote
+ (syntactic-lookup standard-syntactic-environment 'quote))
+
+(define denotation-of-lambda
+ (syntactic-lookup standard-syntactic-environment 'lambda))
+
+(define denotation-of-if
+ (syntactic-lookup standard-syntactic-environment 'if))
+
+(define denotation-of-set!
+ (syntactic-lookup standard-syntactic-environment 'set!))
+
+(define denotation-of-begin
+ (syntactic-lookup standard-syntactic-environment 'begin))
+
+(define denotation-of-define
+ (syntactic-lookup standard-syntactic-environment 'define))
+
+(define denotation-of-define-inline
+ (syntactic-lookup standard-syntactic-environment 'define-inline))
+
+(define denotation-of-define-syntax
+ (syntactic-lookup standard-syntactic-environment 'define-syntax))
+
+(define denotation-of-let-syntax
+ (syntactic-lookup standard-syntactic-environment 'let-syntax))
+
+(define denotation-of-letrec-syntax
+ (syntactic-lookup standard-syntactic-environment 'letrec-syntax))
+
+(define denotation-of-syntax-rules
+ (syntactic-lookup standard-syntactic-environment 'syntax-rules))
+
+(define denotation-of-...
+ (syntactic-lookup standard-syntactic-environment '...))
+
+(define denotation-of-transformer
+ (syntactic-lookup standard-syntactic-environment 'transformer))
+
+; Given a syntactic environment env to be extended, an alist returned
+; by rename-vars, and a syntactic environment env2, extends env by
+; binding the fresh identifiers to the denotations of the original
+; identifiers in env2.
+
+(define (syntactic-alias env alist env2)
+ (syntactic-divert
+ env
+ (map (lambda (name-pair)
+ (let ((old-name (car name-pair))
+ (new-name (cdr name-pair)))
+ (cons new-name
+ (syntactic-lookup env2 old-name))))
+ alist)))
+
+; Given a syntactic environment and an alist returned by rename-vars,
+; extends the environment by binding the old identifiers to the fresh
+; identifiers.
+; For Twobit, it also binds the fresh identifiers to their denotations.
+; This is ok so long as the fresh identifiers are not legal Scheme
+; identifiers.
+
+(define (syntactic-rename env alist)
+ (if (null? alist)
+ env
+ (let* ((old (caar alist))
+ (new (cdar alist))
+ (denotation (make-identifier-denotation new)))
+ (syntactic-rename
+ (cons (cons old denotation)
+ (cons (cons new denotation)
+ env))
+ (cdr alist)))))
+
+; Renaming of variables.
+
+(define renaming-counter 0)
+
+(define (make-rename-procedure)
+ (set! renaming-counter (+ renaming-counter 1))
+ (let ((suffix (string-append renaming-suffix (number->string renaming-counter))))
+ (lambda (sym)
+ (if (symbol? sym)
+ (let ((s (symbol->string sym)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (string->symbol (string-append s suffix))
+ (string->symbol (string-append renaming-prefix s suffix))))
+ (m-warn "Illegal use of rename procedure" 'ok:FIXME sym)))))
+
+; Given a datum, strips the suffixes from any symbols that appear within
+; the datum, trying not to copy any more of the datum than necessary.
+
+(define (m-strip x)
+ (define (original-symbol x)
+ (define (loop sym s i n)
+ (cond ((= i n) sym)
+ ((char=? (string-ref s i)
+ renaming-suffix-character)
+ (string->symbol (substring s 1 i)))
+ (else
+ (loop sym s (+ i 1) n))))
+ (let ((s (symbol->string x)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (loop x s 0 (string-length s))
+ x)))
+ (cond ((symbol? x)
+ (original-symbol x))
+ ((pair? x)
+ (let ((a (m-strip (car x)))
+ (b (m-strip (cdr x))))
+ (if (and (eq? a (car x))
+ (eq? b (cdr x)))
+ x
+ (cons a b))))
+ ((vector? x)
+ (let* ((v (vector->list x))
+ (v2 (map m-strip v)))
+ (if (equal? v v2)
+ x
+ (list->vector v2))))
+ (else x)))
+
+; Given a list of identifiers, or a formal parameter "list",
+; returns an alist that associates each identifier with a fresh identifier.
+
+(define (rename-vars original-vars)
+ (let ((rename (make-rename-procedure)))
+ (define (loop vars newvars)
+ (cond ((null? vars) (reverse newvars))
+ ((pair? vars)
+ (let ((var (car vars)))
+ (if (symbol? var)
+ (loop (cdr vars)
+ (cons (cons var (rename var))
+ newvars))
+ (m-error "Illegal variable" var))))
+ ((symbol? vars)
+ (loop (list vars) newvars))
+ (else (m-error "Malformed parameter list" original-vars))))
+ (loop original-vars '())))
+
+; Given a <formals> and an alist returned by rename-vars that contains
+; a new name for each formal identifier in <formals>, renames the
+; formal identifiers.
+
+(define (rename-formals formals alist)
+ (cond ((null? formals) '())
+ ((pair? formals)
+ (cons (cdr (assq (car formals) alist))
+ (rename-formals (cdr formals) alist)))
+ (else (cdr (assq formals alist)))))
+; Copyright 1992 William Clinger
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful purpose, and to redistribute this software
+; is granted subject to the restriction that all copies made of this
+; software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 23 November 1998
+\f; Compiler for a <transformer spec>.
+;
+; References:
+;
+; The Revised^4 Report on the Algorithmic Language Scheme.
+; Clinger and Rees [editors]. To appear in Lisp Pointers.
+; Also available as a technical report from U of Oregon,
+; MIT AI Lab, and Cornell.
+;
+; Macros That Work. Clinger and Rees. POPL '91.
+;
+; The input is a <transformer spec> and a syntactic environment.
+; Syntactic environments are described in another file.
+;
+; The supported syntax differs from the R4RS in that vectors are
+; allowed as patterns and as templates and are not allowed as
+; pattern or template data.
+;
+; <transformer spec> --> (syntax-rules <literals> <rules>)
+; <rules> --> () | (<rule> . <rules>)
+; <rule> --> (<pattern> <template>)
+; <pattern> --> <pattern_var> ; a <symbol> not in <literals>
+; | <symbol> ; a <symbol> in <literals>
+; | ()
+; | (<pattern> . <pattern>)
+; | (<ellipsis_pattern>)
+; | #(<pattern>*) ; extends R4RS
+; | #(<pattern>* <ellipsis_pattern>) ; extends R4RS
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<template>*) ; extends R4RS
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string> ; no <vector>
+; | <character>
+; | <boolean>
+; | <number>
+; <ellipsis_pattern> --> <pattern> ...
+; <ellipsis_template> --> <template> ...
+; <pattern_var> --> <symbol> ; not in <literals>
+; <literals> --> () | (<symbol> . <literals>)
+;
+; Definitions.
+;
+; scope of an ellipsis
+;
+; Within a pattern or template, the scope of an ellipsis
+; (...) is the pattern or template that appears to its left.
+;
+; rank of a pattern variable
+;
+; The rank of a pattern variable is the number of ellipses
+; within whose scope it appears in the pattern.
+;
+; rank of a subtemplate
+;
+; The rank of a subtemplate is the number of ellipses within
+; whose scope it appears in the template.
+;
+; template rank of an occurrence of a pattern variable
+;
+; The template rank of an occurrence of a pattern variable
+; within a template is the rank of that occurrence, viewed
+; as a subtemplate.
+;
+; variables bound by a pattern
+;
+; The variables bound by a pattern are the pattern variables
+; that appear within it.
+;
+; referenced variables of a subtemplate
+;
+; The referenced variables of a subtemplate are the pattern
+; variables that appear within it.
+;
+; variables opened by an ellipsis template
+;
+; The variables opened by an ellipsis template are the
+; referenced pattern variables whose rank is greater than
+; the rank of the ellipsis template.
+;
+;
+; Restrictions.
+;
+; No pattern variable appears more than once within a pattern.
+;
+; For every occurrence of a pattern variable within a template,
+; the template rank of the occurrence must be greater than or
+; equal to the pattern variable's rank.
+;
+; Every ellipsis template must open at least one variable.
+;
+; For every ellipsis template, the variables opened by an
+; ellipsis template must all be bound to sequences of the
+; same length.
+;
+;
+; The compiled form of a <rule> is
+;
+; <rule> --> (<pattern> <template> <inserted>)
+; <pattern> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<pattern> . <pattern>)
+; | <ellipsis_pattern>
+; | #(<pattern>)
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<pattern>)
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string>
+; | <character>
+; | <boolean>
+; | <number>
+; <pattern_var> --> #(<V> <symbol> <rank>)
+; <ellipsis_pattern> --> #(<E> <pattern> <pattern_vars>)
+; <ellipsis_template> --> #(<E> <template> <pattern_vars>)
+; <inserted> --> () | (<symbol> . <inserted>)
+; <pattern_vars> --> () | (<pattern_var> . <pattern_vars>)
+; <rank> --> <exact non-negative integer>
+;
+; where <V> and <E> are unforgeable values.
+; The pattern variables associated with an ellipsis pattern
+; are the variables bound by the pattern, and the pattern
+; variables associated with an ellipsis template are the
+; variables opened by the ellipsis template.
+;
+;
+; What's wrong with the above?
+; If the template contains a big chunk that contains no pattern variables
+; or inserted identifiers, then the big chunk will be copied unnecessarily.
+; That shouldn't matter very often.
+
+($$trace "syntaxrules")
+
+(define pattern-variable-flag (list 'v))
+(define ellipsis-pattern-flag (list 'e))
+(define ellipsis-template-flag ellipsis-pattern-flag)
+
+(define (make-patternvar v rank)
+ (vector pattern-variable-flag v rank))
+(define (make-ellipsis-pattern P vars)
+ (vector ellipsis-pattern-flag P vars))
+(define (make-ellipsis-template T vars)
+ (vector ellipsis-template-flag T vars))
+
+(define (patternvar? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) pattern-variable-flag)))
+
+(define (ellipsis-pattern? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-pattern-flag)))
+
+(define (ellipsis-template? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-template-flag)))
+
+(define (patternvar-name V) (vector-ref V 1))
+(define (patternvar-rank V) (vector-ref V 2))
+(define (ellipsis-pattern P) (vector-ref P 1))
+(define (ellipsis-pattern-vars P) (vector-ref P 2))
+(define (ellipsis-template T) (vector-ref T 1))
+(define (ellipsis-template-vars T) (vector-ref T 2))
+
+(define (pattern-variable v vars)
+ (cond ((null? vars) #f)
+ ((eq? v (patternvar-name (car vars)))
+ (car vars))
+ (else (pattern-variable v (cdr vars)))))
+
+; Given a <transformer spec> and a syntactic environment,
+; returns a macro denotation.
+;
+; A macro denotation is of the form
+;
+; (macro (<rule> ...) env)
+;
+; where each <rule> has been compiled as described above.
+
+(define (m-compile-transformer-spec spec env)
+ (if (and (> (safe-length spec) 1)
+ (eq? (syntactic-lookup env (car spec))
+ denotation-of-syntax-rules))
+ (let ((literals (cadr spec))
+ (rules (cddr spec)))
+ (if (or (not (list? literals))
+ (not (every1? (lambda (rule)
+ (and (= (safe-length rule) 2)
+ (pair? (car rule))))
+ rules)))
+ (m-error "Malformed syntax-rules" spec))
+ (list 'macro
+ (map (lambda (rule)
+ (m-compile-rule rule literals env))
+ rules)
+ env))
+ (m-error "Malformed syntax-rules" spec)))
+
+(define (m-compile-rule rule literals env)
+ (m-compile-pattern (cdr (car rule))
+ literals
+ env
+ (lambda (compiled-rule patternvars)
+ ; FIXME
+ ; should check uniqueness of pattern variables here
+ (cons compiled-rule
+ (m-compile-template
+ (cadr rule)
+ patternvars
+ env)))))
+
+(define (m-compile-pattern P literals env k)
+ (define (loop P vars rank k)
+ (cond ((symbol? P)
+ (if (memq P literals)
+ (k P vars)
+ (let ((var (make-patternvar P rank)))
+ (k var (cons var vars)))))
+ ((null? P) (k '() vars))
+ ((pair? P)
+ (if (and (pair? (cdr P))
+ (symbol? (cadr P))
+ (same-denotation? (syntactic-lookup env (cadr P))
+ denotation-of-...))
+ (if (null? (cddr P))
+ (loop (car P)
+ '()
+ (+ rank 1)
+ (lambda (P vars1)
+ (k (make-ellipsis-pattern P vars1)
+ (union2 vars1 vars))))
+ (m-error "Malformed pattern" P))
+ (loop (car P)
+ vars
+ rank
+ (lambda (P1 vars)
+ (loop (cdr P)
+ vars
+ rank
+ (lambda (P2 vars)
+ (k (cons P1 P2) vars)))))))
+ ((vector? P)
+ (loop (vector->list P)
+ vars
+ rank
+ (lambda (P vars)
+ (k (vector P) vars))))
+ (else (k P vars))))
+ (loop P '() 0 k))
+
+(define (m-compile-template T vars env)
+
+ (define (loop T inserted referenced rank escaped? k)
+ (cond ((symbol? T)
+ (let ((x (pattern-variable T vars)))
+ (if x
+ (if (>= rank (patternvar-rank x))
+ (k x inserted (cons x referenced))
+ (m-error
+ "Too few ellipses follow pattern variable in template"
+ (patternvar-name x)))
+ (k T (cons T inserted) referenced))))
+ ((null? T) (k '() inserted referenced))
+ ((pair? T)
+ (cond ((and (not escaped?)
+ (symbol? (car T))
+ (same-denotation? (syntactic-lookup env (car T))
+ denotation-of-...)
+ (pair? (cdr T))
+ (null? (cddr T)))
+ (loop (cadr T) inserted referenced rank #t k))
+ ((and (not escaped?)
+ (pair? (cdr T))
+ (symbol? (cadr T))
+ (same-denotation? (syntactic-lookup env (cadr T))
+ denotation-of-...))
+ (loop1 T inserted referenced rank escaped? k))
+ (else
+ (loop (car T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T1 inserted referenced)
+ (loop (cdr T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons T1 T2) inserted referenced))))))))
+ ((vector? T)
+ (loop (vector->list T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T inserted referenced)
+ (k (vector T) inserted referenced))))
+ (else (k T inserted referenced))))
+
+ (define (loop1 T inserted referenced rank escaped? k)
+ (loop (car T)
+ inserted
+ '()
+ (+ rank 1)
+ escaped?
+ (lambda (T1 inserted referenced1)
+ (loop (cddr T)
+ inserted
+ (append referenced1 referenced)
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons (make-ellipsis-template
+ T1
+ (filter1 (lambda (var)
+ (> (patternvar-rank var)
+ rank))
+ referenced1))
+ T2)
+ inserted
+ referenced))))))
+
+ (loop T
+ '()
+ '()
+ 0
+ #f
+ (lambda (T inserted referenced)
+ (list T inserted))))
+
+; The pattern matcher.
+;
+; Given an input, a pattern, and two syntactic environments,
+; returns a pattern variable environment (represented as an alist)
+; if the input matches the pattern, otherwise returns #f.
+
+(define empty-pattern-variable-environment
+ (list (make-patternvar (string->symbol "") 0)))
+
+(define (m-match F P env-def env-use)
+
+ (define (match F P answer rank)
+ (cond ((null? P)
+ (and (null? F) answer))
+ ((pair? P)
+ (and (pair? F)
+ (let ((answer (match (car F) (car P) answer rank)))
+ (and answer (match (cdr F) (cdr P) answer rank)))))
+ ((symbol? P)
+ (and (symbol? F)
+ (same-denotation? (syntactic-lookup env-def P)
+ (syntactic-lookup env-use F))
+ answer))
+ ((patternvar? P)
+ (cons (cons P F) answer))
+ ((ellipsis-pattern? P)
+ (match1 F P answer (+ rank 1)))
+ ((vector? P)
+ (and (vector? F)
+ (match (vector->list F) (vector-ref P 0) answer rank)))
+ (else (and (equal? F P) answer))))
+
+ (define (match1 F P answer rank)
+ (cond ((not (list? F)) #f)
+ ((null? F)
+ (append (map (lambda (var) (cons var '()))
+ (ellipsis-pattern-vars P))
+ answer))
+ (else
+ (let* ((P1 (ellipsis-pattern P))
+ (answers (map (lambda (F) (match F P1 answer rank))
+ F)))
+ (if (every1? (lambda (answer) answer) answers)
+ (append (map (lambda (var)
+ (cons var
+ (map (lambda (answer)
+ (cdr (assq var answer)))
+ answers)))
+ (ellipsis-pattern-vars P))
+ answer)
+ #f)))))
+
+ (match F P empty-pattern-variable-environment 0))
+
+(define (m-rewrite T alist)
+
+ (define (rewrite T alist rank)
+ (cond ((null? T) '())
+ ((pair? T)
+ ((if (ellipsis-pattern? (car T))
+ append
+ cons)
+ (rewrite (car T) alist rank)
+ (rewrite (cdr T) alist rank)))
+ ((symbol? T) (cdr (assq T alist)))
+ ((patternvar? T) (cdr (assq T alist)))
+ ((ellipsis-template? T)
+ (rewrite1 T alist (+ rank 1)))
+ ((vector? T)
+ (list->vector (rewrite (vector-ref T 0) alist rank)))
+ (else T)))
+
+ (define (rewrite1 T alist rank)
+ (let* ((T1 (ellipsis-template T))
+ (vars (ellipsis-template-vars T))
+ (rows (map (lambda (var) (cdr (assq var alist)))
+ vars)))
+ (map (lambda (alist) (rewrite T1 alist rank))
+ (make-columns vars rows alist))))
+
+ (define (make-columns vars rows alist)
+ (define (loop rows)
+ (if (null? (car rows))
+ '()
+ (cons (append (map (lambda (var row)
+ (cons var (car row)))
+ vars
+ rows)
+ alist)
+ (loop (map cdr rows)))))
+ (if (or (null? (cdr rows))
+ (apply = (map length rows)))
+ (loop rows)
+ (m-error "Use of macro is not consistent with definition"
+ vars
+ rows)))
+
+ (rewrite T alist 0))
+
+; Given a use of a macro, the syntactic environment of the use,
+; a continuation that expects a transcribed expression and
+; a new environment in which to continue expansion, and a boolean
+; that is true if this transcription is for an inline procedure,
+; does the right thing.
+
+(define (m-transcribe0 exp env-use k inline?)
+ (let* ((m (syntactic-lookup env-use (car exp)))
+ (rules (macro-rules m))
+ (env-def (macro-env m))
+ (F (cdr exp)))
+ (define (loop rules)
+ (if (null? rules)
+ (if inline?
+ (k exp env-use)
+ (m-error "Use of macro does not match definition" exp))
+ (let* ((rule (car rules))
+ (pattern (car rule))
+ (alist (m-match F pattern env-def env-use)))
+ (if alist
+ (let* ((template (cadr rule))
+ (inserted (caddr rule))
+ (alist2 (rename-vars inserted))
+ (newexp (m-rewrite template (append alist2 alist))))
+ (k newexp
+ (syntactic-alias env-use alist2 env-def)))
+ (loop (cdr rules))))))
+ (if (procedure? rules)
+ (m-transcribe-low-level exp env-use k rules env-def)
+ (loop rules))))
+
+(define (m-transcribe exp env-use k)
+ (m-transcribe0 exp env-use k #f))
+
+(define (m-transcribe-inline exp env-use k)
+ (m-transcribe0 exp env-use k #t))
+
+; Copyright 1998 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Low-level macro facility based on explicit renaming. See
+; William D Clinger. Hygienic macros through explicit renaming.
+; In Lisp Pointers IV(4), 25-28, December 1991.
+
+($$trace "lowlevel")
+
+(define (m-transcribe-low-level exp env-use k transformer env-def)
+ (let ((rename0 (make-rename-procedure))
+ (renamed '())
+ (ok #t))
+ (define (lookup sym)
+ (let loop ((alist renamed))
+ (cond ((null? alist)
+ (syntactic-lookup env-use sym))
+ ((eq? sym (cdr (car alist)))
+ (syntactic-lookup env-def (car (car alist))))
+ (else
+ (loop (cdr alist))))))
+ (let ((rename
+ (lambda (sym)
+ (if ok
+ (let ((probe (assq sym renamed)))
+ (if probe
+ (cdr probe)
+ (let ((sym2 (rename0 sym)))
+ (set! renamed (cons (cons sym sym2) renamed))
+ sym2)))
+ (m-error "Illegal use of a rename procedure" sym))))
+ (compare
+ (lambda (sym1 sym2)
+ (same-denotation? (lookup sym1) (lookup sym2)))))
+ (let ((exp2 (transformer exp rename compare)))
+ (set! ok #f)
+ (k exp2
+ (syntactic-alias env-use renamed env-def))))))
+
+(define identifier? symbol?)
+
+(define (identifier->symbol id)
+ (m-strip id))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 22 April 1999
+
+($$trace "expand")
+
+; This procedure sets the default scope of global macro definitions.
+
+(define define-syntax-scope
+ (let ((flag 'letrec))
+ (lambda args
+ (cond ((null? args) flag)
+ ((not (null? (cdr args)))
+ (apply m-warn
+ "Too many arguments passed to define-syntax-scope"
+ args))
+ ((memq (car args) '(letrec letrec* let*))
+ (set! flag (car args)))
+ (else (m-warn "Unrecognized argument to define-syntax-scope"
+ (car args)))))))
+
+; The main entry point.
+; The outermost lambda allows known procedures to be lifted outside
+; all local variables.
+
+(define (macro-expand def-or-exp)
+ (call-with-current-continuation
+ (lambda (k)
+ (set! m-quit k)
+ (set! renaming-counter 0)
+ (make-call
+ (make-lambda '() ; formals
+ '() ; definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; declarations
+ #f ; documentation
+ (desugar-definitions def-or-exp
+ global-syntactic-environment
+ make-toplevel-definition))
+ '()))))
+
+(define (desugar-definitions exp env make-toplevel-definition)
+ (letrec
+
+ ((define-loop
+ (lambda (exp rest first env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-loop (cadr exp) (append (cddr exp) rest) first env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (let ((exp (desugar-define exp env)))
+ (cond ((and (null? first) (null? rest))
+ exp)
+ ((null? rest)
+ (make-begin (reverse (cons exp first))))
+ (else (define-loop (car rest)
+ (cdr rest)
+ (cons exp first)
+ env)))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (or (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax)
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (null? first))
+ (define-syntax-loop exp rest env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-loop exp rest first env))))
+ ((and (null? first) (null? rest))
+ (m-expand exp env))
+ ((null? rest)
+ (make-begin (reverse (cons (m-expand exp env) first))))
+ (else (make-begin
+ (append (reverse first)
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest))))))))
+
+ (define-syntax-loop
+ (lambda (exp rest env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-syntax-loop (cadr exp) (append (cddr exp) rest) env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-syntax exp env)
+ (begin (m-define-syntax exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-inline exp env)
+ (begin (m-define-inline exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-syntax-loop exp rest env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (define-loop exp rest '() env))
+ ((null? rest)
+ (m-expand exp env))
+ (else (make-begin
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest)))))))
+
+ (desugar-define
+ (lambda (exp env)
+ (cond
+ ((null? (cdr exp)) (m-error "Malformed definition" exp))
+ ; (define foo) syntax is transformed into (define foo (undefined)).
+ ((null? (cddr exp))
+ (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (make-undefined))))
+ ((pair? (cadr exp))
+ (desugar-define
+ (let* ((def (car exp))
+ (pattern (cadr exp))
+ (f (car pattern))
+ (args (cdr pattern))
+ (body (cddr exp)))
+ (if (and (symbol? (car (cadr exp)))
+ (benchmark-mode)
+ (list? (cadr exp)))
+ `(,def ,f
+ (,lambda0 ,args
+ ((,lambda0 (,f)
+ (,set!0 ,f (,lambda0 ,args ,@body))
+ ,pattern)
+ 0)))
+ `(,def ,f (,lambda0 ,args ,@body))))
+ env))
+ ((> (length exp) 3) (m-error "Malformed definition" exp))
+ (else (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (m-expand (caddr exp) env)))))))
+
+ (redefinition
+ (lambda (id)
+ (if (symbol? id)
+ (if (not (identifier-denotation?
+ (syntactic-lookup global-syntactic-environment id)))
+ (if (issue-warnings)
+ (m-warn "Redefining " id)))
+ (m-error "Malformed variable or keyword" id)))))
+
+ ; body of letrec
+
+ (define-loop exp '() '() env)))
+
+; Given an expression and a syntactic environment,
+; returns an expression in core Scheme.
+
+(define (m-expand exp env)
+ (cond ((not (pair? exp))
+ (m-atom exp env))
+ ((not (symbol? (car exp)))
+ (m-application exp env))
+ (else
+ (let ((keyword (syntactic-lookup env (car exp))))
+ (case (denotation-class keyword)
+ ((special)
+ (cond
+ ((eq? keyword denotation-of-quote) (m-quote exp))
+ ((eq? keyword denotation-of-lambda) (m-lambda exp env))
+ ((eq? keyword denotation-of-if) (m-if exp env))
+ ((eq? keyword denotation-of-set!) (m-set exp env))
+ ((eq? keyword denotation-of-begin) (m-begin exp env))
+ ((eq? keyword denotation-of-let-syntax)
+ (m-let-syntax exp env))
+ ((eq? keyword denotation-of-letrec-syntax)
+ (m-letrec-syntax exp env))
+ ((or (eq? keyword denotation-of-define)
+ (eq? keyword denotation-of-define-syntax)
+ (eq? keyword denotation-of-define-inline))
+ (m-error "Definition out of context" exp))
+ (else (m-bug "Bug detected in m-expand" exp env))))
+ ((macro) (m-macro exp env))
+ ((inline) (m-inline exp env))
+ ((identifier) (m-application exp env))
+ (else (m-bug "Bug detected in m-expand" exp env)))))))
+
+(define (m-atom exp env)
+ (cond ((not (symbol? exp))
+ ; Here exp ought to be a boolean, number, character, or string.
+ ; I'll warn about other things but treat them as if quoted.
+ ;
+ ; I'm turning off some of the warnings because notably procedures
+ ; and #!unspecified can occur in loaded files and it's a major
+ ; pain if a warning is printed for each. --lars
+ (if (and (not (boolean? exp))
+ (not (number? exp))
+ (not (char? exp))
+ (not (string? exp))
+ (not (procedure? exp))
+ (not (eq? exp (unspecified))))
+ (m-warn "Malformed constant -- should be quoted" exp))
+ (make-constant exp))
+ (else (let ((denotation (syntactic-lookup env exp)))
+ (case (denotation-class denotation)
+ ((special macro)
+ (m-warn "Syntactic keyword used as a variable" exp)
+ ; Syntactic keywords used as variables are treated as #t.
+ (make-constant #t))
+ ((inline)
+ (make-variable (inline-name denotation)))
+ ((identifier)
+ (let ((var (make-variable (identifier-name denotation)))
+ (R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (cons var (R-entry.references R-entry)))
+ var))
+ (else (m-bug "Bug detected by m-atom" exp env)))))))
+
+(define (m-quote exp)
+ (if (and (pair? (cdr exp))
+ (null? (cddr exp)))
+ (make-constant (m-strip (cadr exp)))
+ (m-error "Malformed quoted constant" exp)))
+
+(define (m-lambda exp env)
+ (if (> (safe-length exp) 2)
+
+ (let* ((formals (cadr exp))
+ (alist (rename-vars formals))
+ (env (syntactic-rename env alist))
+ (body (cddr exp)))
+
+ (do ((alist alist (cdr alist)))
+ ((null? alist))
+ (if (assq (caar alist) (cdr alist))
+ (m-error "Malformed parameter list" formals)))
+
+ ; To simplify the run-time system, there's a limit on how many
+ ; fixed arguments can be followed by a rest argument.
+ ; That limit is removed here.
+ ; Bug: documentation slot isn't right when this happens.
+ ; Bug: this generates extremely inefficient code.
+
+ (if (and (not (list? formals))
+ (> (length alist) @maxargs-with-rest-arg@))
+ (let ((TEMP (car (rename-vars '(temp)))))
+ (m-lambda
+ `(,lambda0 ,TEMP
+ ((,lambda0 ,(map car alist)
+ ,@(cddr exp))
+ ,@(do ((actuals '() (cons (list name:CAR path)
+ actuals))
+ (path TEMP (list name:CDR path))
+ (formals formals (cdr formals)))
+ ((symbol? formals)
+ (append (reverse actuals) (list path))))))
+ env))
+ (make-lambda (rename-formals formals alist)
+ '() ; no definitions yet
+ (map (lambda (entry)
+ (cdr (syntactic-lookup env (cdr entry))))
+ alist) ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (make-doc #f
+ (if (list? formals)
+ (length alist)
+ (exact->inexact (- (length alist) 1)))
+ (if (include-variable-names)
+ formals
+ #f)
+ (if (include-source-code)
+ exp
+ #f)
+ source-file-name
+ source-file-position)
+ (m-body body env))))
+
+ (m-error "Malformed lambda expression" exp)))
+
+(define (m-body body env)
+ (define (loop body env defs)
+ (if (null? body)
+ (m-error "Empty body"))
+ (let ((exp (car body)))
+ (if (and (pair? exp)
+ (symbol? (car exp)))
+ (let ((denotation (syntactic-lookup env (car exp))))
+ (case (denotation-class denotation)
+ ((special)
+ (cond ((eq? denotation denotation-of-begin)
+ (loop (append (cdr exp) (cdr body)) env defs))
+ ((eq? denotation denotation-of-define)
+ (loop (cdr body) env (cons exp defs)))
+ (else (finalize-body body env defs))))
+ ((macro)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (loop (cons exp (cdr body))
+ env
+ defs))))
+ ((inline identifier)
+ (finalize-body body env defs))
+ (else (m-bug "Bug detected in m-body" body env))))
+ (finalize-body body env defs))))
+ (loop body env '()))
+
+(define (finalize-body body env defs)
+ (if (null? defs)
+ (let ((body (map (lambda (exp) (m-expand exp env))
+ body)))
+ (if (null? (cdr body))
+ (car body)
+ (make-begin body)))
+ (let ()
+ (define (sort-defs defs)
+ (let* ((augmented
+ (map (lambda (def)
+ (let ((rhs (cadr def)))
+ (if (not (pair? rhs))
+ (cons 'trivial def)
+ (let ((denotation
+ (syntactic-lookup env (car rhs))))
+ (cond ((eq? denotation
+ denotation-of-lambda)
+ (cons 'procedure def))
+ ((eq? denotation
+ denotation-of-quote)
+ (cons 'trivial def))
+ (else
+ (cons 'miscellaneous def)))))))
+ defs))
+ (sorted (twobit-sort (lambda (x y)
+ (or (eq? (car x) 'procedure)
+ (eq? (car y) 'miscellaneous)))
+ augmented)))
+ (map cdr sorted)))
+ (define (desugar-definition def)
+ (if (> (safe-length def) 2)
+ (cond ((pair? (cadr def))
+ (desugar-definition
+ `(,(car def)
+ ,(car (cadr def))
+ (,lambda0
+ ,(cdr (cadr def))
+ ,@(cddr def)))))
+ ((and (= (length def) 3)
+ (symbol? (cadr def)))
+ (cdr def))
+ (else (m-error "Malformed definition" def)))
+ (m-error "Malformed definition" def)))
+ (define (expand-letrec bindings body)
+ (make-call
+ (m-expand
+ `(,lambda0 ,(map car bindings)
+ ,@(map (lambda (binding)
+ `(,set!0 ,(car binding)
+ ,(cadr binding)))
+ bindings)
+ ,@body)
+ env)
+ (map (lambda (binding) (make-unspecified)) bindings)))
+ (expand-letrec (sort-defs (map desugar-definition
+ (reverse defs)))
+ body))))
+
+(define (m-if exp env)
+ (let ((n (safe-length exp)))
+ (if (or (= n 3) (= n 4))
+ (make-conditional (m-expand (cadr exp) env)
+ (m-expand (caddr exp) env)
+ (if (= n 3)
+ (make-unspecified)
+ (m-expand (cadddr exp) env)))
+ (m-error "Malformed if expression" exp))))
+
+(define (m-set exp env)
+ (if (= (safe-length exp) 3)
+ (let ((lhs (m-expand (cadr exp) env))
+ (rhs (m-expand (caddr exp) env)))
+ (if (variable? lhs)
+ (let* ((x (variable.name lhs))
+ (assignment (make-assignment x rhs))
+ (denotation (syntactic-lookup env x)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (remq lhs (R-entry.references R-entry)))
+ (R-entry.assignments-set!
+ R-entry
+ (cons assignment (R-entry.assignments R-entry)))))
+ (if (and (lambda? rhs)
+ (include-procedure-names))
+ (let ((doc (lambda.doc rhs)))
+ (doc.name-set! doc x)))
+ (if pass1-block-compiling?
+ (set! pass1-block-assignments
+ (cons x pass1-block-assignments)))
+ assignment)
+ (m-error "Malformed assignment" exp)))
+ (m-error "Malformed assignment" exp)))
+
+(define (m-begin exp env)
+ (cond ((> (safe-length exp) 1)
+ (make-begin (map (lambda (exp) (m-expand exp env)) (cdr exp))))
+ ((= (safe-length exp) 1)
+ (m-warn "Non-standard begin expression" exp)
+ (make-unspecified))
+ (else
+ (m-error "Malformed begin expression" exp))))
+
+(define (m-application exp env)
+ (if (> (safe-length exp) 0)
+ (let* ((proc (m-expand (car exp) env))
+ (args (map (lambda (exp) (m-expand exp env))
+ (cdr exp)))
+ (call (make-call proc args)))
+ (if (variable? proc)
+ (let* ((procname (variable.name proc))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every1? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ (let ((denotation (syntactic-lookup env procname)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.calls-set!
+ R-entry
+ (cons call (R-entry.calls R-entry)))))
+ call)))
+ call))
+ (m-error "Malformed application" exp)))
+
+; The environment argument should always be global here.
+
+(define (m-define-inline exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (let ((name (cadr exp)))
+ (m-define-syntax1 name
+ (caddr exp)
+ env
+ (define-syntax-scope))
+ (let ((denotation
+ (syntactic-lookup global-syntactic-environment name)))
+ (syntactic-bind-globally!
+ name
+ (make-inline-denotation name
+ (macro-rules denotation)
+ (macro-env denotation))))
+ (make-constant name)))
+ (else
+ (m-error "Malformed define-inline" exp))))
+
+; The environment argument should always be global here.
+
+(define (m-define-syntax exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (m-define-syntax1 (cadr exp)
+ (caddr exp)
+ env
+ (define-syntax-scope)))
+ ((and (= (safe-length exp) 4)
+ (symbol? (cadr exp))
+ ; FIXME: should use denotations here
+ (memq (caddr exp) '(letrec letrec* let*)))
+ (m-define-syntax1 (cadr exp)
+ (cadddr exp)
+ env
+ (caddr exp)))
+ (else (m-error "Malformed define-syntax" exp))))
+
+(define (m-define-syntax1 keyword spec env scope)
+ (if (and (pair? spec)
+ (symbol? (car spec)))
+ (let* ((transformer-keyword (car spec))
+ (denotation (syntactic-lookup env transformer-keyword)))
+ (cond ((eq? denotation denotation-of-syntax-rules)
+ (case scope
+ ((letrec) (m-define-syntax-letrec keyword spec env))
+ ((letrec*) (m-define-syntax-letrec* keyword spec env))
+ ((let*) (m-define-syntax-let* keyword spec env))
+ (else (m-bug "Weird scope" scope))))
+ ((same-denotation? denotation denotation-of-transformer)
+ ; FIXME: no error checking here
+ (syntactic-bind-globally!
+ keyword
+ (make-macro-denotation (eval (cadr spec)) env)))
+ (else
+ (m-error "Malformed syntax transformer" spec))))
+ (m-error "Malformed syntax transformer" spec))
+ (make-constant keyword))
+
+(define (m-define-syntax-letrec keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec env)))
+
+(define (m-define-syntax-letrec* keyword spec env)
+ (let* ((env (syntactic-extend (syntactic-copy env)
+ (list keyword)
+ '((fake denotation))))
+ (transformer (m-compile-transformer-spec spec env)))
+ (syntactic-assign! env keyword transformer)
+ (syntactic-bind-globally! keyword transformer)))
+
+(define (m-define-syntax-let* keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec (syntactic-copy env))))
+
+(define (m-let-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (m-body (cddr exp)
+ (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (spec)
+ (m-compile-transformer-spec
+ spec
+ env))
+ (map cadr (cadr exp)))))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-letrec-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (let ((env (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (id)
+ '(fake denotation))
+ (cadr exp)))))
+ (for-each (lambda (id spec)
+ (syntactic-assign!
+ env
+ id
+ (m-compile-transformer-spec spec env)))
+ (map car (cadr exp))
+ (map cadr (cadr exp)))
+ (m-body (cddr exp) env))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-macro exp env)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (m-expand exp env))))
+
+(define (m-inline exp env)
+ (if (integrate-usual-procedures)
+ (m-transcribe-inline exp
+ env
+ (lambda (newexp env)
+ (if (eq? exp newexp)
+ (m-application exp env)
+ (m-expand newexp env))))
+ (m-application exp env)))
+
+(define m-quit ; assigned by macro-expand
+ (lambda (v) v))
+
+; To do:
+; Clean up alist hacking et cetera.
+; Declarations.
+; Integrable procedures.
+; New semantics for body of LET-SYNTAX and LETREC-SYNTAX.
+; Copyright 1992 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 5 April 1999.
+
+($$trace "usual")
+
+; The usual macros, adapted from Jonathan's Version 2 implementation.
+; DEFINE is handled primitively, since top-level DEFINE has a side
+; effect on the global syntactic environment, and internal definitions
+; have to be handled specially anyway.
+;
+; Some extensions are noted, as are some optimizations.
+;
+; The LETREC* scope rule is used here to protect these macros against
+; redefinition of LAMBDA etc. The scope rule is changed to LETREC at
+; the end of this file.
+
+(define-syntax-scope 'letrec*)
+
+(for-each (lambda (form)
+ (macro-expand form))
+ '(
+
+; Named LET is defined later, after LETREC has been defined.
+
+(define-syntax let
+ (syntax-rules ()
+ ((let ((?name ?val) ...) ?body ?body1 ...)
+ ((lambda (?name ...) ?body ?body1 ...) ?val ...))))
+
+(define-syntax let*
+ (syntax-rules ()
+ ((let* () ?body ?body1 ...)
+ (let () ?body ?body1 ...))
+ ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...)
+ (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...)))))
+
+; Internal definitions have to be handled specially anyway,
+; so we might as well rely on them here.
+
+(define-syntax letrec
+ (syntax-rules (lambda quote)
+ ((letrec ((?name ?val) ...) ?body ?body2 ...)
+ ((lambda ()
+ (define ?name ?val) ...
+ ?body ?body2 ...)))))
+
+; This definition of named LET extends the prior definition of LET.
+; The first rule is non-circular, thanks to the LET* scope that is
+; specified for this use of DEFINE-SYNTAX.
+
+(define-syntax let let*
+ (syntax-rules ()
+ ((let (?bindings ...) . ?body)
+ (let (?bindings ...) . ?body))
+ ((let ?tag ((?name ?val) ...) ?body ?body1 ...)
+ (let ((?name ?val) ...)
+ (letrec ((?tag (lambda (?name ...) ?body ?body1 ...)))
+ (?tag ?name ...))))))
+
+(define-syntax and
+ (syntax-rules ()
+ ((and) #t)
+ ((and ?e) ?e)
+ ((and ?e1 ?e2 ?e3 ...)
+ (if ?e1 (and ?e2 ?e3 ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((or) #f)
+ ((or ?e) ?e)
+ ((or ?e1 ?e2 ?e3 ...)
+ (let ((temp ?e1))
+ (if temp temp (or ?e2 ?e3 ...))))))
+
+(define-syntax cond
+ (syntax-rules (else =>)
+ ((cond (else ?result ?result2 ...))
+ (begin ?result ?result2 ...))
+
+ ((cond (?test => ?result))
+ (let ((temp ?test))
+ (if temp (?result temp))))
+
+ ((cond (?test)) ?test)
+
+ ((cond (?test ?result ?result2 ...))
+ (if ?test (begin ?result ?result2 ...)))
+
+ ((cond (?test => ?result) ?clause ?clause2 ...)
+ (let ((temp ?test))
+ (if temp (?result temp) (cond ?clause ?clause2 ...))))
+
+ ((cond (?test) ?clause ?clause2 ...)
+ (or ?test (cond ?clause ?clause2 ...)))
+
+ ((cond (?test ?result ?result2 ...)
+ ?clause ?clause2 ...)
+ (if ?test
+ (begin ?result ?result2 ...)
+ (cond ?clause ?clause2 ...)))))
+
+; The R4RS says a <step> may be omitted.
+; That's a good excuse for a macro-defining macro that uses LETREC-SYNTAX
+; and the ... escape.
+
+(define-syntax do
+ (syntax-rules ()
+ ((do (?bindings0 ...) (?test) ?body0 ...)
+ (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...))
+ ((do (?bindings0 ...) ?clause0 ?body0 ...)
+ (letrec-syntax
+ ((do-aux
+ (... (syntax-rules ()
+ ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...)
+ (letrec ((loop (lambda (?name ...)
+ (cond ?clause
+ (else
+ (begin #t ?body ...)
+ (loop ?step ...))))))
+ (loop ?init ...)))
+ ((do-aux ((?name ?init ?step) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?step))
+ ?clause
+ ?body ...))
+ ((do-aux ((?name ?init) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?name))
+ ?clause
+ ?body ...))))))
+ (do-aux (?bindings0 ...) () ?clause0 ?body0 ...)))))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((delay ?e) (.make-promise (lambda () ?e)))))
+
+; Another use of LETREC-SYNTAX and the escape extension.
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case ?e1 (else ?body ?body2 ...))
+ (begin ?e1 ?body ?body2 ...))
+ ((case ?e1 (?z ?body ?body2 ...))
+ (if (memv ?e1 '?z) (begin ?body ?body2 ...)))
+ ((case ?e1 ?clause1 ?clause2 ?clause3 ...)
+ (letrec-syntax
+ ((case-aux
+ (... (syntax-rules (else)
+ ((case-aux ?temp (else ?body ?body2 ...))
+ (begin ?body ?body2 ...))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...))
+ (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...)))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...)
+ (if (memv ?temp '(?z ...))
+ (begin ?body ?body2 ...)
+ (case-aux ?temp ?c1 ?c2 ...)))
+ ; a popular extension
+ ((case-aux ?temp (?z ?body ...) ?c1 ...)
+ (case-aux ?temp ((?z) ?body ...) ?c1 ...))))))
+ (let ((temp ?e1))
+ (case-aux temp ?clause1 ?clause2 ?clause3 ...))))))
+
+; A complete implementation of quasiquote, obtained by translating
+; Jonathan Rees's implementation that was posted to RRRS-AUTHORS
+; on 22 December 1986.
+; Unfortunately, the use of LETREC scope means that it is vulnerable
+; to top-level redefinitions of QUOTE etc. That could be fixed, but
+; it has hair enough already.
+
+(begin
+
+ (define-syntax .finalize-quasiquote letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.finalize-quasiquote quote ?arg ?return)
+ (.interpret-continuation ?return (quote ?arg)))
+ ((.finalize-quasiquote unquote ?arg ?return)
+ (.interpret-continuation ?return ?arg))
+ ((.finalize-quasiquote unquote-splicing ?arg ?return)
+ (syntax-error ",@ in illegal context" ?arg))
+ ((.finalize-quasiquote ?mode ?arg ?return)
+ (.interpret-continuation ?return (?mode . ?arg)))))
+
+ ; The first two "arguments" to .descend-quasiquote and to
+ ; .descend-quasiquote-pair are always identical.
+
+ (define-syntax .descend-quasiquote letrec
+ (syntax-rules (quasiquote unquote unquote-splicing)
+ ((.descend-quasiquote `?y ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x (?level) ?return))
+ ((.descend-quasiquote ,?y ?x () ?return)
+ (.interpret-continuation ?return unquote ?y))
+ ((.descend-quasiquote ,?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote ,@?y ?x () ?return)
+ (.interpret-continuation ?return unquote-splicing ?y))
+ ((.descend-quasiquote ,@?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote (?y . ?z) ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote-vector ?x ?x ?level ?return))
+ ((.descend-quasiquote ?y ?x ?level ?return)
+ (.interpret-continuation ?return quote ?x))))
+
+ (define-syntax .descend-quasiquote-pair letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return)
+ (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return)))))
+
+ (define-syntax .descend-quasiquote-vector letrec
+ (syntax-rules (quote)
+ ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return)))))
+
+ ; Representations for continuations used here.
+ ; Continuation types 0, 1, 2, and 6 take a mode and an expression.
+ ; Continuation types -1, 3, 4, 5, and 7 take just an expression.
+ ;
+ ; (-1)
+ ; means no continuation
+ ; (0)
+ ; means to call .finalize-quasiquote with no further continuation
+ ; (1 ?cdrx ?x ?level ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-pair
+ ; (2 ?car-mode ?car-arg ?x ?return)
+ ; means a return from the second call to .descend-quasiquote in
+ ; in Jonathan's code for .descend-quasiquote-pair
+ ; (3 ?car-arg ?return)
+ ; means take the result and return an append of ?car-arg with it
+ ; (4 ?cdr-mode ?cdr-arg ?return)
+ ; means take the result and call .finalize-quasiquote on ?cdr-mode
+ ; and ?cdr-arg with a continuation of type 5
+ ; (5 ?car-result ?return)
+ ; means take the result and return a cons of ?car-result onto it
+ ; (6 ?x ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-vector
+ ; (7 ?return)
+ ; means take the result and return a call of list->vector on it
+
+ (define-syntax .interpret-continuation letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.interpret-continuation (-1) ?e) ?e)
+ ((.interpret-continuation (0) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (-1)))
+ ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg)
+ (.descend-quasiquote ?cdrx
+ ?cdrx
+ ?level
+ (2 ?car-mode ?car-arg ?x ?return)))
+ ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ())
+ (.interpret-continuation ?return unquote ?car-arg))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return)))
+ ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return)))
+
+ ((.interpret-continuation (3 ?car-arg ?return) ?e)
+ (.interpret-continuation ?return append (?car-arg ?e)))
+ ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return)))
+ ((.interpret-continuation (5 ?e1 ?return) ?e2)
+ (.interpret-continuation ?return .cons (?e1 ?e2)))
+ ((.interpret-continuation (6 ?x ?return) quote ?arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (6 ?x ?return) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (7 ?return)))
+ ((.interpret-continuation (7 ?return) ?e)
+ (.interpret-continuation ?return .list->vector (?e)))))
+
+ (define-syntax quasiquote letrec
+ (syntax-rules ()
+ ((quasiquote ?x)
+ (.descend-quasiquote ?x ?x () (0)))))
+ )
+
+(define-syntax let*-syntax
+ (syntax-rules ()
+ ((let*-syntax () ?body)
+ (let-syntax () ?body))
+ ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body)
+ (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))
+
+
+ ))
+
+(define-syntax-scope 'letrec)
+
+(define standard-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-standard-syntactic-environment)
+ (syntactic-copy standard-syntactic-environment))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 25 April 1999
+;
+; Given an expression in the subset of Scheme used as an intermediate language
+; by Twobit, returns a newly allocated copy of the expression in which the
+; local variables have been renamed and the referencing information has been
+; recomputed.
+
+(define (copy-exp exp)
+
+ (define special-names (cons name:IGNORED argument-registers))
+
+ (define original-names (make-hashtable symbol-hash assq))
+
+ (define renaming-counter 0)
+
+ (define (rename-vars vars)
+ (let ((rename (make-rename-procedure)))
+ (map (lambda (var)
+ (cond ((memq var special-names)
+ var)
+ ((hashtable-get original-names var)
+ (rename var))
+ (else
+ (hashtable-put! original-names var #t)
+ var)))
+ vars)))
+
+ (define (rename-formals formals newnames)
+ (cond ((null? formals) '())
+ ((symbol? formals) (car newnames))
+ ((memq (car formals) special-names)
+ (cons (car formals)
+ (rename-formals (cdr formals)
+ (cdr newnames))))
+ (else (cons (car newnames)
+ (rename-formals (cdr formals)
+ (cdr newnames))))))
+
+ ; Environments that map symbols to arbitrary information.
+ ; This data type is mutable, and uses the shallow binding technique.
+
+ (define (make-env) (make-hashtable symbol-hash assq))
+
+ (define (env-bind! env sym info)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cons info stack))))
+
+ (define (env-unbind! env sym)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cdr stack))))
+
+ (define (env-lookup env sym default)
+ (let ((stack (hashtable-get env sym)))
+ (if stack
+ (car stack)
+ default)))
+
+ (define (env-bind-multiple! env symbols infos)
+ (for-each (lambda (sym info) (env-bind! env sym info))
+ symbols
+ infos))
+
+ (define (env-unbind-multiple! env symbols)
+ (for-each (lambda (sym) (env-unbind! env sym))
+ symbols))
+
+ ;
+
+ (define (lexical-lookup R-table name)
+ (assq name R-table))
+
+ (define (copy exp env notepad R-table)
+ (cond ((constant? exp) exp)
+ ((lambda? exp)
+ (let* ((bvl (make-null-terminated (lambda.args exp)))
+ (newnames (rename-vars bvl))
+ (procnames (map def.lhs (lambda.defs exp)))
+ (newprocnames (rename-vars procnames))
+ (refinfo (map (lambda (var)
+ (make-R-entry var '() '() '()))
+ (append newnames newprocnames)))
+ (newexp
+ (make-lambda
+ (rename-formals (lambda.args exp) newnames)
+ '()
+ refinfo
+ '()
+ '()
+ (lambda.decls exp)
+ (lambda.doc exp)
+ (lambda.body exp))))
+ (env-bind-multiple! env procnames newprocnames)
+ (env-bind-multiple! env bvl newnames)
+ (for-each (lambda (entry)
+ (env-bind! R-table (R-entry.name entry) entry))
+ refinfo)
+ (notepad-lambda-add! notepad newexp)
+ (let ((newnotepad (make-notepad notepad)))
+ (for-each (lambda (name rhs)
+ (lambda.defs-set!
+ newexp
+ (cons (make-definition
+ name
+ (copy rhs env newnotepad R-table))
+ (lambda.defs newexp))))
+ (reverse newprocnames)
+ (map def.rhs
+ (reverse (lambda.defs exp))))
+ (lambda.body-set!
+ newexp
+ (copy (lambda.body exp) env newnotepad R-table))
+ (lambda.F-set! newexp (notepad-free-variables newnotepad))
+ (lambda.G-set! newexp (notepad-captured-variables newnotepad)))
+ (env-unbind-multiple! env procnames)
+ (env-unbind-multiple! env bvl)
+ (for-each (lambda (entry)
+ (env-unbind! R-table (R-entry.name entry)))
+ refinfo)
+ newexp))
+ ((assignment? exp)
+ (let* ((oldname (assignment.lhs exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp
+ (make-assignment name
+ (copy (assignment.rhs exp) env notepad R-table))))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.assignments-set!
+ varinfo
+ (cons newexp (R-entry.assignments varinfo))))
+ newexp))
+ ((conditional? exp)
+ (make-conditional (copy (if.test exp) env notepad R-table)
+ (copy (if.then exp) env notepad R-table)
+ (copy (if.else exp) env notepad R-table)))
+ ((begin? exp)
+ (make-begin (map (lambda (exp) (copy exp env notepad R-table))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (let* ((oldname (variable.name exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp (make-variable name)))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.references-set!
+ varinfo
+ (cons newexp (R-entry.references varinfo))))
+ newexp))
+ ((call? exp)
+ (let ((newexp (make-call (copy (call.proc exp) env notepad R-table)
+ (map (lambda (exp)
+ (copy exp env notepad R-table))
+ (call.args exp)))))
+ (if (variable? (call.proc newexp))
+ (let ((varinfo
+ (env-lookup R-table
+ (variable.name
+ (call.proc newexp))
+ #f)))
+ (if varinfo
+ (R-entry.calls-set!
+ varinfo
+ (cons newexp (R-entry.calls varinfo))))))
+ (if (lambda? (call.proc newexp))
+ (notepad-nonescaping-add! notepad (call.proc newexp)))
+ newexp))
+ (else ???)))
+
+ (copy exp (make-env) (make-notepad #f) (make-env)))
+
+; For debugging.
+; Given an expression, traverses the expression to confirm
+; that the referencing invariants are correct.
+
+(define (check-referencing-invariants exp . flags)
+
+ (let ((check-free-variables? (memq 'free flags))
+ (check-referencing? (memq 'reference flags))
+ (first-violation? #t))
+
+ ; env is the list of enclosing lambda expressions,
+ ; beginning with the innermost.
+
+ (define (check exp env)
+ (cond ((constant? exp) (return exp #t))
+ ((lambda? exp)
+ (let ((env (cons exp env)))
+ (return exp
+ (and (every? (lambda (exp)
+ (check exp env))
+ (map def.rhs (lambda.defs exp)))
+ (check (lambda.body exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (subset? (difference
+ (lambda.F exp)
+ (make-null-terminated
+ (lambda.args exp)))
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((env (cons exp env))
+ (R (lambda.R exp)))
+ (every? (lambda (formal)
+ (or (ignored? formal)
+ (R-entry R formal)))
+ (make-null-terminated
+ (lambda.args exp))))
+ #t)))))
+ ((variable? exp)
+ (return exp
+ (and (if (and check-free-variables?
+ (not (null? env)))
+ (memq (variable.name exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (variable.name exp))))
+ (if Rinfo
+ (memq exp (R-entry.references Rinfo))
+ #t))
+ #t))))
+ ((assignment? exp)
+ (return exp
+ (and (check (assignment.rhs exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (memq (assignment.lhs exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (assignment.lhs exp))))
+ (if Rinfo
+ (memq exp (R-entry.assignments Rinfo))
+ #t))
+ #t))))
+ ((conditional? exp)
+ (return exp
+ (and (check (if.test exp) env)
+ (check (if.then exp) env)
+ (check (if.else exp) env))))
+ ((begin? exp)
+ (return exp
+ (every? (lambda (exp) (check exp env))
+ (begin.exprs exp))))
+ ((call? exp)
+ (return exp
+ (and (check (call.proc exp) env)
+ (every? (lambda (exp) (check exp env))
+ (call.args exp))
+ (if (and check-referencing?
+ (variable? (call.proc exp)))
+ (let ((Rinfo (lookup env
+ (variable.name
+ (call.proc exp)))))
+ (if Rinfo
+ (memq exp (R-entry.calls Rinfo))
+ #t))
+ #t))))
+ (else ???)))
+
+ (define (return exp flag)
+ (cond (flag
+ #t)
+ (first-violation?
+ (set! first-violation? #f)
+ (display "Violation of referencing invariants")
+ (newline)
+ (pretty-print (make-readable exp))
+ #f)
+ (else (pretty-print (make-readable exp))
+ #f)))
+
+ (define (lookup env I)
+ (if (null? env)
+ #f
+ (let ((Rinfo (R-entry (lambda.R (car env)) I)))
+ (or Rinfo
+ (lookup (cdr env) I)))))
+
+ (if (null? flags)
+ (begin (set! check-free-variables? #t)
+ (set! check-referencing? #t)))
+
+ (check exp '())))
+
+
+; Calculating the free variable information for an expression
+; as output by pass 2. This should be faster than computing both
+; the free variables and the referencing information.
+
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-set '()))
+
+ (define (singleton x) (list x))
+
+ (define (union2 x y) (union x y))
+ (define (union3 x y z) (union x y z))
+
+ (define (set->list set) set)
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (free exp))
+
+; As above, but representing sets as hashtrees.
+; This is commented out because it is much slower than the implementation
+; above. Because the set of free variables is represented as a list
+; within a lambda expression, this implementation must convert the
+; representation for every lambda expression, which is quite expensive
+; for A-normal form.
+
+(begin
+'
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-hashtree symbol-hash assq))
+
+ (define (singleton x)
+ (hashtree-put empty-set x #t))
+
+ (define (make-set values)
+ (if (null? values)
+ empty-set
+ (hashtree-put (make-set (cdr values))
+ (car values)
+ #t)))
+
+ (define (union2 x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-put x key #t)))
+ y)
+ x)
+
+ (define (union3 x y z)
+ (union2 (union2 x y) z))
+
+ (define (apply-union sets)
+ (cond ((null? sets)
+ (make-set '()))
+ ((null? (cdr sets))
+ (car sets))
+ (else
+ (union2 (car sets)
+ (apply-union (cdr sets))))))
+
+ (define (difference x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-remove x key)))
+ y)
+ x)
+
+ (define (set->list set)
+ (hashtree-map (lambda (sym val) sym) set))
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (hashtree-map (lambda (sym val) sym)
+ (free exp)))
+#t); Copyright 1991 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 24 April 1999
+;
+; First pass of the Twobit compiler:
+; macro expansion, syntax checking, alpha conversion,
+; preliminary annotation.
+;
+; The input to this pass is a Scheme definition or expression.
+; The output is an expression in the subset of Scheme described
+; by the following grammar, where the output satisfies certain
+; additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the output:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+; * F and G are garbage.
+
+($$trace "pass1")
+
+(define source-file-name #f)
+(define source-file-position #f)
+
+(define pass1-block-compiling? #f)
+(define pass1-block-assignments '())
+(define pass1-block-inlines '())
+
+(define (pass1 def-or-exp . rest)
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (set! renaming-counter 0)
+ (macro-expand def-or-exp))
+
+; Compiles a whole sequence of top-level forms on the assumption
+; that no variable that is defined by a form in the sequence is
+; ever defined or assigned outside of the sequence.
+;
+; This is a crock in three parts:
+;
+; 1. Macro-expand each form and record assignments.
+; 2. Find the top-level variables that are defined but not
+; assigned, give them local names, generate a DEFINE-INLINE
+; for each of the top-level procedures, and macro-expand
+; each form again.
+; 3. Wrap the whole mess in an appropriate LET and recompute
+; the referencing information by copying it.
+;
+; Note that macros get expanded twice, and that all DEFINE-SYNTAX
+; macros are considered local to the forms.
+
+; FIXME: Need to turn off warning messages.
+
+(define (pass1-block forms . rest)
+
+ (define (part1)
+ (set! pass1-block-compiling? #t)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings))
+ (defined '()))
+ (define (make-toplevel-definition id exp)
+ (cond ((memq id defined)
+ (set! pass1-block-assignments
+ (cons id pass1-block-assignments)))
+ ((or (constant? exp)
+ (and (lambda? exp)
+ (list? (lambda.args exp))))
+ (set! defined (cons id defined))))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+ (benchmark-mode #f)
+ (issue-warnings #f)
+ (for-each (lambda (form)
+ (desugar-definitions form
+ global-syntactic-environment
+ make-toplevel-definition))
+ forms)
+ (set! global-syntactic-environment env0)
+ (benchmark-mode bmode)
+ (issue-warnings wmode)
+ (part2 (filter (lambda (id)
+ (not (memq id pass1-block-assignments)))
+ (reverse defined)))))
+
+ (define (part2 defined)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let* ((rename (make-rename-procedure))
+ (alist (map (lambda (id)
+ (cons id (rename id)))
+ defined))
+ (definitions0 '()) ; for constants
+ (definitions1 '())) ; for lambda expressions
+ (define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (let ((probe (assq id alist)))
+ (if probe
+ (let ((id1 (cdr probe)))
+ (cond ((constant? exp)
+ (set! definitions0
+ (cons (make-assignment id exp)
+ definitions0))
+ (make-constant id))
+ ((lambda? exp)
+ (set! definitions1
+ (cons (make-assignment id1 exp)
+ definitions1))
+ (make-assignment
+ id
+ (make-lambda (lambda.args exp)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (lambda.doc exp)
+ (make-call
+ (make-variable id1)
+ (map make-variable
+ (lambda.args exp))))))
+ (else
+ (m-error "Inconsistent macro expansion"
+ (make-readable exp)))))
+ (make-assignment id exp))))
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings)))
+ (issue-warnings #f)
+ (for-each (lambda (pair)
+ (let ((id0 (car pair))
+ (id1 (cdr pair)))
+ (syntactic-bind-globally!
+ id0
+ (make-inline-denotation
+ id0
+ (lambda (exp rename compare)
+ ; Deliberately non-hygienic!
+ (cons id1 (cdr exp)))
+ global-syntactic-environment))
+ (set! pass1-block-inlines
+ (cons id0 pass1-block-inlines))))
+ alist)
+ (benchmark-mode #f)
+ (issue-warnings wmode)
+ (let ((forms
+ (do ((forms forms (cdr forms))
+ (newforms '()
+ (cons (desugar-definitions
+ (car forms)
+ global-syntactic-environment
+ make-toplevel-definition)
+ newforms)))
+ ((null? forms)
+ (reverse newforms)))))
+ (benchmark-mode bmode)
+ (set! global-syntactic-environment env0)
+ (part3 alist definitions0 definitions1 forms)))))
+
+ (define (part3 alist definitions0 definitions1 forms)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (let* ((constnames0 (map assignment.lhs definitions0))
+ (constnames1 (map (lambda (id0)
+ (cdr (assq id0 alist)))
+ constnames0))
+ (procnames1 (map assignment.lhs definitions1)))
+ (copy-exp
+ (make-call
+ (make-lambda
+ constnames1
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin
+ (list
+ (make-begin
+ (cons (make-constant #f)
+ (reverse
+ (map (lambda (id)
+ (make-assignment id (make-variable (cdr (assq id alist)))))
+ constnames0))))
+ (make-call
+ (make-lambda
+ constnames0
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-call
+ (make-lambda
+ (map assignment.lhs definitions1)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin (cons (make-constant #f)
+ (append definitions1 forms))))
+ (map (lambda (ignored) (make-unspecified))
+ definitions1)))
+ (map make-variable constnames1))
+ )))
+ (map assignment.rhs definitions0)))))
+
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (part1))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Support for intraprocedural value numbering:
+; set of available expressions
+; miscellaneous
+;
+; The set of available expressions is represented as a
+; mutable abstract data type Available with these operations:
+;
+; make-available-table: -> Available
+; copy-available-table: Available -> Available
+; available-expression: Available x Expr -> (symbol + {#f})
+; available-variable: Available x symbol -> Expr
+; available-extend!: Available x symbol x Expr x Killer ->
+; available-kill!: Available x Killer ->
+;
+; where Expr is of the form
+;
+; Expr --> W
+; | (W_0 W_1 ...)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; and Killer is a fixnum, as defined later in this file.
+;
+; (make-available-table)
+; returns an empty table of available expressions.
+; (copy-available-table available)
+; copies the given table.
+; (available-expression available E)
+; returns the name of E if it is available in the table, else #f.
+; (available-variable available T)
+; returns a constant or variable to use in place of T, else #f.
+; (available-extend! available T E K)
+; adds the binding (T E) to the table, with Killer K.
+; If E is a variable and this binding is never killed, then copy
+; propagation will replace uses of T by uses of E; otherwise
+; commoning will replace uses of E by uses of T, until the
+; binding is killed.
+; (available-kill! available K)
+; removes all bindings whose Killer intersects K.
+;
+; (available-extend! available T E K) is very fast if the previous
+; operation on the table was (available-expression available E).
+
+; Implementation.
+;
+; Quick and dirty.
+; The available expressions are represented as a vector of 2 association
+; lists. The first list is used for common subexpression elimination,
+; and the second is used for copy and constant propagation.
+;
+; Each element of the first list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (E T K).
+;
+; Each element of the second list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (T E K).
+; The expression E will be a constant or variable.
+
+(define (make-available-table)
+ (vector '() '()))
+
+(define (copy-available-table available)
+ (vector (vector-ref available 0)
+ (vector-ref available 1)))
+
+(define (available-expression available E)
+ (let ((binding (assoc E (vector-ref available 0))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-variable available T)
+ (let ((binding (assq T (vector-ref available 1))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-extend! available T E K)
+ (cond ((constant? E)
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ ((and (variable? E)
+ (eq? K available:killer:none))
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ (else
+ (vector-set! available
+ 0
+ (cons (list E T K)
+ (vector-ref available 0))))))
+
+(define (available-kill! available K)
+ (vector-set! available
+ 0
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 0)))
+ (vector-set! available
+ 1
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 1))))
+
+(define (available-intersect! available0 available1 available2)
+ (vector-set! available0
+ 0
+ (intersection (vector-ref available1 0)
+ (vector-ref available2 0)))
+ (vector-set! available0
+ 1
+ (intersection (vector-ref available1 1)
+ (vector-ref available2 1))))
+
+; The Killer concrete data type, represented as a fixnum.
+;
+; The set of side effects that can kill an available expression
+; are a subset of
+;
+; assignments to global variables
+; uses of SET-CAR!
+; uses of SET-CDR!
+; uses of STRING-SET!
+; uses of VECTOR-SET!
+;
+; This list is not complete. If we were trying to perform common
+; subexpression elimination on calls to PEEK-CHAR, for example,
+; then those calls would be killed by reads.
+
+(define available:killer:globals 2)
+(define available:killer:car 4)
+(define available:killer:cdr 8)
+(define available:killer:string 16) ; also bytevectors etc
+(define available:killer:vector 32) ; also structures etc
+(define available:killer:cell 64)
+(define available:killer:io 128)
+(define available:killer:none 0) ; none of the above
+(define available:killer:all 1022) ; all of the above
+
+(define available:killer:immortal 0) ; never killed
+(define available:killer:dead 1023) ; never available
+
+
+
+(define (available:killer-combine k1 k2)
+ (logior k1 k2))
+
+; Miscellaneous.
+
+; A simple lambda expression has no internal definitions at its head
+; and no declarations aside from A-normal form.
+
+(define (simple-lambda? L)
+ (and (null? (lambda.defs L))
+ (every? (lambda (decl)
+ (eq? decl A-normal-form-declaration))
+ (lambda.decls L))))
+
+; A real call is a call whose procedure expression is
+; neither a lambda expression nor a primop.
+
+(define (real-call? E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (not (lambda? proc))
+ (or (not (variable? proc))
+ (let ((f (variable.name proc)))
+ (or (not (integrate-usual-procedures))
+ (not (prim-entry f)))))))))
+
+(define (prim-call E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc))))))
+
+(define (no-side-effects? E)
+ (or (constant? E)
+ (variable? E)
+ (lambda? E)
+ (and (conditional? E)
+ (no-side-effects? (if.test E))
+ (no-side-effects? (if.then E))
+ (no-side-effects? (if.else E)))
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (let ((entry (prim-entry (variable.name proc))))
+ (and entry
+ (not (eq? available:killer:dead
+ (prim-lives-until entry))))))))))
+
+; Given a local variable, the expression within its scope, and
+; a list of local variables that are known to be used only once,
+; returns #t if the variable is used only once.
+;
+; The purpose of this routine is to recognize temporaries that
+; may once have had two or more uses because of CSE, but now have
+; only one use because of further CSE followed by dead code elimination.
+
+(define (temporary-used-once? T E used-once)
+ (cond ((call? E)
+ (let ((proc (call.proc E))
+ (args (call.args E)))
+ (or (and (lambda? proc)
+ (not (memq T (lambda.F proc)))
+ (and (pair? args)
+ (null? (cdr args))
+ (temporary-used-once? T (car args) used-once)))
+ (do ((exprs (cons proc (call.args E))
+ (cdr exprs))
+ (n 0
+ (let ((exp (car exprs)))
+ (cond ((constant? exp)
+ n)
+ ((variable? exp)
+ (if (eq? T (variable.name exp))
+ (+ n 1)
+ n))
+ (else
+ ; Terminate the loop and return #f.
+ 2)))))
+ ((or (null? exprs)
+ (> n 1))
+ (= n 1))))))
+ (else
+ (memq T used-once))))
+
+; Register bindings.
+
+(define (make-regbinding lhs rhs use)
+ (list lhs rhs use))
+
+(define (regbinding.lhs x) (car x))
+(define (regbinding.rhs x) (cadr x))
+(define (regbinding.use x) (caddr x))
+
+; Given a list of register bindings, an expression E and its free variables F,
+; returns two values:
+; E with the register bindings wrapped around it
+; the free variables of the wrapped expression
+
+(define (wrap-with-register-bindings regbindings E F)
+ (if (null? regbindings)
+ (values E F)
+ (let* ((regbinding (car regbindings))
+ (R (regbinding.lhs regbinding))
+ (x (regbinding.rhs regbinding)))
+ (wrap-with-register-bindings
+ (cdr regbindings)
+ (make-call (make-lambda (list R)
+ '()
+ '()
+ F
+ F
+ (list A-normal-form-declaration)
+ #f
+ E)
+ (list (make-variable x)))
+ (union (list x)
+ (difference F (list R)))))))
+
+; Returns two values:
+; the subset of regbindings that have x as their right hand side
+; the rest of regbindings
+
+(define (register-bindings regbindings x)
+ (define (loop regbindings to-x others)
+ (cond ((null? regbindings)
+ (values to-x others))
+ ((eq? x (regbinding.rhs (car regbindings)))
+ (loop (cdr regbindings)
+ (cons (car regbindings) to-x)
+ others))
+ (else
+ (loop (cdr regbindings)
+ to-x
+ (cons (car regbindings) others)))))
+ (loop regbindings '() '()))
+
+; This procedure is called when the compiler can tell that an assertion
+; is never true.
+
+(define (declaration-error E)
+ (if (issue-warnings)
+ (begin (display "WARNING: Assertion is false: ")
+ (write (make-readable E #t))
+ (newline))))
+; Representations, which form a subtype hierarchy.
+;
+; <rep> ::= <fixnum> | (<fixnum> <datum> ...)
+;
+; (<rep> <datum> ...) is a subtype of <rep>, but the non-fixnum
+; representations are otherwise interpreted by arbitrary code.
+
+(define *nreps* 0)
+(define *rep-encodings* '())
+(define *rep-decodings* '())
+(define *rep-subtypes* '())
+(define *rep-joins* (make-bytevector 0))
+(define *rep-meets* (make-bytevector 0))
+(define *rep-joins-special* '#())
+(define *rep-meets-special* '#())
+
+(define (representation-error msg . stuff)
+ (apply error
+ (if (string? msg)
+ (string-append "Bug in flow analysis: " msg)
+ msg)
+ stuff))
+
+(define (symbol->rep sym)
+ (let ((probe (assq sym *rep-encodings*)))
+ (if probe
+ (cdr probe)
+ (let ((rep *nreps*))
+ (set! *nreps* (+ *nreps* 1))
+ (if (> *nreps* 255)
+ (representation-error "Too many representation types"))
+ (set! *rep-encodings*
+ (cons (cons sym rep)
+ *rep-encodings*))
+ (set! *rep-decodings*
+ (cons (cons rep sym)
+ *rep-decodings*))
+ rep))))
+
+(define (rep->symbol rep)
+ (if (pair? rep)
+ (cons (rep->symbol (car rep)) (cdr rep))
+ (let ((probe (assv rep *rep-decodings*)))
+ (if probe
+ (cdr probe)
+ 'unknown))))
+
+(define (representation-table table)
+ (map (lambda (row)
+ (map (lambda (x)
+ (if (list? x)
+ (map symbol->rep x)
+ x))
+ row))
+ table))
+
+; DEFINE-SUBTYPE is how representation types are defined.
+
+(define (define-subtype sym1 sym2)
+ (let* ((rep2 (symbol->rep sym2))
+ (rep1 (symbol->rep sym1)))
+ (set! *rep-subtypes*
+ (cons (cons rep1 rep2)
+ *rep-subtypes*))
+ sym1))
+
+; COMPUTE-TYPE-STRUCTURE! must be called before DEFINE-INTERSECTION.
+
+(define (define-intersection sym1 sym2 sym3)
+ (let ((rep1 (symbol->rep sym1))
+ (rep2 (symbol->rep sym2))
+ (rep3 (symbol->rep sym3)))
+ (representation-aset! *rep-meets* rep1 rep2 rep3)
+ (representation-aset! *rep-meets* rep2 rep1 rep3)))
+
+;
+
+(define (representation-aref bv i j)
+ (bytevector-ref bv (+ (* *nreps* i) j)))
+
+(define (representation-aset! bv i j x)
+ (bytevector-set! bv (+ (* *nreps* i) j) x))
+
+(define (compute-unions!)
+
+ ; Always define a bottom element.
+
+ (for-each (lambda (sym)
+ (define-subtype 'bottom sym))
+ (map car *rep-encodings*))
+
+ (let* ((debugging? #f)
+ (n *nreps*)
+ (n^2 (* n n))
+ (matrix (make-bytevector n^2)))
+
+ ; This code assumes there will always be a top element.
+
+ (define (lub rep1 rep2 subtype?)
+ (do ((i 0 (+ i 1))
+ (bounds '()
+ (if (and (subtype? rep1 i)
+ (subtype? rep2 i))
+ (cons i bounds)
+ bounds)))
+ ((= i n)
+ (car (twobit-sort subtype? bounds)))))
+
+ (define (join i j)
+ (lub i j (lambda (rep1 rep2)
+ (= 1 (representation-aref matrix rep1 rep2)))))
+
+ (define (compute-transitive-closure!)
+ (let ((changed? #f))
+ (define (loop)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((k 0 (+ k 1)))
+ ((= k n))
+ (do ((j 0 (+ j 1))
+ (sum 0
+ (logior sum
+ (logand
+ (representation-aref matrix i j)
+ (representation-aref matrix j k)))))
+ ((= j n)
+ (if (> sum 0)
+ (let ((x (representation-aref matrix i k)))
+ (if (zero? x)
+ (begin
+ (set! changed? #t)
+ (representation-aset! matrix i k 1)))))))))
+ (if changed?
+ (begin (set! changed? #f)
+ (loop))))
+ (loop)))
+
+ (define (compute-joins!)
+ (let ((default (lambda (x y)
+ (error "Compiler bug: special meet or join" x y))))
+ (set! *rep-joins-special* (make-vector n default))
+ (set! *rep-meets-special* (make-vector n default)))
+ (set! *rep-joins* (make-bytevector n^2))
+ (set! *rep-meets* (make-bytevector n^2))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-joins*
+ i
+ j
+ (join i j)))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! matrix i j 0))
+ (representation-aset! matrix i i 1))
+ (for-each (lambda (subtype)
+ (let ((rep1 (car subtype))
+ (rep2 (cdr subtype)))
+ (representation-aset! matrix rep1 rep2 1)))
+ *rep-subtypes*)
+ (compute-transitive-closure!)
+ (if debugging?
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (write-char #\space)
+ (write (representation-aref matrix i j)))
+ (newline)))
+ (compute-joins!)
+ (set! *rep-subtypes* '())))
+
+; Intersections are not dual to unions because a conservative analysis
+; must always err on the side of the larger subtype.
+; COMPUTE-UNIONS! must be called before COMPUTE-INTERSECTIONS!.
+
+(define (compute-intersections!)
+ (let ((n *nreps*))
+
+ (define (meet i j)
+ (let ((k (representation-union i j)))
+ (if (= i k)
+ j
+ i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-meets*
+ i
+ j
+ (meet i j))))))
+
+(define (compute-type-structure!)
+ (compute-unions!)
+ (compute-intersections!))
+
+(define (representation-subtype? rep1 rep2)
+ (equal? rep2 (representation-union rep1 rep2)))
+
+(define (representation-union rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-joins* rep1 rep2)
+ (representation-union rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-union (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-joins-special* r1) rep1 rep2)
+ (representation-union r1 r2))))))
+
+(define (representation-intersection rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-meets* rep1 rep2)
+ (representation-intersection rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-intersection (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-meets-special* r1) rep1 rep2)
+ (representation-intersection r1 r2))))))
+
+; For debugging.
+
+(define (display-unions-and-intersections)
+ (let* ((column-width 10)
+ (columns/row (quotient 80 column-width)))
+
+ (define (display-symbol sym)
+ (let* ((s (symbol->string sym))
+ (n (string-length s)))
+ (if (< n column-width)
+ (begin (display s)
+ (display (make-string (- column-width n) #\space)))
+ (begin (display (substring s 0 (- column-width 1)))
+ (write-char #\space)))))
+
+ ; Display columns i to n.
+
+ (define (display-matrix f i n)
+ (display (make-string column-width #\space))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol i)))
+ (newline)
+ (newline)
+ (do ((k 0 (+ k 1)))
+ ((= k *nreps*))
+ (display-symbol (rep->symbol k))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol (f k i))))
+ (newline))
+ (newline)
+ (newline))
+
+ (display "Unions:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-union
+ i
+ (min *nreps* (+ i columns/row))))
+
+ (display "Intersections:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-intersection
+ i
+ (min *nreps* (+ i columns/row))))))
+
+; Operations that can be specialized.
+;
+; Format: (<name> (<arg-rep> ...) <specific-name>)
+
+(define (rep-specific? f rs)
+ (rep-match f rs rep-specific caddr))
+
+; Operations whose result has some specific representation.
+;
+; Format: (<name> (<arg-rep> ...) (<result-rep>))
+
+(define (rep-result? f rs)
+ (rep-match f rs rep-result caaddr))
+
+; Unary predicates that give information about representation.
+;
+; Format: (<name> <rep-if-true> <rep-if-false>)
+
+(define (rep-if-true f rs)
+ (rep-match f rs rep-informing caddr))
+
+(define (rep-if-false f rs)
+ (rep-match f rs rep-informing cadddr))
+
+; Given the name of an integrable primitive,
+; the representations of its arguments,
+; a representation table, and a selector function
+; finds the most type-specific row of the table that matches both
+; the name of the primitive and the representations of its arguments,
+; and returns the result of applying the selector to that row.
+; If no row matches, then REP-MATCH returns #f.
+;
+; FIXME: This should be more efficient, and should prefer the most
+; specific matches.
+
+(define (rep-match f rs table selector)
+ (let ((n (length rs)))
+ (let loop ((entries table))
+ (cond ((null? entries)
+ #f)
+ ((eq? f (car (car entries)))
+ (let ((rs0 (cadr (car entries))))
+ (if (and (= n (length rs0))
+ (every? (lambda (r1+r2)
+ (let ((r1 (car r1+r2))
+ (r2 (cdr r1+r2)))
+ (representation-subtype? r1 r2)))
+ (map cons rs rs0)))
+ (selector (car entries))
+ (loop (cdr entries)))))
+ (else
+ (loop (cdr entries)))))))
+
+; Abstract interpretation with respect to types and constraints.
+; Returns a representation type.
+
+(define (aeval E types constraints)
+ (cond ((call? E)
+ (let ((proc (call.proc E)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (argtypes (map (lambda (E)
+ (aeval E types constraints))
+ (call.args E)))
+ (type (rep-result? op argtypes)))
+ (if type
+ type
+ rep:object))
+ rep:object)))
+ ((variable? E)
+ (representation-typeof (variable.name E) types constraints))
+ ((constant? E)
+ (representation-of-value (constant.value E)))
+ (else
+ rep:object)))
+
+; If x has representation type t0 in the hash table,
+; and some further constraints
+;
+; x = (op y1 ... yn)
+; x : t1
+; ...
+; x : tk
+;
+; then
+;
+; typeof (x) = op (typeof (y1), ..., typeof (yn))
+; & t0 & t1 & ... & tk
+;
+; where & means intersection and op is the abstraction of op.
+;
+; Also if T : true and T = E then E may give information about
+; the types of other variables. Similarly for T : false.
+
+(define (representation-typeof name types constraints)
+ (let ((t0 (hashtable-fetch types name rep:object))
+ (cs (hashtable-fetch (constraints.table constraints) name '())))
+ (define (loop type cs)
+ (if (null? cs)
+ type
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E (constraint.rhs c)))
+ (cond ((constant? E)
+ (loop (representation-intersection type
+ (constant.value E))
+ cs))
+ ((call? E)
+ (loop (representation-intersection
+ type (aeval E types constraints))
+ cs))
+ (else
+ (loop type cs))))))
+ (loop t0 cs)))
+
+; Constraints.
+;
+; The constraints used by this analysis consist of type constraints
+; together with the available expressions used for commoning.
+;
+; (T E K) T = E until killed by an effect in K
+; (T '<rep> K) T : <rep> until killed by an effect in K
+
+(define (make-constraint T E K)
+ (list T E K))
+
+(define (constraint.lhs c)
+ (car c))
+
+(define (constraint.rhs c)
+ (cadr c))
+
+(define (constraint.killer c)
+ (caddr c))
+
+(define (make-type-constraint T type K)
+ (make-constraint T
+ (make-constant type)
+ K))
+
+; If the new constraint is of the form T = E until killed by K,
+; then there shouldn't be any prior constraints.
+;
+; Otherwise the new constraint is of the form T : t until killed by K.
+; Suppose the prior constraints are
+; T = E until killed by K
+; T : t1 until killed by K1
+; ...
+; T : tn until killed by Kn
+;
+; If there exists i such that ti is a subtype of t and Ki a subset of K,
+; then the new constraint adds no new information and should be ignored.
+; Otherwise compute t' = t1 & ... & tn and K' = K1 | ... | Kn, where
+; & indicates intersection and | indicates union.
+; If K = K' then add the new constraint T : t' until killed by K;
+; otherwise add two new constraints:
+; T : t' until killed by K'
+; T : t until killed by K
+
+(define (constraints-add! types constraints new)
+ (let* ((debugging? #f)
+ (T (constraint.lhs new))
+ (E (constraint.rhs new))
+ (K (constraint.killer new))
+ (cs (constraints-for-variable constraints T)))
+
+ (define (loop type K cs newcs)
+ (if (null? cs)
+ (cons (make-type-constraint T type K) newcs)
+ (let* ((c2 (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c2))
+ (K2 (constraint.killer c2)))
+ (if (constant? E2)
+ (let* ((type2 (constant.value E2))
+ (type3 (representation-intersection type type2)))
+ (cond ((eq? type2 type3)
+ (if (= K2 (logand K K2))
+ (append newcs cs)
+ (loop (representation-intersection type type2)
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs))))
+ ((representation-subtype? type type3)
+ (if (= K (logand K K2))
+ (loop type K cs newcs)
+ (loop type K cs (cons c2 newcs))))
+ (else
+ (loop type3
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs)))))
+ (let* ((op (variable.name (call.proc E2)))
+ (args (call.args E2))
+ (argtypes (map (lambda (exp)
+ (aeval exp types constraints))
+ args)))
+ (cond ((representation-subtype? type rep:true)
+ (let ((reps (rep-if-true op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2))))
+ ((representation-subtype? type rep:false)
+ (let ((reps (rep-if-false op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2)))))
+ (loop type K cs (cons c2 newcs)))))))
+
+ (define (record-new-reps! args argtypes reps K2)
+ (if debugging?
+ (begin (write (list (map make-readable args)
+ (map rep->symbol argtypes)
+ (map rep->symbol reps)))
+ (newline)))
+ (for-each (lambda (arg type0 type1)
+ (if (not (representation-subtype? type0 type1))
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ ; FIXME: In this context, a variable
+ ; should always be local so the hashtable
+ ; operation isn't necessary.
+ (if (hashtable-get types name)
+ (constraints-add!
+ types
+ constraints
+ (make-type-constraint
+ name
+ type1
+ (available:killer-combine K K2)))
+ (cerror
+ "Compiler bug: unexpected global: "
+ name))))))
+ args argtypes reps))
+
+ (if (not (zero? K))
+ (constraints-add-killedby! constraints T K))
+
+ (let* ((table (constraints.table constraints))
+ (cs (hashtable-fetch table T '())))
+ (cond ((constant? E)
+ ; It's a type constraint.
+ (let ((type (constant.value E)))
+ (if debugging?
+ (begin (display T)
+ (display " : ")
+ (display (rep->symbol type))
+ (newline)))
+ (let ((cs (loop type K cs '())))
+ (hashtable-put! table T cs)
+ constraints)))
+ (else
+ (if debugging?
+ (begin (display T)
+ (display " = ")
+ (display (make-readable E #t))
+ (newline)))
+ (if (not (null? cs))
+ (begin
+ (display "Compiler bug: ")
+ (write T)
+ (display " has unexpectedly nonempty constraints")
+ (newline)))
+ (hashtable-put! table T (list (list T E K)))
+ constraints)))))
+
+; Sets of constraints.
+;
+; The set of constraints is represented as (<hashtable> <killedby>),
+; where <hashtable> is a hashtable mapping variables to lists of
+; constraints as above, and <killedby> is a vector mapping basic killers
+; to lists of variables that need to be examined for constraints that
+; are killed by that basic killer.
+
+(define number-of-basic-killers
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((> k available:killer:dead)
+ i)))
+
+(define (constraints.table constraints) (car constraints))
+(define (constraints.killed constraints) (cadr constraints))
+
+(define (make-constraints-table)
+ (list (make-hashtable symbol-hash assq)
+ (make-vector number-of-basic-killers '())))
+
+(define (copy-constraints-table constraints)
+ (list (hashtable-copy (constraints.table constraints))
+ (list->vector (vector->list (constraints.killed constraints)))))
+
+(define (constraints-for-variable constraints T)
+ (hashtable-fetch (constraints.table constraints) T '()))
+
+(define (constraints-add-killedby! constraints T K0)
+ (if (not (zero? K0))
+ (let ((v (constraints.killed constraints)))
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand k K0)))
+ (vector-set! v i (cons T (vector-ref v i))))))))
+
+(define (constraints-kill! constraints K)
+ (if (not (zero? K))
+ (let ((table (constraints.table constraints))
+ (killed (constraints.killed constraints)))
+ (define (examine! T)
+ (let ((cs (filter (lambda (c)
+ (zero? (logand (constraint.killer c) K)))
+ (hashtable-fetch table T '()))))
+ (if (null? cs)
+ (hashtable-remove! table T)
+ (hashtable-put! table T cs))))
+ (do ((i 0 (+ i 1))
+ (j 1 (+ j j)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand j K)))
+ (begin (for-each examine! (vector-ref killed i))
+ (vector-set! killed i '())))))))
+
+(define (constraints-intersect! constraints0 constraints1 constraints2)
+ (let ((table0 (constraints.table constraints0))
+ (table1 (constraints.table constraints1))
+ (table2 (constraints.table constraints2)))
+ (if (eq? table0 table1)
+ ; FIXME: Which is more efficient: to update the killed vector,
+ ; or not to update it? Both are safe.
+ (hashtable-for-each (lambda (T cs)
+ (if (not (null? cs))
+ (hashtable-put!
+ table0
+ T
+ (cs-intersect
+ (hashtable-fetch table2 T '())
+ cs))))
+ table1)
+ ; This case shouldn't ever happen, so it can be slow.
+ (begin
+ (constraints-intersect! constraints0 constraints0 constraints1)
+ (constraints-intersect! constraints0 constraints0 constraints2)))))
+
+(define (cs-intersect cs1 cs2)
+ (define (loop cs init rep Krep)
+ (if (null? cs)
+ (values init rep Krep)
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c))
+ (K2 (constraint.killer c)))
+ (cond ((constant? E2)
+ (loop cs
+ init
+ (representation-intersection rep (constant.value E2))
+ (available:killer-combine Krep K2)))
+ ((call? E2)
+ (if init
+ (begin (display "Compiler bug in cs-intersect")
+ (break))
+ (loop cs c rep Krep)))
+ (else
+ (error "Compiler bug in cs-intersect"))))))
+ (call-with-values
+ (lambda ()
+ (loop cs1 #f rep:object available:killer:none))
+ (lambda (c1 rep1 Krep1)
+ (call-with-values
+ (lambda ()
+ (loop cs2 #f rep:object available:killer:none))
+ (lambda (c2 rep2 Krep2)
+ (let ((c (if (equal? c1 c2) c1 #f))
+ (rep (representation-union rep1 rep2))
+ (Krep (available:killer-combine Krep1 Krep2)))
+ (if (eq? rep rep:object)
+ (if c (list c) '())
+ (let ((T (constraint.lhs (car cs1))))
+ (if c
+ (list c (make-type-constraint T rep Krep))
+ (list (make-type-constraint T rep Krep)))))))))))
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $gc.ephemeral 0)
+(define $gc.tenuring 1)
+(define $gc.full 2)
+(define $mstat.wallocated-hi 0)
+(define $mstat.wallocated-lo 1)
+(define $mstat.wcollected-hi 2)
+(define $mstat.wcollected-lo 3)
+(define $mstat.wcopied-hi 4)
+(define $mstat.wcopied-lo 5)
+(define $mstat.gctime 6)
+(define $mstat.wlive 7)
+(define $mstat.gc-last-gen 8)
+(define $mstat.gc-last-type 9)
+(define $mstat.generations 10)
+(define $mstat.g-gc-count 0)
+(define $mstat.g-prom-count 1)
+(define $mstat.g-gctime 2)
+(define $mstat.g-wlive 3)
+(define $mstat.g-np-youngp 4)
+(define $mstat.g-np-oldp 5)
+(define $mstat.g-np-j 6)
+(define $mstat.g-np-k 7)
+(define $mstat.g-alloc 8)
+(define $mstat.g-target 9)
+(define $mstat.g-promtime 10)
+(define $mstat.remsets 11)
+(define $mstat.r-apool 0)
+(define $mstat.r-upool 1)
+(define $mstat.r-ahash 2)
+(define $mstat.r-uhash 3)
+(define $mstat.r-hrec-hi 4)
+(define $mstat.r-hrec-lo 5)
+(define $mstat.r-hrem-hi 6)
+(define $mstat.r-hrem-lo 7)
+(define $mstat.r-hscan-hi 8)
+(define $mstat.r-hscan-lo 9)
+(define $mstat.r-wscan-hi 10)
+(define $mstat.r-wscan-lo 11)
+(define $mstat.r-ssbrec-hi 12)
+(define $mstat.r-ssbrec-lo 13)
+(define $mstat.r-np-p 14)
+(define $mstat.fflushed-hi 12)
+(define $mstat.fflushed-lo 13)
+(define $mstat.wflushed-hi 14)
+(define $mstat.wflushed-lo 15)
+(define $mstat.stk-created 16)
+(define $mstat.frestored-hi 17)
+(define $mstat.frestored-lo 18)
+(define $mstat.words-heap 19)
+(define $mstat.words-remset 20)
+(define $mstat.words-rts 21)
+(define $mstat.swb-assign 22)
+(define $mstat.swb-lhs-ok 23)
+(define $mstat.swb-rhs-const 24)
+(define $mstat.swb-not-xgen 25)
+(define $mstat.swb-trans 26)
+(define $mstat.rtime 27)
+(define $mstat.stime 28)
+(define $mstat.utime 29)
+(define $mstat.minfaults 30)
+(define $mstat.majfaults 31)
+(define $mstat.np-remsetp 32)
+(define $mstat.max-heap 33)
+(define $mstat.promtime 34)
+(define $mstat.wmoved-hi 35)
+(define $mstat.wmoved-lo 36)
+(define $mstat.vsize 37)
+(define $g.reg0 12)
+(define $r.reg8 44)
+(define $r.reg9 48)
+(define $r.reg10 52)
+(define $r.reg11 56)
+(define $r.reg12 60)
+(define $r.reg13 64)
+(define $r.reg14 68)
+(define $r.reg15 72)
+(define $r.reg16 76)
+(define $r.reg17 80)
+(define $r.reg18 84)
+(define $r.reg19 88)
+(define $r.reg20 92)
+(define $r.reg21 96)
+(define $r.reg22 100)
+(define $r.reg23 104)
+(define $r.reg24 108)
+(define $r.reg25 112)
+(define $r.reg26 116)
+(define $r.reg27 120)
+(define $r.reg28 124)
+(define $r.reg29 128)
+(define $r.reg30 132)
+(define $r.reg31 136)
+(define $g.stkbot 180)
+(define $g.gccnt 420)
+(define $m.alloc 1024)
+(define $m.alloci 1032)
+(define $m.gc 1040)
+(define $m.addtrans 1048)
+(define $m.stkoflow 1056)
+(define $m.stkuflow 1072)
+(define $m.creg 1080)
+(define $m.creg-set! 1088)
+(define $m.add 1096)
+(define $m.subtract 1104)
+(define $m.multiply 1112)
+(define $m.quotient 1120)
+(define $m.remainder 1128)
+(define $m.divide 1136)
+(define $m.modulo 1144)
+(define $m.negate 1152)
+(define $m.numeq 1160)
+(define $m.numlt 1168)
+(define $m.numle 1176)
+(define $m.numgt 1184)
+(define $m.numge 1192)
+(define $m.zerop 1200)
+(define $m.complexp 1208)
+(define $m.realp 1216)
+(define $m.rationalp 1224)
+(define $m.integerp 1232)
+(define $m.exactp 1240)
+(define $m.inexactp 1248)
+(define $m.exact->inexact 1256)
+(define $m.inexact->exact 1264)
+(define $m.make-rectangular 1272)
+(define $m.real-part 1280)
+(define $m.imag-part 1288)
+(define $m.sqrt 1296)
+(define $m.round 1304)
+(define $m.truncate 1312)
+(define $m.apply 1320)
+(define $m.varargs 1328)
+(define $m.typetag 1336)
+(define $m.typetag-set 1344)
+(define $m.break 1352)
+(define $m.eqv 1360)
+(define $m.partial-list->vector 1368)
+(define $m.timer-exception 1376)
+(define $m.exception 1384)
+(define $m.singlestep 1392)
+(define $m.syscall 1400)
+(define $m.bvlcmp 1408)
+(define $m.enable-interrupts 1416)
+(define $m.disable-interrupts 1424)
+(define $m.alloc-bv 1432)
+(define $m.global-ex 1440)
+(define $m.invoke-ex 1448)
+(define $m.global-invoke-ex 1456)
+(define $m.argc-ex 1464)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $r.g0 0)
+(define $r.g1 1)
+(define $r.g2 2)
+(define $r.g3 3)
+(define $r.g4 4)
+(define $r.g5 5)
+(define $r.g6 6)
+(define $r.g7 7)
+(define $r.o0 8)
+(define $r.o1 9)
+(define $r.o2 10)
+(define $r.o3 11)
+(define $r.o4 12)
+(define $r.o5 13)
+(define $r.o6 14)
+(define $r.o7 15)
+(define $r.l0 16)
+(define $r.l1 17)
+(define $r.l2 18)
+(define $r.l3 19)
+(define $r.l4 20)
+(define $r.l5 21)
+(define $r.l6 22)
+(define $r.l7 23)
+(define $r.i0 24)
+(define $r.i1 25)
+(define $r.i2 26)
+(define $r.i3 27)
+(define $r.i4 28)
+(define $r.i5 29)
+(define $r.i6 30)
+(define $r.i7 31)
+(define $r.result $r.o0)
+(define $r.argreg2 $r.o1)
+(define $r.argreg3 $r.o2)
+(define $r.stkp $r.o3)
+(define $r.stklim $r.i0)
+(define $r.tmp1 $r.o4)
+(define $r.tmp2 $r.o5)
+(define $r.tmp0 $r.g1)
+(define $r.e-top $r.i0)
+(define $r.e-limit $r.o3)
+(define $r.timer $r.i4)
+(define $r.millicode $r.i7)
+(define $r.globals $r.i7)
+(define $r.reg0 $r.l0)
+(define $r.reg1 $r.l1)
+(define $r.reg2 $r.l2)
+(define $r.reg3 $r.l3)
+(define $r.reg4 $r.l4)
+(define $r.reg5 $r.l5)
+(define $r.reg6 $r.l6)
+(define $r.reg7 $r.l7)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $ex.car 0)
+(define $ex.cdr 1)
+(define $ex.setcar 2)
+(define $ex.setcdr 3)
+(define $ex.add 10)
+(define $ex.sub 11)
+(define $ex.mul 12)
+(define $ex.div 13)
+(define $ex.lessp 14)
+(define $ex.lesseqp 15)
+(define $ex.equalp 16)
+(define $ex.greatereqp 17)
+(define $ex.greaterp 18)
+(define $ex.quotient 19)
+(define $ex.remainder 20)
+(define $ex.modulo 21)
+(define $ex.logior 22)
+(define $ex.logand 23)
+(define $ex.logxor 24)
+(define $ex.lognot 25)
+(define $ex.lsh 26)
+(define $ex.rsha 27)
+(define $ex.rshl 28)
+(define $ex.e2i 29)
+(define $ex.i2e 30)
+(define $ex.exactp 31)
+(define $ex.inexactp 32)
+(define $ex.round 33)
+(define $ex.trunc 34)
+(define $ex.zerop 35)
+(define $ex.neg 36)
+(define $ex.abs 37)
+(define $ex.realpart 38)
+(define $ex.imagpart 39)
+(define $ex.vref 40)
+(define $ex.vset 41)
+(define $ex.vlen 42)
+(define $ex.pref 50)
+(define $ex.pset 51)
+(define $ex.plen 52)
+(define $ex.sref 60)
+(define $ex.sset 61)
+(define $ex.slen 62)
+(define $ex.bvref 70)
+(define $ex.bvset 71)
+(define $ex.bvlen 72)
+(define $ex.bvlref 80)
+(define $ex.bvlset 81)
+(define $ex.bvllen 82)
+(define $ex.vlref 90)
+(define $ex.vlset 91)
+(define $ex.vllen 92)
+(define $ex.typetag 100)
+(define $ex.typetagset 101)
+(define $ex.apply 102)
+(define $ex.argc 103)
+(define $ex.vargc 104)
+(define $ex.nonproc 105)
+(define $ex.undef-global 106)
+(define $ex.dump 107)
+(define $ex.dumpfail 108)
+(define $ex.timer 109)
+(define $ex.unsupported 110)
+(define $ex.int2char 111)
+(define $ex.char2int 112)
+(define $ex.mkbvl 113)
+(define $ex.mkvl 114)
+(define $ex.char<? 115)
+(define $ex.char<=? 116)
+(define $ex.char=? 117)
+(define $ex.char>? 118)
+(define $ex.char>=? 119)
+(define $ex.bvfill 120)
+(define $ex.enable-interrupts 121)
+(define $ex.keyboard-interrupt 122)
+(define $ex.arithmetic-exception 123)
+(define $ex.global-invoke 124)
+(define $ex.fx+ 140)
+(define $ex.fx- 141)
+(define $ex.fx-- 142)
+(define $ex.fx= 143)
+(define $ex.fx< 144)
+(define $ex.fx<= 145)
+(define $ex.fx> 146)
+(define $ex.fx>= 147)
+(define $ex.fxpositive? 148)
+(define $ex.fxnegative? 149)
+(define $ex.fxzero? 150)
+(define $ex.fx* 151)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $tag.tagmask 7)
+(define $tag.pair-tag 1)
+(define $tag.vector-tag 3)
+(define $tag.bytevector-tag 5)
+(define $tag.procedure-tag 7)
+(define $imm.vector-header 162)
+(define $imm.bytevector-header 194)
+(define $imm.procedure-header 254)
+(define $imm.true 6)
+(define $imm.false 2)
+(define $imm.null 10)
+(define $imm.unspecified 278)
+(define $imm.eof 534)
+(define $imm.undefined 790)
+(define $imm.character 38)
+(define $tag.vector-typetag 0)
+(define $tag.rectnum-typetag 4)
+(define $tag.ratnum-typetag 8)
+(define $tag.symbol-typetag 12)
+(define $tag.port-typetag 16)
+(define $tag.structure-typetag 20)
+(define $tag.bytevector-typetag 0)
+(define $tag.string-typetag 4)
+(define $tag.flonum-typetag 8)
+(define $tag.compnum-typetag 12)
+(define $tag.bignum-typetag 16)
+(define $hdr.port 178)
+(define $hdr.struct 182)
+(define $p.codevector -3)
+(define $p.constvector 1)
+(define $p.linkoffset 5)
+(define $p.reg0 5)
+(define $p.codeoffset -1)
+; Copyright 1991 William Clinger
+;
+; Relatively target-independent information for Twobit's backend.
+;
+; 24 April 1999 / wdc
+;
+; Most of the definitions in this file can be extended or overridden by
+; target-specific definitions.
+
+(define twobit-sort
+ (lambda (less? list) (compat:sort list less?)))
+
+(define renaming-prefix ".")
+
+; The prefix used for cells introduced by the compiler.
+
+(define cell-prefix (string-append renaming-prefix "CELL:"))
+
+; Names of global procedures that cannot be redefined or assigned
+; by ordinary code.
+; The expansion of quasiquote uses .cons and .list directly, so these
+; should not be changed willy-nilly.
+; Others may be used directly by a DEFINE-INLINE.
+
+(define name:CHECK! '.check!)
+(define name:CONS '.cons)
+(define name:LIST '.list)
+(define name:MAKE-CELL '.make-cell)
+(define name:CELL-REF '.cell-ref)
+(define name:CELL-SET! '.cell-set!)
+(define name:IGNORED (string->symbol "IGNORED"))
+(define name:CAR '.car)
+(define name:CDR '.cdr)
+
+;(begin (eval `(define ,name:CONS cons))
+; (eval `(define ,name:LIST list))
+; (eval `(define ,name:MAKE-CELL list))
+; (eval `(define ,name:CELL-REF car))
+; (eval `(define ,name:CELL-SET! set-car!)))
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures.
+
+(define name:NOT 'not)
+(define name:MEMQ 'memq)
+(define name:MEMV 'memv)
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures and also creates calls to them.
+
+(define name:EQ? 'eq?)
+(define name:EQV? 'eqv?)
+
+; Control optimization creates calls to these procedures,
+; which do not need to check their arguments.
+
+(define name:FIXNUM? 'fixnum?)
+(define name:CHAR? 'char?)
+(define name:SYMBOL? 'symbol?)
+(define name:FX< '<:fix:fix)
+(define name:FX- 'fx-) ; non-checking version
+(define name:CHAR->INTEGER 'char->integer) ; non-checking version
+(define name:VECTOR-REF 'vector-ref:trusted)
+
+
+; Constant folding.
+; Prototype, will probably change in the future.
+
+(define (constant-folding-entry name)
+ (assq name $usual-constant-folding-procedures$))
+
+(define constant-folding-predicates cadr)
+(define constant-folding-folder caddr)
+
+(define $usual-constant-folding-procedures$
+ (let ((always? (lambda (x) #t))
+ (charcode? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (<= 0 n)
+ (< n 128))))
+ (ratnum? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (rational? n))))
+ ; smallint? is defined later.
+ (smallint? (lambda (n) (smallint? n))))
+ `(
+ ; This makes some assumptions about the host system.
+
+ (integer->char (,charcode?) ,integer->char)
+ (char->integer (,char?) ,char->integer)
+ (zero? (,ratnum?) ,zero?)
+ (< (,ratnum? ,ratnum?) ,<)
+ (<= (,ratnum? ,ratnum?) ,<=)
+ (= (,ratnum? ,ratnum?) ,=)
+ (>= (,ratnum? ,ratnum?) ,>=)
+ (> (,ratnum? ,ratnum?) ,>)
+ (+ (,ratnum? ,ratnum?) ,+)
+ (- (,ratnum? ,ratnum?) ,-)
+ (* (,ratnum? ,ratnum?) ,*)
+ (-- (,ratnum?) ,(lambda (x) (- 0 x)))
+ (eq? (,always? ,always?) ,eq?)
+ (eqv? (,always? ,always?) ,eqv?)
+ (equal? (,always? ,always?) ,equal?)
+ (memq (,always? ,list?) ,memq)
+ (memv (,always? ,list?) ,memv)
+ (member (,always? ,list?) ,member)
+ (assq (,always? ,list?) ,assq)
+ (assv (,always? ,list?) ,assv)
+ (assoc (,always? ,list?) ,assoc)
+ (length (,list?) ,length)
+ (fixnum? (,smallint?) ,smallint?)
+ (=:fix:fix (,smallint? ,smallint?) ,=)
+ (<:fix:fix (,smallint? ,smallint?) ,<)
+ (<=:fix:fix (,smallint? ,smallint?) ,<=)
+ (>:fix:fix (,smallint? ,smallint?) ,>)
+ (>=:fix:fix (,smallint? ,smallint?) ,>=)
+ )))
+
+(begin '
+ (define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+ #t)
+
+; Order matters. If f and g are both inlined, and the definition of g
+; uses f, then f should be defined before g.
+
+(for-each pass1
+ `(
+
+(define-inline car
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.car x)
+ (car:pair x)))))
+
+(define-inline cdr
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.cdr x)
+ (cdr:pair x)))))
+
+(define-inline vector-length
+ (syntax-rules ()
+ ((vector-length v0)
+ (let ((v v0))
+ (.check! (vector? v) ,$ex.vlen v)
+ (vector-length:vec v)))))
+
+(define-inline vector-ref
+ (syntax-rules ()
+ ((vector-ref v0 i0)
+ (let ((v v0)
+ (i i0))
+ (.check! (fixnum? i) ,$ex.vref v i)
+ (.check! (vector? v) ,$ex.vref v i)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vref v i)
+ (.check! (>=:fix:fix i 0) ,$ex.vref v i)
+ (vector-ref:trusted v i)))))
+
+(define-inline vector-set!
+ (syntax-rules ()
+ ((vector-set! v0 i0 x0)
+ (let ((v v0)
+ (i i0)
+ (x x0))
+ (.check! (fixnum? i) ,$ex.vset v i x)
+ (.check! (vector? v) ,$ex.vset v i x)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vset v i x)
+ (.check! (>=:fix:fix i 0) ,$ex.vset v i x)
+ (vector-set!:trusted v i x)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to LIST returns more than once.
+
+(define-inline list
+ (syntax-rules ()
+ ((list)
+ '())
+ ((list ?e)
+ (cons ?e '()))
+ ((list ?e1 ?e2 ...)
+ (let* ((t1 ?e1)
+ (t2 (list ?e2 ...)))
+ (cons t1 t2)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to VECTOR returns more than once.
+
+(define-inline vector
+ (syntax-rules ()
+ ((vector)
+ '#())
+ ((vector ?e)
+ (make-vector 1 ?e))
+ ((vector ?e1 ?e2 ...)
+ (letrec-syntax
+ ((vector-aux1
+ (... (syntax-rules ()
+ ((vector-aux1 () ?n ?exps ?indexes ?temps)
+ (vector-aux2 ?n ?exps ?indexes ?temps))
+ ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps)
+ (vector-aux1 (?exp2 ...)
+ (+ ?n 1)
+ (?exp1 . ?exps)
+ (?n . ?indexes)
+ (t . ?temps))))))
+ (vector-aux2
+ (... (syntax-rules ()
+ ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...))
+ (let* ((?t1 ?exp1)
+ (?t2 ?exp2)
+ ...
+ (v (make-vector ?n ?t1)))
+ (vector-set! v ?n2 ?t2)
+ ...
+ v))))))
+ (vector-aux1 (?e1 ?e2 ...) 0 () () ())))))
+
+(define-inline cadddr
+ (syntax-rules ()
+ ((cadddr ?e)
+ (car (cdr (cdr (cdr ?e)))))))
+
+(define-inline cddddr
+ (syntax-rules ()
+ ((cddddr ?e)
+ (cdr (cdr (cdr (cdr ?e)))))))
+
+(define-inline cdddr
+ (syntax-rules ()
+ ((cdddr ?e)
+ (cdr (cdr (cdr ?e))))))
+
+(define-inline caddr
+ (syntax-rules ()
+ ((caddr ?e)
+ (car (cdr (cdr ?e))))))
+
+(define-inline cddr
+ (syntax-rules ()
+ ((cddr ?e)
+ (cdr (cdr ?e)))))
+
+(define-inline cdar
+ (syntax-rules ()
+ ((cdar ?e)
+ (cdr (car ?e)))))
+
+(define-inline cadr
+ (syntax-rules ()
+ ((cadr ?e)
+ (car (cdr ?e)))))
+
+(define-inline caar
+ (syntax-rules ()
+ ((caar ?e)
+ (car (car ?e)))))
+
+(define-inline make-vector
+ (syntax-rules ()
+ ((make-vector ?n)
+ (make-vector ?n '()))))
+
+(define-inline make-string
+ (syntax-rules ()
+ ((make-string ?n)
+ (make-string ?n #\space))))
+
+(define-inline =
+ (syntax-rules ()
+ ((= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (= ?e1 t)
+ (= t ?e3 ?e4 ...))))))
+
+(define-inline <
+ (syntax-rules ()
+ ((< ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (< ?e1 t)
+ (< t ?e3 ?e4 ...))))))
+
+(define-inline >
+ (syntax-rules ()
+ ((> ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (> ?e1 t)
+ (> t ?e3 ?e4 ...))))))
+
+(define-inline <=
+ (syntax-rules ()
+ ((<= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (<= ?e1 t)
+ (<= t ?e3 ?e4 ...))))))
+
+(define-inline >=
+ (syntax-rules ()
+ ((>= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (>= ?e1 t)
+ (>= t ?e3 ?e4 ...))))))
+
+(define-inline +
+ (syntax-rules ()
+ ((+)
+ 0)
+ ((+ ?e)
+ ?e)
+ ((+ ?e1 ?e2 ?e3 ?e4 ...)
+ (+ (+ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline *
+ (syntax-rules ()
+ ((*)
+ 1)
+ ((* ?e)
+ ?e)
+ ((* ?e1 ?e2 ?e3 ?e4 ...)
+ (* (* ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline -
+ (syntax-rules ()
+ ((- ?e)
+ (- 0 ?e))
+ ((- ?e1 ?e2 ?e3 ?e4 ...)
+ (- (- ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline /
+ (syntax-rules ()
+ ((/ ?e)
+ (/ 1 ?e))
+ ((/ ?e1 ?e2 ?e3 ?e4 ...)
+ (/ (/ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline abs
+ (syntax-rules ()
+ ((abs ?z)
+ (let ((temp ?z))
+ (if (< temp 0)
+ (-- temp)
+ temp)))))
+
+(define-inline negative?
+ (syntax-rules ()
+ ((negative? ?x)
+ (< ?x 0))))
+
+(define-inline positive?
+ (syntax-rules ()
+ ((positive? ?x)
+ (> ?x 0))))
+
+(define-inline eqv?
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (define (constant? exp)
+ (or (boolean? exp)
+ (char? exp)
+ (and (pair? exp)
+ (= (length exp) 2)
+ (identifier? (car exp))
+ (compare (car exp) (rename 'quote))
+ (symbol? (cadr exp)))))
+ (if (or (constant? arg1)
+ (constant? arg2))
+ (cons (rename 'eq?) (cdr exp))
+ exp)))))
+
+(define-inline memq
+ (syntax-rules (quote)
+ ((memq ?expr '(?datum ...))
+ (letrec-syntax
+ ((memq0
+ (... (syntax-rules (quote)
+ ((memq0 '?xx '(?d ...))
+ (let ((t1 '(?d ...)))
+ (memq1 '?xx t1 (?d ...))))
+ ((memq0 ?e '(?d ...))
+ (let ((t0 ?e)
+ (t1 '(?d ...)))
+ (memq1 t0 t1 (?d ...)))))))
+ (memq1
+ (... (syntax-rules ()
+ ((memq1 ?t0 ?t1 ())
+ #f)
+ ((memq1 ?t0 ?t1 (?d1 ?d2 ...))
+ (if (eq? ?t0 '?d1)
+ ?t1
+ (let ((?t1 (cdr ?t1)))
+ (memq1 ?t0 ?t1 (?d2 ...)))))))))
+ (memq0 ?expr '(?datum ...))))))
+
+(define-inline memv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (fixnum? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (x)
+ (or (boolean? x)
+ (fixnum? x)
+ (char? x)
+ (symbol? x)))
+ (cadr arg2))))
+ (cons (rename 'memq) (cdr exp))
+ exp)))))
+
+(define-inline assv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (y)
+ (and (pair? y)
+ (let ((x (car y)))
+ (or (boolean? x)
+ (char? x)
+ (symbol? x)))))
+ (cadr arg2))))
+ (cons (rename 'assq) (cdr exp))
+ exp)))))
+
+(define-inline map
+ (syntax-rules (lambda)
+ ((map ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...
+ (results '() (cons (?f (car ?y1) (car ?y2) ...)
+ results)))
+ ((or (null? ?y1) (null? ?y2) ...)
+ (reverse results))))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+(define-inline for-each
+ (syntax-rules (lambda)
+ ((for-each ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...)
+ ((or (null? ?y1) (null? ?y2) ...)
+ (if #f #f))
+ (?f (car ?y1) (car ?y2) ...)))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+))
+
+(define extended-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-extended-syntactic-environment)
+ (syntactic-copy extended-syntactic-environment))
+
+; MacScheme machine assembly instructions.
+
+(define instruction.op car)
+(define instruction.arg1 cadr)
+(define instruction.arg2 caddr)
+(define instruction.arg3 cadddr)
+
+; Opcode table.
+
+(define *mnemonic-names* '()) ; For readify-lap
+(begin
+ '
+ (define *last-reserved-mnemonic* 32767) ; For consistency check
+ '
+ (define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (if (= count *last-reserved-mnemonic*)
+ (error "Error in make-mnemonic: conflict: " name))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+ '
+ (define (reserved-mnemonic name value)
+ (if (and (> value 0) (< value *last-reserved-mnemonic*))
+ (set! *last-reserved-mnemonic* value))
+ (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*))
+ value)
+ #t)
+
+(define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+
+(define (reserved-mnemonic name ignored)
+ (make-mnemonic name))
+
+(define $.linearize (reserved-mnemonic '.linearize -1)) ; unused?
+(define $.label (reserved-mnemonic '.label 63))
+(define $.proc (reserved-mnemonic '.proc 62)) ; proc entry point
+(define $.cont (reserved-mnemonic '.cont 61)) ; return point
+(define $.align (reserved-mnemonic '.align 60)) ; align code stream
+(define $.asm (reserved-mnemonic '.asm 59)) ; in-line native code
+(define $.proc-doc ; internal def proc info
+ (reserved-mnemonic '.proc-doc 58))
+(define $.end ; end of code vector
+ (reserved-mnemonic '.end 57)) ; (asm internal)
+(define $.singlestep ; insert singlestep point
+ (reserved-mnemonic '.singlestep 56)) ; (asm internal)
+(define $.entry (reserved-mnemonic '.entry 55)) ; procedure entry point
+ ; (asm internal)
+
+(define $op1 (make-mnemonic 'op1)) ; op prim
+(define $op2 (make-mnemonic 'op2)) ; op2 prim,k
+(define $op3 (make-mnemonic 'op3)) ; op3 prim,k1,k2
+(define $op2imm (make-mnemonic 'op2imm)) ; op2imm prim,x
+(define $const (make-mnemonic 'const)) ; const x
+(define $global (make-mnemonic 'global)) ; global x
+(define $setglbl (make-mnemonic 'setglbl)) ; setglbl x
+(define $lexical (make-mnemonic 'lexical)) ; lexical m,n
+(define $setlex (make-mnemonic 'setlex)) ; setlex m,n
+(define $stack (make-mnemonic 'stack)) ; stack n
+(define $setstk (make-mnemonic 'setstk)) ; setstk n
+(define $load (make-mnemonic 'load)) ; load k,n
+(define $store (make-mnemonic 'store)) ; store k,n
+(define $reg (make-mnemonic 'reg)) ; reg k
+(define $setreg (make-mnemonic 'setreg)) ; setreg k
+(define $movereg (make-mnemonic 'movereg)) ; movereg k1,k2
+(define $lambda (make-mnemonic 'lambda)) ; lambda x,n,doc
+(define $lexes (make-mnemonic 'lexes)) ; lexes n,doc
+(define $args= (make-mnemonic 'args=)) ; args= k
+(define $args>= (make-mnemonic 'args>=)) ; args>= k
+(define $invoke (make-mnemonic 'invoke)) ; invoke k
+(define $save (make-mnemonic 'save)) ; save L,k
+(define $setrtn (make-mnemonic 'setrtn)) ; setrtn L
+(define $restore (make-mnemonic 'restore)) ; restore n ; deprecated
+(define $pop (make-mnemonic 'pop)) ; pop k
+(define $popstk (make-mnemonic 'popstk)) ; popstk ; for students
+(define $return (make-mnemonic 'return)) ; return
+(define $mvrtn (make-mnemonic 'mvrtn)) ; mvrtn ; NYI
+(define $apply (make-mnemonic 'apply)) ; apply
+(define $nop (make-mnemonic 'nop)) ; nop
+(define $jump (make-mnemonic 'jump)) ; jump m,o
+(define $skip (make-mnemonic 'skip)) ; skip L ; forward
+(define $branch (make-mnemonic 'branch)) ; branch L
+(define $branchf (make-mnemonic 'branchf)) ; branchf L
+(define $check (make-mnemonic 'check)) ; check k1,k2,k3,L
+(define $trap (make-mnemonic 'trap)) ; trap k1,k2,k3,exn
+
+; A peephole optimizer may define more instructions in some
+; target-specific file.
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Larceny -- target-specific information for Twobit's SPARC backend.
+;
+; 11 June 1999 / wdc
+
+; The maximum number of fixed arguments that may be followed by a rest
+; argument. This limitation is removed by the macro expander.
+
+(define @maxargs-with-rest-arg@ 30)
+
+; The number of MacScheme machine registers.
+; (They do not necessarily correspond to hardware registers.)
+
+(define *nregs* 32)
+(define *lastreg* (- *nregs* 1))
+(define *fullregs* (quotient *nregs* 2))
+
+; The number of argument registers that are represented by hardware
+; registers.
+
+(define *nhwregs* 8)
+
+; Variable names that indicate register targets.
+
+(define *regnames*
+ (do ((alist '() (cons (cons (string->symbol
+ (string-append ".REG" (number->string r)))
+ r)
+ alist))
+ (r (- *nhwregs* 1) (- r 1)))
+ ((<= r 0)
+ alist)))
+
+; A non-inclusive upper bound for the instruction encodings.
+
+(define *number-of-mnemonics* 72)
+
+; Integrable procedures and procedure-specific source code transformations.
+; Every integrable procedure that takes a varying number of arguments must
+; supply a transformation procedure to map calls into the fixed arity
+; required by the MacScheme machine instructions.
+
+; The table of integrable procedures.
+; Each entry is a list of the following items:
+;
+; procedure name
+; arity (or -1 for special primops like .check!)
+; procedure name to be used by the disassembler
+; predicate for immediate operands (or #f)
+; primop code in the MacScheme machine (not used by Larceny)
+; the effects that kill this primop's result
+; the effects of this primop that kill available expressions
+
+(define (prim-entry name)
+ (assq name $usual-integrable-procedures$))
+
+(define prim-arity cadr)
+(define prim-opcodename caddr)
+(define prim-immediate? cadddr)
+(define (prim-primcode entry)
+ (car (cddddr entry)))
+
+; This predicate returns #t iff its argument will be represented
+; as a fixnum on the target machine.
+
+(define smallint?
+ (let* ((least (- (expt 2 29)))
+ (greatest (- (- least) 1)))
+ (lambda (x)
+ (and (number? x)
+ (exact? x)
+ (integer? x)
+ (<= least x greatest)))))
+
+(define (sparc-imm? x)
+ (and (fixnum? x)
+ (<= -1024 x 1023)))
+
+(define (sparc-eq-imm? x)
+ (or (sparc-imm? x)
+ (eq? x #t)
+ (eq? x #f)
+ (eq? x '())))
+
+(define (valid-typetag? x)
+ (and (fixnum? x)
+ (<= 0 x 7)))
+
+(define (fixnum-primitives) #t)
+(define (flonum-primitives) #t)
+
+; The table of primitives has been extended with
+; kill information used for commoning.
+
+(define (prim-lives-until entry)
+ (list-ref entry 5))
+
+(define (prim-kills entry)
+ (list-ref entry 6))
+
+(define $usual-integrable-procedures$
+ (let ((:globals available:killer:globals)
+ (:car available:killer:car)
+ (:cdr available:killer:cdr)
+ (:string available:killer:string)
+ (:vector available:killer:vector)
+ (:cell available:killer:cell)
+ (:io available:killer:io)
+ (:none available:killer:none) ; none of the above
+ (:all available:killer:all) ; all of the above
+ (:immortal available:killer:immortal) ; never killed
+ (:dead available:killer:dead) ; never available
+ )
+
+; external arity internal immediate ignored killed kills
+; name name predicate by what
+; kind of
+; effect
+
+ `((break 0 break #f 3 ,:dead ,:all)
+ (creg 0 creg #f 7 ,:dead ,:all)
+ (unspecified 0 unspecified #f -1 ,:dead ,:none)
+ (undefined 0 undefined #f 8 ,:dead ,:none)
+ (eof-object 0 eof-object #f -1 ,:dead ,:none)
+ (enable-interrupts 1 enable-interrupts #f -1 ,:dead ,:all)
+ (disable-interrupts 0 disable-interrupts #f -1 ,:dead ,:all)
+
+ (typetag 1 typetag #f #x11 ,:dead ,:none)
+ (not 1 not #f #x18 ,:immortal ,:none)
+ (null? 1 null? #f #x19 ,:immortal ,:none)
+ (pair? 1 pair? #f #x1a ,:immortal ,:none)
+ (eof-object? 1 eof-object? #f -1 ,:immortal ,:none)
+ (port? 1 port? #f -1 ,:dead ,:none)
+ (structure? 1 structure? #f -1 ,:dead ,:none)
+ (car 1 car #f #x1b ,:car ,:none)
+ (,name:CAR 1 car #f #x1b ,:car ,:none)
+ (cdr 1 cdr #f #x1c ,:cdr ,:none)
+ (,name:CDR 1 cdr #f #x1c ,:cdr ,:none)
+ (symbol? 1 symbol? #f #x1f ,:immortal ,:none)
+ (number? 1 complex? #f #x20 ,:immortal ,:none)
+ (complex? 1 complex? #f #x20 ,:immortal ,:none)
+ (real? 1 rational? #f #x21 ,:immortal ,:none)
+ (rational? 1 rational? #f #x21 ,:immortal ,:none)
+ (integer? 1 integer? #f #x22 ,:immortal ,:none)
+ (fixnum? 1 fixnum? #f #x23 ,:immortal ,:none)
+ (flonum? 1 flonum? #f -1 ,:immortal ,:none)
+ (compnum? 1 compnum? #f -1 ,:immortal ,:none)
+ (exact? 1 exact? #f #x24 ,:immortal ,:none)
+ (inexact? 1 inexact? #f #x25 ,:immortal ,:none)
+ (exact->inexact 1 exact->inexact #f #x26 ,:immortal ,:none)
+ (inexact->exact 1 inexact->exact #f #x27 ,:immortal ,:none)
+ (round 1 round #f #x28 ,:immortal ,:none)
+ (truncate 1 truncate #f #x29 ,:immortal ,:none)
+ (zero? 1 zero? #f #x2c ,:immortal ,:none)
+ (-- 1 -- #f #x2d ,:immortal ,:none)
+ (lognot 1 lognot #f #x2f ,:immortal ,:none)
+ (real-part 1 real-part #f #x3e ,:immortal ,:none)
+ (imag-part 1 imag-part #f #x3f ,:immortal ,:none)
+ (char? 1 char? #f #x40 ,:immortal ,:none)
+ (char->integer 1 char->integer #f #x41 ,:immortal ,:none)
+ (integer->char 1 integer->char #f #x42 ,:immortal ,:none)
+ (string? 1 string? #f #x50 ,:immortal ,:none)
+ (string-length 1 string-length #f #x51 ,:immortal ,:none)
+ (vector? 1 vector? #f #x52 ,:immortal ,:none)
+ (vector-length 1 vector-length #f #x53 ,:immortal ,:none)
+ (bytevector? 1 bytevector? #f #x54 ,:immortal ,:none)
+ (bytevector-length 1 bytevector-length #f #x55 ,:immortal ,:none)
+ (bytevector-fill! 2 bytevector-fill! #f -1 ,:dead ,:string)
+ (make-bytevector 1 make-bytevector #f #x56 ,:dead ,:none)
+ (procedure? 1 procedure? #f #x58 ,:immortal ,:none)
+ (procedure-length 1 procedure-length #f #x59 ,:dead ,:none)
+ (make-procedure 1 make-procedure #f #x5a ,:dead ,:none)
+ (creg-set! 1 creg-set! #f #x71 ,:dead ,:none)
+ (,name:MAKE-CELL 1 make-cell #f #x7e ,:dead ,:none)
+ (,name:CELL-REF 1 cell-ref #f #x7f ,:cell ,:none)
+ (,name:CELL-SET! 2 cell-set! #f #xdf ,:dead ,:cell)
+ (typetag-set! 2 typetag-set! ,valid-typetag? #xa0 ,:dead ,:all)
+ (eq? 2 eq? ,sparc-eq-imm? #xa1 ,:immortal ,:none)
+ (eqv? 2 eqv? #f #xa2 ,:immortal ,:none)
+ (cons 2 cons #f #xa8 ,:dead ,:none)
+ (,name:CONS 2 cons #f #xa8 ,:dead ,:none)
+ (set-car! 2 set-car! #f #xa9 ,:dead ,:car)
+ (set-cdr! 2 set-cdr! #f #xaa ,:dead ,:cdr)
+ (+ 2 + ,sparc-imm? #xb0 ,:immortal ,:none)
+ (- 2 - ,sparc-imm? #xb1 ,:immortal ,:none)
+ (* 2 * ,sparc-imm? #xb2 ,:immortal ,:none)
+ (/ 2 / #f #xb3 ,:immortal ,:none)
+ (quotient 2 quotient #f #xb4 ,:immortal ,:none)
+ (< 2 < ,sparc-imm? #xb5 ,:immortal ,:none)
+ (<= 2 <= ,sparc-imm? #xb6 ,:immortal ,:none)
+ (= 2 = ,sparc-imm? #xb7 ,:immortal ,:none)
+ (> 2 > ,sparc-imm? #xb8 ,:immortal ,:none)
+ (>= 2 >= ,sparc-imm? #xb9 ,:immortal ,:none)
+ (logand 2 logand #f #xc0 ,:immortal ,:none)
+ (logior 2 logior #f #xc1 ,:immortal ,:none)
+ (logxor 2 logxor #f #xc2 ,:immortal ,:none)
+ (lsh 2 lsh #f #xc3 ,:immortal ,:none)
+ (rsha 2 rsha #f -1 ,:immortal ,:none)
+ (rshl 2 rshl #f -1 ,:immortal ,:none)
+ (rot 2 rot #f #xc4 ,:immortal ,:none)
+ (make-string 2 make-string #f -1 ,:dead ,:none)
+ (string-ref 2 string-ref ,sparc-imm? #xd1 ,:string ,:none)
+ (string-set! 3 string-set! ,sparc-imm? -1 ,:dead ,:string)
+ (make-vector 2 make-vector #f #xd2 ,:dead ,:none)
+ (vector-ref 2 vector-ref ,sparc-imm? #xd3 ,:vector ,:none)
+ (bytevector-ref 2 bytevector-ref ,sparc-imm? #xd5 ,:string ,:none)
+ (procedure-ref 2 procedure-ref #f #xd7 ,:dead ,:none)
+ (char<? 2 char<? ,char? #xe0 ,:immortal ,:none)
+ (char<=? 2 char<=? ,char? #xe1 ,:immortal ,:none)
+ (char=? 2 char=? ,char? #xe2 ,:immortal ,:none)
+ (char>? 2 char>? ,char? #xe3 ,:immortal ,:none)
+ (char>=? 2 char>=? ,char? #xe4 ,:immortal ,:none)
+
+ (sys$partial-list->vector 2 sys$partial-list->vector #f -1 ,:dead ,:all)
+ (vector-set! 3 vector-set! #f #xf1 ,:dead ,:vector)
+ (bytevector-set! 3 bytevector-set! #f #xf2 ,:dead ,:string)
+ (procedure-set! 3 procedure-set! #f #xf3 ,:dead ,:all)
+ (bytevector-like? 1 bytevector-like? #f -1 ,:immortal ,:none)
+ (vector-like? 1 vector-like? #f -1 ,:immortal ,:none)
+ (bytevector-like-ref 2 bytevector-like-ref #f -1 ,:string ,:none)
+ (bytevector-like-set! 3 bytevector-like-set! #f -1 ,:dead ,:string)
+ (sys$bvlcmp 2 sys$bvlcmp #f -1 ,:dead ,:all)
+ (vector-like-ref 2 vector-like-ref #f -1 ,:vector ,:none)
+ (vector-like-set! 3 vector-like-set! #f -1 ,:dead ,:vector)
+ (vector-like-length 1 vector-like-length #f -1 ,:immortal ,:none)
+ (bytevector-like-length 1 bytevector-like-length #f -1 ,:immortal ,:none)
+ (remainder 2 remainder #f -1 ,:immortal ,:none)
+ (sys$read-char 1 sys$read-char #f -1 ,:dead ,:io)
+ (gc-counter 0 gc-counter #f -1 ,:dead ,:none)
+ ,@(if (fixnum-primitives)
+ `((most-positive-fixnum
+ 0 most-positive-fixnum
+ #f -1 ,:immortal ,:none)
+ (most-negative-fixnum
+ 0 most-negative-fixnum
+ #f -1 ,:immortal ,:none)
+ (fx+ 2 fx+ ,sparc-imm? -1 ,:immortal ,:none)
+ (fx- 2 fx- ,sparc-imm? -1 ,:immortal ,:none)
+ (fx-- 1 fx-- #f -1 ,:immortal ,:none)
+ (fx* 2 fx* #f -1 ,:immortal ,:none)
+ (fx= 2 fx= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx< 2 fx< ,sparc-imm? -1 ,:immortal ,:none)
+ (fx<= 2 fx<= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx> 2 fx> ,sparc-imm? -1 ,:immortal ,:none)
+ (fx>= 2 fx>= ,sparc-imm? -1 ,:immortal ,:none)
+ (fxzero? 1 fxzero? #f -1 ,:immortal ,:none)
+ (fxpositive? 1 fxpositive? #f -1 ,:immortal ,:none)
+ (fxnegative? 1 fxnegative? #f -1 ,:immortal ,:none))
+ '())
+ ,@(if (flonum-primitives)
+ `((fl+ 2 + #f -1 ,:immortal ,:none)
+ (fl- 2 - #f -1 ,:immortal ,:none)
+ (fl-- 1 -- #f -1 ,:immortal ,:none)
+ (fl* 2 * #f -1 ,:immortal ,:none)
+ (fl= 2 = #f -1 ,:immortal ,:none)
+ (fl< 2 < #f -1 ,:immortal ,:none)
+ (fl<= 2 <= #f -1 ,:immortal ,:none)
+ (fl> 2 > #f -1 ,:immortal ,:none)
+ (fl>= 2 >= #f -1 ,:immortal ,:none))
+ '())
+
+ ; Added for CSE, representation analysis.
+
+ (,name:CHECK! -1 check! #f -1 ,:dead ,:none)
+ (vector-length:vec 1 vector-length:vec #f -1 ,:immortal ,:none)
+ (vector-ref:trusted 2 vector-ref:trusted ,sparc-imm? -1 ,:vector ,:none)
+ (vector-set!:trusted 3 vector-set!:trusted #f -1 ,:dead ,:vector)
+ (car:pair 1 car:pair #f -1 ,:car ,:none)
+ (cdr:pair 1 cdr:pair #f -1 ,:cdr ,:none)
+ (=:fix:fix 2 =:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<:fix:fix 2 <:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<=:fix:fix 2 <=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>=:fix:fix 2 >=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>:fix:fix 2 >:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+
+ ; Not yet implemented.
+
+ (+:idx:idx 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:fix:fix 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:exi:exi 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:flo:flo 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (=:flo:flo 2 =:flo:flo #f -1 ,:immortal ,:none)
+ (=:obj:flo 2 =:obj:flo #f -1 ,:immortal ,:none)
+ (=:flo:obj 2 =:flo:obj #f -1 ,:immortal ,:none)
+ )))
+
+; Not used by the Sparc assembler; for information only.
+
+(define $immediate-primops$
+ '((typetag-set! #x80)
+ (eq? #x81)
+ (+ #x82)
+ (- #x83)
+ (< #x84)
+ (<= #x85)
+ (= #x86)
+ (> #x87)
+ (>= #x88)
+ (char<? #x89)
+ (char<=? #x8a)
+ (char=? #x8b)
+ (char>? #x8c)
+ (char>=? #x8d)
+ (string-ref #x90)
+ (vector-ref #x91)
+ (bytevector-ref #x92)
+ (bytevector-like-ref -1)
+ (vector-like-ref -1)
+ (fx+ -1)
+ (fx- -1)
+ (fx-- -1)
+ (fx= -1)
+ (fx< -1)
+ (fx<= -1)
+ (fx> -1)
+ (fx>= -1)))
+
+; Operations introduced by peephole optimizer.
+
+(define $reg/op1/branchf ; reg/op1/branchf prim,k1,L
+ (make-mnemonic 'reg/op1/branchf))
+(define $reg/op2/branchf ; reg/op2/branchf prim,k1,k2,L
+ (make-mnemonic 'reg/op2/branchf))
+(define $reg/op2imm/branchf ; reg/op2imm/branchf prim,k1,x,L
+ (make-mnemonic 'reg/op2imm/branchf))
+(define $reg/op1/check ; reg/op1/check prim,k1,k2,k3,k4,exn
+ (make-mnemonic 'reg/op1/check))
+(define $reg/op2/check ; reg/op2/check prim,k1,k2,k3,k4,k5,exn
+ (make-mnemonic 'reg/op2/check))
+(define $reg/op2imm/check ; reg/op2imm/check prim,k1,x,k2,k3,k4,exn
+ (make-mnemonic 'reg/op2imm/check))
+(define $reg/op1/setreg ; reg/op1/setreg prim,k1,kr
+ (make-mnemonic 'reg/op1/setreg))
+(define $reg/op2/setreg ; reg/op2/setreg prim,k1,k2,kr
+ (make-mnemonic 'reg/op2/setreg))
+(define $reg/op2imm/setreg ; reg/op2imm/setreg prim,k1,x,kr
+ (make-mnemonic 'reg/op2imm/setreg))
+(define $reg/branchf ; reg/branchf k, L
+ (make-mnemonic 'reg/branchf))
+(define $reg/return ; reg/return k
+ (make-mnemonic 'reg/return))
+(define $reg/setglbl ; reg/setglbl k,x
+ (make-mnemonic 'reg/setglbl))
+(define $reg/op3 ; reg/op3 prim,k1,k2,k3
+ (make-mnemonic 'reg/op3))
+(define $const/setreg ; const/setreg const,k
+ (make-mnemonic 'const/setreg))
+(define $const/return ; const/return const
+ (make-mnemonic 'const/return))
+(define $global/setreg ; global/setreg x,k
+ (make-mnemonic 'global/setreg))
+(define $setrtn/branch ; setrtn/branch L,doc
+ (make-mnemonic 'setrtn/branch))
+(define $setrtn/invoke ; setrtn/invoke L
+ (make-mnemonic 'setrtn/invoke))
+(define $global/invoke ; global/invoke global,n
+ (make-mnemonic 'global/invoke))
+
+; misc
+
+(define $cons 'cons)
+(define $car:pair 'car)
+(define $cdr:pair 'cdr)
+
+; eof
+; Target-specific representations.
+;
+; A few of these representation types must be specified for every target:
+; rep:object
+; rep:procedure
+; rep:true
+; rep:false
+; rep:bottom
+
+(define-subtype 'true 'object) ; values that count as true
+(define-subtype 'eqtype 'object) ; can use EQ? instead of EQV?
+(define-subtype 'nonpointer 'eqtype) ; can omit write barrier
+(define-subtype 'eqtype1 'eqtype) ; eqtypes excluding #f
+(define-subtype 'boolean 'nonpointer)
+(define-subtype 'truth 'eqtype1) ; { #t }
+(define-subtype 'truth 'boolean)
+(define-subtype 'false 'boolean) ; { #f }
+(define-subtype 'eqtype1 'true)
+(define-subtype 'procedure 'true)
+(define-subtype 'vector 'true)
+(define-subtype 'bytevector 'true)
+(define-subtype 'string 'true)
+(define-subtype 'pair 'true)
+(define-subtype 'emptylist 'eqtype1)
+(define-subtype 'emptylist 'nonpointer)
+(define-subtype 'symbol 'eqtype1)
+(define-subtype 'char 'eqtype1)
+(define-subtype 'char 'nonpointer)
+(define-subtype 'number 'true)
+(define-subtype 'inexact 'number)
+(define-subtype 'flonum 'inexact)
+(define-subtype 'integer 'number)
+(define-subtype 'exact 'number)
+(define-subtype 'exactint 'integer)
+(define-subtype 'exactint 'exact)
+(define-subtype 'fixnum 'exactint)
+(define-subtype '!fixnum 'fixnum) ; 0 <= n
+(define-subtype 'fixnum! 'fixnum) ; n <= largest index
+(define-subtype 'index '!fixnum)
+(define-subtype 'index 'fixnum!)
+(define-subtype 'zero 'index)
+(define-subtype 'fixnum 'eqtype1)
+(define-subtype 'fixnum 'nonpointer)
+
+(compute-type-structure!)
+
+; If the intersection of rep1 and rep2 is known precisely,
+; but neither is a subtype of the other, then their intersection
+; should be declared explicitly.
+; Otherwise a conservative approximation will be used.
+
+(define-intersection 'true 'eqtype 'eqtype1)
+(define-intersection 'true 'boolean 'truth)
+(define-intersection 'exact 'integer 'exactint)
+(define-intersection '!fixnum 'fixnum! 'index)
+
+;(display-unions-and-intersections)
+
+; Parameters.
+
+(define rep:min_fixnum (- (expt 2 29)))
+(define rep:max_fixnum (- (expt 2 29) 1))
+(define rep:max_index (- (expt 2 24) 1))
+
+; The representations we'll recognize for now.
+
+(define rep:object (symbol->rep 'object))
+(define rep:true (symbol->rep 'true))
+(define rep:truth (symbol->rep 'truth))
+(define rep:false (symbol->rep 'false))
+(define rep:boolean (symbol->rep 'boolean))
+(define rep:pair (symbol->rep 'pair))
+(define rep:symbol (symbol->rep 'symbol))
+(define rep:number (symbol->rep 'number))
+(define rep:zero (symbol->rep 'zero))
+(define rep:index (symbol->rep 'index))
+(define rep:fixnum (symbol->rep 'fixnum))
+(define rep:exactint (symbol->rep 'exactint))
+(define rep:flonum (symbol->rep 'flonum))
+(define rep:exact (symbol->rep 'exact))
+(define rep:inexact (symbol->rep 'inexact))
+(define rep:integer (symbol->rep 'integer))
+;(define rep:real (symbol->rep 'real))
+(define rep:char (symbol->rep 'char))
+(define rep:string (symbol->rep 'string))
+(define rep:vector (symbol->rep 'vector))
+(define rep:procedure (symbol->rep 'procedure))
+(define rep:bottom (symbol->rep 'bottom))
+
+; Given the value of a quoted constant, return its representation.
+
+(define (representation-of-value x)
+ (cond ((boolean? x)
+ (if x
+ rep:truth
+ rep:false))
+ ((pair? x)
+ rep:pair)
+ ((symbol? x)
+ rep:symbol)
+ ((number? x)
+ (cond ((and (exact? x)
+ (integer? x))
+ (cond ((zero? x)
+ rep:zero)
+ ((<= 0 x rep:max_index)
+ rep:index)
+ ((<= rep:min_fixnum
+ x
+ rep:max_fixnum)
+ rep:fixnum)
+ (else
+ rep:exactint)))
+ ((and (inexact? x)
+ (real? x))
+ rep:flonum)
+ (else
+ ; We're not tracking other numbers yet.
+ rep:number)))
+ ((char? x)
+ rep:char)
+ ((string? x)
+ rep:string)
+ ((vector? x)
+ rep:vector)
+ ; Everything counts as true except for #f.
+ (else
+ rep:true)))
+
+; Tables that express the representation-specific operations,
+; and the information about representations that are implied
+; by certain operations.
+; FIXME: Currently way incomplete, but good enough for testing.
+
+(define rep-specific
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the procedure
+ ; in the last column can be called instead.
+
+ '(
+ ;(+ (index index) +:idx:idx)
+ ;(+ (fixnum fixnum) +:fix:fix)
+ ;(- (index index) -:idx:idx)
+ ;(- (fixnum fixnum) -:fix:fix)
+
+ (= (fixnum fixnum) =:fix:fix)
+ (< (fixnum fixnum) <:fix:fix)
+ (<= (fixnum fixnum) <=:fix:fix)
+ (> (fixnum fixnum) >:fix:fix)
+ (>= (fixnum fixnum) >=:fix:fix)
+
+ ;(+ (flonum flonum) +:flo:flo)
+ ;(- (flonum flonum) -:flo:flo)
+ ;(= (flonum flonum) =:flo:flo)
+ ;(< (flonum flonum) <:flo:flo)
+ ;(<= (flonum flonum) <=:flo:flo)
+ ;(> (flonum flonum) >:flo:flo)
+ ;(>= (flonum flonum) >=:flo:flo)
+
+ ;(vector-set!:trusted (vector fixnum nonpointer) vector-set!:trusted:imm)
+ )))
+
+(define rep-result
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the result
+ ; is described by the last column.
+
+ '((fixnum? (fixnum) (truth))
+ (vector? (vector) (truth))
+ (<= (zero !fixnum) (truth))
+ (>= (!fixnum zero) (truth))
+ (<=:fix:fix (zero !fixnum) (truth))
+ (>=:fix:fix (!fixnum zero) (truth))
+
+ (+ (index index) (!fixnum))
+ (+ (fixnum fixnum) (exactint))
+ (- (index index) (fixnum!))
+ (- (fixnum fixnum) (exactint))
+
+ (+ (flonum flonum) (flonum))
+ (- (flonum flonum) (flonum))
+
+ ;(+:idx:idx (index index) (!fixnum))
+ ;(-:idx:idx (index index) (fixnum!))
+ ;(+:fix:fix (index index) (exactint))
+ ;(+:fix:fix (fixnum fixnum) (exactint))
+ ;(-:idx:idx (index index) (fixnum))
+ ;(-:fix:fix (fixnum fixnum) (exactint))
+
+ (make-vector (object object) (vector))
+ (vector-length:vec (vector) (index))
+ (cons (object object) (pair))
+
+ ; Is it really all that useful to know that the result
+ ; of these comparisons is a boolean?
+
+ (= (number number) (boolean))
+ (< (number number) (boolean))
+ (<= (number number) (boolean))
+ (> (number number) (boolean))
+ (>= (number number) (boolean))
+
+ (=:fix:fix (fixnum fixnum) (boolean))
+ (<:fix:fix (fixnum fixnum) (boolean))
+ (<=:fix:fix (fixnum fixnum) (boolean))
+ (>:fix:fix (fixnum fixnum) (boolean))
+ (>=:fix:fix (fixnum fixnum) (boolean))
+ )))
+
+(define rep-informing
+
+ (representation-table
+
+ ; When the predicate in the first column is called in the test position
+ ; of a conditional expression, on arguments described by the second
+ ; column, then the arguments are described by the third column if the
+ ; predicate returns true, and by the fourth column if the predicate
+ ; returns false.
+
+ '(
+ (fixnum? (object) (fixnum) (object))
+ (flonum? (object) (flonum) (object))
+ (vector? (object) (vector) (object))
+ (pair? (object) (pair) (object))
+
+ (= (exactint index) (index index) (exactint index))
+ (= (index exactint) (index index) (index exactint))
+ (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (< (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+ (< (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+
+ (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (> (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (> (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (=:fix:fix (exactint index) (index index) (exactint index))
+ (=:fix:fix (index exactint) (index index) (index exactint))
+ (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+ )))
+; Copyright 1991 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 25 April 1999.
+;
+; Second pass of the Twobit compiler:
+; single assignment analysis, local source transformations,
+; assignment elimination, and lambda lifting.
+; The code for assignment elimination and lambda lifting
+; are in a separate file.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+
+(define (pass2 exp)
+ (simplify exp (make-notepad #f)))
+
+; Given an expression and a "notepad" data structure that conveys
+; inherited attributes, performs the appropriate optimizations and
+; destructively modifies the notepad to record various attributes
+; that it synthesizes while traversing the expression. In particular,
+; any nested lambda expressions and any variable references will be
+; noted in the notepad.
+
+(define (simplify exp notepad)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (simplify-lambda exp notepad))
+ ((set!) (simplify-assignment exp notepad))
+ ((if) (simplify-conditional exp notepad))
+ ((begin) (if (variable? exp)
+ (begin (notepad-var-add! notepad (variable.name exp))
+ exp)
+ (simplify-sequential exp notepad)))
+ (else (simplify-call exp notepad))))
+
+; Most optimization occurs here.
+; The right hand sides of internal definitions are simplified,
+; as is the body.
+; Internal definitions of enclosed lambda expressions may
+; then be lifted to this one.
+; Single assignment analysis creates internal definitions.
+; Single assignment elimination converts single assignments
+; to bindings where possible, and renames arguments whose value
+; is ignored.
+; Assignment elimination then replaces all remaining assigned
+; variables by heap-allocated cells.
+
+(define (simplify-lambda exp notepad)
+ (notepad-lambda-add! notepad exp)
+ (let ((defs (lambda.defs exp))
+ (body (lambda.body exp))
+ (newnotepad (make-notepad exp)))
+ (for-each (lambda (def)
+ (simplify-lambda (def.rhs def) newnotepad))
+ defs)
+ (lambda.body-set! exp (simplify body newnotepad))
+ (lambda.F-set! exp (notepad-free-variables newnotepad))
+ (lambda.G-set! exp (notepad-captured-variables newnotepad))
+ (single-assignment-analysis exp newnotepad)
+ (let ((known-lambdas (notepad.nonescaping newnotepad)))
+ (for-each (lambda (L)
+ (if (memq L known-lambdas)
+ (lambda-lifting L exp)
+ (lambda-lifting L L)))
+ (notepad.lambdas newnotepad))))
+ (single-assignment-elimination exp notepad)
+ (assignment-elimination exp)
+ (if (not (notepad.parent notepad))
+ ; This is an outermost lambda expression.
+ (lambda-lifting exp exp))
+ exp)
+
+; SIMPLIFY-ASSIGNMENT performs this transformation:
+;
+; (set! I (begin ... E))
+; -> (begin ... (set! I E))
+
+(define (simplify-assignment exp notepad)
+ (notepad-var-add! notepad (assignment.lhs exp))
+ (let ((rhs (simplify (assignment.rhs exp) notepad)))
+ (cond ((begin? rhs)
+ (let ((exprs (reverse (begin.exprs rhs))))
+ (assignment.rhs-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons exp (cdr exprs))))
+ notepad)))
+ (else (assignment.rhs-set! exp rhs) exp))))
+
+(define (simplify-sequential exp notepad)
+ (let ((exprs (map (lambda (exp) (simplify exp notepad))
+ (begin.exprs exp))))
+ (begin.exprs-set! exp exprs)
+ (post-simplify-begin exp notepad)))
+
+; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
+; flattens any nested BEGINs and removes trivial expressions that
+; don't appear in the last position. The second argument is used only
+; if a lambda expression is removed.
+; This procedure is careful to return E instead of (BEGIN E).
+; Fairly harmless bug: a variable reference removed by this procedure
+; may remain on the notepad when it shouldn't.
+
+(define (post-simplify-begin exp notepad)
+ (let ((unspecified-expression (make-unspecified)))
+ ; (flatten exprs '()) returns the flattened exprs in reverse order.
+ (define (flatten exprs flattened)
+ (cond ((null? exprs) flattened)
+ ((begin? (car exprs))
+ (flatten (cdr exprs)
+ (flatten (begin.exprs (car exprs)) flattened)))
+ (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
+ (define (filter exprs filtered)
+ (if (null? exprs)
+ filtered
+ (let ((exp (car exprs)))
+ (cond ((constant? exp) (filter (cdr exprs) filtered))
+ ((variable? exp) (filter (cdr exprs) filtered))
+ ((lambda? exp)
+ (notepad.lambdas-set!
+ notepad
+ (remq exp (notepad.lambdas notepad)))
+ (filter (cdr exprs) filtered))
+ ((equal? exp unspecified-expression)
+ (filter (cdr exprs) filtered))
+ (else (filter (cdr exprs) (cons exp filtered)))))))
+ (let ((exprs (flatten (begin.exprs exp) '())))
+ (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
+ (if (null? (cdr (begin.exprs exp)))
+ (car (begin.exprs exp))
+ exp))))
+
+; SIMPLIFY-CALL performs this transformation:
+;
+; (... (begin ... E) ...)
+; -> (begin ... (... E ...))
+;
+; It also takes care of LET transformations.
+
+(define (simplify-call exp notepad)
+ (define (loop args newargs exprs)
+ (cond ((null? args)
+ (finish newargs exprs))
+ ((begin? (car args))
+ (let ((newexprs (reverse (begin.exprs (car args)))))
+ (loop (cdr args)
+ (cons (car newexprs) newargs)
+ (append (cdr newexprs) exprs))))
+ (else (loop (cdr args) (cons (car args) newargs) exprs))))
+ (define (finish newargs exprs)
+ (call.args-set! exp (reverse newargs))
+ (let* ((newexp
+ (if (lambda? (call.proc exp))
+ (simplify-let exp notepad)
+ (begin
+ (call.proc-set! exp
+ (simplify (call.proc exp) notepad))
+ exp)))
+ (newexp
+ (if (and (call? newexp)
+ (variable? (call.proc newexp)))
+ (let* ((procname (variable.name (call.proc newexp)))
+ (args (call.args newexp))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value
+ (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ newexp))
+ newexp)))
+ (cond ((and (call? newexp)
+ (begin? (call.proc newexp)))
+ (let ((exprs0 (reverse (begin.exprs (call.proc newexp)))))
+ (call.proc-set! newexp (car exprs0))
+ (post-simplify-begin
+ (make-begin (reverse
+ (cons newexp
+ (append (cdr exprs0) exprs))))
+ notepad)))
+ ((null? exprs)
+ newexp)
+ (else
+ (post-simplify-begin
+ (make-begin (reverse (cons newexp exprs)))
+ notepad)))))
+ (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
+ (call.args exp)))
+ (loop (call.args exp) '() '()))
+
+; SIMPLIFY-LET performs these transformations:
+;
+; ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
+; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (LIST Ek+1 ...))
+;
+; ((lambda (I1 I2 ...) (begin D ...) (quote ...) E) L ...)
+; -> ((lambda (I2 ...) (begin (define I1 L) D ...) (quote ...) E) ...)
+;
+; provided I1 is not assigned and each reference to I1 is in call position.
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (begin I1))
+; E1)
+;
+; -> E1
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (if (begin I1) E2 E3))
+; E1)
+;
+; -> (if E1 E2 E3)
+;
+; (Together with SIMPLIFY-CONDITIONAL, this cleans up the output of the OR
+; macro and enables certain control optimizations.)
+;
+; ((lambda (I1 I2 ...)
+; (begin D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; E)
+; K ...)
+; -> ((lambda (I2 ...)
+; (begin D' ...)
+; (quote (... ...) ...)
+; E')
+; ...)
+;
+; where D' ... and E' ... are obtained from D ... and E ...
+; by replacing all references to I1 by K. This transformation
+; applies if K is a constant that can be duplicated without changing
+; its EQV? behavior.
+;
+; ((lambda () (begin) (quote ...) E)) -> E
+;
+; ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
+; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
+;
+; (Single assignment analysis, performed by the simplifier for lambda
+; expressions, detects unused arguments and replaces them in the argument
+; list by the special identifier IGNORED.)
+
+(define (simplify-let exp notepad)
+ (define proc (call.proc exp))
+
+ ; Loop1 operates before simplification of the lambda body.
+
+ (define (loop1 formals actuals processed-formals processed-actuals)
+ (cond ((null? formals)
+ (if (not (null? actuals))
+ (pass2-error p2error:wna exp))
+ (return1 processed-formals processed-actuals))
+ ((symbol? formals)
+ (return1 (cons formals processed-formals)
+ (cons (make-call-to-LIST actuals) processed-actuals)))
+ ((null? actuals)
+ (pass2-error p2error:wna exp)
+ (return1 processed-formals
+ processed-actuals))
+ ((and (lambda? (car actuals))
+ (let ((Rinfo (R-lookup (lambda.R proc) (car formals))))
+ (and (null? (R-entry.assignments Rinfo))
+ (= (length (R-entry.references Rinfo))
+ (length (R-entry.calls Rinfo))))))
+ (let ((I (car formals))
+ (L (car actuals)))
+ (notepad-nonescaping-add! notepad L)
+ (lambda.defs-set! proc
+ (cons (make-definition I L)
+ (lambda.defs proc)))
+ (standardize-known-calls L
+ (R-entry.calls
+ (R-lookup (lambda.R proc) I)))
+ (lambda.F-set! proc (union (lambda.F proc)
+ (free-variables L)))
+ (lambda.G-set! proc (union (lambda.G proc) (lambda.G L))))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ ((and (constant? (car actuals))
+ (let ((x (constant.value (car actuals))))
+ (or (boolean? x)
+ (number? x)
+ (symbol? x)
+ (char? x))))
+ (let* ((I (car formals))
+ (Rinfo (R-lookup (lambda.R proc) I)))
+ (if (null? (R-entry.assignments Rinfo))
+ (begin
+ (for-each (lambda (ref)
+ (variable-set! ref (car actuals)))
+ (R-entry.references Rinfo))
+ (lambda.R-set! proc (remq Rinfo (lambda.R proc)))
+ (lambda.F-set! proc (remq I (lambda.F proc)))
+ (lambda.G-set! proc (remq I (lambda.G proc)))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+ (else (if (null? actuals)
+ (pass2-error p2error:wna exp))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+
+ (define (return1 rev-formals rev-actuals)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals)))
+ (lambda.args-set! proc formals)
+ (if (and (not (null? formals))
+ (null? (cdr formals))
+ (let* ((x (car formals))
+ (R (lambda.R proc))
+ (refs (references R x)))
+ (and (= 1 (length refs))
+ (null? (assignments R x)))))
+ (let ((x (car formals))
+ (body (lambda.body proc)))
+ (cond ((and (variable? body)
+ (eq? x (variable.name body)))
+ (simplify (car actuals) notepad))
+ ((and (conditional? body)
+ (let ((B0 (if.test body)))
+ (variable? B0)
+ (eq? x (variable.name B0))))
+ (if.test-set! body (car actuals))
+ (simplify body notepad))
+ (else
+ (return1-finish formals actuals))))
+ (return1-finish formals actuals))))
+
+ (define (return1-finish formals actuals)
+ (simplify-lambda proc notepad)
+ (loop2 formals actuals '() '() '()))
+
+ ; Loop2 operates after simplification of the lambda body.
+
+ (define (loop2 formals actuals processed-formals processed-actuals for-effect)
+ (cond ((null? formals)
+ (return2 processed-formals processed-actuals for-effect))
+ ((ignored? (car formals))
+ (loop2 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else (loop2 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect))))
+
+ (define (return2 rev-formals rev-actuals rev-for-effect)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals))
+ (for-effect (reverse rev-for-effect)))
+ (lambda.args-set! proc formals)
+ (call.args-set! exp actuals)
+ (let ((exp (if (and (null? actuals)
+ (or (null? (lambda.defs proc))
+ (and (notepad.parent notepad)
+ (POLICY:LIFT? proc
+ (notepad.parent notepad)
+ (map (lambda (def) '())
+ (lambda.defs proc))))))
+ (begin (for-each (lambda (I)
+ (notepad-var-add! notepad I))
+ (lambda.F proc))
+ (if (not (null? (lambda.defs proc)))
+ (let ((parent (notepad.parent notepad))
+ (defs (lambda.defs proc))
+ (R (lambda.R proc)))
+ (lambda.defs-set!
+ parent
+ (append defs (lambda.defs parent)))
+ (lambda.defs-set! proc '())
+ (lambda.R-set!
+ parent
+ (append (map (lambda (def)
+ (R-lookup R (def.lhs def)))
+ defs)
+ (lambda.R parent)))))
+ (lambda.body proc))
+ exp)))
+ (if (null? for-effect)
+ exp
+ (post-simplify-begin (make-begin (append for-effect (list exp)))
+ notepad)))))
+
+ (notepad-nonescaping-add! notepad proc)
+ (loop1 (lambda.args proc) (call.args exp) '() '()))
+
+; Single assignment analysis performs the transformation
+;
+; (lambda (... I ...)
+; (begin D ...)
+; (quote (... (I <references> ((set! I L)) <calls>) ...) ...)
+; (begin (set! I L) E1 ...))
+; -> (lambda (... IGNORED ...)
+; (begin (define I L) D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; (begin E1 ...))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs so
+; that procedure definitions/bindings come first.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-analysis L notepad)
+ (let ((formals (lambda.args L))
+ (defs (lambda.defs L))
+ (R (lambda.R L))
+ (body (lambda.body L)))
+ (define (finish! exprs escapees)
+ (begin.exprs-set! body
+ (append (reverse escapees)
+ exprs))
+ (lambda.body-set! L (post-simplify-begin body '())))
+ (if (begin? body)
+ (let loop ((exprs (begin.exprs body))
+ (escapees '()))
+ (let ((first (car exprs)))
+ (if (and (assignment? first)
+ (not (null? (cdr exprs))))
+ (let ((I (assignment.lhs first))
+ (rhs (assignment.rhs first)))
+ (if (and (lambda? rhs)
+ (local? R I)
+ (= 1 (length (assignments R I))))
+ (if (= (length (calls R I))
+ (length (references R I)))
+ (begin (notepad-nonescaping-add! notepad rhs)
+ (flag-as-ignored I L)
+ (lambda.defs-set! L
+ (cons (make-definition I rhs)
+ (lambda.defs L)))
+ (assignments-set! R I '())
+ (standardize-known-calls
+ rhs
+ (R-entry.calls (R-lookup R I)))
+ (loop (cdr exprs) escapees))
+ (loop (cdr exprs)
+ (cons (car exprs) escapees)))
+ (finish! exprs escapees)))
+ (finish! exprs escapees)))))))
+
+(define (standardize-known-calls L calls)
+ (let ((formals (lambda.args L)))
+ (cond ((not (list? formals))
+ (let* ((newformals (make-null-terminated formals))
+ (n (- (length newformals) 1)))
+ (lambda.args-set! L newformals)
+ (for-each (lambda (call)
+ (if (>= (length (call.args call)) n)
+ (call.args-set!
+ call
+ (append (list-head (call.args call) n)
+ (list
+ (make-call-to-LIST
+ (list-tail (call.args call) n)))))
+ (pass2-error p2error:wna call)))
+ calls)))
+ (else (let ((n (length formals)))
+ (for-each (lambda (call)
+ (if (not (= (length (call.args call)) n))
+ (pass2-error p2error:wna call)))
+ calls))))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 13 November 1998
+;
+; Second pass of the Twobit compiler, part 2:
+; single assignment elimination, assignment elimination,
+; and lambda lifting.
+;
+; See part 1 for further documentation.
+
+; Single assignment elimination performs the transformation
+;
+; (lambda (... I1 ... In ...)
+; (begin D ...)
+; (begin (set! I1 E1)
+; ...
+; (set! In En)
+; E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (let* ((I1 E1) ... (In En))
+; (begin D ...)
+; (begin E ...)))
+;
+; provided for each k:
+;
+; 1. Ik does not occur in E1, ..., Ek.
+; 2. Either E1 through Ek contain no procedure calls
+; or Ik is not referenced by an escaping lambda expression.
+; 3. Ik is assigned only once.
+;
+; I doubt whether the third condition is really necessary, but
+; dropping it would involve a more complex calculation of the
+; revised referencing information.
+;
+; A more precise description of the transformation:
+;
+; (lambda (... I1 ... In ...)
+; (begin (define F1 L1) ...)
+; (quote (... (I1 <references> ((set! I1 E1)) <calls>) ...
+; (In <references> ((set! In En)) <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin (set! I1 E1) ... (set! In En) E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (begin)
+; (quote (...) ...)
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 <references> () <calls>)) ...)
+; ...
+; ((lambda (In)
+; (begin (define F1 L1) ...)
+; (quote (... (In <references> () <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin E ...))
+; En)
+; ...)
+; E1))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs
+; so that procedure definitions/bindings come first, followed by
+; definitions/bindings whose right hand side contains no calls,
+; followed by definitions/bindings of variables that do not escape,
+; followed by all other definitions/bindings.
+;
+; Pass 1 can't tell which variables escape, however. Pass 2 can't tell
+; which variables escape either until all enclosed lambda expressions
+; have been simplified and the first transformation above has been
+; performed. That is why single assignment analysis precedes single
+; assignment elimination. As implemented here, an assignment that does
+; not satisfy the conditions above will prevent the transformation from
+; being applied to any subsequent assignments.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-elimination L notepad)
+
+ (if (begin? (lambda.body L))
+
+ (let* ((formals (make-null-terminated (lambda.args L)))
+ (defined (map def.lhs (lambda.defs L)))
+ (escaping (intersection formals
+ (notepad-captured-variables notepad)))
+ (R (lambda.R L)))
+
+ ; Given:
+ ; exprs that remain in the body;
+ ; assigns that will be replaced by let* variables;
+ ; call-has-occurred?, a boolean;
+ ; free variables of the assigns;
+ ; Performs the transformation described above.
+
+ (define (loop exprs assigns call-has-occurred? free)
+ (cond ((null? (cdr exprs))
+ (return exprs assigns))
+ ((assignment? (car exprs))
+ (let ((I1 (assignment.lhs (car exprs)))
+ (E1 (assignment.rhs (car exprs))))
+ (if (and (memq I1 formals)
+ (= (length (assignments R I1)) 1)
+ (not (and call-has-occurred?
+ (memq I1 escaping))))
+ (let* ((free-in-E1 (free-variables E1))
+ (newfree (union free-in-E1 free)))
+ (if (or (memq I1 newfree)
+ (not
+ (empty-set?
+ (intersection free-in-E1 defined))))
+ (return exprs assigns)
+ (loop (cdr exprs)
+ (cons (car exprs) assigns)
+ (or call-has-occurred?
+ (might-return-twice? E1))
+ newfree)))
+ (return exprs assigns))))
+ (else (return exprs assigns))))
+
+ (define (return exprs assigns)
+ (if (not (null? assigns))
+ (let ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (defs (lambda.defs L))
+ (F (lambda.F L))
+ (G (lambda.G L)))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ defs
+ (cons (R-entry R I)
+ (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ (make-begin exprs))))
+ (lambda.defs-set! L '())
+ (for-each (lambda (entry)
+ (lambda.R-set! L (remq entry R)))
+ (lambda.R L2))
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (define (return-loop assigns body)
+ (if (null? assigns)
+ (let ((L3 (call.proc body)))
+ (lambda.body-set! L body)
+ (lambda-lifting L3 L))
+ (let* ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (L3 (call.proc body))
+ (F (remq I (lambda.F L3)))
+ (G (remq I (lambda.G L3))))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ '()
+ (list (R-entry R I))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ body)))
+ (lambda.R-set! L (remq (R-entry R I) R))
+ (lambda-lifting L3 L2)
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (loop (begin.exprs (lambda.body L)) '() #f '())))
+
+ L)
+
+; Temporary definitions.
+
+(define (free-variables exp)
+ (case (car exp)
+ ((quote) '())
+ ((lambda) (difference (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ ((set!) (union (list (assignment.lhs exp))
+ (free-variables (assignment.rhs exp))))
+ ((if) (union (free-variables (if.test exp))
+ (free-variables (if.then exp))
+ (free-variables (if.else exp))))
+ ((begin) (if (variable? exp)
+ (list (variable.name exp))
+ (apply union (map free-variables (begin.exprs exp)))))
+ (else (apply union (map free-variables exp)))))
+
+(define (might-return-twice? exp)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (might-return-twice? (assignment.rhs exp)))
+ ((if) (or (might-return-twice? (if.test exp))
+ (might-return-twice? (if.then exp))
+ (might-return-twice? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? might-return-twice? (begin.exprs exp))))
+ (else #t)))
+
+
+; Assignment elimination replaces variables that appear on the left
+; hand side of an assignment by data structures. This is necessary
+; to avoid some nasty complications with lambda lifting.
+;
+; This procedure operates by side effect.
+
+(define (assignment-elimination L)
+ (let ((R (lambda.R L)))
+
+ ; Given a list of entries, return those for assigned variables.
+
+ (define (loop entries assigned)
+ (cond ((null? entries)
+ (if (not (null? assigned))
+ (eliminate assigned)))
+ ((not (null? (R-entry.assignments (car entries))))
+ (loop (cdr entries) (cons (car entries) assigned)))
+ ((null? (R-entry.references (car entries)))
+ (flag-as-ignored (R-entry.name (car entries)) L)
+ (loop (cdr entries) assigned))
+ (else (loop (cdr entries) assigned))))
+
+ ; Given a list of entries for assigned variables I1 ...,
+ ; remove the assignments by replacing the body by a LET of the form
+ ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
+ ; by calls to CELL-REF, and by replacing assignments by calls to
+ ; CELL-SET!.
+
+ (define (eliminate assigned)
+ (let* ((oldnames (map R-entry.name assigned))
+ (newnames (map generate-new-name oldnames)))
+ (let ((augmented-entries (map list newnames assigned))
+ (renaming-alist (map cons oldnames newnames))
+ (defs (lambda.defs L)))
+ (for-each cellify! augmented-entries)
+ (for-each (lambda (def)
+ (do ((free (lambda.F (def.rhs def)) (cdr free)))
+ ((null? free))
+ (let ((z (assq (car free) renaming-alist)))
+ (if z
+ (set-car! free (cdr z))))))
+ defs)
+ (let ((newbody
+ (make-call
+ (make-lambda (map car augmented-entries)
+ defs
+ (union (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs)
+ (map new-reference-info augmented-entries))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.F L) oldnames))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.G L) oldnames))
+ (lambda.decls L)
+ (lambda.doc L)
+ (lambda.body L))
+ (map (lambda (name)
+ (make-call (make-variable name:MAKE-CELL)
+ (list (make-variable name))))
+ (map R-entry.name assigned)))))
+ (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
+ (difference (lambda.F L)
+ (map def.lhs (lambda.defs L)))))
+ (lambda.defs-set! L '())
+ (for-each update-old-reference-info!
+ (map (lambda (arg)
+ (car (call.args arg)))
+ (call.args newbody)))
+ (lambda.body-set! L newbody)
+ (lambda-lifting (call.proc newbody) L)))))
+
+ (define (generate-new-name name)
+ (string->symbol (string-append cell-prefix (symbol->string name))))
+
+ ; In addition to replacing references and assignments involving the
+ ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
+ ; uses the old entry to collect the referencing information for the
+ ; new variable.
+
+ (define (cellify! augmented-entry)
+ (let ((newname (car augmented-entry))
+ (entry (cadr augmented-entry)))
+ (do ((refs (R-entry.references entry)
+ (cdr refs)))
+ ((null? refs))
+ (let* ((reference (car refs))
+ (newref (make-variable newname)))
+ (set-car! reference (make-variable name:CELL-REF))
+ (set-car! (cdr reference) newref)
+ (set-car! refs newref)))
+ (do ((assigns (R-entry.assignments entry)
+ (cdr assigns)))
+ ((null? assigns))
+ (let* ((assignment (car assigns))
+ (newref (make-variable newname)))
+ (set-car! assignment (make-variable name:CELL-SET!))
+ (set-car! (cdr assignment) newref)
+ (R-entry.references-set! entry
+ (cons newref
+ (R-entry.references entry)))))
+ (R-entry.assignments-set! entry '())))
+
+ ; This procedure creates a brand new entry for a new variable, extracting
+ ; the references stored in the old entry by CELLIFY!.
+
+ (define (new-reference-info augmented-entry)
+ (make-R-entry (car augmented-entry)
+ (R-entry.references (cadr augmented-entry))
+ '()
+ '()))
+
+ ; This procedure updates the old entry to reflect the fact that it is
+ ; now referenced once and never assigned.
+
+ (define (update-old-reference-info! ref)
+ (references-set! R (variable.name ref) (list ref))
+ (assignments-set! R (variable.name ref) '())
+ (calls-set! R (variable.name ref) '()))
+
+ (loop R '())))
+
+; Lambda lifting raises internal definitions to outer scopes to avoid
+; having to choose between creating a closure or losing tail recursion.
+; If L is not #f, then L2 is a lambda expression nested within L.
+; Any internal definitions that occur within L2 may be lifted to L
+; by adding extra arguments to the defined procedure and to all calls to it.
+; Lambda lifting is not a clear win, because the extra arguments could
+; easily become more expensive than creating a closure and referring
+; to the non-local arguments through the closure. The heuristics used
+; to decide whether to lift a group of internal definitions are isolated
+; within the POLICY:LIFT? procedure.
+
+; L2 can be the same as L, so the order of side effects is critical.
+
+(define (lambda-lifting L2 L)
+
+ ; The call to sort is optional. It gets the added arguments into
+ ; the same order they appear in the formals list, which is an
+ ; advantage for register targeting.
+
+ (define (lift L2 L args-to-add)
+ (let ((formals (make-null-terminated (lambda.args L2))))
+ (do ((defs (lambda.defs L2) (cdr defs))
+ (args-to-add args-to-add (cdr args-to-add)))
+ ((null? defs))
+ (let* ((def (car defs))
+ (entry (R-lookup (lambda.R L2) (def.lhs def)))
+ (calls (R-entry.calls entry))
+ (added (twobit-sort (lambda (x y)
+ (let ((xx (memq x formals))
+ (yy (memq y formals)))
+ (if (and xx yy)
+ (> (length xx) (length yy))
+ #t)))
+ (car args-to-add)))
+ (L3 (def.rhs def)))
+ ; The flow equation guarantees that these added arguments
+ ; will occur free by the time this round of lifting is done.
+ (lambda.F-set! L3 (union added (lambda.F L3)))
+ (lambda.args-set! L3 (append added (lambda.args L3)))
+ (for-each (lambda (call)
+ (let ((newargs (map make-variable added)))
+ ; The referencing information is made obsolete here!
+ (call.args-set! call
+ (append newargs (call.args call)))))
+ calls)
+ (lambda.R-set! L2 (remq entry (lambda.R L2)))
+ (lambda.R-set! L (cons entry (lambda.R L)))
+ ))
+ (if (not (eq? L2 L))
+ (begin
+ (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
+ (lambda.defs-set! L2 '())))))
+
+ (if L
+ (if (not (null? (lambda.defs L2)))
+ (let ((args-to-add (compute-added-arguments
+ (lambda.defs L2)
+ (make-null-terminated (lambda.args L2)))))
+ (if (POLICY:LIFT? L2 L args-to-add)
+ (lift L2 L args-to-add))))))
+
+; Given a list of definitions ((define f1 ...) ...) and a set of formals
+; N over which the definitions may be lifted, returns a list of the
+; subsets of N that need to be added to each procedure definition
+; as new arguments.
+;
+; Algorithm: Let F_i be the variables that occur free in the body of
+; the lambda expression associated with f_i. Construct the call graph.
+; Solve the flow equations
+;
+; A_i = (F_i /\ N) \/ (\/ {A_j | A_i calls A_j})
+;
+; where /\ is intersection and \/ is union.
+
+(define (compute-added-arguments defs formals)
+ (let ((procs (map def.lhs defs))
+ (freevars (map lambda.F (map def.rhs defs))))
+ (let ((callgraph (map (lambda (names)
+ (map (lambda (name)
+ (position name procs))
+ (intersection names procs)))
+ freevars))
+ (added_0 (map (lambda (names)
+ (intersection names formals))
+ freevars)))
+ (vector->list
+ (compute-fixedpoint
+ (make-vector (length procs) '())
+ (list->vector (map (lambda (term0 indexes)
+ (lambda (approximations)
+ (union term0
+ (apply union
+ (map (lambda (i)
+ (vector-ref approximations i))
+ indexes)))))
+ added_0
+ callgraph))
+ set-equal?)))))
+
+(define (position x l)
+ (cond ((eq? x (car l)) 0)
+ (else (+ 1 (position x (cdr l))))))
+
+; Given a vector of starting approximations,
+; a vector of functions that compute a next approximation
+; as a function of the vector of approximations,
+; and an equality predicate,
+; returns a vector of fixed points.
+
+(define (compute-fixedpoint v functions equiv?)
+ (define (loop i flag)
+ (if (negative? i)
+ (if flag
+ (loop (- (vector-length v) 1) #f)
+ v)
+ (let ((next_i ((vector-ref functions i) v)))
+ (if (equiv? next_i (vector-ref v i))
+ (loop (- i 1) flag)
+ (begin (vector-set! v i next_i)
+ (loop (- i 1) #t))))))
+ (loop (- (vector-length v) 1) #f))
+
+
+; Given a lambda expression L2, its parent lambda expression
+; L (which may be the same as L2, or #f), and a list of the
+; lists of arguments that would need to be added to known
+; local procedures, returns #t iff lambda lifting should be done.
+;
+; Here are some heuristics:
+;
+; Don't lift if it means adding too many arguments.
+; Don't lift large groups of definitions.
+; In questionable cases it is better to lift to an outer
+; lambda expression that already contains internal
+; definitions than to one that doesn't.
+; It is better not to lift if the body contains a lambda
+; expression that has to be closed anyway.
+
+(define (POLICY:LIFT? L2 L args-to-add)
+ (and (lambda-optimizations)
+ (not (lambda? (lambda.body L2)))
+ (every? (lambda (addlist)
+ (< (length addlist) 6))
+ args-to-add)))
+; Copyright 1991 William D Clinger (for SIMPLIFY-CONDITIONAL)
+; Copyright 1999 William D Clinger (for everything else)
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 April 1999.
+;
+; Some source transformations on IF expressions:
+;
+; (if '#f E1 E2) E2
+; (if 'K E1 E2) E1 K != #f
+; (if (if B0 '#f '#f) E1 E2) (begin B0 E2)
+; (if (if B0 '#f 'K ) E1 E2) (if B0 E2 E1) K != #f
+; (if (if B0 'K '#f) E1 E2) (if B0 E1 E2) K != #f
+; (if (if B0 'K1 'K2) E1 E2) (begin B0 E1) K1, K2 != #f
+; (if (if B0 (if B1 #t #f) B2) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if B0 B1 (if B2 #t #f)) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if X X B0 ) E1 E2) (if (if X #t B0) E1 E2) X a variable
+; (if (if X B0 X ) E1 E2) (if (if X B0 #f) E1 E2) X a variable
+; (if ((lambda (X) (if ((lambda (X)
+; (if X X B2)) B0) (if X #t (if B2 #t #f))) B0)
+; E1 E2) E1 E2)
+; (if (begin ... B0) E1 E2) (begin ... (if B0 E1 E2))
+; (if (not E0) E1 E2) (if E0 E2 E1) not is integrable
+;
+; FIXME: Three of the transformations above are intended to clean up
+; the output of the OR macro. It isn't yet clear how well this works.
+
+(define (simplify-conditional exp notepad)
+ (define (coercion-to-boolean? exp)
+ (and (conditional? exp)
+ (let ((E1 (if.then exp))
+ (E2 (if.else exp)))
+ (and (constant? E1)
+ (eq? #t (constant.value E1))
+ (constant? E2)
+ (eq? #f (constant.value E2))))))
+ (if (not (control-optimization))
+ (begin (if.test-set! exp (simplify (if.test exp) notepad))
+ (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp)
+ (let* ((test (if.test exp)))
+ (if (and (call? test)
+ (lambda? (call.proc test))
+ (let* ((L (call.proc test))
+ (body (lambda.body L)))
+ (and (conditional? body)
+ (let ((R (lambda.R L))
+ (B0 (if.test body))
+ (B1 (if.then body)))
+ (and (variable? B0)
+ (variable? B1)
+ (let ((x (variable.name B0)))
+ (and (eq? x (variable.name B1))
+ (local? R x)
+ (= 1 (length R))
+ (= 1 (length (call.args test))))))))))
+ (let* ((L (call.proc test))
+ (R (lambda.R L))
+ (body (lambda.body L))
+ (ref (if.then body))
+ (x (variable.name ref))
+ (entry (R-entry R x)))
+ (if.then-set! body (make-constant #t))
+ (if.else-set! body
+ (make-conditional (if.else body)
+ (make-constant #t)
+ (make-constant #f)))
+ (R-entry.references-set! entry
+ (remq ref
+ (R-entry.references entry)))
+ (simplify-conditional exp notepad))
+ (let loop ((test (simplify (if.test exp) notepad)))
+ (if.test-set! exp test)
+ (cond ((constant? test)
+ (simplify (if (constant.value test)
+ (if.then exp)
+ (if.else exp))
+ notepad))
+ ((and (conditional? test)
+ (constant? (if.then test))
+ (constant? (if.else test)))
+ (cond ((and (constant.value (if.then test))
+ (constant.value (if.else test)))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.then exp)
+ notepad)))
+ notepad))
+ ((and (not (constant.value (if.then test)))
+ (not (constant.value (if.else test))))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.else exp)
+ notepad)))
+ notepad))
+ (else (if (not (constant.value (if.then test)))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp)))
+ (if.test-set! exp (if.test test))
+ (loop (if.test exp)))))
+ ((and (conditional? test)
+ (or (coercion-to-boolean? (if.then test))
+ (coercion-to-boolean? (if.else test))))
+ (if (coercion-to-boolean? (if.then test))
+ (if.then-set! test (if.test (if.then test)))
+ (if.else-set! test (if.test (if.else test))))
+ (loop test))
+ ((and (conditional? test)
+ (variable? (if.test test))
+ (let ((x (variable.name (if.test test))))
+ (or (and (variable? (if.then test))
+ (eq? x (variable.name (if.then test)))
+ 1)
+ (and (variable? (if.else test))
+ (eq? x (variable.name (if.else test)))
+ 2))))
+ =>
+ (lambda (n)
+ (case n
+ ((1) (if.then-set! test (make-constant #t)))
+ ((2) (if.else-set! test (make-constant #f))))
+ (loop test)))
+ ((begin? test)
+ (let ((exprs (reverse (begin.exprs test))))
+ (if.test-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons (loop (car exprs))
+ (cdr exprs))))
+ notepad)))
+ ((and (call? test)
+ (variable? (call.proc test))
+ (eq? (variable.name (call.proc test)) name:NOT)
+ (integrable? name:NOT)
+ (integrate-usual-procedures)
+ (= (length (call.args test)) 1))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp))
+ (loop (car (call.args test))))
+ (else
+ (simplify-case exp notepad))))))))
+
+; Given a conditional expression whose test has been simplified,
+; simplifies the then and else parts while applying optimizations
+; for CASE expressions.
+; Precondition: (control-optimization) is true.
+
+(define (simplify-case exp notepad)
+ (let ((E0 (if.test exp)))
+ (if (and (call? E0)
+ (variable? (call.proc E0))
+ (let ((name (variable.name (call.proc E0))))
+ ; FIXME: Should ensure that the name is integrable,
+ ; but MEMQ and MEMV probably aren't according to the
+ ; INTEGRABLE? predicate.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (integrate-usual-procedures)
+ (= (length (call.args E0)) 2)
+ (variable? (car (call.args E0)))
+ (constant? (cadr (call.args E0))))
+ (simplify-case-clauses (variable.name (car (call.args E0)))
+ exp
+ notepad)
+ (begin (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp))))
+
+; Code generation for case expressions.
+;
+; A case expression turns into a conditional expression
+; of the form
+;
+; CASE{I} ::= E | (if (PRED I K) E CASE{I})
+; PRED ::= memv | memq | eqv? | eq?
+;
+; The memq and eq? predicates are used when the constant
+; is a (list of) boolean, fixnum, char, empty list, or symbol.
+; The constants will almost always be of these types.
+;
+; The first step is to remove duplicated constants and to
+; collect all the case clauses, sorting them into the following
+; categories based on their simplified list of constants:
+; constants are fixnums
+; constants are characters
+; constants are symbols
+; constants are of mixed or other type
+; After duplicated constants have been removed, the predicates
+; for these clauses can be tested in any order.
+
+; Given the name of an arbitrary variable, an expression that
+; has not yet been simplified or can safely be simplified again,
+; and a notepad, returns the expression after simplification.
+; If the expression is equivalent to a case expression that dispatches
+; on the given variable, then case-optimization will be applied.
+
+(define (simplify-case-clauses var0 E notepad)
+
+ (define notepad2 (make-notepad (notepad.parent notepad)))
+
+ (define (collect-clauses E fix chr sym other constants)
+ (if (not (conditional? E))
+ (analyze (simplify E notepad2)
+ fix chr sym other constants)
+ (let ((test (simplify (if.test E) notepad2))
+ (code (simplify (if.then E) notepad2)))
+ (if.test-set! E test)
+ (if.then-set! E code)
+ (if (not (call? test))
+ (finish E fix chr sym other constants)
+ (let ((proc (call.proc test))
+ (args (call.args test)))
+ (if (not (and (variable? proc)
+ (let ((name (variable.name proc)))
+ ; FIXME: See note above.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (= (length args) 2)
+ (variable? (car args))
+ (eq? (variable.name (car args)) var0)
+ (constant? (cadr args))))
+ (finish E fix chr sym other constants)
+ (let ((pred (variable.name proc))
+ (datum (constant.value (cadr args))))
+ ; FIXME
+ (if (or (and (or (eq? pred name:MEMV)
+ (eq? pred name:MEMQ))
+ (not (list? datum)))
+ (and (eq? pred name:EQ?)
+ (not (eqv-is-ok? datum)))
+ (and (eq? pred name:MEMQ)
+ (not (every? (lambda (datum)
+ (eqv-is-ok? datum))
+ datum))))
+ (finish E fix chr sym other constants)
+ (call-with-values
+ (lambda ()
+ (remove-duplicates (if (or (eq? pred name:EQV?)
+ (eq? pred name:EQ?))
+ (list datum)
+ datum)
+ constants))
+ (lambda (data constants)
+ (let ((clause (list data code))
+ (E2 (if.else E)))
+ (cond ((every? smallint? data)
+ (collect-clauses E2
+ (cons clause fix)
+ chr
+ sym
+ other
+ constants))
+ ((every? char? data)
+ (collect-clauses E2
+ fix
+ (cons clause chr)
+ sym
+ other
+ constants))
+ ((every? symbol? data)
+ (collect-clauses E2
+ fix
+ chr
+ (cons clause sym)
+ other
+ constants))
+ (else
+ (collect-clauses E2
+ fix
+ chr
+ sym
+ (cons clause other)
+ constants))))))))))))))
+
+ (define (remove-duplicates data set)
+ (let loop ((originals data)
+ (data '())
+ (set set))
+ (if (null? originals)
+ (values data set)
+ (let ((x (car originals))
+ (originals (cdr originals)))
+ (if (memv x set)
+ (loop originals data set)
+ (loop originals (cons x data) (cons x set)))))))
+
+ (define (finish E fix chr sym other constants)
+ (if.else-set! E (simplify (if.else E) notepad2))
+ (analyze E fix chr sym other constants))
+
+ (define (analyze default fix chr sym other constants)
+ (notepad-var-add! notepad2 var0)
+ (for-each (lambda (L)
+ (notepad-lambda-add! notepad L))
+ (notepad.lambdas notepad2))
+ (for-each (lambda (L)
+ (notepad-nonescaping-add! notepad L))
+ (notepad.nonescaping notepad2))
+ (for-each (lambda (var)
+ (notepad-var-add! notepad var))
+ (append (list name:FIXNUM?
+ name:CHAR?
+ name:SYMBOL?
+ name:FX<
+ name:FX-
+ name:CHAR->INTEGER
+ name:VECTOR-REF)
+ (notepad.vars notepad2)))
+ (analyze-clauses (notepad.vars notepad2)
+ var0
+ default
+ (reverse fix)
+ (reverse chr)
+ (reverse sym)
+ (reverse other)
+ constants))
+
+ (collect-clauses E '() '() '() '() '()))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eqv-is-ok? x)
+ (or (smallint? x)
+ (char? x)
+ (symbol? x)
+ (boolean? x)))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eq-is-ok? x)
+ (eqv-is-ok? x))
+
+; Any case expression that dispatches on a variable var0 and whose
+; constants are disjoint can be compiled as
+;
+; (let ((n (cond ((eq? var0 'K1) ...) ; miscellaneous constants
+; ...
+; ((fixnum? var0)
+; <dispatch-on-fixnum>)
+; ((char? var0)
+; <dispatch-on-char>)
+; ((symbol? var0)
+; <dispatch-on-symbols>)
+; (else 0))))
+; <dispatch-on-case-number>)
+;
+; where the <dispatch-on-case-number> uses binary search within
+; the interval [0, p+1), where p is the number of non-default cases.
+;
+; On the SPARC, sequential search is faster if there are fewer than
+; 8 constants, and sequential search uses less than half the space
+; if there are fewer than 10 constants. Most target machines should
+; similar, so I'm hard-wiring this constant.
+; FIXME: The hardwired constant is annoying.
+
+(define (analyze-clauses F var0 default fix chr sym other constants)
+ (cond ((or (and (null? fix)
+ (null? chr))
+ (< (length constants) 12))
+ (implement-clauses-by-sequential-search var0
+ default
+ (append fix chr sym other)))
+ (else
+ (implement-clauses F var0 default fix chr sym other constants))))
+
+; Implements the general technique described above.
+
+(define (implement-clauses F var0 default fix chr sym other constants)
+ (let* ((name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ (entry (make-R-entry name:n '() '() '()))
+ (F (union (make-set (list name:n)) F))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-case-dispatch
+ name:n
+ (cons default
+ (map cadr
+ ; The order here must match the order
+ ; used by IMPLEMENT-DISPATCH.
+ (append other fix chr sym)))))))
+ (make-call L
+ (list (implement-dispatch 0
+ var0
+ (map car other)
+ (map car fix)
+ (map car chr)
+ (map car sym))))))
+
+(define (implement-case-dispatch var0 exprs)
+ (implement-intervals var0
+ (map (lambda (n code)
+ (list n (+ n 1) code))
+ (iota (length exprs))
+ exprs)))
+
+; Given the number of prior clauses,
+; the variable on which to dispatch,
+; a list of constant lists for mixed or miscellaneous clauses,
+; a list of constant lists for the fixnum clauses,
+; a list of constant lists for the character clauses, and
+; a list of constant lists for the symbol clauses,
+; returns code that computes the index of the selected clause.
+; The mixed/miscellaneous clauses must be tested first because
+; Twobit's SMALLINT? predicate might not be true of all fixnums
+; on the target machine, which means that Twobit might classify
+; some fixnums as miscellaneous.
+
+(define (implement-dispatch prior var0 other fix chr sym)
+ (cond ((not (null? other))
+ (implement-dispatch-other
+ (implement-dispatch (+ prior (length other))
+ var0 fix chr sym '())
+ prior var other))
+ ((not (null? fix))
+ (make-conditional (make-call (make-variable name:FIXNUM?)
+ (list (make-variable var0)))
+ (implement-dispatch-fixnum prior var0 fix)
+ (implement-dispatch (+ prior (length fix))
+ var0 '() chr sym other)))
+ ((not (null? chr))
+ (make-conditional (make-call (make-variable name:CHAR?)
+ (list (make-variable var0)))
+ (implement-dispatch-char prior var0 chr)
+ (implement-dispatch (+ prior (length chr))
+ var0 fix '() sym other)))
+ ((not (null? sym))
+ (make-conditional (make-call (make-variable name:SYMBOL?)
+ (list (make-variable var0)))
+ (implement-dispatch-symbol prior var0 sym)
+ (implement-dispatch (+ prior (length sym))
+ var0 fix chr '() other)))
+ (else
+ (make-constant 0))))
+
+; The value of var0 will be known to be a fixnum.
+; Can use table lookup, binary search, or sequential search.
+; FIXME: Never uses sequential search, which is best when
+; there are only a few constants, with gaps between them.
+
+(define (implement-dispatch-fixnum prior var0 lists)
+
+ (define (calculate-intervals n lists)
+ (define (loop n lists intervals)
+ (if (null? lists)
+ (twobit-sort (lambda (interval1 interval2)
+ (< (car interval1) (car interval2)))
+ intervals)
+ (let ((constants (twobit-sort < (car lists))))
+ (loop (+ n 1)
+ (cdr lists)
+ (append (extract-intervals n constants)
+ intervals)))))
+ (loop n lists '()))
+
+ (define (extract-intervals n constants)
+ (if (null? constants)
+ '()
+ (let ((k0 (car constants)))
+ (do ((constants (cdr constants) (cdr constants))
+ (k1 (+ k0 1) (+ k1 1)))
+ ((or (null? constants)
+ (not (= k1 (car constants))))
+ (cons (list k0 k1 (make-constant n))
+ (extract-intervals n constants)))))))
+
+ (define (complete-intervals intervals)
+ (cond ((null? intervals)
+ intervals)
+ ((null? (cdr intervals))
+ intervals)
+ (else
+ (let* ((i1 (car intervals))
+ (i2 (cadr intervals))
+ (end1 (cadr i1))
+ (start2 (car i2))
+ (intervals (complete-intervals (cdr intervals))))
+ (if (= end1 start2)
+ (cons i1 intervals)
+ (cons i1
+ (cons (list end1 start2 (make-constant 0))
+ intervals)))))))
+
+ (let* ((intervals (complete-intervals
+ (calculate-intervals (+ prior 1) lists)))
+ (lo (car (car intervals)))
+ (hi (car (car (reverse intervals))))
+ (p (length intervals)))
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant lo)))
+ (make-constant 0)
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant (+ hi 1))))
+ ; The static cost of table lookup is about hi - lo words.
+ ; The static cost of binary search is about 5 SPARC instructions
+ ; per interval.
+ (if (< (- hi lo) (* 5 p))
+ (implement-table-lookup var0 (+ prior 1) lists lo hi)
+ (implement-intervals var0 intervals))
+ (make-constant 0)))))
+
+(define (implement-dispatch-char prior var0 lists)
+ (let* ((lists (map (lambda (constants)
+ (map compat:char->integer constants))
+ lists))
+ (name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ ;(entry (make-R-entry name:n '() '() '()))
+ (F (list name:n name:EQ? name:FX< name:FX- name:VECTOR-REF))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-dispatch-fixnum prior name:n lists))))
+ (make-call L
+ (make-call (make-variable name:CHAR->INTEGER)
+ (list (make-variable var0))))))
+
+(define (implement-dispatch-symbol prior var0 lists)
+ (implement-dispatch-other (make-constant 0) prior var0 lists))
+
+(define (implement-dispatch-other default prior var0 lists)
+ (if (null? lists)
+ default
+ (let* ((constants (car lists))
+ (lists (cdr lists))
+ (n (+ prior 1)))
+ (make-conditional (make-call-to-memv var0 constants)
+ (make-constant n)
+ (implement-dispatch-other default n var0 lists)))))
+
+(define (make-call-to-memv var0 constants)
+ (cond ((null? constants)
+ (make-constant #f))
+ ((null? (cdr constants))
+ (make-call-to-eqv var0 (car constants)))
+ (else
+ (make-conditional (make-call-to-eqv var0 (car constants))
+ (make-constant #t)
+ (make-call-to-memv var0 (cdr constants))))))
+
+(define (make-call-to-eqv var0 constant)
+ (make-call (make-variable
+ (if (eq-is-ok? constant)
+ name:EQ?
+ name:EQV?))
+ (list (make-variable var0)
+ (make-constant constant))))
+
+; Given a variable whose value is known to be a fixnum,
+; the clause index for the first fixnum clause,
+; an ordered list of lists of constants for fixnum-only clauses,
+; and the least and greatest constants in those lists,
+; returns code for a table lookup.
+
+(define (implement-table-lookup var0 index lists lo hi)
+ (let ((v (make-vector (+ 1 (- hi lo)) 0)))
+ (do ((index index (+ index 1))
+ (lists lists (cdr lists)))
+ ((null? lists))
+ (for-each (lambda (k)
+ (vector-set! v (- k lo) index))
+ (car lists)))
+ (make-call (make-variable name:VECTOR-REF)
+ (list (make-constant v)
+ (make-call (make-variable name:FX-)
+ (list (make-variable var0)
+ (make-constant lo)))))))
+
+; Given a variable whose value is known to lie within the
+; half-open interval [m0, mk), and an ordered complete
+; list of intervals of the form
+;
+; ((m0 m1 code0)
+; (m1 m2 code1)
+; ...
+; (m{k-1} mk code{k-1})
+; )
+;
+; returns an expression that finds the unique i such that
+; var0 lies within [mi, m{i+1}), and then executes code{i}.
+
+(define (implement-intervals var0 intervals)
+ (if (null? (cdr intervals))
+ (caddr (car intervals))
+ (let ((n (quotient (length intervals) 2)))
+ (do ((n n (- n 1))
+ (intervals1 '() (cons (car intervals2) intervals1))
+ (intervals2 intervals (cdr intervals2)))
+ ((zero? n)
+ (let ((intervals1 (reverse intervals1))
+ (m (car (car intervals2))))
+ (make-conditional (make-call (make-variable name:FX<)
+ (list
+ (make-variable var0)
+ (make-constant m)))
+ (implement-intervals var0 intervals1)
+ (implement-intervals var0 intervals2))))))))
+
+; The brute force approach.
+; Given the variable on which the dispatch is being performed, and
+; actual (simplified) code for the default clause and
+; for all other clauses,
+; returns code to perform the dispatch by sequential search.
+
+(define *memq-threshold* 20)
+(define *memv-threshold* 4)
+
+(define (implement-clauses-by-sequential-search var0 default clauses)
+ (if (null? clauses)
+ default
+ (let* ((case1 (car clauses))
+ (clauses (cdr clauses))
+ (constants1 (car case1))
+ (code1 (cadr case1)))
+ (make-conditional (make-call-to-memv var0 constants1)
+ code1
+ (implement-clauses-by-sequential-search
+ var0 default clauses)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 13 April 1999.
+;
+; The tail and non-tail call graphs of known and unknown procedures.
+;
+; Given an expression E returned by pass 2 of Twobit,
+; returns a list of the following form:
+;
+; ((#t L () <tailcalls> <nontailcalls> <size> #f)
+; (<name> L <vars> <tailcalls> <nontailcalls> <size> #f)
+; ...)
+;
+; where
+;
+; Each L is a lambda expression that occurs within E
+; as either an escaping lambda expression or as a known
+; procedure. If L is a known procedure, then <name> is
+; its name; otherwise <name> is #f.
+;
+; <vars> is a list of the non-global variables within whose
+; scope L occurs.
+;
+; <tailcalls> is a complete list of names of known local procedures
+; that L calls tail-recursively, disregarding calls from other known
+; procedures or escaping lambda expressions that occur within L.
+;
+; <nontailcalls> is a complete list of names of known local procedures
+; that L calls non-tail-recursively, disregarding calls from other
+; known procedures or escaping lambda expressions that occur within L.
+;
+; <size> is a measure of the size of L, including known procedures
+; and escaping lambda expressions that occur within L.
+
+(define (callgraphnode.name x) (car x))
+(define (callgraphnode.code x) (cadr x))
+(define (callgraphnode.vars x) (caddr x))
+(define (callgraphnode.tailcalls x) (cadddr x))
+(define (callgraphnode.nontailcalls x) (car (cddddr x)))
+(define (callgraphnode.size x) (cadr (cddddr x)))
+(define (callgraphnode.info x) (caddr (cddddr x)))
+
+(define (callgraphnode.size! x v) (set-car! (cdr (cddddr x)) v) #f)
+(define (callgraphnode.info! x v) (set-car! (cddr (cddddr x)) v) #f)
+
+(define (callgraph exp)
+
+ ; Returns (union (list x) z).
+
+ (define (adjoin x z)
+ (if (memq x z)
+ z
+ (cons x z)))
+
+ (let ((result '()))
+
+ ; Given a <name> as described above, a lambda expression, a list
+ ; of variables that are in scope, and a list of names of known
+ ; local procedure that are in scope, computes an entry for L and
+ ; entries for any nested known procedures or escaping lambda
+ ; expressions, and adds them to the result.
+
+ (define (add-vertex! name L vars known)
+
+ (let ((tailcalls '())
+ (nontailcalls '())
+ (size 0))
+
+ ; Given an expression, a list of variables that are in scope,
+ ; a list of names of known local procedures that are in scope,
+ ; and a boolean indicating whether the expression occurs in a
+ ; tail context, adds any tail or non-tail calls to known
+ ; procedures that occur within the expression to the list
+ ; variables declared above.
+
+ (define (graph! exp vars known tail?)
+ (set! size (+ size 1))
+ (case (car exp)
+
+ ((quote) #f)
+
+ ((lambda) (add-vertex! #f exp vars known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+
+ ((set!) (graph! (assignment.rhs exp) vars known #f))
+
+ ((if) (graph! (if.test exp) vars known #f)
+ (graph! (if.then exp) vars known tail?)
+ (graph! (if.else exp) vars known tail?))
+
+ ((begin) (if (not (variable? exp))
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (graph! (car exprs) vars known tail?))
+ (graph! (car exprs) vars known #f))))
+
+ (else (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let ((name (variable.name proc)))
+ (if (memq name known)
+ (if tail?
+ (set! tailcalls
+ (adjoin name tailcalls))
+ (set! nontailcalls
+ (adjoin name nontailcalls))))))
+ ((lambda? proc)
+ (graph-lambda! proc vars known tail?))
+ (else
+ (graph! proc vars known #f)))
+ (for-each (lambda (exp)
+ (graph! exp vars known #f))
+ (call.args exp))))))
+
+ (define (graph-lambda! L vars known tail?)
+ (let* ((defs (lambda.defs L))
+ (newknown (map def.lhs defs))
+ (vars (append newknown
+ (make-null-terminated
+ (lambda.args L))
+ vars))
+ (known (append newknown known)))
+ (for-each (lambda (def)
+ (add-vertex! (def.lhs def)
+ (def.rhs def)
+ vars
+ known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+ defs)
+ (graph! (lambda.body L) vars known tail?)))
+
+ (graph-lambda! L vars known #t)
+
+ (set! result
+ (cons (list name L vars tailcalls nontailcalls size #f)
+ result))))
+
+ (add-vertex! #t
+ (make-lambda '() '() '() '() '() '() '() exp)
+ '()
+ '())
+ result))
+
+; Displays the callgraph, for debugging.
+
+(define (view-callgraph g)
+ (for-each (lambda (entry)
+ (let ((name (callgraphnode.name entry))
+ (exp (callgraphnode.code entry))
+ (vars (callgraphnode.vars entry))
+ (tail (callgraphnode.tailcalls entry))
+ (nt (callgraphnode.nontailcalls entry))
+ (size (callgraphnode.size entry)))
+ (cond ((symbol? name)
+ (write name))
+ (name
+ (display "TOP LEVEL EXPRESSION"))
+ (else
+ (display "ESCAPING LAMBDA EXPRESSION")))
+ (display ":")
+ (newline)
+ (display "Size: ")
+ (write size)
+ (newline)
+ ;(newline)
+ ;(display "Variables in scope: ")
+ ;(write vars)
+ ;(newline)
+ (display "Tail calls: ")
+ (write tail)
+ (newline)
+ (display "Non-tail calls: ")
+ (write nt)
+ (newline)
+ ;(newline)
+ ;(pretty-print (make-readable exp))
+ ;(newline)
+ ;(newline)
+ (newline)))
+ g))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Inlining of known local procedures.
+;
+; First find the known and escaping procedures and compute the call graph.
+;
+; If a known local procedure is not called at all, then delete its code.
+;
+; If a known local procedure is called exactly once,
+; then inline its code at the call site and delete the
+; known local procedure. Change the size of the code
+; at the call site by adding the size of the inlined code.
+;
+; Divide the remaining known and escaping procedures into categories:
+; 1. makes no calls to known local procedures
+; 2. known procedures that call known procedures;
+; within this category, try to sort so that procedures do not
+; call procedures that come later in the sequence; or sort by
+; number of calls and/or size
+; 3. escaping procedures that call known procedures
+;
+; Approve each procedure in category 1 for inlining if its code size
+; is less than some threshold.
+;
+; For each procedure in categories 2 and 3, traverse its code, inlining
+; where it seems like a good idea. The compiler should be more aggressive
+; about inlining non-tail calls than tail calls because:
+;
+; Inlining a non-tail call can eliminate a stack frame
+; or expose the inlined code to loop optimizations.
+;
+; The main reason for inlining a tail call is to enable
+; intraprocedural optimizations or to unroll a loop.
+;
+; After inlining has been performed on a known local procedure,
+; then approve it for inlining if its size is less than some threshold.
+;
+; FIXME:
+; This strategy avoids infinite unrolling, but it also avoids finite
+; unrolling of loops.
+
+; Parameters to control inlining.
+; These can be tuned later.
+
+(define *tail-threshold* 10)
+(define *nontail-threshold* 20)
+(define *multiplier* 300)
+
+; Given a callgraph, performs inlining of known local procedures
+; by side effect. The original expression must then be copied to
+; reinstate Twobit's invariants.
+
+; FIXME: This code doesn't yet do the right thing with known local
+; procedures that aren't called or are called in exactly one place.
+
+(define (inline-using-callgraph! g)
+ (let ((known (make-hashtable))
+ (category2 '())
+ (category3 '()))
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (tcalls (callgraphnode.tailcalls node))
+ (ncalls (callgraphnode.nontailcalls node)))
+ (if (symbol? name)
+ (hashtable-put! known name node))
+ (if (and (null? tcalls)
+ (null? ncalls))
+ (if (< (callgraphnode.size node)
+ *nontail-threshold*)
+ (callgraphnode.info! node #t))
+ (if (symbol? name)
+ (set! category2 (cons node category2))
+ (set! category3 (cons node category3))))))
+ g)
+ (set! category2 (twobit-sort (lambda (x y)
+ (< (callgraphnode.size x)
+ (callgraphnode.size y)))
+ category2))
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category2)
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category3)
+ ; FIXME:
+ ; Inlining destroys the callgraph, so maybe this cleanup is useless.
+ (hashtable-for-each (lambda (name node) (callgraphnode.info! node #f))
+ known)))
+
+; Given a node of the callgraph and a hash table of nodes for
+; known local procedures, performs inlining by side effect.
+
+(define (inline-node! node known)
+ (let* ((debugging? #f)
+ (name (callgraphnode.name node))
+ (exp (callgraphnode.code node))
+ (size0 (callgraphnode.size node))
+ (budget (quotient (* (- *multiplier* 100) size0) 100))
+ (tail-threshold *tail-threshold*)
+ (nontail-threshold *nontail-threshold*))
+
+ ; Given an expression,
+ ; a boolean indicating whether the expression is in a tail context,
+ ; a list of procedures that should not be inlined,
+ ; and a size budget,
+ ; performs inlining by side effect and returns the unused budget.
+
+ (define (inline exp tail? budget)
+ (if (positive? budget)
+
+ (case (car exp)
+
+ ((quote lambda)
+ budget)
+
+ ((set!)
+ (inline (assignment.rhs exp) #f budget))
+
+ ((if)
+ (let* ((budget (inline (if.test exp) #f budget))
+ (budget (inline (if.then exp) tail? budget))
+ (budget (inline (if.else exp) tail? budget)))
+ budget))
+
+ ((begin)
+ (if (variable? exp)
+ budget
+ (do ((exprs (begin.exprs exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? (cdr exprs))
+ (inline (car exprs) tail? budget)))))
+
+ (else
+ (let ((budget (do ((exprs (call.args exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? exprs)
+ budget))))
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname)))
+ (if procnode
+ (let ((size (callgraphnode.size procnode))
+ (info (callgraphnode.info procnode)))
+ (if (and info
+ (<= size budget)
+ (<= size
+ (if tail?
+ tail-threshold
+ nontail-threshold)))
+ (begin
+ (if debugging?
+ (begin
+ (display " Inlining ")
+ (write (variable.name proc))
+ (newline)))
+ (call.proc-set!
+ exp
+ (copy-exp
+ (callgraphnode.code procnode)))
+ (callgraphnode.size!
+ node
+ (+ (callgraphnode.size node) size))
+ (- budget size))
+ (begin
+ (if (and #f debugging?)
+ (begin
+ (display " Declining to inline ")
+ (write (variable.name proc))
+ (newline)))
+ budget)))
+ budget)))
+ ((lambda? proc)
+ (inline (lambda.body proc) tail? budget))
+ (else
+ (inline proc #f budget)))))))
+ -1))
+
+ (if (and #f debugging?)
+ (begin
+ (display "Processing ")
+ (write name)
+ (newline)))
+
+ (let ((budget (inline (if (lambda? exp)
+ (lambda.body exp)
+ exp)
+ #t
+ budget)))
+ (if (and (negative? budget)
+ debugging?)
+ ; This shouldn't happen very often.
+ (begin (display "Ran out of inlining budget for ")
+ (write (callgraphnode.name node))
+ (newline)))
+ (if (<= (callgraphnode.size node) nontail-threshold)
+ (callgraphnode.info! node #t))
+ #f)))
+
+; For testing.
+
+(define (test-inlining test0)
+ (begin (define exp0 (begin (display "Compiling...")
+ (newline)
+ (pass2 (pass1 test0))))
+ (define g0 (begin (display "Computing call graph...")
+ (newline)
+ (callgraph exp0))))
+ (display "Inlining...")
+ (newline)
+ (inline-using-callgraph! g0)
+ (pretty-print (make-readable (copy-exp exp0))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Interprocedural constant propagation and folding.
+;
+; Constant propagation must converge before constant folding can be
+; performed. Constant folding creates more constants that can be
+; propagated, so these two optimizations must be iterated, but it
+; is safe to stop at any time.
+;
+; Abstract interpretation for constant folding.
+;
+; The abstract values are
+; bottom (represented here by #f)
+; constants (represented by quoted literals)
+; top (represented here by #t)
+;
+; Let [[ E ]] be the abstract interpretation of E over that domain
+; of abstract values, with respect to some arbitrary set of abstract
+; values for local variables.
+;
+; If a is a global variable or a formal parameter of an escaping
+; lambda expression, then [[ a ]] = #t.
+;
+; If x is the ith formal parameter of a known local procedure f,
+; then [[ x ]] = \join_{(f E1 ... En)} [[ Ei ]].
+;
+; [[ K ]] = K
+; [[ L ]] = #t
+; [[ (begin E1 ... En) ]] = [[ En ]]
+; [[ (set! I E) ]] = #f
+;
+; If [[ E0 ]] = #t, then [[ (if E0 E1 E2) ]] = [[ E1 ]] \join [[ E2 ]]
+; else if [[ E0 ]] = K, then [[ (if E0 E1 E2) ]] = [[ E1 ]]
+; or [[ (if E0 E1 E2) ]] = [[ E2 ]]
+; depending upon K
+; else [[ (if E0 E1 E2) ]] = #f
+;
+; If f is a known local procedure with body E,
+; then [[ (f E1 ... En) ]] = [[ E ]]
+;
+; If g is a foldable integrable procedure, then:
+; if there is some i for which [[ Ei ]] = #t,
+; then [[ (g E1 ... En) ]] = #t
+; else if [[ E1 ]] = K1, ..., [[ En ]] = Kn,
+; then [[ (g E1 ... En) ]] = (g K1 ... Kn)
+; else [[ (g E1 ... En) ]] = #f
+;
+; Symbolic representations of abstract values.
+; (Can be thought of as mappings from abstract environments to
+; abstract values.)
+;
+; <symbolic> ::= #t | ( <expressions> )
+; <expressions> ::= <empty> | <expression> <expressions>
+
+; Parameter to limit constant propagation and folding.
+; This parameter can be tuned later.
+
+(define *constant-propagation-limit* 5)
+
+; Given an expression as output by pass 2, performs constant
+; propagation and folding.
+
+(define (constant-propagation exp)
+ (define (constant-propagation exp i)
+ (if (< i *constant-propagation-limit*)
+ (begin
+ ;(display "Performing constant propagation and folding...")
+ ;(newline)
+ (let* ((g (callgraph exp))
+ (L (callgraphnode.code (car g)))
+ (variables (constant-propagation-using-callgraph g))
+ (changed? (constant-folding! L variables)))
+ (if changed?
+ (constant-propagation (lambda.body L) (+ i 1))
+ (lambda.body L))))))
+ (constant-propagation exp 0))
+
+; Given a callgraph, returns a hashtable of abstract values for
+; all local variables.
+
+(define (constant-propagation-using-callgraph g)
+ (let ((debugging? #f)
+ (folding? (integrate-usual-procedures))
+ (known (make-hashtable))
+ (variables (make-hashtable))
+ (counter 0))
+
+ ; Computes joins of abstract values.
+
+ (define (join x y)
+ (cond ((boolean? x)
+ (if x #t y))
+ ((boolean? y)
+ (join y x))
+ ((equal? x y)
+ x)
+ (else #t)))
+
+ ; Given a <symbolic> and a vector of abstract values,
+ ; evaluates the <symbolic> and returns its abstract value.
+
+ (define (aeval rep env)
+ (cond ((eq? rep #t)
+ #t)
+ ((null? rep)
+ #f)
+ ((null? (cdr rep))
+ (aeval1 (car rep) env))
+ (else
+ (join (aeval1 (car rep) env)
+ (aeval (cdr rep) env)))))
+
+ (define (aeval1 exp env)
+
+ (case (car exp)
+
+ ((quote)
+ exp)
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ #f)
+
+ ((begin)
+ (if (variable? exp)
+ (let* ((name (variable.name exp))
+ (i (hashtable-get variables name)))
+ (if i
+ (vector-ref env i)
+ #t))
+ (aeval1-error)))
+
+ ((if)
+ (let* ((val0 (aeval1 (if.test exp) env))
+ (val1 (aeval1 (if.then exp) env))
+ (val2 (aeval1 (if.else exp) env)))
+ (cond ((eq? val0 #t)
+ (join val1 val2))
+ ((pair? val0)
+ (if (constant.value val0)
+ val1
+ val2))
+ (else
+ #f))))
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (vals '() (cons (aeval1 (car exprs) env) vals)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (vector-ref env
+ (hashtable-get variables
+ procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else (aeval1-error)))))
+ (else
+ (aeval1-error)))))))))
+
+ (define (aeval1-error)
+ (error "Compiler bug: constant propagation (aeval1)"))
+
+ ; Combines two <symbolic>s.
+
+ (define (combine-symbolic rep1 rep2)
+ (cond ((eq? rep1 #t) #t)
+ ((eq? rep2 #t) #t)
+ (else
+ (append rep1 rep2))))
+
+ ; Given an expression, returns a <symbolic> that represents
+ ; a list of expressions whose abstract values can be joined
+ ; to obtain the abstract value of the given expression.
+ ; As a side effect, enters local variables into variables.
+
+ (define (collect! exp)
+
+ (case (car exp)
+
+ ((quote)
+ (list exp))
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ (collect! (assignment.rhs exp))
+ '())
+
+ ((begin)
+ (if (variable? exp)
+ (list exp)
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (collect! (car exprs)))
+ (collect! (car exprs)))))
+
+ ((if)
+ (collect! (if.test exp))
+ (collect! (if.then exp))
+ (collect! (if.else exp))
+ #t)
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (reps '() (cons (collect! (car exprs)) reps)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (define (put-args! args reps)
+ (cond ((pair? args)
+ (let ((v (car args))
+ (rep (car reps)))
+ (hashtable-put! variables v rep)
+ (put-args! (cdr args) (cdr reps))))
+ ((symbol? args)
+ (hashtable-put! variables args #t))
+ (else #f)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (for-each (lambda (v rep)
+ (hashtable-put!
+ variables
+ v
+ (combine-symbolic
+ rep (hashtable-get variables v))))
+ (lambda.args
+ (callgraphnode.code procnode))
+ reps)
+ (list (make-variable procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else #t))))
+ ((lambda? proc)
+ (put-args! (lambda.args proc) reps)
+ (collect! (lambda.body proc)))
+ (else
+ (collect! proc)
+ #t))))))))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (known? (symbol? name))
+ (rep (if known? '() #t)))
+ (if known?
+ (hashtable-put! known name node))
+ (if (lambda? code)
+ (for-each (lambda (var)
+ (hashtable-put! variables var rep))
+ (make-null-terminated (lambda.args code))))))
+ g)
+
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (code (callgraphnode.code node)))
+ (cond ((symbol? name)
+ (hashtable-put! variables
+ name
+ (collect! (lambda.body code))))
+ (else
+ (collect! (lambda.body code))))))
+ g)
+
+ (if (and #f debugging?)
+ (begin
+ (hashtable-for-each (lambda (v rep)
+ (write v)
+ (display ": ")
+ (write rep)
+ (newline))
+ variables)
+
+ (display "----------------------------------------")
+ (newline)))
+
+ ;(trace aeval aeval1)
+
+ (let* ((n (hashtable-size variables))
+ (vars (hashtable-map (lambda (v rep) v) variables))
+ (reps (map (lambda (v) (hashtable-get variables v)) vars))
+ (init (make-vector n #f))
+ (next (make-vector n)))
+ (do ((i 0 (+ i 1))
+ (vars vars (cdr vars))
+ (reps reps (cdr reps)))
+ ((= i n))
+ (hashtable-put! variables (car vars) i)
+ (vector-set! next
+ i
+ (let ((rep (car reps)))
+ (lambda (env)
+ (aeval rep env)))))
+ (compute-fixedpoint init next equal?)
+ (for-each (lambda (v)
+ (let* ((i (hashtable-get variables v))
+ (aval (vector-ref init i)))
+ (hashtable-put! variables v aval)
+ (if (and debugging?
+ (not (eq? aval #t)))
+ (begin (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))
+ vars)
+ variables)))
+
+; Given a lambda expression, performs constant propagation, folding,
+; and simplifications by side effect, using the abstract values in the
+; hash table of variables.
+; Returns #t if any new constants were created by constant folding,
+; otherwise returns #f.
+
+(define (constant-folding! L variables)
+ (let ((debugging? #f)
+ (msg1 " Propagating constant value for ")
+ (msg2 " Folding: ")
+ (msg3 " ==> ")
+ (folding? (integrate-usual-procedures))
+ (changed? #f))
+
+ ; Given a known lambda expression L, its original formal parameters,
+ ; and a list of all calls to L, deletes arguments that are now
+ ; ignored because of constant propagation.
+
+ (define (delete-ignored-args! L formals0 calls)
+ (let ((formals1 (lambda.args L)))
+ (for-each (lambda (call)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (args (call.args call)
+ (cdr args))
+ (newargs '()
+ (if (and (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ newargs
+ (cons (car args) newargs))))
+ ((null? formals0)
+ (call.args-set! call (reverse newargs)))))
+ calls)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (formals2 '()
+ (if (and (not (eq? (car formals0)
+ (car formals1)))
+ (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ formals2
+ (cons (car formals1) formals2))))
+ ((null? formals0)
+ (lambda.args-set! L (reverse formals2))))))
+
+ (define (fold! exp)
+
+ (case (car exp)
+
+ ((quote) exp)
+
+ ((lambda)
+ (let ((Rinfo (lambda.R exp))
+ (known (map def.lhs (lambda.defs exp))))
+ (for-each (lambda (entry)
+ (let* ((v (R-entry.name entry))
+ (aval (hashtable-fetch variables v #t)))
+ (if (and (pair? aval)
+ (not (memq v known)))
+ (let ((x (constant.value aval)))
+ (if (or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (number? x)
+ (char? x)
+ (and (vector? x)
+ (zero? (vector-length x))))
+ (let ((refs (R-entry.references entry)))
+ (for-each (lambda (ref)
+ (variable-set! ref aval))
+ refs)
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp)))
+ (flag-as-ignored v exp)
+ (if debugging?
+ (begin (display msg1)
+ (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))))))
+ Rinfo)
+ (for-each (lambda (def)
+ (let* ((name (def.lhs def))
+ (rhs (def.rhs def))
+ (entry (R-lookup Rinfo name))
+ (calls (R-entry.calls entry)))
+ (if (null? calls)
+ (begin (lambda.defs-set!
+ exp
+ (remq def (lambda.defs exp)))
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp))))
+ (let* ((formals0 (append (lambda.args rhs) '()))
+ (L (fold! rhs))
+ (formals1 (lambda.args L)))
+ (if (not (equal? formals0 formals1))
+ (delete-ignored-args! L formals0 calls))))))
+ (lambda.defs exp))
+ (lambda.body-set!
+ exp
+ (fold! (lambda.body exp)))
+ exp))
+
+ ((set!)
+ (assignment.rhs-set! exp (fold! (assignment.rhs exp)))
+ exp)
+
+ ((begin)
+ (if (variable? exp)
+ exp
+ (post-simplify-begin (make-begin (map fold! (begin.exprs exp)))
+ (make-notepad #f))))
+
+ ((if)
+ (let ((exp0 (fold! (if.test exp)))
+ (exp1 (fold! (if.then exp)))
+ (exp2 (fold! (if.else exp))))
+ (if (constant? exp0)
+ (let ((newexp (if (constant.value exp0)
+ exp1
+ exp2)))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable exp))
+ (display msg3)
+ (write (make-readable newexp))
+ (newline)))
+ (set! changed? #t)
+ newexp)
+ (make-conditional exp0 exp1 exp2))))
+
+ (else
+ (let ((args (map fold! (call.args exp)))
+ (proc (fold! (call.proc exp))))
+ (cond ((and folding?
+ (variable? proc)
+ (every? constant? args)
+ (let ((entry
+ (constant-folding-entry (variable.name proc))))
+ (and entry
+ (let ((preds
+ (constant-folding-predicates entry)))
+ (and (= (length args) (length preds))
+ (every?
+ (lambda (x) x)
+ (map (lambda (f v) (f v))
+ (constant-folding-predicates entry)
+ (map constant.value args))))))))
+ (set! changed? #t)
+ (let ((result
+ (make-constant
+ (apply (constant-folding-folder
+ (constant-folding-entry
+ (variable.name proc)))
+ (map constant.value args)))))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable (make-call proc args)))
+ (display msg3)
+ (write result)
+ (newline)))
+ result))
+ ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ ; FIXME: Folding should be done even if there is
+ ; a rest argument.
+ (let loop ((formals (reverse (lambda.args proc)))
+ (actuals (reverse args))
+ (processed-formals '())
+ (processed-actuals '())
+ (for-effect '()))
+ (cond ((null? formals)
+ (lambda.args-set! proc processed-formals)
+ (call.args-set! exp processed-actuals)
+ (let ((call (if (and (null? processed-formals)
+ (null? (lambda.defs proc)))
+ (lambda.body proc)
+ exp)))
+ (if (null? for-effect)
+ call
+ (post-simplify-begin
+ (make-begin
+ (reverse (cons call for-effect)))
+ (make-notepad #f)))))
+ ((ignored? (car formals))
+ (loop (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else
+ (loop (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect)))))
+ (else
+ (call.proc-set! exp proc)
+ (call.args-set! exp args)
+ exp))))))
+
+ (fold! L)
+ changed?))
+; Copyright 1998 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Conversion to A-normal form, with heuristics for
+; choosing a good order of evaluation.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * There are no sequential expressions.
+; * The output is an expression E with syntax
+;
+; E --> A
+; | (L)
+; | (L A)
+;
+; A --> W
+; | L
+; | (W_0 W_1 ...)
+; | (set! I W)
+; | (if W E1 E2)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; In other words:
+; An expression is a LET* such that the rhs of every binding is
+; a conditional with the test already evaluated, or
+; an expression that can be evaluated in one step
+; (treating function calls as a single step)
+;
+; A-normal form corresponds to the control flow graph for a lambda
+; expression.
+
+; Algorithm: repeated use of these rules:
+;
+; (E0 E1 ...) ((lambda (T0 T1 ...) (T0 T1 ...))
+; E0 E1 ...)
+; (set! I E) ((lambda (T) (set! I T)) E)
+; (if E0 E1 E2) ((lambda (T) (if T E1 E2)) E0)
+; (begin E0 E1 E2 ...) ((lambda (T) (begin E1 E2 ...)) E0)
+;
+; ((lambda (I1 I2 I3 ...) E) ((lambda (I1)
+; E1 E2 E3) ((lambda (I2 I3 ...) E)
+; E2 E3))
+; E1)
+;
+; ((lambda (I2) E) ((lambda (I1)
+; ((lambda (I1) E2) ((lambda (I2) E)
+; E1)) E2)
+; E1)
+;
+; In other words:
+; Introduce a temporary name for every expression except:
+; tail expressions
+; the alternatives of a non-tail conditional
+; Convert every LET into a LET*.
+; Get rid of LET* on the right hand side of a binding.
+
+; Given an expression E in the representation output by pass 2,
+; returns an A-normal form for E in that representation.
+; Except for quoted values, the A-normal form does not share
+; mutable structure with the original expression E.
+;
+; KNOWN BUG:
+;
+; If you call A-normal on a form that has already been converted
+; to A-normal form, then the same temporaries will be generated
+; twice. An optional argument lets you specify a different prefix
+; for temporaries the second time around. Example:
+;
+; (A-normal-form (A-normal-form E ".T")
+; ".U")
+
+; This is the declaration that is used to indicate A-normal form.
+
+(define A-normal-form-declaration (list 'anf))
+
+(define (A-normal-form E . rest)
+
+ (define (A-normal-form E)
+ (anf-make-let* (anf E '() '())))
+
+ ; New temporaries.
+
+ (define temp-counter 0)
+
+ (define temp-prefix
+ (if (or (null? rest)
+ (not (string? (car rest))))
+ (string-append renaming-prefix "T")
+ (car rest)))
+
+ (define (newtemp)
+ (set! temp-counter (+ temp-counter 1))
+ (string->symbol
+ (string-append temp-prefix
+ (number->string temp-counter))))
+
+ ; Given an expression E as output by pass 2,
+ ; a list of surrounding LET* bindings,
+ ; and an ordered list of likely register variables,
+ ; return a non-empty list of LET* bindings
+ ; whose first binding associates a dummy variable
+ ; with an A-expression giving the value for E.
+
+ (define (anf E bindings regvars)
+ (case (car E)
+ ((quote) (anf-bind-dummy E bindings))
+ ((begin) (if (variable? E)
+ (anf-bind-dummy E bindings)
+ (anf-sequential E bindings regvars)))
+ ((lambda) (anf-lambda E bindings regvars))
+ ((set!) (anf-assignment E bindings regvars))
+ ((if) (anf-conditional E bindings regvars))
+ (else (anf-call E bindings regvars))))
+
+ (define anf:dummy (string->symbol "RESULT"))
+
+ (define (anf-bind-dummy E bindings)
+ (cons (list anf:dummy E)
+ bindings))
+
+ ; Unlike anf-bind-dummy, anf-bind-name and anf-bind convert
+ ; their expression argument to A-normal form.
+ ; Don't change anf-bind to call anf-bind-name, because that
+ ; would name the temporaries in an aesthetically bad order.
+
+ (define (anf-bind-name name E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list name (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-bind E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list (newtemp) (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-result bindings)
+ (make-variable (car (car bindings))))
+
+ (define (anf-make-let* bindings)
+ (define (loop bindings body)
+ (if (null? bindings)
+ body
+ (let ((T1 (car (car bindings)))
+ (E1 (cadr (car bindings))))
+ (loop (cdr bindings)
+ (make-call (make-lambda (list T1)
+ '()
+ '()
+ '()
+ '()
+ (list A-normal-form-declaration)
+ '()
+ body)
+ (list E1))))))
+ (loop (cdr bindings)
+ (cadr (car bindings))))
+
+ (define (anf-sequential E bindings regvars)
+ (do ((bindings bindings
+ (anf-bind (car exprs) bindings regvars))
+ (exprs (begin.exprs E)
+ (cdr exprs)))
+ ((null? (cdr exprs))
+ (anf (car exprs) bindings regvars))))
+
+ ; Heuristic: the formal parameters of an escaping lambda or
+ ; known local procedure are kept in REG1, REG2, et cetera.
+
+ (define (anf-lambda L bindings regvars)
+ (anf-bind-dummy
+ (make-lambda (lambda.args L)
+ (map (lambda (def)
+ (make-definition
+ (def.lhs def)
+ (A-normal-form (def.rhs def))))
+ (lambda.defs L))
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls L))
+ (lambda.doc L)
+ (anf-make-let*
+ (anf (lambda.body L)
+ '()
+ (make-null-terminated (lambda.args L)))))
+ bindings))
+
+ (define (anf-assignment E bindings regvars)
+ (let ((I (assignment.lhs E))
+ (E1 (assignment.rhs E)))
+ (if (variable? E1)
+ (anf-bind-dummy E bindings)
+ (let* ((bindings (anf-bind E1 bindings regvars))
+ (T1 (anf-result bindings)))
+ (anf-bind-dummy (make-assignment I T1) bindings)))))
+
+ (define (anf-conditional E bindings regvars)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (variable? E0)
+ (let ((E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional E0 E1 E2)
+ bindings))
+ (let* ((bindings (anf-bind E0 bindings regvars))
+ (E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional (anf-result bindings) E1 E2)
+ bindings)))))
+
+ (define (anf-call E bindings regvars)
+ (let* ((proc (call.proc E))
+ (args (call.args E)))
+
+ ; Evaluates the exprs and returns both a list of bindings and
+ ; a list of the temporaries that name the results of the exprs.
+ ; If rename-always? is true, then temporaries are generated even
+ ; for constants and temporaries.
+
+ (define (loop exprs bindings names rename-always?)
+ (if (null? exprs)
+ (values bindings (reverse names))
+ (let ((E (car exprs)))
+ (if (or rename-always?
+ (not (or (constant? E)
+ (variable? E))))
+ (let* ((bindings
+ (anf-bind (car exprs) bindings regvars)))
+ (loop (cdr exprs)
+ bindings
+ (cons (anf-result bindings) names)
+ rename-always?))
+ (loop (cdr exprs)
+ bindings
+ (cons E names)
+ rename-always?)))))
+
+ ; Evaluates the exprs, binding them to the vars, and returns
+ ; a list of bindings.
+ ;
+ ; Although LET variables are likely to be kept in registers,
+ ; trying to guess which register will be allocated is likely
+ ; to do more harm than good.
+
+ (define (let-loop exprs bindings regvars vars)
+ (if (null? exprs)
+ (if (null? (lambda.defs proc))
+ (anf (lambda.body proc)
+ bindings
+ regvars)
+ (let ((bindings
+ (anf-bind
+ (make-lambda '()
+ (lambda.defs proc)
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls proc))
+ (lambda.doc proc)
+ (lambda.body proc))
+ bindings
+ '())))
+ (anf-bind-dummy
+ (make-call (anf-result bindings) '())
+ bindings)))
+ (let-loop (cdr exprs)
+ (anf-bind-name (car vars)
+ (car exprs)
+ bindings
+ regvars)
+ regvars
+ (cdr vars))))
+
+ (cond ((lambda? proc)
+ (let ((formals (lambda.args proc)))
+ (if (list? formals)
+ (let* ((pi (anf-order-of-evaluation args regvars #f))
+ (exprs (permute args pi))
+ (names (permute (lambda.args proc) pi)))
+ (let-loop (reverse exprs) bindings regvars (reverse names)))
+ (anf-call (normalize-let E) bindings regvars))))
+
+ ((not (variable? proc))
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((bindings (anf-bind proc bindings regvars)))
+ (anf-bind-dummy
+ (make-call (anf-result bindings)
+ (unpermute names pi))
+ bindings))))))
+
+ ((and (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (let ((pi (anf-order-of-evaluation args regvars #t)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings)))))
+
+ ((memq (variable.name proc) regvars)
+ (let* ((exprs (cons proc args))
+ (pi (anf-order-of-evaluation
+ exprs
+ (cons name:IGNORED regvars)
+ #f)))
+ (call-with-values
+ (lambda () (loop (permute exprs pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((names (unpermute names pi)))
+ (anf-bind-dummy
+ (make-call (car names) (cdr names))
+ bindings))))))
+
+ (else
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings))))))))
+
+ ; Given a list of expressions, a list of likely register contents,
+ ; and a switch telling whether these are arguments for a primop
+ ; or something else (such as the arguments for a real call),
+ ; try to choose a good order in which to evaluate the expressions.
+ ;
+ ; Heuristic: If none of the expressions is a call to a non-primop,
+ ; then parallel assignment optimization gives a good order if the
+ ; regvars are right, and should do no worse than a random order if
+ ; the regvars are wrong.
+ ;
+ ; Heuristic: If the expressions are arguments to a primop, and
+ ; none are a call to a non-primop, then the register contents
+ ; are irrelevant, and the first argument should be evaluated last.
+ ;
+ ; Heuristic: If one or more of the expressions is a call to a
+ ; non-primop, then the following should be a good order:
+ ;
+ ; expressions that are neither a constant, variable, or a call
+ ; calls to non-primops
+ ; constants and variables
+
+ (define (anf-order-of-evaluation exprs regvars for-primop?)
+ (define (ordering targets exprs alist)
+ (let ((para
+ (parallel-assignment targets alist exprs)))
+ (or para
+ ; Evaluate left to right until a parallel assignment is found.
+ (cons (car targets)
+ (ordering (cdr targets)
+ (cdr exprs)
+ alist)))))
+ (if (parallel-assignment-optimization)
+ (cond ((null? exprs) '())
+ ((null? (cdr exprs)) '(0))
+ (else
+ (let* ((contains-call? #f)
+ (vexprs (list->vector exprs))
+ (vindexes (list->vector
+ (iota (vector-length vexprs))))
+ (contains-call? #f)
+ (categories
+ (list->vector
+ (map (lambda (E)
+ (cond ((constant? E)
+ 2)
+ ((variable? E)
+ 2)
+ ((complicated? E)
+ (set! contains-call? #t)
+ 1)
+ (else
+ 0)))
+ exprs))))
+ (cond (contains-call?
+ (twobit-sort (lambda (i j)
+ (< (vector-ref categories i)
+ (vector-ref categories j)))
+ (iota (length exprs))))
+ (for-primop?
+ (reverse (iota (length exprs))))
+ (else
+ (let ((targets (iota (length exprs))))
+ (define (pairup regvars targets)
+ (if (or (null? targets)
+ (null? regvars))
+ '()
+ (cons (cons (car regvars)
+ (car targets))
+ (pairup (cdr regvars)
+ (cdr targets)))))
+ (ordering targets
+ exprs
+ (pairup regvars targets))))))))
+ (iota (length exprs))))
+
+ (define (permute things pi)
+ (let ((v (list->vector things)))
+ (map (lambda (i) (vector-ref v i))
+ pi)))
+
+ (define (unpermute things pi)
+ (let* ((v0 (list->vector things))
+ (v1 (make-vector (vector-length v0))))
+ (do ((pi pi (cdr pi))
+ (k 0 (+ k 1)))
+ ((null? pi)
+ (vector->list v1))
+ (vector-set! v1 (car pi) (vector-ref v0 k)))))
+
+ ; Given a call whose procedure is a lambda expression that has
+ ; a rest argument, return a genuine let expression.
+
+ (define (normalize-let-error exp)
+ (if (issue-warnings)
+ (begin (display "WARNING from compiler: ")
+ (display "Wrong number of arguments ")
+ (display "to lambda expression")
+ (newline)
+ (pretty-print (make-readable exp) #t)
+ (newline))))
+
+ (define (normalize-let exp)
+ (let* ((L (call.proc exp)))
+ (let loop ((formals (lambda.args L))
+ (args (call.args exp))
+ (newformals '())
+ (newargs '()))
+ (cond ((null? formals)
+ (if (null? args)
+ (begin (lambda.args-set! L (reverse newformals))
+ (call.args-set! exp (reverse newargs)))
+ (begin (normalize-let-error exp)
+ (loop (list (newtemp))
+ args
+ newformals
+ newargs))))
+ ((pair? formals)
+ (if (pair? args)
+ (loop (cdr formals)
+ (cdr args)
+ (cons (car formals) newformals)
+ (cons (car args) newargs))
+ (begin (normalize-let-error exp)
+ (loop formals
+ (cons (make-constant 0)
+ args)
+ newformals
+ newargs))))
+ (else
+ (loop (list formals)
+ (list (make-call-to-list args))
+ newformals
+ newargs))))))
+
+ ; For heuristic use only.
+ ; An expression is complicated unless it can probably be evaluated
+ ; without saving and restoring any registers, even if it occurs in
+ ; a non-tail position.
+
+ (define (complicated? exp)
+ ; Let's not spend all day on this.
+ (let ((budget 10))
+ (define (complicated? exp)
+ (set! budget (- budget 1))
+ (if (zero? budget)
+ #t
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (complicated? (assignment.rhs exp)))
+ ((if) (or (complicated? (if.test exp))
+ (complicated? (if.then exp))
+ (complicated? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? complicated?
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (some? complicated?
+ (call.args exp))
+ #t))))))
+ (complicated? exp)))
+
+ (A-normal-form E))
+(define (post-simplify-anf L0 T1 E0 E1 free regbindings L2)
+
+ (define (return-normally)
+ (values (make-call L0 (list E1))
+ free
+ regbindings))
+
+ (return-normally))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Intraprocedural common subexpression elimination, constant propagation,
+; copy propagation, dead code elimination, and register targeting.
+;
+; (intraprocedural-commoning E 'commoning)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an optimized
+; A-normal form with correct free variables but incorrect referencing
+; information.
+;
+; (intraprocedural-commoning E 'target-registers)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an A-normal form
+; with correct free variables but incorrect referencing information,
+; and in which MacScheme machine register names are used as temporary
+; variables. The result is alpha-converted except for register names.
+;
+; (intraprocedural-commoning E 'commoning 'target-registers)
+; (intraprocedural-commoning E)
+;
+; Given an A-normal form as described above, returns an optimized
+; form in which register names are used as temporary variables.
+
+; Semantics of .check!:
+;
+; (.check! b exn x ...) faults with code exn and arguments x ...
+; if b is #f.
+
+; The list of argument registers.
+; This can't go in pass3commoning.aux.sch because that file must be
+; loaded before the target-specific file that defines *nregs*.
+
+(define argument-registers
+ (do ((n (- *nregs* 2) (- n 1))
+ (regs '()
+ (cons (string->symbol
+ (string-append ".REG" (number->string n)))
+ regs)))
+ ((zero? n)
+ regs)))
+
+(define (intraprocedural-commoning E . flags)
+
+ (define target-registers? (or (null? flags) (memq 'target-registers flags)))
+ (define commoning? (or (null? flags) (memq 'commoning flags)))
+
+ (define debugging? #f)
+
+ (call-with-current-continuation
+ (lambda (return)
+
+ (define (error . stuff)
+ (display "Bug detected during intraprocedural optimization")
+ (newline)
+ (for-each (lambda (s)
+ (display s) (newline))
+ stuff)
+ (return (make-constant #f)))
+
+ ; Given an expression, an environment, the available expressions,
+ ; and an ordered list of likely register variables (used heuristically),
+ ; returns the transformed expression and its set of free variables.
+
+ (define (scan-body E env available regvars)
+
+ ; The local variables are those that are bound by a LET within
+ ; this procedure. The formals of a lambda expression and the
+ ; known local procedures are counted as non-global, not local,
+ ; because there is no let-binding for a formal that can be
+ ; renamed during register targeting.
+ ; For each local variable, we keep track of how many times it
+ ; is referenced. This information is not accurate until we
+ ; are backing out of the recursion, and does not have to be.
+
+ (define local-variables (make-hashtable symbol-hash assq))
+
+ (define (local-variable? sym)
+ (hashtable-get local-variables sym))
+
+ (define (local-variable-not-used? sym)
+ (= 0 (hashtable-fetch local-variables sym -1)))
+
+ (define (local-variable-used-once? sym)
+ (= 1 (hashtable-fetch local-variables sym 0)))
+
+ (define (record-local-variable! sym)
+ (hashtable-put! local-variables sym 0))
+
+ (define (used-local-variable! sym)
+ (adjust-local-variable! sym 1))
+
+ (define (adjust-local-variable! sym n)
+ (let ((m (hashtable-get local-variables sym)))
+ (if debugging?
+ (if (and m (> m 0))
+ (begin (write (list sym (+ m n)))
+ (newline))))
+ (if m
+ (hashtable-put! local-variables
+ sym
+ (+ m n)))))
+
+ (define (closed-over-local-variable! sym)
+ ; Set its reference count to infinity so it won't be optimized away.
+ ; FIXME: One million isn't infinity.
+ (hashtable-put! local-variables sym 1000000))
+
+ (define (used-variable! sym)
+ (used-local-variable! sym))
+
+ (define (abandon-expression! E)
+ (cond ((variable? E)
+ (adjust-local-variable! (variable.name E) -1))
+ ((conditional? E)
+ (abandon-expression! (if.test E))
+ (abandon-expression! (if.then E))
+ (abandon-expression! (if.else E)))
+ ((call? E)
+ (for-each (lambda (exp)
+ (if (variable? exp)
+ (let ((name (variable.name exp)))
+ (if (local-variable? name)
+ (adjust-local-variable! name -1)))))
+ (cons (call.proc E)
+ (call.args E))))))
+
+ ; Environments are represented as hashtrees.
+
+ (define (make-empty-environment)
+ (make-hashtree symbol-hash assq))
+
+ (define (environment-extend env sym)
+ (hashtree-put env sym #t))
+
+ (define (environment-extend* env symbols)
+ (if (null? symbols)
+ env
+ (environment-extend* (hashtree-put env (car symbols) #t)
+ (cdr symbols))))
+
+ (define (environment-lookup env sym)
+ (hashtree-get env sym))
+
+ (define (global? x)
+ (cond ((local-variable? x)
+ #f)
+ ((environment-lookup env x)
+ #f)
+ (else
+ #t)))
+
+ ;
+
+ (define (available-add! available T E)
+ (cond ((constant? E)
+ (available-extend! available T E available:killer:immortal))
+ ((variable? E)
+ (available-extend! available
+ T
+ E
+ (if (global? (variable.name E))
+ available:killer:globals
+ available:killer:immortal)))
+ (else
+ (let ((entry (prim-call E)))
+ (if entry
+ (let ((killer (prim-lives-until entry)))
+ (if (not (eq? killer available:killer:dead))
+ (do ((args (call.args E) (cdr args))
+ (k killer
+ (let ((arg (car args)))
+ (if (and (variable? arg)
+ (global? (variable.name arg)))
+ available:killer:globals
+ k))))
+ ((null? args)
+ (available-extend!
+ available
+ T
+ E
+ (logior killer k)))))))))))
+
+ ; Given an expression E,
+ ; an environment containing all variables that are in scope,
+ ; and a table of available expressions,
+ ; returns multiple values:
+ ; the transformed E
+ ; the free variables of E
+ ; the register bindings to be inserted; each binding has the form
+ ; (R x (begin R)), where (begin R) is a reference to R.
+ ;
+ ; Side effects E.
+
+ (define (scan E env available)
+ (if (not (call? E))
+ (scan-rhs E env available)
+ (let ((proc (call.proc E)))
+ (if (not (lambda? proc))
+ (scan-rhs E env available)
+ (let ((vars (lambda.args proc)))
+ (cond ((null? vars)
+ (scan-let0 E env available))
+ ((null? (cdr vars))
+ (scan-binding E env available))
+ (else
+ (error (make-readable E)))))))))
+
+ ; E has the form of (let ((T1 E1)) E0).
+
+ (define (scan-binding E env available)
+ (let* ((L (call.proc E))
+ (T1 (car (lambda.args L)))
+ (E1 (car (call.args E)))
+ (E0 (lambda.body L)))
+ (record-local-variable! T1)
+ (call-with-values
+ (lambda () (scan-rhs E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (available-add! available T1 E1)
+ (let* ((env (let ((formals
+ (make-null-terminated (lambda.args L))))
+ (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs L)))))
+ (Fdefs (scan-defs L env available)))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (lambda.body-set! L E0)
+ (if target-registers?
+ (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+ (scan-binding-phase3
+ L E0 E1 (union F0 Fdefs)
+ F1 regbindings0 regbindings1)))))))))
+
+ ; Given the lambda expression for a let expression that binds
+ ; a single variable T1, the transformed body E0 and right hand side E1,
+ ; their sets of free variables F0 and F1, the set of free variables
+ ; for the internal definitions of L, and the sets of register
+ ; bindings that need to be wrapped around E0 and E1, returns the
+ ; transformed let expression, its free variables, and register
+ ; bindings.
+ ;
+ ; This phase is concerned exclusively with register bindings,
+ ; and is bypassed unless the target-registers flag is specified.
+
+ (define (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+
+ ; T1 can't be a register because we haven't
+ ; yet inserted register bindings that high up.
+
+ ; Classify the register bindings that need to wrapped around E0:
+ ; 1. those that have T1 as their rhs
+ ; 2. those whose lhs is a register that is likely to hold
+ ; a variable that occurs free in E1
+ ; 3. all others
+
+ (define (phase2a)
+ (do ((rvars regvars (cdr rvars))
+ (regs argument-registers (cdr regs))
+ (regs1 '() (if (memq (car rvars) F1)
+ (cons (car regs) regs1)
+ regs1)))
+ ((or (null? rvars)
+ (null? regs))
+ ; regs1 is the set of registers that are live for E1
+
+ (let loop ((regbindings regbindings0)
+ (rb1 '())
+ (rb2 '())
+ (rb3 '()))
+ (if (null? regbindings)
+ (phase2b rb1 rb2 rb3)
+ (let* ((binding (car regbindings))
+ (regbindings (cdr regbindings))
+ (lhs (regbinding.lhs binding))
+ (rhs (regbinding.rhs binding)))
+ (cond ((eq? rhs T1)
+ (loop regbindings
+ (cons binding rb1)
+ rb2
+ rb3))
+ ((memq lhs regs1)
+ (loop regbindings
+ rb1
+ (cons binding rb2)
+ rb3))
+ (else
+ (loop regbindings
+ rb1
+ rb2
+ (cons binding rb3))))))))))
+
+ ; Determine which categories of register bindings should be
+ ; wrapped around E0.
+ ; Always wrap the register bindings in category 2.
+ ; If E1 is a conditional or a real call, then wrap category 3.
+ ; If T1 might be used more than once, then wrap category 1.
+
+ (define (phase2b rb1 rb2 rb3)
+ (if (or (conditional? E1)
+ (real-call? E1))
+ (phase2c (append rb2 rb3) rb1 '())
+ (phase2c rb2 rb1 rb3)))
+
+ (define (phase2c towrap rb1 regbindings0)
+ (cond ((and (not (null? rb1))
+ (local-variable-used-once? T1))
+ (phase2d towrap rb1 regbindings0))
+ (else
+ (phase2e (append rb1 towrap) regbindings0))))
+
+ ; T1 is used only once, and there is a register binding (R T1).
+ ; Change T1 to R.
+
+ (define (phase2d towrap regbindings-T1 regbindings0)
+ (if (not (null? (cdr regbindings-T1)))
+ (error "incorrect number of uses" T1))
+ (let* ((regbinding (car regbindings-T1))
+ (R (regbinding.lhs regbinding)))
+ (lambda.args-set! L (list R))
+ (phase2e towrap regbindings0)))
+
+ ; Wrap the selected register bindings around E0.
+
+ (define (phase2e towrap regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings towrap E0 F0))
+ (lambda (E0 F0)
+ (let ((F (union Fdefs F0)))
+ (scan-binding-phase3
+ L E0 E1 F F1 regbindings0 regbindings1)))))
+
+ (phase2a))
+
+ ; This phase, with arguments as above, constructs the result.
+
+ (define (scan-binding-phase3 L E0 E1 F F1 regbindings0 regbindings1)
+ (let* ((args (lambda.args L))
+ (T1 (car args))
+ (free (union F1 (difference F args)))
+ (simple-let? (simple-lambda? L))
+ (regbindings
+
+ ; At least one of regbindings0 and regbindings1
+ ; is the empty list.
+
+ (cond ((null? regbindings0)
+ regbindings1)
+ ((null? regbindings1)
+ regbindings0)
+ (else
+ (error 'scan-binding 'regbindings)))))
+ (lambda.body-set! L E0)
+ (lambda.F-set! L F)
+ (lambda.G-set! L F)
+ (cond ((and simple-let?
+ (not (memq T1 F))
+ (no-side-effects? E1))
+ (abandon-expression! E1)
+ (values E0 F regbindings0))
+ ((and target-registers?
+ simple-let?
+ (local-variable-used-once? T1))
+ (post-simplify-anf L T1 E0 E1 free regbindings #f))
+ (else
+ (values (make-call L (list E1))
+ free
+ regbindings)))))
+
+ (define (scan-let0 E env available)
+ (let ((L (call.proc E)))
+ (if (simple-lambda? L)
+ (scan (lambda.body L) env available)
+ (let ((T1 (make-variable name:IGNORED)))
+ (lambda.args-set! L (list T1))
+ (call-with-values
+ (lambda () (scan (make-call L (list (make-constant 0)))
+ env
+ available))
+ (lambda (E F regbindings)
+ (lambda.args-set! L '())
+ (values (make-call L '())
+ F
+ regbindings)))))))
+
+ ; Optimizes the internal definitions of L and returns their
+ ; free variables.
+
+ (define (scan-defs L env available)
+ (let loop ((defs (lambda.defs L))
+ (newdefs '())
+ (Fdefs '()))
+ (if (null? defs)
+ (begin (lambda.defs-set! L (reverse newdefs))
+ Fdefs)
+ (let ((def (car defs)))
+ (call-with-values
+ (lambda ()
+ (let* ((Ldef (def.rhs def))
+ (Lformals (make-null-terminated (lambda.args Ldef)))
+ (Lenv (environment-extend*
+ (environment-extend* env Lformals)
+ (map def.lhs (lambda.defs Ldef)))))
+ (scan Ldef Lenv available)))
+ (lambda (rhs Frhs empty)
+ (if (not (null? empty))
+ (error 'scan-binding 'def))
+ (loop (cdr defs)
+ (cons (make-definition (def.lhs def) rhs)
+ newdefs)
+ (union Frhs Fdefs))))))))
+
+ ; Given the right-hand side of a let-binding, an environment,
+ ; and a table of available expressions, returns the transformed
+ ; expression, its free variables, and the register bindings that
+ ; need to be wrapped around it.
+
+ (define (scan-rhs E env available)
+
+ (cond
+ ((constant? E)
+ (values E (empty-set) '()))
+
+ ((variable? E)
+ (let* ((name (variable.name E))
+ (Enew (and commoning?
+ (if (global? name)
+ (let ((T (available-expression
+ available E)))
+ (if T
+ (make-variable T)
+ #f))
+ (available-variable available name)))))
+ (if Enew
+ (scan-rhs Enew env available)
+ (begin (used-variable! name)
+ (values E (list name) '())))))
+
+ ((lambda? E)
+ (let* ((formals (make-null-terminated (lambda.args E)))
+ (env (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs E))))
+ (Fdefs (scan-defs E env available)))
+ (call-with-values
+ (lambda ()
+ (let ((available (copy-available-table available)))
+ (available-kill! available available:killer:all)
+ (scan-body (lambda.body E)
+ env
+ available
+ formals)))
+ (lambda (E0 F0 regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings regbindings0 E0 F0))
+ (lambda (E0 F0)
+ (lambda.body-set! E E0)
+ (let ((F (union Fdefs F0)))
+ (for-each (lambda (x)
+ (closed-over-local-variable! x))
+ F)
+ (lambda.F-set! E F)
+ (lambda.G-set! E F)
+ (values E
+ (difference F
+ (make-null-terminated
+ (lambda.args E)))
+ '()))))))))
+
+ ((conditional? E)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (constant? E0)
+ ; FIXME: E1 and E2 might not be a legal rhs,
+ ; so we can't just return the simplified E1 or E2.
+ (let ((E1 (if (constant.value E0) E1 E2)))
+ (call-with-values
+ (lambda () (scan E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (cond ((or (not (call? E1))
+ (not (lambda? (call.proc E1))))
+ (values E1 F1 regbindings1))
+ (else
+ ; FIXME: Must return a valid rhs.
+ (values (make-conditional
+ (make-constant #t)
+ E1
+ (make-constant 0))
+ F1
+ regbindings1))))))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (if (not (null? regbindings0))
+ (error 'scan-rhs 'if))
+ (if (not (eq? E0 (if.test E)))
+ (scan-rhs (make-conditional E0 E1 E2)
+ env available)
+ (let ((available1
+ (copy-available-table available))
+ (available2
+ (copy-available-table available)))
+ (if (variable? E0)
+ (let ((T0 (variable.name E0)))
+ (available-add!
+ available2 T0 (make-constant #f)))
+ (error (make-readable E #t)))
+ (call-with-values
+ (lambda () (scan E1 env available1))
+ (lambda (E1 F1 regbindings1)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings1 E1 F1))
+ (lambda (E1 F1)
+ (call-with-values
+ (lambda () (scan E2 env available2))
+ (lambda (E2 F2 regbindings2)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings2 E2 F2))
+ (lambda (E2 F2)
+ (let ((E (make-conditional
+ E0 E1 E2))
+ (F (union F0 F1 F2)))
+ (available-intersect!
+ available
+ available1
+ available2)
+ (values E F '())))))))))))))))))
+
+
+ ((assignment? E)
+ (call-with-values
+ (lambda () (scan-rhs (assignment.rhs E) env available))
+ (lambda (E1 F1 regbindings1)
+ (if (not (null? regbindings1))
+ (error 'scan-rhs 'set!))
+ (available-kill! available available:killer:globals)
+ (values (make-assignment (assignment.lhs E) E1)
+ (union (list (assignment.lhs E)) F1)
+ '()))))
+
+ ((begin? E)
+ ; Shouldn't occur in A-normal form.
+ (error 'scan-rhs 'begin))
+
+ ((real-call? E)
+ (let* ((E0 (call.proc E))
+ (args (call.args E))
+ (regcontents (append regvars
+ (map (lambda (x) #f) args))))
+ (let loop ((args args)
+ (regs argument-registers)
+ (regcontents regcontents)
+ (newargs '())
+ (regbindings '())
+ (F (if (variable? E0)
+ (let ((f (variable.name E0)))
+ (used-variable! f)
+ (list f))
+ (empty-set))))
+ (cond ((null? args)
+ (available-kill! available available:killer:all)
+ (values (make-call E0 (reverse newargs))
+ F
+ regbindings))
+ ((null? regs)
+ (let ((arg (car args)))
+ (loop (cdr args)
+ '()
+ (cdr regcontents)
+ (cons arg newargs)
+ regbindings
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))
+ ((and commoning?
+ (variable? (car args))
+ (available-variable
+ available
+ (variable.name (car args))))
+ (let* ((name (variable.name (car args)))
+ (Enew (available-variable available name)))
+ (loop (cons Enew (cdr args))
+ regs regcontents newargs regbindings F)))
+ ((and target-registers?
+ (variable? (car args))
+ (let ((x (variable.name (car args))))
+ ; We haven't yet recorded this use.
+ (or (local-variable-not-used? x)
+ (and (memq x regvars)
+ (not (eq? x (car regcontents)))))))
+ (let* ((x (variable.name (car args)))
+ (R (car regs))
+ (newarg (make-variable R)))
+ (used-variable! x)
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons newarg newargs)
+ (cons (make-regbinding R x newarg)
+ regbindings)
+ (union (list R) F))))
+ (else
+ (let ((E1 (car args)))
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons E1 newargs)
+ regbindings
+ (if (variable? E1)
+ (let ((name (variable.name E1)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))))))
+
+ ((call? E)
+ ; Must be a call to a primop.
+ (let* ((E0 (call.proc E))
+ (f0 (variable.name E0)))
+ (let loop ((args (call.args E))
+ (newargs '())
+ (F (list f0)))
+ (cond ((null? args)
+ (let* ((E (make-call E0 (reverse newargs)))
+ (T (and commoning?
+ (available-expression
+ available E))))
+ (if T
+ (begin (abandon-expression! E)
+ (scan-rhs (make-variable T) env available))
+ (begin
+ (available-kill!
+ available
+ (prim-kills (prim-entry f0)))
+ (cond ((eq? f0 name:check!)
+ (let ((x (car (call.args E))))
+ (cond ((not (runtime-safety-checking))
+ (abandon-expression! E)
+ ;(values x '() '())
+ (scan-rhs x env available))
+ ((variable? x)
+ (available-add!
+ available
+ (variable.name x)
+ (make-constant #t))
+ (values E F '()))
+ ((constant.value x)
+ (abandon-expression! E)
+ (values x '() '()))
+ (else
+ (declaration-error E)
+ (values E F '())))))
+ (else
+ (values E F '())))))))
+ ((variable? (car args))
+ (let* ((E1 (car args))
+ (x (variable.name E1))
+ (Enew
+ (and commoning?
+ (available-variable available x))))
+ (if Enew
+ ; All of the arguments are constants or
+ ; variables, so if the variable is replaced
+ ; here it will be replaced throughout the call.
+ (loop (cons Enew (cdr args))
+ newargs
+ (remq x F))
+ (begin
+ (used-variable! x)
+ (loop (cdr args)
+ (cons (car args) newargs)
+ (union (list x) F))))))
+ (else
+ (loop (cdr args)
+ (cons (car args) newargs)
+ F))))))
+
+ (else
+ (error 'scan-rhs (make-readable E)))))
+
+ (call-with-values
+ (lambda () (scan E env available))
+ (lambda (E F regbindings)
+ (call-with-values
+ (lambda () (wrap-with-register-bindings regbindings E F))
+ (lambda (E F)
+ (values E F '()))))))
+
+ (call-with-values
+ (lambda ()
+ (scan-body E
+ (make-hashtree symbol-hash assq)
+ (make-available-table)
+ '()))
+ (lambda (E F regbindings)
+ (if (not (null? regbindings))
+ (error 'scan-body))
+ E)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 16 June 1999.
+;
+; Intraprocedural representation inference.
+
+(define (representation-analysis exp)
+ (let* ((debugging? #f)
+ (integrate-usual? (integrate-usual-procedures))
+ (known (make-hashtable symbol-hash assq))
+ (types (make-hashtable symbol-hash assq))
+ (g (callgraph exp))
+ (schedule (list (callgraphnode.code (car g))))
+ (changed? #f)
+ (mutate? #f))
+
+ ; known is a hashtable that maps the name of a known local procedure
+ ; to a list of the form (tv1 ... tvN), where tv1, ..., tvN
+ ; are type variables that stand for the representation types of its
+ ; arguments. The type variable that stands for the representation
+ ; type of the result of the procedure has the same name as the
+ ; procedure itself.
+
+ ; types is a hashtable that maps local variables and the names
+ ; of known local procedures to an approximation of their
+ ; representation type.
+ ; For a known local procedure, the representation type is for the
+ ; result of the procedure, not the procedure itself.
+
+ ; schedule is a stack of work that needs to be done.
+ ; Each entry in the stack is either an escaping lambda expression
+ ; or the name of a known local procedure.
+
+ (define (schedule! job)
+ (if (not (memq job schedule))
+ (begin (set! schedule (cons job schedule))
+ (if (not (symbol? job))
+ (callgraphnode.info! (lookup-node job) #t)))))
+
+ ; Schedules a known local procedure.
+
+ (define (schedule-known-procedure! name)
+ ; Mark every known procedure that can actually be called.
+ (callgraphnode.info! (assq name g) #t)
+ (schedule! name))
+
+ ; Schedule all code that calls the given known local procedure.
+
+ (define (schedule-callers! name)
+ (for-each (lambda (node)
+ (if (and (callgraphnode.info node)
+ (or (memq name (callgraphnode.tailcalls node))
+ (memq name (callgraphnode.nontailcalls node))))
+ (let ((caller (callgraphnode.name node)))
+ (if caller
+ (schedule! caller)
+ (schedule! (callgraphnode.code node))))))
+ g))
+
+ ; Schedules local procedures of a lambda expression.
+
+ (define (schedule-local-procedures! L)
+ (for-each (lambda (def)
+ (let ((name (def.lhs def)))
+ (if (known-procedure-is-callable? name)
+ (schedule! name))))
+ (lambda.defs L)))
+
+ ; Returns true iff the given known procedure is known to be callable.
+
+ (define (known-procedure-is-callable? name)
+ (callgraphnode.info (assq name g)))
+
+ ; Sets CHANGED? to #t and returns #t if the type variable's
+ ; approximation has changed; otherwise returns #f.
+
+ (define (update-typevar! tv type)
+ (let* ((type0 (hashtable-get types tv))
+ (type0 (or type0
+ (begin (hashtable-put! types tv rep:bottom)
+ rep:bottom)))
+ (type1 (representation-union type0 type)))
+ (if (eq? type0 type1)
+ #f
+ (begin (hashtable-put! types tv type1)
+ (set! changed? #t)
+ (if (and debugging? mutate?)
+ (begin (display "******** Changing type of ")
+ (display tv)
+ (display " from ")
+ (display (rep->symbol type0))
+ (display " to ")
+ (display (rep->symbol type1))
+ (newline)))
+ #t))))
+
+ ; GIven the name of a known local procedure, returns its code.
+
+ (define (lookup-code name)
+ (callgraphnode.code (assq name g)))
+
+ ; Given a lambda expression, either escaping or the code for
+ ; a known local procedure, returns its node in the call graph.
+
+ (define (lookup-node L)
+ (let loop ((g g))
+ (cond ((null? g)
+ (error "Unknown lambda expression" (make-readable L #t)))
+ ((eq? L (callgraphnode.code (car g)))
+ (car g))
+ (else
+ (loop (cdr g))))))
+
+ ; Given: a type variable, expression, and a set of constraints.
+ ; Side effects:
+ ; Update the representation types of all variables that are
+ ; bound within the expression.
+ ; Update the representation types of all arguments to known
+ ; local procedures that are called within the expression.
+ ; If the representation type of an argument to a known local
+ ; procedure changes, then schedule that procedure's code
+ ; for analysis.
+ ; Update the constraint set to reflect the constraints that
+ ; hold following execution of the expression.
+ ; If mutate? is true, then transform the expression to rely
+ ; on the representation types that have been inferred.
+ ; Return: type of the expression under the current assumptions
+ ; and constraints.
+
+ (define (analyze exp constraints)
+
+ (if (and #f debugging?)
+ (begin (display "Analyzing: ")
+ (newline)
+ (pretty-print (make-readable exp #t))
+ (newline)))
+
+ (case (car exp)
+
+ ((quote)
+ (representation-of-value (constant.value exp)))
+
+ ((begin)
+ (let* ((name (variable.name exp)))
+ (representation-typeof name types constraints)))
+
+ ((lambda)
+ (schedule! exp)
+ rep:procedure)
+
+ ((set!)
+ (analyze (assignment.rhs exp) constraints)
+ (constraints-kill! constraints available:killer:globals)
+ rep:object)
+
+ ((if)
+ (let* ((E0 (if.test exp))
+ (E1 (if.then exp))
+ (E2 (if.else exp))
+ (type0 (analyze E0 constraints)))
+ (if mutate?
+ (cond ((representation-subtype? type0 rep:true)
+ (if.test-set! exp (make-constant #t)))
+ ((representation-subtype? type0 rep:false)
+ (if.test-set! exp (make-constant #f)))))
+ (cond ((representation-subtype? type0 rep:true)
+ (analyze E1 constraints))
+ ((representation-subtype? type0 rep:false)
+ (analyze E2 constraints))
+ ((variable? E0)
+ (let* ((T0 (variable.name E0))
+ (ignored (analyze E0 constraints))
+ (constraints1 (copy-constraints-table constraints))
+ (constraints2 (copy-constraints-table constraints)))
+ (constraints-add! types
+ constraints1
+ (make-type-constraint
+ T0 rep:true available:killer:immortal))
+ (constraints-add! types
+ constraints2
+ (make-type-constraint
+ T0 rep:false available:killer:immortal))
+ (let* ((type1 (analyze E1 constraints1))
+ (type2 (analyze E2 constraints2))
+ (type (representation-union type1 type2)))
+ (constraints-intersect! constraints
+ constraints1
+ constraints2)
+ type)))
+ (else
+ (representation-error "Bad ANF" (make-readable exp #t))))))
+
+ (else
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((lambda? proc)
+ (cond ((null? args)
+ (analyze-let0 exp constraints))
+ ((null? (cdr args))
+ (analyze-let1 exp constraints))
+ (else
+ (error "Compiler bug: pass3rep"))))
+ ((variable? proc)
+ (let* ((procname (variable.name proc)))
+ (cond ((hashtable-get known procname)
+ =>
+ (lambda (vars)
+ (analyze-known-call exp constraints vars)))
+ (integrate-usual?
+ (let ((entry (prim-entry procname)))
+ (if entry
+ (analyze-primop-call exp constraints entry)
+ (analyze-unknown-call exp constraints))))
+ (else
+ (analyze-unknown-call exp constraints)))))
+ (else
+ (analyze-unknown-call exp constraints)))))))
+
+ (define (analyze-let0 exp constraints)
+ (let ((proc (call.proc exp)))
+ (schedule-local-procedures! proc)
+ (if (null? (lambda.args proc))
+ (analyze (lambda.body exp) constraints)
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-let1 exp constraints)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc)))
+ (schedule-local-procedures! proc)
+ (if (and (pair? vars)
+ (null? (cdr vars)))
+ (let* ((T1 (car vars))
+ (E1 (car (call.args exp))))
+ (if (and integrate-usual? (call? E1))
+ (let ((proc (call.proc E1))
+ (args (call.args E1)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (entry (prim-entry op))
+ (K1 (if entry
+ (prim-lives-until entry)
+ available:killer:dead)))
+ (if (not (= K1 available:killer:dead))
+ ; Must copy the call to avoid problems
+ ; with side effects when mutate? is true.
+ (constraints-add!
+ types
+ constraints
+ (make-constraint T1
+ (make-call proc args)
+ K1)))))))
+ (update-typevar! T1 (analyze E1 constraints))
+ (analyze (lambda.body proc) constraints))
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-primop-call exp constraints entry)
+ (let* ((op (prim-opcodename entry))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args))
+ (type (rep-result? op argtypes)))
+ (constraints-kill! constraints (prim-kills entry))
+ (cond ((and (eq? op 'check!)
+ (variable? (car args)))
+ (let ((varname (variable.name (car args))))
+ (if (and mutate?
+ (representation-subtype? (car argtypes) rep:true))
+ (call.args-set! exp
+ (cons (make-constant #t) (cdr args))))
+ (constraints-add! types
+ constraints
+ (make-type-constraint
+ varname
+ rep:true
+ available:killer:immortal))))
+ ((and mutate? (rep-specific? op argtypes))
+ =>
+ (lambda (newop)
+ (call.proc-set! exp (make-variable newop)))))
+ (or type rep:object)))
+
+ (define (analyze-known-call exp constraints vars)
+ (let* ((procname (variable.name (call.proc exp)))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args)))
+ (if (not (known-procedure-is-callable? procname))
+ (schedule-known-procedure! procname))
+ (for-each (lambda (var type)
+ (if (update-typevar! var type)
+ (schedule-known-procedure! procname)))
+ vars
+ argtypes)
+ ; FIXME: We aren't analyzing the effects of known local procedures.
+ (constraints-kill! constraints available:killer:all)
+ (hashtable-get types procname)))
+
+ (define (analyze-unknown-call exp constraints)
+ (analyze (call.proc exp) constraints)
+ (for-each (lambda (arg) (analyze arg constraints))
+ (call.args exp))
+ (constraints-kill! constraints available:killer:all)
+ rep:object)
+
+ (define (analyze-known-local-procedure name)
+ (if debugging?
+ (begin (display "Analyzing ")
+ (display name)
+ (newline)))
+ (let ((L (lookup-code name))
+ (constraints (make-constraints-table)))
+ (schedule-local-procedures! L)
+ (let ((type (analyze (lambda.body L) constraints)))
+ (if (update-typevar! name type)
+ (schedule-callers! name))
+ type)))
+
+ (define (analyze-unknown-lambda L)
+ (if debugging?
+ (begin (display "Analyzing escaping lambda expression")
+ (newline)))
+ (schedule-local-procedures! L)
+ (let ((vars (make-null-terminated (lambda.args L))))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep:object))
+ vars)
+ (analyze (lambda.body L)
+ (make-constraints-table))))
+
+ ; For debugging.
+
+ (define (display-types)
+ (hashtable-for-each (lambda (f vars)
+ (write f)
+ (display " : returns ")
+ (write (rep->symbol (hashtable-get types f)))
+ (newline)
+ (for-each (lambda (x)
+ (display " ")
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars))
+ known))
+
+ (define (display-all-types)
+ (let* ((vars (hashtable-map (lambda (x type) x) types))
+ (vars (twobit-sort (lambda (var1 var2)
+ (string<=? (symbol->string var1)
+ (symbol->string var2)))
+ vars)))
+ (for-each (lambda (x)
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars)))
+ '
+ (if debugging?
+ (begin (pretty-print (make-readable (car schedule) #t))
+ (newline)))
+ (if debugging?
+ (view-callgraph g))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (vars (make-null-terminated (lambda.args code)))
+ (known? (symbol? name))
+ (rep (if known? rep:bottom rep:object)))
+ (callgraphnode.info! node #f)
+ (if known?
+ (begin (hashtable-put! known name vars)
+ (hashtable-put! types name rep)))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep))
+ vars)))
+ g)
+
+ (let loop ()
+ (cond ((not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop)))
+ (changed?
+ (set! changed? #f)
+ (set! schedule (list (callgraphnode.code (car g))))
+ (if debugging?
+ (begin (display-all-types) (newline)))
+ (loop))))
+
+ (if debugging?
+ (display-types))
+
+ (set! mutate? #t)
+
+ ; We don't want to analyze known procedures that are never called.
+
+ (set! schedule
+ (cons (callgraphnode.code (car g))
+ (map callgraphnode.name
+ (filter (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (known? (symbol? name))
+ (marked?
+ (known-procedure-is-callable? name)))
+ (callgraphnode.info! node #f)
+ (and known? marked?)))
+ g))))
+ (let loop ()
+ (if (not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop))))
+
+ (if changed?
+ (error "Compiler bug in representation inference"))
+
+ (if debugging?
+ (pretty-print (make-readable (callgraphnode.code (car g)) #t)))
+
+ exp))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 June 1999.
+;
+; The third "pass" of the Twobit compiler actually consists of several
+; passes, which are related by the common theme of flow analysis:
+; interprocedural inlining of known local procedures
+; interprocedural constant propagation and folding
+; intraprocedural commoning, copy propagation, and dead code elimination
+; representation inference (not yet implemented)
+; register targeting
+;
+; This pass operates as source-to-source transformations on
+; expressions written in the subset of Scheme described by the
+; following grammar:
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * Variables named IGNORED are neither referenced nor assigned.
+; * The expression does not share structure with the original input,
+; but might share structure with itself.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R is garbage.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * If a lambda expression is declared to be in A-normal form (see
+; pass3anormal.sch), then it really is in A-normal form.
+;
+; The phases of pass 3 interact with the referencing information R
+; and the free variables F as follows:
+;
+; Inlining ignores R, ignores F, destroys R, destroys F.
+; Constant propagation uses R, ignores F, preserves R, preserves F.
+; Conversion to ANF ignores R, ignores F, destroys R, destroys F.
+; Commoning ignores R, ignores F, destroys R, computes F.
+; Register targeting ignores R, ignores F, destroys R, computes F.
+
+(define (pass3 exp)
+
+ (define (phase1 exp)
+ (if (interprocedural-inlining)
+ (let ((g (callgraph exp)))
+ (inline-using-callgraph! g)
+ exp)
+ exp))
+
+ (define (phase2 exp)
+ (if (interprocedural-constant-propagation)
+ (constant-propagation (copy-exp exp))
+ exp))
+
+ (define (phase3 exp)
+ (if (common-subexpression-elimination)
+ (let* ((exp (if (interprocedural-constant-propagation)
+ exp
+ ; alpha-conversion
+ (copy-exp exp)))
+ (exp (a-normal-form exp)))
+ (if (representation-inference)
+ (intraprocedural-commoning exp 'commoning)
+ (intraprocedural-commoning exp)))
+ exp))
+
+ (define (phase4 exp)
+ (if (representation-inference)
+ (let ((exp (cond ((common-subexpression-elimination)
+ exp)
+ ((interprocedural-constant-propagation)
+ (a-normal-form exp))
+ (else
+ ; alpha-conversion
+ (a-normal-form (copy-exp exp))))))
+ (intraprocedural-commoning
+ (representation-analysis exp)))
+ exp))
+
+ (define (finish exp)
+ (if (and (not (interprocedural-constant-propagation))
+ (not (common-subexpression-elimination)))
+ (begin (compute-free-variables! exp)
+ exp)
+ ;(make-begin (list (make-constant 'anf) exp))))
+ exp))
+
+ (define (verify exp)
+ (check-referencing-invariants exp 'free)
+ exp)
+
+ (if (global-optimization)
+ (verify (finish (phase4 (phase3 (phase2 (phase1 exp))))))
+ (begin (compute-free-variables! exp)
+ (verify exp))))
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 4 June 1999
+
+; Implements the following abstract data types.
+;
+; labels
+; (init-labels)
+; (make-label)
+; cg-label-counter
+;
+; assembly streams
+; (make-assembly-stream)
+; (assembly-stream-code as)
+; (gen! as . instruction)
+; (gen-instruction! as instruction)
+; (gen-save! as frame)
+; (gen-restore! as frame)
+; (gen-pop! as frame)
+; (gen-setstk! as frame v)
+; (gen-store! as frame r v)
+; (gen-load! as frame r v)
+; (gen-stack! as frame v)
+;
+; temporaries
+; (init-temps)
+; (newtemp)
+; (newtemps)
+; newtemp-counter
+;
+; register environments
+; (cgreg-initial)
+; (cgreg-copy regs)
+; (cgreg-tos regs)
+; (cgreg-liveregs regs)
+; (cgreg-live regs r)
+; (cgreg-vars regs)
+; (cgreg-bind! regs r v)
+; (cgreg-bindregs! regs vars)
+; (cgreg-rename! regs alist)
+; (cgreg-release! regs r)
+; (cgreg-clear! regs)
+; (cgreg-lookup regs var)
+; (cgreg-lookup-reg regs r)
+; (cgreg-join! regs1 regs2)
+;
+; stack frame environments
+; (cgframe-initial)
+; (cgframe-size-cell frame)
+; (cgframe-size frame)
+; (cgframe-copy frame)
+; (cgframe-join! frame1 frame2)
+; (cgframe-update-stale! frame)
+; (cgframe-used! frame)
+; (cgframe-bind! frame n v instruction)
+; (cgframe-touch! frame v)
+; (cgframe-rename! frame alist)
+; (cgframe-release! frame v)
+; (cgframe-lookup frame v)
+; (cgframe-spilled? frame v)
+;
+; environments
+; (entry.name entry)
+; (entry.kind entry)
+; (entry.rib entry)
+; (entry.offset entry)
+; (entry.label entry)
+; (entry.regnum entry)
+; (entry.arity entry)
+; (entry.op entry)
+; (entry.imm entry)
+; (cgenv-initial)
+; (cgenv-lookup env id)
+; (cgenv-extend env vars procs)
+; (cgenv-bindprocs env procs)
+; (var-lookup var regs frame env)
+
+; Labels.
+
+(define (init-labels)
+ (set! cg-label-counter 1000))
+
+(define (make-label)
+ (set! cg-label-counter (+ cg-label-counter 1))
+ cg-label-counter)
+
+(define cg-label-counter 1000)
+
+; an assembly stream into which instructions should be emitted
+; an expression
+; the desired target register ('result, a register number, or '#f)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; contains size of frame, current top of frame
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+
+; Assembly streams, into which instructions are emitted by side effect.
+; Represented as a list of two things:
+;
+; Assembly code, represented as a pair whose car is a nonempty list
+; whose cdr is a possibly empty list of MacScheme machine assembly
+; instructions, and whose cdr is the last pair of the car.
+;
+; Any Scheme object that the code generator wants to associate with
+; this code.
+
+(define (make-assembly-stream)
+ (let ((code (list (list 0))))
+ (set-cdr! code (car code))
+ (list code #f)))
+
+(define (assembly-stream-code output)
+ (if (local-optimizations)
+ (filter-basic-blocks (cdar (car output)))
+ (cdar (car output))))
+
+(define (assembly-stream-info output)
+ (cadr output))
+
+(define (assembly-stream-info! output x)
+ (set-car! (cdr output) x)
+ #f)
+
+(define (gen-instruction! output instruction)
+ (let ((pair (list instruction))
+ (code (car output)))
+ (set-cdr! (cdr code) pair)
+ (set-cdr! code pair)
+ output))
+
+;
+
+(define (gen! output . instruction)
+ (gen-instruction! output instruction))
+
+(define (gen-save! output frame t0)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $save size))
+ (gen-store! output frame 0 t0)
+ (cgframe:stale-set! frame '())))
+
+(define (gen-restore! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $restore size))))
+
+(define (gen-pop! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $pop size))))
+
+(define (gen-setstk! output frame tempname)
+ (let ((instruction (list $nop $setstk -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-store! output frame r tempname)
+ (let ((instruction (list $nop $store r -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-load! output frame r tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $load r n)))
+
+(define (gen-stack! output frame tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $stack n)))
+
+; Returns a temporary name.
+; Temporaries are compared using EQ?, so the use of small
+; exact integers as temporary names is implementation-dependent.
+
+(define (init-temps)
+ (set! newtemp-counter 5000))
+
+(define (newtemp)
+ (set! newtemp-counter
+ (+ newtemp-counter 1))
+ newtemp-counter)
+
+(define newtemp-counter 5000)
+
+(define (newtemps n)
+ (if (zero? n)
+ '()
+ (cons (newtemp)
+ (newtemps (- n 1)))))
+
+; New representation of
+; Register environments.
+; Represented as a list of three items:
+; an exact integer, one more than the highest index of a live register
+; a mutable vector with *nregs* elements of the form
+; #f (the register is dead)
+; #t (the register is live)
+; v (the register contains variable v)
+; t (the register contains temporary variable t)
+; a mutable vector of booleans: true if the register might be stale
+
+(define (cgreg-makeregs n v1 v2) (list n v1 v2))
+
+(define (cgreg-liveregs regs)
+ (car regs))
+
+(define (cgreg-contents regs)
+ (cadr regs))
+
+(define (cgreg-stale regs)
+ (caddr regs))
+
+(define (cgreg-liveregs-set! regs n)
+ (set-car! regs n)
+ regs)
+
+(define (cgreg-initial)
+ (let ((v1 (make-vector *nregs* #f))
+ (v2 (make-vector *nregs* #f)))
+ (cgreg-makeregs 0 v1 v2)))
+
+(define (cgreg-copy regs)
+ (let* ((newregs (cgreg-initial))
+ (v1a (cgreg-contents regs))
+ (v2a (cgreg-stale regs))
+ (v1 (cgreg-contents newregs))
+ (v2 (cgreg-stale newregs))
+ (n (vector-length v1a)))
+ (cgreg-liveregs-set! newregs (cgreg-liveregs regs))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ newregs)
+ (vector-set! v1 i (vector-ref v1a i))
+ (vector-set! v2 i (vector-ref v2a i)))))
+
+(define (cgreg-tos regs)
+ (- (cgreg-liveregs regs) 1))
+
+(define (cgreg-live regs r)
+ (if (eq? r 'result)
+ (cgreg-tos regs)
+ (max r (cgreg-tos regs))))
+
+(define (cgreg-vars regs)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (do ((i (- m 1) (- i 1))
+ (vars '()
+ (cons (vector-ref v i)
+ vars)))
+ ((< i 0)
+ vars))))
+
+(define (cgreg-bind! regs r t)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r t)
+ (if (>= r m)
+ (cgreg-liveregs-set! regs (+ r 1)))))
+
+(define (cgreg-bindregs! regs vars)
+ (do ((m (cgreg-liveregs regs) (+ m 1))
+ (v (cgreg-contents regs))
+ (vars vars (cdr vars)))
+ ((null? vars)
+ (cgreg-liveregs-set! regs m)
+ regs)
+ (vector-set! v m (car vars))))
+
+(define (cgreg-rename! regs alist)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if var
+ (let ((probe (assv var alist)))
+ (if probe
+ (vector-set! v i (cdr probe))))))))
+
+(define (cgreg-release! regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r #f)
+ (vector-set! (cgreg-stale regs) r #t)
+ (if (= r (- m 1))
+ (do ((m r (- m 1)))
+ ((or (negative? m)
+ (vector-ref v m))
+ (cgreg-liveregs-set! regs (+ m 1)))))))
+
+(define (cgreg-release-except! regs vars)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if (and var (not (memq var vars)))
+ (cgreg-release! regs i)))))
+
+(define (cgreg-clear! regs)
+ (let ((m (cgreg-liveregs regs))
+ (v1 (cgreg-contents regs))
+ (v2 (cgreg-stale regs)))
+ (do ((r 0 (+ r 1)))
+ ((= r m)
+ (cgreg-liveregs-set! regs 0))
+ (vector-set! v1 r #f)
+ (vector-set! v2 r #t))))
+
+(define (cgreg-lookup regs var)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (define (loop i)
+ (cond ((< i 0)
+ #f)
+ ((eq? var (vector-ref v i))
+ (list var 'register i '(object)))
+ (else
+ (loop (- i 1)))))
+ (loop (- m 1))))
+
+(define (cgreg-lookup-reg regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (if (<= m r)
+ #f
+ (vector-ref v r))))
+
+(define (cgreg-join! regs1 regs2)
+ (let ((m1 (cgreg-liveregs regs1))
+ (m2 (cgreg-liveregs regs2))
+ (v1 (cgreg-contents regs1))
+ (v2 (cgreg-contents regs2))
+ (stale1 (cgreg-stale regs1)))
+ (do ((i (- (max m1 m2) 1) (- i 1)))
+ ((< i 0)
+ (cgreg-liveregs-set! regs1 (min m1 m2)))
+ (let ((x1 (vector-ref v1 i))
+ (x2 (vector-ref v2 i)))
+ (cond ((eq? x1 x2)
+ #t)
+ ((not x1)
+ (if x2
+ (vector-set! stale1 i #t)))
+ (else
+ (vector-set! v1 i #f)
+ (vector-set! stale1 i #t)))))))
+
+; New representation of
+; Stack-frame environments.
+; Represented as a three-element list.
+;
+; Its car is a list whose car is a list of slot entries, each
+; of the form
+; (v n instruction stale)
+; where
+; v is the name of a variable or temporary,
+; n is #f or a slot number,
+; instruction is a possibly phantom store or setstk instruction
+; that stores v into slot n, and
+; stale is a list of stale slot entries, each of the form
+; (#t . n)
+; or (#f . -1)
+; where slot n had been allocated, initialized, and released
+; before the store or setstk instruction was generated.
+; Slot entries are updated by side effect.
+;
+; Its cadr is the list of currently stale slots.
+;
+; Its caddr is a list of variables that are free in the continuation,
+; or #f if that information is unknown.
+; This information allows a direct-style code generator to know when
+; a slot becomes stale.
+;
+; Its cadddr is the size of the stack frame, which can be
+; increased but not decreased. The cdddr of the stack frame
+; environment is shared with the save instruction that
+; created the frame. What a horrible crock!
+
+; This stuff is private to the implementation of stack-frame
+; environments.
+
+(define cgframe:slots car)
+(define cgframe:stale cadr)
+(define cgframe:livevars caddr)
+(define cgframe:slot.name car)
+(define cgframe:slot.offset cadr)
+(define cgframe:slot.instruction caddr)
+(define cgframe:slot.stale cadddr)
+
+(define cgframe:slots-set! set-car!)
+(define (cgframe:stale-set! frame stale)
+ (set-car! (cdr frame) stale))
+(define (cgframe:livevars-set! frame vars)
+ (set-car! (cddr frame) vars))
+
+(define cgframe:slot.name-set! set-car!)
+
+(define (cgframe:slot.offset-set! entry n)
+ (let ((instruction (caddr entry)))
+ (if (or (not (eq? #f (cadr entry)))
+ (not (eq? $nop (car instruction))))
+ (error "Compiler bug: cgframe" entry)
+ (begin
+ (set-car! (cdr entry) n)
+ (set-car! instruction (cadr instruction))
+ (set-cdr! instruction (cddr instruction))
+ (if (eq? $setstk (car instruction))
+ (set-car! (cdr instruction) n)
+ (set-car! (cddr instruction) n))))))
+
+; Reserves a slot offset that was unused where the instruction
+; of the slot entry was generated, and returns that offset.
+
+(define (cgframe:unused-slot frame entry)
+ (let* ((stale (cgframe:slot.stale entry))
+ (probe (assq #t stale)))
+ (if probe
+ (let ((n (cdr probe)))
+ (if (zero? n)
+ (cgframe-used! frame))
+ (set-car! probe #f)
+ n)
+ (let* ((cell (cgframe-size-cell frame))
+ (n (+ 1 (car cell))))
+ (set-car! cell n)
+ (if (zero? n)
+ (cgframe:unused-slot frame entry)
+ n)))))
+
+; Public entry points.
+
+; The runtime system requires slot 0 of a frame to contain
+; a closure whose code pointer contains the return address
+; of the frame.
+; To prevent slot 0 from being used for some other purpose,
+; we rely on a complex trick: Slot 0 is initially stale.
+; Gen-save! generates a store instruction for register 0,
+; with slot 0 as the only stale slot for that instruction;
+; then gen-save! clears the frame's set of stale slots, which
+; prevents other store instructions from using slot 0.
+
+(define (cgframe-initial)
+ (list '()
+ (list (cons #t 0))
+ '#f
+ -1))
+
+(define cgframe-livevars cgframe:livevars)
+(define cgframe-livevars-set! cgframe:livevars-set!)
+
+(define (cgframe-size-cell frame)
+ (cdddr frame))
+
+(define (cgframe-size frame)
+ (car (cgframe-size-cell frame)))
+
+(define (cgframe-used! frame)
+ (if (negative? (cgframe-size frame))
+ (set-car! (cgframe-size-cell frame) 0)))
+
+; Called only by gen-store!, gen-setstk!
+
+(define (cgframe-bind! frame var instruction)
+ (cgframe:slots-set! frame
+ (cons (list var #f instruction (cgframe:stale frame))
+ (cgframe:slots frame))))
+
+; Called only by gen-load!, gen-stack!
+
+(define (cgframe-touch! frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (let ((n (cgframe:unused-slot frame entry)))
+ (cgframe:slot.offset-set! entry n))))
+ (error "Compiler bug: cgframe-touch!" frame var))))
+
+(define (cgframe-rename! frame alist)
+ (for-each (lambda (entry)
+ (let ((probe (assq (cgframe:slot.name entry) alist)))
+ (if probe
+ (cgframe:slot.name-set! entry (cdr probe)))))
+ (cgframe:slots frame)))
+
+(define (cgframe-release! frame var)
+ (let* ((slots (cgframe:slots frame))
+ (entry (assq var slots)))
+ (if entry
+ (begin (cgframe:slots-set! frame (remq entry slots))
+ (let ((n (cgframe:slot.offset entry)))
+ (if (and (not (eq? #f n))
+ (not (zero? n)))
+ (cgframe:stale-set!
+ frame
+ (cons (cons #t n)
+ (cgframe:stale frame)))))))))
+
+(define (cgframe-release-except! frame vars)
+ (let loop ((slots (reverse (cgframe:slots frame)))
+ (newslots '())
+ (stale (cgframe:stale frame)))
+ (if (null? slots)
+ (begin (cgframe:slots-set! frame newslots)
+ (cgframe:stale-set! frame stale))
+ (let ((slot (car slots)))
+ (if (memq (cgframe:slot.name slot) vars)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale)
+ (let ((n (cgframe:slot.offset slot)))
+ (cond ((eq? n #f)
+ (loop (cdr slots)
+ newslots
+ stale))
+ ((zero? n)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale))
+ (else
+ (loop (cdr slots)
+ newslots
+ (cons (cons #t n) stale))))))))))
+
+(define (cgframe-lookup frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (cgframe-touch! frame var))
+ (list var 'frame (cgframe:slot.offset entry) '(object)))
+ #f)))
+
+(define (cgframe-spilled? frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (not (eq? #f n)))
+ #f)))
+
+; For a conditional expression, the then and else parts must be
+; evaluated using separate copies of the frame environment,
+; and those copies must be resolved at the join point. The
+; nature of the resolution depends upon whether the conditional
+; expression is in a tail position.
+;
+; Critical invariant:
+; Any store instructions that are generated within either arm of the
+; conditional involve variables and temporaries that are local to the
+; conditional.
+;
+; If the conditional expression is in a tail position, then a slot
+; that is stale after the test can be allocated independently by the
+; two arms of the conditional. If the conditional expression is in a
+; non-tail position, then the slot can be allocated independently
+; provided it is not a candidate destination for any previous emitted
+; store instruction.
+
+(define (cgframe-copy frame)
+ (cons (car frame)
+ (cons (cadr frame)
+ (cons (caddr frame)
+ (cdddr frame)))))
+
+(define (cgframe-update-stale! frame)
+ (let* ((n (cgframe-size frame))
+ (v (make-vector (+ 1 n) #t))
+ (stale (cgframe:stale frame)))
+ (for-each (lambda (x)
+ (if (car x)
+ (let ((i (cdr x)))
+ (if (<= i n)
+ (vector-set! v i #f)))))
+ stale)
+ (for-each (lambda (slot)
+ (let ((offset (cgframe:slot.offset slot)))
+ (if offset
+ (vector-set! v offset #f)
+ (for-each (lambda (stale)
+ (if (car stale)
+ (let ((i (cdr stale)))
+ (if (< i n)
+ (vector-set! v i #f)))))
+ (cgframe:slot.stale slot)))))
+ (cgframe:slots frame))
+ (do ((i n (- i 1))
+ (stale (filter car stale)
+ (if (vector-ref v i)
+ (cons (cons #t i) stale)
+ stale)))
+ ((<= i 0)
+ (cgframe:stale-set! frame stale)))))
+
+(define (cgframe-join! frame1 frame2)
+ (let* ((slots1 (cgframe:slots frame1))
+ (slots2 (cgframe:slots frame2))
+ (slots (intersection slots1 slots2))
+ (deadslots (append (difference slots1 slots)
+ (difference slots2 slots)))
+ (deadoffsets (make-set
+ (filter (lambda (x) (not (eq? x #f)))
+ (map cgframe:slot.offset deadslots))))
+ (stale1 (cgframe:stale frame1))
+ (stale2 (cgframe:stale frame2))
+ (stale (intersection stale1 stale2))
+ (stale (append (map (lambda (n) (cons #t n))
+ deadoffsets)
+ stale)))
+ (cgframe:slots-set! frame1 slots)
+ (cgframe:stale-set! frame1 stale)))
+
+; Environments.
+;
+; Each identifier has one of the following kinds of entry.
+;
+; (<name> register <number> (object))
+; (<name> frame <slot> (object))
+; (<name> lexical <rib> <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+; (<name> global (object))
+;
+; Implementation.
+;
+; An environment is represented as a list of the form
+;
+; ((<entry> ...) ; lexical rib
+; ...)
+;
+; where each <entry> has one of the forms
+;
+; (<name> lexical <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+
+(define entry.name car)
+(define entry.kind cadr)
+(define entry.rib caddr)
+(define entry.offset cadddr)
+(define entry.label cadddr)
+(define entry.regnum caddr)
+(define entry.slotnum caddr)
+(define entry.arity caddr)
+(define entry.op cadddr)
+(define (entry.imm entry) (car (cddddr entry)))
+
+(define (cgenv-initial integrable)
+ (list (map (lambda (x)
+ (list (car x)
+ 'integrable
+ (cadr x)
+ (caddr x)
+ (cadddr x)
+ '(object)))
+ integrable)))
+
+(define (cgenv-lookup env id)
+ (define (loop ribs m)
+ (if (null? ribs)
+ (cons id '(global (object)))
+ (let ((x (assq id (car ribs))))
+ (if x
+ (case (cadr x)
+ ((lexical)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((procedure)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((integrable)
+ (if (integrate-usual-procedures)
+ x
+ (loop '() m)))
+ (else ???))
+ (loop (cdr ribs) (+ m 1))))))
+ (loop env 0))
+
+(define (cgenv-extend env vars procs)
+ (cons (do ((n 0 (+ n 1))
+ (vars vars (cdr vars))
+ (rib (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (cons (list (car vars) 'lexical n '(object)) rib)))
+ ((null? vars) rib))
+ env))
+
+(define (cgenv-bindprocs env procs)
+ (cons (append (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (car env))
+ (cdr env)))
+
+(define (var-lookup var regs frame env)
+ (or (cgreg-lookup regs var)
+ (cgframe-lookup frame var)
+ (cgenv-lookup env var)))
+
+; Compositions.
+
+(define compile
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1 x))) $usual-integrable-procedures$)))
+
+(define compile-block
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1-block x))) $usual-integrable-procedures$)))
+
+; For testing.
+
+(define foo
+ (lambda (x)
+ (pretty-print (compile x))))
+
+; Find the smallest number of registers such that
+; adding more registers does not affect the code
+; generated for x (from 4 to 32 registers).
+
+(define (minregs x)
+ (define (defregs R)
+ (set! *nregs* R)
+ (set! *lastreg* (- *nregs* 1))
+ (set! *fullregs* (quotient *nregs* 2)))
+ (defregs 32)
+ (let ((code (assemble (compile x))))
+ (define (binary-search m1 m2)
+ (if (= (+ m1 1) m2)
+ m2
+ (let ((midpt (quotient (+ m1 m2) 2)))
+ (defregs midpt)
+ (if (equal? code (assemble (compile x)))
+ (binary-search m1 midpt)
+ (binary-search midpt m2)))))
+ (defregs 4)
+ (let ((newcode (assemble (compile x))))
+ (if (equal? code newcode)
+ 4
+ (binary-search 4 32)))))
+
+; Minimums:
+; browse 10
+; triangle 5
+; traverse 10
+; destruct 6
+; puzzle 8,8,10,7
+; tak 6
+; fft 28 (changing the named lets to macros didn't matter)
+; Copyright 1991 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 7 June 1999.
+;
+; Fourth pass of the Twobit compiler:
+; code generation for the MacScheme machine.
+;
+; This pass operates on input expressions described by the
+; following grammar and the invariants that follow it.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Every procedure defined by an internal definition takes a
+; fixed number of arguments.
+; * Every call to a procedure defined by an internal definition
+; passes the correct number of arguments.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Any lambda expression that is declared to be in A-normal form
+; really is in A-normal form.
+;
+;
+; Stack frames are created by "save" instructions.
+; A save instruction is generated
+;
+; * at the beginning of each lambda body
+; * at the beginning of the code for each arm of a conditional,
+; provided:
+; the conditional is in a tail position
+; the frames that were allocated by the save instructions
+; that dominate the arms of the conditional have not been
+; used (those save instructions will be eliminated during
+; assembly)
+;
+; The operand of a save instruction, and of its matching pop instructions,
+; increases automatically as frame slots are allocated.
+;
+; The code generated to return from a procedure is
+;
+; pop n
+; return
+;
+; The code generated for a tail call is
+;
+; pop n
+; invoke ...
+;
+; Invariant: When the code generator reserves an argument register
+; to hold a value, that value is named, and is stored into the current
+; stack frame. These store instructions are eliminated during assembly
+; unless there is a matching load instruction. If all of the instructions
+; that store into a stack frame are eliminated, then the stack frame
+; itself is eliminated.
+; Exception: An argument register may be used without naming or storing
+; its value provided the register is not in use and no expressions are
+; evaluated while it contains the unnamed and unstored value.
+
+
+(define (pass4 exp integrable)
+ (init-labels)
+ (init-temps)
+ (let ((output (make-assembly-stream))
+ (frame (cgframe-initial))
+ (regs (cgreg-initial))
+ (t0 (newtemp)))
+ (assembly-stream-info! output (make-hashtable equal-hash assoc))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (cg0 output
+ exp
+ 'result
+ regs
+ frame
+ (cgenv-initial integrable)
+ #t)
+ (pass4-code output)))
+
+(define (pass4-code output)
+ (hashtable-for-each (lambda (situation label)
+ (cg-trap output situation label))
+ (assembly-stream-info output))
+ (assembly-stream-code output))
+
+; Given:
+; an assembly stream into which instructions should be emitted
+; an expression
+; the target register
+; ('result, a register number, or '#f; tail position implies 'result)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+; Returns:
+; the target register ('result or a register number)
+; Side effects:
+; may change the register and stack-frame environments
+; may increase the size of the stack frame, which changes previously
+; emitted instructions
+; writes instructions to the assembly stream
+
+(define (cg0 output exp target regs frame env tail?)
+ (case (car exp)
+ ((quote) (gen! output $const (constant.value exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((lambda) (cg-lambda output exp regs frame env)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((set!) (cg0 output (assignment.rhs exp) 'result regs frame env #f)
+ (cg-assignment-result output exp target regs frame env tail?))
+ ((if) (cg-if output exp target regs frame env tail?))
+ ((begin) (if (variable? exp)
+ (cg-variable output exp target regs frame env tail?)
+ (cg-sequential output exp target regs frame env tail?)))
+ (else (cg-call output exp target regs frame env tail?))))
+
+; Lambda expressions that evaluate to closures.
+; This is hard because the MacScheme machine's lambda instruction
+; closes over the values that are in argument registers 0 through r
+; (where r can be larger than *nregs*).
+; The set of free variables is calculated and then sorted to minimize
+; register shuffling.
+;
+; Returns: nothing.
+
+(define (cg-lambda output exp regs frame env)
+ (let* ((args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (free (difference (lambda.F exp) vars))
+ (free (cg-sort-vars free regs frame env))
+ (newenv (cgenv-extend env (cons #t free) '()))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv)
+ (cg-eval-vars output free regs frame env)
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this the right constant?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: This load forces a stack frame to be allocated.
+ (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))
+
+; Given a list of free variables, filters out the ones that
+; need to be copied into a closure, and sorts them into an order
+; that reduces register shuffling. Returns a sorted version of
+; the list in which the first element (element 0) should go
+; into register 1, the second into register 2, and so on.
+
+(define (cg-sort-vars free regs frame env)
+ (let* ((free (filter (lambda (var)
+ (case (entry.kind
+ (var-lookup var regs frame env))
+ ((register frame)
+ #t)
+ ((lexical)
+ (not (ignore-space-leaks)))
+ (else #f)))
+ free))
+ (n (length free))
+ (m (min n (- *nregs* 1)))
+ (vec (make-vector m #f)))
+ (define (loop1 free free-notregister)
+ (if (null? free)
+ (loop2 0 free-notregister)
+ (let* ((var (car free))
+ (entry (cgreg-lookup regs var)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (<= r n)
+ (begin (vector-set! vec (- r 1) var)
+ (loop1 (cdr free)
+ free-notregister))
+ (loop1 (cdr free)
+ (cons var free-notregister))))
+ (loop1 (cdr free)
+ (cons var free-notregister))))))
+ (define (loop2 i free)
+ (cond ((null? free)
+ (vector->list vec))
+ ((= i m)
+ (append (vector->list vec) free))
+ ((vector-ref vec i)
+ (loop2 (+ i 1) free))
+ (else
+ (vector-set! vec i (car free))
+ (loop2 (+ i 1) (cdr free)))))
+ (loop1 free '())))
+
+; Fetches the given list of free variables into the corresponding
+; registers in preparation for a $lambda or $lexes instruction.
+
+(define (cg-eval-vars output free regs frame env)
+ (let ((n (length free))
+ (R-1 (- *nregs* 1)))
+ (if (>= n R-1)
+ (begin (gen! output $const '())
+ (gen! output $setreg R-1)
+ (cgreg-release! regs R-1)))
+ (do ((r n (- r 1))
+ (vars (reverse free) (cdr vars)))
+ ((zero? r))
+ (let* ((v (car vars))
+ (entry (var-lookup v regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (let ((r1 (entry.regnum entry)))
+ (if (not (eqv? r r1))
+ (if (< r R-1)
+ (begin (gen! output $movereg r1 r)
+ (cgreg-bind! regs r v))
+ (gen! output $reg r1 v)))))
+ ((frame)
+ (if (< r R-1)
+ (begin (gen-load! output frame r v)
+ (cgreg-bind! regs r v))
+ (gen-stack! output frame v)))
+ ((lexical)
+ (gen! output $lexical
+ (entry.rib entry)
+ (entry.offset entry)
+ v)
+ (if (< r R-1)
+ (begin (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v))))
+ (else
+ (error "Bug in cg-close-lambda")))
+ (if (>= r R-1)
+ (begin (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1)))))))
+
+; Lambda expressions that appear on the rhs of a definition are
+; compiled here. They don't need an args= instruction at their head.
+;
+; Returns: nothing.
+
+(define (cg-known-lambda output exp env)
+ (let* ((vars (make-null-terminated (lambda.args exp)))
+ (regs (cgreg-initial))
+ (frame (cgframe-initial))
+ (t0 (newtemp)))
+ (if (member A-normal-form-declaration (lambda.decls exp))
+ (cgframe-livevars-set! frame '()))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (do ((r 1 (+ r 1))
+ (vars vars (cdr vars)))
+ ((or (null? vars)
+ (= r *lastreg*))
+ (if (not (null? vars))
+ (begin (gen! output $movereg *lastreg* 1)
+ (cgreg-release! regs 1)
+ (do ((vars vars (cdr vars)))
+ ((null? vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $car:pair)
+ (gen-setstk! output frame (car vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $cdr:pair)
+ (gen! output $setreg 1)))))
+ (cgreg-bind! regs r (car vars))
+ (gen-store! output frame r (car vars)))
+ (cg-body output
+ exp
+ 'result
+ regs
+ frame
+ env
+ #t)))
+
+; Compiles a let or lambda body.
+; The arguments of the lambda expression L are already in
+; registers or the stack frame, as specified by regs and frame.
+;
+; The problem here is that the free variables of an internal
+; definition must be in a heap-allocated environment, so any
+; such variables in registers must be copied to the heap.
+;
+; Returns: destination register.
+
+(define (cg-body output L target regs frame env tail?)
+ (let* ((exp (lambda.body L))
+ (defs (lambda.defs L))
+ (free (apply-union
+ (map (lambda (def)
+ (let ((L (def.rhs def)))
+ (difference (lambda.F L)
+ (lambda.args L))))
+ defs))))
+ (cond ((or (null? defs) (constant? exp) (variable? exp))
+ (cg0 output exp target regs frame env tail?))
+ ((lambda? exp)
+ (let* ((free (cg-sort-vars
+ (union free
+ (difference
+ (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ regs frame env))
+ (newenv1 (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv1)
+ (cg-defs newoutput defs newenv1)
+ (cg-eval-vars output free regs frame env)
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target))))
+ ((every? (lambda (def)
+ (every? (lambda (v)
+ (case (entry.kind
+ (var-lookup v regs frame env))
+ ((register frame) #f)
+ (else #t)))
+ (let ((Ldef (def.rhs def)))
+ (difference (lambda.F Ldef)
+ (lambda.args Ldef)))))
+ defs)
+ (let* ((newenv (cgenv-bindprocs env (map def.lhs defs)))
+ (L (make-label))
+ (r (cg0 output exp target regs frame newenv tail?)))
+ (if (not tail?)
+ (gen! output $skip L (cgreg-live regs r)))
+ (cg-defs output defs newenv)
+ (if (not tail?)
+ (gen! output $.label L))
+ r))
+ (else
+ (let ((free (cg-sort-vars free regs frame env)))
+ (cg-eval-vars output free regs frame env)
+ ; FIXME: Have to restore it too!
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this constant the right one?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (let ((t0 (cgreg-lookup-reg regs 0))
+ (t1 (newtemp))
+ (newenv (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (L (make-label)))
+ (gen! output $lexes (length free) free)
+ (gen! output $setreg 0)
+ (cgreg-bind! regs 0 t1)
+ (if tail?
+ (begin (cgframe-release! frame t0)
+ (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #t)
+ (cg-defs output defs newenv)
+ 'result)
+ (begin (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #f)
+ (gen! output $skip L (cgreg-tos regs))
+ (cg-defs output defs newenv)
+ (gen! output $.label L)
+ (gen-load! output frame 0 t0)
+ (cgreg-bind! regs 0 t0)
+ (cgframe-release! frame t1)
+ (cg-move output frame regs 'result target)))))))))
+
+(define (cg-defs output defs env)
+ (for-each (lambda (def)
+ (gen! output $.align 4)
+ (gen! output $.label
+ (entry.label
+ (cgenv-lookup env (def.lhs def))))
+ (gen! output $.proc)
+ (gen! output $.proc-doc (lambda.doc (def.rhs def)))
+ (cg-known-lambda output
+ (def.rhs def)
+ env))
+ defs))
+
+; The right hand side has already been evaluated into the result register.
+
+(define (cg-assignment-result output exp target regs frame env tail?)
+ (gen! output $setglbl (assignment.lhs exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+
+(define (cg-if output exp target regs frame env tail?)
+ ; The test can be a constant, because it is awkward
+ ; to remove constant tests from an A-normal form.
+ (if (constant? (if.test exp))
+ (cg0 output
+ (if (constant.value (if.test exp))
+ (if.then exp)
+ (if.else exp))
+ target regs frame env tail?)
+ (begin
+ (cg0 output (if.test exp) 'result regs frame env #f)
+ (cg-if-result output exp target regs frame env tail?))))
+
+; The test expression has already been evaluated into the result register.
+
+(define (cg-if-result output exp target regs frame env tail?)
+ (let ((L1 (make-label))
+ (L2 (make-label)))
+ (gen! output $branchf L1 (cgreg-tos regs))
+ (let* ((regs2 (cgreg-copy regs))
+ (frame1 (if (and tail?
+ (negative? (cgframe-size frame)))
+ (cgframe-initial)
+ frame))
+ (frame2 (if (eq? frame frame1)
+ (cgframe-copy frame1)
+ (cgframe-initial)))
+ (t0 (cgreg-lookup-reg regs 0)))
+ (if (not (eq? frame frame1))
+ (let ((live (cgframe-livevars frame)))
+ (cgframe-livevars-set! frame1 live)
+ (cgframe-livevars-set! frame2 live)
+ (gen-save! output frame1 t0)
+ (cg-saveregs output regs frame1)))
+ (let ((r (cg0 output (if.then exp) target regs frame1 env tail?)))
+ (if (not tail?)
+ (gen! output $skip L2 (cgreg-live regs r)))
+ (gen! output $.label L1)
+ (if (not (eq? frame frame1))
+ (begin (gen-save! output frame2 t0)
+ (cg-saveregs output regs2 frame2))
+ (cgframe-update-stale! frame2))
+ (cg0 output (if.else exp) r regs2 frame2 env tail?)
+ (if (not tail?)
+ (begin (gen! output $.label L2)
+ (cgreg-join! regs regs2)
+ (cgframe-join! frame1 frame2)))
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r)))))
+
+(define (cg-variable output exp target regs frame env tail?)
+ (define (return id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ (gen-store! output frame target id)
+ target)
+ 'result)))
+ ; Same as return, but doesn't emit a store instruction.
+ (define (return-nostore id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ target)
+ 'result)))
+ (let* ((id (variable.name exp))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (gen! output $global id)
+ (return (newtemp)))
+ ((lexical)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry)))
+ (gen! output $lexical m n id)
+ (if (or (zero? m)
+ (negative? (cgframe-size frame)))
+ (return-nostore id)
+ (return id))))
+ ((procedure) (error "Bug in cg-variable" exp))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (if (or tail?
+ (and target (not (eqv? target r))))
+ (begin (gen! output $reg (entry.regnum entry) id)
+ (return-nostore id))
+ r)))
+ ((frame)
+ (cond ((eq? target 'result)
+ (gen-stack! output frame id)
+ (return id))
+ (target
+ ; Must be non-tail.
+ (gen-load! output frame target id)
+ (cgreg-bind! regs target id)
+ target)
+ (else
+ ; Must be non-tail.
+ (let ((r (choose-register regs frame)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ r))))
+ (else (error "Bug in cg-variable" exp)))))
+
+(define (cg-sequential output exp target regs frame env tail?)
+ (cg-sequential-loop output (begin.exprs exp) target regs frame env tail?))
+
+(define (cg-sequential-loop output exprs target regs frame env tail?)
+ (cond ((null? exprs)
+ (gen! output $const unspecified)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((null? (cdr exprs))
+ (cg0 output (car exprs) target regs frame env tail?))
+ (else (cg0 output (car exprs) #f regs frame env #f)
+ (cg-sequential-loop output
+ (cdr exprs)
+ target regs frame env tail?))))
+
+(define (cg-saveregs output regs frame)
+ (do ((i 1 (+ i 1))
+ (vars (cdr (cgreg-vars regs)) (cdr vars)))
+ ((null? vars))
+ (let ((t (car vars)))
+ (if t
+ (gen-store! output frame i t)))))
+
+(define (cg-move output frame regs src dst)
+ (define (bind dst)
+ (let ((temp (newtemp)))
+ (cgreg-bind! regs dst temp)
+ (gen-store! output frame dst temp)
+ dst))
+ (cond ((not dst)
+ src)
+ ((eqv? src dst)
+ dst)
+ ((eq? dst 'result)
+ (gen! output $reg src)
+ dst)
+ ((eq? src 'result)
+ (gen! output $setreg dst)
+ (bind dst))
+ ((and (not (zero? src))
+ (not (zero? dst)))
+ (gen! output $movereg src dst)
+ (bind dst))
+ (else
+ (gen! output $reg src)
+ (gen! output $setreg dst)
+ (bind dst))))
+
+; On-the-fly register allocator.
+; Tries to allocate:
+; a hardware register that isn't being used
+; a hardware register whose contents have already been spilled
+; a software register that isn't being used, unless a stack
+; frame has already been created, in which case it is better to use
+; a hardware register that is in use and hasn't yet been spilled
+;
+; All else equal, it is better to allocate a higher-numbered register
+; because the lower-numbered registers are targets when arguments
+; are being evaluated.
+;
+; Invariant: Every register that is returned by this allocator
+; is either not in use or has been spilled.
+
+(define (choose-register regs frame)
+ (car (choose-registers regs frame 1)))
+
+(define (choose-registers regs frame n)
+
+ ; Find unused hardware registers.
+ (define (loop1 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (if (negative? (cgframe-size frame))
+ (hardcase)
+ (loop2 (- *nhwregs* 1) n good)))
+ (else
+ (if (cgreg-lookup-reg regs i)
+ (loop1 (- i 1) n good)
+ (loop1 (- i 1)
+ (- n 1)
+ (cons i good))))))
+
+ ; Find already spilled hardware registers.
+ (define (loop2 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (hardcase))
+ (else
+ (let ((t (cgreg-lookup-reg regs i)))
+ (if (and t (cgframe-spilled? frame t))
+ (loop2 (- i 1)
+ (- n 1)
+ (cons i good))
+ (loop2 (- i 1) n good))))))
+
+ ; This is ridiculous.
+ ; Fortunately the correctness of the compiler is independent
+ ; of the predicate used for this sort.
+
+ (define (hardcase)
+ (let* ((frame-exists? (not (negative? (cgframe-size frame))))
+ (stufftosort
+ (map (lambda (r)
+ (let* ((t (cgreg-lookup-reg regs r))
+ (spilled?
+ (and t
+ (cgframe-spilled? frame t))))
+ (list r t spilled?)))
+ (cdr (iota *nregs*))))
+ (registers
+ (twobit-sort
+ (lambda (x1 x2)
+ (let ((r1 (car x1))
+ (r2 (car x2))
+ (t1 (cadr x1))
+ (t2 (cadr x2)))
+ (cond ((< r1 *nhwregs*)
+ (cond ((not t1) #t)
+ ((< r2 *nhwregs*)
+ (cond ((not t2) #f)
+ ((caddr x1) #t)
+ ((caddr x2) #f)
+ (else #t)))
+ (frame-exists? #t)
+ (t2 #t)
+ (else #f)))
+ ((< r2 *nhwregs*)
+ (cond (frame-exists? #f)
+ (t1 #f)
+ (t2 #t)
+ (else #f)))
+ (t1
+ (if (and (caddr x1)
+ t2
+ (not (caddr x2)))
+ #t
+ #f))
+ (else #t))))
+ stufftosort)))
+ ; FIXME: What was this for?
+ '
+ (for-each (lambda (register)
+ (let ((t (cadr register))
+ (spilled? (caddr register)))
+ (if (and t (not spilled?))
+ (cgframe-touch! frame t))))
+ registers)
+ (do ((sorted (map car registers) (cdr sorted))
+ (rs '() (cons (car sorted) rs))
+ (n n (- n 1)))
+ ((zero? n)
+ (reverse rs)))))
+
+ (if (< n *nregs*)
+ (loop1 (- *nhwregs* 1) n '())
+ (error (string-append "Compiler bug: can't allocate "
+ (number->string n)
+ " registers on this target."))))
+; Copyright 1991 William Clinger
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 21 May 1999.
+
+; Procedure calls.
+
+(define (cg-call output exp target regs frame env tail?)
+ (let ((proc (call.proc exp)))
+ (cond ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ (cg-let output exp target regs frame env tail?))
+ ((not (variable? proc))
+ (cg-unknown-call output exp target regs frame env tail?))
+ (else (let ((entry
+ (var-lookup (variable.name proc) regs frame env)))
+ (case (entry.kind entry)
+ ((global lexical frame register)
+ (cg-unknown-call output
+ exp
+ target regs frame env tail?))
+ ((integrable)
+ (cg-integrable-call output
+ exp
+ target regs frame env tail?))
+ ((procedure)
+ (cg-known-call output
+ exp
+ target regs frame env tail?))
+ (else (error "Bug in cg-call" exp))))))))
+
+(define (cg-unknown-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (if (variable? proc)
+ (let ((entry (cgreg-lookup regs (variable.name proc))))
+ (if (and entry
+ (<= (entry.regnum entry) n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1)))
+ (begin (cg-arguments output
+ (iota1 n)
+ args
+ regs frame env)
+ (cg0 output proc 'result regs frame env #f)))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+(define (cg-known-call output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (cg-arguments output (iota1 n) args regs frame env)
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (let* ((entry (cgenv-lookup env (variable.name (call.proc exp))))
+ (label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+; Any call can be compiled as follows, even if there are no free registers.
+;
+; Let T0, T1, ..., Tn be newly allocated stack temporaries.
+;
+; <arg0>
+; setstk T0
+; <arg1> -|
+; setstk T1 |
+; ... |- evaluate args into stack frame
+; <argn> |
+; setstk Tn -|
+; const ()
+; setreg R-1
+; stack Tn -|
+; op2 cons,R-1 |
+; setreg R-1 |
+; ... |- cons up overflow args
+; stack T_{R-1} |
+; op2 cons,R-1 |
+; setreg R-1 -|
+; stack T_{R-2} -|
+; setreg R-2 |
+; ... |- pop remaining args into registers
+; stack T1 |
+; setreg 1 -|
+; stack T0
+; invoke n
+
+(define (cg-big-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (argslots (newtemps n))
+ (procslot (newtemp))
+ (r0 (cgreg-lookup-reg regs 0))
+ (R-1 (- *nregs* 1))
+ (entry (if (variable? proc)
+ (let ((entry
+ (var-lookup (variable.name proc)
+ regs frame env)))
+ (if (eq? (entry.kind entry) 'procedure)
+ entry
+ #f))
+ #f))
+ (L (make-label)))
+ (if (not entry)
+ (begin
+ (cg0 output proc 'result regs frame env #f)
+ (gen-setstk! output frame procslot)))
+ (for-each (lambda (arg argslot)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame argslot))
+ args
+ argslots)
+ (cgreg-clear! regs)
+ (gen! output $const '())
+ (gen! output $setreg R-1)
+ (do ((i n (- i 1))
+ (slots (reverse argslots) (cdr slots)))
+ ((zero? i))
+ (if (< i R-1)
+ (gen-load! output frame i (car slots))
+ (begin (gen-stack! output frame (car slots))
+ (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1))))
+ (if (not entry)
+ (gen-stack! output frame procslot))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (if entry
+ (let ((label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (gen! output $invoke n))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs) ; redundant, see above
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target)))))
+
+(define (cg-integrable-call output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op1 (entry.op entry)))
+ ((2) (cg-integrable-call2 output
+ entry
+ args
+ regs frame env))
+ ((3) (cg-integrable-call3 output
+ entry
+ args
+ regs frame env))
+ (else (error "Bug detected by cg-integrable-call"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-integrable-call2 output entry args regs frame env)
+ (let ((op (entry.op entry)))
+ (if (and (entry.imm entry)
+ (constant? (cadr args))
+ ((entry.imm entry) (constant.value (cadr args))))
+ (begin (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op2imm
+ op
+ (constant.value (cadr args))))
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (choose-register regs frame)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2))))
+ (gen! output $op2 (entry.op entry) r2)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))))))
+ 'result)
+
+(define (cg-integrable-call3 output entry args regs frame env)
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2)))
+ (reg3 (cg0 output (caddr args) #f regs frame env #f))
+ (spillregs (choose-registers regs frame 2))
+ (t3 (if (eq? reg3 'result)
+ (let ((t3 (newtemp))
+ (r3 (if (eq? t2 (cgreg-lookup-reg
+ regs (car spillregs)))
+ (cadr spillregs)
+ (car spillregs))))
+ (gen! output $setreg r3)
+ (cgreg-bind! regs r3 t3)
+ (gen-store! output frame r3 t3)
+ t3)
+ (cgreg-lookup-reg regs reg3))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((spillregs (choose-registers regs frame 2))
+ (r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (car spillregs)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2)))
+ (r3 (or (let ((entry (cgreg-lookup regs t3)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r3 (if (eq? r2 (car spillregs))
+ (cadr spillregs)
+ (car spillregs))))
+ (cgreg-bind! regs r3 t3)
+ (gen-load! output frame r3 t3)
+ r3))))
+ (gen! output $op3 (entry.op entry) r2 r3)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))
+ (if (eq? reg3 'result)
+ (begin (cgreg-release! regs r3)
+ (cgframe-release! frame t3)))))
+ 'result)
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+(define (cg-primop-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+
+
+; Parallel assignment.
+
+; Given a list of target registers, a list of expressions, and a
+; compile-time environment, generates code to evaluate the expressions
+; into the registers.
+;
+; Argument evaluation proceeds as follows:
+;
+; 1. Evaluate all but one of the complicated arguments.
+; 2. Evaluate remaining arguments.
+; 3. Load spilled arguments from stack.
+
+(define (cg-arguments output targets args regs frame env)
+
+ ; Sorts the args and their targets into complicated and
+ ; uncomplicated args and targets.
+ ; Then it calls evalargs.
+
+ (define (sortargs targets args targets1 args1 targets2 args2)
+ (if (null? args)
+ (evalargs targets1 args1 targets2 args2)
+ (let ((target (car targets))
+ (arg (car args))
+ (targets (cdr targets))
+ (args (cdr args)))
+ (if (complicated? arg env)
+ (sortargs targets
+ args
+ (cons target targets1)
+ (cons arg args1)
+ targets2
+ args2)
+ (sortargs targets
+ args
+ targets1
+ args1
+ (cons target targets2)
+ (cons arg args2))))))
+
+ ; Given the complicated args1 and their targets1,
+ ; and the uncomplicated args2 and their targets2,
+ ; evaluates all the arguments into their target registers.
+
+ (define (evalargs targets1 args1 targets2 args2)
+ (let* ((temps1 (newtemps (length targets1)))
+ (temps2 (newtemps (length targets2))))
+ (if (not (null? args1))
+ (for-each (lambda (arg temp)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame temp))
+ (cdr args1)
+ (cdr temps1)))
+ (if (not (null? args1))
+ (evalargs0 (cons (car targets1) targets2)
+ (cons (car args1) args2)
+ (cons (car temps1) temps2))
+ (evalargs0 targets2 args2 temps2))
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (let ((entry (var-lookup t regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (gen! output $movereg (entry.regnum entry) r))
+ ((frame)
+ (gen-load! output frame r t)))
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ (append targets1 targets2)
+ (append temps1 temps2))))
+
+ (define (evalargs0 targets args temps)
+ (if (not (null? targets))
+ (let ((para (let* ((regvars (map (lambda (reg)
+ (cgreg-lookup-reg regs reg))
+ targets)))
+ (parallel-assignment targets
+ (map cons regvars targets)
+ args))))
+ (if para
+ (let ((targets para)
+ (args (cg-permute args targets para))
+ (temps (cg-permute temps targets para)))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ para
+ temps))
+ (let ((r (choose-register regs frame))
+ (t (car temps)))
+ (cg0 output (car args) r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (evalargs0 (cdr targets)
+ (cdr args)
+ (cdr temps)))))))
+
+ (if (parallel-assignment-optimization)
+ (sortargs (reverse targets) (reverse args) '() '() '() '())
+ (cg-evalargs output targets args regs frame env)))
+
+; Left-to-right evaluation of arguments directly into targets.
+
+(define (cg-evalargs output targets args regs frame env)
+ (let ((temps (newtemps (length targets))))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ targets
+ temps)
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ targets
+ temps)))
+
+; For heuristic use only.
+; An expression is complicated unless it can probably be evaluated
+; without saving and restoring any registers, even if it occurs in
+; a non-tail position.
+
+(define (complicated? exp env)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #t)
+ ((set!) (complicated? (assignment.rhs exp) env))
+ ((if) (or (complicated? (if.test exp) env)
+ (complicated? (if.then exp) env)
+ (complicated? (if.else exp) env)))
+ ((begin) (if (variable? exp)
+ #f
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (let ((entry
+ (cgenv-lookup env (variable.name proc))))
+ (eq? (entry.kind entry) 'integrable)))
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (call.args exp))
+ #t)))))
+
+; Returns a permutation of the src list, permuted the same way the
+; key list was permuted to obtain newkey.
+
+(define (cg-permute src key newkey)
+ (let ((alist (map cons key (iota (length key)))))
+ (do ((newkey newkey (cdr newkey))
+ (dest '()
+ (cons (list-ref src (cdr (assq (car newkey) alist)))
+ dest)))
+ ((null? newkey) (reverse dest)))))
+
+; Given a list of register numbers,
+; an association list with entries of the form (name . regnum) giving
+; the variable names by which those registers are known in code,
+; and a list of expressions giving new values for those registers,
+; returns an ordering of the register assignments that implements a
+; parallel assignment if one can be found, otherwise returns #f.
+
+(define parallel-assignment
+ (lambda (regnums alist exps)
+ (if (null? regnums)
+ #t
+ (let ((x (toposort (dependency-graph regnums alist exps))))
+ (if x (reverse x) #f)))))
+
+(define dependency-graph
+ (lambda (regnums alist exps)
+ (let ((names (map car alist)))
+ (do ((regnums regnums (cdr regnums))
+ (exps exps (cdr exps))
+ (l '() (cons (cons (car regnums)
+ (map (lambda (var) (cdr (assq var alist)))
+ (intersection (freevariables (car exps))
+ names)))
+ l)))
+ ((null? regnums) l)))))
+
+; Given a nonempty graph represented as a list of the form
+; ((node1 . <list of nodes that node1 is less than or equal to>)
+; (node2 . <list of nodes that node2 is less than or equal to>)
+; ...)
+; returns a topological sort of the nodes if one can be found,
+; otherwise returns #f.
+
+(define toposort
+ (lambda (graph)
+ (cond ((null? (cdr graph)) (list (caar graph)))
+ (else (toposort2 graph '())))))
+
+(define toposort2
+ (lambda (totry tried)
+ (cond ((null? totry) #f)
+ ((or (null? (cdr (car totry)))
+ (and (null? (cddr (car totry)))
+ (eq? (cadr (car totry))
+ (car (car totry)))))
+ (if (and (null? (cdr totry)) (null? tried))
+ (list (caar totry))
+ (let* ((node (caar totry))
+ (x (toposort2 (map (lambda (y)
+ (cons (car y) (remove node (cdr y))))
+ (append (cdr totry) tried))
+ '())))
+ (if x
+ (cons node x)
+ #f))))
+ (else (toposort2 (cdr totry) (cons (car totry) tried))))))
+
+(define iota (lambda (n) (iota2 n '())))
+
+(define iota1 (lambda (n) (cdr (iota2 (+ n 1) '()))))
+
+(define iota2
+ (lambda (n l)
+ (if (zero? n)
+ l
+ (let ((n (- n 1)))
+ (iota2 n (cons n l))))))
+
+(define (freevariables exp)
+ (freevars2 exp '()))
+
+(define (freevars2 exp env)
+ (cond ((symbol? exp)
+ (if (memq exp env) '() (list exp)))
+ ((not (pair? exp)) '())
+ (else (let ((keyword (car exp)))
+ (cond ((eq? keyword 'quote) '())
+ ((eq? keyword 'lambda)
+ (let ((env (append (make-null-terminated (cadr exp))
+ env)))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cddr exp)))))
+ ((memq keyword '(if set! begin))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cdr exp))))
+ (else (apply-union
+ (map (lambda (x) (freevars2 x env))
+ exp))))))))
+; Copyright 1991 William Clinger (cg-let and cg-let-body)
+; Copyright 1999 William Clinger (everything else)
+;
+; 10 June 1999.
+
+; Generates code for a let expression.
+
+(define (cg-let output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc))
+ (n (length vars))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame)))
+ (if (and (null? (lambda.defs proc))
+ (= n 1))
+ (cg-let1 output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (temps (newtemps n))
+ (alist (map cons temps vars)))
+ (for-each (lambda (arg t)
+ (let ((r (choose-register regs frame)))
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)))
+ args
+ temps)
+ (cgreg-rename! regs alist)
+ (cgframe-rename! frame alist)
+ (cg-let-release! free live regs frame tail?)
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given the free variables of a let body, and the variables that are
+; live after the let expression, and the usual regs, frame, and tail?
+; arguments, releases any registers and frame slots that don't need
+; to be preserved across the body of the let.
+
+(define (cg-let-release! free live regs frame tail?)
+ ; The tail case is easy because there are no live temporaries,
+ ; and there are no free variables in the context.
+ ; The non-tail case assumes A-normal form.
+ (cond (tail?
+ (let ((keepers (cons (cgreg-lookup-reg regs 0) free)))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))
+ (live
+ (let ((keepers (cons (cgreg-lookup-reg regs 0)
+ (union live free))))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))))
+
+; Generates code for the body of a let.
+
+(define (cg-let-body output L target regs frame env tail?)
+ (let ((vars (lambda.args L))
+ (free (lambda.F L))
+ (live (cgframe-livevars frame)))
+ (let ((r (cg-body output L target regs frame env tail?)))
+ (for-each (lambda (v)
+ (let ((entry (cgreg-lookup regs v)))
+ (if entry
+ (cgreg-release! regs (entry.regnum entry)))
+ (cgframe-release! frame v)))
+ vars)
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r))))
+
+; Generates code for a let expression that binds exactly one variable
+; and has no internal definitions. These let expressions are very
+; common in A-normal form, and there are many special cases with
+; respect to register allocation and order of evaluation.
+
+(define (cg-let1 output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (arg (car (call.args exp)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc)))
+
+ (define (evaluate-into-register r)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ (define (finish)
+ (release-registers!)
+ (cg-let-body output proc target regs frame env tail?))
+
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+
+ (cond ((assq v *regnames*)
+ (evaluate-into-register (cdr (assq v *regnames*)))
+ (finish))
+ ((not (memq v free))
+ (cg0 output arg #f regs frame env #f)
+ (finish))
+ (live
+ (cg0 output arg 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output exp target regs frame env tail?))
+ (else
+ (evaluate-into-register (choose-register regs frame))
+ (finish)))))
+
+; Given a let expression that binds one variable whose value has already
+; been evaluated into the result register, generates code for the rest
+; of the let expression.
+; The main difficulty is an unfortunate interaction between A-normal
+; form and the MacScheme machine architecture: We don't want to move
+; a value from the result register into a general register if it has
+; only one use and can remain in the result register until that use.
+
+(define (cg-let1-result output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc))
+ (pattern (cg-let-used-once v body)))
+
+ (define (move-to-register r)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ ; FIXME: The live variables must be correct in the frame.
+
+ (case pattern
+ ((if)
+ (cg-if-result output body target regs frame env tail?))
+ ((let-if)
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+ (cg-if-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output body target regs frame env tail?))
+ ((set!)
+ (cg-assignment-result output
+ body target regs frame env tail?))
+ ((let-set!)
+ (cg-assignment-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ((primop)
+ (cg-primop-result output body target regs frame env tail?))
+ ((let-primop)
+ (cg-primop-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ; FIXME
+ ((_called)
+ (cg-call-result output body target regs frame env tail?))
+ ; FIXME
+ ((_let-called)
+ (cg-call-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ (else
+ ; FIXME: The first case was handled by cg-let1.
+ (cond ((assq v *regnames*)
+ (move-to-register (cdr (assq v *regnames*))))
+ ((memq v free)
+ (move-to-register (choose-register regs frame))))
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given a call to a primop whose first argument has already been
+; evaluated into the result register and whose remaining arguments
+; consist of constants and variable references, generates code for
+; the call.
+
+(define (cg-primop-result output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (gen! output $op1 (entry.op entry)))
+ ((2) (cg-primop2-result! output entry args regs frame env))
+ ((3) (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output
+ $op3 (entry.op entry) (car rs) (cadr rs))))
+ (else (error "Bug detected by cg-primop-result"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special-result output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-primop2-result! output entry args regs frame env)
+ (let ((op (entry.op entry))
+ (arg2 (cadr args)))
+ (if (and (constant? arg2)
+ (entry.imm entry)
+ ((entry.imm entry) (constant.value arg2)))
+ (gen! output $op2imm op (constant.value arg2))
+ (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output $op2 op (car rs))))))
+
+; Given a short list of constants and variable references to be evaluated
+; into arbitrary general registers, evaluates them into registers without
+; disturbing the result register and returns a list of the registers into
+; which they are evaluated. Before returning, any registers that were
+; allocated by this routine are released.
+
+(define (cg-result-args output args regs frame env)
+
+ ; Given a list of unevaluated arguments,
+ ; a longer list of disjoint general registers,
+ ; the register that holds the first evaluated argument,
+ ; a list of registers in reverse order that hold other arguments,
+ ; and a list of registers to be released afterwards,
+ ; generates code to evaluate the arguments,
+ ; deallocates any registers that were evaluated to hold the arguments,
+ ; and returns the list of registers that contain the arguments.
+
+ (define (loop args registers rr rs temps)
+ (if (null? args)
+ (begin (if (not (eq? rr 'result))
+ (gen! output $reg rr))
+ (for-each (lambda (r) (cgreg-release! regs r))
+ temps)
+ (reverse rs))
+ (let ((arg (car args)))
+ (cond ((constant? arg)
+ (let ((r (car registers)))
+ (gen! output $const/setreg (constant.value arg) r)
+ (cgreg-bind! regs r #t)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ ((variable? arg)
+ (let* ((id (variable.name arg))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $global id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((lexical)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry))
+ (r (car registers)))
+ (gen! output $lexical m n id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((procedure) (error "Bug in cg-variable" arg))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (loop (cdr args)
+ registers
+ rr
+ (cons r rs)
+ temps)))
+ ((frame)
+ (let ((r (car registers)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ (else (error "Bug in cg-result-args" arg)))))
+ (else
+ (error "Bug in cg-result-args"))))))
+
+ (define (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $setreg r)
+ (loop args
+ (cdr registers)
+ r
+ rs
+ temps)))
+
+ (loop (cdr args)
+ (choose-registers regs frame (length args))
+ 'result '() '()))
+
+; Given a local variable T1 and an expression in A-normal form,
+; cg-let-used-once returns a symbol if the local variable is used
+; exactly once in the expression and the expression matches one of
+; the patterns below. Otherwise returns #f. The symbol that is
+; returned is the name of the pattern that is matched.
+;
+; pattern symbol returned
+;
+; (if T1 ... ...) if
+;
+; (<primop> T1 ...) primop
+;
+; (T1 ...) called
+;
+; (set! ... T1) set!
+;
+; (let ((T2 (if T1 ... ...))) let-if
+; E3)
+;
+; (let ((T2 (<primop> T1 ...))) let-primop
+; E3)
+;
+; (let ((T2 (T1 ...))) let-called
+; E3)
+;
+; (let ((T2 (set! ... T1))) let-set!
+; E3)
+;
+; This implementation sometimes returns #f incorrectly, but it always
+; returns an answer in constant time (assuming A-normal form).
+
+(define (cg-let-used-once T1 exp)
+ (define budget 20)
+ (define (cg-let-used-once T1 exp)
+ (define (used? T1 exp)
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #t)
+ ((constant? exp) #f)
+ ((variable? exp)
+ (eq? T1 (variable.name exp)))
+ ((lambda? exp)
+ (memq T1 (lambda.F exp)))
+ ((assignment? exp)
+ (used? T1 (assignment.rhs exp)))
+ ((call? exp)
+ (or (used? T1 (call.proc exp))
+ (used-in-args? T1 (call.args exp))))
+ ((conditional? exp)
+ (or (used? T1 (if.test exp))
+ (used? T1 (if.then exp))
+ (used? T1 (if.else exp))))
+ (else #t)))
+ (define (used-in-args? T1 args)
+ (if (null? args)
+ #f
+ (or (used? T1 (car args))
+ (used-in-args? T1 (cdr args)))))
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #f)
+ ((call? exp)
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((variable? proc)
+ (let ((f (variable.name proc)))
+ (cond ((eq? f T1)
+ (and (not (used-in-args? T1 args))
+ 'called))
+ ((and (integrable? f)
+ (not (null? args))
+ (variable? (car args))
+ (eq? T1 (variable.name (car args))))
+ (and (not (used-in-args? T1 (cdr args)))
+ 'primop))
+ (else #f))))
+ ((lambda? proc)
+ (and (not (memq T1 (lambda.F proc)))
+ (not (null? args))
+ (null? (cdr args))
+ (case (cg-let-used-once T1 (car args))
+ ((if) 'let-if)
+ ((primop) 'let-primop)
+ ((called) 'let-called)
+ ((set!) 'let-set!)
+ (else #f))))
+ (else #f))))
+ ((conditional? exp)
+ (let ((E0 (if.test exp)))
+ (and (variable? E0)
+ (eq? T1 (variable.name E0))
+ (not (used? T1 (if.then exp)))
+ (not (used? T1 (if.else exp)))
+ 'if)))
+ ((assignment? exp)
+ (let ((rhs (assignment.rhs exp)))
+ (and (variable? rhs)
+ (eq? T1 (variable.name rhs))
+ 'set!)))
+ (else #f)))
+ (cg-let-used-once T1 exp))
+
+; Given the name of a let-body pattern, an expression that matches that
+; pattern, and an expression to be substituted for the let variable,
+; returns the transformed expression.
+
+; FIXME: No longer used.
+
+(define (cg-let-transform pattern exp E1)
+ (case pattern
+ ((if)
+ (make-conditional E1 (if.then exp) (if.else exp)))
+ ((primop)
+ (make-call (call.proc exp)
+ (cons E1 (cdr (call.args exp)))))
+ ((called)
+ (make-call E1 (call.args exp)))
+ ((set!)
+ (make-assignment (assignment.lhs exp) E1))
+ ((let-if let-primop let-called let-set!)
+ (make-call (call.proc exp)
+ (list (cg-let-transform (case pattern
+ ((let-if) 'if)
+ ((let-primop) 'primop)
+ ((let-called) 'called)
+ ((let-set!) 'set!))
+ (car (call.args exp))
+ E1))))
+ (else
+ (error "Unrecognized pattern in cg-let-transform" pattern)))); Copyright 1999 William Clinger
+;
+; Code for special primitives, used to generate runtime safety checks,
+; efficient code for call-with-values, and other weird things.
+;
+; 4 June 1999.
+
+(define (cg-special output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-special-result output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check-result output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-check output exp target regs frame env tail?)
+ (cg0 output (car (call.args exp)) 'result regs frame env #f)
+ (cg-check-result output exp target regs frame env tail?))
+
+(define (cg-check-result output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (nargs (length args))
+ (valexps (cddr args)))
+ (if (and (<= 2 nargs 5)
+ (constant? (cadr args))
+ (every? (lambda (exp)
+ (or (constant? exp)
+ (variable? exp)))
+ valexps))
+ (let* ((exn (constant.value (cadr args)))
+ (vars (filter variable? valexps))
+ (rs (cg-result-args output
+ (cons (car args) vars)
+ regs frame env)))
+
+ ; Construct the trap situation:
+ ; the exception number followed by an ordered list of
+ ; register numbers and constant expressions.
+
+ (let loop ((registers rs)
+ (exps valexps)
+ (operands '()))
+ (cond ((null? exps)
+ (let* ((situation (cons exn (reverse operands)))
+ (ht (assembly-stream-info output))
+ (L1 (or (hashtable-get ht situation)
+ (let ((L1 (make-label)))
+ (hashtable-put! ht situation L1)
+ L1))))
+ (define (translate r)
+ (if (number? r) r 0))
+ (case (length operands)
+ ((0) (gen! output $check 0 0 0 L1))
+ ((1) (gen! output $check
+ (translate (car operands))
+ 0 0 L1))
+ ((2) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ 0 L1))
+ ((3) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ (translate (caddr operands))
+ L1)))))
+ ((constant? (car exps))
+ (loop registers
+ (cdr exps)
+ (cons (car exps) operands)))
+ (else
+ (loop (cdr registers)
+ (cdr exps)
+ (cons (car registers) operands))))))
+ (error "Compiler bug: runtime check" (make-readable exp)))))
+
+; Given an assembly stream and the description of a trap as recorded
+; by cg-check above, generates a non-continuable trap at that label for
+; that trap, passing the operands to the exception handler.
+
+(define (cg-trap output situation L1)
+ (let* ((exn (car situation))
+ (operands (cdr situation)))
+ (gen! output $.label L1)
+ (let ((liveregs (filter number? operands)))
+ (define (loop operands registers r)
+ (cond ((null? operands)
+ (case (length registers)
+ ((0) (gen! output $trap 0 0 0 exn))
+ ((1) (gen! output $trap (car registers) 0 0 exn))
+ ((2) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ 0
+ exn))
+ ((3) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ (caddr registers)
+ exn))
+ (else "Compiler bug: trap")))
+ ((number? (car operands))
+ (loop (cdr operands)
+ (cons (car operands) registers)
+ r))
+ ((memv r liveregs)
+ (loop operands registers (+ r 1)))
+ (else
+ (gen! output $const (constant.value (car operands)))
+ (gen! output $setreg r)
+ (loop (cdr operands)
+ (cons r registers)
+ (+ r 1)))))
+ (loop (reverse operands) '() 1))))
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+; FIXME: No longer used.
+
+(define (cg-check-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 5 June 1999.
+;
+; Local optimizations for MacScheme machine assembly code.
+;
+; Branch tensioning.
+; Suppress nop instructions.
+; Suppress save, restore, and pop instructions whose operand is -1.
+; Suppress redundant stores.
+; Suppress definitions (primarily loads) of dead registers.
+;
+; Note: Twobit never generates a locally redundant load or store,
+; so this code must be tested with a different code generator.
+;
+; To perform these optimizations, the basic block must be traversed
+; both forwards and backwards.
+; The forward traversal keeps track of registers that were defined
+; by a load.
+; The backward traversal keeps track of live registers.
+
+(define filter-basic-blocks
+
+ (let* ((suppression-message
+ "Local optimization detected a useless instruction.")
+
+ ; Each instruction is mapping to an encoding of the actions
+ ; to be performed when it is encountered during the forward
+ ; or backward traversal.
+
+ (forward:normal 0)
+ (forward:nop 1)
+ (forward:ends-block 2)
+ (forward:interesting 3)
+ (forward:kills-all-registers 4)
+ (forward:nop-if-arg1-is-negative 5)
+
+ (backward:normal 0)
+ (backward:ends-block 1)
+ (backward:begins-block 2)
+ (backward:uses-arg1 4)
+ (backward:uses-arg2 8)
+ (backward:uses-arg3 16)
+ (backward:kills-arg1 32)
+ (backward:kills-arg2 64)
+ (backward:uses-many 128)
+
+ ; largest mnemonic + 1
+
+ (dispatch-table-size *number-of-mnemonics*)
+
+ ; Dispatch table for the forwards traversal.
+
+ (forward-table (make-bytevector dispatch-table-size))
+
+ ; Dispatch table for the backwards traversal.
+
+ (backward-table (make-bytevector dispatch-table-size)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i dispatch-table-size))
+ (bytevector-set! forward-table i forward:normal)
+ (bytevector-set! backward-table i backward:normal))
+
+ (bytevector-set! forward-table $nop forward:nop)
+
+ (bytevector-set! forward-table $invoke forward:ends-block)
+ (bytevector-set! forward-table $return forward:ends-block)
+ (bytevector-set! forward-table $skip forward:ends-block)
+ (bytevector-set! forward-table $branch forward:ends-block)
+ (bytevector-set! forward-table $branchf forward:ends-block)
+ (bytevector-set! forward-table $jump forward:ends-block)
+ (bytevector-set! forward-table $.align forward:ends-block)
+ (bytevector-set! forward-table $.proc forward:ends-block)
+ (bytevector-set! forward-table $.cont forward:ends-block)
+ (bytevector-set! forward-table $.label forward:ends-block)
+
+ (bytevector-set! forward-table $store forward:interesting)
+ (bytevector-set! forward-table $load forward:interesting)
+ (bytevector-set! forward-table $setstk forward:interesting)
+ (bytevector-set! forward-table $setreg forward:interesting)
+ (bytevector-set! forward-table $movereg forward:interesting)
+ (bytevector-set! forward-table $const/setreg
+ forward:interesting)
+
+ (bytevector-set! forward-table $args>= forward:kills-all-registers)
+ (bytevector-set! forward-table $popstk forward:kills-all-registers)
+
+ ; These instructions also kill all registers.
+
+ (bytevector-set! forward-table $save forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $restore forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $pop forward:nop-if-arg1-is-negative)
+
+ (bytevector-set! backward-table $invoke backward:ends-block)
+ (bytevector-set! backward-table $return backward:ends-block)
+ (bytevector-set! backward-table $skip backward:ends-block)
+ (bytevector-set! backward-table $branch backward:ends-block)
+ (bytevector-set! backward-table $branchf backward:ends-block)
+
+ (bytevector-set! backward-table $jump backward:begins-block) ; [sic]
+ (bytevector-set! backward-table $.align backward:begins-block)
+ (bytevector-set! backward-table $.proc backward:begins-block)
+ (bytevector-set! backward-table $.cont backward:begins-block)
+ (bytevector-set! backward-table $.label backward:begins-block)
+
+ (bytevector-set! backward-table $op2 backward:uses-arg2)
+ (bytevector-set! backward-table $op3 (logior backward:uses-arg2
+ backward:uses-arg3))
+ (bytevector-set! backward-table $check (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $trap (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $store backward:uses-arg1)
+ (bytevector-set! backward-table $reg backward:uses-arg1)
+ (bytevector-set! backward-table $load backward:kills-arg1)
+ (bytevector-set! backward-table $setreg backward:kills-arg1)
+ (bytevector-set! backward-table $movereg (logior backward:uses-arg1
+ backward:kills-arg2))
+ (bytevector-set! backward-table $const/setreg
+ backward:kills-arg2)
+ (bytevector-set! backward-table $lambda backward:uses-many)
+ (bytevector-set! backward-table $lexes backward:uses-many)
+ (bytevector-set! backward-table $args>= backward:uses-many)
+
+ (lambda (instructions)
+
+ (let* ((*nregs* *nregs*) ; locals might be faster than globals
+
+ ; During the forwards traversal:
+ ; (vector-ref registers i) = #f
+ ; means the content of register i is unknown
+ ; (vector-ref registers i) = j
+ ; means register was defined by load i,j
+ ;
+ ; During the backwards traversal:
+ ; (vector-ref registers i) = #f means register i is dead
+ ; (vector-ref registers i) = #t means register i is live
+
+ (registers (make-vector *nregs* #f))
+
+ ; During the forwards traversal, the label of a block that
+ ; falls through into another block or consists of a skip
+ ; to another block is mapped to another label.
+ ; This mapping is implemented by a hash table.
+ ; Before the backwards traversal, the transitive closure
+ ; is computed. The graph has no cycles, and the maximum
+ ; out-degree is 1, so this is easy.
+
+ (label-table (make-hashtable (lambda (n) n) assv)))
+
+ (define (compute-transitive-closure!)
+ (define (lookup x)
+ (let ((y (hashtable-get label-table x)))
+ (if y
+ (lookup y)
+ x)))
+ (hashtable-for-each (lambda (x y)
+ (hashtable-put! label-table x (lookup y)))
+ label-table))
+
+ ; Don't use this procedure until the preceding procedure
+ ; has been called.
+
+ (define (lookup-label x)
+ (hashtable-fetch label-table x x))
+
+ (define (vector-fill! v x)
+ (subvector-fill! v 0 (vector-length v) x))
+
+ (define (subvector-fill! v i j x)
+ (if (< i j)
+ (begin (vector-set! v i x)
+ (subvector-fill! v (+ i 1) j x))))
+
+ (define (kill-stack! j)
+ (do ((i 0 (+ i 1)))
+ ((= i *nregs*))
+ (let ((x (vector-ref registers i)))
+ (if (and x (= x j))
+ (vector-set! registers i #f)))))
+
+ ; Dispatch procedure for the forwards traversal.
+
+ (define (forwards instructions filtered)
+ (if (null? instructions)
+ (begin (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (compute-transitive-closure!)
+ (backwards0 filtered '()))
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:normal)
+ (forwards instructions (cons instruction filtered)))
+ ((eqv? flags forward:nop)
+ (forwards instructions filtered))
+ ((eqv? flags forward:nop-if-arg1-is-negative)
+ (if (negative? (instruction.arg1 instruction))
+ (forwards instructions filtered)
+ (begin (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))))
+ ((eqv? flags forward:kills-all-registers)
+ (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? flags forward:ends-block)
+ (vector-fill! registers #f)
+ (if (eqv? op $.label)
+ (forwards-label instruction
+ instructions
+ filtered)
+ (forwards instructions
+ (cons instruction filtered))))
+ ((eqv? flags forward:interesting)
+ (cond ((eqv? op $setreg)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $const/setreg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $movereg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $setstk)
+ (kill-stack! (instruction.arg1 instruction))
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $load)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant load.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (vector-set! registers i j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ ((eqv? op $store)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant store.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (kill-stack! j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ (else
+ (local-optimization-error op))))
+ (else
+ (local-optimization-error op))))))
+
+ ; Enters labels into a table for branch tensioning.
+
+ (define (forwards-label instruction1 instructions filtered)
+ (let ((label1 (instruction.arg1 instruction1)))
+ (if (null? instructions)
+ ; This is ok provided the label is unreachable.
+ (forwards instructions (cdr filtered))
+ (let loop ((instructions instructions)
+ (filtered (cons instruction1 filtered)))
+ (let* ((instruction (car instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:nop)
+ (loop (cdr instructions) filtered))
+ ((and (eqv? flags forward:nop-if-arg1-is-negative)
+ (negative? (instruction.arg1 instruction)))
+ (loop (cdr instructions) filtered))
+ ((eqv? op $.label)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ (forwards-label instruction
+ (cdr instructions)
+ (cdr filtered))))
+ ((eqv? op $skip)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ ; We can't get rid of the skip instruction
+ ; because control might fall into this block,
+ ; but we can get rid of the label.
+ (forwards instructions (cdr filtered))))
+ (else
+ (forwards instructions filtered))))))))
+
+ ; Dispatch procedure for the backwards traversal.
+
+ (define (backwards instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref backward-table op)))
+ (cond ((eqv? flags backward:normal)
+ (backwards instructions (cons instruction filtered)))
+ ((eqv? flags backward:ends-block)
+ (backwards0 (cons instruction instructions)
+ filtered))
+ ((eqv? flags backward:begins-block)
+ (backwards0 instructions
+ (cons instruction filtered)))
+ ((eqv? flags backward:uses-many)
+ (cond ((or (eqv? op $lambda)
+ (eqv? op $lexes))
+ (let ((live
+ (if (eqv? op $lexes)
+ (instruction.arg1 instruction)
+ (instruction.arg2 instruction))))
+ (subvector-fill! registers
+ 0
+ (min *nregs* (+ 1 live))
+ #t)
+ (backwards instructions
+ (cons instruction filtered))))
+ ((eqv? op $args>=)
+ (vector-fill! registers #t)
+ (backwards instructions
+ (cons instruction filtered)))
+ (else
+ (local-optimization-error op))))
+ ((and (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (not (vector-ref registers
+ (instruction.arg1 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (not (vector-ref registers
+ (instruction.arg2 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? op $movereg)
+ (= (instruction.arg1 instruction)
+ (instruction.arg2 instruction)))
+ (backwards instructions filtered))
+ (else
+ (let ((filtered (cons instruction filtered)))
+ (if (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f))
+ (if (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f))
+ (if (eqv? (logand flags backward:uses-arg1)
+ backward:uses-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg2)
+ backward:uses-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg3)
+ backward:uses-arg3)
+ (vector-set! registers
+ (instruction.arg3 instruction)
+ #t))
+ (backwards instructions filtered)))))))
+
+ ; Given a list of instructions in reverse order, whose first
+ ; element is the last instruction of a basic block,
+ ; and a filtered list of instructions in forward order,
+ ; returns a filtered list of instructions in the correct order.
+
+ (define (backwards0 instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (mnemonic (instruction.op instruction)))
+ (cond ((or (eqv? mnemonic $.label)
+ (eqv? mnemonic $.proc)
+ (eqv? mnemonic $.cont)
+ (eqv? mnemonic $.align))
+ (backwards0 (cdr instructions)
+ (cons instruction filtered)))
+ ; all registers are dead at a $return
+ ((eqv? mnemonic $return)
+ (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (backwards (cdr instructions)
+ (cons instruction filtered)))
+ ; all but the argument registers are dead at an $invoke
+ ((eqv? mnemonic $invoke)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg1 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the compiler says which registers are live at the
+ ; target of $skip, $branch, $branchf, or $jump
+ ((or (eqv? mnemonic $skip)
+ (eqv? mnemonic $branch))
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ ((eqv? mnemonic $jump)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg3 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the live registers at the target of a $branchf must be
+ ; combined with the live registers at the $branchf
+ ((eqv? mnemonic $branchf)
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ (else (backwards instructions filtered))))))
+
+ (define (suppress-forwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (forwards instructions filtered))
+
+ (define (suppress-backwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (backwards instructions filtered))
+
+ (define (local-optimization-error op)
+ (error "Compiler bug: local optimization" op))
+
+ (vector-fill! registers #f)
+ (forwards instructions '())))))
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; 28 April 1999
+;
+; compile313 -- compilation parameters and driver procedures.
+
+
+; File types -- these may differ between operating systems.
+
+(define *scheme-file-types* '(".sch" ".scm"))
+(define *lap-file-type* ".lap")
+(define *mal-file-type* ".mal")
+(define *lop-file-type* ".lop")
+(define *fasl-file-type* ".fasl")
+
+; Compile and assemble a scheme source file and produce a fastload file.
+
+(define (compile-file infilename . rest)
+
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *fasl-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (and (not (integrate-usual-procedures))
+ (issue-warnings))
+ (begin
+ (display "WARNING from compiler: ")
+ (display "integrate-usual-procedures is turned off")
+ (newline)
+ (display "Performance is likely to be poor.")
+ (newline)))
+ (if (benchmark-block-mode)
+ (process-file-block infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (forms)
+ (assemble (compile-block forms) user)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (expr)
+ (assemble (compile expr) user))))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Compile-file not supported on this target architecture.")
+ (doit)))
+
+
+; Assemble a MAL or LOP file and produce a FASL file.
+
+(define (assemble-file infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ (list *lap-file-type* *mal-file-type*)
+ *fasl-file-type*)))
+ (malfile?
+ (file-type=? infilename *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Assemble-file not supported on this target architecture.")
+ (doit)))
+
+
+; Compile and assemble a single expression; return the LOP segment.
+
+(define compile-expression
+ (let ()
+
+ (define (compile-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (assemble (compile expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ compile-expression))
+
+
+(define macro-expand-expression
+ (let ()
+
+ (define (macro-expand-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (make-readable
+ (macro-expand expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ macro-expand-expression))
+
+
+; Compile a scheme source file to a LAP file.
+
+(define (compile313 infilename . rest)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *lap-file-type*)))
+ (write-lap
+ (lambda (item port)
+ (write item port)
+ (newline port)
+ (newline port))))
+ (if (benchmark-block-mode)
+ (process-file-block infilename outfilename write-lap compile-block)
+ (process-file infilename outfilename write-lap compile))
+ (unspecified)))
+
+
+; Assemble a LAP or MAL file to a LOP file.
+
+(define (assemble313 file . rest)
+ (let ((outputfile
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type file
+ (list *lap-file-type* *mal-file-type*)
+ *lop-file-type*)))
+ (malfile?
+ (file-type=? file *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file file
+ outputfile
+ write-lop
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+
+; Compile and assemble a Scheme source file to a LOP file.
+
+(define (compile-and-assemble313 input-file . rest)
+ (let ((output-file
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type input-file
+ *scheme-file-types*
+ *lop-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (benchmark-block-mode)
+ (process-file-block input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile-block x) user)))
+ (process-file input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile x) user))))
+ (unspecified)))
+
+
+; Convert a LOP file to a FASL file.
+
+(define (make-fasl infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *lop-file-type*
+ *fasl-file-type*))))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) x))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Make-fasl not supported on this target architecture.")
+ (doit)))
+
+
+; Disassemble a procedure's code vector.
+
+(define (disassemble item . rest)
+ (let ((output-port (if (null? rest)
+ (current-output-port)
+ (car rest))))
+ (disassemble-item item #f output-port)
+ (unspecified)))
+
+
+; The item can be either a procedure or a pair (assumed to be a segment).
+
+(define (disassemble-item item segment-no port)
+
+ (define (print . rest)
+ (for-each (lambda (x) (display x port)) rest)
+ (newline port))
+
+ (define (print-constvector cv)
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length cv)))
+ (print "------------------------------------------")
+ (print "Constant vector element # " i)
+ (case (car (vector-ref cv i))
+ ((codevector)
+ (print "Code vector")
+ (print-instructions (disassemble-codevector
+ (cadr (vector-ref cv i)))
+ port))
+ ((constantvector)
+ (print "Constant vector")
+ (print-constvector (cadr (vector-ref cv i))))
+ ((global)
+ (print "Global: " (cadr (vector-ref cv i))))
+ ((data)
+ (print "Data: " (cadr (vector-ref cv i)))))))
+
+ (define (print-segment segment)
+ (print "Segment # " segment-no)
+ (print-instructions (disassemble-codevector (car segment)) port)
+ (print-constvector (cdr segment))
+ (print "========================================"))
+
+ (cond ((procedure? item)
+ (print-instructions (disassemble-codevector (procedure-ref item 0))
+ port))
+ ((and (pair? item)
+ (bytevector? (car item))
+ (vector? (cdr item)))
+ (print-segment item))
+ (else
+ (error "disassemble-item: " item " is not disassemblable."))))
+
+
+; Disassemble a ".lop" or ".fasl" file; dump output to screen or
+; other (optional) file.
+
+(define (disassemble-file file . rest)
+
+ (define (doit input-port output-port)
+ (display "; From " output-port)
+ (display file output-port)
+ (newline output-port)
+ (do ((segment-no 0 (+ segment-no 1))
+ (segment (read input-port) (read input-port)))
+ ((eof-object? segment))
+ (disassemble-item segment segment-no output-port)))
+
+ ; disassemble313
+
+ (call-with-input-file
+ file
+ (lambda (input-port)
+ (if (null? rest)
+ (doit input-port (current-output-port))
+ (begin
+ (delete-file (car rest))
+ (call-with-output-file
+ (car rest)
+ (lambda (output-port) (doit input-port output-port)))))))
+ (unspecified))
+
+
+; Display and manipulate the compiler switches.
+
+(define (compiler-switches . rest)
+
+ (define (slow-code)
+ (set-compiler-flags! 'no-optimization)
+ (set-assembler-flags! 'no-optimization))
+
+ (define (standard-code)
+ (set-compiler-flags! 'standard)
+ (set-assembler-flags! 'standard))
+
+ (define (fast-safe-code)
+ (set-compiler-flags! 'fast-safe)
+ (set-assembler-flags! 'fast-safe))
+
+ (define (fast-unsafe-code)
+ (set-compiler-flags! 'fast-unsafe)
+ (set-assembler-flags! 'fast-unsafe))
+
+ (cond ((null? rest)
+ (display "Debugging:")
+ (newline)
+ (display-twobit-flags 'debugging)
+ (display-assembler-flags 'debugging)
+ (newline)
+ (display "Safety:")
+ (newline)
+ (display-twobit-flags 'safety)
+ (display-assembler-flags 'safety)
+ (newline)
+ (display "Speed:")
+ (newline)
+ (display-twobit-flags 'optimization)
+ (display-assembler-flags 'optimization)
+ (if #f #f))
+ ((null? (cdr rest))
+ (case (car rest)
+ ((0 slow) (slow-code))
+ ((1 standard) (standard-code))
+ ((2 fast-safe) (fast-safe-code))
+ ((3 fast-unsafe) (fast-unsafe-code))
+ ((default
+ factory-settings) (fast-safe-code)
+ (include-source-code #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f))
+ (else
+ (error "Unrecognized flag " (car rest) " to compiler-switches.")))
+ (unspecified))
+ (else
+ (error "Too many arguments to compiler-switches."))))
+
+; Read and process one file, producing another.
+; Preserves the global syntactic environment.
+
+(define (process-file infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (let loop ((x (read inport)))
+ (if (eof-object? x)
+ #t
+ (begin (writer (processer x) outport)
+ (loop (read inport))))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+; Same as above, but passes a list of the entire file's contents
+; to the processer.
+; FIXME: Both versions of PROCESS-FILE always delete the output file.
+; Shouldn't it be left alone if the input file can't be opened?
+
+(define (process-file-block infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (do ((x (read inport) (read inport))
+ (forms '() (cons x forms)))
+ ((eof-object? x)
+ (writer (processer (reverse forms)) outport))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+
+; Given a file name with some type, produce another with some other type.
+
+(define (rewrite-file-type filename matches new)
+ (if (not (pair? matches))
+ (rewrite-file-type filename (list matches) new)
+ (let ((j (string-length filename)))
+ (let loop ((m matches))
+ (cond ((null? m)
+ (string-append filename new))
+ (else
+ (let* ((n (car m))
+ (l (string-length n)))
+ (if (file-type=? filename n)
+ (string-append (substring filename 0 (- j l)) new)
+ (loop (cdr m))))))))))
+
+(define (file-type=? file-name type-name)
+ (let ((fl (string-length file-name))
+ (tl (string-length type-name)))
+ (and (>= fl tl)
+ (string-ci=? type-name
+ (substring file-name (- fl tl) fl)))))
+
+; eof
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit-smaller.sch,v 1.1 1999/09/09 22:13:42 lth Exp $
+;
+; Procedures that make .LAP structures human-readable
+
+(define (readify-lap code)
+ (map (lambda (x)
+ (let ((iname (cdr (assv (car x) *mnemonic-names*))))
+ (if (not (= (car x) $lambda))
+ (cons iname (cdr x))
+ (list iname (readify-lap (cadr x)) (caddr x)))))
+ code))
+
+(define (readify-file f . o)
+
+ (define (doit)
+ (let ((i (open-input-file f)))
+ (let loop ((x (read i)))
+ (if (not (eof-object? x))
+ (begin (pretty-print (readify-lap x))
+ (loop (read i)))))))
+
+ (if (null? o)
+ (doit)
+ (begin (delete-file (car o))
+ (with-output-to-file (car o) doit))))
+
+; eof
+; ----------------------------------------------------------------------
+
+(define (twobit-benchmark . rest)
+ (let ((k (if (null? rest) 1 (car rest))))
+ (compiler-switches 'fast-safe)
+ (benchmark-block-mode #t)
+ (run-benchmark
+ "twobit"
+ k
+ (lambda () (compile-file "twobit-input.sch"))
+ (lambda (result)
+ #t))))
+
+; eof
--- /dev/null
+; Complete source for Twobit and Sparc assembler in one file.
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; See 'twobit-benchmark', at end.
+
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Completely fundamental pathname manipulation.
+
+; This takes zero or more directory components and a file name and
+; constructs a filename relative to the current directory.
+
+(define (make-relative-filename . components)
+
+ (define (construct l)
+ (if (null? (cdr l))
+ l
+ (cons (car l)
+ (cons "/" (construct (cdr l))))))
+
+ (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components))))
+
+; This takes one or more directory components and constructs a
+; directory name with proper termination (a crock -- we can finess
+; this later).
+
+(define (pathname-append . components)
+
+ (define (construct l)
+ (cond ((null? (cdr l))
+ l)
+ ((string=? (car l) "")
+ (construct (cdr l)))
+ ((char=? #\/ (string-ref (car l) (- (string-length (car l)) 1)))
+ (cons (car l) (construct (cdr l))))
+ (else
+ (cons (car l)
+ (cons "/" (construct (cdr l)))))))
+
+ (let ((n (if (null? (cdr components))
+ (car components)
+ (apply string-append (construct components)))))
+ (if (not (char=? #\/ (string-ref n (- (string-length n) 1))))
+ (string-append n "/")
+ n)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Nbuild parameters for SPARC Larceny.
+
+(define (make-nbuild-parameter dir source? verbose? hostdir hostname)
+ (let ((parameters
+ `((compiler . ,(pathname-append dir "Compiler"))
+ (util . ,(pathname-append dir "Util"))
+ (build . ,(pathname-append dir "Rts" "Build"))
+ (source . ,(pathname-append dir "Lib"))
+ (common-source . ,(pathname-append dir "Lib" "Common"))
+ (repl-source . ,(pathname-append dir "Repl"))
+ (interp-source . ,(pathname-append dir "Eval"))
+ (machine-source . ,(pathname-append dir "Lib" "Sparc"))
+ (common-asm . ,(pathname-append dir "Asm" "Common"))
+ (sparc-asm . ,(pathname-append dir "Asm" "Sparc"))
+ (target-machine . SPARC)
+ (endianness . big)
+ (word-size . 32)
+ (always-source? . ,source?)
+ (verbose-load? . ,verbose?)
+ (compatibility . ,(pathname-append dir "Compat" hostdir))
+ (host-system . ,hostname)
+ )))
+ (lambda (key)
+ (let ((probe (assq key parameters)))
+ (if probe
+ (cdr probe)
+ #f)))))
+
+(define nbuild-parameter
+ (make-nbuild-parameter "" #f #f "Larceny" "Larceny"))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Useful list functions.
+;
+; Notes:
+; * Reduce, reduce-right, fold-right, fold-left are compatible with MIT Scheme.
+; * Make-list is compatible with MIT Scheme and Chez Scheme.
+; * These are not (yet) compatible with Shivers's proposed list functions.
+; * remq, remv, remove, remq!, remv!, remov!, every?, and some? are in the
+; basic library.
+
+; Destructively remove all associations whose key matches `key' from `alist'.
+
+(define (aremq! key alist)
+ (cond ((null? alist) alist)
+ ((eq? key (caar alist))
+ (aremq! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremq! key (cdr alist)))
+ alist)))
+
+(define (aremv! key alist)
+ (cond ((null? alist) alist)
+ ((eqv? key (caar alist))
+ (aremv! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremv! key (cdr alist)))
+ alist)))
+
+(define (aremove! key alist)
+ (cond ((null? alist) alist)
+ ((equal? key (caar alist))
+ (aremove! key (cdr alist)))
+ (else
+ (set-cdr! alist (aremove! key (cdr alist)))
+ alist)))
+
+; Return a list of elements of `list' selected by the predicate.
+
+(define (filter select? list)
+ (cond ((null? list) list)
+ ((select? (car list))
+ (cons (car list) (filter select? (cdr list))))
+ (else
+ (filter select? (cdr list)))))
+
+; Return the first element of `list' selected by the predicate.
+
+(define (find selected? list)
+ (cond ((null? list) #f)
+ ((selected? (car list)) (car list))
+ (else (find selected? (cdr list)))))
+
+; Return a list with all duplicates (according to predicate) removed.
+
+(define (remove-duplicates list same?)
+
+ (define (member? x list)
+ (cond ((null? list) #f)
+ ((same? x (car list)) #t)
+ (else (member? x (cdr list)))))
+
+ (cond ((null? list) list)
+ ((member? (car list) (cdr list))
+ (remove-duplicates (cdr list) same?))
+ (else
+ (cons (car list) (remove-duplicates (cdr list) same?)))))
+
+; Return the least element of `list' according to some total order.
+
+(define (least less? list)
+ (reduce (lambda (a b) (if (less? a b) a b)) #f list))
+
+; Return the greatest element of `list' according to some total order.
+
+(define (greatest greater? list)
+ (reduce (lambda (a b) (if (greater? a b) a b)) #f list))
+
+; (mappend p l) = (apply append (map p l))
+
+(define (mappend proc l)
+ (apply append (map proc l)))
+
+; (make-list n) => (a1 ... an) for some ai
+; (make-list n x) => (a1 ... an) where ai = x
+
+(define (make-list nelem . rest)
+ (let ((val (if (null? rest) #f (car rest))))
+ (define (loop n l)
+ (if (zero? n)
+ l
+ (loop (- n 1) (cons val l))))
+ (loop nelem '())))
+
+; (reduce p x ()) => x
+; (reduce p x (a)) => a
+; (reduce p x (a b ...)) => (p (p a b) ...))
+
+(define (reduce proc initial l)
+
+ (define (loop val l)
+ (if (null? l)
+ val
+ (loop (proc val (car l)) (cdr l))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop (car l) (cdr l)))))
+
+; (reduce-right p x ()) => x
+; (reduce-right p x (a)) => a
+; (reduce-right p x (a b ...)) => (p a (p b ...))
+
+(define (reduce-right proc initial l)
+
+ (define (loop l)
+ (if (null? (cdr l))
+ (car l)
+ (proc (car l) (loop (cdr l)))))
+
+ (cond ((null? l) initial)
+ ((null? (cdr l)) (car l))
+ (else (loop l))))
+
+; (fold-left p x (a b ...)) => (p (p (p x a) b) ...)
+
+(define (fold-left proc initial l)
+ (if (null? l)
+ initial
+ (fold-left proc (proc initial (car l)) (cdr l))))
+
+; (fold-right p x (a b ...)) => (p a (p b (p ... x)))
+
+(define (fold-right proc initial l)
+ (if (null? l)
+ initial
+ (proc (car l) (fold-right proc initial (cdr l)))))
+
+; (iota n) => (0 1 2 ... n-1)
+
+(define (iota n)
+ (let loop ((n (- n 1)) (r '()))
+ (let ((r (cons n r)))
+ (if (= n 0)
+ r
+ (loop (- n 1) r)))))
+
+; (list-head (a1 ... an) m) => (a1 ... am) for m <= n
+
+(define (list-head l n)
+ (if (zero? n)
+ '()
+ (cons (car l) (list-head (cdr l) (- n 1)))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- compatibility library for Twobit running under Larceny.
+
+(define ($$trace x) #t)
+
+(define host-system 'larceny)
+
+; Temporary?
+
+(define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+
+; The compatibility library loads Auxlib if compat:initialize is called
+; without arguments. Compat:load will load fasl files when appropriate.
+
+(define (compat:initialize . rest)
+ (if (null? rest)
+ (let ((dir (nbuild-parameter 'compatibility)))
+ (compat:load (string-append dir "compat2.sch"))
+ (compat:load (string-append dir "../../Auxlib/list.sch"))
+ (compat:load (string-append dir "../../Auxlib/pp.sch")))))
+
+(define (with-optimization level thunk)
+ (thunk))
+
+; Calls thunk1, and if thunk1 causes an error to be signalled, calls thunk2.
+
+(define (call-with-error-control thunk1 thunk2)
+ (let ((eh (error-handler)))
+ (error-handler (lambda args
+ (error-handler eh)
+ (thunk2)
+ (apply eh args)))
+ (thunk1)
+ (error-handler eh)))
+
+(define (larc-new-extension fn ext)
+ (let* ((l (string-length fn))
+ (x (let loop ((i (- l 1)))
+ (cond ((< i 0) #f)
+ ((char=? (string-ref fn i) #\.) (+ i 1))
+ (else (loop (- i 1)))))))
+ (if (not x)
+ (string-append fn "." ext)
+ (string-append (substring fn 0 x) ext))))
+
+(define (compat:load filename)
+ (define (loadit fn)
+ (if (nbuild-parameter 'verbose-load?)
+ (format #t "~a~%" fn))
+ (load fn))
+ (if (nbuild-parameter 'always-source?)
+ (loadit filename)
+ (let ((fn (larc-new-extension filename "fasl")))
+ (if (and (file-exists? fn)
+ (compat:file-newer? fn filename))
+ (loadit fn)
+ (loadit filename)))))
+
+(define (compat:file-newer? a b)
+ (let* ((ta (file-modification-time a))
+ (tb (file-modification-time b))
+ (limit (vector-length ta)))
+ (let loop ((i 0))
+ (cond ((= i limit)
+ #f)
+ ((= (vector-ref ta i) (vector-ref tb i))
+ (loop (+ i 1)))
+ (else
+ (> (vector-ref ta i) (vector-ref tb i)))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- second part of compatibility code
+; This file ought to be compiled, but doesn't have to be.
+;
+; 12 April 1999
+
+(define host-system 'larceny) ; Don't remove this!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; A well-defined sorting procedure.
+
+(define compat:sort (lambda (list less?) (sort list less?)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Well-defined character codes.
+; Returns the UCS-2 code for a character.
+
+(define compat:char->integer char->integer)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Input and output
+
+(define (write-lop item port)
+ (lowlevel-write item port)
+ (newline port)
+ (newline port))
+
+(define write-fasl-datum lowlevel-write)
+
+; The power of self-hosting ;-)
+
+(define (misc->bytevector x)
+ (let ((bv (bytevector-like-copy x)))
+ (typetag-set! bv $tag.bytevector-typetag)
+ bv))
+
+(define string->bytevector misc->bytevector)
+
+(define bignum->bytevector misc->bytevector)
+
+(define (flonum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+(define (compnum->bytevector x)
+ (clear-first-word (misc->bytevector x)))
+
+; Clears garbage word of compnum/flonum; makes regression testing much
+; easier.
+
+(define (clear-first-word bv)
+ (bytevector-like-set! bv 0 0)
+ (bytevector-like-set! bv 1 0)
+ (bytevector-like-set! bv 2 0)
+ (bytevector-like-set! bv 3 0)
+ bv)
+
+(define (list->bytevector l)
+ (let ((b (make-bytevector (length l))))
+ (do ((i 0 (+ i 1))
+ (l l (cdr l)))
+ ((null? l) b)
+ (bytevector-set! b i (car l)))))
+
+(define bytevector-word-ref
+ (let ((two^8 (expt 2 8))
+ (two^16 (expt 2 16))
+ (two^24 (expt 2 24)))
+ (lambda (bv i)
+ (+ (* (bytevector-ref bv i) two^24)
+ (* (bytevector-ref bv (+ i 1)) two^16)
+ (* (bytevector-ref bv (+ i 2)) two^8)
+ (bytevector-ref bv (+ i 3))))))
+
+(define (twobit-format fmt . rest)
+ (let ((out (open-output-string)))
+ (apply format out fmt rest)
+ (get-output-string out)))
+
+; This needs to be a random number in both a weaker and stronger sense
+; than `random': it doesn't need to be a truly random number, so a sequence
+; of calls can return a non-random sequence, but if two processes generate
+; two sequences, then those sequences should not be the same.
+;
+; Gross, huh?
+
+(define (an-arbitrary-number)
+ (system "echo \\\"`date`\\\" > a-random-number")
+ (let ((x (string-hash (call-with-input-file "a-random-number" read))))
+ (delete-file "a-random-number")
+ x))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Miscellaneous
+
+(define cerror error)
+
+; eof
+; Copyright 1991 Wiliam Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Sets represented as lists.
+;
+; 5 April 1999.
+
+(define (empty-set) '())
+
+(define (empty-set? x) (null? x))
+
+(define (make-set x)
+ (define (loop x y)
+ (cond ((null? x) y)
+ ((member (car x) y) (loop (cdr x) y))
+ (else (loop (cdr x) (cons (car x) y)))))
+ (loop x '()))
+
+(define (set-equal? x y)
+ (and (subset? x y) (subset? y x)))
+
+(define (subset? x y)
+ (every? (lambda (x) (member x y))
+ x))
+
+; To get around MacScheme's limit on the number of arguments.
+
+(define apply-union)
+
+(define union
+ (letrec ((union2
+ (lambda (x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))))
+
+ (set! apply-union
+ (lambda (sets)
+ (do ((sets sets (cdr sets))
+ (result '() (union2 (car sets) result)))
+ ((null? sets)
+ result))))
+
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (union2 (car args) (cadr args)))
+ (else (union2 (union2 (car args)
+ (cadr args))
+ (apply union (cddr args))))))))
+
+(define intersection
+ (letrec ((intersection2
+ (lambda (x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (cons (car x) (intersection2 (cdr x) y)))
+ (else (intersection2 (cdr x) y))))))
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (cddr args)) (intersection2 (car args) (cadr args)))
+ (else (intersection2 (intersection2 (car args)
+ (cadr args))
+ (apply intersection (cddr args))))))))
+
+(define (difference x y)
+ (cond ((null? x) '())
+ ((member (car x) y)
+ (difference (cdr x) y))
+ (else (cons (car x) (difference (cdr x) y)))))
+; Reasonably portable hashing on EQ?, EQV?, EQUAL?.
+; Requires bignums, SYMBOL-HASH.
+;
+; Given any Scheme object, returns a non-negative exact integer
+; less than 2^24.
+
+(define object-hash (lambda (x) 0)) ; hash on EQ?, EQV?
+(define equal-hash (lambda (x) 0)) ; hash on EQUAL?
+
+(let ((n 16777216)
+ (n-1 16777215)
+ (adj:fixnum 9000000)
+ (adj:negative 8000000)
+ (adj:large 7900000)
+ (adj:ratnum 7800000)
+ (adj:complex 7700000)
+ (adj:flonum 7000000)
+ (adj:compnum 6900000)
+ (adj:char 6111000)
+ (adj:string 5022200)
+ (adj:vector 4003330)
+ (adj:misc 3000444)
+ (adj:pair 2555000)
+ (adj:proc 2321001)
+ (adj:iport 2321002)
+ (adj:oport 2321003)
+ (adj:weird 2321004)
+ (budget0 32))
+
+ (define (combine hash adjustment)
+ (modulo (+ hash hash hash adjustment) 16777216))
+
+ (define (hash-on-equal x budget)
+ (if (> budget 0)
+ (cond ((string? x)
+ (string-hash x))
+ ((pair? x)
+ (let ((budget (quotient budget 2)))
+ (combine (hash-on-equal (car x) budget)
+ (hash-on-equal (cdr x) budget))))
+ ((vector? x)
+ (let ((n (vector-length x))
+ (budget (quotient budget 4)))
+ (if (> n 0)
+ (combine
+ (combine (hash-on-equal (vector-ref x 0) budget)
+ (hash-on-equal (vector-ref x (- n 1)) budget))
+ (hash-on-equal (vector-ref x (quotient n 2))
+ (+ budget budget)))
+ adj:vector)))
+ (else
+ (object-hash x)))
+ adj:weird))
+
+ (set! object-hash
+ (lambda (x)
+ (cond ((symbol? x)
+ (symbol-hash x))
+ ((number? x)
+ (if (exact? x)
+ (cond ((integer? x)
+ (cond ((negative? x)
+ (combine (object-hash (- x)) adj:negative))
+ ((< x n)
+ (combine x adj:fixnum))
+ (else
+ (combine (modulo x n) adj:large))))
+ ((rational? x)
+ (combine (combine (object-hash (numerator x))
+ adj:ratnum)
+ (object-hash (denominator x))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:complex)
+ (object-hash (imag-part x))))
+ (else
+ adj:weird))
+ (cond (#t
+ ; We can't really do anything with inexact numbers
+ ; unless infinities and NaNs behave reasonably.
+ adj:flonum)
+ ((rational? x)
+ (combine
+ (combine (object-hash
+ (inexact->exact (numerator x)))
+ adj:flonum)
+ (object-hash (inexact->exact (denominator x)))))
+ ((real? x)
+ adj:weird)
+ ((complex? x)
+ (combine (combine (object-hash (real-part x))
+ adj:compnum)
+ (object-hash (imag-part x))))
+ (else adj:weird))))
+ ((char? x)
+ (combine (char->integer x) adj:char))
+ ((string? x)
+ (combine (string-length x) adj:string))
+ ((vector? x)
+ (combine (vector-length x) adj:vector))
+ ((eq? x #t)
+ (combine 1 adj:misc))
+ ((eq? x #f)
+ (combine 2 adj:misc))
+ ((null? x)
+ (combine 3 adj:misc))
+ ((pair? x)
+ adj:pair)
+ ((procedure? x)
+ adj:proc)
+ ((input-port? x)
+ adj:iport)
+ ((output-port? x)
+ adj:oport)
+ (else
+ adj:weird))))
+
+ (set! equal-hash
+ (lambda (x)
+ (hash-on-equal x budget0)))); Hash tables.
+; Requires CALL-WITHOUT-INTERRUPTS.
+; This code should be thread-safe provided VECTOR-REF is atomic.
+;
+; (make-hashtable <hash-function> <bucket-searcher> <size>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket
+; with <size> buckets at first, expanding the number of buckets as needed.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtable <hash-function> <bucket-searcher>)
+;
+; Equivalent to (make-hashtable <hash-function> <bucket-searcher> n)
+; for some value of n chosen by the implementation.
+;
+; (make-hashtable <hash-function>)
+;
+; Equivalent to (make-hashtable <hash-function> assv).
+;
+; (make-hashtable)
+;
+; Equivalent to (make-hashtable object-hash assv).
+;
+; (hashtable-contains? <hashtable> <key>)
+;
+; Returns true iff the <hashtable> contains an entry for <key>.
+;
+; (hashtable-fetch <hashtable> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtable> if the
+; <hashtable> contains <key>; otherwise returns <flag>.
+;
+; (hashtable-get <hashtable> <key>)
+;
+; Equivalent to (hashtable-fetch <hashtable> <key> #f)
+;
+; (hashtable-put! <hashtable> <key> <value>)
+;
+; Changes the <hashtable> to associate <key> with <value>, replacing
+; any existing association for <key>.
+;
+; (hashtable-remove! <hashtable> <key>)
+;
+; Removes any association for <key> within the <hashtable>.
+;
+; (hashtable-clear! <hashtable>)
+;
+; Removes all associations from the <hashtable>.
+;
+; (hashtable-size <hashtable>)
+;
+; Returns the number of keys contained within the <hashtable>.
+;
+; (hashtable-for-each <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtable-map <procedure> <hashtable>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+;
+; (hashtable-copy <hashtable>)
+;
+; Returns a copy of the <hashtable>.
+
+; These global variables are assigned new values later.
+
+(define make-hashtable (lambda args '*))
+(define hashtable-contains? (lambda (ht key) #f))
+(define hashtable-fetch (lambda (ht key flag) flag))
+(define hashtable-get (lambda (ht key) (hashtable-fetch ht key #f)))
+(define hashtable-put! (lambda (ht key val) '*))
+(define hashtable-remove! (lambda (ht key) '*))
+(define hashtable-clear! (lambda (ht) '*))
+(define hashtable-size (lambda (ht) 0))
+(define hashtable-for-each (lambda (ht proc) '*))
+(define hashtable-map (lambda (ht proc) '()))
+(define hashtable-copy (lambda (ht) ht))
+
+; Implementation.
+; A hashtable is represented as a vector of the form
+;
+; #(("HASHTABLE") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtable,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is a vector of buckets.
+;
+; The <hasher> and <searcher> fields are constant, but
+; the <count> and <buckets> fields are mutable.
+;
+; For thread-safe operation, the mutators must modify both
+; as an atomic operation. Other operations do not require
+; critical sections provided VECTOR-REF is an atomic operation
+; and the operation does not modify the hashtable, does not
+; reference the <count> field, and fetches the <buckets>
+; field exactly once.
+
+(let ((doc (list "HASHTABLE"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (count! (lambda (ht n) (vector-set! ht 1 n)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+ (buckets! (lambda (ht v) (vector-set! ht 4 v)))
+ (defaultn 10))
+ (let ((hashtable? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtable-error (lambda (x)
+ (display "ERROR: Bad hash table: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht hashfun searcher size)
+ (vector doc 0 hashfun searcher (make-vector size '())))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ (define (resize ht0)
+ (call-without-interrupts
+ (lambda ()
+ (let ((ht (make-ht (hasher ht0)
+ (searcher ht0)
+ (+ 1 (* 2 (count ht0))))))
+ (ht-for-each (lambda (key val)
+ (put! ht key val))
+ ht0)
+ (buckets! ht0 (buckets ht))))))
+
+ ; Returns the contents of the hashtable as a vector of pairs.
+
+ (define (contents ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (z (make-vector (count ht) '())))
+ (define (loop i bucket j)
+ (if (null? bucket)
+ (if (= i n)
+ (if (= j (vector-length z))
+ z
+ (begin (display "BUG in hashtable")
+ (newline)
+ '#()))
+ (loop (+ i 1)
+ (vector-ref v i)
+ j))
+ (let ((entry (car bucket)))
+ (vector-set! z j (cons (car entry) (cdr entry)))
+ (loop i
+ (cdr bucket)
+ (+ j 1)))))
+ (loop 0 '() 0)))
+
+ (define (contains? ht key)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h)))
+ (if ((searcher ht) key b)
+ #t
+ #f))
+ (hashtable-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtable? ht)
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtable-error ht)))
+
+ (define (put! ht key val)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ ; Using SET-CDR! on the probe would make it necessary
+ ; to synchronize the CONTENTS routine.
+ (vector-set! v h (substitute1 (cons key val) probe b))
+ (begin (count! ht (+ (count ht) 1))
+ (vector-set! v h (cons (cons key val) b))
+ (if (> (count ht) n)
+ (resize ht)))))
+ #f))
+ (hashtable-error ht)))
+
+ (define (remove! ht key)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (let* ((v (buckets ht))
+ (n (vector-length v))
+ (h (modulo ((hasher ht) key) n))
+ (b (vector-ref v h))
+ (probe ((searcher ht) key b)))
+ (if probe
+ (begin (count! ht (- (count ht) 1))
+ (vector-set! v h (remq1 probe b))
+ (if (< (* 2 (+ defaultn (count ht))) n)
+ (resize ht))))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (clear! ht)
+ (if (hashtable? ht)
+ (call-without-interrupts
+ (lambda ()
+ (begin (count! ht 0)
+ (buckets! ht (make-vector defaultn '()))
+ #f)))
+ (hashtable-error ht)))
+
+ (define (size ht)
+ (if (hashtable? ht)
+ (count ht)
+ (hashtable-error ht)))
+
+ ; This code must be written so that the procedure can modify the
+ ; hashtable without breaking any invariants.
+
+ (define (ht-for-each f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (let ((x (vector-ref v j)))
+ (f (car x) (cdr x)))))
+ (hashtable-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtable? ht)
+ (let* ((v (contents ht))
+ (n (vector-length v)))
+ (do ((j 0 (+ j 1))
+ (results '() (let ((x (vector-ref v j)))
+ (cons (f (car x) (cdr x))
+ results))))
+ ((= j n)
+ (reverse results))))
+ (hashtable-error ht)))
+
+ (define (ht-copy ht)
+ (if (hashtable? ht)
+ (let* ((newtable (make-hashtable (hasher ht) (searcher ht) 0))
+ (v (buckets ht))
+ (n (vector-length v))
+ (newvector (make-vector n '())))
+ (count! newtable (count ht))
+ (buckets! newtable newvector)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! newvector i (append (vector-ref v i) '())))
+ newtable)
+ (hashtable-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtable
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args)))
+ (size (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+ defaultn
+ (caddr args))))
+ (make-ht hashfun searcher size))))
+
+ (set! hashtable-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtable-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtable-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtable-put! (lambda (ht key val) (put! ht key val)))
+ (set! hashtable-remove! (lambda (ht key) (remove! ht key)))
+ (set! hashtable-clear! (lambda (ht) (clear! ht)))
+ (set! hashtable-size (lambda (ht) (size ht)))
+ (set! hashtable-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtable-map (lambda (ht proc) (ht-map ht proc)))
+ (set! hashtable-copy (lambda (ht) (ht-copy ht)))
+ #f))
+; Hash trees: a functional data structure analogous to hash tables.
+;
+; (make-hashtree <hash-function> <bucket-searcher>)
+;
+; Returns a newly allocated mutable hash table
+; using <hash-function> as the hash function
+; and <bucket-searcher>, e.g. ASSQ, ASSV, ASSOC, to search a bucket.
+; The <hash-function> must accept a key and return a non-negative exact
+; integer.
+;
+; (make-hashtree <hash-function>)
+;
+; Equivalent to (make-hashtree <hash-function> assv).
+;
+; (make-hashtree)
+;
+; Equivalent to (make-hashtree object-hash assv).
+;
+; (hashtree-contains? <hashtree> <key>)
+;
+; Returns true iff the <hashtree> contains an entry for <key>.
+;
+; (hashtree-fetch <hashtree> <key> <flag>)
+;
+; Returns the value associated with <key> in the <hashtree> if the
+; <hashtree> contains <key>; otherwise returns <flag>.
+;
+; (hashtree-get <hashtree> <key>)
+;
+; Equivalent to (hashtree-fetch <hashtree> <key> #f)
+;
+; (hashtree-put <hashtree> <key> <value>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is associated with <value>.
+;
+; (hashtree-remove <hashtree> <key>)
+;
+; Returns a new hashtree that is like <hashtree> except that
+; <key> is not associated with any value.
+;
+; (hashtree-size <hashtree>)
+;
+; Returns the number of keys contained within the <hashtree>.
+;
+; (hashtree-for-each <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association. The order of these calls is indeterminate.
+;
+; (hashtree-map <procedure> <hashtree>)
+;
+; The <procedure> must accept two arguments, a key and the value
+; associated with that key. Calls the <procedure> once for each
+; key-value association, and returns a list of the results. The
+; order of the calls is indeterminate.
+
+; These global variables are assigned new values later.
+
+(define make-hashtree (lambda args '*))
+(define hashtree-contains? (lambda (ht key) #f))
+(define hashtree-fetch (lambda (ht key flag) flag))
+(define hashtree-get (lambda (ht key) (hashtree-fetch ht key #f)))
+(define hashtree-put (lambda (ht key val) '*))
+(define hashtree-remove (lambda (ht key) '*))
+(define hashtree-size (lambda (ht) 0))
+(define hashtree-for-each (lambda (ht proc) '*))
+(define hashtree-map (lambda (ht proc) '()))
+
+; Implementation.
+; A hashtree is represented as a vector of the form
+;
+; #(("hashtree") <count> <hasher> <searcher> <buckets>)
+;
+; where <count> is the number of associations within the hashtree,
+; <hasher> is the hash function, <searcher> is the bucket searcher,
+; and <buckets> is generated by the following grammar:
+;
+; <buckets> ::= ()
+; | (<fixnum> <associations> <buckets> <buckets>)
+; <alist> ::= (<associations>)
+; <associations> ::=
+; | <association> <associations>
+; <association> ::= (<key> . <value>)
+;
+; If <buckets> is of the form (n alist buckets1 buckets2),
+; then n is the hash code of all keys in alist, all keys in buckets1
+; have a hash code less than n, and all keys in buckets2 have a hash
+; code greater than n.
+
+(let ((doc (list "hashtree"))
+ (count (lambda (ht) (vector-ref ht 1)))
+ (hasher (lambda (ht) (vector-ref ht 2)))
+ (searcher (lambda (ht) (vector-ref ht 3)))
+ (buckets (lambda (ht) (vector-ref ht 4)))
+
+ (make-empty-buckets (lambda () '()))
+
+ (make-buckets
+ (lambda (h alist buckets1 buckets2)
+ (list h alist buckets1 buckets2)))
+
+ (buckets-empty? (lambda (buckets) (null? buckets)))
+
+ (buckets-n (lambda (buckets) (car buckets)))
+ (buckets-alist (lambda (buckets) (cadr buckets)))
+ (buckets-left (lambda (buckets) (caddr buckets)))
+ (buckets-right (lambda (buckets) (cadddr buckets))))
+
+ (let ((hashtree? (lambda (ht)
+ (and (vector? ht)
+ (= 5 (vector-length ht))
+ (eq? doc (vector-ref ht 0)))))
+ (hashtree-error (lambda (x)
+ (display "ERROR: Bad hash tree: ")
+ (newline)
+ (write x)
+ (newline))))
+
+ ; Internal operations.
+
+ (define (make-ht count hashfun searcher buckets)
+ (vector doc count hashfun searcher buckets))
+
+ ; Substitute x for the first occurrence of y within the list z.
+ ; y is known to occur within z.
+
+ (define (substitute1 x y z)
+ (cond ((eq? y (car z))
+ (cons x (cdr z)))
+ (else
+ (cons (car z)
+ (substitute1 x y (cdr z))))))
+
+ ; Remove the first occurrence of x from y.
+ ; x is known to occur within y.
+
+ (define (remq1 x y)
+ (cond ((eq? x (car y))
+ (cdr y))
+ (else
+ (cons (car y)
+ (remq1 x (cdr y))))))
+
+ ; Returns the contents of the hashtree as a list of pairs.
+
+ (define (contents ht)
+ (let* ((t (buckets ht)))
+
+ (define (contents t alist)
+ (if (buckets-empty? t)
+ alist
+ (contents (buckets-left t)
+ (contents (buckets-right t)
+ (append-reverse (buckets-alist t)
+ alist)))))
+
+ (define (append-reverse x y)
+ (if (null? x)
+ y
+ (append-reverse (cdr x)
+ (cons (car x) y))))
+
+ ; Creating a new hashtree from a list that is almost sorted
+ ; in hash code order would create an extremely unbalanced
+ ; hashtree, so this routine randomizes the order a bit.
+
+ (define (randomize1 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize2 (cdr alist)
+ (cons (car alist) alist1)
+ alist2
+ alist3)))
+
+ (define (randomize2 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize3 (cdr alist)
+ alist1
+ (cons (car alist) alist2)
+ alist3)))
+
+ (define (randomize3 alist alist1 alist2 alist3)
+ (if (null? alist)
+ (randomize-combine alist1 alist2 alist3)
+ (randomize1 (cdr alist)
+ alist1
+ alist2
+ (cons (car alist) alist3))))
+
+ (define (randomize-combine alist1 alist2 alist3)
+ (cond ((null? alist2)
+ alist1)
+ ((null? alist3)
+ (append-reverse alist2 alist1))
+ (else
+ (append-reverse
+ (randomize1 alist3 '() '() '())
+ (append-reverse
+ (randomize1 alist1 '() '() '())
+ (randomize1 alist2 '() '() '()))))))
+
+ (randomize1 (contents t '()) '() '() '())))
+
+ (define (contains? ht key)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key)))
+ (if ((searcher ht) key (find-bucket t h))
+ #t
+ #f))
+ (hashtree-error ht)))
+
+ (define (fetch ht key flag)
+ (if (hashtree? ht)
+ (let* ((t (buckets ht))
+ (h ((hasher ht) key))
+ (probe ((searcher ht) key (find-bucket t h))))
+ (if probe
+ (cdr probe)
+ flag))
+ (hashtree-error ht)))
+
+ ; Given a <buckets> t and a hash code h, returns the alist for h.
+
+ (define (find-bucket t h)
+ (if (buckets-empty? t)
+ '()
+ (let ((n (buckets-n t)))
+ (cond ((< h n)
+ (find-bucket (buckets-left t) h))
+ ((< n h)
+ (find-bucket (buckets-right t) h))
+ (else
+ (buckets-alist t))))))
+
+ (define (put ht key val)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (association (cons key val))
+ (c (count ht)))
+ (define (put t h)
+ (if (buckets-empty? t)
+ (begin (set! c (+ c 1))
+ (make-buckets h (list association) t t))
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (put (buckets-left t) h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (put (buckets-right t) h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (make-buckets n
+ (substitute1 association
+ probe
+ alist)
+ left
+ right)
+ (begin
+ (set! c (+ c 1))
+ (make-buckets n
+ (cons association alist)
+ left
+ right)))))))))
+ (let ((buckets (put t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (remove ht key)
+ (if (hashtree? ht)
+ (let ((t (buckets ht))
+ (h ((hasher ht) key))
+ (c (count ht)))
+ (define (remove t h)
+ (if (buckets-empty? t)
+ t
+ (let ((n (buckets-n t))
+ (alist (buckets-alist t))
+ (left (buckets-left t))
+ (right (buckets-right t)))
+ (cond ((< h n)
+ (make-buckets n
+ alist
+ (remove left h)
+ right))
+ ((< n h)
+ (make-buckets n
+ alist
+ left
+ (remove right h)))
+ (else
+ (let ((probe ((searcher ht) key alist)))
+ (if probe
+ (begin (set! c (- c 1))
+ (make-buckets n
+ (remq1 probe alist)
+ left
+ right))
+ t)))))))
+ (let ((buckets (remove t h)))
+ (make-ht c (hasher ht) (searcher ht) buckets)))
+ (hashtree-error ht)))
+
+ (define (size ht)
+ (if (hashtree? ht)
+ (count ht)
+ (hashtree-error ht)))
+
+ (define (ht-for-each f ht)
+ (if (hashtree? ht)
+ (for-each (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ (define (ht-map f ht)
+ (if (hashtree? ht)
+ (map (lambda (association)
+ (f (car association)
+ (cdr association)))
+ (contents ht))
+ (hashtree-error ht)))
+
+ ; External entry points.
+
+ (set! make-hashtree
+ (lambda args
+ (let* ((hashfun (if (null? args) object-hash (car args)))
+ (searcher (if (or (null? args) (null? (cdr args)))
+ assv
+ (cadr args))))
+ (make-ht 0 hashfun searcher (make-empty-buckets)))))
+
+ (set! hashtree-contains? (lambda (ht key) (contains? ht key)))
+ (set! hashtree-fetch (lambda (ht key flag) (fetch ht key flag)))
+ (set! hashtree-get (lambda (ht key) (fetch ht key #f)))
+ (set! hashtree-put (lambda (ht key val) (put ht key val)))
+ (set! hashtree-remove (lambda (ht key) (remove ht key)))
+ (set! hashtree-size (lambda (ht) (size ht)))
+ (set! hashtree-for-each (lambda (ht proc) (ht-for-each ht proc)))
+ (set! hashtree-map (lambda (ht proc) (ht-map ht proc)))
+ #f))
+; Copyright 1994 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 24 April 1999
+;
+; Compiler switches needed by Twobit.
+
+(define make-twobit-flag)
+(define display-twobit-flag)
+
+(define make-twobit-flag
+ (lambda (name)
+
+ (define (twobit-warning)
+ (display "Error: incorrect arguments to ")
+ (write name)
+ (newline)
+ (reset))
+
+ (define (display-flag state)
+ (display (if state " + " " - "))
+ (display name)
+ (display " is ")
+ (display (if state "on" "off"))
+ (newline))
+
+ (let ((state #t))
+ (lambda args
+ (cond ((null? args) state)
+ ((and (null? (cdr args))
+ (boolean? (car args)))
+ (set! state (car args))
+ state)
+ ((and (null? (cdr args))
+ (eq? (car args) 'display))
+ (display-flag state))
+ (else (twobit-warning)))))))
+
+(define (display-twobit-flag flag)
+ (flag 'display))
+
+; Debugging and convenience.
+
+(define issue-warnings
+ (make-twobit-flag 'issue-warnings))
+
+(define include-source-code
+ (make-twobit-flag 'include-source-code))
+
+(define include-variable-names
+ (make-twobit-flag 'include-variable-names))
+
+(define include-procedure-names
+ (make-twobit-flag 'include-procedure-names))
+
+; Space efficiency.
+; This switch isn't fully implemented yet. If it is true, then
+; Twobit will generate flat closures and will go to some trouble
+; to zero stale registers and stack slots.
+; Don't turn this switch off unless space is more important than speed.
+
+(define avoid-space-leaks
+ (make-twobit-flag 'avoid-space-leaks))
+
+; Major optimizations.
+
+(define integrate-usual-procedures
+ (make-twobit-flag 'integrate-usual-procedures))
+
+(define control-optimization
+ (make-twobit-flag 'control-optimization))
+
+(define parallel-assignment-optimization
+ (make-twobit-flag 'parallel-assignment-optimization))
+
+(define lambda-optimization
+ (make-twobit-flag 'lambda-optimization))
+
+(define benchmark-mode
+ (make-twobit-flag 'benchmark-mode))
+
+(define benchmark-block-mode
+ (make-twobit-flag 'benchmark-block-mode))
+
+(define global-optimization
+ (make-twobit-flag 'global-optimization))
+
+(define interprocedural-inlining
+ (make-twobit-flag 'interprocedural-inlining))
+
+(define interprocedural-constant-propagation
+ (make-twobit-flag 'interprocedural-constant-propagation))
+
+(define common-subexpression-elimination
+ (make-twobit-flag 'common-subexpression-elimination))
+
+(define representation-inference
+ (make-twobit-flag 'representation-inference))
+
+(define local-optimization
+ (make-twobit-flag 'local-optimization))
+
+; For backwards compatibility, until I can change the code.
+
+(define (ignore-space-leaks . args)
+ (if (null? args)
+ (not (avoid-space-leaks))
+ (avoid-space-leaks (not (car args)))))
+
+(define lambda-optimizations lambda-optimization)
+(define local-optimizations local-optimization)
+
+(define (set-compiler-flags! how)
+ (case how
+ ((no-optimization)
+ (set-compiler-flags! 'standard)
+ (avoid-space-leaks #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #f)
+ (parallel-assignment-optimization #f)
+ (lambda-optimization #f)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #f)
+ (interprocedural-inlining #f)
+ (interprocedural-constant-propagation #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f)
+ (local-optimization #f))
+ ((standard)
+ (issue-warnings #t)
+ (include-source-code #f)
+ (include-procedure-names #t)
+ (include-variable-names #t)
+ (avoid-space-leaks #f)
+ (runtime-safety-checking #t)
+ (integrate-usual-procedures #f)
+ (control-optimization #t)
+ (parallel-assignment-optimization #t)
+ (lambda-optimization #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (global-optimization #t)
+ (interprocedural-inlining #t)
+ (interprocedural-constant-propagation #t)
+ (common-subexpression-elimination #t)
+ (representation-inference #t)
+ (local-optimization #t))
+ ((fast-safe)
+ (let ((bbmode (benchmark-block-mode)))
+ (set-compiler-flags! 'standard)
+ (integrate-usual-procedures #t)
+ (benchmark-mode #t)
+ (benchmark-block-mode bbmode)))
+ ((fast-unsafe)
+ (set-compiler-flags! 'fast-safe)
+ (runtime-safety-checking #f))
+ (else
+ (error "set-compiler-flags!: unknown mode " how))))
+
+(define (display-twobit-flags which)
+ (case which
+ ((debugging)
+ (display-twobit-flag issue-warnings)
+ (display-twobit-flag include-procedure-names)
+ (display-twobit-flag include-variable-names)
+ (display-twobit-flag include-source-code))
+ ((safety)
+ (display-twobit-flag avoid-space-leaks))
+ ((optimization)
+ (display-twobit-flag integrate-usual-procedures)
+ (display-twobit-flag control-optimization)
+ (display-twobit-flag parallel-assignment-optimization)
+ (display-twobit-flag lambda-optimization)
+ (display-twobit-flag benchmark-mode)
+ (display-twobit-flag benchmark-block-mode)
+ (display-twobit-flag global-optimization)
+ (if (global-optimization)
+ (begin (display " ")
+ (display-twobit-flag interprocedural-inlining)
+ (display " ")
+ (display-twobit-flag interprocedural-constant-propagation)
+ (display " ")
+ (display-twobit-flag common-subexpression-elimination)
+ (display " ")
+ (display-twobit-flag representation-inference)))
+ (display-twobit-flag local-optimization))
+ (else
+ ; The switch might mean something to the assembler, but not to Twobit
+ #t)))
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 14 April 1999 / wdc
+
+($$trace "pass1.aux")
+
+;***************************************************************
+;
+; Each definition in this section should be overridden by an assignment
+; in a target-specific file.
+;
+; If a lambda expression has more than @maxargs-with-rest-arg@ required
+; arguments followed by a rest argument, then the macro expander will
+; rewrite the lambda expression as a lambda expression with only one
+; argument (a rest argument) whose body is a LET that binds the arguments
+; of the original lambda expression.
+
+(define @maxargs-with-rest-arg@
+ 1000000) ; infinity
+
+(define (prim-entry name) #f) ; no integrable procedures
+(define (prim-arity name) 0) ; all of which take 0 arguments
+(define (prim-opcodename name) name) ; and go by their source names
+
+; End of definitions to be overridden by target-specific assignments.
+;
+;***************************************************************
+
+; Miscellaneous routines.
+
+(define (m-warn msg . more)
+ (if (issue-warnings)
+ (begin
+ (display "WARNING from macro expander:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more))))
+
+(define (m-error msg . more)
+ (display "ERROR detected during macro expansion:")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+(define (m-bug msg . more)
+ (display "BUG in macro expander: ")
+ (newline)
+ (display msg)
+ (newline)
+ (for-each (lambda (x) (write x) (newline))
+ more)
+ (m-quit (make-constant #f)))
+
+; Given a <formals>, returns a list of bound variables.
+
+'
+(define (make-null-terminated x)
+ (cond ((null? x) '())
+ ((pair? x)
+ (cons (car x) (make-null-terminated (cdr x))))
+ (else (list x))))
+
+; Returns the length of the given list, or -1 if the argument
+; is not a list. Does not check for circular lists.
+
+(define (safe-length x)
+ (define (loop x n)
+ (cond ((null? x) n)
+ ((pair? x) (loop (cdr x) (+ n 1)))
+ (else -1)))
+ (loop x 0))
+
+; Given a unary predicate and a list, returns a list of those
+; elements for which the predicate is true.
+
+(define (filter1 p x)
+ (cond ((null? x) '())
+ ((p (car x)) (cons (car x) (filter1 p (cdr x))))
+ (else (filter1 p (cdr x)))))
+
+; Given a unary predicate and a list, returns #t if the
+; predicate is true of every element of the list.
+
+(define (every1? p x)
+ (cond ((null? x) #t)
+ ((p (car x)) (every1? p (cdr x)))
+ (else #f)))
+
+; Binary union of two sets represented as lists, using equal?.
+
+(define (union2 x y)
+ (cond ((null? x) y)
+ ((member (car x) y)
+ (union2 (cdr x) y))
+ (else (union2 (cdr x) (cons (car x) y)))))
+
+; Given an association list, copies the association pairs.
+
+(define (copy-alist alist)
+ (map (lambda (x) (cons (car x) (cdr x)))
+ alist))
+
+; Removes a value from a list. May destroy the list.
+
+'
+(define remq!
+ (letrec ((loop (lambda (x y prev)
+ (cond ((null? y) #t)
+ ((eq? x (car y))
+ (set-cdr! prev (cdr y))
+ (loop x (cdr prev) prev))
+ (else
+ (loop x (cdr y) y))))))
+ (lambda (x y)
+ (cond ((null? y) '())
+ ((eq? x (car y))
+ (remq! x (cdr y)))
+ (else
+ (loop x (cdr y) y)
+ y)))))
+
+; Procedure-specific source code transformations.
+; The transformer is passed a source code expression and a predicate
+; and returns one of:
+;
+; the original source code expression
+; a new source code expression to use in place of the original
+; #f to indicate that the procedure is being called
+; with an incorrect number of arguments or
+; with an incorrect operand
+;
+; The original source code expression is guaranteed to be a list whose
+; car is the name associated with the transformer.
+; The predicate takes an identifier (a symbol) and returns true iff
+; that identifier is bound to something other than its global binding.
+;
+; Since the procedures and their transformations are target-specific,
+; they are defined in another file, in the Target subdirectory.
+
+; FIXME:
+; I think this is now used in only one place, in simplify-if.
+
+(define (integrable? name)
+ (and (integrate-usual-procedures)
+ (prim-entry name)))
+
+; MAKE-READABLE strips the referencing information
+; and replaces (begin I) by I.
+; If the optional argument is true, then it also reconstructs LET.
+
+(define (make-readable exp . rest)
+ (let ((fancy? (and (not (null? rest))
+ (car rest))))
+ (define (make-readable exp)
+ (case (car exp)
+ ((quote) (make-readable-quote exp))
+ ((lambda) `(lambda ,(lambda.args exp)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs exp))
+ ,(make-readable (lambda.body exp))))
+ ((set!) `(set! ,(assignment.lhs exp)
+ ,(make-readable (assignment.rhs exp))))
+ ((if) `(if ,(make-readable (if.test exp))
+ ,(make-readable (if.then exp))
+ ,(make-readable (if.else exp))))
+ ((begin) (if (variable? exp)
+ (variable.name exp)
+ `(begin ,@(map make-readable (begin.exprs exp)))))
+ (else (make-readable-call exp))))
+ (define (make-readable-quote exp)
+ (let ((x (constant.value exp)))
+ (if (and fancy?
+ (or (boolean? x)
+ (number? x)
+ (char? x)
+ (string? x)))
+ x
+ exp)))
+ (define (make-readable-call exp)
+ (let ((proc (call.proc exp)))
+ (if (and fancy?
+ (lambda? proc)
+ (list? (lambda.args proc)))
+ ;(make-readable-let* exp '() '() '())
+ (make-readable-let exp)
+ `(,(make-readable (call.proc exp))
+ ,@(map make-readable (call.args exp))))))
+ (define (make-readable-let exp)
+ (let* ((L (call.proc exp))
+ (formals (lambda.args L))
+ (args (map make-readable (call.args exp)))
+ (body (make-readable (lambda.body L))))
+ (if (and (null? (lambda.defs L))
+ (= (length args) 1)
+ (pair? body)
+ (or (and (eq? (car body) 'let)
+ (= (length (cadr body)) 1))
+ (eq? (car body) 'let*)))
+ `(let* ((,(car formals) ,(car args))
+ ,@(cadr body))
+ ,@(cddr body))
+ `(let ,(map list
+ (lambda.args L)
+ args)
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs L))
+ ,body))))
+ (define (make-readable-let* exp vars inits defs)
+ (if (and (null? defs)
+ (call? exp)
+ (lambda? (call.proc exp))
+ (= 1 (length (lambda.args (call.proc exp)))))
+ (let ((proc (call.proc exp))
+ (arg (car (call.args exp))))
+ (if (and (call? arg)
+ (lambda? (call.proc arg))
+ (= 1 (length (lambda.args (call.proc arg))))
+ (null? (lambda.defs (call.proc arg))))
+ (make-readable-let*
+ (make-call proc (list (lambda.body (call.proc arg))))
+ (cons (car (lambda.args (call.proc arg))) vars)
+ (cons (make-readable (car (call.args arg))) inits)
+ '())
+ (make-readable-let* (lambda.body proc)
+ (cons (car (lambda.args proc)) vars)
+ (cons (make-readable (car (call.args exp)))
+ inits)
+ (map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (reverse (lambda.defs proc))))))
+ (cond ((or (not (null? vars))
+ (not (null? defs)))
+ `(let* ,(map list
+ (reverse vars)
+ (reverse inits))
+ ,@defs
+ ,(make-readable exp)))
+ ((and (call? exp)
+ (lambda? (call.proc exp)))
+ (let ((proc (call.proc exp)))
+ `(let ,(map list
+ (lambda.args proc)
+ (map make-readable (call.args exp)))
+ ,@(map (lambda (def)
+ `(define ,(def.lhs def)
+ ,(make-readable (def.rhs def))))
+ (lambda.defs proc))
+ ,(make-readable (lambda.body proc)))))
+ (else
+ (make-readable exp)))))
+ (make-readable exp)))
+
+; For testing.
+
+; MAKE-UNREADABLE does the reverse.
+; It assumes there are no internal definitions.
+
+(define (make-unreadable exp)
+ (cond ((symbol? exp) (list 'begin exp))
+ ((pair? exp)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (list 'lambda
+ (cadr exp)
+ '(begin)
+ (list '() '() '() '())
+ (make-unreadable (cons 'begin (cddr exp)))))
+ ((set!) (list 'set! (cadr exp) (make-unreadable (caddr exp))))
+ ((if) (list 'if
+ (make-unreadable (cadr exp))
+ (make-unreadable (caddr exp))
+ (if (= (length exp) 3)
+ '(unspecified)
+ (make-unreadable (cadddr exp)))))
+ ((begin) (if (= (length exp) 2)
+ (make-unreadable (cadr exp))
+ (cons 'begin (map make-unreadable (cdr exp)))))
+ (else (map make-unreadable exp))))
+ (else (list 'quote exp))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 12 April 1999.
+;
+; Procedures for fetching and clobbering parts of expressions.
+
+($$trace "pass2.aux")
+
+(define (constant? exp) (eq? (car exp) 'quote))
+(define (variable? exp)
+ (and (eq? (car exp) 'begin)
+ (null? (cddr exp))))
+(define (lambda? exp) (eq? (car exp) 'lambda))
+(define (call? exp) (pair? (car exp)))
+(define (assignment? exp) (eq? (car exp) 'set!))
+(define (conditional? exp) (eq? (car exp) 'if))
+(define (begin? exp)
+ (and (eq? (car exp) 'begin)
+ (not (null? (cddr exp)))))
+
+(define (make-constant value) (list 'quote value))
+(define (make-variable name) (list 'begin name))
+(define (make-lambda formals defs R F G decls doc body)
+ (list 'lambda
+ formals
+ (cons 'begin defs)
+ (list 'quote (list R F G decls doc))
+ body))
+(define (make-call proc args) (cons proc (append args '())))
+(define (make-assignment lhs rhs) (list 'set! lhs rhs))
+(define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
+(define (make-begin exprs)
+ (if (null? (cdr exprs))
+ (car exprs)
+ (cons 'begin (append exprs '()))))
+(define (make-definition lhs rhs) (list 'define lhs rhs))
+
+(define (constant.value exp) (cadr exp))
+(define (variable.name exp) (cadr exp))
+(define (lambda.args exp) (cadr exp))
+(define (lambda.defs exp) (cdr (caddr exp)))
+(define (lambda.R exp) (car (cadr (cadddr exp))))
+(define (lambda.F exp) (cadr (cadr (cadddr exp))))
+(define (lambda.G exp) (caddr (cadr (cadddr exp))))
+(define (lambda.decls exp) (cadddr (cadr (cadddr exp))))
+(define (lambda.doc exp) (car (cddddr (cadr (cadddr exp)))))
+(define (lambda.body exp) (car (cddddr exp)))
+(define (call.proc exp) (car exp))
+(define (call.args exp) (cdr exp))
+(define (assignment.lhs exp) (cadr exp))
+(define (assignment.rhs exp) (caddr exp))
+(define (if.test exp) (cadr exp))
+(define (if.then exp) (caddr exp))
+(define (if.else exp) (cadddr exp))
+(define (begin.exprs exp) (cdr exp))
+(define (def.lhs exp) (cadr exp))
+(define (def.rhs exp) (caddr exp))
+
+(define (variable-set! exp newexp)
+ (set-car! exp (car newexp))
+ (set-cdr! exp (append (cdr newexp) '())))
+(define (lambda.args-set! exp args) (set-car! (cdr exp) args))
+(define (lambda.defs-set! exp defs) (set-cdr! (caddr exp) defs))
+(define (lambda.R-set! exp R) (set-car! (cadr (cadddr exp)) R))
+(define (lambda.F-set! exp F) (set-car! (cdr (cadr (cadddr exp))) F))
+(define (lambda.G-set! exp G) (set-car! (cddr (cadr (cadddr exp))) G))
+(define (lambda.decls-set! exp decls) (set-car! (cdddr (cadr (cadddr exp))) decls))
+(define (lambda.doc-set! exp doc) (set-car! (cddddr (cadr (cadddr exp))) doc))
+(define (lambda.body-set! exp exp0) (set-car! (cddddr exp) exp0))
+(define (call.proc-set! exp exp0) (set-car! exp exp0))
+(define (call.args-set! exp exprs) (set-cdr! exp exprs))
+(define (assignment.rhs-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.test-set! exp exp0) (set-car! (cdr exp) exp0))
+(define (if.then-set! exp exp0) (set-car! (cddr exp) exp0))
+(define (if.else-set! exp exp0) (set-car! (cdddr exp) exp0))
+(define (begin.exprs-set! exp exprs) (set-cdr! exp exprs))
+
+(define expression-set! variable-set!) ; used only by pass 3
+
+; FIXME: This duplicates information in Lib/procinfo.sch.
+
+(define (make-doc name arity formals source-code filename filepos)
+ (vector name source-code arity filename filepos formals))
+(define (doc.name d) (vector-ref d 0))
+(define (doc.code d) (vector-ref d 1))
+(define (doc.arity d) (vector-ref d 2))
+(define (doc.file d) (vector-ref d 3))
+(define (doc.filepos d) (vector-ref d 4))
+(define (doc.formals d) (vector-ref d 5))
+(define (doc.name-set! d x) (if d (vector-set! d 0 x)))
+(define (doc.code-set! d x) (if d (vector-set! d 1 x)))
+(define (doc.arity-set! d x) (if d (vector-set! d 2 x)))
+(define (doc.file-set! d x) (if d (vector-set! d 3 x)))
+(define (doc.filepos-set! d x) (if d (vector-set! d 4 x)))
+(define (doc.formals-set! d x) (if d (vector-set! d 5 x)))
+(define (doc-copy d) (list->vector (vector->list d)))
+
+(define (ignored? name) (eq? name name:IGNORED))
+
+; Fairly harmless bug: rest arguments aren't getting flagged.
+
+(define (flag-as-ignored name L)
+ (define (loop name formals)
+ (cond ((null? formals)
+ ;(pass2-error p2error:violation-of-invariant name formals)
+ #t)
+ ((symbol? formals) #t)
+ ((eq? name (car formals))
+ (set-car! formals name:IGNORED)
+ (if (not (local? (lambda.R L) name:IGNORED))
+ (lambda.R-set! L
+ (cons (make-R-entry name:IGNORED '() '() '())
+ (lambda.R L)))))
+ (else (loop name (cdr formals)))))
+ (loop name (lambda.args L)))
+
+(define (make-null-terminated formals)
+ (cond ((null? formals) '())
+ ((symbol? formals) (list formals))
+ (else (cons (car formals)
+ (make-null-terminated (cdr formals))))))
+
+(define (list-head x n)
+ (cond ((zero? n) '())
+ (else (cons (car x) (list-head (cdr x) (- n 1))))))
+
+(define (remq x y)
+ (cond ((null? y) '())
+ ((eq? x (car y)) (remq x (cdr y)))
+ (else (cons (car y) (remq x (cdr y))))))
+
+(define (make-call-to-LIST args)
+ (cond ((null? args) (make-constant '()))
+ ((null? (cdr args))
+ (make-call (make-variable name:CONS)
+ (list (car args) (make-constant '()))))
+ (else (make-call (make-variable name:LIST) args))))
+
+(define (pass2-error i . etc)
+ (apply cerror (cons (vector-ref pass2-error-messages i) etc)))
+
+(define pass2-error-messages
+ '#("System error: violation of an invariant in pass 2"
+ "Wrong number of arguments to known procedure"))
+
+(define p2error:violation-of-invariant 0)
+(define p2error:wna 1)
+
+; Procedures for fetching referencing information from R-tables.
+
+(define (make-R-entry name refs assigns calls)
+ (list name refs assigns calls))
+
+(define (R-entry.name x) (car x))
+(define (R-entry.references x) (cadr x))
+(define (R-entry.assignments x) (caddr x))
+(define (R-entry.calls x) (cadddr x))
+
+(define (R-entry.references-set! x refs) (set-car! (cdr x) refs))
+(define (R-entry.assignments-set! x assignments) (set-car! (cddr x) assignments))
+(define (R-entry.calls-set! x calls) (set-car! (cdddr x) calls))
+
+(define (local? R I)
+ (assq I R))
+
+(define (R-entry R I)
+ (assq I R))
+
+(define (R-lookup R I)
+ (or (assq I R)
+ (pass2-error p2error:violation-of-invariant R I)))
+
+(define (references R I)
+ (cadr (R-lookup R I)))
+
+(define (assignments R I)
+ (caddr (R-lookup R I)))
+
+(define (calls R I)
+ (cadddr (R-lookup R I)))
+
+(define (references-set! R I X)
+ (set-car! (cdr (R-lookup R I)) X))
+
+(define (assignments-set! R I X)
+ (set-car! (cddr (R-lookup R I)) X))
+
+(define (calls-set! R I X)
+ (set-car! (cdddr (R-lookup R I)) X))
+
+; A notepad is a vector of the form #(L0 (L1 ...) (L2 ...) (I ...)),
+; where the components are:
+; element 0: a parent lambda expression (or #f if there is no enclosing
+; parent, or we want to pretend that there isn't).
+; element 1: a list of lambda expressions that the parent lambda
+; expression encloses immediately.
+; element 2: a subset of that list that does not escape.
+; element 3: a list of free variables.
+
+(define (make-notepad L)
+ (vector L '() '() '()))
+
+(define (notepad.parent np) (vector-ref np 0))
+(define (notepad.lambdas np) (vector-ref np 1))
+(define (notepad.nonescaping np) (vector-ref np 2))
+(define (notepad.vars np) (vector-ref np 3))
+
+(define (notepad.lambdas-set! np x) (vector-set! np 1 x))
+(define (notepad.nonescaping-set! np x) (vector-set! np 2 x))
+(define (notepad.vars-set! np x) (vector-set! np 3 x))
+
+(define (notepad-lambda-add! np L)
+ (notepad.lambdas-set! np (cons L (notepad.lambdas np))))
+
+(define (notepad-nonescaping-add! np L)
+ (notepad.nonescaping-set! np (cons L (notepad.nonescaping np))))
+
+(define (notepad-var-add! np I)
+ (let ((vars (notepad.vars np)))
+ (if (not (memq I vars))
+ (notepad.vars-set! np (cons I vars)))))
+
+; Given a notepad, returns the list of variables that are closed
+; over by some nested lambda expression that escapes.
+
+(define (notepad-captured-variables np)
+ (let ((nonescaping (notepad.nonescaping np)))
+ (apply-union
+ (map (lambda (L)
+ (if (memq L nonescaping)
+ (lambda.G L)
+ (lambda.F L)))
+ (notepad.lambdas np)))))
+
+; Given a notepad, returns a list of free variables computed
+; as the union of the immediate free variables with the free
+; variables of nested lambda expressions.
+
+(define (notepad-free-variables np)
+ (do ((lambdas (notepad.lambdas np) (cdr lambdas))
+ (fv (notepad.vars np)
+ (let ((L (car lambdas)))
+ (union (difference (lambda.F L)
+ (make-null-terminated (lambda.args L)))
+ fv))))
+ ((null? lambdas) fv)))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 13 December 1998
+\f; Implementation-dependent parameters and preferences that determine
+; how identifiers are represented in the output of the macro expander.
+;
+; The basic problem is that there are no reserved words, so the
+; syntactic keywords of core Scheme that are used to express the
+; output need to be represented by data that cannot appear in the
+; input. This file defines those data.
+
+($$trace "prefs")
+
+; FIXME: The following definitions are currently ignored.
+
+; The following definitions assume that identifiers of mixed case
+; cannot appear in the input.
+
+(define begin1 (string->symbol "Begin"))
+(define define1 (string->symbol "Define"))
+(define quote1 (string->symbol "Quote"))
+(define lambda1 (string->symbol "Lambda"))
+(define if1 (string->symbol "If"))
+(define set!1 (string->symbol "Set!"))
+
+; The following defines an implementation-dependent expression
+; that evaluates to an undefined (not unspecified!) value, for
+; use in expanding the (define x) syntax.
+
+(define undefined1 (list (string->symbol "Undefined")))
+
+; End of FIXME.
+
+; A variable is renamed by suffixing a vertical bar followed by a unique
+; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
+; of an identifier, but presumably this is enforced by the reader and not
+; by the compiler. Any other character that cannot appear as part of an
+; identifier may be used instead of the vertical bar.
+
+(define renaming-prefix-character #\.)
+(define renaming-suffix-character #\|)
+
+(define renaming-prefix (string renaming-prefix-character))
+(define renaming-suffix (string renaming-suffix-character))
+
+; Patches for Twobit. Here temporarily.
+
+(define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+
+(define (make-undefined)
+ (make-call (make-variable 'undefined) '()))
+
+(define (make-unspecified)
+ (make-call (make-variable 'unspecified) '()))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 December 1998
+\f; Syntactic environments.
+;
+; A syntactic environment maps identifiers to denotations,
+; where a denotation is one of
+;
+; (special <special>)
+; (macro <rules> <env>)
+; (inline <rules> <env>)
+; (identifier <id> <references> <assignments> <calls>)
+;
+; and where <special> is one of
+;
+; quote
+; lambda
+; if
+; set!
+; begin
+; define
+; define-syntax
+; let-syntax
+; letrec-syntax
+; syntax-rules
+;
+; and where <rules> is a compiled <transformer spec> (see R4RS),
+; <env> is a syntactic environment, and <id> is an identifier.
+;
+; An inline denotation is like a macro denotation, except that it
+; is not an error when none of the rules match the use. Inline
+; denotations are created by DEFINE-INLINE.
+; The standard syntactic environment should not include any
+; identifier denotations; space leaks will result if it does.
+
+($$trace "syntaxenv")
+
+(define standard-syntactic-environment
+ `((quote . (special quote))
+ (lambda . (special lambda))
+ (if . (special if))
+ (set! . (special set!))
+ (begin . (special begin))
+ (define . (special define))
+ (define-inline . (special define-inline))
+ (define-syntax . (special define-syntax))
+ (let-syntax . (special let-syntax))
+ (letrec-syntax . (special letrec-syntax))
+ (syntax-rules . (special syntax-rules))
+ ))
+
+; Unforgeable synonyms for lambda and set!, used to expand definitions.
+
+(define lambda0 (string->symbol " lambda "))
+(define set!0 (string->symbol " set! "))
+
+(define (syntactic-copy env)
+ (copy-alist env))
+
+(define (make-basic-syntactic-environment)
+ (cons (cons lambda0
+ (cdr (assq 'lambda standard-syntactic-environment)))
+ (cons (cons set!0
+ (cdr (assq 'set! standard-syntactic-environment)))
+ (syntactic-copy standard-syntactic-environment))))
+
+; The global-syntactic-environment will always be a nonempty
+; association list since there is no way to remove the entry
+; for lambda0. That entry is used as a header by destructive
+; operations.
+
+(define global-syntactic-environment
+ (make-basic-syntactic-environment))
+
+(define (global-syntactic-environment-set! env)
+ (set-cdr! global-syntactic-environment env)
+ #t)
+
+(define (syntactic-bind-globally! id denotation)
+ (if (and (identifier-denotation? denotation)
+ (eq? id (identifier-name denotation)))
+ (letrec ((remove-bindings-for-id
+ (lambda (bindings)
+ (cond ((null? bindings) '())
+ ((eq? (caar bindings) id)
+ (remove-bindings-for-id (cdr bindings)))
+ (else (cons (car bindings)
+ (remove-bindings-for-id (cdr bindings))))))))
+ (global-syntactic-environment-set!
+ (remove-bindings-for-id (cdr global-syntactic-environment))))
+ (let ((x (assq id global-syntactic-environment)))
+ (if x
+ (begin (set-cdr! x denotation) #t)
+ (global-syntactic-environment-set!
+ (cons (cons id denotation)
+ (cdr global-syntactic-environment)))))))
+
+(define (syntactic-divert env1 env2)
+ (append env2 env1))
+
+(define (syntactic-extend env ids denotations)
+ (syntactic-divert env (map cons ids denotations)))
+
+(define (syntactic-lookup env id)
+ (let ((entry (assq id env)))
+ (if entry
+ (cdr entry)
+ (make-identifier-denotation id))))
+
+(define (syntactic-assign! env id denotation)
+ (let ((entry (assq id env)))
+ (if entry
+ (set-cdr! entry denotation)
+ (m-bug "Bug detected in syntactic-assign!" env id denotation))))
+
+; Denotations.
+
+(define denotation-class car)
+
+(define (special-denotation? denotation)
+ (eq? (denotation-class denotation) 'special))
+
+(define (macro-denotation? denotation)
+ (eq? (denotation-class denotation) 'macro))
+
+(define (inline-denotation? denotation)
+ (eq? (denotation-class denotation) 'inline))
+
+(define (identifier-denotation? denotation)
+ (eq? (denotation-class denotation) 'identifier))
+
+(define (make-macro-denotation rules env)
+ (list 'macro rules env))
+
+(define (make-inline-denotation id rules env)
+ (list 'inline rules env id))
+
+(define (make-identifier-denotation id)
+ (list 'identifier id '() '() '()))
+
+(define macro-rules cadr)
+(define macro-env caddr)
+
+(define inline-rules macro-rules)
+(define inline-env macro-env)
+(define inline-name cadddr)
+
+(define identifier-name cadr)
+(define identifier-R-entry cdr)
+
+(define (same-denotation? d1 d2)
+ (or (eq? d1 d2)
+ (and (identifier-denotation? d1)
+ (identifier-denotation? d2)
+ (eq? (identifier-name d1)
+ (identifier-name d2)))))
+
+(define denotation-of-quote
+ (syntactic-lookup standard-syntactic-environment 'quote))
+
+(define denotation-of-lambda
+ (syntactic-lookup standard-syntactic-environment 'lambda))
+
+(define denotation-of-if
+ (syntactic-lookup standard-syntactic-environment 'if))
+
+(define denotation-of-set!
+ (syntactic-lookup standard-syntactic-environment 'set!))
+
+(define denotation-of-begin
+ (syntactic-lookup standard-syntactic-environment 'begin))
+
+(define denotation-of-define
+ (syntactic-lookup standard-syntactic-environment 'define))
+
+(define denotation-of-define-inline
+ (syntactic-lookup standard-syntactic-environment 'define-inline))
+
+(define denotation-of-define-syntax
+ (syntactic-lookup standard-syntactic-environment 'define-syntax))
+
+(define denotation-of-let-syntax
+ (syntactic-lookup standard-syntactic-environment 'let-syntax))
+
+(define denotation-of-letrec-syntax
+ (syntactic-lookup standard-syntactic-environment 'letrec-syntax))
+
+(define denotation-of-syntax-rules
+ (syntactic-lookup standard-syntactic-environment 'syntax-rules))
+
+(define denotation-of-...
+ (syntactic-lookup standard-syntactic-environment '...))
+
+(define denotation-of-transformer
+ (syntactic-lookup standard-syntactic-environment 'transformer))
+
+; Given a syntactic environment env to be extended, an alist returned
+; by rename-vars, and a syntactic environment env2, extends env by
+; binding the fresh identifiers to the denotations of the original
+; identifiers in env2.
+
+(define (syntactic-alias env alist env2)
+ (syntactic-divert
+ env
+ (map (lambda (name-pair)
+ (let ((old-name (car name-pair))
+ (new-name (cdr name-pair)))
+ (cons new-name
+ (syntactic-lookup env2 old-name))))
+ alist)))
+
+; Given a syntactic environment and an alist returned by rename-vars,
+; extends the environment by binding the old identifiers to the fresh
+; identifiers.
+; For Twobit, it also binds the fresh identifiers to their denotations.
+; This is ok so long as the fresh identifiers are not legal Scheme
+; identifiers.
+
+(define (syntactic-rename env alist)
+ (if (null? alist)
+ env
+ (let* ((old (caar alist))
+ (new (cdar alist))
+ (denotation (make-identifier-denotation new)))
+ (syntactic-rename
+ (cons (cons old denotation)
+ (cons (cons new denotation)
+ env))
+ (cdr alist)))))
+
+; Renaming of variables.
+
+(define renaming-counter 0)
+
+(define (make-rename-procedure)
+ (set! renaming-counter (+ renaming-counter 1))
+ (let ((suffix (string-append renaming-suffix (number->string renaming-counter))))
+ (lambda (sym)
+ (if (symbol? sym)
+ (let ((s (symbol->string sym)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (string->symbol (string-append s suffix))
+ (string->symbol (string-append renaming-prefix s suffix))))
+ (m-warn "Illegal use of rename procedure" 'ok:FIXME sym)))))
+
+; Given a datum, strips the suffixes from any symbols that appear within
+; the datum, trying not to copy any more of the datum than necessary.
+
+(define (m-strip x)
+ (define (original-symbol x)
+ (define (loop sym s i n)
+ (cond ((= i n) sym)
+ ((char=? (string-ref s i)
+ renaming-suffix-character)
+ (string->symbol (substring s 1 i)))
+ (else
+ (loop sym s (+ i 1) n))))
+ (let ((s (symbol->string x)))
+ (if (and (positive? (string-length s))
+ (char=? (string-ref s 0) renaming-prefix-character))
+ (loop x s 0 (string-length s))
+ x)))
+ (cond ((symbol? x)
+ (original-symbol x))
+ ((pair? x)
+ (let ((a (m-strip (car x)))
+ (b (m-strip (cdr x))))
+ (if (and (eq? a (car x))
+ (eq? b (cdr x)))
+ x
+ (cons a b))))
+ ((vector? x)
+ (let* ((v (vector->list x))
+ (v2 (map m-strip v)))
+ (if (equal? v v2)
+ x
+ (list->vector v2))))
+ (else x)))
+
+; Given a list of identifiers, or a formal parameter "list",
+; returns an alist that associates each identifier with a fresh identifier.
+
+(define (rename-vars original-vars)
+ (let ((rename (make-rename-procedure)))
+ (define (loop vars newvars)
+ (cond ((null? vars) (reverse newvars))
+ ((pair? vars)
+ (let ((var (car vars)))
+ (if (symbol? var)
+ (loop (cdr vars)
+ (cons (cons var (rename var))
+ newvars))
+ (m-error "Illegal variable" var))))
+ ((symbol? vars)
+ (loop (list vars) newvars))
+ (else (m-error "Malformed parameter list" original-vars))))
+ (loop original-vars '())))
+
+; Given a <formals> and an alist returned by rename-vars that contains
+; a new name for each formal identifier in <formals>, renames the
+; formal identifiers.
+
+(define (rename-formals formals alist)
+ (cond ((null? formals) '())
+ ((pair? formals)
+ (cons (cdr (assq (car formals) alist))
+ (rename-formals (cdr formals) alist)))
+ (else (cdr (assq formals alist)))))
+; Copyright 1992 William Clinger
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful purpose, and to redistribute this software
+; is granted subject to the restriction that all copies made of this
+; software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 23 November 1998
+\f; Compiler for a <transformer spec>.
+;
+; References:
+;
+; The Revised^4 Report on the Algorithmic Language Scheme.
+; Clinger and Rees [editors]. To appear in Lisp Pointers.
+; Also available as a technical report from U of Oregon,
+; MIT AI Lab, and Cornell.
+;
+; Macros That Work. Clinger and Rees. POPL '91.
+;
+; The input is a <transformer spec> and a syntactic environment.
+; Syntactic environments are described in another file.
+;
+; The supported syntax differs from the R4RS in that vectors are
+; allowed as patterns and as templates and are not allowed as
+; pattern or template data.
+;
+; <transformer spec> --> (syntax-rules <literals> <rules>)
+; <rules> --> () | (<rule> . <rules>)
+; <rule> --> (<pattern> <template>)
+; <pattern> --> <pattern_var> ; a <symbol> not in <literals>
+; | <symbol> ; a <symbol> in <literals>
+; | ()
+; | (<pattern> . <pattern>)
+; | (<ellipsis_pattern>)
+; | #(<pattern>*) ; extends R4RS
+; | #(<pattern>* <ellipsis_pattern>) ; extends R4RS
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<template>*) ; extends R4RS
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string> ; no <vector>
+; | <character>
+; | <boolean>
+; | <number>
+; <ellipsis_pattern> --> <pattern> ...
+; <ellipsis_template> --> <template> ...
+; <pattern_var> --> <symbol> ; not in <literals>
+; <literals> --> () | (<symbol> . <literals>)
+;
+; Definitions.
+;
+; scope of an ellipsis
+;
+; Within a pattern or template, the scope of an ellipsis
+; (...) is the pattern or template that appears to its left.
+;
+; rank of a pattern variable
+;
+; The rank of a pattern variable is the number of ellipses
+; within whose scope it appears in the pattern.
+;
+; rank of a subtemplate
+;
+; The rank of a subtemplate is the number of ellipses within
+; whose scope it appears in the template.
+;
+; template rank of an occurrence of a pattern variable
+;
+; The template rank of an occurrence of a pattern variable
+; within a template is the rank of that occurrence, viewed
+; as a subtemplate.
+;
+; variables bound by a pattern
+;
+; The variables bound by a pattern are the pattern variables
+; that appear within it.
+;
+; referenced variables of a subtemplate
+;
+; The referenced variables of a subtemplate are the pattern
+; variables that appear within it.
+;
+; variables opened by an ellipsis template
+;
+; The variables opened by an ellipsis template are the
+; referenced pattern variables whose rank is greater than
+; the rank of the ellipsis template.
+;
+;
+; Restrictions.
+;
+; No pattern variable appears more than once within a pattern.
+;
+; For every occurrence of a pattern variable within a template,
+; the template rank of the occurrence must be greater than or
+; equal to the pattern variable's rank.
+;
+; Every ellipsis template must open at least one variable.
+;
+; For every ellipsis template, the variables opened by an
+; ellipsis template must all be bound to sequences of the
+; same length.
+;
+;
+; The compiled form of a <rule> is
+;
+; <rule> --> (<pattern> <template> <inserted>)
+; <pattern> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<pattern> . <pattern>)
+; | <ellipsis_pattern>
+; | #(<pattern>)
+; | <pattern_datum>
+; <template> --> <pattern_var>
+; | <symbol>
+; | ()
+; | (<template2> . <template2>)
+; | #(<pattern>)
+; | <pattern_datum>
+; <template2> --> <template> | <ellipsis_template>
+; <pattern_datum> --> <string>
+; | <character>
+; | <boolean>
+; | <number>
+; <pattern_var> --> #(<V> <symbol> <rank>)
+; <ellipsis_pattern> --> #(<E> <pattern> <pattern_vars>)
+; <ellipsis_template> --> #(<E> <template> <pattern_vars>)
+; <inserted> --> () | (<symbol> . <inserted>)
+; <pattern_vars> --> () | (<pattern_var> . <pattern_vars>)
+; <rank> --> <exact non-negative integer>
+;
+; where <V> and <E> are unforgeable values.
+; The pattern variables associated with an ellipsis pattern
+; are the variables bound by the pattern, and the pattern
+; variables associated with an ellipsis template are the
+; variables opened by the ellipsis template.
+;
+;
+; What's wrong with the above?
+; If the template contains a big chunk that contains no pattern variables
+; or inserted identifiers, then the big chunk will be copied unnecessarily.
+; That shouldn't matter very often.
+
+($$trace "syntaxrules")
+
+(define pattern-variable-flag (list 'v))
+(define ellipsis-pattern-flag (list 'e))
+(define ellipsis-template-flag ellipsis-pattern-flag)
+
+(define (make-patternvar v rank)
+ (vector pattern-variable-flag v rank))
+(define (make-ellipsis-pattern P vars)
+ (vector ellipsis-pattern-flag P vars))
+(define (make-ellipsis-template T vars)
+ (vector ellipsis-template-flag T vars))
+
+(define (patternvar? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) pattern-variable-flag)))
+
+(define (ellipsis-pattern? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-pattern-flag)))
+
+(define (ellipsis-template? x)
+ (and (vector? x)
+ (= (vector-length x) 3)
+ (eq? (vector-ref x 0) ellipsis-template-flag)))
+
+(define (patternvar-name V) (vector-ref V 1))
+(define (patternvar-rank V) (vector-ref V 2))
+(define (ellipsis-pattern P) (vector-ref P 1))
+(define (ellipsis-pattern-vars P) (vector-ref P 2))
+(define (ellipsis-template T) (vector-ref T 1))
+(define (ellipsis-template-vars T) (vector-ref T 2))
+
+(define (pattern-variable v vars)
+ (cond ((null? vars) #f)
+ ((eq? v (patternvar-name (car vars)))
+ (car vars))
+ (else (pattern-variable v (cdr vars)))))
+
+; Given a <transformer spec> and a syntactic environment,
+; returns a macro denotation.
+;
+; A macro denotation is of the form
+;
+; (macro (<rule> ...) env)
+;
+; where each <rule> has been compiled as described above.
+
+(define (m-compile-transformer-spec spec env)
+ (if (and (> (safe-length spec) 1)
+ (eq? (syntactic-lookup env (car spec))
+ denotation-of-syntax-rules))
+ (let ((literals (cadr spec))
+ (rules (cddr spec)))
+ (if (or (not (list? literals))
+ (not (every1? (lambda (rule)
+ (and (= (safe-length rule) 2)
+ (pair? (car rule))))
+ rules)))
+ (m-error "Malformed syntax-rules" spec))
+ (list 'macro
+ (map (lambda (rule)
+ (m-compile-rule rule literals env))
+ rules)
+ env))
+ (m-error "Malformed syntax-rules" spec)))
+
+(define (m-compile-rule rule literals env)
+ (m-compile-pattern (cdr (car rule))
+ literals
+ env
+ (lambda (compiled-rule patternvars)
+ ; FIXME
+ ; should check uniqueness of pattern variables here
+ (cons compiled-rule
+ (m-compile-template
+ (cadr rule)
+ patternvars
+ env)))))
+
+(define (m-compile-pattern P literals env k)
+ (define (loop P vars rank k)
+ (cond ((symbol? P)
+ (if (memq P literals)
+ (k P vars)
+ (let ((var (make-patternvar P rank)))
+ (k var (cons var vars)))))
+ ((null? P) (k '() vars))
+ ((pair? P)
+ (if (and (pair? (cdr P))
+ (symbol? (cadr P))
+ (same-denotation? (syntactic-lookup env (cadr P))
+ denotation-of-...))
+ (if (null? (cddr P))
+ (loop (car P)
+ '()
+ (+ rank 1)
+ (lambda (P vars1)
+ (k (make-ellipsis-pattern P vars1)
+ (union2 vars1 vars))))
+ (m-error "Malformed pattern" P))
+ (loop (car P)
+ vars
+ rank
+ (lambda (P1 vars)
+ (loop (cdr P)
+ vars
+ rank
+ (lambda (P2 vars)
+ (k (cons P1 P2) vars)))))))
+ ((vector? P)
+ (loop (vector->list P)
+ vars
+ rank
+ (lambda (P vars)
+ (k (vector P) vars))))
+ (else (k P vars))))
+ (loop P '() 0 k))
+
+(define (m-compile-template T vars env)
+
+ (define (loop T inserted referenced rank escaped? k)
+ (cond ((symbol? T)
+ (let ((x (pattern-variable T vars)))
+ (if x
+ (if (>= rank (patternvar-rank x))
+ (k x inserted (cons x referenced))
+ (m-error
+ "Too few ellipses follow pattern variable in template"
+ (patternvar-name x)))
+ (k T (cons T inserted) referenced))))
+ ((null? T) (k '() inserted referenced))
+ ((pair? T)
+ (cond ((and (not escaped?)
+ (symbol? (car T))
+ (same-denotation? (syntactic-lookup env (car T))
+ denotation-of-...)
+ (pair? (cdr T))
+ (null? (cddr T)))
+ (loop (cadr T) inserted referenced rank #t k))
+ ((and (not escaped?)
+ (pair? (cdr T))
+ (symbol? (cadr T))
+ (same-denotation? (syntactic-lookup env (cadr T))
+ denotation-of-...))
+ (loop1 T inserted referenced rank escaped? k))
+ (else
+ (loop (car T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T1 inserted referenced)
+ (loop (cdr T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons T1 T2) inserted referenced))))))))
+ ((vector? T)
+ (loop (vector->list T)
+ inserted
+ referenced
+ rank
+ escaped?
+ (lambda (T inserted referenced)
+ (k (vector T) inserted referenced))))
+ (else (k T inserted referenced))))
+
+ (define (loop1 T inserted referenced rank escaped? k)
+ (loop (car T)
+ inserted
+ '()
+ (+ rank 1)
+ escaped?
+ (lambda (T1 inserted referenced1)
+ (loop (cddr T)
+ inserted
+ (append referenced1 referenced)
+ rank
+ escaped?
+ (lambda (T2 inserted referenced)
+ (k (cons (make-ellipsis-template
+ T1
+ (filter1 (lambda (var)
+ (> (patternvar-rank var)
+ rank))
+ referenced1))
+ T2)
+ inserted
+ referenced))))))
+
+ (loop T
+ '()
+ '()
+ 0
+ #f
+ (lambda (T inserted referenced)
+ (list T inserted))))
+
+; The pattern matcher.
+;
+; Given an input, a pattern, and two syntactic environments,
+; returns a pattern variable environment (represented as an alist)
+; if the input matches the pattern, otherwise returns #f.
+
+(define empty-pattern-variable-environment
+ (list (make-patternvar (string->symbol "") 0)))
+
+(define (m-match F P env-def env-use)
+
+ (define (match F P answer rank)
+ (cond ((null? P)
+ (and (null? F) answer))
+ ((pair? P)
+ (and (pair? F)
+ (let ((answer (match (car F) (car P) answer rank)))
+ (and answer (match (cdr F) (cdr P) answer rank)))))
+ ((symbol? P)
+ (and (symbol? F)
+ (same-denotation? (syntactic-lookup env-def P)
+ (syntactic-lookup env-use F))
+ answer))
+ ((patternvar? P)
+ (cons (cons P F) answer))
+ ((ellipsis-pattern? P)
+ (match1 F P answer (+ rank 1)))
+ ((vector? P)
+ (and (vector? F)
+ (match (vector->list F) (vector-ref P 0) answer rank)))
+ (else (and (equal? F P) answer))))
+
+ (define (match1 F P answer rank)
+ (cond ((not (list? F)) #f)
+ ((null? F)
+ (append (map (lambda (var) (cons var '()))
+ (ellipsis-pattern-vars P))
+ answer))
+ (else
+ (let* ((P1 (ellipsis-pattern P))
+ (answers (map (lambda (F) (match F P1 answer rank))
+ F)))
+ (if (every1? (lambda (answer) answer) answers)
+ (append (map (lambda (var)
+ (cons var
+ (map (lambda (answer)
+ (cdr (assq var answer)))
+ answers)))
+ (ellipsis-pattern-vars P))
+ answer)
+ #f)))))
+
+ (match F P empty-pattern-variable-environment 0))
+
+(define (m-rewrite T alist)
+
+ (define (rewrite T alist rank)
+ (cond ((null? T) '())
+ ((pair? T)
+ ((if (ellipsis-pattern? (car T))
+ append
+ cons)
+ (rewrite (car T) alist rank)
+ (rewrite (cdr T) alist rank)))
+ ((symbol? T) (cdr (assq T alist)))
+ ((patternvar? T) (cdr (assq T alist)))
+ ((ellipsis-template? T)
+ (rewrite1 T alist (+ rank 1)))
+ ((vector? T)
+ (list->vector (rewrite (vector-ref T 0) alist rank)))
+ (else T)))
+
+ (define (rewrite1 T alist rank)
+ (let* ((T1 (ellipsis-template T))
+ (vars (ellipsis-template-vars T))
+ (rows (map (lambda (var) (cdr (assq var alist)))
+ vars)))
+ (map (lambda (alist) (rewrite T1 alist rank))
+ (make-columns vars rows alist))))
+
+ (define (make-columns vars rows alist)
+ (define (loop rows)
+ (if (null? (car rows))
+ '()
+ (cons (append (map (lambda (var row)
+ (cons var (car row)))
+ vars
+ rows)
+ alist)
+ (loop (map cdr rows)))))
+ (if (or (null? (cdr rows))
+ (apply = (map length rows)))
+ (loop rows)
+ (m-error "Use of macro is not consistent with definition"
+ vars
+ rows)))
+
+ (rewrite T alist 0))
+
+; Given a use of a macro, the syntactic environment of the use,
+; a continuation that expects a transcribed expression and
+; a new environment in which to continue expansion, and a boolean
+; that is true if this transcription is for an inline procedure,
+; does the right thing.
+
+(define (m-transcribe0 exp env-use k inline?)
+ (let* ((m (syntactic-lookup env-use (car exp)))
+ (rules (macro-rules m))
+ (env-def (macro-env m))
+ (F (cdr exp)))
+ (define (loop rules)
+ (if (null? rules)
+ (if inline?
+ (k exp env-use)
+ (m-error "Use of macro does not match definition" exp))
+ (let* ((rule (car rules))
+ (pattern (car rule))
+ (alist (m-match F pattern env-def env-use)))
+ (if alist
+ (let* ((template (cadr rule))
+ (inserted (caddr rule))
+ (alist2 (rename-vars inserted))
+ (newexp (m-rewrite template (append alist2 alist))))
+ (k newexp
+ (syntactic-alias env-use alist2 env-def)))
+ (loop (cdr rules))))))
+ (if (procedure? rules)
+ (m-transcribe-low-level exp env-use k rules env-def)
+ (loop rules))))
+
+(define (m-transcribe exp env-use k)
+ (m-transcribe0 exp env-use k #f))
+
+(define (m-transcribe-inline exp env-use k)
+ (m-transcribe0 exp env-use k #t))
+
+; Copyright 1998 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Low-level macro facility based on explicit renaming. See
+; William D Clinger. Hygienic macros through explicit renaming.
+; In Lisp Pointers IV(4), 25-28, December 1991.
+
+($$trace "lowlevel")
+
+(define (m-transcribe-low-level exp env-use k transformer env-def)
+ (let ((rename0 (make-rename-procedure))
+ (renamed '())
+ (ok #t))
+ (define (lookup sym)
+ (let loop ((alist renamed))
+ (cond ((null? alist)
+ (syntactic-lookup env-use sym))
+ ((eq? sym (cdr (car alist)))
+ (syntactic-lookup env-def (car (car alist))))
+ (else
+ (loop (cdr alist))))))
+ (let ((rename
+ (lambda (sym)
+ (if ok
+ (let ((probe (assq sym renamed)))
+ (if probe
+ (cdr probe)
+ (let ((sym2 (rename0 sym)))
+ (set! renamed (cons (cons sym sym2) renamed))
+ sym2)))
+ (m-error "Illegal use of a rename procedure" sym))))
+ (compare
+ (lambda (sym1 sym2)
+ (same-denotation? (lookup sym1) (lookup sym2)))))
+ (let ((exp2 (transformer exp rename compare)))
+ (set! ok #f)
+ (k exp2
+ (syntactic-alias env-use renamed env-def))))))
+
+(define identifier? symbol?)
+
+(define (identifier->symbol id)
+ (m-strip id))
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 22 April 1999
+
+($$trace "expand")
+
+; This procedure sets the default scope of global macro definitions.
+
+(define define-syntax-scope
+ (let ((flag 'letrec))
+ (lambda args
+ (cond ((null? args) flag)
+ ((not (null? (cdr args)))
+ (apply m-warn
+ "Too many arguments passed to define-syntax-scope"
+ args))
+ ((memq (car args) '(letrec letrec* let*))
+ (set! flag (car args)))
+ (else (m-warn "Unrecognized argument to define-syntax-scope"
+ (car args)))))))
+
+; The main entry point.
+; The outermost lambda allows known procedures to be lifted outside
+; all local variables.
+
+(define (macro-expand def-or-exp)
+ (call-with-current-continuation
+ (lambda (k)
+ (set! m-quit k)
+ (set! renaming-counter 0)
+ (make-call
+ (make-lambda '() ; formals
+ '() ; definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; declarations
+ #f ; documentation
+ (desugar-definitions def-or-exp
+ global-syntactic-environment
+ make-toplevel-definition))
+ '()))))
+
+(define (desugar-definitions exp env make-toplevel-definition)
+ (letrec
+
+ ((define-loop
+ (lambda (exp rest first env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-loop (cadr exp) (append (cddr exp) rest) first env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (let ((exp (desugar-define exp env)))
+ (cond ((and (null? first) (null? rest))
+ exp)
+ ((null? rest)
+ (make-begin (reverse (cons exp first))))
+ (else (define-loop (car rest)
+ (cdr rest)
+ (cons exp first)
+ env)))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (or (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax)
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (null? first))
+ (define-syntax-loop exp rest env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-loop exp rest first env))))
+ ((and (null? first) (null? rest))
+ (m-expand exp env))
+ ((null? rest)
+ (make-begin (reverse (cons (m-expand exp env) first))))
+ (else (make-begin
+ (append (reverse first)
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest))))))))
+
+ (define-syntax-loop
+ (lambda (exp rest env)
+ (cond ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-begin)
+ (pair? (cdr exp)))
+ (define-syntax-loop (cadr exp) (append (cddr exp) rest) env))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-syntax))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-syntax exp env)
+ (begin (m-define-syntax exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define-inline))
+ (if (pair? (cdr exp))
+ (redefinition (cadr exp)))
+ (if (null? rest)
+ (m-define-inline exp env)
+ (begin (m-define-inline exp env)
+ (define-syntax-loop (car rest) (cdr rest) env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (macro-denotation? (syntactic-lookup env (car exp))))
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (define-syntax-loop exp rest env))))
+ ((and (pair? exp)
+ (symbol? (car exp))
+ (eq? (syntactic-lookup env (car exp))
+ denotation-of-define))
+ (define-loop exp rest '() env))
+ ((null? rest)
+ (m-expand exp env))
+ (else (make-begin
+ (map (lambda (exp) (m-expand exp env))
+ (cons exp rest)))))))
+
+ (desugar-define
+ (lambda (exp env)
+ (cond
+ ((null? (cdr exp)) (m-error "Malformed definition" exp))
+ ; (define foo) syntax is transformed into (define foo (undefined)).
+ ((null? (cddr exp))
+ (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (make-undefined))))
+ ((pair? (cadr exp))
+ (desugar-define
+ (let* ((def (car exp))
+ (pattern (cadr exp))
+ (f (car pattern))
+ (args (cdr pattern))
+ (body (cddr exp)))
+ (if (and (symbol? (car (cadr exp)))
+ (benchmark-mode)
+ (list? (cadr exp)))
+ `(,def ,f
+ (,lambda0 ,args
+ ((,lambda0 (,f)
+ (,set!0 ,f (,lambda0 ,args ,@body))
+ ,pattern)
+ 0)))
+ `(,def ,f (,lambda0 ,args ,@body))))
+ env))
+ ((> (length exp) 3) (m-error "Malformed definition" exp))
+ (else (let ((id (cadr exp)))
+ (if (or (null? pass1-block-inlines)
+ (not (memq id pass1-block-inlines)))
+ (begin
+ (redefinition id)
+ (syntactic-bind-globally! id (make-identifier-denotation id))))
+ (make-toplevel-definition id (m-expand (caddr exp) env)))))))
+
+ (redefinition
+ (lambda (id)
+ (if (symbol? id)
+ (if (not (identifier-denotation?
+ (syntactic-lookup global-syntactic-environment id)))
+ (if (issue-warnings)
+ (m-warn "Redefining " id)))
+ (m-error "Malformed variable or keyword" id)))))
+
+ ; body of letrec
+
+ (define-loop exp '() '() env)))
+
+; Given an expression and a syntactic environment,
+; returns an expression in core Scheme.
+
+(define (m-expand exp env)
+ (cond ((not (pair? exp))
+ (m-atom exp env))
+ ((not (symbol? (car exp)))
+ (m-application exp env))
+ (else
+ (let ((keyword (syntactic-lookup env (car exp))))
+ (case (denotation-class keyword)
+ ((special)
+ (cond
+ ((eq? keyword denotation-of-quote) (m-quote exp))
+ ((eq? keyword denotation-of-lambda) (m-lambda exp env))
+ ((eq? keyword denotation-of-if) (m-if exp env))
+ ((eq? keyword denotation-of-set!) (m-set exp env))
+ ((eq? keyword denotation-of-begin) (m-begin exp env))
+ ((eq? keyword denotation-of-let-syntax)
+ (m-let-syntax exp env))
+ ((eq? keyword denotation-of-letrec-syntax)
+ (m-letrec-syntax exp env))
+ ((or (eq? keyword denotation-of-define)
+ (eq? keyword denotation-of-define-syntax)
+ (eq? keyword denotation-of-define-inline))
+ (m-error "Definition out of context" exp))
+ (else (m-bug "Bug detected in m-expand" exp env))))
+ ((macro) (m-macro exp env))
+ ((inline) (m-inline exp env))
+ ((identifier) (m-application exp env))
+ (else (m-bug "Bug detected in m-expand" exp env)))))))
+
+(define (m-atom exp env)
+ (cond ((not (symbol? exp))
+ ; Here exp ought to be a boolean, number, character, or string.
+ ; I'll warn about other things but treat them as if quoted.
+ ;
+ ; I'm turning off some of the warnings because notably procedures
+ ; and #!unspecified can occur in loaded files and it's a major
+ ; pain if a warning is printed for each. --lars
+ (if (and (not (boolean? exp))
+ (not (number? exp))
+ (not (char? exp))
+ (not (string? exp))
+ (not (procedure? exp))
+ (not (eq? exp (unspecified))))
+ (m-warn "Malformed constant -- should be quoted" exp))
+ (make-constant exp))
+ (else (let ((denotation (syntactic-lookup env exp)))
+ (case (denotation-class denotation)
+ ((special macro)
+ (m-warn "Syntactic keyword used as a variable" exp)
+ ; Syntactic keywords used as variables are treated as #t.
+ (make-constant #t))
+ ((inline)
+ (make-variable (inline-name denotation)))
+ ((identifier)
+ (let ((var (make-variable (identifier-name denotation)))
+ (R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (cons var (R-entry.references R-entry)))
+ var))
+ (else (m-bug "Bug detected by m-atom" exp env)))))))
+
+(define (m-quote exp)
+ (if (and (pair? (cdr exp))
+ (null? (cddr exp)))
+ (make-constant (m-strip (cadr exp)))
+ (m-error "Malformed quoted constant" exp)))
+
+(define (m-lambda exp env)
+ (if (> (safe-length exp) 2)
+
+ (let* ((formals (cadr exp))
+ (alist (rename-vars formals))
+ (env (syntactic-rename env alist))
+ (body (cddr exp)))
+
+ (do ((alist alist (cdr alist)))
+ ((null? alist))
+ (if (assq (caar alist) (cdr alist))
+ (m-error "Malformed parameter list" formals)))
+
+ ; To simplify the run-time system, there's a limit on how many
+ ; fixed arguments can be followed by a rest argument.
+ ; That limit is removed here.
+ ; Bug: documentation slot isn't right when this happens.
+ ; Bug: this generates extremely inefficient code.
+
+ (if (and (not (list? formals))
+ (> (length alist) @maxargs-with-rest-arg@))
+ (let ((TEMP (car (rename-vars '(temp)))))
+ (m-lambda
+ `(,lambda0 ,TEMP
+ ((,lambda0 ,(map car alist)
+ ,@(cddr exp))
+ ,@(do ((actuals '() (cons (list name:CAR path)
+ actuals))
+ (path TEMP (list name:CDR path))
+ (formals formals (cdr formals)))
+ ((symbol? formals)
+ (append (reverse actuals) (list path))))))
+ env))
+ (make-lambda (rename-formals formals alist)
+ '() ; no definitions yet
+ (map (lambda (entry)
+ (cdr (syntactic-lookup env (cdr entry))))
+ alist) ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (make-doc #f
+ (if (list? formals)
+ (length alist)
+ (exact->inexact (- (length alist) 1)))
+ (if (include-variable-names)
+ formals
+ #f)
+ (if (include-source-code)
+ exp
+ #f)
+ source-file-name
+ source-file-position)
+ (m-body body env))))
+
+ (m-error "Malformed lambda expression" exp)))
+
+(define (m-body body env)
+ (define (loop body env defs)
+ (if (null? body)
+ (m-error "Empty body"))
+ (let ((exp (car body)))
+ (if (and (pair? exp)
+ (symbol? (car exp)))
+ (let ((denotation (syntactic-lookup env (car exp))))
+ (case (denotation-class denotation)
+ ((special)
+ (cond ((eq? denotation denotation-of-begin)
+ (loop (append (cdr exp) (cdr body)) env defs))
+ ((eq? denotation denotation-of-define)
+ (loop (cdr body) env (cons exp defs)))
+ (else (finalize-body body env defs))))
+ ((macro)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (loop (cons exp (cdr body))
+ env
+ defs))))
+ ((inline identifier)
+ (finalize-body body env defs))
+ (else (m-bug "Bug detected in m-body" body env))))
+ (finalize-body body env defs))))
+ (loop body env '()))
+
+(define (finalize-body body env defs)
+ (if (null? defs)
+ (let ((body (map (lambda (exp) (m-expand exp env))
+ body)))
+ (if (null? (cdr body))
+ (car body)
+ (make-begin body)))
+ (let ()
+ (define (sort-defs defs)
+ (let* ((augmented
+ (map (lambda (def)
+ (let ((rhs (cadr def)))
+ (if (not (pair? rhs))
+ (cons 'trivial def)
+ (let ((denotation
+ (syntactic-lookup env (car rhs))))
+ (cond ((eq? denotation
+ denotation-of-lambda)
+ (cons 'procedure def))
+ ((eq? denotation
+ denotation-of-quote)
+ (cons 'trivial def))
+ (else
+ (cons 'miscellaneous def)))))))
+ defs))
+ (sorted (twobit-sort (lambda (x y)
+ (or (eq? (car x) 'procedure)
+ (eq? (car y) 'miscellaneous)))
+ augmented)))
+ (map cdr sorted)))
+ (define (desugar-definition def)
+ (if (> (safe-length def) 2)
+ (cond ((pair? (cadr def))
+ (desugar-definition
+ `(,(car def)
+ ,(car (cadr def))
+ (,lambda0
+ ,(cdr (cadr def))
+ ,@(cddr def)))))
+ ((and (= (length def) 3)
+ (symbol? (cadr def)))
+ (cdr def))
+ (else (m-error "Malformed definition" def)))
+ (m-error "Malformed definition" def)))
+ (define (expand-letrec bindings body)
+ (make-call
+ (m-expand
+ `(,lambda0 ,(map car bindings)
+ ,@(map (lambda (binding)
+ `(,set!0 ,(car binding)
+ ,(cadr binding)))
+ bindings)
+ ,@body)
+ env)
+ (map (lambda (binding) (make-unspecified)) bindings)))
+ (expand-letrec (sort-defs (map desugar-definition
+ (reverse defs)))
+ body))))
+
+(define (m-if exp env)
+ (let ((n (safe-length exp)))
+ (if (or (= n 3) (= n 4))
+ (make-conditional (m-expand (cadr exp) env)
+ (m-expand (caddr exp) env)
+ (if (= n 3)
+ (make-unspecified)
+ (m-expand (cadddr exp) env)))
+ (m-error "Malformed if expression" exp))))
+
+(define (m-set exp env)
+ (if (= (safe-length exp) 3)
+ (let ((lhs (m-expand (cadr exp) env))
+ (rhs (m-expand (caddr exp) env)))
+ (if (variable? lhs)
+ (let* ((x (variable.name lhs))
+ (assignment (make-assignment x rhs))
+ (denotation (syntactic-lookup env x)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.references-set!
+ R-entry
+ (remq lhs (R-entry.references R-entry)))
+ (R-entry.assignments-set!
+ R-entry
+ (cons assignment (R-entry.assignments R-entry)))))
+ (if (and (lambda? rhs)
+ (include-procedure-names))
+ (let ((doc (lambda.doc rhs)))
+ (doc.name-set! doc x)))
+ (if pass1-block-compiling?
+ (set! pass1-block-assignments
+ (cons x pass1-block-assignments)))
+ assignment)
+ (m-error "Malformed assignment" exp)))
+ (m-error "Malformed assignment" exp)))
+
+(define (m-begin exp env)
+ (cond ((> (safe-length exp) 1)
+ (make-begin (map (lambda (exp) (m-expand exp env)) (cdr exp))))
+ ((= (safe-length exp) 1)
+ (m-warn "Non-standard begin expression" exp)
+ (make-unspecified))
+ (else
+ (m-error "Malformed begin expression" exp))))
+
+(define (m-application exp env)
+ (if (> (safe-length exp) 0)
+ (let* ((proc (m-expand (car exp) env))
+ (args (map (lambda (exp) (m-expand exp env))
+ (cdr exp)))
+ (call (make-call proc args)))
+ (if (variable? proc)
+ (let* ((procname (variable.name proc))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every1? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ (let ((denotation (syntactic-lookup env procname)))
+ (if (identifier-denotation? denotation)
+ (let ((R-entry (identifier-R-entry denotation)))
+ (R-entry.calls-set!
+ R-entry
+ (cons call (R-entry.calls R-entry)))))
+ call)))
+ call))
+ (m-error "Malformed application" exp)))
+
+; The environment argument should always be global here.
+
+(define (m-define-inline exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (let ((name (cadr exp)))
+ (m-define-syntax1 name
+ (caddr exp)
+ env
+ (define-syntax-scope))
+ (let ((denotation
+ (syntactic-lookup global-syntactic-environment name)))
+ (syntactic-bind-globally!
+ name
+ (make-inline-denotation name
+ (macro-rules denotation)
+ (macro-env denotation))))
+ (make-constant name)))
+ (else
+ (m-error "Malformed define-inline" exp))))
+
+; The environment argument should always be global here.
+
+(define (m-define-syntax exp env)
+ (cond ((and (= (safe-length exp) 3)
+ (symbol? (cadr exp)))
+ (m-define-syntax1 (cadr exp)
+ (caddr exp)
+ env
+ (define-syntax-scope)))
+ ((and (= (safe-length exp) 4)
+ (symbol? (cadr exp))
+ ; FIXME: should use denotations here
+ (memq (caddr exp) '(letrec letrec* let*)))
+ (m-define-syntax1 (cadr exp)
+ (cadddr exp)
+ env
+ (caddr exp)))
+ (else (m-error "Malformed define-syntax" exp))))
+
+(define (m-define-syntax1 keyword spec env scope)
+ (if (and (pair? spec)
+ (symbol? (car spec)))
+ (let* ((transformer-keyword (car spec))
+ (denotation (syntactic-lookup env transformer-keyword)))
+ (cond ((eq? denotation denotation-of-syntax-rules)
+ (case scope
+ ((letrec) (m-define-syntax-letrec keyword spec env))
+ ((letrec*) (m-define-syntax-letrec* keyword spec env))
+ ((let*) (m-define-syntax-let* keyword spec env))
+ (else (m-bug "Weird scope" scope))))
+ ((same-denotation? denotation denotation-of-transformer)
+ ; FIXME: no error checking here
+ (syntactic-bind-globally!
+ keyword
+ (make-macro-denotation (eval (cadr spec)) env)))
+ (else
+ (m-error "Malformed syntax transformer" spec))))
+ (m-error "Malformed syntax transformer" spec))
+ (make-constant keyword))
+
+(define (m-define-syntax-letrec keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec env)))
+
+(define (m-define-syntax-letrec* keyword spec env)
+ (let* ((env (syntactic-extend (syntactic-copy env)
+ (list keyword)
+ '((fake denotation))))
+ (transformer (m-compile-transformer-spec spec env)))
+ (syntactic-assign! env keyword transformer)
+ (syntactic-bind-globally! keyword transformer)))
+
+(define (m-define-syntax-let* keyword spec env)
+ (syntactic-bind-globally!
+ keyword
+ (m-compile-transformer-spec spec (syntactic-copy env))))
+
+(define (m-let-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (m-body (cddr exp)
+ (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (spec)
+ (m-compile-transformer-spec
+ spec
+ env))
+ (map cadr (cadr exp)))))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-letrec-syntax exp env)
+ (if (and (> (safe-length exp) 2)
+ (every1? (lambda (binding)
+ (and (pair? binding)
+ (symbol? (car binding))
+ (pair? (cdr binding))
+ (null? (cddr binding))))
+ (cadr exp)))
+ (let ((env (syntactic-extend env
+ (map car (cadr exp))
+ (map (lambda (id)
+ '(fake denotation))
+ (cadr exp)))))
+ (for-each (lambda (id spec)
+ (syntactic-assign!
+ env
+ id
+ (m-compile-transformer-spec spec env)))
+ (map car (cadr exp))
+ (map cadr (cadr exp)))
+ (m-body (cddr exp) env))
+ (m-error "Malformed let-syntax" exp)))
+
+(define (m-macro exp env)
+ (m-transcribe exp
+ env
+ (lambda (exp env)
+ (m-expand exp env))))
+
+(define (m-inline exp env)
+ (if (integrate-usual-procedures)
+ (m-transcribe-inline exp
+ env
+ (lambda (newexp env)
+ (if (eq? exp newexp)
+ (m-application exp env)
+ (m-expand newexp env))))
+ (m-application exp env)))
+
+(define m-quit ; assigned by macro-expand
+ (lambda (v) v))
+
+; To do:
+; Clean up alist hacking et cetera.
+; Declarations.
+; Integrable procedures.
+; New semantics for body of LET-SYNTAX and LETREC-SYNTAX.
+; Copyright 1992 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 5 April 1999.
+
+($$trace "usual")
+
+; The usual macros, adapted from Jonathan's Version 2 implementation.
+; DEFINE is handled primitively, since top-level DEFINE has a side
+; effect on the global syntactic environment, and internal definitions
+; have to be handled specially anyway.
+;
+; Some extensions are noted, as are some optimizations.
+;
+; The LETREC* scope rule is used here to protect these macros against
+; redefinition of LAMBDA etc. The scope rule is changed to LETREC at
+; the end of this file.
+
+(define-syntax-scope 'letrec*)
+
+(for-each (lambda (form)
+ (macro-expand form))
+ '(
+
+; Named LET is defined later, after LETREC has been defined.
+
+(define-syntax let
+ (syntax-rules ()
+ ((let ((?name ?val) ...) ?body ?body1 ...)
+ ((lambda (?name ...) ?body ?body1 ...) ?val ...))))
+
+(define-syntax let*
+ (syntax-rules ()
+ ((let* () ?body ?body1 ...)
+ (let () ?body ?body1 ...))
+ ((let* ((?name1 ?val1) (?name ?val) ...) ?body ?body1 ...)
+ (let ((?name1 ?val1)) (let* ((?name ?val) ...) ?body ?body1 ...)))))
+
+; Internal definitions have to be handled specially anyway,
+; so we might as well rely on them here.
+
+(define-syntax letrec
+ (syntax-rules (lambda quote)
+ ((letrec ((?name ?val) ...) ?body ?body2 ...)
+ ((lambda ()
+ (define ?name ?val) ...
+ ?body ?body2 ...)))))
+
+; This definition of named LET extends the prior definition of LET.
+; The first rule is non-circular, thanks to the LET* scope that is
+; specified for this use of DEFINE-SYNTAX.
+
+(define-syntax let let*
+ (syntax-rules ()
+ ((let (?bindings ...) . ?body)
+ (let (?bindings ...) . ?body))
+ ((let ?tag ((?name ?val) ...) ?body ?body1 ...)
+ (let ((?name ?val) ...)
+ (letrec ((?tag (lambda (?name ...) ?body ?body1 ...)))
+ (?tag ?name ...))))))
+
+(define-syntax and
+ (syntax-rules ()
+ ((and) #t)
+ ((and ?e) ?e)
+ ((and ?e1 ?e2 ?e3 ...)
+ (if ?e1 (and ?e2 ?e3 ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((or) #f)
+ ((or ?e) ?e)
+ ((or ?e1 ?e2 ?e3 ...)
+ (let ((temp ?e1))
+ (if temp temp (or ?e2 ?e3 ...))))))
+
+(define-syntax cond
+ (syntax-rules (else =>)
+ ((cond (else ?result ?result2 ...))
+ (begin ?result ?result2 ...))
+
+ ((cond (?test => ?result))
+ (let ((temp ?test))
+ (if temp (?result temp))))
+
+ ((cond (?test)) ?test)
+
+ ((cond (?test ?result ?result2 ...))
+ (if ?test (begin ?result ?result2 ...)))
+
+ ((cond (?test => ?result) ?clause ?clause2 ...)
+ (let ((temp ?test))
+ (if temp (?result temp) (cond ?clause ?clause2 ...))))
+
+ ((cond (?test) ?clause ?clause2 ...)
+ (or ?test (cond ?clause ?clause2 ...)))
+
+ ((cond (?test ?result ?result2 ...)
+ ?clause ?clause2 ...)
+ (if ?test
+ (begin ?result ?result2 ...)
+ (cond ?clause ?clause2 ...)))))
+
+; The R4RS says a <step> may be omitted.
+; That's a good excuse for a macro-defining macro that uses LETREC-SYNTAX
+; and the ... escape.
+
+(define-syntax do
+ (syntax-rules ()
+ ((do (?bindings0 ...) (?test) ?body0 ...)
+ (do (?bindings0 ...) (?test (if #f #f)) ?body0 ...))
+ ((do (?bindings0 ...) ?clause0 ?body0 ...)
+ (letrec-syntax
+ ((do-aux
+ (... (syntax-rules ()
+ ((do-aux () ((?name ?init ?step) ...) ?clause ?body ...)
+ (letrec ((loop (lambda (?name ...)
+ (cond ?clause
+ (else
+ (begin #t ?body ...)
+ (loop ?step ...))))))
+ (loop ?init ...)))
+ ((do-aux ((?name ?init ?step) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?step))
+ ?clause
+ ?body ...))
+ ((do-aux ((?name ?init) ?todo ...)
+ (?bindings ...)
+ ?clause
+ ?body ...)
+ (do-aux (?todo ...)
+ (?bindings ... (?name ?init ?name))
+ ?clause
+ ?body ...))))))
+ (do-aux (?bindings0 ...) () ?clause0 ?body0 ...)))))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((delay ?e) (.make-promise (lambda () ?e)))))
+
+; Another use of LETREC-SYNTAX and the escape extension.
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case ?e1 (else ?body ?body2 ...))
+ (begin ?e1 ?body ?body2 ...))
+ ((case ?e1 (?z ?body ?body2 ...))
+ (if (memv ?e1 '?z) (begin ?body ?body2 ...)))
+ ((case ?e1 ?clause1 ?clause2 ?clause3 ...)
+ (letrec-syntax
+ ((case-aux
+ (... (syntax-rules (else)
+ ((case-aux ?temp (else ?body ?body2 ...))
+ (begin ?body ?body2 ...))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...))
+ (if (memv ?temp '(?z ...)) (begin ?body ?body2 ...)))
+ ((case-aux ?temp ((?z ...) ?body ?body2 ...) ?c1 ?c2 ...)
+ (if (memv ?temp '(?z ...))
+ (begin ?body ?body2 ...)
+ (case-aux ?temp ?c1 ?c2 ...)))
+ ; a popular extension
+ ((case-aux ?temp (?z ?body ...) ?c1 ...)
+ (case-aux ?temp ((?z) ?body ...) ?c1 ...))))))
+ (let ((temp ?e1))
+ (case-aux temp ?clause1 ?clause2 ?clause3 ...))))))
+
+; A complete implementation of quasiquote, obtained by translating
+; Jonathan Rees's implementation that was posted to RRRS-AUTHORS
+; on 22 December 1986.
+; Unfortunately, the use of LETREC scope means that it is vulnerable
+; to top-level redefinitions of QUOTE etc. That could be fixed, but
+; it has hair enough already.
+
+(begin
+
+ (define-syntax .finalize-quasiquote letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.finalize-quasiquote quote ?arg ?return)
+ (.interpret-continuation ?return (quote ?arg)))
+ ((.finalize-quasiquote unquote ?arg ?return)
+ (.interpret-continuation ?return ?arg))
+ ((.finalize-quasiquote unquote-splicing ?arg ?return)
+ (syntax-error ",@ in illegal context" ?arg))
+ ((.finalize-quasiquote ?mode ?arg ?return)
+ (.interpret-continuation ?return (?mode . ?arg)))))
+
+ ; The first two "arguments" to .descend-quasiquote and to
+ ; .descend-quasiquote-pair are always identical.
+
+ (define-syntax .descend-quasiquote letrec
+ (syntax-rules (quasiquote unquote unquote-splicing)
+ ((.descend-quasiquote `?y ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x (?level) ?return))
+ ((.descend-quasiquote ,?y ?x () ?return)
+ (.interpret-continuation ?return unquote ?y))
+ ((.descend-quasiquote ,?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote ,@?y ?x () ?return)
+ (.interpret-continuation ?return unquote-splicing ?y))
+ ((.descend-quasiquote ,@?y ?x (?level) ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote (?y . ?z) ?x ?level ?return)
+ (.descend-quasiquote-pair ?x ?x ?level ?return))
+ ((.descend-quasiquote #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote-vector ?x ?x ?level ?return))
+ ((.descend-quasiquote ?y ?x ?level ?return)
+ (.interpret-continuation ?return quote ?x))))
+
+ (define-syntax .descend-quasiquote-pair letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.descend-quasiquote-pair (?carx . ?cdrx) ?x ?level ?return)
+ (.descend-quasiquote ?carx ?carx ?level (1 ?cdrx ?x ?level ?return)))))
+
+ (define-syntax .descend-quasiquote-vector letrec
+ (syntax-rules (quote)
+ ((.descend-quasiquote-vector #(?y ...) ?x ?level ?return)
+ (.descend-quasiquote (?y ...) (?y ...) ?level (6 ?x ?return)))))
+
+ ; Representations for continuations used here.
+ ; Continuation types 0, 1, 2, and 6 take a mode and an expression.
+ ; Continuation types -1, 3, 4, 5, and 7 take just an expression.
+ ;
+ ; (-1)
+ ; means no continuation
+ ; (0)
+ ; means to call .finalize-quasiquote with no further continuation
+ ; (1 ?cdrx ?x ?level ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-pair
+ ; (2 ?car-mode ?car-arg ?x ?return)
+ ; means a return from the second call to .descend-quasiquote in
+ ; in Jonathan's code for .descend-quasiquote-pair
+ ; (3 ?car-arg ?return)
+ ; means take the result and return an append of ?car-arg with it
+ ; (4 ?cdr-mode ?cdr-arg ?return)
+ ; means take the result and call .finalize-quasiquote on ?cdr-mode
+ ; and ?cdr-arg with a continuation of type 5
+ ; (5 ?car-result ?return)
+ ; means take the result and return a cons of ?car-result onto it
+ ; (6 ?x ?return)
+ ; means a return from the call to .descend-quasiquote from
+ ; .descend-quasiquote-vector
+ ; (7 ?return)
+ ; means take the result and return a call of list->vector on it
+
+ (define-syntax .interpret-continuation letrec
+ (syntax-rules (quote unquote unquote-splicing)
+ ((.interpret-continuation (-1) ?e) ?e)
+ ((.interpret-continuation (0) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (-1)))
+ ((.interpret-continuation (1 ?cdrx ?x ?level ?return) ?car-mode ?car-arg)
+ (.descend-quasiquote ?cdrx
+ ?cdrx
+ ?level
+ (2 ?car-mode ?car-arg ?x ?return)))
+ ((.interpret-continuation (2 quote ?car-arg ?x ?return) quote ?cdr-arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return) quote ())
+ (.interpret-continuation ?return unquote ?car-arg))
+ ((.interpret-continuation (2 unquote-splicing ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (3 ?car-arg ?return)))
+ ((.interpret-continuation (2 ?car-mode ?car-arg ?x ?return)
+ ?cdr-mode ?cdr-arg)
+ (.finalize-quasiquote ?car-mode ?car-arg (4 ?cdr-mode ?cdr-arg ?return)))
+
+ ((.interpret-continuation (3 ?car-arg ?return) ?e)
+ (.interpret-continuation ?return append (?car-arg ?e)))
+ ((.interpret-continuation (4 ?cdr-mode ?cdr-arg ?return) ?e1)
+ (.finalize-quasiquote ?cdr-mode ?cdr-arg (5 ?e1 ?return)))
+ ((.interpret-continuation (5 ?e1 ?return) ?e2)
+ (.interpret-continuation ?return .cons (?e1 ?e2)))
+ ((.interpret-continuation (6 ?x ?return) quote ?arg)
+ (.interpret-continuation ?return quote ?x))
+ ((.interpret-continuation (6 ?x ?return) ?mode ?arg)
+ (.finalize-quasiquote ?mode ?arg (7 ?return)))
+ ((.interpret-continuation (7 ?return) ?e)
+ (.interpret-continuation ?return .list->vector (?e)))))
+
+ (define-syntax quasiquote letrec
+ (syntax-rules ()
+ ((quasiquote ?x)
+ (.descend-quasiquote ?x ?x () (0)))))
+ )
+
+(define-syntax let*-syntax
+ (syntax-rules ()
+ ((let*-syntax () ?body)
+ (let-syntax () ?body))
+ ((let*-syntax ((?name1 ?val1) (?name ?val) ...) ?body)
+ (let-syntax ((?name1 ?val1)) (let*-syntax ((?name ?val) ...) ?body)))))
+
+
+ ))
+
+(define-syntax-scope 'letrec)
+
+(define standard-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-standard-syntactic-environment)
+ (syntactic-copy standard-syntactic-environment))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 25 April 1999
+;
+; Given an expression in the subset of Scheme used as an intermediate language
+; by Twobit, returns a newly allocated copy of the expression in which the
+; local variables have been renamed and the referencing information has been
+; recomputed.
+
+(define (copy-exp exp)
+
+ (define special-names (cons name:IGNORED argument-registers))
+
+ (define original-names (make-hashtable symbol-hash assq))
+
+ (define renaming-counter 0)
+
+ (define (rename-vars vars)
+ (let ((rename (make-rename-procedure)))
+ (map (lambda (var)
+ (cond ((memq var special-names)
+ var)
+ ((hashtable-get original-names var)
+ (rename var))
+ (else
+ (hashtable-put! original-names var #t)
+ var)))
+ vars)))
+
+ (define (rename-formals formals newnames)
+ (cond ((null? formals) '())
+ ((symbol? formals) (car newnames))
+ ((memq (car formals) special-names)
+ (cons (car formals)
+ (rename-formals (cdr formals)
+ (cdr newnames))))
+ (else (cons (car newnames)
+ (rename-formals (cdr formals)
+ (cdr newnames))))))
+
+ ; Environments that map symbols to arbitrary information.
+ ; This data type is mutable, and uses the shallow binding technique.
+
+ (define (make-env) (make-hashtable symbol-hash assq))
+
+ (define (env-bind! env sym info)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cons info stack))))
+
+ (define (env-unbind! env sym)
+ (let ((stack (hashtable-get env sym)))
+ (hashtable-put! env sym (cdr stack))))
+
+ (define (env-lookup env sym default)
+ (let ((stack (hashtable-get env sym)))
+ (if stack
+ (car stack)
+ default)))
+
+ (define (env-bind-multiple! env symbols infos)
+ (for-each (lambda (sym info) (env-bind! env sym info))
+ symbols
+ infos))
+
+ (define (env-unbind-multiple! env symbols)
+ (for-each (lambda (sym) (env-unbind! env sym))
+ symbols))
+
+ ;
+
+ (define (lexical-lookup R-table name)
+ (assq name R-table))
+
+ (define (copy exp env notepad R-table)
+ (cond ((constant? exp) exp)
+ ((lambda? exp)
+ (let* ((bvl (make-null-terminated (lambda.args exp)))
+ (newnames (rename-vars bvl))
+ (procnames (map def.lhs (lambda.defs exp)))
+ (newprocnames (rename-vars procnames))
+ (refinfo (map (lambda (var)
+ (make-R-entry var '() '() '()))
+ (append newnames newprocnames)))
+ (newexp
+ (make-lambda
+ (rename-formals (lambda.args exp) newnames)
+ '()
+ refinfo
+ '()
+ '()
+ (lambda.decls exp)
+ (lambda.doc exp)
+ (lambda.body exp))))
+ (env-bind-multiple! env procnames newprocnames)
+ (env-bind-multiple! env bvl newnames)
+ (for-each (lambda (entry)
+ (env-bind! R-table (R-entry.name entry) entry))
+ refinfo)
+ (notepad-lambda-add! notepad newexp)
+ (let ((newnotepad (make-notepad notepad)))
+ (for-each (lambda (name rhs)
+ (lambda.defs-set!
+ newexp
+ (cons (make-definition
+ name
+ (copy rhs env newnotepad R-table))
+ (lambda.defs newexp))))
+ (reverse newprocnames)
+ (map def.rhs
+ (reverse (lambda.defs exp))))
+ (lambda.body-set!
+ newexp
+ (copy (lambda.body exp) env newnotepad R-table))
+ (lambda.F-set! newexp (notepad-free-variables newnotepad))
+ (lambda.G-set! newexp (notepad-captured-variables newnotepad)))
+ (env-unbind-multiple! env procnames)
+ (env-unbind-multiple! env bvl)
+ (for-each (lambda (entry)
+ (env-unbind! R-table (R-entry.name entry)))
+ refinfo)
+ newexp))
+ ((assignment? exp)
+ (let* ((oldname (assignment.lhs exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp
+ (make-assignment name
+ (copy (assignment.rhs exp) env notepad R-table))))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.assignments-set!
+ varinfo
+ (cons newexp (R-entry.assignments varinfo))))
+ newexp))
+ ((conditional? exp)
+ (make-conditional (copy (if.test exp) env notepad R-table)
+ (copy (if.then exp) env notepad R-table)
+ (copy (if.else exp) env notepad R-table)))
+ ((begin? exp)
+ (make-begin (map (lambda (exp) (copy exp env notepad R-table))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (let* ((oldname (variable.name exp))
+ (name (env-lookup env oldname oldname))
+ (varinfo (env-lookup R-table name #f))
+ (newexp (make-variable name)))
+ (notepad-var-add! notepad name)
+ (if varinfo
+ (R-entry.references-set!
+ varinfo
+ (cons newexp (R-entry.references varinfo))))
+ newexp))
+ ((call? exp)
+ (let ((newexp (make-call (copy (call.proc exp) env notepad R-table)
+ (map (lambda (exp)
+ (copy exp env notepad R-table))
+ (call.args exp)))))
+ (if (variable? (call.proc newexp))
+ (let ((varinfo
+ (env-lookup R-table
+ (variable.name
+ (call.proc newexp))
+ #f)))
+ (if varinfo
+ (R-entry.calls-set!
+ varinfo
+ (cons newexp (R-entry.calls varinfo))))))
+ (if (lambda? (call.proc newexp))
+ (notepad-nonescaping-add! notepad (call.proc newexp)))
+ newexp))
+ (else ???)))
+
+ (copy exp (make-env) (make-notepad #f) (make-env)))
+
+; For debugging.
+; Given an expression, traverses the expression to confirm
+; that the referencing invariants are correct.
+
+(define (check-referencing-invariants exp . flags)
+
+ (let ((check-free-variables? (memq 'free flags))
+ (check-referencing? (memq 'reference flags))
+ (first-violation? #t))
+
+ ; env is the list of enclosing lambda expressions,
+ ; beginning with the innermost.
+
+ (define (check exp env)
+ (cond ((constant? exp) (return exp #t))
+ ((lambda? exp)
+ (let ((env (cons exp env)))
+ (return exp
+ (and (every? (lambda (exp)
+ (check exp env))
+ (map def.rhs (lambda.defs exp)))
+ (check (lambda.body exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (subset? (difference
+ (lambda.F exp)
+ (make-null-terminated
+ (lambda.args exp)))
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((env (cons exp env))
+ (R (lambda.R exp)))
+ (every? (lambda (formal)
+ (or (ignored? formal)
+ (R-entry R formal)))
+ (make-null-terminated
+ (lambda.args exp))))
+ #t)))))
+ ((variable? exp)
+ (return exp
+ (and (if (and check-free-variables?
+ (not (null? env)))
+ (memq (variable.name exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (variable.name exp))))
+ (if Rinfo
+ (memq exp (R-entry.references Rinfo))
+ #t))
+ #t))))
+ ((assignment? exp)
+ (return exp
+ (and (check (assignment.rhs exp) env)
+ (if (and check-free-variables?
+ (not (null? env)))
+ (memq (assignment.lhs exp)
+ (lambda.F (car env)))
+ #t)
+ (if check-referencing?
+ (let ((Rinfo (lookup env (assignment.lhs exp))))
+ (if Rinfo
+ (memq exp (R-entry.assignments Rinfo))
+ #t))
+ #t))))
+ ((conditional? exp)
+ (return exp
+ (and (check (if.test exp) env)
+ (check (if.then exp) env)
+ (check (if.else exp) env))))
+ ((begin? exp)
+ (return exp
+ (every? (lambda (exp) (check exp env))
+ (begin.exprs exp))))
+ ((call? exp)
+ (return exp
+ (and (check (call.proc exp) env)
+ (every? (lambda (exp) (check exp env))
+ (call.args exp))
+ (if (and check-referencing?
+ (variable? (call.proc exp)))
+ (let ((Rinfo (lookup env
+ (variable.name
+ (call.proc exp)))))
+ (if Rinfo
+ (memq exp (R-entry.calls Rinfo))
+ #t))
+ #t))))
+ (else ???)))
+
+ (define (return exp flag)
+ (cond (flag
+ #t)
+ (first-violation?
+ (set! first-violation? #f)
+ (display "Violation of referencing invariants")
+ (newline)
+ (pretty-print (make-readable exp))
+ #f)
+ (else (pretty-print (make-readable exp))
+ #f)))
+
+ (define (lookup env I)
+ (if (null? env)
+ #f
+ (let ((Rinfo (R-entry (lambda.R (car env)) I)))
+ (or Rinfo
+ (lookup (cdr env) I)))))
+
+ (if (null? flags)
+ (begin (set! check-free-variables? #t)
+ (set! check-referencing? #t)))
+
+ (check exp '())))
+
+
+; Calculating the free variable information for an expression
+; as output by pass 2. This should be faster than computing both
+; the free variables and the referencing information.
+
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-set '()))
+
+ (define (singleton x) (list x))
+
+ (define (union2 x y) (union x y))
+ (define (union3 x y z) (union x y z))
+
+ (define (set->list set) set)
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (free exp))
+
+; As above, but representing sets as hashtrees.
+; This is commented out because it is much slower than the implementation
+; above. Because the set of free variables is represented as a list
+; within a lambda expression, this implementation must convert the
+; representation for every lambda expression, which is quite expensive
+; for A-normal form.
+
+(begin
+'
+(define (compute-free-variables! exp)
+
+ (define empty-set (make-hashtree symbol-hash assq))
+
+ (define (singleton x)
+ (hashtree-put empty-set x #t))
+
+ (define (make-set values)
+ (if (null? values)
+ empty-set
+ (hashtree-put (make-set (cdr values))
+ (car values)
+ #t)))
+
+ (define (union2 x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-put x key #t)))
+ y)
+ x)
+
+ (define (union3 x y z)
+ (union2 (union2 x y) z))
+
+ (define (apply-union sets)
+ (cond ((null? sets)
+ (make-set '()))
+ ((null? (cdr sets))
+ (car sets))
+ (else
+ (union2 (car sets)
+ (apply-union (cdr sets))))))
+
+ (define (difference x y)
+ (hashtree-for-each (lambda (key val)
+ (set! x (hashtree-remove x key)))
+ y)
+ x)
+
+ (define (set->list set)
+ (hashtree-map (lambda (sym val) sym) set))
+
+ (define (free exp)
+ (cond ((constant? exp) empty-set)
+ ((lambda? exp)
+ (let* ((defs (lambda.defs exp))
+ (formals (make-set
+ (make-null-terminated (lambda.args exp))))
+ (defined (make-set (map def.lhs defs)))
+ (Fdefs
+ (apply-union
+ (map (lambda (def)
+ (free (def.rhs def)))
+ defs)))
+ (Fbody (free (lambda.body exp)))
+ (F (union2 Fdefs Fbody)))
+ (lambda.F-set! exp (set->list F))
+ (lambda.G-set! exp (set->list F))
+ (difference F (union2 formals defined))))
+ ((assignment? exp)
+ (union2 (make-set (list (assignment.lhs exp)))
+ (free (assignment.rhs exp))))
+ ((conditional? exp)
+ (union3 (free (if.test exp))
+ (free (if.then exp))
+ (free (if.else exp))))
+ ((begin? exp)
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (begin.exprs exp))))
+ ((variable? exp)
+ (singleton (variable.name exp)))
+ ((call? exp)
+ (union2 (free (call.proc exp))
+ (apply-union
+ (map (lambda (exp) (free exp))
+ (call.args exp)))))
+ (else ???)))
+
+ (hashtree-map (lambda (sym val) sym)
+ (free exp)))
+#t); Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 24 April 1999
+;
+; First pass of the Twobit compiler:
+; macro expansion, syntax checking, alpha conversion,
+; preliminary annotation.
+;
+; The input to this pass is a Scheme definition or expression.
+; The output is an expression in the subset of Scheme described
+; by the following grammar, where the output satisfies certain
+; additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the output:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+; * F and G are garbage.
+
+($$trace "pass1")
+
+(define source-file-name #f)
+(define source-file-position #f)
+
+(define pass1-block-compiling? #f)
+(define pass1-block-assignments '())
+(define pass1-block-inlines '())
+
+(define (pass1 def-or-exp . rest)
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (set! renaming-counter 0)
+ (macro-expand def-or-exp))
+
+; Compiles a whole sequence of top-level forms on the assumption
+; that no variable that is defined by a form in the sequence is
+; ever defined or assigned outside of the sequence.
+;
+; This is a crock in three parts:
+;
+; 1. Macro-expand each form and record assignments.
+; 2. Find the top-level variables that are defined but not
+; assigned, give them local names, generate a DEFINE-INLINE
+; for each of the top-level procedures, and macro-expand
+; each form again.
+; 3. Wrap the whole mess in an appropriate LET and recompute
+; the referencing information by copying it.
+;
+; Note that macros get expanded twice, and that all DEFINE-SYNTAX
+; macros are considered local to the forms.
+
+; FIXME: Need to turn off warning messages.
+
+(define (pass1-block forms . rest)
+
+ (define (part1)
+ (set! pass1-block-compiling? #t)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings))
+ (defined '()))
+ (define (make-toplevel-definition id exp)
+ (cond ((memq id defined)
+ (set! pass1-block-assignments
+ (cons id pass1-block-assignments)))
+ ((or (constant? exp)
+ (and (lambda? exp)
+ (list? (lambda.args exp))))
+ (set! defined (cons id defined))))
+ (make-begin
+ (list (make-assignment id exp)
+ (make-constant id))))
+ (benchmark-mode #f)
+ (issue-warnings #f)
+ (for-each (lambda (form)
+ (desugar-definitions form
+ global-syntactic-environment
+ make-toplevel-definition))
+ forms)
+ (set! global-syntactic-environment env0)
+ (benchmark-mode bmode)
+ (issue-warnings wmode)
+ (part2 (filter (lambda (id)
+ (not (memq id pass1-block-assignments)))
+ (reverse defined)))))
+
+ (define (part2 defined)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (set! renaming-counter 0)
+ (let* ((rename (make-rename-procedure))
+ (alist (map (lambda (id)
+ (cons id (rename id)))
+ defined))
+ (definitions0 '()) ; for constants
+ (definitions1 '())) ; for lambda expressions
+ (define (make-toplevel-definition id exp)
+ (if (lambda? exp)
+ (doc.name-set! (lambda.doc exp) id))
+ (let ((probe (assq id alist)))
+ (if probe
+ (let ((id1 (cdr probe)))
+ (cond ((constant? exp)
+ (set! definitions0
+ (cons (make-assignment id exp)
+ definitions0))
+ (make-constant id))
+ ((lambda? exp)
+ (set! definitions1
+ (cons (make-assignment id1 exp)
+ definitions1))
+ (make-assignment
+ id
+ (make-lambda (lambda.args exp)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ (lambda.doc exp)
+ (make-call
+ (make-variable id1)
+ (map make-variable
+ (lambda.args exp))))))
+ (else
+ (m-error "Inconsistent macro expansion"
+ (make-readable exp)))))
+ (make-assignment id exp))))
+ (let ((env0 (syntactic-copy global-syntactic-environment))
+ (bmode (benchmark-mode))
+ (wmode (issue-warnings)))
+ (issue-warnings #f)
+ (for-each (lambda (pair)
+ (let ((id0 (car pair))
+ (id1 (cdr pair)))
+ (syntactic-bind-globally!
+ id0
+ (make-inline-denotation
+ id0
+ (lambda (exp rename compare)
+ ; Deliberately non-hygienic!
+ (cons id1 (cdr exp)))
+ global-syntactic-environment))
+ (set! pass1-block-inlines
+ (cons id0 pass1-block-inlines))))
+ alist)
+ (benchmark-mode #f)
+ (issue-warnings wmode)
+ (let ((forms
+ (do ((forms forms (cdr forms))
+ (newforms '()
+ (cons (desugar-definitions
+ (car forms)
+ global-syntactic-environment
+ make-toplevel-definition)
+ newforms)))
+ ((null? forms)
+ (reverse newforms)))))
+ (benchmark-mode bmode)
+ (set! global-syntactic-environment env0)
+ (part3 alist definitions0 definitions1 forms)))))
+
+ (define (part3 alist definitions0 definitions1 forms)
+ (set! pass1-block-compiling? #f)
+ (set! pass1-block-assignments '())
+ (set! pass1-block-inlines '())
+ (let* ((constnames0 (map assignment.lhs definitions0))
+ (constnames1 (map (lambda (id0)
+ (cdr (assq id0 alist)))
+ constnames0))
+ (procnames1 (map assignment.lhs definitions1)))
+ (copy-exp
+ (make-call
+ (make-lambda
+ constnames1
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin
+ (list
+ (make-begin
+ (cons (make-constant #f)
+ (reverse
+ (map (lambda (id)
+ (make-assignment id (make-variable (cdr (assq id alist)))))
+ constnames0))))
+ (make-call
+ (make-lambda
+ constnames0
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-call
+ (make-lambda
+ (map assignment.lhs definitions1)
+ '() ; no definitions
+ '() ; R
+ '() ; F
+ '() ; G
+ '() ; decls
+ #f ; doc
+ (make-begin (cons (make-constant #f)
+ (append definitions1 forms))))
+ (map (lambda (ignored) (make-unspecified))
+ definitions1)))
+ (map make-variable constnames1))
+ )))
+ (map assignment.rhs definitions0)))))
+
+ (set! source-file-name #f)
+ (set! source-file-position #f)
+ (if (not (null? rest))
+ (begin (set! source-file-name (car rest))
+ (if (not (null? (cdr rest)))
+ (set! source-file-position (cadr rest)))))
+ (part1))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Support for intraprocedural value numbering:
+; set of available expressions
+; miscellaneous
+;
+; The set of available expressions is represented as a
+; mutable abstract data type Available with these operations:
+;
+; make-available-table: -> Available
+; copy-available-table: Available -> Available
+; available-expression: Available x Expr -> (symbol + {#f})
+; available-variable: Available x symbol -> Expr
+; available-extend!: Available x symbol x Expr x Killer ->
+; available-kill!: Available x Killer ->
+;
+; where Expr is of the form
+;
+; Expr --> W
+; | (W_0 W_1 ...)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; and Killer is a fixnum, as defined later in this file.
+;
+; (make-available-table)
+; returns an empty table of available expressions.
+; (copy-available-table available)
+; copies the given table.
+; (available-expression available E)
+; returns the name of E if it is available in the table, else #f.
+; (available-variable available T)
+; returns a constant or variable to use in place of T, else #f.
+; (available-extend! available T E K)
+; adds the binding (T E) to the table, with Killer K.
+; If E is a variable and this binding is never killed, then copy
+; propagation will replace uses of T by uses of E; otherwise
+; commoning will replace uses of E by uses of T, until the
+; binding is killed.
+; (available-kill! available K)
+; removes all bindings whose Killer intersects K.
+;
+; (available-extend! available T E K) is very fast if the previous
+; operation on the table was (available-expression available E).
+
+; Implementation.
+;
+; Quick and dirty.
+; The available expressions are represented as a vector of 2 association
+; lists. The first list is used for common subexpression elimination,
+; and the second is used for copy and constant propagation.
+;
+; Each element of the first list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (E T K).
+;
+; Each element of the second list is a binding of
+; a symbol T to an expression E, with killer K,
+; represented by the list (T E K).
+; The expression E will be a constant or variable.
+
+(define (make-available-table)
+ (vector '() '()))
+
+(define (copy-available-table available)
+ (vector (vector-ref available 0)
+ (vector-ref available 1)))
+
+(define (available-expression available E)
+ (let ((binding (assoc E (vector-ref available 0))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-variable available T)
+ (let ((binding (assq T (vector-ref available 1))))
+ (if binding
+ (cadr binding)
+ #f)))
+
+(define (available-extend! available T E K)
+ (cond ((constant? E)
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ ((and (variable? E)
+ (eq? K available:killer:none))
+ (vector-set! available
+ 1
+ (cons (list T E K)
+ (vector-ref available 1))))
+ (else
+ (vector-set! available
+ 0
+ (cons (list E T K)
+ (vector-ref available 0))))))
+
+(define (available-kill! available K)
+ (vector-set! available
+ 0
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 0)))
+ (vector-set! available
+ 1
+ (filter (lambda (binding)
+ (zero?
+ (logand K
+ (caddr binding))))
+ (vector-ref available 1))))
+
+(define (available-intersect! available0 available1 available2)
+ (vector-set! available0
+ 0
+ (intersection (vector-ref available1 0)
+ (vector-ref available2 0)))
+ (vector-set! available0
+ 1
+ (intersection (vector-ref available1 1)
+ (vector-ref available2 1))))
+
+; The Killer concrete data type, represented as a fixnum.
+;
+; The set of side effects that can kill an available expression
+; are a subset of
+;
+; assignments to global variables
+; uses of SET-CAR!
+; uses of SET-CDR!
+; uses of STRING-SET!
+; uses of VECTOR-SET!
+;
+; This list is not complete. If we were trying to perform common
+; subexpression elimination on calls to PEEK-CHAR, for example,
+; then those calls would be killed by reads.
+
+(define available:killer:globals 2)
+(define available:killer:car 4)
+(define available:killer:cdr 8)
+(define available:killer:string 16) ; also bytevectors etc
+(define available:killer:vector 32) ; also structures etc
+(define available:killer:cell 64)
+(define available:killer:io 128)
+(define available:killer:none 0) ; none of the above
+(define available:killer:all 1022) ; all of the above
+
+(define available:killer:immortal 0) ; never killed
+(define available:killer:dead 1023) ; never available
+
+
+
+(define (available:killer-combine k1 k2)
+ (logior k1 k2))
+
+; Miscellaneous.
+
+; A simple lambda expression has no internal definitions at its head
+; and no declarations aside from A-normal form.
+
+(define (simple-lambda? L)
+ (and (null? (lambda.defs L))
+ (every? (lambda (decl)
+ (eq? decl A-normal-form-declaration))
+ (lambda.decls L))))
+
+; A real call is a call whose procedure expression is
+; neither a lambda expression nor a primop.
+
+(define (real-call? E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (not (lambda? proc))
+ (or (not (variable? proc))
+ (let ((f (variable.name proc)))
+ (or (not (integrate-usual-procedures))
+ (not (prim-entry f)))))))))
+
+(define (prim-call E)
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc))))))
+
+(define (no-side-effects? E)
+ (or (constant? E)
+ (variable? E)
+ (lambda? E)
+ (and (conditional? E)
+ (no-side-effects? (if.test E))
+ (no-side-effects? (if.then E))
+ (no-side-effects? (if.else E)))
+ (and (call? E)
+ (let ((proc (call.proc E)))
+ (and (variable? proc)
+ (integrate-usual-procedures)
+ (let ((entry (prim-entry (variable.name proc))))
+ (and entry
+ (not (eq? available:killer:dead
+ (prim-lives-until entry))))))))))
+
+; Given a local variable, the expression within its scope, and
+; a list of local variables that are known to be used only once,
+; returns #t if the variable is used only once.
+;
+; The purpose of this routine is to recognize temporaries that
+; may once have had two or more uses because of CSE, but now have
+; only one use because of further CSE followed by dead code elimination.
+
+(define (temporary-used-once? T E used-once)
+ (cond ((call? E)
+ (let ((proc (call.proc E))
+ (args (call.args E)))
+ (or (and (lambda? proc)
+ (not (memq T (lambda.F proc)))
+ (and (pair? args)
+ (null? (cdr args))
+ (temporary-used-once? T (car args) used-once)))
+ (do ((exprs (cons proc (call.args E))
+ (cdr exprs))
+ (n 0
+ (let ((exp (car exprs)))
+ (cond ((constant? exp)
+ n)
+ ((variable? exp)
+ (if (eq? T (variable.name exp))
+ (+ n 1)
+ n))
+ (else
+ ; Terminate the loop and return #f.
+ 2)))))
+ ((or (null? exprs)
+ (> n 1))
+ (= n 1))))))
+ (else
+ (memq T used-once))))
+
+; Register bindings.
+
+(define (make-regbinding lhs rhs use)
+ (list lhs rhs use))
+
+(define (regbinding.lhs x) (car x))
+(define (regbinding.rhs x) (cadr x))
+(define (regbinding.use x) (caddr x))
+
+; Given a list of register bindings, an expression E and its free variables F,
+; returns two values:
+; E with the register bindings wrapped around it
+; the free variables of the wrapped expression
+
+(define (wrap-with-register-bindings regbindings E F)
+ (if (null? regbindings)
+ (values E F)
+ (let* ((regbinding (car regbindings))
+ (R (regbinding.lhs regbinding))
+ (x (regbinding.rhs regbinding)))
+ (wrap-with-register-bindings
+ (cdr regbindings)
+ (make-call (make-lambda (list R)
+ '()
+ '()
+ F
+ F
+ (list A-normal-form-declaration)
+ #f
+ E)
+ (list (make-variable x)))
+ (union (list x)
+ (difference F (list R)))))))
+
+; Returns two values:
+; the subset of regbindings that have x as their right hand side
+; the rest of regbindings
+
+(define (register-bindings regbindings x)
+ (define (loop regbindings to-x others)
+ (cond ((null? regbindings)
+ (values to-x others))
+ ((eq? x (regbinding.rhs (car regbindings)))
+ (loop (cdr regbindings)
+ (cons (car regbindings) to-x)
+ others))
+ (else
+ (loop (cdr regbindings)
+ to-x
+ (cons (car regbindings) others)))))
+ (loop regbindings '() '()))
+
+; This procedure is called when the compiler can tell that an assertion
+; is never true.
+
+(define (declaration-error E)
+ (if (issue-warnings)
+ (begin (display "WARNING: Assertion is false: ")
+ (write (make-readable E #t))
+ (newline))))
+; Representations, which form a subtype hierarchy.
+;
+; <rep> ::= <fixnum> | (<fixnum> <datum> ...)
+;
+; (<rep> <datum> ...) is a subtype of <rep>, but the non-fixnum
+; representations are otherwise interpreted by arbitrary code.
+
+(define *nreps* 0)
+(define *rep-encodings* '())
+(define *rep-decodings* '())
+(define *rep-subtypes* '())
+(define *rep-joins* (make-bytevector 0))
+(define *rep-meets* (make-bytevector 0))
+(define *rep-joins-special* '#())
+(define *rep-meets-special* '#())
+
+(define (representation-error msg . stuff)
+ (apply error
+ (if (string? msg)
+ (string-append "Bug in flow analysis: " msg)
+ msg)
+ stuff))
+
+(define (symbol->rep sym)
+ (let ((probe (assq sym *rep-encodings*)))
+ (if probe
+ (cdr probe)
+ (let ((rep *nreps*))
+ (set! *nreps* (+ *nreps* 1))
+ (if (> *nreps* 255)
+ (representation-error "Too many representation types"))
+ (set! *rep-encodings*
+ (cons (cons sym rep)
+ *rep-encodings*))
+ (set! *rep-decodings*
+ (cons (cons rep sym)
+ *rep-decodings*))
+ rep))))
+
+(define (rep->symbol rep)
+ (if (pair? rep)
+ (cons (rep->symbol (car rep)) (cdr rep))
+ (let ((probe (assv rep *rep-decodings*)))
+ (if probe
+ (cdr probe)
+ 'unknown))))
+
+(define (representation-table table)
+ (map (lambda (row)
+ (map (lambda (x)
+ (if (list? x)
+ (map symbol->rep x)
+ x))
+ row))
+ table))
+
+; DEFINE-SUBTYPE is how representation types are defined.
+
+(define (define-subtype sym1 sym2)
+ (let* ((rep2 (symbol->rep sym2))
+ (rep1 (symbol->rep sym1)))
+ (set! *rep-subtypes*
+ (cons (cons rep1 rep2)
+ *rep-subtypes*))
+ sym1))
+
+; COMPUTE-TYPE-STRUCTURE! must be called before DEFINE-INTERSECTION.
+
+(define (define-intersection sym1 sym2 sym3)
+ (let ((rep1 (symbol->rep sym1))
+ (rep2 (symbol->rep sym2))
+ (rep3 (symbol->rep sym3)))
+ (representation-aset! *rep-meets* rep1 rep2 rep3)
+ (representation-aset! *rep-meets* rep2 rep1 rep3)))
+
+;
+
+(define (representation-aref bv i j)
+ (bytevector-ref bv (+ (* *nreps* i) j)))
+
+(define (representation-aset! bv i j x)
+ (bytevector-set! bv (+ (* *nreps* i) j) x))
+
+(define (compute-unions!)
+
+ ; Always define a bottom element.
+
+ (for-each (lambda (sym)
+ (define-subtype 'bottom sym))
+ (map car *rep-encodings*))
+
+ (let* ((debugging? #f)
+ (n *nreps*)
+ (n^2 (* n n))
+ (matrix (make-bytevector n^2)))
+
+ ; This code assumes there will always be a top element.
+
+ (define (lub rep1 rep2 subtype?)
+ (do ((i 0 (+ i 1))
+ (bounds '()
+ (if (and (subtype? rep1 i)
+ (subtype? rep2 i))
+ (cons i bounds)
+ bounds)))
+ ((= i n)
+ (car (twobit-sort subtype? bounds)))))
+
+ (define (join i j)
+ (lub i j (lambda (rep1 rep2)
+ (= 1 (representation-aref matrix rep1 rep2)))))
+
+ (define (compute-transitive-closure!)
+ (let ((changed? #f))
+ (define (loop)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((k 0 (+ k 1)))
+ ((= k n))
+ (do ((j 0 (+ j 1))
+ (sum 0
+ (logior sum
+ (logand
+ (representation-aref matrix i j)
+ (representation-aref matrix j k)))))
+ ((= j n)
+ (if (> sum 0)
+ (let ((x (representation-aref matrix i k)))
+ (if (zero? x)
+ (begin
+ (set! changed? #t)
+ (representation-aset! matrix i k 1)))))))))
+ (if changed?
+ (begin (set! changed? #f)
+ (loop))))
+ (loop)))
+
+ (define (compute-joins!)
+ (let ((default (lambda (x y)
+ (error "Compiler bug: special meet or join" x y))))
+ (set! *rep-joins-special* (make-vector n default))
+ (set! *rep-meets-special* (make-vector n default)))
+ (set! *rep-joins* (make-bytevector n^2))
+ (set! *rep-meets* (make-bytevector n^2))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-joins*
+ i
+ j
+ (join i j)))))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! matrix i j 0))
+ (representation-aset! matrix i i 1))
+ (for-each (lambda (subtype)
+ (let ((rep1 (car subtype))
+ (rep2 (cdr subtype)))
+ (representation-aset! matrix rep1 rep2 1)))
+ *rep-subtypes*)
+ (compute-transitive-closure!)
+ (if debugging?
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (write-char #\space)
+ (write (representation-aref matrix i j)))
+ (newline)))
+ (compute-joins!)
+ (set! *rep-subtypes* '())))
+
+; Intersections are not dual to unions because a conservative analysis
+; must always err on the side of the larger subtype.
+; COMPUTE-UNIONS! must be called before COMPUTE-INTERSECTIONS!.
+
+(define (compute-intersections!)
+ (let ((n *nreps*))
+
+ (define (meet i j)
+ (let ((k (representation-union i j)))
+ (if (= i k)
+ j
+ i)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (representation-aset! *rep-meets*
+ i
+ j
+ (meet i j))))))
+
+(define (compute-type-structure!)
+ (compute-unions!)
+ (compute-intersections!))
+
+(define (representation-subtype? rep1 rep2)
+ (equal? rep2 (representation-union rep1 rep2)))
+
+(define (representation-union rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-joins* rep1 rep2)
+ (representation-union rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-union (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-joins-special* r1) rep1 rep2)
+ (representation-union r1 r2))))))
+
+(define (representation-intersection rep1 rep2)
+ (if (fixnum? rep1)
+ (if (fixnum? rep2)
+ (representation-aref *rep-meets* rep1 rep2)
+ (representation-intersection rep1 (car rep2)))
+ (if (fixnum? rep2)
+ (representation-intersection (car rep1) rep2)
+ (let ((r1 (car rep1))
+ (r2 (car rep2)))
+ (if (= r1 r2)
+ ((vector-ref *rep-meets-special* r1) rep1 rep2)
+ (representation-intersection r1 r2))))))
+
+; For debugging.
+
+(define (display-unions-and-intersections)
+ (let* ((column-width 10)
+ (columns/row (quotient 80 column-width)))
+
+ (define (display-symbol sym)
+ (let* ((s (symbol->string sym))
+ (n (string-length s)))
+ (if (< n column-width)
+ (begin (display s)
+ (display (make-string (- column-width n) #\space)))
+ (begin (display (substring s 0 (- column-width 1)))
+ (write-char #\space)))))
+
+ ; Display columns i to n.
+
+ (define (display-matrix f i n)
+ (display (make-string column-width #\space))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol i)))
+ (newline)
+ (newline)
+ (do ((k 0 (+ k 1)))
+ ((= k *nreps*))
+ (display-symbol (rep->symbol k))
+ (do ((i i (+ i 1)))
+ ((= i n))
+ (display-symbol (rep->symbol (f k i))))
+ (newline))
+ (newline)
+ (newline))
+
+ (display "Unions:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-union
+ i
+ (min *nreps* (+ i columns/row))))
+
+ (display "Intersections:")
+ (newline)
+ (newline)
+
+ (do ((i 0 (+ i columns/row)))
+ ((>= i *nreps*))
+ (display-matrix representation-intersection
+ i
+ (min *nreps* (+ i columns/row))))))
+
+; Operations that can be specialized.
+;
+; Format: (<name> (<arg-rep> ...) <specific-name>)
+
+(define (rep-specific? f rs)
+ (rep-match f rs rep-specific caddr))
+
+; Operations whose result has some specific representation.
+;
+; Format: (<name> (<arg-rep> ...) (<result-rep>))
+
+(define (rep-result? f rs)
+ (rep-match f rs rep-result caaddr))
+
+; Unary predicates that give information about representation.
+;
+; Format: (<name> <rep-if-true> <rep-if-false>)
+
+(define (rep-if-true f rs)
+ (rep-match f rs rep-informing caddr))
+
+(define (rep-if-false f rs)
+ (rep-match f rs rep-informing cadddr))
+
+; Given the name of an integrable primitive,
+; the representations of its arguments,
+; a representation table, and a selector function
+; finds the most type-specific row of the table that matches both
+; the name of the primitive and the representations of its arguments,
+; and returns the result of applying the selector to that row.
+; If no row matches, then REP-MATCH returns #f.
+;
+; FIXME: This should be more efficient, and should prefer the most
+; specific matches.
+
+(define (rep-match f rs table selector)
+ (let ((n (length rs)))
+ (let loop ((entries table))
+ (cond ((null? entries)
+ #f)
+ ((eq? f (car (car entries)))
+ (let ((rs0 (cadr (car entries))))
+ (if (and (= n (length rs0))
+ (every? (lambda (r1+r2)
+ (let ((r1 (car r1+r2))
+ (r2 (cdr r1+r2)))
+ (representation-subtype? r1 r2)))
+ (map cons rs rs0)))
+ (selector (car entries))
+ (loop (cdr entries)))))
+ (else
+ (loop (cdr entries)))))))
+
+; Abstract interpretation with respect to types and constraints.
+; Returns a representation type.
+
+(define (aeval E types constraints)
+ (cond ((call? E)
+ (let ((proc (call.proc E)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (argtypes (map (lambda (E)
+ (aeval E types constraints))
+ (call.args E)))
+ (type (rep-result? op argtypes)))
+ (if type
+ type
+ rep:object))
+ rep:object)))
+ ((variable? E)
+ (representation-typeof (variable.name E) types constraints))
+ ((constant? E)
+ (representation-of-value (constant.value E)))
+ (else
+ rep:object)))
+
+; If x has representation type t0 in the hash table,
+; and some further constraints
+;
+; x = (op y1 ... yn)
+; x : t1
+; ...
+; x : tk
+;
+; then
+;
+; typeof (x) = op (typeof (y1), ..., typeof (yn))
+; & t0 & t1 & ... & tk
+;
+; where & means intersection and op is the abstraction of op.
+;
+; Also if T : true and T = E then E may give information about
+; the types of other variables. Similarly for T : false.
+
+(define (representation-typeof name types constraints)
+ (let ((t0 (hashtable-fetch types name rep:object))
+ (cs (hashtable-fetch (constraints.table constraints) name '())))
+ (define (loop type cs)
+ (if (null? cs)
+ type
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E (constraint.rhs c)))
+ (cond ((constant? E)
+ (loop (representation-intersection type
+ (constant.value E))
+ cs))
+ ((call? E)
+ (loop (representation-intersection
+ type (aeval E types constraints))
+ cs))
+ (else
+ (loop type cs))))))
+ (loop t0 cs)))
+
+; Constraints.
+;
+; The constraints used by this analysis consist of type constraints
+; together with the available expressions used for commoning.
+;
+; (T E K) T = E until killed by an effect in K
+; (T '<rep> K) T : <rep> until killed by an effect in K
+
+(define (make-constraint T E K)
+ (list T E K))
+
+(define (constraint.lhs c)
+ (car c))
+
+(define (constraint.rhs c)
+ (cadr c))
+
+(define (constraint.killer c)
+ (caddr c))
+
+(define (make-type-constraint T type K)
+ (make-constraint T
+ (make-constant type)
+ K))
+
+; If the new constraint is of the form T = E until killed by K,
+; then there shouldn't be any prior constraints.
+;
+; Otherwise the new constraint is of the form T : t until killed by K.
+; Suppose the prior constraints are
+; T = E until killed by K
+; T : t1 until killed by K1
+; ...
+; T : tn until killed by Kn
+;
+; If there exists i such that ti is a subtype of t and Ki a subset of K,
+; then the new constraint adds no new information and should be ignored.
+; Otherwise compute t' = t1 & ... & tn and K' = K1 | ... | Kn, where
+; & indicates intersection and | indicates union.
+; If K = K' then add the new constraint T : t' until killed by K;
+; otherwise add two new constraints:
+; T : t' until killed by K'
+; T : t until killed by K
+
+(define (constraints-add! types constraints new)
+ (let* ((debugging? #f)
+ (T (constraint.lhs new))
+ (E (constraint.rhs new))
+ (K (constraint.killer new))
+ (cs (constraints-for-variable constraints T)))
+
+ (define (loop type K cs newcs)
+ (if (null? cs)
+ (cons (make-type-constraint T type K) newcs)
+ (let* ((c2 (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c2))
+ (K2 (constraint.killer c2)))
+ (if (constant? E2)
+ (let* ((type2 (constant.value E2))
+ (type3 (representation-intersection type type2)))
+ (cond ((eq? type2 type3)
+ (if (= K2 (logand K K2))
+ (append newcs cs)
+ (loop (representation-intersection type type2)
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs))))
+ ((representation-subtype? type type3)
+ (if (= K (logand K K2))
+ (loop type K cs newcs)
+ (loop type K cs (cons c2 newcs))))
+ (else
+ (loop type3
+ (available:killer-combine K K2)
+ cs
+ (cons c2 newcs)))))
+ (let* ((op (variable.name (call.proc E2)))
+ (args (call.args E2))
+ (argtypes (map (lambda (exp)
+ (aeval exp types constraints))
+ args)))
+ (cond ((representation-subtype? type rep:true)
+ (let ((reps (rep-if-true op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2))))
+ ((representation-subtype? type rep:false)
+ (let ((reps (rep-if-false op argtypes)))
+ (if reps
+ (record-new-reps! args argtypes reps K2)))))
+ (loop type K cs (cons c2 newcs)))))))
+
+ (define (record-new-reps! args argtypes reps K2)
+ (if debugging?
+ (begin (write (list (map make-readable args)
+ (map rep->symbol argtypes)
+ (map rep->symbol reps)))
+ (newline)))
+ (for-each (lambda (arg type0 type1)
+ (if (not (representation-subtype? type0 type1))
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ ; FIXME: In this context, a variable
+ ; should always be local so the hashtable
+ ; operation isn't necessary.
+ (if (hashtable-get types name)
+ (constraints-add!
+ types
+ constraints
+ (make-type-constraint
+ name
+ type1
+ (available:killer-combine K K2)))
+ (cerror
+ "Compiler bug: unexpected global: "
+ name))))))
+ args argtypes reps))
+
+ (if (not (zero? K))
+ (constraints-add-killedby! constraints T K))
+
+ (let* ((table (constraints.table constraints))
+ (cs (hashtable-fetch table T '())))
+ (cond ((constant? E)
+ ; It's a type constraint.
+ (let ((type (constant.value E)))
+ (if debugging?
+ (begin (display T)
+ (display " : ")
+ (display (rep->symbol type))
+ (newline)))
+ (let ((cs (loop type K cs '())))
+ (hashtable-put! table T cs)
+ constraints)))
+ (else
+ (if debugging?
+ (begin (display T)
+ (display " = ")
+ (display (make-readable E #t))
+ (newline)))
+ (if (not (null? cs))
+ (begin
+ (display "Compiler bug: ")
+ (write T)
+ (display " has unexpectedly nonempty constraints")
+ (newline)))
+ (hashtable-put! table T (list (list T E K)))
+ constraints)))))
+
+; Sets of constraints.
+;
+; The set of constraints is represented as (<hashtable> <killedby>),
+; where <hashtable> is a hashtable mapping variables to lists of
+; constraints as above, and <killedby> is a vector mapping basic killers
+; to lists of variables that need to be examined for constraints that
+; are killed by that basic killer.
+
+(define number-of-basic-killers
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((> k available:killer:dead)
+ i)))
+
+(define (constraints.table constraints) (car constraints))
+(define (constraints.killed constraints) (cadr constraints))
+
+(define (make-constraints-table)
+ (list (make-hashtable symbol-hash assq)
+ (make-vector number-of-basic-killers '())))
+
+(define (copy-constraints-table constraints)
+ (list (hashtable-copy (constraints.table constraints))
+ (list->vector (vector->list (constraints.killed constraints)))))
+
+(define (constraints-for-variable constraints T)
+ (hashtable-fetch (constraints.table constraints) T '()))
+
+(define (constraints-add-killedby! constraints T K0)
+ (if (not (zero? K0))
+ (let ((v (constraints.killed constraints)))
+ (do ((i 0 (+ i 1))
+ (k 1 (+ k k)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand k K0)))
+ (vector-set! v i (cons T (vector-ref v i))))))))
+
+(define (constraints-kill! constraints K)
+ (if (not (zero? K))
+ (let ((table (constraints.table constraints))
+ (killed (constraints.killed constraints)))
+ (define (examine! T)
+ (let ((cs (filter (lambda (c)
+ (zero? (logand (constraint.killer c) K)))
+ (hashtable-fetch table T '()))))
+ (if (null? cs)
+ (hashtable-remove! table T)
+ (hashtable-put! table T cs))))
+ (do ((i 0 (+ i 1))
+ (j 1 (+ j j)))
+ ((= i number-of-basic-killers))
+ (if (not (zero? (logand j K)))
+ (begin (for-each examine! (vector-ref killed i))
+ (vector-set! killed i '())))))))
+
+(define (constraints-intersect! constraints0 constraints1 constraints2)
+ (let ((table0 (constraints.table constraints0))
+ (table1 (constraints.table constraints1))
+ (table2 (constraints.table constraints2)))
+ (if (eq? table0 table1)
+ ; FIXME: Which is more efficient: to update the killed vector,
+ ; or not to update it? Both are safe.
+ (hashtable-for-each (lambda (T cs)
+ (if (not (null? cs))
+ (hashtable-put!
+ table0
+ T
+ (cs-intersect
+ (hashtable-fetch table2 T '())
+ cs))))
+ table1)
+ ; This case shouldn't ever happen, so it can be slow.
+ (begin
+ (constraints-intersect! constraints0 constraints0 constraints1)
+ (constraints-intersect! constraints0 constraints0 constraints2)))))
+
+(define (cs-intersect cs1 cs2)
+ (define (loop cs init rep Krep)
+ (if (null? cs)
+ (values init rep Krep)
+ (let* ((c (car cs))
+ (cs (cdr cs))
+ (E2 (constraint.rhs c))
+ (K2 (constraint.killer c)))
+ (cond ((constant? E2)
+ (loop cs
+ init
+ (representation-intersection rep (constant.value E2))
+ (available:killer-combine Krep K2)))
+ ((call? E2)
+ (if init
+ (begin (display "Compiler bug in cs-intersect")
+ (break))
+ (loop cs c rep Krep)))
+ (else
+ (error "Compiler bug in cs-intersect"))))))
+ (call-with-values
+ (lambda ()
+ (loop cs1 #f rep:object available:killer:none))
+ (lambda (c1 rep1 Krep1)
+ (call-with-values
+ (lambda ()
+ (loop cs2 #f rep:object available:killer:none))
+ (lambda (c2 rep2 Krep2)
+ (let ((c (if (equal? c1 c2) c1 #f))
+ (rep (representation-union rep1 rep2))
+ (Krep (available:killer-combine Krep1 Krep2)))
+ (if (eq? rep rep:object)
+ (if c (list c) '())
+ (let ((T (constraint.lhs (car cs1))))
+ (if c
+ (list c (make-type-constraint T rep Krep))
+ (list (make-type-constraint T rep Krep)))))))))))
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $gc.ephemeral 0)
+(define $gc.tenuring 1)
+(define $gc.full 2)
+(define $mstat.wallocated-hi 0)
+(define $mstat.wallocated-lo 1)
+(define $mstat.wcollected-hi 2)
+(define $mstat.wcollected-lo 3)
+(define $mstat.wcopied-hi 4)
+(define $mstat.wcopied-lo 5)
+(define $mstat.gctime 6)
+(define $mstat.wlive 7)
+(define $mstat.gc-last-gen 8)
+(define $mstat.gc-last-type 9)
+(define $mstat.generations 10)
+(define $mstat.g-gc-count 0)
+(define $mstat.g-prom-count 1)
+(define $mstat.g-gctime 2)
+(define $mstat.g-wlive 3)
+(define $mstat.g-np-youngp 4)
+(define $mstat.g-np-oldp 5)
+(define $mstat.g-np-j 6)
+(define $mstat.g-np-k 7)
+(define $mstat.g-alloc 8)
+(define $mstat.g-target 9)
+(define $mstat.g-promtime 10)
+(define $mstat.remsets 11)
+(define $mstat.r-apool 0)
+(define $mstat.r-upool 1)
+(define $mstat.r-ahash 2)
+(define $mstat.r-uhash 3)
+(define $mstat.r-hrec-hi 4)
+(define $mstat.r-hrec-lo 5)
+(define $mstat.r-hrem-hi 6)
+(define $mstat.r-hrem-lo 7)
+(define $mstat.r-hscan-hi 8)
+(define $mstat.r-hscan-lo 9)
+(define $mstat.r-wscan-hi 10)
+(define $mstat.r-wscan-lo 11)
+(define $mstat.r-ssbrec-hi 12)
+(define $mstat.r-ssbrec-lo 13)
+(define $mstat.r-np-p 14)
+(define $mstat.fflushed-hi 12)
+(define $mstat.fflushed-lo 13)
+(define $mstat.wflushed-hi 14)
+(define $mstat.wflushed-lo 15)
+(define $mstat.stk-created 16)
+(define $mstat.frestored-hi 17)
+(define $mstat.frestored-lo 18)
+(define $mstat.words-heap 19)
+(define $mstat.words-remset 20)
+(define $mstat.words-rts 21)
+(define $mstat.swb-assign 22)
+(define $mstat.swb-lhs-ok 23)
+(define $mstat.swb-rhs-const 24)
+(define $mstat.swb-not-xgen 25)
+(define $mstat.swb-trans 26)
+(define $mstat.rtime 27)
+(define $mstat.stime 28)
+(define $mstat.utime 29)
+(define $mstat.minfaults 30)
+(define $mstat.majfaults 31)
+(define $mstat.np-remsetp 32)
+(define $mstat.max-heap 33)
+(define $mstat.promtime 34)
+(define $mstat.wmoved-hi 35)
+(define $mstat.wmoved-lo 36)
+(define $mstat.vsize 37)
+(define $g.reg0 12)
+(define $r.reg8 44)
+(define $r.reg9 48)
+(define $r.reg10 52)
+(define $r.reg11 56)
+(define $r.reg12 60)
+(define $r.reg13 64)
+(define $r.reg14 68)
+(define $r.reg15 72)
+(define $r.reg16 76)
+(define $r.reg17 80)
+(define $r.reg18 84)
+(define $r.reg19 88)
+(define $r.reg20 92)
+(define $r.reg21 96)
+(define $r.reg22 100)
+(define $r.reg23 104)
+(define $r.reg24 108)
+(define $r.reg25 112)
+(define $r.reg26 116)
+(define $r.reg27 120)
+(define $r.reg28 124)
+(define $r.reg29 128)
+(define $r.reg30 132)
+(define $r.reg31 136)
+(define $g.stkbot 180)
+(define $g.gccnt 420)
+(define $m.alloc 1024)
+(define $m.alloci 1032)
+(define $m.gc 1040)
+(define $m.addtrans 1048)
+(define $m.stkoflow 1056)
+(define $m.stkuflow 1072)
+(define $m.creg 1080)
+(define $m.creg-set! 1088)
+(define $m.add 1096)
+(define $m.subtract 1104)
+(define $m.multiply 1112)
+(define $m.quotient 1120)
+(define $m.remainder 1128)
+(define $m.divide 1136)
+(define $m.modulo 1144)
+(define $m.negate 1152)
+(define $m.numeq 1160)
+(define $m.numlt 1168)
+(define $m.numle 1176)
+(define $m.numgt 1184)
+(define $m.numge 1192)
+(define $m.zerop 1200)
+(define $m.complexp 1208)
+(define $m.realp 1216)
+(define $m.rationalp 1224)
+(define $m.integerp 1232)
+(define $m.exactp 1240)
+(define $m.inexactp 1248)
+(define $m.exact->inexact 1256)
+(define $m.inexact->exact 1264)
+(define $m.make-rectangular 1272)
+(define $m.real-part 1280)
+(define $m.imag-part 1288)
+(define $m.sqrt 1296)
+(define $m.round 1304)
+(define $m.truncate 1312)
+(define $m.apply 1320)
+(define $m.varargs 1328)
+(define $m.typetag 1336)
+(define $m.typetag-set 1344)
+(define $m.break 1352)
+(define $m.eqv 1360)
+(define $m.partial-list->vector 1368)
+(define $m.timer-exception 1376)
+(define $m.exception 1384)
+(define $m.singlestep 1392)
+(define $m.syscall 1400)
+(define $m.bvlcmp 1408)
+(define $m.enable-interrupts 1416)
+(define $m.disable-interrupts 1424)
+(define $m.alloc-bv 1432)
+(define $m.global-ex 1440)
+(define $m.invoke-ex 1448)
+(define $m.global-invoke-ex 1456)
+(define $m.argc-ex 1464)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $r.g0 0)
+(define $r.g1 1)
+(define $r.g2 2)
+(define $r.g3 3)
+(define $r.g4 4)
+(define $r.g5 5)
+(define $r.g6 6)
+(define $r.g7 7)
+(define $r.o0 8)
+(define $r.o1 9)
+(define $r.o2 10)
+(define $r.o3 11)
+(define $r.o4 12)
+(define $r.o5 13)
+(define $r.o6 14)
+(define $r.o7 15)
+(define $r.l0 16)
+(define $r.l1 17)
+(define $r.l2 18)
+(define $r.l3 19)
+(define $r.l4 20)
+(define $r.l5 21)
+(define $r.l6 22)
+(define $r.l7 23)
+(define $r.i0 24)
+(define $r.i1 25)
+(define $r.i2 26)
+(define $r.i3 27)
+(define $r.i4 28)
+(define $r.i5 29)
+(define $r.i6 30)
+(define $r.i7 31)
+(define $r.result $r.o0)
+(define $r.argreg2 $r.o1)
+(define $r.argreg3 $r.o2)
+(define $r.stkp $r.o3)
+(define $r.stklim $r.i0)
+(define $r.tmp1 $r.o4)
+(define $r.tmp2 $r.o5)
+(define $r.tmp0 $r.g1)
+(define $r.e-top $r.i0)
+(define $r.e-limit $r.o3)
+(define $r.timer $r.i4)
+(define $r.millicode $r.i7)
+(define $r.globals $r.i7)
+(define $r.reg0 $r.l0)
+(define $r.reg1 $r.l1)
+(define $r.reg2 $r.l2)
+(define $r.reg3 $r.l3)
+(define $r.reg4 $r.l4)
+(define $r.reg5 $r.l5)
+(define $r.reg6 $r.l6)
+(define $r.reg7 $r.l7)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $ex.car 0)
+(define $ex.cdr 1)
+(define $ex.setcar 2)
+(define $ex.setcdr 3)
+(define $ex.add 10)
+(define $ex.sub 11)
+(define $ex.mul 12)
+(define $ex.div 13)
+(define $ex.lessp 14)
+(define $ex.lesseqp 15)
+(define $ex.equalp 16)
+(define $ex.greatereqp 17)
+(define $ex.greaterp 18)
+(define $ex.quotient 19)
+(define $ex.remainder 20)
+(define $ex.modulo 21)
+(define $ex.logior 22)
+(define $ex.logand 23)
+(define $ex.logxor 24)
+(define $ex.lognot 25)
+(define $ex.lsh 26)
+(define $ex.rsha 27)
+(define $ex.rshl 28)
+(define $ex.e2i 29)
+(define $ex.i2e 30)
+(define $ex.exactp 31)
+(define $ex.inexactp 32)
+(define $ex.round 33)
+(define $ex.trunc 34)
+(define $ex.zerop 35)
+(define $ex.neg 36)
+(define $ex.abs 37)
+(define $ex.realpart 38)
+(define $ex.imagpart 39)
+(define $ex.vref 40)
+(define $ex.vset 41)
+(define $ex.vlen 42)
+(define $ex.pref 50)
+(define $ex.pset 51)
+(define $ex.plen 52)
+(define $ex.sref 60)
+(define $ex.sset 61)
+(define $ex.slen 62)
+(define $ex.bvref 70)
+(define $ex.bvset 71)
+(define $ex.bvlen 72)
+(define $ex.bvlref 80)
+(define $ex.bvlset 81)
+(define $ex.bvllen 82)
+(define $ex.vlref 90)
+(define $ex.vlset 91)
+(define $ex.vllen 92)
+(define $ex.typetag 100)
+(define $ex.typetagset 101)
+(define $ex.apply 102)
+(define $ex.argc 103)
+(define $ex.vargc 104)
+(define $ex.nonproc 105)
+(define $ex.undef-global 106)
+(define $ex.dump 107)
+(define $ex.dumpfail 108)
+(define $ex.timer 109)
+(define $ex.unsupported 110)
+(define $ex.int2char 111)
+(define $ex.char2int 112)
+(define $ex.mkbvl 113)
+(define $ex.mkvl 114)
+(define $ex.char<? 115)
+(define $ex.char<=? 116)
+(define $ex.char=? 117)
+(define $ex.char>? 118)
+(define $ex.char>=? 119)
+(define $ex.bvfill 120)
+(define $ex.enable-interrupts 121)
+(define $ex.keyboard-interrupt 122)
+(define $ex.arithmetic-exception 123)
+(define $ex.global-invoke 124)
+(define $ex.fx+ 140)
+(define $ex.fx- 141)
+(define $ex.fx-- 142)
+(define $ex.fx= 143)
+(define $ex.fx< 144)
+(define $ex.fx<= 145)
+(define $ex.fx> 146)
+(define $ex.fx>= 147)
+(define $ex.fxpositive? 148)
+(define $ex.fxnegative? 149)
+(define $ex.fxzero? 150)
+(define $ex.fx* 151)
+; DO NOT EDIT THIS FILE. Edit the config file and rerun "config".
+
+(define $tag.tagmask 7)
+(define $tag.pair-tag 1)
+(define $tag.vector-tag 3)
+(define $tag.bytevector-tag 5)
+(define $tag.procedure-tag 7)
+(define $imm.vector-header 162)
+(define $imm.bytevector-header 194)
+(define $imm.procedure-header 254)
+(define $imm.true 6)
+(define $imm.false 2)
+(define $imm.null 10)
+(define $imm.unspecified 278)
+(define $imm.eof 534)
+(define $imm.undefined 790)
+(define $imm.character 38)
+(define $tag.vector-typetag 0)
+(define $tag.rectnum-typetag 4)
+(define $tag.ratnum-typetag 8)
+(define $tag.symbol-typetag 12)
+(define $tag.port-typetag 16)
+(define $tag.structure-typetag 20)
+(define $tag.bytevector-typetag 0)
+(define $tag.string-typetag 4)
+(define $tag.flonum-typetag 8)
+(define $tag.compnum-typetag 12)
+(define $tag.bignum-typetag 16)
+(define $hdr.port 178)
+(define $hdr.struct 182)
+(define $p.codevector -3)
+(define $p.constvector 1)
+(define $p.linkoffset 5)
+(define $p.reg0 5)
+(define $p.codeoffset -1)
+; Copyright 1991 William Clinger
+;
+; Relatively target-independent information for Twobit's backend.
+;
+; 24 April 1999 / wdc
+;
+; Most of the definitions in this file can be extended or overridden by
+; target-specific definitions.
+
+(define twobit-sort
+ (lambda (less? list) (compat:sort list less?)))
+
+(define renaming-prefix ".")
+
+; The prefix used for cells introduced by the compiler.
+
+(define cell-prefix (string-append renaming-prefix "CELL:"))
+
+; Names of global procedures that cannot be redefined or assigned
+; by ordinary code.
+; The expansion of quasiquote uses .cons and .list directly, so these
+; should not be changed willy-nilly.
+; Others may be used directly by a DEFINE-INLINE.
+
+(define name:CHECK! '.check!)
+(define name:CONS '.cons)
+(define name:LIST '.list)
+(define name:MAKE-CELL '.make-cell)
+(define name:CELL-REF '.cell-ref)
+(define name:CELL-SET! '.cell-set!)
+(define name:IGNORED (string->symbol "IGNORED"))
+(define name:CAR '.car)
+(define name:CDR '.cdr)
+
+;(begin (eval `(define ,name:CONS cons))
+; (eval `(define ,name:LIST list))
+; (eval `(define ,name:MAKE-CELL list))
+; (eval `(define ,name:CELL-REF car))
+; (eval `(define ,name:CELL-SET! set-car!)))
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures.
+
+(define name:NOT 'not)
+(define name:MEMQ 'memq)
+(define name:MEMV 'memv)
+
+; If (INTEGRATE-USUAL-PROCEDURES) is true, then control optimization
+; recognizes calls to these procedures and also creates calls to them.
+
+(define name:EQ? 'eq?)
+(define name:EQV? 'eqv?)
+
+; Control optimization creates calls to these procedures,
+; which do not need to check their arguments.
+
+(define name:FIXNUM? 'fixnum?)
+(define name:CHAR? 'char?)
+(define name:SYMBOL? 'symbol?)
+(define name:FX< '<:fix:fix)
+(define name:FX- 'fx-) ; non-checking version
+(define name:CHAR->INTEGER 'char->integer) ; non-checking version
+(define name:VECTOR-REF 'vector-ref:trusted)
+
+
+; Constant folding.
+; Prototype, will probably change in the future.
+
+(define (constant-folding-entry name)
+ (assq name $usual-constant-folding-procedures$))
+
+(define constant-folding-predicates cadr)
+(define constant-folding-folder caddr)
+
+(define $usual-constant-folding-procedures$
+ (let ((always? (lambda (x) #t))
+ (charcode? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (<= 0 n)
+ (< n 128))))
+ (ratnum? (lambda (n)
+ (and (number? n)
+ (exact? n)
+ (rational? n))))
+ ; smallint? is defined later.
+ (smallint? (lambda (n) (smallint? n))))
+ `(
+ ; This makes some assumptions about the host system.
+
+ (integer->char (,charcode?) ,integer->char)
+ (char->integer (,char?) ,char->integer)
+ (zero? (,ratnum?) ,zero?)
+ (< (,ratnum? ,ratnum?) ,<)
+ (<= (,ratnum? ,ratnum?) ,<=)
+ (= (,ratnum? ,ratnum?) ,=)
+ (>= (,ratnum? ,ratnum?) ,>=)
+ (> (,ratnum? ,ratnum?) ,>)
+ (+ (,ratnum? ,ratnum?) ,+)
+ (- (,ratnum? ,ratnum?) ,-)
+ (* (,ratnum? ,ratnum?) ,*)
+ (-- (,ratnum?) ,(lambda (x) (- 0 x)))
+ (eq? (,always? ,always?) ,eq?)
+ (eqv? (,always? ,always?) ,eqv?)
+ (equal? (,always? ,always?) ,equal?)
+ (memq (,always? ,list?) ,memq)
+ (memv (,always? ,list?) ,memv)
+ (member (,always? ,list?) ,member)
+ (assq (,always? ,list?) ,assq)
+ (assv (,always? ,list?) ,assv)
+ (assoc (,always? ,list?) ,assoc)
+ (length (,list?) ,length)
+ (fixnum? (,smallint?) ,smallint?)
+ (=:fix:fix (,smallint? ,smallint?) ,=)
+ (<:fix:fix (,smallint? ,smallint?) ,<)
+ (<=:fix:fix (,smallint? ,smallint?) ,<=)
+ (>:fix:fix (,smallint? ,smallint?) ,>)
+ (>=:fix:fix (,smallint? ,smallint?) ,>=)
+ )))
+
+(begin '
+ (define (.check! flag exn . args)
+ (if (not flag)
+ (apply error "Runtime check exception: " exn args)))
+ #t)
+
+; Order matters. If f and g are both inlined, and the definition of g
+; uses f, then f should be defined before g.
+
+(for-each pass1
+ `(
+
+(define-inline car
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.car x)
+ (car:pair x)))))
+
+(define-inline cdr
+ (syntax-rules ()
+ ((car x0)
+ (let ((x x0))
+ (.check! (pair? x) ,$ex.cdr x)
+ (cdr:pair x)))))
+
+(define-inline vector-length
+ (syntax-rules ()
+ ((vector-length v0)
+ (let ((v v0))
+ (.check! (vector? v) ,$ex.vlen v)
+ (vector-length:vec v)))))
+
+(define-inline vector-ref
+ (syntax-rules ()
+ ((vector-ref v0 i0)
+ (let ((v v0)
+ (i i0))
+ (.check! (fixnum? i) ,$ex.vref v i)
+ (.check! (vector? v) ,$ex.vref v i)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vref v i)
+ (.check! (>=:fix:fix i 0) ,$ex.vref v i)
+ (vector-ref:trusted v i)))))
+
+(define-inline vector-set!
+ (syntax-rules ()
+ ((vector-set! v0 i0 x0)
+ (let ((v v0)
+ (i i0)
+ (x x0))
+ (.check! (fixnum? i) ,$ex.vset v i x)
+ (.check! (vector? v) ,$ex.vset v i x)
+ (.check! (<:fix:fix i (vector-length:vec v)) ,$ex.vset v i x)
+ (.check! (>=:fix:fix i 0) ,$ex.vset v i x)
+ (vector-set!:trusted v i x)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to LIST returns more than once.
+
+(define-inline list
+ (syntax-rules ()
+ ((list)
+ '())
+ ((list ?e)
+ (cons ?e '()))
+ ((list ?e1 ?e2 ...)
+ (let* ((t1 ?e1)
+ (t2 (list ?e2 ...)))
+ (cons t1 t2)))))
+
+; This transformation must make sure the entire list is freshly
+; allocated when an argument to VECTOR returns more than once.
+
+(define-inline vector
+ (syntax-rules ()
+ ((vector)
+ '#())
+ ((vector ?e)
+ (make-vector 1 ?e))
+ ((vector ?e1 ?e2 ...)
+ (letrec-syntax
+ ((vector-aux1
+ (... (syntax-rules ()
+ ((vector-aux1 () ?n ?exps ?indexes ?temps)
+ (vector-aux2 ?n ?exps ?indexes ?temps))
+ ((vector-aux1 (?exp1 ?exp2 ...) ?n ?exps ?indexes ?temps)
+ (vector-aux1 (?exp2 ...)
+ (+ ?n 1)
+ (?exp1 . ?exps)
+ (?n . ?indexes)
+ (t . ?temps))))))
+ (vector-aux2
+ (... (syntax-rules ()
+ ((vector-aux2 ?n (?exp1 ?exp2 ...) (?n1 ?n2 ...) (?t1 ?t2 ...))
+ (let* ((?t1 ?exp1)
+ (?t2 ?exp2)
+ ...
+ (v (make-vector ?n ?t1)))
+ (vector-set! v ?n2 ?t2)
+ ...
+ v))))))
+ (vector-aux1 (?e1 ?e2 ...) 0 () () ())))))
+
+(define-inline cadddr
+ (syntax-rules ()
+ ((cadddr ?e)
+ (car (cdr (cdr (cdr ?e)))))))
+
+(define-inline cddddr
+ (syntax-rules ()
+ ((cddddr ?e)
+ (cdr (cdr (cdr (cdr ?e)))))))
+
+(define-inline cdddr
+ (syntax-rules ()
+ ((cdddr ?e)
+ (cdr (cdr (cdr ?e))))))
+
+(define-inline caddr
+ (syntax-rules ()
+ ((caddr ?e)
+ (car (cdr (cdr ?e))))))
+
+(define-inline cddr
+ (syntax-rules ()
+ ((cddr ?e)
+ (cdr (cdr ?e)))))
+
+(define-inline cdar
+ (syntax-rules ()
+ ((cdar ?e)
+ (cdr (car ?e)))))
+
+(define-inline cadr
+ (syntax-rules ()
+ ((cadr ?e)
+ (car (cdr ?e)))))
+
+(define-inline caar
+ (syntax-rules ()
+ ((caar ?e)
+ (car (car ?e)))))
+
+(define-inline make-vector
+ (syntax-rules ()
+ ((make-vector ?n)
+ (make-vector ?n '()))))
+
+(define-inline make-string
+ (syntax-rules ()
+ ((make-string ?n)
+ (make-string ?n #\space))))
+
+(define-inline =
+ (syntax-rules ()
+ ((= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (= ?e1 t)
+ (= t ?e3 ?e4 ...))))))
+
+(define-inline <
+ (syntax-rules ()
+ ((< ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (< ?e1 t)
+ (< t ?e3 ?e4 ...))))))
+
+(define-inline >
+ (syntax-rules ()
+ ((> ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (> ?e1 t)
+ (> t ?e3 ?e4 ...))))))
+
+(define-inline <=
+ (syntax-rules ()
+ ((<= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (<= ?e1 t)
+ (<= t ?e3 ?e4 ...))))))
+
+(define-inline >=
+ (syntax-rules ()
+ ((>= ?e1 ?e2 ?e3 ?e4 ...)
+ (let ((t ?e2))
+ (and (>= ?e1 t)
+ (>= t ?e3 ?e4 ...))))))
+
+(define-inline +
+ (syntax-rules ()
+ ((+)
+ 0)
+ ((+ ?e)
+ ?e)
+ ((+ ?e1 ?e2 ?e3 ?e4 ...)
+ (+ (+ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline *
+ (syntax-rules ()
+ ((*)
+ 1)
+ ((* ?e)
+ ?e)
+ ((* ?e1 ?e2 ?e3 ?e4 ...)
+ (* (* ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline -
+ (syntax-rules ()
+ ((- ?e)
+ (- 0 ?e))
+ ((- ?e1 ?e2 ?e3 ?e4 ...)
+ (- (- ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline /
+ (syntax-rules ()
+ ((/ ?e)
+ (/ 1 ?e))
+ ((/ ?e1 ?e2 ?e3 ?e4 ...)
+ (/ (/ ?e1 ?e2) ?e3 ?e4 ...))))
+
+(define-inline abs
+ (syntax-rules ()
+ ((abs ?z)
+ (let ((temp ?z))
+ (if (< temp 0)
+ (-- temp)
+ temp)))))
+
+(define-inline negative?
+ (syntax-rules ()
+ ((negative? ?x)
+ (< ?x 0))))
+
+(define-inline positive?
+ (syntax-rules ()
+ ((positive? ?x)
+ (> ?x 0))))
+
+(define-inline eqv?
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (define (constant? exp)
+ (or (boolean? exp)
+ (char? exp)
+ (and (pair? exp)
+ (= (length exp) 2)
+ (identifier? (car exp))
+ (compare (car exp) (rename 'quote))
+ (symbol? (cadr exp)))))
+ (if (or (constant? arg1)
+ (constant? arg2))
+ (cons (rename 'eq?) (cdr exp))
+ exp)))))
+
+(define-inline memq
+ (syntax-rules (quote)
+ ((memq ?expr '(?datum ...))
+ (letrec-syntax
+ ((memq0
+ (... (syntax-rules (quote)
+ ((memq0 '?xx '(?d ...))
+ (let ((t1 '(?d ...)))
+ (memq1 '?xx t1 (?d ...))))
+ ((memq0 ?e '(?d ...))
+ (let ((t0 ?e)
+ (t1 '(?d ...)))
+ (memq1 t0 t1 (?d ...)))))))
+ (memq1
+ (... (syntax-rules ()
+ ((memq1 ?t0 ?t1 ())
+ #f)
+ ((memq1 ?t0 ?t1 (?d1 ?d2 ...))
+ (if (eq? ?t0 '?d1)
+ ?t1
+ (let ((?t1 (cdr ?t1)))
+ (memq1 ?t0 ?t1 (?d2 ...)))))))))
+ (memq0 ?expr '(?datum ...))))))
+
+(define-inline memv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (fixnum? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (x)
+ (or (boolean? x)
+ (fixnum? x)
+ (char? x)
+ (symbol? x)))
+ (cadr arg2))))
+ (cons (rename 'memq) (cdr exp))
+ exp)))))
+
+(define-inline assv
+ (transformer
+ (lambda (exp rename compare)
+ (let ((arg1 (cadr exp))
+ (arg2 (caddr exp)))
+ (if (or (boolean? arg1)
+ (char? arg1)
+ (and (pair? arg1)
+ (= (length arg1) 2)
+ (identifier? (car arg1))
+ (compare (car arg1) (rename 'quote))
+ (symbol? (cadr arg1)))
+ (and (pair? arg2)
+ (= (length arg2) 2)
+ (identifier? (car arg2))
+ (compare (car arg2) (rename 'quote))
+ (every1? (lambda (y)
+ (and (pair? y)
+ (let ((x (car y)))
+ (or (boolean? x)
+ (char? x)
+ (symbol? x)))))
+ (cadr arg2))))
+ (cons (rename 'assq) (cdr exp))
+ exp)))))
+
+(define-inline map
+ (syntax-rules (lambda)
+ ((map ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...
+ (results '() (cons (?f (car ?y1) (car ?y2) ...)
+ results)))
+ ((or (null? ?y1) (null? ?y2) ...)
+ (reverse results))))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+(define-inline for-each
+ (syntax-rules (lambda)
+ ((for-each ?proc ?exp1 ?exp2 ...)
+ (letrec-syntax
+ ((loop
+ (... (syntax-rules (lambda)
+ ((loop 1 () (?y1 ?y2 ...) ?f ?exprs)
+ (loop 2 (?y1 ?y2 ...) ?f ?exprs))
+ ((loop 1 (?a1 ?a2 ...) (?y2 ...) ?f ?exprs)
+ (loop 1 (?a2 ...) (y1 ?y2 ...) ?f ?exprs))
+
+ ((loop 2 ?ys (lambda ?formals ?body) ?exprs)
+ (loop 3 ?ys (lambda ?formals ?body) ?exprs))
+ ((loop 2 ?ys (?f1 . ?f2) ?exprs)
+ (let ((f (?f1 . ?f2)))
+ (loop 3 ?ys f ?exprs)))
+ ; ?f must be a constant or variable.
+ ((loop 2 ?ys ?f ?exprs)
+ (loop 3 ?ys ?f ?exprs))
+
+ ((loop 3 (?y1 ?y2 ...) ?f (?e1 ?e2 ...))
+ (do ((?y1 ?e1 (cdr ?y1))
+ (?y2 ?e2 (cdr ?y2))
+ ...)
+ ((or (null? ?y1) (null? ?y2) ...)
+ (if #f #f))
+ (?f (car ?y1) (car ?y2) ...)))))))
+
+ (loop 1 (?exp1 ?exp2 ...) () ?proc (?exp1 ?exp2 ...))))))
+
+))
+
+(define extended-syntactic-environment
+ (syntactic-copy global-syntactic-environment))
+
+(define (make-extended-syntactic-environment)
+ (syntactic-copy extended-syntactic-environment))
+
+; MacScheme machine assembly instructions.
+
+(define instruction.op car)
+(define instruction.arg1 cadr)
+(define instruction.arg2 caddr)
+(define instruction.arg3 cadddr)
+
+; Opcode table.
+
+(define *mnemonic-names* '()) ; For readify-lap
+(begin
+ '
+ (define *last-reserved-mnemonic* 32767) ; For consistency check
+ '
+ (define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (if (= count *last-reserved-mnemonic*)
+ (error "Error in make-mnemonic: conflict: " name))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+ '
+ (define (reserved-mnemonic name value)
+ (if (and (> value 0) (< value *last-reserved-mnemonic*))
+ (set! *last-reserved-mnemonic* value))
+ (set! *mnemonic-names* (cons (cons value name) *mnemonic-names*))
+ value)
+ #t)
+
+(define make-mnemonic
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ count 1))
+ (set! *mnemonic-names* (cons (cons count name) *mnemonic-names*))
+ count)))
+
+(define (reserved-mnemonic name ignored)
+ (make-mnemonic name))
+
+(define $.linearize (reserved-mnemonic '.linearize -1)) ; unused?
+(define $.label (reserved-mnemonic '.label 63))
+(define $.proc (reserved-mnemonic '.proc 62)) ; proc entry point
+(define $.cont (reserved-mnemonic '.cont 61)) ; return point
+(define $.align (reserved-mnemonic '.align 60)) ; align code stream
+(define $.asm (reserved-mnemonic '.asm 59)) ; in-line native code
+(define $.proc-doc ; internal def proc info
+ (reserved-mnemonic '.proc-doc 58))
+(define $.end ; end of code vector
+ (reserved-mnemonic '.end 57)) ; (asm internal)
+(define $.singlestep ; insert singlestep point
+ (reserved-mnemonic '.singlestep 56)) ; (asm internal)
+(define $.entry (reserved-mnemonic '.entry 55)) ; procedure entry point
+ ; (asm internal)
+
+(define $op1 (make-mnemonic 'op1)) ; op prim
+(define $op2 (make-mnemonic 'op2)) ; op2 prim,k
+(define $op3 (make-mnemonic 'op3)) ; op3 prim,k1,k2
+(define $op2imm (make-mnemonic 'op2imm)) ; op2imm prim,x
+(define $const (make-mnemonic 'const)) ; const x
+(define $global (make-mnemonic 'global)) ; global x
+(define $setglbl (make-mnemonic 'setglbl)) ; setglbl x
+(define $lexical (make-mnemonic 'lexical)) ; lexical m,n
+(define $setlex (make-mnemonic 'setlex)) ; setlex m,n
+(define $stack (make-mnemonic 'stack)) ; stack n
+(define $setstk (make-mnemonic 'setstk)) ; setstk n
+(define $load (make-mnemonic 'load)) ; load k,n
+(define $store (make-mnemonic 'store)) ; store k,n
+(define $reg (make-mnemonic 'reg)) ; reg k
+(define $setreg (make-mnemonic 'setreg)) ; setreg k
+(define $movereg (make-mnemonic 'movereg)) ; movereg k1,k2
+(define $lambda (make-mnemonic 'lambda)) ; lambda x,n,doc
+(define $lexes (make-mnemonic 'lexes)) ; lexes n,doc
+(define $args= (make-mnemonic 'args=)) ; args= k
+(define $args>= (make-mnemonic 'args>=)) ; args>= k
+(define $invoke (make-mnemonic 'invoke)) ; invoke k
+(define $save (make-mnemonic 'save)) ; save L,k
+(define $setrtn (make-mnemonic 'setrtn)) ; setrtn L
+(define $restore (make-mnemonic 'restore)) ; restore n ; deprecated
+(define $pop (make-mnemonic 'pop)) ; pop k
+(define $popstk (make-mnemonic 'popstk)) ; popstk ; for students
+(define $return (make-mnemonic 'return)) ; return
+(define $mvrtn (make-mnemonic 'mvrtn)) ; mvrtn ; NYI
+(define $apply (make-mnemonic 'apply)) ; apply
+(define $nop (make-mnemonic 'nop)) ; nop
+(define $jump (make-mnemonic 'jump)) ; jump m,o
+(define $skip (make-mnemonic 'skip)) ; skip L ; forward
+(define $branch (make-mnemonic 'branch)) ; branch L
+(define $branchf (make-mnemonic 'branchf)) ; branchf L
+(define $check (make-mnemonic 'check)) ; check k1,k2,k3,L
+(define $trap (make-mnemonic 'trap)) ; trap k1,k2,k3,exn
+
+; A peephole optimizer may define more instructions in some
+; target-specific file.
+
+; eof
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny -- target-specific information for Twobit's SPARC backend.
+;
+; 11 June 1999 / wdc
+
+; The maximum number of fixed arguments that may be followed by a rest
+; argument. This limitation is removed by the macro expander.
+
+(define @maxargs-with-rest-arg@ 30)
+
+; The number of MacScheme machine registers.
+; (They do not necessarily correspond to hardware registers.)
+
+(define *nregs* 32)
+(define *lastreg* (- *nregs* 1))
+(define *fullregs* (quotient *nregs* 2))
+
+; The number of argument registers that are represented by hardware
+; registers.
+
+(define *nhwregs* 8)
+
+; Variable names that indicate register targets.
+
+(define *regnames*
+ (do ((alist '() (cons (cons (string->symbol
+ (string-append ".REG" (number->string r)))
+ r)
+ alist))
+ (r (- *nhwregs* 1) (- r 1)))
+ ((<= r 0)
+ alist)))
+
+; A non-inclusive upper bound for the instruction encodings.
+
+(define *number-of-mnemonics* 72)
+
+; Integrable procedures and procedure-specific source code transformations.
+; Every integrable procedure that takes a varying number of arguments must
+; supply a transformation procedure to map calls into the fixed arity
+; required by the MacScheme machine instructions.
+
+; The table of integrable procedures.
+; Each entry is a list of the following items:
+;
+; procedure name
+; arity (or -1 for special primops like .check!)
+; procedure name to be used by the disassembler
+; predicate for immediate operands (or #f)
+; primop code in the MacScheme machine (not used by Larceny)
+; the effects that kill this primop's result
+; the effects of this primop that kill available expressions
+
+(define (prim-entry name)
+ (assq name $usual-integrable-procedures$))
+
+(define prim-arity cadr)
+(define prim-opcodename caddr)
+(define prim-immediate? cadddr)
+(define (prim-primcode entry)
+ (car (cddddr entry)))
+
+; This predicate returns #t iff its argument will be represented
+; as a fixnum on the target machine.
+
+(define smallint?
+ (let* ((least (- (expt 2 29)))
+ (greatest (- (- least) 1)))
+ (lambda (x)
+ (and (number? x)
+ (exact? x)
+ (integer? x)
+ (<= least x greatest)))))
+
+(define (sparc-imm? x)
+ (and (fixnum? x)
+ (<= -1024 x 1023)))
+
+(define (sparc-eq-imm? x)
+ (or (sparc-imm? x)
+ (eq? x #t)
+ (eq? x #f)
+ (eq? x '())))
+
+(define (valid-typetag? x)
+ (and (fixnum? x)
+ (<= 0 x 7)))
+
+(define (fixnum-primitives) #t)
+(define (flonum-primitives) #t)
+
+; The table of primitives has been extended with
+; kill information used for commoning.
+
+(define (prim-lives-until entry)
+ (list-ref entry 5))
+
+(define (prim-kills entry)
+ (list-ref entry 6))
+
+(define $usual-integrable-procedures$
+ (let ((:globals available:killer:globals)
+ (:car available:killer:car)
+ (:cdr available:killer:cdr)
+ (:string available:killer:string)
+ (:vector available:killer:vector)
+ (:cell available:killer:cell)
+ (:io available:killer:io)
+ (:none available:killer:none) ; none of the above
+ (:all available:killer:all) ; all of the above
+ (:immortal available:killer:immortal) ; never killed
+ (:dead available:killer:dead) ; never available
+ )
+
+; external arity internal immediate ignored killed kills
+; name name predicate by what
+; kind of
+; effect
+
+ `((break 0 break #f 3 ,:dead ,:all)
+ (creg 0 creg #f 7 ,:dead ,:all)
+ (unspecified 0 unspecified #f -1 ,:dead ,:none)
+ (undefined 0 undefined #f 8 ,:dead ,:none)
+ (eof-object 0 eof-object #f -1 ,:dead ,:none)
+ (enable-interrupts 1 enable-interrupts #f -1 ,:dead ,:all)
+ (disable-interrupts 0 disable-interrupts #f -1 ,:dead ,:all)
+
+ (typetag 1 typetag #f #x11 ,:dead ,:none)
+ (not 1 not #f #x18 ,:immortal ,:none)
+ (null? 1 null? #f #x19 ,:immortal ,:none)
+ (pair? 1 pair? #f #x1a ,:immortal ,:none)
+ (eof-object? 1 eof-object? #f -1 ,:immortal ,:none)
+ (port? 1 port? #f -1 ,:dead ,:none)
+ (structure? 1 structure? #f -1 ,:dead ,:none)
+ (car 1 car #f #x1b ,:car ,:none)
+ (,name:CAR 1 car #f #x1b ,:car ,:none)
+ (cdr 1 cdr #f #x1c ,:cdr ,:none)
+ (,name:CDR 1 cdr #f #x1c ,:cdr ,:none)
+ (symbol? 1 symbol? #f #x1f ,:immortal ,:none)
+ (number? 1 complex? #f #x20 ,:immortal ,:none)
+ (complex? 1 complex? #f #x20 ,:immortal ,:none)
+ (real? 1 rational? #f #x21 ,:immortal ,:none)
+ (rational? 1 rational? #f #x21 ,:immortal ,:none)
+ (integer? 1 integer? #f #x22 ,:immortal ,:none)
+ (fixnum? 1 fixnum? #f #x23 ,:immortal ,:none)
+ (flonum? 1 flonum? #f -1 ,:immortal ,:none)
+ (compnum? 1 compnum? #f -1 ,:immortal ,:none)
+ (exact? 1 exact? #f #x24 ,:immortal ,:none)
+ (inexact? 1 inexact? #f #x25 ,:immortal ,:none)
+ (exact->inexact 1 exact->inexact #f #x26 ,:immortal ,:none)
+ (inexact->exact 1 inexact->exact #f #x27 ,:immortal ,:none)
+ (round 1 round #f #x28 ,:immortal ,:none)
+ (truncate 1 truncate #f #x29 ,:immortal ,:none)
+ (zero? 1 zero? #f #x2c ,:immortal ,:none)
+ (-- 1 -- #f #x2d ,:immortal ,:none)
+ (lognot 1 lognot #f #x2f ,:immortal ,:none)
+ (real-part 1 real-part #f #x3e ,:immortal ,:none)
+ (imag-part 1 imag-part #f #x3f ,:immortal ,:none)
+ (char? 1 char? #f #x40 ,:immortal ,:none)
+ (char->integer 1 char->integer #f #x41 ,:immortal ,:none)
+ (integer->char 1 integer->char #f #x42 ,:immortal ,:none)
+ (string? 1 string? #f #x50 ,:immortal ,:none)
+ (string-length 1 string-length #f #x51 ,:immortal ,:none)
+ (vector? 1 vector? #f #x52 ,:immortal ,:none)
+ (vector-length 1 vector-length #f #x53 ,:immortal ,:none)
+ (bytevector? 1 bytevector? #f #x54 ,:immortal ,:none)
+ (bytevector-length 1 bytevector-length #f #x55 ,:immortal ,:none)
+ (bytevector-fill! 2 bytevector-fill! #f -1 ,:dead ,:string)
+ (make-bytevector 1 make-bytevector #f #x56 ,:dead ,:none)
+ (procedure? 1 procedure? #f #x58 ,:immortal ,:none)
+ (procedure-length 1 procedure-length #f #x59 ,:dead ,:none)
+ (make-procedure 1 make-procedure #f #x5a ,:dead ,:none)
+ (creg-set! 1 creg-set! #f #x71 ,:dead ,:none)
+ (,name:MAKE-CELL 1 make-cell #f #x7e ,:dead ,:none)
+ (,name:CELL-REF 1 cell-ref #f #x7f ,:cell ,:none)
+ (,name:CELL-SET! 2 cell-set! #f #xdf ,:dead ,:cell)
+ (typetag-set! 2 typetag-set! ,valid-typetag? #xa0 ,:dead ,:all)
+ (eq? 2 eq? ,sparc-eq-imm? #xa1 ,:immortal ,:none)
+ (eqv? 2 eqv? #f #xa2 ,:immortal ,:none)
+ (cons 2 cons #f #xa8 ,:dead ,:none)
+ (,name:CONS 2 cons #f #xa8 ,:dead ,:none)
+ (set-car! 2 set-car! #f #xa9 ,:dead ,:car)
+ (set-cdr! 2 set-cdr! #f #xaa ,:dead ,:cdr)
+ (+ 2 + ,sparc-imm? #xb0 ,:immortal ,:none)
+ (- 2 - ,sparc-imm? #xb1 ,:immortal ,:none)
+ (* 2 * ,sparc-imm? #xb2 ,:immortal ,:none)
+ (/ 2 / #f #xb3 ,:immortal ,:none)
+ (quotient 2 quotient #f #xb4 ,:immortal ,:none)
+ (< 2 < ,sparc-imm? #xb5 ,:immortal ,:none)
+ (<= 2 <= ,sparc-imm? #xb6 ,:immortal ,:none)
+ (= 2 = ,sparc-imm? #xb7 ,:immortal ,:none)
+ (> 2 > ,sparc-imm? #xb8 ,:immortal ,:none)
+ (>= 2 >= ,sparc-imm? #xb9 ,:immortal ,:none)
+ (logand 2 logand #f #xc0 ,:immortal ,:none)
+ (logior 2 logior #f #xc1 ,:immortal ,:none)
+ (logxor 2 logxor #f #xc2 ,:immortal ,:none)
+ (lsh 2 lsh #f #xc3 ,:immortal ,:none)
+ (rsha 2 rsha #f -1 ,:immortal ,:none)
+ (rshl 2 rshl #f -1 ,:immortal ,:none)
+ (rot 2 rot #f #xc4 ,:immortal ,:none)
+ (make-string 2 make-string #f -1 ,:dead ,:none)
+ (string-ref 2 string-ref ,sparc-imm? #xd1 ,:string ,:none)
+ (string-set! 3 string-set! ,sparc-imm? -1 ,:dead ,:string)
+ (make-vector 2 make-vector #f #xd2 ,:dead ,:none)
+ (vector-ref 2 vector-ref ,sparc-imm? #xd3 ,:vector ,:none)
+ (bytevector-ref 2 bytevector-ref ,sparc-imm? #xd5 ,:string ,:none)
+ (procedure-ref 2 procedure-ref #f #xd7 ,:dead ,:none)
+ (char<? 2 char<? ,char? #xe0 ,:immortal ,:none)
+ (char<=? 2 char<=? ,char? #xe1 ,:immortal ,:none)
+ (char=? 2 char=? ,char? #xe2 ,:immortal ,:none)
+ (char>? 2 char>? ,char? #xe3 ,:immortal ,:none)
+ (char>=? 2 char>=? ,char? #xe4 ,:immortal ,:none)
+
+ (sys$partial-list->vector 2 sys$partial-list->vector #f -1 ,:dead ,:all)
+ (vector-set! 3 vector-set! #f #xf1 ,:dead ,:vector)
+ (bytevector-set! 3 bytevector-set! #f #xf2 ,:dead ,:string)
+ (procedure-set! 3 procedure-set! #f #xf3 ,:dead ,:all)
+ (bytevector-like? 1 bytevector-like? #f -1 ,:immortal ,:none)
+ (vector-like? 1 vector-like? #f -1 ,:immortal ,:none)
+ (bytevector-like-ref 2 bytevector-like-ref #f -1 ,:string ,:none)
+ (bytevector-like-set! 3 bytevector-like-set! #f -1 ,:dead ,:string)
+ (sys$bvlcmp 2 sys$bvlcmp #f -1 ,:dead ,:all)
+ (vector-like-ref 2 vector-like-ref #f -1 ,:vector ,:none)
+ (vector-like-set! 3 vector-like-set! #f -1 ,:dead ,:vector)
+ (vector-like-length 1 vector-like-length #f -1 ,:immortal ,:none)
+ (bytevector-like-length 1 bytevector-like-length #f -1 ,:immortal ,:none)
+ (remainder 2 remainder #f -1 ,:immortal ,:none)
+ (sys$read-char 1 sys$read-char #f -1 ,:dead ,:io)
+ (gc-counter 0 gc-counter #f -1 ,:dead ,:none)
+ ,@(if (fixnum-primitives)
+ `((most-positive-fixnum
+ 0 most-positive-fixnum
+ #f -1 ,:immortal ,:none)
+ (most-negative-fixnum
+ 0 most-negative-fixnum
+ #f -1 ,:immortal ,:none)
+ (fx+ 2 fx+ ,sparc-imm? -1 ,:immortal ,:none)
+ (fx- 2 fx- ,sparc-imm? -1 ,:immortal ,:none)
+ (fx-- 1 fx-- #f -1 ,:immortal ,:none)
+ (fx* 2 fx* #f -1 ,:immortal ,:none)
+ (fx= 2 fx= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx< 2 fx< ,sparc-imm? -1 ,:immortal ,:none)
+ (fx<= 2 fx<= ,sparc-imm? -1 ,:immortal ,:none)
+ (fx> 2 fx> ,sparc-imm? -1 ,:immortal ,:none)
+ (fx>= 2 fx>= ,sparc-imm? -1 ,:immortal ,:none)
+ (fxzero? 1 fxzero? #f -1 ,:immortal ,:none)
+ (fxpositive? 1 fxpositive? #f -1 ,:immortal ,:none)
+ (fxnegative? 1 fxnegative? #f -1 ,:immortal ,:none))
+ '())
+ ,@(if (flonum-primitives)
+ `((fl+ 2 + #f -1 ,:immortal ,:none)
+ (fl- 2 - #f -1 ,:immortal ,:none)
+ (fl-- 1 -- #f -1 ,:immortal ,:none)
+ (fl* 2 * #f -1 ,:immortal ,:none)
+ (fl= 2 = #f -1 ,:immortal ,:none)
+ (fl< 2 < #f -1 ,:immortal ,:none)
+ (fl<= 2 <= #f -1 ,:immortal ,:none)
+ (fl> 2 > #f -1 ,:immortal ,:none)
+ (fl>= 2 >= #f -1 ,:immortal ,:none))
+ '())
+
+ ; Added for CSE, representation analysis.
+
+ (,name:CHECK! -1 check! #f -1 ,:dead ,:none)
+ (vector-length:vec 1 vector-length:vec #f -1 ,:immortal ,:none)
+ (vector-ref:trusted 2 vector-ref:trusted ,sparc-imm? -1 ,:vector ,:none)
+ (vector-set!:trusted 3 vector-set!:trusted #f -1 ,:dead ,:vector)
+ (car:pair 1 car:pair #f -1 ,:car ,:none)
+ (cdr:pair 1 cdr:pair #f -1 ,:cdr ,:none)
+ (=:fix:fix 2 =:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<:fix:fix 2 <:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (<=:fix:fix 2 <=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>=:fix:fix 2 >=:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+ (>:fix:fix 2 >:fix:fix ,sparc-imm? -1 ,:immortal ,:none)
+
+ ; Not yet implemented.
+
+ (+:idx:idx 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:fix:fix 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:exi:exi 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (+:flo:flo 2 +:idx:idx #f -1 ,:immortal ,:none)
+ (=:flo:flo 2 =:flo:flo #f -1 ,:immortal ,:none)
+ (=:obj:flo 2 =:obj:flo #f -1 ,:immortal ,:none)
+ (=:flo:obj 2 =:flo:obj #f -1 ,:immortal ,:none)
+ )))
+
+; Not used by the Sparc assembler; for information only.
+
+(define $immediate-primops$
+ '((typetag-set! #x80)
+ (eq? #x81)
+ (+ #x82)
+ (- #x83)
+ (< #x84)
+ (<= #x85)
+ (= #x86)
+ (> #x87)
+ (>= #x88)
+ (char<? #x89)
+ (char<=? #x8a)
+ (char=? #x8b)
+ (char>? #x8c)
+ (char>=? #x8d)
+ (string-ref #x90)
+ (vector-ref #x91)
+ (bytevector-ref #x92)
+ (bytevector-like-ref -1)
+ (vector-like-ref -1)
+ (fx+ -1)
+ (fx- -1)
+ (fx-- -1)
+ (fx= -1)
+ (fx< -1)
+ (fx<= -1)
+ (fx> -1)
+ (fx>= -1)))
+
+; Operations introduced by peephole optimizer.
+
+(define $reg/op1/branchf ; reg/op1/branchf prim,k1,L
+ (make-mnemonic 'reg/op1/branchf))
+(define $reg/op2/branchf ; reg/op2/branchf prim,k1,k2,L
+ (make-mnemonic 'reg/op2/branchf))
+(define $reg/op2imm/branchf ; reg/op2imm/branchf prim,k1,x,L
+ (make-mnemonic 'reg/op2imm/branchf))
+(define $reg/op1/check ; reg/op1/check prim,k1,k2,k3,k4,exn
+ (make-mnemonic 'reg/op1/check))
+(define $reg/op2/check ; reg/op2/check prim,k1,k2,k3,k4,k5,exn
+ (make-mnemonic 'reg/op2/check))
+(define $reg/op2imm/check ; reg/op2imm/check prim,k1,x,k2,k3,k4,exn
+ (make-mnemonic 'reg/op2imm/check))
+(define $reg/op1/setreg ; reg/op1/setreg prim,k1,kr
+ (make-mnemonic 'reg/op1/setreg))
+(define $reg/op2/setreg ; reg/op2/setreg prim,k1,k2,kr
+ (make-mnemonic 'reg/op2/setreg))
+(define $reg/op2imm/setreg ; reg/op2imm/setreg prim,k1,x,kr
+ (make-mnemonic 'reg/op2imm/setreg))
+(define $reg/branchf ; reg/branchf k, L
+ (make-mnemonic 'reg/branchf))
+(define $reg/return ; reg/return k
+ (make-mnemonic 'reg/return))
+(define $reg/setglbl ; reg/setglbl k,x
+ (make-mnemonic 'reg/setglbl))
+(define $reg/op3 ; reg/op3 prim,k1,k2,k3
+ (make-mnemonic 'reg/op3))
+(define $const/setreg ; const/setreg const,k
+ (make-mnemonic 'const/setreg))
+(define $const/return ; const/return const
+ (make-mnemonic 'const/return))
+(define $global/setreg ; global/setreg x,k
+ (make-mnemonic 'global/setreg))
+(define $setrtn/branch ; setrtn/branch L,doc
+ (make-mnemonic 'setrtn/branch))
+(define $setrtn/invoke ; setrtn/invoke L
+ (make-mnemonic 'setrtn/invoke))
+(define $global/invoke ; global/invoke global,n
+ (make-mnemonic 'global/invoke))
+
+; misc
+
+(define $cons 'cons)
+(define $car:pair 'car)
+(define $cdr:pair 'cdr)
+
+; eof
+; Target-specific representations.
+;
+; A few of these representation types must be specified for every target:
+; rep:object
+; rep:procedure
+; rep:true
+; rep:false
+; rep:bottom
+
+(define-subtype 'true 'object) ; values that count as true
+(define-subtype 'eqtype 'object) ; can use EQ? instead of EQV?
+(define-subtype 'nonpointer 'eqtype) ; can omit write barrier
+(define-subtype 'eqtype1 'eqtype) ; eqtypes excluding #f
+(define-subtype 'boolean 'nonpointer)
+(define-subtype 'truth 'eqtype1) ; { #t }
+(define-subtype 'truth 'boolean)
+(define-subtype 'false 'boolean) ; { #f }
+(define-subtype 'eqtype1 'true)
+(define-subtype 'procedure 'true)
+(define-subtype 'vector 'true)
+(define-subtype 'bytevector 'true)
+(define-subtype 'string 'true)
+(define-subtype 'pair 'true)
+(define-subtype 'emptylist 'eqtype1)
+(define-subtype 'emptylist 'nonpointer)
+(define-subtype 'symbol 'eqtype1)
+(define-subtype 'char 'eqtype1)
+(define-subtype 'char 'nonpointer)
+(define-subtype 'number 'true)
+(define-subtype 'inexact 'number)
+(define-subtype 'flonum 'inexact)
+(define-subtype 'integer 'number)
+(define-subtype 'exact 'number)
+(define-subtype 'exactint 'integer)
+(define-subtype 'exactint 'exact)
+(define-subtype 'fixnum 'exactint)
+(define-subtype '!fixnum 'fixnum) ; 0 <= n
+(define-subtype 'fixnum! 'fixnum) ; n <= largest index
+(define-subtype 'index '!fixnum)
+(define-subtype 'index 'fixnum!)
+(define-subtype 'zero 'index)
+(define-subtype 'fixnum 'eqtype1)
+(define-subtype 'fixnum 'nonpointer)
+
+(compute-type-structure!)
+
+; If the intersection of rep1 and rep2 is known precisely,
+; but neither is a subtype of the other, then their intersection
+; should be declared explicitly.
+; Otherwise a conservative approximation will be used.
+
+(define-intersection 'true 'eqtype 'eqtype1)
+(define-intersection 'true 'boolean 'truth)
+(define-intersection 'exact 'integer 'exactint)
+(define-intersection '!fixnum 'fixnum! 'index)
+
+;(display-unions-and-intersections)
+
+; Parameters.
+
+(define rep:min_fixnum (- (expt 2 29)))
+(define rep:max_fixnum (- (expt 2 29) 1))
+(define rep:max_index (- (expt 2 24) 1))
+
+; The representations we'll recognize for now.
+
+(define rep:object (symbol->rep 'object))
+(define rep:true (symbol->rep 'true))
+(define rep:truth (symbol->rep 'truth))
+(define rep:false (symbol->rep 'false))
+(define rep:boolean (symbol->rep 'boolean))
+(define rep:pair (symbol->rep 'pair))
+(define rep:symbol (symbol->rep 'symbol))
+(define rep:number (symbol->rep 'number))
+(define rep:zero (symbol->rep 'zero))
+(define rep:index (symbol->rep 'index))
+(define rep:fixnum (symbol->rep 'fixnum))
+(define rep:exactint (symbol->rep 'exactint))
+(define rep:flonum (symbol->rep 'flonum))
+(define rep:exact (symbol->rep 'exact))
+(define rep:inexact (symbol->rep 'inexact))
+(define rep:integer (symbol->rep 'integer))
+;(define rep:real (symbol->rep 'real))
+(define rep:char (symbol->rep 'char))
+(define rep:string (symbol->rep 'string))
+(define rep:vector (symbol->rep 'vector))
+(define rep:procedure (symbol->rep 'procedure))
+(define rep:bottom (symbol->rep 'bottom))
+
+; Given the value of a quoted constant, return its representation.
+
+(define (representation-of-value x)
+ (cond ((boolean? x)
+ (if x
+ rep:truth
+ rep:false))
+ ((pair? x)
+ rep:pair)
+ ((symbol? x)
+ rep:symbol)
+ ((number? x)
+ (cond ((and (exact? x)
+ (integer? x))
+ (cond ((zero? x)
+ rep:zero)
+ ((<= 0 x rep:max_index)
+ rep:index)
+ ((<= rep:min_fixnum
+ x
+ rep:max_fixnum)
+ rep:fixnum)
+ (else
+ rep:exactint)))
+ ((and (inexact? x)
+ (real? x))
+ rep:flonum)
+ (else
+ ; We're not tracking other numbers yet.
+ rep:number)))
+ ((char? x)
+ rep:char)
+ ((string? x)
+ rep:string)
+ ((vector? x)
+ rep:vector)
+ ; Everything counts as true except for #f.
+ (else
+ rep:true)))
+
+; Tables that express the representation-specific operations,
+; and the information about representations that are implied
+; by certain operations.
+; FIXME: Currently way incomplete, but good enough for testing.
+
+(define rep-specific
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the procedure
+ ; in the last column can be called instead.
+
+ '(
+ ;(+ (index index) +:idx:idx)
+ ;(+ (fixnum fixnum) +:fix:fix)
+ ;(- (index index) -:idx:idx)
+ ;(- (fixnum fixnum) -:fix:fix)
+
+ (= (fixnum fixnum) =:fix:fix)
+ (< (fixnum fixnum) <:fix:fix)
+ (<= (fixnum fixnum) <=:fix:fix)
+ (> (fixnum fixnum) >:fix:fix)
+ (>= (fixnum fixnum) >=:fix:fix)
+
+ ;(+ (flonum flonum) +:flo:flo)
+ ;(- (flonum flonum) -:flo:flo)
+ ;(= (flonum flonum) =:flo:flo)
+ ;(< (flonum flonum) <:flo:flo)
+ ;(<= (flonum flonum) <=:flo:flo)
+ ;(> (flonum flonum) >:flo:flo)
+ ;(>= (flonum flonum) >=:flo:flo)
+
+ ;(vector-set!:trusted (vector fixnum nonpointer) vector-set!:trusted:imm)
+ )))
+
+(define rep-result
+
+ (representation-table
+
+ ; When the procedure in the first column is called with
+ ; arguments described in the middle column, then the result
+ ; is described by the last column.
+
+ '((fixnum? (fixnum) (truth))
+ (vector? (vector) (truth))
+ (<= (zero !fixnum) (truth))
+ (>= (!fixnum zero) (truth))
+ (<=:fix:fix (zero !fixnum) (truth))
+ (>=:fix:fix (!fixnum zero) (truth))
+
+ (+ (index index) (!fixnum))
+ (+ (fixnum fixnum) (exactint))
+ (- (index index) (fixnum!))
+ (- (fixnum fixnum) (exactint))
+
+ (+ (flonum flonum) (flonum))
+ (- (flonum flonum) (flonum))
+
+ ;(+:idx:idx (index index) (!fixnum))
+ ;(-:idx:idx (index index) (fixnum!))
+ ;(+:fix:fix (index index) (exactint))
+ ;(+:fix:fix (fixnum fixnum) (exactint))
+ ;(-:idx:idx (index index) (fixnum))
+ ;(-:fix:fix (fixnum fixnum) (exactint))
+
+ (make-vector (object object) (vector))
+ (vector-length:vec (vector) (index))
+ (cons (object object) (pair))
+
+ ; Is it really all that useful to know that the result
+ ; of these comparisons is a boolean?
+
+ (= (number number) (boolean))
+ (< (number number) (boolean))
+ (<= (number number) (boolean))
+ (> (number number) (boolean))
+ (>= (number number) (boolean))
+
+ (=:fix:fix (fixnum fixnum) (boolean))
+ (<:fix:fix (fixnum fixnum) (boolean))
+ (<=:fix:fix (fixnum fixnum) (boolean))
+ (>:fix:fix (fixnum fixnum) (boolean))
+ (>=:fix:fix (fixnum fixnum) (boolean))
+ )))
+
+(define rep-informing
+
+ (representation-table
+
+ ; When the predicate in the first column is called in the test position
+ ; of a conditional expression, on arguments described by the second
+ ; column, then the arguments are described by the third column if the
+ ; predicate returns true, and by the fourth column if the predicate
+ ; returns false.
+
+ '(
+ (fixnum? (object) (fixnum) (object))
+ (flonum? (object) (flonum) (object))
+ (vector? (object) (vector) (object))
+ (pair? (object) (pair) (object))
+
+ (= (exactint index) (index index) (exactint index))
+ (= (index exactint) (index index) (index exactint))
+ (= (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (= (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (= (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (= (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (< (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (< (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (< (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+ (< (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+
+ (<= (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<= (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<= (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<= (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (> (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (> (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (> (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (> (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>= (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>= (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>= (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>= (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (=:fix:fix (exactint index) (index index) (exactint index))
+ (=:fix:fix (index exactint) (index index) (index exactint))
+ (=:fix:fix (exactint !fixnum) (!fixnum !fixnum) (exactint !fixnum))
+ (=:fix:fix (!fixnum exactint) (!fixnum !fixnum) (!fixnum exactint))
+ (=:fix:fix (exactint fixnum!) (fixnum! fixnum!) (exactint fixnum!))
+ (=:fix:fix (fixnum! exactint) (fixnum! fixnum!) (fixnum! exactint))
+
+ (<:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (<=:fix:fix (!fixnum fixnum!) (index index) (!fixnum fixnum!))
+ (<=:fix:fix (fixnum! !fixnum) (fixnum! !fixnum) (index index))
+ (<=:fix:fix (fixnum fixnum!) (fixnum! fixnum!) (fixnum fixnum!))
+ (<=:fix:fix (!fixnum fixnum) (!fixnum !fixnum) (!fixnum fixnum))
+
+ (>:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+
+ (>=:fix:fix (!fixnum fixnum!) (!fixnum fixnum!) (index index))
+ (>=:fix:fix (fixnum! !fixnum) (index index) (fixnum! !fixnum))
+ (>=:fix:fix (fixnum fixnum!) (fixnum fixnum!) (fixnum! fixnum!))
+ (>=:fix:fix (!fixnum fixnum) (!fixnum fixnum) (!fixnum !fixnum))
+ )))
+; Copyright 1991 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 25 April 1999.
+;
+; Second pass of the Twobit compiler:
+; single assignment analysis, local source transformations,
+; assignment elimination, and lambda lifting.
+; The code for assignment elimination and lambda lifting
+; are in a separate file.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no internal definitions.
+; * No identifier containing an upper case letter is bound anywhere.
+; (Change the "name:..." variables if upper case is preferred.)
+; * No identifier is bound in more than one place.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Each R contains one entry for every identifier bound in the
+; formal argument list and the internal definition list that
+; precede it. Each entry contains a list of pointers to all
+; references to the identifier, a list of pointers to all
+; assignments to the identifier, and a list of pointers to all
+; calls to the identifier.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Except for constants, the expression does not share structure
+; with the original input or itself, except that the references
+; and assignments in R are guaranteed to share structure with
+; the expression. Thus the expression may be side effected, and
+; side effects to references or assignments obtained through R
+; are guaranteed to change the references or assignments pointed
+; to by R.
+
+(define (pass2 exp)
+ (simplify exp (make-notepad #f)))
+
+; Given an expression and a "notepad" data structure that conveys
+; inherited attributes, performs the appropriate optimizations and
+; destructively modifies the notepad to record various attributes
+; that it synthesizes while traversing the expression. In particular,
+; any nested lambda expressions and any variable references will be
+; noted in the notepad.
+
+(define (simplify exp notepad)
+ (case (car exp)
+ ((quote) exp)
+ ((lambda) (simplify-lambda exp notepad))
+ ((set!) (simplify-assignment exp notepad))
+ ((if) (simplify-conditional exp notepad))
+ ((begin) (if (variable? exp)
+ (begin (notepad-var-add! notepad (variable.name exp))
+ exp)
+ (simplify-sequential exp notepad)))
+ (else (simplify-call exp notepad))))
+
+; Most optimization occurs here.
+; The right hand sides of internal definitions are simplified,
+; as is the body.
+; Internal definitions of enclosed lambda expressions may
+; then be lifted to this one.
+; Single assignment analysis creates internal definitions.
+; Single assignment elimination converts single assignments
+; to bindings where possible, and renames arguments whose value
+; is ignored.
+; Assignment elimination then replaces all remaining assigned
+; variables by heap-allocated cells.
+
+(define (simplify-lambda exp notepad)
+ (notepad-lambda-add! notepad exp)
+ (let ((defs (lambda.defs exp))
+ (body (lambda.body exp))
+ (newnotepad (make-notepad exp)))
+ (for-each (lambda (def)
+ (simplify-lambda (def.rhs def) newnotepad))
+ defs)
+ (lambda.body-set! exp (simplify body newnotepad))
+ (lambda.F-set! exp (notepad-free-variables newnotepad))
+ (lambda.G-set! exp (notepad-captured-variables newnotepad))
+ (single-assignment-analysis exp newnotepad)
+ (let ((known-lambdas (notepad.nonescaping newnotepad)))
+ (for-each (lambda (L)
+ (if (memq L known-lambdas)
+ (lambda-lifting L exp)
+ (lambda-lifting L L)))
+ (notepad.lambdas newnotepad))))
+ (single-assignment-elimination exp notepad)
+ (assignment-elimination exp)
+ (if (not (notepad.parent notepad))
+ ; This is an outermost lambda expression.
+ (lambda-lifting exp exp))
+ exp)
+
+; SIMPLIFY-ASSIGNMENT performs this transformation:
+;
+; (set! I (begin ... E))
+; -> (begin ... (set! I E))
+
+(define (simplify-assignment exp notepad)
+ (notepad-var-add! notepad (assignment.lhs exp))
+ (let ((rhs (simplify (assignment.rhs exp) notepad)))
+ (cond ((begin? rhs)
+ (let ((exprs (reverse (begin.exprs rhs))))
+ (assignment.rhs-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons exp (cdr exprs))))
+ notepad)))
+ (else (assignment.rhs-set! exp rhs) exp))))
+
+(define (simplify-sequential exp notepad)
+ (let ((exprs (map (lambda (exp) (simplify exp notepad))
+ (begin.exprs exp))))
+ (begin.exprs-set! exp exprs)
+ (post-simplify-begin exp notepad)))
+
+; Given (BEGIN E0 E1 E2 ...) where the E_i are simplified expressions,
+; flattens any nested BEGINs and removes trivial expressions that
+; don't appear in the last position. The second argument is used only
+; if a lambda expression is removed.
+; This procedure is careful to return E instead of (BEGIN E).
+; Fairly harmless bug: a variable reference removed by this procedure
+; may remain on the notepad when it shouldn't.
+
+(define (post-simplify-begin exp notepad)
+ (let ((unspecified-expression (make-unspecified)))
+ ; (flatten exprs '()) returns the flattened exprs in reverse order.
+ (define (flatten exprs flattened)
+ (cond ((null? exprs) flattened)
+ ((begin? (car exprs))
+ (flatten (cdr exprs)
+ (flatten (begin.exprs (car exprs)) flattened)))
+ (else (flatten (cdr exprs) (cons (car exprs) flattened)))))
+ (define (filter exprs filtered)
+ (if (null? exprs)
+ filtered
+ (let ((exp (car exprs)))
+ (cond ((constant? exp) (filter (cdr exprs) filtered))
+ ((variable? exp) (filter (cdr exprs) filtered))
+ ((lambda? exp)
+ (notepad.lambdas-set!
+ notepad
+ (remq exp (notepad.lambdas notepad)))
+ (filter (cdr exprs) filtered))
+ ((equal? exp unspecified-expression)
+ (filter (cdr exprs) filtered))
+ (else (filter (cdr exprs) (cons exp filtered)))))))
+ (let ((exprs (flatten (begin.exprs exp) '())))
+ (begin.exprs-set! exp (filter (cdr exprs) (list (car exprs))))
+ (if (null? (cdr (begin.exprs exp)))
+ (car (begin.exprs exp))
+ exp))))
+
+; SIMPLIFY-CALL performs this transformation:
+;
+; (... (begin ... E) ...)
+; -> (begin ... (... E ...))
+;
+; It also takes care of LET transformations.
+
+(define (simplify-call exp notepad)
+ (define (loop args newargs exprs)
+ (cond ((null? args)
+ (finish newargs exprs))
+ ((begin? (car args))
+ (let ((newexprs (reverse (begin.exprs (car args)))))
+ (loop (cdr args)
+ (cons (car newexprs) newargs)
+ (append (cdr newexprs) exprs))))
+ (else (loop (cdr args) (cons (car args) newargs) exprs))))
+ (define (finish newargs exprs)
+ (call.args-set! exp (reverse newargs))
+ (let* ((newexp
+ (if (lambda? (call.proc exp))
+ (simplify-let exp notepad)
+ (begin
+ (call.proc-set! exp
+ (simplify (call.proc exp) notepad))
+ exp)))
+ (newexp
+ (if (and (call? newexp)
+ (variable? (call.proc newexp)))
+ (let* ((procname (variable.name (call.proc newexp)))
+ (args (call.args newexp))
+ (entry
+ (and (not (null? args))
+ (constant? (car args))
+ (integrate-usual-procedures)
+ (every? constant? args)
+ (let ((entry (constant-folding-entry procname)))
+ (and entry
+ (let ((predicates
+ (constant-folding-predicates entry)))
+ (and (= (length args)
+ (length predicates))
+ (let loop ((args args)
+ (predicates predicates))
+ (cond ((null? args) entry)
+ (((car predicates)
+ (constant.value
+ (car args)))
+ (loop (cdr args)
+ (cdr predicates)))
+ (else #f))))))))))
+ (if entry
+ (make-constant (apply (constant-folding-folder entry)
+ (map constant.value args)))
+ newexp))
+ newexp)))
+ (cond ((and (call? newexp)
+ (begin? (call.proc newexp)))
+ (let ((exprs0 (reverse (begin.exprs (call.proc newexp)))))
+ (call.proc-set! newexp (car exprs0))
+ (post-simplify-begin
+ (make-begin (reverse
+ (cons newexp
+ (append (cdr exprs0) exprs))))
+ notepad)))
+ ((null? exprs)
+ newexp)
+ (else
+ (post-simplify-begin
+ (make-begin (reverse (cons newexp exprs)))
+ notepad)))))
+ (call.args-set! exp (map (lambda (arg) (simplify arg notepad))
+ (call.args exp)))
+ (loop (call.args exp) '() '()))
+
+; SIMPLIFY-LET performs these transformations:
+;
+; ((lambda (I_1 ... I_k . I_rest) ---) E1 ... Ek Ek+1 ...)
+; -> ((lambda (I_1 ... I_k I_rest) ---) E1 ... Ek (LIST Ek+1 ...))
+;
+; ((lambda (I1 I2 ...) (begin D ...) (quote ...) E) L ...)
+; -> ((lambda (I2 ...) (begin (define I1 L) D ...) (quote ...) E) ...)
+;
+; provided I1 is not assigned and each reference to I1 is in call position.
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (begin I1))
+; E1)
+;
+; -> E1
+;
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 ((begin I1)) () ())))
+; (if (begin I1) E2 E3))
+; E1)
+;
+; -> (if E1 E2 E3)
+;
+; (Together with SIMPLIFY-CONDITIONAL, this cleans up the output of the OR
+; macro and enables certain control optimizations.)
+;
+; ((lambda (I1 I2 ...)
+; (begin D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; E)
+; K ...)
+; -> ((lambda (I2 ...)
+; (begin D' ...)
+; (quote (... ...) ...)
+; E')
+; ...)
+;
+; where D' ... and E' ... are obtained from D ... and E ...
+; by replacing all references to I1 by K. This transformation
+; applies if K is a constant that can be duplicated without changing
+; its EQV? behavior.
+;
+; ((lambda () (begin) (quote ...) E)) -> E
+;
+; ((lambda (IGNORED I2 ...) ---) E1 E2 ...)
+; -> (begin E1 ((lambda (I2 ...) ---) E2 ...))
+;
+; (Single assignment analysis, performed by the simplifier for lambda
+; expressions, detects unused arguments and replaces them in the argument
+; list by the special identifier IGNORED.)
+
+(define (simplify-let exp notepad)
+ (define proc (call.proc exp))
+
+ ; Loop1 operates before simplification of the lambda body.
+
+ (define (loop1 formals actuals processed-formals processed-actuals)
+ (cond ((null? formals)
+ (if (not (null? actuals))
+ (pass2-error p2error:wna exp))
+ (return1 processed-formals processed-actuals))
+ ((symbol? formals)
+ (return1 (cons formals processed-formals)
+ (cons (make-call-to-LIST actuals) processed-actuals)))
+ ((null? actuals)
+ (pass2-error p2error:wna exp)
+ (return1 processed-formals
+ processed-actuals))
+ ((and (lambda? (car actuals))
+ (let ((Rinfo (R-lookup (lambda.R proc) (car formals))))
+ (and (null? (R-entry.assignments Rinfo))
+ (= (length (R-entry.references Rinfo))
+ (length (R-entry.calls Rinfo))))))
+ (let ((I (car formals))
+ (L (car actuals)))
+ (notepad-nonescaping-add! notepad L)
+ (lambda.defs-set! proc
+ (cons (make-definition I L)
+ (lambda.defs proc)))
+ (standardize-known-calls L
+ (R-entry.calls
+ (R-lookup (lambda.R proc) I)))
+ (lambda.F-set! proc (union (lambda.F proc)
+ (free-variables L)))
+ (lambda.G-set! proc (union (lambda.G proc) (lambda.G L))))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ ((and (constant? (car actuals))
+ (let ((x (constant.value (car actuals))))
+ (or (boolean? x)
+ (number? x)
+ (symbol? x)
+ (char? x))))
+ (let* ((I (car formals))
+ (Rinfo (R-lookup (lambda.R proc) I)))
+ (if (null? (R-entry.assignments Rinfo))
+ (begin
+ (for-each (lambda (ref)
+ (variable-set! ref (car actuals)))
+ (R-entry.references Rinfo))
+ (lambda.R-set! proc (remq Rinfo (lambda.R proc)))
+ (lambda.F-set! proc (remq I (lambda.F proc)))
+ (lambda.G-set! proc (remq I (lambda.G proc)))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+ (else (if (null? actuals)
+ (pass2-error p2error:wna exp))
+ (loop1 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)))))
+
+ (define (return1 rev-formals rev-actuals)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals)))
+ (lambda.args-set! proc formals)
+ (if (and (not (null? formals))
+ (null? (cdr formals))
+ (let* ((x (car formals))
+ (R (lambda.R proc))
+ (refs (references R x)))
+ (and (= 1 (length refs))
+ (null? (assignments R x)))))
+ (let ((x (car formals))
+ (body (lambda.body proc)))
+ (cond ((and (variable? body)
+ (eq? x (variable.name body)))
+ (simplify (car actuals) notepad))
+ ((and (conditional? body)
+ (let ((B0 (if.test body)))
+ (variable? B0)
+ (eq? x (variable.name B0))))
+ (if.test-set! body (car actuals))
+ (simplify body notepad))
+ (else
+ (return1-finish formals actuals))))
+ (return1-finish formals actuals))))
+
+ (define (return1-finish formals actuals)
+ (simplify-lambda proc notepad)
+ (loop2 formals actuals '() '() '()))
+
+ ; Loop2 operates after simplification of the lambda body.
+
+ (define (loop2 formals actuals processed-formals processed-actuals for-effect)
+ (cond ((null? formals)
+ (return2 processed-formals processed-actuals for-effect))
+ ((ignored? (car formals))
+ (loop2 (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else (loop2 (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect))))
+
+ (define (return2 rev-formals rev-actuals rev-for-effect)
+ (let ((formals (reverse rev-formals))
+ (actuals (reverse rev-actuals))
+ (for-effect (reverse rev-for-effect)))
+ (lambda.args-set! proc formals)
+ (call.args-set! exp actuals)
+ (let ((exp (if (and (null? actuals)
+ (or (null? (lambda.defs proc))
+ (and (notepad.parent notepad)
+ (POLICY:LIFT? proc
+ (notepad.parent notepad)
+ (map (lambda (def) '())
+ (lambda.defs proc))))))
+ (begin (for-each (lambda (I)
+ (notepad-var-add! notepad I))
+ (lambda.F proc))
+ (if (not (null? (lambda.defs proc)))
+ (let ((parent (notepad.parent notepad))
+ (defs (lambda.defs proc))
+ (R (lambda.R proc)))
+ (lambda.defs-set!
+ parent
+ (append defs (lambda.defs parent)))
+ (lambda.defs-set! proc '())
+ (lambda.R-set!
+ parent
+ (append (map (lambda (def)
+ (R-lookup R (def.lhs def)))
+ defs)
+ (lambda.R parent)))))
+ (lambda.body proc))
+ exp)))
+ (if (null? for-effect)
+ exp
+ (post-simplify-begin (make-begin (append for-effect (list exp)))
+ notepad)))))
+
+ (notepad-nonescaping-add! notepad proc)
+ (loop1 (lambda.args proc) (call.args exp) '() '()))
+
+; Single assignment analysis performs the transformation
+;
+; (lambda (... I ...)
+; (begin D ...)
+; (quote (... (I <references> ((set! I L)) <calls>) ...) ...)
+; (begin (set! I L) E1 ...))
+; -> (lambda (... IGNORED ...)
+; (begin (define I L) D ...)
+; (quote (... (I <references> () <calls>) ...) ...)
+; (begin E1 ...))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs so
+; that procedure definitions/bindings come first.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-analysis L notepad)
+ (let ((formals (lambda.args L))
+ (defs (lambda.defs L))
+ (R (lambda.R L))
+ (body (lambda.body L)))
+ (define (finish! exprs escapees)
+ (begin.exprs-set! body
+ (append (reverse escapees)
+ exprs))
+ (lambda.body-set! L (post-simplify-begin body '())))
+ (if (begin? body)
+ (let loop ((exprs (begin.exprs body))
+ (escapees '()))
+ (let ((first (car exprs)))
+ (if (and (assignment? first)
+ (not (null? (cdr exprs))))
+ (let ((I (assignment.lhs first))
+ (rhs (assignment.rhs first)))
+ (if (and (lambda? rhs)
+ (local? R I)
+ (= 1 (length (assignments R I))))
+ (if (= (length (calls R I))
+ (length (references R I)))
+ (begin (notepad-nonescaping-add! notepad rhs)
+ (flag-as-ignored I L)
+ (lambda.defs-set! L
+ (cons (make-definition I rhs)
+ (lambda.defs L)))
+ (assignments-set! R I '())
+ (standardize-known-calls
+ rhs
+ (R-entry.calls (R-lookup R I)))
+ (loop (cdr exprs) escapees))
+ (loop (cdr exprs)
+ (cons (car exprs) escapees)))
+ (finish! exprs escapees)))
+ (finish! exprs escapees)))))))
+
+(define (standardize-known-calls L calls)
+ (let ((formals (lambda.args L)))
+ (cond ((not (list? formals))
+ (let* ((newformals (make-null-terminated formals))
+ (n (- (length newformals) 1)))
+ (lambda.args-set! L newformals)
+ (for-each (lambda (call)
+ (if (>= (length (call.args call)) n)
+ (call.args-set!
+ call
+ (append (list-head (call.args call) n)
+ (list
+ (make-call-to-LIST
+ (list-tail (call.args call) n)))))
+ (pass2-error p2error:wna call)))
+ calls)))
+ (else (let ((n (length formals)))
+ (for-each (lambda (call)
+ (if (not (= (length (call.args call)) n))
+ (pass2-error p2error:wna call)))
+ calls))))))
+; Copyright 1991 William D Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 13 November 1998
+;
+; Second pass of the Twobit compiler, part 2:
+; single assignment elimination, assignment elimination,
+; and lambda lifting.
+;
+; See part 1 for further documentation.
+
+; Single assignment elimination performs the transformation
+;
+; (lambda (... I1 ... In ...)
+; (begin D ...)
+; (begin (set! I1 E1)
+; ...
+; (set! In En)
+; E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (let* ((I1 E1) ... (In En))
+; (begin D ...)
+; (begin E ...)))
+;
+; provided for each k:
+;
+; 1. Ik does not occur in E1, ..., Ek.
+; 2. Either E1 through Ek contain no procedure calls
+; or Ik is not referenced by an escaping lambda expression.
+; 3. Ik is assigned only once.
+;
+; I doubt whether the third condition is really necessary, but
+; dropping it would involve a more complex calculation of the
+; revised referencing information.
+;
+; A more precise description of the transformation:
+;
+; (lambda (... I1 ... In ...)
+; (begin (define F1 L1) ...)
+; (quote (... (I1 <references> ((set! I1 E1)) <calls>) ...
+; (In <references> ((set! In En)) <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin (set! I1 E1) ... (set! In En) E ...))
+; -> (lambda (... IGNORED ... IGNORED ...)
+; (begin)
+; (quote (...) ...)
+; ((lambda (I1)
+; (begin)
+; (quote ((I1 <references> () <calls>)) ...)
+; ...
+; ((lambda (In)
+; (begin (define F1 L1) ...)
+; (quote (... (In <references> () <calls>)
+; (F1 <references> () <calls>) ...) ...)
+; (begin E ...))
+; En)
+; ...)
+; E1))
+;
+; For best results, pass 1 should sort internal definitions and LETRECs
+; so that procedure definitions/bindings come first, followed by
+; definitions/bindings whose right hand side contains no calls,
+; followed by definitions/bindings of variables that do not escape,
+; followed by all other definitions/bindings.
+;
+; Pass 1 can't tell which variables escape, however. Pass 2 can't tell
+; which variables escape either until all enclosed lambda expressions
+; have been simplified and the first transformation above has been
+; performed. That is why single assignment analysis precedes single
+; assignment elimination. As implemented here, an assignment that does
+; not satisfy the conditions above will prevent the transformation from
+; being applied to any subsequent assignments.
+;
+; This procedure operates by side effect.
+
+(define (single-assignment-elimination L notepad)
+
+ (if (begin? (lambda.body L))
+
+ (let* ((formals (make-null-terminated (lambda.args L)))
+ (defined (map def.lhs (lambda.defs L)))
+ (escaping (intersection formals
+ (notepad-captured-variables notepad)))
+ (R (lambda.R L)))
+
+ ; Given:
+ ; exprs that remain in the body;
+ ; assigns that will be replaced by let* variables;
+ ; call-has-occurred?, a boolean;
+ ; free variables of the assigns;
+ ; Performs the transformation described above.
+
+ (define (loop exprs assigns call-has-occurred? free)
+ (cond ((null? (cdr exprs))
+ (return exprs assigns))
+ ((assignment? (car exprs))
+ (let ((I1 (assignment.lhs (car exprs)))
+ (E1 (assignment.rhs (car exprs))))
+ (if (and (memq I1 formals)
+ (= (length (assignments R I1)) 1)
+ (not (and call-has-occurred?
+ (memq I1 escaping))))
+ (let* ((free-in-E1 (free-variables E1))
+ (newfree (union free-in-E1 free)))
+ (if (or (memq I1 newfree)
+ (not
+ (empty-set?
+ (intersection free-in-E1 defined))))
+ (return exprs assigns)
+ (loop (cdr exprs)
+ (cons (car exprs) assigns)
+ (or call-has-occurred?
+ (might-return-twice? E1))
+ newfree)))
+ (return exprs assigns))))
+ (else (return exprs assigns))))
+
+ (define (return exprs assigns)
+ (if (not (null? assigns))
+ (let ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (defs (lambda.defs L))
+ (F (lambda.F L))
+ (G (lambda.G L)))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ defs
+ (cons (R-entry R I)
+ (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ (make-begin exprs))))
+ (lambda.defs-set! L '())
+ (for-each (lambda (entry)
+ (lambda.R-set! L (remq entry R)))
+ (lambda.R L2))
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (define (return-loop assigns body)
+ (if (null? assigns)
+ (let ((L3 (call.proc body)))
+ (lambda.body-set! L body)
+ (lambda-lifting L3 L))
+ (let* ((I (assignment.lhs (car assigns)))
+ (E (assignment.rhs (car assigns)))
+ (L3 (call.proc body))
+ (F (remq I (lambda.F L3)))
+ (G (remq I (lambda.G L3))))
+ (flag-as-ignored I L)
+ (assignments-set! R I '())
+ (let ((L2 (make-lambda (list I)
+ '()
+ (list (R-entry R I))
+ F
+ G
+ (lambda.decls L)
+ (lambda.doc L)
+ body)))
+ (lambda.R-set! L (remq (R-entry R I) R))
+ (lambda-lifting L3 L2)
+ (return-loop (cdr assigns) (make-call L2 (list E)))))))
+
+ (loop (begin.exprs (lambda.body L)) '() #f '())))
+
+ L)
+
+; Temporary definitions.
+
+(define (free-variables exp)
+ (case (car exp)
+ ((quote) '())
+ ((lambda) (difference (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ ((set!) (union (list (assignment.lhs exp))
+ (free-variables (assignment.rhs exp))))
+ ((if) (union (free-variables (if.test exp))
+ (free-variables (if.then exp))
+ (free-variables (if.else exp))))
+ ((begin) (if (variable? exp)
+ (list (variable.name exp))
+ (apply union (map free-variables (begin.exprs exp)))))
+ (else (apply union (map free-variables exp)))))
+
+(define (might-return-twice? exp)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (might-return-twice? (assignment.rhs exp)))
+ ((if) (or (might-return-twice? (if.test exp))
+ (might-return-twice? (if.then exp))
+ (might-return-twice? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? might-return-twice? (begin.exprs exp))))
+ (else #t)))
+
+
+; Assignment elimination replaces variables that appear on the left
+; hand side of an assignment by data structures. This is necessary
+; to avoid some nasty complications with lambda lifting.
+;
+; This procedure operates by side effect.
+
+(define (assignment-elimination L)
+ (let ((R (lambda.R L)))
+
+ ; Given a list of entries, return those for assigned variables.
+
+ (define (loop entries assigned)
+ (cond ((null? entries)
+ (if (not (null? assigned))
+ (eliminate assigned)))
+ ((not (null? (R-entry.assignments (car entries))))
+ (loop (cdr entries) (cons (car entries) assigned)))
+ ((null? (R-entry.references (car entries)))
+ (flag-as-ignored (R-entry.name (car entries)) L)
+ (loop (cdr entries) assigned))
+ (else (loop (cdr entries) assigned))))
+
+ ; Given a list of entries for assigned variables I1 ...,
+ ; remove the assignments by replacing the body by a LET of the form
+ ; ((LAMBDA (V1 ...) ...) (MAKE-CELL I1) ...), by replacing references
+ ; by calls to CELL-REF, and by replacing assignments by calls to
+ ; CELL-SET!.
+
+ (define (eliminate assigned)
+ (let* ((oldnames (map R-entry.name assigned))
+ (newnames (map generate-new-name oldnames)))
+ (let ((augmented-entries (map list newnames assigned))
+ (renaming-alist (map cons oldnames newnames))
+ (defs (lambda.defs L)))
+ (for-each cellify! augmented-entries)
+ (for-each (lambda (def)
+ (do ((free (lambda.F (def.rhs def)) (cdr free)))
+ ((null? free))
+ (let ((z (assq (car free) renaming-alist)))
+ (if z
+ (set-car! free (cdr z))))))
+ defs)
+ (let ((newbody
+ (make-call
+ (make-lambda (map car augmented-entries)
+ defs
+ (union (map (lambda (def)
+ (R-entry R (def.lhs def)))
+ defs)
+ (map new-reference-info augmented-entries))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.F L) oldnames))
+ (union (list name:CELL-REF name:CELL-SET!)
+ newnames
+ (difference (lambda.G L) oldnames))
+ (lambda.decls L)
+ (lambda.doc L)
+ (lambda.body L))
+ (map (lambda (name)
+ (make-call (make-variable name:MAKE-CELL)
+ (list (make-variable name))))
+ (map R-entry.name assigned)))))
+ (lambda.F-set! L (union (list name:MAKE-CELL name:CELL-REF name:CELL-SET!)
+ (difference (lambda.F L)
+ (map def.lhs (lambda.defs L)))))
+ (lambda.defs-set! L '())
+ (for-each update-old-reference-info!
+ (map (lambda (arg)
+ (car (call.args arg)))
+ (call.args newbody)))
+ (lambda.body-set! L newbody)
+ (lambda-lifting (call.proc newbody) L)))))
+
+ (define (generate-new-name name)
+ (string->symbol (string-append cell-prefix (symbol->string name))))
+
+ ; In addition to replacing references and assignments involving the
+ ; old variable by calls to CELL-REF and CELL-SET! on the new, CELLIFY!
+ ; uses the old entry to collect the referencing information for the
+ ; new variable.
+
+ (define (cellify! augmented-entry)
+ (let ((newname (car augmented-entry))
+ (entry (cadr augmented-entry)))
+ (do ((refs (R-entry.references entry)
+ (cdr refs)))
+ ((null? refs))
+ (let* ((reference (car refs))
+ (newref (make-variable newname)))
+ (set-car! reference (make-variable name:CELL-REF))
+ (set-car! (cdr reference) newref)
+ (set-car! refs newref)))
+ (do ((assigns (R-entry.assignments entry)
+ (cdr assigns)))
+ ((null? assigns))
+ (let* ((assignment (car assigns))
+ (newref (make-variable newname)))
+ (set-car! assignment (make-variable name:CELL-SET!))
+ (set-car! (cdr assignment) newref)
+ (R-entry.references-set! entry
+ (cons newref
+ (R-entry.references entry)))))
+ (R-entry.assignments-set! entry '())))
+
+ ; This procedure creates a brand new entry for a new variable, extracting
+ ; the references stored in the old entry by CELLIFY!.
+
+ (define (new-reference-info augmented-entry)
+ (make-R-entry (car augmented-entry)
+ (R-entry.references (cadr augmented-entry))
+ '()
+ '()))
+
+ ; This procedure updates the old entry to reflect the fact that it is
+ ; now referenced once and never assigned.
+
+ (define (update-old-reference-info! ref)
+ (references-set! R (variable.name ref) (list ref))
+ (assignments-set! R (variable.name ref) '())
+ (calls-set! R (variable.name ref) '()))
+
+ (loop R '())))
+
+; Lambda lifting raises internal definitions to outer scopes to avoid
+; having to choose between creating a closure or losing tail recursion.
+; If L is not #f, then L2 is a lambda expression nested within L.
+; Any internal definitions that occur within L2 may be lifted to L
+; by adding extra arguments to the defined procedure and to all calls to it.
+; Lambda lifting is not a clear win, because the extra arguments could
+; easily become more expensive than creating a closure and referring
+; to the non-local arguments through the closure. The heuristics used
+; to decide whether to lift a group of internal definitions are isolated
+; within the POLICY:LIFT? procedure.
+
+; L2 can be the same as L, so the order of side effects is critical.
+
+(define (lambda-lifting L2 L)
+
+ ; The call to sort is optional. It gets the added arguments into
+ ; the same order they appear in the formals list, which is an
+ ; advantage for register targeting.
+
+ (define (lift L2 L args-to-add)
+ (let ((formals (make-null-terminated (lambda.args L2))))
+ (do ((defs (lambda.defs L2) (cdr defs))
+ (args-to-add args-to-add (cdr args-to-add)))
+ ((null? defs))
+ (let* ((def (car defs))
+ (entry (R-lookup (lambda.R L2) (def.lhs def)))
+ (calls (R-entry.calls entry))
+ (added (twobit-sort (lambda (x y)
+ (let ((xx (memq x formals))
+ (yy (memq y formals)))
+ (if (and xx yy)
+ (> (length xx) (length yy))
+ #t)))
+ (car args-to-add)))
+ (L3 (def.rhs def)))
+ ; The flow equation guarantees that these added arguments
+ ; will occur free by the time this round of lifting is done.
+ (lambda.F-set! L3 (union added (lambda.F L3)))
+ (lambda.args-set! L3 (append added (lambda.args L3)))
+ (for-each (lambda (call)
+ (let ((newargs (map make-variable added)))
+ ; The referencing information is made obsolete here!
+ (call.args-set! call
+ (append newargs (call.args call)))))
+ calls)
+ (lambda.R-set! L2 (remq entry (lambda.R L2)))
+ (lambda.R-set! L (cons entry (lambda.R L)))
+ ))
+ (if (not (eq? L2 L))
+ (begin
+ (lambda.defs-set! L (append (lambda.defs L2) (lambda.defs L)))
+ (lambda.defs-set! L2 '())))))
+
+ (if L
+ (if (not (null? (lambda.defs L2)))
+ (let ((args-to-add (compute-added-arguments
+ (lambda.defs L2)
+ (make-null-terminated (lambda.args L2)))))
+ (if (POLICY:LIFT? L2 L args-to-add)
+ (lift L2 L args-to-add))))))
+
+; Given a list of definitions ((define f1 ...) ...) and a set of formals
+; N over which the definitions may be lifted, returns a list of the
+; subsets of N that need to be added to each procedure definition
+; as new arguments.
+;
+; Algorithm: Let F_i be the variables that occur free in the body of
+; the lambda expression associated with f_i. Construct the call graph.
+; Solve the flow equations
+;
+; A_i = (F_i /\ N) \/ (\/ {A_j | A_i calls A_j})
+;
+; where /\ is intersection and \/ is union.
+
+(define (compute-added-arguments defs formals)
+ (let ((procs (map def.lhs defs))
+ (freevars (map lambda.F (map def.rhs defs))))
+ (let ((callgraph (map (lambda (names)
+ (map (lambda (name)
+ (position name procs))
+ (intersection names procs)))
+ freevars))
+ (added_0 (map (lambda (names)
+ (intersection names formals))
+ freevars)))
+ (vector->list
+ (compute-fixedpoint
+ (make-vector (length procs) '())
+ (list->vector (map (lambda (term0 indexes)
+ (lambda (approximations)
+ (union term0
+ (apply union
+ (map (lambda (i)
+ (vector-ref approximations i))
+ indexes)))))
+ added_0
+ callgraph))
+ set-equal?)))))
+
+(define (position x l)
+ (cond ((eq? x (car l)) 0)
+ (else (+ 1 (position x (cdr l))))))
+
+; Given a vector of starting approximations,
+; a vector of functions that compute a next approximation
+; as a function of the vector of approximations,
+; and an equality predicate,
+; returns a vector of fixed points.
+
+(define (compute-fixedpoint v functions equiv?)
+ (define (loop i flag)
+ (if (negative? i)
+ (if flag
+ (loop (- (vector-length v) 1) #f)
+ v)
+ (let ((next_i ((vector-ref functions i) v)))
+ (if (equiv? next_i (vector-ref v i))
+ (loop (- i 1) flag)
+ (begin (vector-set! v i next_i)
+ (loop (- i 1) #t))))))
+ (loop (- (vector-length v) 1) #f))
+
+
+; Given a lambda expression L2, its parent lambda expression
+; L (which may be the same as L2, or #f), and a list of the
+; lists of arguments that would need to be added to known
+; local procedures, returns #t iff lambda lifting should be done.
+;
+; Here are some heuristics:
+;
+; Don't lift if it means adding too many arguments.
+; Don't lift large groups of definitions.
+; In questionable cases it is better to lift to an outer
+; lambda expression that already contains internal
+; definitions than to one that doesn't.
+; It is better not to lift if the body contains a lambda
+; expression that has to be closed anyway.
+
+(define (POLICY:LIFT? L2 L args-to-add)
+ (and (lambda-optimizations)
+ (not (lambda? (lambda.body L2)))
+ (every? (lambda (addlist)
+ (< (length addlist) 6))
+ args-to-add)))
+; Copyright 1991 William D Clinger (for SIMPLIFY-CONDITIONAL)
+; Copyright 1999 William D Clinger (for everything else)
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 April 1999.
+;
+; Some source transformations on IF expressions:
+;
+; (if '#f E1 E2) E2
+; (if 'K E1 E2) E1 K != #f
+; (if (if B0 '#f '#f) E1 E2) (begin B0 E2)
+; (if (if B0 '#f 'K ) E1 E2) (if B0 E2 E1) K != #f
+; (if (if B0 'K '#f) E1 E2) (if B0 E1 E2) K != #f
+; (if (if B0 'K1 'K2) E1 E2) (begin B0 E1) K1, K2 != #f
+; (if (if B0 (if B1 #t #f) B2) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if B0 B1 (if B2 #t #f)) E1 E2) (if (if B0 B1 B2) E1 E2)
+; (if (if X X B0 ) E1 E2) (if (if X #t B0) E1 E2) X a variable
+; (if (if X B0 X ) E1 E2) (if (if X B0 #f) E1 E2) X a variable
+; (if ((lambda (X) (if ((lambda (X)
+; (if X X B2)) B0) (if X #t (if B2 #t #f))) B0)
+; E1 E2) E1 E2)
+; (if (begin ... B0) E1 E2) (begin ... (if B0 E1 E2))
+; (if (not E0) E1 E2) (if E0 E2 E1) not is integrable
+;
+; FIXME: Three of the transformations above are intended to clean up
+; the output of the OR macro. It isn't yet clear how well this works.
+
+(define (simplify-conditional exp notepad)
+ (define (coercion-to-boolean? exp)
+ (and (conditional? exp)
+ (let ((E1 (if.then exp))
+ (E2 (if.else exp)))
+ (and (constant? E1)
+ (eq? #t (constant.value E1))
+ (constant? E2)
+ (eq? #f (constant.value E2))))))
+ (if (not (control-optimization))
+ (begin (if.test-set! exp (simplify (if.test exp) notepad))
+ (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp)
+ (let* ((test (if.test exp)))
+ (if (and (call? test)
+ (lambda? (call.proc test))
+ (let* ((L (call.proc test))
+ (body (lambda.body L)))
+ (and (conditional? body)
+ (let ((R (lambda.R L))
+ (B0 (if.test body))
+ (B1 (if.then body)))
+ (and (variable? B0)
+ (variable? B1)
+ (let ((x (variable.name B0)))
+ (and (eq? x (variable.name B1))
+ (local? R x)
+ (= 1 (length R))
+ (= 1 (length (call.args test))))))))))
+ (let* ((L (call.proc test))
+ (R (lambda.R L))
+ (body (lambda.body L))
+ (ref (if.then body))
+ (x (variable.name ref))
+ (entry (R-entry R x)))
+ (if.then-set! body (make-constant #t))
+ (if.else-set! body
+ (make-conditional (if.else body)
+ (make-constant #t)
+ (make-constant #f)))
+ (R-entry.references-set! entry
+ (remq ref
+ (R-entry.references entry)))
+ (simplify-conditional exp notepad))
+ (let loop ((test (simplify (if.test exp) notepad)))
+ (if.test-set! exp test)
+ (cond ((constant? test)
+ (simplify (if (constant.value test)
+ (if.then exp)
+ (if.else exp))
+ notepad))
+ ((and (conditional? test)
+ (constant? (if.then test))
+ (constant? (if.else test)))
+ (cond ((and (constant.value (if.then test))
+ (constant.value (if.else test)))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.then exp)
+ notepad)))
+ notepad))
+ ((and (not (constant.value (if.then test)))
+ (not (constant.value (if.else test))))
+ (post-simplify-begin
+ (make-begin (list (if.test test)
+ (simplify (if.else exp)
+ notepad)))
+ notepad))
+ (else (if (not (constant.value (if.then test)))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp)))
+ (if.test-set! exp (if.test test))
+ (loop (if.test exp)))))
+ ((and (conditional? test)
+ (or (coercion-to-boolean? (if.then test))
+ (coercion-to-boolean? (if.else test))))
+ (if (coercion-to-boolean? (if.then test))
+ (if.then-set! test (if.test (if.then test)))
+ (if.else-set! test (if.test (if.else test))))
+ (loop test))
+ ((and (conditional? test)
+ (variable? (if.test test))
+ (let ((x (variable.name (if.test test))))
+ (or (and (variable? (if.then test))
+ (eq? x (variable.name (if.then test)))
+ 1)
+ (and (variable? (if.else test))
+ (eq? x (variable.name (if.else test)))
+ 2))))
+ =>
+ (lambda (n)
+ (case n
+ ((1) (if.then-set! test (make-constant #t)))
+ ((2) (if.else-set! test (make-constant #f))))
+ (loop test)))
+ ((begin? test)
+ (let ((exprs (reverse (begin.exprs test))))
+ (if.test-set! exp (car exprs))
+ (post-simplify-begin
+ (make-begin (reverse (cons (loop (car exprs))
+ (cdr exprs))))
+ notepad)))
+ ((and (call? test)
+ (variable? (call.proc test))
+ (eq? (variable.name (call.proc test)) name:NOT)
+ (integrable? name:NOT)
+ (integrate-usual-procedures)
+ (= (length (call.args test)) 1))
+ (let ((temp (if.then exp)))
+ (if.then-set! exp (if.else exp))
+ (if.else-set! exp temp))
+ (loop (car (call.args test))))
+ (else
+ (simplify-case exp notepad))))))))
+
+; Given a conditional expression whose test has been simplified,
+; simplifies the then and else parts while applying optimizations
+; for CASE expressions.
+; Precondition: (control-optimization) is true.
+
+(define (simplify-case exp notepad)
+ (let ((E0 (if.test exp)))
+ (if (and (call? E0)
+ (variable? (call.proc E0))
+ (let ((name (variable.name (call.proc E0))))
+ ; FIXME: Should ensure that the name is integrable,
+ ; but MEMQ and MEMV probably aren't according to the
+ ; INTEGRABLE? predicate.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (integrate-usual-procedures)
+ (= (length (call.args E0)) 2)
+ (variable? (car (call.args E0)))
+ (constant? (cadr (call.args E0))))
+ (simplify-case-clauses (variable.name (car (call.args E0)))
+ exp
+ notepad)
+ (begin (if.then-set! exp (simplify (if.then exp) notepad))
+ (if.else-set! exp (simplify (if.else exp) notepad))
+ exp))))
+
+; Code generation for case expressions.
+;
+; A case expression turns into a conditional expression
+; of the form
+;
+; CASE{I} ::= E | (if (PRED I K) E CASE{I})
+; PRED ::= memv | memq | eqv? | eq?
+;
+; The memq and eq? predicates are used when the constant
+; is a (list of) boolean, fixnum, char, empty list, or symbol.
+; The constants will almost always be of these types.
+;
+; The first step is to remove duplicated constants and to
+; collect all the case clauses, sorting them into the following
+; categories based on their simplified list of constants:
+; constants are fixnums
+; constants are characters
+; constants are symbols
+; constants are of mixed or other type
+; After duplicated constants have been removed, the predicates
+; for these clauses can be tested in any order.
+
+; Given the name of an arbitrary variable, an expression that
+; has not yet been simplified or can safely be simplified again,
+; and a notepad, returns the expression after simplification.
+; If the expression is equivalent to a case expression that dispatches
+; on the given variable, then case-optimization will be applied.
+
+(define (simplify-case-clauses var0 E notepad)
+
+ (define notepad2 (make-notepad (notepad.parent notepad)))
+
+ (define (collect-clauses E fix chr sym other constants)
+ (if (not (conditional? E))
+ (analyze (simplify E notepad2)
+ fix chr sym other constants)
+ (let ((test (simplify (if.test E) notepad2))
+ (code (simplify (if.then E) notepad2)))
+ (if.test-set! E test)
+ (if.then-set! E code)
+ (if (not (call? test))
+ (finish E fix chr sym other constants)
+ (let ((proc (call.proc test))
+ (args (call.args test)))
+ (if (not (and (variable? proc)
+ (let ((name (variable.name proc)))
+ ; FIXME: See note above.
+ (or (eq? name name:EQ?)
+ (eq? name name:EQV?)
+ (eq? name name:MEMQ)
+ (eq? name name:MEMV)))
+ (= (length args) 2)
+ (variable? (car args))
+ (eq? (variable.name (car args)) var0)
+ (constant? (cadr args))))
+ (finish E fix chr sym other constants)
+ (let ((pred (variable.name proc))
+ (datum (constant.value (cadr args))))
+ ; FIXME
+ (if (or (and (or (eq? pred name:MEMV)
+ (eq? pred name:MEMQ))
+ (not (list? datum)))
+ (and (eq? pred name:EQ?)
+ (not (eqv-is-ok? datum)))
+ (and (eq? pred name:MEMQ)
+ (not (every? (lambda (datum)
+ (eqv-is-ok? datum))
+ datum))))
+ (finish E fix chr sym other constants)
+ (call-with-values
+ (lambda ()
+ (remove-duplicates (if (or (eq? pred name:EQV?)
+ (eq? pred name:EQ?))
+ (list datum)
+ datum)
+ constants))
+ (lambda (data constants)
+ (let ((clause (list data code))
+ (E2 (if.else E)))
+ (cond ((every? smallint? data)
+ (collect-clauses E2
+ (cons clause fix)
+ chr
+ sym
+ other
+ constants))
+ ((every? char? data)
+ (collect-clauses E2
+ fix
+ (cons clause chr)
+ sym
+ other
+ constants))
+ ((every? symbol? data)
+ (collect-clauses E2
+ fix
+ chr
+ (cons clause sym)
+ other
+ constants))
+ (else
+ (collect-clauses E2
+ fix
+ chr
+ sym
+ (cons clause other)
+ constants))))))))))))))
+
+ (define (remove-duplicates data set)
+ (let loop ((originals data)
+ (data '())
+ (set set))
+ (if (null? originals)
+ (values data set)
+ (let ((x (car originals))
+ (originals (cdr originals)))
+ (if (memv x set)
+ (loop originals data set)
+ (loop originals (cons x data) (cons x set)))))))
+
+ (define (finish E fix chr sym other constants)
+ (if.else-set! E (simplify (if.else E) notepad2))
+ (analyze E fix chr sym other constants))
+
+ (define (analyze default fix chr sym other constants)
+ (notepad-var-add! notepad2 var0)
+ (for-each (lambda (L)
+ (notepad-lambda-add! notepad L))
+ (notepad.lambdas notepad2))
+ (for-each (lambda (L)
+ (notepad-nonescaping-add! notepad L))
+ (notepad.nonescaping notepad2))
+ (for-each (lambda (var)
+ (notepad-var-add! notepad var))
+ (append (list name:FIXNUM?
+ name:CHAR?
+ name:SYMBOL?
+ name:FX<
+ name:FX-
+ name:CHAR->INTEGER
+ name:VECTOR-REF)
+ (notepad.vars notepad2)))
+ (analyze-clauses (notepad.vars notepad2)
+ var0
+ default
+ (reverse fix)
+ (reverse chr)
+ (reverse sym)
+ (reverse other)
+ constants))
+
+ (collect-clauses E '() '() '() '() '()))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eqv-is-ok? x)
+ (or (smallint? x)
+ (char? x)
+ (symbol? x)
+ (boolean? x)))
+
+; Returns true if EQ? and EQV? behave the same on x.
+
+(define (eq-is-ok? x)
+ (eqv-is-ok? x))
+
+; Any case expression that dispatches on a variable var0 and whose
+; constants are disjoint can be compiled as
+;
+; (let ((n (cond ((eq? var0 'K1) ...) ; miscellaneous constants
+; ...
+; ((fixnum? var0)
+; <dispatch-on-fixnum>)
+; ((char? var0)
+; <dispatch-on-char>)
+; ((symbol? var0)
+; <dispatch-on-symbols>)
+; (else 0))))
+; <dispatch-on-case-number>)
+;
+; where the <dispatch-on-case-number> uses binary search within
+; the interval [0, p+1), where p is the number of non-default cases.
+;
+; On the SPARC, sequential search is faster if there are fewer than
+; 8 constants, and sequential search uses less than half the space
+; if there are fewer than 10 constants. Most target machines should
+; similar, so I'm hard-wiring this constant.
+; FIXME: The hardwired constant is annoying.
+
+(define (analyze-clauses F var0 default fix chr sym other constants)
+ (cond ((or (and (null? fix)
+ (null? chr))
+ (< (length constants) 12))
+ (implement-clauses-by-sequential-search var0
+ default
+ (append fix chr sym other)))
+ (else
+ (implement-clauses F var0 default fix chr sym other constants))))
+
+; Implements the general technique described above.
+
+(define (implement-clauses F var0 default fix chr sym other constants)
+ (let* ((name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ (entry (make-R-entry name:n '() '() '()))
+ (F (union (make-set (list name:n)) F))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-case-dispatch
+ name:n
+ (cons default
+ (map cadr
+ ; The order here must match the order
+ ; used by IMPLEMENT-DISPATCH.
+ (append other fix chr sym)))))))
+ (make-call L
+ (list (implement-dispatch 0
+ var0
+ (map car other)
+ (map car fix)
+ (map car chr)
+ (map car sym))))))
+
+(define (implement-case-dispatch var0 exprs)
+ (implement-intervals var0
+ (map (lambda (n code)
+ (list n (+ n 1) code))
+ (iota (length exprs))
+ exprs)))
+
+; Given the number of prior clauses,
+; the variable on which to dispatch,
+; a list of constant lists for mixed or miscellaneous clauses,
+; a list of constant lists for the fixnum clauses,
+; a list of constant lists for the character clauses, and
+; a list of constant lists for the symbol clauses,
+; returns code that computes the index of the selected clause.
+; The mixed/miscellaneous clauses must be tested first because
+; Twobit's SMALLINT? predicate might not be true of all fixnums
+; on the target machine, which means that Twobit might classify
+; some fixnums as miscellaneous.
+
+(define (implement-dispatch prior var0 other fix chr sym)
+ (cond ((not (null? other))
+ (implement-dispatch-other
+ (implement-dispatch (+ prior (length other))
+ var0 fix chr sym '())
+ prior var other))
+ ((not (null? fix))
+ (make-conditional (make-call (make-variable name:FIXNUM?)
+ (list (make-variable var0)))
+ (implement-dispatch-fixnum prior var0 fix)
+ (implement-dispatch (+ prior (length fix))
+ var0 '() chr sym other)))
+ ((not (null? chr))
+ (make-conditional (make-call (make-variable name:CHAR?)
+ (list (make-variable var0)))
+ (implement-dispatch-char prior var0 chr)
+ (implement-dispatch (+ prior (length chr))
+ var0 fix '() sym other)))
+ ((not (null? sym))
+ (make-conditional (make-call (make-variable name:SYMBOL?)
+ (list (make-variable var0)))
+ (implement-dispatch-symbol prior var0 sym)
+ (implement-dispatch (+ prior (length sym))
+ var0 fix chr '() other)))
+ (else
+ (make-constant 0))))
+
+; The value of var0 will be known to be a fixnum.
+; Can use table lookup, binary search, or sequential search.
+; FIXME: Never uses sequential search, which is best when
+; there are only a few constants, with gaps between them.
+
+(define (implement-dispatch-fixnum prior var0 lists)
+
+ (define (calculate-intervals n lists)
+ (define (loop n lists intervals)
+ (if (null? lists)
+ (twobit-sort (lambda (interval1 interval2)
+ (< (car interval1) (car interval2)))
+ intervals)
+ (let ((constants (twobit-sort < (car lists))))
+ (loop (+ n 1)
+ (cdr lists)
+ (append (extract-intervals n constants)
+ intervals)))))
+ (loop n lists '()))
+
+ (define (extract-intervals n constants)
+ (if (null? constants)
+ '()
+ (let ((k0 (car constants)))
+ (do ((constants (cdr constants) (cdr constants))
+ (k1 (+ k0 1) (+ k1 1)))
+ ((or (null? constants)
+ (not (= k1 (car constants))))
+ (cons (list k0 k1 (make-constant n))
+ (extract-intervals n constants)))))))
+
+ (define (complete-intervals intervals)
+ (cond ((null? intervals)
+ intervals)
+ ((null? (cdr intervals))
+ intervals)
+ (else
+ (let* ((i1 (car intervals))
+ (i2 (cadr intervals))
+ (end1 (cadr i1))
+ (start2 (car i2))
+ (intervals (complete-intervals (cdr intervals))))
+ (if (= end1 start2)
+ (cons i1 intervals)
+ (cons i1
+ (cons (list end1 start2 (make-constant 0))
+ intervals)))))))
+
+ (let* ((intervals (complete-intervals
+ (calculate-intervals (+ prior 1) lists)))
+ (lo (car (car intervals)))
+ (hi (car (car (reverse intervals))))
+ (p (length intervals)))
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant lo)))
+ (make-constant 0)
+ (make-conditional
+ (make-call (make-variable name:FX<)
+ (list (make-variable var0)
+ (make-constant (+ hi 1))))
+ ; The static cost of table lookup is about hi - lo words.
+ ; The static cost of binary search is about 5 SPARC instructions
+ ; per interval.
+ (if (< (- hi lo) (* 5 p))
+ (implement-table-lookup var0 (+ prior 1) lists lo hi)
+ (implement-intervals var0 intervals))
+ (make-constant 0)))))
+
+(define (implement-dispatch-char prior var0 lists)
+ (let* ((lists (map (lambda (constants)
+ (map compat:char->integer constants))
+ lists))
+ (name:n ((make-rename-procedure) 'n))
+ ; Referencing information is destroyed by pass 2.
+ ;(entry (make-R-entry name:n '() '() '()))
+ (F (list name:n name:EQ? name:FX< name:FX- name:VECTOR-REF))
+ (L (make-lambda
+ (list name:n)
+ '()
+ '() ; entry
+ F
+ '()
+ '()
+ #f
+ (implement-dispatch-fixnum prior name:n lists))))
+ (make-call L
+ (make-call (make-variable name:CHAR->INTEGER)
+ (list (make-variable var0))))))
+
+(define (implement-dispatch-symbol prior var0 lists)
+ (implement-dispatch-other (make-constant 0) prior var0 lists))
+
+(define (implement-dispatch-other default prior var0 lists)
+ (if (null? lists)
+ default
+ (let* ((constants (car lists))
+ (lists (cdr lists))
+ (n (+ prior 1)))
+ (make-conditional (make-call-to-memv var0 constants)
+ (make-constant n)
+ (implement-dispatch-other default n var0 lists)))))
+
+(define (make-call-to-memv var0 constants)
+ (cond ((null? constants)
+ (make-constant #f))
+ ((null? (cdr constants))
+ (make-call-to-eqv var0 (car constants)))
+ (else
+ (make-conditional (make-call-to-eqv var0 (car constants))
+ (make-constant #t)
+ (make-call-to-memv var0 (cdr constants))))))
+
+(define (make-call-to-eqv var0 constant)
+ (make-call (make-variable
+ (if (eq-is-ok? constant)
+ name:EQ?
+ name:EQV?))
+ (list (make-variable var0)
+ (make-constant constant))))
+
+; Given a variable whose value is known to be a fixnum,
+; the clause index for the first fixnum clause,
+; an ordered list of lists of constants for fixnum-only clauses,
+; and the least and greatest constants in those lists,
+; returns code for a table lookup.
+
+(define (implement-table-lookup var0 index lists lo hi)
+ (let ((v (make-vector (+ 1 (- hi lo)) 0)))
+ (do ((index index (+ index 1))
+ (lists lists (cdr lists)))
+ ((null? lists))
+ (for-each (lambda (k)
+ (vector-set! v (- k lo) index))
+ (car lists)))
+ (make-call (make-variable name:VECTOR-REF)
+ (list (make-constant v)
+ (make-call (make-variable name:FX-)
+ (list (make-variable var0)
+ (make-constant lo)))))))
+
+; Given a variable whose value is known to lie within the
+; half-open interval [m0, mk), and an ordered complete
+; list of intervals of the form
+;
+; ((m0 m1 code0)
+; (m1 m2 code1)
+; ...
+; (m{k-1} mk code{k-1})
+; )
+;
+; returns an expression that finds the unique i such that
+; var0 lies within [mi, m{i+1}), and then executes code{i}.
+
+(define (implement-intervals var0 intervals)
+ (if (null? (cdr intervals))
+ (caddr (car intervals))
+ (let ((n (quotient (length intervals) 2)))
+ (do ((n n (- n 1))
+ (intervals1 '() (cons (car intervals2) intervals1))
+ (intervals2 intervals (cdr intervals2)))
+ ((zero? n)
+ (let ((intervals1 (reverse intervals1))
+ (m (car (car intervals2))))
+ (make-conditional (make-call (make-variable name:FX<)
+ (list
+ (make-variable var0)
+ (make-constant m)))
+ (implement-intervals var0 intervals1)
+ (implement-intervals var0 intervals2))))))))
+
+; The brute force approach.
+; Given the variable on which the dispatch is being performed, and
+; actual (simplified) code for the default clause and
+; for all other clauses,
+; returns code to perform the dispatch by sequential search.
+
+(define *memq-threshold* 20)
+(define *memv-threshold* 4)
+
+(define (implement-clauses-by-sequential-search var0 default clauses)
+ (if (null? clauses)
+ default
+ (let* ((case1 (car clauses))
+ (clauses (cdr clauses))
+ (constants1 (car case1))
+ (code1 (cadr case1)))
+ (make-conditional (make-call-to-memv var0 constants1)
+ code1
+ (implement-clauses-by-sequential-search
+ var0 default clauses)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 13 April 1999.
+;
+; The tail and non-tail call graphs of known and unknown procedures.
+;
+; Given an expression E returned by pass 2 of Twobit,
+; returns a list of the following form:
+;
+; ((#t L () <tailcalls> <nontailcalls> <size> #f)
+; (<name> L <vars> <tailcalls> <nontailcalls> <size> #f)
+; ...)
+;
+; where
+;
+; Each L is a lambda expression that occurs within E
+; as either an escaping lambda expression or as a known
+; procedure. If L is a known procedure, then <name> is
+; its name; otherwise <name> is #f.
+;
+; <vars> is a list of the non-global variables within whose
+; scope L occurs.
+;
+; <tailcalls> is a complete list of names of known local procedures
+; that L calls tail-recursively, disregarding calls from other known
+; procedures or escaping lambda expressions that occur within L.
+;
+; <nontailcalls> is a complete list of names of known local procedures
+; that L calls non-tail-recursively, disregarding calls from other
+; known procedures or escaping lambda expressions that occur within L.
+;
+; <size> is a measure of the size of L, including known procedures
+; and escaping lambda expressions that occur within L.
+
+(define (callgraphnode.name x) (car x))
+(define (callgraphnode.code x) (cadr x))
+(define (callgraphnode.vars x) (caddr x))
+(define (callgraphnode.tailcalls x) (cadddr x))
+(define (callgraphnode.nontailcalls x) (car (cddddr x)))
+(define (callgraphnode.size x) (cadr (cddddr x)))
+(define (callgraphnode.info x) (caddr (cddddr x)))
+
+(define (callgraphnode.size! x v) (set-car! (cdr (cddddr x)) v) #f)
+(define (callgraphnode.info! x v) (set-car! (cddr (cddddr x)) v) #f)
+
+(define (callgraph exp)
+
+ ; Returns (union (list x) z).
+
+ (define (adjoin x z)
+ (if (memq x z)
+ z
+ (cons x z)))
+
+ (let ((result '()))
+
+ ; Given a <name> as described above, a lambda expression, a list
+ ; of variables that are in scope, and a list of names of known
+ ; local procedure that are in scope, computes an entry for L and
+ ; entries for any nested known procedures or escaping lambda
+ ; expressions, and adds them to the result.
+
+ (define (add-vertex! name L vars known)
+
+ (let ((tailcalls '())
+ (nontailcalls '())
+ (size 0))
+
+ ; Given an expression, a list of variables that are in scope,
+ ; a list of names of known local procedures that are in scope,
+ ; and a boolean indicating whether the expression occurs in a
+ ; tail context, adds any tail or non-tail calls to known
+ ; procedures that occur within the expression to the list
+ ; variables declared above.
+
+ (define (graph! exp vars known tail?)
+ (set! size (+ size 1))
+ (case (car exp)
+
+ ((quote) #f)
+
+ ((lambda) (add-vertex! #f exp vars known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+
+ ((set!) (graph! (assignment.rhs exp) vars known #f))
+
+ ((if) (graph! (if.test exp) vars known #f)
+ (graph! (if.then exp) vars known tail?)
+ (graph! (if.else exp) vars known tail?))
+
+ ((begin) (if (not (variable? exp))
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (graph! (car exprs) vars known tail?))
+ (graph! (car exprs) vars known #f))))
+
+ (else (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let ((name (variable.name proc)))
+ (if (memq name known)
+ (if tail?
+ (set! tailcalls
+ (adjoin name tailcalls))
+ (set! nontailcalls
+ (adjoin name nontailcalls))))))
+ ((lambda? proc)
+ (graph-lambda! proc vars known tail?))
+ (else
+ (graph! proc vars known #f)))
+ (for-each (lambda (exp)
+ (graph! exp vars known #f))
+ (call.args exp))))))
+
+ (define (graph-lambda! L vars known tail?)
+ (let* ((defs (lambda.defs L))
+ (newknown (map def.lhs defs))
+ (vars (append newknown
+ (make-null-terminated
+ (lambda.args L))
+ vars))
+ (known (append newknown known)))
+ (for-each (lambda (def)
+ (add-vertex! (def.lhs def)
+ (def.rhs def)
+ vars
+ known)
+ (set! size
+ (+ size
+ (callgraphnode.size (car result)))))
+ defs)
+ (graph! (lambda.body L) vars known tail?)))
+
+ (graph-lambda! L vars known #t)
+
+ (set! result
+ (cons (list name L vars tailcalls nontailcalls size #f)
+ result))))
+
+ (add-vertex! #t
+ (make-lambda '() '() '() '() '() '() '() exp)
+ '()
+ '())
+ result))
+
+; Displays the callgraph, for debugging.
+
+(define (view-callgraph g)
+ (for-each (lambda (entry)
+ (let ((name (callgraphnode.name entry))
+ (exp (callgraphnode.code entry))
+ (vars (callgraphnode.vars entry))
+ (tail (callgraphnode.tailcalls entry))
+ (nt (callgraphnode.nontailcalls entry))
+ (size (callgraphnode.size entry)))
+ (cond ((symbol? name)
+ (write name))
+ (name
+ (display "TOP LEVEL EXPRESSION"))
+ (else
+ (display "ESCAPING LAMBDA EXPRESSION")))
+ (display ":")
+ (newline)
+ (display "Size: ")
+ (write size)
+ (newline)
+ ;(newline)
+ ;(display "Variables in scope: ")
+ ;(write vars)
+ ;(newline)
+ (display "Tail calls: ")
+ (write tail)
+ (newline)
+ (display "Non-tail calls: ")
+ (write nt)
+ (newline)
+ ;(newline)
+ ;(pretty-print (make-readable exp))
+ ;(newline)
+ ;(newline)
+ (newline)))
+ g))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Inlining of known local procedures.
+;
+; First find the known and escaping procedures and compute the call graph.
+;
+; If a known local procedure is not called at all, then delete its code.
+;
+; If a known local procedure is called exactly once,
+; then inline its code at the call site and delete the
+; known local procedure. Change the size of the code
+; at the call site by adding the size of the inlined code.
+;
+; Divide the remaining known and escaping procedures into categories:
+; 1. makes no calls to known local procedures
+; 2. known procedures that call known procedures;
+; within this category, try to sort so that procedures do not
+; call procedures that come later in the sequence; or sort by
+; number of calls and/or size
+; 3. escaping procedures that call known procedures
+;
+; Approve each procedure in category 1 for inlining if its code size
+; is less than some threshold.
+;
+; For each procedure in categories 2 and 3, traverse its code, inlining
+; where it seems like a good idea. The compiler should be more aggressive
+; about inlining non-tail calls than tail calls because:
+;
+; Inlining a non-tail call can eliminate a stack frame
+; or expose the inlined code to loop optimizations.
+;
+; The main reason for inlining a tail call is to enable
+; intraprocedural optimizations or to unroll a loop.
+;
+; After inlining has been performed on a known local procedure,
+; then approve it for inlining if its size is less than some threshold.
+;
+; FIXME:
+; This strategy avoids infinite unrolling, but it also avoids finite
+; unrolling of loops.
+
+; Parameters to control inlining.
+; These can be tuned later.
+
+(define *tail-threshold* 10)
+(define *nontail-threshold* 20)
+(define *multiplier* 300)
+
+; Given a callgraph, performs inlining of known local procedures
+; by side effect. The original expression must then be copied to
+; reinstate Twobit's invariants.
+
+; FIXME: This code doesn't yet do the right thing with known local
+; procedures that aren't called or are called in exactly one place.
+
+(define (inline-using-callgraph! g)
+ (let ((known (make-hashtable))
+ (category2 '())
+ (category3 '()))
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (tcalls (callgraphnode.tailcalls node))
+ (ncalls (callgraphnode.nontailcalls node)))
+ (if (symbol? name)
+ (hashtable-put! known name node))
+ (if (and (null? tcalls)
+ (null? ncalls))
+ (if (< (callgraphnode.size node)
+ *nontail-threshold*)
+ (callgraphnode.info! node #t))
+ (if (symbol? name)
+ (set! category2 (cons node category2))
+ (set! category3 (cons node category3))))))
+ g)
+ (set! category2 (twobit-sort (lambda (x y)
+ (< (callgraphnode.size x)
+ (callgraphnode.size y)))
+ category2))
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category2)
+ (for-each (lambda (node)
+ (inline-node! node known))
+ category3)
+ ; FIXME:
+ ; Inlining destroys the callgraph, so maybe this cleanup is useless.
+ (hashtable-for-each (lambda (name node) (callgraphnode.info! node #f))
+ known)))
+
+; Given a node of the callgraph and a hash table of nodes for
+; known local procedures, performs inlining by side effect.
+
+(define (inline-node! node known)
+ (let* ((debugging? #f)
+ (name (callgraphnode.name node))
+ (exp (callgraphnode.code node))
+ (size0 (callgraphnode.size node))
+ (budget (quotient (* (- *multiplier* 100) size0) 100))
+ (tail-threshold *tail-threshold*)
+ (nontail-threshold *nontail-threshold*))
+
+ ; Given an expression,
+ ; a boolean indicating whether the expression is in a tail context,
+ ; a list of procedures that should not be inlined,
+ ; and a size budget,
+ ; performs inlining by side effect and returns the unused budget.
+
+ (define (inline exp tail? budget)
+ (if (positive? budget)
+
+ (case (car exp)
+
+ ((quote lambda)
+ budget)
+
+ ((set!)
+ (inline (assignment.rhs exp) #f budget))
+
+ ((if)
+ (let* ((budget (inline (if.test exp) #f budget))
+ (budget (inline (if.then exp) tail? budget))
+ (budget (inline (if.else exp) tail? budget)))
+ budget))
+
+ ((begin)
+ (if (variable? exp)
+ budget
+ (do ((exprs (begin.exprs exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? (cdr exprs))
+ (inline (car exprs) tail? budget)))))
+
+ (else
+ (let ((budget (do ((exprs (call.args exp) (cdr exprs))
+ (budget budget
+ (inline (car exprs) #f budget)))
+ ((null? exprs)
+ budget))))
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname)))
+ (if procnode
+ (let ((size (callgraphnode.size procnode))
+ (info (callgraphnode.info procnode)))
+ (if (and info
+ (<= size budget)
+ (<= size
+ (if tail?
+ tail-threshold
+ nontail-threshold)))
+ (begin
+ (if debugging?
+ (begin
+ (display " Inlining ")
+ (write (variable.name proc))
+ (newline)))
+ (call.proc-set!
+ exp
+ (copy-exp
+ (callgraphnode.code procnode)))
+ (callgraphnode.size!
+ node
+ (+ (callgraphnode.size node) size))
+ (- budget size))
+ (begin
+ (if (and #f debugging?)
+ (begin
+ (display " Declining to inline ")
+ (write (variable.name proc))
+ (newline)))
+ budget)))
+ budget)))
+ ((lambda? proc)
+ (inline (lambda.body proc) tail? budget))
+ (else
+ (inline proc #f budget)))))))
+ -1))
+
+ (if (and #f debugging?)
+ (begin
+ (display "Processing ")
+ (write name)
+ (newline)))
+
+ (let ((budget (inline (if (lambda? exp)
+ (lambda.body exp)
+ exp)
+ #t
+ budget)))
+ (if (and (negative? budget)
+ debugging?)
+ ; This shouldn't happen very often.
+ (begin (display "Ran out of inlining budget for ")
+ (write (callgraphnode.name node))
+ (newline)))
+ (if (<= (callgraphnode.size node) nontail-threshold)
+ (callgraphnode.info! node #t))
+ #f)))
+
+; For testing.
+
+(define (test-inlining test0)
+ (begin (define exp0 (begin (display "Compiling...")
+ (newline)
+ (pass2 (pass1 test0))))
+ (define g0 (begin (display "Computing call graph...")
+ (newline)
+ (callgraph exp0))))
+ (display "Inlining...")
+ (newline)
+ (inline-using-callgraph! g0)
+ (pretty-print (make-readable (copy-exp exp0))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 14 April 1999.
+;
+; Interprocedural constant propagation and folding.
+;
+; Constant propagation must converge before constant folding can be
+; performed. Constant folding creates more constants that can be
+; propagated, so these two optimizations must be iterated, but it
+; is safe to stop at any time.
+;
+; Abstract interpretation for constant folding.
+;
+; The abstract values are
+; bottom (represented here by #f)
+; constants (represented by quoted literals)
+; top (represented here by #t)
+;
+; Let [[ E ]] be the abstract interpretation of E over that domain
+; of abstract values, with respect to some arbitrary set of abstract
+; values for local variables.
+;
+; If a is a global variable or a formal parameter of an escaping
+; lambda expression, then [[ a ]] = #t.
+;
+; If x is the ith formal parameter of a known local procedure f,
+; then [[ x ]] = \join_{(f E1 ... En)} [[ Ei ]].
+;
+; [[ K ]] = K
+; [[ L ]] = #t
+; [[ (begin E1 ... En) ]] = [[ En ]]
+; [[ (set! I E) ]] = #f
+;
+; If [[ E0 ]] = #t, then [[ (if E0 E1 E2) ]] = [[ E1 ]] \join [[ E2 ]]
+; else if [[ E0 ]] = K, then [[ (if E0 E1 E2) ]] = [[ E1 ]]
+; or [[ (if E0 E1 E2) ]] = [[ E2 ]]
+; depending upon K
+; else [[ (if E0 E1 E2) ]] = #f
+;
+; If f is a known local procedure with body E,
+; then [[ (f E1 ... En) ]] = [[ E ]]
+;
+; If g is a foldable integrable procedure, then:
+; if there is some i for which [[ Ei ]] = #t,
+; then [[ (g E1 ... En) ]] = #t
+; else if [[ E1 ]] = K1, ..., [[ En ]] = Kn,
+; then [[ (g E1 ... En) ]] = (g K1 ... Kn)
+; else [[ (g E1 ... En) ]] = #f
+;
+; Symbolic representations of abstract values.
+; (Can be thought of as mappings from abstract environments to
+; abstract values.)
+;
+; <symbolic> ::= #t | ( <expressions> )
+; <expressions> ::= <empty> | <expression> <expressions>
+
+; Parameter to limit constant propagation and folding.
+; This parameter can be tuned later.
+
+(define *constant-propagation-limit* 5)
+
+; Given an expression as output by pass 2, performs constant
+; propagation and folding.
+
+(define (constant-propagation exp)
+ (define (constant-propagation exp i)
+ (if (< i *constant-propagation-limit*)
+ (begin
+ ;(display "Performing constant propagation and folding...")
+ ;(newline)
+ (let* ((g (callgraph exp))
+ (L (callgraphnode.code (car g)))
+ (variables (constant-propagation-using-callgraph g))
+ (changed? (constant-folding! L variables)))
+ (if changed?
+ (constant-propagation (lambda.body L) (+ i 1))
+ (lambda.body L))))))
+ (constant-propagation exp 0))
+
+; Given a callgraph, returns a hashtable of abstract values for
+; all local variables.
+
+(define (constant-propagation-using-callgraph g)
+ (let ((debugging? #f)
+ (folding? (integrate-usual-procedures))
+ (known (make-hashtable))
+ (variables (make-hashtable))
+ (counter 0))
+
+ ; Computes joins of abstract values.
+
+ (define (join x y)
+ (cond ((boolean? x)
+ (if x #t y))
+ ((boolean? y)
+ (join y x))
+ ((equal? x y)
+ x)
+ (else #t)))
+
+ ; Given a <symbolic> and a vector of abstract values,
+ ; evaluates the <symbolic> and returns its abstract value.
+
+ (define (aeval rep env)
+ (cond ((eq? rep #t)
+ #t)
+ ((null? rep)
+ #f)
+ ((null? (cdr rep))
+ (aeval1 (car rep) env))
+ (else
+ (join (aeval1 (car rep) env)
+ (aeval (cdr rep) env)))))
+
+ (define (aeval1 exp env)
+
+ (case (car exp)
+
+ ((quote)
+ exp)
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ #f)
+
+ ((begin)
+ (if (variable? exp)
+ (let* ((name (variable.name exp))
+ (i (hashtable-get variables name)))
+ (if i
+ (vector-ref env i)
+ #t))
+ (aeval1-error)))
+
+ ((if)
+ (let* ((val0 (aeval1 (if.test exp) env))
+ (val1 (aeval1 (if.then exp) env))
+ (val2 (aeval1 (if.else exp) env)))
+ (cond ((eq? val0 #t)
+ (join val1 val2))
+ ((pair? val0)
+ (if (constant.value val0)
+ val1
+ val2))
+ (else
+ #f))))
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (vals '() (cons (aeval1 (car exprs) env) vals)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (vector-ref env
+ (hashtable-get variables
+ procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else (aeval1-error)))))
+ (else
+ (aeval1-error)))))))))
+
+ (define (aeval1-error)
+ (error "Compiler bug: constant propagation (aeval1)"))
+
+ ; Combines two <symbolic>s.
+
+ (define (combine-symbolic rep1 rep2)
+ (cond ((eq? rep1 #t) #t)
+ ((eq? rep2 #t) #t)
+ (else
+ (append rep1 rep2))))
+
+ ; Given an expression, returns a <symbolic> that represents
+ ; a list of expressions whose abstract values can be joined
+ ; to obtain the abstract value of the given expression.
+ ; As a side effect, enters local variables into variables.
+
+ (define (collect! exp)
+
+ (case (car exp)
+
+ ((quote)
+ (list exp))
+
+ ((lambda)
+ #t)
+
+ ((set!)
+ (collect! (assignment.rhs exp))
+ '())
+
+ ((begin)
+ (if (variable? exp)
+ (list exp)
+ (do ((exprs (begin.exprs exp) (cdr exprs)))
+ ((null? (cdr exprs))
+ (collect! (car exprs)))
+ (collect! (car exprs)))))
+
+ ((if)
+ (collect! (if.test exp))
+ (collect! (if.then exp))
+ (collect! (if.else exp))
+ #t)
+
+ (else
+ (do ((exprs (reverse (call.args exp)) (cdr exprs))
+ (reps '() (cons (collect! (car exprs)) reps)))
+ ((null? exprs)
+ (let ((proc (call.proc exp)))
+ (define (put-args! args reps)
+ (cond ((pair? args)
+ (let ((v (car args))
+ (rep (car reps)))
+ (hashtable-put! variables v rep)
+ (put-args! (cdr args) (cdr reps))))
+ ((symbol? args)
+ (hashtable-put! variables args #t))
+ (else #f)))
+ (cond ((variable? proc)
+ (let* ((procname (variable.name proc))
+ (procnode (hashtable-get known procname))
+ (entry (if folding?
+ (constant-folding-entry procname)
+ #f)))
+ (cond (procnode
+ (for-each (lambda (v rep)
+ (hashtable-put!
+ variables
+ v
+ (combine-symbolic
+ rep (hashtable-get variables v))))
+ (lambda.args
+ (callgraphnode.code procnode))
+ reps)
+ (list (make-variable procname)))
+ (entry
+ ; FIXME: No constant folding
+ #t)
+ (else #t))))
+ ((lambda? proc)
+ (put-args! (lambda.args proc) reps)
+ (collect! (lambda.body proc)))
+ (else
+ (collect! proc)
+ #t))))))))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (known? (symbol? name))
+ (rep (if known? '() #t)))
+ (if known?
+ (hashtable-put! known name node))
+ (if (lambda? code)
+ (for-each (lambda (var)
+ (hashtable-put! variables var rep))
+ (make-null-terminated (lambda.args code))))))
+ g)
+
+ (for-each (lambda (node)
+ (let ((name (callgraphnode.name node))
+ (code (callgraphnode.code node)))
+ (cond ((symbol? name)
+ (hashtable-put! variables
+ name
+ (collect! (lambda.body code))))
+ (else
+ (collect! (lambda.body code))))))
+ g)
+
+ (if (and #f debugging?)
+ (begin
+ (hashtable-for-each (lambda (v rep)
+ (write v)
+ (display ": ")
+ (write rep)
+ (newline))
+ variables)
+
+ (display "----------------------------------------")
+ (newline)))
+
+ ;(trace aeval aeval1)
+
+ (let* ((n (hashtable-size variables))
+ (vars (hashtable-map (lambda (v rep) v) variables))
+ (reps (map (lambda (v) (hashtable-get variables v)) vars))
+ (init (make-vector n #f))
+ (next (make-vector n)))
+ (do ((i 0 (+ i 1))
+ (vars vars (cdr vars))
+ (reps reps (cdr reps)))
+ ((= i n))
+ (hashtable-put! variables (car vars) i)
+ (vector-set! next
+ i
+ (let ((rep (car reps)))
+ (lambda (env)
+ (aeval rep env)))))
+ (compute-fixedpoint init next equal?)
+ (for-each (lambda (v)
+ (let* ((i (hashtable-get variables v))
+ (aval (vector-ref init i)))
+ (hashtable-put! variables v aval)
+ (if (and debugging?
+ (not (eq? aval #t)))
+ (begin (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))
+ vars)
+ variables)))
+
+; Given a lambda expression, performs constant propagation, folding,
+; and simplifications by side effect, using the abstract values in the
+; hash table of variables.
+; Returns #t if any new constants were created by constant folding,
+; otherwise returns #f.
+
+(define (constant-folding! L variables)
+ (let ((debugging? #f)
+ (msg1 " Propagating constant value for ")
+ (msg2 " Folding: ")
+ (msg3 " ==> ")
+ (folding? (integrate-usual-procedures))
+ (changed? #f))
+
+ ; Given a known lambda expression L, its original formal parameters,
+ ; and a list of all calls to L, deletes arguments that are now
+ ; ignored because of constant propagation.
+
+ (define (delete-ignored-args! L formals0 calls)
+ (let ((formals1 (lambda.args L)))
+ (for-each (lambda (call)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (args (call.args call)
+ (cdr args))
+ (newargs '()
+ (if (and (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ newargs
+ (cons (car args) newargs))))
+ ((null? formals0)
+ (call.args-set! call (reverse newargs)))))
+ calls)
+ (do ((formals0 formals0 (cdr formals0))
+ (formals1 formals1 (cdr formals1))
+ (formals2 '()
+ (if (and (not (eq? (car formals0)
+ (car formals1)))
+ (eq? (car formals1) name:IGNORED)
+ (pair?
+ (hashtable-get variables
+ (car formals0))))
+ formals2
+ (cons (car formals1) formals2))))
+ ((null? formals0)
+ (lambda.args-set! L (reverse formals2))))))
+
+ (define (fold! exp)
+
+ (case (car exp)
+
+ ((quote) exp)
+
+ ((lambda)
+ (let ((Rinfo (lambda.R exp))
+ (known (map def.lhs (lambda.defs exp))))
+ (for-each (lambda (entry)
+ (let* ((v (R-entry.name entry))
+ (aval (hashtable-fetch variables v #t)))
+ (if (and (pair? aval)
+ (not (memq v known)))
+ (let ((x (constant.value aval)))
+ (if (or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (number? x)
+ (char? x)
+ (and (vector? x)
+ (zero? (vector-length x))))
+ (let ((refs (R-entry.references entry)))
+ (for-each (lambda (ref)
+ (variable-set! ref aval))
+ refs)
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp)))
+ (flag-as-ignored v exp)
+ (if debugging?
+ (begin (display msg1)
+ (write v)
+ (display ": ")
+ (write aval)
+ (newline)))))))))
+ Rinfo)
+ (for-each (lambda (def)
+ (let* ((name (def.lhs def))
+ (rhs (def.rhs def))
+ (entry (R-lookup Rinfo name))
+ (calls (R-entry.calls entry)))
+ (if (null? calls)
+ (begin (lambda.defs-set!
+ exp
+ (remq def (lambda.defs exp)))
+ ; Do not try to use Rinfo in place of
+ ; (lambda.R exp) below!
+ (lambda.R-set!
+ exp
+ (remq entry (lambda.R exp))))
+ (let* ((formals0 (append (lambda.args rhs) '()))
+ (L (fold! rhs))
+ (formals1 (lambda.args L)))
+ (if (not (equal? formals0 formals1))
+ (delete-ignored-args! L formals0 calls))))))
+ (lambda.defs exp))
+ (lambda.body-set!
+ exp
+ (fold! (lambda.body exp)))
+ exp))
+
+ ((set!)
+ (assignment.rhs-set! exp (fold! (assignment.rhs exp)))
+ exp)
+
+ ((begin)
+ (if (variable? exp)
+ exp
+ (post-simplify-begin (make-begin (map fold! (begin.exprs exp)))
+ (make-notepad #f))))
+
+ ((if)
+ (let ((exp0 (fold! (if.test exp)))
+ (exp1 (fold! (if.then exp)))
+ (exp2 (fold! (if.else exp))))
+ (if (constant? exp0)
+ (let ((newexp (if (constant.value exp0)
+ exp1
+ exp2)))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable exp))
+ (display msg3)
+ (write (make-readable newexp))
+ (newline)))
+ (set! changed? #t)
+ newexp)
+ (make-conditional exp0 exp1 exp2))))
+
+ (else
+ (let ((args (map fold! (call.args exp)))
+ (proc (fold! (call.proc exp))))
+ (cond ((and folding?
+ (variable? proc)
+ (every? constant? args)
+ (let ((entry
+ (constant-folding-entry (variable.name proc))))
+ (and entry
+ (let ((preds
+ (constant-folding-predicates entry)))
+ (and (= (length args) (length preds))
+ (every?
+ (lambda (x) x)
+ (map (lambda (f v) (f v))
+ (constant-folding-predicates entry)
+ (map constant.value args))))))))
+ (set! changed? #t)
+ (let ((result
+ (make-constant
+ (apply (constant-folding-folder
+ (constant-folding-entry
+ (variable.name proc)))
+ (map constant.value args)))))
+ (if debugging?
+ (begin (display msg2)
+ (write (make-readable (make-call proc args)))
+ (display msg3)
+ (write result)
+ (newline)))
+ result))
+ ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ ; FIXME: Folding should be done even if there is
+ ; a rest argument.
+ (let loop ((formals (reverse (lambda.args proc)))
+ (actuals (reverse args))
+ (processed-formals '())
+ (processed-actuals '())
+ (for-effect '()))
+ (cond ((null? formals)
+ (lambda.args-set! proc processed-formals)
+ (call.args-set! exp processed-actuals)
+ (let ((call (if (and (null? processed-formals)
+ (null? (lambda.defs proc)))
+ (lambda.body proc)
+ exp)))
+ (if (null? for-effect)
+ call
+ (post-simplify-begin
+ (make-begin
+ (reverse (cons call for-effect)))
+ (make-notepad #f)))))
+ ((ignored? (car formals))
+ (loop (cdr formals)
+ (cdr actuals)
+ processed-formals
+ processed-actuals
+ (cons (car actuals) for-effect)))
+ (else
+ (loop (cdr formals)
+ (cdr actuals)
+ (cons (car formals) processed-formals)
+ (cons (car actuals) processed-actuals)
+ for-effect)))))
+ (else
+ (call.proc-set! exp proc)
+ (call.args-set! exp args)
+ exp))))))
+
+ (fold! L)
+ changed?))
+; Copyright 1998 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Conversion to A-normal form, with heuristics for
+; choosing a good order of evaluation.
+;
+; This pass operates as a source-to-source transformation on
+; expressions written in the subset of Scheme described by the
+; following grammar, where the input and output expressions
+; satisfy certain additional invariants described below.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * There are no sequential expressions.
+; * The output is an expression E with syntax
+;
+; E --> A
+; | (L)
+; | (L A)
+;
+; A --> W
+; | L
+; | (W_0 W_1 ...)
+; | (set! I W)
+; | (if W E1 E2)
+;
+; W --> (quote K)
+; | (begin I)
+;
+; In other words:
+; An expression is a LET* such that the rhs of every binding is
+; a conditional with the test already evaluated, or
+; an expression that can be evaluated in one step
+; (treating function calls as a single step)
+;
+; A-normal form corresponds to the control flow graph for a lambda
+; expression.
+
+; Algorithm: repeated use of these rules:
+;
+; (E0 E1 ...) ((lambda (T0 T1 ...) (T0 T1 ...))
+; E0 E1 ...)
+; (set! I E) ((lambda (T) (set! I T)) E)
+; (if E0 E1 E2) ((lambda (T) (if T E1 E2)) E0)
+; (begin E0 E1 E2 ...) ((lambda (T) (begin E1 E2 ...)) E0)
+;
+; ((lambda (I1 I2 I3 ...) E) ((lambda (I1)
+; E1 E2 E3) ((lambda (I2 I3 ...) E)
+; E2 E3))
+; E1)
+;
+; ((lambda (I2) E) ((lambda (I1)
+; ((lambda (I1) E2) ((lambda (I2) E)
+; E1)) E2)
+; E1)
+;
+; In other words:
+; Introduce a temporary name for every expression except:
+; tail expressions
+; the alternatives of a non-tail conditional
+; Convert every LET into a LET*.
+; Get rid of LET* on the right hand side of a binding.
+
+; Given an expression E in the representation output by pass 2,
+; returns an A-normal form for E in that representation.
+; Except for quoted values, the A-normal form does not share
+; mutable structure with the original expression E.
+;
+; KNOWN BUG:
+;
+; If you call A-normal on a form that has already been converted
+; to A-normal form, then the same temporaries will be generated
+; twice. An optional argument lets you specify a different prefix
+; for temporaries the second time around. Example:
+;
+; (A-normal-form (A-normal-form E ".T")
+; ".U")
+
+; This is the declaration that is used to indicate A-normal form.
+
+(define A-normal-form-declaration (list 'anf))
+
+(define (A-normal-form E . rest)
+
+ (define (A-normal-form E)
+ (anf-make-let* (anf E '() '())))
+
+ ; New temporaries.
+
+ (define temp-counter 0)
+
+ (define temp-prefix
+ (if (or (null? rest)
+ (not (string? (car rest))))
+ (string-append renaming-prefix "T")
+ (car rest)))
+
+ (define (newtemp)
+ (set! temp-counter (+ temp-counter 1))
+ (string->symbol
+ (string-append temp-prefix
+ (number->string temp-counter))))
+
+ ; Given an expression E as output by pass 2,
+ ; a list of surrounding LET* bindings,
+ ; and an ordered list of likely register variables,
+ ; return a non-empty list of LET* bindings
+ ; whose first binding associates a dummy variable
+ ; with an A-expression giving the value for E.
+
+ (define (anf E bindings regvars)
+ (case (car E)
+ ((quote) (anf-bind-dummy E bindings))
+ ((begin) (if (variable? E)
+ (anf-bind-dummy E bindings)
+ (anf-sequential E bindings regvars)))
+ ((lambda) (anf-lambda E bindings regvars))
+ ((set!) (anf-assignment E bindings regvars))
+ ((if) (anf-conditional E bindings regvars))
+ (else (anf-call E bindings regvars))))
+
+ (define anf:dummy (string->symbol "RESULT"))
+
+ (define (anf-bind-dummy E bindings)
+ (cons (list anf:dummy E)
+ bindings))
+
+ ; Unlike anf-bind-dummy, anf-bind-name and anf-bind convert
+ ; their expression argument to A-normal form.
+ ; Don't change anf-bind to call anf-bind-name, because that
+ ; would name the temporaries in an aesthetically bad order.
+
+ (define (anf-bind-name name E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list name (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-bind E bindings regvars)
+ (let ((bindings (anf E bindings regvars)))
+ (cons (list (newtemp) (cadr (car bindings)))
+ (cdr bindings))))
+
+ (define (anf-result bindings)
+ (make-variable (car (car bindings))))
+
+ (define (anf-make-let* bindings)
+ (define (loop bindings body)
+ (if (null? bindings)
+ body
+ (let ((T1 (car (car bindings)))
+ (E1 (cadr (car bindings))))
+ (loop (cdr bindings)
+ (make-call (make-lambda (list T1)
+ '()
+ '()
+ '()
+ '()
+ (list A-normal-form-declaration)
+ '()
+ body)
+ (list E1))))))
+ (loop (cdr bindings)
+ (cadr (car bindings))))
+
+ (define (anf-sequential E bindings regvars)
+ (do ((bindings bindings
+ (anf-bind (car exprs) bindings regvars))
+ (exprs (begin.exprs E)
+ (cdr exprs)))
+ ((null? (cdr exprs))
+ (anf (car exprs) bindings regvars))))
+
+ ; Heuristic: the formal parameters of an escaping lambda or
+ ; known local procedure are kept in REG1, REG2, et cetera.
+
+ (define (anf-lambda L bindings regvars)
+ (anf-bind-dummy
+ (make-lambda (lambda.args L)
+ (map (lambda (def)
+ (make-definition
+ (def.lhs def)
+ (A-normal-form (def.rhs def))))
+ (lambda.defs L))
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls L))
+ (lambda.doc L)
+ (anf-make-let*
+ (anf (lambda.body L)
+ '()
+ (make-null-terminated (lambda.args L)))))
+ bindings))
+
+ (define (anf-assignment E bindings regvars)
+ (let ((I (assignment.lhs E))
+ (E1 (assignment.rhs E)))
+ (if (variable? E1)
+ (anf-bind-dummy E bindings)
+ (let* ((bindings (anf-bind E1 bindings regvars))
+ (T1 (anf-result bindings)))
+ (anf-bind-dummy (make-assignment I T1) bindings)))))
+
+ (define (anf-conditional E bindings regvars)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (variable? E0)
+ (let ((E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional E0 E1 E2)
+ bindings))
+ (let* ((bindings (anf-bind E0 bindings regvars))
+ (E1 (anf-make-let* (anf E1 '() regvars)))
+ (E2 (anf-make-let* (anf E2 '() regvars))))
+ (anf-bind-dummy
+ (make-conditional (anf-result bindings) E1 E2)
+ bindings)))))
+
+ (define (anf-call E bindings regvars)
+ (let* ((proc (call.proc E))
+ (args (call.args E)))
+
+ ; Evaluates the exprs and returns both a list of bindings and
+ ; a list of the temporaries that name the results of the exprs.
+ ; If rename-always? is true, then temporaries are generated even
+ ; for constants and temporaries.
+
+ (define (loop exprs bindings names rename-always?)
+ (if (null? exprs)
+ (values bindings (reverse names))
+ (let ((E (car exprs)))
+ (if (or rename-always?
+ (not (or (constant? E)
+ (variable? E))))
+ (let* ((bindings
+ (anf-bind (car exprs) bindings regvars)))
+ (loop (cdr exprs)
+ bindings
+ (cons (anf-result bindings) names)
+ rename-always?))
+ (loop (cdr exprs)
+ bindings
+ (cons E names)
+ rename-always?)))))
+
+ ; Evaluates the exprs, binding them to the vars, and returns
+ ; a list of bindings.
+ ;
+ ; Although LET variables are likely to be kept in registers,
+ ; trying to guess which register will be allocated is likely
+ ; to do more harm than good.
+
+ (define (let-loop exprs bindings regvars vars)
+ (if (null? exprs)
+ (if (null? (lambda.defs proc))
+ (anf (lambda.body proc)
+ bindings
+ regvars)
+ (let ((bindings
+ (anf-bind
+ (make-lambda '()
+ (lambda.defs proc)
+ '()
+ '()
+ '()
+ (cons A-normal-form-declaration
+ (lambda.decls proc))
+ (lambda.doc proc)
+ (lambda.body proc))
+ bindings
+ '())))
+ (anf-bind-dummy
+ (make-call (anf-result bindings) '())
+ bindings)))
+ (let-loop (cdr exprs)
+ (anf-bind-name (car vars)
+ (car exprs)
+ bindings
+ regvars)
+ regvars
+ (cdr vars))))
+
+ (cond ((lambda? proc)
+ (let ((formals (lambda.args proc)))
+ (if (list? formals)
+ (let* ((pi (anf-order-of-evaluation args regvars #f))
+ (exprs (permute args pi))
+ (names (permute (lambda.args proc) pi)))
+ (let-loop (reverse exprs) bindings regvars (reverse names)))
+ (anf-call (normalize-let E) bindings regvars))))
+
+ ((not (variable? proc))
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((bindings (anf-bind proc bindings regvars)))
+ (anf-bind-dummy
+ (make-call (anf-result bindings)
+ (unpermute names pi))
+ bindings))))))
+
+ ((and (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (let ((pi (anf-order-of-evaluation args regvars #t)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings)))))
+
+ ((memq (variable.name proc) regvars)
+ (let* ((exprs (cons proc args))
+ (pi (anf-order-of-evaluation
+ exprs
+ (cons name:IGNORED regvars)
+ #f)))
+ (call-with-values
+ (lambda () (loop (permute exprs pi) bindings '() #t))
+ (lambda (bindings names)
+ (let ((names (unpermute names pi)))
+ (anf-bind-dummy
+ (make-call (car names) (cdr names))
+ bindings))))))
+
+ (else
+ (let ((pi (anf-order-of-evaluation args regvars #f)))
+ (call-with-values
+ (lambda () (loop (permute args pi) bindings '() #t))
+ (lambda (bindings names)
+ (anf-bind-dummy
+ (make-call proc (unpermute names pi))
+ bindings))))))))
+
+ ; Given a list of expressions, a list of likely register contents,
+ ; and a switch telling whether these are arguments for a primop
+ ; or something else (such as the arguments for a real call),
+ ; try to choose a good order in which to evaluate the expressions.
+ ;
+ ; Heuristic: If none of the expressions is a call to a non-primop,
+ ; then parallel assignment optimization gives a good order if the
+ ; regvars are right, and should do no worse than a random order if
+ ; the regvars are wrong.
+ ;
+ ; Heuristic: If the expressions are arguments to a primop, and
+ ; none are a call to a non-primop, then the register contents
+ ; are irrelevant, and the first argument should be evaluated last.
+ ;
+ ; Heuristic: If one or more of the expressions is a call to a
+ ; non-primop, then the following should be a good order:
+ ;
+ ; expressions that are neither a constant, variable, or a call
+ ; calls to non-primops
+ ; constants and variables
+
+ (define (anf-order-of-evaluation exprs regvars for-primop?)
+ (define (ordering targets exprs alist)
+ (let ((para
+ (parallel-assignment targets alist exprs)))
+ (or para
+ ; Evaluate left to right until a parallel assignment is found.
+ (cons (car targets)
+ (ordering (cdr targets)
+ (cdr exprs)
+ alist)))))
+ (if (parallel-assignment-optimization)
+ (cond ((null? exprs) '())
+ ((null? (cdr exprs)) '(0))
+ (else
+ (let* ((contains-call? #f)
+ (vexprs (list->vector exprs))
+ (vindexes (list->vector
+ (iota (vector-length vexprs))))
+ (contains-call? #f)
+ (categories
+ (list->vector
+ (map (lambda (E)
+ (cond ((constant? E)
+ 2)
+ ((variable? E)
+ 2)
+ ((complicated? E)
+ (set! contains-call? #t)
+ 1)
+ (else
+ 0)))
+ exprs))))
+ (cond (contains-call?
+ (twobit-sort (lambda (i j)
+ (< (vector-ref categories i)
+ (vector-ref categories j)))
+ (iota (length exprs))))
+ (for-primop?
+ (reverse (iota (length exprs))))
+ (else
+ (let ((targets (iota (length exprs))))
+ (define (pairup regvars targets)
+ (if (or (null? targets)
+ (null? regvars))
+ '()
+ (cons (cons (car regvars)
+ (car targets))
+ (pairup (cdr regvars)
+ (cdr targets)))))
+ (ordering targets
+ exprs
+ (pairup regvars targets))))))))
+ (iota (length exprs))))
+
+ (define (permute things pi)
+ (let ((v (list->vector things)))
+ (map (lambda (i) (vector-ref v i))
+ pi)))
+
+ (define (unpermute things pi)
+ (let* ((v0 (list->vector things))
+ (v1 (make-vector (vector-length v0))))
+ (do ((pi pi (cdr pi))
+ (k 0 (+ k 1)))
+ ((null? pi)
+ (vector->list v1))
+ (vector-set! v1 (car pi) (vector-ref v0 k)))))
+
+ ; Given a call whose procedure is a lambda expression that has
+ ; a rest argument, return a genuine let expression.
+
+ (define (normalize-let-error exp)
+ (if (issue-warnings)
+ (begin (display "WARNING from compiler: ")
+ (display "Wrong number of arguments ")
+ (display "to lambda expression")
+ (newline)
+ (pretty-print (make-readable exp) #t)
+ (newline))))
+
+ (define (normalize-let exp)
+ (let* ((L (call.proc exp)))
+ (let loop ((formals (lambda.args L))
+ (args (call.args exp))
+ (newformals '())
+ (newargs '()))
+ (cond ((null? formals)
+ (if (null? args)
+ (begin (lambda.args-set! L (reverse newformals))
+ (call.args-set! exp (reverse newargs)))
+ (begin (normalize-let-error exp)
+ (loop (list (newtemp))
+ args
+ newformals
+ newargs))))
+ ((pair? formals)
+ (if (pair? args)
+ (loop (cdr formals)
+ (cdr args)
+ (cons (car formals) newformals)
+ (cons (car args) newargs))
+ (begin (normalize-let-error exp)
+ (loop formals
+ (cons (make-constant 0)
+ args)
+ newformals
+ newargs))))
+ (else
+ (loop (list formals)
+ (list (make-call-to-list args))
+ newformals
+ newargs))))))
+
+ ; For heuristic use only.
+ ; An expression is complicated unless it can probably be evaluated
+ ; without saving and restoring any registers, even if it occurs in
+ ; a non-tail position.
+
+ (define (complicated? exp)
+ ; Let's not spend all day on this.
+ (let ((budget 10))
+ (define (complicated? exp)
+ (set! budget (- budget 1))
+ (if (zero? budget)
+ #t
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #f)
+ ((set!) (complicated? (assignment.rhs exp)))
+ ((if) (or (complicated? (if.test exp))
+ (complicated? (if.then exp))
+ (complicated? (if.else exp))))
+ ((begin) (if (variable? exp)
+ #f
+ (some? complicated?
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (integrate-usual-procedures)
+ (prim-entry (variable.name proc)))
+ (some? complicated?
+ (call.args exp))
+ #t))))))
+ (complicated? exp)))
+
+ (A-normal-form E))
+(define (post-simplify-anf L0 T1 E0 E1 free regbindings L2)
+
+ (define (return-normally)
+ (values (make-call L0 (list E1))
+ free
+ regbindings))
+
+ (return-normally))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 7 June 1999.
+;
+; Intraprocedural common subexpression elimination, constant propagation,
+; copy propagation, dead code elimination, and register targeting.
+;
+; (intraprocedural-commoning E 'commoning)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an optimized
+; A-normal form with correct free variables but incorrect referencing
+; information.
+;
+; (intraprocedural-commoning E 'target-registers)
+;
+; Given an A-normal form E (alpha-converted, with correct free
+; variables and referencing information), returns an A-normal form
+; with correct free variables but incorrect referencing information,
+; and in which MacScheme machine register names are used as temporary
+; variables. The result is alpha-converted except for register names.
+;
+; (intraprocedural-commoning E 'commoning 'target-registers)
+; (intraprocedural-commoning E)
+;
+; Given an A-normal form as described above, returns an optimized
+; form in which register names are used as temporary variables.
+
+; Semantics of .check!:
+;
+; (.check! b exn x ...) faults with code exn and arguments x ...
+; if b is #f.
+
+; The list of argument registers.
+; This can't go in pass3commoning.aux.sch because that file must be
+; loaded before the target-specific file that defines *nregs*.
+
+(define argument-registers
+ (do ((n (- *nregs* 2) (- n 1))
+ (regs '()
+ (cons (string->symbol
+ (string-append ".REG" (number->string n)))
+ regs)))
+ ((zero? n)
+ regs)))
+
+(define (intraprocedural-commoning E . flags)
+
+ (define target-registers? (or (null? flags) (memq 'target-registers flags)))
+ (define commoning? (or (null? flags) (memq 'commoning flags)))
+
+ (define debugging? #f)
+
+ (call-with-current-continuation
+ (lambda (return)
+
+ (define (error . stuff)
+ (display "Bug detected during intraprocedural optimization")
+ (newline)
+ (for-each (lambda (s)
+ (display s) (newline))
+ stuff)
+ (return (make-constant #f)))
+
+ ; Given an expression, an environment, the available expressions,
+ ; and an ordered list of likely register variables (used heuristically),
+ ; returns the transformed expression and its set of free variables.
+
+ (define (scan-body E env available regvars)
+
+ ; The local variables are those that are bound by a LET within
+ ; this procedure. The formals of a lambda expression and the
+ ; known local procedures are counted as non-global, not local,
+ ; because there is no let-binding for a formal that can be
+ ; renamed during register targeting.
+ ; For each local variable, we keep track of how many times it
+ ; is referenced. This information is not accurate until we
+ ; are backing out of the recursion, and does not have to be.
+
+ (define local-variables (make-hashtable symbol-hash assq))
+
+ (define (local-variable? sym)
+ (hashtable-get local-variables sym))
+
+ (define (local-variable-not-used? sym)
+ (= 0 (hashtable-fetch local-variables sym -1)))
+
+ (define (local-variable-used-once? sym)
+ (= 1 (hashtable-fetch local-variables sym 0)))
+
+ (define (record-local-variable! sym)
+ (hashtable-put! local-variables sym 0))
+
+ (define (used-local-variable! sym)
+ (adjust-local-variable! sym 1))
+
+ (define (adjust-local-variable! sym n)
+ (let ((m (hashtable-get local-variables sym)))
+ (if debugging?
+ (if (and m (> m 0))
+ (begin (write (list sym (+ m n)))
+ (newline))))
+ (if m
+ (hashtable-put! local-variables
+ sym
+ (+ m n)))))
+
+ (define (closed-over-local-variable! sym)
+ ; Set its reference count to infinity so it won't be optimized away.
+ ; FIXME: One million isn't infinity.
+ (hashtable-put! local-variables sym 1000000))
+
+ (define (used-variable! sym)
+ (used-local-variable! sym))
+
+ (define (abandon-expression! E)
+ (cond ((variable? E)
+ (adjust-local-variable! (variable.name E) -1))
+ ((conditional? E)
+ (abandon-expression! (if.test E))
+ (abandon-expression! (if.then E))
+ (abandon-expression! (if.else E)))
+ ((call? E)
+ (for-each (lambda (exp)
+ (if (variable? exp)
+ (let ((name (variable.name exp)))
+ (if (local-variable? name)
+ (adjust-local-variable! name -1)))))
+ (cons (call.proc E)
+ (call.args E))))))
+
+ ; Environments are represented as hashtrees.
+
+ (define (make-empty-environment)
+ (make-hashtree symbol-hash assq))
+
+ (define (environment-extend env sym)
+ (hashtree-put env sym #t))
+
+ (define (environment-extend* env symbols)
+ (if (null? symbols)
+ env
+ (environment-extend* (hashtree-put env (car symbols) #t)
+ (cdr symbols))))
+
+ (define (environment-lookup env sym)
+ (hashtree-get env sym))
+
+ (define (global? x)
+ (cond ((local-variable? x)
+ #f)
+ ((environment-lookup env x)
+ #f)
+ (else
+ #t)))
+
+ ;
+
+ (define (available-add! available T E)
+ (cond ((constant? E)
+ (available-extend! available T E available:killer:immortal))
+ ((variable? E)
+ (available-extend! available
+ T
+ E
+ (if (global? (variable.name E))
+ available:killer:globals
+ available:killer:immortal)))
+ (else
+ (let ((entry (prim-call E)))
+ (if entry
+ (let ((killer (prim-lives-until entry)))
+ (if (not (eq? killer available:killer:dead))
+ (do ((args (call.args E) (cdr args))
+ (k killer
+ (let ((arg (car args)))
+ (if (and (variable? arg)
+ (global? (variable.name arg)))
+ available:killer:globals
+ k))))
+ ((null? args)
+ (available-extend!
+ available
+ T
+ E
+ (logior killer k)))))))))))
+
+ ; Given an expression E,
+ ; an environment containing all variables that are in scope,
+ ; and a table of available expressions,
+ ; returns multiple values:
+ ; the transformed E
+ ; the free variables of E
+ ; the register bindings to be inserted; each binding has the form
+ ; (R x (begin R)), where (begin R) is a reference to R.
+ ;
+ ; Side effects E.
+
+ (define (scan E env available)
+ (if (not (call? E))
+ (scan-rhs E env available)
+ (let ((proc (call.proc E)))
+ (if (not (lambda? proc))
+ (scan-rhs E env available)
+ (let ((vars (lambda.args proc)))
+ (cond ((null? vars)
+ (scan-let0 E env available))
+ ((null? (cdr vars))
+ (scan-binding E env available))
+ (else
+ (error (make-readable E)))))))))
+
+ ; E has the form of (let ((T1 E1)) E0).
+
+ (define (scan-binding E env available)
+ (let* ((L (call.proc E))
+ (T1 (car (lambda.args L)))
+ (E1 (car (call.args E)))
+ (E0 (lambda.body L)))
+ (record-local-variable! T1)
+ (call-with-values
+ (lambda () (scan-rhs E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (available-add! available T1 E1)
+ (let* ((env (let ((formals
+ (make-null-terminated (lambda.args L))))
+ (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs L)))))
+ (Fdefs (scan-defs L env available)))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (lambda.body-set! L E0)
+ (if target-registers?
+ (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+ (scan-binding-phase3
+ L E0 E1 (union F0 Fdefs)
+ F1 regbindings0 regbindings1)))))))))
+
+ ; Given the lambda expression for a let expression that binds
+ ; a single variable T1, the transformed body E0 and right hand side E1,
+ ; their sets of free variables F0 and F1, the set of free variables
+ ; for the internal definitions of L, and the sets of register
+ ; bindings that need to be wrapped around E0 and E1, returns the
+ ; transformed let expression, its free variables, and register
+ ; bindings.
+ ;
+ ; This phase is concerned exclusively with register bindings,
+ ; and is bypassed unless the target-registers flag is specified.
+
+ (define (scan-binding-phase2
+ L T1 E0 E1 F0 F1 Fdefs regbindings0 regbindings1)
+
+ ; T1 can't be a register because we haven't
+ ; yet inserted register bindings that high up.
+
+ ; Classify the register bindings that need to wrapped around E0:
+ ; 1. those that have T1 as their rhs
+ ; 2. those whose lhs is a register that is likely to hold
+ ; a variable that occurs free in E1
+ ; 3. all others
+
+ (define (phase2a)
+ (do ((rvars regvars (cdr rvars))
+ (regs argument-registers (cdr regs))
+ (regs1 '() (if (memq (car rvars) F1)
+ (cons (car regs) regs1)
+ regs1)))
+ ((or (null? rvars)
+ (null? regs))
+ ; regs1 is the set of registers that are live for E1
+
+ (let loop ((regbindings regbindings0)
+ (rb1 '())
+ (rb2 '())
+ (rb3 '()))
+ (if (null? regbindings)
+ (phase2b rb1 rb2 rb3)
+ (let* ((binding (car regbindings))
+ (regbindings (cdr regbindings))
+ (lhs (regbinding.lhs binding))
+ (rhs (regbinding.rhs binding)))
+ (cond ((eq? rhs T1)
+ (loop regbindings
+ (cons binding rb1)
+ rb2
+ rb3))
+ ((memq lhs regs1)
+ (loop regbindings
+ rb1
+ (cons binding rb2)
+ rb3))
+ (else
+ (loop regbindings
+ rb1
+ rb2
+ (cons binding rb3))))))))))
+
+ ; Determine which categories of register bindings should be
+ ; wrapped around E0.
+ ; Always wrap the register bindings in category 2.
+ ; If E1 is a conditional or a real call, then wrap category 3.
+ ; If T1 might be used more than once, then wrap category 1.
+
+ (define (phase2b rb1 rb2 rb3)
+ (if (or (conditional? E1)
+ (real-call? E1))
+ (phase2c (append rb2 rb3) rb1 '())
+ (phase2c rb2 rb1 rb3)))
+
+ (define (phase2c towrap rb1 regbindings0)
+ (cond ((and (not (null? rb1))
+ (local-variable-used-once? T1))
+ (phase2d towrap rb1 regbindings0))
+ (else
+ (phase2e (append rb1 towrap) regbindings0))))
+
+ ; T1 is used only once, and there is a register binding (R T1).
+ ; Change T1 to R.
+
+ (define (phase2d towrap regbindings-T1 regbindings0)
+ (if (not (null? (cdr regbindings-T1)))
+ (error "incorrect number of uses" T1))
+ (let* ((regbinding (car regbindings-T1))
+ (R (regbinding.lhs regbinding)))
+ (lambda.args-set! L (list R))
+ (phase2e towrap regbindings0)))
+
+ ; Wrap the selected register bindings around E0.
+
+ (define (phase2e towrap regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings towrap E0 F0))
+ (lambda (E0 F0)
+ (let ((F (union Fdefs F0)))
+ (scan-binding-phase3
+ L E0 E1 F F1 regbindings0 regbindings1)))))
+
+ (phase2a))
+
+ ; This phase, with arguments as above, constructs the result.
+
+ (define (scan-binding-phase3 L E0 E1 F F1 regbindings0 regbindings1)
+ (let* ((args (lambda.args L))
+ (T1 (car args))
+ (free (union F1 (difference F args)))
+ (simple-let? (simple-lambda? L))
+ (regbindings
+
+ ; At least one of regbindings0 and regbindings1
+ ; is the empty list.
+
+ (cond ((null? regbindings0)
+ regbindings1)
+ ((null? regbindings1)
+ regbindings0)
+ (else
+ (error 'scan-binding 'regbindings)))))
+ (lambda.body-set! L E0)
+ (lambda.F-set! L F)
+ (lambda.G-set! L F)
+ (cond ((and simple-let?
+ (not (memq T1 F))
+ (no-side-effects? E1))
+ (abandon-expression! E1)
+ (values E0 F regbindings0))
+ ((and target-registers?
+ simple-let?
+ (local-variable-used-once? T1))
+ (post-simplify-anf L T1 E0 E1 free regbindings #f))
+ (else
+ (values (make-call L (list E1))
+ free
+ regbindings)))))
+
+ (define (scan-let0 E env available)
+ (let ((L (call.proc E)))
+ (if (simple-lambda? L)
+ (scan (lambda.body L) env available)
+ (let ((T1 (make-variable name:IGNORED)))
+ (lambda.args-set! L (list T1))
+ (call-with-values
+ (lambda () (scan (make-call L (list (make-constant 0)))
+ env
+ available))
+ (lambda (E F regbindings)
+ (lambda.args-set! L '())
+ (values (make-call L '())
+ F
+ regbindings)))))))
+
+ ; Optimizes the internal definitions of L and returns their
+ ; free variables.
+
+ (define (scan-defs L env available)
+ (let loop ((defs (lambda.defs L))
+ (newdefs '())
+ (Fdefs '()))
+ (if (null? defs)
+ (begin (lambda.defs-set! L (reverse newdefs))
+ Fdefs)
+ (let ((def (car defs)))
+ (call-with-values
+ (lambda ()
+ (let* ((Ldef (def.rhs def))
+ (Lformals (make-null-terminated (lambda.args Ldef)))
+ (Lenv (environment-extend*
+ (environment-extend* env Lformals)
+ (map def.lhs (lambda.defs Ldef)))))
+ (scan Ldef Lenv available)))
+ (lambda (rhs Frhs empty)
+ (if (not (null? empty))
+ (error 'scan-binding 'def))
+ (loop (cdr defs)
+ (cons (make-definition (def.lhs def) rhs)
+ newdefs)
+ (union Frhs Fdefs))))))))
+
+ ; Given the right-hand side of a let-binding, an environment,
+ ; and a table of available expressions, returns the transformed
+ ; expression, its free variables, and the register bindings that
+ ; need to be wrapped around it.
+
+ (define (scan-rhs E env available)
+
+ (cond
+ ((constant? E)
+ (values E (empty-set) '()))
+
+ ((variable? E)
+ (let* ((name (variable.name E))
+ (Enew (and commoning?
+ (if (global? name)
+ (let ((T (available-expression
+ available E)))
+ (if T
+ (make-variable T)
+ #f))
+ (available-variable available name)))))
+ (if Enew
+ (scan-rhs Enew env available)
+ (begin (used-variable! name)
+ (values E (list name) '())))))
+
+ ((lambda? E)
+ (let* ((formals (make-null-terminated (lambda.args E)))
+ (env (environment-extend*
+ (environment-extend* env formals)
+ (map def.lhs (lambda.defs E))))
+ (Fdefs (scan-defs E env available)))
+ (call-with-values
+ (lambda ()
+ (let ((available (copy-available-table available)))
+ (available-kill! available available:killer:all)
+ (scan-body (lambda.body E)
+ env
+ available
+ formals)))
+ (lambda (E0 F0 regbindings0)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings regbindings0 E0 F0))
+ (lambda (E0 F0)
+ (lambda.body-set! E E0)
+ (let ((F (union Fdefs F0)))
+ (for-each (lambda (x)
+ (closed-over-local-variable! x))
+ F)
+ (lambda.F-set! E F)
+ (lambda.G-set! E F)
+ (values E
+ (difference F
+ (make-null-terminated
+ (lambda.args E)))
+ '()))))))))
+
+ ((conditional? E)
+ (let ((E0 (if.test E))
+ (E1 (if.then E))
+ (E2 (if.else E)))
+ (if (constant? E0)
+ ; FIXME: E1 and E2 might not be a legal rhs,
+ ; so we can't just return the simplified E1 or E2.
+ (let ((E1 (if (constant.value E0) E1 E2)))
+ (call-with-values
+ (lambda () (scan E1 env available))
+ (lambda (E1 F1 regbindings1)
+ (cond ((or (not (call? E1))
+ (not (lambda? (call.proc E1))))
+ (values E1 F1 regbindings1))
+ (else
+ ; FIXME: Must return a valid rhs.
+ (values (make-conditional
+ (make-constant #t)
+ E1
+ (make-constant 0))
+ F1
+ regbindings1))))))
+ (call-with-values
+ (lambda () (scan E0 env available))
+ (lambda (E0 F0 regbindings0)
+ (if (not (null? regbindings0))
+ (error 'scan-rhs 'if))
+ (if (not (eq? E0 (if.test E)))
+ (scan-rhs (make-conditional E0 E1 E2)
+ env available)
+ (let ((available1
+ (copy-available-table available))
+ (available2
+ (copy-available-table available)))
+ (if (variable? E0)
+ (let ((T0 (variable.name E0)))
+ (available-add!
+ available2 T0 (make-constant #f)))
+ (error (make-readable E #t)))
+ (call-with-values
+ (lambda () (scan E1 env available1))
+ (lambda (E1 F1 regbindings1)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings1 E1 F1))
+ (lambda (E1 F1)
+ (call-with-values
+ (lambda () (scan E2 env available2))
+ (lambda (E2 F2 regbindings2)
+ (call-with-values
+ (lambda ()
+ (wrap-with-register-bindings
+ regbindings2 E2 F2))
+ (lambda (E2 F2)
+ (let ((E (make-conditional
+ E0 E1 E2))
+ (F (union F0 F1 F2)))
+ (available-intersect!
+ available
+ available1
+ available2)
+ (values E F '())))))))))))))))))
+
+
+ ((assignment? E)
+ (call-with-values
+ (lambda () (scan-rhs (assignment.rhs E) env available))
+ (lambda (E1 F1 regbindings1)
+ (if (not (null? regbindings1))
+ (error 'scan-rhs 'set!))
+ (available-kill! available available:killer:globals)
+ (values (make-assignment (assignment.lhs E) E1)
+ (union (list (assignment.lhs E)) F1)
+ '()))))
+
+ ((begin? E)
+ ; Shouldn't occur in A-normal form.
+ (error 'scan-rhs 'begin))
+
+ ((real-call? E)
+ (let* ((E0 (call.proc E))
+ (args (call.args E))
+ (regcontents (append regvars
+ (map (lambda (x) #f) args))))
+ (let loop ((args args)
+ (regs argument-registers)
+ (regcontents regcontents)
+ (newargs '())
+ (regbindings '())
+ (F (if (variable? E0)
+ (let ((f (variable.name E0)))
+ (used-variable! f)
+ (list f))
+ (empty-set))))
+ (cond ((null? args)
+ (available-kill! available available:killer:all)
+ (values (make-call E0 (reverse newargs))
+ F
+ regbindings))
+ ((null? regs)
+ (let ((arg (car args)))
+ (loop (cdr args)
+ '()
+ (cdr regcontents)
+ (cons arg newargs)
+ regbindings
+ (if (variable? arg)
+ (let ((name (variable.name arg)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))
+ ((and commoning?
+ (variable? (car args))
+ (available-variable
+ available
+ (variable.name (car args))))
+ (let* ((name (variable.name (car args)))
+ (Enew (available-variable available name)))
+ (loop (cons Enew (cdr args))
+ regs regcontents newargs regbindings F)))
+ ((and target-registers?
+ (variable? (car args))
+ (let ((x (variable.name (car args))))
+ ; We haven't yet recorded this use.
+ (or (local-variable-not-used? x)
+ (and (memq x regvars)
+ (not (eq? x (car regcontents)))))))
+ (let* ((x (variable.name (car args)))
+ (R (car regs))
+ (newarg (make-variable R)))
+ (used-variable! x)
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons newarg newargs)
+ (cons (make-regbinding R x newarg)
+ regbindings)
+ (union (list R) F))))
+ (else
+ (let ((E1 (car args)))
+ (loop (cdr args)
+ (cdr regs)
+ (cdr regcontents)
+ (cons E1 newargs)
+ regbindings
+ (if (variable? E1)
+ (let ((name (variable.name E1)))
+ (used-variable! name)
+ (union (list name) F))
+ F))))))))
+
+ ((call? E)
+ ; Must be a call to a primop.
+ (let* ((E0 (call.proc E))
+ (f0 (variable.name E0)))
+ (let loop ((args (call.args E))
+ (newargs '())
+ (F (list f0)))
+ (cond ((null? args)
+ (let* ((E (make-call E0 (reverse newargs)))
+ (T (and commoning?
+ (available-expression
+ available E))))
+ (if T
+ (begin (abandon-expression! E)
+ (scan-rhs (make-variable T) env available))
+ (begin
+ (available-kill!
+ available
+ (prim-kills (prim-entry f0)))
+ (cond ((eq? f0 name:check!)
+ (let ((x (car (call.args E))))
+ (cond ((not (runtime-safety-checking))
+ (abandon-expression! E)
+ ;(values x '() '())
+ (scan-rhs x env available))
+ ((variable? x)
+ (available-add!
+ available
+ (variable.name x)
+ (make-constant #t))
+ (values E F '()))
+ ((constant.value x)
+ (abandon-expression! E)
+ (values x '() '()))
+ (else
+ (declaration-error E)
+ (values E F '())))))
+ (else
+ (values E F '())))))))
+ ((variable? (car args))
+ (let* ((E1 (car args))
+ (x (variable.name E1))
+ (Enew
+ (and commoning?
+ (available-variable available x))))
+ (if Enew
+ ; All of the arguments are constants or
+ ; variables, so if the variable is replaced
+ ; here it will be replaced throughout the call.
+ (loop (cons Enew (cdr args))
+ newargs
+ (remq x F))
+ (begin
+ (used-variable! x)
+ (loop (cdr args)
+ (cons (car args) newargs)
+ (union (list x) F))))))
+ (else
+ (loop (cdr args)
+ (cons (car args) newargs)
+ F))))))
+
+ (else
+ (error 'scan-rhs (make-readable E)))))
+
+ (call-with-values
+ (lambda () (scan E env available))
+ (lambda (E F regbindings)
+ (call-with-values
+ (lambda () (wrap-with-register-bindings regbindings E F))
+ (lambda (E F)
+ (values E F '()))))))
+
+ (call-with-values
+ (lambda ()
+ (scan-body E
+ (make-hashtree symbol-hash assq)
+ (make-available-table)
+ '()))
+ (lambda (E F regbindings)
+ (if (not (null? regbindings))
+ (error 'scan-body))
+ E)))))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 16 June 1999.
+;
+; Intraprocedural representation inference.
+
+(define (representation-analysis exp)
+ (let* ((debugging? #f)
+ (integrate-usual? (integrate-usual-procedures))
+ (known (make-hashtable symbol-hash assq))
+ (types (make-hashtable symbol-hash assq))
+ (g (callgraph exp))
+ (schedule (list (callgraphnode.code (car g))))
+ (changed? #f)
+ (mutate? #f))
+
+ ; known is a hashtable that maps the name of a known local procedure
+ ; to a list of the form (tv1 ... tvN), where tv1, ..., tvN
+ ; are type variables that stand for the representation types of its
+ ; arguments. The type variable that stands for the representation
+ ; type of the result of the procedure has the same name as the
+ ; procedure itself.
+
+ ; types is a hashtable that maps local variables and the names
+ ; of known local procedures to an approximation of their
+ ; representation type.
+ ; For a known local procedure, the representation type is for the
+ ; result of the procedure, not the procedure itself.
+
+ ; schedule is a stack of work that needs to be done.
+ ; Each entry in the stack is either an escaping lambda expression
+ ; or the name of a known local procedure.
+
+ (define (schedule! job)
+ (if (not (memq job schedule))
+ (begin (set! schedule (cons job schedule))
+ (if (not (symbol? job))
+ (callgraphnode.info! (lookup-node job) #t)))))
+
+ ; Schedules a known local procedure.
+
+ (define (schedule-known-procedure! name)
+ ; Mark every known procedure that can actually be called.
+ (callgraphnode.info! (assq name g) #t)
+ (schedule! name))
+
+ ; Schedule all code that calls the given known local procedure.
+
+ (define (schedule-callers! name)
+ (for-each (lambda (node)
+ (if (and (callgraphnode.info node)
+ (or (memq name (callgraphnode.tailcalls node))
+ (memq name (callgraphnode.nontailcalls node))))
+ (let ((caller (callgraphnode.name node)))
+ (if caller
+ (schedule! caller)
+ (schedule! (callgraphnode.code node))))))
+ g))
+
+ ; Schedules local procedures of a lambda expression.
+
+ (define (schedule-local-procedures! L)
+ (for-each (lambda (def)
+ (let ((name (def.lhs def)))
+ (if (known-procedure-is-callable? name)
+ (schedule! name))))
+ (lambda.defs L)))
+
+ ; Returns true iff the given known procedure is known to be callable.
+
+ (define (known-procedure-is-callable? name)
+ (callgraphnode.info (assq name g)))
+
+ ; Sets CHANGED? to #t and returns #t if the type variable's
+ ; approximation has changed; otherwise returns #f.
+
+ (define (update-typevar! tv type)
+ (let* ((type0 (hashtable-get types tv))
+ (type0 (or type0
+ (begin (hashtable-put! types tv rep:bottom)
+ rep:bottom)))
+ (type1 (representation-union type0 type)))
+ (if (eq? type0 type1)
+ #f
+ (begin (hashtable-put! types tv type1)
+ (set! changed? #t)
+ (if (and debugging? mutate?)
+ (begin (display "******** Changing type of ")
+ (display tv)
+ (display " from ")
+ (display (rep->symbol type0))
+ (display " to ")
+ (display (rep->symbol type1))
+ (newline)))
+ #t))))
+
+ ; GIven the name of a known local procedure, returns its code.
+
+ (define (lookup-code name)
+ (callgraphnode.code (assq name g)))
+
+ ; Given a lambda expression, either escaping or the code for
+ ; a known local procedure, returns its node in the call graph.
+
+ (define (lookup-node L)
+ (let loop ((g g))
+ (cond ((null? g)
+ (error "Unknown lambda expression" (make-readable L #t)))
+ ((eq? L (callgraphnode.code (car g)))
+ (car g))
+ (else
+ (loop (cdr g))))))
+
+ ; Given: a type variable, expression, and a set of constraints.
+ ; Side effects:
+ ; Update the representation types of all variables that are
+ ; bound within the expression.
+ ; Update the representation types of all arguments to known
+ ; local procedures that are called within the expression.
+ ; If the representation type of an argument to a known local
+ ; procedure changes, then schedule that procedure's code
+ ; for analysis.
+ ; Update the constraint set to reflect the constraints that
+ ; hold following execution of the expression.
+ ; If mutate? is true, then transform the expression to rely
+ ; on the representation types that have been inferred.
+ ; Return: type of the expression under the current assumptions
+ ; and constraints.
+
+ (define (analyze exp constraints)
+
+ (if (and #f debugging?)
+ (begin (display "Analyzing: ")
+ (newline)
+ (pretty-print (make-readable exp #t))
+ (newline)))
+
+ (case (car exp)
+
+ ((quote)
+ (representation-of-value (constant.value exp)))
+
+ ((begin)
+ (let* ((name (variable.name exp)))
+ (representation-typeof name types constraints)))
+
+ ((lambda)
+ (schedule! exp)
+ rep:procedure)
+
+ ((set!)
+ (analyze (assignment.rhs exp) constraints)
+ (constraints-kill! constraints available:killer:globals)
+ rep:object)
+
+ ((if)
+ (let* ((E0 (if.test exp))
+ (E1 (if.then exp))
+ (E2 (if.else exp))
+ (type0 (analyze E0 constraints)))
+ (if mutate?
+ (cond ((representation-subtype? type0 rep:true)
+ (if.test-set! exp (make-constant #t)))
+ ((representation-subtype? type0 rep:false)
+ (if.test-set! exp (make-constant #f)))))
+ (cond ((representation-subtype? type0 rep:true)
+ (analyze E1 constraints))
+ ((representation-subtype? type0 rep:false)
+ (analyze E2 constraints))
+ ((variable? E0)
+ (let* ((T0 (variable.name E0))
+ (ignored (analyze E0 constraints))
+ (constraints1 (copy-constraints-table constraints))
+ (constraints2 (copy-constraints-table constraints)))
+ (constraints-add! types
+ constraints1
+ (make-type-constraint
+ T0 rep:true available:killer:immortal))
+ (constraints-add! types
+ constraints2
+ (make-type-constraint
+ T0 rep:false available:killer:immortal))
+ (let* ((type1 (analyze E1 constraints1))
+ (type2 (analyze E2 constraints2))
+ (type (representation-union type1 type2)))
+ (constraints-intersect! constraints
+ constraints1
+ constraints2)
+ type)))
+ (else
+ (representation-error "Bad ANF" (make-readable exp #t))))))
+
+ (else
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((lambda? proc)
+ (cond ((null? args)
+ (analyze-let0 exp constraints))
+ ((null? (cdr args))
+ (analyze-let1 exp constraints))
+ (else
+ (error "Compiler bug: pass3rep"))))
+ ((variable? proc)
+ (let* ((procname (variable.name proc)))
+ (cond ((hashtable-get known procname)
+ =>
+ (lambda (vars)
+ (analyze-known-call exp constraints vars)))
+ (integrate-usual?
+ (let ((entry (prim-entry procname)))
+ (if entry
+ (analyze-primop-call exp constraints entry)
+ (analyze-unknown-call exp constraints))))
+ (else
+ (analyze-unknown-call exp constraints)))))
+ (else
+ (analyze-unknown-call exp constraints)))))))
+
+ (define (analyze-let0 exp constraints)
+ (let ((proc (call.proc exp)))
+ (schedule-local-procedures! proc)
+ (if (null? (lambda.args proc))
+ (analyze (lambda.body exp) constraints)
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-let1 exp constraints)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc)))
+ (schedule-local-procedures! proc)
+ (if (and (pair? vars)
+ (null? (cdr vars)))
+ (let* ((T1 (car vars))
+ (E1 (car (call.args exp))))
+ (if (and integrate-usual? (call? E1))
+ (let ((proc (call.proc E1))
+ (args (call.args E1)))
+ (if (variable? proc)
+ (let* ((op (variable.name proc))
+ (entry (prim-entry op))
+ (K1 (if entry
+ (prim-lives-until entry)
+ available:killer:dead)))
+ (if (not (= K1 available:killer:dead))
+ ; Must copy the call to avoid problems
+ ; with side effects when mutate? is true.
+ (constraints-add!
+ types
+ constraints
+ (make-constraint T1
+ (make-call proc args)
+ K1)))))))
+ (update-typevar! T1 (analyze E1 constraints))
+ (analyze (lambda.body proc) constraints))
+ (analyze-unknown-call exp constraints))))
+
+ (define (analyze-primop-call exp constraints entry)
+ (let* ((op (prim-opcodename entry))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args))
+ (type (rep-result? op argtypes)))
+ (constraints-kill! constraints (prim-kills entry))
+ (cond ((and (eq? op 'check!)
+ (variable? (car args)))
+ (let ((varname (variable.name (car args))))
+ (if (and mutate?
+ (representation-subtype? (car argtypes) rep:true))
+ (call.args-set! exp
+ (cons (make-constant #t) (cdr args))))
+ (constraints-add! types
+ constraints
+ (make-type-constraint
+ varname
+ rep:true
+ available:killer:immortal))))
+ ((and mutate? (rep-specific? op argtypes))
+ =>
+ (lambda (newop)
+ (call.proc-set! exp (make-variable newop)))))
+ (or type rep:object)))
+
+ (define (analyze-known-call exp constraints vars)
+ (let* ((procname (variable.name (call.proc exp)))
+ (args (call.args exp))
+ (argtypes (map (lambda (arg) (analyze arg constraints))
+ args)))
+ (if (not (known-procedure-is-callable? procname))
+ (schedule-known-procedure! procname))
+ (for-each (lambda (var type)
+ (if (update-typevar! var type)
+ (schedule-known-procedure! procname)))
+ vars
+ argtypes)
+ ; FIXME: We aren't analyzing the effects of known local procedures.
+ (constraints-kill! constraints available:killer:all)
+ (hashtable-get types procname)))
+
+ (define (analyze-unknown-call exp constraints)
+ (analyze (call.proc exp) constraints)
+ (for-each (lambda (arg) (analyze arg constraints))
+ (call.args exp))
+ (constraints-kill! constraints available:killer:all)
+ rep:object)
+
+ (define (analyze-known-local-procedure name)
+ (if debugging?
+ (begin (display "Analyzing ")
+ (display name)
+ (newline)))
+ (let ((L (lookup-code name))
+ (constraints (make-constraints-table)))
+ (schedule-local-procedures! L)
+ (let ((type (analyze (lambda.body L) constraints)))
+ (if (update-typevar! name type)
+ (schedule-callers! name))
+ type)))
+
+ (define (analyze-unknown-lambda L)
+ (if debugging?
+ (begin (display "Analyzing escaping lambda expression")
+ (newline)))
+ (schedule-local-procedures! L)
+ (let ((vars (make-null-terminated (lambda.args L))))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep:object))
+ vars)
+ (analyze (lambda.body L)
+ (make-constraints-table))))
+
+ ; For debugging.
+
+ (define (display-types)
+ (hashtable-for-each (lambda (f vars)
+ (write f)
+ (display " : returns ")
+ (write (rep->symbol (hashtable-get types f)))
+ (newline)
+ (for-each (lambda (x)
+ (display " ")
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars))
+ known))
+
+ (define (display-all-types)
+ (let* ((vars (hashtable-map (lambda (x type) x) types))
+ (vars (twobit-sort (lambda (var1 var2)
+ (string<=? (symbol->string var1)
+ (symbol->string var2)))
+ vars)))
+ (for-each (lambda (x)
+ (write x)
+ (display ": ")
+ (write (rep->symbol
+ (hashtable-get types x)))
+ (newline))
+ vars)))
+ '
+ (if debugging?
+ (begin (pretty-print (make-readable (car schedule) #t))
+ (newline)))
+ (if debugging?
+ (view-callgraph g))
+
+ (for-each (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (code (callgraphnode.code node))
+ (vars (make-null-terminated (lambda.args code)))
+ (known? (symbol? name))
+ (rep (if known? rep:bottom rep:object)))
+ (callgraphnode.info! node #f)
+ (if known?
+ (begin (hashtable-put! known name vars)
+ (hashtable-put! types name rep)))
+ (for-each (lambda (var)
+ (hashtable-put! types var rep))
+ vars)))
+ g)
+
+ (let loop ()
+ (cond ((not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop)))
+ (changed?
+ (set! changed? #f)
+ (set! schedule (list (callgraphnode.code (car g))))
+ (if debugging?
+ (begin (display-all-types) (newline)))
+ (loop))))
+
+ (if debugging?
+ (display-types))
+
+ (set! mutate? #t)
+
+ ; We don't want to analyze known procedures that are never called.
+
+ (set! schedule
+ (cons (callgraphnode.code (car g))
+ (map callgraphnode.name
+ (filter (lambda (node)
+ (let* ((name (callgraphnode.name node))
+ (known? (symbol? name))
+ (marked?
+ (known-procedure-is-callable? name)))
+ (callgraphnode.info! node #f)
+ (and known? marked?)))
+ g))))
+ (let loop ()
+ (if (not (null? schedule))
+ (let ((job (car schedule)))
+ (set! schedule (cdr schedule))
+ (if (symbol? job)
+ (analyze-known-local-procedure job)
+ (analyze-unknown-lambda job))
+ (loop))))
+
+ (if changed?
+ (error "Compiler bug in representation inference"))
+
+ (if debugging?
+ (pretty-print (make-readable (callgraphnode.code (car g)) #t)))
+
+ exp))
+; Copyright 1999 William D Clinger.
+;
+; Permission to copy this software, in whole or in part, to use this
+; software for any lawful noncommercial purpose, and to redistribute
+; this software is granted subject to the restriction that all copies
+; made of this software must include this copyright notice in full.
+;
+; I also request that you send me a copy of any improvements that you
+; make to this software so that they may be incorporated within it to
+; the benefit of the Scheme community.
+;
+; 11 June 1999.
+;
+; The third "pass" of the Twobit compiler actually consists of several
+; passes, which are related by the common theme of flow analysis:
+; interprocedural inlining of known local procedures
+; interprocedural constant propagation and folding
+; intraprocedural commoning, copy propagation, and dead code elimination
+; representation inference (not yet implemented)
+; register targeting
+;
+; This pass operates as source-to-source transformations on
+; expressions written in the subset of Scheme described by the
+; following grammar:
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R, F, and G are garbage.
+; * Variables named IGNORED are neither referenced nor assigned.
+; * The expression does not share structure with the original input,
+; but might share structure with itself.
+;
+; Invariants that hold for the output only:
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * R is garbage.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * If a lambda expression is declared to be in A-normal form (see
+; pass3anormal.sch), then it really is in A-normal form.
+;
+; The phases of pass 3 interact with the referencing information R
+; and the free variables F as follows:
+;
+; Inlining ignores R, ignores F, destroys R, destroys F.
+; Constant propagation uses R, ignores F, preserves R, preserves F.
+; Conversion to ANF ignores R, ignores F, destroys R, destroys F.
+; Commoning ignores R, ignores F, destroys R, computes F.
+; Register targeting ignores R, ignores F, destroys R, computes F.
+
+(define (pass3 exp)
+
+ (define (phase1 exp)
+ (if (interprocedural-inlining)
+ (let ((g (callgraph exp)))
+ (inline-using-callgraph! g)
+ exp)
+ exp))
+
+ (define (phase2 exp)
+ (if (interprocedural-constant-propagation)
+ (constant-propagation (copy-exp exp))
+ exp))
+
+ (define (phase3 exp)
+ (if (common-subexpression-elimination)
+ (let* ((exp (if (interprocedural-constant-propagation)
+ exp
+ ; alpha-conversion
+ (copy-exp exp)))
+ (exp (a-normal-form exp)))
+ (if (representation-inference)
+ (intraprocedural-commoning exp 'commoning)
+ (intraprocedural-commoning exp)))
+ exp))
+
+ (define (phase4 exp)
+ (if (representation-inference)
+ (let ((exp (cond ((common-subexpression-elimination)
+ exp)
+ ((interprocedural-constant-propagation)
+ (a-normal-form exp))
+ (else
+ ; alpha-conversion
+ (a-normal-form (copy-exp exp))))))
+ (intraprocedural-commoning
+ (representation-analysis exp)))
+ exp))
+
+ (define (finish exp)
+ (if (and (not (interprocedural-constant-propagation))
+ (not (common-subexpression-elimination)))
+ (begin (compute-free-variables! exp)
+ exp)
+ ;(make-begin (list (make-constant 'anf) exp))))
+ exp))
+
+ (define (verify exp)
+ (check-referencing-invariants exp 'free)
+ exp)
+
+ (if (global-optimization)
+ (verify (finish (phase4 (phase3 (phase2 (phase1 exp))))))
+ (begin (compute-free-variables! exp)
+ (verify exp))))
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 4 June 1999
+
+; Implements the following abstract data types.
+;
+; labels
+; (init-labels)
+; (make-label)
+; cg-label-counter
+;
+; assembly streams
+; (make-assembly-stream)
+; (assembly-stream-code as)
+; (gen! as . instruction)
+; (gen-instruction! as instruction)
+; (gen-save! as frame)
+; (gen-restore! as frame)
+; (gen-pop! as frame)
+; (gen-setstk! as frame v)
+; (gen-store! as frame r v)
+; (gen-load! as frame r v)
+; (gen-stack! as frame v)
+;
+; temporaries
+; (init-temps)
+; (newtemp)
+; (newtemps)
+; newtemp-counter
+;
+; register environments
+; (cgreg-initial)
+; (cgreg-copy regs)
+; (cgreg-tos regs)
+; (cgreg-liveregs regs)
+; (cgreg-live regs r)
+; (cgreg-vars regs)
+; (cgreg-bind! regs r v)
+; (cgreg-bindregs! regs vars)
+; (cgreg-rename! regs alist)
+; (cgreg-release! regs r)
+; (cgreg-clear! regs)
+; (cgreg-lookup regs var)
+; (cgreg-lookup-reg regs r)
+; (cgreg-join! regs1 regs2)
+;
+; stack frame environments
+; (cgframe-initial)
+; (cgframe-size-cell frame)
+; (cgframe-size frame)
+; (cgframe-copy frame)
+; (cgframe-join! frame1 frame2)
+; (cgframe-update-stale! frame)
+; (cgframe-used! frame)
+; (cgframe-bind! frame n v instruction)
+; (cgframe-touch! frame v)
+; (cgframe-rename! frame alist)
+; (cgframe-release! frame v)
+; (cgframe-lookup frame v)
+; (cgframe-spilled? frame v)
+;
+; environments
+; (entry.name entry)
+; (entry.kind entry)
+; (entry.rib entry)
+; (entry.offset entry)
+; (entry.label entry)
+; (entry.regnum entry)
+; (entry.arity entry)
+; (entry.op entry)
+; (entry.imm entry)
+; (cgenv-initial)
+; (cgenv-lookup env id)
+; (cgenv-extend env vars procs)
+; (cgenv-bindprocs env procs)
+; (var-lookup var regs frame env)
+
+; Labels.
+
+(define (init-labels)
+ (set! cg-label-counter 1000))
+
+(define (make-label)
+ (set! cg-label-counter (+ cg-label-counter 1))
+ cg-label-counter)
+
+(define cg-label-counter 1000)
+
+; an assembly stream into which instructions should be emitted
+; an expression
+; the desired target register ('result, a register number, or '#f)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; contains size of frame, current top of frame
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+
+; Assembly streams, into which instructions are emitted by side effect.
+; Represented as a list of two things:
+;
+; Assembly code, represented as a pair whose car is a nonempty list
+; whose cdr is a possibly empty list of MacScheme machine assembly
+; instructions, and whose cdr is the last pair of the car.
+;
+; Any Scheme object that the code generator wants to associate with
+; this code.
+
+(define (make-assembly-stream)
+ (let ((code (list (list 0))))
+ (set-cdr! code (car code))
+ (list code #f)))
+
+(define (assembly-stream-code output)
+ (if (local-optimizations)
+ (filter-basic-blocks (cdar (car output)))
+ (cdar (car output))))
+
+(define (assembly-stream-info output)
+ (cadr output))
+
+(define (assembly-stream-info! output x)
+ (set-car! (cdr output) x)
+ #f)
+
+(define (gen-instruction! output instruction)
+ (let ((pair (list instruction))
+ (code (car output)))
+ (set-cdr! (cdr code) pair)
+ (set-cdr! code pair)
+ output))
+
+;
+
+(define (gen! output . instruction)
+ (gen-instruction! output instruction))
+
+(define (gen-save! output frame t0)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $save size))
+ (gen-store! output frame 0 t0)
+ (cgframe:stale-set! frame '())))
+
+(define (gen-restore! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $restore size))))
+
+(define (gen-pop! output frame)
+ (let ((size (cgframe-size-cell frame)))
+ (gen-instruction! output (cons $pop size))))
+
+(define (gen-setstk! output frame tempname)
+ (let ((instruction (list $nop $setstk -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-store! output frame r tempname)
+ (let ((instruction (list $nop $store r -1)))
+ (cgframe-bind! frame tempname instruction)
+ (gen-instruction! output instruction)))
+
+(define (gen-load! output frame r tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $load r n)))
+
+(define (gen-stack! output frame tempname)
+ (cgframe-touch! frame tempname)
+ (let ((n (entry.slotnum (cgframe-lookup frame tempname))))
+ (gen! output $stack n)))
+
+; Returns a temporary name.
+; Temporaries are compared using EQ?, so the use of small
+; exact integers as temporary names is implementation-dependent.
+
+(define (init-temps)
+ (set! newtemp-counter 5000))
+
+(define (newtemp)
+ (set! newtemp-counter
+ (+ newtemp-counter 1))
+ newtemp-counter)
+
+(define newtemp-counter 5000)
+
+(define (newtemps n)
+ (if (zero? n)
+ '()
+ (cons (newtemp)
+ (newtemps (- n 1)))))
+
+; New representation of
+; Register environments.
+; Represented as a list of three items:
+; an exact integer, one more than the highest index of a live register
+; a mutable vector with *nregs* elements of the form
+; #f (the register is dead)
+; #t (the register is live)
+; v (the register contains variable v)
+; t (the register contains temporary variable t)
+; a mutable vector of booleans: true if the register might be stale
+
+(define (cgreg-makeregs n v1 v2) (list n v1 v2))
+
+(define (cgreg-liveregs regs)
+ (car regs))
+
+(define (cgreg-contents regs)
+ (cadr regs))
+
+(define (cgreg-stale regs)
+ (caddr regs))
+
+(define (cgreg-liveregs-set! regs n)
+ (set-car! regs n)
+ regs)
+
+(define (cgreg-initial)
+ (let ((v1 (make-vector *nregs* #f))
+ (v2 (make-vector *nregs* #f)))
+ (cgreg-makeregs 0 v1 v2)))
+
+(define (cgreg-copy regs)
+ (let* ((newregs (cgreg-initial))
+ (v1a (cgreg-contents regs))
+ (v2a (cgreg-stale regs))
+ (v1 (cgreg-contents newregs))
+ (v2 (cgreg-stale newregs))
+ (n (vector-length v1a)))
+ (cgreg-liveregs-set! newregs (cgreg-liveregs regs))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ newregs)
+ (vector-set! v1 i (vector-ref v1a i))
+ (vector-set! v2 i (vector-ref v2a i)))))
+
+(define (cgreg-tos regs)
+ (- (cgreg-liveregs regs) 1))
+
+(define (cgreg-live regs r)
+ (if (eq? r 'result)
+ (cgreg-tos regs)
+ (max r (cgreg-tos regs))))
+
+(define (cgreg-vars regs)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (do ((i (- m 1) (- i 1))
+ (vars '()
+ (cons (vector-ref v i)
+ vars)))
+ ((< i 0)
+ vars))))
+
+(define (cgreg-bind! regs r t)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r t)
+ (if (>= r m)
+ (cgreg-liveregs-set! regs (+ r 1)))))
+
+(define (cgreg-bindregs! regs vars)
+ (do ((m (cgreg-liveregs regs) (+ m 1))
+ (v (cgreg-contents regs))
+ (vars vars (cdr vars)))
+ ((null? vars)
+ (cgreg-liveregs-set! regs m)
+ regs)
+ (vector-set! v m (car vars))))
+
+(define (cgreg-rename! regs alist)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if var
+ (let ((probe (assv var alist)))
+ (if probe
+ (vector-set! v i (cdr probe))))))))
+
+(define (cgreg-release! regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (vector-set! v r #f)
+ (vector-set! (cgreg-stale regs) r #t)
+ (if (= r (- m 1))
+ (do ((m r (- m 1)))
+ ((or (negative? m)
+ (vector-ref v m))
+ (cgreg-liveregs-set! regs (+ m 1)))))))
+
+(define (cgreg-release-except! regs vars)
+ (do ((i (- (cgreg-liveregs regs) 1) (- i 1))
+ (v (cgreg-contents regs)))
+ ((negative? i))
+ (let ((var (vector-ref v i)))
+ (if (and var (not (memq var vars)))
+ (cgreg-release! regs i)))))
+
+(define (cgreg-clear! regs)
+ (let ((m (cgreg-liveregs regs))
+ (v1 (cgreg-contents regs))
+ (v2 (cgreg-stale regs)))
+ (do ((r 0 (+ r 1)))
+ ((= r m)
+ (cgreg-liveregs-set! regs 0))
+ (vector-set! v1 r #f)
+ (vector-set! v2 r #t))))
+
+(define (cgreg-lookup regs var)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (define (loop i)
+ (cond ((< i 0)
+ #f)
+ ((eq? var (vector-ref v i))
+ (list var 'register i '(object)))
+ (else
+ (loop (- i 1)))))
+ (loop (- m 1))))
+
+(define (cgreg-lookup-reg regs r)
+ (let ((m (cgreg-liveregs regs))
+ (v (cgreg-contents regs)))
+ (if (<= m r)
+ #f
+ (vector-ref v r))))
+
+(define (cgreg-join! regs1 regs2)
+ (let ((m1 (cgreg-liveregs regs1))
+ (m2 (cgreg-liveregs regs2))
+ (v1 (cgreg-contents regs1))
+ (v2 (cgreg-contents regs2))
+ (stale1 (cgreg-stale regs1)))
+ (do ((i (- (max m1 m2) 1) (- i 1)))
+ ((< i 0)
+ (cgreg-liveregs-set! regs1 (min m1 m2)))
+ (let ((x1 (vector-ref v1 i))
+ (x2 (vector-ref v2 i)))
+ (cond ((eq? x1 x2)
+ #t)
+ ((not x1)
+ (if x2
+ (vector-set! stale1 i #t)))
+ (else
+ (vector-set! v1 i #f)
+ (vector-set! stale1 i #t)))))))
+
+; New representation of
+; Stack-frame environments.
+; Represented as a three-element list.
+;
+; Its car is a list whose car is a list of slot entries, each
+; of the form
+; (v n instruction stale)
+; where
+; v is the name of a variable or temporary,
+; n is #f or a slot number,
+; instruction is a possibly phantom store or setstk instruction
+; that stores v into slot n, and
+; stale is a list of stale slot entries, each of the form
+; (#t . n)
+; or (#f . -1)
+; where slot n had been allocated, initialized, and released
+; before the store or setstk instruction was generated.
+; Slot entries are updated by side effect.
+;
+; Its cadr is the list of currently stale slots.
+;
+; Its caddr is a list of variables that are free in the continuation,
+; or #f if that information is unknown.
+; This information allows a direct-style code generator to know when
+; a slot becomes stale.
+;
+; Its cadddr is the size of the stack frame, which can be
+; increased but not decreased. The cdddr of the stack frame
+; environment is shared with the save instruction that
+; created the frame. What a horrible crock!
+
+; This stuff is private to the implementation of stack-frame
+; environments.
+
+(define cgframe:slots car)
+(define cgframe:stale cadr)
+(define cgframe:livevars caddr)
+(define cgframe:slot.name car)
+(define cgframe:slot.offset cadr)
+(define cgframe:slot.instruction caddr)
+(define cgframe:slot.stale cadddr)
+
+(define cgframe:slots-set! set-car!)
+(define (cgframe:stale-set! frame stale)
+ (set-car! (cdr frame) stale))
+(define (cgframe:livevars-set! frame vars)
+ (set-car! (cddr frame) vars))
+
+(define cgframe:slot.name-set! set-car!)
+
+(define (cgframe:slot.offset-set! entry n)
+ (let ((instruction (caddr entry)))
+ (if (or (not (eq? #f (cadr entry)))
+ (not (eq? $nop (car instruction))))
+ (error "Compiler bug: cgframe" entry)
+ (begin
+ (set-car! (cdr entry) n)
+ (set-car! instruction (cadr instruction))
+ (set-cdr! instruction (cddr instruction))
+ (if (eq? $setstk (car instruction))
+ (set-car! (cdr instruction) n)
+ (set-car! (cddr instruction) n))))))
+
+; Reserves a slot offset that was unused where the instruction
+; of the slot entry was generated, and returns that offset.
+
+(define (cgframe:unused-slot frame entry)
+ (let* ((stale (cgframe:slot.stale entry))
+ (probe (assq #t stale)))
+ (if probe
+ (let ((n (cdr probe)))
+ (if (zero? n)
+ (cgframe-used! frame))
+ (set-car! probe #f)
+ n)
+ (let* ((cell (cgframe-size-cell frame))
+ (n (+ 1 (car cell))))
+ (set-car! cell n)
+ (if (zero? n)
+ (cgframe:unused-slot frame entry)
+ n)))))
+
+; Public entry points.
+
+; The runtime system requires slot 0 of a frame to contain
+; a closure whose code pointer contains the return address
+; of the frame.
+; To prevent slot 0 from being used for some other purpose,
+; we rely on a complex trick: Slot 0 is initially stale.
+; Gen-save! generates a store instruction for register 0,
+; with slot 0 as the only stale slot for that instruction;
+; then gen-save! clears the frame's set of stale slots, which
+; prevents other store instructions from using slot 0.
+
+(define (cgframe-initial)
+ (list '()
+ (list (cons #t 0))
+ '#f
+ -1))
+
+(define cgframe-livevars cgframe:livevars)
+(define cgframe-livevars-set! cgframe:livevars-set!)
+
+(define (cgframe-size-cell frame)
+ (cdddr frame))
+
+(define (cgframe-size frame)
+ (car (cgframe-size-cell frame)))
+
+(define (cgframe-used! frame)
+ (if (negative? (cgframe-size frame))
+ (set-car! (cgframe-size-cell frame) 0)))
+
+; Called only by gen-store!, gen-setstk!
+
+(define (cgframe-bind! frame var instruction)
+ (cgframe:slots-set! frame
+ (cons (list var #f instruction (cgframe:stale frame))
+ (cgframe:slots frame))))
+
+; Called only by gen-load!, gen-stack!
+
+(define (cgframe-touch! frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (let ((n (cgframe:unused-slot frame entry)))
+ (cgframe:slot.offset-set! entry n))))
+ (error "Compiler bug: cgframe-touch!" frame var))))
+
+(define (cgframe-rename! frame alist)
+ (for-each (lambda (entry)
+ (let ((probe (assq (cgframe:slot.name entry) alist)))
+ (if probe
+ (cgframe:slot.name-set! entry (cdr probe)))))
+ (cgframe:slots frame)))
+
+(define (cgframe-release! frame var)
+ (let* ((slots (cgframe:slots frame))
+ (entry (assq var slots)))
+ (if entry
+ (begin (cgframe:slots-set! frame (remq entry slots))
+ (let ((n (cgframe:slot.offset entry)))
+ (if (and (not (eq? #f n))
+ (not (zero? n)))
+ (cgframe:stale-set!
+ frame
+ (cons (cons #t n)
+ (cgframe:stale frame)))))))))
+
+(define (cgframe-release-except! frame vars)
+ (let loop ((slots (reverse (cgframe:slots frame)))
+ (newslots '())
+ (stale (cgframe:stale frame)))
+ (if (null? slots)
+ (begin (cgframe:slots-set! frame newslots)
+ (cgframe:stale-set! frame stale))
+ (let ((slot (car slots)))
+ (if (memq (cgframe:slot.name slot) vars)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale)
+ (let ((n (cgframe:slot.offset slot)))
+ (cond ((eq? n #f)
+ (loop (cdr slots)
+ newslots
+ stale))
+ ((zero? n)
+ (loop (cdr slots)
+ (cons slot newslots)
+ stale))
+ (else
+ (loop (cdr slots)
+ newslots
+ (cons (cons #t n) stale))))))))))
+
+(define (cgframe-lookup frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (if (eq? #f n)
+ (cgframe-touch! frame var))
+ (list var 'frame (cgframe:slot.offset entry) '(object)))
+ #f)))
+
+(define (cgframe-spilled? frame var)
+ (let ((entry (assq var (cgframe:slots frame))))
+ (if entry
+ (let ((n (cgframe:slot.offset entry)))
+ (not (eq? #f n)))
+ #f)))
+
+; For a conditional expression, the then and else parts must be
+; evaluated using separate copies of the frame environment,
+; and those copies must be resolved at the join point. The
+; nature of the resolution depends upon whether the conditional
+; expression is in a tail position.
+;
+; Critical invariant:
+; Any store instructions that are generated within either arm of the
+; conditional involve variables and temporaries that are local to the
+; conditional.
+;
+; If the conditional expression is in a tail position, then a slot
+; that is stale after the test can be allocated independently by the
+; two arms of the conditional. If the conditional expression is in a
+; non-tail position, then the slot can be allocated independently
+; provided it is not a candidate destination for any previous emitted
+; store instruction.
+
+(define (cgframe-copy frame)
+ (cons (car frame)
+ (cons (cadr frame)
+ (cons (caddr frame)
+ (cdddr frame)))))
+
+(define (cgframe-update-stale! frame)
+ (let* ((n (cgframe-size frame))
+ (v (make-vector (+ 1 n) #t))
+ (stale (cgframe:stale frame)))
+ (for-each (lambda (x)
+ (if (car x)
+ (let ((i (cdr x)))
+ (if (<= i n)
+ (vector-set! v i #f)))))
+ stale)
+ (for-each (lambda (slot)
+ (let ((offset (cgframe:slot.offset slot)))
+ (if offset
+ (vector-set! v offset #f)
+ (for-each (lambda (stale)
+ (if (car stale)
+ (let ((i (cdr stale)))
+ (if (< i n)
+ (vector-set! v i #f)))))
+ (cgframe:slot.stale slot)))))
+ (cgframe:slots frame))
+ (do ((i n (- i 1))
+ (stale (filter car stale)
+ (if (vector-ref v i)
+ (cons (cons #t i) stale)
+ stale)))
+ ((<= i 0)
+ (cgframe:stale-set! frame stale)))))
+
+(define (cgframe-join! frame1 frame2)
+ (let* ((slots1 (cgframe:slots frame1))
+ (slots2 (cgframe:slots frame2))
+ (slots (intersection slots1 slots2))
+ (deadslots (append (difference slots1 slots)
+ (difference slots2 slots)))
+ (deadoffsets (make-set
+ (filter (lambda (x) (not (eq? x #f)))
+ (map cgframe:slot.offset deadslots))))
+ (stale1 (cgframe:stale frame1))
+ (stale2 (cgframe:stale frame2))
+ (stale (intersection stale1 stale2))
+ (stale (append (map (lambda (n) (cons #t n))
+ deadoffsets)
+ stale)))
+ (cgframe:slots-set! frame1 slots)
+ (cgframe:stale-set! frame1 stale)))
+
+; Environments.
+;
+; Each identifier has one of the following kinds of entry.
+;
+; (<name> register <number> (object))
+; (<name> frame <slot> (object))
+; (<name> lexical <rib> <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+; (<name> global (object))
+;
+; Implementation.
+;
+; An environment is represented as a list of the form
+;
+; ((<entry> ...) ; lexical rib
+; ...)
+;
+; where each <entry> has one of the forms
+;
+; (<name> lexical <offset> (object))
+; (<name> procedure <rib> <label> (object))
+; (<name> integrable <arity> <op> <imm> (object))
+
+(define entry.name car)
+(define entry.kind cadr)
+(define entry.rib caddr)
+(define entry.offset cadddr)
+(define entry.label cadddr)
+(define entry.regnum caddr)
+(define entry.slotnum caddr)
+(define entry.arity caddr)
+(define entry.op cadddr)
+(define (entry.imm entry) (car (cddddr entry)))
+
+(define (cgenv-initial integrable)
+ (list (map (lambda (x)
+ (list (car x)
+ 'integrable
+ (cadr x)
+ (caddr x)
+ (cadddr x)
+ '(object)))
+ integrable)))
+
+(define (cgenv-lookup env id)
+ (define (loop ribs m)
+ (if (null? ribs)
+ (cons id '(global (object)))
+ (let ((x (assq id (car ribs))))
+ (if x
+ (case (cadr x)
+ ((lexical)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((procedure)
+ (cons id
+ (cons (cadr x)
+ (cons m (cddr x)))))
+ ((integrable)
+ (if (integrate-usual-procedures)
+ x
+ (loop '() m)))
+ (else ???))
+ (loop (cdr ribs) (+ m 1))))))
+ (loop env 0))
+
+(define (cgenv-extend env vars procs)
+ (cons (do ((n 0 (+ n 1))
+ (vars vars (cdr vars))
+ (rib (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (cons (list (car vars) 'lexical n '(object)) rib)))
+ ((null? vars) rib))
+ env))
+
+(define (cgenv-bindprocs env procs)
+ (cons (append (map (lambda (id)
+ (list id 'procedure (make-label) '(object)))
+ procs)
+ (car env))
+ (cdr env)))
+
+(define (var-lookup var regs frame env)
+ (or (cgreg-lookup regs var)
+ (cgframe-lookup frame var)
+ (cgenv-lookup env var)))
+
+; Compositions.
+
+(define compile
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1 x))) $usual-integrable-procedures$)))
+
+(define compile-block
+ (lambda (x)
+ (pass4 (pass3 (pass2 (pass1-block x))) $usual-integrable-procedures$)))
+
+; For testing.
+
+(define foo
+ (lambda (x)
+ (pretty-print (compile x))))
+
+; Find the smallest number of registers such that
+; adding more registers does not affect the code
+; generated for x (from 4 to 32 registers).
+
+(define (minregs x)
+ (define (defregs R)
+ (set! *nregs* R)
+ (set! *lastreg* (- *nregs* 1))
+ (set! *fullregs* (quotient *nregs* 2)))
+ (defregs 32)
+ (let ((code (assemble (compile x))))
+ (define (binary-search m1 m2)
+ (if (= (+ m1 1) m2)
+ m2
+ (let ((midpt (quotient (+ m1 m2) 2)))
+ (defregs midpt)
+ (if (equal? code (assemble (compile x)))
+ (binary-search m1 midpt)
+ (binary-search midpt m2)))))
+ (defregs 4)
+ (let ((newcode (assemble (compile x))))
+ (if (equal? code newcode)
+ 4
+ (binary-search 4 32)))))
+
+; Minimums:
+; browse 10
+; triangle 5
+; traverse 10
+; destruct 6
+; puzzle 8,8,10,7
+; tak 6
+; fft 28 (changing the named lets to macros didn't matter)
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 7 June 1999.
+;
+; Fourth pass of the Twobit compiler:
+; code generation for the MacScheme machine.
+;
+; This pass operates on input expressions described by the
+; following grammar and the invariants that follow it.
+;
+; "X ..." means zero or more occurrences of X.
+;
+; L --> (lambda (I_1 ...)
+; (begin D ...)
+; (quote (R F G <decls> <doc>)
+; E)
+; | (lambda (I_1 ... . I_rest)
+; (begin D ...)
+; (quote (R F G <decls> <doc>))
+; E)
+; D --> (define I L)
+; E --> (quote K) ; constants
+; | (begin I) ; variable references
+; | L ; lambda expressions
+; | (E0 E1 ...) ; calls
+; | (set! I E) ; assignments
+; | (if E0 E1 E2) ; conditionals
+; | (begin E0 E1 E2 ...) ; sequential expressions
+; I --> <identifier>
+;
+; R --> ((I <references> <assignments> <calls>) ...)
+; F --> (I ...)
+; G --> (I ...)
+;
+; Invariants that hold for the input
+; * There are no assignments except to global variables.
+; * If I is declared by an internal definition, then the right hand
+; side of the internal definition is a lambda expression and I
+; is referenced only in the procedure position of a call.
+; * Every procedure defined by an internal definition takes a
+; fixed number of arguments.
+; * Every call to a procedure defined by an internal definition
+; passes the correct number of arguments.
+; * For each lambda expression, the associated F is a list of all
+; the identifiers that occur free in the body of that lambda
+; expression, and possibly a few extra identifiers that were
+; once free but have been removed by optimization.
+; * For each lambda expression, the associated G is a subset of F
+; that contains every identifier that occurs free within some
+; inner lambda expression that escapes, and possibly a few that
+; don't. (Assignment-elimination does not calculate G exactly.)
+; * Variables named IGNORED are neither referenced nor assigned.
+; * Any lambda expression that is declared to be in A-normal form
+; really is in A-normal form.
+;
+;
+; Stack frames are created by "save" instructions.
+; A save instruction is generated
+;
+; * at the beginning of each lambda body
+; * at the beginning of the code for each arm of a conditional,
+; provided:
+; the conditional is in a tail position
+; the frames that were allocated by the save instructions
+; that dominate the arms of the conditional have not been
+; used (those save instructions will be eliminated during
+; assembly)
+;
+; The operand of a save instruction, and of its matching pop instructions,
+; increases automatically as frame slots are allocated.
+;
+; The code generated to return from a procedure is
+;
+; pop n
+; return
+;
+; The code generated for a tail call is
+;
+; pop n
+; invoke ...
+;
+; Invariant: When the code generator reserves an argument register
+; to hold a value, that value is named, and is stored into the current
+; stack frame. These store instructions are eliminated during assembly
+; unless there is a matching load instruction. If all of the instructions
+; that store into a stack frame are eliminated, then the stack frame
+; itself is eliminated.
+; Exception: An argument register may be used without naming or storing
+; its value provided the register is not in use and no expressions are
+; evaluated while it contains the unnamed and unstored value.
+
+
+(define (pass4 exp integrable)
+ (init-labels)
+ (init-temps)
+ (let ((output (make-assembly-stream))
+ (frame (cgframe-initial))
+ (regs (cgreg-initial))
+ (t0 (newtemp)))
+ (assembly-stream-info! output (make-hashtable equal-hash assoc))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (cg0 output
+ exp
+ 'result
+ regs
+ frame
+ (cgenv-initial integrable)
+ #t)
+ (pass4-code output)))
+
+(define (pass4-code output)
+ (hashtable-for-each (lambda (situation label)
+ (cg-trap output situation label))
+ (assembly-stream-info output))
+ (assembly-stream-code output))
+
+; Given:
+; an assembly stream into which instructions should be emitted
+; an expression
+; the target register
+; ('result, a register number, or '#f; tail position implies 'result)
+; a register environment [cgreg]
+; a stack-frame environment [cgframe]
+; a compile-time environment [cgenv]
+; a flag indicating whether the expression is in tail position
+; Returns:
+; the target register ('result or a register number)
+; Side effects:
+; may change the register and stack-frame environments
+; may increase the size of the stack frame, which changes previously
+; emitted instructions
+; writes instructions to the assembly stream
+
+(define (cg0 output exp target regs frame env tail?)
+ (case (car exp)
+ ((quote) (gen! output $const (constant.value exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((lambda) (cg-lambda output exp regs frame env)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((set!) (cg0 output (assignment.rhs exp) 'result regs frame env #f)
+ (cg-assignment-result output exp target regs frame env tail?))
+ ((if) (cg-if output exp target regs frame env tail?))
+ ((begin) (if (variable? exp)
+ (cg-variable output exp target regs frame env tail?)
+ (cg-sequential output exp target regs frame env tail?)))
+ (else (cg-call output exp target regs frame env tail?))))
+
+; Lambda expressions that evaluate to closures.
+; This is hard because the MacScheme machine's lambda instruction
+; closes over the values that are in argument registers 0 through r
+; (where r can be larger than *nregs*).
+; The set of free variables is calculated and then sorted to minimize
+; register shuffling.
+;
+; Returns: nothing.
+
+(define (cg-lambda output exp regs frame env)
+ (let* ((args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (free (difference (lambda.F exp) vars))
+ (free (cg-sort-vars free regs frame env))
+ (newenv (cgenv-extend env (cons #t free) '()))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv)
+ (cg-eval-vars output free regs frame env)
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this the right constant?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ ; FIXME
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: This load forces a stack frame to be allocated.
+ (gen-load! output frame 0 (cgreg-lookup-reg regs 0)))))
+
+; Given a list of free variables, filters out the ones that
+; need to be copied into a closure, and sorts them into an order
+; that reduces register shuffling. Returns a sorted version of
+; the list in which the first element (element 0) should go
+; into register 1, the second into register 2, and so on.
+
+(define (cg-sort-vars free regs frame env)
+ (let* ((free (filter (lambda (var)
+ (case (entry.kind
+ (var-lookup var regs frame env))
+ ((register frame)
+ #t)
+ ((lexical)
+ (not (ignore-space-leaks)))
+ (else #f)))
+ free))
+ (n (length free))
+ (m (min n (- *nregs* 1)))
+ (vec (make-vector m #f)))
+ (define (loop1 free free-notregister)
+ (if (null? free)
+ (loop2 0 free-notregister)
+ (let* ((var (car free))
+ (entry (cgreg-lookup regs var)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (<= r n)
+ (begin (vector-set! vec (- r 1) var)
+ (loop1 (cdr free)
+ free-notregister))
+ (loop1 (cdr free)
+ (cons var free-notregister))))
+ (loop1 (cdr free)
+ (cons var free-notregister))))))
+ (define (loop2 i free)
+ (cond ((null? free)
+ (vector->list vec))
+ ((= i m)
+ (append (vector->list vec) free))
+ ((vector-ref vec i)
+ (loop2 (+ i 1) free))
+ (else
+ (vector-set! vec i (car free))
+ (loop2 (+ i 1) (cdr free)))))
+ (loop1 free '())))
+
+; Fetches the given list of free variables into the corresponding
+; registers in preparation for a $lambda or $lexes instruction.
+
+(define (cg-eval-vars output free regs frame env)
+ (let ((n (length free))
+ (R-1 (- *nregs* 1)))
+ (if (>= n R-1)
+ (begin (gen! output $const '())
+ (gen! output $setreg R-1)
+ (cgreg-release! regs R-1)))
+ (do ((r n (- r 1))
+ (vars (reverse free) (cdr vars)))
+ ((zero? r))
+ (let* ((v (car vars))
+ (entry (var-lookup v regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (let ((r1 (entry.regnum entry)))
+ (if (not (eqv? r r1))
+ (if (< r R-1)
+ (begin (gen! output $movereg r1 r)
+ (cgreg-bind! regs r v))
+ (gen! output $reg r1 v)))))
+ ((frame)
+ (if (< r R-1)
+ (begin (gen-load! output frame r v)
+ (cgreg-bind! regs r v))
+ (gen-stack! output frame v)))
+ ((lexical)
+ (gen! output $lexical
+ (entry.rib entry)
+ (entry.offset entry)
+ v)
+ (if (< r R-1)
+ (begin (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v))))
+ (else
+ (error "Bug in cg-close-lambda")))
+ (if (>= r R-1)
+ (begin (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1)))))))
+
+; Lambda expressions that appear on the rhs of a definition are
+; compiled here. They don't need an args= instruction at their head.
+;
+; Returns: nothing.
+
+(define (cg-known-lambda output exp env)
+ (let* ((vars (make-null-terminated (lambda.args exp)))
+ (regs (cgreg-initial))
+ (frame (cgframe-initial))
+ (t0 (newtemp)))
+ (if (member A-normal-form-declaration (lambda.decls exp))
+ (cgframe-livevars-set! frame '()))
+ (cgreg-bind! regs 0 t0)
+ (gen-save! output frame t0)
+ (do ((r 1 (+ r 1))
+ (vars vars (cdr vars)))
+ ((or (null? vars)
+ (= r *lastreg*))
+ (if (not (null? vars))
+ (begin (gen! output $movereg *lastreg* 1)
+ (cgreg-release! regs 1)
+ (do ((vars vars (cdr vars)))
+ ((null? vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $car:pair)
+ (gen-setstk! output frame (car vars))
+ (gen! output $reg 1)
+ (gen! output $op1 $cdr:pair)
+ (gen! output $setreg 1)))))
+ (cgreg-bind! regs r (car vars))
+ (gen-store! output frame r (car vars)))
+ (cg-body output
+ exp
+ 'result
+ regs
+ frame
+ env
+ #t)))
+
+; Compiles a let or lambda body.
+; The arguments of the lambda expression L are already in
+; registers or the stack frame, as specified by regs and frame.
+;
+; The problem here is that the free variables of an internal
+; definition must be in a heap-allocated environment, so any
+; such variables in registers must be copied to the heap.
+;
+; Returns: destination register.
+
+(define (cg-body output L target regs frame env tail?)
+ (let* ((exp (lambda.body L))
+ (defs (lambda.defs L))
+ (free (apply-union
+ (map (lambda (def)
+ (let ((L (def.rhs def)))
+ (difference (lambda.F L)
+ (lambda.args L))))
+ defs))))
+ (cond ((or (null? defs) (constant? exp) (variable? exp))
+ (cg0 output exp target regs frame env tail?))
+ ((lambda? exp)
+ (let* ((free (cg-sort-vars
+ (union free
+ (difference
+ (lambda.F exp)
+ (make-null-terminated (lambda.args exp))))
+ regs frame env))
+ (newenv1 (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (args (lambda.args exp))
+ (vars (make-null-terminated args))
+ (newoutput (make-assembly-stream)))
+ (assembly-stream-info! newoutput (make-hashtable equal-hash assoc))
+ (gen! newoutput $.proc)
+ (if (list? args)
+ (gen! newoutput $args= (length args))
+ (gen! newoutput $args>= (- (length vars) 1)))
+ (cg-known-lambda newoutput exp newenv1)
+ (cg-defs newoutput defs newenv1)
+ (cg-eval-vars output free regs frame env)
+ (gen! output
+ $lambda
+ (pass4-code newoutput)
+ (length free)
+ (lambda.doc exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target))))
+ ((every? (lambda (def)
+ (every? (lambda (v)
+ (case (entry.kind
+ (var-lookup v regs frame env))
+ ((register frame) #f)
+ (else #t)))
+ (let ((Ldef (def.rhs def)))
+ (difference (lambda.F Ldef)
+ (lambda.args Ldef)))))
+ defs)
+ (let* ((newenv (cgenv-bindprocs env (map def.lhs defs)))
+ (L (make-label))
+ (r (cg0 output exp target regs frame newenv tail?)))
+ (if (not tail?)
+ (gen! output $skip L (cgreg-live regs r)))
+ (cg-defs output defs newenv)
+ (if (not tail?)
+ (gen! output $.label L))
+ r))
+ (else
+ (let ((free (cg-sort-vars free regs frame env)))
+ (cg-eval-vars output free regs frame env)
+ ; FIXME: Have to restore it too!
+ '
+ (if (not (ignore-space-leaks))
+ ; FIXME: Is this constant the right one?
+ (begin (gen! output $const #f)
+ (gen! output $setreg 0)))
+ (let ((t0 (cgreg-lookup-reg regs 0))
+ (t1 (newtemp))
+ (newenv (cgenv-extend env
+ (cons #t free)
+ (map def.lhs defs)))
+ (L (make-label)))
+ (gen! output $lexes (length free) free)
+ (gen! output $setreg 0)
+ (cgreg-bind! regs 0 t1)
+ (if tail?
+ (begin (cgframe-release! frame t0)
+ (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #t)
+ (cg-defs output defs newenv)
+ 'result)
+ (begin (gen-store! output frame 0 t1)
+ (cg0 output exp 'result regs frame newenv #f)
+ (gen! output $skip L (cgreg-tos regs))
+ (cg-defs output defs newenv)
+ (gen! output $.label L)
+ (gen-load! output frame 0 t0)
+ (cgreg-bind! regs 0 t0)
+ (cgframe-release! frame t1)
+ (cg-move output frame regs 'result target)))))))))
+
+(define (cg-defs output defs env)
+ (for-each (lambda (def)
+ (gen! output $.align 4)
+ (gen! output $.label
+ (entry.label
+ (cgenv-lookup env (def.lhs def))))
+ (gen! output $.proc)
+ (gen! output $.proc-doc (lambda.doc (def.rhs def)))
+ (cg-known-lambda output
+ (def.rhs def)
+ env))
+ defs))
+
+; The right hand side has already been evaluated into the result register.
+
+(define (cg-assignment-result output exp target regs frame env tail?)
+ (gen! output $setglbl (assignment.lhs exp))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+
+(define (cg-if output exp target regs frame env tail?)
+ ; The test can be a constant, because it is awkward
+ ; to remove constant tests from an A-normal form.
+ (if (constant? (if.test exp))
+ (cg0 output
+ (if (constant.value (if.test exp))
+ (if.then exp)
+ (if.else exp))
+ target regs frame env tail?)
+ (begin
+ (cg0 output (if.test exp) 'result regs frame env #f)
+ (cg-if-result output exp target regs frame env tail?))))
+
+; The test expression has already been evaluated into the result register.
+
+(define (cg-if-result output exp target regs frame env tail?)
+ (let ((L1 (make-label))
+ (L2 (make-label)))
+ (gen! output $branchf L1 (cgreg-tos regs))
+ (let* ((regs2 (cgreg-copy regs))
+ (frame1 (if (and tail?
+ (negative? (cgframe-size frame)))
+ (cgframe-initial)
+ frame))
+ (frame2 (if (eq? frame frame1)
+ (cgframe-copy frame1)
+ (cgframe-initial)))
+ (t0 (cgreg-lookup-reg regs 0)))
+ (if (not (eq? frame frame1))
+ (let ((live (cgframe-livevars frame)))
+ (cgframe-livevars-set! frame1 live)
+ (cgframe-livevars-set! frame2 live)
+ (gen-save! output frame1 t0)
+ (cg-saveregs output regs frame1)))
+ (let ((r (cg0 output (if.then exp) target regs frame1 env tail?)))
+ (if (not tail?)
+ (gen! output $skip L2 (cgreg-live regs r)))
+ (gen! output $.label L1)
+ (if (not (eq? frame frame1))
+ (begin (gen-save! output frame2 t0)
+ (cg-saveregs output regs2 frame2))
+ (cgframe-update-stale! frame2))
+ (cg0 output (if.else exp) r regs2 frame2 env tail?)
+ (if (not tail?)
+ (begin (gen! output $.label L2)
+ (cgreg-join! regs regs2)
+ (cgframe-join! frame1 frame2)))
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r)))))
+
+(define (cg-variable output exp target regs frame env tail?)
+ (define (return id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ (gen-store! output frame target id)
+ target)
+ 'result)))
+ ; Same as return, but doesn't emit a store instruction.
+ (define (return-nostore id)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (if (and target
+ (not (eq? 'result target)))
+ (begin (gen! output $setreg target)
+ (cgreg-bind! regs target id)
+ target)
+ 'result)))
+ (let* ((id (variable.name exp))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (gen! output $global id)
+ (return (newtemp)))
+ ((lexical)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry)))
+ (gen! output $lexical m n id)
+ (if (or (zero? m)
+ (negative? (cgframe-size frame)))
+ (return-nostore id)
+ (return id))))
+ ((procedure) (error "Bug in cg-variable" exp))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (if (or tail?
+ (and target (not (eqv? target r))))
+ (begin (gen! output $reg (entry.regnum entry) id)
+ (return-nostore id))
+ r)))
+ ((frame)
+ (cond ((eq? target 'result)
+ (gen-stack! output frame id)
+ (return id))
+ (target
+ ; Must be non-tail.
+ (gen-load! output frame target id)
+ (cgreg-bind! regs target id)
+ target)
+ (else
+ ; Must be non-tail.
+ (let ((r (choose-register regs frame)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ r))))
+ (else (error "Bug in cg-variable" exp)))))
+
+(define (cg-sequential output exp target regs frame env tail?)
+ (cg-sequential-loop output (begin.exprs exp) target regs frame env tail?))
+
+(define (cg-sequential-loop output exprs target regs frame env tail?)
+ (cond ((null? exprs)
+ (gen! output $const unspecified)
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ ((null? (cdr exprs))
+ (cg0 output (car exprs) target regs frame env tail?))
+ (else (cg0 output (car exprs) #f regs frame env #f)
+ (cg-sequential-loop output
+ (cdr exprs)
+ target regs frame env tail?))))
+
+(define (cg-saveregs output regs frame)
+ (do ((i 1 (+ i 1))
+ (vars (cdr (cgreg-vars regs)) (cdr vars)))
+ ((null? vars))
+ (let ((t (car vars)))
+ (if t
+ (gen-store! output frame i t)))))
+
+(define (cg-move output frame regs src dst)
+ (define (bind dst)
+ (let ((temp (newtemp)))
+ (cgreg-bind! regs dst temp)
+ (gen-store! output frame dst temp)
+ dst))
+ (cond ((not dst)
+ src)
+ ((eqv? src dst)
+ dst)
+ ((eq? dst 'result)
+ (gen! output $reg src)
+ dst)
+ ((eq? src 'result)
+ (gen! output $setreg dst)
+ (bind dst))
+ ((and (not (zero? src))
+ (not (zero? dst)))
+ (gen! output $movereg src dst)
+ (bind dst))
+ (else
+ (gen! output $reg src)
+ (gen! output $setreg dst)
+ (bind dst))))
+
+; On-the-fly register allocator.
+; Tries to allocate:
+; a hardware register that isn't being used
+; a hardware register whose contents have already been spilled
+; a software register that isn't being used, unless a stack
+; frame has already been created, in which case it is better to use
+; a hardware register that is in use and hasn't yet been spilled
+;
+; All else equal, it is better to allocate a higher-numbered register
+; because the lower-numbered registers are targets when arguments
+; are being evaluated.
+;
+; Invariant: Every register that is returned by this allocator
+; is either not in use or has been spilled.
+
+(define (choose-register regs frame)
+ (car (choose-registers regs frame 1)))
+
+(define (choose-registers regs frame n)
+
+ ; Find unused hardware registers.
+ (define (loop1 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (if (negative? (cgframe-size frame))
+ (hardcase)
+ (loop2 (- *nhwregs* 1) n good)))
+ (else
+ (if (cgreg-lookup-reg regs i)
+ (loop1 (- i 1) n good)
+ (loop1 (- i 1)
+ (- n 1)
+ (cons i good))))))
+
+ ; Find already spilled hardware registers.
+ (define (loop2 i n good)
+ (cond ((zero? n)
+ good)
+ ((zero? i)
+ (hardcase))
+ (else
+ (let ((t (cgreg-lookup-reg regs i)))
+ (if (and t (cgframe-spilled? frame t))
+ (loop2 (- i 1)
+ (- n 1)
+ (cons i good))
+ (loop2 (- i 1) n good))))))
+
+ ; This is ridiculous.
+ ; Fortunately the correctness of the compiler is independent
+ ; of the predicate used for this sort.
+
+ (define (hardcase)
+ (let* ((frame-exists? (not (negative? (cgframe-size frame))))
+ (stufftosort
+ (map (lambda (r)
+ (let* ((t (cgreg-lookup-reg regs r))
+ (spilled?
+ (and t
+ (cgframe-spilled? frame t))))
+ (list r t spilled?)))
+ (cdr (iota *nregs*))))
+ (registers
+ (twobit-sort
+ (lambda (x1 x2)
+ (let ((r1 (car x1))
+ (r2 (car x2))
+ (t1 (cadr x1))
+ (t2 (cadr x2)))
+ (cond ((< r1 *nhwregs*)
+ (cond ((not t1) #t)
+ ((< r2 *nhwregs*)
+ (cond ((not t2) #f)
+ ((caddr x1) #t)
+ ((caddr x2) #f)
+ (else #t)))
+ (frame-exists? #t)
+ (t2 #t)
+ (else #f)))
+ ((< r2 *nhwregs*)
+ (cond (frame-exists? #f)
+ (t1 #f)
+ (t2 #t)
+ (else #f)))
+ (t1
+ (if (and (caddr x1)
+ t2
+ (not (caddr x2)))
+ #t
+ #f))
+ (else #t))))
+ stufftosort)))
+ ; FIXME: What was this for?
+ '
+ (for-each (lambda (register)
+ (let ((t (cadr register))
+ (spilled? (caddr register)))
+ (if (and t (not spilled?))
+ (cgframe-touch! frame t))))
+ registers)
+ (do ((sorted (map car registers) (cdr sorted))
+ (rs '() (cons (car sorted) rs))
+ (n n (- n 1)))
+ ((zero? n)
+ (reverse rs)))))
+
+ (if (< n *nregs*)
+ (loop1 (- *nhwregs* 1) n '())
+ (error (string-append "Compiler bug: can't allocate "
+ (number->string n)
+ " registers on this target."))))
+; Copyright 1991 William Clinger
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 21 May 1999.
+
+; Procedure calls.
+
+(define (cg-call output exp target regs frame env tail?)
+ (let ((proc (call.proc exp)))
+ (cond ((and (lambda? proc)
+ (list? (lambda.args proc)))
+ (cg-let output exp target regs frame env tail?))
+ ((not (variable? proc))
+ (cg-unknown-call output exp target regs frame env tail?))
+ (else (let ((entry
+ (var-lookup (variable.name proc) regs frame env)))
+ (case (entry.kind entry)
+ ((global lexical frame register)
+ (cg-unknown-call output
+ exp
+ target regs frame env tail?))
+ ((integrable)
+ (cg-integrable-call output
+ exp
+ target regs frame env tail?))
+ ((procedure)
+ (cg-known-call output
+ exp
+ target regs frame env tail?))
+ (else (error "Bug in cg-call" exp))))))))
+
+(define (cg-unknown-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (if (variable? proc)
+ (let ((entry (cgreg-lookup regs (variable.name proc))))
+ (if (and entry
+ (<= (entry.regnum entry) n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1)))
+ (begin (cg-arguments output
+ (iota1 n)
+ args
+ regs frame env)
+ (cg0 output proc 'result regs frame env #f)))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n))
+ (begin (cg-arguments output
+ (iota1 (+ n 1))
+ (append args (list proc))
+ regs frame env)
+ (gen! output $reg (+ n 1))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (gen! output $invoke n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+(define (cg-known-call output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (n (length args))
+ (L (make-label)))
+ (cond ((>= (+ n 1) *lastreg*)
+ (cg-big-call output exp target regs frame env tail?))
+ (else
+ (let ((r0 (cgreg-lookup-reg regs 0)))
+ (cg-arguments output (iota1 n) args regs frame env)
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (let* ((entry (cgenv-lookup env (variable.name (call.proc exp))))
+ (label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs)
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target))))))))
+
+; Any call can be compiled as follows, even if there are no free registers.
+;
+; Let T0, T1, ..., Tn be newly allocated stack temporaries.
+;
+; <arg0>
+; setstk T0
+; <arg1> -|
+; setstk T1 |
+; ... |- evaluate args into stack frame
+; <argn> |
+; setstk Tn -|
+; const ()
+; setreg R-1
+; stack Tn -|
+; op2 cons,R-1 |
+; setreg R-1 |
+; ... |- cons up overflow args
+; stack T_{R-1} |
+; op2 cons,R-1 |
+; setreg R-1 -|
+; stack T_{R-2} -|
+; setreg R-2 |
+; ... |- pop remaining args into registers
+; stack T1 |
+; setreg 1 -|
+; stack T0
+; invoke n
+
+(define (cg-big-call output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (args (call.args exp))
+ (n (length args))
+ (argslots (newtemps n))
+ (procslot (newtemp))
+ (r0 (cgreg-lookup-reg regs 0))
+ (R-1 (- *nregs* 1))
+ (entry (if (variable? proc)
+ (let ((entry
+ (var-lookup (variable.name proc)
+ regs frame env)))
+ (if (eq? (entry.kind entry) 'procedure)
+ entry
+ #f))
+ #f))
+ (L (make-label)))
+ (if (not entry)
+ (begin
+ (cg0 output proc 'result regs frame env #f)
+ (gen-setstk! output frame procslot)))
+ (for-each (lambda (arg argslot)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame argslot))
+ args
+ argslots)
+ (cgreg-clear! regs)
+ (gen! output $const '())
+ (gen! output $setreg R-1)
+ (do ((i n (- i 1))
+ (slots (reverse argslots) (cdr slots)))
+ ((zero? i))
+ (if (< i R-1)
+ (gen-load! output frame i (car slots))
+ (begin (gen-stack! output frame (car slots))
+ (gen! output $op2 $cons R-1)
+ (gen! output $setreg R-1))))
+ (if (not entry)
+ (gen-stack! output frame procslot))
+ (if tail?
+ (gen-pop! output frame)
+ (begin (cgframe-used! frame)
+ (gen! output $setrtn L)))
+ (if entry
+ (let ((label (entry.label entry))
+ (m (entry.rib entry)))
+ (if (zero? m)
+ (gen! output $branch label n)
+ (gen! output $jump m label n)))
+ (gen! output $invoke n))
+ (if tail?
+ 'result
+ (begin (gen! output $.align 4)
+ (gen! output $.label L)
+ (gen! output $.cont)
+ (cgreg-clear! regs) ; redundant, see above
+ (cgreg-bind! regs 0 r0)
+ (gen-load! output frame 0 r0)
+ (cg-move output frame regs 'result target)))))
+
+(define (cg-integrable-call output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op1 (entry.op entry)))
+ ((2) (cg-integrable-call2 output
+ entry
+ args
+ regs frame env))
+ ((3) (cg-integrable-call3 output
+ entry
+ args
+ regs frame env))
+ (else (error "Bug detected by cg-integrable-call"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-integrable-call2 output entry args regs frame env)
+ (let ((op (entry.op entry)))
+ (if (and (entry.imm entry)
+ (constant? (cadr args))
+ ((entry.imm entry) (constant.value (cadr args))))
+ (begin (cg0 output (car args) 'result regs frame env #f)
+ (gen! output $op2imm
+ op
+ (constant.value (cadr args))))
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (choose-register regs frame)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2))))
+ (gen! output $op2 (entry.op entry) r2)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))))))
+ 'result)
+
+(define (cg-integrable-call3 output entry args regs frame env)
+ (let* ((reg2 (cg0 output (cadr args) #f regs frame env #f))
+ (r2 (choose-register regs frame))
+ (t2 (if (eq? reg2 'result)
+ (let ((t2 (newtemp)))
+ (gen! output $setreg r2)
+ (cgreg-bind! regs r2 t2)
+ (gen-store! output frame r2 t2)
+ t2)
+ (cgreg-lookup-reg regs reg2)))
+ (reg3 (cg0 output (caddr args) #f regs frame env #f))
+ (spillregs (choose-registers regs frame 2))
+ (t3 (if (eq? reg3 'result)
+ (let ((t3 (newtemp))
+ (r3 (if (eq? t2 (cgreg-lookup-reg
+ regs (car spillregs)))
+ (cadr spillregs)
+ (car spillregs))))
+ (gen! output $setreg r3)
+ (cgreg-bind! regs r3 t3)
+ (gen-store! output frame r3 t3)
+ t3)
+ (cgreg-lookup-reg regs reg3))))
+ (cg0 output (car args) 'result regs frame env #f)
+ (let* ((spillregs (choose-registers regs frame 2))
+ (r2 (or (let ((entry (cgreg-lookup regs t2)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r2 (car spillregs)))
+ (cgreg-bind! regs r2 t2)
+ (gen-load! output frame r2 t2)
+ r2)))
+ (r3 (or (let ((entry (cgreg-lookup regs t3)))
+ (if entry
+ (entry.regnum entry)
+ #f))
+ (let ((r3 (if (eq? r2 (car spillregs))
+ (cadr spillregs)
+ (car spillregs))))
+ (cgreg-bind! regs r3 t3)
+ (gen-load! output frame r3 t3)
+ r3))))
+ (gen! output $op3 (entry.op entry) r2 r3)
+ (if (eq? reg2 'result)
+ (begin (cgreg-release! regs r2)
+ (cgframe-release! frame t2)))
+ (if (eq? reg3 'result)
+ (begin (cgreg-release! regs r3)
+ (cgframe-release! frame t3)))))
+ 'result)
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+(define (cg-primop-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+
+
+; Parallel assignment.
+
+; Given a list of target registers, a list of expressions, and a
+; compile-time environment, generates code to evaluate the expressions
+; into the registers.
+;
+; Argument evaluation proceeds as follows:
+;
+; 1. Evaluate all but one of the complicated arguments.
+; 2. Evaluate remaining arguments.
+; 3. Load spilled arguments from stack.
+
+(define (cg-arguments output targets args regs frame env)
+
+ ; Sorts the args and their targets into complicated and
+ ; uncomplicated args and targets.
+ ; Then it calls evalargs.
+
+ (define (sortargs targets args targets1 args1 targets2 args2)
+ (if (null? args)
+ (evalargs targets1 args1 targets2 args2)
+ (let ((target (car targets))
+ (arg (car args))
+ (targets (cdr targets))
+ (args (cdr args)))
+ (if (complicated? arg env)
+ (sortargs targets
+ args
+ (cons target targets1)
+ (cons arg args1)
+ targets2
+ args2)
+ (sortargs targets
+ args
+ targets1
+ args1
+ (cons target targets2)
+ (cons arg args2))))))
+
+ ; Given the complicated args1 and their targets1,
+ ; and the uncomplicated args2 and their targets2,
+ ; evaluates all the arguments into their target registers.
+
+ (define (evalargs targets1 args1 targets2 args2)
+ (let* ((temps1 (newtemps (length targets1)))
+ (temps2 (newtemps (length targets2))))
+ (if (not (null? args1))
+ (for-each (lambda (arg temp)
+ (cg0 output arg 'result regs frame env #f)
+ (gen-setstk! output frame temp))
+ (cdr args1)
+ (cdr temps1)))
+ (if (not (null? args1))
+ (evalargs0 (cons (car targets1) targets2)
+ (cons (car args1) args2)
+ (cons (car temps1) temps2))
+ (evalargs0 targets2 args2 temps2))
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (let ((entry (var-lookup t regs frame env)))
+ (case (entry.kind entry)
+ ((register)
+ (gen! output $movereg (entry.regnum entry) r))
+ ((frame)
+ (gen-load! output frame r t)))
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ (append targets1 targets2)
+ (append temps1 temps2))))
+
+ (define (evalargs0 targets args temps)
+ (if (not (null? targets))
+ (let ((para (let* ((regvars (map (lambda (reg)
+ (cgreg-lookup-reg regs reg))
+ targets)))
+ (parallel-assignment targets
+ (map cons regvars targets)
+ args))))
+ (if para
+ (let ((targets para)
+ (args (cg-permute args targets para))
+ (temps (cg-permute temps targets para)))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ para
+ temps))
+ (let ((r (choose-register regs frame))
+ (t (car temps)))
+ (cg0 output (car args) r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (evalargs0 (cdr targets)
+ (cdr args)
+ (cdr temps)))))))
+
+ (if (parallel-assignment-optimization)
+ (sortargs (reverse targets) (reverse args) '() '() '() '())
+ (cg-evalargs output targets args regs frame env)))
+
+; Left-to-right evaluation of arguments directly into targets.
+
+(define (cg-evalargs output targets args regs frame env)
+ (let ((temps (newtemps (length targets))))
+ (for-each (lambda (arg r t)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t))
+ args
+ targets
+ temps)
+ (for-each (lambda (r t)
+ (let ((temp (cgreg-lookup-reg regs r)))
+ (if (not (eq? temp t))
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)))
+ (cgframe-release! frame t)))
+ targets
+ temps)))
+
+; For heuristic use only.
+; An expression is complicated unless it can probably be evaluated
+; without saving and restoring any registers, even if it occurs in
+; a non-tail position.
+
+(define (complicated? exp env)
+ (case (car exp)
+ ((quote) #f)
+ ((lambda) #t)
+ ((set!) (complicated? (assignment.rhs exp) env))
+ ((if) (or (complicated? (if.test exp) env)
+ (complicated? (if.then exp) env)
+ (complicated? (if.else exp) env)))
+ ((begin) (if (variable? exp)
+ #f
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (begin.exprs exp))))
+ (else (let ((proc (call.proc exp)))
+ (if (and (variable? proc)
+ (let ((entry
+ (cgenv-lookup env (variable.name proc))))
+ (eq? (entry.kind entry) 'integrable)))
+ (some? (lambda (exp)
+ (complicated? exp env))
+ (call.args exp))
+ #t)))))
+
+; Returns a permutation of the src list, permuted the same way the
+; key list was permuted to obtain newkey.
+
+(define (cg-permute src key newkey)
+ (let ((alist (map cons key (iota (length key)))))
+ (do ((newkey newkey (cdr newkey))
+ (dest '()
+ (cons (list-ref src (cdr (assq (car newkey) alist)))
+ dest)))
+ ((null? newkey) (reverse dest)))))
+
+; Given a list of register numbers,
+; an association list with entries of the form (name . regnum) giving
+; the variable names by which those registers are known in code,
+; and a list of expressions giving new values for those registers,
+; returns an ordering of the register assignments that implements a
+; parallel assignment if one can be found, otherwise returns #f.
+
+(define parallel-assignment
+ (lambda (regnums alist exps)
+ (if (null? regnums)
+ #t
+ (let ((x (toposort (dependency-graph regnums alist exps))))
+ (if x (reverse x) #f)))))
+
+(define dependency-graph
+ (lambda (regnums alist exps)
+ (let ((names (map car alist)))
+ (do ((regnums regnums (cdr regnums))
+ (exps exps (cdr exps))
+ (l '() (cons (cons (car regnums)
+ (map (lambda (var) (cdr (assq var alist)))
+ (intersection (freevariables (car exps))
+ names)))
+ l)))
+ ((null? regnums) l)))))
+
+; Given a nonempty graph represented as a list of the form
+; ((node1 . <list of nodes that node1 is less than or equal to>)
+; (node2 . <list of nodes that node2 is less than or equal to>)
+; ...)
+; returns a topological sort of the nodes if one can be found,
+; otherwise returns #f.
+
+(define toposort
+ (lambda (graph)
+ (cond ((null? (cdr graph)) (list (caar graph)))
+ (else (toposort2 graph '())))))
+
+(define toposort2
+ (lambda (totry tried)
+ (cond ((null? totry) #f)
+ ((or (null? (cdr (car totry)))
+ (and (null? (cddr (car totry)))
+ (eq? (cadr (car totry))
+ (car (car totry)))))
+ (if (and (null? (cdr totry)) (null? tried))
+ (list (caar totry))
+ (let* ((node (caar totry))
+ (x (toposort2 (map (lambda (y)
+ (cons (car y) (remove node (cdr y))))
+ (append (cdr totry) tried))
+ '())))
+ (if x
+ (cons node x)
+ #f))))
+ (else (toposort2 (cdr totry) (cons (car totry) tried))))))
+
+(define iota (lambda (n) (iota2 n '())))
+
+(define iota1 (lambda (n) (cdr (iota2 (+ n 1) '()))))
+
+(define iota2
+ (lambda (n l)
+ (if (zero? n)
+ l
+ (let ((n (- n 1)))
+ (iota2 n (cons n l))))))
+
+(define (freevariables exp)
+ (freevars2 exp '()))
+
+(define (freevars2 exp env)
+ (cond ((symbol? exp)
+ (if (memq exp env) '() (list exp)))
+ ((not (pair? exp)) '())
+ (else (let ((keyword (car exp)))
+ (cond ((eq? keyword 'quote) '())
+ ((eq? keyword 'lambda)
+ (let ((env (append (make-null-terminated (cadr exp))
+ env)))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cddr exp)))))
+ ((memq keyword '(if set! begin))
+ (apply-union
+ (map (lambda (x) (freevars2 x env))
+ (cdr exp))))
+ (else (apply-union
+ (map (lambda (x) (freevars2 x env))
+ exp))))))))
+; Copyright 1991 William Clinger (cg-let and cg-let-body)
+; Copyright 1999 William Clinger (everything else)
+;
+; 10 June 1999.
+
+; Generates code for a let expression.
+
+(define (cg-let output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (vars (lambda.args proc))
+ (n (length vars))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame)))
+ (if (and (null? (lambda.defs proc))
+ (= n 1))
+ (cg-let1 output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (temps (newtemps n))
+ (alist (map cons temps vars)))
+ (for-each (lambda (arg t)
+ (let ((r (choose-register regs frame)))
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)))
+ args
+ temps)
+ (cgreg-rename! regs alist)
+ (cgframe-rename! frame alist)
+ (cg-let-release! free live regs frame tail?)
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given the free variables of a let body, and the variables that are
+; live after the let expression, and the usual regs, frame, and tail?
+; arguments, releases any registers and frame slots that don't need
+; to be preserved across the body of the let.
+
+(define (cg-let-release! free live regs frame tail?)
+ ; The tail case is easy because there are no live temporaries,
+ ; and there are no free variables in the context.
+ ; The non-tail case assumes A-normal form.
+ (cond (tail?
+ (let ((keepers (cons (cgreg-lookup-reg regs 0) free)))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))
+ (live
+ (let ((keepers (cons (cgreg-lookup-reg regs 0)
+ (union live free))))
+ (cgreg-release-except! regs keepers)
+ (cgframe-release-except! frame keepers)))))
+
+; Generates code for the body of a let.
+
+(define (cg-let-body output L target regs frame env tail?)
+ (let ((vars (lambda.args L))
+ (free (lambda.F L))
+ (live (cgframe-livevars frame)))
+ (let ((r (cg-body output L target regs frame env tail?)))
+ (for-each (lambda (v)
+ (let ((entry (cgreg-lookup regs v)))
+ (if entry
+ (cgreg-release! regs (entry.regnum entry)))
+ (cgframe-release! frame v)))
+ vars)
+ (if (and (not target)
+ (not (eq? r 'result))
+ (not (cgreg-lookup-reg regs r)))
+ (cg-move output frame regs r 'result)
+ r))))
+
+; Generates code for a let expression that binds exactly one variable
+; and has no internal definitions. These let expressions are very
+; common in A-normal form, and there are many special cases with
+; respect to register allocation and order of evaluation.
+
+(define (cg-let1 output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (arg (car (call.args exp)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc)))
+
+ (define (evaluate-into-register r)
+ (cg0 output arg r regs frame env #f)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ (define (finish)
+ (release-registers!)
+ (cg-let-body output proc target regs frame env tail?))
+
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+
+ (cond ((assq v *regnames*)
+ (evaluate-into-register (cdr (assq v *regnames*)))
+ (finish))
+ ((not (memq v free))
+ (cg0 output arg #f regs frame env #f)
+ (finish))
+ (live
+ (cg0 output arg 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output exp target regs frame env tail?))
+ (else
+ (evaluate-into-register (choose-register regs frame))
+ (finish)))))
+
+; Given a let expression that binds one variable whose value has already
+; been evaluated into the result register, generates code for the rest
+; of the let expression.
+; The main difficulty is an unfortunate interaction between A-normal
+; form and the MacScheme machine architecture: We don't want to move
+; a value from the result register into a general register if it has
+; only one use and can remain in the result register until that use.
+
+(define (cg-let1-result output exp target regs frame env tail?)
+ (let* ((proc (call.proc exp))
+ (v (car (lambda.args proc)))
+ (free (lambda.F proc))
+ (live (cgframe-livevars frame))
+ (body (lambda.body proc))
+ (pattern (cg-let-used-once v body)))
+
+ (define (move-to-register r)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r v)
+ (gen-store! output frame r v)
+ r)
+
+ (define (release-registers!)
+ (cgframe-livevars-set! frame live)
+ (cg-let-release! free live regs frame tail?))
+
+ ; FIXME: The live variables must be correct in the frame.
+
+ (case pattern
+ ((if)
+ (cg-if-result output body target regs frame env tail?))
+ ((let-if)
+ (if live
+ (cgframe-livevars-set! frame (union live free)))
+ (cg-if-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (release-registers!)
+ (cg-let1-result output body target regs frame env tail?))
+ ((set!)
+ (cg-assignment-result output
+ body target regs frame env tail?))
+ ((let-set!)
+ (cg-assignment-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ((primop)
+ (cg-primop-result output body target regs frame env tail?))
+ ((let-primop)
+ (cg-primop-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ ; FIXME
+ ((_called)
+ (cg-call-result output body target regs frame env tail?))
+ ; FIXME
+ ((_let-called)
+ (cg-call-result output
+ (car (call.args body))
+ 'result regs frame env #f)
+ (cg-let1-result output body target regs frame env tail?))
+ (else
+ ; FIXME: The first case was handled by cg-let1.
+ (cond ((assq v *regnames*)
+ (move-to-register (cdr (assq v *regnames*))))
+ ((memq v free)
+ (move-to-register (choose-register regs frame))))
+ (cg-let-body output proc target regs frame env tail?)))))
+
+; Given a call to a primop whose first argument has already been
+; evaluated into the result register and whose remaining arguments
+; consist of constants and variable references, generates code for
+; the call.
+
+(define (cg-primop-result output exp target regs frame env tail?)
+ (let ((args (call.args exp))
+ (entry (var-lookup (variable.name (call.proc exp)) regs frame env)))
+ (if (= (entry.arity entry) (length args))
+ (begin (case (entry.arity entry)
+ ((0) (gen! output $op1 (entry.op entry)))
+ ((1) (gen! output $op1 (entry.op entry)))
+ ((2) (cg-primop2-result! output entry args regs frame env))
+ ((3) (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output
+ $op3 (entry.op entry) (car rs) (cadr rs))))
+ (else (error "Bug detected by cg-primop-result"
+ (make-readable exp))))
+ (if tail?
+ (begin (gen-pop! output frame)
+ (gen! output $return)
+ 'result)
+ (cg-move output frame regs 'result target)))
+ (if (negative? (entry.arity entry))
+ (cg-special-result output exp target regs frame env tail?)
+ (error "Wrong number of arguments to integrable procedure"
+ (make-readable exp))))))
+
+(define (cg-primop2-result! output entry args regs frame env)
+ (let ((op (entry.op entry))
+ (arg2 (cadr args)))
+ (if (and (constant? arg2)
+ (entry.imm entry)
+ ((entry.imm entry) (constant.value arg2)))
+ (gen! output $op2imm op (constant.value arg2))
+ (let ((rs (cg-result-args output args regs frame env)))
+ (gen! output $op2 op (car rs))))))
+
+; Given a short list of constants and variable references to be evaluated
+; into arbitrary general registers, evaluates them into registers without
+; disturbing the result register and returns a list of the registers into
+; which they are evaluated. Before returning, any registers that were
+; allocated by this routine are released.
+
+(define (cg-result-args output args regs frame env)
+
+ ; Given a list of unevaluated arguments,
+ ; a longer list of disjoint general registers,
+ ; the register that holds the first evaluated argument,
+ ; a list of registers in reverse order that hold other arguments,
+ ; and a list of registers to be released afterwards,
+ ; generates code to evaluate the arguments,
+ ; deallocates any registers that were evaluated to hold the arguments,
+ ; and returns the list of registers that contain the arguments.
+
+ (define (loop args registers rr rs temps)
+ (if (null? args)
+ (begin (if (not (eq? rr 'result))
+ (gen! output $reg rr))
+ (for-each (lambda (r) (cgreg-release! regs r))
+ temps)
+ (reverse rs))
+ (let ((arg (car args)))
+ (cond ((constant? arg)
+ (let ((r (car registers)))
+ (gen! output $const/setreg (constant.value arg) r)
+ (cgreg-bind! regs r #t)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ ((variable? arg)
+ (let* ((id (variable.name arg))
+ (entry (var-lookup id regs frame env)))
+ (case (entry.kind entry)
+ ((global integrable)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $global id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((lexical)
+ (if (eq? rr 'result)
+ (save-result! args registers rr rs temps)
+ (let ((m (entry.rib entry))
+ (n (entry.offset entry))
+ (r (car registers)))
+ (gen! output $lexical m n id)
+ (gen! output $setreg r)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps)))))
+ ((procedure) (error "Bug in cg-variable" arg))
+ ((register)
+ (let ((r (entry.regnum entry)))
+ (loop (cdr args)
+ registers
+ rr
+ (cons r rs)
+ temps)))
+ ((frame)
+ (let ((r (car registers)))
+ (gen-load! output frame r id)
+ (cgreg-bind! regs r id)
+ (loop (cdr args)
+ (cdr registers)
+ rr
+ (cons r rs)
+ (cons r temps))))
+ (else (error "Bug in cg-result-args" arg)))))
+ (else
+ (error "Bug in cg-result-args"))))))
+
+ (define (save-result! args registers rr rs temps)
+ (let ((r (car registers)))
+ (gen! output $setreg r)
+ (loop args
+ (cdr registers)
+ r
+ rs
+ temps)))
+
+ (loop (cdr args)
+ (choose-registers regs frame (length args))
+ 'result '() '()))
+
+; Given a local variable T1 and an expression in A-normal form,
+; cg-let-used-once returns a symbol if the local variable is used
+; exactly once in the expression and the expression matches one of
+; the patterns below. Otherwise returns #f. The symbol that is
+; returned is the name of the pattern that is matched.
+;
+; pattern symbol returned
+;
+; (if T1 ... ...) if
+;
+; (<primop> T1 ...) primop
+;
+; (T1 ...) called
+;
+; (set! ... T1) set!
+;
+; (let ((T2 (if T1 ... ...))) let-if
+; E3)
+;
+; (let ((T2 (<primop> T1 ...))) let-primop
+; E3)
+;
+; (let ((T2 (T1 ...))) let-called
+; E3)
+;
+; (let ((T2 (set! ... T1))) let-set!
+; E3)
+;
+; This implementation sometimes returns #f incorrectly, but it always
+; returns an answer in constant time (assuming A-normal form).
+
+(define (cg-let-used-once T1 exp)
+ (define budget 20)
+ (define (cg-let-used-once T1 exp)
+ (define (used? T1 exp)
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #t)
+ ((constant? exp) #f)
+ ((variable? exp)
+ (eq? T1 (variable.name exp)))
+ ((lambda? exp)
+ (memq T1 (lambda.F exp)))
+ ((assignment? exp)
+ (used? T1 (assignment.rhs exp)))
+ ((call? exp)
+ (or (used? T1 (call.proc exp))
+ (used-in-args? T1 (call.args exp))))
+ ((conditional? exp)
+ (or (used? T1 (if.test exp))
+ (used? T1 (if.then exp))
+ (used? T1 (if.else exp))))
+ (else #t)))
+ (define (used-in-args? T1 args)
+ (if (null? args)
+ #f
+ (or (used? T1 (car args))
+ (used-in-args? T1 (cdr args)))))
+ (set! budget (- budget 1))
+ (cond ((negative? budget) #f)
+ ((call? exp)
+ (let ((proc (call.proc exp))
+ (args (call.args exp)))
+ (cond ((variable? proc)
+ (let ((f (variable.name proc)))
+ (cond ((eq? f T1)
+ (and (not (used-in-args? T1 args))
+ 'called))
+ ((and (integrable? f)
+ (not (null? args))
+ (variable? (car args))
+ (eq? T1 (variable.name (car args))))
+ (and (not (used-in-args? T1 (cdr args)))
+ 'primop))
+ (else #f))))
+ ((lambda? proc)
+ (and (not (memq T1 (lambda.F proc)))
+ (not (null? args))
+ (null? (cdr args))
+ (case (cg-let-used-once T1 (car args))
+ ((if) 'let-if)
+ ((primop) 'let-primop)
+ ((called) 'let-called)
+ ((set!) 'let-set!)
+ (else #f))))
+ (else #f))))
+ ((conditional? exp)
+ (let ((E0 (if.test exp)))
+ (and (variable? E0)
+ (eq? T1 (variable.name E0))
+ (not (used? T1 (if.then exp)))
+ (not (used? T1 (if.else exp)))
+ 'if)))
+ ((assignment? exp)
+ (let ((rhs (assignment.rhs exp)))
+ (and (variable? rhs)
+ (eq? T1 (variable.name rhs))
+ 'set!)))
+ (else #f)))
+ (cg-let-used-once T1 exp))
+
+; Given the name of a let-body pattern, an expression that matches that
+; pattern, and an expression to be substituted for the let variable,
+; returns the transformed expression.
+
+; FIXME: No longer used.
+
+(define (cg-let-transform pattern exp E1)
+ (case pattern
+ ((if)
+ (make-conditional E1 (if.then exp) (if.else exp)))
+ ((primop)
+ (make-call (call.proc exp)
+ (cons E1 (cdr (call.args exp)))))
+ ((called)
+ (make-call E1 (call.args exp)))
+ ((set!)
+ (make-assignment (assignment.lhs exp) E1))
+ ((let-if let-primop let-called let-set!)
+ (make-call (call.proc exp)
+ (list (cg-let-transform (case pattern
+ ((let-if) 'if)
+ ((let-primop) 'primop)
+ ((let-called) 'called)
+ ((let-set!) 'set!))
+ (car (call.args exp))
+ E1))))
+ (else
+ (error "Unrecognized pattern in cg-let-transform" pattern)))); Copyright 1999 William Clinger
+;
+; Code for special primitives, used to generate runtime safety checks,
+; efficient code for call-with-values, and other weird things.
+;
+; 4 June 1999.
+
+(define (cg-special output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-special-result output exp target regs frame env tail?)
+ (let ((name (variable.name (call.proc exp))))
+ (cond ((eq? name name:CHECK!)
+ (if (runtime-safety-checking)
+ (cg-check-result output exp target regs frame env tail?)))
+ (else
+ (error "Compiler bug: cg-special" (make-readable exp))))))
+
+(define (cg-check output exp target regs frame env tail?)
+ (cg0 output (car (call.args exp)) 'result regs frame env #f)
+ (cg-check-result output exp target regs frame env tail?))
+
+(define (cg-check-result output exp target regs frame env tail?)
+ (let* ((args (call.args exp))
+ (nargs (length args))
+ (valexps (cddr args)))
+ (if (and (<= 2 nargs 5)
+ (constant? (cadr args))
+ (every? (lambda (exp)
+ (or (constant? exp)
+ (variable? exp)))
+ valexps))
+ (let* ((exn (constant.value (cadr args)))
+ (vars (filter variable? valexps))
+ (rs (cg-result-args output
+ (cons (car args) vars)
+ regs frame env)))
+
+ ; Construct the trap situation:
+ ; the exception number followed by an ordered list of
+ ; register numbers and constant expressions.
+
+ (let loop ((registers rs)
+ (exps valexps)
+ (operands '()))
+ (cond ((null? exps)
+ (let* ((situation (cons exn (reverse operands)))
+ (ht (assembly-stream-info output))
+ (L1 (or (hashtable-get ht situation)
+ (let ((L1 (make-label)))
+ (hashtable-put! ht situation L1)
+ L1))))
+ (define (translate r)
+ (if (number? r) r 0))
+ (case (length operands)
+ ((0) (gen! output $check 0 0 0 L1))
+ ((1) (gen! output $check
+ (translate (car operands))
+ 0 0 L1))
+ ((2) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ 0 L1))
+ ((3) (gen! output $check
+ (translate (car operands))
+ (translate (cadr operands))
+ (translate (caddr operands))
+ L1)))))
+ ((constant? (car exps))
+ (loop registers
+ (cdr exps)
+ (cons (car exps) operands)))
+ (else
+ (loop (cdr registers)
+ (cdr exps)
+ (cons (car registers) operands))))))
+ (error "Compiler bug: runtime check" (make-readable exp)))))
+
+; Given an assembly stream and the description of a trap as recorded
+; by cg-check above, generates a non-continuable trap at that label for
+; that trap, passing the operands to the exception handler.
+
+(define (cg-trap output situation L1)
+ (let* ((exn (car situation))
+ (operands (cdr situation)))
+ (gen! output $.label L1)
+ (let ((liveregs (filter number? operands)))
+ (define (loop operands registers r)
+ (cond ((null? operands)
+ (case (length registers)
+ ((0) (gen! output $trap 0 0 0 exn))
+ ((1) (gen! output $trap (car registers) 0 0 exn))
+ ((2) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ 0
+ exn))
+ ((3) (gen! output $trap
+ (car registers)
+ (cadr registers)
+ (caddr registers)
+ exn))
+ (else "Compiler bug: trap")))
+ ((number? (car operands))
+ (loop (cdr operands)
+ (cons (car operands) registers)
+ r))
+ ((memv r liveregs)
+ (loop operands registers (+ r 1)))
+ (else
+ (gen! output $const (constant.value (car operands)))
+ (gen! output $setreg r)
+ (loop (cdr operands)
+ (cons r registers)
+ (+ r 1)))))
+ (loop (reverse operands) '() 1))))
+
+; Given a short list of expressions that can be evaluated in any order,
+; evaluates the first into the result register and the others into any
+; register, and returns an ordered list of the registers that contain
+; the arguments that follow the first.
+; The number of expressions must be less than the number of argument
+; registers.
+
+; FIXME: No longer used.
+
+(define (cg-check-args output args regs frame env)
+
+ ; Given a list of expressions to evaluate, a list of variables
+ ; and temporary names for arguments that have already been
+ ; evaluated, in reverse order, and a mask of booleans that
+ ; indicate which temporaries should be released before returning,
+ ; returns the correct result.
+
+ (define (eval-loop args temps mask)
+ (if (null? args)
+ (eval-first-into-result temps mask)
+ (let ((reg (cg0 output (car args) #f regs frame env #f)))
+ (if (eq? reg 'result)
+ (let* ((r (choose-register regs frame))
+ (t (newtemp)))
+ (gen! output $setreg r)
+ (cgreg-bind! regs r t)
+ (gen-store! output frame r t)
+ (eval-loop (cdr args)
+ (cons t temps)
+ (cons #t mask)))
+ (eval-loop (cdr args)
+ (cons (cgreg-lookup-reg regs reg) temps)
+ (cons #f mask))))))
+
+ (define (eval-first-into-result temps mask)
+ (cg0 output (car args) 'result regs frame env #f)
+ (finish-loop (choose-registers regs frame (length temps))
+ temps
+ mask
+ '()))
+
+ ; Given a sufficient number of disjoint registers, a list of
+ ; variable and temporary names that may need to be loaded into
+ ; registers, a mask of booleans that indicates which temporaries
+ ; should be released, and a list of registers in forward order,
+ ; returns the correct result.
+
+ (define (finish-loop disjoint temps mask registers)
+ (if (null? temps)
+ registers
+ (let* ((t (car temps))
+ (entry (cgreg-lookup regs t)))
+ (if entry
+ (let ((r (entry.regnum entry)))
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))
+ (let ((r (car disjoint)))
+ (if (memv r registers)
+ (finish-loop (cdr disjoint) temps mask registers)
+ (begin (gen-load! output frame r t)
+ (cgreg-bind! regs r t)
+ (if (car mask)
+ (begin (cgreg-release! regs r)
+ (cgframe-release! frame t)))
+ (finish-loop disjoint
+ (cdr temps)
+ (cdr mask)
+ (cons r registers)))))))))
+
+ (if (< (length args) *nregs*)
+ (eval-loop (cdr args) '() '())
+ (error "Bug detected by cg-primop-args" args)))
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 5 June 1999.
+;
+; Local optimizations for MacScheme machine assembly code.
+;
+; Branch tensioning.
+; Suppress nop instructions.
+; Suppress save, restore, and pop instructions whose operand is -1.
+; Suppress redundant stores.
+; Suppress definitions (primarily loads) of dead registers.
+;
+; Note: Twobit never generates a locally redundant load or store,
+; so this code must be tested with a different code generator.
+;
+; To perform these optimizations, the basic block must be traversed
+; both forwards and backwards.
+; The forward traversal keeps track of registers that were defined
+; by a load.
+; The backward traversal keeps track of live registers.
+
+(define filter-basic-blocks
+
+ (let* ((suppression-message
+ "Local optimization detected a useless instruction.")
+
+ ; Each instruction is mapping to an encoding of the actions
+ ; to be performed when it is encountered during the forward
+ ; or backward traversal.
+
+ (forward:normal 0)
+ (forward:nop 1)
+ (forward:ends-block 2)
+ (forward:interesting 3)
+ (forward:kills-all-registers 4)
+ (forward:nop-if-arg1-is-negative 5)
+
+ (backward:normal 0)
+ (backward:ends-block 1)
+ (backward:begins-block 2)
+ (backward:uses-arg1 4)
+ (backward:uses-arg2 8)
+ (backward:uses-arg3 16)
+ (backward:kills-arg1 32)
+ (backward:kills-arg2 64)
+ (backward:uses-many 128)
+
+ ; largest mnemonic + 1
+
+ (dispatch-table-size *number-of-mnemonics*)
+
+ ; Dispatch table for the forwards traversal.
+
+ (forward-table (make-bytevector dispatch-table-size))
+
+ ; Dispatch table for the backwards traversal.
+
+ (backward-table (make-bytevector dispatch-table-size)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i dispatch-table-size))
+ (bytevector-set! forward-table i forward:normal)
+ (bytevector-set! backward-table i backward:normal))
+
+ (bytevector-set! forward-table $nop forward:nop)
+
+ (bytevector-set! forward-table $invoke forward:ends-block)
+ (bytevector-set! forward-table $return forward:ends-block)
+ (bytevector-set! forward-table $skip forward:ends-block)
+ (bytevector-set! forward-table $branch forward:ends-block)
+ (bytevector-set! forward-table $branchf forward:ends-block)
+ (bytevector-set! forward-table $jump forward:ends-block)
+ (bytevector-set! forward-table $.align forward:ends-block)
+ (bytevector-set! forward-table $.proc forward:ends-block)
+ (bytevector-set! forward-table $.cont forward:ends-block)
+ (bytevector-set! forward-table $.label forward:ends-block)
+
+ (bytevector-set! forward-table $store forward:interesting)
+ (bytevector-set! forward-table $load forward:interesting)
+ (bytevector-set! forward-table $setstk forward:interesting)
+ (bytevector-set! forward-table $setreg forward:interesting)
+ (bytevector-set! forward-table $movereg forward:interesting)
+ (bytevector-set! forward-table $const/setreg
+ forward:interesting)
+
+ (bytevector-set! forward-table $args>= forward:kills-all-registers)
+ (bytevector-set! forward-table $popstk forward:kills-all-registers)
+
+ ; These instructions also kill all registers.
+
+ (bytevector-set! forward-table $save forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $restore forward:nop-if-arg1-is-negative)
+ (bytevector-set! forward-table $pop forward:nop-if-arg1-is-negative)
+
+ (bytevector-set! backward-table $invoke backward:ends-block)
+ (bytevector-set! backward-table $return backward:ends-block)
+ (bytevector-set! backward-table $skip backward:ends-block)
+ (bytevector-set! backward-table $branch backward:ends-block)
+ (bytevector-set! backward-table $branchf backward:ends-block)
+
+ (bytevector-set! backward-table $jump backward:begins-block) ; [sic]
+ (bytevector-set! backward-table $.align backward:begins-block)
+ (bytevector-set! backward-table $.proc backward:begins-block)
+ (bytevector-set! backward-table $.cont backward:begins-block)
+ (bytevector-set! backward-table $.label backward:begins-block)
+
+ (bytevector-set! backward-table $op2 backward:uses-arg2)
+ (bytevector-set! backward-table $op3 (logior backward:uses-arg2
+ backward:uses-arg3))
+ (bytevector-set! backward-table $check (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $trap (logior
+ backward:uses-arg1
+ (logior backward:uses-arg2
+ backward:uses-arg3)))
+ (bytevector-set! backward-table $store backward:uses-arg1)
+ (bytevector-set! backward-table $reg backward:uses-arg1)
+ (bytevector-set! backward-table $load backward:kills-arg1)
+ (bytevector-set! backward-table $setreg backward:kills-arg1)
+ (bytevector-set! backward-table $movereg (logior backward:uses-arg1
+ backward:kills-arg2))
+ (bytevector-set! backward-table $const/setreg
+ backward:kills-arg2)
+ (bytevector-set! backward-table $lambda backward:uses-many)
+ (bytevector-set! backward-table $lexes backward:uses-many)
+ (bytevector-set! backward-table $args>= backward:uses-many)
+
+ (lambda (instructions)
+
+ (let* ((*nregs* *nregs*) ; locals might be faster than globals
+
+ ; During the forwards traversal:
+ ; (vector-ref registers i) = #f
+ ; means the content of register i is unknown
+ ; (vector-ref registers i) = j
+ ; means register was defined by load i,j
+ ;
+ ; During the backwards traversal:
+ ; (vector-ref registers i) = #f means register i is dead
+ ; (vector-ref registers i) = #t means register i is live
+
+ (registers (make-vector *nregs* #f))
+
+ ; During the forwards traversal, the label of a block that
+ ; falls through into another block or consists of a skip
+ ; to another block is mapped to another label.
+ ; This mapping is implemented by a hash table.
+ ; Before the backwards traversal, the transitive closure
+ ; is computed. The graph has no cycles, and the maximum
+ ; out-degree is 1, so this is easy.
+
+ (label-table (make-hashtable (lambda (n) n) assv)))
+
+ (define (compute-transitive-closure!)
+ (define (lookup x)
+ (let ((y (hashtable-get label-table x)))
+ (if y
+ (lookup y)
+ x)))
+ (hashtable-for-each (lambda (x y)
+ (hashtable-put! label-table x (lookup y)))
+ label-table))
+
+ ; Don't use this procedure until the preceding procedure
+ ; has been called.
+
+ (define (lookup-label x)
+ (hashtable-fetch label-table x x))
+
+ (define (vector-fill! v x)
+ (subvector-fill! v 0 (vector-length v) x))
+
+ (define (subvector-fill! v i j x)
+ (if (< i j)
+ (begin (vector-set! v i x)
+ (subvector-fill! v (+ i 1) j x))))
+
+ (define (kill-stack! j)
+ (do ((i 0 (+ i 1)))
+ ((= i *nregs*))
+ (let ((x (vector-ref registers i)))
+ (if (and x (= x j))
+ (vector-set! registers i #f)))))
+
+ ; Dispatch procedure for the forwards traversal.
+
+ (define (forwards instructions filtered)
+ (if (null? instructions)
+ (begin (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (compute-transitive-closure!)
+ (backwards0 filtered '()))
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:normal)
+ (forwards instructions (cons instruction filtered)))
+ ((eqv? flags forward:nop)
+ (forwards instructions filtered))
+ ((eqv? flags forward:nop-if-arg1-is-negative)
+ (if (negative? (instruction.arg1 instruction))
+ (forwards instructions filtered)
+ (begin (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))))
+ ((eqv? flags forward:kills-all-registers)
+ (vector-fill! registers #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? flags forward:ends-block)
+ (vector-fill! registers #f)
+ (if (eqv? op $.label)
+ (forwards-label instruction
+ instructions
+ filtered)
+ (forwards instructions
+ (cons instruction filtered))))
+ ((eqv? flags forward:interesting)
+ (cond ((eqv? op $setreg)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $const/setreg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $movereg)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f)
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $setstk)
+ (kill-stack! (instruction.arg1 instruction))
+ (forwards instructions
+ (cons instruction filtered)))
+ ((eqv? op $load)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant load.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (vector-set! registers i j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ ((eqv? op $store)
+ (let ((i (instruction.arg1 instruction))
+ (j (instruction.arg2 instruction)))
+ (if (eqv? (vector-ref registers i) j)
+ ; Suppress redundant store.
+ ; Should never happen with Twobit.
+ (suppress-forwards instruction
+ instructions
+ filtered)
+ (begin (kill-stack! j)
+ (forwards instructions
+ (cons instruction
+ filtered))))))
+ (else
+ (local-optimization-error op))))
+ (else
+ (local-optimization-error op))))))
+
+ ; Enters labels into a table for branch tensioning.
+
+ (define (forwards-label instruction1 instructions filtered)
+ (let ((label1 (instruction.arg1 instruction1)))
+ (if (null? instructions)
+ ; This is ok provided the label is unreachable.
+ (forwards instructions (cdr filtered))
+ (let loop ((instructions instructions)
+ (filtered (cons instruction1 filtered)))
+ (let* ((instruction (car instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref forward-table op)))
+ (cond ((eqv? flags forward:nop)
+ (loop (cdr instructions) filtered))
+ ((and (eqv? flags forward:nop-if-arg1-is-negative)
+ (negative? (instruction.arg1 instruction)))
+ (loop (cdr instructions) filtered))
+ ((eqv? op $.label)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ (forwards-label instruction
+ (cdr instructions)
+ (cdr filtered))))
+ ((eqv? op $skip)
+ (let ((label2 (instruction.arg1 instruction)))
+ (hashtable-put! label-table label1 label2)
+ ; We can't get rid of the skip instruction
+ ; because control might fall into this block,
+ ; but we can get rid of the label.
+ (forwards instructions (cdr filtered))))
+ (else
+ (forwards instructions filtered))))))))
+
+ ; Dispatch procedure for the backwards traversal.
+
+ (define (backwards instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (instructions (cdr instructions))
+ (op (instruction.op instruction))
+ (flags (bytevector-ref backward-table op)))
+ (cond ((eqv? flags backward:normal)
+ (backwards instructions (cons instruction filtered)))
+ ((eqv? flags backward:ends-block)
+ (backwards0 (cons instruction instructions)
+ filtered))
+ ((eqv? flags backward:begins-block)
+ (backwards0 instructions
+ (cons instruction filtered)))
+ ((eqv? flags backward:uses-many)
+ (cond ((or (eqv? op $lambda)
+ (eqv? op $lexes))
+ (let ((live
+ (if (eqv? op $lexes)
+ (instruction.arg1 instruction)
+ (instruction.arg2 instruction))))
+ (subvector-fill! registers
+ 0
+ (min *nregs* (+ 1 live))
+ #t)
+ (backwards instructions
+ (cons instruction filtered))))
+ ((eqv? op $args>=)
+ (vector-fill! registers #t)
+ (backwards instructions
+ (cons instruction filtered)))
+ (else
+ (local-optimization-error op))))
+ ((and (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (not (vector-ref registers
+ (instruction.arg1 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (not (vector-ref registers
+ (instruction.arg2 instruction))))
+ ; Suppress initialization of dead register.
+ (suppress-backwards instruction
+ instructions
+ filtered))
+ ((and (eqv? op $movereg)
+ (= (instruction.arg1 instruction)
+ (instruction.arg2 instruction)))
+ (backwards instructions filtered))
+ (else
+ (let ((filtered (cons instruction filtered)))
+ (if (eqv? (logand flags backward:kills-arg1)
+ backward:kills-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #f))
+ (if (eqv? (logand flags backward:kills-arg2)
+ backward:kills-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #f))
+ (if (eqv? (logand flags backward:uses-arg1)
+ backward:uses-arg1)
+ (vector-set! registers
+ (instruction.arg1 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg2)
+ backward:uses-arg2)
+ (vector-set! registers
+ (instruction.arg2 instruction)
+ #t))
+ (if (eqv? (logand flags backward:uses-arg3)
+ backward:uses-arg3)
+ (vector-set! registers
+ (instruction.arg3 instruction)
+ #t))
+ (backwards instructions filtered)))))))
+
+ ; Given a list of instructions in reverse order, whose first
+ ; element is the last instruction of a basic block,
+ ; and a filtered list of instructions in forward order,
+ ; returns a filtered list of instructions in the correct order.
+
+ (define (backwards0 instructions filtered)
+ (if (null? instructions)
+ filtered
+ (let* ((instruction (car instructions))
+ (mnemonic (instruction.op instruction)))
+ (cond ((or (eqv? mnemonic $.label)
+ (eqv? mnemonic $.proc)
+ (eqv? mnemonic $.cont)
+ (eqv? mnemonic $.align))
+ (backwards0 (cdr instructions)
+ (cons instruction filtered)))
+ ; all registers are dead at a $return
+ ((eqv? mnemonic $return)
+ (vector-fill! registers #f)
+ (vector-set! registers 0 #t)
+ (backwards (cdr instructions)
+ (cons instruction filtered)))
+ ; all but the argument registers are dead at an $invoke
+ ((eqv? mnemonic $invoke)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg1 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the compiler says which registers are live at the
+ ; target of $skip, $branch, $branchf, or $jump
+ ((or (eqv? mnemonic $skip)
+ (eqv? mnemonic $branch))
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ ((eqv? mnemonic $jump)
+ (let ((n+1 (min *nregs*
+ (+ (instruction.arg3 instruction) 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (subvector-fill! registers n+1 *nregs* #f)
+ (backwards (cdr instructions)
+ (cons instruction filtered))))
+ ; the live registers at the target of a $branchf must be
+ ; combined with the live registers at the $branchf
+ ((eqv? mnemonic $branchf)
+ (let* ((live (instruction.arg2 instruction))
+ (n+1 (min *nregs* (+ live 1))))
+ (subvector-fill! registers 0 n+1 #t)
+ (let ((instruction
+ ; FIXME
+ (list mnemonic
+ (lookup-label
+ (instruction.arg1 instruction))
+ live)))
+ (backwards (cdr instructions)
+ (cons instruction filtered)))))
+ (else (backwards instructions filtered))))))
+
+ (define (suppress-forwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (forwards instructions filtered))
+
+ (define (suppress-backwards instruction instructions filtered)
+ (if (issue-warnings)
+ '(begin (display suppression-message)
+ (newline)))
+ (backwards instructions filtered))
+
+ (define (local-optimization-error op)
+ (error "Compiler bug: local optimization" op))
+
+ (vector-fill! registers #f)
+ (forwards instructions '())))))
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 28 April 1999
+;
+; compile313 -- compilation parameters and driver procedures.
+
+
+; File types -- these may differ between operating systems.
+
+(define *scheme-file-types* '(".sch" ".scm"))
+(define *lap-file-type* ".lap")
+(define *mal-file-type* ".mal")
+(define *lop-file-type* ".lop")
+(define *fasl-file-type* ".fasl")
+
+; Compile and assemble a scheme source file and produce a fastload file.
+
+(define (compile-file infilename . rest)
+
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *fasl-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (and (not (integrate-usual-procedures))
+ (issue-warnings))
+ (begin
+ (display "WARNING from compiler: ")
+ (display "integrate-usual-procedures is turned off")
+ (newline)
+ (display "Performance is likely to be poor.")
+ (newline)))
+ (if (benchmark-block-mode)
+ (process-file-block infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (forms)
+ (assemble (compile-block forms) user)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (expr)
+ (assemble (compile expr) user))))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Compile-file not supported on this target architecture.")
+ (doit)))
+
+
+; Assemble a MAL or LOP file and produce a FASL file.
+
+(define (assemble-file infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ (list *lap-file-type* *mal-file-type*)
+ *fasl-file-type*)))
+ (malfile?
+ (file-type=? infilename *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Assemble-file not supported on this target architecture.")
+ (doit)))
+
+
+; Compile and assemble a single expression; return the LOP segment.
+
+(define compile-expression
+ (let ()
+
+ (define (compile-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (assemble (compile expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ compile-expression))
+
+
+(define macro-expand-expression
+ (let ()
+
+ (define (macro-expand-expression expr env)
+ (let ((syntax-env
+ (case (environment-tag env)
+ ((0 1) (make-standard-syntactic-environment))
+ ((2) global-syntactic-environment)
+ (else
+ (error "Invalid environment for compile-expression: " env)
+ #t))))
+ (let ((current-env global-syntactic-environment))
+ (dynamic-wind
+ (lambda ()
+ (set! global-syntactic-environment syntax-env))
+ (lambda ()
+ (make-readable
+ (macro-expand expr)))
+ (lambda ()
+ (set! global-syntactic-environment current-env))))))
+
+ macro-expand-expression))
+
+
+; Compile a scheme source file to a LAP file.
+
+(define (compile313 infilename . rest)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *scheme-file-types*
+ *lap-file-type*)))
+ (write-lap
+ (lambda (item port)
+ (write item port)
+ (newline port)
+ (newline port))))
+ (if (benchmark-block-mode)
+ (process-file-block infilename outfilename write-lap compile-block)
+ (process-file infilename outfilename write-lap compile))
+ (unspecified)))
+
+
+; Assemble a LAP or MAL file to a LOP file.
+
+(define (assemble313 file . rest)
+ (let ((outputfile
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type file
+ (list *lap-file-type* *mal-file-type*)
+ *lop-file-type*)))
+ (malfile?
+ (file-type=? file *mal-file-type*))
+ (user
+ (assembly-user-data)))
+ (process-file file
+ outputfile
+ write-lop
+ (lambda (x) (assemble (if malfile? (eval x) x) user)))
+ (unspecified)))
+
+
+; Compile and assemble a Scheme source file to a LOP file.
+
+(define (compile-and-assemble313 input-file . rest)
+ (let ((output-file
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type input-file
+ *scheme-file-types*
+ *lop-file-type*)))
+ (user
+ (assembly-user-data)))
+ (if (benchmark-block-mode)
+ (process-file-block input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile-block x) user)))
+ (process-file input-file
+ output-file
+ write-lop
+ (lambda (x) (assemble (compile x) user))))
+ (unspecified)))
+
+
+; Convert a LOP file to a FASL file.
+
+(define (make-fasl infilename . rest)
+ (define (doit)
+ (let ((outfilename
+ (if (not (null? rest))
+ (car rest)
+ (rewrite-file-type infilename
+ *lop-file-type*
+ *fasl-file-type*))))
+ (process-file infilename
+ outfilename
+ dump-fasl-segment-to-port
+ (lambda (x) x))
+ (unspecified)))
+
+ (if (eq? (nbuild-parameter 'target-machine) 'standard-c)
+ (error "Make-fasl not supported on this target architecture.")
+ (doit)))
+
+
+; Disassemble a procedure's code vector.
+
+(define (disassemble item . rest)
+ (let ((output-port (if (null? rest)
+ (current-output-port)
+ (car rest))))
+ (disassemble-item item #f output-port)
+ (unspecified)))
+
+
+; The item can be either a procedure or a pair (assumed to be a segment).
+
+(define (disassemble-item item segment-no port)
+
+ (define (print . rest)
+ (for-each (lambda (x) (display x port)) rest)
+ (newline port))
+
+ (define (print-constvector cv)
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length cv)))
+ (print "------------------------------------------")
+ (print "Constant vector element # " i)
+ (case (car (vector-ref cv i))
+ ((codevector)
+ (print "Code vector")
+ (print-instructions (disassemble-codevector
+ (cadr (vector-ref cv i)))
+ port))
+ ((constantvector)
+ (print "Constant vector")
+ (print-constvector (cadr (vector-ref cv i))))
+ ((global)
+ (print "Global: " (cadr (vector-ref cv i))))
+ ((data)
+ (print "Data: " (cadr (vector-ref cv i)))))))
+
+ (define (print-segment segment)
+ (print "Segment # " segment-no)
+ (print-instructions (disassemble-codevector (car segment)) port)
+ (print-constvector (cdr segment))
+ (print "========================================"))
+
+ (cond ((procedure? item)
+ (print-instructions (disassemble-codevector (procedure-ref item 0))
+ port))
+ ((and (pair? item)
+ (bytevector? (car item))
+ (vector? (cdr item)))
+ (print-segment item))
+ (else
+ (error "disassemble-item: " item " is not disassemblable."))))
+
+
+; Disassemble a ".lop" or ".fasl" file; dump output to screen or
+; other (optional) file.
+
+(define (disassemble-file file . rest)
+
+ (define (doit input-port output-port)
+ (display "; From " output-port)
+ (display file output-port)
+ (newline output-port)
+ (do ((segment-no 0 (+ segment-no 1))
+ (segment (read input-port) (read input-port)))
+ ((eof-object? segment))
+ (disassemble-item segment segment-no output-port)))
+
+ ; disassemble313
+
+ (call-with-input-file
+ file
+ (lambda (input-port)
+ (if (null? rest)
+ (doit input-port (current-output-port))
+ (begin
+ (delete-file (car rest))
+ (call-with-output-file
+ (car rest)
+ (lambda (output-port) (doit input-port output-port)))))))
+ (unspecified))
+
+
+; Display and manipulate the compiler switches.
+
+(define (compiler-switches . rest)
+
+ (define (slow-code)
+ (set-compiler-flags! 'no-optimization)
+ (set-assembler-flags! 'no-optimization))
+
+ (define (standard-code)
+ (set-compiler-flags! 'standard)
+ (set-assembler-flags! 'standard))
+
+ (define (fast-safe-code)
+ (set-compiler-flags! 'fast-safe)
+ (set-assembler-flags! 'fast-safe))
+
+ (define (fast-unsafe-code)
+ (set-compiler-flags! 'fast-unsafe)
+ (set-assembler-flags! 'fast-unsafe))
+
+ (cond ((null? rest)
+ (display "Debugging:")
+ (newline)
+ (display-twobit-flags 'debugging)
+ (display-assembler-flags 'debugging)
+ (newline)
+ (display "Safety:")
+ (newline)
+ (display-twobit-flags 'safety)
+ (display-assembler-flags 'safety)
+ (newline)
+ (display "Speed:")
+ (newline)
+ (display-twobit-flags 'optimization)
+ (display-assembler-flags 'optimization)
+ (if #f #f))
+ ((null? (cdr rest))
+ (case (car rest)
+ ((0 slow) (slow-code))
+ ((1 standard) (standard-code))
+ ((2 fast-safe) (fast-safe-code))
+ ((3 fast-unsafe) (fast-unsafe-code))
+ ((default
+ factory-settings) (fast-safe-code)
+ (include-source-code #t)
+ (benchmark-mode #f)
+ (benchmark-block-mode #f)
+ (common-subexpression-elimination #f)
+ (representation-inference #f))
+ (else
+ (error "Unrecognized flag " (car rest) " to compiler-switches.")))
+ (unspecified))
+ (else
+ (error "Too many arguments to compiler-switches."))))
+
+; Read and process one file, producing another.
+; Preserves the global syntactic environment.
+
+(define (process-file infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (let loop ((x (read inport)))
+ (if (eof-object? x)
+ #t
+ (begin (writer (processer x) outport)
+ (loop (read inport))))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+; Same as above, but passes a list of the entire file's contents
+; to the processer.
+; FIXME: Both versions of PROCESS-FILE always delete the output file.
+; Shouldn't it be left alone if the input file can't be opened?
+
+(define (process-file-block infilename outfilename writer processer)
+ (define (doit)
+ (delete-file outfilename)
+ (call-with-output-file
+ outfilename
+ (lambda (outport)
+ (call-with-input-file
+ infilename
+ (lambda (inport)
+ (do ((x (read inport) (read inport))
+ (forms '() (cons x forms)))
+ ((eof-object? x)
+ (writer (processer (reverse forms)) outport))))))))
+ (let ((current-syntactic-environment
+ (syntactic-copy global-syntactic-environment)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (doit))
+ (lambda ()
+ (set! global-syntactic-environment
+ current-syntactic-environment)))))
+
+
+; Given a file name with some type, produce another with some other type.
+
+(define (rewrite-file-type filename matches new)
+ (if (not (pair? matches))
+ (rewrite-file-type filename (list matches) new)
+ (let ((j (string-length filename)))
+ (let loop ((m matches))
+ (cond ((null? m)
+ (string-append filename new))
+ (else
+ (let* ((n (car m))
+ (l (string-length n)))
+ (if (file-type=? filename n)
+ (string-append (substring filename 0 (- j l)) new)
+ (loop (cdr m))))))))))
+
+(define (file-type=? file-name type-name)
+ (let ((fl (string-length file-name))
+ (tl (string-length type-name)))
+ (and (>= fl tl)
+ (string-ci=? type-name
+ (substring file-name (- fl tl) fl)))))
+
+; eof
+; Copyright 1998 William Clinger.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Procedures that make .LAP structures human-readable
+
+(define (readify-lap code)
+ (map (lambda (x)
+ (let ((iname (cdr (assv (car x) *mnemonic-names*))))
+ (if (not (= (car x) $lambda))
+ (cons iname (cdr x))
+ (list iname (readify-lap (cadr x)) (caddr x)))))
+ code))
+
+(define (readify-file f . o)
+
+ (define (doit)
+ (let ((i (open-input-file f)))
+ (let loop ((x (read i)))
+ (if (not (eof-object? x))
+ (begin (pretty-print (readify-lap x))
+ (loop (read i)))))))
+
+ (if (null? o)
+ (doit)
+ (begin (delete-file (car o))
+ (with-output-to-file (car o) doit))))
+
+; eof
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Target-independent part of the assembler.
+;
+; This is a simple, table-driven, one-pass assembler.
+; Part of it assumes a big-endian target machine.
+;
+; The input to this pass is a list of symbolic MacScheme machine
+; instructions and pseudo-instructions. Each symbolic MacScheme
+; machine instruction or pseudo-instruction is a list whose car
+; is a small non-negative fixnum that acts as the mnemonic for the
+; instruction. The rest of the list is interpreted as indicated
+; by the mnemonic.
+;
+; The output is a pair consisting of machine code (a bytevector or
+; string) and a constant vector.
+;
+; This assembler is table-driven, and may be customized to emit
+; machine code for different target machines. The table consists
+; of a vector of procedures indexed by mnemonics. Each procedure
+; in the table should take two arguments: an assembly structure
+; and a source instruction. The procedure should just assemble
+; the instruction using the operations defined below.
+;
+; The table and target can be changed by redefining the following
+; five procedures.
+
+(define (assembly-table) (error "No assembly table defined."))
+(define (assembly-start as) #t)
+(define (assembly-end as segment) segment)
+(define (assembly-user-data) #f)
+
+; The main entry point.
+
+(define (assemble source . rest)
+ (let* ((user (if (null? rest) (assembly-user-data) (car rest)))
+ (as (make-assembly-structure source (assembly-table) user)))
+ (assembly-start as)
+ (assemble1 as
+ (lambda (as)
+ (let ((segment (assemble-pasteup as)))
+ (assemble-finalize! as)
+ (assembly-end as segment)))
+ #f)))
+
+; The following procedures are to be called by table routines.
+;
+; The assembly source for nested lambda expressions should be
+; assembled by calling this procedure. This allows an inner
+; lambda to refer to labels defined by outer lambdas.
+;
+; We delay the assembly of the nested lambda until after the outer lambda
+; has been finalized so that all labels in the outer lambda are known
+; to the inner lambda.
+;
+; The continuation procedure k is called to backpatch the constant
+; vector of the outer lambda after the inner lambda has been
+; finalized. This is necessary because of the delayed evaluation: the
+; outer lambda holds code and constants for the inner lambda in its
+; constant vector.
+
+(define (assemble-nested-lambda as source doc k . rest)
+ (let* ((user (if (null? rest) #f (car rest)))
+ (nested-as (make-assembly-structure source (as-table as) user)))
+ (as-parent! nested-as as)
+ (as-nested! as (cons (lambda ()
+ (assemble1 nested-as
+ (lambda (nested-as)
+ (let ((segment
+ (assemble-pasteup nested-as)))
+ (assemble-finalize! nested-as)
+ (k nested-as segment)))
+ doc))
+ (as-nested as)))))
+
+(define operand0 car) ; the mnemonic
+(define operand1 cadr)
+(define operand2 caddr)
+(define operand3 cadddr)
+(define (operand4 i) (car (cddddr i)))
+
+; Emits the bits contained in the bytevector bv.
+
+(define (emit! as bv)
+ (as-code! as (cons bv (as-code as)))
+ (as-lc! as (+ (as-lc as) (bytevector-length bv))))
+
+; Emits the characters contained in the string s as code (for C generation).
+
+(define (emit-string! as s)
+ (as-code! as (cons s (as-code as)))
+ (as-lc! as (+ (as-lc as) (string-length s))))
+
+; Given any Scheme object that may legally be quoted, returns an
+; index into the constant vector for that constant.
+
+(define (emit-constant as x)
+ (do ((i 0 (+ i 1))
+ (y (as-constants as) (cdr y)))
+ ((or (null? y) (equal? x (car y)))
+ (if (null? y)
+ (as-constants! as (append! (as-constants as) (list x))))
+ i)))
+
+(define (emit-datum as x)
+ (emit-constant as (list 'data x)))
+
+(define (emit-global as x)
+ (emit-constant as (list 'global x)))
+
+(define (emit-codevector as x)
+ (emit-constants as (list 'codevector x)))
+
+(define (emit-constantvector as x)
+ (emit-constants as (list 'constantvector x)))
+
+; Set-constant changes the datum stored, without affecting the tag.
+; It can operate on the list form because the pair stored in the list
+; is shared between the list and any vector created from the list.
+
+(define (set-constant! as n datum)
+ (let ((pair (list-ref (as-constants as) n)))
+ (set-car! (cdr pair) datum)))
+
+; Guarantees that the constants will not share structure
+; with any others, and will occupy consecutive positions
+; in the constant vector. Returns the index of the first
+; constant.
+
+(define (emit-constants as x . rest)
+ (let* ((constants (as-constants as))
+ (i (length constants)))
+ (as-constants! as (append! constants (cons x rest)))
+ i))
+
+; Defines the given label using the current location counter.
+
+(define (emit-label! as L)
+ (set-cdr! L (as-lc as)))
+
+; Adds the integer n to the size code bytes beginning at the
+; given byte offset from the current value of the location counter.
+
+(define (emit-fixup! as offset size n)
+ (as-fixups! as (cons (list (+ offset (as-lc as)) size n)
+ (as-fixups as))))
+
+; Adds the value of the label L to the size code bytes beginning
+; at the given byte offset from the current location counter.
+
+(define (emit-fixup-label! as offset size L)
+ (as-fixups! as (cons (list (+ offset (as-lc as)) size (list L))
+ (as-fixups as))))
+
+; Allows the procedure proc of two arguments (code vector and current
+; location counter) to modify the code vector at will, at fixup time.
+
+(define (emit-fixup-proc! as proc)
+ (as-fixups! as (cons (list (as-lc as) 0 proc)
+ (as-fixups as))))
+
+; Labels.
+
+; The current value of the location counter.
+
+(define (here as) (as-lc as))
+
+; Given a MAL label (a number), create an assembler label.
+
+(define (make-asm-label as label)
+ (let ((probe (find-label as label)))
+ (if probe
+ probe
+ (let ((l (cons label #f)))
+ (as-labels! as (cons l (as-labels as)))
+ l))))
+
+; This can use hashed lookup.
+
+(define (find-label as L)
+
+ (define (lookup-label-loop x labels parent)
+ (let ((entry (assq x labels)))
+ (cond (entry)
+ ((not parent) #f)
+ (else
+ (lookup-label-loop x (as-labels parent) (as-parent parent))))))
+
+ (lookup-label-loop L (as-labels as) (as-parent as)))
+
+; Create a new assembler label, distinguishable from a MAL label.
+
+(define new-label
+ (let ((n 0))
+ (lambda ()
+ (set! n (- n 1))
+ (cons n #f))))
+
+; Given a value name (a number), return the label value or #f.
+
+(define (label-value as L) (cdr L))
+
+; For peephole optimization.
+
+(define (next-instruction as)
+ (let ((source (as-source as)))
+ (if (null? source)
+ '(-1)
+ (car source))))
+
+(define (consume-next-instruction! as)
+ (as-source! as (cdr (as-source as))))
+
+(define (push-instruction as instruction)
+ (as-source! as (cons instruction (as-source as))))
+
+; For use by the machine assembler: assoc lists connected to as structure.
+
+(define (assembler-value as key)
+ (let ((probe (assq key (as-values as))))
+ (if probe
+ (cdr probe)
+ #f)))
+
+(define (assembler-value! as key value)
+ (let ((probe (assq key (as-values as))))
+ (if probe
+ (set-cdr! probe value)
+ (as-values! as (cons (cons key value) (as-values as))))))
+
+; For documentation.
+;
+; The value must be a documentation structure (a vector).
+
+(define (add-documentation as doc)
+ (let* ((existing-constants (cadr (car (as-constants as))))
+ (new-constants
+ (twobit-sort (lambda (a b)
+ (< (car a) (car b)))
+ (cond ((not existing-constants)
+ (list (cons (here as) doc)))
+ ((pair? existing-constants)
+ (cons (cons (here as) doc)
+ existing-constants))
+ (else
+ (list (cons (here as) doc)
+ (cons 0 existing-constants)))))))
+ (set-car! (cdar (as-constants as)) new-constants)))
+
+; This is called when a value is too large to be handled by the assembler.
+; Info is a string, expr an assembler expression, and val the resulting
+; value. The default behavior is to signal an error.
+
+(define (asm-value-too-large as info expr val)
+ (if (as-retry as)
+ ((as-retry as))
+ (asm-error info ": Value too large: " expr " = " val)))
+
+; The implementations of asm-error and disasm-error depend on the host
+; system. Sigh.
+
+(define (asm-error msg . rest)
+ (cond ((eq? host-system 'chez)
+ (error 'assembler "~a" (list msg rest)))
+ (else
+ (apply error msg rest))))
+
+(define (disasm-error msg . rest)
+ (cond ((eq? host-system 'chez)
+ (error 'disassembler "~a" (list msg rest)))
+ (else
+ (apply error msg rest))))
+
+\f; The remaining procedures in this file are local to the assembler.
+
+; An assembly structure is a vector consisting of
+;
+; table (a table of assembly routines)
+; source (a list of symbolic instructions)
+; lc (location counter; an integer)
+; code (a list of bytevectors)
+; constants (a list)
+; labels (an alist of labels and values)
+; fixups (an alist of locations, sizes, and labels or fixnums)
+; nested (a list of assembly procedures for nested lambdas)
+; values (an assoc list)
+; parent (an assembly structure or #f)
+; retry (a thunk or #f)
+; user-data (anything)
+;
+; In fixups, labels are of the form (<L>) to distinguish them from fixnums.
+
+(define (label? x) (and (pair? x) (fixnum? (car x))))
+(define label.ident car)
+
+(define (make-assembly-structure source table user-data)
+ (vector table
+ source
+ 0
+ '()
+ '()
+ '()
+ '()
+ '()
+ '()
+ #f
+ #f
+ user-data))
+
+(define (as-reset! as source)
+ (as-source! as source)
+ (as-lc! as 0)
+ (as-code! as '())
+ (as-constants! as '())
+ (as-labels! as '())
+ (as-fixups! as '())
+ (as-nested! as '())
+ (as-values! as '())
+ (as-retry! as #f))
+
+(define (as-table as) (vector-ref as 0))
+(define (as-source as) (vector-ref as 1))
+(define (as-lc as) (vector-ref as 2))
+(define (as-code as) (vector-ref as 3))
+(define (as-constants as) (vector-ref as 4))
+(define (as-labels as) (vector-ref as 5))
+(define (as-fixups as) (vector-ref as 6))
+(define (as-nested as) (vector-ref as 7))
+(define (as-values as) (vector-ref as 8))
+(define (as-parent as) (vector-ref as 9))
+(define (as-retry as) (vector-ref as 10))
+(define (as-user as) (vector-ref as 11))
+
+(define (as-source! as x) (vector-set! as 1 x))
+(define (as-lc! as x) (vector-set! as 2 x))
+(define (as-code! as x) (vector-set! as 3 x))
+(define (as-constants! as x) (vector-set! as 4 x))
+(define (as-labels! as x) (vector-set! as 5 x))
+(define (as-fixups! as x) (vector-set! as 6 x))
+(define (as-nested! as x) (vector-set! as 7 x))
+(define (as-values! as x) (vector-set! as 8 x))
+(define (as-parent! as x) (vector-set! as 9 x))
+(define (as-retry! as x) (vector-set! as 10 x))
+(define (as-user! as x) (vector-set! as 11 x))
+
+; The guts of the assembler.
+
+(define (assemble1 as finalize doc)
+ (let ((assembly-table (as-table as))
+ (peep? (peephole-optimization))
+ (step? (single-stepping))
+ (step-instr (list $.singlestep))
+ (end-instr (list $.end)))
+
+ (define (loop)
+ (let ((source (as-source as)))
+ (if (null? source)
+ (begin ((vector-ref assembly-table $.end) end-instr as)
+ (finalize as))
+ (begin (if step?
+ ((vector-ref assembly-table $.singlestep)
+ step-instr
+ as))
+ (if peep?
+ (let peeploop ((src1 source))
+ (peep as)
+ (let ((src2 (as-source as)))
+ (if (not (eq? src1 src2))
+ (peeploop src2)))))
+ (let ((source (as-source as)))
+ (as-source! as (cdr source))
+ ((vector-ref assembly-table (caar source))
+ (car source)
+ as)
+ (loop))))))
+
+ (define (doit)
+ (emit-datum as doc)
+ (loop))
+
+ (let* ((source (as-source as))
+ (r (call-with-current-continuation
+ (lambda (k)
+ (as-retry! as (lambda () (k 'retry)))
+ (doit)))))
+ (if (eq? r 'retry)
+ (let ((old (short-effective-addresses)))
+ (as-reset! as source)
+ (dynamic-wind
+ (lambda ()
+ (short-effective-addresses #f))
+ doit
+ (lambda ()
+ (short-effective-addresses old))))
+ r))))
+
+(define (assemble-pasteup as)
+
+ (define (pasteup-code)
+ (let ((code (make-bytevector (as-lc as)))
+ (constants (list->vector (as-constants as))))
+
+ ; The bytevectors: byte 0 is most significant.
+
+ (define (paste-code! bvs i)
+ (if (not (null? bvs))
+ (let* ((bv (car bvs))
+ (n (bytevector-length bv)))
+ (do ((i i (- i 1))
+ (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
+ ((< j 0) ; (= j n)
+ (paste-code! (cdr bvs) i))
+ (bytevector-set! code i (bytevector-ref bv j))))))
+
+ (paste-code! (as-code as) (- (as-lc as) 1))
+ (as-code! as (list code))
+ (cons code constants)))
+
+ (define (pasteup-strings)
+ (let ((code (make-string (as-lc as)))
+ (constants (list->vector (as-constants as))))
+
+ (define (paste-code! strs i)
+ (if (not (null? strs))
+ (let* ((s (car strs))
+ (n (string-length s)))
+ (do ((i i (- i 1))
+ (j (- n 1) (- j 1))) ; (j 0 (+ j 1))
+ ((< j 0) ; (= j n)
+ (paste-code! (cdr strs) i))
+ (string-set! code i (string-ref s j))))))
+
+ (paste-code! (as-code as) (- (as-lc as) 1))
+ (as-code! as (list code))
+ (cons code constants)))
+
+ (if (bytevector? (car (as-code as)))
+ (pasteup-code)
+ (pasteup-strings)))
+
+(define (assemble-finalize! as)
+ (let ((code (car (as-code as))))
+
+ (define (apply-fixups! fixups)
+ (if (not (null? fixups))
+ (let* ((fixup (car fixups))
+ (i (car fixup))
+ (size (cadr fixup))
+ (adjustment (caddr fixup)) ; may be procedure
+ (n (if (label? adjustment)
+ (lookup-label adjustment)
+ adjustment)))
+ (case size
+ ((0) (fixup-proc code i n))
+ ((1) (fixup1 code i n))
+ ((2) (fixup2 code i n))
+ ((3) (fixup3 code i n))
+ ((4) (fixup4 code i n))
+ (else ???))
+ (apply-fixups! (cdr fixups)))))
+
+ (define (lookup-label L)
+ (or (label-value as (label.ident L))
+ (asm-error "Assembler error -- undefined label " L)))
+
+ (apply-fixups! (reverse! (as-fixups as)))
+
+ (for-each (lambda (nested-as-proc)
+ (nested-as-proc))
+ (as-nested as))))
+
+
+; These fixup routines assume a big-endian target machine.
+
+(define (fixup1 code i n)
+ (bytevector-set! code i (+ n (bytevector-ref code i))))
+
+(define (fixup2 code i n)
+ (let* ((x (+ (* 256 (bytevector-ref code i))
+ (bytevector-ref code (+ i 1))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256)))
+ (bytevector-set! code i y1)
+ (bytevector-set! code (+ i 1) y0)))
+
+(define (fixup3 code i n)
+ (let* ((x (+ (* 65536 (bytevector-ref code i))
+ (* 256 (bytevector-ref code (+ i 1)))
+ (bytevector-ref code (+ i 2))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256))
+ (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256)))
+ (bytevector-set! code i y2)
+ (bytevector-set! code (+ i 1) y1)
+ (bytevector-set! code (+ i 2) y0)))
+
+(define (fixup4 code i n)
+ (let* ((x (+ (* 16777216 (bytevector-ref code i))
+ (* 65536 (bytevector-ref code (+ i 1)))
+ (* 256 (bytevector-ref code (+ i 2)))
+ (bytevector-ref code (+ i 3))))
+ (y (+ x n))
+ (y0 (modulo y 256))
+ (y1 (modulo (quotient (- y y0) 256) 256))
+ (y2 (modulo (quotient (- y (* 256 y1) y0) 256) 256))
+ (y3 (modulo (quotient (- y (* 65536 y2)
+ (* 256 y1)
+ y0)
+ 256)
+ 256)))
+ (bytevector-set! code i y3)
+ (bytevector-set! code (+ i 1) y2)
+ (bytevector-set! code (+ i 2) y1)
+ (bytevector-set! code (+ i 3) y0)))
+
+(define (fixup-proc code i p)
+ (p code i))
+
+\f; For testing.
+
+(define (view-segment segment)
+ (define (display-bytevector bv)
+ (let ((n (bytevector-length bv)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (if (zero? (remainder i 4))
+ (write-char #\space))
+ (if (zero? (remainder i 8))
+ (write-char #\space))
+ (if (zero? (remainder i 32))
+ (newline))
+ (let ((byte (bytevector-ref bv i)))
+ (write-char
+ (string-ref (number->string (quotient byte 16) 16) 0))
+ (write-char
+ (string-ref (number->string (remainder byte 16) 16) 0))))))
+ (if (and (pair? segment)
+ (bytevector? (car segment))
+ (vector? (cdr segment)))
+ (begin (display-bytevector (car segment))
+ (newline)
+ (write (cdr segment))
+ (newline)
+ (do ((constants (vector->list (cdr segment))
+ (cdr constants)))
+ ((or (null? constants)
+ (null? (cdr constants))))
+ (if (and (bytevector? (car constants))
+ (vector? (cadr constants)))
+ (view-segment (cons (car constants)
+ (cadr constants))))))))
+
+; emit is a procedure that takes an as and emits instructions into it.
+
+(define (test-asm emit)
+ (let ((as (make-assembly-structure #f #f #f)))
+ (emit as)
+ (let ((segment (assemble-pasteup as)))
+ (assemble-finalize! as)
+ (disassemble segment))))
+
+(define (compile&assemble x)
+ (view-segment (assemble (compile x))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Common assembler -- miscellaneous utility procedures.
+
+; Given any Scheme object, return its printable representation as a string.
+; This code is largely portable (see comments).
+
+(define (format-object x)
+
+ (define (format-list x)
+ (define (loop x)
+ (cond ((null? x)
+ '(")"))
+ ((null? (cdr x))
+ (list (format-object (car x)) ")"))
+ (else
+ (cons (format-object (car x))
+ (cons " "
+ (loop (cdr x)))))))
+ (apply string-append (cons "(" (loop x))))
+
+ (define (format-improper-list x)
+ (define (loop x)
+ (if (pair? (cdr x))
+ (cons (format-object (car x))
+ (cons " "
+ (loop (cdr x))))
+ (list (format-object (car x))
+ " . "
+ (format-object (cdr x))
+ ")")))
+ (apply string-append (cons "(" (loop x))))
+
+ (cond ((null? x) "()")
+ ((not x) "#f")
+ ((eq? x #t) "#t")
+ ((symbol? x) (symbol->string x))
+ ((number? x) (number->string x))
+ ((char? x) (string x))
+ ((string? x) x)
+ ((procedure? x) "#<procedure>")
+ ((bytevector? x) "#<bytevector>") ; Larceny
+ ((eof-object? x) "#<eof>")
+ ((port? x) "#<port>")
+ ((eq? x (unspecified)) "#!unspecified") ; Larceny
+ ((eq? x (undefined)) "#!undefined") ; Larceny
+ ((vector? x)
+ (string-append "#" (format-list (vector->list x))))
+ ((list? x)
+ (format-list x))
+ ((pair? x)
+ (format-improper-list x))
+ (else "#<weird>")))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny assembler -- 32-bit big-endian utility procedures.
+;
+; 32-bit numbers are represented as 4-byte bytevectors where byte 3
+; is the least significant and byte 0 is the most significant.
+;
+; Logically, the 'big' end is on the left and the 'little' end
+; is on the right, so a left shift shifts towards the 'big' end.
+;
+; Performance: poor, for good reasons. See asmutil32.sch.
+
+; Identifies the code loaded.
+
+(define asm:endianness 'big)
+
+
+; Given four bytes, create a length-4 bytevector.
+; N1 is the most significant byte, n4 the least significant.
+
+(define (asm:bv n1 n2 n3 n4)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-set! bv 0 n1)
+ (bytevector-set! bv 1 n2)
+ (bytevector-set! bv 2 n3)
+ (bytevector-set! bv 3 n4)
+ bv))
+
+
+; Given a length-4 bytevector, convert it to an integer.
+
+(define (asm:bv->int bv)
+ (let ((i (+ (* (+ (* (+ (* (bytevector-ref bv 0) 256)
+ (bytevector-ref bv 1))
+ 256)
+ (bytevector-ref bv 2))
+ 256)
+ (bytevector-ref bv 3))))
+ (if (> (bytevector-ref bv 0) 127)
+ (- i)
+ i)))
+
+
+; Shift the bits of m left by n bits, shifting in zeroes at the right end.
+; Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define (asm:lsh m n)
+ (if (not (bytevector? m))
+ (asm:lsh (asm:int->bv m) n)
+ (let ((m (bytevector-copy m))
+ (n (remainder n 33)))
+ (if (>= n 8)
+ (let ((k (quotient n 8)))
+ (do ((i 0 (+ i 1)))
+ ((= (+ i k) 4)
+ (do ((i i (+ i 1)))
+ ((= i 4))
+ (bytevector-set! m i 0)))
+ (bytevector-set! m i (bytevector-ref m (+ i k))))))
+ (let* ((d0 (bytevector-ref m 0))
+ (d1 (bytevector-ref m 1))
+ (d2 (bytevector-ref m 2))
+ (d3 (bytevector-ref m 3))
+ (n (remainder n 8))
+ (n- (- 8 n)))
+ (asm:bv (logand (logior (lsh d0 n) (rshl d1 n-)) 255)
+ (logand (logior (lsh d1 n) (rshl d2 n-)) 255)
+ (logand (logior (lsh d2 n) (rshl d3 n-)) 255)
+ (logand (lsh d3 n) 255))))))
+
+
+; Shift the bits of m right by n bits, shifting in zeroes at the high end.
+; Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define (asm:rshl m n)
+ (if (not (bytevector? m))
+ (asm:rshl (asm:int->bv m) n)
+ (let ((m (bytevector-copy m))
+ (n (remainder n 33)))
+ (if (>= n 8)
+ (let ((k (quotient n 8)))
+ (do ((i 3 (- i 1)))
+ ((< (- i k) 0)
+ (do ((i i (- i 1)))
+ ((< i 0))
+ (bytevector-set! m i 0)))
+ (bytevector-set! m i (bytevector-ref m (- i k))))))
+ (let* ((d0 (bytevector-ref m 0))
+ (d1 (bytevector-ref m 1))
+ (d2 (bytevector-ref m 2))
+ (d3 (bytevector-ref m 3))
+ (n (remainder n 8))
+ (n- (- 8 n)))
+ (asm:bv (rshl d0 n)
+ (logand (logior (rshl d1 n) (lsh d0 n-)) 255)
+ (logand (logior (rshl d2 n) (lsh d1 n-)) 255)
+ (logand (logior (rshl d3 n) (lsh d2 n-)) 255))))))
+
+
+; Shift the bits of m right by n bits, shifting in the sign bit at the
+; high end. Returns a length-4 bytevector.
+;
+; M may be an exact integer or a length-4 bytevector.
+; N must be an exact nonnegative integer; it's interpreted modulo 33.
+
+(define asm:rsha
+ (let ((ones (asm:bv #xff #xff #xff #xff)))
+ (lambda (m n)
+ (let* ((m (if (bytevector? m) m (asm:int->bv m)))
+ (n (remainder n 33))
+ (h (rshl (bytevector-ref m 0) 7))
+ (k (asm:rshl m n)))
+; (format #t "~a ~a ~a~%" h (bytevector-ref m 0) n)
+; (prnx (asm:lsh ones (- 32 n))) (newline)
+ (if (zero? h)
+ k
+ (asm:logior k (asm:lsh ones (- 32 n))))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Larceny assembler -- 32-bit endianness-independent utility procedures.
+;
+; 32-bit numbers are represented as 4-byte bytevectors where the
+; exact layout depends on whether the little-endian or big-endian
+; module has been loaded. One of them must be loaded prior to loading
+; this module.
+;
+; Logically, the 'big' end is on the left and the 'little' end
+; is on the right, so a left shift shifts towards the big end.
+;
+; Generally, performance is not a major issue in this module. The
+; assemblers should use more specialized code for truly good performance.
+; These procedures are mainly suitable for one-time construction of
+; instruction templates, and during development.
+;
+; Endian-ness specific operations are in asmutil32be.sch and asmutil32le.sch:
+;
+; (asm:bv n0 n1 n2 n3) ; Construct bytevector
+; (asm:bv->int bv) ; Convert bytevector to integer
+; (asm:lsh m k) ; Shift left logical k bits
+; (asm:rshl m k) ; Shift right logical k bits
+; (asm:rsha m k) ; Shirt right arithmetic k bits
+
+
+; Convert an integer to a length-4 bytevector using two's complement
+; representation for negative numbers.
+; Returns length-4 bytevector.
+;
+; The procedure handles numbers in the range -2^31..2^32-1 [sic].
+; It is an error for the number to be outside this range.
+;
+; FIXME: quotient/remainder may be slow; we could have special fixnum
+; case that uses shifts (that could be in-lined as macro). It could
+; work for negative numbers too.
+; FIXME: should probably check that the number is within range.
+
+(define asm:int->bv
+ (let ((two^32 (expt 2 32)))
+ (lambda (m)
+ (let* ((m (if (< m 0) (+ two^32 m) m))
+ (b0 (remainder m 256))
+ (m (quotient m 256))
+ (b1 (remainder m 256))
+ (m (quotient m 256))
+ (b2 (remainder m 256))
+ (m (quotient m 256))
+ (b3 (remainder m 256)))
+ (asm:bv b3 b2 b1 b0)))))
+
+
+; `Or' the bits of multiple operands together.
+; Each operand may be an exact integer or a length-4 bytevector.
+; Returns a length-4 bytevector.
+
+(define (asm:logior . ops)
+ (let ((r (asm:bv 0 0 0 0)))
+ (do ((ops ops (cdr ops)))
+ ((null? ops) r)
+ (let* ((op (car ops))
+ (op (if (bytevector? op) op (asm:int->bv op))))
+ (bytevector-set! r 0 (logior (bytevector-ref r 0)
+ (bytevector-ref op 0)))
+ (bytevector-set! r 1 (logior (bytevector-ref r 1)
+ (bytevector-ref op 1)))
+ (bytevector-set! r 2 (logior (bytevector-ref r 2)
+ (bytevector-ref op 2)))
+ (bytevector-set! r 3 (logior (bytevector-ref r 3)
+ (bytevector-ref op 3)))))))
+
+
+; `And' the bits of two operands together.
+; Either may be an exact integer or length-4 bytevector.
+; Returns length-4 bytevector.
+
+(define (asm:logand op1 op2)
+ (let ((op1 (if (bytevector? op1) op1 (asm:int->bv op1)))
+ (op2 (if (bytevector? op2) op2 (asm:int->bv op2)))
+ (bv (make-bytevector 4)))
+ (bytevector-set! bv 0 (logand (bytevector-ref op1 0)
+ (bytevector-ref op2 0)))
+ (bytevector-set! bv 1 (logand (bytevector-ref op1 1)
+ (bytevector-ref op2 1)))
+ (bytevector-set! bv 2 (logand (bytevector-ref op1 2)
+ (bytevector-ref op2 2)))
+ (bytevector-set! bv 3 (logand (bytevector-ref op1 3)
+ (bytevector-ref op2 3)))
+ bv))
+
+
+; Extract the n low-order bits of m.
+; m may be an exact integer or a length-4 bytevector.
+; n must be an exact nonnegative integer, interpreted modulo 32.
+; Returns length-4 bytevector.
+;
+; Does not depend on endian-ness.
+
+(define asm:lobits
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (asm:int->bv (- (expt 2 i) 1))))
+ (lambda (m n)
+ (asm:logand m (vector-ref v (remainder n 33))))))
+
+; Extract the n high-order bits of m.
+; m may be an exact integer or a length-4 bytevector.
+; n must be an exact nonnegative integer, interpreted modulo 33.
+; Returns length-4 bytevector with the high-order bits of m at low end.
+;
+; Does not depend on endian-ness.
+
+(define (asm:hibits m n)
+ (asm:rshl m (- 32 (remainder n 33))))
+
+; Test that the given number (not! bytevector) m fits in an n-bit
+; signed slot.
+;
+; Does not depend on endian-ness.
+
+(define asm:fits?
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (expt 2 i)))
+ (lambda (m n)
+ (<= (- (vector-ref v (- n 1))) m (- (vector-ref v (- n 1)) 1)))))
+
+; Test that the given number (not! bytevector) m fits in an n-bit
+; unsigned slot.
+;
+; Does not depend on endian-ness.
+
+(define asm:fits-unsigned?
+ (let ((v (make-vector 33)))
+ (do ((i 0 (+ i 1)))
+ ((= i 33))
+ (vector-set! v i (expt 2 i)))
+ (lambda (m n)
+ (<= 0 m (- (vector-ref v n) 1)))))
+
+; Add two operands (numbers or bytevectors).
+;
+; Does not depend on endian-ness.
+
+(define (asm:add a b)
+ (asm:int->bv (+ (if (bytevector? a) (asm:bv->int a) a)
+ (if (bytevector? b) (asm:bv->int b) b))))
+
+; Given an unsigned 32-bit number, return it as a signed number
+; as appropriate.
+;
+; Does not depend on endian-ness.
+
+(define (asm:signed n)
+ (if (< n 2147483647)
+ n
+ (- n 4294967296)))
+
+
+(define (asm:print-bv bv)
+
+ (define hex "0123456789abcdef")
+
+ (define (pdig k)
+ (display (string-ref hex (quotient k 16)))
+ (display (string-ref hex (remainder k 16)))
+ (display " "))
+
+ (if (eq? asm:endianness 'little)
+ (do ((i 3 (- i 1)))
+ ((< i 0))
+ (pdig (bytevector-ref bv i)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4))
+ (pdig (bytevector-ref bv i)))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Procedure that writes fastload segment.
+;
+; The procedure 'dump-fasl-segment-to-port' takes a segment and an output
+; port as arguments and dumps the segment in fastload format on that port.
+; The port must be a binary (untranslated) port.
+;
+; A fastload segment looks like a Scheme expression, and in fact,
+; fastload files can mix compiled and uncompiled expressions. A compiled
+; expression (as created by dump-fasl-segment-to-port) is a list with
+; a literal procedure in the operator position and no arguments.
+;
+; A literal procedure is a three-element list prefixed by #^P. The three
+; elements are code (a bytevector), constants (a regular vector), and
+; R0/static link slot (always #f).
+;
+; A bytevector is a string prefixed by #^B. The string may contain
+; control characters; \ and " must be quoted as usual.
+;
+; A global variable reference in the constant vector is a symbol prefixed
+; by #^G. On reading, the reference is replaced by (a pointer to) the
+; actual cell.
+;
+; This code is highly bummed. The procedure write-bytevector-like has the
+; same meaning as display, but in Larceny, the former is currently much
+; faster than the latter.
+
+(define (dump-fasl-segment-to-port segment outp . rest)
+ (let* ((omit-code? (not (null? rest)))
+ (controllify
+ (lambda (char)
+ (integer->char (- (char->integer char) (char->integer #\@)))))
+ (CTRLP (controllify #\P))
+ (CTRLB (controllify #\B))
+ (CTRLG (controllify #\G))
+ (DOUBLEQUOTE (char->integer #\"))
+ (BACKSLASH (char->integer #\\))
+ (len 1024))
+
+ (define buffer (make-string len #\&))
+ (define ptr 0)
+
+ (define (flush)
+ (if (< ptr len)
+ (write-bytevector-like (substring buffer 0 ptr) outp)
+ (write-bytevector-like buffer outp))
+ (set! ptr 0))
+
+ (define (putc c)
+ (if (= ptr len) (flush))
+ (string-set! buffer ptr c)
+ (set! ptr (+ ptr 1)))
+
+ (define (putb b)
+ (if (= ptr len) (flush))
+ (string-set! buffer ptr (integer->char b))
+ (set! ptr (+ ptr 1)))
+
+ (define (puts s)
+ (let ((ls (string-length s)))
+ (if (>= (+ ptr ls) len)
+ (begin (flush)
+ (write-bytevector-like s outp))
+ (do ((i (- ls 1) (- i 1))
+ (p (+ ptr ls -1) (- p 1)))
+ ((< i 0)
+ (set! ptr (+ ptr ls)))
+ (string-set! buffer p (string-ref s i))))))
+
+ (define (putd d)
+ (flush)
+ (write-fasl-datum d outp))
+
+ (define (dump-codevec bv)
+ (if omit-code?
+ (puts "#f")
+ (begin
+ (putc #\#)
+ (putc CTRLB)
+ (putc #\")
+ (let ((limit (bytevector-length bv)))
+ (do ((i 0 (+ i 1)))
+ ((= i limit) (putc #\")
+ (putc #\newline))
+ (let ((c (bytevector-ref bv i)))
+ (cond ((= c DOUBLEQUOTE) (putc #\\))
+ ((= c BACKSLASH) (putc #\\)))
+ (putb c)))))))
+
+ (define (dump-constvec cv)
+ (puts "#(")
+ (for-each (lambda (const)
+ (putc #\space)
+ (case (car const)
+ ((data)
+ (putd (cadr const)))
+ ((constantvector)
+ (dump-constvec (cadr const)))
+ ((codevector)
+ (dump-codevec (cadr const)))
+ ((global)
+ (putc #\#)
+ (putc CTRLG)
+ (putd (cadr const)))
+ ((bits)
+ (error "BITS attribute is not supported in fasl files."))
+ (else
+ (error "Faulty .lop file."))))
+ (vector->list cv))
+ (puts ")")
+ (putc #\newline))
+
+ (define (dump-fasl-segment segment)
+ (if (not omit-code?) (putc #\())
+ (putc #\#)
+ (putc CTRLP)
+ (putc #\()
+ (dump-codevec (car segment))
+ (putc #\space)
+ (dump-constvec (cdr segment))
+ (puts " #f)")
+ (if (not omit-code?) (putc #\)))
+ (putc #\newline))
+
+ (dump-fasl-segment segment)
+ (flush)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Bootstrap heap dumper.
+;
+; Usage: (build-heap-image outputfile inputfile-list)
+;
+; Each input file is a sequence of segments, the structure of which
+; depends on the target architecture, but at least segment.code and
+; segment.constants exist as accessors.
+;
+; The code is a bytevector. The constant vector contains tagged
+; entries (represented using length-2 lists), where the tags are
+; `data', `codevector', `constantvector', `global', or `bits'.
+;
+; `build-heap-image' reads its file arguments into the heap, creates
+; thunks from the segments, and creates a list of the thunks. It also
+; creates a list of all symbols present in the loaded files. Finally,
+; it generates an initialization procedure (the LAP of which is hardcoded
+; into this file; see below). A pointer to this procedure is installed
+; in the SCHEME_ENTRY root pointer; hence, this procedure (a thunk, as
+; it were) is called when the heap image is loaded.
+;
+; The initialization procedure calls each procedure in the thunk list in
+; order. It then invokes the procedure `go', which takes one argument:
+; the list of symbols. Typically, `go' will initialize the symbol table
+; and other system tables and then call `main', but this is by no means
+; required.
+;
+; The Scheme assembler must be co-resident, since it is used by
+; `build-heap-image' procedure to assemble the final startup code. This
+; could be avoided by pre-assembling the code and patching it here, but
+; the way it is now, this procedure is entirely portable -- no target
+; dependencies.
+;
+; The code is structured to allow most procedures to be overridden for
+; target architectures with more complex needs (notably the C backend).
+
+(define generate-global-symbols
+ (make-twobit-flag 'generate-global-symbols))
+(generate-global-symbols #t)
+
+(define heap.version-number 9) ; Heap version number
+
+(define heap.root-names ; Roots in heap version 9
+ '(result argreg2 argreg3
+ reg0 reg1 reg2 reg3 reg3 reg5 reg6 reg7 reg8 reg9 reg10 reg11 reg12
+ reg13 reg14 reg15 reg16 reg17 reg18 reg19 reg20 reg21 reg22 reg23
+ reg24 reg25 reg26 reg27 reg28 reg29 reg30 reg31
+ cont startup callouts schcall-arg4 alloci-tmp))
+
+(define (build-heap-image output-file input-files)
+
+ (define tmp-file "HEAPDATA.dat")
+
+ (define (process-input-files heap)
+ (let loop ((files input-files) (inits '()))
+ (cond ((null? files)
+ (heap.thunks! heap (apply append inits)))
+ (else
+ (let ((filename (car files)))
+ (display "Loading ")
+ (display filename)
+ (newline)
+ (loop (cdr files)
+ (append inits (list (dump-file! heap filename)))))))))
+
+ (delete-file tmp-file)
+ (let ((heap (make-heap #f (open-output-file tmp-file))))
+ (before-all-files heap output-file input-files)
+ (process-input-files heap)
+ (heap.set-root! heap
+ 'startup
+ (dump-startup-procedure! heap))
+ (heap.set-root! heap
+ 'callouts
+ (dump-global! heap 'millicode-support))
+ (write-header heap output-file)
+ (after-all-files heap output-file input-files)
+ (close-output-port (heap.output-port heap))
+ (append-file-shell-command tmp-file output-file)
+ (load-map heap)
+ (unspecified)))
+
+(define (before-all-files heap output-file-name input-file-names) #t)
+(define (after-all-files heap output-file-name input-file-names) #t)
+
+; Public
+;
+; A 'heap' is a data structure with the following public fields; none
+; of them are constant unless so annotated:
+;
+; version a fixnum (constant) - heap type version number
+; roots an assoc list that maps root names to values
+; top an exact nonnegative integer: the address of the
+; next byte to be emitted
+; symbol-table a symbol table abstract data type
+; extra any value - a client-extension field
+; output-port an output port (for the data stream)
+; thunks a list of codevector addresses
+;
+; Bytes are emitted with the heap.byte! and heap.word! procedures,
+; which emit a byte and a 4-byte word respectively. These update
+; the top field.
+
+(define (make-heap extra output-port)
+ (vector heap.version-number ; version
+ '() ; roots
+ 0 ; top
+ (make-heap-symbol-table) ; symtab
+ extra ; extra
+ output-port ; output port
+ '() ; thunks
+ ))
+
+(define (heap.version h) (vector-ref h 0))
+(define (heap.roots h) (vector-ref h 1))
+(define (heap.top h) (vector-ref h 2))
+(define (heap.symbol-table h) (vector-ref h 3))
+(define (heap.extra h) (vector-ref h 4))
+(define (heap.output-port h) (vector-ref h 5))
+(define (heap.thunks h) (vector-ref h 6))
+
+(define (heap.roots! h x) (vector-set! h 1 x))
+(define (heap.top! h x) (vector-set! h 2 x))
+(define (heap.thunks! h x) (vector-set! h 6 x))
+
+
+; Symbol table.
+;
+; The symbol table maps names to symbol structures, and a symbol
+; structure contains information about that symbol.
+;
+; The structure has four fields:
+; name a symbol - the print name
+; symloc a fixnum or null - if fixnum, the location in the
+; heap of the symbol structure.
+; valloc a fixnum or null - if fixnum, the location in the
+; heap of the global variable cell that has this
+; symbol for its name.
+; valno a fixnum or null - if fixnum, the serial number of
+; the global variable cell (largely obsolete).
+;
+; Note therefore that the symbol table maintains information about
+; whether the symbol is used as a symbol (in a datum), as a global
+; variable, or both.
+
+(define (make-heap-symbol-table)
+ (vector '() 0))
+
+(define (symtab.symbols st) (vector-ref st 0))
+(define (symtab.cell-no st) (vector-ref st 1))
+
+(define (symtab.symbols! st x) (vector-set! st 0 x))
+(define (symtab.cell-no! st x) (vector-set! st 1 x))
+
+(define (make-symcell name)
+ (vector name '() '() '()))
+
+(define (symcell.name sc) (vector-ref sc 0)) ; name
+(define (symcell.symloc sc) (vector-ref sc 1)) ; symbol location (if any)
+(define (symcell.valloc sc) (vector-ref sc 2)) ; value cell location (ditto)
+(define (symcell.valno sc) (vector-ref sc 3)) ; value cell number (ditto)
+
+(define (symcell.symloc! sc x) (vector-set! sc 1 x))
+(define (symcell.valloc! sc x) (vector-set! sc 2 x))
+(define (symcell.valno! sc x) (vector-set! sc 3 x))
+
+; Find a symcell in the table, or make a new one if there's none.
+
+(define (symbol-cell h name)
+ (let ((symtab (heap.symbol-table h)))
+ (let loop ((symbols (symtab.symbols symtab)))
+ (cond ((null? symbols)
+ (let ((new-sym (make-symcell name)))
+ (symtab.symbols! symtab (cons new-sym
+ (symtab.symbols symtab)))
+ new-sym))
+ ((eq? name (symcell.name (car symbols)))
+ (car symbols))
+ (else
+ (loop (cdr symbols)))))))
+
+
+; Fundamental data emitters
+
+(define twofiftysix^3 (* 256 256 256))
+(define twofiftysix^2 (* 256 256))
+(define twofiftysix 256)
+
+(define (heap.word-be! h w)
+ (heap.byte! h (quotient w twofiftysix^3))
+ (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
+ (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
+ (heap.byte! h (remainder w twofiftysix)))
+
+(define (heap.word-el! h w)
+ (heap.byte! h (remainder w twofiftysix))
+ (heap.byte! h (quotient (remainder w twofiftysix^2) twofiftysix))
+ (heap.byte! h (quotient (remainder w twofiftysix^3) twofiftysix^2))
+ (heap.byte! h (quotient w twofiftysix^3)))
+
+(define heap.word! heap.word-be!)
+
+(define (dumpheap.set-endianness! which)
+ (case which
+ ((big) (set! heap.word! heap.word-be!))
+ ((little) (set! heap.word! heap.word-el!))
+ (else ???)))
+
+(define (heap.byte! h b)
+ (write-char (integer->char b) (heap.output-port h))
+ (heap.top! h (+ 1 (heap.top h))))
+
+
+; Useful abstractions and constants.
+
+(define (heap.header-word! h immediate length)
+ (heap.word! h (+ (* length 256) immediate)))
+
+(define (heap.adjust! h)
+ (let ((p (heap.top h)))
+ (let loop ((i (- (* 8 (quotient (+ p 7) 8)) p)))
+ (if (zero? i)
+ '()
+ (begin (heap.byte! h 0)
+ (loop (- i 1)))))))
+
+(define heap.largest-fixnum (- (expt 2 29) 1))
+(define heap.smallest-fixnum (- (expt 2 29)))
+
+(define (heap.set-root! h name value)
+ (heap.roots! h (cons (cons name value) (heap.roots h))))
+
+
+;;; The segment.* procedures may be overridden by custom code.
+
+(define segment.code car)
+(define segment.constants cdr)
+
+;;; The dump-*! procedures may be overridden by custom code.
+
+; Load a LOP file into the heap, create a thunk in the heap to hold the
+; code and constant vector, and return the list of thunk addresses in
+; the order dumped.
+
+(define (dump-file! h filename)
+ (before-dump-file h filename)
+ (call-with-input-file filename
+ (lambda (in)
+ (do ((segment (read in) (read in))
+ (thunks '() (cons (dump-segment! h segment) thunks)))
+ ((eof-object? segment)
+ (after-dump-file h filename)
+ (reverse thunks))))))
+
+(define (before-dump-file h filename) #t)
+(define (after-dump-file h filename) #t)
+
+; Dump a segment and return the heap address of the resulting thunk.
+
+(define (dump-segment! h segment)
+ (let* ((the-code (dump-codevector! h (segment.code segment)))
+ (the-consts (dump-constantvector! h (segment.constants segment))))
+ (dump-thunk! h the-code the-consts)))
+
+(define (dump-tagged-item! h item)
+ (case (car item)
+ ((codevector)
+ (dump-codevector! h (cadr item)))
+ ((constantvector)
+ (dump-constantvector! h (cadr item)))
+ ((data)
+ (dump-datum! h (cadr item)))
+ ((global)
+ (dump-global! h (cadr item)))
+ ((bits)
+ (cadr item))
+ (else
+ (error 'dump-tagged-item! "Unknown item ~a" item))))
+
+(define (dump-datum! h datum)
+
+ (define (fixnum? x)
+ (and (integer? x)
+ (exact? x)
+ (<= heap.smallest-fixnum x heap.largest-fixnum)))
+
+ (define (bignum? x)
+ (and (integer? x)
+ (exact? x)
+ (or (> x heap.largest-fixnum)
+ (< x heap.smallest-fixnum))))
+
+ (define (ratnum? x)
+ (and (rational? x) (exact? x) (not (integer? x))))
+
+ (define (flonum? x)
+ (and (real? x) (inexact? x)))
+
+ (define (compnum? x)
+ (and (complex? x) (inexact? x) (not (real? x))))
+
+ (define (rectnum? x)
+ (and (complex? x) (exact? x) (not (real? x))))
+
+ (cond ((fixnum? datum)
+ (dump-fixnum! h datum))
+ ((bignum? datum)
+ (dump-bignum! h datum))
+ ((ratnum? datum)
+ (dump-ratnum! h datum))
+ ((flonum? datum)
+ (dump-flonum! h datum))
+ ((compnum? datum)
+ (dump-compnum! h datum))
+ ((rectnum? datum)
+ (dump-rectnum! h datum))
+ ((char? datum)
+ (dump-char! h datum))
+ ((null? datum)
+ $imm.null)
+ ((eq? datum #t)
+ $imm.true)
+ ((eq? datum #f)
+ $imm.false)
+ ((equal? datum (unspecified))
+ $imm.unspecified)
+ ((equal? datum (undefined))
+ $imm.undefined)
+ ((vector? datum)
+ (dump-vector! h datum $tag.vector-typetag))
+ ((bytevector? datum)
+ (dump-bytevector! h datum $tag.bytevector-typetag))
+ ((pair? datum)
+ (dump-pair! h datum))
+ ((string? datum)
+ (dump-string! h datum))
+ ((symbol? datum)
+ (dump-symbol! h datum))
+ (else
+ (error 'dump-datum! "Unsupported type of datum ~a" datum))))
+
+; Returns the two's complement representation as a positive number.
+
+(define (dump-fixnum! h f)
+ (if (negative? f)
+ (- #x100000000 (* (abs f) 4))
+ (* 4 f)))
+
+(define (dump-char! h c)
+ (+ (* (char->integer c) twofiftysix^2) $imm.character))
+
+(define (dump-bignum! h b)
+ (dump-bytevector! h (bignum->bytevector b) $tag.bignum-typetag))
+
+(define (dump-ratnum! h r)
+ (dump-vector! h
+ (vector (numerator r) (denominator r))
+ $tag.ratnum-typetag))
+
+(define (dump-flonum! h f)
+ (dump-bytevector! h (flonum->bytevector f) $tag.flonum-typetag))
+
+(define (dump-compnum! h c)
+ (dump-bytevector! h (compnum->bytevector c) $tag.compnum-typetag))
+
+(define (dump-rectnum! h r)
+ (dump-vector! h
+ (vector (real-part r) (imag-part r))
+ $tag.rectnum-typetag))
+
+(define (dump-string! h s)
+ (dump-bytevector! h (string->bytevector s) $tag.string-typetag))
+
+(define (dump-pair! h p)
+ (let ((the-car (dump-datum! h (car p)))
+ (the-cdr (dump-datum! h (cdr p))))
+ (let ((base (heap.top h)))
+ (heap.word! h the-car)
+ (heap.word! h the-cdr)
+ (+ base $tag.pair-tag))))
+
+(define (dump-bytevector! h bv variation)
+ (let ((base (heap.top h))
+ (l (bytevector-length bv)))
+ (heap.header-word! h (+ $imm.bytevector-header variation) l)
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (heap.byte! h (bytevector-ref bv i))
+ (loop (+ i 1)))
+ (begin (heap.adjust! h)
+ (+ base $tag.bytevector-tag))))))
+
+(define (dump-vector! h v variation)
+ (dump-vector-like! h v dump-datum! variation))
+
+(define (dump-vector-like! h cv recur! variation)
+ (let* ((l (vector-length cv))
+ (v (make-vector l '())))
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (vector-set! v i (recur! h (vector-ref cv i)))
+ (loop (+ i 1)))
+ (let ((base (heap.top h)))
+ (heap.header-word! h (+ $imm.vector-header variation) (* l 4))
+ (let loop ((i 0))
+ (if (< i l)
+ (begin (heap.word! h (vector-ref v i))
+ (loop (+ i 1)))
+ (begin (heap.adjust! h)
+ (+ base $tag.vector-tag)))))))))
+
+(define (dump-codevector! h cv)
+ (dump-bytevector! h cv $tag.bytevector-typetag))
+
+(define (dump-constantvector! h cv)
+ (dump-vector-like! h cv dump-tagged-item! $tag.vector-typetag))
+
+(define (dump-symbol! h s)
+ (let ((x (symbol-cell h s)))
+ (if (null? (symcell.symloc x))
+ (symcell.symloc! x (create-symbol! h s)))
+ (symcell.symloc x)))
+
+(define (dump-global! h g)
+ (let ((x (symbol-cell h g)))
+ (if (null? (symcell.valloc x))
+ (let ((cell (create-cell! h g)))
+ (symcell.valloc! x (car cell))
+ (symcell.valno! x (cdr cell))))
+ (symcell.valloc x)))
+
+(define (dump-thunk! h code constants)
+ (let ((base (heap.top h)))
+ (heap.header-word! h $imm.procedure-header 8)
+ (heap.word! h code)
+ (heap.word! h constants)
+ (heap.adjust! h)
+ (+ base $tag.procedure-tag)))
+
+; The car's are all heap pointers, so they should not be messed with.
+; The cdr must be dumped, and then the pair.
+
+(define (dump-list-spine! h l)
+ (if (null? l)
+ $imm.null
+ (let ((the-car (car l))
+ (the-cdr (dump-list-spine! h (cdr l))))
+ (let ((base (heap.top h)))
+ (heap.word! h the-car)
+ (heap.word! h the-cdr)
+ (+ base $tag.pair-tag)))))
+
+(define (dump-startup-procedure! h)
+ (let ((thunks (dump-list-spine! h (heap.thunks h)))
+ (symbols (dump-list-spine! h (symbol-locations h))))
+ (dump-segment! h (construct-startup-procedure symbols thunks))))
+
+; The initialization procedure. The lists are magically patched into
+; the constant vector after the procedure has been assembled but before
+; it is dumped into the heap. See below.
+;
+; (define (init-proc argv)
+; (let loop ((l <list-of-thunks>))
+; (if (null? l)
+; (go <list-of-symbols> argv)
+; (begin ((car l))
+; (loop (cdr l))))))
+
+(define init-proc
+ `((,$.proc)
+ (,$args= 1)
+ (,$reg 1) ; argv into
+ (,$setreg 2) ; register 2
+ (,$const (thunks)) ; dummy list of thunks.
+ (,$setreg 1)
+ (,$.label 0)
+ (,$reg 1)
+ (,$op1 null?) ; (null? l)
+ (,$branchf 2)
+ (,$const (symbols)) ; dummy list of symbols
+ (,$setreg 1)
+ (,$global go)
+ ;(,$op1 break)
+ (,$invoke 2) ; (go <list of symbols> argv)
+ (,$.label 2)
+ (,$save 2)
+ (,$store 0 0)
+ (,$store 1 1)
+ (,$store 2 2)
+ (,$setrtn 3)
+ (,$reg 1)
+ (,$op1 car)
+ (,$invoke 0) ; ((car l))
+ (,$.label 3)
+ (,$.cont)
+ (,$restore 2)
+ (,$pop 2)
+ (,$reg 1)
+ (,$op1 cdr)
+ (,$setreg 1)
+ (,$branch 0))) ; (loop (cdr l))
+
+
+;;; Non-overridable code beyond this point
+
+; Stuff a new symbol into the heap, return its location.
+
+(define (create-symbol! h s)
+ (dump-vector-like!
+ h
+ (vector `(bits ,(dump-string! h (symbol->string s)))
+ '(data 0)
+ '(data ()))
+ dump-tagged-item!
+ $tag.symbol-typetag))
+
+
+; Stuff a value cell into the heap, return a pair of its location
+; and its cell number.
+
+(define (create-cell! h s)
+ (let* ((symtab (heap.symbol-table h))
+ (n (symtab.cell-no symtab))
+ (p (dump-pair! h (cons (undefined)
+ (if (generate-global-symbols)
+ s
+ n)))))
+ (symtab.cell-no! symtab (+ n 1))
+ (cons p n)))
+
+
+(define (construct-startup-procedure symbol-list-addr init-list-addr)
+
+ ; Given some value which might appear in the constant vector,
+ ; replace the entries matching that value with a new value.
+
+ (define (patch-constant-vector! v old new)
+ (let loop ((i (- (vector-length v) 1)))
+ (if (>= i 0)
+ (begin (if (equal? (vector-ref v i) old)
+ (vector-set! v i new))
+ (loop (- i 1))))))
+
+ ; Assemble the startup thunk, patch it, and return it.
+
+ (display "Assembling final procedure") (newline)
+ (let ((e (single-stepping)))
+ (single-stepping #f)
+ (let ((segment (assemble init-proc)))
+ (single-stepping e)
+ (patch-constant-vector! (segment.constants segment)
+ '(data (thunks))
+ `(bits ,init-list-addr))
+ (patch-constant-vector! (segment.constants segment)
+ '(data (symbols))
+ `(bits ,symbol-list-addr))
+ segment)))
+
+
+; Return a list of symbol locations for symbols in the heap, in order.
+
+(define (symbol-locations h)
+ (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
+ (cond ((null? symbols)
+ (reverse res))
+ ((not (null? (symcell.symloc (car symbols))))
+ (loop (cdr symbols)
+ (cons (symcell.symloc (car symbols)) res)))
+ (else
+ (loop (cdr symbols) res)))))
+
+; Return list of variable name to cell number mappings for global vars.
+
+(define (load-map h)
+ (let loop ((symbols (symtab.symbols (heap.symbol-table h))) (res '()))
+ (cond ((null? symbols)
+ (reverse res))
+ ((not (null? (symcell.valloc (car symbols))))
+ (loop (cdr symbols)
+ (cons (cons (symcell.name (car symbols))
+ (symcell.valno (car symbols)))
+ res)))
+ (else
+ (loop (cdr symbols) res)))))
+
+
+(define (write-header h output-file)
+ (delete-file output-file)
+ (call-with-output-file output-file
+ (lambda (out)
+
+ (define (write-word w)
+ (display (integer->char (quotient w twofiftysix^3)) out)
+ (display (integer->char (quotient (remainder w twofiftysix^3)
+ twofiftysix^2))
+ out)
+ (display (integer->char (quotient (remainder w twofiftysix^2)
+ twofiftysix))
+ out)
+ (display (integer->char (remainder w twofiftysix)) out))
+
+ (define (write-roots)
+ (let ((assigned-roots (heap.roots h)))
+ (for-each (lambda (root-name)
+ (let ((probe (assq root-name assigned-roots)))
+ (if probe
+ (write-word (cdr probe))
+ (write-word $imm.false))))
+ heap.root-names)))
+
+ (write-word heap.version-number)
+ (write-roots)
+ (write-word (quotient (heap.top h) 4)))))
+
+
+; This is a gross hack that happens to work very well.
+
+(define (append-file-shell-command file-to-append file-to-append-to)
+
+ (define (message)
+ (display "You must execute the command") (newline)
+ (display " cat ") (display file-to-append)
+ (display " >> ") (display file-to-append-to) (newline)
+ (display "to create the final heap image.") (newline))
+
+ (case host-system
+ ((chez larceny)
+ (display "Creating final image in \"")
+ (display file-to-append-to) (display "\"...") (newline)
+ (if (zero? (system (string-append "cat " file-to-append " >> "
+ file-to-append-to)))
+ (delete-file file-to-append)
+ (begin (display "Failed to create image!")
+ (newline))))
+ (else
+ (message))))
+
+; eof
+; Copyright 1991 Lightship Software, Incorporated.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 11 June 1999 / wdc
+;
+; Asm/Sparc/pass5p2.sch -- Sparc machine assembler, top level
+
+; Overrides the procedure of the same name in Asm/Common/pass5p1.sch.
+
+(define (assembly-table) $sparc-assembly-table$)
+
+; Controls listing of instructions during assembly.
+
+(define listify? #f)
+
+; Table of assembler procedures.
+
+(define $sparc-assembly-table$
+ (make-vector
+ *number-of-mnemonics*
+ (lambda (instruction as)
+ (asm-error "Unrecognized mnemonic " instruction))))
+
+(define (define-instruction i proc)
+ (vector-set! $sparc-assembly-table$ i proc)
+ #t)
+
+(define (list-instruction name instruction)
+ (if listify?
+ (begin (display list-indentation)
+ (display " ")
+ (display name)
+ (display (make-string (max (- 12 (string-length name)) 1)
+ #\space))
+ (if (not (null? (cdr instruction)))
+ (begin (write (cadr instruction))
+ (do ((operands (cddr instruction)
+ (cdr operands)))
+ ((null? operands))
+ (write-char #\,)
+ (write (car operands)))))
+ (newline)
+ (flush-output-port))))
+
+(define (list-label instruction)
+ (if listify?
+ (begin (display list-indentation)
+ (write-char #\L)
+ (write (cadr instruction))
+ (newline))))
+
+(define (list-lambda-start instruction)
+ (list-instruction "lambda" (list $lambda '* (operand2 instruction)))
+ (set! list-indentation (string-append list-indentation "| ")))
+
+(define (list-lambda-end)
+ (set! list-indentation
+ (substring list-indentation
+ 0
+ (- (string-length list-indentation) 4))))
+
+(define list-indentation "")
+
+; Utilities
+
+; Pseudo-instructions.
+
+(define-instruction $.label
+ (lambda (instruction as)
+ (list-label instruction)
+ (sparc.label as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $.proc
+ (lambda (instruction as)
+ (list-instruction ".proc" instruction)
+ #t))
+
+(define-instruction $.proc-doc
+ (lambda (instruction as)
+ (list-instruction ".proc-doc" instruction)
+ (add-documentation as (operand1 instruction))
+ #t))
+
+(define-instruction $.cont
+ (lambda (instruction as)
+ (list-instruction ".cont" instruction)
+ #t))
+
+(define-instruction $.align
+ (lambda (instruction as)
+ (list-instruction ".align" instruction)
+ #t))
+
+(define-instruction $.end
+ (lambda (instruction as)
+ #t))
+
+(define-instruction $.singlestep
+ (lambda (instruction as)
+ (let ((instr (car (as-source as))))
+
+ (define (special?)
+ (let ((op (operand0 instr)))
+ (or (= op $.label)
+ (= op $.proc)
+ (= op $.cont)
+ (= op $.align)
+ (and (= op $load) (= 0 (operand1 instr))))))
+
+ (define (readify-instr)
+ (if (= (operand0 instr) $lambda)
+ (list 'lambda '(...) (caddr instr) (cadddr instr))
+ (car (readify-lap (list instr)))))
+
+ (if (not (special?))
+ (let ((repr (format-object (readify-instr)))
+ (funky? (= (operand0 instr) $restore)))
+ (let ((o (emit-datum as repr)))
+ (emit-singlestep-instr! as funky? 0 o)))))))
+
+
+; Instructions.
+
+(define-instruction $op1
+ (lambda (instruction as)
+ (list-instruction "op1" instruction)
+ (emit-primop.1arg! as (operand1 instruction))))
+
+(define-instruction $op2
+ (lambda (instruction as)
+ (list-instruction "op2" instruction)
+ (emit-primop.2arg! as
+ (operand1 instruction)
+ (regname (operand2 instruction)))))
+
+(define-instruction $op3
+ (lambda (instruction as)
+ (list-instruction "op3" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (regname (operand2 instruction))
+ (regname (operand3 instruction)))))
+
+(define-instruction $op2imm
+ (lambda (instruction as)
+ (list-instruction "op2imm" instruction)
+ (let ((op (case (operand1 instruction)
+ ((+) 'internal:+/imm)
+ ((-) 'internal:-/imm)
+ ((fx+) 'internal:fx+/imm)
+ ((fx-) 'internal:fx-/imm)
+ ((fx=) 'internal:fx=/imm)
+ ((fx<) 'internal:fx</imm)
+ ((fx<=) 'internal:fx<=/imm)
+ ((fx>) 'internal:fx>/imm)
+ ((fx>=) 'internal:fx>=/imm)
+ ((=:fix:fix) 'internal:=:fix:fix/imm)
+ ((<:fix:fix) 'internal:<:fix:fix/imm)
+ ((<=:fix:fix) 'internal:<=:fix:fix/imm)
+ ((>:fix:fix) 'internal:>:fix:fix/imm)
+ ((>=:fix:fix) 'internal:>=:fix:fix/imm)
+ (else #f))))
+ (if op
+ (emit-primop.4arg! as op $r.result (operand2 instruction) $r.result)
+ (begin
+ (emit-constant->register as (operand2 instruction) $r.argreg2)
+ (emit-primop.2arg! as
+ (operand1 instruction)
+ $r.argreg2))))))
+
+(define-instruction $const
+ (lambda (instruction as)
+ (list-instruction "const" instruction)
+ (emit-constant->register as (operand1 instruction) $r.result)))
+
+(define-instruction $global
+ (lambda (instruction as)
+ (list-instruction "global" instruction)
+ (emit-global->register! as
+ (emit-global as (operand1 instruction))
+ $r.result)))
+
+(define-instruction $setglbl
+ (lambda (instruction as)
+ (list-instruction "setglbl" instruction)
+ (emit-register->global! as
+ $r.result
+ (emit-global as (operand1 instruction)))))
+
+; FIXME: A problem is that the listing is messed up because of the delayed
+; assembly; somehow we should fix this by putting an identifying label
+; in the listing and emitting this label later, with the code.
+
+(define-instruction $lambda
+ (lambda (instruction as)
+ (let ((code-offset #f)
+ (const-offset #f))
+ (list-lambda-start instruction)
+ (assemble-nested-lambda as
+ (operand1 instruction)
+ (operand3 instruction) ; documentation
+ (lambda (nested-as segment)
+ (set-constant! as code-offset (car segment))
+ (set-constant! as const-offset (cdr segment))))
+ (list-lambda-end)
+ (set! code-offset (emit-codevector as 0))
+ (set! const-offset (emit-constantvector as 0))
+ (emit-lambda! as
+ code-offset
+ const-offset
+ (operand2 instruction)))))
+
+(define-instruction $lexes
+ (lambda (instruction as)
+ (list-instruction "lexes" instruction)
+ (emit-lexes! as (operand1 instruction))))
+
+(define-instruction $args=
+ (lambda (instruction as)
+ (list-instruction "args=" instruction)
+ (emit-args=! as (operand1 instruction))))
+
+(define-instruction $args>=
+ (lambda (instruction as)
+ (list-instruction "args>=" instruction)
+ (emit-args>=! as (operand1 instruction))))
+
+(define-instruction $invoke
+ (lambda (instruction as)
+ (list-instruction "invoke" instruction)
+ (emit-invoke as (operand1 instruction) #f $m.invoke-ex)))
+
+(define-instruction $restore
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "restore" instruction)
+ (emit-restore! as (operand1 instruction))))))
+
+(define-instruction $pop
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "pop" instruction)
+ (let ((next (next-instruction as)))
+ (if (and (peephole-optimization)
+ (eqv? $return (operand0 next)))
+ (begin (list-instruction "return" next)
+ (consume-next-instruction! as)
+ (emit-pop! as (operand1 instruction) #t))
+ (emit-pop! as (operand1 instruction) #f)))))))
+
+(define-instruction $stack
+ (lambda (instruction as)
+ (list-instruction "stack" instruction)
+ (emit-load! as (operand1 instruction) $r.result)))
+
+(define-instruction $setstk
+ (lambda (instruction as)
+ (list-instruction "setstk" instruction)
+ (emit-store! as $r.result (operand1 instruction))))
+
+(define-instruction $load
+ (lambda (instruction as)
+ (list-instruction "load" instruction)
+ (emit-load! as (operand2 instruction) (regname (operand1 instruction)))))
+
+(define-instruction $store
+ (lambda (instruction as)
+ (list-instruction "store" instruction)
+ (emit-store! as (regname (operand1 instruction)) (operand2 instruction))))
+
+(define-instruction $lexical
+ (lambda (instruction as)
+ (list-instruction "lexical" instruction)
+ (emit-lexical! as (operand1 instruction) (operand2 instruction))))
+
+(define-instruction $setlex
+ (lambda (instruction as)
+ (list-instruction "setlex" instruction)
+ (emit-setlex! as (operand1 instruction) (operand2 instruction))))
+
+(define-instruction $reg
+ (lambda (instruction as)
+ (list-instruction "reg" instruction)
+ (emit-register->register! as (regname (operand1 instruction)) $r.result)))
+
+(define-instruction $setreg
+ (lambda (instruction as)
+ (list-instruction "setreg" instruction)
+ (emit-register->register! as $r.result (regname (operand1 instruction)))))
+
+(define-instruction $movereg
+ (lambda (instruction as)
+ (list-instruction "movereg" instruction)
+ (emit-register->register! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $return
+ (lambda (instruction as)
+ (list-instruction "return" instruction)
+ (emit-return! as)))
+
+(define-instruction $reg/return
+ (lambda (instruction as)
+ (list-instruction "reg/return" instruction)
+ (emit-return-reg! as (regname (operand1 instruction)))))
+
+(define-instruction $const/return
+ (lambda (instruction as)
+ (list-instruction "const/return" instruction)
+ (emit-return-const! as (operand1 instruction))))
+
+(define-instruction $nop
+ (lambda (instruction as)
+ (list-instruction "nop" instruction)))
+
+(define-instruction $save
+ (lambda (instruction as)
+ (if (not (negative? (operand1 instruction)))
+ (begin
+ (list-instruction "save" instruction)
+ (let* ((n (operand1 instruction))
+ (v (make-vector (+ n 1) #t)))
+ (emit-save0! as n)
+ (if (peephole-optimization)
+ (let loop ((instruction (next-instruction as)))
+ (if (eqv? $store (operand0 instruction))
+ (begin (list-instruction "store" instruction)
+ (emit-store! as
+ (regname (operand1 instruction))
+ (operand2 instruction))
+ (consume-next-instruction! as)
+ (vector-set! v (operand2 instruction) #f)
+ (loop (next-instruction as))))))
+ (emit-save1! as v))))))
+
+(define-instruction $setrtn
+ (lambda (instruction as)
+ (list-instruction "setrtn" instruction)
+ (emit-setrtn! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $apply
+ (lambda (instruction as)
+ (list-instruction "apply" instruction)
+ (emit-apply! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $jump
+ (lambda (instruction as)
+ (list-instruction "jump" instruction)
+ (emit-jump! as
+ (operand1 instruction)
+ (make-asm-label as (operand2 instruction)))))
+
+(define-instruction $skip
+ (lambda (instruction as)
+ (list-instruction "skip" instruction)
+ (emit-branch! as #f (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $branch
+ (lambda (instruction as)
+ (list-instruction "branch" instruction)
+ (emit-branch! as #t (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $branchf
+ (lambda (instruction as)
+ (list-instruction "branchf" instruction)
+ (emit-branchf! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $check
+ (lambda (instruction as)
+ (list-instruction "check" instruction)
+ (if (not (unsafe-code))
+ (emit-check! as $r.result
+ (make-asm-label as (operand4 instruction))
+ (list (regname (operand1 instruction))
+ (regname (operand2 instruction))
+ (regname (operand3 instruction)))))))
+
+(define-instruction $trap
+ (lambda (instruction as)
+ (list-instruction "trap" instruction)
+ (emit-trap! as
+ (regname (operand1 instruction))
+ (regname (operand2 instruction))
+ (regname (operand3 instruction))
+ (operand4 instruction))))
+
+(define-instruction $const/setreg
+ (lambda (instruction as)
+ (list-instruction "const/setreg" instruction)
+ (let ((x (operand1 instruction))
+ (r (operand2 instruction)))
+ (if (hwreg? r)
+ (emit-constant->register as x (regname r))
+ (begin (emit-constant->register as x $r.tmp0)
+ (emit-register->register! as $r.tmp0 (regname r)))))))
+
+; Operations introduced by the peephole optimizer.
+
+(define (peep-regname r)
+ (if (eq? r 'RESULT) $r.result (regname r)))
+
+(define-instruction $reg/op1/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op1/branchf" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (make-asm-label as (operand3 instruction)))))
+
+(define-instruction $reg/op2/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op2/branchf" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (make-asm-label as (operand4 instruction)))))
+
+(define-instruction $reg/op2imm/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/branchf" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (make-asm-label as (operand4 instruction)))))
+
+; These three are like the corresponding branchf sequences except that
+; there is a strong prediction that the branch will not be taken.
+
+(define-instruction $reg/op1/check
+ (lambda (instruction as)
+ (list-instruction "reg/op1/check" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (make-asm-label as (operand3 instruction))
+ (map peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op2/check
+ (lambda (instruction as)
+ (list-instruction "reg/op2/check" instruction)
+ (emit-primop.5arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (make-asm-label as (operand4 instruction))
+ (map peep-regname (operand5 instruction)))))
+
+(define-instruction $reg/op2imm/check
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/check" instruction)
+ (emit-primop.5arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (make-asm-label as (operand4 instruction))
+ (map peep-regname (operand5 instruction)))))
+
+;
+
+(define-instruction $reg/op1/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op1/setreg" instruction)
+ (emit-primop.3arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction)))))
+
+(define-instruction $reg/op2/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op2/setreg" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op2imm/setreg
+ (lambda (instruction as)
+ (list-instruction "reg/op2imm/setreg" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (operand3 instruction)
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/op3
+ (lambda (instruction as)
+ (list-instruction "reg/op3" instruction)
+ (emit-primop.4arg! as
+ (operand1 instruction)
+ (peep-regname (operand2 instruction))
+ (peep-regname (operand3 instruction))
+ (peep-regname (operand4 instruction)))))
+
+(define-instruction $reg/branchf
+ (lambda (instruction as)
+ (list-instruction "reg/branchf" instruction)
+ (emit-branchfreg! as
+ (regname (operand1 instruction))
+ (make-asm-label as (operand2 instruction)))))
+
+(define-instruction $setrtn/branch
+ (lambda (instruction as)
+ (list-instruction "setrtn/branch" instruction)
+ (emit-branch-with-setrtn! as (make-asm-label as (operand1 instruction)))))
+
+(define-instruction $setrtn/invoke
+ (lambda (instruction as)
+ (list-instruction "setrtn/invoke" instruction)
+ (emit-invoke as (operand1 instruction) #t $m.invoke-ex)))
+
+(define-instruction $global/setreg
+ (lambda (instruction as)
+ (list-instruction "global/setreg" instruction)
+ (emit-global->register! as
+ (emit-global as (operand1 instruction))
+ (regname (operand2 instruction)))))
+
+(define-instruction $global/invoke
+ (lambda (instruction as)
+ (list-instruction "global/invoke" instruction)
+ (emit-load-global as
+ (emit-global as (operand1 instruction))
+ $r.result
+ #f)
+ (emit-invoke as (operand2 instruction) #f $m.global-invoke-ex)))
+
+(define-instruction $reg/setglbl
+ (lambda (instruction as)
+ (list-instruction "reg/setglbl" instruction)
+ (emit-register->global! as
+ (regname (operand1 instruction))
+ (emit-global as (operand2 instruction)))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999.
+;
+; Asm/Sparc/peepopt.sch -- MAL peephole optimizer, for the SPARC assembler.
+;
+; The procedure `peep' is called on the as structure before every
+; instruction is assembled. It may replace the prefix of the instruction
+; stream by some other instruction sequence.
+;
+; Invariant: if the peephole optimizer doesn't change anything, then
+;
+; (let ((x (as-source as)))
+; (peep as)
+; (eq? x (as-source as))) => #t
+;
+; Note this still isn't right -- it should be integrated with pass5p2 --
+; but it's a step in the right direction.
+
+(define *peephole-table* (make-vector *number-of-mnemonics* #f))
+
+(define (define-peephole n p)
+ (vector-set! *peephole-table* n p)
+ (unspecified))
+
+(define (peep as)
+ (let ((t0 (as-source as)))
+ (if (not (null? t0))
+ (let ((i1 (car t0)))
+ (let ((p (vector-ref *peephole-table* (car i1))))
+ (if p
+ (let* ((t1 (if (null? t0) t0 (cdr t0)))
+ (i2 (if (null? t1) '(-1 0 0 0) (car t1)))
+ (t2 (if (null? t1) t1 (cdr t1)))
+ (i3 (if (null? t2) '(-1 0 0 0) (car t2)))
+ (t3 (if (null? t2) t2 (cdr t2))))
+ (p as i1 i2 i3 t1 t2 t3))))))))
+
+(define-peephole $reg
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $return)
+ (reg-return as i1 i2 t2))
+ ((= (car i2) $setglbl)
+ (reg-setglbl as i1 i2 t2))
+ ((= (car i2) $op1)
+ (cond ((= (car i3) $setreg)
+ (reg-op1-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op1-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op1-check as i1 i2 i3 t3))
+ (else
+ (reg-op1 as i1 i2 t2))))
+ ((= (car i2) $op2)
+ (cond ((= (car i3) $setreg)
+ (reg-op2-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op2-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op2-check as i1 i2 i3 t3))
+ (else
+ (reg-op2 as i1 i2 t2))))
+ ((= (car i2) $op2imm)
+ (cond ((= (car i3) $setreg)
+ (reg-op2imm-setreg as i1 i2 i3 t2 t3))
+ ((= (car i3) $branchf)
+ (reg-op2imm-branchf as i1 i2 i3 t3))
+ ((= (car i3) $check)
+ (reg-op2imm-check as i1 i2 i3 t3))
+ (else
+ (reg-op2imm as i1 i2 t2))))
+ ((= (car i2) $op3)
+ (reg-op3 as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (reg-setreg as i1 i2 t2))
+ ((= (car i2) $branchf)
+ (reg-branchf as i1 i2 t2)))))
+
+(define-peephole $op1
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op1-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op1-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op1-check as i1 i2 t2)))))
+
+(define-peephole $op2
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op2-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op2-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op2-check as i1 i2 t2)))))
+
+(define-peephole $op2imm
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branchf)
+ (op2imm-branchf as i1 i2 t2))
+ ((= (car i2) $setreg)
+ (op2imm-setreg as i1 i2 t2))
+ ((= (car i2) $check)
+ (op2imm-check as i1 i2 t2)))))
+
+(define-peephole $const
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $setreg)
+ (const-setreg as i1 i2 t2))
+ ((= (car i2) $op2)
+ (const-op2 as i1 i2 t2))
+ ((= (car i2) $return)
+ (const-return as i1 i2 t2)))))
+
+(define-peephole $setrtn
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $branch)
+ (cond ((= (car i3) $.align)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $.label)
+ (setrtn-branch as i1 i2 i3 i4 t4))))))))
+ ((= (car i2) $invoke)
+ (cond ((= (car i3) $.align)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $.label)
+ (setrtn-invoke as i1 i2 i3 i4 t4)))))))))))
+
+(define-peephole $branch
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $.align)
+ (cond ((= (car i3) $.label)
+ (branch-and-label as i1 i2 i3 t3)))))))
+
+(define-peephole $global
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $setreg)
+ (global-setreg as i1 i2 t2))
+ ((= (car i2) $invoke)
+ (global-invoke as i1 i2 t2))
+ ((= (car i2) $setrtn)
+ (cond ((= (car i3) $invoke)
+ (global-setrtn-invoke as i1 i2 i3 t3)))))))
+
+(define-peephole $reg/op1/check
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $reg)
+ (cond ((= (car i3) $op1)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $setreg)
+ (reg/op1/check-reg-op1-setreg
+ as i1 i2 i3 i4 t4)))))))))))
+
+(define-peephole $reg/op2/check
+ (lambda (as i1 i2 i3 t1 t2 t3)
+ (cond ((= (car i2) $reg)
+ (cond ((= (car i3) $op2imm)
+ (if (not (null? t3))
+ (let ((i4 (car t3))
+ (t4 (cdr t3)))
+ (cond ((= (car i4) $check)
+ (reg/op2/check-reg-op2imm-check
+ as i1 i2 i3 i4 t4)))))))))))
+
+; Worker procedures.
+
+(define (reg-return as i:reg i:return tail)
+ (let ((rs (operand1 i:reg)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/return rs) tail)))))
+
+(define (reg-op1-setreg as i:reg i:op1 i:setreg tail-1 tail)
+ (let ((rs (operand1 i:reg))
+ (rd (operand1 i:setreg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (if (hwreg? rd)
+ (peep-reg/op1/setreg as op rs rd tail)
+ (peep-reg/op1/setreg as op rs 'RESULT tail-1)))))
+
+(define (reg-op1 as i:reg i:op1 tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (peep-reg/op1/setreg as op rs 'RESULT tail))))
+
+(define (op1-setreg as i:op1 i:setreg tail)
+ (let ((op (operand1 i:op1))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op1/setreg as op 'RESULT rd tail))))
+
+(define (peep-reg/op1/setreg as op rs rd tail)
+ (let ((op (case op
+ ((car) 'internal:car)
+ ((cdr) 'internal:cdr)
+ ((car:pair) 'internal:car:pair)
+ ((cdr:pair) 'internal:cdr:pair)
+ ((cell-ref) 'internal:cell-ref)
+ ((vector-length) 'internal:vector-length)
+ ((vector-length:vec) 'internal:vector-length:vec)
+ ((string-length) 'internal:string-length)
+ ((--) 'internal:--)
+ ((fx--) 'internal:fx--)
+ ((fxpositive?) 'internal:fxpositive?)
+ ((fxnegative?) 'internal:fxnegative?)
+ ((fxzero?) 'internal:fxzero?)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op1/setreg op rs rd) tail)))))
+
+(define (reg-op2-setreg as i:reg i:op2 i:setreg tail-1 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rs1)
+ (if (hwreg? rd)
+ (peep-reg/op2/setreg as op rs1 rs2 rd tail)
+ (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail-1)))))
+
+(define (reg-op2 as i:reg i:op2 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/setreg as op rs1 rs2 'RESULT tail))))
+
+(define (op2-setreg as i:op2 i:setreg tail)
+ (let ((op (operand1 i:op2))
+ (rs2 (operand2 i:op2))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op2/setreg as op 'RESULT rs2 rd tail))))
+
+(define (peep-reg/op2/setreg as op rs1 rs2 rd tail)
+ (let ((op (case op
+ ((+) 'internal:+)
+ ((-) 'internal:-)
+ ((fx+) 'internal:fx+)
+ ((fx-) 'internal:fx-)
+ ((fx=) 'internal:fx=)
+ ((fx>) 'internal:fx>)
+ ((fx>=) 'internal:fx>=)
+ ((fx<) 'internal:fx<)
+ ((fx<=) 'internal:fx<=)
+ ((eq?) 'internal:eq?)
+ ((cons) 'internal:cons)
+ ((vector-ref) 'internal:vector-ref)
+ ((vector-ref:trusted) 'internal:vector-ref:trusted)
+ ((string-ref) 'internal:string-ref)
+ ((set-car!) 'internal:set-car!)
+ ((set-cdr!) 'internal:set-cdr!)
+ ((cell-set!) 'internal:cell-set!)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op2/setreg op rs1 rs2 rd) tail)))))
+
+(define (reg-op2imm-setreg as i:reg i:op2imm i:setreg tail-1 tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rs)
+ (if (hwreg? rd)
+ (peep-reg/op2imm/setreg as op rs imm rd tail)
+ (peep-reg/op2imm/setreg as op rs imm 'RESULT tail-1)))))
+
+(define (reg-op2imm as i:reg i:op2imm tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm)))
+ (if (hwreg? rs)
+ (peep-reg/op2imm/setreg as op rs imm 'RESULT tail))))
+
+(define (op2imm-setreg as i:op2imm i:setreg tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (peep-reg/op2imm/setreg as op 'RESULT imm rd tail))))
+
+(define (peep-reg/op2imm/setreg as op rs imm rd tail)
+ (let ((op (case op
+ ((+) 'internal:+/imm)
+ ((-) 'internal:-/imm)
+ ((fx+) 'internal:fx+/imm)
+ ((fx-) 'internal:fx-/imm)
+ ((fx=) 'internal:fx=/imm)
+ ((fx<) 'internal:fx</imm)
+ ((fx<=) 'internal:fx<=/imm)
+ ((fx>) 'internal:fx>/imm)
+ ((fx>=) 'internal:fx>=/imm)
+ ((eq?) 'internal:eq?/imm)
+ ((vector-ref) 'internal:vector-ref/imm)
+ ((string-ref) 'internal:string-ref/imm)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op2imm/setreg op rs imm rd) tail)))))
+
+(define (reg-op1-branchf as i:reg i:op1 i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (peep-reg/op1/branchf as op rs L tail))))
+
+(define (op1-branchf as i:op1 i:branchf tail)
+ (let ((op (operand1 i:op1))
+ (L (operand1 i:branchf)))
+ (peep-reg/op1/branchf as op 'RESULT L tail)))
+
+(define (peep-reg/op1/branchf as op rs L tail)
+ (let ((op (case op
+ ((null?) 'internal:branchf-null?)
+ ((pair?) 'internal:branchf-pair?)
+ ((zero?) 'internal:branchf-zero?)
+ ((eof-object?) 'internal:branchf-eof-object?)
+ ((fixnum?) 'internal:branchf-fixnum?)
+ ((char?) 'internal:branchf-char?)
+ ((fxzero?) 'internal:branchf-fxzero?)
+ ((fxnegative?) 'internal:branchf-fxnegative?)
+ ((fxpositive?) 'internal:branchf-fxpositive?)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op1/branchf op rs L) tail)))))
+
+(define (reg-op2-branchf as i:reg i:op2 i:branchf tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/branchf as op rs1 rs2 L tail))))
+
+(define (op2-branchf as i:op2 i:branchf tail)
+ (let ((op (operand1 i:op2))
+ (rs2 (operand2 i:op2))
+ (L (operand1 i:branchf)))
+ (peep-reg/op2/branchf as op 'RESULT rs2 L tail)))
+
+(define (peep-reg/op2/branchf as op rs1 rs2 L tail)
+ (let ((op (case op
+ ((<) 'internal:branchf-<)
+ ((>) 'internal:branchf->)
+ ((>=) 'internal:branchf->=)
+ ((<=) 'internal:branchf-<=)
+ ((=) 'internal:branchf-=)
+ ((eq?) 'internal:branchf-eq?)
+ ((char=?) 'internal:branchf-char=?)
+ ((char>=?) 'internal:branchf-char>=?)
+ ((char>?) 'internal:branchf-char>?)
+ ((char<=?) 'internal:branchf-char<=?)
+ ((char<?) 'internal:branchf-char<?)
+ ((fx=) 'internal:branchf-fx=)
+ ((fx>) 'internal:branchf-fx>)
+ ((fx>=) 'internal:branchf-fx>=)
+ ((fx<) 'internal:branchf-fx<)
+ ((fx<=) 'internal:branchf-fx<=)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2/branchf op rs1 rs2 L)
+ tail)))))
+
+(define (reg-op2imm-branchf as i:reg i:op2imm i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (imm (operand2 i:op2imm))
+ (op (operand1 i:op2imm))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (peep-reg/op2imm/branchf as op rs imm L tail))))
+
+(define (op2imm-branchf as i:op2imm i:branchf tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm))
+ (L (operand1 i:branchf)))
+ (peep-reg/op2imm/branchf as op 'RESULT imm L tail)))
+
+(define (peep-reg/op2imm/branchf as op rs imm L tail)
+ (let ((op (case op
+ ((<) 'internal:branchf-</imm)
+ ((>) 'internal:branchf->/imm)
+ ((>=) 'internal:branchf->=/imm)
+ ((<=) 'internal:branchf-<=/imm)
+ ((=) 'internal:branchf-=/imm)
+ ((eq?) 'internal:branchf-eq?/imm)
+ ((char=?) 'internal:branchf-char=?/imm)
+ ((char>=?) 'internal:branchf-char>=?/imm)
+ ((char>?) 'internal:branchf-char>?/imm)
+ ((char<=?) 'internal:branchf-char<=?/imm)
+ ((char<?) 'internal:branchf-char<?/imm)
+ ((fx=) 'internal:branchf-fx=/imm)
+ ((fx>) 'internal:branchf-fx>/imm)
+ ((fx>=) 'internal:branchf-fx>=/imm)
+ ((fx<) 'internal:branchf-fx</imm)
+ ((fx<=) 'internal:branchf-fx<=/imm)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2imm/branchf op rs imm L)
+ tail)))))
+
+; Check optimization.
+
+(define (reg-op1-check as i:reg i:op1 i:check tail)
+ (let ((rs (operand1 i:reg))
+ (op (operand1 i:op1)))
+ (if (hwreg? rs)
+ (peep-reg/op1/check as
+ op
+ rs
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op1-check as i:op1 i:check tail)
+ (let ((op (operand1 i:op1)))
+ (peep-reg/op1/check as
+ op
+ 'RESULT
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op1/check as op rs L1 liveregs tail)
+ (let ((op (case op
+ ((fixnum?) 'internal:check-fixnum?)
+ ((pair?) 'internal:check-pair?)
+ ((vector?) 'internal:check-vector?)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op1/check op rs L1 liveregs)
+ tail)))))
+
+(define (reg-op2-check as i:reg i:op2 i:check tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (if (hwreg? rs1)
+ (peep-reg/op2/check as
+ op
+ rs1
+ rs2
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op2-check as i:op2 i:check tail)
+ (let ((rs2 (operand2 i:op2))
+ (op (operand1 i:op2)))
+ (peep-reg/op2/check as
+ op
+ 'RESULT
+ rs2
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op2/check as op rs1 rs2 L1 liveregs tail)
+ (let ((op (case op
+ ((<:fix:fix) 'internal:check-<:fix:fix)
+ ((<=:fix:fix) 'internal:check-<=:fix:fix)
+ ((>=:fix:fix) 'internal:check->=:fix:fix)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2/check op rs1 rs2 L1 liveregs)
+ tail)))))
+
+(define (reg-op2imm-check as i:reg i:op2imm i:check tail)
+ (let ((rs1 (operand1 i:reg))
+ (op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm)))
+ (if (hwreg? rs1)
+ (peep-reg/op2imm/check as
+ op
+ rs1
+ imm
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail))))
+
+(define (op2imm-check as i:op2imm i:check tail)
+ (let ((op (operand1 i:op2imm))
+ (imm (operand2 i:op2imm)))
+ (peep-reg/op2imm/check as
+ op
+ 'RESULT
+ imm
+ (operand4 i:check)
+ (list (operand1 i:check)
+ (operand2 i:check)
+ (operand3 i:check))
+ tail)))
+
+(define (peep-reg/op2imm/check as op rs1 imm L1 liveregs tail)
+ (let ((op (case op
+ ((<:fix:fix) 'internal:check-<:fix:fix/imm)
+ ((<=:fix:fix) 'internal:check-<=:fix:fix/imm)
+ ((>=:fix:fix) 'internal:check->=:fix:fix/imm)
+ (else #f))))
+ (if op
+ (as-source! as
+ (cons (list $reg/op2imm/check op rs1 imm L1 liveregs)
+ tail)))))
+
+(define (reg/op1/check-reg-op1-setreg as i:ro1check i:reg i:op1 i:setreg tail)
+ (let ((o1 (operand1 i:ro1check))
+ (r1 (operand2 i:ro1check))
+ (r2 (operand1 i:reg))
+ (o2 (operand1 i:op1))
+ (r3 (operand1 i:setreg)))
+ (if (and (eq? o1 'internal:check-vector?)
+ (eq? r1 r2)
+ (eq? o2 'vector-length:vec)
+ (hwreg? r1)
+ (hwreg? r3))
+ (as-source! as
+ (cons (list $reg/op2/check
+ 'internal:check-vector?/vector-length:vec
+ r1
+ r3
+ (operand3 i:ro1check)
+ (operand4 i:ro1check))
+ tail)))))
+
+; Range checks of the form 0 <= i < n can be performed by a single check.
+; This peephole optimization recognizes
+; reg rs1
+; op2 <:fix:fix,rs2
+; check r1,r2,r3,L
+; reg rs1 ; must match earlier reg
+; op2imm >=:fix:fix,0
+; check r1,r2,r3,L ; label must match earlier check
+
+(define (reg/op2/check-reg-op2imm-check
+ as i:ro2check i:reg i:op2imm i:check tail)
+ (let ((o1 (operand1 i:ro2check))
+ (rs1 (operand2 i:ro2check))
+ (rs2 (operand3 i:ro2check))
+ (L1 (operand4 i:ro2check))
+ (live (operand5 i:ro2check))
+ (rs3 (operand1 i:reg))
+ (o2 (operand1 i:op2imm))
+ (x (operand2 i:op2imm))
+ (L2 (operand4 i:check)))
+ (if (and (eq? o1 'internal:check-<:fix:fix)
+ (eq? o2 '>=:fix:fix)
+ (eq? rs1 rs3)
+ (eq? x 0)
+ (eq? L1 L2))
+ (as-source! as
+ (cons (list $reg/op2/check 'internal:check-range
+ rs1 rs2 L1 live)
+ tail)))))
+
+; End of check optimization.
+
+(define (reg-op3 as i:reg i:op3 tail)
+ (let ((rs1 (operand1 i:reg))
+ (rs2 (operand2 i:op3))
+ (rs3 (operand3 i:op3))
+ (op (operand1 i:op3)))
+ (if (hwreg? rs1)
+ (let ((op (case op
+ ((vector-set!) 'internal:vector-set!)
+ ((string-set!) 'internal:string-set!)
+ (else #f))))
+ (if op
+ (as-source! as (cons (list $reg/op3 op rs1 rs2 rs3) tail)))))))
+
+; Reg-setreg is not restricted to hardware registers, as $movereg is
+; a standard instruction.
+
+(define (reg-setreg as i:reg i:setreg tail)
+ (let ((rs (operand1 i:reg))
+ (rd (operand1 i:setreg)))
+ (if (= rs rd)
+ (as-source! as tail)
+ (as-source! as (cons (list $movereg rs rd) tail)))))
+
+(define (reg-branchf as i:reg i:branchf tail)
+ (let ((rs (operand1 i:reg))
+ (L (operand1 i:branchf)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/branchf rs L) tail)))))
+
+(define (const-setreg as i:const i:setreg tail)
+ (let ((c (operand1 i:const))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (as-source! as (cons (list $const/setreg c rd) tail)))))
+
+; Make-vector on vectors of known short length.
+
+(define (const-op2 as i:const i:op2 tail)
+ (let ((vn '#(make-vector:0 make-vector:1 make-vector:2 make-vector:3
+ make-vector:4 make-vector:5 make-vector:6 make-vector:7
+ make-vector:8 make-vector:9))
+ (c (operand1 i:const))
+ (op (operand1 i:op2))
+ (r (operand2 i:op2)))
+ (if (and (eq? op 'make-vector)
+ (fixnum? c)
+ (<= 0 c 9))
+ (as-source! as (cons (list $op2 (vector-ref vn c) r) tail)))))
+
+; Constants that can be synthesized in a single instruction can be
+; moved into RESULT in the delay slot of the return instruction.
+
+(define (const-return as i:const i:return tail)
+ (let ((c (operand1 i:const)))
+ (if (or (and (number? c) (immediate-int? c))
+ (null? c)
+ (boolean? c))
+ (as-source! as (cons (list $const/return c) tail)))))
+
+; This allows the use of hardware 'call' instructions.
+; (setrtn Lx)
+; (branch Ly k)
+; (.align k) Ignored on SPARC
+; (.label Lx)
+; => (setrtn/branch Ly k)
+; (.label Lx)
+
+(define (setrtn-branch as i:setrtn i:branch i:align i:label tail)
+ (let ((return-label (operand1 i:setrtn))
+ (branch-ops (cdr i:branch))
+ (label (operand1 i:label)))
+ (if (= return-label label)
+ (as-source! as (cons (cons $setrtn/branch branch-ops)
+ (cons i:label
+ tail))))))
+
+; Ditto for 'invoke'.
+;
+; Disabled because it does _not_ pay off on the SPARC currently --
+; probably, the dependency created between 'jmpl' and 'st' is not
+; handled well on the test machine (an Ultrasparc). Might work
+; better if the return address were to be kept in a register always.
+
+(define (setrtn-invoke as i:setrtn i:invoke i:align i:label tail)
+ (let ((return-label (operand1 i:setrtn))
+ (invoke-ops (operand1 i:invoke))
+ (label (operand1 i:label)))
+ (if (and #f ; DISABLED
+ (= return-label label))
+ (as-source! as (cons (cons $setrtn/invoke invoke-ops)
+ (cons i:label
+ tail))))))
+
+; Gets rid of spurious branch-to-next-instruction
+; (branch Lx k)
+; (.align y)
+; (.label Lx)
+; => (.align y)
+; (.label Lx)
+
+(define (branch-and-label as i:branch i:align i:label tail)
+ (let ((branch-label (operand1 i:branch))
+ (label (operand1 i:label)))
+ (if (= branch-label label)
+ (as-source! as (cons i:align (cons i:label tail))))))
+
+(define (global-setreg as i:global i:setreg tail)
+ (let ((global (operand1 i:global))
+ (rd (operand1 i:setreg)))
+ (if (hwreg? rd)
+ (as-source! as (cons (list $global/setreg global rd) tail)))))
+
+; Obscure guard: unsafe-code = #t implies that global/invoke will not
+; check the value of the global variable, yet unsafe-code and
+; catch-undefined-globals are supposed to be independent.
+
+(define (global-invoke as i:global i:invoke tail)
+ (let ((global (operand1 i:global))
+ (argc (operand1 i:invoke)))
+ (if (not (and (unsafe-code) (catch-undefined-globals)))
+ (as-source! as (cons (list $global/invoke global argc) tail)))))
+
+; Obscure guard: see comment for previous procedure.
+; FIXME! This implementation is temporary until setrtn-invoke is enabled.
+
+(define (global-setrtn-invoke as i:global i:setrtn i:invoke tail)
+ (let ((global (operand1 i:global))
+ (argc (operand1 i:invoke)))
+ (if (not (and (unsafe-code) (catch-undefined-globals)))
+ (as-source! as (cons i:setrtn
+ (cons (list $global/invoke global argc)
+ tail))))))
+
+(define (reg-setglbl as i:reg i:setglbl tail)
+ (let ((rs (operand1 i:reg))
+ (global (operand1 i:setglbl)))
+ (if (hwreg? rs)
+ (as-source! as (cons (list $reg/setglbl rs global) tail)))))
+
+
+
+; Test code
+
+(define (peeptest istream)
+ (let ((as (make-assembly-structure istream)))
+ (let loop ((l '()))
+ (if (null? (as-source as))
+ (reverse l)
+ (begin (peep as)
+ (let ((a (car (as-source as))))
+ (as-source! as (cdr (as-source as)))
+ (loop (cons a l))))))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC assembler machine parameters & utility procedures.
+;
+; 13 May 1999 / wdc
+
+; Round up to nearest 8.
+
+(define (roundup8 n)
+ (* (quotient (+ n 7) 8) 8))
+
+; Given an integer code for a register, return its register label.
+; This register label is the register number for a h.w. register and the
+; offsets from GLOBALS[ r0 ] for a s.w. register.
+
+(define regname
+ (let ((v (vector $r.reg0 $r.reg1 $r.reg2 $r.reg3 $r.reg4 $r.reg5
+ $r.reg6 $r.reg7 $r.reg8 $r.reg9 $r.reg10 $r.reg11
+ $r.reg12 $r.reg13 $r.reg14 $r.reg15 $r.reg16 $r.reg17
+ $r.reg18 $r.reg19 $r.reg20 $r.reg21 $r.reg22 $r.reg23
+ $r.reg24 $r.reg25 $r.reg26 $r.reg27 $r.reg28 $r.reg29
+ $r.reg30 $r.reg31)))
+ (lambda (r)
+ (vector-ref v r))))
+
+; Is a general-purpose register mapped to a hardware register?
+; This is fragile! FIXME.
+
+(define (hardware-mapped? r)
+ (or (and (>= r $r.reg0) (<= r $r.reg7))
+ (= r $r.argreg2)
+ (= r $r.argreg3)
+ (= r $r.result)
+ (= r $r.g0)
+ (= r $r.tmp0)
+ (= r $r.tmp1)
+ (= r $r.tmp2)))
+
+; Used by peephole optimizer
+
+(define (hwreg? x)
+ (<= 0 x 7))
+
+(define (immediate-int? x)
+ (and (exact? x)
+ (integer? x)
+ (<= -1024 x 1023)))
+
+; Given an exact integer, can it be represented as a fixnum?
+
+(define fixnum-range?
+ (let ((-two^29 (- (expt 2 29)))
+ (two^29-1 (- (expt 2 29) 1)))
+ (lambda (x)
+ (<= -two^29 x two^29-1))))
+
+; Does the integer x fit in the immediate field of an instruction?
+
+(define (immediate-literal? x)
+ (<= -4096 x 4095))
+
+; Return the offset in the %GLOBALS table of the given memory-mapped
+; register. A memory-mapped register is represented by an integer which
+; is its offet, so just return the value.
+
+(define (swreg-global-offset r) r)
+
+; Return a bit representation of a character constant.
+
+(define (char->immediate c)
+ (+ (* (char->integer c) 65536) $imm.character))
+
+; Convert an integer to a fixnum.
+
+(define (thefixnum x) (* x 4))
+
+; The offset of data slot 'n' within a procedure structure, not adjusting
+; for tag. The proc is a header followed by code, const, and then data.
+
+(define (procedure-slot-offset n)
+ (+ 12 (* n 4)))
+
+; Src is a register, hwreg is a hardware register. If src is a
+; hardware register, return src. Otherwise, emit an instruction to load
+; src into hwreg and return hwreg.
+
+(define (force-hwreg! as src hwreg)
+ (if (hardware-mapped? src)
+ src
+ (emit-load-reg! as src hwreg)))
+
+; Given an arbitrary constant opd, generate code to load it into a
+; register r.
+
+(define (emit-constant->register as opd r)
+ (cond ((and (integer? opd) (exact? opd))
+ (if (fixnum-range? opd)
+ (emit-immediate->register! as (thefixnum opd) r)
+ (emit-const->register! as (emit-datum as opd) r)))
+ ((boolean? opd)
+ (emit-immediate->register! as
+ (if (eq? opd #t)
+ $imm.true
+ $imm.false)
+ r))
+ ((equal? opd (eof-object))
+ (emit-immediate->register! as $imm.eof r))
+ ((equal? opd (unspecified))
+ (emit-immediate->register! as $imm.unspecified r))
+ ((equal? opd (undefined))
+ (emit-immediate->register! as $imm.undefined r))
+ ((null? opd)
+ (emit-immediate->register! as $imm.null r))
+ ((char? opd)
+ (emit-immediate->register! as (char->immediate opd) r))
+ (else
+ (emit-const->register! as (emit-datum as opd) r))))
+
+
+; Stuff a bitpattern or symbolic expression into a register.
+; (CONST, for immediate constants.)
+;
+; FIXME(?): if this had access to eval-expr (currently hidden inside the
+; sparc assembler) it could attempt to evaluate symbolic expressions,
+; thereby selecting better code sequences when possible.
+
+(define (emit-immediate->register! as i r)
+ (let ((dest (if (not (hardware-mapped? r)) $r.tmp0 r)))
+ (cond ((and (number? i) (immediate-literal? i))
+ (sparc.set as i dest))
+ ((and (number? i) (zero? (remainder (abs i) 1024)))
+ (sparc.sethi as `(hi ,i) dest))
+ (else
+ (sparc.sethi as `(hi ,i) dest)
+ (sparc.ori as dest `(lo ,i) dest)))
+ (if (not (hardware-mapped? r))
+ (emit-store-reg! as r dest))))
+
+
+; Reference the constants vector and put the constant reference in a register.
+; `offset' is an integer offset into the constants vector (a constant) for
+; the current procedure.
+; Destroys $r.tmp0 and $r.tmp1, but either can be the destination register.
+; (CONST, for structured constants, GLOBAL, SETGLBL, LAMBDA).
+
+(define (emit-const->register! as offset r)
+ (let ((cvlabel (+ 4 (- (* offset 4) $tag.vector-tag))))
+ (cond ((hardware-mapped? r)
+ (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (if (asm:fits? cvlabel 13)
+ (sparc.ldi as $r.tmp0 cvlabel r)
+ (begin (sparc.sethi as `(hi ,cvlabel) $r.tmp1)
+ (sparc.addr as $r.tmp0 $r.tmp1 $r.tmp0)
+ (sparc.ldi as $r.tmp0 `(lo ,cvlabel) r))))
+ (else
+ (emit-const->register! as offset $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)))))
+
+
+
+; Emit single instruction to load sw-mapped reg into another reg, and return
+; the destination reg.
+
+(define (emit-load-reg! as from to)
+ (if (or (hardware-mapped? from) (not (hardware-mapped? to)))
+ (asm-error "emit-load-reg: " from to)
+ (begin (sparc.ldi as $r.globals (swreg-global-offset from) to)
+ to)))
+
+(define (emit-store-reg! as from to)
+ (if (or (not (hardware-mapped? from)) (hardware-mapped? to))
+ (asm-error "emit-store-reg: " from to)
+ (begin (sparc.sti as from (swreg-global-offset to) $r.globals)
+ to)))
+
+; Generic move-reg-to-HW-reg
+
+(define (emit-move2hwreg! as from to)
+ (if (hardware-mapped? from)
+ (sparc.move as from to)
+ (emit-load-reg! as from to))
+ to)
+
+; Evaluation of condition code for value or control.
+;
+; branchf.a is an annulled conditional branch that tests the condition codes
+; and branches if some condition is false.
+; rd is #f or a hardware register.
+; target is #f or a label.
+; Exactly one of rd and target must be #f.
+;
+; (Why isn't this split into two separate procedures? Because dozens of
+; this procedure's callers have the value/control duality, and it saves
+; space to put the test here instead of putting it in each caller.)
+
+(define (emit-evaluate-cc! as branchf.a rd target)
+ (if target
+ (begin (branchf.a as target)
+ (sparc.slot as))
+ (let ((target (new-label)))
+ (branchf.a as target)
+ (sparc.set as $imm.false rd)
+ (sparc.set as $imm.true rd)
+ (sparc.label as target))))
+
+; Code for runtime safety checking.
+
+(define (emit-check! as rs0 L1 liveregs)
+ (sparc.cmpi as rs0 $imm.false)
+ (emit-checkcc! as sparc.be L1 liveregs))
+
+; FIXME: This should call the exception handler for non-continuable exceptions.
+
+(define (emit-trap! as rs1 rs2 rs3 exn)
+ (if (not (= rs3 $r.reg0))
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ (if (not (= rs2 $r.reg0))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (if (not (= rs1 $r.reg0))
+ (emit-move2hwreg! as rs1 $r.result))
+ (millicode-call/numarg-in-reg as $m.exception (thefixnum exn) $r.tmp0))
+
+; Given:
+; an annulled conditional branch that branches
+; if the check is ok
+; a non-annulled conditional branch that branches
+; if the check is not ok
+; #f, or a procedure that takes an assembly segment as
+; argument and emits an instruction that goes into
+; the delay slot of either branch
+; three registers whose contents should be passed to the
+; exception handler if the check is not ok
+; the exception code
+; Emits code to call the millicode exception routine with
+; the given exception code if the condition is false.
+;
+; FIXME: The nop can often be replaced by the instruction that
+; follows it.
+
+(begin
+ '
+(define (emit-checkcc-and-fill-slot!
+ as branch-ok.a branch-bad slot-filler L1)
+ (let* ((situation (list exn rs1 rs2 rs3))
+ (L1 (exception-label as situation)))
+ (if L1
+ (begin (branch-bad as L1)
+ (if slot-filler
+ (slot-filler as)
+ (sparc.nop as)))
+ (let* ((L1 (new-label))
+ (L2 (new-label)))
+ (exception-label-set! as situation L1)
+ (branch-ok.a as L2)
+ (if slot-filler
+ (slot-filler as)
+ (sparc.slot as))
+ (sparc.label as L1)
+ (cond ((= rs3 $r.reg0)
+ #f)
+ ((hardware-mapped? $r.argreg3)
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ ((hardware-mapped? rs3)
+ (emit-store-reg! as rs3 $r.argreg3))
+ (else
+ (emit-move2hwreg! as rs3 $r.tmp0)
+ (emit-store-reg! as $r.tmp0 $r.argreg3)))
+ (if (not (= rs2 $r.reg0))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (if (not (= rs1 $r.reg0))
+ (emit-move2hwreg! as rs1 $r.result))
+ ; FIXME: This should be a non-continuable exception.
+ (sparc.jmpli as $r.millicode $m.exception $r.o7)
+ (emit-immediate->register! as (thefixnum exn) $r.tmp0)
+ (sparc.label as L2)))))
+#f
+)
+
+(define (emit-checkcc! as branch-bad L1 liveregs)
+ (branch-bad as L1)
+ (apply sparc.slot2 as liveregs))
+
+; Generation of millicode calls for non-continuable exceptions.
+
+(begin
+ '
+; To create only one millicode call per code segment per non-continuable
+; exception situation, we use the "as-user" feature of assembly segments.
+; Could use a hash table here.
+
+(define (exception-label as situation)
+ (let ((user-data (as-user as)))
+ (if user-data
+ (let ((exception-labels (assq 'exception-labels user-data)))
+ (if exception-labels
+ (let ((probe (assoc situation (cdr exception-labels))))
+ (if probe
+ (cdr probe)
+ #f))
+ #f))
+ #f)))
+'
+(define (exception-label-set! as situation label)
+ (let ((user-data (as-user as)))
+ (if user-data
+ (let ((exception-labels (assq 'exception-labels user-data)))
+ (if exception-labels
+ (let ((probe (assoc situation (cdr exception-labels))))
+ (if probe
+ (error "COMPILER BUG: Exception situation defined twice")
+ (set-cdr! exception-labels
+ (cons (cons situation label)
+ (cdr exception-labels)))))
+ (begin (as-user! as
+ (cons (list 'exception-labels)
+ user-data))
+ (exception-label-set! as situation label))))
+ (begin (as-user! as '())
+ (exception-label-set! as situation label)))))
+#f
+)
+
+; Millicode calling
+
+(define (millicode-call/0arg as mproc)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.nop as))
+
+(define (millicode-call/1arg as mproc r)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as r $r.argreg2))
+
+(define (millicode-call/1arg-in-result as mproc r)
+ (millicode-call/1arg-in-reg as mproc r $r.result))
+
+(define (millicode-call/1arg-in-reg as mproc rs rd)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as rs rd))
+
+(define (millicode-call/numarg-in-result as mproc num)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.set as num $r.result))
+
+(define (millicode-call/numarg-in-reg as mproc num reg)
+ (if (not (hardware-mapped? reg))
+ (asm-error "millicode-call/numarg-in-reg requires HW register: " reg))
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.set as num reg))
+
+(define (millicode-call/2arg as mproc r1 r2)
+ (emit-move2hwreg! as r1 $r.argreg2)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (emit-move2hwreg! as r2 $r.argreg3))
+
+; NOTE: Don't use TMP0 since TMP0 is sometimes a millicode argument
+; register (for example to m_exception).
+;
+; NOTE: Don't use sparc.set rather than sethi/ori; we need to know that
+; two instructions get generated.
+;
+; FIXME: Should calculate the value if possible to get better precision
+; and to avoid generating a fixup. See emit-return-address! in gen-msi.sch.
+
+(define (millicode-call/ret as mproc label)
+ (cond ((short-effective-addresses)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.addi as $r.o7 `(- ,label (- ,(here as) 4) 8) $r.o7))
+ (else
+ (let ((val `(- ,label (+ ,(here as) 8) 8)))
+ (sparc.sethi as `(hi ,val) $r.tmp1)
+ (sparc.ori as $r.tmp1 `(lo ,val) $r.tmp1)
+ (sparc.jmpli as $r.millicode mproc $r.o7)
+ (sparc.addr as $r.o7 $r.tmp1 $r.o7)))))
+
+(define (check-timer as DESTINATION RETRY)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as DESTINATION)
+ (sparc.slot as)
+ (millicode-call/ret as $m.timer-exception RETRY))
+
+; When the destination and retry labels are the same, and follow the
+; timer check immediately, then this code saves two static instructions.
+
+(define (check-timer0 as)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as (+ (here as) 16))
+ (sparc.slot as)
+ (sparc.jmpli as $r.millicode $m.timer-exception $r.o7)
+ (sparc.nop as))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC machine assembler.
+;
+; The procedure `sparc-instruction' takes an instruction class keyword and
+; some operands and returns an assembler procedure for the instruction
+; denoted by the class and the operands.
+;
+; All assembler procedures for SPARC mnemonics are defined in sparcasm2.sch.
+;
+; The SPARC has 32-bit, big-endian words. All instructions are 1 word.
+; This assembler currently accepts a subset of the SPARC v8 instruction set.
+;
+; Each assembler procedure takes an `as' assembly structure (see
+; Asm/Common/pass5p1.sch) and operands relevant to the instruction, and
+; side-effects the assembly structure by emitting bits for the instruction
+; and any necessary fixups. There are separate instruction mnemonics and
+; assembler procedures for instructions which in the SPARC instruction set
+; are normally considered the "same". For example, the `add' instruction is
+; split into two operations here: `sparc.addr' takes a register as operand2,
+; and `sparc.addi' takes an immediate. We could remove this restriction
+; by using objects with identity rather than numbers for registers, but it
+; does not seem to be an important problem.
+;
+; Operands that denote values (addresses, immediates, offsets) may be
+; expressed using symbolic expressions. These expressions must conform
+; to the following grammar:
+;
+; <expr> --> ( <number> . <obj> ) ; label
+; | <number> ; literal value (exact integer)
+; | (+ <expr> ... ) ; sum
+; | (- <expr> ... ) ; difference
+; | (hi <expr>) ; high 22 bits
+; | (lo <expr>) ; low 10 bits
+;
+; Each assembler procedure will check that its value operand(s) fit in
+; their instruction fields. It is a fatal error for an operand not
+; to fit, and the assembler calls `asm-error' to signal this error.
+; However, in some cases the assembler will instead call the error
+; procedure `asm-value-too-large', which allows the higher-level assembler
+; to retry the assembly with different settings (typically, by splitting
+; a jump instruction into an offset calculation and a jump).
+;
+; Note: the idiom that is seen in this file,
+; (emit-fixup-proc! as (lambda (b l) (fixup b l)))
+; when `fixup' is a local procedure, avoids allocation of the closure
+; except in the cases where the fixup is in fact needed, for gains in
+; speed and reduction in allocation. (Ask me if you want numbers.)
+;
+; If FILL-DELAY-SLOTS returns true, then this assembler supports two
+; distinct mechanisms for filling branch delay slots.
+;
+; An annulled conditional branch or an un-annulled unconditional branch
+; may be followed by the strange instruction SPARC.SLOT, which turns into
+; a nop in the delay slot that may be replaced by copying the instruction
+; at the target of the branch into the delay slot and increasing the branch
+; offset by 4.
+;
+; An un-annulled conditional branch whose target depends upon a known set
+; of general registers, and does not depend upon the condition codes, may
+; be followed by the strange instruction SPARC.SLOT2, which takes any
+; number of registers as operands. This strange instruction turns into
+; nothing at all if the following instruction has no side effects except
+; to the condition codes and/or to a destination register that is distinct
+; from the specified registers plus the stack pointer and %o7; otherwise
+; the SPARC.SLOT2 instruction becomes a nop in the delay slot. The
+; implementation of this uses a buffer that must be cleared when a label
+; is emitted or when the current offset is obtained.
+
+(define sparc-instruction)
+
+(let ((original-emit-label! emit-label!)
+ (original-here here))
+ (set! emit-label!
+ (lambda (as L)
+ (assembler-value! as 'slot2-info #f)
+ (original-emit-label! as L)))
+ (set! here
+ (lambda (as)
+ (assembler-value! as 'slot2-info #f)
+ (original-here as)))
+ 'emit-label!)
+
+(let ((emit! (lambda (as bits)
+ (assembler-value! as 'slot2-info #f)
+ (emit! as bits)))
+ (emit-fixup-proc! (lambda (as proc)
+ (assembler-value! as 'slot2-info #f)
+ (emit-fixup-proc! as proc)))
+ (goes-in-delay-slot2? (lambda (as rd)
+ (let ((regs (assembler-value as 'slot2-info)))
+ (and regs
+ (fill-delay-slots)
+ (not (= rd $r.stkp))
+ (not (= rd $r.o7))
+ (not (memv rd regs)))))))
+
+ (define ibit (asm:bv 0 0 #x20 0)) ; immediate bit: 2^13
+ (define abit (asm:bv #x20 0 0 0)) ; annul bit: 2^29
+ (define zero (asm:bv 0 0 0 0)) ; all zero bits
+
+ (define two^32 (expt 2 32))
+
+ ; Constant expression evaluation. If the expression cannot be
+ ; evaluated, eval-expr returns #f, otherwise a number.
+ ; The symbol table lookup must fail by returning #f.
+
+ (define (eval-expr as e)
+
+ (define (complement x)
+ (modulo (+ two^32 x) two^32))
+
+ (define (hibits e)
+ (cond ((not e) e)
+ ((< e 0)
+ (complement (quotient (complement e) 1024)))
+ (else
+ (quotient e 1024))))
+
+ (define (lobits e)
+ (cond ((not e) e)
+ ((< e 0)
+ (remainder (complement e) 1024))
+ (else
+ (remainder e 1024))))
+
+ (define (evaluate e)
+ (cond ((integer? e) e)
+ ((label? e) (label-value as e))
+ ((eq? 'hi (car e)) (hibits (evaluate (cadr e))))
+ ((eq? 'lo (car e)) (lobits (evaluate (cadr e))))
+ ((eq? '+ (car e))
+ (let loop ((e (cdr e)) (s 0))
+ (if (null? e) s
+ (let ((op (evaluate (car e))))
+ (if (not op) op
+ (loop (cdr e) (+ s op)))))))
+ ((eq? '- (car e))
+ (let loop ((e (cdr e)) (d #f))
+ (if (null? e) d
+ (let ((op (evaluate (car e))))
+ (if (not op) op
+ (loop (cdr e) (if d (- d op) op)))))))
+ (else
+ (signal-error 'badexpr e))))
+
+ (evaluate e))
+
+ ; Common error handling.
+
+ (define (signal-error code . rest)
+ (define msg "SPARC assembler: ")
+ (case code
+ ((badexpr)
+ (asm-error msg "invalid expression " (car rest)))
+ ((toolarge)
+ (asm-error msg "value too large in " (car rest) ": "
+ (cadr rest) " = " (caddr rest)))
+ ((fixup)
+ (asm-error msg "fixup failed in " (car rest) " for " (cadr rest)))
+ ((unaligned)
+ (asm-error msg "unaligned target in " (car rest) ": " (cadr rest)))
+ (else
+ (error "Invalid error code in assembler: " code))))
+
+ ; The following procedures construct instructions by depositing field
+ ; values directly into bytevectors; the location parameter in the dep-*!
+ ; procedures is the address in the bytevector of the most significant byte.
+
+ (define (copy! bv k bits)
+ (bytevector-set! bv k (bytevector-ref bits 0))
+ (bytevector-set! bv (+ k 1) (bytevector-ref bits 1))
+ (bytevector-set! bv (+ k 2) (bytevector-ref bits 2))
+ (bytevector-set! bv (+ k 3) (bytevector-ref bits 3))
+ bv)
+
+ (define (copy bits)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-set! bv 0 (bytevector-ref bits 0))
+ (bytevector-set! bv 1 (bytevector-ref bits 1))
+ (bytevector-set! bv 2 (bytevector-ref bits 2))
+ (bytevector-set! bv 3 (bytevector-ref bits 3))
+ bv))
+
+ (define (copy-instr bv from to)
+ (bytevector-set! bv to (bytevector-ref bv from))
+ (bytevector-set! bv (+ to 1) (bytevector-ref bv (+ from 1)))
+ (bytevector-set! bv (+ to 2) (bytevector-ref bv (+ from 2)))
+ (bytevector-set! bv (+ to 3) (bytevector-ref bv (+ from 3))))
+
+ (define (dep-rs1! bits k rs1)
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (rshl rs1 2)))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (lsh (logand rs1 3) 6))))
+
+ (define (dep-rs2! bits k rs2)
+ (bytevector-set! bits (+ k 3)
+ (logior (bytevector-ref bits (+ k 3)) rs2)))
+
+ (define (dep-rd! bits k rd)
+ (bytevector-set! bits k
+ (logior (bytevector-ref bits k) (lsh rd 1))))
+
+ (define (dep-imm! bits k imm)
+ (cond ((fixnum? imm)
+ (bytevector-set! bits (+ k 3) (logand imm 255))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (logand (rsha imm 8) 31))))
+ ((bytevector? imm)
+ (bytevector-set! bits (+ k 3) (bytevector-ref imm 0))
+ (bytevector-set! bits (+ k 2)
+ (logior (bytevector-ref bits (+ k 2))
+ (logand (bytevector-ref imm 1)
+ 31))))
+ (else
+ (dep-imm! bits k (asm:int->bv imm)))))
+
+ (define (dep-branch-offset! bits k offs)
+ (cond ((fixnum? offs)
+ (if (not (= (logand offs 3) 0))
+ (signal-error 'unaligned "branch" offs))
+ (dep-imm22! bits k (rsha offs 2)))
+ ((bytevector? offs)
+ (if (not (= (logand (bytevector-ref offs 3) 3) 0))
+ (signal-error 'unaligned "branch" (asm:bv->int offs)))
+ (dep-imm22! bits k (asm:rsha offs 2)))
+ (else
+ (dep-branch-offset! bits k (asm:int->bv offs)))))
+
+ (define (dep-imm22! bits k imm)
+ (cond ((fixnum? imm)
+ (bytevector-set! bits (+ k 3) (logand imm 255))
+ (bytevector-set! bits (+ k 2)
+ (logand (rsha imm 8) 255))
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (logand (rsha imm 16) 63))))
+ ((bytevector? imm)
+ (bytevector-set! bits (+ k 3) (bytevector-ref imm 3))
+ (bytevector-set! bits (+ k 2) (bytevector-ref imm 2))
+ (bytevector-set! bits (+ k 1)
+ (logior (bytevector-ref bits (+ k 1))
+ (logand (bytevector-ref imm 1)
+ 63))))
+ (else
+ (dep-imm22! bits k (asm:int->bv imm)))))
+
+ (define (dep-call-offset! bits k offs)
+ (cond ((fixnum? offs)
+ (if (not (= (logand offs 3) 0))
+ (signal-error 'unaligned "call" offs))
+ (bytevector-set! bits (+ k 3) (logand (rsha offs 2) 255))
+ (bytevector-set! bits (+ k 2) (logand (rsha offs 10) 255))
+ (bytevector-set! bits (+ k 1) (logand (rsha offs 18) 255))
+ (bytevector-set! bits k (logior (bytevector-ref bits k)
+ (logand (rsha offs 26) 63))))
+ ((bytevector? offs)
+ (if (not (= (logand (bytevector-ref offs 3) 3) 0))
+ (signal-error 'unaligned "call" (asm:bv->int offs)))
+ (let ((offs (asm:rsha offs 2)))
+ (bytevector-set! bits (+ k 3) (bytevector-ref offs 3))
+ (bytevector-set! bits (+ k 2) (bytevector-ref offs 2))
+ (bytevector-set! bits (+ k 1) (bytevector-ref offs 1))
+ (bytevector-set! bits k (logior (bytevector-ref bits k)
+ (logand (bytevector-ref offs 0)
+ 63)))))
+ (else
+ (dep-call-offset! bits k (asm:int->bv offs)))))
+
+ ; Add 1 to an instruction (to bump a branch offset by 4).
+ ; FIXME: should check for field overflow.
+
+ (define (add1 bv loc)
+ (let* ((r0 (+ (bytevector-ref bv (+ loc 3)) 1))
+ (d0 (logand r0 255))
+ (c0 (rshl r0 8)))
+ (bytevector-set! bv (+ loc 3) d0)
+ (let* ((r1 (+ (bytevector-ref bv (+ loc 2)) c0))
+ (d1 (logand r1 255))
+ (c1 (rshl r1 8)))
+ (bytevector-set! bv (+ loc 2) d1)
+ (let* ((r2 (+ (bytevector-ref bv (+ loc 1)) c1))
+ (d2 (logand r2 255)))
+ (bytevector-set! bv (+ loc 1) d2)))))
+
+ ; For delay slot filling -- uses the assembler value scratchpad in
+ ; the as structure. Delay slot filling is discussed in the comments
+ ; for `branch' and `class-slot', below.
+
+ (define (remember-branch-target as obj)
+ (assembler-value! as 'branch-target obj))
+
+ (define (recover-branch-target as)
+ (assembler-value as 'branch-target))
+
+ ; Mark the instruction at the current address as not being eligible
+ ; for being lifted into a branch delay slot.
+ ;
+ ; FIXME: should perhaps be a hash table; see BOOT-STATUS file for details.
+
+ (define (not-a-delay-slot-instruction as)
+ (assembler-value! as 'not-dsi
+ (cons (here as)
+ (or (assembler-value as 'not-dsi) '()))))
+
+ (define (is-a-delay-slot-instruction? as bv addr)
+ (and (not (memv addr (or (assembler-value as 'not-dsi) '())))
+ (< addr (bytevector-length bv))))
+
+ ; SETHI, etc.
+
+ (define (class-sethi bits)
+ (let ((bits (asm:lsh bits 22)))
+ (lambda (as val rd)
+
+ (define (fixup bv loc)
+ (dep-imm22! bv loc
+ (or (eval-expr as val)
+ (signal-error 'fixup "sethi" val))))
+
+ (define (fixup2 bv loc)
+ (copy! bv loc bits)
+ (dep-rd! bv loc rd)
+ (fixup bv loc))
+
+ (if (goes-in-delay-slot2? as rd)
+ (emit-fixup-proc! as
+ (lambda (b l)
+ (fixup2 b (- l 4))))
+
+ (let ((bits (copy bits))
+ (e (eval-expr as val)))
+ (if e
+ (dep-imm22! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (dep-rd! bits 0 rd)
+ (emit! as bits))))))
+
+ ; NOP is a peculiar sethi
+
+ (define (class-nop i)
+ (let ((instr (class-sethi i)))
+ (lambda (as)
+ (instr as 0 $r.g0))))
+
+
+ ; Branches
+
+ (define (class00b i) (branch #b010 i zero)) ; Un-annulled IU branches.
+ (define (class00a i) (branch #b010 i abit)) ; Annulled IU branches.
+ (define (classf00b i) (branch #b110 i zero)) ; Un-annulled FP branches.
+ (define (classf00a i) (branch #b110 i abit)) ; Annulled FP branches.
+
+ ; The `type' parameter is #b010 for IU branches, #b110 for FP branches.
+ ; The `bits' parameter is the bits for the cond field.
+ ; The `annul' parameter is either `zero' or `abit' (see top of file).
+ ;
+ ; Annuled branches require special treatement for delay slot
+ ; filling based on the `slot' pseudo-instruction.
+ ;
+ ; Strategy: when a branch with the annul bit set is assembled, remember
+ ; its target in a one-element cache in the AS structure. When a slot
+ ; instruction is found (it has its own class) then the cached
+ ; value (possibly a delayed expression) is gotten, and a fixup for the
+ ; slot is registered. When the fixup is later evaluated, the branch
+ ; target instruction can be found, examined, and evaluated.
+ ;
+ ; The cached value is always valid when the slot instruction is assembled,
+ ; because a slot instruction is always directly preceded by an annulled
+ ; branch (which will always set the cache).
+
+ (define (branch type bits annul)
+ ; The delay slot should be filled if this is an annulled branch
+ ; or an unconditional branch.
+ (let ((fill-delay-slot? (or (not (eq? annul zero))
+ (eq? bits #b1000)))
+ (bits (asm:logior (asm:lsh bits 25) (asm:lsh type 22) annul)))
+ (lambda (as target0)
+ (let ((target `(- ,target0 ,(here as))))
+
+ (define (expr)
+ (let ((e (eval-expr as target)))
+ (cond ((not e)
+ e)
+ ((not (zero? (logand e 3)))
+ (signal-error 'unaligned "branch" target0))
+ ((asm:fits? e 24)
+ e)
+ (else
+ (asm-value-too-large as "branch" target e)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-branch-offset! bv loc e)
+ (signal-error 'fixup "branch" target0))))
+
+ (if fill-delay-slot?
+ (remember-branch-target as target0)
+ (remember-branch-target as #f)) ; Clears the cache.
+ (not-a-delay-slot-instruction as)
+ (let ((bits (copy bits))
+ (e (expr)))
+ (if e
+ (dep-branch-offset! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits))))))
+
+ ; Branch delay slot pseudo-instruction.
+ ;
+ ; Get the branch target expression from the cache in the AS structure,
+ ; and if it is not #f, register a fixup procedure for the delay slot that
+ ; will copy the target instruction to the slot and add 4 to the branch
+ ; offset (unless that will overflow the offset or the instruction at the
+ ; target is not suitable for lifting).
+ ;
+ ; It's important that this fixup run _after_ any fixups for the branch
+ ; instruction itself!
+
+ (define (class-slot)
+ (let ((nop-instr (class-nop #b100)))
+ (lambda (as)
+
+ ; The branch target is the expression denoting the target location.
+
+ (define branch-target (recover-branch-target as))
+
+ (define (fixup bv loc)
+ (let ((bt (or (eval-expr as branch-target)
+ (asm-error "Branch fixup: can't happen: "
+ branch-target))))
+ (if (is-a-delay-slot-instruction? as bv bt)
+ (begin
+ (copy-instr bv bt loc)
+ (add1 bv (- loc 4))))))
+
+ (if (and branch-target (fill-delay-slots))
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (nop-instr as))))
+
+ ; Branch delay slot pseudo-instruction 2.
+ ;
+ ; Emit a nop, but record the information that will allow this nop to be
+ ; replaced by a sufficiently harmless ALU instruction.
+
+ (define (class-slot2)
+ (let ((nop-instr (class-nop #b100)))
+ (lambda (as . regs)
+ (nop-instr as)
+ (assembler-value! as 'slot2-info regs))))
+
+ ; ALU stuff, register operand, rdy, wryr. Also: jump.
+
+ (define (class10r bits . extra)
+ (cond ((and (not (null? extra)) (eq? (car extra) 'rdy))
+ (let ((op (class10r bits)))
+ (lambda (as rd)
+ (op as 0 0 rd))))
+ ((and (not (null? extra)) (eq? (car extra) 'wry))
+ (let ((op (class10r bits)))
+ (lambda (as rs)
+ (op as rs 0 0))))
+ (else
+ (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19)))
+ (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (cond (jump?
+ (not-a-delay-slot-instruction as)
+ (emit! as bits))
+ ((goes-in-delay-slot2? as rd)
+ (emit-fixup-proc!
+ as
+ (lambda (bv loc)
+ (copy! bv (- loc 4) bits))))
+ (else
+ (emit! as bits)))))))))
+
+
+ ; ALU stuff, immediate operand, wryi. Also: jump.
+
+ (define (class10i bits . extra)
+ (if (and (not (null? extra)) (eq? (car extra) 'wry))
+ (let ((op (class10i bits)))
+ (lambda (as src)
+ (op as 0 src 0)))
+ (let ((bits (asm:logior (asm:lsh #b10 30) (asm:lsh bits 19) ibit))
+ (jump? (and (not (null? extra)) (eq? (car extra) 'jump))))
+ (lambda (as rs1 e rd)
+
+ (define (expr)
+ (let ((imm (eval-expr as e)))
+ (cond ((not imm)
+ imm)
+ ((asm:fits? imm 13)
+ imm)
+ (jump?
+ (asm-value-too-large as "`jmpli'" e imm))
+ (else
+ (asm-value-too-large as "ALU instruction" e imm)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-imm! bv loc e)
+ (signal-error 'fixup "ALU instruction" e))))
+
+ (let ((bits (copy bits))
+ (e (expr)))
+ (if e
+ (dep-imm! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (dep-rs1! bits 0 rs1)
+ (dep-rd! bits 0 rd)
+ (cond (jump?
+ (not-a-delay-slot-instruction as)
+ (emit! as bits))
+ ((goes-in-delay-slot2? as rd)
+ (emit-fixup-proc!
+ as
+ (lambda (bv loc)
+ (copy! bv (- loc 4) bits))))
+ (else
+ (emit! as bits))))))))
+
+ ; Memory stuff, register operand.
+
+ (define (class11r bits)
+ (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (emit! as bits)))))
+
+ ; Memory stuff, immediate operand.
+
+ (define (class11i bits)
+ (let ((bits (asm:logior (asm:lsh #b11 30) (asm:lsh bits 19) ibit)))
+ (lambda (as rs1 e rd)
+
+ (define (expr)
+ (let ((imm (eval-expr as e)))
+ (cond ((not imm) imm)
+ ((asm:fits? imm 13) imm)
+ (else
+ (signal-error 'toolarge "Memory instruction" e imm)))))
+
+ (define (fixup bv loc)
+ (let ((e (expr)))
+ (if e
+ (dep-imm! bv loc e)
+ (signal-error 'fixup "Memory instruction" e))))
+
+ (let ((bits (copy bits))
+ (e (expr)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rd! bits 0 rd)
+ (if e
+ (dep-imm! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits)))))
+
+ ; For store instructions. The syntax is (st a b c) meaning m[ b+c ] <- a.
+ ; However, on the Sparc, the destination (rd) field is the source of
+ ; a store, so we transform the instruction into (st c b a) and pass it
+ ; to the real store procedure.
+
+ (define (class11sr bits)
+ (let ((store-instr (class11r bits)))
+ (lambda (as a b c)
+ (store-instr as c b a))))
+
+ (define (class11si bits)
+ (let ((store-instr (class11i bits)))
+ (lambda (as a b c)
+ (store-instr as c b a))))
+
+ ; Call is a class all by itself.
+
+ (define (class-call)
+ (let ((code (asm:lsh #b01 30)))
+ (lambda (as target0)
+ (let ((target `(- ,target0 ,(here as))))
+
+ (define (fixup bv loc)
+ (let ((e (eval-expr as target)))
+ (if e
+ (dep-call-offset! bv loc e)
+ (signal-error 'fixup "call" target0))))
+
+ (let ((bits (copy code))
+ (e (eval-expr as target)))
+ (not-a-delay-slot-instruction as)
+ (if e
+ (dep-call-offset! bits 0 e)
+ (emit-fixup-proc! as (lambda (b l) (fixup b l))))
+ (emit! as bits))))))
+
+ (define (class-label)
+ (lambda (as label)
+ (emit-label! as label)))
+
+ ; FP operation, don't set CC.
+
+ (define (class-fpop1 i) (fpop #b110100 i))
+
+ ; FP operation, set CC
+
+ (define (class-fpop2 i) (fpop #b110101 i))
+
+ (define (fpop type opf)
+ (let ((bits (asm:logior (asm:lsh #b10 30)
+ (asm:lsh type 19)
+ (asm:lsh opf 5))))
+ (lambda (as rs1 rs2 rd)
+ (let ((bits (copy bits)))
+ (dep-rs1! bits 0 rs1)
+ (dep-rs2! bits 0 rs2)
+ (dep-rd! bits 0 rd)
+ (emit! as bits)))))
+
+ (set! sparc-instruction
+ (lambda (kwd . ops)
+ (case kwd
+ ((i11) (apply class11i ops))
+ ((r11) (apply class11r ops))
+ ((si11) (apply class11si ops))
+ ((sr11) (apply class11sr ops))
+ ((sethi) (apply class-sethi ops))
+ ((r10) (apply class10r ops))
+ ((i10) (apply class10i ops))
+ ((b00) (apply class00b ops))
+ ((a00) (apply class00a ops))
+ ((call) (apply class-call ops))
+ ((label) (apply class-label ops))
+ ((nop) (apply class-nop ops))
+ ((slot) (apply class-slot ops))
+ ((slot2) (apply class-slot2 ops))
+ ((fb00) (apply classf00b ops))
+ ((fa00) (apply classf00a ops))
+ ((fp) (apply class-fpop1 ops))
+ ((fpcc) (apply class-fpop2 ops))
+ (else
+ (asm-error "sparc-instruction: unrecognized class: " kwd)))))
+ 'sparc-instruction)
+
+; eof
+; Instruction mnemonics
+
+(define sparc.lddi (sparc-instruction 'i11 #b000011))
+(define sparc.lddr (sparc-instruction 'r11 #b000011))
+(define sparc.ldi (sparc-instruction 'i11 #b000000))
+(define sparc.ldr (sparc-instruction 'r11 #b000000))
+(define sparc.ldhi (sparc-instruction 'i11 #b000010))
+(define sparc.ldhr (sparc-instruction 'r11 #b000010))
+(define sparc.ldbi (sparc-instruction 'i11 #b000001))
+(define sparc.ldbr (sparc-instruction 'r11 #b000001))
+(define sparc.lddfi (sparc-instruction 'i11 #b100011))
+(define sparc.lddfr (sparc-instruction 'r11 #b100011))
+(define sparc.stdi (sparc-instruction 'si11 #b000111))
+(define sparc.stdr (sparc-instruction 'sr11 #b000111))
+(define sparc.sti (sparc-instruction 'si11 #b000100))
+(define sparc.str (sparc-instruction 'sr11 #b000100))
+(define sparc.sthi (sparc-instruction 'si11 #b000110))
+(define sparc.sthr (sparc-instruction 'sr11 #b000110))
+(define sparc.stbi (sparc-instruction 'si11 #b000101))
+(define sparc.stbr (sparc-instruction 'sr11 #b000101))
+(define sparc.stdfi (sparc-instruction 'si11 #b100111))
+(define sparc.stdfr (sparc-instruction 'sr11 #b100111))
+(define sparc.sethi (sparc-instruction 'sethi #b100))
+(define sparc.andr (sparc-instruction 'r10 #b000001))
+(define sparc.andrcc (sparc-instruction 'r10 #b010001))
+(define sparc.andi (sparc-instruction 'i10 #b000001))
+(define sparc.andicc (sparc-instruction 'i10 #b010001))
+(define sparc.orr (sparc-instruction 'r10 #b000010))
+(define sparc.orrcc (sparc-instruction 'r10 #b010010))
+(define sparc.ori (sparc-instruction 'i10 #b000010))
+(define sparc.oricc (sparc-instruction 'i10 #b010010))
+(define sparc.xorr (sparc-instruction 'r10 #b000011))
+(define sparc.xorrcc (sparc-instruction 'r10 #b010011))
+(define sparc.xori (sparc-instruction 'i10 #b000011))
+(define sparc.xoricc (sparc-instruction 'i10 #b010011))
+(define sparc.sllr (sparc-instruction 'r10 #b100101))
+(define sparc.slli (sparc-instruction 'i10 #b100101))
+(define sparc.srlr (sparc-instruction 'r10 #b100110))
+(define sparc.srli (sparc-instruction 'i10 #b100110))
+(define sparc.srar (sparc-instruction 'r10 #b100111))
+(define sparc.srai (sparc-instruction 'i10 #b100111))
+(define sparc.addr (sparc-instruction 'r10 #b000000))
+(define sparc.addrcc (sparc-instruction 'r10 #b010000))
+(define sparc.addi (sparc-instruction 'i10 #b000000))
+(define sparc.addicc (sparc-instruction 'i10 #b010000))
+(define sparc.taddrcc (sparc-instruction 'r10 #b100000))
+(define sparc.taddicc (sparc-instruction 'i10 #b100000))
+(define sparc.subr (sparc-instruction 'r10 #b000100))
+(define sparc.subrcc (sparc-instruction 'r10 #b010100))
+(define sparc.subi (sparc-instruction 'i10 #b000100))
+(define sparc.subicc (sparc-instruction 'i10 #b010100))
+(define sparc.tsubrcc (sparc-instruction 'r10 #b100001))
+(define sparc.tsubicc (sparc-instruction 'i10 #b100001))
+(define sparc.smulr (sparc-instruction 'r10 #b001011))
+(define sparc.smulrcc (sparc-instruction 'r10 #b011011))
+(define sparc.smuli (sparc-instruction 'i10 #b001011))
+(define sparc.smulicc (sparc-instruction 'i10 #b011011))
+(define sparc.sdivr (sparc-instruction 'r10 #b001111))
+(define sparc.sdivrcc (sparc-instruction 'r10 #b011111))
+(define sparc.sdivi (sparc-instruction 'i10 #b001111))
+(define sparc.sdivicc (sparc-instruction 'i10 #b011111))
+(define sparc.b (sparc-instruction 'b00 #b1000))
+(define sparc.b.a (sparc-instruction 'a00 #b1000))
+(define sparc.bne (sparc-instruction 'b00 #b1001))
+(define sparc.bne.a (sparc-instruction 'a00 #b1001))
+(define sparc.be (sparc-instruction 'b00 #b0001))
+(define sparc.be.a (sparc-instruction 'a00 #b0001))
+(define sparc.bg (sparc-instruction 'b00 #b1010))
+(define sparc.bg.a (sparc-instruction 'a00 #b1010))
+(define sparc.ble (sparc-instruction 'b00 #b0010))
+(define sparc.ble.a (sparc-instruction 'a00 #b0010))
+(define sparc.bge (sparc-instruction 'b00 #b1011))
+(define sparc.bge.a (sparc-instruction 'a00 #b1011))
+(define sparc.bl (sparc-instruction 'b00 #b0011))
+(define sparc.bl.a (sparc-instruction 'a00 #b0011))
+(define sparc.bgu (sparc-instruction 'b00 #b1100))
+(define sparc.bgu.a (sparc-instruction 'a00 #b1100))
+(define sparc.bleu (sparc-instruction 'b00 #b0100))
+(define sparc.bleu.a (sparc-instruction 'a00 #b0100))
+(define sparc.bcc (sparc-instruction 'b00 #b1101))
+(define sparc.bcc.a (sparc-instruction 'a00 #b1101))
+(define sparc.bcs (sparc-instruction 'b00 #b0101))
+(define sparc.bcs.a (sparc-instruction 'a00 #b0101))
+(define sparc.bpos (sparc-instruction 'b00 #b1110))
+(define sparc.bpos.a (sparc-instruction 'a00 #b1110))
+(define sparc.bneg (sparc-instruction 'b00 #b0110))
+(define sparc.bneg.a (sparc-instruction 'a00 #b0110))
+(define sparc.bvc (sparc-instruction 'b00 #b1111))
+(define sparc.bvc.a (sparc-instruction 'a00 #b1111))
+(define sparc.bvs (sparc-instruction 'b00 #b0111))
+(define sparc.bvs.a (sparc-instruction 'a00 #b0111))
+(define sparc.call (sparc-instruction 'call))
+(define sparc.jmplr (sparc-instruction 'r10 #b111000 'jump))
+(define sparc.jmpli (sparc-instruction 'i10 #b111000 'jump))
+(define sparc.nop (sparc-instruction 'nop #b100))
+(define sparc.ornr (sparc-instruction 'r10 #b000110))
+(define sparc.orni (sparc-instruction 'i10 #b000110))
+(define sparc.ornrcc (sparc-instruction 'r10 #b010110))
+(define sparc.ornicc (sparc-instruction 'i10 #b010110))
+(define sparc.andni (sparc-instruction 'i10 #b000101))
+(define sparc.andnr (sparc-instruction 'r10 #b000101))
+(define sparc.andnicc (sparc-instruction 'i10 #b010101))
+(define sparc.andnrcc (sparc-instruction 'r10 #b010101))
+(define sparc.rdy (sparc-instruction 'r10 #b101000 'rdy))
+(define sparc.wryr (sparc-instruction 'r10 #b110000 'wry))
+(define sparc.wryi (sparc-instruction 'i10 #b110000 'wry))
+(define sparc.fb (sparc-instruction 'fb00 #b1000))
+(define sparc.fb.a (sparc-instruction 'fa00 #b1000))
+(define sparc.fbn (sparc-instruction 'fb00 #b0000))
+(define sparc.fbn.a (sparc-instruction 'fa00 #b0000))
+(define sparc.fbu (sparc-instruction 'fb00 #b0111))
+(define sparc.fbu.a (sparc-instruction 'fa00 #b0111))
+(define sparc.fbg (sparc-instruction 'fb00 #b0110))
+(define sparc.fbg.a (sparc-instruction 'fa00 #b0110))
+(define sparc.fbug (sparc-instruction 'fb00 #b0101))
+(define sparc.fbug.a (sparc-instruction 'fa00 #b0101))
+(define sparc.fbl (sparc-instruction 'fb00 #b0100))
+(define sparc.fbl.a (sparc-instruction 'fa00 #b0100))
+(define sparc.fbul (sparc-instruction 'fb00 #b0011))
+(define sparc.fbul.a (sparc-instruction 'fa00 #b0011))
+(define sparc.fblg (sparc-instruction 'fb00 #b0010))
+(define sparc.fblg.a (sparc-instruction 'fa00 #b0010))
+(define sparc.fbne (sparc-instruction 'fb00 #b0001))
+(define sparc.fbne.a (sparc-instruction 'fa00 #b0001))
+(define sparc.fbe (sparc-instruction 'fb00 #b1001))
+(define sparc.fbe.a (sparc-instruction 'fa00 #b1001))
+(define sparc.fbue (sparc-instruction 'fb00 #b1010))
+(define sparc.fbue.a (sparc-instruction 'fa00 #b1010))
+(define sparc.fbge (sparc-instruction 'fb00 #b1011))
+(define sparc.fbge.a (sparc-instruction 'fa00 #b1011))
+(define sparc.fbuge (sparc-instruction 'fb00 #b1100))
+(define sparc.fbuge.a (sparc-instruction 'fa00 #b1100))
+(define sparc.fble (sparc-instruction 'fb00 #b1101))
+(define sparc.fble.a (sparc-instruction 'fa00 #b1101))
+(define sparc.fbule (sparc-instruction 'fb00 #b1110))
+(define sparc.fbule.a (sparc-instruction 'fa00 #b1110))
+(define sparc.fbo (sparc-instruction 'fb00 #b1111))
+(define sparc.fbo.a (sparc-instruction 'fa00 #b1111))
+(define sparc.faddd (sparc-instruction 'fp #b001000010))
+(define sparc.fsubd (sparc-instruction 'fp #b001000110))
+(define sparc.fmuld (sparc-instruction 'fp #b001001010))
+(define sparc.fdivd (sparc-instruction 'fp #b001001110))
+(define sparc%fnegs (sparc-instruction 'fp #b000000101)) ; See below
+(define sparc%fmovs (sparc-instruction 'fp #b000000001)) ; See below
+(define sparc%fabss (sparc-instruction 'fp #b000001001)) ; See below
+(define sparc%fcmpdcc (sparc-instruction 'fpcc #b001010010)) ; See below
+
+; Strange instructions.
+
+(define sparc.slot (sparc-instruction 'slot))
+(define sparc.slot2 (sparc-instruction 'slot2))
+(define sparc.label (sparc-instruction 'label))
+
+; Aliases.
+
+(define sparc.bnz sparc.bne)
+(define sparc.bnz.a sparc.bne.a)
+(define sparc.bz sparc.be)
+(define sparc.bz.a sparc.be.a)
+(define sparc.bgeu sparc.bcc)
+(define sparc.bgeu.a sparc.bcc.a)
+(define sparc.blu sparc.bcs)
+(define sparc.blu.a sparc.bcs.a)
+
+; Abstractions.
+
+(define (sparc.cmpr as r1 r2) (sparc.subrcc as r1 r2 $r.g0))
+(define (sparc.cmpi as r imm) (sparc.subicc as r imm $r.g0))
+(define (sparc.move as rs rd) (sparc.orr as $r.g0 rs rd))
+(define (sparc.set as imm rd) (sparc.ori as $r.g0 imm rd))
+(define (sparc.btsti as rs imm) (sparc.andicc as rs imm $r.g0))
+(define (sparc.clr as rd) (sparc.move as $r.g0 rd))
+
+(define (sparc.deccc as rs . rest)
+ (let ((k (cond ((null? rest) 1)
+ ((null? (cdr rest)) (car rest))
+ (else (asm-error "sparc.deccc: too many operands: " rest)))))
+ (sparc.subicc as rs k rs)))
+
+; Floating-point abstractions
+;
+; For fmovd, fnegd, and fabsd, we must synthesize the instruction from
+; fmovs, fnegs, and fabss -- SPARC V8 has only the latter. (SPARC V9 add
+; the former.)
+
+(define (sparc.fmovd as rs rd)
+ (sparc%fmovs as rs 0 rd)
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1)))
+
+(define (sparc.fnegd as rs rd)
+ (sparc%fnegs as rs 0 rd)
+ (if (not (= rs rd))
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
+
+(define (sparc.fabsd as rs rd)
+ (sparc%fabss as rs 0 rd)
+ (if (not (= rs rd))
+ (sparc%fmovs as (+ rs 1) 0 (+ rd 1))))
+
+(define (sparc.fcmpd as rs1 rs2)
+ (sparc%fcmpdcc as rs1 rs2 0))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; Asm/Sparc/gen-msi.sch -- SPARC assembler code emitters for
+; core MacScheme instructions
+;
+; 9 May 1999 / wdc
+
+
+; SETGLBL
+;
+; RS must be a hardware register.
+;
+; A global cell is a pair, where the car holds the value.
+
+(define (emit-register->global! as rs offset)
+ (cond ((= rs $r.result)
+ (sparc.move as $r.result $r.argreg2)
+ (emit-const->register! as offset $r.result)
+ (if (write-barrier)
+ (sparc.jmpli as $r.millicode $m.addtrans $r.o7))
+ (sparc.sti as $r.argreg2 (- $tag.pair-tag) $r.result))
+ (else
+ (emit-const->register! as offset $r.result)
+ (sparc.sti as rs (- $tag.pair-tag) $r.result)
+ (if (write-barrier)
+ (millicode-call/1arg as $m.addtrans rs)))))
+
+
+; GLOBAL
+;
+; A global cell is a pair, where the car holds the value.
+; If (catch-undefined-globals) is true, then code will be emitted to
+; check whether the global is #!undefined when loaded. If it is,
+; an exception will be taken, with the global in question in $r.result.
+
+(define (emit-global->register! as offset r)
+ (emit-load-global as offset r (catch-undefined-globals)))
+
+; This leaves the cell in ARGREG2. That fact is utilized by global/invoke
+; to signal an appropriate error message.
+
+(define (emit-load-global as offset r check?)
+
+ (define (emit-undef-check! as r)
+ (if check?
+ (let ((GLOBAL-OK (new-label)))
+ (sparc.cmpi as r $imm.undefined)
+ (sparc.bne.a as GLOBAL-OK)
+ (sparc.slot as)
+ (millicode-call/0arg as $m.global-ex) ; Cell in ARGREG2.
+ (sparc.label as GLOBAL-OK))))
+
+ (emit-const->register! as offset $r.argreg2) ; Load cell.
+ (if (hardware-mapped? r)
+ (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) r)
+ (emit-undef-check! as r))
+ (begin (sparc.ldi as $r.argreg2 (- $tag.pair-tag) $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)
+ (emit-undef-check! as $r.tmp0))))
+
+
+; MOVEREG
+
+(define (emit-register->register! as from to)
+ (if (not (= from to))
+ (cond ((and (hardware-mapped? from) (hardware-mapped? to))
+ (sparc.move as from to))
+ ((hardware-mapped? from)
+ (emit-store-reg! as from to))
+ ((hardware-mapped? to)
+ (emit-load-reg! as from to))
+ (else
+ (emit-load-reg! as from $r.tmp0)
+ (emit-store-reg! as $r.tmp0 to)))))
+
+
+; ARGS=
+
+(define (emit-args=! as n)
+ (if (not (unsafe-code))
+ (let ((L2 (new-label)))
+ (sparc.cmpi as $r.result (thefixnum n)) ; FIXME: limit 1023 args
+ (sparc.be.a as L2)
+ (sparc.slot as)
+ (millicode-call/numarg-in-reg as $m.argc-ex (thefixnum n) $r.argreg2)
+ (sparc.label as L2))))
+
+
+; ARGS>=
+;
+; The cases for 0 and 1 rest arguments are handled in-line; all other
+; cases, including too few, are handled in millicode (really: a C call-out).
+;
+; The fast path only applies when we don't have to mess with the last
+; register, hence the test.
+
+(define (emit-args>=! as n)
+ (let ((L0 (new-label))
+ (L99 (new-label))
+ (L98 (new-label)))
+ (if (< n (- *lastreg* 1))
+ (let ((dest (regname (+ n 1))))
+ (sparc.cmpi as $r.result (thefixnum n)) ; n args
+ (if (hardware-mapped? dest)
+ (begin
+ (sparc.be.a as L99)
+ (sparc.set as $imm.null dest))
+ (begin
+ (sparc.set as $imm.null $r.tmp0)
+ (sparc.be.a as L99)
+ (sparc.sti as $r.tmp0 (swreg-global-offset dest) $r.globals)))
+ (sparc.cmpi as $r.result (thefixnum (+ n 1))) ; n+1 args
+ (sparc.bne.a as L98)
+ (sparc.nop as)
+ (millicode-call/numarg-in-result as $m.alloc 8)
+ (let ((src1 (force-hwreg! as dest $r.tmp1)))
+ (sparc.set as $imm.null $r.tmp0)
+ (sparc.sti as src1 0 $r.result)
+ (sparc.sti as $r.tmp0 4 $r.result)
+ (sparc.addi as $r.result $tag.pair-tag $r.result)
+ (sparc.b as L99)
+ (if (hardware-mapped? dest)
+ (sparc.move as $r.result dest)
+ (sparc.sti as $r.result (swreg-global-offset dest)
+ $r.globals)))))
+ ; General case
+ (sparc.label as L98)
+ (sparc.move as $r.reg0 $r.argreg3) ; FIXME in Sparc/mcode.s
+ (millicode-call/numarg-in-reg as $m.varargs (thefixnum n) $r.argreg2)
+ (sparc.label as L99)))
+
+
+; INVOKE
+; SETRTN/INVOKE
+;
+; Bummed. Can still do better when the procedure to call is in a general
+; register (avoids the redundant move to RESULT preceding INVOKE).
+;
+; Note we must set up the argument count even in unsafe mode, because we
+; may be calling code that was not compiled unsafe.
+
+(define (emit-invoke as n setrtn? mc-exception)
+ (let ((START (new-label))
+ (TIMER-OK (new-label))
+ (PROC-OK (new-label)))
+ (cond ((not (unsafe-code))
+ (sparc.label as START)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne as TIMER-OK)
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (millicode-call/ret as $m.timer-exception START)
+ (sparc.label as TIMER-OK)
+ (sparc.cmpi as $r.tmp0 $tag.procedure-tag)
+ (sparc.be.a as PROC-OK)
+ (sparc.ldi as $r.result $p.codevector $r.tmp0)
+ (millicode-call/ret as mc-exception START)
+ (sparc.label as PROC-OK))
+ (else
+ (sparc.label as START)
+ (sparc.subicc as $r.timer 1 $r.timer)
+ (sparc.bne.a as TIMER-OK)
+ (sparc.ldi as $r.result $p.codevector $r.tmp0)
+ (millicode-call/ret as $m.timer-exception START)
+ (sparc.label as TIMER-OK)))
+ (sparc.move as $r.result $r.reg0)
+ ;; FIXME: limit 1023 args
+ (cond (setrtn?
+ (sparc.set as (thefixnum n) $r.result)
+ (sparc.jmpli as $r.tmp0 $p.codeoffset $r.o7)
+ (sparc.sti as $r.o7 4 $r.stkp))
+ (else
+ (sparc.jmpli as $r.tmp0 $p.codeoffset $r.g0)
+ (sparc.set as (thefixnum n) $r.result)))))
+
+; SAVE -- for new compiler
+;
+; Create stack frame. To avoid confusing the garbage collector, the
+; slots must be initialized to something definite unless they will
+; immediately be initialized by a MacScheme machine store instruction.
+; The creation is done by emit-save0!, and the initialization is done
+; by emit-save1!.
+
+(define (emit-save0! as n)
+ (let* ((L1 (new-label))
+ (L0 (new-label))
+ (framesize (+ 8 (* (+ n 1) 4)))
+ (realsize (roundup8 (+ framesize 4))))
+ (sparc.label as L0)
+ (sparc.subi as $r.stkp realsize $r.stkp)
+ (sparc.cmpr as $r.stklim $r.stkp)
+ (sparc.ble.a as L1)
+ (sparc.set as framesize $r.tmp0)
+ (sparc.addi as $r.stkp realsize $r.stkp)
+ (millicode-call/ret as $m.stkoflow L0)
+ (sparc.label as L1)
+ ; initialize size and return fields of stack frame
+ (sparc.sti as $r.tmp0 0 $r.stkp)
+ (sparc.sti as $r.g0 4 $r.stkp)))
+
+; Given a vector v of booleans, initializes slot i of the stack frame
+; if and only if (vector-ref v i).
+
+(define (emit-save1! as v)
+ (let ((n (vector-length v)))
+ (let loop ((i 0) (offset 12))
+ (cond ((= i n)
+ #t)
+ ((vector-ref v i)
+ (sparc.sti as $r.g0 offset $r.stkp)
+ (loop (+ i 1) (+ offset 4)))
+ (else
+ (loop (+ i 1) (+ offset 4)))))))
+
+
+; RESTORE
+;
+; Restore registers from stack frame
+; FIXME: Use ldd/std here; see comments for emit-save!, above.
+; We pop only actual registers.
+
+(define (emit-restore! as n)
+ (let ((n (min n 31)))
+ (do ((i 0 (+ i 1))
+ (offset 12 (+ offset 4)))
+ ((> i n))
+ (let ((r (regname i)))
+ (if (hardware-mapped? r)
+ (sparc.ldi as $r.stkp offset r)
+ (begin (sparc.ldi as $r.stkp offset $r.tmp0)
+ (emit-store-reg! as $r.tmp0 r)))))))
+
+; POP -- for new compiler
+;
+; Pop frame.
+; If returning?, then emit the return as well and put the pop
+; in its delay slot.
+
+(define (emit-pop! as n returning?)
+ (let* ((framesize (+ 8 (* (+ n 1) 4)))
+ (realsize (roundup8 (+ framesize 4))))
+ (if returning?
+ (begin (sparc.ldi as $r.stkp (+ realsize 4) $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.addi as $r.stkp realsize $r.stkp))
+ (sparc.addi as $r.stkp realsize $r.stkp))))
+
+
+; SETRTN
+;
+; Change the return address in the stack frame.
+
+(define (emit-setrtn! as label)
+ (emit-return-address! as label)
+ (sparc.sti as $r.o7 4 $r.stkp))
+
+
+; APPLY
+;
+; `apply' falls into millicode.
+;
+; The timer check is performed here because it is not very easy for the
+; millicode to do this.
+
+(define (emit-apply! as r1 r2)
+ (let ((L0 (new-label)))
+ (check-timer0 as)
+ (sparc.label as L0)
+ (emit-move2hwreg! as r1 $r.argreg2)
+ (emit-move2hwreg! as r2 $r.argreg3)
+ (millicode-call/0arg as $m.apply)))
+
+
+; LOAD
+
+(define (emit-load! as slot dest-reg)
+ (if (hardware-mapped? dest-reg)
+ (sparc.ldi as $r.stkp (+ 12 (* slot 4)) dest-reg)
+ (begin (sparc.ldi as $r.stkp (+ 12 (* slot 4)) $r.tmp0)
+ (emit-store-reg! as $r.tmp0 dest-reg))))
+
+
+; STORE
+
+(define (emit-store! as k n)
+ (if (hardware-mapped? k)
+ (sparc.sti as k (+ 12 (* n 4)) $r.stkp)
+ (begin (emit-load-reg! as k $r.tmp0)
+ (sparc.sti as $r.tmp0 (+ 12 (* n 4)) $r.stkp))))
+
+
+; LEXICAL
+
+(define (emit-lexical! as m n)
+ (let ((base (emit-follow-chain! as m)))
+ (sparc.ldi as base (- (procedure-slot-offset n) $tag.procedure-tag)
+ $r.result)))
+
+
+; SETLEX
+; FIXME: should allow an in-line barrier
+
+(define (emit-setlex! as m n)
+ (let ((base (emit-follow-chain! as m)))
+ (sparc.sti as $r.result (- (procedure-slot-offset n) $tag.procedure-tag)
+ base)
+ (if (write-barrier)
+ (begin
+ (sparc.move as $r.result $r.argreg2)
+ (millicode-call/1arg-in-result as $m.addtrans base)))))
+
+
+; Follow static links.
+;
+; By using and leaving the result in ARGREG3 rather than in RESULT,
+; we save a temporary register.
+
+(define (emit-follow-chain! as m)
+ (let loop ((q m))
+ (cond ((not (zero? q))
+ (sparc.ldi as
+ (if (= q m) $r.reg0 $r.argreg3)
+ $p.linkoffset
+ $r.argreg3)
+ (loop (- q 1)))
+ ((zero? m)
+ $r.reg0)
+ (else
+ $r.argreg3))))
+
+; RETURN
+
+(define (emit-return! as)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.nop as))
+
+
+; RETURN-REG k
+
+(define (emit-return-reg! as r)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (sparc.move as r $r.result))
+
+
+; RETURN-CONST k
+;
+; The constant c must be synthesizable in a single instruction.
+
+(define (emit-return-const! as c)
+ (sparc.ldi as $r.stkp 4 $r.o7)
+ (sparc.jmpli as $r.o7 8 $r.g0)
+ (emit-constant->register as c $r.result))
+
+
+; MVRTN
+
+(define (emit-mvrtn! as)
+ (asm-error "multiple-value return has not been implemented (yet)."))
+
+
+; LEXES
+
+(define (emit-lexes! as n-slots)
+ (emit-alloc-proc! as n-slots)
+ (sparc.ldi as $r.reg0 $p.codevector $r.tmp0)
+ (sparc.ldi as $r.reg0 $p.constvector $r.tmp1)
+ (sparc.sti as $r.tmp0 $p.codevector $r.result)
+ (sparc.sti as $r.tmp1 $p.constvector $r.result)
+ (emit-init-proc-slots! as n-slots))
+
+
+; LAMBDA
+
+(define (emit-lambda! as code-offs0 const-offs0 n-slots)
+ (let* ((code-offs (+ 4 (- (* 4 code-offs0) $tag.vector-tag)))
+ (const-offs (+ 4 (- (* 4 const-offs0) $tag.vector-tag)))
+ (fits? (asm:fits? const-offs 13)))
+ (emit-alloc-proc! as n-slots)
+ (if fits?
+ (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (sparc.ldi as $r.tmp0 code-offs $r.tmp1))
+ (emit-const->register! as code-offs0 $r.tmp1))
+ (sparc.sti as $r.tmp1 $p.codevector $r.result)
+ (if fits?
+ (begin (sparc.ldi as $r.reg0 $p.constvector $r.tmp0)
+ (sparc.ldi as $r.tmp0 const-offs $r.tmp1))
+ (emit-const->register! as const-offs0 $r.tmp1))
+ (sparc.sti as $r.tmp1 $p.constvector $r.result)
+ (emit-init-proc-slots! as n-slots)))
+
+; Allocate procedure with room for n register slots; return tagged pointer.
+
+(define emit-alloc-proc!
+ (let ((two^12 (expt 2 12)))
+ (lambda (as n)
+ (millicode-call/numarg-in-result as $m.alloc (* (+ n 4) 4))
+ (let ((header (+ (* (* (+ n 3) 4) 256) $imm.procedure-header)))
+ (emit-immediate->register! as header $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (sparc.addi as $r.result $tag.procedure-tag $r.result)))))
+
+; Initialize data slots in procedure from current registers as specified for
+; `lamba' and `lexes'. If there are more data slots than registers, then
+; we must generate code to cdr down the list in the last register to obtain
+; the rest of the data. The list is expected to have at least the minimal
+; length.
+;
+; The tagged pointer to the procedure is in $r.result.
+
+(define (emit-init-proc-slots! as n)
+
+ (define (save-registers lo hi offset)
+ (do ((lo lo (+ lo 1))
+ (offset offset (+ offset 4)))
+ ((> lo hi))
+ (let ((r (force-hwreg! as (regname lo) $r.tmp0)))
+ (sparc.sti as r offset $r.result))))
+
+ (define (save-list lo hi offset)
+ (emit-load-reg! as $r.reg31 $r.tmp0)
+ (do ((lo lo (+ lo 1))
+ (offset offset (+ offset 4)))
+ ((> lo hi))
+ (sparc.ldi as $r.tmp0 (- $tag.pair-tag) $r.tmp1)
+ (sparc.sti as $r.tmp1 offset $r.result)
+ (if (< lo hi)
+ (begin
+ (sparc.ldi as $r.tmp0 (+ (- $tag.pair-tag) 4) $r.tmp0)))))
+
+ (cond ((< n *lastreg*)
+ (save-registers 0 n $p.reg0))
+ (else
+ (save-registers 0 (- *lastreg* 1) $p.reg0)
+ (save-list *lastreg* n (+ $p.reg0 (* *lastreg* 4))))))
+
+; BRANCH
+
+(define (emit-branch! as check-timer? label)
+ (if check-timer?
+ (check-timer as label label)
+ (begin (sparc.b as label)
+ (sparc.slot as))))
+
+
+; BRANCHF
+
+(define (emit-branchf! as label)
+ (emit-branchfreg! as $r.result label))
+
+
+; BRANCHFREG -- introduced by peephole optimization.
+
+(define (emit-branchfreg! as hwreg label)
+ (sparc.cmpi as hwreg $imm.false)
+ (sparc.be.a as label)
+ (sparc.slot as))
+
+
+; BRANCH-WITH-SETRTN -- introduced by peephole optimization
+
+(define (emit-branch-with-setrtn! as label)
+ (check-timer0 as)
+ (sparc.call as label)
+ (sparc.sti as $r.o7 4 $r.stkp))
+
+; JUMP
+;
+; Given the finalization order (outer is finalized before inner is assembled)
+; the label value will always be available when a jump is assembled. The
+; only exception is when m = 0, but does this ever happen? This code handles
+; the case anyway.
+
+(define (emit-jump! as m label)
+ (let* ((r (emit-follow-chain! as m))
+ (labelv (label-value as label))
+ (v (if (number? labelv)
+ (+ labelv $p.codeoffset)
+ (list '+ label $p.codeoffset))))
+ (sparc.ldi as r $p.codevector $r.tmp0)
+ (if (and (number? v) (immediate-literal? v))
+ (sparc.jmpli as $r.tmp0 v $r.g0)
+ (begin (emit-immediate->register! as v $r.tmp1)
+ (sparc.jmplr as $r.tmp0 $r.tmp1 $r.g0)))
+ (sparc.move as r $r.reg0)))
+
+
+; .SINGLESTEP
+;
+; Single step: jump to millicode; pass index of documentation string in
+; %TMP0. Some instructions execute when reg0 is not a valid pointer to
+; the current procedure (because this is just after returning); in this
+; case we restore reg0 from the stack location given by 'funkyloc'.
+
+(define (emit-singlestep-instr! as funky? funkyloc cvlabel)
+ (if funky?
+ (sparc.ldi as $r.stkp (+ (thefixnum funkyloc) 12) $r.reg0))
+ (millicode-call/numarg-in-reg as $m.singlestep
+ (thefixnum cvlabel)
+ $r.argreg2))
+
+
+; Emit the effective address of a label-8 into %o7.
+;
+; There are multiple ways to do this. If the call causes an expensive
+; bubble in the pipeline it is probably much less expensive to grub
+; the code vector address out of the procedure in REG0 and calculate it
+; that way. FIXME: We need to benchmark these options.
+;
+; In general the point is moot as the common-case sequence
+; setrtn L1
+; invoke n
+; L1:
+; should be peephole-optimized into the obvious fast code.
+
+(define (emit-return-address! as label)
+ (let* ((loc (here as))
+ (lloc (label-value as label)))
+
+ (define (emit-short val)
+ (sparc.call as (+ loc 8))
+ (sparc.addi as $r.o7 val $r.o7))
+
+ (define (emit-long val)
+ ; Don't use sparc.set: we need to know that two instructions get
+ ; generated.
+ (sparc.sethi as `(hi ,val) $r.tmp0)
+ (sparc.ori as $r.tmp0 `(lo ,val) $r.tmp0)
+ (sparc.call as (+ loc 16))
+ (sparc.addr as $r.o7 $r.tmp0 $r.o7))
+
+ (cond (lloc
+ (let ((target-rel-addr (- lloc loc 8)))
+ (if (immediate-literal? target-rel-addr)
+ (emit-short target-rel-addr)
+ (emit-long (- target-rel-addr 8)))))
+ ((short-effective-addresses)
+ (emit-short `(- ,label ,loc 8)))
+ (else
+ (emit-long `(- ,label ,loc 16))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 22 April 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 1:
+; primitives defined in Compiler/sparc.imp.sch.
+
+; These extend Asm/Common/pass5p1.sch.
+
+(define (operand5 instruction)
+ (car (cddddr (cdr instruction))))
+
+(define (operand6 instruction)
+ (cadr (cddddr (cdr instruction))))
+
+(define (operand7 instruction)
+ (caddr (cddddr (cdr instruction))))
+
+
+; Primop emitters.
+
+(define (emit-primop.1arg! as op)
+ ((find-primop op) as))
+
+(define (emit-primop.2arg! as op r)
+ ((find-primop op) as r))
+
+(define (emit-primop.3arg! as a1 a2 a3)
+ ((find-primop a1) as a2 a3))
+
+(define (emit-primop.4arg! as a1 a2 a3 a4)
+ ((find-primop a1) as a2 a3 a4))
+
+(define (emit-primop.5arg! as a1 a2 a3 a4 a5)
+ ((find-primop a1) as a2 a3 a4 a5))
+
+(define (emit-primop.6arg! as a1 a2 a3 a4 a5 a6)
+ ((find-primop a1) as a2 a3 a4 a5 a6))
+
+(define (emit-primop.7arg! as a1 a2 a3 a4 a5 a6 a7)
+ ((find-primop a1) as a2 a3 a4 a5 a6 a7))
+
+
+; Hash table of primops
+
+(define primop-vector (make-vector 256 '()))
+
+(define (define-primop name proc)
+ (let ((h (logand (symbol-hash name) 255)))
+ (vector-set! primop-vector h (cons (cons name proc)
+ (vector-ref primop-vector h)))
+ name))
+
+(define (find-primop name)
+ (let ((h (logand (symbol-hash name) 255)))
+ (cdr (assq name (vector-ref primop-vector h)))))
+
+(define (for-each-primop proc)
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length primop-vector)))
+ (for-each (lambda (p)
+ (proc (cdr p)))
+ (vector-ref primop-vector i))))
+
+; Primops
+
+(define-primop 'unspecified
+ (lambda (as)
+ (emit-immediate->register! as $imm.unspecified $r.result)))
+
+(define-primop 'undefined
+ (lambda (as)
+ (emit-immediate->register! as $imm.undefined $r.result)))
+
+(define-primop 'eof-object
+ (lambda (as)
+ (emit-immediate->register! as $imm.eof $r.result)))
+
+(define-primop 'enable-interrupts
+ (lambda (as)
+ (millicode-call/0arg as $m.enable-interrupts)))
+
+(define-primop 'disable-interrupts
+ (lambda (as)
+ (millicode-call/0arg as $m.disable-interrupts)))
+
+(define-primop 'gc-counter
+ (lambda (as)
+ (sparc.ldi as $r.globals $g.gccnt $r.result)))
+
+(define-primop 'zero?
+ (lambda (as)
+ (emit-cmp-primop! as sparc.be.a $m.zerop $r.g0)))
+
+(define-primop '=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.be.a $m.numeq r)))
+
+(define-primop '<
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bl.a $m.numlt r)))
+
+(define-primop '<=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.ble.a $m.numle r)))
+
+(define-primop '>
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bg.a $m.numgt r)))
+
+(define-primop '>=
+ (lambda (as r)
+ (emit-cmp-primop! as sparc.bge.a $m.numge r)))
+
+(define-primop 'complex?
+ (lambda (as)
+ (millicode-call/0arg as $m.complexp)))
+
+(define-primop 'real?
+ (lambda (as)
+ (millicode-call/0arg as $m.realp)))
+
+(define-primop 'rational?
+ (lambda (as)
+ (millicode-call/0arg as $m.rationalp)))
+
+(define-primop 'integer?
+ (lambda (as)
+ (millicode-call/0arg as $m.integerp)))
+
+(define-primop 'exact?
+ (lambda (as)
+ (millicode-call/0arg as $m.exactp)))
+
+(define-primop 'inexact?
+ (lambda (as)
+ (millicode-call/0arg as $m.inexactp)))
+
+(define-primop 'fixnum?
+ (lambda (as)
+ (sparc.btsti as $r.result 3)
+ (emit-set-boolean! as)))
+
+(define-primop '+
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:+ $r.result r $r.result)))
+
+(define-primop '-
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:- $r.result r $r.result)))
+
+(define-primop '*
+ (lambda (as rs2)
+ (emit-multiply-code as rs2 #f)))
+
+(define (emit-multiply-code as rs2 fixnum-arithmetic?)
+ (if (and (unsafe-code) fixnum-arithmetic?)
+ (begin
+ (sparc.srai as $r.result 2 $r.tmp0)
+ (sparc.smulr as $r.tmp0 rs2 $r.result))
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (Lstart (new-label))
+ (Ltagok (new-label))
+ (Loflo (new-label))
+ (Ldone (new-label)))
+ (sparc.label as Lstart)
+ (sparc.orr as $r.result rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.be.a as Ltagok)
+ (sparc.srai as $r.result 2 $r.tmp0)
+ (sparc.label as Loflo)
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (if (not fixnum-arithmetic?)
+ (begin
+ (millicode-call/ret as $m.multiply Ldone))
+ (begin
+ (sparc.set as (thefixnum $ex.fx*) $r.tmp0)
+ (millicode-call/ret as $m.exception Lstart)))
+ (sparc.label as Ltagok)
+ (sparc.smulr as $r.tmp0 rs2 $r.tmp0)
+ (sparc.rdy as $r.tmp1)
+ (sparc.srai as $r.tmp0 31 $r.tmp2)
+ (sparc.cmpr as $r.tmp1 $r.tmp2)
+ (sparc.bne.a as Loflo)
+ (sparc.slot as)
+ (sparc.move as $r.tmp0 $r.result)
+ (sparc.label as Ldone))))
+
+(define-primop '/
+ (lambda (as r)
+ (millicode-call/1arg as $m.divide r)))
+
+(define-primop 'quotient
+ (lambda (as r)
+ (millicode-call/1arg as $m.quotient r)))
+
+(define-primop 'remainder
+ (lambda (as r)
+ (millicode-call/1arg as $m.remainder r)))
+
+(define-primop '--
+ (lambda (as)
+ (emit-negate as $r.result $r.result)))
+
+(define-primop 'round
+ (lambda (as)
+ (millicode-call/0arg as $m.round)))
+
+(define-primop 'truncate
+ (lambda (as)
+ (millicode-call/0arg as $m.truncate)))
+
+(define-primop 'lognot
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-fixnum! as $r.result $ex.lognot))
+ (sparc.ornr as $r.g0 $r.result $r.result) ; argument order matters
+ (sparc.xori as $r.result 3 $r.result)))
+
+(define-primop 'logand
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.andr $ex.logand)))
+
+(define-primop 'logior
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.orr $ex.logior)))
+
+(define-primop 'logxor
+ (lambda (as x)
+ (logical-op as $r.result x $r.result sparc.xorr $ex.logxor)))
+
+; Fixnum shifts.
+;
+; Only positive shifts are meaningful.
+; FIXME: These are incompatible with MacScheme and MIT Scheme.
+; FIXME: need to return to start of sequence after fault.
+
+(define-primop 'lsh
+ (lambda (as x)
+ (emit-shift-operation as $ex.lsh $r.result x $r.result)))
+
+(define-primop 'rshl
+ (lambda (as x)
+ (emit-shift-operation as $ex.rshl $r.result x $r.result)))
+
+(define-primop 'rsha
+ (lambda (as x)
+ (emit-shift-operation as $ex.rsha $r.result x $r.result)))
+
+
+; fixnums only.
+; FIXME: for symmetry with shifts there should be rotl and rotr (?)
+; or perhaps rot should only ever rotate one way.
+; FIXME: implement.
+
+(define-primop 'rot
+ (lambda (as x)
+ (asm-error "Sparcasm: ROT primop is not implemented.")))
+
+(define-primop 'null?
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.null)
+ (emit-set-boolean! as)))
+
+(define-primop 'pair?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.pair-tag)))
+
+(define-primop 'eof-object?
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.eof)
+ (emit-set-boolean! as)))
+
+; Tests the specific representation, not 'flonum or compnum with 0i'.
+
+(define-primop 'flonum?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.flonum-typetag))))
+
+(define-primop 'compnum?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.compnum-typetag))))
+
+(define-primop 'symbol?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.symbol-typetag))))
+
+(define-primop 'port?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.port-typetag))))
+
+(define-primop 'structure?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.structure-typetag))))
+
+(define-primop 'char?
+ (lambda (as)
+ (sparc.andi as $r.result #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (emit-set-boolean! as)))
+
+(define-primop 'string?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.string-typetag))))
+
+(define-primop 'bytevector?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag))))
+
+(define-primop 'bytevector-like?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.bytevector-tag)))
+
+(define-primop 'vector?
+ (lambda (as)
+ (emit-double-tagcheck->bool! as
+ $tag.vector-tag
+ (+ $imm.vector-header
+ $tag.vector-typetag))))
+
+(define-primop 'vector-like?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.vector-tag)))
+
+(define-primop 'procedure?
+ (lambda (as)
+ (emit-single-tagcheck->bool! as $tag.procedure-tag)))
+
+(define-primop 'cons
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:cons $r.result r $r.result)))
+
+(define-primop 'car
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:car $r.result $r.result)))
+
+(define-primop 'cdr
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:cdr $r.result $r.result)))
+
+(define-primop 'car:pair
+ (lambda (as)
+ (sparc.ldi as $r.result (- $tag.pair-tag) $r.result)))
+
+(define-primop 'cdr:pair
+ (lambda (as)
+ (sparc.ldi as $r.result (- 4 $tag.pair-tag) $r.result)))
+
+(define-primop 'set-car!
+ (lambda (as x)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as $tag.pair-tag $ex.car #f))
+ (emit-setcar/setcdr! as $r.result x 0)))
+
+(define-primop 'set-cdr!
+ (lambda (as x)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as $tag.pair-tag $ex.cdr #f))
+ (emit-setcar/setcdr! as $r.result x 4)))
+
+; Cells are internal data structures, represented using pairs.
+; No error checking is done on cell references.
+
+(define-primop 'make-cell
+ (lambda (as)
+ (emit-primop.4arg! as 'internal:cons $r.result $r.g0 $r.result)))
+
+(define-primop 'cell-ref
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:cell-ref $r.result $r.result)))
+
+(define-primop 'cell-set!
+ (lambda (as r)
+ (emit-setcar/setcdr! as $r.result r 0)))
+
+(define-primop 'syscall
+ (lambda (as)
+ (millicode-call/0arg as $m.syscall)))
+
+(define-primop 'break
+ (lambda (as)
+ (millicode-call/0arg as $m.break)))
+
+(define-primop 'creg
+ (lambda (as)
+ (millicode-call/0arg as $m.creg)))
+
+(define-primop 'creg-set!
+ (lambda (as)
+ (millicode-call/0arg as $m.creg-set!)))
+
+(define-primop 'typetag
+ (lambda (as)
+ (millicode-call/0arg as $m.typetag)))
+
+(define-primop 'typetag-set!
+ (lambda (as r)
+ (millicode-call/1arg as $m.typetag-set r)))
+
+(define-primop 'exact->inexact
+ (lambda (as)
+ (millicode-call/0arg as $m.exact->inexact)))
+
+(define-primop 'inexact->exact
+ (lambda (as)
+ (millicode-call/0arg as $m.inexact->exact)))
+
+(define-primop 'real-part
+ (lambda (as)
+ (millicode-call/0arg as $m.real-part)))
+
+(define-primop 'imag-part
+ (lambda (as)
+ (millicode-call/0arg as $m.imag-part)))
+
+(define-primop 'char->integer
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-char! as $ex.char2int #f))
+ (sparc.srli as $r.result 14 $r.result)))
+
+(define-primop 'integer->char
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-fixnum! as $r.result $ex.int2char))
+ (sparc.andi as $r.result #x3FF $r.result)
+ (sparc.slli as $r.result 14 $r.result)
+ (sparc.ori as $r.result $imm.character $r.result)))
+
+(define-primop 'not
+ (lambda (as)
+ (sparc.cmpi as $r.result $imm.false)
+ (emit-set-boolean! as)))
+
+(define-primop 'eq?
+ (lambda (as x)
+ (emit-primop.4arg! as 'internal:eq? $r.result x $r.result)))
+
+(define-primop 'eqv?
+ (lambda (as x)
+ (let ((tmp (force-hwreg! as x $r.tmp0))
+ (L1 (new-label)))
+ (sparc.cmpr as $r.result tmp)
+ (sparc.be.a as L1)
+ (sparc.set as $imm.true $r.result)
+ (millicode-call/1arg as $m.eqv tmp)
+ (sparc.label as L1))))
+
+(define-primop 'make-bytevector
+ (lambda (as)
+ (if (not (unsafe-code))
+ (emit-assert-positive-fixnum! as $r.result $ex.mkbvl))
+ (emit-allocate-bytevector as
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag)
+ #f)
+ (sparc.addi as $r.result $tag.bytevector-tag $r.result)))
+
+(define-primop 'bytevector-fill!
+ (lambda (as rs2)
+ (let* ((fault (emit-double-tagcheck-assert! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header
+ $tag.bytevector-typetag)
+ $ex.bvfill
+ rs2))
+ (rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (sparc.srai as rs2 2 $r.tmp2)
+ (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0)
+ (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.tmp1)
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (emit-bytevector-fill as $r.tmp0 $r.tmp1 $r.tmp2))))
+
+(define-primop 'bytevector-length
+ (lambda (as)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvlen
+ $r.result
+ $r.result)))
+
+(define-primop 'bytevector-like-length
+ (lambda (as)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ #f
+ $ex.bvllen
+ $r.result
+ $r.result)))
+
+(define-primop 'bytevector-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvref
+ r)
+ #f)))
+ (emit-bytevector-like-ref! as $r.result r $r.result fault #f #t))))
+
+(define-primop 'bytevector-like-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.bytevector-tag
+ $ex.bvlref
+ r)
+ #f)))
+ (emit-bytevector-like-ref! as $r.result r $r.result fault #f #f))))
+
+(define-primop 'bytevector-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.bytevector-typetag)
+ $ex.bvset
+ r1)
+ #f)))
+ (emit-bytevector-like-set! as r1 r2 fault #t))))
+
+(define-primop 'bytevector-like-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.bytevector-tag
+ $ex.bvlset
+ r1)
+ #f)))
+ (emit-bytevector-like-set! as r1 r2 fault #f))))
+
+(define-primop 'sys$bvlcmp
+ (lambda (as x)
+ (millicode-call/1arg as $m.bvlcmp x)))
+
+; Strings
+
+; RESULT must have nonnegative fixnum.
+; RS2 must have character.
+
+(define-primop 'make-string
+ (lambda (as rs2)
+ (let ((FAULT (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (let ((L1 (new-label))
+ (L2 (new-label)))
+ (sparc.tsubrcc as $r.result $r.g0 $r.g0)
+ (sparc.bvc.a as L1)
+ (sparc.andi as rs2 255 $r.tmp0)
+ (sparc.label as FAULT)
+ (if (not (= rs2 $r.argreg2))
+ (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum $ex.mkbvl) $r.tmp0) ; Wrong code.
+ (millicode-call/ret as $m.exception START)
+ (sparc.label as L1)
+ (sparc.bl as FAULT)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne as FAULT)
+ (sparc.move as $r.result $r.argreg3))
+ (begin
+ (sparc.move as $r.result $r.argreg3)))
+ (emit-allocate-bytevector as
+ (+ $imm.bytevector-header
+ $tag.string-typetag)
+ $r.argreg3)
+ (sparc.srai as rs2 16 $r.tmp1)
+ (sparc.addi as $r.result 4 $r.result)
+ (sparc.srai as $r.argreg3 2 $r.tmp0)
+ (emit-bytevector-fill as $r.tmp0 $r.result $r.tmp1)
+ (sparc.addi as $r.result (- $tag.bytevector-tag 4) $r.result)))))
+
+(define-primop 'string-length
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:string-length $r.result $r.result)))
+
+(define-primop 'string-ref
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:string-ref $r.result r $r.result)))
+
+(define-primop 'string-set!
+ (lambda (as r1 r2)
+ (emit-string-set! as $r.result r1 r2)))
+
+(define-primop 'sys$partial-list->vector
+ (lambda (as r)
+ (millicode-call/1arg as $m.partial-list->vector r)))
+
+(define-primop 'make-procedure
+ (lambda (as)
+ (emit-make-vector-like! as
+ '()
+ $imm.procedure-header
+ $tag.procedure-tag)))
+
+(define-primop 'make-vector
+ (lambda (as r)
+ (emit-make-vector-like! as
+ r
+ (+ $imm.vector-header $tag.vector-typetag)
+ $tag.vector-tag)))
+
+(define-primop 'make-vector:0
+ (lambda (as r) (make-vector-n as 0 r)))
+
+(define-primop 'make-vector:1
+ (lambda (as r) (make-vector-n as 1 r)))
+
+(define-primop 'make-vector:2
+ (lambda (as r) (make-vector-n as 2 r)))
+
+(define-primop 'make-vector:3
+ (lambda (as r) (make-vector-n as 3 r)))
+
+(define-primop 'make-vector:4
+ (lambda (as r) (make-vector-n as 4 r)))
+
+(define-primop 'make-vector:5
+ (lambda (as r) (make-vector-n as 5 r)))
+
+(define-primop 'make-vector:6
+ (lambda (as r) (make-vector-n as 6 r)))
+
+(define-primop 'make-vector:7
+ (lambda (as r) (make-vector-n as 7 r)))
+
+(define-primop 'make-vector:8
+ (lambda (as r) (make-vector-n as 8 r)))
+
+(define-primop 'make-vector:9
+ (lambda (as r) (make-vector-n as 9 r)))
+
+(define-primop 'vector-length
+ (lambda (as)
+ (emit-primop.3arg! as 'internal:vector-length $r.result $r.result)))
+
+(define-primop 'vector-like-length
+ (lambda (as)
+ (emit-get-length! as $tag.vector-tag #f $ex.vllen $r.result $r.result)))
+
+(define-primop 'vector-length:vec
+ (lambda (as)
+ (emit-get-length-trusted! as $tag.vector-tag $r.result $r.result)))
+
+(define-primop 'procedure-length
+ (lambda (as)
+ (emit-get-length! as $tag.procedure-tag #f $ex.plen $r.result $r.result)))
+
+(define-primop 'vector-ref
+ (lambda (as r)
+ (emit-primop.4arg! as 'internal:vector-ref $r.result r $r.result)))
+
+(define-primop 'vector-like-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.vector-tag
+ $ex.vlref
+ r)
+ #f)))
+ (emit-vector-like-ref!
+ as $r.result r $r.result fault $tag.vector-tag #f))))
+
+(define-primop 'vector-ref:trusted
+ (lambda (as rs2)
+ (emit-vector-like-ref-trusted!
+ as $r.result rs2 $r.result $tag.vector-tag)))
+
+(define-primop 'procedure-ref
+ (lambda (as r)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.procedure-tag
+ $ex.pref
+ r)
+ #f)))
+ (emit-vector-like-ref!
+ as $r.result r $r.result fault $tag.procedure-tag #f))))
+
+(define-primop 'vector-set!
+ (lambda (as r1 r2)
+ (emit-primop.4arg! as 'internal:vector-set! $r.result r1 r2)))
+
+(define-primop 'vector-like-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.vector-tag
+ $ex.vlset
+ r1)
+ #f)))
+ (emit-vector-like-set! as $r.result r1 r2 fault $tag.vector-tag #f))))
+
+(define-primop 'vector-set!:trusted
+ (lambda (as rs2 rs3)
+ (emit-vector-like-set-trusted! as $r.result rs2 rs3 $tag.vector-tag)))
+
+(define-primop 'procedure-set!
+ (lambda (as r1 r2)
+ (let ((fault (if (not (unsafe-code))
+ (emit-single-tagcheck-assert! as
+ $tag.procedure-tag
+ $ex.pset
+ r1)
+ #f)))
+ (emit-vector-like-set! as $r.result r1 r2 fault $tag.procedure-tag #f))))
+
+(define-primop 'char<?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bl.a $ex.char<?)))
+
+(define-primop 'char<=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.ble.a $ex.char<=?)))
+
+(define-primop 'char=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.be.a $ex.char=?)))
+
+(define-primop 'char>?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bg.a $ex.char>?)))
+
+(define-primop 'char>=?
+ (lambda (as x)
+ (emit-char-cmp as x sparc.bge.a $ex.char>=?)))
+
+; Experimental (for performance).
+; This makes massive assumptions about the layout of the port structure:
+; A port is a vector-like where
+; #0 = port.input?
+; #4 = port.buffer
+; #7 = port.rd-lim
+; #8 = port.rd-ptr
+; See Lib/iosys.sch for more information.
+
+(define-primop 'sys$read-char
+ (lambda (as)
+ (let ((Lfinish (new-label))
+ (Lend (new-label)))
+ (if (not (unsafe-code))
+ (begin
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0) ; mask argument tag
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag); vector-like?
+ (sparc.bne as Lfinish) ; skip if not vector-like
+ (sparc.nop as)
+ (sparc.ldbi as $r.RESULT 0 $r.tmp1))) ; header byte
+ (sparc.ldi as $r.RESULT 1 $r.tmp2) ; port.input? or garbage
+ (if (not (unsafe-code))
+ (begin
+ (sparc.cmpi as $r.tmp1 $hdr.port) ; port?
+ (sparc.bne as Lfinish))) ; skip if not port
+ (sparc.cmpi as $r.tmp2 $imm.false) ; [slot] input port?
+ (sparc.be as Lfinish) ; skip if not active port
+ (sparc.ldi as $r.RESULT (+ 1 32) $r.tmp1) ; [slot] port.rd-ptr
+ (sparc.ldi as $r.RESULT (+ 1 28) $r.tmp2) ; port.rd-lim
+ (sparc.ldi as $r.RESULT (+ 1 16) $r.tmp0) ; port.buffer
+ (sparc.cmpr as $r.tmp1 $r.tmp2) ; rd-ptr < rd-lim?
+ (sparc.bge as Lfinish) ; skip if rd-ptr >= rd-lim
+ (sparc.subi as $r.tmp0 1 $r.tmp0) ; [slot] addr of string@0
+ (sparc.srai as $r.tmp1 2 $r.tmp2) ; rd-ptr as native int
+ (sparc.ldbr as $r.tmp0 $r.tmp2 $r.tmp2) ; get byte from string
+ (sparc.addi as $r.tmp1 4 $r.tmp1) ; bump rd-ptr
+ (sparc.sti as $r.tmp1 (+ 1 32) $r.RESULT) ; store rd-ptr in port
+ (sparc.slli as $r.tmp2 16 $r.tmp2) ; convert to char #1
+ (sparc.b as Lend)
+ (sparc.ori as $r.tmp2 $imm.character $r.RESULT) ; [slot] convert to char
+ (sparc.label as Lfinish)
+ (sparc.set as $imm.false $r.RESULT) ; failed
+ (sparc.label as Lend))))
+
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 2:
+; primitives introduced by peephole optimization.
+
+(define-primop 'internal:car
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:car src1 dest)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as
+ $tag.pair-tag src1 #f $ex.car))
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:cdr
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cdr src1 dest)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as
+ $tag.pair-tag src1 #f $ex.cdr))
+ (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
+
+(define-primop 'internal:cell-ref
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cell-ref src1 dest)
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:set-car!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:set-car! rs1 dest-ignored)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.car))
+ (emit-setcar/setcdr! as rs1 rs2 0)))
+
+(define-primop 'internal:set-cdr!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:set-cdr! rs1 dest-ignored)
+ (if (not (unsafe-code))
+ (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.cdr))
+ (emit-setcar/setcdr! as rs1 rs2 4)))
+
+(define-primop 'internal:cell-set!
+ (lambda (as rs1 rs2 dest-ignored)
+ (internal-primop-invariant2 'internal:cell-set! rs1 dest-ignored)
+ (emit-setcar/setcdr! as rs1 rs2 0)))
+
+; CONS
+;
+; One instruction reduced here translates into about 2.5KB reduction in the
+; size of the basic heap image. :-)
+;
+; In the out-of-line case, if rd != RESULT then a garbage value is left
+; in RESULT, but it always looks like a fixnum, so it's OK.
+
+(define-primop 'internal:cons
+ (lambda (as rs1 rs2 rd)
+ (if (inline-allocation)
+ (let ((ENOUGH-MEMORY (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (sparc.addi as $r.e-top 8 $r.e-top)
+ (sparc.cmpr as $r.e-top $r.e-limit)
+ (sparc.ble.a as ENOUGH-MEMORY)
+ (sparc.sti as rs1 -8 $r.e-top)
+ (millicode-call/ret as $m.gc START)
+ (sparc.label as ENOUGH-MEMORY)
+ (sparc.sti as (force-hwreg! as rs2 $r.tmp0) -4 $r.e-top)
+ (sparc.subi as $r.e-top (- 8 $tag.pair-tag) rd))
+ (begin
+ (if (= rs1 $r.result)
+ (sparc.move as $r.result $r.argreg2))
+ (millicode-call/numarg-in-result as $m.alloc 8)
+ (if (= rs1 $r.result)
+ (sparc.sti as $r.argreg2 0 $r.result)
+ (sparc.sti as rs1 0 $r.result))
+ (sparc.sti as (force-hwreg! as rs2 $r.tmp1) 4 $r.result)
+ (sparc.addi as $r.result $tag.pair-tag rd)))))
+
+(define-primop 'internal:car:pair
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:car src1 dest)
+ (sparc.ldi as src1 (- $tag.pair-tag) dest)))
+
+(define-primop 'internal:cdr:pair
+ (lambda (as src1 dest)
+ (internal-primop-invariant2 'internal:cdr src1 dest)
+ (sparc.ldi as src1 (- 4 $tag.pair-tag) dest)))
+
+; Vector operations.
+
+(define-primop 'internal:vector-length
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:vector-length rs rd)
+ (emit-get-length! as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ $ex.vlen
+ rs
+ rd)))
+
+(define-primop 'internal:vector-ref
+ (lambda (as rs1 rs2 rd)
+ (internal-primop-invariant2 'internal:vector-ref rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ rs2
+ $ex.vref))))
+ (emit-vector-like-ref! as rs1 rs2 rd fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-ref/imm
+ (lambda (as rs1 imm rd)
+ (internal-primop-invariant2 'internal:vector-ref/imm rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/imm!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ imm
+ $ex.vref))))
+ (emit-vector-like-ref/imm! as rs1 imm rd fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-set!
+ (lambda (as rs1 rs2 rs3)
+ (internal-primop-invariant1 'internal:vector-set! rs1)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.vector-tag
+ (+ $imm.vector-header $tag.vector-typetag)
+ rs1
+ rs2
+ $ex.vset))))
+ (emit-vector-like-set! as rs1 rs2 rs3 fault $tag.vector-tag #t))))
+
+(define-primop 'internal:vector-length:vec
+ (lambda (as rs1 dst)
+ (internal-primop-invariant2 'internal:vector-length:vec rs1 dst)
+ (emit-get-length-trusted! as $tag.vector-tag rs1 dst)))
+
+(define-primop 'internal:vector-ref:trusted
+ (lambda (as rs1 rs2 dst)
+ (emit-vector-like-ref-trusted! as rs1 rs2 dst $tag.vector-tag)))
+
+(define-primop 'internal:vector-set!:trusted
+ (lambda (as rs1 rs2 rs3)
+ (emit-vector-like-ref-trusted! as rs1 rs2 rs3 $tag.vector-tag)))
+
+; Strings.
+
+(define-primop 'internal:string-length
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:string-length rs rd)
+ (emit-get-length! as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ $ex.slen
+ rs
+ rd)))
+
+(define-primop 'internal:string-ref
+ (lambda (as rs1 rs2 rd)
+ (internal-primop-invariant2 'internal:string-ref rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/reg!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1
+ rs2
+ $ex.sref))))
+ (emit-bytevector-like-ref! as rs1 rs2 rd fault #t #t))))
+
+(define-primop 'internal:string-ref/imm
+ (lambda (as rs1 imm rd)
+ (internal-primop-invariant2 'internal:string-ref/imm rs1 rd)
+ (let ((fault (if (not (unsafe-code))
+ (emit-double-tagcheck-assert-reg/imm!
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1
+ imm
+ $ex.sref))))
+ (emit-bytevector-like-ref/imm! as rs1 imm rd fault #t #t))))
+
+(define-primop 'internal:string-set!
+ (lambda (as rs1 rs2 rs3)
+ (internal-primop-invariant1 'internal:string-set! rs1)
+ (emit-string-set! as rs1 rs2 rs3)))
+
+(define-primop 'internal:+
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:+ src1 dest)
+ (emit-arith-primop! as sparc.taddrcc sparc.subr $m.add src1 src2 dest #t)))
+
+(define-primop 'internal:+/imm
+ (lambda (as src1 imm dest)
+ (internal-primop-invariant2 'internal:+/imm src1 dest)
+ (emit-arith-primop! as sparc.taddicc sparc.subi $m.add src1 imm dest #f)))
+
+(define-primop 'internal:-
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:- src1 dest)
+ (emit-arith-primop! as sparc.tsubrcc sparc.addr $m.subtract
+ src1 src2 dest #t)))
+
+(define-primop 'internal:-/imm
+ (lambda (as src1 imm dest)
+ (internal-primop-invariant2 'internal:-/imm src1 dest)
+ (emit-arith-primop! as sparc.tsubicc sparc.addi $m.subtract
+ src1 imm dest #f)))
+
+(define-primop 'internal:--
+ (lambda (as rs rd)
+ (internal-primop-invariant2 'internal:-- rs rd)
+ (emit-negate as rs rd)))
+
+(define-primop 'internal:branchf-null?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:branchf-null? reg)
+ (sparc.cmpi as reg $imm.null)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-pair?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:branchf-pair? reg)
+ (sparc.andi as reg $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.pair-tag)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-zero?
+ (lambda (as reg label)
+ (internal-primop-invariant1 'internal:brancf-zero? reg)
+ (emit-bcmp-primop! as sparc.bne.a reg $r.g0 label $m.zerop #t)))
+
+(define-primop 'internal:branchf-eof-object?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-eof-object? rs)
+ (sparc.cmpi as rs $imm.eof)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-fixnum?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-fixnum? rs)
+ (sparc.btsti as rs 3)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-char?
+ (lambda (as rs label)
+ (internal-primop-invariant1 'internal:branchf-char? rs)
+ (sparc.andi as rs 255 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+(define-primop 'internal:branchf-=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-= src1)
+ (emit-bcmp-primop! as sparc.bne.a src1 src2 label $m.numeq #t)))
+
+(define-primop 'internal:branchf-<
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-< src1)
+ (emit-bcmp-primop! as sparc.bge.a src1 src2 label $m.numlt #t)))
+
+(define-primop 'internal:branchf-<=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-<= src1)
+ (emit-bcmp-primop! as sparc.bg.a src1 src2 label $m.numle #t)))
+
+(define-primop 'internal:branchf->
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-> src1)
+ (emit-bcmp-primop! as sparc.ble.a src1 src2 label $m.numgt #t)))
+
+(define-primop 'internal:branchf->=
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf->= src1)
+ (emit-bcmp-primop! as sparc.bl.a src1 src2 label $m.numge #t)))
+
+(define-primop 'internal:branchf-=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-=/imm src1)
+ (emit-bcmp-primop! as sparc.bne.a src1 imm label $m.numeq #f)))
+
+(define-primop 'internal:branchf-</imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-</imm src1)
+ (emit-bcmp-primop! as sparc.bge.a src1 imm label $m.numlt #f)))
+
+(define-primop 'internal:branchf-<=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf-<=/imm src1)
+ (emit-bcmp-primop! as sparc.bg.a src1 imm label $m.numle #f)))
+
+(define-primop 'internal:branchf->/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf->/imm src1)
+ (emit-bcmp-primop! as sparc.ble.a src1 imm label $m.numgt #f)))
+
+(define-primop 'internal:branchf->=/imm
+ (lambda (as src1 imm label)
+ (internal-primop-invariant1 'internal:branchf->=/imm src1)
+ (emit-bcmp-primop! as sparc.bl.a src1 imm label $m.numge #f)))
+
+(define-primop 'internal:branchf-char=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char=? src1)
+ (emit-char-bcmp-primop! as sparc.bne.a src1 src2 label $ex.char=?)))
+
+(define-primop 'internal:branchf-char<=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char<=? src1)
+ (emit-char-bcmp-primop! as sparc.bg.a src1 src2 label $ex.char<=?)))
+
+(define-primop 'internal:branchf-char<?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char<? src1)
+ (emit-char-bcmp-primop! as sparc.bge.a src1 src2 label $ex.char<?)))
+
+(define-primop 'internal:branchf-char>=?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char>=? src1)
+ (emit-char-bcmp-primop! as sparc.bl.a src1 src2 label $ex.char>=?)))
+
+(define-primop 'internal:branchf-char>?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-char>=? src1)
+ (emit-char-bcmp-primop! as sparc.ble.a src1 src2 label $ex.char>?)))
+
+(define-primop 'internal:branchf-char=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bne.a src imm label $ex.char=?)))
+
+(define-primop 'internal:branchf-char>=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char>=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bl.a src imm label $ex.char>=?)))
+
+(define-primop 'internal:branchf-char>?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char>?/imm src)
+ (emit-char-bcmp-primop! as sparc.ble.a src imm label $ex.char>?)))
+
+(define-primop 'internal:branchf-char<=?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char<=?/imm src)
+ (emit-char-bcmp-primop! as sparc.bg.a src imm label $ex.char<=?)))
+
+(define-primop 'internal:branchf-char<?/imm
+ (lambda (as src imm label)
+ (internal-primop-invariant1 'internal:branchf-char<?/imm src)
+ (emit-char-bcmp-primop! as sparc.bge.a src imm label $ex.char<?)))
+
+(define-primop 'internal:eq?
+ (lambda (as src1 src2 dest)
+ (internal-primop-invariant2 'internal:eq? src1 dest)
+ (let ((tmp (force-hwreg! as src2 $r.tmp0)))
+ (sparc.cmpr as src1 tmp)
+ (emit-set-boolean-reg! as dest))))
+
+(define-primop 'internal:eq?/imm
+ (lambda (as rs imm rd)
+ (internal-primop-invariant2 'internal:eq?/imm rs rd)
+ (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
+ ((eq? imm #t) (sparc.cmpi as rs $imm.true))
+ ((eq? imm #f) (sparc.cmpi as rs $imm.false))
+ ((null? imm) (sparc.cmpi as rs $imm.null))
+ (else ???))
+ (emit-set-boolean-reg! as rd)))
+
+(define-primop 'internal:branchf-eq?
+ (lambda (as src1 src2 label)
+ (internal-primop-invariant1 'internal:branchf-eq? src1)
+ (let ((src2 (force-hwreg! as src2 $r.tmp0)))
+ (sparc.cmpr as src1 src2)
+ (sparc.bne.a as label)
+ (sparc.slot as))))
+
+(define-primop 'internal:branchf-eq?/imm
+ (lambda (as rs imm label)
+ (internal-primop-invariant1 'internal:branchf-eq?/imm rs)
+ (cond ((fixnum? imm) (sparc.cmpi as rs (thefixnum imm)))
+ ((eq? imm #t) (sparc.cmpi as rs $imm.true))
+ ((eq? imm #f) (sparc.cmpi as rs $imm.false))
+ ((null? imm) (sparc.cmpi as rs $imm.null))
+ (else ???))
+ (sparc.bne.a as label)
+ (sparc.slot as)))
+
+; Unary predicates followed by a check.
+
+(define-primop 'internal:check-fixnum?
+ (lambda (as src L1 liveregs)
+ (sparc.btsti as src 3)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-pair?
+ (lambda (as src L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.pair-tag)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-vector?
+ (lambda (as src L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag)
+ (sparc.bne as L1)
+ (sparc.nop as)
+ (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 $imm.vector-header)
+ (emit-checkcc! as sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-vector?/vector-length:vec
+ (lambda (as src dst L1 liveregs)
+ (sparc.andi as src $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $tag.vector-tag)
+ (sparc.bne as L1)
+ (sparc.nop as)
+ (sparc.ldi as src (- $tag.vector-tag) $r.tmp0)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 $imm.vector-header)
+ (sparc.bne as L1)
+ (apply sparc.slot2 as liveregs)
+ (sparc.srli as $r.tmp0 8 dst)))
+
+(define (internal-primop-invariant2 name a b)
+ (if (not (and (hardware-mapped? a) (hardware-mapped? b)))
+ (asm-error "SPARC assembler internal invariant violated by " name
+ " on operands " a " and " b)))
+
+(define (internal-primop-invariant1 name a)
+ (if (not (hardware-mapped? a))
+ (asm-error "SPARC assembler internal invariant violated by " name
+ " on operand " a)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC code generation macros for primitives, part 3a:
+; helper procedures for scalars.
+
+
+; LOGAND, LOGIOR, LOGXOR: logical operations on fixnums.
+;
+; Input: Registers rs1 and rs2, both of which can be general registers.
+; In addition, rs1 can be RESULT, and rs2 can be ARGREG2.
+; Output: Register dest, which can be a general register or RESULT.
+
+(define (logical-op as rs1 rs2 dest op excode)
+
+ (define (fail rs1 rs2 L0)
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0))
+
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (let ((rs1 (force-hwreg! as rs1 $r.result))
+ (rs2 (force-hwreg! as rs2 $r.argreg2))
+ (u (unsafe-code))
+ (d (hardware-mapped? dest)))
+ (cond ((and u d)
+ (op as rs1 rs2 dest))
+ ((and u (not d))
+ (op as rs1 rs2 $r.tmp0)
+ (emit-store-reg! as $r.tmp0 dest))
+ ((and (not u) d)
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.bz.a as L1)
+ (op as rs1 rs2 dest)
+ (fail rs1 rs2 L0)
+ (sparc.label as L1))
+ (else
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.bz.a as L1)
+ (op as rs1 rs2 $r.tmp0)
+ (fail rs1 rs2 L0)
+ (sparc.label as L1)
+ (emit-store-reg! as $r.tmp0 dest))))))
+
+
+; LSH, RSHA, RSHL: Bitwise shifts on fixnums.
+;
+; Notes for future contemplation:
+; - The semantics do not match those of MIT Scheme or MacScheme: only
+; positive shifts are allowed.
+; - The names do not match the fixnum-specific procedures of Chez Scheme
+; that have the same semantics: fxsll, fxsra, fxsrl.
+; - This code checks that the second argument is in range; if it did
+; not, then we could get a MOD for free. Probably too hardware-dependent
+; to worry about.
+; - The range 0..31 for the shift count is curious given that the fixnum
+; is 30-bit.
+
+(define (emit-shift-operation as exn rs1 rs2 rd)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (let ((L0 (new-label))
+ (FAULT (new-label))
+ (START (new-label)))
+ (sparc.label as START)
+ (sparc.btsti as rs1 3) ; RS1 fixnum?
+ (sparc.be.a as L0)
+ (sparc.andi as rs2 #x7c $r.g0) ; RS2 fixnum and 0 <= RS2 < 32?
+ (sparc.label as FAULT)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2))
+ (emit-move2hwreg! as rs2 $r.argreg2))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception START)
+ (sparc.label as L0)
+ (sparc.bne as FAULT)
+ (sparc.srai as rs2 2 $r.tmp1))
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ (cond ((= exn $ex.lsh)
+ (sparc.sllr as rs1 $r.tmp1 rd))
+ ((= exn $ex.rshl)
+ (sparc.srlr as rs1 $r.tmp1 rd)
+ (sparc.andni as rd 3 rd))
+ ((= exn $ex.rsha)
+ (sparc.srar as rs1 $r.tmp1 rd)
+ (sparc.andni as rd 3 rd))
+ (else ???))))
+
+
+; Set result on condition code.
+;
+; The processor's zero bit has been affected by a previous instruction.
+; If the bit is set, store #t in RESULT, otherwise store #f in RESULT.
+
+(define (emit-set-boolean! as)
+ (emit-set-boolean-reg! as $r.result))
+
+
+; Set on condition code.
+;
+; The processor's zero bit has been affected by a previous instruction.
+; If the bit is set, store #t in the processor register 'dest', otherwise
+; store #f in 'dest'.
+
+(define (emit-set-boolean-reg! as dest)
+ (let ((L1 (new-label)))
+ (sparc.set as $imm.true dest)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false dest)
+ (sparc.label as L1)))
+
+
+; Representation predicate.
+
+(define (emit-single-tagcheck->bool! as tag)
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag)
+ (emit-set-boolean! as))
+
+(define (emit-single-tagcheck-assert! as tag1 excode reg2)
+ (emit-single-tagcheck-assert-reg! as tag1 $r.result reg2 excode))
+
+(define (emit-single-tagcheck-assert-reg! as tag1 reg reg2 excode)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as reg $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (fault-if-ne as excode #f #f reg reg2 L0)))
+
+; Assert that a machine register has a fixnum in it.
+; Returns the label of the fault code.
+
+(define (emit-assert-fixnum! as reg excode)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.btsti as reg 3)
+ (fault-if-ne as excode #f #f reg #f L0)))
+
+; Assert that RESULT has a character in it.
+; Returns the label of the fault code.
+
+(define (emit-assert-char! as excode fault-label)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as $r.result #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (fault-if-ne as excode #f fault-label #f #f L0)))
+
+; Generate code for fault handling if the zero flag is not set.
+; - excode is the nativeint exception code.
+; - cont-label, if not #f, is the label to go to if there is no fault.
+; - fault-label, if not #f, is the label of an existing fault handler.
+; - reg1, if not #f, is the number of a register which must be
+; moved into RESULT before the fault handler is called.
+; - reg2, if not #f, is the number of a register which must be moved
+; into ARGREG2 before the fault handler is called.
+; - ret-label, if not #f, is the return address to be set up before calling
+; the fault handler.
+;
+; Ret-label and fault-label cannot simultaneously be non-#f; in this case
+; the ret-label is ignored (since the existing fault handler most likely
+; sets up the return in the desired manner).
+
+(define (fault-if-ne as excode cont-label fault-label reg1 reg2 ret-label)
+ (if fault-label
+ (begin
+ (if (and reg2 (not (= reg2 $r.argreg2)))
+ (emit-move2hwreg! as reg2 $r.argreg2))
+ (sparc.bne as fault-label)
+ (if (and reg1 (not (= reg1 $r.result)))
+ (sparc.move as reg1 $r.result)
+ (sparc.nop as))
+ fault-label)
+ (let ((FAULT (new-label))
+ (L1 (new-label)))
+ (sparc.be.a as (or cont-label L1))
+ (sparc.slot as)
+ (sparc.label as FAULT)
+ (if (and reg1 (not (= reg1 $r.result)))
+ (sparc.move as reg1 $r.result))
+ (if (and reg2 (not (= reg2 $r.argreg2)))
+ (emit-move2hwreg! as reg2 $r.argreg2))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception (or ret-label L1))
+ (if (or (not cont-label) (not ret-label))
+ (sparc.label as L1))
+ FAULT)))
+
+; This is more expensive than what is good for it (5 cycles in the usual case),
+; but there does not seem to be a better way.
+
+(define (emit-assert-positive-fixnum! as reg excode)
+ (let ((L1 (new-label))
+ (L2 (new-label))
+ (L3 (new-label)))
+ (sparc.label as L2)
+ (sparc.tsubrcc as reg $r.g0 $r.g0)
+ (sparc.bvc as L1)
+ (sparc.nop as)
+ (sparc.label as L3)
+ (if (not (= reg $r.result))
+ (sparc.move as reg $r.result))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception l2)
+ (sparc.label as L1)
+ (sparc.bl as L3)
+ (sparc.nop as)
+ L3))
+
+
+; Arithmetic comparison with boolean result.
+
+(define (emit-cmp-primop! as branch_t.a generic r)
+ (let ((Ltagok (new-label))
+ (Lcont (new-label))
+ (r (force-hwreg! as r $r.argreg2)))
+ (sparc.tsubrcc as $r.result r $r.g0)
+ (sparc.bvc.a as Ltagok)
+ (sparc.set as $imm.false $r.result)
+ (if (not (= r $r.argreg2))
+ (sparc.move as r $r.argreg2))
+ (millicode-call/ret as generic Lcont)
+ (sparc.label as Ltagok)
+ (branch_t.a as Lcont)
+ (sparc.set as $imm.true $r.result)
+ (sparc.label as Lcont)))
+
+
+; Arithmetic comparison and branch.
+;
+; This code does not use the chained branch trick (DCTI) that was documented
+; in the Sparc v8 manual and deprecated in the v9 manual. This code executes
+; _much_ faster on the Ultra than the code using DCTI, even though it executes
+; the same instructions.
+;
+; Parameters and preconditions.
+; Src1 is a general register, RESULT, ARGREG2, or ARGREG3.
+; Src2 is a general register, RESULT, ARGREG2, ARGREG3, or an immediate.
+; Src2 is an immediate iff src2isreg = #f.
+; Branch_f.a is a branch on condition code that branches if the condition
+; is not true.
+; Generic is the millicode table offset of the generic procedure.
+
+(define (emit-bcmp-primop! as branch_f.a src1 src2 Lfalse generic src2isreg)
+ (let ((Ltagok (new-label))
+ (Ltrue (new-label))
+ (op2 (if src2isreg
+ (force-hwreg! as src2 $r.tmp1)
+ (thefixnum src2)))
+ (sub (if src2isreg sparc.tsubrcc sparc.tsubicc))
+ (mov (if src2isreg sparc.move sparc.set)))
+ (sub as src1 op2 $r.g0)
+ (sparc.bvc.a as Ltagok)
+ (sparc.slot as)
+
+ ; Not both fixnums.
+ ; Must move src1 to result if src1 is not result.
+ ; Must move src2 to argreg2 if src2 is not argreg2.
+
+ (let ((move-res (not (= src1 $r.result)))
+ (move-arg2 (or (not src2isreg) (not (= op2 $r.argreg2)))))
+ (if (and move-arg2 move-res)
+ (mov as op2 $r.argreg2))
+ (sparc.jmpli as $r.millicode generic $r.o7)
+ (cond (move-res (sparc.move as src1 $r.result))
+ (move-arg2 (mov as op2 $r.argreg2))
+ (else (sparc.nop as)))
+ (sparc.cmpi as $r.result $imm.false)
+ (sparc.bne.a as Ltrue)
+ (sparc.slot as)
+ (sparc.b as Lfalse)
+ (sparc.slot as))
+
+ (sparc.label as Ltagok)
+ (branch_f.a as Lfalse)
+ (sparc.slot as)
+ (sparc.label as Ltrue)))
+
+
+; Generic arithmetic for + and -.
+; Some rules:
+; We have two HW registers src1 and dest.
+; If src2isreg is #t then src2 may be a HW reg or a SW reg
+; If src2isreg is #f then src2 is an immediate fixnum, not shifted.
+; Src1 and dest may be RESULT, but src2 may not.
+; Src2 may be ARGREG2, the others may not.
+;
+; FIXME! This is incomprehensible.
+
+; New code below.
+
+'(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg)
+ (let ((L1 (new-label))
+ (op2 (if src2isreg
+ (force-hwreg! as src2 $r.tmp1)
+ (thefixnum src2))))
+ (if (and src2isreg (= op2 dest))
+ (begin (op as src1 op2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 dest))
+ (begin (op as src1 op2 dest)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as dest op2 dest)))
+ (let ((n (+ (if (not (= src1 $r.result)) 1 0)
+ (if (or (not src2isreg) (not (= op2 $r.argreg2))) 1 0)))
+ (mov2 (if src2isreg sparc.move sparc.set)))
+ (if (= n 2)
+ (mov2 as op2 $r.argreg2))
+ (sparc.jmpli as $r.millicode generic $r.o7)
+ (cond ((= n 0) (sparc.nop as))
+ ((= n 1) (mov2 as op2 $r.argreg2))
+ (else (sparc.move as src1 $r.result)))
+ ; Generic arithmetic leaves stuff in RESULT, must move to dest if
+ ; dest is not RESULT.
+ (if (not (= dest $r.result))
+ (sparc.move as $r.result dest))
+ (sparc.label as L1))))
+
+; Comprehensible, but longer.
+;
+; Important to be careful not to clobber arguments, and not to leave garbage
+; in rd, if millicode is called.
+;
+; op is the appropriate operation.
+; invop is the appropriate inverse operation.
+; RS1 can be any general hw register or RESULT.
+; RS2/IMM can be any general register or ARGREG2 (op2isreg=#t), or
+; an immediate (op2isreg=#f)
+; RD can be any general hw register or RESULT.
+;
+; FIXME: split this into two procedures.
+
+(define (emit-arith-primop! as op invop generic rs1 rs2/imm rd op2isreg)
+ (let ((L1 (new-label)))
+ (if op2isreg
+ (let ((rs2 (force-hwreg! as rs2/imm $r.argreg2)))
+ (cond ((or (= rs1 rs2 rd)
+ (and (= rs2 rd)
+ (= generic $m.subtract)))
+ (op as rs1 rs2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd))
+ ((= rs1 rd)
+ (op as rs1 rs2 rs1)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rs1 rs2 rs1))
+ ((= rs2 rd)
+ (op as rs1 rs2 rs2)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rs2 rs1 rs2))
+ (else
+ (op as rs1 rs2 rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (if (and (not (= rd $r.result)) (not (= rd $r.argreg2)))
+ (sparc.clr as rd))))
+ (cond ((and (= rs1 $r.result) (= rs2 $r.argreg2))
+ ;; Could peephole the INVOP or CLR into the slot here.
+ (millicode-call/0arg as generic))
+ ((= rs1 $r.result)
+ (millicode-call/1arg as generic rs2))
+ ((= rs2 $r.argreg2)
+ (millicode-call/1arg-in-result as generic rs1))
+ (else
+ (sparc.move as rs2 $r.argreg2)
+ (millicode-call/1arg-in-result as generic rs1))))
+ (let ((imm (thefixnum rs2/imm)))
+ (op as rs1 imm rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (invop as rd imm rd)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (millicode-call/numarg-in-reg as generic imm $r.argreg2)))
+ (if (not (= rd $r.result))
+ (sparc.move as $r.result rd))
+ (sparc.label as L1)))
+
+
+; Important to be careful not to leave garbage in rd if millicode is called.
+
+(define (emit-negate as rs rd)
+ (let ((L1 (new-label)))
+ (cond ((= rs rd)
+ (sparc.tsubrcc as $r.g0 rs rs)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (if (= rs $r.result)
+ (begin
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.subr as $r.g0 $r.result $r.result))
+ (begin
+ (sparc.subr as $r.g0 rs rs)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result))))
+ (else
+ (sparc.tsubrcc as $r.g0 rs rd)
+ (sparc.bvc.a as L1)
+ (sparc.slot as)
+ (cond ((= rs $r.result)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.clr as rd))
+ ((= rd $r.result)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result))
+ (else
+ (sparc.clr as rd)
+ (sparc.jmpli as $r.millicode $m.negate $r.o7)
+ (sparc.move as rs $r.result)))))
+ (if (not (= rd $r.result))
+ (sparc.move as $r.result rd))
+ (sparc.label as L1)))
+
+; Character comparison.
+
+; r is a register or a character constant.
+
+(define (emit-char-cmp as r btrue.a excode)
+ (emit-charcmp! as (lambda ()
+ (let ((l2 (new-label)))
+ (sparc.set as $imm.false $r.result)
+ (btrue.a as L2)
+ (sparc.set as $imm.true $r.result)
+ (sparc.label as L2)))
+ $r.result
+ r
+ excode))
+
+; op1 is a hw register
+; op2 is a register or a character constant
+
+(define (emit-char-bcmp-primop! as bfalse.a op1 op2 L0 excode)
+ (emit-charcmp! as (lambda ()
+ (bfalse.a as L0)
+ (sparc.slot as))
+ op1
+ op2
+ excode))
+
+; We check the tags of both by xoring them and seeing if the low byte is 0.
+; If so, then we can subtract one from the other (tag and all) and check the
+; condition codes.
+;
+; The branch-on-true instruction must have the annull bit set. (???)
+;
+; op1 is a hw register
+; op2 is a register or a character constant.
+
+(define (emit-charcmp! as tail op1 op2 excode)
+ (let ((op2 (if (char? op2)
+ op2
+ (force-hwreg! as op2 $r.argreg2))))
+ (cond ((not (unsafe-code))
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (cond ((char? op2)
+ (sparc.xori as op1 $imm.character $r.tmp0)
+ (sparc.btsti as $r.tmp0 #xFF)
+ (sparc.srli as op1 16 $r.tmp0)
+ (sparc.be.a as L1)
+ (sparc.cmpi as $r.tmp0 (char->integer op2)))
+ (else
+ (sparc.andi as op1 #xFF $r.tmp0)
+ (sparc.andi as op2 #xFF $r.tmp1)
+ (sparc.cmpr as $r.tmp0 $r.tmp1)
+ (sparc.bne as FAULT)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.be.a as L1)
+ (sparc.cmpr as op1 op2)))
+ (sparc.label as FAULT)
+ (if (not (eqv? op1 $r.result))
+ (sparc.move as op1 $r.result))
+ (cond ((char? op2)
+ (emit-immediate->register! as
+ (char->immediate op2)
+ $r.argreg2))
+ ((not (eqv? op2 $r.argreg2))
+ (sparc.move as op2 $r.argreg2)))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)))
+ ((not (char? op2))
+ (sparc.cmpr as op1 op2))
+ (else
+ (sparc.srli as op1 16 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 (char->integer op2))))
+ (tail)))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC code generation macros for primitives, part 3b:
+; helper procedures for data structures.
+
+
+; SET-CAR!, SET-CDR!, CELL-SET!
+;
+; Input: RS1: a hardware register; has pair pointer (tag check must be
+; performed by the caller).
+; RS2: any register; has value to store.
+; Output: None.
+;
+; Having rs1 != RESULT is pretty silly with the current write barrier
+; but will be less silly with the new barrier.
+
+(define (emit-setcar/setcdr! as rs1 rs2 offs)
+ (cond ((and (write-barrier) (hardware-mapped? rs2))
+ (sparc.sti as rs2 (- offs $tag.pair-tag) rs1)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (millicode-call/1arg as $m.addtrans rs2))
+ ((write-barrier)
+ (emit-move2hwreg! as rs2 $r.argreg2)
+ (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1)
+ (millicode-call/1arg-in-result as $m.addtrans rs1))
+ ((hardware-mapped? rs2)
+ (sparc.sti as rs2 (- offs $tag.pair-tag) rs1))
+ (else
+ (emit-move2hwreg! as rs2 $r.argreg2)
+ (sparc.sti as $r.argreg2 (- offs $tag.pair-tag) rs1))))
+
+
+
+
+; Representation predicate.
+;
+; RESULT has an object. If the tag of RESULT is 'tag1' and the
+; header byte of the object is 'tag2' then set RESULT to #t, else
+; set it to #f.
+
+(define (emit-double-tagcheck->bool! as tag1 tag2)
+ (let ((L1 (new-label)))
+ (sparc.andi as $r.result $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false $r.result)
+ (sparc.ldbi as $r.result (+ (- tag1) 3) $r.tmp0)
+ (sparc.set as $imm.true $r.result)
+ (sparc.cmpi as $r.tmp0 tag2)
+ (sparc.bne.a as L1)
+ (sparc.set as $imm.false $r.result)
+ (sparc.label as L1)))
+
+
+; Check structure tag.
+;
+; RS1 has an object. If the tag of RS1 is not 'tag1', or if the tag is
+; 'tag1' but the header byte of the object header is not 'tag2', then an
+; exception with code 'excode' is signalled. The exception call is set
+; up to return to the first instruction of the emitted code.
+;
+; If RS1 is not RESULT then it is moved to RESULT before the exception
+; is signalled.
+;
+; If RS2/IMM is not #f, then it is a register or immediate that is moved
+; to ARGREG2 before the exception is signalled; it is an immediate iff
+; imm? = #t.
+;
+; RS1 must be a hardware register.
+; RS2/IMM is a general register, ARGREG2, an immediate, or #f.
+; RS3 is a general register, ARGREG3, or #f.
+;
+; The procedure returns the label of the fault address. If the execution
+; falls off the end of the emitted instruction sequence, then the following
+; are true:
+; - the tag of the object in RS1 was 'tag1' and its header byte was 'tag2'
+; - the object header word is in TMP0.
+
+(define (double-tagcheck-assert as tag1 tag2 rs1 rs2/imm rs3 excode imm?)
+ (let ((L0 (new-label))
+ (L1 (new-label))
+ (FAULT (new-label)))
+ (sparc.label as L0)
+ (sparc.andi as rs1 $tag.tagmask $r.tmp0)
+ (sparc.cmpi as $r.tmp0 tag1)
+ (sparc.be.a as L1)
+ (sparc.ldi as rs1 (- tag1) $r.tmp0)
+ (sparc.label as FAULT)
+ (if (not (= rs1 $r.result))
+ (sparc.move as rs1 $r.result))
+ (if rs2/imm
+ (cond (imm?
+ (sparc.set as (thefixnum rs2/imm) $r.argreg2))
+ ((= rs2/imm $r.argreg2))
+ (else
+ (emit-move2hwreg! as rs2/imm $r.argreg2))))
+ (if (and rs3 (not (= rs3 $r.argreg3)))
+ (emit-move2hwreg! as rs3 $r.argreg3))
+ (sparc.set as (thefixnum excode) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)
+ (sparc.andi as $r.tmp0 255 $r.tmp1)
+ (sparc.cmpi as $r.tmp1 tag2)
+ (sparc.bne.a as FAULT)
+ (sparc.slot as)
+ FAULT))
+
+(define (emit-double-tagcheck-assert! as tag1 tag2 excode reg2)
+ (double-tagcheck-assert as tag1 tag2 $r.result reg2 #f excode #f))
+
+(define (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs1 rs2 excode)
+ (double-tagcheck-assert as tag1 tag2 rs1 rs2 #f excode #f))
+
+(define (emit-double-tagcheck-assert-reg/imm! as tag1 tag2 rs1 imm excode)
+ (double-tagcheck-assert as tag1 tag2 rs1 imm #f excode #t))
+
+
+
+
+; Get the length of a vector or bytevector structure, with tag checking
+; included.
+;
+; Input: RS and RD are both hardware registers.
+
+(define (emit-get-length! as tag1 tag2 excode rs rd)
+ (if (not (unsafe-code))
+ (if tag2
+ (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs rd excode)
+ (emit-single-tagcheck-assert-reg! as tag1 rs rd excode)))
+ (emit-get-length-trusted! as tag1 rs rd))
+
+; Get the length of a vector or bytevector structure, without tag checking.
+;
+; Input: RS and RD are both hardware registers.
+
+(define (emit-get-length-trusted! as tag1 rs rd)
+ (sparc.ldi as rs (- tag1) $r.tmp0)
+ (sparc.srli as $r.tmp0 8 rd)
+ (if (= tag1 $tag.bytevector-tag)
+ (sparc.slli as rd 2 rd)))
+
+
+; Allocate a bytevector, leave untagged pointer in RESULT.
+
+(define (emit-allocate-bytevector as hdr preserved-result)
+
+ ; Preserve the length field, then calculate the number of words
+ ; to allocate. The value `28' is an adjustment of 3 (for rounding
+ ; up) plus another 4 bytes for the header, all represented as a fixnum.
+
+ (if (not preserved-result)
+ (sparc.move as $r.result $r.argreg2))
+ (sparc.addi as $r.result 28 $r.result)
+ (sparc.andi as $r.result (asm:signed #xFFFFFFF0) $r.result)
+
+ ; Allocate space
+
+ (sparc.jmpli as $r.millicode $m.alloc-bv $r.o7)
+ (sparc.srai as $r.result 2 $r.result)
+
+ ; Setup the header.
+
+ (if (not preserved-result)
+ (sparc.slli as $r.argreg2 6 $r.tmp0)
+ (sparc.slli as preserved-result 6 $r.tmp0))
+ (sparc.addi as $r.tmp0 hdr $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result))
+
+
+; Given a nativeint count, a pointer to the first element of a
+; bytevector-like structure, and a byte value, fill the bytevector
+; with the byte value.
+
+(define (emit-bytevector-fill as r-bytecount r-pointer r-value)
+ (let ((L2 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L2)
+ (sparc.deccc as r-bytecount)
+ (sparc.bge.a as L2)
+ (sparc.stbr as r-value r-bytecount r-pointer)
+ (sparc.label as L1)))
+
+
+; BYTEVECTOR-REF, BYTEVECTOR-LIKE-REF, STRING-REF.
+;
+; The pointer in RS1 is known to be bytevector-like. RS2 is the fixnum
+; index into the structure. Get the RS2'th element and place it in RD.
+;
+; RS1 and RD are hardware registers.
+; RS2 is a general register or ARGREG2.
+; 'fault' is defined iff (unsafe-code) = #f
+; header is in TMP0 iff (unsafe-code) = #f and 'header-loaded?' = #t
+; if 'charize?' is #t then store result as char, otherwise as fixnum.
+
+(define (emit-bytevector-like-ref! as rs1 rs2 rd fault charize? header-loaded?)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ ; check that index is fixnum
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
+ ; check length
+ (sparc.srai as rs2 2 $r.tmp1)
+ (sparc.srli as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 $r.tmp1)
+ (sparc.bleu as fault)
+ ; No NOP or SLOT -- the SUBI below goes into the slot.
+ )
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ ; Pointer is in RS1.
+ ; Shifted index is in TMP1.
+ (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
+ (sparc.ldbr as $r.tmp0 $r.tmp1 $r.tmp0)
+ (if (not charize?)
+ (sparc.slli as $r.tmp0 2 rd)
+ (begin (sparc.slli as $r.tmp0 16 rd)
+ (sparc.ori as rd $imm.character rd)))))
+
+; As above, but RS2 is replaced by an immediate, IMM.
+;
+; The immediate, represented as a fixnum, is guaranteed fit in the
+; instruction's immediate field.
+
+(define (emit-bytevector-like-ref/imm! as rs1 imm rd fault charize?
+ header-loaded?)
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- $tag.bytevector-tag) $r.tmp0))
+ ; Range check.
+ (sparc.srli as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 imm)
+ (sparc.bleu.a as fault)
+ (sparc.slot as)))
+
+ ; Pointer is in RS1.
+
+ (let ((adjusted-offset (+ (- 4 $tag.bytevector-tag) imm)))
+ (if (immediate-literal? adjusted-offset)
+ (begin
+ (sparc.ldbi as rs1 adjusted-offset $r.tmp0))
+ (begin
+ (sparc.addi as rs1 (- 4 $tag.bytevector-tag) $r.tmp0)
+ (sparc.ldbr as $r.tmp0 imm $r.tmp0)))
+ (if (not charize?)
+ (sparc.slli as $r.tmp0 2 rd)
+ (begin (sparc.slli as $r.tmp0 16 rd)
+ (sparc.ori as rd $imm.character rd)))))
+
+
+; BYTEVECTOR-SET!, BYTEVECTOR-LIKE-SET!
+;
+; Input: RESULT -- a pointer to a bytevector-like structure.
+; TMP0 -- the header iff (unsafe-code) = #f and header-loaded? = #t
+; IDX -- a register that holds the second argument
+; BYTE -- a register that holds the third argument
+; Output: Nothing.
+;
+; 'Fault' is the address of the error code iff (unsafe-code) = #f
+;
+; FIXME:
+; - Argument values passed to error handler appear to be bogus
+; (error message is very strange).
+; - There's no check that the value actually fits in a byte.
+; - Uses ARGREG3 and and TMP2.
+
+(define (emit-bytevector-like-set! as idx byte fault header-loaded?)
+ (let ((r1 (force-hwreg! as idx $r.tmp1))
+ (r2 (force-hwreg! as byte $r.argreg3)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as $r.result (- $tag.bytevector-tag) $r.tmp0))
+ ; Both index and byte must be fixnums.
+ ; Can't use tsubcc because the computation may really overflow.
+ (sparc.orr as r1 r2 $r.tmp2)
+ (sparc.btsti as $r.tmp2 3)
+ (sparc.bnz as fault)
+ ; No NOP -- next instruction is OK in slot.
+ ; Index must be in range.
+ (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit - in slot
+ (sparc.srai as r1 2 $r.tmp1) ; index
+ (sparc.cmpr as $r.tmp1 $r.tmp0)
+ (sparc.bgeu as fault)
+ ; No NOP -- next instruction is OK in slot.
+ )
+ (begin
+ (sparc.srai as r1 2 $r.tmp1)))
+ (sparc.srli as r2 2 $r.tmp0)
+ ; Using ARGREG2 as the destination is OK because the resulting pointer
+ ; value always looks like a fixnum. By doing so, we avoid needing TMP2.
+ (sparc.addi as $r.result (- 4 $tag.bytevector-tag) $r.argreg2)
+ (sparc.stbr as $r.tmp0 $r.tmp1 $r.argreg2)))
+
+
+; STRING-SET!
+
+(define (emit-string-set! as rs1 rs2 rs3)
+ (let* ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (rs3 (force-hwreg! as rs3 $r.argreg3))
+ (FAULT (if (not (unsafe-code))
+ (double-tagcheck-assert
+ as
+ $tag.bytevector-tag
+ (+ $imm.bytevector-header $tag.string-typetag)
+ rs1 rs2 rs3
+ $ex.sset
+ #f))))
+ ; Header is in TMP0; TMP1 and TMP2 are free.
+ (if (not (unsafe-code))
+ (begin
+ ; RS2 must be a fixnum.
+ (sparc.btsti as rs2 3)
+ (sparc.bne as FAULT)
+ ; Index (in RS2) must be valid; header is in tmp0.
+ (sparc.srli as $r.tmp0 8 $r.tmp0) ; limit
+ (sparc.srai as rs2 2 $r.tmp1) ; index
+ (sparc.cmpr as $r.tmp1 $r.tmp0)
+ (sparc.bgeu as FAULT)
+ ; RS3 must be a character.
+ (sparc.andi as rs3 #xFF $r.tmp0)
+ (sparc.cmpi as $r.tmp0 $imm.character)
+ (sparc.bne as FAULT)
+ ; No NOP -- the SRLI below goes in the slot
+ )
+ (begin
+ (sparc.srai as rs2 2 $r.tmp1)))
+ ; tmp1 has nativeint index.
+ ; rs3/argreg3 has character.
+ ; tmp0 is garbage.
+ (sparc.subi as $r.tmp1 (- $tag.bytevector-tag 4) $r.tmp1)
+ (sparc.srli as rs3 16 $r.tmp0)
+ (sparc.stbr as $r.tmp0 rs1 $r.tmp1)))
+
+
+; VECTORS and PROCEDURES
+
+; Allocate short vectors of known length; faster than the general case.
+; FIXME: can also allocate in-line.
+
+(define (make-vector-n as length r)
+ (sparc.jmpli as $r.millicode $m.alloc $r.o7)
+ (sparc.set as (thefixnum (+ length 1)) $r.result)
+ (emit-immediate->register! as (+ (* 256 (thefixnum length))
+ $imm.vector-header
+ $tag.vector-typetag)
+ $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (let ((dest (force-hwreg! as r $r.argreg2)))
+ (do ((i 0 (+ i 1)))
+ ((= i length))
+ (sparc.sti as dest (* (+ i 1) 4) $r.result)))
+ (sparc.addi as $r.result $tag.vector-tag $r.result))
+
+
+; emit-make-vector-like! assumes argreg3 is not destroyed by alloci.
+; FIXME: bug: $ex.mkvl is not right if the operation is make-procedure
+; or make-vector.
+
+(define (emit-make-vector-like! as r hdr ptrtag)
+ (let ((FAULT (emit-assert-positive-fixnum! as $r.result $ex.mkvl)))
+ (sparc.move as $r.result $r.argreg3)
+ (sparc.addi as $r.result 4 $r.result)
+ (sparc.jmpli as $r.millicode $m.alloci $r.o7)
+ (if (null? r)
+ (sparc.set as $imm.null $r.argreg2)
+ (emit-move2hwreg! as r $r.argreg2))
+ (sparc.slli as $r.argreg3 8 $r.tmp0)
+ (sparc.addi as $r.tmp0 hdr $r.tmp0)
+ (sparc.sti as $r.tmp0 0 $r.result)
+ (sparc.addi as $r.result ptrtag $r.result)))
+
+
+; VECTOR-REF, VECTOR-LIKE-REF, PROCEDURE-REF
+;
+; FAULT is valid iff (unsafe-code) = #f
+; Header is in TMP0 iff (unsafe-code) = #f and header-loaded? = #t.
+
+(define (emit-vector-like-ref! as rs1 rs2 rd FAULT tag header-loaded?)
+ (let ((index (force-hwreg! as rs2 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as rs1 (- tag) $r.tmp0))
+ ; Index must be fixnum.
+ (sparc.btsti as index 3)
+ (sparc.bne as FAULT)
+ ; Index must be within bounds.
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 index)
+ (sparc.bleu as FAULT)
+ ; No NOP; the following instruction is valid in the slot.
+ ))
+ (emit-vector-like-ref-trusted! as rs1 index rd tag)))
+
+(define (emit-vector-like-ref-trusted! as rs1 rs2 rd tag)
+ (let ((index (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.addi as rs1 (- 4 tag) $r.tmp0)
+ (sparc.ldr as $r.tmp0 index rd)))
+
+
+; VECTOR-REF/IMM, VECTOR-LIKE-REF/IMM, PROCEDURE-REF/IMM
+;
+; 'rs1' is a hardware register containing a vectorish pointer (to a
+; vector-like or procedure).
+; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
+; 'rd' is a hardware register.
+; 'FAULT' is the label of the error code iff (unsafe-code) => #f
+; 'tag' is the tag of the pointer in rs1.
+; 'header-loaded?' is #t iff the structure header word is in $r.tmp0.
+
+(define (emit-vector-like-ref/imm! as rs1 imm rd FAULT tag header-loaded?)
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?) (sparc.ldi as rs1 (- tag) $r.tmp0))
+ ; Check bounds.
+ (sparc.srai as $r.tmp0 10 $r.tmp0)
+ (sparc.cmpi as $r.tmp0 imm)
+ (sparc.bleu as FAULT)
+ (sparc.nop as)))
+ (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag))
+
+; 'rs1' is a hardware register containing a vectorish pointer (to a
+; vector-like or procedure).
+; 'imm' is a fixnum s.t. (immediate-literal? imm) => #t.
+; 'rd' is a hardware register.
+; 'tag' is the tag of the pointer in rs1.
+
+(define (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag)
+ (let* ((offset (* imm 4)) ; words->bytes
+ (adjusted-offset (+ (- 4 tag) offset)))
+ (if (immediate-literal? adjusted-offset)
+ (begin
+ (sparc.ldi as rs1 adjusted-offset rd))
+ (begin
+ (sparc.addi as rs1 (- 4 tag) $r.tmp0)
+ (sparc.ldi as $r.tmp0 offset rd)))))
+
+
+
+; VECTOR-SET!, VECTOR-LIKE-SET!, PROCEDURE-SET!
+;
+; It is assumed that the pointer in RESULT is valid. We must check the index
+; in register x for validity and then perform the side effect (by calling
+; millicode). The tag is the pointer tag to be adjusted for.
+;
+; The use of vector-set is ok even if it is a procedure.
+
+; fault is valid iff (unsafe-code) = #f
+; header is in tmp0 iff (unsafe-code) = #f and header-loaded? = #t
+
+(define (emit-vector-like-set! as rs1 rs2 rs3 fault tag header-loaded?)
+ (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
+ (rs3 (force-hwreg! as rs3 $r.argreg2)))
+ (if (not (unsafe-code))
+ (begin
+ (if (not header-loaded?)
+ (sparc.ldi as $r.result (- tag) $r.tmp0))
+ (sparc.btsti as rs2 3)
+ (sparc.bne as fault)
+ (sparc.srai as $r.tmp0 8 $r.tmp0)
+ (sparc.cmpr as $r.tmp0 rs2)
+ (sparc.bleu as fault)))
+ (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)))
+
+; rs1 must be a hardware register.
+; tag is the pointer tag to be adjusted for.
+
+(define (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)
+ (let ((rs2 (force-hwreg! as rs2 $r.tmp1))
+ (rs3 (force-hwreg! as rs3 $r.argreg2)))
+ ;; The ADDR can go in the delay slot of a preceding BLEU.
+ (sparc.addr as rs1 rs2 $r.tmp0)
+ (cond ((not (write-barrier))
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0))
+ ((= rs1 $r.result)
+ (cond ((= rs3 $r.argreg2)
+ (sparc.jmpli as $r.millicode $m.addtrans $r.o7)
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0))
+ (else
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (millicode-call/1arg as $m.addtrans rs3))))
+ (else
+ (cond ((= rs3 $r.argreg2)
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (millicode-call/1arg-in-result as $m.addtrans rs1))
+ (else
+ (sparc.sti as rs3 (- 4 tag) $r.tmp0)
+ (sparc.move as rs1 $r.result)
+ (millicode-call/1arg as $m.addtrans rs3)))))))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; 9 May 1999 / wdc
+;
+; SPARC code generation macros for primitives, part 3:
+; fixnum-specific operations.
+;
+; Constraints for all the primops.
+;
+; RS1 is a general hardware register or RESULT.
+; RS2 is a general register or ARGREG2.
+; IMM is an exact integer in the range -1024 .. 1023.
+; RD is a general hardware register or RESULT.
+
+; FIXME
+; Missing fxquotient, fxremainder
+; When new pass1 in place:
+; Must add code to pass1 to allow n-ary calls to be rewritten as binary
+; Must add compiler macro for fxabs.
+
+
+; most-negative-fixnum, most-positive-fixnum.
+
+(define-primop 'most-negative-fixnum
+ (lambda (as)
+ (emit-immediate->register! as (asm:signed #x80000000) $r.result)))
+
+(define-primop 'most-positive-fixnum
+ (lambda (as)
+ (emit-immediate->register! as (asm:signed #x7FFFFFFC) $r.result)))
+
+
+; fx+, fx- w/o immediates
+
+(define-primop 'fx+
+ (lambda (as rs2)
+ (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr $r.result rs2 $r.result
+ $ex.fx+)))
+
+(define-primop 'internal:fx+
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr rs1 rs2 rd $ex.fx+)))
+
+(define-primop 'fx-
+ (lambda (as rs2)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.result rs2 $r.result
+ $ex.fx-)))
+
+(define-primop 'internal:fx-
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr rs1 rs2 rd $ex.fx-)))
+
+(define-primop 'fx--
+ (lambda (as)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr
+ $r.g0 $r.result $r.result $ex.fx--)))
+
+(define-primop 'internal:fx--
+ (lambda (as rs rd)
+ (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.g0 rs rd $ex.fx--)))
+
+(define (emit-fixnum-arithmetic as op-check op-nocheck rs1 rs2 rd exn)
+ (if (unsafe-code)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (op-nocheck as rs1 rs2 rd))
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (op-check as rs1 rs2 $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd)
+ (if (not (= exn $ex.fx--))
+ (begin
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2)))
+ (begin
+ (if (not (= rs2 $r.result)) (sparc.move as rs2 $r.result))))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1))))
+
+; fx* w/o immediate
+
+(define-primop 'fx*
+ (lambda (as rs2)
+ (emit-multiply-code as rs2 #t)))
+
+; fx+, fx- w/immediates
+
+(define-primop 'internal:fx+/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-arithmetic/imm as sparc.taddicc sparc.addi
+ rs imm rd $ex.fx+)))
+
+(define-primop 'internal:fx-/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-arithmetic/imm as sparc.tsubicc sparc.subi
+ rs imm rd $ex.fx-)))
+
+(define (emit-fixnum-arithmetic/imm as op-check op-nocheck rs imm rd exn)
+ (if (unsafe-code)
+ (op-nocheck as rs (thefixnum imm) rd)
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (op-check as rs (thefixnum imm) $r.tmp0)
+ (sparc.bvc.a as L1)
+ (sparc.move as $r.tmp0 rd)
+ (if (not (= rs $r.result)) (sparc.move as rs $r.result))
+ (sparc.set as (thefixnum imm) $r.argreg2)
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1))))
+
+
+; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
+
+(define-primop 'fx=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bne.a $r.result rs2 $r.result $ex.fx= #f)))
+
+(define-primop 'fx<
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bge.a $r.result rs2 $r.result $ex.fx< #f)))
+
+(define-primop 'fx<=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bg.a $r.result rs2 $r.result $ex.fx<= #f)))
+
+(define-primop 'fx>
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.ble.a $r.result rs2 $r.result $ex.fx> #f)))
+
+(define-primop 'fx>=
+ (lambda (as rs2)
+ (emit-fixnum-compare as sparc.bl.a $r.result rs2 $r.result $ex.fx>= #f)))
+
+(define-primop 'internal:fx=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bne.a rs1 rs2 rd $ex.fx= #f)))
+
+(define-primop 'internal:fx<
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bge.a rs1 rs2 rd $ex.fx< #f)))
+
+(define-primop 'internal:fx<=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bg.a rs1 rs2 rd $ex.fx<= #f)))
+
+(define-primop 'internal:fx>
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.ble.a rs1 rs2 rd $ex.fx> #f)))
+
+(define-primop 'internal:fx>=
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare as sparc.bl.a rs1 rs2 rd $ex.fx>= #f)))
+
+
+; Use '/imm' code for these because the generated code is better.
+
+(define-primop 'fxpositive?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.ble.a $r.result 0 $r.result
+ $ex.fxpositive? #f)))
+
+(define-primop 'fxnegative?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.bge.a $r.result 0 $r.result
+ $ex.fxnegative? #f)))
+
+(define-primop 'fxzero?
+ (lambda (as)
+ (emit-fixnum-compare/imm as sparc.bne.a $r.result 0 $r.result
+ $ex.fxzero? #f)))
+
+(define-primop 'internal:fxpositive?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.ble.a rs 0 rd $ex.fxpositive? #f)))
+
+(define-primop 'internal:fxnegative?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.bge.a rs 0 rd $ex.fxnegative? #f)))
+
+(define-primop 'internal:fxzero?
+ (lambda (as rs rd)
+ (emit-fixnum-compare/imm as sparc.bne.a rs 0 rd $ex.fxzero? #f)))
+
+
+; fx=, fx<, fx<=, fx>, fx>= w/immediates
+
+(define-primop 'internal:fx=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bne.a rs imm rd $ex.fx= #f)))
+
+(define-primop 'internal:fx</imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bge.a rs imm rd $ex.fx< #f)))
+
+(define-primop 'internal:fx<=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bg.a rs imm rd $ex.fx<= #f)))
+
+(define-primop 'internal:fx>/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.ble.a rs imm rd $ex.fx> #f)))
+
+(define-primop 'internal:fx>=/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm as sparc.bl.a rs imm rd $ex.fx>= #f)))
+
+; fx=, fx<, fx<=, fx>, fx>=, fxpositive?, fxnegative?, fxzero? w/o immediates
+; for control.
+
+(define-primop 'internal:branchf-fx=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bne.a rs1 rs2 #f $ex.fx= L)))
+
+(define-primop 'internal:branchf-fx<
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bge.a rs1 rs2 #f $ex.fx< L)))
+
+(define-primop 'internal:branchf-fx<=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bg.a rs1 rs2 #f $ex.fx<= L)))
+
+(define-primop 'internal:branchf-fx>
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.ble.a rs1 rs2 #f $ex.fx> L)))
+
+(define-primop 'internal:branchf-fx>=
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare as sparc.bl.a rs1 rs2 #f $ex.fx>= L)))
+
+(define-primop 'internal:branchf-fxpositive?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.ble.a rs1 0 #f $ex.fxpositive? L)))
+
+(define-primop 'internal:branchf-fxnegative?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.bge.a rs1 0 #f $ex.fxnegative? L)))
+
+(define-primop 'internal:branchf-fxzero?
+ (lambda (as rs1 L)
+ (emit-fixnum-compare/imm as sparc.bne.a rs1 0 #f $ex.fxzero? L)))
+
+
+; fx=, fx<, fx<=, fx>, fx>= w/immediates for control.
+
+(define-primop 'internal:branchf-fx=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bne.a rs imm #f $ex.fx= L)))
+
+(define-primop 'internal:branchf-fx</imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bge.a rs imm #f $ex.fx< L)))
+
+(define-primop 'internal:branchf-fx<=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bg.a rs imm #f $ex.fx<= L)))
+
+(define-primop 'internal:branchf-fx>/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.ble.a rs imm #f $ex.fx> L)))
+
+(define-primop 'internal:branchf-fx>=/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm as sparc.bl.a rs imm #f $ex.fx>= L)))
+
+
+; Trusted fixnum comparisons.
+
+(define-primop '=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bne.a $r.result rs2 $r.result #f)))
+
+(define-primop '<:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bge.a $r.result rs2 $r.result #f)))
+
+(define-primop '<=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bg.a $r.result rs2 $r.result #f)))
+
+(define-primop '>:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.ble.a $r.result rs2 $r.result #f)))
+
+(define-primop '>=:fix:fix
+ (lambda (as rs2)
+ (emit-fixnum-compare-trusted as sparc.bl.a $r.result rs2 $r.result #f)))
+
+(define-primop 'internal:=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:<:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:<=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:>:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 rd #f)))
+
+(define-primop 'internal:>=:fix:fix
+ (lambda (as rs1 rs2 rd)
+ (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 rd #f)))
+
+; With immediates.
+
+(define-primop 'internal:=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm rd #f)))
+
+(define-primop 'internal:<:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm rd #f)))
+
+(define-primop 'internal:<=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm rd #f)))
+
+(define-primop 'internal:>:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm rd #f)))
+
+(define-primop 'internal:>=:fix:fix/imm
+ (lambda (as rs imm rd)
+ (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm rd #f)))
+
+; Without immediates, for control.
+
+(define-primop 'internal:branchf-=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf-<:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf-<=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf->:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 #f L)))
+
+(define-primop 'internal:branchf->=:fix:fix
+ (lambda (as rs1 rs2 L)
+ (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 #f L)))
+
+; With immediates, for control.
+
+(define-primop 'internal:branchf-=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm #f L)))
+
+(define-primop 'internal:branchf-<:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm #f L)))
+
+(define-primop 'internal:branchf-<=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm #f L)))
+
+(define-primop 'internal:branchf->:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm #f L)))
+
+(define-primop 'internal:branchf->=:fix:fix/imm
+ (lambda (as rs imm L)
+ (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm #f L)))
+
+; Range check: 0 <= src1 < src2
+
+(define-primop 'internal:check-range
+ (lambda (as src1 src2 L1 livregs)
+ (let ((src2 (force-hwreg! as src2 $r.argreg2)))
+ (emit-fixnum-compare-check
+ as src2 src1 sparc.bleu L1 livregs))))
+
+; Trusted fixnum comparisons followed by a check.
+
+(define-primop 'internal:check-=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-<:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bge L1 liveregs)))
+
+(define-primop 'internal:check-<=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bg L1 liveregs)))
+
+(define-primop 'internal:check->:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.ble L1 liveregs)))
+
+(define-primop 'internal:check->=:fix:fix
+ (lambda (as src1 src2 L1 liveregs)
+ (emit-fixnum-compare-check
+ as src1 src2 sparc.bl L1 liveregs)))
+
+(define-primop 'internal:check-=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bne L1 liveregs)))
+
+(define-primop 'internal:check-<:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bge L1 liveregs)))
+
+(define-primop 'internal:check-<=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bg L1 liveregs)))
+
+(define-primop 'internal:check->:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.ble L1 liveregs)))
+
+(define-primop 'internal:check->=:fix:fix/imm
+ (lambda (as src1 imm L1 liveregs)
+ (emit-fixnum-compare/imm-check
+ as src1 imm sparc.bl L1 liveregs)))
+
+; Below, 'target' is a label or #f. If #f, RD must be a general hardware
+; register or RESULT, and a boolean result is generated in RD.
+
+(define (emit-fixnum-compare as branchf.a rs1 rs2 rd exn target)
+ (if (unsafe-code)
+ (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2))
+ (L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (sparc.orr as rs1 rs2 $r.tmp0)
+ (sparc.btsti as $r.tmp0 3)
+ (sparc.be.a as L1)
+ (sparc.cmpr as rs1 rs2)
+ (if (not (= rs1 $r.result)) (sparc.move as rs1 $r.result))
+ (if (not (= rs2 $r.argreg2)) (sparc.move as rs2 $r.argreg2))
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)
+ (emit-evaluate-cc! as branchf.a rd target))))
+
+; Below, 'target' is a label or #f. If #f, RD must be a general hardware
+; register or RESULT, and a boolean result is generated in RD.
+
+(define (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
+ (let ((rs2 (force-hwreg! as rs2 $r.argreg2)))
+ (sparc.cmpr as rs1 rs2)
+ (emit-evaluate-cc! as branchf.a rd target)))
+
+; rs must be a hardware register.
+
+(define (emit-fixnum-compare/imm as branchf.a rs imm rd exn target)
+ (if (unsafe-code)
+ (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
+ (let ((L0 (new-label))
+ (L1 (new-label)))
+ (sparc.label as L0)
+ (sparc.btsti as rs 3)
+ (sparc.be.a as L1)
+ (sparc.cmpi as rs (thefixnum imm))
+ (if (not (= rs $r.result)) (sparc.move as rs $r.result))
+ (sparc.set as (thefixnum imm) $r.argreg2)
+ (sparc.set as (thefixnum exn) $r.tmp0)
+ (millicode-call/ret as $m.exception L0)
+ (sparc.label as L1)))
+ (emit-evaluate-cc! as branchf.a rd target))
+
+; rs must be a hardware register.
+
+(define (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
+ (sparc.cmpi as rs (thefixnum imm))
+ (emit-evaluate-cc! as branchf.a rd target))
+
+; Range checks.
+
+(define (emit-fixnum-compare-check
+ as src1 src2 branch-bad L1 liveregs)
+ (internal-primop-invariant1 'emit-fixnum-compare-check src1)
+ (let ((src2 (force-hwreg! as src2 $r.argreg2)))
+ (sparc.cmpr as src1 src2)
+ (emit-checkcc! as branch-bad L1 liveregs)))
+
+(define (emit-fixnum-compare/imm-check
+ as src1 imm branch-bad L1 liveregs)
+ (internal-primop-invariant1 'emit-fixnum-compare/imm-check src1)
+ (sparc.cmpi as src1 imm)
+ (emit-checkcc! as branch-bad L1 liveregs))
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC machine assembler flags.
+;
+; 12 April 1999
+
+
+; INTERNAL!
+(define short-effective-addresses
+ (make-twobit-flag 'short-effective-addresses))
+
+(define runtime-safety-checking
+ (make-twobit-flag 'runtime-safety-checking))
+
+(define catch-undefined-globals
+ (make-twobit-flag 'catch-undefined-globals))
+
+(define inline-allocation
+ (make-twobit-flag 'inline-allocation))
+
+;(define inline-assignment
+; (make-twobit-flag 'inline-assignment))
+
+(define write-barrier
+ (make-twobit-flag 'write-barrier))
+
+(define peephole-optimization
+ (make-twobit-flag 'peephole-optimization))
+
+(define single-stepping
+ (make-twobit-flag 'single-stepping))
+
+(define fill-delay-slots
+ (make-twobit-flag 'fill-delay-slots))
+
+; For backward compatibility.
+
+;(define unsafe-code
+; (make-twobit-flag 'unsafe-code))
+
+(define (unsafe-code . args)
+ (if (null? args)
+ (not (runtime-safety-checking))
+ (runtime-safety-checking (not (car args)))))
+
+(define (display-assembler-flags which)
+ (case which
+ ((debugging)
+ (display-twobit-flag single-stepping))
+ ((safety)
+ (display-twobit-flag write-barrier)
+ ;(display-twobit-flag unsafe-code)
+ (display-twobit-flag runtime-safety-checking)
+ (if (runtime-safety-checking)
+ (begin (display " ")
+ (display-twobit-flag catch-undefined-globals))))
+ ((optimization)
+ (display-twobit-flag peephole-optimization)
+ (display-twobit-flag inline-allocation)
+ ; (display-twobit-flag inline-assignment)
+ (display-twobit-flag fill-delay-slots))
+ (else #t)))
+
+(define (set-assembler-flags! mode)
+ (case mode
+ ((no-optimization)
+ (set-assembler-flags! 'standard)
+ (peephole-optimization #f)
+ (fill-delay-slots #f))
+ ((standard)
+ (short-effective-addresses #t)
+ (catch-undefined-globals #t)
+ (inline-allocation #f)
+ ; (inline-assignment #f)
+ (peephole-optimization #t)
+ (runtime-safety-checking #t)
+ (write-barrier #t)
+ (single-stepping #f)
+ (fill-delay-slots #t))
+ ((fast-safe default)
+ (set-assembler-flags! 'standard)
+ ; (inline-assignment #t)
+ (inline-allocation #t))
+ ((fast-unsafe)
+ (set-assembler-flags! 'fast-safe)
+ (catch-undefined-globals #f)
+ (runtime-safety-checking #f))
+ (else
+ (error "set-assembler-flags!: unknown mode " mode))))
+
+(set-assembler-flags! 'default)
+
+; eof
+; Copyright 1998 Lars T Hansen.
+;
+; $Id: twobit.sch,v 1.3 1999/08/23 19:14:26 lth Exp $
+;
+; SPARC disassembler.
+;
+; (disassemble-instruction instruction address)
+; => decoded-instruction
+;
+; (disassemble-codevector codevector)
+; => decoded-instruction-list
+;
+; (print-instructions decoded-instruction-list)
+; => unspecified
+; Also takes an optional port and optionally the symbol "native-names".
+;
+; (format-instruction decoded-instruction address larceny-names?)
+; => string
+;
+; A `decoded-instruction' is a list where the car is a mnemonic and
+; the operands are appropriate for that mnemonic.
+;
+; A `mnemonic' is an exact nonnegative integer. It encodes the name of
+; the instruction as well as its attributes (operand pattern and instruction
+; type). See below for specific operations on mnemonics.
+
+(define (disassemble-codevector cv)
+ (define (loop addr ilist)
+ (if (< addr 0)
+ ilist
+ (loop (- addr 4)
+ (cons (disassemble-instruction (bytevector-word-ref cv addr)
+ addr)
+ ilist))))
+ (loop (- (bytevector-length cv) 4) '()))
+
+(define disassemble-instruction) ; Defined below.
+
+\f; Mnemonics
+
+(define *asm-annul* 1)
+(define *asm-immed* 2)
+(define *asm-store* 4)
+(define *asm-load* 8)
+(define *asm-branch* 16)
+(define *asm-freg* 32)
+(define *asm-fpop* 64)
+(define *asm-no-op2* 128)
+(define *asm-no-op3* 256)
+
+(define *asm-bits*
+ `((a . ,*asm-annul*) (i . ,*asm-immed*) (s . ,*asm-store*)
+ (l . ,*asm-load*) (b . ,*asm-branch*) (f . ,*asm-freg*)
+ (fpop . ,*asm-fpop*) (no-op2 . ,*asm-no-op2*) (no-op3 . ,*asm-no-op3*)))
+
+(define *asm-mnemonic-table* '())
+
+(define mnemonic
+ (let ((n 0))
+ (lambda (name . rest)
+ (let* ((probe (assq name *asm-mnemonic-table*))
+ (code (* 1024
+ (if probe
+ (cdr probe)
+ (let ((code n))
+ (set! n (+ n 1))
+ (set! *asm-mnemonic-table*
+ (cons (cons name code)
+ *asm-mnemonic-table*))
+ code)))))
+ (for-each (lambda (x)
+ (set! code (+ code (cdr (assq x *asm-bits*)))))
+ rest)
+ code))))
+
+(define (mnemonic:name mnemonic)
+ (let ((mnemonic (quotient mnemonic 1024)))
+ (let loop ((t *asm-mnemonic-table*))
+ (cond ((null? t) #f)
+ ((= (cdar t) mnemonic) (caar t))
+ (else (loop (cdr t)))))))
+
+(define (mnemonic=? m name)
+ (= (quotient m 1024) (quotient (mnemonic name) 1024)))
+
+(define (mnemonic:test bit)
+ (lambda (mnemonic)
+ (not (zero? (logand mnemonic bit)))))
+
+(define (mnemonic:test-not bit)
+ (lambda (mnemonic)
+ (zero? (logand mnemonic bit))))
+
+(define mnemonic:annul? (mnemonic:test *asm-annul*))
+(define mnemonic:immediate? (mnemonic:test *asm-immed*))
+(define mnemonic:store? (mnemonic:test *asm-store*))
+(define mnemonic:load? (mnemonic:test *asm-load*))
+(define mnemonic:branch? (mnemonic:test *asm-branch*))
+(define mnemonic:freg? (mnemonic:test *asm-freg*))
+(define mnemonic:fpop? (mnemonic:test *asm-fpop*))
+(define mnemonic:op2? (mnemonic:test-not *asm-no-op2*))
+(define mnemonic:op3? (mnemonic:test-not *asm-no-op3*))
+
+\f; Instruction disassembler.
+
+(let ()
+
+ ;; Useful constants
+
+ (define two^3 (expt 2 3))
+ (define two^5 (expt 2 5))
+ (define two^6 (expt 2 6))
+ (define two^8 (expt 2 8))
+ (define two^9 (expt 2 9))
+ (define two^12 (expt 2 12))
+ (define two^13 (expt 2 13))
+ (define two^14 (expt 2 14))
+ (define two^16 (expt 2 16))
+ (define two^19 (expt 2 19))
+ (define two^21 (expt 2 21))
+ (define two^22 (expt 2 22))
+ (define two^24 (expt 2 24))
+ (define two^25 (expt 2 25))
+ (define two^29 (expt 2 29))
+ (define two^30 (expt 2 30))
+ (define two^32 (expt 2 32))
+
+ ;; Class 0 has branches and weirdness, like sethi and nop.
+ ;; We dispatch first on the op2 field and then on the op3 field.
+
+ (define class00
+ (let ((b-table
+ (vector (mnemonic 'bn 'b)
+ (mnemonic 'be 'b)
+ (mnemonic 'ble 'b)
+ (mnemonic 'bl 'b)
+ (mnemonic 'bleu 'b)
+ (mnemonic 'bcs 'b)
+ (mnemonic 'bneg 'b)
+ (mnemonic 'bvs 'b)
+ (mnemonic 'ba 'b)
+ (mnemonic 'bne 'b)
+ (mnemonic 'bg 'b)
+ (mnemonic 'bge 'b)
+ (mnemonic 'bgu 'b)
+ (mnemonic 'bcc 'b)
+ (mnemonic 'bpos 'b)
+ (mnemonic 'bvc 'b)
+ (mnemonic 'bn 'a 'b)
+ (mnemonic 'be 'a 'b)
+ (mnemonic 'ble 'a 'b)
+ (mnemonic 'bl 'a 'b)
+ (mnemonic 'bleu 'a 'b)
+ (mnemonic 'bcs 'a 'b)
+ (mnemonic 'bneg 'a 'b)
+ (mnemonic 'bvs 'a 'b)
+ (mnemonic 'ba 'a 'b)
+ (mnemonic 'bne 'a 'b)
+ (mnemonic 'bg 'a 'b)
+ (mnemonic 'bge 'a 'b)
+ (mnemonic 'bgu 'a 'b)
+ (mnemonic 'bcc 'a 'b)
+ (mnemonic 'bpos 'a 'b)
+ (mnemonic 'bvc 'a 'b)))
+ (fb-table
+ (vector (mnemonic 'fbn 'b)
+ (mnemonic 'fbne 'b)
+ (mnemonic 'fblg 'b)
+ (mnemonic 'fbul 'b)
+ (mnemonic 'fbl 'b)
+ (mnemonic 'fbug 'b)
+ (mnemonic 'fbg 'b)
+ (mnemonic 'fbu 'b)
+ (mnemonic 'fba 'b)
+ (mnemonic 'fbe 'b)
+ (mnemonic 'fbue 'b)
+ (mnemonic 'fbge 'b)
+ (mnemonic 'fbuge 'b)
+ (mnemonic 'fble 'b)
+ (mnemonic 'fbule 'b)
+ (mnemonic 'fbo 'b)
+ (mnemonic 'fbn 'a 'b)
+ (mnemonic 'fbne 'a 'b)
+ (mnemonic 'fblg 'a 'b)
+ (mnemonic 'fbul 'a 'b)
+ (mnemonic 'fbl 'a 'b)
+ (mnemonic 'fbug 'a 'b)
+ (mnemonic 'fbg 'a 'b)
+ (mnemonic 'fbu 'a 'b)
+ (mnemonic 'fba 'a 'b)
+ (mnemonic 'fbe 'a 'b)
+ (mnemonic 'fbue 'a 'b)
+ (mnemonic 'fbge 'a 'b)
+ (mnemonic 'fbuge 'a 'b)
+ (mnemonic 'fble 'a 'b)
+ (mnemonic 'fbule 'a 'b)
+ (mnemonic 'fbo 'a 'b)))
+ (nop (mnemonic 'nop))
+ (sethi (mnemonic 'sethi)))
+
+ (lambda (ip instr)
+ (let ((op2 (op2field instr)))
+ (cond ((= op2 #b100)
+ (if (zero? (rdfield instr))
+ `(,nop)
+ `(,sethi ,(imm22field instr) ,(rdfield instr))))
+ ((= op2 #b010)
+ `(,(vector-ref b-table (rdfield instr))
+ ,(* 4 (imm22field instr))))
+ ((= op2 #b110)
+ `(,(vector-ref fb-table (rdfield instr))
+ ,(* 4 (imm22field instr))))
+ (else
+ (disasm-error "Can't disassemble " (number->string instr 16)
+ " at ip=" ip
+ " with op2=" op2)))))))
+
+ ;; Class 1 is the call instruction; there's no choice.
+
+ (define (class01 ip instr)
+ `(,(mnemonic 'call) ,(* 4 (imm30field instr))))
+
+ ;; Class 2 is for the ALU. Dispatch on op3 field.
+
+ (define class10
+ (let ((op3-table
+ `#((,(mnemonic 'add) ,(mnemonic 'add 'i))
+ (,(mnemonic 'and) ,(mnemonic 'and 'i))
+ (,(mnemonic 'or) ,(mnemonic 'or 'i))
+ (,(mnemonic 'xor) ,(mnemonic 'xor 'i))
+ (,(mnemonic 'sub) ,(mnemonic 'sub 'i))
+ (,(mnemonic 'andn) ,(mnemonic 'andn 'i))
+ (,(mnemonic 'orn) ,(mnemonic 'orn 'i))
+ (,(mnemonic 'xnor) ,(mnemonic 'xnor 'i))
+ (0 0)
+ (0 0)
+ (0 0) ; 10
+ (,(mnemonic 'smul) ,(mnemonic 'smul 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'sdiv) ,(mnemonic 'sdiv 'i))
+ (,(mnemonic 'addcc) ,(mnemonic 'addcc 'i))
+ (,(mnemonic 'andcc) ,(mnemonic 'andcc 'i))
+ (,(mnemonic 'orcc) ,(mnemonic 'orcc 'i))
+ (,(mnemonic 'xorcc) ,(mnemonic 'xorcc 'i))
+ (,(mnemonic 'subcc) ,(mnemonic 'subcc 'i)) ; 20
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'smulcc) ,(mnemonic 'smulcc 'i))
+ (0 0)
+ (0 0)
+ (0 0) ; 30
+ (,(mnemonic 'sdivcc) ,(mnemonic 'sdivcc 'i))
+ (,(mnemonic 'taddcc) ,(mnemonic 'taddcc 'i))
+ (,(mnemonic 'tsubcc) ,(mnemonic 'tsubcc 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'sll) ,(mnemonic 'sll 'i))
+ (,(mnemonic 'srl) ,(mnemonic 'srl 'i))
+ (,(mnemonic 'sra) ,(mnemonic 'sra 'i))
+ (,(mnemonic 'rd) 0) ; 40
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'wr) ,(mnemonic 'wr 'i))
+ (0 0)
+ (0 0) ; 50
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'jmpl) ,(mnemonic 'jmpl 'i))
+ (0 0)
+ (0 0)
+ (0 0)
+ (,(mnemonic 'save) ,(mnemonic 'save 'i)) ; 60
+ (,(mnemonic 'restore) ,(mnemonic 'restore 'i))
+ (0 0)
+ (0 0))))
+
+ (lambda (ip instr)
+ (let ((op3 (op3field instr)))
+ (if (or (= op3 #b110100) (= op3 #b110101))
+ (fpop-instruction ip instr)
+ (nice-instruction op3-table ip instr))))))
+
+
+ ;; Class 3 is memory stuff.
+
+ (define class11
+ (let ((op3-table
+ `#((,(mnemonic 'ld 'l) ,(mnemonic 'ld 'i 'l))
+ (,(mnemonic 'ldb 'l) ,(mnemonic 'ldb 'i 'l))
+ (,(mnemonic 'ldh 'l) ,(mnemonic 'ldh 'i 'l))
+ (,(mnemonic 'ldd 'l) ,(mnemonic 'ldd 'i 'l))
+ (,(mnemonic 'st 's) ,(mnemonic 'st 'i 's))
+ (,(mnemonic 'stb 's) ,(mnemonic 'stb 'i 's))
+ (,(mnemonic 'sth 's) ,(mnemonic 'sth 'i 's))
+ (,(mnemonic 'std 's) ,(mnemonic 'std 'i 's))
+ (0 0)
+ (0 0)
+ (0 0) ; 10
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 20
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 30
+ (0 0)
+ (,(mnemonic 'ldf 'f 'l) ,(mnemonic 'ldf 'i 'f 'l))
+ (0 0)
+ (0 0)
+ (,(mnemonic 'lddf 'f 'l) ,(mnemonic 'lddf 'i 'f 'l))
+ (,(mnemonic 'stf 'f 's) ,(mnemonic 'stf 'i 'f 's))
+ (0 0)
+ (0 0)
+ (,(mnemonic 'stdf 'f 's) ,(mnemonic 'stdf 'i 'f 's))
+ (0 0) ; 40
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 50
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0)
+ (0 0) ; 60
+ (0 0)
+ (0 0)
+ (0 0))))
+
+ (lambda (ip instr)
+ (nice-instruction op3-table ip instr))))
+
+ ;; For classes 2 and 3
+
+ (define (nice-instruction op3-table ip instr)
+ (let* ((op3 (op3field instr))
+ (imm (ifield instr))
+ (rd (rdfield instr))
+ (rs1 (rs1field instr))
+ (src2 (if (zero? imm)
+ (rs2field instr)
+ (imm13field instr))))
+ (let ((op ((if (zero? imm) car cadr) (vector-ref op3-table op3))))
+ `(,op ,rs1 ,src2 ,rd))))
+
+ ;; Floating-point operate instructions
+
+ (define (fpop-instruction ip instr)
+ (let ((rd (rdfield instr))
+ (rs1 (rs1field instr))
+ (rs2 (rs2field instr))
+ (fpop (fpop-field instr)))
+ `(,(cdr (assv fpop fpop-names)) ,rs1 ,rs2 ,rd)))
+
+ (define fpop-names
+ `((#b000000001 . ,(mnemonic 'fmovs 'fpop 'no-op2))
+ (#b000000101 . ,(mnemonic 'fnegs 'fpop 'no-op2))
+ (#b000001001 . ,(mnemonic 'fabss 'fpop 'no-op2))
+ (#b001000010 . ,(mnemonic 'faddd 'fpop))
+ (#b001000110 . ,(mnemonic 'fsubd 'fpop))
+ (#b001001010 . ,(mnemonic 'fmuld 'fpop))
+ (#b001001110 . ,(mnemonic 'fdivd 'fpop))
+ (#b001010010 . ,(mnemonic 'fcmpd 'fpop 'no-op3))))
+
+
+ ;; The following procedures pick apart an instruction
+
+ (define (op2field instr)
+ (remainder (quotient instr two^22) two^3))
+
+ (define (op3field instr)
+ (remainder (quotient instr two^19) two^6))
+
+ (define (ifield instr)
+ (remainder (quotient instr two^13) 2))
+
+ (define (rs2field instr)
+ (remainder instr two^5))
+
+ (define (rs1field instr)
+ (remainder (quotient instr two^14) two^5))
+
+ (define (rdfield instr)
+ (remainder (quotient instr two^25) two^5))
+
+ (define (imm13field instr)
+ (let ((x (remainder instr two^13)))
+ (if (not (zero? (quotient x two^12)))
+ (- x two^13)
+ x)))
+
+ (define (imm22field instr)
+ (let ((x (remainder instr two^22)))
+ (if (not (zero? (quotient x two^21)))
+ (- x two^22)
+ x)))
+
+ (define (imm30field instr)
+ (let ((x (remainder instr two^30)))
+ (if (not (zero? (quotient x two^29)))
+ (- x two^30)
+ x)))
+
+ (define (fpop-field instr)
+ (remainder (quotient instr two^5) two^9))
+
+ (set! disassemble-instruction
+ (let ((class-table (vector class00 class01 class10 class11)))
+ (lambda (instr addr)
+ ((vector-ref class-table (quotient instr two^30)) addr instr))))
+
+ 'disassemble-instruction)
+
+
+\f; Instruction printer
+;
+; It assumes that the first instruction comes from address 0, and prints
+; addresses (and relative addresses) based on that assumption.
+;
+; If the optional symbol native-names is supplied, then SPARC register
+; names is used, and millicode calls are not annotated with millicode names.
+
+(define (print-instructions ilist . rest)
+
+ (define port (current-output-port))
+ (define larceny-names? #t)
+
+ (define (print-ilist ilist a)
+ (if (null? ilist)
+ '()
+ (begin (display (format-instruction (car ilist) a larceny-names?)
+ port)
+ (newline port)
+ (print-ilist (cdr ilist) (+ a 4)))))
+
+ (do ((rest rest (cdr rest)))
+ ((null? rest))
+ (cond ((port? (car rest))
+ (set! port (car rest)))
+ ((eq? (car rest) 'native-names)
+ (set! larceny-names? #f))))
+
+ (print-ilist ilist 0))
+
+(define format-instruction) ; Defined below
+
+(define *format-instructions-pretty* #t)
+
+; Instruction formatter.
+
+(let ()
+
+ (define use-larceny-registers #t)
+
+ (define sparc-register-table
+ (vector "%g0" "%g1" "%g2" "%g3" "%g4" "%g5" "%g6" "%g7"
+ "%o0" "%o1" "%o2" "%o3" "%o4" "%o5" "%o6" "%o7"
+ "%l0" "%l1" "%l2" "%l3" "%l4" "%l5" "%l6" "%l7"
+ "%i0" "%i1" "%i2" "%i3" "%i4" "%i5" "%i6" "%i7"))
+
+ (define larceny-register-table
+ (make-vector 32 #f))
+
+ (define (larceny-register-name reg . rest)
+ (if (null? rest)
+ (or (and use-larceny-registers
+ (vector-ref larceny-register-table reg))
+ (vector-ref sparc-register-table reg))
+ (vector-set! larceny-register-table reg (car rest))))
+
+ (define millicode-procs '())
+
+ (define (float-register-name reg)
+ (string-append "%f" (number->string reg)))
+
+ (define op car)
+ (define op1 cadr)
+ (define op2 caddr)
+ (define op3 cadddr)
+ (define tabstring (string #\tab))
+
+ (define (heximm n)
+ (if (>= n 16)
+ (string-append tabstring "! 0x" (number->string n 16))
+ ""))
+
+ (define (millicode-name offset . rest)
+ (if (null? rest)
+ (let ((probe (assv offset millicode-procs)))
+ (if probe
+ (cdr probe)
+ "[unknown]"))
+ (set! millicode-procs
+ (cons (cons offset (car rest)) millicode-procs))))
+
+ (define (millicode-call offset)
+ (string-append tabstring "! " (millicode-name offset)))
+
+ (define (plus/minus n)
+ (cond ((< n 0)
+ (string-append " - " (number->string (abs n))))
+ ((and (= n 0) *format-instructions-pretty*) "")
+ (else
+ (string-append " + " (number->string n)))))
+
+ (define (srcreg instr extractor)
+ (if (mnemonic:freg? (op instr))
+ (float-register-name (extractor instr))
+ (larceny-register-name (extractor instr))))
+
+ (define (sethi instr)
+ (string-append (number->string (* (op1 instr) 1024)) ", "
+ (larceny-register-name (op2 instr))
+ (heximm (* (op1 instr) 1024))))
+
+ (define (rrr instr)
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (larceny-register-name (op2 instr)) ", "
+ (larceny-register-name (op3 instr))))
+
+ (define (rir instr)
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (number->string (op2 instr)) ", "
+ (larceny-register-name (op3 instr))
+ (heximm (op2 instr))))
+
+ (define (sir instr)
+ (string-append (srcreg instr op3) ", [ "
+ (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) " ]"))
+
+ (define (srr instr)
+ (string-append (srcreg instr op3) ", [ "
+ (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) " ]"))
+
+ (define (lir instr)
+ (string-append "[ " (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) " ], "
+ (srcreg instr op3)))
+
+ (define (lrr instr)
+ (string-append "[ " (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) " ], "
+ (srcreg instr op3)))
+
+ (define (bimm instr addr)
+ (string-append "#" (number->string (+ (op1 instr) addr))))
+
+ (define (jmpli instr)
+ (string-append (larceny-register-name (op1 instr))
+ (plus/minus (op2 instr)) ", "
+ (larceny-register-name (op3 instr))
+ (if (and (= (op1 instr) $r.globals)
+ use-larceny-registers)
+ (millicode-call (op2 instr))
+ (heximm (op2 instr)))))
+
+ (define (jmplr instr)
+ (string-append (larceny-register-name (op1 instr)) "+"
+ (larceny-register-name (op2 instr)) ", "
+ (larceny-register-name (op3 instr))))
+
+ (define (call instr addr)
+ (string-append "#" (number->string (+ (op1 instr) addr))))
+
+ (define (rd instr)
+ (string-append "%y, " (srcreg instr op3)))
+
+ (define (wr instr imm?)
+ (if imm?
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (number->string (op2 instr)) ", %y"
+ (larceny-register-name (op3 instr)))
+ (string-append (larceny-register-name (op1 instr)) ", "
+ (larceny-register-name (op2 instr)) ", %y")))
+
+ (define (fpop instr op2-used? op3-used?)
+ (string-append (float-register-name (op1 instr)) ", "
+ (cond ((and op2-used? op3-used?)
+ (string-append
+ (float-register-name (op2 instr)) ", "
+ (float-register-name (op3 instr))))
+ (op2-used?
+ (float-register-name (op2 instr)))
+ (else
+ (float-register-name (op3 instr))))))
+
+ ;; If we want to handle instruction aliases (clr, mov, etc) then
+ ;; the structure of this procedure must change, because as it is,
+ ;; the printing of the name is independent of the operand values.
+
+ (define (format-instr i a larceny-names?)
+ (set! use-larceny-registers larceny-names?)
+ (let ((m (car i)))
+ (string-append (number->string a)
+ tabstring
+ (symbol->string (mnemonic:name m))
+ (if (mnemonic:annul? m) ",a" "")
+ tabstring
+ (cond ((mnemonic:store? m)
+ (if (mnemonic:immediate? m) (sir i) (srr i)))
+ ((mnemonic:load? m)
+ (if (mnemonic:immediate? m) (lir i) (lrr i)))
+ ((mnemonic:fpop? m)
+ (fpop i (mnemonic:op2? m) (mnemonic:op3? m)))
+ ((mnemonic:branch? m) (bimm i a))
+ ((mnemonic=? m 'sethi) (sethi i))
+ ((mnemonic=? m 'nop) "")
+ ((mnemonic=? m 'jmpl)
+ (if (mnemonic:immediate? m) (jmpli i) (jmplr i)))
+ ((mnemonic=? m 'call) (call i a))
+ ((mnemonic=? m 'rd) (rd i))
+ ((mnemonic=? m 'wr) (wr i (mnemonic:immediate? m)))
+ ((mnemonic:immediate? m) (rir i))
+ (else (rrr i))))))
+
+ (larceny-register-name $r.tmp0 "%tmp0")
+ (larceny-register-name $r.result "%result")
+ (larceny-register-name $r.argreg2 "%argreg2")
+ (larceny-register-name $r.argreg3 "%argreg3")
+ (larceny-register-name $r.tmp1 "%tmp1")
+ (larceny-register-name $r.tmp2 "%tmp2")
+ (larceny-register-name $r.reg0 "%r0")
+ (larceny-register-name $r.reg1 "%r1")
+ (larceny-register-name $r.reg2 "%r2")
+ (larceny-register-name $r.reg3 "%r3")
+ (larceny-register-name $r.reg4 "%r4")
+ (larceny-register-name $r.reg5 "%r5")
+ (larceny-register-name $r.reg6 "%r6")
+ (larceny-register-name $r.reg7 "%r7")
+ (larceny-register-name $r.e-top "%etop")
+ (larceny-register-name $r.e-limit "%elim")
+ (larceny-register-name $r.timer "%timer")
+ (larceny-register-name $r.millicode "%millicode")
+ (larceny-register-name $r.globals "%globals")
+ (larceny-register-name $r.stkp "%stkp") ; note: after elim
+
+ (millicode-name $m.alloc "alloc")
+ (millicode-name $m.alloci "alloci")
+ (millicode-name $m.gc "gc")
+ (millicode-name $m.addtrans "addtrans")
+ (millicode-name $m.stkoflow "stkoflow")
+ (millicode-name $m.stkuflow "stkuflow")
+ (millicode-name $m.creg "creg")
+ (millicode-name $m.creg-set! "creg-set!")
+ (millicode-name $m.add "+")
+ (millicode-name $m.subtract "- (binary)")
+ (millicode-name $m.multiply "*")
+ (millicode-name $m.quotient "quotient")
+ (millicode-name $m.remainder "remainder")
+ (millicode-name $m.divide "/")
+ (millicode-name $m.modulo "modulo")
+ (millicode-name $m.negate "- (unary)")
+ (millicode-name $m.numeq "=")
+ (millicode-name $m.numlt "<")
+ (millicode-name $m.numle "<=")
+ (millicode-name $m.numgt ">")
+ (millicode-name $m.numge ">=")
+ (millicode-name $m.zerop "zero?")
+ (millicode-name $m.complexp "complex?")
+ (millicode-name $m.realp "real?")
+ (millicode-name $m.rationalp "rational?")
+ (millicode-name $m.integerp "integer?")
+ (millicode-name $m.exactp "exact?")
+ (millicode-name $m.inexactp "inexact?")
+ (millicode-name $m.exact->inexact "exact->inexact")
+ (millicode-name $m.inexact->exact "inexact->exact")
+ (millicode-name $m.make-rectangular "make-rectangular")
+ (millicode-name $m.real-part "real-part")
+ (millicode-name $m.imag-part "imag-part")
+ (millicode-name $m.sqrt "sqrt")
+ (millicode-name $m.round "round")
+ (millicode-name $m.truncate "truncate")
+ (millicode-name $m.apply "apply")
+ (millicode-name $m.varargs "varargs")
+ (millicode-name $m.typetag "typetag")
+ (millicode-name $m.typetag-set "typetag-set")
+ (millicode-name $m.break "break")
+ (millicode-name $m.eqv "eqv?")
+ (millicode-name $m.partial-list->vector "partial-list->vector")
+ (millicode-name $m.timer-exception "timer-exception")
+ (millicode-name $m.exception "exception")
+ (millicode-name $m.singlestep "singlestep")
+ (millicode-name $m.syscall "syscall")
+ (millicode-name $m.bvlcmp "bvlcmp")
+ (millicode-name $m.enable-interrupts "enable-interrupts")
+ (millicode-name $m.disable-interrupts "disable-interrupts")
+ (millicode-name $m.alloc-bv "alloc-bv")
+ (millicode-name $m.global-ex "global-exception")
+ (millicode-name $m.invoke-ex "invoke-exception")
+ (millicode-name $m.global-invoke-ex "global-invoke-exception")
+ (millicode-name $m.argc-ex "argc-exception")
+
+ (set! format-instruction format-instr)
+ 'format-instruction)
+
+
+; eof
+
+
+; ----------------------------------------------------------------------
+
+(define (twobit-benchmark type . rest)
+ (let ((k (if (null? rest) 1 (car rest))))
+ (run-benchmark
+ "twobit"
+ k
+ (lambda ()
+ (case type
+ ((long)
+ (compiler-switches 'fast-safe)
+ (benchmark-block-mode #f)
+ (compile-file "twobit-input-long.sch"))
+ ((short)
+ (compiler-switches 'fast-safe)
+ (benchmark-block-mode #t)
+ (compile-file "twobit-input-short.sch"))
+ (else
+ (error "Benchmark type must be `long' or `short': " type))))
+ (lambda (result)
+ #t))))
+
+; eof
HCoop / bpt / guile.git / commitdiff