From: Ludovic Courtès Date: Sun, 14 Dec 2008 19:25:56 +0000 (+0100) Subject: Merge branch 'master' into boehm-demers-weiser-gc X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/083f810fe9b7f04dc0de6b8ebc62053a41714f2b?hp=55aae983565cd14821d4cdff9f44afc96f8868c1 Merge branch 'master' into boehm-demers-weiser-gc Conflicts: lib/Makefile.am libguile/struct.c libguile/threads.c m4/gnulib-cache.m4 m4/gnulib-comp.m4 --- diff --git a/GUILE-VERSION b/GUILE-VERSION index c23f8f6f9..9d9539a5c 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -5,7 +5,7 @@ GUILE_MINOR_VERSION=9 GUILE_MICRO_VERSION=0 GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} -GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION} +GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}-bdwgc # For automake. VERSION=${GUILE_VERSION} diff --git a/configure.in b/configure.in index a7fd9c914..964db5958 100644 --- a/configure.in +++ b/configure.in @@ -1177,6 +1177,25 @@ main () [], [AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)]) +#-------------------------------------------------------------------- +# +# Boehm's GC library +# +#-------------------------------------------------------------------- +PKG_CHECK_MODULES([BDW_GC], [bdw-gc]) + +CFLAGS="$BDW_GC_CFLAGS $CFLAGS" +LIBS="$BDW_GC_LIBS $LIBS" + +# `GC_do_blocking ()' is available in GC 7.1 but not declared. +AC_CHECK_FUNCS([GC_do_blocking]) +AC_CHECK_DECL([GC_do_blocking], + [AC_DEFINE([HAVE_DECL_GC_DO_BLOCKING], [1], + [Define this if the `GC_do_blocking ()' function is declared])], + [], + [#include ]) + + AC_CHECK_SIZEOF(float) if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then AC_DEFINE(SCM_SINGLES, 1, diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm new file mode 100755 index 000000000..002bfc595 --- /dev/null +++ b/gc-benchmarks/gc-profile.scm @@ -0,0 +1,280 @@ +#!/bin/sh +# -*- Scheme -*- +exec ${GUILE-guile} --no-debug -q -l "$0" \ + -c '(apply main (cdr (command-line)))' "$@" +!# +;;; Copyright (C) 2008 Free Software Foundation, Inc. +;;; +;;; 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, 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 software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;; Boston, MA 02110-1301 USA + +(use-modules (ice-9 format) + (ice-9 rdelim) + (ice-9 regex) + (srfi srfi-1) + (srfi srfi-37) + (srfi srfi-39)) + + +;;; +;;; Memory usage. +;;; + +(define (memory-mappings pid) + "Return an list of alists, each of which contains information about a +memory mapping of process @var{pid}. This information is obtained by reading +@file{/proc/PID/smaps} on Linux. See `procs(5)' for details." + + (define mapping-line-rx + (make-regexp + "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$")) + + (define rss-line-rx + (make-regexp + "^Rss:[[:blank:]]+([[:digit:]]+) kB$")) + + (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid)) + (lambda () + (let loop ((line (read-line)) + (result '())) + (if (eof-object? line) + (reverse result) + (cond ((regexp-exec mapping-line-rx line) + => + (lambda (match) + (let ((mapping-start (string->number + (match:substring match 1) + 16)) + (mapping-end (string->number + (match:substring match 2) + 16)) + (access-bits (match:substring match 3)) + (name (match:substring match 5))) + (loop (read-line) + (cons `((mapping-start . ,mapping-start) + (mapping-end . ,mapping-end) + (access-bits . ,access-bits) + (name . ,(if (string=? name "") + #f + name))) + result))))) + ((regexp-exec rss-line-rx line) + => + (lambda (match) + (let ((section+ (cons (cons 'rss + (string->number + (match:substring match 1))) + (car result)))) + (loop (read-line) + (cons section+ (cdr result)))))) + (else + (loop (read-line) result)))))))) + +(define (total-heap-size pid) + "Return the total heap size of process @var{pid}." + + (define heap-or-anon-rx + (make-regexp "\\[(heap|anon)\\]")) + + (define private-mapping-rx + (make-regexp "^[r-][w-][x-]p$")) + + (fold (lambda (heap total+rss) + (let ((name (assoc-ref heap 'name)) + (perm (assoc-ref heap 'access-bits))) + ;; Include anonymous private mappings. + (if (or (and (not name) + (regexp-exec private-mapping-rx perm)) + (and name + (regexp-exec heap-or-anon-rx name))) + (let ((start (assoc-ref heap 'mapping-start)) + (end (assoc-ref heap 'mapping-end)) + (rss (assoc-ref heap 'rss))) + (cons (+ (car total+rss) (- end start)) + (+ (cdr total+rss) rss))) + total+rss))) + '(0 . 0) + (memory-mappings pid))) + + +(define (display-stats start end) + (define (->usecs sec+usecs) + (+ (* 1000000 (car sec+usecs)) + (cdr sec+usecs))) + + (let ((usecs (- (->usecs end) (->usecs start))) + (heap-size (total-heap-size (getpid))) + (gc-heap-size (assoc-ref (gc-stats) 'heap-size))) + + (format #t "execution time: ~6,3f seconds~%" + (/ usecs 1000000.0)) + + (and gc-heap-size + (format #t "GC-reported heap size: ~8d B (~1,2f MiB)~%" + gc-heap-size + (/ gc-heap-size 1024.0 1024.0))) + + (format #t "heap size: ~8d B (~1,2f MiB)~%" + (car heap-size) + (/ (car heap-size) 1024.0 1024.0)) + (format #t "heap RSS: ~8d KiB (~1,2f MiB)~%" + (cdr heap-size) + (/ (cdr heap-size) 1024.0)) +;; (system (format #f "cat /proc/~a/smaps" (getpid))) +;; (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid))) + )) + + +;;; +;;; Larceny/Twobit benchmarking compability layer. +;;; + +(define *iteration-count* + (make-parameter #f)) + +(define (run-benchmark name . args) + "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking +framework. See +@url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for +details." + + (define %concise-invocation? + ;; This procedure can be called with only two arguments, NAME and + ;; RUN-MAKER. + (procedure? (car args))) + + (let ((count (or (*iteration-count*) + (if %concise-invocation? 0 (car args)))) + (run-maker (if %concise-invocation? (car args) (cadr args))) + (ok? (if %concise-invocation? + (lambda (result) #t) + (caddr args))) + (args (if %concise-invocation? '() (cdddr args)))) + (let loop ((i 0)) + (and (< i count) + (let ((result (apply run-maker args))) + (if (not (ok? result)) + (begin + (format (current-output-port) "invalid result for `~A'~%" + name) + (exit 1))) + (loop (1+ i))))))) + +(define (save-directory-excursion directory thunk) + (let ((previous-dir (getcwd))) + (dynamic-wind + (lambda () + (chdir directory)) + thunk + (lambda () + (chdir previous-dir))))) + +(define (load-larceny-benchmark file) + "Load the Larceny benchmark from @var{file}." + (let ((name (let ((base (basename file))) + (substring base 0 (or (string-rindex base #\.) + (string-length base))))) + (module (let ((m (make-module))) + (beautify-user-module! m) + (module-use! m (resolve-interface '(ice-9 syncase))) + m))) + (save-directory-excursion (dirname file) + (lambda () + (save-module-excursion + (lambda () + (set-current-module module) + (module-define! module 'run-benchmark run-benchmark) + (load (basename file)) + + ;; Invoke the benchmark's entry point. + (let ((entry (module-ref (current-module) + (symbol-append (string->symbol name) + '-benchmark)))) + (entry)))))))) + + + +;;; +;;; Option processing. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\l "larceny") #f #f + (lambda (opt name arg result) + (alist-cons 'larceny? #t result))) + (option '(#\i "iterations") #t #f + (lambda (opt name arg result) + (alist-cons 'iterations (string->number arg) result))))) + +(define (show-help) + (format #t "Usage: gc-profile [OPTIONS] FILE.SCM +Load FILE.SCM, a Guile Scheme source file, and report its execution time and +final heap usage. + + -h, --help Show this help message + + -l, --larceny Provide mechanisms compatible with the Larceny/Twobit + GC benchmark suite. + -i, --iterations=COUNT + Run the given benchmark COUNT times, regardless of the + iteration count passed to `run-benchmark' (for Larceny + benchmarks). + +Report bugs to .~%")) + +(define (parse-args args) + (define (leave fmt . args) + (apply format (current-error-port) (string-append fmt "~%") args) + (exit 1)) + + (args-fold args %options + (lambda (opt name arg result) + (leave "~A: unrecognized option" opt)) + (lambda (file result) + (if (pair? (assoc 'input result)) + (leave "~a: only one input file at a time" file) + (alist-cons 'input file result))) + '())) + + +;;; +;;; Main program. +;;; + +(define (main . args) + (let* ((options (parse-args args)) + (prog (assoc-ref options 'input)) + (load (if (assoc-ref options 'larceny?) + load-larceny-benchmark + load))) + + (parameterize ((*iteration-count* (assoc-ref options 'iterations))) + (format #t "running `~a' with Guile ~a...~%" prog (version)) + + (let ((start (gettimeofday))) + (dynamic-wind + (lambda () + #t) + (lambda () + (set! quit (lambda args args)) + (load prog)) + (lambda () + (let ((end (gettimeofday))) + (format #t "done~%") + (display-stats start end)))))))) diff --git a/gc-benchmarks/gcbench.scm b/gc-benchmarks/gcbench.scm new file mode 100644 index 000000000..31098ec24 --- /dev/null +++ b/gc-benchmarks/gcbench.scm @@ -0,0 +1,210 @@ +; 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 ) +; Last modified 30 May 1997. +; +; 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. + +(use-modules (ice-9 syncase)) + +(define (PrintDiagnostics) + (display " Total memory available= ???????? bytes") + (display " Free memory= ???????? bytes") + (newline)) + + + +(define (run-benchmark str thu) + (display str) + (thu)) +; 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 procedures. + ((let-class (((method . args) . method-body) ...) . body) + (let () (define (method . args) . method-body) ... . body)) + + + ;; 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)) + + + )) + + +(define (gcbench kStretchTreeDepth) + + ; 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; + ; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 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" + (lambda () + (do ((i 0 (+ i 1))) + ((>= i iNumIters)) + (Populate depth (make-empty-node))))) + (run-benchmark "GCBench: Bottom up construction" + (lambda () + (do ((i 0 (+ i 1))) + ((>= i iNumIters)) + (MakeTree depth)))))) + + (define (main) + (display "Garbage Collector Test") + (newline) + (display (string-append + " Stretching memory with a binary tree of depth " + (number->string kStretchTreeDepth))) + (newline) + (run-benchmark "GCBench: Main" + (lambda () + ; Stretch the memory space quickly + (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 + )))) + (PrintDiagnostics)) + + (main)))) + +(define (gc-benchmark . rest) + (let ((k (if (null? rest) 18 (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) + (run-benchmark (string-append "GCBench" (number->string k)) + (lambda () (gcbench k))))) + + + +(gc-benchmark ) +(display (gc-stats)) diff --git a/gc-benchmarks/guile-test.scm b/gc-benchmarks/guile-test.scm new file mode 100644 index 000000000..ddc414dba --- /dev/null +++ b/gc-benchmarks/guile-test.scm @@ -0,0 +1,9 @@ +(set! %load-path (cons (string-append (getenv "HOME") "/src/guile") + %load-path)) + +(load "../test-suite/guile-test") + +(main `("guile-test" + "--test-suite" ,(string-append (getenv "HOME") + "/src/guile/test-suite/tests") + "--log-file" ",,test-suite.log")) diff --git a/gc-benchmarks/larceny/GPL b/gc-benchmarks/larceny/GPL new file mode 100644 index 000000000..486449cc3 --- /dev/null +++ b/gc-benchmarks/larceny/GPL @@ -0,0 +1,340 @@ + 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. + + + Copyright (C) + + 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. + + , 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. diff --git a/gc-benchmarks/larceny/README b/gc-benchmarks/larceny/README new file mode 100644 index 000000000..78639cd6c --- /dev/null +++ b/gc-benchmarks/larceny/README @@ -0,0 +1,92 @@ +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. diff --git a/gc-benchmarks/larceny/dumb.sch b/gc-benchmarks/larceny/dumb.sch new file mode 100644 index 000000000..353564a8a --- /dev/null +++ b/gc-benchmarks/larceny/dumb.sch @@ -0,0 +1,21 @@ +; 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))) + diff --git a/gc-benchmarks/larceny/dummy.sch b/gc-benchmarks/larceny/dummy.sch new file mode 100644 index 000000000..021756e69 --- /dev/null +++ b/gc-benchmarks/larceny/dummy.sch @@ -0,0 +1,19 @@ +; 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 diff --git a/gc-benchmarks/larceny/dynamic-input-large.sch b/gc-benchmarks/larceny/dynamic-input-large.sch new file mode 100644 index 000000000..068ea3e5f --- /dev/null +++ b/gc-benchmarks/larceny/dynamic-input-large.sch @@ -0,0 +1,2111 @@ +(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? 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 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? 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) "#" (if (bytevector? .x|3) "#" (if (eof-object? .x|3) "#" (if (port? .x|3) "#" (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) "#")))))))))))))))))))) (.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)) '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)) '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-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-)) '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-fx>/imm (if (memv .temp|48|51 '(fx>=)) 'internal:branchf-fx>=/imm (if (memv .temp|48|51 '(fx<)) 'internal:branchf-fx=: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.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.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.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-charbool! (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.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.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)) diff --git a/gc-benchmarks/larceny/dynamic-input-small.sch b/gc-benchmarks/larceny/dynamic-input-small.sch new file mode 100644 index 000000000..def99069f --- /dev/null +++ b/gc-benchmarks/larceny/dynamic-input-small.sch @@ -0,0 +1,1201 @@ +(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? 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 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? 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)) diff --git a/gc-benchmarks/larceny/dynamic.sch b/gc-benchmarks/larceny/dynamic.sch new file mode 100644 index 000000000..779ad766e --- /dev/null +++ b/gc-benchmarks/larceny/dynamic.sch @@ -0,0 +1,2348 @@ +; 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, , + '(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 + +(define (dynamic-parse-datum e) + ;; Source: IEEE Scheme, sect. 7.2, + ;; 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 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 + +(define (dynamic-parse-formals formals) + ;; parses ; 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 + +(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) + ; = * + + (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 ( ) 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 diff --git a/gc-benchmarks/larceny/earley.sch b/gc-benchmarks/larceny/earley.sch new file mode 100644 index 000000000..55736c482 --- /dev/null +++ b/gc-benchmarks/larceny/earley.sch @@ -0,0 +1,658 @@ +;;; 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)))) diff --git a/gc-benchmarks/larceny/gcbench.sch b/gc-benchmarks/larceny/gcbench.sch new file mode 100644 index 000000000..1ef71fdc8 --- /dev/null +++ b/gc-benchmarks/larceny/gcbench.sch @@ -0,0 +1,233 @@ +; 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 ) +; 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))) diff --git a/gc-benchmarks/larceny/gcold.scm b/gc-benchmarks/larceny/gcold.scm new file mode 100644 index 000000000..36eee6b3b --- /dev/null +++ b/gc-benchmarks/larceny/gcold.scm @@ -0,0 +1,386 @@ +; +; GCOld.sch x.x 00/08/03 +; translated from GCOld.java 2.0a 00/08/23 +; +; Copyright 2000 Sun Microsystems, Inc. All rights reserved. +; +; + +; Should be good enough for this benchmark. + +(define (newRandom) + (letrec ((random14 + (lambda (n) + (set! x (remainder (+ (* a x) c) m)) + (remainder (quotient x 8) n))) + (a 701) + (x 1) + (c 743483) + (m 524288) + (loop + (lambda (q r n) + (if (zero? q) + (remainder r n) + (loop (quotient q 16384) + (+ (* 16384 r) (random14 16384)) + n))))) + (lambda (n) + (if (and (exact? n) (integer? n) (< n 16384)) + (random14 n) + (loop n (random14 16384) n))))) + +; A TreeNode is a record with three fields: left, right, val. +; The left and right fields contain a TreeNode or 0, and the +; val field will contain the integer height of the tree. + +(define-syntax newTreeNode + (syntax-rules () + ((newTreeNode left right val) + (vector left right val)) + ((newTreeNode) + (vector 0 0 0)))) + +(define-syntax TreeNode.left + (syntax-rules () + ((TreeNode.left node) + (vector-ref node 0)))) + +(define-syntax TreeNode.right + (syntax-rules () + ((TreeNode.right node) + (vector-ref node 1)))) + +(define-syntax TreeNode.val + (syntax-rules () + ((TreeNode.val node) + (vector-ref node 2)))) + +(define-syntax setf + (syntax-rules (TreeNode.left TreeNode.right TreeNode.val) + ((setf (TreeNode.left node) x) + (vector-set! node 0 x)) + ((setf (TreeNode.right node) x) + (vector-set! node 1 x)) + ((setf (TreeNode.val node) x) + (vector-set! node 2 x)))) + +; Args: +; live-data-size: in megabytes. +; work: units of mutator non-allocation work per byte allocated, +; (in unspecified units. This will affect the promotion rate +; printed at the end of the run: more mutator work per step implies +; fewer steps per second implies fewer bytes promoted per second.) +; short/long ratio: ratio of short-lived bytes allocated to long-lived +; bytes allocated. +; pointer mutation rate: number of pointer mutations per step. +; steps: number of steps to do. +; + +(define (GCOld size workUnits promoteRate ptrMutRate steps) + + (define (println . args) + (for-each display args) + (newline)) + + ; Rounds an inexact real to two decimal places. + + (define (round2 x) + (/ (round (* 100.0 x)) 100.0)) + + ; Returns the height of the given tree. + + (define (height t) + (if (eqv? t 0) + 0 + (+ 1 (max (height (TreeNode.left t)) + (height (TreeNode.right t)))))) + + ; Returns the length of the shortest path in the given tree. + + (define (shortestPath t) + (if (eqv? t 0) + 0 + (+ 1 (min (shortestPath (TreeNode.left t)) + (shortestPath (TreeNode.right t)))))) + + ; Returns the number of nodes in a balanced tree of the given height. + + (define (heightToNodes h) + (- (expt 2 h) 1)) + + ; Returns the height of the largest balanced tree + ; that has no more than the given number of nodes. + + (define (nodesToHeight nodes) + (do ((h 1 (+ h 1)) + (n 1 (+ n n))) + ((> (+ n n -1) nodes) + (- h 1)))) + + (let* ( + + ; Constants. + + (null 0) ; Java's null + (pathBits 65536) ; to generate 16 random bits + + (MEG 1000000) + (INSIGNIFICANT 999) ; this many bytes don't matter + (bytes/word 4) + (bytes/node 20) ; bytes per tree node in typical JVM + (words/dead 100) ; size of young garbage objects + + ; Returns the number of bytes in a balanced tree of the given height. + + (heightToBytes + (lambda (h) + (* bytes/node (heightToNodes h)))) + + ; Returns the height of the largest balanced tree + ; that occupies no more than the given number of bytes. + + (bytesToHeight + (lambda (bytes) + (nodesToHeight (/ bytes bytes/node)))) + + (treeHeight 14) + (treeSize (heightToBytes treeHeight)) + + (msg1 "Usage: java GCOld ") + (msg2 " where is the live storage in megabytes") + (msg3 " is the mutator work per step (arbitrary units)") + (msg4 " is the ratio of short-lived to long-lived allocation") + (msg5 " is the mutations per step") + (msg6 " is the number of steps") + + ; Counters (and global variables that discourage optimization). + + (youngBytes 0) + (nodes 0) + (actuallyMut 0) + (mutatorSum 0) + (aexport '#()) + + ; Global variables. + + (trees '#()) + (where 0) + (rnd (newRandom)) + + ) + + ; Returns a newly allocated balanced binary tree of height h. + + (define (makeTree h) + (if (zero? h) + null + (let ((res (newTreeNode))) + (set! nodes (+ nodes 1)) + (setf (TreeNode.left res) (makeTree (- h 1))) + (setf (TreeNode.right res) (makeTree (- h 1))) + (setf (TreeNode.val res) h) + res))) + + ; Allocates approximately size megabytes of trees and stores + ; them into a global array. + + (define (init) + ; Each tree will be about a megabyte. + (let ((ntrees (quotient (* size MEG) treeSize))) + (set! trees (make-vector ntrees null)) + (println "Allocating " ntrees " trees.") + (println " (" (* ntrees treeSize) " bytes)") + (do ((i 0 (+ i 1))) + ((>= i ntrees)) + (vector-set! trees i (makeTree treeHeight)) + (doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead)) + (println " (" nodes " nodes)"))) + + ; Confirms that all trees are balanced and have the correct height. + + (define (checkTrees) + (let ((ntrees (vector-length trees))) + (do ((i 0 (+ i 1))) + ((>= i ntrees)) + (let* ((t (vector-ref trees i)) + (h1 (height t)) + (h2 (shortestPath t))) + (if (or (not (= h1 treeHeight)) + (not (= h2 treeHeight))) + (println "*****BUG: " h1 " " h2)))))) + + ; Called only by replaceTree (below) and by itself. + + (define (replaceTreeWork full partial dir) + (let ((canGoLeft (and (not (eq? (TreeNode.left full) null)) + (> (TreeNode.val (TreeNode.left full)) + (TreeNode.val partial)))) + (canGoRight (and (not (eq? (TreeNode.right full) null)) + (> (TreeNode.val (TreeNode.right full)) + (TreeNode.val partial))))) + (cond ((and canGoLeft canGoRight) + (if dir + (replaceTreeWork (TreeNode.left full) + partial + (not dir)) + (replaceTreeWork (TreeNode.right full) + partial + (not dir)))) + ((and (not canGoLeft) (not canGoRight)) + (if dir + (setf (TreeNode.left full) partial) + (setf (TreeNode.right full) partial))) + ((not canGoLeft) + (setf (TreeNode.left full) partial)) + (else + (setf (TreeNode.right full) partial))))) + + ; Given a balanced tree full and a smaller balanced tree partial, + ; replaces an appropriate subtree of full by partial, taking care + ; to preserve the shape of the full tree. + + (define (replaceTree full partial) + (let ((dir (zero? (modulo (TreeNode.val partial) 2)))) + (set! actuallyMut (+ actuallyMut 1)) + (replaceTreeWork full partial dir))) + + ; Allocates approximately n bytes of long-lived storage, + ; replacing oldest existing long-lived storage. + + (define (oldGenAlloc n) + (let ((full (quotient n treeSize)) + (partial (modulo n treeSize))) + ;(println "In oldGenAlloc, doing " + ; full + ; " full trees and one partial tree of size " + ; partial) + (do ((i 0 (+ i 1))) + ((>= i full)) + (vector-set! trees where (makeTree treeHeight)) + (set! where + (modulo (+ where 1) (vector-length trees)))) + (let loop ((partial partial)) + (if (> partial INSIGNIFICANT) + (let* ((h (bytesToHeight partial)) + (newTree (makeTree h))) + (replaceTree (vector-ref trees where) newTree) + (set! where + (modulo (+ where 1) (vector-length trees))) + (loop (- partial (heightToBytes h)))))))) + + ; Interchanges two randomly selected subtrees (of same size and depth). + + (define (oldGenSwapSubtrees) + ; Randomly pick: + ; * two tree indices + ; * A depth + ; * A path to that depth. + (let* ((index1 (rnd (vector-length trees))) + (index2 (rnd (vector-length trees))) + (depth (rnd treeHeight)) + (path (rnd pathBits)) + (tn1 (vector-ref trees index1)) + (tn2 (vector-ref trees index2))) + (do ((i 0 (+ i 1))) + ((>= i depth)) + (if (even? path) + (begin (set! tn1 (TreeNode.left tn1)) + (set! tn2 (TreeNode.left tn2))) + (begin (set! tn1 (TreeNode.right tn1)) + (set! tn2 (TreeNode.right tn2)))) + (set! path (quotient path 2))) + (if (even? path) + (let ((tmp (TreeNode.left tn1))) + (setf (TreeNode.left tn1) (TreeNode.left tn2)) + (setf (TreeNode.left tn2) tmp)) + (let ((tmp (TreeNode.right tn1))) + (setf (TreeNode.right tn1) (TreeNode.right tn2)) + (setf (TreeNode.right tn2) tmp))) + (set! actuallyMut (+ actuallyMut 2)))) + + ; Update "n" old-generation pointers. + + (define (oldGenMut n) + (do ((i 0 (+ i 1))) + ((>= i (quotient n 2))) + (oldGenSwapSubtrees))) + + ; Does the amount of mutator work appropriate for n bytes of young-gen + ; garbage allocation. + + (define (doMutWork n) + (let ((limit (quotient (* workUnits n) 10))) + (do ((k 0 (+ k 1)) + (sum 0 (+ sum 1))) + ((>= k limit) + ; We don't want dead code elimination to eliminate this loop. + (set! mutatorSum (+ mutatorSum sum)))))) + + ; Allocate n bytes of young-gen garbage, in units of "nwords" + ; words. + + (define (doYoungGenAlloc n nwords) + (let ((nbytes (* nwords bytes/word))) + (do ((allocated 0 (+ allocated nbytes))) + ((>= allocated n) + (set! youngBytes (+ youngBytes allocated))) + (set! aexport (make-vector nwords 0))))) + + ; Allocate "n" bytes of young-gen data; and do the + ; corresponding amount of old-gen allocation and pointer + ; mutation. + + ; oldGenAlloc may perform some mutations, so this code + ; takes those mutations into account. + + (define (doStep n) + (let ((mutations actuallyMut)) + (doYoungGenAlloc n words/dead) + (doMutWork n) + ; Now do old-gen allocation + (oldGenAlloc (quotient n promoteRate)) + (oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut))))) + + (println size " megabytes") + (println workUnits " work units per step.") + (println "promotion ratio is 1:" promoteRate) + (println "pointer mutation rate is " ptrMutRate) + (println steps " steps") + + (init) + (checkTrees) + (set! youngBytes 0) + (set! nodes 0) + + (println "Initialization complete...") + + (run-benchmark "GCOld" + 1 + (lambda () + (lambda () + (do ((step 0 (+ step 1))) + ((>= step steps)) + (doStep MEG)))) + (lambda (result) #t)) + + (checkTrees) + + (println "Allocated " steps " Mb of young gen garbage") + (println " (actually allocated " + (round2 (/ youngBytes MEG)) + " megabytes)") + (println "Promoted " (round2 (/ steps promoteRate)) " Mb") + (println " (actually promoted " + (round2 (/ (* nodes bytes/node) MEG)) + " megabytes)") + (if (not (zero? ptrMutRate)) + (println "Mutated " actuallyMut " pointers")) + + ; This output serves mainly to discourage optimization. + + (+ mutatorSum (vector-length aexport)))) + +(define (gcold-benchmark . args) + (define gcold-iters 1) + + (GCOld 25 0 10 10 gcold-iters)) diff --git a/gc-benchmarks/larceny/graphs.sch b/gc-benchmarks/larceny/graphs.sch new file mode 100644 index 000000000..ab9d76923 --- /dev/null +++ b/gc-benchmarks/larceny/graphs.sch @@ -0,0 +1,644 @@ +; 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 +; '()))) diff --git a/gc-benchmarks/larceny/lattice.sch b/gc-benchmarks/larceny/lattice.sch new file mode 100644 index 000000000..cf7d689ae --- /dev/null +++ b/gc-benchmarks/larceny/lattice.sch @@ -0,0 +1,219 @@ +; 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))))) + diff --git a/gc-benchmarks/larceny/nboyer.sch b/gc-benchmarks/larceny/nboyer.sch new file mode 100644 index 000000000..690c2216c --- /dev/null +++ b/gc-benchmarks/larceny/nboyer.sch @@ -0,0 +1,770 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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))))) diff --git a/gc-benchmarks/larceny/nucleic2.sch b/gc-benchmarks/larceny/nucleic2.sch new file mode 100644 index 000000000..f55048de9 --- /dev/null +++ b/gc-benchmarks/larceny/nucleic2.sch @@ -0,0 +1,3772 @@ +; 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) diff --git a/gc-benchmarks/larceny/perm.sch b/gc-benchmarks/larceny/perm.sch new file mode 100644 index 000000000..56b4da14f --- /dev/null +++ b/gc-benchmarks/larceny/perm.sch @@ -0,0 +1,324 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 ) +; (RUN-BENCHMARK ) +; +; reports the time required to call the number of times +; specified by , and uses to test whether the +; result returned by 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)))) diff --git a/gc-benchmarks/larceny/run-benchmark.chez b/gc-benchmarks/larceny/run-benchmark.chez new file mode 100644 index 000000000..9ed10db07 --- /dev/null +++ b/gc-benchmarks/larceny/run-benchmark.chez @@ -0,0 +1,50 @@ +;;; 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))))) diff --git a/gc-benchmarks/larceny/sboyer.sch b/gc-benchmarks/larceny/sboyer.sch new file mode 100644 index 000000000..eae4689b0 --- /dev/null +++ b/gc-benchmarks/larceny/sboyer.sch @@ -0,0 +1,784 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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))))) diff --git a/gc-benchmarks/larceny/softscheme.sch b/gc-benchmarks/larceny/softscheme.sch new file mode 100644 index 000000000..8db2e48ad --- /dev/null +++ b/gc-benchmarks/larceny/softscheme.sch @@ -0,0 +1,9319 @@ +; 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-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-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 bool)) + (char>? (char char -> bool)) + (char<=? (char char -> bool)) + (char>=? (char char -> bool)) + (char-ci=? (char char -> bool)) + (char-ci 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 bool)) + (string>? (str str -> bool)) + (string<=? (str str -> bool)) + (string>=? (str str -> bool)) + (string-ci=? (str str -> bool)) + (string-ci 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) )) + (($ 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) ')) + ((? 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!) diff --git a/gc-benchmarks/larceny/twobit-input-long.sch b/gc-benchmarks/larceny/twobit-input-long.sch new file mode 100644 index 000000000..5727ad72c --- /dev/null +++ b/gc-benchmarks/larceny/twobit-input-long.sch @@ -0,0 +1,23798 @@ +; 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 ) +; +; Returns a newly allocated mutable hash table +; using as the hash function +; and , e.g. ASSQ, ASSV, ASSOC, to search a bucket +; with buckets at first, expanding the number of buckets as needed. +; The must accept a key and return a non-negative exact +; integer. +; +; (make-hashtable ) +; +; Equivalent to (make-hashtable n) +; for some value of n chosen by the implementation. +; +; (make-hashtable ) +; +; Equivalent to (make-hashtable assv). +; +; (make-hashtable) +; +; Equivalent to (make-hashtable object-hash assv). +; +; (hashtable-contains? ) +; +; Returns true iff the contains an entry for . +; +; (hashtable-fetch ) +; +; Returns the value associated with in the if the +; contains ; otherwise returns . +; +; (hashtable-get ) +; +; Equivalent to (hashtable-fetch #f) +; +; (hashtable-put! ) +; +; Changes the to associate with , replacing +; any existing association for . +; +; (hashtable-remove! ) +; +; Removes any association for within the . +; +; (hashtable-clear! ) +; +; Removes all associations from the . +; +; (hashtable-size ) +; +; Returns the number of keys contained within the . +; +; (hashtable-for-each ) +; +; The must accept two arguments, a key and the value +; associated with that key. Calls the once for each +; key-value association. The order of these calls is indeterminate. +; +; (hashtable-map ) +; +; The must accept two arguments, a key and the value +; associated with that key. Calls the once for each +; key-value association, and returns a list of the results. The +; order of the calls is indeterminate. +; +; (hashtable-copy ) +; +; Returns a copy of the . + +; 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") ) +; +; where is the number of associations within the hashtable, +; is the hash function, is the bucket searcher, +; and is a vector of buckets. +; +; The and fields are constant, but +; the and 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 field, and fetches the +; 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 ) +; +; Returns a newly allocated mutable hash table +; using as the hash function +; and , e.g. ASSQ, ASSV, ASSOC, to search a bucket. +; The must accept a key and return a non-negative exact +; integer. +; +; (make-hashtree ) +; +; Equivalent to (make-hashtree assv). +; +; (make-hashtree) +; +; Equivalent to (make-hashtree object-hash assv). +; +; (hashtree-contains? ) +; +; Returns true iff the contains an entry for . +; +; (hashtree-fetch ) +; +; Returns the value associated with in the if the +; contains ; otherwise returns . +; +; (hashtree-get ) +; +; Equivalent to (hashtree-fetch #f) +; +; (hashtree-put ) +; +; Returns a new hashtree that is like except that +; is associated with . +; +; (hashtree-remove ) +; +; Returns a new hashtree that is like except that +; is not associated with any value. +; +; (hashtree-size ) +; +; Returns the number of keys contained within the . +; +; (hashtree-for-each ) +; +; The must accept two arguments, a key and the value +; associated with that key. Calls the once for each +; key-value association. The order of these calls is indeterminate. +; +; (hashtree-map ) +; +; The must accept two arguments, a key and the value +; associated with that key. Calls the 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") ) +; +; where is the number of associations within the hashtree, +; is the hash function, is the bucket searcher, +; and is generated by the following grammar: +; +; ::= () +; | ( ) +; ::= () +; ::= +; | +; ::= ( . ) +; +; If 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 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 , 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 + ; 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 + ; Syntactic environments. +; +; A syntactic environment maps identifiers to denotations, +; where a denotation is one of +; +; (special ) +; (macro ) +; (inline ) +; (identifier ) +; +; and where is one of +; +; quote +; lambda +; if +; set! +; begin +; define +; define-syntax +; let-syntax +; letrec-syntax +; syntax-rules +; +; and where is a compiled (see R4RS), +; is a syntactic environment, and 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 and an alist returned by rename-vars that contains +; a new name for each formal identifier in , 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 + ; Compiler for a . +; +; 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 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. +; +; --> (syntax-rules ) +; --> () | ( . ) +; --> (